USING: alien.strings tools.test kernel libc
io.encodings.8-bit io.encodings.utf8 io.encodings.utf16
-io.encodings.ascii alien ;
+io.encodings.ascii alien io.encodings.string ;
IN: alien.strings.tests
[ "\u0000ff" ]
] unit-test
[ f ] [ f utf8 alien>string ] unit-test
+
+[ "hello" ] [ "hello" utf16 encode utf16 decode ] unit-test
+
+[ "hello" ] [ "hello" utf16 string>alien utf16 alien>string ] unit-test
. malloc calloc free memcpy
} compile-uncompiled
+"." write flush
+
{ build-tree } compile-uncompiled
+"." write flush
+
{ optimize-tree } compile-uncompiled
+"." write flush
+
{ optimize-cfg } compile-uncompiled
+"." write flush
+
{ (compile) } compile-uncompiled
+"." write flush
+
vocabs [ words compile-uncompiled "." write flush ] each
" done" print flush
M: tuple ' emit-tuple ;
-M: tuple-layout '
- [
- [
- {
- [ hashcode>> , ]
- [ class>> , ]
- [ size>> , ]
- [ superclasses>> , ]
- [ echelon>> , ]
- } cleave
- ] { } make [ ' ] map
- \ tuple-layout type-number
- object tag-number [ emit-seq ] emit-object
- ] cache-object ;
-
M: tombstone '
state>> "((tombstone))" "((empty))" ?
"hashtables.private" lookup def>> first
[ emit-tuple ] cache-object ;
! Arrays
-M: array '
+: emit-array ( array -- offset )
[ ' ] map array type-number object tag-number
[ [ length emit-fixnum ] [ emit-seq ] bi ] emit-object ;
+M: array ' emit-array ;
+
+! This is a hack. We need to detect arrays which are tuple
+! layout arrays so that they can be internalized, but making
+! them a built-in type is not worth it.
+PREDICATE: tuple-layout-array < array
+ dup length 5 >= [
+ [ first tuple-class? ]
+ [ second fixnum? ]
+ [ third fixnum? ]
+ tri and and
+ ] [ drop f ] if ;
+
+M: tuple-layout-array '
+ [
+ [ dup integer? [ <fake-bignum> ] when ] map
+ emit-array
+ ] cache-object ;
+
! Quotations
M: quotation '
+++ /dev/null
-USING: vocabs.loader sequences system
-random random.mersenne-twister combinators init
-namespaces random ;
-IN: bootstrap.random
-
-"random.mersenne-twister" require
-
-{
- { [ os windows? ] [ "random.windows" require ] }
- { [ os unix? ] [ "random.unix" require ] }
-} cond
-
-[
- [ 32 random-bits ] with-system-random
- <mersenne-twister> random-generator set-global
-] "bootstrap.random" add-init-hook
default-image-name "output-image" set-global
- "math compiler threads help io tools ui ui.tools random unicode handbook" "include" set-global
+ "math compiler threads help io tools ui ui.tools unicode handbook" "include" set-global
"" "exclude" set-global
parse-command-line
: ##branch-t ( vreg -- )
\ f tag-number cc/= ##compare-imm-branch ;
+: trivial-branch? ( nodes -- value ? )
+ dup length 1 = [
+ first dup #push? [ literal>> t ] [ drop f f ] if
+ ] [ drop f f ] if ;
+
+: trivial-if? ( #if -- ? )
+ children>> first2
+ [ trivial-branch? [ t eq? ] when ]
+ [ trivial-branch? [ f eq? ] when ] bi*
+ and ;
+
+: emit-trivial-if ( -- )
+ ds-pop \ f tag-number cc/= ^^compare-imm ds-push ;
+
+: trivial-not-if? ( #if -- ? )
+ children>> first2
+ [ trivial-branch? [ f eq? ] when ]
+ [ trivial-branch? [ t eq? ] when ] bi*
+ and ;
+
+: emit-trivial-not-if ( -- )
+ ds-pop \ f tag-number cc= ^^compare-imm ds-push ;
+
M: #if emit-node
- ds-pop ##branch-t emit-if iterate-next ;
+ {
+ { [ dup trivial-if? ] [ drop emit-trivial-if ] }
+ { [ dup trivial-not-if? ] [ drop emit-trivial-not-if ] }
+ [ ds-pop ##branch-t emit-if ]
+ } cond iterate-next ;
! #dispatch
+: trivial-dispatch-branch? ( nodes -- ? )
+ dup length 1 = [
+ first dup #call? [
+ word>> "intrinsic" word-prop not
+ ] [ drop f ] if
+ ] [ drop f ] if ;
+
: dispatch-branch ( nodes word -- label )
- gensym [
- [
- V{ } clone node-stack set
- ##prologue
- emit-nodes
- basic-block get [
- ##epilogue
- ##return
- end-basic-block
- ] when
- ] with-cfg-builder
- ] keep ;
+ over trivial-dispatch-branch? [
+ drop first word>>
+ ] [
+ gensym [
+ [
+ V{ } clone node-stack set
+ ##prologue
+ emit-nodes
+ basic-block get [
+ ##epilogue
+ ##return
+ end-basic-block
+ ] when
+ ] with-cfg-builder
+ ] keep
+ ] if ;
: dispatch-branches ( node -- )
children>> [
M: ##dispatch defs-vregs temp>> 1array ;
M: ##slot defs-vregs [ dst>> ] [ temp>> ] bi 2array ;
M: ##set-slot defs-vregs temp>> 1array ;
+M: ##string-nth defs-vregs [ dst>> ] [ temp>> ] bi 2array ;
M: insn defs-vregs drop f ;
M: ##unary uses-vregs src>> 1array ;
M: ##slot-imm uses-vregs obj>> 1array ;
M: ##set-slot uses-vregs [ src>> ] [ obj>> ] [ slot>> ] tri 3array ;
M: ##set-slot-imm uses-vregs [ src>> ] [ obj>> ] bi 2array ;
+M: ##string-nth uses-vregs [ obj>> ] [ index>> ] bi 2array ;
M: ##conditional-branch uses-vregs [ src1>> ] [ src2>> ] bi 2array ;
M: ##compare-imm-branch uses-vregs src1>> 1array ;
M: ##dispatch uses-vregs src>> 1array ;
: ^^slot ( obj slot tag -- dst ) ^^i3 i ##slot ; inline
: ^^slot-imm ( obj slot tag -- dst ) ^^i3 ##slot-imm ; inline
: ^^set-slot ( src obj slot tag -- ) i ##set-slot ; inline
+: ^^string-nth ( obj index -- dst ) ^^i2 i ##string-nth ; inline
: ^^add ( src1 src2 -- dst ) ^^i2 ##add ; inline
: ^^add-imm ( src1 src2 -- dst ) ^^i2 ##add-imm ; inline
: ^^sub ( src1 src2 -- dst ) ^^i2 ##sub ; inline
INSN: ##set-slot < ##write { obj vreg } { slot vreg } { tag integer } { temp vreg } ;
INSN: ##set-slot-imm < ##write { obj vreg } { slot integer } { tag integer } ;
+! String element access
+INSN: ##string-nth < ##flushable { obj vreg } { index vreg } { temp vreg } ;
+
! Integer arithmetic
INSN: ##add < ##commutative ;
INSN: ##add-imm < ##commutative-imm ;
: prepare-alien-accessor ( infos -- offset-vreg )
<reversed> [ second class>> ] [ first ] bi
- dup value-info-small-tagged? [
+ dup value-info-small-fixnum? [
literal>> (prepare-alien-accessor-imm)
] [ drop (prepare-alien-accessor) ] if ;
[ ##set-slots ] [ [ drop ] [ ds-push ] [ drop ] tri* ] 3bi ;
: tuple-slot-regs ( layout -- vregs )
- [ size>> ds-load ] [ ^^load-literal ] bi prefix ;
+ [ second ds-load ] [ ^^load-literal ] bi prefix ;
: emit-<tuple-boa> ( node -- )
dup node-input-infos peek literal>>
- dup tuple-layout? [
+ dup array? [
nip
ds-drop
- [ tuple-slot-regs ] [ size>> ^^allot-tuple ] bi
+ [ tuple-slot-regs ] [ second ^^allot-tuple ] bi
[ tuple ##set-slots ] [ ds-push drop ] 2bi
] [ drop emit-primitive ] if ;
: (emit-fixnum-imm-op) ( infos insn -- dst )
ds-drop
- [ ds-pop ] [ second literal>> tag-fixnum ] [ ] tri*
+ [ ds-pop ]
+ [ second literal>> [ tag-fixnum ] [ \ f tag-number ] if* ]
+ [ ]
+ tri*
call ; inline
: (emit-fixnum-op) ( insn -- dst )
] ; inline
: emit-fixnum-shift-fast ( node -- )
- dup node-input-infos dup second value-info-small-tagged? [
+ dup node-input-infos dup second value-info-small-fixnum? [
nip
[ ds-drop ds-pop ] dip
second literal>> dup sgn {
: emit-fixnum*fast ( node -- )
node-input-infos
- dup second value-info-small-tagged?
+ dup second value-info-small-fixnum?
[ (emit-fixnum*fast-imm) ] [ drop (emit-fixnum*fast) ] if
ds-push ;
QUALIFIED: byte-arrays
QUALIFIED: kernel.private
QUALIFIED: slots.private
+QUALIFIED: strings.private
QUALIFIED: classes.tuple.private
QUALIFIED: math.private
QUALIFIED: alien.accessors
kernel:eq?
slots.private:slot
slots.private:set-slot
+ strings.private:string-nth
classes.tuple.private:<tuple-boa>
arrays:<array>
byte-arrays:<byte-array>
{ \ math.private:fixnum>float [ drop emit-fixnum>float ] }
{ \ slots.private:slot [ emit-slot ] }
{ \ slots.private:set-slot [ emit-set-slot ] }
+ { \ strings.private:string-nth [ drop emit-string-nth ] }
{ \ classes.tuple.private:<tuple-boa> [ emit-<tuple-boa> ] }
{ \ arrays:<array> [ emit-<array> ] }
{ \ byte-arrays:<byte-array> [ emit-<byte-array> ] }
dup node-input-infos
dup first value-tag [
nip
- dup second value-info-small-tagged?
+ dup second value-info-small-fixnum?
[ (emit-slot-imm) ] [ (emit-slot) ] if
ds-push
] [ drop emit-primitive ] if ;
dup second value-tag [
nip
[
- dup third value-info-small-tagged?
+ dup third value-info-small-fixnum?
[ (emit-set-slot-imm) ] [ (emit-set-slot) ] if
] [ first class>> immediate class<= ] bi
[ drop ] [ i i ##write-barrier ] if
] [ drop emit-primitive ] if ;
+
+: emit-string-nth ( -- )
+ 2inputs swap ^^untag-fixnum ^^string-nth ^^tag-fixnum ds-push ;
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: namespaces accessors math.order assocs kernel sequences
-combinators make cpu.architecture compiler.cfg.instructions
-compiler.cfg.registers ;
+combinators make classes words cpu.architecture
+compiler.cfg.instructions compiler.cfg.registers ;
IN: compiler.cfg.stack-frame
SYMBOL: frame-required?
M: ##call compute-stack-frame*
word>> sub-primitive>> [ frame-required? on ] unless ;
-M: _gc compute-stack-frame*
- drop frame-required? on ;
-
-M: _spill compute-stack-frame*
- drop frame-required? on ;
-
M: _spill-counts compute-stack-frame*
counts>> stack-frame get (>>spill-counts) ;
-M: insn compute-stack-frame* drop ;
+M: insn compute-stack-frame*
+ class frame-required? word-prop [
+ frame-required? on
+ ] when ;
+
+\ _gc t frame-required? set-word-prop
+\ _spill t frame-required? set-word-prop
: compute-stack-frame ( insns -- )
frame-required? off
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors kernel math layouts make sequences
+USING: accessors kernel math layouts make sequences combinators
cpu.architecture namespaces compiler.cfg
compiler.cfg.instructions ;
IN: compiler.cfg.utilities
+: value-info-small-fixnum? ( value-info -- ? )
+ literal>> {
+ { [ dup fixnum? ] [ tag-fixnum small-enough? ] }
+ [ drop f ]
+ } cond ;
+
: value-info-small-tagged? ( value-info -- ? )
- literal>> dup fixnum? [ tag-fixnum small-enough? ] [ drop f ] if ;
+ dup literal?>> [
+ literal>> {
+ { [ dup fixnum? ] [ tag-fixnum small-enough? ] }
+ { [ dup not ] [ drop t ] }
+ [ drop f ]
+ } cond
+ ] [ drop f ] if ;
: set-basic-block ( basic-block -- )
[ basic-block set ] [ instructions>> building set ] bi ;
[ resolve ] change-obj
[ resolve ] change-slot ;
+M: ##string-nth propagate
+ [ resolve ] change-obj
+ [ resolve ] change-index ;
+
M: ##set-slot-imm propagate
call-next-method
[ resolve ] change-obj ;
: tag-fixnum-expr? ( expr -- ? )
dup op>> \ ##shl-imm eq?
- [ in2>> vn>expr value>> tag-bits get = ] [ drop f ] if ;
+ [ in2>> vn>constant tag-bits get = ] [ drop f ] if ;
: rewrite-tagged-comparison? ( insn -- ? )
#! Are we comparing two tagged fixnums? Then untag them.
- dup ##compare-imm-branch? [
- [ src1>> vreg>expr tag-fixnum-expr? ]
- [ src2>> tag-mask get bitand 0 = ]
- bi and
- ] [ drop f ] if ; inline
+ [ src1>> vreg>expr tag-fixnum-expr? ]
+ [ src2>> tag-mask get bitand 0 = ]
+ bi and ; inline
-: rewrite-tagged-comparison ( insn -- insn' )
+: (rewrite-tagged-comparison) ( insn -- src1 src2 cc )
[ src1>> vreg>expr in1>> vn>vreg ]
[ src2>> tag-bits get neg shift ]
[ cc>> ]
- tri
- f \ ##compare-imm-branch boa ;
+ tri ; inline
+
+GENERIC: rewrite-tagged-comparison ( insn -- insn' )
+
+M: ##compare-imm-branch rewrite-tagged-comparison
+ (rewrite-tagged-comparison) f \ ##compare-imm-branch boa ;
+
+M: ##compare-imm rewrite-tagged-comparison
+ [ dst>> ] [ (rewrite-tagged-comparison) ] bi
+ f \ ##compare-imm boa ;
M: ##compare-imm-branch rewrite
dup rewrite-boolean-comparison? [ rewrite-boolean-comparison ] when
- dup rewrite-tagged-comparison? [ rewrite-tagged-comparison ] when ;
+ dup ##compare-imm-branch? [
+ dup rewrite-tagged-comparison? [ rewrite-tagged-comparison ] when
+ ] when ;
+
+: flip-comparison? ( insn -- ? )
+ dup cc>> cc= eq? [ src1>> vreg>expr constant-expr? ] [ drop f ] if ;
+
+: flip-comparison ( insn -- insn' )
+ [ dst>> ]
+ [ src2>> ]
+ [ src1>> vreg>vn vn>constant ] tri
+ cc= f \ ##compare-imm boa ;
+
+M: ##compare rewrite
+ dup flip-comparison? [
+ flip-comparison
+ dup number-values
+ rewrite
+ ] when ;
+
+: rewrite-redundant-comparison? ( insn -- ? )
+ [ src1>> vreg>expr compare-expr? ]
+ [ src2>> \ f tag-number = ]
+ [ cc>> { cc= cc/= } memq? ]
+ tri and and ; inline
+
+: rewrite-redundant-comparison ( insn -- insn' )
+ [ cc>> ] [ dst>> ] [ src1>> vreg>expr dup op>> ] tri {
+ { \ ##compare [ >compare-expr< f \ ##compare boa ] }
+ { \ ##compare-imm [ >compare-imm-expr< f \ ##compare-imm boa ] }
+ { \ ##compare-float [ >compare-expr< f \ ##compare-float boa ] }
+ } case
+ swap cc= eq? [ [ negate-cc ] change-cc ] when ;
+
+M: ##compare-imm rewrite
+ dup rewrite-redundant-comparison? [
+ rewrite-redundant-comparison
+ dup number-values rewrite
+ ] when
+ dup ##compare-imm? [
+ dup rewrite-tagged-comparison? [
+ rewrite-tagged-comparison
+ dup number-values rewrite
+ ] when
+ ] when ;
M: insn rewrite ;
IN: compiler.cfg.value-numbering.tests
USING: compiler.cfg.value-numbering compiler.cfg.instructions
-compiler.cfg.registers cpu.architecture tools.test kernel ;
+compiler.cfg.registers cpu.architecture tools.test kernel math ;
[
{
T{ ##peek f V int-regs 45 D 1 }
T{ ##replace f V int-regs 3 D 0 }
} value-numbering
] unit-test
+
+[
+ {
+ T{ ##load-indirect f V int-regs 1 + }
+ T{ ##peek f V int-regs 2 D 0 }
+ T{ ##compare f V int-regs 4 V int-regs 2 V int-regs 1 cc> }
+ T{ ##compare f V int-regs 6 V int-regs 2 V int-regs 1 cc> }
+ T{ ##replace f V int-regs 4 D 0 }
+ }
+] [
+ {
+ T{ ##load-indirect f V int-regs 1 + }
+ T{ ##peek f V int-regs 2 D 0 }
+ T{ ##compare f V int-regs 4 V int-regs 2 V int-regs 1 cc> }
+ T{ ##compare-imm f V int-regs 6 V int-regs 4 7 cc/= }
+ T{ ##replace f V int-regs 6 D 0 }
+ } value-numbering
+] unit-test
+
+[
+ {
+ T{ ##load-indirect f V int-regs 1 + }
+ T{ ##peek f V int-regs 2 D 0 }
+ T{ ##compare f V int-regs 4 V int-regs 2 V int-regs 1 cc<= }
+ T{ ##compare f V int-regs 6 V int-regs 2 V int-regs 1 cc> }
+ T{ ##replace f V int-regs 6 D 0 }
+ }
+] [
+ {
+ T{ ##load-indirect f V int-regs 1 + }
+ T{ ##peek f V int-regs 2 D 0 }
+ T{ ##compare f V int-regs 4 V int-regs 2 V int-regs 1 cc<= }
+ T{ ##compare-imm f V int-regs 6 V int-regs 4 7 cc= }
+ T{ ##replace f V int-regs 6 D 0 }
+ } value-numbering
+] unit-test
+
+[
+ {
+ T{ ##peek f V int-regs 8 D 0 }
+ T{ ##peek f V int-regs 9 D -1 }
+ T{ ##unbox-float f V double-float-regs 10 V int-regs 8 }
+ T{ ##unbox-float f V double-float-regs 11 V int-regs 9 }
+ T{ ##compare-float f V int-regs 12 V double-float-regs 10 V double-float-regs 11 cc< }
+ T{ ##compare-float f V int-regs 14 V double-float-regs 10 V double-float-regs 11 cc>= }
+ T{ ##replace f V int-regs 14 D 0 }
+ }
+] [
+ {
+ T{ ##peek f V int-regs 8 D 0 }
+ T{ ##peek f V int-regs 9 D -1 }
+ T{ ##unbox-float f V double-float-regs 10 V int-regs 8 }
+ T{ ##unbox-float f V double-float-regs 11 V int-regs 9 }
+ T{ ##compare-float f V int-regs 12 V double-float-regs 10 V double-float-regs 11 cc< }
+ T{ ##compare-imm f V int-regs 14 V int-regs 12 7 cc= }
+ T{ ##replace f V int-regs 14 D 0 }
+ } value-numbering
+] unit-test
+
+[
+ {
+ T{ ##peek f V int-regs 29 D -1 }
+ T{ ##peek f V int-regs 30 D -2 }
+ T{ ##compare f V int-regs 33 V int-regs 29 V int-regs 30 cc<= }
+ T{ ##compare-branch f V int-regs 29 V int-regs 30 cc<= }
+ }
+] [
+ {
+ T{ ##peek f V int-regs 29 D -1 }
+ T{ ##peek f V int-regs 30 D -2 }
+ T{ ##compare f V int-regs 33 V int-regs 29 V int-regs 30 cc<= }
+ T{ ##compare-imm-branch f V int-regs 33 7 cc/= }
+ } value-numbering
+] unit-test
M: ##set-slot-imm generate-insn
>set-slot< %set-slot-imm ;
+M: ##string-nth generate-insn
+ {
+ [ dst>> register ]
+ [ obj>> register ]
+ [ index>> register ]
+ [ temp>> register ]
+ } cleave %string-nth ;
+
: dst/src ( insn -- dst src )
[ dst>> register ] [ src>> register ] bi ; inline
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: math kernel layouts system ;
+USING: math kernel layouts system strings ;
IN: compiler.constants
! These constants must match vm/memory.h
-: card-bits 8 ;
-: deck-bits 18 ;
-: card-mark ( -- n ) HEX: 40 HEX: 80 bitor ;
+: card-bits 8 ; inline
+: deck-bits 18 ; inline
+: card-mark ( -- n ) HEX: 40 HEX: 80 bitor ; inline
! These constants must match vm/layouts.h
-: header-offset ( -- n ) object tag-number neg ;
-: float-offset ( -- n ) 8 float tag-number - ;
-: string-offset ( -- n ) 4 bootstrap-cells object tag-number - ;
-: profile-count-offset ( -- n ) 7 bootstrap-cells object tag-number - ;
-: byte-array-offset ( -- n ) 2 bootstrap-cells object tag-number - ;
-: alien-offset ( -- n ) 3 bootstrap-cells object tag-number - ;
-: underlying-alien-offset ( -- n ) bootstrap-cell object tag-number - ;
-: tuple-class-offset ( -- n ) bootstrap-cell tuple tag-number - ;
-: class-hash-offset ( -- n ) bootstrap-cell object tag-number - ;
-: word-xt-offset ( -- n ) 9 bootstrap-cells object tag-number - ;
-: quot-xt-offset ( -- n ) 3 bootstrap-cells object tag-number - ;
-: word-code-offset ( -- n ) 10 bootstrap-cells object tag-number - ;
-: array-start-offset ( -- n ) 2 bootstrap-cells object tag-number - ;
-: compiled-header-size ( -- n ) 4 bootstrap-cells ;
+: header-offset ( -- n ) object tag-number neg ; inline
+: float-offset ( -- n ) 8 float tag-number - ; inline
+: string-offset ( -- n ) 4 bootstrap-cells object tag-number - ; inline
+: string-aux-offset ( -- n ) 2 bootstrap-cells string tag-number - ; inline
+: profile-count-offset ( -- n ) 7 bootstrap-cells object tag-number - ; inline
+: byte-array-offset ( -- n ) 2 bootstrap-cells object tag-number - ; inline
+: alien-offset ( -- n ) 3 bootstrap-cells object tag-number - ; inline
+: underlying-alien-offset ( -- n ) bootstrap-cell object tag-number - ; inline
+: tuple-class-offset ( -- n ) bootstrap-cell tuple tag-number - ; inline
+: class-hash-offset ( -- n ) bootstrap-cell object tag-number - ; inline
+: word-xt-offset ( -- n ) 9 bootstrap-cells object tag-number - ; inline
+: quot-xt-offset ( -- n ) 3 bootstrap-cells object tag-number - ; inline
+: word-code-offset ( -- n ) 10 bootstrap-cells object tag-number - ; inline
+: array-start-offset ( -- n ) 2 bootstrap-cells object tag-number - ; inline
+: compiled-header-size ( -- n ) 4 bootstrap-cells ; inline
! Relocation classes
-: rc-absolute-cell 0 ;
-: rc-absolute 1 ;
-: rc-relative 2 ;
-: rc-absolute-ppc-2/2 3 ;
-: rc-relative-ppc-2 4 ;
-: rc-relative-ppc-3 5 ;
-: rc-relative-arm-3 6 ;
-: rc-indirect-arm 7 ;
-: rc-indirect-arm-pc 8 ;
+: rc-absolute-cell 0 ; inline
+: rc-absolute 1 ; inline
+: rc-relative 2 ; inline
+: rc-absolute-ppc-2/2 3 ; inline
+: rc-relative-ppc-2 4 ; inline
+: rc-relative-ppc-3 5 ; inline
+: rc-relative-arm-3 6 ; inline
+: rc-indirect-arm 7 ; inline
+: rc-indirect-arm-pc 8 ; inline
! Relocation types
-: rt-primitive 0 ;
-: rt-dlsym 1 ;
-: rt-literal 2 ;
-: rt-dispatch 3 ;
-: rt-xt 4 ;
-: rt-here 5 ;
-: rt-label 6 ;
-: rt-immediate 7 ;
+: rt-primitive 0 ; inline
+: rt-dlsym 1 ; inline
+: rt-literal 2 ; inline
+: rt-dispatch 3 ; inline
+: rt-xt 4 ; inline
+: rt-here 5 ; inline
+: rt-label 6 ; inline
+: rt-immediate 7 ; inline
: rc-absolute? ( n -- ? )
[ rc-absolute-ppc-2/2 = ]
strings.private system random layouts vectors
sbufs strings.private slots.private alien math.order
alien.accessors alien.c-types alien.syntax alien.strings
-namespaces libc sequences.private io.encodings.ascii ;
+namespaces libc sequences.private io.encodings.ascii
+classes ;
IN: compiler.tests
! Make sure that intrinsic ops compile to correct code.
[ 1 ] [ { 1 2 } [ 2 slot ] compile-call ] unit-test
[ 1 ] [ [ { 1 2 } 2 slot ] compile-call ] unit-test
+
+[ { f f } ] [ 2 f <array> ] unit-test
+
[ 3 ] [ 3 1 2 2array [ { array } declare [ 2 set-slot ] keep ] compile-call first ] unit-test
[ 3 ] [ 3 1 2 [ 2array [ 2 set-slot ] keep ] compile-call first ] unit-test
[ 3 ] [ [ 3 1 2 2array [ 2 set-slot ] keep ] compile-call first ] unit-test
! Write barrier hits on the wrong value were causing segfaults
[ -3 ] [ -3 1 2 [ 2array [ 3 set-slot ] keep ] compile-call second ] unit-test
-! [ CHAR: b ] [ 1 "abc" [ char-slot ] compile-call ] unit-test
-! [ CHAR: b ] [ 1 [ "abc" char-slot ] compile-call ] unit-test
-! [ CHAR: b ] [ [ 1 "abc" char-slot ] compile-call ] unit-test
-!
-! [ "axc" ] [ CHAR: x 1 "abc" [ [ set-char-slot ] keep { string } declare dup rehash-string ] compile-call ] unit-test
-! [ "axc" ] [ CHAR: x 1 [ "abc" [ set-char-slot ] keep { string } declare dup rehash-string ] compile-call ] unit-test
-! [ "axc" ] [ CHAR: x [ 1 "abc" [ set-char-slot ] keep { string } declare dup rehash-string ] compile-call ] unit-test
+[ CHAR: a ] [ 0 "abc" [ string-nth ] compile-call ] unit-test
+[ CHAR: a ] [ 0 [ "abc" string-nth ] compile-call ] unit-test
+[ CHAR: a ] [ [ 0 "abc" string-nth ] compile-call ] unit-test
+[ CHAR: b ] [ 1 "abc" [ string-nth ] compile-call ] unit-test
+[ CHAR: b ] [ 1 [ "abc" string-nth ] compile-call ] unit-test
+[ CHAR: b ] [ [ 1 "abc" string-nth ] compile-call ] unit-test
+
+[ HEX: 123456 ] [ 0 "\u123456bc" [ string-nth ] compile-call ] unit-test
+[ HEX: 123456 ] [ 0 [ "\u123456bc" string-nth ] compile-call ] unit-test
+[ HEX: 123456 ] [ [ 0 "\u123456bc" string-nth ] compile-call ] unit-test
+[ HEX: 123456 ] [ 1 "a\u123456c" [ string-nth ] compile-call ] unit-test
+[ HEX: 123456 ] [ 1 [ "a\u123456c" string-nth ] compile-call ] unit-test
+[ HEX: 123456 ] [ [ 1 "a\u123456c" string-nth ] compile-call ] unit-test
[ ] [ [ 0 getenv ] compile-call drop ] unit-test
[ ] [ 1 getenv [ 1 setenv ] compile-call ] unit-test
[ 4 ] [ 1 [ 3 fixnum+fast ] compile-call ] unit-test
[ 4 ] [ [ 1 3 fixnum+fast ] compile-call ] unit-test
+[ -2 ] [ 1 3 [ fixnum-fast ] compile-call ] unit-test
+[ -2 ] [ 1 [ 3 fixnum-fast ] compile-call ] unit-test
+[ -2 ] [ [ 1 3 fixnum-fast ] compile-call ] unit-test
+
[ 30001 ] [ 1 [ 30000 fixnum+fast ] compile-call ] unit-test
[ 6 ] [ 2 3 [ fixnum*fast ] compile-call ] unit-test
: compiled-fixnum>bignum fixnum>bignum ;
+[ bignum ] [ 0 compiled-fixnum>bignum class ] unit-test
+
[ ] [
10000 [
32 random-bits >fixnum
--- /dev/null
+USING: kernel tools.test eval ;
+IN: compiler.tests.redefine12
+
+! A regression that came about when fixing the
+! 'no method on classes-intersect?' bug
+
+GENERIC: g ( a -- b )
+
+M: object g drop t ;
+
+: h ( a -- b ) dup [ g ] when ;
+
+[ f ] [ f h ] unit-test
+[ t ] [ "hi" h ] unit-test
+
+TUPLE: jeah ;
+
+[ ] [ "USE: kernel IN: compiler.tests.redefine12 M: jeah g drop f ;" eval ] unit-test
+
+[ f ] [ T{ jeah } h ] unit-test
--- /dev/null
+USING: math.private kernel combinators accessors arrays
+generalizations float-arrays tools.test ;
+IN: compiler.tests
+
+: float-spill-bug ( a -- b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b )
+ {
+ [ dup float+ ]
+ [ dup float+ ]
+ [ dup float+ ]
+ [ dup float+ ]
+ [ dup float+ ]
+ [ dup float+ ]
+ [ dup float+ ]
+ [ dup float+ ]
+ [ dup float+ ]
+ [ dup float+ ]
+ [ dup float+ ]
+ [ dup float+ ]
+ [ dup float+ ]
+ [ dup float+ ]
+ [ dup float+ ]
+ [ dup float+ ]
+ [ dup float+ ]
+ [ dup float+ ]
+ [ dup float+ ]
+ [ dup float+ ]
+ [ dup float+ ]
+ [ dup float+ ]
+ [ dup float+ ]
+ [ dup float+ ]
+ [ dup float+ ]
+ [ dup float+ ]
+ [ dup float+ ]
+ [ dup float+ ]
+ [ dup float+ ]
+ [ dup float+ ]
+ [ dup float+ ]
+ [ dup float+ ]
+ [ dup float+ ]
+ [ dup float+ ]
+ [ dup float+ ]
+ [ dup float+ ]
+ [ dup float+ ]
+ [ dup float+ ]
+ } cleave ;
+
+[ 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 ]
+[ 1.0 float-spill-bug ] unit-test
+
+[ t ] [ \ float-spill-bug compiled>> ] unit-test
+
+: float-fixnum-spill-bug ( object -- object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object )
+ {
+ [ dup float+ ]
+ [ float>fixnum dup fixnum+fast ]
+ [ dup float+ ]
+ [ float>fixnum dup fixnum+fast ]
+ [ dup float+ ]
+ [ float>fixnum dup fixnum+fast ]
+ [ dup float+ ]
+ [ float>fixnum dup fixnum+fast ]
+ [ dup float+ ]
+ [ float>fixnum dup fixnum+fast ]
+ [ dup float+ ]
+ [ float>fixnum dup fixnum+fast ]
+ [ dup float+ ]
+ [ float>fixnum dup fixnum+fast ]
+ [ dup float+ ]
+ [ float>fixnum dup fixnum+fast ]
+ [ dup float+ ]
+ [ float>fixnum dup fixnum+fast ]
+ [ dup float+ ]
+ [ float>fixnum dup fixnum+fast ]
+ [ dup float+ ]
+ [ float>fixnum dup fixnum+fast ]
+ [ dup float+ ]
+ [ float>fixnum dup fixnum+fast ]
+ [ dup float+ ]
+ [ float>fixnum dup fixnum+fast ]
+ [ dup float+ ]
+ [ float>fixnum dup fixnum+fast ]
+ [ dup float+ ]
+ [ float>fixnum dup fixnum+fast ]
+ [ dup float+ ]
+ [ float>fixnum dup fixnum+fast ]
+ [ dup float+ ]
+ [ float>fixnum dup fixnum+fast ]
+ [ dup float+ ]
+ [ float>fixnum dup fixnum+fast ]
+ [ dup float+ ]
+ [ float>fixnum dup fixnum+fast ]
+ [ dup float+ ]
+ [ float>fixnum dup fixnum+fast ]
+ [ dup float+ ]
+ [ float>fixnum dup fixnum+fast ]
+ [ dup float+ ]
+ [ float>fixnum dup fixnum+fast ]
+ [ dup float+ ]
+ [ float>fixnum dup fixnum+fast ]
+ [ dup float+ ]
+ [ float>fixnum dup fixnum+fast ]
+ [ dup float+ ]
+ [ float>fixnum dup fixnum+fast ]
+ [ dup float+ ]
+ [ float>fixnum dup fixnum+fast ]
+ [ dup float+ ]
+ [ float>fixnum dup fixnum+fast ]
+ [ dup float+ ]
+ [ float>fixnum dup fixnum+fast ]
+ [ dup float+ ]
+ [ float>fixnum dup fixnum+fast ]
+ [ dup float+ ]
+ [ float>fixnum dup fixnum+fast ]
+ [ dup float+ ]
+ [ float>fixnum dup fixnum+fast ]
+ [ dup float+ ]
+ [ float>fixnum dup fixnum+fast ]
+ [ dup float+ ]
+ [ float>fixnum dup fixnum+fast ]
+ [ dup float+ ]
+ [ float>fixnum dup fixnum+fast ]
+ [ dup float+ ]
+ [ float>fixnum dup fixnum+fast ]
+ [ dup float+ ]
+ [ float>fixnum dup fixnum+fast ]
+ [ dup float+ ]
+ [ float>fixnum dup fixnum+fast ]
+ [ dup float+ ]
+ [ float>fixnum dup fixnum+fast ]
+ } cleave ;
+
+[ 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 ]
+[ 1.0 float-fixnum-spill-bug ] unit-test
+
+[ t ] [ \ float-fixnum-spill-bug compiled>> ] unit-test
+
+: resolve-spill-bug ( a b -- c )
+ [ 1 fixnum+fast ] bi@ dup 10 fixnum< [
+ nip 2 fixnum+fast
+ ] [
+ drop {
+ [ dup fixnum+fast ]
+ [ dup fixnum+fast ]
+ [ dup fixnum+fast ]
+ [ dup fixnum+fast ]
+ [ dup fixnum+fast ]
+ [ dup fixnum+fast ]
+ [ dup fixnum+fast ]
+ [ dup fixnum+fast ]
+ [ dup fixnum+fast ]
+ [ dup fixnum+fast ]
+ [ dup fixnum+fast ]
+ [ dup fixnum+fast ]
+ [ dup fixnum+fast ]
+ [ dup fixnum+fast ]
+ [ dup fixnum+fast ]
+ [ dup fixnum+fast ]
+ } cleave
+ 16 narray
+ ] if ;
+
+[ t ] [ \ resolve-spill-bug compiled>> ] unit-test
+
+[ 4 ] [ 1 1 resolve-spill-bug ] unit-test
+
+! The above don't really test spilling...
+: spill-test-1 ( a -- b )
+ dup 1 fixnum+fast
+ dup 1 fixnum+fast
+ dup 1 fixnum+fast
+ dup 1 fixnum+fast
+ dup 1 fixnum+fast
+ dup 1 fixnum+fast
+ dup 1 fixnum+fast
+ dup 1 fixnum+fast
+ dup 1 fixnum+fast
+ dup 1 fixnum+fast
+ dup 1 fixnum+fast
+ dup 1 fixnum+fast
+ dup 1 fixnum+fast
+ dup 1 fixnum+fast
+ dup 1 fixnum+fast
+ dup 1 fixnum+fast
+ dup 1 fixnum+fast
+ dup 1 fixnum+fast
+ dup 1 fixnum+fast
+ dup 1 fixnum+fast
+ dup 1 fixnum+fast
+ dup 1 fixnum+fast
+ dup 1 fixnum+fast
+ dup 1 fixnum+fast
+ dup 1 fixnum+fast
+ dup 1 fixnum+fast
+ dup 1 fixnum+fast
+ dup 1 fixnum+fast
+ dup 1 fixnum+fast fixnum>float
+ 3array
+ 3array [ 8 narray ] dip 2array
+ [ 8 narray [ 8 narray ] dip 2array ] dip 2array
+ 2array ;
+
+[
+ {
+ 1
+ {
+ { { 2 3 4 5 6 7 8 9 } { 10 11 12 13 14 15 16 17 } }
+ {
+ { 18 19 20 21 22 23 24 25 }
+ { 26 27 { 28 29 30.0 } }
+ }
+ }
+ }
+] [ 1 spill-test-1 ] unit-test
+
+: spill-test-2 ( a -- b )
+ dup 1.0 float+
+ dup 1.0 float+
+ dup 1.0 float+
+ dup 1.0 float+
+ dup 1.0 float+
+ dup 1.0 float+
+ dup 1.0 float+
+ dup 1.0 float+
+ dup 1.0 float+
+ dup 1.0 float+
+ dup 1.0 float+
+ dup 1.0 float+
+ dup 1.0 float+
+ dup 1.0 float+
+ dup 1.0 float+
+ dup 1.0 float+
+ dup 1.0 float+
+ dup 1.0 float+
+ dup 1.0 float+
+ dup 1.0 float+
+ dup 1.0 float+
+ dup 1.0 float+
+ dup 1.0 float+
+ dup 1.0 float+
+ dup 1.0 float+
+ dup 1.0 float+
+ dup 1.0 float+
+ dup 1.0 float+
+ dup 1.0 float+
+ dup 1.0 float+
+ dup 1.0 float+
+ dup 1.0 float+
+ dup 1.0 float+
+ dup 1.0 float+
+ dup 1.0 float+
+ dup 1.0 float+
+ dup 1.0 float+
+ dup 1.0 float+
+ dup 1.0 float+
+ dup 1.0 float+
+ dup 1.0 float+
+ dup 1.0 float+
+ dup 1.0 float+
+ dup 1.0 float+
+ dup 1.0 float+
+ dup 1.0 float+
+ dup 1.0 float+
+ dup 1.0 float+
+ dup 1.0 float+
+ dup 1.0 float+
+ dup 1.0 float+
+ dup 1.0 float+
+ dup 1.0 float+
+ dup 1.0 float+
+ dup 1.0 float+
+ dup 1.0 float+
+ dup 1.0 float+
+ dup 1.0 float+
+ dup 1.0 float+
+ dup 1.0 float+
+ dup 1.0 float+
+ dup 1.0 float+
+ dup 1.0 float+
+ float*
+ float*
+ float*
+ float*
+ float*
+ float*
+ float*
+ float*
+ float*
+ float*
+ float*
+ float*
+ float*
+ float*
+ float*
+ float*
+ float*
+ float*
+ float*
+ float*
+ float*
+ float*
+ float*
+ float*
+ float*
+ float*
+ float*
+ float*
+ float*
+ float*
+ float*
+ float*
+ float*
+ float*
+ float*
+ float*
+ float*
+ float*
+ float*
+ float*
+ float*
+ float*
+ float*
+ float*
+ float*
+ float*
+ float*
+ float*
+ float*
+ float*
+ float*
+ float*
+ float*
+ float*
+ float*
+ float*
+ float*
+ float*
+ float*
+ float*
+ float*
+ float*
+ float* ;
+
+[ t ] [ 1.0 spill-test-2 1.0 \ spill-test-2 def>> call = ] unit-test
sequences sequences.private tools.test namespaces.private
slots.private sequences.private byte-arrays alien
alien.accessors layouts words definitions compiler.units io
-combinators vectors ;
+combinators vectors float-arrays ;
IN: compiler.tests
! Originally, this file did black box testing of templating
] compile-call
] unit-test
-: float-spill-bug ( a -- b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b )
- {
- [ dup float+ ]
- [ dup float+ ]
- [ dup float+ ]
- [ dup float+ ]
- [ dup float+ ]
- [ dup float+ ]
- [ dup float+ ]
- [ dup float+ ]
- [ dup float+ ]
- [ dup float+ ]
- [ dup float+ ]
- [ dup float+ ]
- [ dup float+ ]
- [ dup float+ ]
- [ dup float+ ]
- [ dup float+ ]
- [ dup float+ ]
- [ dup float+ ]
- [ dup float+ ]
- [ dup float+ ]
- [ dup float+ ]
- [ dup float+ ]
- [ dup float+ ]
- [ dup float+ ]
- [ dup float+ ]
- [ dup float+ ]
- [ dup float+ ]
- [ dup float+ ]
- [ dup float+ ]
- [ dup float+ ]
- [ dup float+ ]
- [ dup float+ ]
- [ dup float+ ]
- [ dup float+ ]
- [ dup float+ ]
- [ dup float+ ]
- [ dup float+ ]
- [ dup float+ ]
- } cleave ;
-
-[ 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 ]
-[ 1.0 float-spill-bug ] unit-test
-
-[ t ] [ \ float-spill-bug compiled>> ] unit-test
-
-: float-fixnum-spill-bug ( object -- object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object )
- {
- [ dup float+ ]
- [ float>fixnum dup fixnum+fast ]
- [ dup float+ ]
- [ float>fixnum dup fixnum+fast ]
- [ dup float+ ]
- [ float>fixnum dup fixnum+fast ]
- [ dup float+ ]
- [ float>fixnum dup fixnum+fast ]
- [ dup float+ ]
- [ float>fixnum dup fixnum+fast ]
- [ dup float+ ]
- [ float>fixnum dup fixnum+fast ]
- [ dup float+ ]
- [ float>fixnum dup fixnum+fast ]
- [ dup float+ ]
- [ float>fixnum dup fixnum+fast ]
- [ dup float+ ]
- [ float>fixnum dup fixnum+fast ]
- [ dup float+ ]
- [ float>fixnum dup fixnum+fast ]
- [ dup float+ ]
- [ float>fixnum dup fixnum+fast ]
- [ dup float+ ]
- [ float>fixnum dup fixnum+fast ]
- [ dup float+ ]
- [ float>fixnum dup fixnum+fast ]
- [ dup float+ ]
- [ float>fixnum dup fixnum+fast ]
- [ dup float+ ]
- [ float>fixnum dup fixnum+fast ]
- [ dup float+ ]
- [ float>fixnum dup fixnum+fast ]
- [ dup float+ ]
- [ float>fixnum dup fixnum+fast ]
- [ dup float+ ]
- [ float>fixnum dup fixnum+fast ]
- [ dup float+ ]
- [ float>fixnum dup fixnum+fast ]
- [ dup float+ ]
- [ float>fixnum dup fixnum+fast ]
- [ dup float+ ]
- [ float>fixnum dup fixnum+fast ]
- [ dup float+ ]
- [ float>fixnum dup fixnum+fast ]
- [ dup float+ ]
- [ float>fixnum dup fixnum+fast ]
- [ dup float+ ]
- [ float>fixnum dup fixnum+fast ]
- [ dup float+ ]
- [ float>fixnum dup fixnum+fast ]
- [ dup float+ ]
- [ float>fixnum dup fixnum+fast ]
- [ dup float+ ]
- [ float>fixnum dup fixnum+fast ]
- [ dup float+ ]
- [ float>fixnum dup fixnum+fast ]
- [ dup float+ ]
- [ float>fixnum dup fixnum+fast ]
- [ dup float+ ]
- [ float>fixnum dup fixnum+fast ]
- [ dup float+ ]
- [ float>fixnum dup fixnum+fast ]
- [ dup float+ ]
- [ float>fixnum dup fixnum+fast ]
- [ dup float+ ]
- [ float>fixnum dup fixnum+fast ]
- [ dup float+ ]
- [ float>fixnum dup fixnum+fast ]
- [ dup float+ ]
- [ float>fixnum dup fixnum+fast ]
- [ dup float+ ]
- [ float>fixnum dup fixnum+fast ]
- [ dup float+ ]
- [ float>fixnum dup fixnum+fast ]
- [ dup float+ ]
- [ float>fixnum dup fixnum+fast ]
- } cleave ;
-
-[ 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 ]
-[ 1.0 float-fixnum-spill-bug ] unit-test
-
-[ t ] [ \ float-fixnum-spill-bug compiled>> ] unit-test
-
-: resolve-spill-bug ( a b -- c )
- [ 1 fixnum+fast ] bi@ dup 10 fixnum< [
- nip 2 fixnum+fast
- ] [
- drop {
- [ dup fixnum+fast ]
- [ dup fixnum+fast ]
- [ dup fixnum+fast ]
- [ dup fixnum+fast ]
- [ dup fixnum+fast ]
- [ dup fixnum+fast ]
- [ dup fixnum+fast ]
- [ dup fixnum+fast ]
- [ dup fixnum+fast ]
- [ dup fixnum+fast ]
- [ dup fixnum+fast ]
- [ dup fixnum+fast ]
- [ dup fixnum+fast ]
- [ dup fixnum+fast ]
- [ dup fixnum+fast ]
- [ dup fixnum+fast ]
- } cleave
- 16 narray
- ] if ;
-
-[ t ] [ \ resolve-spill-bug compiled>> ] unit-test
-
-[ 4 ] [ 1 1 resolve-spill-bug ] unit-test
-
! Regression
: dispatch-alignment-regression ( -- c )
{ tuple vector } 3 slot { word } declare
: immutable-tuple-boa? ( #call -- ? )
dup word>> \ <tuple-boa> eq? [
dup in-d>> peek node-value-info
- literal>> class>> immutable-tuple-class?
+ literal>> first immutable-tuple-class?
] [ drop f ] if ;
] bi* + + + + + ;
: should-inline? ( #call word -- ? )
- inlining-rank 5 >= ;
+ dup "inline" word-prop [ 2drop t ] [ inlining-rank 5 >= ] if ;
SYMBOL: history
{ <tuple> <tuple-boa> } [
[
- literal>> dup tuple-layout? [ class>> ] [ drop tuple ] if <class-info>
+ literal>> dup array? [ first ] [ drop tuple ] if <class-info>
[ clear ] dip
] "outputs" set-word-prop
] each
[ T{ mutable-tuple-test f "hey" } x>> ] final-classes
] unit-test
-[ V{ tuple-layout } ] [
+[ V{ array } ] [
[ T{ mutable-tuple-test f "hey" } layout-of ] final-classes
] unit-test
: propagate-<tuple-boa> ( #call -- info )
in-d>> unclip-last
- value-info literal>> class>> (propagate-tuple-constructor) ;
+ value-info literal>> first (propagate-tuple-constructor) ;
: propagate-<complex> ( #call -- info )
in-d>> [ value-info ] map complex <tuple-info> ;
! See http://factorcode.org/license.txt for BSD license.\r
IN: concurrency.mailboxes\r
USING: dlists deques threads sequences continuations\r
-destructors namespaces random math quotations words kernel\r
+destructors namespaces math quotations words kernel\r
arrays assocs init system concurrency.conditions accessors\r
debugger debugger.threads locals ;\r
\r
! Concurrency library for Factor, based on Erlang/Termite style\r
! concurrency.\r
USING: kernel threads concurrency.mailboxes continuations\r
-namespaces assocs random accessors summary ;\r
+namespaces assocs accessors summary ;\r
IN: concurrency.messaging\r
\r
GENERIC: send ( message thread -- )\r
TUPLE: synchronous data sender tag ;\r
\r
: <synchronous> ( data -- sync )\r
- self 256 random-bits synchronous boa ;\r
+ self synchronous counter synchronous boa ;\r
\r
TUPLE: reply data tag ;\r
\r
HOOK: %set-slot cpu ( src obj slot tag temp -- )
HOOK: %set-slot-imm cpu ( src obj slot tag -- )
+HOOK: %string-nth cpu ( dst obj index temp -- )
+
HOOK: %add cpu ( dst src1 src2 -- )
HOOK: %add-imm cpu ( dst src1 src2 -- )
HOOK: %sub cpu ( dst src1 src2 -- )
\r
4 jit-code-format set\r
\r
-: ds-reg 30 ;\r
-: rs-reg 31 ;\r
+: ds-reg 29 ;\r
+: rs-reg 30 ;\r
\r
: factor-area-size ( -- n ) 4 bootstrap-cells ;\r
\r
! Copyright (C) 2005, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: alien.c-types
-accessors
-cpu.architecture
-compiler.cfg.registers
-cpu.ppc.assembler
-kernel
-locals
-layouts
-combinators
-make
-compiler.cfg.instructions
-math.order
-system
-math
-compiler.constants
-namespaces compiler.codegen.fixup ;
+USING: accessors assocs sequences kernel combinators make math
+math.order math.ranges system namespaces locals layouts words
+alien alien.c-types cpu.architecture cpu.ppc.assembler
+compiler.cfg.registers compiler.cfg.instructions
+compiler.constants compiler.codegen compiler.codegen.fixup
+compiler.cfg.intrinsics compiler.cfg.stack-frame ;
IN: cpu.ppc
! PowerPC register assignments:
-! r2-r28: integer vregs
-! r29: integer scratch
-! r30: data stack
-! r31: retain stack
+! r2-r27: integer vregs
+! r28: integer scratch
+! r29: data stack
+! r30: retain stack
! f0-f29: float vregs
! f30, f31: float scratch
t "longlong" c-type (>>stack-align?)
t "ulonglong" c-type (>>stack-align?)
] }
-} cond >>
+} cond
+
+enable-float-intrinsics
+
+\ ##integer>float t frame-required? set-word-prop
+\ ##float>integer t frame-required? set-word-prop >>
M: ppc machine-registers
{
- { int-regs T{ range f 2 27 1 } }
- { double-float-regs T{ range f 0 28 1 } }
+ { int-regs T{ range f 2 26 1 } }
+ { double-float-regs T{ range f 0 29 1 } }
} ;
-: scratch-reg 29 ; inline
-: fp-scratch-reg-1 30 ; inline
-: fp-scratch-reg-2 31 ; inline
+: scratch-reg 28 ; inline
+: fp-scratch-reg 30 ; inline
M: ppc two-operand? f ;
obj rc-absolute-ppc-2/2 rel-literal
reg reg 0 LWZ ;
-: ds-reg 30 ; inline
-: rs-reg 31 ; inline
+: ds-reg 29 ; inline
+: rs-reg 30 ; inline
GENERIC: loc-reg ( loc -- reg )
-M: ds-loc log-reg drop ds-reg ;
-M: rs-loc log-reg drop rs-reg ;
+M: ds-loc loc-reg drop ds-reg ;
+M: rs-loc loc-reg drop rs-reg ;
: loc>operand ( loc -- reg n )
[ loc-reg ] [ n>> cells neg ] bi ; inline
{ macosx [ 6 ] }
} case cells ; foldable
-: lr-save ( -- n )
- os {
- { linux [ 1 ] }
- { macosx [ 2 ] }
- } case cells ; foldable
+! The start of the stack frame contains the size of this frame
+! as well as the currently executing XT
+: factor-area-size ( -- n ) 2 cells ; foldable
+: next-save ( n -- i ) cell - ;
+: xt-save ( n -- i ) 2 cells - ;
+! Next, we have the spill area as well as the FFI parameter area.
+! They overlap, since basic blocks with FFI calls will never
+! spill.
: param@ ( n -- x ) reserved-area-size + ; inline
: param-save-size ( -- n ) 8 cells ; foldable
: local@ ( n -- x )
reserved-area-size param-save-size + + ; inline
-: factor-area-size ( -- n ) 2 cells ; foldable
+: spill-integer-base ( -- n )
+ stack-frame get spill-counts>> double-float-regs swap at
+ double-float-regs reg-size * ;
-: next-save ( n -- i ) cell - ;
+: spill-integer@ ( n -- offset )
+ cells spill-integer-base + param@ ;
-: xt-save ( n -- i ) 2 cells - ;
+: spill-float@ ( n -- offset )
+ double-float-regs reg-size * param@ ;
+
+! Some FP intrinsics need a temporary scratch area in the stack
+! frame, 8 bytes in size
+: scratch@ ( n -- offset )
+ stack-frame get total-size>>
+ factor-area-size -
+ param-save-size -
+ + ;
+
+! Finally we have the linkage area
+: lr-save ( -- n )
+ os {
+ { linux [ 1 ] }
+ { macosx [ 2 ] }
+ } case cells ; foldable
M: ppc stack-frame-size ( stack-frame -- i )
[ spill-counts>> [ swap reg-size * ] { } assoc>map sum ]
[ params>> ]
[ return>> ]
tri + +
- reserved-area-size +
param-save-size +
+ reserved-area-size +
factor-area-size +
4 cells align ;
M: ppc %set-slot ( src obj slot tag temp -- ) (%slot) STW ;
M: ppc %set-slot-imm ( src obj slot tag -- ) (%slot-imm) STW ;
+M:: ppc %string-nth ( dst src index temp -- )
+ [
+ "end" define-label
+ temp src index ADD
+ dst temp string-offset LBZ
+ temp src string-aux-offset LWZ
+ 0 temp \ f tag-number CMPI
+ "end" get BEQ
+ temp temp index ADD
+ temp temp index ADD
+ temp temp byte-array-offset LHZ
+ temp temp 8 SLWI
+ dst dst temp OR
+ "end" resolve-label
+ ] with-scope ;
+
M: ppc %add ADD ;
M: ppc %add-imm ADDI ;
-M: ppc %sub swapd SUBF ;
+M: ppc %sub swap SUBF ;
M: ppc %sub-imm SUBI ;
M: ppc %mul MULLW ;
M: ppc %mul-imm MULLI ;
: bignum@ ( n -- offset ) cells bignum tag-number - ; inline
-M: ppc %integer>bignum ( dst src temp -- )
+M:: ppc %integer>bignum ( dst src temp -- )
[
- { "end" "non-zero" "pos" "store" } [ define-label ] each
- dst 0 >bignum %load-immediate
+ "end" define-label
+ dst 0 >bignum %load-indirect
! Is it zero? Then just go to the end and return this zero
0 src 0 CMPI
"end" get BEQ
! Allocate a bignum
dst 4 cells bignum temp %allot
! Write length
- 2 temp LI
- dst 1 bignum@ temp STW
- ! Store value
- dst 3 bignum@ src STW
+ 2 tag-fixnum temp LI
+ temp dst 1 bignum@ STW
! Compute sign
temp src MR
- temp cell-bits 1- SRAWI
+ temp temp cell-bits 1- SRAWI
temp temp 1 ANDI
! Store sign
- dst 2 bignum@ temp STW
+ temp dst 2 bignum@ STW
! Make negative value positive
temp temp temp ADD
temp temp NEG
temp temp 1 ADDI
temp src temp MULLW
! Store the bignum
- dst 3 bignum@ temp STW
+ temp dst 3 bignum@ STW
"end" resolve-label
] with-scope ;
-M:: %bignum>integer ( dst src temp -- )
+M:: ppc %bignum>integer ( dst src temp -- )
[
"end" define-label
temp src 1 bignum@ LWZ
! if the length is 1, its just the sign and nothing else,
! so output 0
0 dst LI
- 0 temp 1 v>operand CMPI
+ 0 temp 1 tag-fixnum CMPI
"end" get BEQ
! load the value
dst src 3 bignum@ LWZ
! and 1 into -1
temp temp temp ADD
temp temp 1 SUBI
+ temp temp NEG
! multiply value by sign
dst dst temp MULLW
"end" resolve-label
M: ppc %mul-float FMUL ;
M: ppc %div-float FDIV ;
-M: ppc %integer>float ( dst src -- )
+M:: ppc %integer>float ( dst src -- )
HEX: 4330 scratch-reg LIS
- scratch-reg 1 0 param@ STW
+ scratch-reg 1 0 scratch@ STW
scratch-reg src MR
scratch-reg dup HEX: 8000 XORIS
- scratch-reg 1 cell param@ STW
- fp-scratch-reg-2 1 0 param@ LFD
- 4503601774854144.0 scratch-reg load-indirect
- fp-scratch-reg-2 scratch-reg float-offset LFD
- fp-scratch-reg-2 fp-scratch-reg-2 fp-scratch-reg-2 FSUB ;
+ scratch-reg 1 4 scratch@ STW
+ dst 1 0 scratch@ LFD
+ scratch-reg 4503601774854144.0 %load-indirect
+ fp-scratch-reg scratch-reg float-offset LFD
+ dst dst fp-scratch-reg FSUB ;
M:: ppc %float>integer ( dst src -- )
- fp-scratch-reg-1 src FCTIWZ
- fp-scratch-reg-2 1 0 param@ STFD
- dst 1 4 param@ LWZ ;
+ fp-scratch-reg src FCTIWZ
+ fp-scratch-reg 1 0 scratch@ STFD
+ dst 1 4 scratch@ LWZ ;
M: ppc %copy ( dst src -- ) MR ;
-M: ppc %copy-float ( dst src -- ) MFR ;
+M: ppc %copy-float ( dst src -- ) FMR ;
M: ppc %unbox-float ( dst src -- ) float-offset LFD ;
+M:: ppc %box-float ( dst src temp -- )
+ dst 16 float temp %allot
+ src dst float-offset STFD ;
+
M:: ppc %unbox-any-c-ptr ( dst src temp -- )
[
{ "is-byte-array" "end" "start" } [ define-label ] each
"f" get BEQ
dst 4 cells alien temp %allot
! Store offset
- dst src 3 alien@ STW
- temp \ f tag-number %load-immediate
+ src dst 3 alien@ STW
! Store expired slot
+ temp \ f tag-number %load-immediate
temp dst 1 alien@ STW
! Store underlying-alien slot
temp dst 2 alien@ STW
M: ppc %alien-unsigned-1 0 LBZ ;
M: ppc %alien-unsigned-2 0 LHZ ;
-M: ppc %alien-signed-1 dupd 0 LBZ EXTSB ;
+M: ppc %alien-signed-1 dupd 0 LBZ dup EXTSB ;
M: ppc %alien-signed-2 0 LHA ;
M: ppc %alien-cell 0 LWZ ;
M: ppc %alien-float 0 LFS ;
M: ppc %alien-double 0 LFD ;
-M: ppc %set-alien-integer-1 0 STB ;
-M: ppc %set-alien-integer-2 0 STH ;
+M: ppc %set-alien-integer-1 swap 0 STB ;
+M: ppc %set-alien-integer-2 swap 0 STH ;
+
+M: ppc %set-alien-cell swap 0 STW ;
-M: ppc %set-alien-cell 0 STW ;
+M: ppc %set-alien-float swap 0 STFS ;
+M: ppc %set-alien-double swap 0 STFD ;
-M: ppc %set-alien-float 0 STFS ;
-M: ppc %set-alien-double 0 STFD ;
+: %load-dlsym ( symbol dll register -- )
+ 0 swap LOAD32 rc-absolute-ppc-2/2 rel-dlsym ;
: load-zone-ptr ( reg -- )
[ "nursery" f ] dip %load-dlsym ;
: load-allot-ptr ( nursery-ptr allot-ptr -- )
- [ drop load-zone-ptr ] [ swap cell LWZ ] 2bi ;
+ [ drop load-zone-ptr ] [ swap 4 LWZ ] 2bi ;
-:: inc-allot-ptr ( nursery-ptr n -- )
- scratch-reg inc-allot-ptr 4 LWZ
- scratch-reg scratch-reg n 8 align ADD
- scratch-reg inc-allot-ptr 4 STW ;
+:: inc-allot-ptr ( nursery-ptr allot-ptr n -- )
+ scratch-reg allot-ptr n 8 align ADDI
+ scratch-reg nursery-ptr 4 STW ;
-:: store-header ( temp class -- )
+:: store-header ( dst class -- )
class type-number tag-fixnum scratch-reg LI
- temp scratch-reg 0 STW ;
+ scratch-reg dst 0 STW ;
: store-tagged ( dst tag -- )
dupd tag-number ORI ;
M:: ppc %allot ( dst size class nursery-ptr -- )
nursery-ptr dst load-allot-ptr
+ nursery-ptr dst size inc-allot-ptr
dst class store-header
- dst class store-tagged
- nursery-ptr size inc-allot-ptr ;
+ dst class store-tagged ;
-: %alien-global ( dest name -- )
- [ f swap %load-dlsym ] [ drop dup 0 LWZ ] 2bi ;
+: %alien-global ( dst name -- )
+ [ f rot %load-dlsym ] [ drop dup 0 LWZ ] 2bi ;
-: load-cards-offset ( dest -- )
+: load-cards-offset ( dst -- )
"cards_offset" %alien-global ;
-: load-decks-offset ( dest -- )
+: load-decks-offset ( dst -- )
"decks_offset" %alien-global ;
M:: ppc %write-barrier ( src card# table -- )
11 11 1024 ADDI ! add ALLOT_BUFFER_ZONE to here
11 0 12 CMP ! is here >= end?
"end" get BLE
- 0 frame-required
%prepare-alien-invoke
"minor_gc" f %alien-invoke
"end" resolve-label ;
M: ppc %prologue ( n -- )
- 0 scrach-reg LOAD32 rc-absolute-ppc-2/2 rel-this
+ 0 11 LOAD32 rc-absolute-ppc-2/2 rel-this
0 MFLR
1 1 pick neg ADDI
- scrach-reg 1 pick xt-save STW
- dup scrach-reg LI
- scrach-reg 1 pick next-save STW
+ 11 1 pick xt-save STW
+ dup 11 LI
+ 11 1 pick next-save STW
0 1 rot lr-save + STW ;
M: ppc %epilogue ( n -- )
:: (%boolean) ( dst word -- )
"end" define-label
- \ f tag-number %load-immediate
+ dst \ f tag-number %load-immediate
"end" get word execute
dst \ t %load-indirect
"end" get resolve-label ; inline
: %boolean ( dst cc -- )
negate-cc {
- { cc< [ \ BLT %boolean ] }
- { cc<= [ \ BLE %boolean ] }
- { cc> [ \ BGT %boolean ] }
- { cc>= [ \ BGE %boolean ] }
- { cc= [ \ BEQ %boolean ] }
- { cc/= [ \ BNE %boolean ] }
+ { cc< [ \ BLT (%boolean) ] }
+ { cc<= [ \ BLE (%boolean) ] }
+ { cc> [ \ BGT (%boolean) ] }
+ { cc>= [ \ BGE (%boolean) ] }
+ { cc= [ \ BEQ (%boolean) ] }
+ { cc/= [ \ BNE (%boolean) ] }
} case ;
: (%compare) ( src1 src2 -- ) [ 0 ] dip CMP ; inline
M: ppc %compare-imm-branch (%compare-imm) %branch ;
M: ppc %compare-float-branch (%compare-float) %branch ;
-: spill-integer-base ( stack-frame -- n )
- [ params>> ] [ return>> ] bi + ;
-
-: stack@ 1 swap ; inline
-
-: spill-integer@ ( n -- op )
- cells
- stack-frame get spill-integer-base
- + stack@ ;
-
-: spill-float-base ( stack-frame -- n )
- [ spill-counts>> int-regs swap at int-regs reg-size * ]
- [ params>> ]
- [ return>> ]
- tri + + ;
-
-: spill-float@ ( n -- op )
- double-float-regs reg-size *
- stack-frame get spill-float-base
- + stack@ ;
-
-M: ppc %spill-integer ( src n -- ) spill-integer@ STW ;
-M: ppc %reload-integer ( dst n -- ) spill-integer@ LWZ ;
+M: ppc %spill-integer ( src n -- ) spill-integer@ 1 swap STW ;
+M: ppc %reload-integer ( dst n -- ) spill-integer@ 1 swap LWZ ;
-M: ppc %spill-float ( src n -- ) spill-float@ STFD ;
-M: ppc %reload-float ( dst n -- ) spill-float@ LFD ;
+M: ppc %spill-float ( src n -- ) spill-float@ 1 swap STFD ;
+M: ppc %reload-float ( dst n -- ) spill-float@ 1 swap LFD ;
M: ppc %loop-entry ;
11 %load-dlsym 11 MTLR BLRL ;
M: ppc %alien-callback ( quot -- )
- 3 load-indirect "c_to_factor" f %alien-invoke ;
+ 3 swap %load-indirect "c_to_factor" f %alien-invoke ;
M: ppc %prepare-alien-indirect ( -- )
"unbox_alien" f %alien-invoke
--- /dev/null
+unportable
+compiler
! Copyright (C) 2005, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors assocs alien alien.c-types arrays
+USING: accessors assocs alien alien.c-types arrays strings
cpu.x86.assembler cpu.x86.assembler.private cpu.architecture
kernel kernel.private math memory namespaces make sequences
words system layouts combinators math.order fry locals
: small-regs ( -- regs ) { EAX ECX EDX EBX } ; inline
: small-reg-that-isn't ( exclude -- reg' )
- small-reg-4 small-regs [ eq? not ] with find nip ;
+ small-regs swap [ small-reg-4 ] map '[ _ memq? not ] find nip ;
: with-save/restore ( reg quot -- )
[ drop PUSH ] [ call ] [ drop POP ] 2tri ; inline
-:: with-small-register ( dst src quot: ( dst src -- ) -- )
+:: with-small-register ( dst exclude quot: ( new-dst -- ) -- )
#! If the destination register overlaps a small register, we
#! call the quot with that. Otherwise, we find a small
- #! register that is not equal to src, and call quot, saving
+ #! register that is not in exclude, and call quot, saving
#! and restoring the small register.
- dst small-reg-4 small-regs memq? [ dst src quot call ] [
- src small-reg-that-isn't
- [| new-dst |
- new-dst src quot call
- dst new-dst MOV
- ] with-save/restore
+ dst small-reg-4 small-regs memq? [ dst quot call ] [
+ exclude small-reg-that-isn't
+ [ quot call ] with-save/restore
] if ; inline
-: %alien-integer-getter ( dst src size quot -- )
- '[ [ dup _ small-reg dup ] [ [] ] bi* MOV @ ]
- with-small-register ; inline
+M:: x86 %string-nth ( dst src index temp -- )
+ "end" define-label
+ dst { src index temp } [| new-dst |
+ temp src index [+] LEA
+ new-dst 1 small-reg temp string-offset [+] MOV
+ new-dst new-dst 1 small-reg MOVZX
+ temp src string-aux-offset [+] MOV
+ temp \ f tag-number CMP
+ "end" get JE
+ new-dst temp XCHG
+ new-dst index ADD
+ new-dst index ADD
+ new-dst 2 small-reg new-dst byte-array-offset [+] MOV
+ new-dst new-dst 2 small-reg MOVZX
+ new-dst 8 SHL
+ new-dst temp OR
+ "end" resolve-label
+ dst new-dst ?MOV
+ ] with-small-register ;
+
+:: %alien-integer-getter ( dst src size quot -- )
+ dst { src } [| new-dst |
+ new-dst dup size small-reg dup src [] MOV
+ quot call
+ dst new-dst ?MOV
+ ] with-small-register ; inline
: %alien-unsigned-getter ( dst src size -- )
[ MOVZX ] %alien-integer-getter ; inline
M: x86 %alien-double [] MOVSD ;
:: %alien-integer-setter ( ptr value size -- )
- value ptr [| new-value ptr |
+ value { ptr } [| new-value |
new-value value ?MOV
ptr [] new-value size small-reg MOV
] with-small-register ; inline
{ $subsection "slots" }
{ $subsection "mirrors" } ;
-USE: random
-
ARTICLE: "numbers" "Numbers"
{ $subsection "arithmetic" }
{ $subsection "math-constants" }
{ $subsection "math-functions" }
{ $subsection "number-strings" }
-{ $subsection "random" }
"Number implementations:"
{ $subsection "integers" }
{ $subsection "rationals" }
{ first first2 first3 first4 }
[ { array } "specializer" set-word-prop ] each
-{ peek pop* pop push } [
+{ peek pop* pop } [
{ vector } "specializer" set-word-prop
] each
+\ push { { vector } { sbuf } } "specializer" set-word-prop
+
\ push-all
{ { string sbuf } { array vector } { byte-array byte-vector } }
"specializer" set-word-prop
[ ptr>> ] [ pos>> ] bi alien-unsigned-1 ; inline
: buffer-pop ( buffer -- byte )
- [ buffer-peek ] [ 1 swap buffer-consume ] bi ;
-
-HINTS: buffer-pop buffer ;
+ [ buffer-peek ] [ 1 swap buffer-consume ] bi ; inline
: buffer-length ( buffer -- n )
[ fill>> ] [ pos>> ] bi - ; inline
HINTS: >buffer byte-array buffer ;
: byte>buffer ( byte buffer -- )
+ [ >fixnum ] dip
[ [ ptr>> ] [ fill>> ] bi set-alien-unsigned-1 ]
[ 1 swap n>buffer ]
- bi ;
-
-HINTS: byte>buffer fixnum buffer ;
+ bi ; inline
: search-buffer-until ( pos fill ptr separators -- n )
- [ [ swap alien-unsigned-1 ] dip memq? ] 2curry find-from drop ;
+ [ [ swap alien-unsigned-1 ] dip memq? ] 2curry find-from drop ; inline
: finish-buffer-until ( buffer n -- byte-array separator )
[
] [
[ buffer-length ] keep
buffer-read f
- ] if* ;
+ ] if* ; inline
: buffer-until ( separators buffer -- byte-array separator )
swap [ { [ ] [ pos>> ] [ fill>> ] [ ptr>> ] } cleave ] dip
: decode-if< ( stream encoding max -- character )
nip swap stream-read1 dup
- [ tuck > [ drop replacement-char ] unless ] [ 2drop f ] if ; inline
+ [ tuck > [ >fixnum ] [ drop replacement-char ] if ] [ 2drop f ] if ; inline
PRIVATE>
SINGLETON: ascii
M: input-port stream-read1
dup check-disposed
- dup wait-to-read [ drop f ] [ buffer>> buffer-pop ] if ;
+ dup wait-to-read [ drop f ] [ buffer>> buffer-pop ] if ; inline
: read-step ( count port -- byte-array/f )
dup wait-to-read [ 2drop f ] [ buffer>> buffer-read ] if ;
: wait-to-write ( len port -- )
tuck buffer>> buffer-capacity <=
- [ drop ] [ stream-flush ] if ;
+ [ drop ] [ stream-flush ] if ; inline
M: output-port stream-write1
dup check-disposed
1 over wait-to-write
- buffer>> byte>buffer ;
+ buffer>> byte>buffer ; inline
M: output-port stream-write
dup check-disposed
HINTS: decoder-readln { input-port utf8 } { input-port ascii } ;
-HINTS: decoder-write { string output-port utf8 } { string output-port ascii } ;
+HINTS: encoder-write { string output-port utf8 } { string output-port ascii } ;
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel accessors alien.accessors math io ;
+USING: kernel accessors alien alien.c-types alien.accessors math io ;
IN: io.streams.memory
TUPLE: memory-stream alien index ;
M: memory-stream stream-read1
[ [ alien>> ] [ index>> ] bi alien-unsigned-1 ]
[ [ 1+ ] change-index drop ] bi ;
+
+M: memory-stream stream-read
+ [
+ [ index>> ] [ alien>> ] bi <displaced-alien>
+ swap memory>byte-array
+ ] [ [ + ] change-index drop ] 2bi ;
USING: locals math sequences tools.test hashtables words kernel
namespaces arrays strings prettyprint io.streams.string parser
accessors generic eval combinators combinators.short-circuit
-combinators.short-circuit.smart math.order math.functions ;
+combinators.short-circuit.smart math.order math.functions
+definitions compiler.units ;
IN: locals.tests
:: foo ( a b -- a a ) a a ;
[ 9 ] [ 3 big-case-test ] unit-test
+GENERIC: lambda-method-forget-test ( a -- b )
+
+M:: integer lambda-method-forget-test ( a -- b ) ;
+
+[ ] [ [ { integer lambda-method-forget-test } forget ] with-compilation-unit ] unit-test
+
! :: wlet-&&-test ( a -- ? )
! [wlet | is-integer? [ a integer? ]
! is-even? [ a even? ]
"lambda" word-prop body>> ;
M: lambda-method reset-word
- [ f "lambda" set-word-prop ] [ call-next-method ] bi ;
+ [ call-next-method ] [ f "lambda" set-word-prop ] bi ;
INTERSECTION: lambda-memoized memoized lambda-word ;
0 1 (a,b) 1 2 [a,b] interval-union 0 2 (a,b] =
] unit-test
-[ f ] [ 0 1 (a,b) f interval-union ] unit-test
-
[ t ] [
0 1 (a,b) 0 1 [a,b] interval-intersect 0 1 (a,b) =
] unit-test
{ [ dup empty-interval eq? ] [ nip ] }
{ [ over empty-interval eq? ] [ drop ] }
[
- 2dup and [
- [ interval>points ] bi@ swapd
- [ [ swap endpoint< ] most ]
- [ [ swap endpoint> ] most ] 2bi*
- <interval>
- ] [
- or
- ] if
+ [ interval>points ] bi@ swapd
+ [ [ swap endpoint< ] most ]
+ [ [ swap endpoint> ] most ] 2bi*
+ <interval>
]
} cond ;
{
{ [ dup empty-interval eq? ] [ drop ] }
{ [ over empty-interval eq? ] [ nip ] }
- [
- 2dup and [
- [ interval>points 2array ] bi@ append points>interval
- ] [
- 2drop f
- ] if
- ]
+ [ [ interval>points 2array ] bi@ append points>interval ]
} cond ;
: interval-subset? ( i1 i2 -- ? )
: interval-length ( int -- n )
{
{ [ dup empty-interval eq? ] [ drop 0 ] }
- { [ dup not ] [ drop 0 ] }
[ interval>points [ first ] bi@ swap - ]
} cond ;
[ object>> [ swap slot ] curry ] bi
map zip ;
-M: mirror assoc-size object>> layout-of size>> ;
+M: mirror assoc-size object>> layout-of second ;
INSTANCE: mirror assoc
] [
pprint-object
] if ;
-
-M: tuple-layout pprint*
- "( tuple layout )" swap present-text ;
[ next-index ]
[ seq>> nth mt-temper ]
[ [ 1+ ] change-i drop ] tri ;
+
+USE: init
+
+[
+ [ 32 random-bits ] with-system-random
+ <mersenne-twister> random-generator set-global
+] "bootstrap.random" add-init-hook
: with-secure-random ( quot -- )
secure-random-generator get swap with-random ; inline
+
+USE: vocabs.loader
+
+{
+ { [ os windows? ] [ "random.windows" require ] }
+ { [ os unix? ] [ "random.unix" require ] }
+} cond
+
+"random.mersenne-twister" require
SINGLETON: beginning-of-input
SINGLETON: end-of-input
-! : beginning-of-input ( -- obj )
-: handle-front-anchor ( -- ) front-anchor push-stack ;
-: end-of-line ( -- obj )
- end-of-input
+: newlines ( -- obj1 obj2 obj3 )
CHAR: \r <constant>
CHAR: \n <constant>
- 2dup 2array <concatenation> 4array <alternation> lookahead boa ;
+ 2dup 2array <concatenation> ;
+
+: beginning-of-line ( -- obj )
+ beginning-of-input newlines 4array <alternation> lookbehind boa ;
+
+: end-of-line ( -- obj )
+ end-of-input newlines 4array <alternation> lookahead boa ;
+
+: handle-front-anchor ( -- )
+ get-multiline beginning-of-line beginning-of-input ? push-stack ;
-: handle-back-anchor ( -- ) end-of-line push-stack ;
+: handle-back-anchor ( -- )
+ get-multiline end-of-line end-of-input ? push-stack ;
ERROR: bad-character-class obj ;
ERROR: expected-posix-class ;
[ [ push ] keep current-regexp get (>>stack) ]
[ finish-regexp-parse push-stack ] bi* ;
-
: parse-regexp-token ( token -- ? )
{
-! todo: only match these at beginning/end of regexp
- { CHAR: ^ [ handle-front-anchor t ] }
- { CHAR: $ [ handle-back-anchor t ] }
-
- { CHAR: . [ handle-dot t ] }
- { CHAR: ( [ handle-left-parenthesis t ] }
+ { CHAR: ( [ handle-left-parenthesis t ] } ! handle (?..) at beginning?
{ CHAR: ) [ handle-right-parenthesis f ] }
+ { CHAR: . [ handle-dot t ] }
{ CHAR: | [ handle-pipe t ] }
{ CHAR: ? [ handle-question t ] }
{ CHAR: * [ handle-star t ] }
{ CHAR: { [ handle-left-brace t ] }
{ CHAR: [ [ handle-left-bracket t ] }
{ CHAR: \ [ handle-escape t ] }
- [ <constant> push-stack t ]
+ [
+ dup CHAR: $ = peek1 f = and [
+ drop
+ handle-back-anchor f
+ ] [
+ <constant> push-stack t
+ ] if
+ ]
} case ;
: (parse-regexp) ( -- )
read1 [ parse-regexp-token [ (parse-regexp) ] when ] when* ;
+: parse-regexp-beginning ( -- )
+ peek1 CHAR: ^ = [ drop1 handle-front-anchor ] when ;
+
: parse-regexp ( regexp -- )
dup current-regexp [
raw>> [
- <string-reader> [ (parse-regexp) ] with-input-stream
+ <string-reader> [
+ parse-regexp-beginning (parse-regexp)
+ ] with-input-stream
] unless-empty
current-regexp get
stack finish-regexp-parse
[ { 0 3 } ] [ "abc" "(ab|a)(bc)?" <regexp> first-match ] unit-test
[ { 23 24 } ] [ "aaaaaaaaaaaaaaaaaaaaaaab" "((a*)*b)*b" <regexp> first-match ] unit-test
-
reversed-regexp initial-option
construct-regexp ;
-
: parsing-regexp ( accum end -- accum )
lexer get dup skip-blank
[ [ index-from dup 1+ swap ] 2keep swapd subseq swap ] change-lexer-column
: R{ CHAR: } parsing-regexp ; parsing
: R| CHAR: | parsing-regexp ; parsing
-
: find-regexp-syntax ( string -- prefix suffix )
{
{ "R/ " "/" }
! See http://factorcode.org/license.txt for BSD license.
USING: accessors assocs combinators kernel math math.ranges
quotations sequences regexp.parser regexp.classes fry arrays
-combinators.short-circuit regexp.utils prettyprint regexp.nfa ;
+combinators.short-circuit regexp.utils prettyprint regexp.nfa
+shuffle ;
IN: regexp.traversal
TUPLE: dfa-traverser
[ dfa-table>> ] [ dfa-traversal-flags>> ] bi
dfa-traverser new
swap >>traversal-flags
- swap [ start-state>> >>current-state ] keep
- >>dfa-table
+ swap [ start-state>> >>current-state ] [ >>dfa-table ] bi
swap >>text
t >>traverse-forward
0 >>start-index
V{ } clone >>matches ;
: match-literal ( transition from-state table -- to-state/f )
- transitions>> at* [ at ] [ 2drop f ] if ;
+ transitions>> at at ;
: match-class ( transition from-state table -- to-state/f )
transitions>> at* [
] [ drop ] if ;
: match-default ( transition from-state table -- to-state/f )
- [ nip ] dip transitions>> at*
- [ t swap at* [ ] [ drop f ] if ] [ drop f ] if ;
+ nipd transitions>> at t swap at ;
: match-transition ( obj from-state dfa -- to-state/f )
{ [ match-literal ] [ match-class ] [ match-default ] } 3|| ;
: infer-<tuple-boa> ( -- )
\ <tuple-boa>
- peek-d literal value>> size>> 1+ { tuple } <effect>
+ peek-d literal value>> second 1+ { tuple } <effect>
apply-word/effect ;
: infer-(throw) ( -- )
\ <tuple> { tuple-layout } { tuple } define-primitive
\ <tuple> make-flushable
-\ <tuple-layout> { word fixnum array fixnum } { tuple-layout } define-primitive
-\ <tuple-layout> make-foldable
-
\ datastack { } { array } define-primitive
\ datastack make-flushable
{ "compiler" deploy-compiler? }
{ "threads" deploy-threads? }
{ "ui" deploy-ui? }
- { "random" deploy-random? }
+ { "unicode" deploy-unicode? }
} [ nip get ] assoc-filter keys
native-io? [ "io" suffix ] when ;
"There are two sets of deployment flags. The first set controls the major subsystems which are to be included in the deployment image:"
{ $subsection deploy-math? }
{ $subsection deploy-compiler? }
-{ $subsection deploy-random? }
+{ $subsection deploy-unicode? }
{ $subsection deploy-threads? }
{ $subsection deploy-ui? }
"The second set of flags controls the level of stripping to be performed on the deployment image; there is a trade-off between image size, and retaining functionality which is required by the application:"
$nl
"On by default. Most programs should be compiled, not only for performance but because features which depend on the C library interface only function after compilation." } ;
-HELP: deploy-random?
-{ $description "Deploy flag. If set, the random number generator protocol is included, together with two implementations: a native OS-specific random number generator, and the Mersenne Twister."
+HELP: deploy-unicode?
+{ $description "Deploy flag. If set, full Unicode " { $link POSTPONE: CHAR: } " syntax is included."
$nl
-"On by default. If your program does not generate random numbers you can disable this to save some space." } ;
+"Off by default. If your program needs to use " { $link POSTPONE: CHAR: } " with named characters, enable this flag." } ;
HELP: deploy-threads?
{ $description "Deploy flag. If set, thread support will be included in the final image."
SYMBOL: deploy-ui?
SYMBOL: deploy-compiler?
SYMBOL: deploy-math?
-SYMBOL: deploy-random?
+SYMBOL: deploy-unicode?
SYMBOL: deploy-threads?
SYMBOL: deploy-io
{ deploy-reflection 1 }
{ deploy-compiler? t }
{ deploy-threads? t }
- { deploy-random? t }
+ { deploy-unicode? f }
{ deploy-math? t }
{ deploy-word-props? f }
{ deploy-word-defs? f }
USING: tools.deploy.config ;
H{
{ deploy-threads? t }
- { deploy-random? f }
{ deploy-c-types? f }
{ deploy-ui? f }
{ deploy-word-props? f }
USING: tools.deploy.config ;
H{
{ deploy-threads? t }
- { deploy-random? f }
{ deploy-c-types? f }
{ deploy-ui? f }
{ deploy-word-props? f }
USING: tools.deploy.config ;
H{
{ deploy-threads? t }
- { deploy-random? f }
{ deploy-c-types? f }
{ deploy-ui? f }
{ deploy-word-props? f }
USING: tools.deploy.config ;
H{
{ deploy-threads? t }
- { deploy-random? f }
{ deploy-c-types? f }
{ deploy-ui? f }
{ deploy-word-props? f }
USING: tools.deploy.config ;
H{
{ deploy-threads? t }
- { deploy-random? f }
{ deploy-c-types? f }
{ deploy-ui? f }
{ deploy-word-props? f }
{ deploy-io 1 }
{ deploy-name "tools.deploy.test.6" }
{ deploy-math? t }
- { deploy-random? f }
{ deploy-compiler? t }
{ deploy-ui? f }
{ deploy-c-types? f }
deploy-compiler? get "Use optimizing compiler" <checkbox> add-gadget
deploy-math? get "Rational and complex number support" <checkbox> add-gadget
deploy-threads? get "Threading support" <checkbox> add-gadget
- deploy-random? get "Random number generator support" <checkbox> add-gadget
+ deploy-unicode? get "Unicode character literal support" <checkbox> add-gadget
deploy-word-props? get "Retain all word properties" <checkbox> add-gadget
deploy-word-defs? get "Retain all word definitions" <checkbox> add-gadget
deploy-c-types? get "Retain all C types" <checkbox> add-gadget ;
8 num-tags set
3 tag-bits set
-18 num-types set
+17 num-types set
H{
{ fixnum BIN: 000 }
{ byte-array 10 }
{ callstack 11 }
{ string 12 }
- { tuple-layout 13 }
+ { word 13 }
{ quotation 14 }
{ dll 15 }
{ alien 16 }
- { word 17 }
} assoc-union type-numbers set
"alien" "alien" create register-builtin
"word" "words" create register-builtin
"byte-array" "byte-arrays" create register-builtin
-"tuple-layout" "classes.tuple.private" create register-builtin
! For predicate classes
"predicate-instance?" "classes.predicate" create drop
"callstack" "kernel" create { } define-builtin
-"tuple-layout" "classes.tuple.private" create {
- { "hashcode" { "fixnum" "math" } read-only }
- { "class" { "word" "words" } initial: t read-only }
- { "size" { "fixnum" "math" } read-only }
- { "superclasses" { "array" "arrays" } initial: { } read-only }
- { "echelon" { "fixnum" "math" } read-only }
-} define-builtin
-
"tuple" "kernel" create
[ { } define-builtin ]
[ define-tuple-layout ]
{ "array>quotation" "quotations.private" }
{ "quotation-xt" "quotations" }
{ "<tuple>" "classes.tuple.private" }
- { "<tuple-layout>" "classes.tuple.private" }
{ "profiling" "tools.profiler.private" }
{ "become" "kernel.private" }
{ "(sleep)" "threads.private" }
1 exit
] if
] %
-] [ ] make bootstrap-boot-quot set
+] [ ] make
+bootstrap-boot-quot set
: 2cache ( key1 key2 assoc quot -- value )\r
>r >r 2array r> [ first2 ] r> compose cache ; inline\r
\r
+GENERIC: valid-class? ( obj -- ? )\r
+\r
+M: class valid-class? drop t ;\r
+M: anonymous-union valid-class? members>> [ valid-class? ] all? ;\r
+M: anonymous-intersection valid-class? participants>> [ valid-class? ] all? ;\r
+M: anonymous-complement valid-class? class>> valid-class? ;\r
+M: word valid-class? drop f ;\r
+\r
DEFER: (class<=)\r
\r
: class<= ( first second -- ? )\r
: q ( -- b ) j new g ;"> <string-reader>
"class-intersect-no-method-b" parse-stream drop
] unit-test
+
+! Similar problem, but with anonymous classes
+[ ] [
+ <" IN: classes.test.c
+ USE: kernel
+ GENERIC: g ( a -- b )
+ M: object g ;
+ TUPLE: z ;"> <string-reader>
+ "class-intersect-no-method-c" parse-stream drop
+] unit-test
+
+[ ] [
+ <" IN: classes.test.d
+ USE: classes.test.c
+ USE: kernel
+ : q ( a -- b ) dup z? [ g ] unless ;"> <string-reader>
+ "class-intersect-no-method-d" parse-stream drop
+] unit-test
+
+! Now, the user removes the z class and adds a method,
+[ ] [
+ <" IN: classes.test.c
+ USE: kernel
+ GENERIC: g ( a -- b )
+ M: object g ;
+ TUPLE: j ;
+ M: j g ;"> <string-reader>
+ "class-intersect-no-method-c" parse-stream drop
+] unit-test
+
+TUPLE: forgotten-predicate-test ;
+
+[ ] [ [ \ forgotten-predicate-test forget ] with-compilation-unit ] unit-test
+[ f ] [ \ forgotten-predicate-test? predicate? ] unit-test
SYMBOL: implementors-map
-PREDICATE: class < word
- "class" word-prop ;
+PREDICATE: class < word "class" word-prop ;
: classes ( -- seq ) implementors-map get keys ;
PREDICATE: predicate < word "predicating" word-prop >boolean ;
+M: predicate reset-word
+ [ call-next-method ] [ { "predicating" } reset-props ] bi ;
+
: define-predicate ( class quot -- )
- >r "predicate" word-prop first
- r> (( object -- ? )) define-declared ;
+ [ "predicate" word-prop first ] dip
+ (( object -- ? )) define-declared ;
: superclass ( class -- super )
#! Output f for non-classes to work with algebra code
] H{ } make-assoc ;
: (define-class) ( word props -- )
- >r
- dup class? [ dup [ implementors-map+ ] [ new-class ] bi ] unless
- dup reset-class
- dup deferred? [ dup define-symbol ] when
- dup redefined
- dup props>>
- r> assoc-union >>props
+ [
+ dup class? [ dup [ implementors-map+ ] [ new-class ] bi ] unless
+ dup reset-class
+ dup deferred? [ dup define-symbol ] when
+ dup redefined
+ dup props>>
+ ] dip assoc-union >>props
dup predicate-word
[ 1quotation "predicate" set-word-prop ]
[ swap "predicating" set-word-prop ]
{ $list
{ { $snippet "\"predicate\"" } " - a quotation which tests if the top of the stack is an instance of this tuple class" }
{ { $snippet "\"slots\"" } " - a sequence of " { $link slot-spec } " instances" }
- { { $snippet "\"tuple-layout\"" } " - a " { $link tuple-layout } " instance" }
+ { { $snippet "\"tuple-layout\"" } " - an array with the tuple size and superclasses encoded in a format amneable to fast method dispatch" }
} } ;
HELP: define-tuple-predicate
{ $description "Outputs an array having the tuple's slots as elements. The first element is the tuple class word and remainder are declared slots." } ;
HELP: <tuple> ( layout -- tuple )
-{ $values { "layout" tuple-layout } { "tuple" tuple } }
+{ $values { "layout" "a tuple layout array" } { "tuple" tuple } }
{ $description "Low-level tuple constructor. User code should never call this directly, and instead use " { $link new } "." } ;
HELP: <tuple-boa> ( ... layout -- tuple )
-{ $values { "..." "values" } { "layout" tuple-layout } { "tuple" tuple } }
+{ $values { "..." "values" } { "layout" "a tuple layout array" } { "tuple" tuple } }
{ $description "Low-level tuple constructor. User code should never call this directly, and instead use " { $link boa } "." } ;
HELP: new
[ t ] [
T{ size-test } tuple-size
- size-test tuple-layout size>> =
+ size-test tuple-layout second =
] unit-test
GENERIC: <yo-momma>
test-laptop-slot-values
-[ laptop ] [
- "laptop" get 1 slot
- dup echelon>> swap
- superclasses>> nth
-] unit-test
-
[ "TUPLE: laptop < computer battery ;" ] [
[ \ laptop see ] with-string-writer string-lines second
] unit-test
PREDICATE: tuple-class < class
"metaclass" word-prop tuple-class eq? ;
-M: tuple class 1 slot 2 slot { word } declare ;
-
ERROR: not-a-tuple object ;
: check-tuple ( object -- tuple )
"layout" word-prop ;
: layout-of ( tuple -- layout )
- 1 slot { tuple-layout } declare ; inline
+ 1 slot { array } declare ; inline
+
+M: tuple class layout-of 2 slot { word } declare ;
: tuple-size ( tuple -- size )
- layout-of size>> ; inline
+ layout-of second ; inline
: prepare-tuple>array ( tuple -- n tuple layout )
check-tuple [ tuple-size ] [ ] [ layout-of ] tri ;
: tuple>array ( tuple -- array )
prepare-tuple>array
>r copy-tuple-slots r>
- class>> prefix ;
+ first prefix ;
: tuple-slots ( tuple -- seq )
prepare-tuple>array drop copy-tuple-slots ;
2drop f
] if ; inline
-: tuple-instance? ( object class echelon -- ? )
- #! 4 slot == superclasses>>
+: tuple-instance-1? ( object class -- ? )
+ swap dup tuple? [
+ layout-of 7 slot eq?
+ ] [ 2drop f ] if ; inline
+
+: tuple-instance? ( object class offset -- ? )
rot dup tuple? [
- layout-of 4 slot { array } declare
- 2dup 1 slot fixnum< [ array-nth eq? ] [ 3drop f ] if
+ layout-of
+ 2dup 1 slot fixnum<=
+ [ swap slot eq? ] [ 3drop f ] if
] [ 3drop f ] if ; inline
+: layout-class-offset ( echelon -- n )
+ 2 * 5 + ;
+
+: echelon-of ( class -- n )
+ tuple-layout third ;
+
: define-tuple-predicate ( class -- )
- dup dup tuple-layout echelon>>
- [ tuple-instance? ] 2curry define-predicate ;
+ dup dup echelon-of {
+ { 1 [ [ tuple-instance-1? ] curry ] }
+ [ layout-class-offset [ tuple-instance? ] 2curry ]
+ } case define-predicate ;
: class-size ( class -- n )
superclasses [ "slots" word-prop length ] sigma ;
define-accessors ;
: make-tuple-layout ( class -- layout )
- [ ]
- [ [ superclass class-size ] [ "slots" word-prop length ] bi + ]
- [ superclasses dup length 1- ] tri
- <tuple-layout> ;
+ [
+ {
+ [ , ]
+ [ [ superclass class-size ] [ "slots" word-prop length ] bi + , ]
+ [ superclasses length 1- , ]
+ [ superclasses [ [ , ] [ hashcode , ] bi ] each ]
+ } cleave
+ ] { } make ;
: define-tuple-layout ( class -- )
dup make-tuple-layout "layout" set-word-prop ;
[ first3 update-slot ] with map ;
: permute-slots ( old-values layout -- new-values )
- [ class>> all-slots ] [ outdated-tuples get at ] bi
+ [ first all-slots ] [ outdated-tuples get at ] bi
compute-slot-permutation
apply-slot-permutation ;
: update-tuple ( tuple -- newtuple )
[ tuple-slots ] [ layout-of ] bi
- [ permute-slots ] [ class>> ] bi
+ [ permute-slots ] [ first ] bi
slots>tuple ;
: outdated-tuple? ( tuple assoc -- ? )
M: tuple-class rank-class drop 0 ;
M: tuple-class instance?
- dup tuple-layout echelon>> tuple-instance? ;
+ dup echelon-of layout-class-offset tuple-instance? ;
M: tuple-class (flatten-class) dup set ;
: (compiled-generic-usages) ( generic class -- assoc )
[ compiled-generic-usage ] dip
[
- 2dup [ class? ] both?
+ 2dup [ valid-class? ] both?
[ classes-intersect? ] [ 2drop f ] if nip
] curry assoc-filter ;
: CREATE-GENERIC ( -- word ) CREATE dup reset-word ;
: create-method-in ( class generic -- method )
- create-method f set-word dup save-location ;
+ create-method dup set-word dup save-location ;
: CREATE-METHOD ( -- method )
scan-word bootstrap-word scan-word create-method-in ;
: with-method-definition ( quot -- parsed )
[
- >r
- [ "method-class" word-prop current-class set ]
- [ "method-generic" word-prop current-generic set ]
- [ ] tri
- r> call
+ [
+ [ "method-class" word-prop current-class set ]
+ [ "method-generic" word-prop current-generic set ]
+ [ ] tri
+ ] dip call
] with-scope ; inline
: (M:) ( method def -- )
USING: classes.private generic.standard.engines namespaces make
arrays assocs sequences.private quotations kernel.private
math slots.private math.private kernel accessors words
-layouts ;
+layouts sorting sequences ;
IN: generic.standard.engines.tag
TUPLE: lo-tag-dispatch-engine methods ;
] if ;
M: lo-tag-dispatch-engine engine>quot
- methods>> engines>quots* [ >r lo-tag-number r> ] assoc-map
+ methods>> engines>quots*
+ [ >r lo-tag-number r> ] assoc-map
[
picker % [ tag ] % [
+ >alist sort-keys reverse
linear-dispatch-quot
] [
num-tags get direct-dispatch-quot
quotations arrays definitions ;
IN: generic.standard.engines.tuple
+: nth-superclass% ( n -- ) 2 * 5 + , \ slot , ; inline
+
+: nth-hashcode% ( n -- ) 2 * 6 + , \ slot , ; inline
+
+: tuple-layout% ( -- )
+ [ { tuple } declare 1 slot { array } declare ] % ; inline
+
+: tuple-layout-echelon% ( -- )
+ [ 4 slot ] % ; inline
+
TUPLE: echelon-dispatch-engine n methods ;
C: <echelon-dispatch-engine> echelon-dispatch-engine
-TUPLE: trivial-tuple-dispatch-engine methods ;
+TUPLE: trivial-tuple-dispatch-engine n methods ;
C: <trivial-tuple-dispatch-engine> trivial-tuple-dispatch-engine
TUPLE: tuple-dispatch-engine echelons ;
: push-echelon ( class method assoc -- )
- >r swap dup "layout" word-prop echelon>> r>
+ [ swap dup "layout" word-prop third ] dip
[ ?set-at ] change-at ;
: echelon-sort ( assoc -- assoc' )
\ <tuple-dispatch-engine> convert-methods ;
M: trivial-tuple-dispatch-engine engine>quot
- methods>> engines>quots* linear-dispatch-quot ;
+ [ n>> ] [ methods>> ] bi dup assoc-empty? [
+ 2drop default get [ drop ] prepend
+ ] [
+ [
+ [ nth-superclass% ]
+ [ engines>quots* linear-dispatch-quot % ] bi*
+ ] [ ] make
+ ] if ;
-: hash-methods ( methods -- buckets )
+: hash-methods ( n methods -- buckets )
>alist V{ } clone [ hashcode 1array ] distribute-buckets
- [ <trivial-tuple-dispatch-engine> ] map ;
+ [ <trivial-tuple-dispatch-engine> ] with map ;
-: word-hashcode% ( -- ) [ 1 slot ] % ;
-
-: class-hash-dispatch-quot ( methods -- quot )
+: class-hash-dispatch-quot ( n methods -- quot )
[
\ dup ,
- word-hashcode%
- hash-methods [ engine>quot ] map hash-dispatch-quot %
+ [ drop nth-hashcode% ]
+ [ hash-methods [ engine>quot ] map hash-dispatch-quot % ] 2bi
] [ ] make ;
: engine-word-name ( -- string )
dup generic get "tuple-dispatch-generic" set-word-prop ;
: define-engine-word ( quot -- word )
- >r <engine-word> dup r> define ;
-
-: array-nth% ( n -- ) 2 + , [ slot { word } declare ] % ;
-
-: tuple-layout-superclasses% ( -- )
- [
- { tuple } declare
- 1 slot { tuple-layout } declare
- 4 slot { array } declare
- ] % ; inline
+ [ <engine-word> dup ] dip define ;
: tuple-dispatch-engine-body ( engine -- quot )
[
picker %
- tuple-layout-superclasses%
- [ n>> array-nth% ]
- [
- methods>> [
- <trivial-tuple-dispatch-engine> engine>quot
- ] [
- class-hash-dispatch-quot
- ] if-small? %
- ] bi
+ tuple-layout%
+ [ n>> ] [ methods>> ] bi
+ [ <trivial-tuple-dispatch-engine> engine>quot ]
+ [ class-hash-dispatch-quot ]
+ if-small? %
] [ ] make ;
M: echelon-dispatch-engine engine>quot
methods>> dup assoc-empty?
[ drop default get ] [ values first engine>quot ] if
] [
- [
- picker %
- tuple-layout-superclasses%
- [ n>> array-nth% ]
- [
- methods>> [
- <trivial-tuple-dispatch-engine> engine>quot
- ] [
- class-hash-dispatch-quot
- ] if-small? %
- ] bi
- ] [ ] make
+ tuple-dispatch-engine-body
] if ;
-: >=-case-quot ( alist -- quot )
- default get [ drop ] prepend swap
+: >=-case-quot ( default alist -- quot )
+ [ [ drop ] prepend ] dip
[
[ [ dup ] swap [ fixnum>= ] curry compose ]
[ [ drop ] prepose ]
] assoc-map
alist>quot ;
-: tuple-layout-echelon% ( -- )
+: simplify-echelon-alist ( default alist -- default' alist' )
+ dup empty? [
+ dup first first 1 <= [
+ nip unclip second swap
+ simplify-echelon-alist
+ ] when
+ ] unless ;
+
+: echelon-case-quot ( alist -- quot )
+ #! We don't have to test for echelon 1 since all tuple
+ #! classes are at least at depth 1 in the inheritance
+ #! hierarchy.
+ default get swap simplify-echelon-alist
[
- { tuple } declare
- 1 slot { tuple-layout } declare
- 5 slot
- ] % ; inline
+ [
+ picker %
+ tuple-layout%
+ tuple-layout-echelon%
+ >=-case-quot %
+ ] [ ] make
+ ] unless-empty ;
M: tuple-dispatch-engine engine>quot
[
- picker %
- tuple-layout-echelon%
[
tuple assumed set
- echelons>> dup empty? [
- unclip-last
+ echelons>> unclip-last
+ [
[
- [
- engine>quot define-engine-word
+ engine>quot
+ over 0 = [
+ define-engine-word
[ remember-engine ] [ 1quotation ] bi
- dup default set
- ] assoc-map
- ]
- [ first2 engine>quot 2array ] bi*
- suffix
- ] unless
+ ] unless
+ dup default set
+ ] assoc-map
+ ]
+ [ first2 engine>quot 2array ] bi*
+ suffix
] with-scope
- >=-case-quot %
+ echelon-case-quot %
] [ ] make ;
[ 1quotation ] [ extra-values \ drop <repetition> ] bi*
prepend [ ] like ;
+: <standard-engine> ( word -- engine )
+ object bootstrap-word assumed set {
+ [ generic set ]
+ [ "engines" word-prop forget-all ]
+ [ V{ } clone "engines" set-word-prop ]
+ [
+ "methods" word-prop
+ [ generic get mangle-method ] assoc-map
+ [ find-default default set ]
+ [ <big-dispatch-engine> ]
+ bi
+ ]
+ } cleave ;
+
: single-combination ( word -- quot )
- [
- object bootstrap-word assumed set {
- [ generic set ]
- [ "engines" word-prop forget-all ]
- [ V{ } clone "engines" set-word-prop ]
- [
- "methods" word-prop
- [ generic get mangle-method ] assoc-map
- [ find-default default set ]
- [ <big-dispatch-engine> ]
- bi engine>quot
- ]
- } cleave
- ] with-scope ;
+ [ <standard-engine> engine>quot ] with-scope ;
ERROR: inconsistent-next-method class generic ;
M: encoder stream-write1
>encoder< encode-char ;
-: decoder-write ( string stream encoding -- )
+: encoder-write ( string stream encoding -- )
[ encode-char ] 2curry each ;
M: encoder stream-write
- >encoder< decoder-write ;
+ >encoder< encoder-write ;
M: encoder dispose stream>> dispose ;
compose compose ; inline
! Booleans
-: not ( obj -- ? ) f t ? ; inline
+: not ( obj -- ? ) [ f ] [ t ] if ; inline
: and ( obj1 obj2 -- ? ) over ? ; inline
-: >boolean ( obj -- ? ) t f ? ; inline
+: >boolean ( obj -- ? ) [ t ] [ f ] if ; inline
: or ( obj1 obj2 -- ? ) dupd ? ; inline
M: word reset-word
{
- "unannotated-def"
- "parsing" "inline" "recursive" "foldable" "flushable"
- "predicating"
- "reading" "writing"
- "reader" "writer"
- "constructing"
- "declared-effect" "constructor-quot" "delimiter"
+ "unannotated-def" "parsing" "inline" "recursive"
+ "foldable" "flushable" "reading" "writing" "reader"
+ "writer" "declared-effect" "delimiter"
} reset-props ;
GENERIC: subwords ( word -- seq )
dup "forgotten" word-prop [ drop ] [
[ delete-xref ]
[ [ name>> ] [ vocabulary>> vocab-words ] bi delete-at ]
- [ t "forgotten" set-word-prop ]
+ [ [ reset-word ] [ t "forgotten" set-word-prop ] bi ]
tri
] if ;
M: word hashcode*
- nip 1 slot { fixnum } declare ;
+ nip 1 slot { fixnum } declare ; foldable
M: word literalize <wrapper> ;
--- /dev/null
+IN: advice
+USING: help.markup help.syntax tools.annotations words ;
+
+HELP: make-advised
+{ $values { "word" "a word to annotate in preparation of advising" } }
+{ $description "Prepares a word for being advised. This is done by: "
+ { $list
+ { "Annotating it to call the appropriate words before, around, and after the original body " }
+ { "Adding " { $snippet "before" } ", " { $snippet "around" } ", and " { $snippet "after" } " properties, which will contain the advice" }
+ { "Adding an " { $snippet "advised" } "property, which can later be used to determine if a given word is defined (see " { $link advised? } ")" }
+ }
+}
+{ $see-also advised? annotate } ;
+
+HELP: advised?
+{ $values { "word" "a word" } { "?" "t or f, indicating if " { $snippet "word" } " is advised" } }
+{ $description "Determines whether or not the given word has any advice on it." } ;
+
+ARTICLE: "advice" "Advice"
+"Advice is a simple way of adding additition functionality to words by adding 'hooks' to a word, which can act before, after, or around the calling of the word." ;
+
+ABOUT: "advice"
\ No newline at end of file
--- /dev/null
+! Copyright (C) 2008 James Cash
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel sequences math tools.test advice parser namespaces ;
+IN: advice.tests
+
+[
+: foo "foo" ;
+\ foo make-advised
+
+ { "bar" "foo" } [
+ [ "bar" ] "barify" \ foo advise-before
+ foo ] unit-test
+
+ { "bar" "foo" "baz" } [
+ [ "baz" ] "bazify" \ foo advise-after
+ foo ] unit-test
+
+ { "foo" "baz" } [
+ "barify" \ foo before remove-advice
+ foo ] unit-test
+
+: bar ( a -- b ) 1+ ;
+\ bar make-advised
+
+ { 11 } [
+ [ 2 * ] "double" \ bar advise-before
+ 5 bar
+ ] unit-test
+
+ { 11/3 } [
+ [ 3 / ] "third" \ bar advise-after
+ 5 bar
+ ] unit-test
+
+ { -2 } [
+ [ -1 * ad-do-it 3 + ] "frobnobicate" \ bar advise-around
+ 5 bar
+ ] unit-test
+
+ ] with-scope
\ No newline at end of file
--- /dev/null
+! Copyright (C) 2008 James Cash
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel sequences symbols fry words assocs tools.annotations coroutines ;
+IN: advice
+
+SYMBOLS: before after around advised ;
+
+<PRIVATE
+: advise ( quot name word loc -- )
+ word-prop set-at ;
+PRIVATE>
+
+: advise-before ( quot name word -- )
+ before advise ;
+
+: advise-after ( quot name word -- )
+ after advise ;
+
+: advise-around ( quot name word -- )
+ [ \ coterminate suffix ] 2dip
+ around advise ;
+
+: get-advice ( word type -- seq )
+ word-prop values ;
+
+: call-before ( word -- )
+ before get-advice [ call ] each ;
+
+: call-after ( word -- )
+ after get-advice [ call ] each ;
+
+: call-around ( main word -- )
+ around get-advice [ cocreate ] map tuck
+ [ [ coresume ] each ] [ call ] [ reverse [ coresume ] each ] tri* ;
+
+: remove-advice ( name word loc -- )
+ word-prop delete-at ;
+
+: ad-do-it ( input -- result )
+ coyield ;
+
+: advised? ( word -- ? )
+ advised word-prop ;
+
+: make-advised ( word -- )
+ [ dup [ over dup '[ _ call-before _ _ call-around _ call-after ] ] annotate ]
+ [ { before after around } [ H{ } clone swap set-word-prop ] with each ]
+ [ t advised set-word-prop ] tri ;
+
\ No newline at end of file
--- /dev/null
+James Cash
--- /dev/null
+Implmentation of advice/aspects
--- /dev/null
+advice
+aspect
+annotations
IN: benchmark
: run-benchmark ( vocab -- result )
- [ [ require ] [ [ run ] benchmark ] bi ] curry
- [ error. f ] recover ;
+ [ [ require ] [ [ run ] benchmark ] bi ] curry
+ [ error. f ] recover ;
: run-benchmarks ( -- assoc )
- "benchmark" all-child-vocabs-seq
- [ dup run-benchmark ] { } map>assoc ;
+ "benchmark" all-child-vocabs-seq
+ [ dup run-benchmark ] { } map>assoc ;
: benchmarks. ( assoc -- )
standard-table-style [
{ deploy-word-defs? f }
{ deploy-reflection 1 }
{ deploy-compiler? t }
- { deploy-random? f }
{ deploy-c-types? f }
{ deploy-name "Bunny" }
{ deploy-word-props? f }
{ deploy-io 2 }
{ deploy-ui? t }
{ "stop-after-last-window?" t }
- { deploy-random? f }
{ deploy-word-defs? f }
{ deploy-compiler? t }
{ deploy-reflection 1 }
{ deploy-threads? f }
{ deploy-word-props? f }
{ deploy-reflection 2 }
- { deploy-random? f }
{ deploy-io 2 }
{ deploy-math? f }
{ deploy-ui? f }
\ pick [ >r pick r> =/fail ] define-inverse
\ tuck [ swapd [ =/fail ] keep ] define-inverse
+\ not [ not ] define-inverse
+\ >boolean [ { t f } memq? assure ] define-inverse
+
\ >r [ r> ] define-inverse
\ r> [ >r ] define-inverse
{ deploy-io 2 }
{ deploy-word-defs? f }
{ deploy-c-types? t }
- { deploy-random? t }
{ deploy-word-props? f }
{ deploy-reflection 1 }
{ deploy-threads? t }
IN: lisp
USING: help.markup help.syntax ;
+HELP: <LISP
+{ $description "parsing word which converts the lisp code between <LISP and LISP> into factor quotations and calls it" }
+{ $see-also lisp-string>factor } ;
+
+HELP: lisp-string>factor
+{ $values { "str" "a string of lisp code" } { "quot" "the quotation the lisp compiles into" } }
+{ $description "Turns a string of lisp into a factor quotation" } ;
ARTICLE: "lisp" "Lisp in Factor"
"This is a simple implementation of a Lisp dialect, which somewhat resembles Scheme." $nl
<LISP ((lambda (x y) (if x (+ 1 y) (+ 2 y))) #t 3) LISP>
] unit-test
+ { { 3 3 4 } } [
+ <LISP (defun foo (x y &rest z)
+ (cons (+ x y) z))
+ (foo 1 2 3 4)
+ LISP> cons>seq
+ ] unit-test
+
] with-interactive-vocabs
: macro-expand ( cons -- quot )
uncons [ list>seq >quotation ] [ lookup-macro ] bi* call call ;
-<PRIVATE
-: (expand-macros) ( cons -- cons )
- [ dup list? [ (expand-macros) dup car lisp-macro? [ macro-expand ] when ] when ] lmap ;
-PRIVATE>
-
: expand-macros ( cons -- cons )
- dup list? [ (expand-macros) dup car lisp-macro? [ macro-expand ] when ] when ;
-
+ dup list? [ [ expand-macros ] lmap dup car lisp-macro? [ macro-expand expand-macros ] when ] when ;
+
: convert-begin ( cons -- quot )
cdr [ convert-form ] [ ] lmap-as [ 1 tail* ] [ but-last ] bi
[ '[ { } _ with-datastack drop ] ] map prepend '[ _ [ call ] each ] ;
"set" "lisp" "define-lisp-var" define-primitive
- "(lambda (&rest xs) xs)" lisp-string>factor first "list" lisp-define
- "(defmacro setq (var val) (list (quote set) (list (quote quote) var) val))" lisp-eval
+ "(set 'list (lambda (&rest xs) xs))" lisp-eval
+ "(defmacro setq (var val) (list 'set (list 'quote var) val))" lisp-eval
<" (defmacro defun (name vars &rest body)
- (list (quote setq) name (list (quote lambda) vars body))) "> lisp-eval
+ (list 'setq name (cons 'lambda (cons vars body)))) "> lisp-eval
- "(defmacro if (pred tr fl) (list (quote cond) (list pred tr) (list (quote #t) fl)))" lisp-eval
+ "(defmacro if (pred tr fl) (list 'cond (list pred tr) (list (quote #t) fl)))" lisp-eval
;
: <LISP
- "LISP>" parse-multiline-string define-lisp-builtins
- lisp-string>factor parsed \ call parsed ; parsing
+ "LISP>" parse-multiline-string "(begin " prepend ")" append define-lisp-builtins
+ lisp-string>factor parsed \ call parsed ; parsing
\ No newline at end of file
}
} [
"(1 (3 4) 2)" lisp-expr
+] unit-test
+
+{ { T{ lisp-symbol { name "quote" } } { 1 2 3 } } } [
+ "'(1 2 3)" lisp-expr cons>seq
+] unit-test
+
+{ { T{ lisp-symbol f "quote" } T{ lisp-symbol f "foo" } } } [
+ "'foo" lisp-expr cons>seq
+] unit-test
+
+{ { 1 2 { T{ lisp-symbol { name "quote" } } { 3 4 } } 5 } } [
+ "(1 2 '(3 4) 5)" lisp-expr cons>seq
] unit-test
\ No newline at end of file
| identifier
| string
s-expression = LPAREN (list-item)* RPAREN => [[ second seq>cons ]]
-list-item = _ ( atom | s-expression ) _ => [[ second ]]
-;EBNF
+list-item = _ ( atom | s-expression | quoted ) _ => [[ second ]]
+quoted = squote list-item => [[ second nil cons "quote" <lisp-symbol> swap cons ]]
+expr = list-item
+;EBNF
\ No newline at end of file
-! Copyright (C) 2008 Doug Coleman, Slava Pestov.
+! Copyright (C) 2008 Doug Coleman, Slava Pestov, Aaron Schaefer.
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel math math.constants math.functions math.intervals
-math.vectors namespaces sequences combinators.short-circuit ;
+USING: combinators.short-circuit kernel math math.constants math.functions
+ math.vectors sequences ;
IN: math.analysis
<PRIVATE
: gamma-p6
{
2.50662827563479526904 225.525584619175212544 -268.295973841304927459
- 80.9030806934622512966 -5.00757863970517583837 0.0114684895434781459556
+ 80.9030806934622512966 -5.00757863970517583837 0.0114684895434781459556
} ; inline
: gamma-z ( x n -- seq )
: (gamma-lanczos6) ( x -- log[gamma[x+1]] )
#! log(gamma(x+1)
- [ 0.5 + dup gamma-g6 + dup [ log * ] dip - ]
+ [ 0.5 + dup gamma-g6 + [ log * ] keep - ]
[ 6 gamma-z gamma-p6 v. log ] bi + ;
: gamma-lanczos6 ( x -- gamma[x] )
#! gamma(x) = gamma(x+1) / x
- dup (gamma-lanczos6) exp swap / ;
+ [ (gamma-lanczos6) exp ] keep / ;
: gammaln-lanczos6 ( x -- gammaln[x] )
#! log(gamma(x)) = log(gamma(x+1)) - log(x)
- dup (gamma-lanczos6) swap log - ;
+ [ (gamma-lanczos6) ] keep log - ;
: gamma-neg ( gamma[abs[x]] x -- gamma[x] )
dup pi * sin * * pi neg swap / ; inline
#! gamma(x) = integral 0..inf [ t^(x-1) exp(-t) ] dt
#! gamma(n+1) = n! for n > 0
dup { [ 0.0 <= ] [ 1.0 mod zero? ] } 1&& [
- drop 1./0.
- ] [
- dup abs gamma-lanczos6 swap dup 0 > [ drop ] [ gamma-neg ] if
+ drop 1./0.
+ ] [
+ [ abs gamma-lanczos6 ] keep dup 0 > [ drop ] [ gamma-neg ] if
] if ;
: gammaln ( x -- gamma[x] )
#! gammaln(x) is an alternative when gamma(x)'s range
#! varies too widely
dup 0 < [
- drop 1./0.
- ] [
- dup abs gammaln-lanczos6 swap dup 0 > [ drop ] [ gamma-neg ] if
+ drop 1./0.
+ ] [
+ [ abs gammaln-lanczos6 ] keep dup 0 > [ drop ] [ gamma-neg ] if
] if ;
: nth-root ( n x -- y )
- [ recip ] dip swap ^ ;
+ swap recip ^ ;
! Forth Scientific Library Algorithm #1
!
: stirling-fact ( n -- fact )
[ pi 2 * * sqrt ]
- [ dup e / swap ^ ]
- [ 12 * recip 1 + ]
- tri * * ;
+ [ [ e / ] keep ^ ]
+ [ 12 * recip 1+ ] tri * * ;
+
: all-permutations ( seq -- seq )
[ length factorial ] keep '[ _ permutation ] map ;
+: each-permutation ( seq quot -- )
+ [ [ length factorial ] keep ] dip
+ '[ _ permutation @ ] each ; inline
+
+: reduce-permutations ( seq initial quot -- result )
+ swapd each-permutation ; inline
+
: inverse-permutation ( seq -- permutation )
<enum> >alist sort-values keys ;
-! Copyright (c) 2007 Aaron Schaefer.
+! Copyright (c) 2007, 2008 Aaron Schaefer.
! See http://factorcode.org/license.txt for BSD license.
-USING: combinators.lib kernel math math.functions math.parser namespaces
-sequences splitting grouping combinators.short-circuit ;
+USING: combinators.short-circuit grouping kernel math math.parser namespaces
+ sequences ;
IN: math.text.english
<PRIVATE
] if ;
: 3digits>text ( n -- str )
- dup hundreds-place swap tens-place append ;
+ [ hundreds-place ] [ tens-place ] bi append ;
: text-with-scale ( index seq -- str )
- dupd nth 3digits>text swap
- scale-numbers [
- " " swap 3append
- ] unless-empty ;
+ [ nth 3digits>text ] [ drop scale-numbers ] 2bi
+ [ " " swap 3append ] unless-empty ;
: append-with-conjunction ( str1 str2 -- newstr )
over length zero? [
and-needed? off
] if ;
-: (recombine) ( str index seq -- newstr seq )
+: (recombine) ( str index seq -- newstr )
2dup nth zero? [
- nip
+ 2drop
] [
- [ text-with-scale ] keep
- -rot append-with-conjunction swap
+ text-with-scale append-with-conjunction
] if ;
: recombine ( seq -- str )
dup length 1 = [
first 3digits>text
] [
- dup set-conjunction "" swap
- dup length [ swap (recombine) ] each drop
+ [ set-conjunction "" ] [ length ] [ ] tri
+ [ (recombine) ] curry each
] if ;
: (number>text) ( n -- str )
{ deploy-io 2 }
{ deploy-ui? t }
{ "stop-after-last-window?" t }
- { deploy-random? t }
{ deploy-word-defs? f }
{ deploy-compiler? t }
{ deploy-reflection 1 }
--- /dev/null
+USING: project-euler.001 tools.test ;
+IN: project-euler.001.tests
+
+[ 233168 ] [ euler001 ] unit-test
+[ 233168 ] [ euler001a ] unit-test
+[ 233168 ] [ euler001b ] unit-test
--- /dev/null
+USING: project-euler.002 tools.test ;
+IN: project-euler.002.tests
+
+[ 4613732 ] [ euler002 ] unit-test
+[ 4613732 ] [ euler002a ] unit-test
! 1, 2, 3, 5, 8, 13, 21, 34, 55, 89, ...
-! Find the sum of all the even-valued terms in the sequence which do not exceed one million.
+! Find the sum of all the even-valued terms in the sequence which do not exceed
+! four million.
! SOLUTION
V{ 0 } clone 1 rot (fib-upto) ;
: euler002 ( -- answer )
- 1000000 fib-upto [ even? ] filter sum ;
+ 4000000 fib-upto [ even? ] filter sum ;
! [ euler002 ] 100 ave-time
-! 0 ms run / 0 ms GC ave time - 100 trials
+! 0 ms ave run time - 0.22 SD (100 trials)
! ALTERNATE SOLUTIONS
but-last-slice { 0 1 } prepend ;
: euler002a ( -- answer )
- 1000000 fib-upto* [ even? ] filter sum ;
+ 4000000 fib-upto* [ even? ] filter sum ;
! [ euler002a ] 100 ave-time
-! 0 ms run / 0 ms GC ave time - 100 trials
+! 0 ms ave run time - 0.2 SD (100 trials)
MAIN: euler002a
--- /dev/null
+USING: project-euler.003 tools.test ;
+IN: project-euler.003.tests
+
+[ 6857 ] [ euler003 ] unit-test
! The prime factors of 13195 are 5, 7, 13 and 29.
-! What is the largest prime factor of the number 317584931803?
+! What is the largest prime factor of the number 600851475143 ?
! SOLUTION
! --------
: euler003 ( -- answer )
- 317584931803 factors supremum ;
+ 600851475143 factors supremum ;
! [ euler003 ] 100 ave-time
-! 1 ms run / 0 ms GC ave time - 100 trials
+! 1 ms ave run time - 0.49 SD (100 trials)
MAIN: euler003
--- /dev/null
+USING: project-euler.004 tools.test ;
+IN: project-euler.004.tests
+
+[ 906609 ] [ euler004 ] unit-test
source-004 dup cartesian-product [ product ] map prune max-palindrome ;
! [ euler004 ] 100 ave-time
-! 1608 ms run / 102 ms GC ave time - 100 trials
+! 1164 ms ave run time - 39.35 SD (100 trials)
MAIN: euler004
--- /dev/null
+USING: project-euler.005 tools.test ;
+IN: project-euler.005.tests
+
+[ 232792560 ] [ euler005 ] unit-test
20 1 [ 1+ lcm ] reduce ;
! [ euler005 ] 100 ave-time
-! 0 ms run / 0 ms GC ave time - 100 trials
+! 0 ms ave run time - 0.14 SD (100 trials)
MAIN: euler005
--- /dev/null
+USING: project-euler.006 tools.test ;
+IN: project-euler.006.tests
+
+[ 25164150 ] [ euler006 ] unit-test
-! Copyright (c) 2007 Aaron Schaefer.
+! Copyright (c) 2007, 2008 Aaron Schaefer.
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel math math.functions math.ranges sequences ;
+USING: kernel math math.ranges sequences ;
IN: project-euler.006
! http://projecteuler.net/index.php?section=problems&id=6
PRIVATE>
: euler006 ( -- answer )
- 1 100 [a,b] dup sum-of-squares swap square-of-sum - abs ;
+ 100 [1,b] [ sum-of-squares ] [ square-of-sum ] bi - abs ;
! [ euler006 ] 100 ave-time
-! 0 ms run / 0 ms GC ave time - 100 trials
+! 0 ms ave run time - 0.24 SD (100 trials)
MAIN: euler006
--- /dev/null
+USING: project-euler.007 tools.test ;
+IN: project-euler.007.tests
+
+[ 104743 ] [ euler007 ] unit-test
10001 nth-prime ;
! [ euler007 ] 100 ave-time
-! 10 ms run / 0 ms GC ave time - 100 trials
+! 5 ms ave run time - 1.13 SD (100 trials)
MAIN: euler007
--- /dev/null
+USING: project-euler.008 tools.test ;
+IN: project-euler.008.tests
+
+[ 40824 ] [ euler008 ] unit-test
-! Copyright (c) 2007 Aaron Schaefer.
+! Copyright (c) 2007, 2008 Aaron Schaefer.
! See http://factorcode.org/license.txt for BSD license.
-USING: math.parser project-euler.common sequences ;
+USING: grouping math.parser sequences ;
IN: project-euler.008
! http://projecteuler.net/index.php?section=problems&id=8
PRIVATE>
: euler008 ( -- answer )
- source-008 5 collect-consecutive [ string>digits product ] map supremum ;
+ source-008 5 clump [ string>digits product ] map supremum ;
! [ euler008 ] 100 ave-time
-! 11 ms run / 0 ms GC ave time - 100 trials
+! 2 ms ave run time - 0.79 SD (100 trials)
MAIN: euler008
--- /dev/null
+USING: project-euler.009 tools.test ;
+IN: project-euler.009.tests
+
+[ 31875000 ] [ euler009 ] unit-test
-! Copyright (c) 2007 Aaron Schaefer.
+! Copyright (c) 2007, 2008 Aaron Schaefer.
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel math math.functions namespaces make sequences sorting ;
+USING: kernel make math sequences sorting ;
IN: project-euler.009
! http://projecteuler.net/index.php?section=problems&id=9
: abc ( p q -- triplet )
[
- 2dup * , ! a = p * q
- [ sq ] bi@ 2dup - 2 / , ! b = (p² - q²) / 2
- + 2 / , ! c = (p² + q²) / 2
+ 2dup * , ! a = p * q
+ [ sq ] bi@
+ [ - 2 / , ] ! b = (p² - q²) / 2
+ [ + 2 / , ] 2bi ! c = (p² + q²) / 2
] { } make natural-sort ;
: (ptriplet) ( target p q triplet -- target p q )
- roll [ swap sum = ] keep -roll
- [ next-pq 2dup abc (ptriplet) ] unless ;
+ sum [ pick ] dip = [ next-pq 2dup abc (ptriplet) ] unless ;
: ptriplet ( target -- triplet )
3 1 { 3 4 5 } (ptriplet) abc nip ;
1000 ptriplet product ;
! [ euler009 ] 100 ave-time
-! 1 ms run / 0 ms GC ave time - 100 trials
+! 1 ms ave run time - 0.73 SD (100 trials)
MAIN: euler009
--- /dev/null
+USING: project-euler.010 tools.test ;
+IN: project-euler.010.tests
+
+[ 142913828922 ] [ euler010 ] unit-test
! The sum of the primes below 10 is 2 + 3 + 5 + 7 = 17.
-! Find the sum of all the primes below one million.
+! Find the sum of all the primes below two million.
! SOLUTION
! --------
: euler010 ( -- answer )
- 1000000 primes-upto sum ;
+ 2000000 primes-upto sum ;
-! [ euler010 ] 100 ave-time
-! 14 ms run / 0 ms GC ave time - 100 trials
+! [ euler010 ] time
+! 266425 ms run / 10001 ms GC time
+
+! TODO: this takes well over one minute now that they changed the problem to
+! two million instead of one. the primes vocab could use some improvements
MAIN: euler010
--- /dev/null
+USING: project-euler.011 tools.test ;
+IN: project-euler.011.tests
+
+[ 70600674 ] [ euler011 ] unit-test
-! Copyright (c) 2007 Aaron Schaefer.
+! Copyright (c) 2007, 2008 Aaron Schaefer.
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel namespaces make project-euler.common sequences
-splitting grouping ;
+USING: grouping kernel make sequences ;
IN: project-euler.011
! http://projecteuler.net/index.php?section=problems&id=11
horizontal pad-front pad-back flip ;
: max-product ( matrix width -- n )
- [ collect-consecutive ] curry map concat
+ [ clump ] curry map concat
[ product ] map supremum ; inline
PRIVATE>
] { } make supremum ;
! [ euler011 ] 100 ave-time
-! 4 ms run / 0 ms GC ave time - 100 trials
+! 3 ms ave run time - 0.77 SD (100 trials)
MAIN: euler011
--- /dev/null
+USING: project-euler.012 tools.test ;
+IN: project-euler.012.tests
+
+[ 76576500 ] [ euler012 ] unit-test
8 [ dup nth-triangle tau* 500 < ] [ 1+ ] [ ] while nth-triangle ;
! [ euler012 ] 10 ave-time
-! 5413 ms run / 1 ms GC ave time - 10 trials
+! 6573 ms ave run time - 346.27 SD (10 trials)
MAIN: euler012
--- /dev/null
+USING: project-euler.013 tools.test ;
+IN: project-euler.013.tests
+
+[ 5537376230 ] [ euler013 ] unit-test
source-013 sum number>string 10 head string>number ;
! [ euler013 ] 100 ave-time
-! 0 ms run / 0 ms GC ave time - 100 trials
+! 0 ms ave run time - 0.31 SD (100 trials)
MAIN: euler013
--- /dev/null
+USING: project-euler.014 tools.test ;
+IN: project-euler.014.tests
+
+[ 837799 ] [ euler014 ] unit-test
+[ 837799 ] [ euler014a ] unit-test
! Copyright (c) 2007 Aaron Schaefer.
! See http://factorcode.org/license.txt for BSD license.
-USING: arrays combinators.short-circuit kernel
-math math.ranges namespaces make sequences sorting ;
+USING: combinators.short-circuit kernel make math math.ranges sequences ;
IN: project-euler.014
! http://projecteuler.net/index.php?section=problems&id=14
<PRIVATE
: worth-calculating? ( n -- ? )
- { [ dup 1- 3 mod zero? ] [ dup 1- 3 / even? ] } 0&& nip ;
+ 1- 3 { [ mod zero? ] [ / even? ] } 2&& ;
PRIVATE>
--- /dev/null
+USING: project-euler.015 tools.test ;
+IN: project-euler.015.tests
+
+[ 137846528820 ] [ euler015 ] unit-test
20 grid-paths ;
! [ euler015 ] 100 ave-time
-! 0 ms run / 0 ms GC ave time - 100 trials
+! 0 ms ave run time - 0.2 SD (100 trials)
MAIN: euler015
--- /dev/null
+USING: project-euler.016 tools.test ;
+IN: project-euler.016.tests
+
+[ 1366 ] [ euler016 ] unit-test
-! Copyright (c) 2007 Aaron Schaefer.
+! Copyright (c) 2007, 2008 Aaron Schaefer.
! See http://factorcode.org/license.txt for BSD license.
-USING: math.functions math.parser project-euler.common sequences ;
+USING: math.functions project-euler.common sequences ;
IN: project-euler.016
! http://projecteuler.net/index.php?section=problems&id=16
2 1000 ^ number>digits sum ;
! [ euler016 ] 100 ave-time
-! 0 ms run / 0 ms GC ave time - 100 trials
+! 0 ms ave run time - 0.67 SD (100 trials)
MAIN: euler016
--- /dev/null
+USING: project-euler.017 tools.test ;
+IN: project-euler.017.tests
+
+[ 21124 ] [ euler017 ] unit-test
-! Copyright (c) 2007 Aaron Schaefer.
+! Copyright (c) 2007, 2008 Aaron Schaefer.
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel math.ranges math.text.english sequences strings
- ascii combinators.short-circuit ;
+USING: ascii kernel math.ranges math.text.english sequences ;
IN: project-euler.017
! http://projecteuler.net/index.php?section=problems&id=17
: euler017 ( -- answer )
1000 [1,b] SBUF" " clone [ number>text over push-all ] reduce [ Letter? ] count ;
-! [ euler017a ] 100 ave-time
-! 14 ms run / 0 ms GC ave time - 100 trials
+! [ euler017 ] 100 ave-time
+! 15 ms ave run time - 1.71 SD (100 trials)
MAIN: euler017
--- /dev/null
+USING: project-euler.018 tools.test ;
+IN: project-euler.018.tests
+
+[ 1074 ] [ euler018 ] unit-test
+[ 1074 ] [ euler018a ] unit-test
source-018 propagate-all first first ;
! [ euler018 ] 100 ave-time
-! 0 ms run / 0 ms GC ave time - 100 trials
+! 0 ms ave run time - 0.29 SD (100 trials)
! ALTERNATE SOLUTIONS
source-018 max-path ;
! [ euler018a ] 100 ave-time
-! 0 ms run / 0 ms GC ave time - 100 trials
+! 0 ms ave run time - 0.39 SD (100 trials)
MAIN: euler018a
--- /dev/null
+USING: project-euler.019 tools.test ;
+IN: project-euler.019.tests
+
+[ 171 ] [ euler019 ] unit-test
+[ 171 ] [ euler019a ] unit-test
] map concat [ zero? ] count ;
! [ euler019 ] 100 ave-time
-! 1 ms run / 0 ms GC ave time - 100 trials
+! 1 ms ave run time - 0.51 SD (100 trials)
! ALTERNATE SOLUTIONS
end-date start-date first-days [ zero? ] count ;
! [ euler019a ] 100 ave-time
-! 131 ms run / 3 ms GC ave time - 100 trials
+! 17 ms ave run time - 2.13 SD (100 trials)
MAIN: euler019
--- /dev/null
+USING: project-euler.020 tools.test ;
+IN: project-euler.020.tests
+
+[ 648 ] [ euler020 ] unit-test
-! Copyright (c) 2007 Aaron Schaefer.
+! Copyright (c) 2007, 2008 Aaron Schaefer.
! See http://factorcode.org/license.txt for BSD license.
-USING: math.combinatorics math.parser project-euler.common sequences ;
+USING: math.combinatorics project-euler.common sequences ;
IN: project-euler.020
! http://projecteuler.net/index.php?section=problems&id=20
100 factorial number>digits sum ;
! [ euler020 ] 100 ave-time
-! 0 ms run / 0 ms GC ave time - 100 trials
+! 0 ms ave run time - 0.55 (100 trials)
MAIN: euler020
--- /dev/null
+USING: project-euler.021 tools.test ;
+IN: project-euler.021.tests
+
+[ 31626 ] [ euler021 ] unit-test
: amicable? ( n -- ? )
dup sum-proper-divisors
- { [ 2dup = not ] [ 2dup sum-proper-divisors = ] } 0&& 2nip ;
+ { [ = not ] [ sum-proper-divisors = ] } 2&& ;
: euler021 ( -- answer )
10000 [1,b] [ dup amicable? [ drop 0 ] unless ] sigma ;
! [ euler021 ] 100 ave-time
-! 328 ms run / 10 ms GC ave time - 100 trials
+! 335 ms ave run time - 18.63 SD (100 trials)
MAIN: euler021
--- /dev/null
+USING: project-euler.022 tools.test ;
+IN: project-euler.022.tests
+
+[ 871198282 ] [ euler022 ] unit-test
source-022 natural-sort name-scores sum ;
! [ euler022 ] 100 ave-time
-! 123 ms run / 4 ms GC ave time - 100 trials
+! 74 ms ave run time - 5.13 SD (100 trials)
MAIN: euler022
--- /dev/null
+USING: project-euler.023 tools.test ;
+IN: project-euler.023.tests
+
+[ 4179871 ] [ euler023 ] unit-test
! Copyright (c) 2008 Aaron Schaefer.
! See http://factorcode.org/license.txt for BSD license.
-USING: hashtables kernel math math.ranges project-euler.common sequences
- sorting sets ;
+USING: kernel math math.ranges project-euler.common sequences sets sorting ;
IN: project-euler.023
! http://projecteuler.net/index.php?section=problems&id=23
--- /dev/null
+USING: project-euler.024 tools.test ;
+IN: project-euler.024.tests
+
+[ 2783915460 ] [ euler024 ] unit-test
999999 10 permutation 10 digits>integer ;
! [ euler024 ] 100 ave-time
-! 0 ms run / 0 ms GC ave time - 100 trials
+! 0 ms ave run time - 0.27 SD (100 trials)
MAIN: euler024
--- /dev/null
+USING: project-euler.025 tools.test ;
+IN: project-euler.025.tests
+
+[ 4782 ] [ euler025 ] unit-test
+[ 4782 ] [ euler025a ] unit-test
! Copyright (c) 2008 Aaron Schaefer.
! See http://factorcode.org/license.txt for BSD license.
-USING: alien.syntax kernel math math.constants math.functions math.parser
- math.ranges memoize project-euler.common sequences ;
+USING: kernel math math.constants math.functions math.parser memoize
+ project-euler.common sequences ;
IN: project-euler.025
! http://projecteuler.net/index.php?section=problems&id=25
1000 digit-fib ;
! [ euler025 ] 10 ave-time
-! 5237 ms run / 72 ms GC ave time - 10 trials
+! 5345 ms ave run time - 105.91 SD (10 trials)
! ALTERNATE SOLUTIONS
1000 digit-fib* ;
! [ euler025a ] 100 ave-time
-! 0 ms run / 0 ms GC ave time - 100 trials
+! 0 ms ave run time - 0.17 SD (100 trials)
MAIN: euler025a
--- /dev/null
+USING: project-euler.026 tools.test ;
+IN: project-euler.026.tests
+
+[ 983 ] [ euler026 ] unit-test
source-026 max-period drop denominator ;
! [ euler026 ] 100 ave-time
-! 724 ms run / 7 ms GC ave time - 100 trials
+! 290 ms ave run time - 19.2 SD (100 trials)
MAIN: euler026
--- /dev/null
+USING: project-euler.027 tools.test ;
+IN: project-euler.027.tests
+
+[ -59231 ] [ euler027 ] unit-test
source-027 max-consecutive drop product ;
! [ euler027 ] 100 ave-time
-! 687 ms run / 23 ms GC ave time - 100 trials
+! 111 ms ave run time - 6.07 SD (100 trials)
! TODO: generalize max-consecutive/max-product (from #26) into a new word
--- /dev/null
+USING: project-euler.028 tools.test ;
+IN: project-euler.028.tests
+
+[ 669171001 ] [ euler028 ] unit-test
<PRIVATE
: sum-corners ( n -- sum )
- dup 1 = [ [ sq 4 * ] keep 6 * - 6 + ] unless ;
+ dup 1 = [ [ sq 4 * ] [ 6 * ] bi - 6 + ] unless ;
: sum-diags ( n -- sum )
1 swap 2 <range> [ sum-corners ] sigma ;
1001 sum-diags ;
! [ euler028 ] 100 ave-time
-! 0 ms run / 0 ms GC ave time - 100 trials
+! 0 ms ave run time - 0.39 SD (100 trials)
MAIN: euler028
--- /dev/null
+USING: project-euler.029 tools.test ;
+IN: project-euler.029.tests
+
+[ 9183 ] [ euler029 ] unit-test
2 100 [a,b] dup cartesian-product [ first2 ^ ] map prune length ;
! [ euler029 ] 100 ave-time
-! 951 ms run / 12 ms GC ave time - 100 trials
+! 704 ms ave run time - 28.07 SD (100 trials)
MAIN: euler029
--- /dev/null
+USING: project-euler.030 tools.test ;
+IN: project-euler.030.tests
+
+[ 443839 ] [ euler030 ] unit-test
325537 [ dup sum-fifth-powers = ] filter sum 1- ;
! [ euler030 ] 100 ave-time
-! 2537 ms run / 125 ms GC ave time - 100 trials
+! 1700 ms ave run time - 64.84 SD (100 trials)
MAIN: euler030
--- /dev/null
+USING: project-euler.031 tools.test ;
+IN: project-euler.031.tests
+
+[ 73682 ] [ euler031 ] unit-test
drop 1 ;
: 2p ( m -- n )
- dup 0 >= [ [ 2 - 2p ] keep 1p + ] [ drop 0 ] if ;
+ dup 0 >= [ [ 2 - 2p ] [ 1p ] bi + ] [ drop 0 ] if ;
: 5p ( m -- n )
- dup 0 >= [ [ 5 - 5p ] keep 2p + ] [ drop 0 ] if ;
+ dup 0 >= [ [ 5 - 5p ] [ 2p ] bi + ] [ drop 0 ] if ;
: 10p ( m -- n )
- dup 0 >= [ [ 10 - 10p ] keep 5p + ] [ drop 0 ] if ;
+ dup 0 >= [ [ 10 - 10p ] [ 5p ] bi + ] [ drop 0 ] if ;
: 20p ( m -- n )
- dup 0 >= [ [ 20 - 20p ] keep 10p + ] [ drop 0 ] if ;
+ dup 0 >= [ [ 20 - 20p ] [ 10p ] bi + ] [ drop 0 ] if ;
: 50p ( m -- n )
- dup 0 >= [ [ 50 - 50p ] keep 20p + ] [ drop 0 ] if ;
+ dup 0 >= [ [ 50 - 50p ] [ 20p ] bi + ] [ drop 0 ] if ;
: 100p ( m -- n )
- dup 0 >= [ [ 100 - 100p ] keep 50p + ] [ drop 0 ] if ;
+ dup 0 >= [ [ 100 - 100p ] [ 50p ] bi + ] [ drop 0 ] if ;
: 200p ( m -- n )
- dup 0 >= [ [ 200 - 200p ] keep 100p + ] [ drop 0 ] if ;
+ dup 0 >= [ [ 200 - 200p ] [ 100p ] bi + ] [ drop 0 ] if ;
PRIVATE>
200 200p ;
! [ euler031 ] 100 ave-time
-! 4 ms run / 0 ms GC ave time - 100 trials
+! 3 ms ave run time - 0.91 SD (100 trials)
! TODO: generalize to eliminate duplication; use a sequence to specify denominations?
--- /dev/null
+USING: project-euler.032 tools.test ;
+IN: project-euler.032.tests
+
+[ 45228 ] [ euler032 ] unit-test
+[ 45228 ] [ euler032a ] unit-test
! Copyright (c) 2008 Aaron Schaefer.
! See http://factorcode.org/license.txt for BSD license.
-USING: hashtables kernel math math.combinatorics math.functions
- math.parser math.ranges project-euler.common sequences sets ;
+USING: kernel math math.combinatorics math.functions math.parser math.ranges
+ project-euler.common sequences sets ;
IN: project-euler.032
! http://projecteuler.net/index.php?section=problems&id=32
[ string>number ] tri@ [ * ] dip = ;
: valid? ( n -- ? )
- dup 1and4 swap 2and3 or ;
+ [ 1and4 ] [ 2and3 ] bi or ;
: products ( seq -- m )
[ 10 4 ^ mod ] map ;
source-032 [ valid? ] filter products prune sum ;
! [ euler032 ] 10 ave-time
-! 23922 ms run / 1505 ms GC ave time - 10 trials
+! 16361 ms ave run time - 417.8 SD (10 trials)
! ALTERNATE SOLUTIONS
: euler032a ( -- answer )
source-032a [ mmp ] map [ pandigital? ] filter products prune sum ;
-! [ euler032a ] 100 ave-time
-! 5978 ms run / 327 ms GC ave time - 100 trials
+! [ euler032a ] 10 ave-time
+! 2624 ms ave run time - 131.91 SD (10 trials)
MAIN: euler032a
--- /dev/null
+USING: project-euler.033 tools.test ;
+IN: project-euler.033.tests
+
+[ 100 ] [ euler033 ] unit-test
source-033 curious-fractions product denominator ;
! [ euler033 ] 100 ave-time
-! 5 ms run / 0 ms GC ave time - 100 trials
+! 7 ms ave run time - 1.31 SD (100 trials)
MAIN: euler033
--- /dev/null
+USING: project-euler.034 tools.test ;
+IN: project-euler.034.tests
+
+[ 40730 ] [ euler034 ] unit-test
3 2000000 [a,b] [ factorion? ] filter sum ;
! [ euler034 ] 10 ave-time
-! 15089 ms run / 725 ms GC ave time - 10 trials
+! 5506 ms ave run time - 144.0 SD (10 trials)
MAIN: euler034
--- /dev/null
+USING: project-euler.035 tools.test ;
+IN: project-euler.035.tests
+
+[ 55 ] [ euler035 ] unit-test
source-035 [ possible? ] filter [ circular? ] count ;
! [ euler035 ] 100 ave-time
-! 904 ms run / 86 ms GC ave time - 100 trials
+! 538 ms ave run time - 17.16 SD (100 trials)
! TODO: try using bit arrays or other methods outlined here:
! http://home.comcast.net/~babdulbaki/Circular_Primes.html
--- /dev/null
+USING: project-euler.036 tools.test ;
+IN: project-euler.036.tests
+
+[ 872187 ] [ euler036 ] unit-test
<PRIVATE
: both-bases? ( n -- ? )
- { [ dup palindrome? ]
- [ dup >bin dup reverse = ] } 0&& nip ;
+ { [ palindrome? ] [ >bin dup reverse = ] } 1&& ;
PRIVATE>
1 1000000 2 <range> [ both-bases? ] filter sum ;
! [ euler036 ] 100 ave-time
-! 3891 ms run / 173 ms GC ave time - 100 trials
+! 1703 ms ave run time - 96.6 SD (100 trials)
MAIN: euler036
--- /dev/null
+USING: project-euler.037 tools.test ;
+IN: project-euler.037.tests
+
+[ 748317 ] [ euler037 ] unit-test
23 1000000 primes-between [ r-trunc? ] filter [ l-trunc? ] filter sum ;
! [ euler037 ] 100 ave-time
-! 768 ms run / 9 ms GC ave time - 100 trials
+! 130 ms ave run time - 6.27 SD (100 trials)
MAIN: euler037
--- /dev/null
+USING: project-euler.038 tools.test ;
+IN: project-euler.038.tests
+
+[ 932718654 ] [ euler038 ] unit-test
! Copyright (c) 2008 Aaron Schaefer.
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel math math.parser math.ranges project-euler.common sequences ;
+USING: kernel math math.parser math.ranges project-euler.common sequences
+ strings ;
IN: project-euler.038
! http://projecteuler.net/index.php?section=problems&id=38
9123 9876 [a,b] [ concat-product ] map [ pandigital? ] filter supremum ;
! [ euler038 ] 100 ave-time
-! 37 ms run / 1 ms GC ave time - 100 trials
+! 11 ms ave run time - 1.5 SD (100 trials)
MAIN: euler038
--- /dev/null
+USING: project-euler.039 tools.test ;
+IN: project-euler.039.tests
+
+[ 840 ] [ euler039 ] unit-test
] with-scope ;
! [ euler039 ] 100 ave-time
-! 2 ms run / 0 ms GC ave time - 100 trials
+! 1 ms ave run time - 0.37 SD (100 trials)
MAIN: euler039
--- /dev/null
+USING: project-euler.040 tools.test ;
+IN: project-euler.040.tests
+
+[ 210 ] [ euler040 ] unit-test
[ swap nth-integer ] with map product ;
! [ euler040 ] 100 ave-time
-! 1002 ms run / 43 ms GC ave time - 100 trials
+! 444 ms ave run time - 23.64 SD (100 trials)
MAIN: euler040
--- /dev/null
+USING: project-euler.041 tools.test ;
+IN: project-euler.041.tests
+
+[ 7652413 ] [ euler041 ] unit-test
[ 10 digits>integer ] map [ prime? ] find nip ;
! [ euler041 ] 100 ave-time
-! 107 ms run / 7 ms GC ave time - 100 trials
+! 64 ms ave run time - 4.22 SD (100 trials)
MAIN: euler041
--- /dev/null
+USING: project-euler.042 tools.test ;
+IN: project-euler.042.tests
+
+[ 162 ] [ euler042 ] unit-test
+[ 162 ] [ euler042a ] unit-test
! Copyright (c) 2008 Aaron Schaefer.
! See http://factorcode.org/license.txt for BSD license.
-USING: ascii io.files kernel math math.functions namespaces make
- project-euler.common sequences splitting io.encodings.ascii ;
+USING: ascii io.encodings.ascii io.files kernel make math math.functions
+ namespaces project-euler.common sequences splitting ;
IN: project-euler.042
! http://projecteuler.net/index.php?section=problems&id=42
triangle-upto [ member? ] curry count ;
! [ euler042 ] 100 ave-time
-! 27 ms run / 1 ms GC ave time - 100 trials
+! 19 ms ave run time - 1.97 SD (100 trials)
! ALTERNATE SOLUTIONS
source-042 [ alpha-value ] map [ triangle? ] count ;
! [ euler042a ] 100 ave-time
-! 25 ms run / 1 ms GC ave time - 100 trials
+! 21 ms ave run time - 2.2 SD (100 trials)
MAIN: euler042a
--- /dev/null
+USING: project-euler.043 tools.test ;
+IN: project-euler.043.tests
+
+[ 16695334890 ] [ euler043 ] unit-test
+[ 16695334890 ] [ euler043a ] unit-test
! Copyright (c) 2008 Aaron Schaefer.
! See http://factorcode.org/license.txt for BSD license.
-USING: combinators.short-circuit hashtables kernel math
- math.combinatorics math.parser math.ranges project-euler.common sequences
- sorting sets ;
+USING: combinators.short-circuit kernel math math.combinatorics math.parser
+ math.ranges project-euler.common sequences sets sorting ;
IN: project-euler.043
! http://projecteuler.net/index.php?section=problems&id=43
: interesting? ( seq -- ? )
{
- [ 17 8 pick subseq-divisible? ]
- [ 13 7 pick subseq-divisible? ]
- [ 11 6 pick subseq-divisible? ]
- [ 7 5 pick subseq-divisible? ]
- [ 5 4 pick subseq-divisible? ]
- [ 3 3 pick subseq-divisible? ]
- [ 2 2 pick subseq-divisible? ]
- } 0&& nip ;
+ [ 17 8 rot subseq-divisible? ]
+ [ 13 7 rot subseq-divisible? ]
+ [ 11 6 rot subseq-divisible? ]
+ [ 7 5 rot subseq-divisible? ]
+ [ 5 4 rot subseq-divisible? ]
+ [ 3 3 rot subseq-divisible? ]
+ [ 2 2 rot subseq-divisible? ]
+ } 1&& ;
PRIVATE>
: euler043 ( -- answer )
- 1234567890 number>digits all-permutations
- [ interesting? ] filter [ 10 digits>integer ] map sum ;
+ 1234567890 number>digits 0 [
+ dup interesting? [
+ 10 digits>integer +
+ ] [ drop ] if
+ ] reduce-permutations ;
! [ euler043 ] time
-! 125196 ms run / 19548 ms GC time
+! 104526 ms run / 42735 ms GC time
! ALTERNATE SOLUTIONS
1000 over <range> [ number>digits 3 0 pad-left ] map [ all-unique? ] filter ;
: overlap? ( seq -- ? )
- dup first 2 tail* swap second 2 head = ;
+ [ first 2 tail* ] [ second 2 head ] bi = ;
: clean ( seq -- seq )
[ unclip 1 head prefix concat ] map [ all-unique? ] filter ;
: add-missing-digit ( seq -- seq )
- dup natural-sort 10 swap diff first prefix ;
+ dup natural-sort 10 swap diff prepend ;
: interesting-pandigitals ( -- seq )
17 candidates { 13 11 7 5 3 2 } [
interesting-pandigitals [ 10 digits>integer ] sigma ;
! [ euler043a ] 100 ave-time
-! 19 ms run / 1 ms GC ave time - 100 trials
+! 10 ms ave run time - 1.37 SD (100 trials)
MAIN: euler043a
--- /dev/null
+USING: project-euler.044 tools.test ;
+IN: project-euler.044.tests
+
+[ 5482660 ] [ euler044 ] unit-test
dup 3 * 1- * 2 / ;
: sum-and-diff? ( m n -- ? )
- 2dup + -rot - [ pentagonal? ] bi@ and ;
+ [ + ] [ - ] 2bi [ pentagonal? ] bi@ and ;
PRIVATE>
[ first2 sum-and-diff? ] filter [ first2 - abs ] map infimum ;
! [ euler044 ] 10 ave-time
-! 8924 ms run / 2872 ms GC ave time - 10 trials
+! 4996 ms ave run time - 87.46 SD (10 trials)
! TODO: this solution is ugly and not very efficient...find a better algorithm
--- /dev/null
+USING: project-euler.045 tools.test ;
+IN: project-euler.045.tests
+
+[ 1533776805 ] [ euler045 ] unit-test
143 next-solution ;
! [ euler045 ] 100 ave-time
-! 18 ms run / 1 ms GC ave time - 100 trials
+! 12 ms ave run time - 1.71 SD (100 trials)
MAIN: euler045
--- /dev/null
+USING: project-euler.046 tools.test ;
+IN: project-euler.046.tests
+
+[ 5777 ] [ euler046 ] unit-test
9 disprove-conjecture ;
! [ euler046 ] 100 ave-time
-! 150 ms run / 2 ms GC ave time - 100 trials
+! 37 ms ave run time - 3.39 SD (100 trials)
MAIN: euler046
--- /dev/null
+USING: project-euler.047 tools.test ;
+IN: project-euler.047.tests
+
+[ 134043 ] [ euler047 ] unit-test
+[ 134043 ] [ euler047a ] unit-test
4 646 consecutive ;
! [ euler047 ] time
-! 542708 ms run / 60548 ms GC time
+! 344688 ms run / 20727 ms GC time
! ALTERNATE SOLUTIONS
4 200000 consecutive-under ;
! [ euler047a ] 100 ave-time
-! 503 ms run / 5 ms GC ave time - 100 trials
+! 331 ms ave run time - 19.14 SD (100 trials)
! TODO: I don't like that you have to specify the upper bound, maybe try making
! this lazy so it could also short-circuit when it finds the answer?
--- /dev/null
+USING: project-euler.048 tools.test ;
+IN: project-euler.048.tests
+
+[ 9110846700 ] [ euler048 ] unit-test
--- /dev/null
+USING: project-euler.052 tools.test ;
+IN: project-euler.052.tests
+
+[ 142857 ] [ euler052 ] unit-test
[ number>digits natural-sort ] map all-equal? ;
: candidate? ( n -- ? )
- { [ dup odd? ] [ dup 3 mod zero? ] } 0&& nip ;
+ { [ odd? ] [ 3 mod zero? ] } 1&& ;
: next-all-same ( x n -- n )
dup candidate? [
6 123456 next-all-same ;
! [ euler052 ] 100 ave-time
-! 403 ms run / 7 ms GC ave time - 100 trials
+! 92 ms ave run time - 6.29 SD (100 trials)
MAIN: euler052
--- /dev/null
+USING: project-euler.053 tools.test ;
+IN: project-euler.053.tests
+
+[ 4075 ] [ euler053 ] unit-test
23 100 [a,b] [ dup [ nCk 1000000 > ] with count ] sigma ;
! [ euler053 ] 100 ave-time
-! 64 ms run / 2 ms GC ave time - 100 trials
+! 52 ms ave run time - 4.44 SD (100 trials)
MAIN: euler053
--- /dev/null
+USING: project-euler.055 tools.test ;
+IN: project-euler.055.tests
+
+[ 249 ] [ euler055 ] unit-test
10000 [ lychrel? ] count ;
! [ euler055 ] 100 ave-time
-! 1370 ms run / 31 ms GC ave time - 100 trials
+! 478 ms ave run time - 30.63 SD (100 trials)
MAIN: euler055
--- /dev/null
+USING: project-euler.056 tools.test ;
+IN: project-euler.056.tests
+
+[ 972 ] [ euler056 ] unit-test
[ first2 ^ number>digits sum ] map supremum ;
! [ euler056 ] 100 ave-time
-! 33 ms run / 1 ms GC ave time - 100 trials
+! 22 ms ave run time - 2.13 SD (100 trials)
MAIN: euler056
--- /dev/null
+USING: project-euler.059 tools.test ;
+IN: project-euler.059.tests
+
+[ 107359 ] [ euler059 ] unit-test
source-059 dup 3 crack-key decrypt sum ;
! [ euler059 ] 100 ave-time
-! 13 ms run / 0 ms GC ave time - 100 trials
+! 8 ms ave run time - 1.4 SD (100 trials)
MAIN: euler059
--- /dev/null
+USING: project-euler.067 tools.test ;
+IN: project-euler.067.tests
+
+[ 7273 ] [ euler067 ] unit-test
+[ 7273 ] [ euler067a ] unit-test
source-067 propagate-all first first ;
! [ euler067 ] 100 ave-time
-! 18 ms run / 0 ms GC time
+! 20 ms ave run time - 2.12 SD (100 trials)
! ALTERNATE SOLUTIONS
source-067 max-path ;
! [ euler067a ] 100 ave-time
-! 14 ms run / 0 ms GC ave time - 100 trials
+! 21 ms ave run time - 2.65 SD (100 trials)
MAIN: euler067a
--- /dev/null
+USING: project-euler.075 tools.test ;
+IN: project-euler.075.tests
+
+[ 214954 ] [ euler075 ] unit-test
! 120 cm: (30,40,50), (20,48,52), (24,45,51)
-! Given that L is the length of the wire, for how many values of L ≤ 1,000,000
+! Given that L is the length of the wire, for how many values of L ≤ 2,000,000
! can exactly one right angle triangle be formed?
! Algorithm adapted from http://mathworld.wolfram.com/PythagoreanTriple.html
! Identical implementation as problem #39
-! Basically, this makes an array of 1000000 zeros, recursively creates
+! Basically, this makes an array of 2000000 zeros, recursively creates
! primitive triples using the three transforms and then increments the array at
-! index [a+b+c] by one for each triple's sum AND its multiples under 1000000
+! index [a+b+c] by one for each triple's sum AND its multiples under 2000000
! (to account for non-primitive triples). The answer is just the total number
! of indexes that are equal to one.
: euler075 ( -- answer )
[
- 1000000 count-perimeters p-count get [ 1 = ] count
+ 2000000 count-perimeters p-count get [ 1 = ] count
] with-scope ;
-! [ euler075 ] 100 ave-time
-! 1873 ms run / 123 ms GC ave time - 100 trials
+! [ euler075 ] 10 ave-time
+! 3341 ms ave run timen - 157.77 SD (10 trials)
MAIN: euler075
--- /dev/null
+USING: project-euler.076 tools.test ;
+IN: project-euler.076.tests
+
+[ 190569291 ] [ euler076 ] unit-test
! Copyright (c) 2008 Eric Mertens.
! See http://factorcode.org/license.txt for BSD license.
-USING: arrays assocs combinators kernel locals math math.order math.ranges
- sequences ;
+USING: arrays assocs kernel locals math math.order math.ranges sequences ;
IN: project-euler.076
! http://projecteuler.net/index.php?section=problems&id=76
100 (euler076) ;
! [ euler076 ] 100 ave-time
-! 704 ms run time - 100 trials
+! 560 ms ave run time - 17.74 SD (100 trials)
MAIN: euler076
--- /dev/null
+USING: project-euler.079 tools.test ;
+IN: project-euler.079.tests
+
+[ 73162890 ] [ euler079 ] unit-test
! Copyright (c) 2008 Aaron Schaefer.
! See http://factorcode.org/license.txt for BSD license.
-USING: assocs hashtables io.files kernel math math.parser
-namespaces make io.encodings.ascii sequences sets ;
+USING: assocs io.encodings.ascii io.files kernel make math math.parser
+ sequences sets ;
IN: project-euler.079
! http://projecteuler.net/index.php?section=problems&id=79
source-079 >edges topological-sort 10 digits>integer ;
! [ euler079 ] 100 ave-time
-! 2 ms run / 0 ms GC ave time - 100 trials
+! 1 ms ave run time - 0.46 SD (100 trials)
! TODO: prune and diff are relatively slow; topological sort could be
! cleaned up and generalized much better, but it works for this problem
--- /dev/null
+USING: project-euler.092 tools.test ;
+IN: project-euler.092.tests
+
+[ 8581146 ] [ euler092 ] unit-test
! Copyright (c) 2008 Aaron Schaefer, Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel math math.ranges sequences ;
+USING: kernel math math.ranges project-euler.common sequences ;
IN: project-euler.092
! http://projecteuler.net/index.php?section=problems&id=92
<PRIVATE
: next-link ( n -- m )
- 0 swap [ dup zero? not ] [ 10 /mod sq -rot [ + ] dip ] [ ] while drop ;
+ number>digits [ sq ] sigma ;
: chain-ending ( n -- m )
- dup 1 = over 89 = or [ next-link chain-ending ] unless ;
+ dup [ 1 = ] [ 89 = ] bi or [ next-link chain-ending ] unless ;
: lower-endings ( -- seq )
567 [1,b] [ chain-ending ] map ;
: fast-chain-ending ( seq n -- m )
dup 567 > [ next-link ] when 1- swap nth ;
-: count ( seq quot -- n )
- 0 -rot [ rot >r call [ r> 1+ ] [ r> ] if ] curry each ; inline
-
PRIVATE>
: euler092 ( -- answer )
lower-endings 9999999 [1,b] [ fast-chain-ending 89 = ] with count ;
! [ euler092 ] 10 ave-time
-! 11169 ms run / 0 ms GC ave time - 10 trials
+! 33257 ms ave run time - 624.27 SD (10 trials)
+
+! TODO: this solution is not very efficient, much better optimizations exist
MAIN: euler092
--- /dev/null
+USING: project-euler.097 tools.test ;
+IN: project-euler.097.tests
+
+[ 8739992577 ] [ euler097 ] unit-test
2 7830457 10 10 ^ ^mod 28433 * 10 10 ^ mod 1+ ;
! [ euler097 ] 100 ave-time
-! 0 ms run / 0 ms GC ave time - 100 trials
+! 0 ms ave run timen - 0.22 SD (100 trials)
MAIN: euler097
--- /dev/null
+USING: project-euler.100 tools.test ;
+IN: project-euler.100.tests
+
+[ 756872327473 ] [ euler100 ] unit-test
[ dup dup 1- * 2 * 10 24 ^ <= ]
[ tuck 6 * swap - 2 - ] [ ] while nip ;
-! TODO: solution is incredibly slow (>30 minutes) and needs generalization
+! TODO: solution needs generalization
-! [ euler100 ] time
-! ? ms run time
+! [ euler100 ] 100 ave-time
+! 0 ms ave run time - 0.14 SD (100 trials)
MAIN: euler100
--- /dev/null
+USING: project-euler.116 tools.test ;
+IN: project-euler.116.tests
+
+[ 20492570929 ] [ euler116 ] unit-test
50 (euler116) ;
! [ euler116 ] 100 ave-time
-! 0 ms run time - 100 trials
+! 0 ms ave run time - 0.34 SD (100 trials)
MAIN: euler116
--- /dev/null
+USING: project-euler.117 tools.test ;
+IN: project-euler.117.tests
+
+[ 100808458960497 ] [ euler117 ] unit-test
50 (euler117) ;
! [ euler117 ] 100 ave-time
-! 0 ms run time - 100 trials
+! 0 ms ave run time - 0.29 SD (100 trials)
MAIN: euler117
--- /dev/null
+USING: project-euler.134 tools.test ;
+IN: project-euler.134.tests
+
+[ 18613426663617118 ] [ euler134 ] unit-test
[ [ s + ] keep ] leach drop ;
! [ euler134 ] 10 ave-time
-! 2430 ms run / 36 ms GC ave time - 10 trials
+! 933 ms ave run timen - 19.58 SD (10 trials)
MAIN: euler134
--- /dev/null
+USING: project-euler.148 tools.test ;
+IN: project-euler.148.tests
+
+[ 2129970655314432 ] [ euler148 ] unit-test
10 9 ^ (euler148) ;
! [ euler148 ] 100 ave-time
-! 0 ms run time - 100 trials
+! 0 ms ave run time - 0.17 SD (100 trials)
MAIN: euler148
--- /dev/null
+USING: project-euler.150 tools.test ;
+IN: project-euler.150.tests
+
+[ -271248680 ] [ euler150 ] unit-test
1000 (euler150) ;
! [ euler150 ] 10 ave-time
-! 32858 ms run time - 10 trials
+! 30208 ms ave run time - 593.45 SD (10 trials)
MAIN: euler150
--- /dev/null
+USING: project-euler.164 tools.test ;
+IN: project-euler.164.tests
+
+[ 378158756814587 ] [ euler164 ] unit-test
init-table 19 [ next-table ] times values sum ;
! [ euler164 ] 100 ave-time
-! 8 ms run time - 100 trials
+! 7 ms ave run time - 1.23 SD (100 trials)
MAIN: euler164
--- /dev/null
+USING: project-euler.169 tools.test ;
+IN: project-euler.169.tests
+
+[ 178653872807 ] [ euler169 ] unit-test
! 2 + 4 + 4
! 2 + 8
-! What is f(1025)?
+! What is f(10^25)?
! SOLUTION
10 25 ^ fn ;
! [ euler169 ] 100 ave-time
-! 0 ms run / 0 ms GC ave time - 100 trials
+! 0 ms ave run time - 0.2 SD (100 trials)
MAIN: euler169
--- /dev/null
+USING: project-euler.173 tools.test ;
+IN: project-euler.173.tests
+
+[ 1572729 ] [ euler173 ] unit-test
1000000 laminae ;
! [ euler173 ] 100 ave-time
-! 0 ms run / 0 ms GC ave time - 100 trials
+! 0 ms ave run time - 0.35 SD (100 trials)
MAIN: euler173
--- /dev/null
+USING: project-euler.175 tools.test ;
+IN: project-euler.175.tests
+
+[ "1,13717420,8" ] [ euler175 ] unit-test
V{ 1 } clone dup 123456789/987654321 compute [ number>string ] map "," join ;
! [ euler175 ] 100 ave-time
-! 0 ms run / 0 ms GC ave time - 100 trials
+! 0 ms ave run time - 0.31 SD (100 trials)
MAIN: euler175
--- /dev/null
+USING: project-euler.186 tools.test ;
+IN: project-euler.186.tests
+
+[ 2325629 ] [ euler186 ] unit-test
-USING: circular disjoint-sets kernel math math.ranges
-sequences ;
+! Copyright (c) 2008 Eric Mertens.
+! See http://factorcode.org/license.txt for BSD license.
+USING: circular disjoint-sets kernel math math.ranges sequences ;
IN: project-euler.186
+! http://projecteuler.net/index.php?section=problems&id=186
+
+! DESCRIPTION
+! -----------
+
+! Here are the records from a busy telephone system with one million users:
+
+! RecNr Caller Called
+! 1 200007 100053
+! 2 600183 500439
+! 3 600863 701497
+! ... ... ...
+
+! The telephone number of the caller and the called number in record n are
+! Caller(n) = S2n-1 and Called(n) = S2n where S1,2,3,... come from the "Lagged
+! Fibonacci Generator":
+
+! For 1 <= k <= 55, Sk = [100003 - 200003k + 300007k^3] (modulo 1000000)
+! For 56 <= k, Sk = [Sk-24 + Sk-55] (modulo 1000000)
+
+! If Caller(n) = Called(n) then the user is assumed to have misdialled and the
+! call fails; otherwise the call is successful.
+
+! From the start of the records, we say that any pair of users X and Y are
+! friends if X calls Y or vice-versa. Similarly, X is a friend of a friend of Z
+! if X is a friend of Y and Y is a friend of Z; and so on for longer chains.
+
+! The Prime Minister's phone number is 524287. After how many successful calls,
+! not counting misdials, will 99% of the users (including the PM) be a friend,
+! or a friend of a friend etc., of the Prime Minister?
+
+
+! SOLUTION
+! --------
+
: (generator) ( k -- n )
dup sq 300007 * 200003 - * 100003 + 1000000 rem ;
[ first ] [ advance ] bi ;
: 2unless? ( x y ?quot quot -- )
- >r 2keep rot [ 2drop ] r> if ; inline
+ [ 2keep rot [ 2drop ] ] dip if ; inline
: (p186) ( generator counter unionfind -- counter )
- 524287 over equiv-set-size 990000 <
- [
+ 524287 over equiv-set-size 990000 < [
pick [ next ] [ next ] bi
[ = ] [
pick equate
: euler186 ( -- n )
<generator> 0 1000000 <relation> (p186) ;
+! [ euler186 ] 10 ave-time
+! 18572 ms ave run time - 796.87 SD (10 trials)
+
MAIN: euler186
--- /dev/null
+USING: project-euler.190 tools.test ;
+IN: project-euler.190.tests
+
+[ 371048281 ] [ euler190 ] unit-test
2 15 [a,b] [ P_m truncate ] sigma ;
! [ euler150 ] 100 ave-time
-! 7 ms run time - 100 trials
+! 5 ms ave run time - 1.01 SD (100 trials)
MAIN: euler190
! Copyright (c) 2007 Aaron Schaefer.
! See http://factorcode.org/license.txt for BSD license.
-USING: continuations io kernel math math.functions math.parser math.statistics
- namespaces make tools.time ;
+USING: continuations fry io kernel make math math.functions math.parser
+ math.statistics memory tools.time ;
IN: project-euler.ave-time
: collect-benchmarks ( quot n -- seq )
- [
- >r >r datastack r> [ benchmark , ] curry tuck
- [ with-datastack drop ] 2curry r> swap times call
- ] { } make ;
+ [
+ [ datastack ]
+ [ '[ _ gc benchmark , ] tuck '[ _ _ with-datastack drop ] ]
+ [ 1- ] tri* swap times call
+ ] { } make ; inline
: nth-place ( x n -- y )
10 swap ^ [ * round ] keep / ;
: ave-time ( quot n -- )
- [ collect-benchmarks ] keep
- swap [ std 2 nth-place ] [ mean round ] bi [
+ [ collect-benchmarks ] keep swap
+ [ std 2 nth-place ] [ mean round ] bi [
# " ms ave run time - " % # " SD (" % # " trials)" %
] "" make print flush ; inline
-USING: arrays kernel math math.functions math.miller-rabin
-math.matrices math.order math.parser math.primes.factors
-math.ranges namespaces make sequences sequences.lib sorting
-unicode.case ;
+! Copyright (c) 2007-2008 Aaron Schaefer.
+! See http://factorcode.org/license.txt for BSD license.
+USING: arrays kernel make math math.functions math.matrices math.miller-rabin
+ math.order math.parser math.primes.factors math.ranges sequences
+ sequences.lib sorting strings unicode.case ;
IN: project-euler.common
! A collection of words used by more than one Project Euler solution
! -------------------------------
! alpha-value - #22, #42
! cartesian-product - #4, #27, #29, #32, #33, #43, #44, #56
-! collect-consecutive - #8, #11
! log10 - #25, #134
! max-path - #18, #67
! nth-triangle - #12, #42
-! number>digits - #16, #20, #30, #34, #35, #38, #43, #52, #55, #56
+! number>digits - #16, #20, #30, #34, #35, #38, #43, #52, #55, #56, #92
! palindrome? - #4, #36, #55
! pandigital? - #32, #38
! pentagonal? - #44, #45
! [uad]-transform - #39, #75
-: nth-pair ( n seq -- nth next )
- over 1+ over nth >r nth r> ;
+: nth-pair ( seq n -- nth next )
+ tail-slice first2 ;
: perfect-square? ( n -- ? )
dup sqrt mod zero? ;
<PRIVATE
-: count-shifts ( seq width -- n )
- >r length 1+ r> - ;
-
: max-children ( seq -- seq )
- [ dup length 1- [ over nth-pair max , ] each ] { } make nip ;
+ [ dup length 1- [ nth-pair max , ] with each ] { } make ;
! Propagate one row into the upper one
: propagate ( bottom top -- newtop )
[ over rest rot first2 max rot + ] map nip ;
-: shift-3rd ( seq obj obj -- seq obj obj )
- rot rest -rot ;
-
: (sum-divisors) ( n -- sum )
dup sqrt >fixnum [1,b] [
[ 2dup mod zero? [ 2dup / + , ] [ drop ] if ] each
: cartesian-product ( seq1 seq2 -- seq1xseq2 )
swap [ swap [ 2array ] map-with ] map-with concat ;
-: collect-consecutive ( seq width -- seq )
- [
- 2dup count-shifts [ 2dup head shift-3rd , ] times
- ] { } make 2nip ;
-
: log10 ( m -- n )
log 10 log / ;
number>string dup reverse = ;
: pandigital? ( n -- ? )
- number>string natural-sort "123456789" = ;
+ number>string natural-sort >string "123456789" = ;
: pentagonal? ( n -- ? )
dup 0 > [ 24 * 1+ sqrt 1+ 6 / 1 mod zero? ] [ drop f ] if ;
! Not strictly needed, but it is nice to be able to dump the triangle after the
! propagation
-: propagate-all ( triangle -- newtriangle )
- reverse [ first dup ] keep rest [ propagate dup ] map nip reverse swap suffix ;
+: propagate-all ( triangle -- new-triangle )
+ reverse [ first dup ] [ rest ] bi
+ [ propagate dup ] map nip reverse swap suffix ;
: sum-divisors ( n -- sum )
dup 4 < [ { 0 1 3 4 } nth ] [ (sum-divisors) ] if ;
! Optimized brute-force, is often faster than prime factorization
: tau* ( m -- n )
- factor-2s [ 1+ ] dip [ perfect-square? -1 0 ? ] keep
- dup sqrt >fixnum [1,b] [
+ factor-2s dup [ 1+ ]
+ [ perfect-square? -1 0 ? ]
+ [ dup sqrt >fixnum [1,b] ] tri* [
dupd mod zero? [ [ 2 + ] dip ] when
] each drop * ;
! Copyright (c) 2007, 2008 Aaron Schaefer, Samuel Tardieu.
! See http://factorcode.org/license.txt for BSD license.
USING: definitions io io.files kernel math math.parser project-euler.ave-time
- sequences vocabs vocabs.loader
+ sequences vocabs vocabs.loader prettyprint
project-euler.001 project-euler.002 project-euler.003 project-euler.004
project-euler.005 project-euler.006 project-euler.007 project-euler.008
project-euler.009 project-euler.010 project-euler.011 project-euler.012
project-euler.037 project-euler.038 project-euler.039 project-euler.040
project-euler.041 project-euler.042 project-euler.043 project-euler.044
project-euler.045 project-euler.046 project-euler.047 project-euler.048
- project-euler.052 project-euler.053 project-euler.056 project-euler.059
- project-euler.067 project-euler.075 project-euler.079 project-euler.092
- project-euler.097 project-euler.100 project-euler.116 project-euler.117
- project-euler.134 project-euler.148 project-euler.150 project-euler.151
- project-euler.164 project-euler.169 project-euler.173 project-euler.175
- project-euler.186 project-euler.190 ;
+ project-euler.052 project-euler.053 project-euler.055 project-euler.056
+ project-euler.059 project-euler.067 project-euler.075 project-euler.076
+ project-euler.079 project-euler.092 project-euler.097 project-euler.100
+ project-euler.116 project-euler.117 project-euler.134 project-euler.148
+ project-euler.150 project-euler.151 project-euler.164 project-euler.169
+ project-euler.173 project-euler.175 project-euler.186 project-euler.190 ;
IN: project-euler
<PRIVATE
: solution-path ( n -- str/f )
number>euler "project-euler." prepend
- vocab where dup [ first ] when ;
+ vocab where dup [ first <pathname> ] when ;
PRIVATE>
: run-project-euler ( -- )
problem-prompt dup problem-solved? [
dup number>euler "project-euler." prepend run
- "Answer: " swap dup number? [ number>string ] when append print
- "Source: " swap solution-path append print
+ "Answer: " write dup number? [ number>string ] when print
+ "Source: " write solution-path .
] [
drop "That problem has not been solved yet..." print
] if ;
USING: tools.deploy.config ;
H{
{ deploy-reflection 1 }
- { deploy-random? t }
{ deploy-word-defs? f }
{ deploy-word-props? f }
{ deploy-name "Spheres" }
USING: tools.deploy.config ;
H{
{ deploy-word-defs? f }
- { deploy-random? f }
{ deploy-name "Sudoku" }
{ deploy-threads? f }
{ deploy-compiler? t }
{ deploy-word-props? f }
{ deploy-reflection 1 }
{ "stop-after-last-window?" t }
- { deploy-random? t }
{ deploy-io 2 }
{ deploy-math? t }
{ deploy-word-defs? f }
{ deploy-compiler? t }
{ deploy-c-types? f }
{ deploy-reflection 1 }
- { deploy-random? f }
{ deploy-name "WebKit demo" }
{ deploy-io 1 }
{ deploy-math? f }
include vm/Config.macosx
include vm/Config.ppc
+CFLAGS += -arch ppc
PROLOGUE
SAVE_INT(r13,0) /* save GPRs */
- /* don't save ds pointer */
- /* don't save rs pointer */
+ SAVE_INT(r14,1)
+ SAVE_INT(r15,2)
SAVE_INT(r16,3)
SAVE_INT(r17,4)
SAVE_INT(r18,5)
SAVE_INT(r26,13)
SAVE_INT(r27,14)
SAVE_INT(r28,15)
- SAVE_INT(r29,16)
- SAVE_INT(r30,17)
- SAVE_INT(r31,18)
SAVE_FP(f14,20) /* save FPRs */
SAVE_FP(f15,22)
RESTORE_FP(f15,22)
RESTORE_FP(f14,20) /* save FPRs */
- RESTORE_INT(r31,18) /* restore GPRs */
- RESTORE_INT(r30,17)
- RESTORE_INT(r29,16)
- RESTORE_INT(r28,15)
+ RESTORE_INT(r28,15) /* restore GPRs */
RESTORE_INT(r27,14)
RESTORE_INT(r26,13)
RESTORE_INT(r25,12)
RESTORE_INT(r18,5)
RESTORE_INT(r17,4)
RESTORE_INT(r16,3)
- /* don't restore rs pointer */
- /* don't restore ds pointer */
+ RESTORE_INT(r15,2)
+ RESTORE_INT(r14,1)
RESTORE_INT(r13,0)
EPILOGUE
#define FACTOR_CPU_STRING "ppc"
#define F_FASTCALL
-register CELL ds asm("r30");
-register CELL rs asm("r31");
+register CELL ds asm("r29");
+register CELL rs asm("r30");
void c_to_factor(CELL quot);
void undefined(CELL word);
case CALLSTACK_TYPE:
return callstack_size(
untag_fixnum_fast(((F_CALLSTACK *)pointer)->length));
- case TUPLE_LAYOUT_TYPE:
- return sizeof(F_TUPLE_LAYOUT);
default:
critical_error("Invalid header",pointer);
return -1; /* can't happen */
#include "master.h"
+static bool full_output;
+
void print_chars(F_STRING* str)
{
CELL i;
CELL i;
bool trimmed;
- if(length > 10)
+ if(length > 10 && !full_output)
{
trimmed = true;
length = 10;
CELL i;
bool trimmed;
- if(length > 10)
+ if(length > 10 && !full_output)
{
trimmed = true;
length = 10;
void print_nested_obj(CELL obj, F_FIXNUM nesting)
{
- if(nesting <= 0)
+ if(nesting <= 0 && !full_output)
{
printf(" ... ");
return;
printf("d <addr> <count> -- dump memory\n");
printf("u <addr> -- dump object at tagged <addr>\n");
printf(". <addr> -- print object at tagged <addr>\n");
+ printf("t -- toggle output trimming\n");
printf("s r -- dump data, retain stacks\n");
printf(".s .r .c -- print data, retain, call stacks\n");
printf("e -- dump environment\n");
print_obj(addr);
printf("\n");
}
+ else if(strcmp(cmd,"t") == 0)
+ full_output = !full_output;
else if(strcmp(cmd,"s") == 0)
dump_memory(ds_bot,ds);
else if(strcmp(cmd,"r") == 0)
#define BYTE_ARRAY_TYPE 10
#define CALLSTACK_TYPE 11
#define STRING_TYPE 12
-#define TUPLE_LAYOUT_TYPE 13
+#define WORD_TYPE 13
#define QUOTATION_TYPE 14
#define DLL_TYPE 15
#define ALIEN_TYPE 16
-#define WORD_TYPE 17
-#define TYPE_COUNT 20
+#define TYPE_COUNT 17
INLINE bool immediate_p(CELL obj)
{
/* Assembly code makes assumptions about the layout of this struct */
typedef struct {
-/* C sucks. */
+/* We use a union here to force the float value to be aligned on an
+8-byte boundary. */
union {
CELL header;
long long padding;
CELL size;
} F_STACK_FRAME;
+/* These are really just arrays, but certain elements have special
+significance */
typedef struct
{
CELL header;
- /* tagged fixnum */
- CELL hashcode;
+ /* tagged */
+ CELL capacity;
/* tagged */
CELL class;
/* tagged fixnum */
CELL size;
- /* tagged array */
- CELL superclasses;
/* tagged fixnum */
CELL echelon;
} F_TUPLE_LAYOUT;
primitive_array_to_quotation,
primitive_quotation_xt,
primitive_tuple,
- primitive_tuple_layout,
primitive_profiling,
primitive_become,
primitive_sleep,
return result;
}
-/* Tuple layouts */
-DEFINE_PRIMITIVE(tuple_layout)
-{
- F_TUPLE_LAYOUT *layout = allot_object(TUPLE_LAYOUT_TYPE,sizeof(F_TUPLE_LAYOUT));
- layout->echelon = dpop();
- layout->superclasses = dpop();
- layout->size = dpop();
- layout->class = dpop();
- layout->hashcode = untag_word(layout->class)->hashcode;
- dpush(tag_object(layout));
-}
-
/* Tuples */
/* push a new tuple on the stack */
DEFINE_PRIMITIVE(tuple)
{
F_TUPLE_LAYOUT *layout = untag_object(dpop());
- F_FIXNUM size = to_fixnum(layout->size);
+ F_FIXNUM size = untag_fixnum_fast(layout->size);
F_TUPLE *tuple = allot_tuple(layout);
F_FIXNUM i;
DEFINE_PRIMITIVE(tuple_boa)
{
F_TUPLE_LAYOUT *layout = untag_object(dpop());
- F_FIXNUM size = to_fixnum(layout->size);
+ F_FIXNUM size = untag_fixnum_fast(layout->size);
REGISTER_UNTAGGED(layout);
F_TUPLE *tuple = allot_tuple(layout);
projects / factor.git / commitdiff