steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Merge branch 'master' of git://factorcode.org/git/factor

db4
Slava Pestov 2009-04-17 22:49:59 -05:00
parent d22ae36ca5 a12698ee5e
commit 86e4e314f3
150 changed files with 1030 additions and 608 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
.gitignore vendored
View File

@ -25,3 +25,5 @@ build-support/wordsize
.#* .#*
*.swo *.swo
checksums.txt checksums.txt
*.so
a.out

2
basis/bootstrap/finish-bootstrap.factor
View File

@ -8,7 +8,7 @@ namespaces eval kernel vocabs.loader io ;
(command-line) parse-command-line (command-line) parse-command-line
load-vocab-roots load-vocab-roots
run-user-init run-user-init
"e" get [ eval ] when* "e" get [ eval( -- ) ] when*
ignore-cli-args? not script get and ignore-cli-args? not script get and
[ run-script ] [ "run" get run ] if* [ run-script ] [ "run" get run ] if*
output-stream get [ stream-flush ] when* output-stream get [ stream-flush ] when*

1
basis/compiler/errors/errors.factor
View File

@ -44,6 +44,7 @@ T{ error-type
{ icon "vocab:ui/tools/error-list/icons/linkage-error.tiff" } { icon "vocab:ui/tools/error-list/icons/linkage-error.tiff" }
{ quot [ +linkage-error+ errors-of-type values ] } { quot [ +linkage-error+ errors-of-type values ] }
{ forget-quot [ compiler-errors get delete-at ] } { forget-quot [ compiler-errors get delete-at ] }
{ fatal? f }
} define-error-type } define-error-type
: <compiler-error> ( error word -- compiler-error ) : <compiler-error> ( error word -- compiler-error )

4
basis/compiler/tests/folding.factor
View File

@ -12,7 +12,7 @@ IN: compiler.tests
IN: compiler.tests.folding IN: compiler.tests.folding
GENERIC: foldable-generic ( a -- b ) foldable GENERIC: foldable-generic ( a -- b ) foldable
M: integer foldable-generic f <array> ; M: integer foldable-generic f <array> ;
"> eval "> eval( -- )
] unit-test ] unit-test
[ ] [ [ ] [
@ -20,7 +20,7 @@ IN: compiler.tests
USING: math arrays ; USING: math arrays ;
IN: compiler.tests.folding IN: compiler.tests.folding
: fold-test ( -- x ) 10 foldable-generic ; : fold-test ( -- x ) 10 foldable-generic ;
"> eval "> eval( -- )
] unit-test ] unit-test
[ t ] [ [ t ] [

12
basis/compiler/tests/redefine1.factor
View File

@ -11,7 +11,7 @@ M: integer method-redefine-generic-1 3 + ;
[ 6 ] [ method-redefine-test-1 ] unit-test [ 6 ] [ method-redefine-test-1 ] unit-test
[ ] [ "IN: compiler.tests USE: math M: fixnum method-redefine-generic-1 4 + ;" eval ] unit-test [ ] [ "IN: compiler.tests USE: math M: fixnum method-redefine-generic-1 4 + ;" eval( -- ) ] unit-test
[ 7 ] [ method-redefine-test-1 ] unit-test [ 7 ] [ method-redefine-test-1 ] unit-test
@ -27,7 +27,7 @@ M: integer method-redefine-generic-2 3 + ;
[ 6 ] [ method-redefine-test-2 ] unit-test [ 6 ] [ method-redefine-test-2 ] unit-test
[ ] [ "IN: compiler.tests USE: kernel USE: math M: fixnum method-redefine-generic-2 4 + ; USE: strings M: string method-redefine-generic-2 drop f ;" eval ] unit-test [ ] [ "IN: compiler.tests USE: kernel USE: math M: fixnum method-redefine-generic-2 4 + ; USE: strings M: string method-redefine-generic-2 drop f ;" eval( -- ) ] unit-test
[ 7 ] [ method-redefine-test-2 ] unit-test [ 7 ] [ method-redefine-test-2 ] unit-test
@ -43,10 +43,10 @@ M: integer method-redefine-generic-2 3 + ;
[ t ] [ \ hey optimized>> ] unit-test [ t ] [ \ hey optimized>> ] unit-test
[ t ] [ \ there optimized>> ] unit-test [ t ] [ \ there optimized>> ] unit-test
[ ] [ "IN: compiler.tests : hey ( -- ) 3 ;" eval ] unit-test [ ] [ "IN: compiler.tests : hey ( -- ) 3 ;" eval( -- ) ] unit-test
[ f ] [ \ hey optimized>> ] unit-test [ f ] [ \ hey optimized>> ] unit-test
[ f ] [ \ there optimized>> ] unit-test [ f ] [ \ there optimized>> ] unit-test
[ ] [ "IN: compiler.tests : hey ( -- ) ;" eval ] unit-test [ ] [ "IN: compiler.tests : hey ( -- ) ;" eval( -- ) ] unit-test
[ t ] [ \ there optimized>> ] unit-test [ t ] [ \ there optimized>> ] unit-test
: good ( -- ) ; : good ( -- ) ;
@ -59,7 +59,7 @@ M: integer method-redefine-generic-2 3 + ;
[ f ] [ \ good compiled-usage assoc-empty? ] unit-test [ f ] [ \ good compiled-usage assoc-empty? ] unit-test
[ ] [ "IN: compiler.tests : good ( -- ) 3 ;" eval ] unit-test [ ] [ "IN: compiler.tests : good ( -- ) 3 ;" eval( -- ) ] unit-test
[ f ] [ \ good optimized>> ] unit-test [ f ] [ \ good optimized>> ] unit-test
[ f ] [ \ bad optimized>> ] unit-test [ f ] [ \ bad optimized>> ] unit-test
@ -67,7 +67,7 @@ M: integer method-redefine-generic-2 3 + ;
[ t ] [ \ good compiled-usage assoc-empty? ] unit-test [ t ] [ \ good compiled-usage assoc-empty? ] unit-test
[ ] [ "IN: compiler.tests : good ( -- ) ;" eval ] unit-test [ ] [ "IN: compiler.tests : good ( -- ) ;" eval( -- ) ] unit-test
[ t ] [ \ good optimized>> ] unit-test [ t ] [ \ good optimized>> ] unit-test
[ t ] [ \ bad optimized>> ] unit-test [ t ] [ \ bad optimized>> ] unit-test

4
basis/compiler/tests/redefine10.factor
View File

@ -13,7 +13,7 @@ IN: compiler.tests
MIXIN: my-mixin MIXIN: my-mixin
INSTANCE: fixnum my-mixin INSTANCE: fixnum my-mixin
: my-inline ( a -- b ) dup my-mixin instance? [ 1 + ] when ; : my-inline ( a -- b ) dup my-mixin instance? [ 1 + ] when ;
"> eval "> eval( -- )
] unit-test ] unit-test
[ ] [ [ ] [
@ -21,7 +21,7 @@ IN: compiler.tests
USE: math USE: math
IN: compiler.tests.redefine10 IN: compiler.tests.redefine10
INSTANCE: float my-mixin INSTANCE: float my-mixin
"> eval "> eval( -- )
] unit-test ] unit-test
[ 2.0 ] [ [ 2.0 ] [

2
basis/compiler/tests/redefine11.factor
View File

@ -17,7 +17,7 @@ IN: compiler.tests
M: my-mixin my-generic drop 0 ; M: my-mixin my-generic drop 0 ;
M: object my-generic drop 1 ; M: object my-generic drop 1 ;
: my-inline ( -- b ) { } my-generic ; : my-inline ( -- b ) { } my-generic ;
"> eval "> eval( -- )
] unit-test ] unit-test
[ ] [ [ ] [

2
basis/compiler/tests/redefine12.factor
View File

@ -15,6 +15,6 @@ M: object g drop t ;
TUPLE: jeah ; TUPLE: jeah ;
[ ] [ "USE: kernel IN: compiler.tests.redefine12 M: jeah g drop f ;" eval ] unit-test [ ] [ "USE: kernel IN: compiler.tests.redefine12 M: jeah g drop f ;" eval( -- ) ] unit-test
[ f ] [ T{ jeah } h ] unit-test [ f ] [ T{ jeah } h ] unit-test

2
basis/compiler/tests/redefine2.factor
View File

@ -5,7 +5,7 @@ arrays words assocs eval words.symbol ;
DEFER: redefine2-test DEFER: redefine2-test
[ ] [ "USE: sequences USE: kernel IN: compiler.tests TUPLE: redefine2-test ; M: redefine2-test nth 2drop 3 ; INSTANCE: redefine2-test sequence" eval ] unit-test [ ] [ "USE: sequences USE: kernel IN: compiler.tests TUPLE: redefine2-test ; M: redefine2-test nth 2drop 3 ; INSTANCE: redefine2-test sequence" eval( -- ) ] unit-test
[ t ] [ \ redefine2-test symbol? ] unit-test [ t ] [ \ redefine2-test symbol? ] unit-test

2
basis/compiler/tests/redefine3.factor
View File

@ -18,7 +18,7 @@ M: empty-mixin sheeple drop "wake up" ;
[ t ] [ object \ sheeple method \ sheeple-test "compiled-uses" word-prop key? ] unit-test [ t ] [ object \ sheeple method \ sheeple-test "compiled-uses" word-prop key? ] unit-test
[ f ] [ empty-mixin \ sheeple method \ sheeple-test "compiled-uses" word-prop key? ] unit-test [ f ] [ empty-mixin \ sheeple method \ sheeple-test "compiled-uses" word-prop key? ] unit-test
[ ] [ "IN: compiler.tests USE: arrays INSTANCE: array empty-mixin" eval ] unit-test [ ] [ "IN: compiler.tests USE: arrays INSTANCE: array empty-mixin" eval( -- ) ] unit-test
[ "wake up" ] [ sheeple-test ] unit-test [ "wake up" ] [ sheeple-test ] unit-test
[ f ] [ object \ sheeple method \ sheeple-test "compiled-uses" word-prop key? ] unit-test [ f ] [ object \ sheeple method \ sheeple-test "compiled-uses" word-prop key? ] unit-test

2
basis/compiler/tests/redefine4.factor
View File

@ -7,6 +7,6 @@ USING: io.streams.string kernel tools.test eval ;
[ "" ] [ [ declaration-test ] with-string-writer ] unit-test [ "" ] [ [ declaration-test ] with-string-writer ] unit-test
[ ] [ "IN: compiler.tests USE: io : declaration-test-1 ( -- a ) \"X\" write f ;" eval ] unit-test [ ] [ "IN: compiler.tests USE: io : declaration-test-1 ( -- a ) \"X\" write f ;" eval( -- ) ] unit-test
[ "X" ] [ [ declaration-test ] with-string-writer ] unit-test [ "X" ] [ [ declaration-test ] with-string-writer ] unit-test

4
basis/compiler/tests/redefine5.factor
View File

@ -14,7 +14,7 @@ IN: compiler.tests
GENERIC: my-generic ( a -- b ) GENERIC: my-generic ( a -- b )
M: object my-generic [ <=> ] sort ; M: object my-generic [ <=> ] sort ;
: my-inline ( a -- b ) my-generic ; : my-inline ( a -- b ) my-generic ;
"> eval "> eval( -- )
] unit-test ] unit-test
[ ] [ [ ] [
@ -23,7 +23,7 @@ IN: compiler.tests
IN: compiler.tests.redefine5 IN: compiler.tests.redefine5
TUPLE: my-tuple ; TUPLE: my-tuple ;
M: my-tuple my-generic drop 0 ; M: my-tuple my-generic drop 0 ;
"> eval "> eval( -- )
] unit-test ] unit-test
[ 0 ] [ [ 0 ] [

4
basis/compiler/tests/redefine6.factor
View File

@ -14,7 +14,7 @@ IN: compiler.tests
MIXIN: my-mixin MIXIN: my-mixin
M: my-mixin my-generic drop 0 ; M: my-mixin my-generic drop 0 ;
: my-inline ( a -- b ) { my-mixin } declare my-generic ; : my-inline ( a -- b ) { my-mixin } declare my-generic ;
"> eval "> eval( -- )
] unit-test ] unit-test
[ ] [ [ ] [
@ -24,7 +24,7 @@ IN: compiler.tests
TUPLE: my-tuple ; TUPLE: my-tuple ;
M: my-tuple my-generic drop 1 ; M: my-tuple my-generic drop 1 ;
INSTANCE: my-tuple my-mixin INSTANCE: my-tuple my-mixin
"> eval "> eval( -- )
] unit-test ] unit-test
[ 1 ] [ [ 1 ] [

4
basis/compiler/tests/redefine7.factor
View File

@ -13,7 +13,7 @@ IN: compiler.tests
MIXIN: my-mixin MIXIN: my-mixin
INSTANCE: fixnum my-mixin INSTANCE: fixnum my-mixin
: my-inline ( a -- b ) dup my-mixin? [ 1 + ] when ; : my-inline ( a -- b ) dup my-mixin? [ 1 + ] when ;
"> eval "> eval( -- )
] unit-test ] unit-test
[ ] [ [ ] [
@ -21,7 +21,7 @@ IN: compiler.tests
USE: math USE: math
IN: compiler.tests.redefine7 IN: compiler.tests.redefine7
INSTANCE: float my-mixin INSTANCE: float my-mixin
"> eval "> eval( -- )
] unit-test ] unit-test
[ 2.0 ] [ [ 2.0 ] [

4
basis/compiler/tests/redefine8.factor
View File

@ -16,7 +16,7 @@ IN: compiler.tests
! We add the bogus quotation here to hinder inlining ! We add the bogus quotation here to hinder inlining
! since otherwise we cannot trigger this bug. ! since otherwise we cannot trigger this bug.
M: my-mixin my-generic 1 + [ [ <=> ] sort ] drop ; M: my-mixin my-generic 1 + [ [ <=> ] sort ] drop ;
"> eval "> eval( -- )
] unit-test ] unit-test
[ ] [ [ ] [
@ -24,7 +24,7 @@ IN: compiler.tests
USE: math USE: math
IN: compiler.tests.redefine8 IN: compiler.tests.redefine8
INSTANCE: float my-mixin INSTANCE: float my-mixin
"> eval "> eval( -- )
] unit-test ] unit-test
[ 2.0 ] [ [ 2.0 ] [

4
basis/compiler/tests/redefine9.factor
View File

@ -16,7 +16,7 @@ IN: compiler.tests
! We add the bogus quotation here to hinder inlining ! We add the bogus quotation here to hinder inlining
! since otherwise we cannot trigger this bug. ! since otherwise we cannot trigger this bug.
M: my-mixin my-generic 1 + [ [ <=> ] sort ] drop ; M: my-mixin my-generic 1 + [ [ <=> ] sort ] drop ;
"> eval "> eval( -- )
] unit-test ] unit-test
[ ] [ [ ] [
@ -25,7 +25,7 @@ IN: compiler.tests
IN: compiler.tests.redefine9 IN: compiler.tests.redefine9
TUPLE: my-tuple ; TUPLE: my-tuple ;
INSTANCE: my-tuple my-mixin INSTANCE: my-tuple my-mixin
"> eval "> eval( -- )
] unit-test ] unit-test
[ [

2
basis/compiler/tests/simple.factor
View File

@ -237,6 +237,6 @@ M: f single-combination-test-2 single-combination-test-4 ;
10 [ 10 [
[ "compiler.tests.foo" forget-vocab ] with-compilation-unit [ "compiler.tests.foo" forget-vocab ] with-compilation-unit
[ t ] [ [ t ] [
"USING: prettyprint words accessors ; IN: compiler.tests.foo : (recursive) ( -- ) (recursive) (recursive) ; inline recursive : recursive ( -- ) (recursive) ; \\ (recursive) optimized>>" eval "USING: prettyprint words accessors ; IN: compiler.tests.foo : (recursive) ( -- ) (recursive) (recursive) ; inline recursive : recursive ( -- ) (recursive) ; \\ (recursive) optimized>>" eval( -- obj )
] unit-test ] unit-test
] times ] times

4
basis/compiler/tree/cleanup/cleanup-tests.factor
View File

@ -197,7 +197,7 @@ M: fixnum annotate-entry-test-1 drop ;
[ dup annotate-entry-test-1 1+ ] dip (annotate-entry-test-2) [ dup annotate-entry-test-1 1+ ] dip (annotate-entry-test-2)
] if ; inline recursive ] if ; inline recursive
: annotate-entry-test-2 ( from to -- ) 0 -rot (annotate-entry-test-2) ; inline : annotate-entry-test-2 ( from to -- obj ) 0 -rot (annotate-entry-test-2) ; inline
[ f ] [ [ f ] [
[ { bignum } declare annotate-entry-test-2 ] [ { bignum } declare annotate-entry-test-2 ]
@ -302,7 +302,7 @@ cell-bits 32 = [
] unit-test ] unit-test
[ t ] [ [ t ] [
[ 1000 [ 1+ ] map ] { 1+ fixnum+ } inlined? [ 1000 iota [ 1+ ] map ] { 1+ fixnum+ } inlined?
] unit-test ] unit-test
: rec ( a -- b ) : rec ( a -- b )

16
basis/compiler/tree/normalization/normalization-tests.factor
View File

@ -17,13 +17,13 @@ sequences accessors tools.test kernel math ;
[ 2 ] [ [ 3 [ drop ] [ 2drop 3 ] if ] build-tree count-introductions ] unit-test [ 2 ] [ [ 3 [ drop ] [ 2drop 3 ] if ] build-tree count-introductions ] unit-test
: foo ( -- ) swap ; inline recursive : foo ( quot: ( -- ) -- ) call ; inline recursive
: recursive-inputs ( nodes -- n ) : recursive-inputs ( nodes -- n )
[ #recursive? ] find nip child>> first in-d>> length ; [ #recursive? ] find nip child>> first in-d>> length ;
[ 0 2 ] [ [ 1 3 ] [
[ foo ] build-tree [ [ swap ] foo ] build-tree
[ recursive-inputs ] [ recursive-inputs ]
[ analyze-recursive normalize recursive-inputs ] bi [ analyze-recursive normalize recursive-inputs ] bi
] unit-test ] unit-test
@ -34,18 +34,18 @@ sequences accessors tools.test kernel math ;
[ ] [ [ [ 1 ] [ 2 ] if + * ] test-normalization ] unit-test [ ] [ [ [ 1 ] [ 2 ] if + * ] test-normalization ] unit-test
DEFER: bbb DEFER: bbb
: aaa ( x -- ) dup [ dup [ bbb ] dip aaa ] [ drop ] if ; inline recursive : aaa ( obj x -- obj ) dup [ dup [ bbb ] dip aaa ] [ drop ] if ; inline recursive
: bbb ( x -- ) [ drop 0 ] dip aaa ; inline recursive : bbb ( obj x -- obj ) [ drop 0 ] dip aaa ; inline recursive
[ ] [ [ bbb ] test-normalization ] unit-test [ ] [ [ bbb ] test-normalization ] unit-test
: ccc ( -- ) ccc drop 1 ; inline recursive : ccc ( obj -- 1 ) ccc drop 1 ; inline recursive
[ ] [ [ ccc ] test-normalization ] unit-test [ ] [ [ ccc ] test-normalization ] unit-test
DEFER: eee DEFER: eee
: ddd ( -- ) eee ; inline recursive : ddd ( a b -- a b ) eee ; inline recursive
: eee ( -- ) swap ddd ; inline recursive : eee ( a b -- a b ) swap ddd ; inline recursive
[ ] [ [ eee ] test-normalization ] unit-test [ ] [ [ eee ] test-normalization ] unit-test

2
basis/compiler/tree/propagation/propagation-tests.factor
View File

@ -680,7 +680,7 @@ TUPLE: littledan-2 { from read-only } { to read-only } ;
: (littledan-3-test) ( x -- ) : (littledan-3-test) ( x -- )
length 1+ f <array> (littledan-3-test) ; inline recursive length 1+ f <array> (littledan-3-test) ; inline recursive
: littledan-3-test ( x -- ) : littledan-3-test ( -- )
0 f <array> (littledan-3-test) ; inline 0 f <array> (littledan-3-test) ; inline
[ ] [ [ littledan-3-test ] final-classes drop ] unit-test [ ] [ [ littledan-3-test ] final-classes drop ] unit-test

2
basis/compiler/tree/recursive/recursive-tests.factor
View File

@ -57,7 +57,7 @@ compiler.tree.combinators ;
\ (each-integer) label-is-loop? \ (each-integer) label-is-loop?
] unit-test ] unit-test
: loop-test-2 ( a -- ) : loop-test-2 ( a b -- a' )
dup [ 1+ loop-test-2 1- ] [ drop ] if ; inline recursive dup [ 1+ loop-test-2 1- ] [ drop ] if ; inline recursive
[ t ] [ [ t ] [

2
basis/concurrency/exchangers/exchangers-tests.factor
View File

@ -3,7 +3,7 @@ USING: sequences tools.test concurrency.exchangers
concurrency.count-downs concurrency.promises locals kernel concurrency.count-downs concurrency.promises locals kernel
threads ; threads ;
:: exchanger-test ( -- ) :: exchanger-test ( -- string )
[let | [let |
ex [ <exchanger> ] ex [ <exchanger> ]
c [ 2 <count-down> ] c [ 2 <count-down> ]

2
basis/concurrency/flags/flags-tests.factor
View File

@ -11,7 +11,7 @@ kernel threads locals accessors calendar ;
[ f ] [ flag-test-1 ] unit-test [ f ] [ flag-test-1 ] unit-test
:: flag-test-2 ( -- ) :: flag-test-2 ( -- ? )
[let | f [ <flag> ] | [let | f [ <flag> ] |
[ 1 seconds sleep f raise-flag ] "Flag test" spawn drop [ 1 seconds sleep f raise-flag ] "Flag test" spawn drop
f lower-flag f lower-flag

4
basis/cpu/ppc/bootstrap.factor
View File

@ -310,7 +310,7 @@ CONSTANT: rs-reg 30
4 ds-reg 0 LWZ 4 ds-reg 0 LWZ
5 ds-reg -4 LWZU 5 ds-reg -4 LWZU
5 0 4 CMP 5 0 4 CMP
2 swap execute ! magic number 2 swap execute( offset -- ) ! magic number
\ f tag-number 3 LI \ f tag-number 3 LI
3 ds-reg 0 STW ; 3 ds-reg 0 STW ;
@ -341,7 +341,7 @@ CONSTANT: rs-reg 30
: jit-math ( insn -- ) : jit-math ( insn -- )
3 ds-reg 0 LWZ 3 ds-reg 0 LWZ
4 ds-reg -4 LWZU 4 ds-reg -4 LWZU
[ 5 3 4 ] dip execute [ 5 3 4 ] dip execute( dst src1 src2 -- )
5 ds-reg 0 STW ; 5 ds-reg 0 STW ;
[ \ ADD jit-math ] f f f \ fixnum+fast define-sub-primitive [ \ ADD jit-math ] f f f \ fixnum+fast define-sub-primitive

4
basis/cpu/x86/bootstrap.factor
View File

@ -334,7 +334,7 @@ big-endian off
! compare with second value ! compare with second value
ds-reg [] temp0 CMP ds-reg [] temp0 CMP
! move t if true ! move t if true
[ temp1 temp3 ] dip execute [ temp1 temp3 ] dip execute( dst src -- )
! store ! store
ds-reg [] temp1 MOV ; ds-reg [] temp1 MOV ;
@ -355,7 +355,7 @@ big-endian off
! pop stack ! pop stack
ds-reg bootstrap-cell SUB ds-reg bootstrap-cell SUB
! compute result ! compute result
[ ds-reg [] temp0 ] dip execute ; [ ds-reg [] temp0 ] dip execute( dst src -- ) ;
[ \ ADD jit-math ] f f f \ fixnum+fast define-sub-primitive [ \ ADD jit-math ] f f f \ fixnum+fast define-sub-primitive

10
basis/delegate/delegate-tests.factor
View File

@ -35,7 +35,7 @@ M: hello bing hello-test ;
[ 3 ] [ 1 0 <hello> 2 whoa ] unit-test [ 3 ] [ 1 0 <hello> 2 whoa ] unit-test
[ 3 ] [ 1 0 <hello> f <goodbye> 2 whoa ] unit-test [ 3 ] [ 1 0 <hello> f <goodbye> 2 whoa ] unit-test
[ ] [ 3 [ "USING: accessors delegate ; IN: delegate.tests CONSULT: baz goodbye these>> ;" eval ] times ] unit-test [ ] [ 3 [ "USING: accessors delegate ; IN: delegate.tests CONSULT: baz goodbye these>> ;" eval( -- ) ] times ] unit-test
[ H{ { goodbye T{ consultation f baz goodbye [ these>> ] } } } ] [ baz protocol-consult ] unit-test [ H{ { goodbye T{ consultation f baz goodbye [ these>> ] } } } ] [ baz protocol-consult ] unit-test
[ H{ } ] [ bee protocol-consult ] unit-test [ H{ } ] [ bee protocol-consult ] unit-test
@ -63,22 +63,22 @@ CONSULT: beta hey value>> 1- ;
[ 0 ] [ 1 <hey> three ] unit-test [ 0 ] [ 1 <hey> three ] unit-test
[ { hey } ] [ alpha protocol-users ] unit-test [ { hey } ] [ alpha protocol-users ] unit-test
[ { hey } ] [ beta protocol-users ] unit-test [ { hey } ] [ beta protocol-users ] unit-test
[ ] [ "USE: delegate IN: delegate.tests PROTOCOL: alpha one ;" eval ] unit-test [ ] [ "USE: delegate IN: delegate.tests PROTOCOL: alpha one ;" eval( -- ) ] unit-test
[ f ] [ hey \ two method ] unit-test [ f ] [ hey \ two method ] unit-test
[ f ] [ hey \ four method ] unit-test [ f ] [ hey \ four method ] unit-test
[ ] [ "USE: delegate IN: delegate.tests PROTOCOL: beta two three four ;" eval ] unit-test [ ] [ "USE: delegate IN: delegate.tests PROTOCOL: beta two three four ;" eval( -- ) ] unit-test
[ { hey } ] [ alpha protocol-users ] unit-test [ { hey } ] [ alpha protocol-users ] unit-test
[ { hey } ] [ beta protocol-users ] unit-test [ { hey } ] [ beta protocol-users ] unit-test
[ 2 ] [ 1 <hey> one ] unit-test [ 2 ] [ 1 <hey> one ] unit-test
[ 0 ] [ 1 <hey> two ] unit-test [ 0 ] [ 1 <hey> two ] unit-test
[ 0 ] [ 1 <hey> three ] unit-test [ 0 ] [ 1 <hey> three ] unit-test
[ 0 ] [ 1 <hey> four ] unit-test [ 0 ] [ 1 <hey> four ] unit-test
[ ] [ "USING: math accessors delegate ; IN: delegate.tests CONSULT: beta hey value>> 2 - ;" eval ] unit-test [ ] [ "USING: math accessors delegate ; IN: delegate.tests CONSULT: beta hey value>> 2 - ;" eval( -- ) ] unit-test
[ 2 ] [ 1 <hey> one ] unit-test [ 2 ] [ 1 <hey> one ] unit-test
[ -1 ] [ 1 <hey> two ] unit-test [ -1 ] [ 1 <hey> two ] unit-test
[ -1 ] [ 1 <hey> three ] unit-test [ -1 ] [ 1 <hey> three ] unit-test
[ -1 ] [ 1 <hey> four ] unit-test [ -1 ] [ 1 <hey> four ] unit-test
[ ] [ "IN: delegate.tests FORGET: alpha" eval ] unit-test [ ] [ "IN: delegate.tests FORGET: alpha" eval( -- ) ] unit-test
[ f ] [ hey \ one method ] unit-test [ f ] [ hey \ one method ] unit-test
TUPLE: slot-protocol-test-1 a b ; TUPLE: slot-protocol-test-1 a b ;

2
basis/eval/eval-tests.factor
View File

@ -1,4 +1,6 @@
IN: eval.tests IN: eval.tests
USING: eval tools.test ; USING: eval tools.test ;
[ 4 ] [ "USE: math 2 2 +" eval( -- result ) ] unit-test
[ "USE: math 2 2 +" eval( -- ) ] must-fail
[ "4\n" ] [ "USING: math prettyprint ; 2 2 + ." eval>string ] unit-test [ "4\n" ] [ "USING: math prettyprint ; 2 2 + ." eval>string ] unit-test

2
basis/fry/fry-tests.factor
View File

@ -56,7 +56,7 @@ sequences eval accessors ;
3 '[ [ [ _ 1array ] call 1array ] call 1array ] call 3 '[ [ [ _ 1array ] call 1array ] call 1array ] call
] unit-test ] unit-test
[ "USING: fry locals.backend ; f '[ load-local _ ]" eval ] [ "USING: fry locals.backend ; f '[ load-local _ ]" eval( -- quot ) ]
[ error>> >r/r>-in-fry-error? ] must-fail-with [ error>> >r/r>-in-fry-error? ] must-fail-with
[ { { "a" 1 } { "b" 2 } { "c" 3 } { "d" 4 } } ] [ [ { { "a" 1 } { "b" 2 } { "c" 3 } { "d" 4 } } ] [

4
basis/furnace/sessions/sessions-tests.factor
View File

@ -22,7 +22,7 @@ M: foo call-responder*
"x" [ 1+ ] schange "x" [ 1+ ] schange
"x" sget number>string "text/html" <content> ; "x" sget number>string "text/html" <content> ;
: url-responder-mock-test ( -- ) : url-responder-mock-test ( -- string )
[ [
<request> <request>
"GET" >>method "GET" >>method
@ -34,7 +34,7 @@ M: foo call-responder*
[ write-response-body drop ] with-string-writer [ write-response-body drop ] with-string-writer
] with-destructors ; ] with-destructors ;
: sessions-mock-test ( -- ) : sessions-mock-test ( -- string )
[ [
<request> <request>
"GET" >>method "GET" >>method

4
basis/generalizations/generalizations-docs.factor
View File

@ -272,8 +272,8 @@ HELP: nweave
HELP: n*quot HELP: n*quot
{ $values { $values
{ "n" integer } { "seq" sequence } { "n" integer } { "quot" quotation }
{ "seq'" sequence } { "quot'" quotation }
} }
{ $examples { $examples
{ $example "USING: generalizations prettyprint math ;" { $example "USING: generalizations prettyprint math ;"

2
basis/generalizations/generalizations.factor
View File

@ -7,7 +7,7 @@ IN: generalizations
<< <<
: n*quot ( n seq -- seq' ) <repetition> concat >quotation ; : n*quot ( n quot -- seq' ) <repetition> concat >quotation ;
: repeat ( n obj quot -- ) swapd times ; inline : repeat ( n obj quot -- ) swapd times ; inline

2
basis/hash2/hash2-tests.factor
View File

@ -4,7 +4,7 @@ IN: hash2.tests
[ t ] [ 1 2 { 1 2 } 2= ] unit-test [ t ] [ 1 2 { 1 2 } 2= ] unit-test
[ f ] [ 1 3 { 1 2 } 2= ] unit-test [ f ] [ 1 3 { 1 2 } 2= ] unit-test
: sample-hash ( -- ) : sample-hash ( -- hash )
5 <hash2> 5 <hash2>
dup 2 3 "foo" roll set-hash2 dup 2 3 "foo" roll set-hash2
dup 4 2 "bar" roll set-hash2 dup 4 2 "bar" roll set-hash2

2
basis/heaps/heaps-tests.factor
View File

@ -54,7 +54,7 @@ IN: heaps.tests
: sort-entries ( entries -- entries' ) : sort-entries ( entries -- entries' )
[ [ key>> ] compare ] sort ; [ [ key>> ] compare ] sort ;
: delete-test ( n -- ? ) : delete-test ( n -- obj1 obj2 )
[ [
random-alist random-alist
<min-heap> [ heap-push-all ] keep <min-heap> [ heap-push-all ] keep

4
basis/help/crossref/crossref-tests.factor
View File

@ -4,7 +4,7 @@ definitions assocs sequences kernel namespaces parser arrays
io.streams.string continuations debugger compiler.units eval ; io.streams.string continuations debugger compiler.units eval ;
[ ] [ [ ] [
"IN: help.crossref.tests USING: help.syntax help.markup ; : foo ( -- ) ; HELP: foo \"foo is great\" ; ARTICLE: \"foo\" \"Foo\" { $subsection foo } ;" eval "IN: help.crossref.tests USING: help.syntax help.markup ; : foo ( -- ) ; HELP: foo \"foo is great\" ; ARTICLE: \"foo\" \"Foo\" { $subsection foo } ;" eval( -- )
] unit-test ] unit-test
[ $subsection ] [ [ $subsection ] [
@ -23,7 +23,7 @@ io.streams.string continuations debugger compiler.units eval ;
] unit-test ] unit-test
[ ] [ [ ] [
"IN: help.crossref.tests USING: help.syntax help.markup ; : bar ( -- ) ; HELP: bar \"bar is great\" ; ARTICLE: \"bar\" \"Bar\" { $subsection bar } ;" eval "IN: help.crossref.tests USING: help.syntax help.markup ; : bar ( -- ) ; HELP: bar \"bar is great\" ; ARTICLE: \"bar\" \"Bar\" { $subsection bar } ;" eval( -- )
] unit-test ] unit-test
[ ] [ [ ] [

2
basis/help/definitions/definitions-tests.factor
View File

@ -32,7 +32,7 @@ IN: help.definitions.tests
"hello" "help.definitions.tests" lookup "help" word-prop "hello" "help.definitions.tests" lookup "help" word-prop
] unit-test ] unit-test
[ ] [ "IN: help.definitions.tests USING: help.syntax ; : xxx ( -- ) ; HELP: xxx ;" eval ] unit-test [ ] [ "IN: help.definitions.tests USING: help.syntax ; : xxx ( -- ) ; HELP: xxx ;" eval( -- ) ] unit-test
[ ] [ "xxx" "help.definitions.tests" lookup print-topic ] unit-test [ ] [ "xxx" "help.definitions.tests" lookup print-topic ] unit-test

4
basis/help/syntax/syntax-tests.factor
View File

@ -4,12 +4,12 @@ IN: help.syntax.tests
[ [
[ "foobar" ] [ [ "foobar" ] [
"IN: help.syntax.tests USE: help.syntax ABOUT: \"foobar\"" eval "IN: help.syntax.tests USE: help.syntax ABOUT: \"foobar\"" eval( -- )
"help.syntax.tests" vocab vocab-help "help.syntax.tests" vocab vocab-help
] unit-test ] unit-test
[ { "foobar" } ] [ [ { "foobar" } ] [
"IN: help.syntax.tests USE: help.syntax ABOUT: { \"foobar\" }" eval "IN: help.syntax.tests USE: help.syntax ABOUT: { \"foobar\" }" eval( -- )
"help.syntax.tests" vocab vocab-help "help.syntax.tests" vocab vocab-help
] unit-test ] unit-test

2
basis/help/topics/topics-tests.factor
View File

@ -29,7 +29,7 @@ SYMBOL: foo
} "\n" join } "\n" join
[ [
"testfile" source-file file set "testfile" source-file file set
eval eval( -- )
] with-scope ] with-scope
] unit-test ] unit-test

8
basis/io/crlf/crlf-tests.factor Normal file
View File

@ -0,0 +1,8 @@
IN: io.crlf.tests
USING: io.crlf tools.test io.streams.string io ;
[ "Hello, world." ] [ "Hello, world." [ read-crlf ] with-string-reader ] unit-test
[ "Hello, world." ] [ "Hello, world.\r\n" [ read-crlf ] with-string-reader ] unit-test
[ "Hello, world.\r" [ read-crlf ] with-string-reader ] must-fail
[ f ] [ "" [ read-crlf ] with-string-reader ] unit-test
[ "" ] [ "\r\n" [ read-crlf ] with-string-reader ] unit-test

4
basis/io/crlf/crlf.factor
View File

@ -1,6 +1,6 @@
! Copyright (C) 2009 Daniel Ehrenberg, Slava Pestov ! Copyright (C) 2009 Daniel Ehrenberg, Slava Pestov
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: io kernel ; USING: io kernel sequences ;
IN: io.crlf IN: io.crlf
: crlf ( -- ) : crlf ( -- )
@ -8,4 +8,4 @@ IN: io.crlf
: read-crlf ( -- seq ) : read-crlf ( -- seq )
"\r" read-until "\r" read-until
[ CHAR: \r assert= read1 CHAR: \n assert= ] when* ; [ CHAR: \r assert= read1 CHAR: \n assert= ] [ f like ] if* ;

8
basis/io/launcher/windows/nt/nt-tests.factor
View File

@ -98,7 +98,7 @@ IN: io.launcher.windows.nt.tests
<process> <process>
console-vm "-script" "env.factor" 3array >>command console-vm "-script" "env.factor" 3array >>command
ascii <process-reader> contents ascii <process-reader> contents
] with-directory eval ] with-directory eval( -- alist )
os-envs = os-envs =
] unit-test ] unit-test
@ -110,7 +110,7 @@ IN: io.launcher.windows.nt.tests
+replace-environment+ >>environment-mode +replace-environment+ >>environment-mode
os-envs >>environment os-envs >>environment
ascii <process-reader> contents ascii <process-reader> contents
] with-directory eval ] with-directory eval( -- alist )
os-envs = os-envs =
] unit-test ] unit-test
@ -121,7 +121,7 @@ IN: io.launcher.windows.nt.tests
console-vm "-script" "env.factor" 3array >>command console-vm "-script" "env.factor" 3array >>command
{ { "A" "B" } } >>environment { { "A" "B" } } >>environment
ascii <process-reader> contents ascii <process-reader> contents
] with-directory eval ] with-directory eval( -- alist )
"A" swap at "A" swap at
] unit-test ] unit-test
@ -133,7 +133,7 @@ IN: io.launcher.windows.nt.tests
{ { "USERPROFILE" "XXX" } } >>environment { { "USERPROFILE" "XXX" } } >>environment
+prepend-environment+ >>environment-mode +prepend-environment+ >>environment-mode
ascii <process-reader> contents ascii <process-reader> contents
] with-directory eval ] with-directory eval( -- alist )
"USERPROFILE" swap at "XXX" = "USERPROFILE" swap at "XXX" =
] unit-test ] unit-test

4
basis/listener/listener-tests.factor
View File

@ -25,7 +25,7 @@ SYNTAX: hello "Hi" print ;
"\\ + 1 2 3 4" parse-interactive "\\ + 1 2 3 4" parse-interactive
"cont" get continue-with "cont" get continue-with
] ignore-errors ] ignore-errors
"USE: debugger :1" eval "USE: debugger :1" eval( -- quot )
] callcc1 ] callcc1
] unit-test ] unit-test
] with-file-vocabs ] with-file-vocabs
@ -50,7 +50,7 @@ SYNTAX: hello "Hi" print ;
[ [
[ ] [ [ ] [
"IN: listener.tests : hello ( -- )\n\"world\" ;" parse-interactive "IN: listener.tests : hello ( -- string )\n\"world\" ;" parse-interactive
drop drop
] unit-test ] unit-test
] with-file-vocabs ] with-file-vocabs

26
basis/locals/locals-tests.factor
View File

@ -261,7 +261,7 @@ M:: fixnum next-method-test ( a -- b ) a call-next-method 1 + ;
CONSTANT: new-definition "USING: math ;\nIN: locals.tests\n: a-word-with-locals ( -- x ) 2 3 + ;\n" CONSTANT: new-definition "USING: math ;\nIN: locals.tests\n: a-word-with-locals ( -- x ) 2 3 + ;\n"
[ ] [ new-definition eval ] unit-test [ ] [ new-definition eval( -- ) ] unit-test
[ t ] [ [ t ] [
[ \ a-word-with-locals see ] with-string-writer [ \ a-word-with-locals see ] with-string-writer
@ -461,7 +461,7 @@ M:: integer lambda-method-forget-test ( a -- b ) ;
[ [
"USING: locals fry math ; 1 '[ [let | A [ 10 ] | A _ + ] ]" "USING: locals fry math ; 1 '[ [let | A [ 10 ] | A _ + ] ]"
eval call eval( -- ) call
] [ error>> >r/r>-in-fry-error? ] must-fail-with ] [ error>> >r/r>-in-fry-error? ] must-fail-with
:: (funny-macro-test) ( obj quot -- ? ) obj { quot } 1&& ; inline :: (funny-macro-test) ( obj quot -- ? ) obj { quot } 1&& ; inline
@ -473,10 +473,10 @@ M:: integer lambda-method-forget-test ( a -- b ) ;
[ f ] [ 2 funny-macro-test ] unit-test [ f ] [ 2 funny-macro-test ] unit-test
! Some odd parser corner cases ! Some odd parser corner cases
[ "USE: locals [let" eval ] [ error>> unexpected-eof? ] must-fail-with [ "USE: locals [let" eval( -- ) ] [ error>> unexpected-eof? ] must-fail-with
[ "USE: locals [let |" eval ] [ error>> unexpected-eof? ] must-fail-with [ "USE: locals [let |" eval( -- ) ] [ error>> unexpected-eof? ] must-fail-with
[ "USE: locals [let | a" eval ] [ error>> unexpected-eof? ] must-fail-with [ "USE: locals [let | a" eval( -- ) ] [ error>> unexpected-eof? ] must-fail-with
[ "USE: locals [|" eval ] [ error>> unexpected-eof? ] must-fail-with [ "USE: locals [|" eval( -- ) ] [ error>> unexpected-eof? ] must-fail-with
[ 25 ] [ 5 [| a | { [ a sq ] } cond ] call ] unit-test [ 25 ] [ 5 [| a | { [ a sq ] } cond ] call ] unit-test
[ 25 ] [ 5 [| | { [| a | a sq ] } ] call first call ] unit-test [ 25 ] [ 5 [| | { [| a | a sq ] } ] call first call ] unit-test
@ -491,19 +491,19 @@ M:: integer lambda-method-forget-test ( a -- b ) ;
[ 3 ] [ 3 [| a | \ a ] call ] unit-test [ 3 ] [ 3 [| a | \ a ] call ] unit-test
[ "USE: locals [| | { [let | a [ 0 ] | a ] } ]" eval ] must-fail [ "USE: locals [| | { [let | a [ 0 ] | a ] } ]" eval( -- ) ] must-fail
[ "USE: locals [| | { [wlet | a [ 0 ] | a ] } ]" eval ] must-fail [ "USE: locals [| | { [wlet | a [ 0 ] | a ] } ]" eval( -- ) ] must-fail
[ "USE: locals [| | { [let* | a [ 0 ] | a ] } ]" eval ] must-fail [ "USE: locals [| | { [let* | a [ 0 ] | a ] } ]" eval( -- ) ] must-fail
[ "USE: locals [| | [let | a! [ 0 ] | { a! } ] ]" eval ] must-fail [ "USE: locals [| | [let | a! [ 0 ] | { a! } ] ]" eval( -- ) ] must-fail
[ "USE: locals [| | [wlet | a [ 0 ] | { a } ] ]" eval ] must-fail [ "USE: locals [| | [wlet | a [ 0 ] | { a } ] ]" eval( -- ) ] must-fail
[ "USE: locals [| | { :> a } ]" eval ] must-fail [ "USE: locals [| | { :> a } ]" eval( -- ) ] must-fail
[ "USE: locals 3 :> a" eval ] must-fail [ "USE: locals 3 :> a" eval( -- ) ] must-fail
[ 3 ] [ 3 [| | :> a a ] call ] unit-test [ 3 ] [ 3 [| | :> a a ] call ] unit-test

4
basis/macros/macros-tests.factor
View File

@ -13,11 +13,11 @@ unit-test
[ t ] [ \ see-test macro? ] unit-test [ t ] [ \ see-test macro? ] unit-test
[ t ] [ [ t ] [
"USING: math ;\nIN: macros.tests\n: see-test ( a b -- c ) - ;\n" dup eval "USING: math ;\nIN: macros.tests\n: see-test ( a b -- c ) - ;\n" dup eval( -- )
[ \ see-test see ] with-string-writer = [ \ see-test see ] with-string-writer =
] unit-test ] unit-test
[ f ] [ \ see-test macro? ] unit-test [ f ] [ \ see-test macro? ] unit-test
[ ] [ "USING: macros stack-checker kernel ; IN: hanging-macro MACRO: c ( quot -- ) infer drop [ ] ; : a ( -- ) [ a ] c ;" eval ] unit-test [ ] [ "USING: macros stack-checker kernel ; IN: hanging-macro MACRO: c ( quot -- ) infer drop [ ] ; : a ( -- ) [ a ] c ;" eval( -- ) ] unit-test

18
basis/math/intervals/intervals-tests.factor
View File

@ -255,11 +255,11 @@ IN: math.intervals.tests
0 pick interval-contains? over first \ recip eq? and [ 0 pick interval-contains? over first \ recip eq? and [
2drop t 2drop t
] [ ] [
[ [ random-element ] dip first execute ] 2keep [ [ random-element ] dip first execute( a -- b ) ] 2keep
second execute interval-contains? second execute( a -- b ) interval-contains?
] if ; ] if ;
[ t ] [ 80000 [ drop unary-test ] all? ] unit-test [ t ] [ 80000 iota [ drop unary-test ] all? ] unit-test
: random-binary-op ( -- pair ) : random-binary-op ( -- pair )
{ {
@ -286,11 +286,11 @@ IN: math.intervals.tests
0 pick interval-contains? over first { / /i mod rem } member? and [ 0 pick interval-contains? over first { / /i mod rem } member? and [
3drop t 3drop t
] [ ] [
[ [ [ random-element ] bi@ ] dip first execute ] 3keep [ [ [ random-element ] bi@ ] dip first execute( a b -- c ) ] 3keep
second execute interval-contains? second execute( a b -- c ) interval-contains?
] if ; ] if ;
[ t ] [ 80000 [ drop binary-test ] all? ] unit-test [ t ] [ 80000 iota [ drop binary-test ] all? ] unit-test
: random-comparison ( -- pair ) : random-comparison ( -- pair )
{ {
@ -305,7 +305,7 @@ IN: math.intervals.tests
[ [ [ random-element ] bi@ ] dip first execute ] 3keep [ [ [ random-element ] bi@ ] dip first execute ] 3keep
second execute dup incomparable eq? [ 2drop t ] [ = ] if ; second execute dup incomparable eq? [ 2drop t ] [ = ] if ;
[ t ] [ 40000 [ drop comparison-test ] all? ] unit-test [ t ] [ 40000 iota [ drop comparison-test ] all? ] unit-test
[ t ] [ -10 10 [a,b] 0 100 [a,b] assume> 0 10 (a,b] = ] unit-test [ t ] [ -10 10 [a,b] 0 100 [a,b] assume> 0 10 (a,b] = ] unit-test
@ -322,7 +322,7 @@ IN: math.intervals.tests
[ t ] [ -10 10 [a,b] interval-abs 0 10 [a,b] = ] unit-test [ t ] [ -10 10 [a,b] interval-abs 0 10 [a,b] = ] unit-test
! Test that commutative interval ops really are ! Test that commutative interval ops really are
: random-interval-or-empty ( -- ) : random-interval-or-empty ( -- obj )
10 random 0 = [ empty-interval ] [ random-interval ] if ; 10 random 0 = [ empty-interval ] [ random-interval ] if ;
: random-commutative-op ( -- op ) : random-commutative-op ( -- op )
@ -333,7 +333,7 @@ IN: math.intervals.tests
} random ; } random ;
[ t ] [ [ t ] [
80000 [ 80000 iota [
drop drop
random-interval-or-empty random-interval-or-empty random-interval-or-empty random-interval-or-empty
random-commutative-op random-commutative-op

4
basis/memoize/memoize-tests.factor
View File

@ -9,7 +9,7 @@ MEMO: fib ( m -- n )
[ 89 ] [ 10 fib ] unit-test [ 89 ] [ 10 fib ] unit-test
[ "USING: kernel math memoize generalizations ; IN: memoize.tests MEMO: x ( a b c d e -- f g h i j ) [ 1+ ] 4 ndip ;" eval ] must-fail [ "USING: kernel math memoize generalizations ; IN: memoize.tests MEMO: x ( a b c d e -- f g h i j ) [ 1+ ] 4 ndip ;" eval( -- ) ] must-fail
MEMO: see-test ( a -- b ) reverse ; MEMO: see-test ( a -- b ) reverse ;
@ -17,7 +17,7 @@ MEMO: see-test ( a -- b ) reverse ;
[ [ \ see-test see ] with-string-writer ] [ [ \ see-test see ] with-string-writer ]
unit-test unit-test
[ ] [ "IN: memoize.tests : fib ( -- ) ;" eval ] unit-test [ ] [ "IN: memoize.tests : fib ( -- ) ;" eval( -- ) ] unit-test
[ "IN: memoize.tests\n: fib ( -- ) ;\n" ] [ [ \ fib see ] with-string-writer ] unit-test [ "IN: memoize.tests\n: fib ( -- ) ;\n" ] [ [ \ fib see ] with-string-writer ] unit-test

2
basis/mirrors/mirrors-tests.factor
View File

@ -56,6 +56,6 @@ TUPLE: color
! Test reshaping with a mirror ! Test reshaping with a mirror
1 2 3 color boa <mirror> "mirror" set 1 2 3 color boa <mirror> "mirror" set
[ ] [ "IN: mirrors.tests USE: math TUPLE: color { green integer } { red integer } { blue integer } ;" eval ] unit-test [ ] [ "IN: mirrors.tests USE: math TUPLE: color { green integer } { red integer } { blue integer } ;" eval( -- ) ] unit-test
[ 1 ] [ "red" "mirror" get at ] unit-test [ 1 ] [ "red" "mirror" get at ] unit-test

10
basis/peg/ebnf/ebnf-tests.factor
View File

@ -444,12 +444,12 @@ foo=<foreign any-char> 'd'
"ad" parser4 "ad" parser4
] unit-test ] unit-test
{ t } [ { } [
"USING: kernel peg.ebnf ; \"a\\n\" [EBNF foo='a' '\n' => [[ drop \"\n\" ]] EBNF]" eval drop t "USING: kernel peg.ebnf ; \"a\\n\" [EBNF foo='a' '\n' => [[ drop \"\n\" ]] EBNF] drop" eval( -- )
] unit-test ] unit-test
[ [
"USING: peg.ebnf ; <EBNF foo='a' foo='b' EBNF>" eval drop "USING: peg.ebnf ; <EBNF foo='a' foo='b' EBNF>" eval( -- ) drop
] must-fail ] must-fail
{ t } [ { t } [
@ -521,12 +521,12 @@ Tok = Spaces (Number | Special )
"\\" [EBNF foo="\\" EBNF] "\\" [EBNF foo="\\" EBNF]
] unit-test ] unit-test
[ "USE: peg.ebnf [EBNF EBNF]" eval ] must-fail [ "USE: peg.ebnf [EBNF EBNF]" eval( -- ) ] must-fail
[ <" USE: peg.ebnf [EBNF [ <" USE: peg.ebnf [EBNF
lol = a lol = a
lol = b lol = b
EBNF] "> eval EBNF] "> eval( -- )
] [ ] [
error>> [ redefined-rule? ] [ name>> "lol" = ] bi and error>> [ redefined-rule? ] [ name>> "lol" = ] bi and
] must-fail-with ] must-fail-with

6
basis/persistent/hashtables/hashtables-tests.factor
View File

@ -83,7 +83,7 @@ M: hash-0-b hashcode* 2drop 0 ;
: random-string ( -- str ) : random-string ( -- str )
1000000 random ; ! [ CHAR: a CHAR: z [a,b] random ] "" replicate-as ; 1000000 random ; ! [ CHAR: a CHAR: z [a,b] random ] "" replicate-as ;
: random-assocs ( -- hash phash ) : random-assocs ( n -- hash phash )
[ random-string ] replicate [ random-string ] replicate
[ H{ } clone [ '[ swap _ set-at ] each-index ] keep ] [ H{ } clone [ '[ swap _ set-at ] each-index ] keep ]
[ PH{ } clone swap [ spin new-at ] each-index ] [ PH{ } clone swap [ spin new-at ] each-index ]
@ -92,7 +92,7 @@ M: hash-0-b hashcode* 2drop 0 ;
: ok? ( assoc1 assoc2 -- ? ) : ok? ( assoc1 assoc2 -- ? )
[ assoc= ] [ [ assoc-size ] bi@ = ] 2bi and ; [ assoc= ] [ [ assoc-size ] bi@ = ] 2bi and ;
: test-persistent-hashtables-1 ( n -- ) : test-persistent-hashtables-1 ( n -- ? )
random-assocs ok? ; random-assocs ok? ;
[ t ] [ 10 test-persistent-hashtables-1 ] unit-test [ t ] [ 10 test-persistent-hashtables-1 ] unit-test
@ -106,7 +106,7 @@ M: hash-0-b hashcode* 2drop 0 ;
[ t ] [ 10000 test-persistent-hashtables-1 ] unit-test [ t ] [ 10000 test-persistent-hashtables-1 ] unit-test
[ t ] [ 50000 test-persistent-hashtables-1 ] unit-test [ t ] [ 50000 test-persistent-hashtables-1 ] unit-test
: test-persistent-hashtables-2 ( n -- ) : test-persistent-hashtables-2 ( n -- ? )
random-assocs random-assocs
dup keys [ dup keys [
[ nip over delete-at ] [ swap pluck-at nip ] 3bi [ nip over delete-at ] [ swap pluck-at nip ] 3bi

28
basis/prettyprint/prettyprint-tests.factor
View File

@ -2,8 +2,8 @@ USING: arrays definitions io.streams.string io.streams.duplex
kernel math namespaces parser prettyprint prettyprint.config kernel math namespaces parser prettyprint prettyprint.config
prettyprint.sections sequences tools.test vectors words prettyprint.sections sequences tools.test vectors words
effects splitting generic.standard prettyprint.private effects splitting generic.standard prettyprint.private
continuations generic compiler.units tools.walker eval continuations generic compiler.units tools.continuations
accessors make vocabs.parser see ; tools.continuations.private eval accessors make vocabs.parser see ;
IN: prettyprint.tests IN: prettyprint.tests
[ "4" ] [ 4 unparse ] unit-test [ "4" ] [ 4 unparse ] unit-test
@ -90,7 +90,7 @@ unit-test
[ \ blah see ] with-string-writer "\n" ?tail drop 6 tail* [ \ blah see ] with-string-writer "\n" ?tail drop 6 tail*
] unit-test ] unit-test
: check-see ( expect name -- ) : check-see ( expect name -- ? )
[ [
use [ clone ] change use [ clone ] change
@ -105,6 +105,7 @@ unit-test
GENERIC: method-layout ( a -- b ) GENERIC: method-layout ( a -- b )
M: complex method-layout M: complex method-layout
drop
"aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
; ;
@ -116,8 +117,9 @@ M: object method-layout ;
[ [
{ {
"USING: math prettyprint.tests ;" "USING: kernel math prettyprint.tests ;"
"M: complex method-layout" "M: complex method-layout"
" drop"
" \"aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa\"" " \"aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa\""
" ;" " ;"
"" ""
@ -180,15 +182,15 @@ DEFER: parse-error-file
"string-layout-test" string-layout check-see "string-layout-test" string-layout check-see
] unit-test ] unit-test
: narrow-test ( -- str ) : narrow-test ( -- array )
{ {
"USING: arrays combinators continuations kernel sequences ;" "USING: arrays combinators continuations kernel sequences ;"
"IN: prettyprint.tests" "IN: prettyprint.tests"
": narrow-layout ( obj -- )" ": narrow-layout ( obj1 obj2 -- obj3 )"
" {" " {"
" { [ dup continuation? ] [ append ] }" " { [ dup continuation? ] [ append ] }"
" { [ dup not ] [ drop reverse ] }" " { [ dup not ] [ drop reverse ] }"
" { [ dup pair? ] [ delete ] }" " { [ dup pair? ] [ [ delete ] keep ] }"
" } cond ;" " } cond ;"
} ; } ;
@ -196,7 +198,7 @@ DEFER: parse-error-file
"narrow-layout" narrow-test check-see "narrow-layout" narrow-test check-see
] unit-test ] unit-test
: another-narrow-test ( -- str ) : another-narrow-test ( -- array )
{ {
"IN: prettyprint.tests" "IN: prettyprint.tests"
": another-narrow-layout ( -- obj )" ": another-narrow-layout ( -- obj )"
@ -252,18 +254,14 @@ M: class-see-layout class-see-layout ;
! Regression ! Regression
[ t ] [ [ t ] [
"IN: prettyprint.tests\nGENERIC: generic-decl-test ( a -- b ) flushable\n" "IN: prettyprint.tests\nGENERIC: generic-decl-test ( a -- b ) flushable\n"
dup eval dup eval( -- )
"generic-decl-test" "prettyprint.tests" lookup "generic-decl-test" "prettyprint.tests" lookup
[ see ] with-string-writer = [ see ] with-string-writer =
] unit-test ] unit-test
[ [ + ] ] [ [ [ + ] ] [ [ \ + (step-into-execute) ] (remove-breakpoints) ] unit-test
[ \ + (step-into-execute) ] (remove-breakpoints)
] unit-test
[ [ (step-into-execute) ] ] [ [ [ (step-into-execute) ] ] [ [ (step-into-execute) ] (remove-breakpoints) ] unit-test
[ (step-into-execute) ] (remove-breakpoints)
] unit-test
[ [ 2 2 + . ] ] [ [ [ 2 2 + . ] ] [
[ 2 2 \ + (step-into-execute) . ] (remove-breakpoints) [ 2 2 \ + (step-into-execute) . ] (remove-breakpoints)

2
basis/random/mersenne-twister/mersenne-twister-tests.factor
View File

@ -11,7 +11,7 @@ IN: random.mersenne-twister.tests
100 [ 100 random ] replicate ; 100 [ 100 random ] replicate ;
: test-rng ( seed quot -- ) : test-rng ( seed quot -- )
[ <mersenne-twister> ] dip with-random ; [ <mersenne-twister> ] dip with-random ; inline
[ f ] [ 1234 [ randoms randoms = ] test-rng ] unit-test [ f ] [ 1234 [ randoms randoms = ] test-rng ] unit-test

2
basis/regexp/parser/parser-tests.factor
View File

@ -4,7 +4,7 @@ IN: regexp.parser.tests
: regexp-parses ( string -- ) : regexp-parses ( string -- )
[ [ ] ] dip '[ _ parse-regexp drop ] unit-test ; [ [ ] ] dip '[ _ parse-regexp drop ] unit-test ;
: regexp-fails ( string -- ) : regexp-fails ( string -- regexp )
'[ _ parse-regexp ] must-fail ; '[ _ parse-regexp ] must-fail ;
{ {

6
basis/regexp/regexp-tests.factor
View File

@ -262,11 +262,11 @@ IN: regexp-tests
! Comment inside a regular expression ! Comment inside a regular expression
[ t ] [ "ac" "a(?#boo)c" <regexp> matches? ] unit-test [ t ] [ "ac" "a(?#boo)c" <regexp> matches? ] unit-test
[ ] [ "USING: regexp kernel ; R' -{3}[+]{1,6}(?:!!)?\\s' drop" eval ] unit-test [ ] [ "USING: regexp kernel ; R' -{3}[+]{1,6}(?:!!)?\\s' drop" eval( -- ) ] unit-test
[ ] [ "USING: regexp kernel ; R' (ftp|http|https)://(\\w+:?\\w*@)?(\\S+)(:[0-9]+)?(/|/([\\w#!:.?+=&%@!\\-/]))?' drop" eval ] unit-test [ ] [ "USING: regexp kernel ; R' (ftp|http|https)://(\\w+:?\\w*@)?(\\S+)(:[0-9]+)?(/|/([\\w#!:.?+=&%@!\\-/]))?' drop" eval( -- ) ] unit-test
[ ] [ "USING: regexp kernel ; R' \\*[^\s*][^*]*\\*' drop" eval ] unit-test [ ] [ "USING: regexp kernel ; R' \\*[^\s*][^*]*\\*' drop" eval( -- ) ] unit-test
[ "ab" ] [ "ab" "(a|ab)(bc)?" <regexp> first-match >string ] unit-test [ "ab" ] [ "ab" "(a|ab)(bc)?" <regexp> first-match >string ] unit-test
[ "abc" ] [ "abc" "(a|ab)(bc)?" <regexp> first-match >string ] unit-test [ "abc" ] [ "abc" "(a|ab)(bc)?" <regexp> first-match >string ] unit-test

2
basis/smtp/authors.txt
View File

@ -1,3 +1,5 @@
Elie Chaftari Elie Chaftari
Dirk Vleugels Dirk Vleugels
Slava Pestov Slava Pestov
Doug Coleman
Daniel Ehrenberg

1
basis/smtp/server/server.factor
View File

@ -36,6 +36,7 @@ SYMBOL: data-mode
: process ( -- ) : process ( -- )
read-crlf { read-crlf {
{ [ dup not ] [ f ] }
{ {
[ dup [ "HELO" head? ] [ "EHLO" head? ] bi or ] [ dup [ "HELO" head? ] [ "EHLO" head? ] bi or ]
[ "220 and..?\r\n" write flush t ] [ "220 and..?\r\n" write flush t ]

6
basis/smtp/smtp-docs.factor
View File

@ -1,7 +1,7 @@
! Copyright (C) 2008 Doug Coleman. ! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: accessors kernel quotations help.syntax help.markup USING: accessors kernel quotations help.syntax help.markup
io.sockets strings calendar ; io.sockets strings calendar io.encodings.utf8 ;
IN: smtp IN: smtp
HELP: smtp-domain HELP: smtp-domain
@ -41,7 +41,9 @@ HELP: email
{ { $slot "to" } "The recipients of the e-mail. A sequence of e-mail addresses." } { { $slot "to" } "The recipients of the e-mail. A sequence of e-mail addresses." }
{ { $slot "cc" } "Carbon-copy. A sequence of e-mail addresses." } { { $slot "cc" } "Carbon-copy. A sequence of e-mail addresses." }
{ { $slot "bcc" } "Blind carbon-copy. A sequence of e-mail addresses." } { { $slot "bcc" } "Blind carbon-copy. A sequence of e-mail addresses." }
{ { $slot "subject" } " The subject of the e-mail. A string." } { { $slot "subject" } "The subject of the e-mail. A string." }
{ { $slot "content-type" } { "The MIME type of the body. A string, default is " { $snippet "text/plain" } "." } }
{ { $slot "encoding" } { "An encoding to send the body as. Default is " { $link utf8 } "." } }
{ { $slot "body" } " The body of the e-mail. A string." } { { $slot "body" } " The body of the e-mail. A string." }
} }
"The " { $slot "from" } " and " { $slot "to" } " slots are required; the rest are optional." "The " { $slot "from" } " and " { $slot "to" } " slots are required; the rest are optional."

4
basis/smtp/smtp-tests.factor
View File

@ -16,7 +16,7 @@ IN: smtp.tests
[ { "hello" "." "world" } validate-message ] must-fail [ { "hello" "." "world" } validate-message ] must-fail
[ "aGVsbG8Kd29ybGQ=\r\n.\r\n" ] [ [ "aGVsbG8Kd29ybGQ=\r\n.\r\n" ] [
"hello\nworld" [ send-body ] with-string-writer T{ email { body "hello\nworld" } } [ send-body ] with-string-writer
] unit-test ] unit-test
[ { "500 syntax error" } <response> check-response ] [ { "500 syntax error" } <response> check-response ]
@ -51,7 +51,7 @@ IN: smtp.tests
[ [
{ {
{ "Content-Transfer-Encoding" "base64" } { "Content-Transfer-Encoding" "base64" }
{ "Content-Type" "Text/plain; charset=utf-8" } { "Content-Type" "text/plain; charset=UTF-8" }
{ "From" "Doug <erg@factorcode.org>" } { "From" "Doug <erg@factorcode.org>" }
{ "MIME-Version" "1.0" } { "MIME-Version" "1.0" }
{ "Subject" "Factor rules" } { "Subject" "Factor rules" }

41
basis/smtp/smtp.factor
View File

@ -1,12 +1,12 @@
! Copyright (C) 2007, 2008 Elie CHAFTARI, Dirk Vleugels, ! Copyright (C) 2007, 2008 Elie CHAFTARI, Dirk Vleugels,
! Slava Pestov, Doug Coleman. ! Slava Pestov, Doug Coleman, Daniel Ehrenberg.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: arrays namespaces make io io.encodings.string USING: arrays namespaces make io io.encodings.string io.encodings.utf8
io.encodings.utf8 io.timeouts io.sockets io.sockets.secure io.encodings.iana io.timeouts io.sockets io.sockets.secure
io.encodings.ascii kernel logging sequences combinators io.encodings.ascii kernel logging sequences combinators splitting
splitting assocs strings math.order math.parser random system assocs strings math.order math.parser random system calendar summary
calendar summary calendar.format accessors sets hashtables calendar.format accessors sets hashtables base64 debugger classes
base64 debugger classes prettyprint io.crlf ; prettyprint io.crlf words ;
IN: smtp IN: smtp
SYMBOL: smtp-domain SYMBOL: smtp-domain
@ -44,6 +44,8 @@ TUPLE: email
{ cc array } { cc array }
{ bcc array } { bcc array }
{ subject string } { subject string }
{ content-type string initial: "text/plain" }
{ encoding word initial: utf8 }
{ body string } ; { body string } ;
: <email> ( -- email ) email new ; inline : <email> ( -- email ) email new ; inline
@ -85,8 +87,8 @@ M: message-contains-dot summary ( obj -- string )
"." over member? "." over member?
[ message-contains-dot ] when ; [ message-contains-dot ] when ;
: send-body ( body -- ) : send-body ( email -- )
utf8 encode [ body>> ] [ encoding>> ] bi encode
>base64-lines write crlf >base64-lines write crlf
"." command ; "." command ;
@ -195,24 +197,23 @@ ERROR: invalid-header-string string ;
! This could be much smarter. ! This could be much smarter.
" " split1-last swap or "<" ?head drop ">" ?tail drop ; " " split1-last swap or "<" ?head drop ">" ?tail drop ;
: utf8-mime-header ( -- alist ) : email-content-type ( email -- content-type )
{ [ content-type>> ] [ encoding>> encoding>name ] bi "; charset=" glue ;
{ "MIME-Version" "1.0" }
{ "Content-Transfer-Encoding" "base64" }
{ "Content-Type" "Text/plain; charset=utf-8" }
} ;
: email>headers ( email -- hashtable ) : email>headers ( email -- assoc )
[ [
now timestamp>rfc822 "Date" set
message-id "Message-Id" set
"1.0" "MIME-Version" set
"base64" "Content-Transfer-Encoding" set
{ {
[ from>> "From" set ] [ from>> "From" set ]
[ to>> ", " join "To" set ] [ to>> ", " join "To" set ]
[ cc>> ", " join [ "Cc" set ] unless-empty ] [ cc>> ", " join [ "Cc" set ] unless-empty ]
[ subject>> "Subject" set ] [ subject>> "Subject" set ]
[ email-content-type "Content-Type" set ]
} cleave } cleave
now timestamp>rfc822 "Date" set ] { } make-assoc ;
message-id "Message-Id" set
] { } make-assoc utf8-mime-header append ;
: (send-email) ( headers email -- ) : (send-email) ( headers email -- )
[ [
@ -227,7 +228,7 @@ ERROR: invalid-header-string string ;
data get-ok data get-ok
swap write-headers swap write-headers
crlf crlf
body>> send-body get-ok send-body get-ok
quit get-ok quit get-ok
] with-smtp-connection ; ] with-smtp-connection ;

4
basis/sorting/slots/slots-docs.factor
View File

@ -14,7 +14,7 @@ HELP: compare-slots
HELP: sort-by-slots HELP: sort-by-slots
{ $values { $values
{ "seq" sequence } { "sort-specs" "a sequence of accessors ending with a comparator" } { "seq" sequence } { "sort-specs" "a sequence of accessors ending with a comparator" }
{ "sortedseq" sequence } { "seq'" sequence }
} }
{ $description "Sorts a sequence of tuples by the sort-specs in " { $snippet "sort-spec" } ". A sort-spec is a sequence of slot accessors ending in a comparator." } { $description "Sorts a sequence of tuples by the sort-specs in " { $snippet "sort-spec" } ". A sort-spec is a sequence of slot accessors ending in a comparator." }
{ $examples { $examples
@ -42,7 +42,7 @@ HELP: split-by-slots
HELP: sort-by HELP: sort-by
{ $values { $values
{ "seq" sequence } { "sort-seq" "a sequence of comparators" } { "seq" sequence } { "sort-seq" "a sequence of comparators" }
{ "sortedseq" sequence } { "seq'" sequence }
} }
{ $description "Sorts a sequence by comparing elements by comparators, using subsequent comparators when there is a tie." } ; { $description "Sorts a sequence by comparing elements by comparators, using subsequent comparators when there is a tie." } ;

12
basis/sorting/slots/slots-tests.factor
View File

@ -159,3 +159,15 @@ TUPLE: tuple2 d ;
{ { 3 2 1 } { 1 2 3 } { 1 3 2 } { 1 } } { { 3 2 1 } { 1 2 3 } { 1 3 2 } { 1 } }
{ length-test<=> <=> } sort-by { length-test<=> <=> } sort-by
] unit-test ] unit-test
[ { { 0 1 } { 1 2 } { 1 1 } { 3 2 } } ]
[
{ { 3 2 } { 1 2 } { 0 1 } { 1 1 } }
{ length-test<=> <=> } sort-keys-by
] unit-test
[ { { 0 1 } { 1 1 } { 3 2 } { 1 2 } } ]
[
{ { 3 2 } { 1 2 } { 0 1 } { 1 1 } }
{ length-test<=> <=> } sort-values-by
] unit-test

20
basis/sorting/slots/slots.factor
View File

@ -8,12 +8,13 @@ IN: sorting.slots
<PRIVATE <PRIVATE
: short-circuit-comparator ( obj1 obj2 word -- comparator/? ) : short-circuit-comparator ( obj1 obj2 word -- comparator/? )
execute dup +eq+ eq? [ drop f ] when ; inline execute( obj1 obj2 -- obj3 )
dup +eq+ eq? [ drop f ] when ; inline
: slot-comparator ( seq -- quot ) : slot-comparator ( seq -- quot )
[ [
but-last-slice but-last-slice
[ '[ [ _ execute ] bi@ ] ] map concat [ '[ [ _ execute( tuple -- value ) ] bi@ ] ] map concat
] [ ] [
peek peek
'[ @ _ short-circuit-comparator ] '[ @ _ short-circuit-comparator ]
@ -25,21 +26,22 @@ MACRO: compare-slots ( sort-specs -- <=> )
#! sort-spec: { accessors comparator } #! sort-spec: { accessors comparator }
[ slot-comparator ] map '[ _ 2|| +eq+ or ] ; [ slot-comparator ] map '[ _ 2|| +eq+ or ] ;
MACRO: sort-by-slots ( sort-specs -- quot ) : sort-by-slots ( seq sort-specs -- seq' )
'[ [ _ compare-slots ] sort ] ; '[ _ compare-slots ] sort ;
MACRO: compare-seq ( seq -- quot ) MACRO: compare-seq ( seq -- quot )
[ '[ _ short-circuit-comparator ] ] map '[ _ 2|| +eq+ or ] ; [ '[ _ short-circuit-comparator ] ] map '[ _ 2|| +eq+ or ] ;
MACRO: sort-by ( sort-seq -- quot ) : sort-by ( seq sort-seq -- seq' )
'[ [ _ compare-seq ] sort ] ; '[ _ compare-seq ] sort ;
MACRO: sort-keys-by ( sort-seq -- quot ) : sort-keys-by ( seq sort-seq -- seq' )
'[ [ first ] bi@ _ compare-seq ] sort ; '[ [ first ] bi@ _ compare-seq ] sort ;
MACRO: sort-values-by ( sort-seq -- quot ) : sort-values-by ( seq sort-seq -- seq' )
'[ [ second ] bi@ _ compare-seq ] sort ; '[ [ second ] bi@ _ compare-seq ] sort ;
MACRO: split-by-slots ( accessor-seqs -- quot ) MACRO: split-by-slots ( accessor-seqs -- quot )
[ [ '[ [ _ execute ] bi@ ] ] map concat [ = ] compose ] map [ [ '[ [ _ execute( tuple -- value ) ] bi@ ] ] map concat
[ = ] compose ] map
'[ [ _ 2&& ] slice monotonic-slice ] ; '[ [ _ 2&& ] slice monotonic-slice ] ;

4
basis/stack-checker/stack-checker-tests.factor
View File

@ -524,7 +524,7 @@ ERROR: custom-error ;
{ 2 1 } [ [ + ] inference-invalidation-b ] must-infer-as { 2 1 } [ [ + ] inference-invalidation-b ] must-infer-as
[ ] [ "IN: stack-checker.tests : inference-invalidation-a ( -- a b ) 1 2 ;" eval ] unit-test [ ] [ "IN: stack-checker.tests : inference-invalidation-a ( -- a b ) 1 2 ;" eval( -- ) ] unit-test
[ 3 ] [ inference-invalidation-c ] unit-test [ 3 ] [ inference-invalidation-c ] unit-test
@ -536,7 +536,7 @@ M: object inference-invalidation-d inference-invalidation-c 2drop ;
\ inference-invalidation-d must-infer \ inference-invalidation-d must-infer
[ ] [ "IN: stack-checker.tests : inference-invalidation-a ( -- ) ;" eval ] unit-test [ ] [ "IN: stack-checker.tests : inference-invalidation-a ( -- ) ;" eval( -- ) ] unit-test
[ [ inference-invalidation-d ] infer ] must-fail [ [ inference-invalidation-d ] infer ] must-fail

2
basis/threads/threads-tests.factor
View File

@ -31,7 +31,7 @@ yield
[ [ 3 throw ] "A" suspend ] [ 3 = ] must-fail-with [ [ 3 throw ] "A" suspend ] [ 3 = ] must-fail-with
:: spawn-namespace-test ( -- ) :: spawn-namespace-test ( -- ? )
[let | p [ <promise> ] g [ gensym ] | [let | p [ <promise> ] g [ gensym ] |
[ [
g "x" set g "x" set

4
basis/tools/annotations/annotations-tests.factor
View File

@ -18,7 +18,7 @@ M: integer some-generic 1+ ;
[ 4 ] [ 3 some-generic ] unit-test [ 4 ] [ 3 some-generic ] unit-test
[ ] [ "IN: tools.annotations.tests USE: math M: integer some-generic 1- ;" eval ] unit-test [ ] [ "IN: tools.annotations.tests USE: math M: integer some-generic 1- ;" eval( -- ) ] unit-test
[ 2 ] [ 3 some-generic ] unit-test [ 2 ] [ 3 some-generic ] unit-test
@ -33,7 +33,7 @@ M: object another-generic ;
\ another-generic watch \ another-generic watch
[ ] [ "IN: tools.annotations.tests GENERIC: another-generic ( a -- b )" eval ] unit-test [ ] [ "IN: tools.annotations.tests GENERIC: another-generic ( a -- b )" eval( -- ) ] unit-test
[ ] [ \ another-generic reset ] unit-test [ ] [ \ another-generic reset ] unit-test

12
basis/tools/deploy/shaker/shaker.factor
View File

@ -357,7 +357,7 @@ IN: tools.deploy.shaker
V{ } set-namestack V{ } set-namestack
V{ } set-catchstack V{ } set-catchstack
"Saving final image" show "Saving final image" show
[ save-image-and-exit ] call-clear ; save-image-and-exit ;
SYMBOL: deploy-vocab SYMBOL: deploy-vocab
@ -374,9 +374,9 @@ SYMBOL: deploy-vocab
[:c] [:c]
[print-error] [print-error]
'[ '[
[ _ execute ] [ [ _ execute( obj -- ) ] [
_ execute nl _ execute( obj -- ) nl
_ execute _ execute( obj -- )
] recover ] recover
] % ] %
] if ] if
@ -421,10 +421,10 @@ SYMBOL: deploy-vocab
: deploy-error-handler ( quot -- ) : deploy-error-handler ( quot -- )
[ [
strip-debugger? strip-debugger?
[ error-continuation get call>> callstack>array die ] [ error-continuation get call>> callstack>array die 1 exit ]
! Don't reference these words literally, if we're stripping the ! Don't reference these words literally, if we're stripping the
! debugger out we don't want to load the prettyprinter at all ! debugger out we don't want to load the prettyprinter at all
[ [:c] execute nl [print-error] execute flush ] if [ [:c] execute( -- ) nl [print-error] execute( error -- ) flush ] if
1 exit 1 exit
] recover ; inline ] recover ; inline

24
basis/tools/errors/errors.factor
View File

@ -7,29 +7,21 @@ IN: tools.errors
#! Tools for source-files.errors. Used by tools.tests and others #! Tools for source-files.errors. Used by tools.tests and others
#! for error reporting #! for error reporting
M: source-file-error summary
error>> summary ;
M: source-file-error compute-restarts M: source-file-error compute-restarts
error>> compute-restarts ; error>> compute-restarts ;
M: source-file-error error-help M: source-file-error error-help
error>> error-help ; error>> error-help ;
M: source-file-error error. M: source-file-error summary
[ [
[ [ file>> [ % ": " % ] [ "<Listener input>" % ] if* ]
[ [ line#>> [ # ] when* ] bi
[ file>> [ % ": " % ] when* ] ] "" make
[ line#>> [ # "\n" % ] when* ] bi ;
] "" make
] [ M: source-file-error error.
[ [ summary print nl ] [ error>> error. ] bi ;
presented set
bold font-style set
] H{ } make-assoc
] bi format
] [ error>> error. ] bi ;
: errors. ( errors -- ) : errors. ( errors -- )
group-by-source-file sort-errors group-by-source-file sort-errors

12
basis/tools/test/test.factor
View File

@ -129,13 +129,13 @@ TEST: must-infer
TEST: must-fail-with TEST: must-fail-with
TEST: must-fail TEST: must-fail
M: test-failure summary
asset>> [ [ experiment. ] with-string-writer ] [ "Top-level form" ] if* ;
M: test-failure error. ( error -- ) M: test-failure error. ( error -- )
[ call-next-method ] {
[ traceback-button. ] [ summary print nl ]
bi ; [ asset>> [ experiment. nl ] when* ]
[ error>> error. ]
[ traceback-button. ]
} cleave ;
: :test-failures ( -- ) test-failures get errors. ; : :test-failures ( -- ) test-failures get errors. ;

2
basis/ui/gadgets/paragraphs/paragraphs-tests.factor
View File

@ -27,7 +27,7 @@ INSTANCE: fake-break word-break
[ { 0 0 } ] [ "a" get loc>> ] unit-test [ { 0 0 } ] [ "a" get loc>> ] unit-test
[ { 45 15 } ] [ "b" get loc>> ] unit-test [ { 45 7 } ] [ "b" get loc>> ] unit-test
[ { 0 30 } ] [ "c" get loc>> ] unit-test [ { 0 30 } ] [ "c" get loc>> ] unit-test

4
basis/ui/tools/error-list/error-list.factor
View File

@ -26,7 +26,7 @@ MEMO: error-icon ( type -- image-name )
: <error-toggle> ( -- model gadget ) : <error-toggle> ( -- model gadget )
#! Linkage errors are not shown by default. #! Linkage errors are not shown by default.
error-types get keys [ dup +linkage-error+ eq? not <model> ] { } map>assoc error-types get [ fatal?>> <model> ] assoc-map
[ [ [ error-icon ] dip ] assoc-map <checkboxes> ] [ [ [ error-icon ] dip ] assoc-map <checkboxes> ]
[ <mapping> ] bi ; [ <mapping> ] bi ;
@ -80,7 +80,7 @@ M: error-renderer row-columns
{ {
[ error-type error-icon ] [ error-type error-icon ]
[ line#>> [ number>string ] [ "" ] if* ] [ line#>> [ number>string ] [ "" ] if* ]
[ asset>> unparse-short ] [ asset>> [ unparse-short ] [ "" ] if* ]
[ error>> summary ] [ error>> summary ]
} cleave } cleave
] output>array ; ] output>array ;

5
basis/ui/tools/listener/listener.factor
View File

@ -358,9 +358,8 @@ interactor "completion" f {
} define-command-map } define-command-map
: ui-error-summary ( -- ) : ui-error-summary ( -- )
all-errors [ error-counts keys [
[ error-type ] map prune [ icon>> 1array \ $image prefix " " 2array ] { } map-as
[ error-icon-path 1array \ $image prefix " " 2array ] { } map-as
{ "Press " { $command tool "common" show-error-list } " to view errors." } { "Press " { $command tool "common" show-error-list } " to view errors." }
append print-element nl append print-element nl
] unless-empty ; ] unless-empty ;

243
basis/windows/advapi32/advapi32.factor
View File

@ -1,5 +1,6 @@
USING: alien.syntax kernel math windows.types math.bitwise ; USING: alien.syntax kernel math windows.types math.bitwise ;
IN: windows.advapi32 IN: windows.advapi32
LIBRARY: advapi32 LIBRARY: advapi32
CONSTANT: PROV_RSA_FULL 1 CONSTANT: PROV_RSA_FULL 1
@ -122,6 +123,34 @@ C-STRUCT: ACCESS_ALLOWED_CALLBACK_ACE
TYPEDEF: ACCESS_ALLOWED_CALLBACK_ACE* PACCESS_ALLOWED_CALLBACK_ACE TYPEDEF: ACCESS_ALLOWED_CALLBACK_ACE* PACCESS_ALLOWED_CALLBACK_ACE
C-STRUCT: SECURITY_DESCRIPTOR
{ "UCHAR" "Revision" }
{ "UCHAR" "Sbz1" }
{ "WORD" "Control" }
{ "PVOID" "Owner" }
{ "PVOID" "Group" }
{ "PACL" "Sacl" }
{ "PACL" "Dacl" } ;
TYPEDEF: SECURITY_DESCRIPTOR* PSECURITY_DESCRIPTOR
CONSTANT: SE_OWNER_DEFAULTED 1
CONSTANT: SE_GROUP_DEFAULTED 2
CONSTANT: SE_DACL_PRESENT 4
CONSTANT: SE_DACL_DEFAULTED 8
CONSTANT: SE_SACL_PRESENT 16
CONSTANT: SE_SACL_DEFAULTED 32
CONSTANT: SE_DACL_AUTO_INHERIT_REQ 256
CONSTANT: SE_SACL_AUTO_INHERIT_REQ 512
CONSTANT: SE_DACL_AUTO_INHERITED 1024
CONSTANT: SE_SACL_AUTO_INHERITED 2048
CONSTANT: SE_DACL_PROTECTED 4096
CONSTANT: SE_SACL_PROTECTED 8192
CONSTANT: SE_SELF_RELATIVE 32768
TYPEDEF: DWORD SECURITY_DESCRIPTOR_CONTROL
TYPEDEF: SECURITY_DESCRIPTOR_CONTROL* PSECURITY_DESCRIPTOR_CONTROL
! typedef enum _TOKEN_INFORMATION_CLASS { ! typedef enum _TOKEN_INFORMATION_CLASS {
CONSTANT: TokenUser 1 CONSTANT: TokenUser 1
@ -141,6 +170,140 @@ CONSTANT: TokenSessionReference 14
CONSTANT: TokenSandBoxInert 15 CONSTANT: TokenSandBoxInert 15
! } TOKEN_INFORMATION_CLASS; ! } TOKEN_INFORMATION_CLASS;
TYPEDEF: DWORD ACCESS_MODE
C-ENUM:
NOT_USED_ACCESS
GRANT_ACCESS
SET_ACCESS
DENY_ACCESS
REVOKE_ACCESS
SET_AUDIT_SUCCESS
SET_AUDIT_FAILURE ;
TYPEDEF: DWORD MULTIPLE_TRUSTEE_OPERATION
C-ENUM:
NO_MULTIPLE_TRUSTEE
TRUSTEE_IS_IMPERSONATE ;
TYPEDEF: DWORD TRUSTEE_FORM
C-ENUM:
TRUSTEE_IS_SID
TRUSTEE_IS_NAME
TRUSTEE_BAD_FORM
TRUSTEE_IS_OBJECTS_AND_SID
TRUSTEE_IS_OBJECTS_AND_NAME ;
TYPEDEF: DWORD TRUSTEE_TYPE
C-ENUM:
TRUSTEE_IS_UNKNOWN
TRUSTEE_IS_USER
TRUSTEE_IS_GROUP
TRUSTEE_IS_DOMAIN
TRUSTEE_IS_ALIAS
TRUSTEE_IS_WELL_KNOWN_GROUP
TRUSTEE_IS_DELETED
TRUSTEE_IS_INVALID
TRUSTEE_IS_COMPUTER ;
TYPEDEF: DWORD SE_OBJECT_TYPE
C-ENUM:
SE_UNKNOWN_OBJECT_TYPE
SE_FILE_OBJECT
SE_SERVICE
SE_PRINTER
SE_REGISTRY_KEY
SE_LMSHARE
SE_KERNEL_OBJECT
SE_WINDOW_OBJECT
SE_DS_OBJECT
SE_DS_OBJECT_ALL
SE_PROVIDER_DEFINED_OBJECT
SE_WMIGUID_OBJECT
SE_REGISTRY_WOW64_32KEY ;
TYPEDEF: TRUSTEE* PTRUSTEE
C-STRUCT: TRUSTEE
{ "PTRUSTEE" "pMultipleTrustee" }
{ "MULTIPLE_TRUSTEE_OPERATION" "MultipleTrusteeOperation" }
{ "TRUSTEE_FORM" "TrusteeForm" }
{ "TRUSTEE_TYPE" "TrusteeType" }
{ "LPTSTR" "ptstrName" } ;
C-STRUCT: EXPLICIT_ACCESS
{ "DWORD" "grfAccessPermissions" }
{ "ACCESS_MODE" "grfAccessMode" }
{ "DWORD" "grfInheritance" }
{ "TRUSTEE" "Trustee" } ;
C-STRUCT: SID_IDENTIFIER_AUTHORITY
{ { "BYTE" 6 } "Value" } ;
TYPEDEF: SID_IDENTIFIER_AUTHORITY* PSID_IDENTIFIER_AUTHORITY
CONSTANT: SECURITY_NULL_SID_AUTHORITY 0
CONSTANT: SECURITY_WORLD_SID_AUTHORITY 1
CONSTANT: SECURITY_LOCAL_SID_AUTHORITY 2
CONSTANT: SECURITY_CREATOR_SID_AUTHORITY 3
CONSTANT: SECURITY_NON_UNIQUE_AUTHORITY 4
CONSTANT: SECURITY_NT_AUTHORITY 5
CONSTANT: SECURITY_RESOURCE_MANAGER_AUTHORITY 6
CONSTANT: SECURITY_NULL_RID 0
CONSTANT: SECURITY_WORLD_RID 0
CONSTANT: SECURITY_LOCAL_RID 0
CONSTANT: SECURITY_CREATOR_OWNER_RID 0
CONSTANT: SECURITY_CREATOR_GROUP_RID 1
CONSTANT: SECURITY_CREATOR_OWNER_SERVER_RID 2
CONSTANT: SECURITY_CREATOR_GROUP_SERVER_RID 3
CONSTANT: SECURITY_DIALUP_RID 1
CONSTANT: SECURITY_NETWORK_RID 2
CONSTANT: SECURITY_BATCH_RID 3
CONSTANT: SECURITY_INTERACTIVE_RID 4
CONSTANT: SECURITY_SERVICE_RID 6
CONSTANT: SECURITY_ANONYMOUS_LOGON_RID 7
CONSTANT: SECURITY_PROXY_RID 8
CONSTANT: SECURITY_SERVER_LOGON_RID 9
CONSTANT: SECURITY_PRINCIPAL_SELF_RID 10
CONSTANT: SECURITY_AUTHENTICATED_USER_RID 11
CONSTANT: SECURITY_LOGON_IDS_RID 5
CONSTANT: SECURITY_LOGON_IDS_RID_COUNT 3
CONSTANT: SECURITY_LOCAL_SYSTEM_RID 18
CONSTANT: SECURITY_NT_NON_UNIQUE 21
CONSTANT: SECURITY_BUILTIN_DOMAIN_RID 32
CONSTANT: DOMAIN_USER_RID_ADMIN 500
CONSTANT: DOMAIN_USER_RID_GUEST 501
CONSTANT: DOMAIN_GROUP_RID_ADMINS 512
CONSTANT: DOMAIN_GROUP_RID_USERS 513
CONSTANT: DOMAIN_GROUP_RID_GUESTS 514
CONSTANT: DOMAIN_ALIAS_RID_ADMINS 544
CONSTANT: DOMAIN_ALIAS_RID_USERS 545
CONSTANT: DOMAIN_ALIAS_RID_GUESTS 546
CONSTANT: DOMAIN_ALIAS_RID_POWER_USERS 547
CONSTANT: DOMAIN_ALIAS_RID_ACCOUNT_OPS 548
CONSTANT: DOMAIN_ALIAS_RID_SYSTEM_OPS 549
CONSTANT: DOMAIN_ALIAS_RID_PRINT_OPS 550
CONSTANT: DOMAIN_ALIAS_RID_BACKUP_OPS 551
CONSTANT: DOMAIN_ALIAS_RID_REPLICATOR 552
CONSTANT: SE_GROUP_MANDATORY 1
CONSTANT: SE_GROUP_ENABLED_BY_DEFAULT 2
CONSTANT: SE_GROUP_ENABLED 4
CONSTANT: SE_GROUP_OWNER 8
CONSTANT: SE_GROUP_LOGON_ID -1073741824
! SID is a variable length structure
TYPEDEF: void* PSID
TYPEDEF: EXPLICIT_ACCESS* PEXPLICIT_ACCESS
TYPEDEF: DWORD SECURITY_INFORMATION
TYPEDEF: SECURITY_INFORMATION* PSECURITY_INFORMATION
CONSTANT: OWNER_SECURITY_INFORMATION 1
CONSTANT: GROUP_SECURITY_INFORMATION 2
CONSTANT: DACL_SECURITY_INFORMATION 4
CONSTANT: SACL_SECURITY_INFORMATION 8
CONSTANT: DELETE HEX: 00010000 CONSTANT: DELETE HEX: 00010000
CONSTANT: READ_CONTROL HEX: 00020000 CONSTANT: READ_CONTROL HEX: 00020000
CONSTANT: WRITE_DAC HEX: 00040000 CONSTANT: WRITE_DAC HEX: 00040000
@ -187,6 +350,34 @@ CONSTANT: TOKEN_ADJUST_DEFAULT HEX: 0080
TOKEN_ADJUST_DEFAULT TOKEN_ADJUST_DEFAULT
} flags ; foldable } flags ; foldable
CONSTANT: HKEY_CLASSES_ROOT 1
CONSTANT: HKEY_CURRENT_CONFIG 2
CONSTANT: HKEY_CURRENT_USER 3
CONSTANT: HKEY_LOCAL_MACHINE 4
CONSTANT: HKEY_USERS 5
CONSTANT: KEY_ALL_ACCESS HEX: 0001
CONSTANT: KEY_CREATE_LINK HEX: 0002
CONSTANT: KEY_CREATE_SUB_KEY HEX: 0004
CONSTANT: KEY_ENUMERATE_SUB_KEYS HEX: 0008
CONSTANT: KEY_EXECUTE HEX: 0010
CONSTANT: KEY_NOTIFY HEX: 0020
CONSTANT: KEY_QUERY_VALUE HEX: 0040
CONSTANT: KEY_READ HEX: 0080
CONSTANT: KEY_SET_VALUE HEX: 0100
CONSTANT: KEY_WOW64_64KEY HEX: 0200
CONSTANT: KEY_WOW64_32KEY HEX: 0400
CONSTANT: KEY_WRITE HEX: 0800
CONSTANT: REG_BINARY 1
CONSTANT: REG_DWORD 2
CONSTANT: REG_EXPAND_SZ 3
CONSTANT: REG_MULTI_SZ 4
CONSTANT: REG_QWORD 5
CONSTANT: REG_SZ 6
TYPEDEF: DWORD REGSAM
! : I_ScGetCurrentGroupStateW ; ! : I_ScGetCurrentGroupStateW ;
! : A_SHAFinal ; ! : A_SHAFinal ;
@ -224,7 +415,19 @@ FUNCTION: BOOL AdjustTokenPrivileges ( HANDLE TokenHandle,
PTOKEN_PRIVILEGES PreviousState, PTOKEN_PRIVILEGES PreviousState,
PDWORD ReturnLength ) ; PDWORD ReturnLength ) ;
! : AllocateAndInitializeSid ; FUNCTION: BOOL AllocateAndInitializeSid (
PSID_IDENTIFIER_AUTHORITY pIdentifierAuthority,
BYTE nSubAuthorityCount,
DWORD dwSubAuthority0,
DWORD dwSubAuthority1,
DWORD dwSubAuthority2,
DWORD dwSubAuthority3,
DWORD dwSubAuthority4,
DWORD dwSubAuthority5,
DWORD dwSubAuthority6,
DWORD dwSubAuthority7,
PSID* pSid ) ;
! : AllocateLocallyUniqueId ; ! : AllocateLocallyUniqueId ;
! : AreAllAccessesGranted ; ! : AreAllAccessesGranted ;
! : AreAnyAccessesGranted ; ! : AreAnyAccessesGranted ;
@ -442,7 +645,8 @@ FUNCTION: BOOL CryptReleaseContext ( HCRYPTPROV hProv, DWORD dwFlags ) ;
! : GetExplicitEntriesFromAclA ; ! : GetExplicitEntriesFromAclA ;
! : GetExplicitEntriesFromAclW ; ! : GetExplicitEntriesFromAclW ;
! : GetFileSecurityA ; ! : GetFileSecurityA ;
! : GetFileSecurityW ; FUNCTION: BOOL GetFileSecurityW ( LPCTSTR lpFileName, SECURITY_INFORMATION RequestedInformation, PSECURITY_DESCRIPTOR pSecurityDescriptor, DWORD nLength, LPDWORD lpnLengthNeeded ) ;
ALIAS: GetFileSecurity GetFileSecurityW
! : GetInformationCodeAuthzLevelW ; ! : GetInformationCodeAuthzLevelW ;
! : GetInformationCodeAuthzPolicyW ; ! : GetInformationCodeAuthzPolicyW ;
! : GetInheritanceSourceA ; ! : GetInheritanceSourceA ;
@ -459,19 +663,20 @@ FUNCTION: BOOL CryptReleaseContext ( HCRYPTPROV hProv, DWORD dwFlags ) ;
! : GetMultipleTrusteeW ; ! : GetMultipleTrusteeW ;
! : GetNamedSecurityInfoA ; ! : GetNamedSecurityInfoA ;
! : GetNamedSecurityInfoExA ; ! : GetNamedSecurityInfoExA ;
! : GetNamedSecurityInfoExW ; ! FUNCTION: DWORD GetNamedSecurityInfoExW
! : GetNamedSecurityInfoW ; FUNCTION: DWORD GetNamedSecurityInfoW ( LPTSTR pObjectName, SE_OBJECT_TYPE ObjectType, SECURITY_INFORMATION SecurityInfo, PSID* ppsidOwner, PSID* ppsidGroup, PACL* ppDacl, PACL* ppSacl, PSECURITY_DESCRIPTOR* ppSecurityDescriptor ) ;
ALIAS: GetNamedSecurityInfo GetNamedSecurityInfoW
! : GetNumberOfEventLogRecords ; ! : GetNumberOfEventLogRecords ;
! : GetOldestEventLogRecord ; ! : GetOldestEventLogRecord ;
! : GetOverlappedAccessResults ; ! : GetOverlappedAccessResults ;
! : GetPrivateObjectSecurity ; ! : GetPrivateObjectSecurity ;
! : GetSecurityDescriptorControl ; FUNCTION: BOOL GetSecurityDescriptorControl ( PSECURITY_DESCRIPTOR pSecurityDescriptor, PSECURITY_DESCRIPTOR_CONTROL pControl, LPDWORD lpdwRevision ) ;
! : GetSecurityDescriptorDacl ; FUNCTION: BOOL GetSecurityDescriptorDacl ( PSECURITY_DESCRIPTOR pSecurityDescriptor, LPBOOL lpbDaclPresent, PACL* pDacl, LPBOOL lpDaclDefaulted ) ;
! : GetSecurityDescriptorGroup ; FUNCTION: BOOL GetSecurityDescriptorGroup ( PSECURITY_DESCRIPTOR pSecurityDescriptor, PSID* pGroup, LPBOOL lpGroupDefaulted ) ;
! : GetSecurityDescriptorLength ; FUNCTION: BOOL GetSecurityDescriptorLength ( PSECURITY_DESCRIPTOR pSecurityDescriptor ) ;
! : GetSecurityDescriptorOwner ; FUNCTION: BOOL GetSecurityDescriptorOwner ( PSECURITY_DESCRIPTOR pSecurityDescriptor, PSID* pOwner, LPBOOL lpOwnerDefaulted ) ;
! : GetSecurityDescriptorRMControl ; FUNCTION: BOOL GetSecurityDescriptorRMControl ( PSECURITY_DESCRIPTOR pSecurityDescriptor, PUCHAR RMControl ) ;
! : GetSecurityDescriptorSacl ; FUNCTION: BOOL GetSecurityDescriptorSacl ( PSECURITY_DESCRIPTOR pSecurityDescriptor, LPBOOL lpbSaclPresent, PACL* pSacl, LPBOOL lpSaclDefaulted ) ;
! : GetSecurityInfo ; ! : GetSecurityInfo ;
! : GetSecurityInfoExA ; ! : GetSecurityInfoExA ;
! : GetSecurityInfoExW ; ! : GetSecurityInfoExW ;
@ -510,7 +715,7 @@ ALIAS: GetUserName GetUserNameW
! : ImpersonateNamedPipeClient ; ! : ImpersonateNamedPipeClient ;
! : ImpersonateSelf ; ! : ImpersonateSelf ;
FUNCTION: BOOL InitializeAcl ( PACL pAcl, DWORD nAclLength, DWORD dwAclRevision ) ; FUNCTION: BOOL InitializeAcl ( PACL pAcl, DWORD nAclLength, DWORD dwAclRevision ) ;
! : InitializeSecurityDescriptor ; FUNCTION: BOOL InitializeSecurityDescriptor ( PSECURITY_DESCRIPTOR pSecurityDescriptor, DWORD dwRevision ) ;
! : InitializeSid ; ! : InitializeSid ;
! : InitiateSystemShutdownA ; ! : InitiateSystemShutdownA ;
! : InitiateSystemShutdownExA ; ! : InitiateSystemShutdownExA ;
@ -674,8 +879,8 @@ FUNCTION: BOOL OpenThreadToken ( HANDLE ThreadHandle, DWORD DesiredAccess, BOOL
! : RegConnectRegistryW ; ! : RegConnectRegistryW ;
! : RegCreateKeyA ; ! : RegCreateKeyA ;
! : RegCreateKeyExA ; ! : RegCreateKeyExA ;
! : RegCreateKeyExW ; FUNCTION: LONG RegCreateKeyExW ( HKEY hKey, LPCTSTR lpSubKey, DWORD Reserved, LPTSTR lpClass, DWORD dwOptions, REGSAM samDesired, LPSECURITY_ATTRIBUTES lpSecurityAttributes, PHKEY phkResult, LPDWORD lpdwDisposition ) ;
! : RegCreateKeyW ; ! : RegCreateKeyW
! : RegDeleteKeyA ; ! : RegDeleteKeyA ;
! : RegDeleteKeyW ; ! : RegDeleteKeyW ;
! : RegDeleteValueA ; ! : RegDeleteValueA ;
@ -692,7 +897,7 @@ FUNCTION: BOOL OpenThreadToken ( HANDLE ThreadHandle, DWORD DesiredAccess, BOOL
! : RegLoadKeyA ; ! : RegLoadKeyA ;
! : RegLoadKeyW ; ! : RegLoadKeyW ;
! : RegNotifyChangeKeyValue ; ! : RegNotifyChangeKeyValue ;
! : RegOpenCurrentUser ; FUNCTION: LONG RegOpenCurrentUser ( REGSAM samDesired, PHKEY phkResult ) ;
! : RegOpenKeyA ; ! : RegOpenKeyA ;
! : RegOpenKeyExA ; ! : RegOpenKeyExA ;
! : RegOpenKeyExW ; ! : RegOpenKeyExW ;
@ -705,7 +910,7 @@ FUNCTION: BOOL OpenThreadToken ( HANDLE ThreadHandle, DWORD DesiredAccess, BOOL
! : RegQueryMultipleValuesW ; ! : RegQueryMultipleValuesW ;
! : RegQueryValueA ; ! : RegQueryValueA ;
! : RegQueryValueExA ; ! : RegQueryValueExA ;
! : RegQueryValueExW ; FUNCTION: LONG RegQueryValueExW ( HKEY hKey, LPCTSTR lpValueName, LPWORD lpReserved, LPDWORD lpType, LPBYTE lpData, LPDWORD lpcbData ) ;
! : RegQueryValueW ; ! : RegQueryValueW ;
! : RegReplaceKeyA ; ! : RegReplaceKeyA ;
! : RegReplaceKeyW ; ! : RegReplaceKeyW ;
@ -756,7 +961,8 @@ FUNCTION: BOOL OpenThreadToken ( HANDLE ThreadHandle, DWORD DesiredAccess, BOOL
! : SetEntriesInAccessListA ; ! : SetEntriesInAccessListA ;
! : SetEntriesInAccessListW ; ! : SetEntriesInAccessListW ;
! : SetEntriesInAclA ; ! : SetEntriesInAclA ;
! : SetEntriesInAclW ; FUNCTION: DWORD SetEntriesInAclW ( ULONG cCountOfExplicitEntries, PEXPLICIT_ACCESS pListOfExplicitEntries, PACL OldAcl, PACL* NewAcl ) ;
ALIAS: SetEntriesInAcl SetEntriesInAclW
! : SetEntriesInAuditListA ; ! : SetEntriesInAuditListA ;
! : SetEntriesInAuditListW ; ! : SetEntriesInAuditListW ;
! : SetFileSecurityA ; ! : SetFileSecurityA ;
@ -767,7 +973,8 @@ FUNCTION: BOOL OpenThreadToken ( HANDLE ThreadHandle, DWORD DesiredAccess, BOOL
! : SetNamedSecurityInfoA ; ! : SetNamedSecurityInfoA ;
! : SetNamedSecurityInfoExA ; ! : SetNamedSecurityInfoExA ;
! : SetNamedSecurityInfoExW ; ! : SetNamedSecurityInfoExW ;
! : SetNamedSecurityInfoW ; FUNCTION: DWORD SetNamedSecurityInfoW ( LPTSTR pObjectName, SE_OBJECT_TYPE ObjectType, SECURITY_INFORMATION SecurityInfo, PSID psidOwner, PSID psidGroup, PACL pDacl, PACL pSacl ) ;
ALIAS: SetNamedSecurityInfo SetNamedSecurityInfoW
! : SetPrivateObjectSecurity ; ! : SetPrivateObjectSecurity ;
! : SetPrivateObjectSecurityEx ; ! : SetPrivateObjectSecurityEx ;
! : SetSecurityDescriptorControl ; ! : SetSecurityDescriptorControl ;

1
basis/windows/gdi32/gdi32.factor
View File

@ -1501,7 +1501,6 @@ DESTRUCTOR: DeleteObject
FUNCTION: BOOL ExtTextOutW ( HDC hdc, int X, int Y, UINT fuOptions, RECT* lprc, LPCTSTR lpString, UINT cbCount, INT* lpDx ) ; FUNCTION: BOOL ExtTextOutW ( HDC hdc, int X, int Y, UINT fuOptions, RECT* lprc, LPCTSTR lpString, UINT cbCount, INT* lpDx ) ;
ALIAS: ExtTextOut ExtTextOutW ALIAS: ExtTextOut ExtTextOutW
! FUNCTION: FillPath ! FUNCTION: FillPath
FUNCTION: int FillRect ( HDC hDC, RECT* lprc, HBRUSH hbr ) ;
! FUNCTION: FillRgn ! FUNCTION: FillRgn
! FUNCTION: FixBrushOrgEx ! FUNCTION: FixBrushOrgEx
! FUNCTION: FlattenPath ! FUNCTION: FlattenPath

2
basis/windows/kernel32/kernel32.factor
View File

@ -1477,7 +1477,7 @@ ALIAS: LoadLibraryEx LoadLibraryExW
! FUNCTION: LoadLibraryW ! FUNCTION: LoadLibraryW
! FUNCTION: LoadModule ! FUNCTION: LoadModule
! FUNCTION: LoadResource ! FUNCTION: LoadResource
! FUNCTION: LocalAlloc FUNCTION: HLOCAL LocalAlloc ( UINT uFlags, SIZE_T uBytes ) ;
! FUNCTION: LocalCompact ! FUNCTION: LocalCompact
! FUNCTION: LocalFileTimeToFileTime ! FUNCTION: LocalFileTimeToFileTime
! FUNCTION: LocalFlags ! FUNCTION: LocalFlags

2
basis/windows/user32/user32.factor
View File

@ -807,7 +807,7 @@ FUNCTION: UINT EnumClipboardFormats ( UINT format ) ;
! FUNCTION: EqualRect ! FUNCTION: EqualRect
! FUNCTION: ExcludeUpdateRgn ! FUNCTION: ExcludeUpdateRgn
! FUNCTION: ExitWindowsEx ! FUNCTION: ExitWindowsEx
! FUNCTION: FillRect FUNCTION: int FillRect ( HDC hDC, RECT* lprc, HBRUSH hbr ) ;
FUNCTION: HWND FindWindowA ( char* lpClassName, char* lpWindowName ) ; FUNCTION: HWND FindWindowA ( char* lpClassName, char* lpWindowName ) ;
FUNCTION: HWND FindWindowExA ( HWND hwndParent, HWND childAfter, char* lpClassName, char* lpWindowName ) ; FUNCTION: HWND FindWindowExA ( HWND hwndParent, HWND childAfter, char* lpClassName, char* lpWindowName ) ;
! FUNCTION: FindWindowExW ! FUNCTION: FindWindowExW

6
core/classes/classes-tests.factor
View File

@ -29,10 +29,10 @@ M: method-forget-class method-forget-test ;
] unit-test ] unit-test
! Minor leak ! Minor leak
[ ] [ "IN: classes.tests TUPLE: forget-me ;" eval ] unit-test [ ] [ "IN: classes.tests TUPLE: forget-me ;" eval( -- ) ] unit-test
[ ] [ f \ word set-global ] unit-test [ ] [ f \ word set-global ] unit-test
[ ] [ "IN: classes.tests USE: kernel USE: classes.algebra forget-me tuple class<= drop" eval ] unit-test [ ] [ "IN: classes.tests USE: kernel USE: classes.algebra forget-me tuple class<= drop" eval( -- ) ] unit-test
[ ] [ "IN: classes.tests FORGET: forget-me" eval ] unit-test [ ] [ "IN: classes.tests FORGET: forget-me" eval( -- ) ] unit-test
[ 0 ] [ [ 0 ] [
[ word? ] instances [ word? ] instances
[ [ name>> "forget-me" = ] [ vocabulary>> "classes.tests" = ] bi and ] count [ [ name>> "forget-me" = ] [ vocabulary>> "classes.tests" = ] bi and ] count

2
core/classes/mixin/mixin-tests.factor
View File

@ -42,7 +42,7 @@ INSTANCE: integer mx1
[ t ] [ mx1 integer class<= ] unit-test [ t ] [ mx1 integer class<= ] unit-test
[ t ] [ mx1 number class<= ] unit-test [ t ] [ mx1 number class<= ] unit-test
"IN: classes.mixin.tests USE: arrays INSTANCE: array mx1" eval "IN: classes.mixin.tests USE: arrays INSTANCE: array mx1" eval( -- )
[ t ] [ array mx1 class<= ] unit-test [ t ] [ array mx1 class<= ] unit-test
[ f ] [ mx1 number class<= ] unit-test [ f ] [ mx1 number class<= ] unit-test

22
core/classes/tuple/parser/parser-tests.factor
View File

@ -50,20 +50,20 @@ TUPLE: test-8 { b integer read-only } ;
DEFER: foo DEFER: foo
[ "IN: classes.tuple.parser.tests TUPLE: foo < test-1 < ;" eval ] [ "IN: classes.tuple.parser.tests TUPLE: foo < test-1 < ;" eval( -- ) ]
[ error>> invalid-slot-name? ] [ error>> invalid-slot-name? ]
must-fail-with must-fail-with
[ "IN: classes.tuple.parser.tests TUPLE: foo :" eval ] [ "IN: classes.tuple.parser.tests TUPLE: foo :" eval( -- ) ]
[ error>> invalid-slot-name? ] [ error>> invalid-slot-name? ]
must-fail-with must-fail-with
[ "IN: classes.tuple.parser.tests TUPLE: foo" eval ] [ "IN: classes.tuple.parser.tests TUPLE: foo" eval( -- ) ]
[ error>> unexpected-eof? ] [ error>> unexpected-eof? ]
must-fail-with must-fail-with
2 [ 2 [
[ "IN: classes.tuple.parser.tests USE: alien TUPLE: foo { slot dll } ;" eval ] [ "IN: classes.tuple.parser.tests USE: alien TUPLE: foo { slot dll } ;" eval( -- ) ]
[ error>> no-initial-value? ] [ error>> no-initial-value? ]
must-fail-with must-fail-with
@ -71,14 +71,14 @@ must-fail-with
] times ] times
2 [ 2 [
[ "IN: classes.tuple.parser.tests USE: arrays TUPLE: foo { slot array initial: 5 } ;" eval ] [ "IN: classes.tuple.parser.tests USE: arrays TUPLE: foo { slot array initial: 5 } ;" eval( -- ) ]
[ error>> bad-initial-value? ] [ error>> bad-initial-value? ]
must-fail-with must-fail-with
[ f ] [ \ foo tuple-class? ] unit-test [ f ] [ \ foo tuple-class? ] unit-test
] times ] times
[ "IN: classes.tuple.parser.tests USE: arrays TUPLE: foo slot { slot array } ;" eval ] [ "IN: classes.tuple.parser.tests USE: arrays TUPLE: foo slot { slot array } ;" eval( -- ) ]
[ error>> duplicate-slot-names? ] [ error>> duplicate-slot-names? ]
must-fail-with must-fail-with
@ -107,7 +107,7 @@ TUPLE: parsing-corner-case x ;
" f" " f"
" 3" " 3"
"}" "}"
} "\n" join eval } "\n" join eval( -- tuple )
] unit-test ] unit-test
[ T{ parsing-corner-case f 3 } ] [ [ T{ parsing-corner-case f 3 } ] [
@ -116,7 +116,7 @@ TUPLE: parsing-corner-case x ;
"T{ parsing-corner-case" "T{ parsing-corner-case"
" { x 3 }" " { x 3 }"
"}" "}"
} "\n" join eval } "\n" join eval( -- tuple )
] unit-test ] unit-test
[ T{ parsing-corner-case f 3 } ] [ [ T{ parsing-corner-case f 3 } ] [
@ -125,7 +125,7 @@ TUPLE: parsing-corner-case x ;
"T{ parsing-corner-case {" "T{ parsing-corner-case {"
" x 3 }" " x 3 }"
"}" "}"
} "\n" join eval } "\n" join eval( -- tuple )
] unit-test ] unit-test
@ -133,12 +133,12 @@ TUPLE: parsing-corner-case x ;
{ {
"USE: classes.tuple.parser.tests T{ parsing-corner-case" "USE: classes.tuple.parser.tests T{ parsing-corner-case"
" { x 3 }" " { x 3 }"
} "\n" join eval } "\n" join eval( -- tuple )
] [ error>> unexpected-eof? ] must-fail-with ] [ error>> unexpected-eof? ] must-fail-with
[ [
{ {
"USE: classes.tuple.parser.tests T{ parsing-corner-case {" "USE: classes.tuple.parser.tests T{ parsing-corner-case {"
" x 3 }" " x 3 }"
} "\n" join eval } "\n" join eval( -- tuple )
] [ error>> unexpected-eof? ] must-fail-with ] [ error>> unexpected-eof? ] must-fail-with

86
core/classes/tuple/tuple-tests.factor
View File

@ -27,7 +27,7 @@ C: <redefinition-test> redefinition-test
[ t ] [ "redefinition-test" get redefinition-test? ] unit-test [ t ] [ "redefinition-test" get redefinition-test? ] unit-test
"IN: classes.tuple.tests TUPLE: redefinition-test ;" eval "IN: classes.tuple.tests TUPLE: redefinition-test ;" eval( -- )
[ t ] [ "redefinition-test" get redefinition-test? ] unit-test [ t ] [ "redefinition-test" get redefinition-test? ] unit-test
@ -39,7 +39,7 @@ C: <point> point
[ ] [ 100 200 <point> "p" set ] unit-test [ ] [ 100 200 <point> "p" set ] unit-test
! Use eval to sequence parsing explicitly ! Use eval to sequence parsing explicitly
[ ] [ "IN: classes.tuple.tests TUPLE: point x y z ;" eval ] unit-test [ ] [ "IN: classes.tuple.tests TUPLE: point x y z ;" eval( -- ) ] unit-test
[ 100 ] [ "p" get x>> ] unit-test [ 100 ] [ "p" get x>> ] unit-test
[ 200 ] [ "p" get y>> ] unit-test [ 200 ] [ "p" get y>> ] unit-test
@ -51,7 +51,7 @@ C: <point> point
[ 300 ] [ "p" get "z>>" "accessors" lookup execute ] unit-test [ 300 ] [ "p" get "z>>" "accessors" lookup execute ] unit-test
[ ] [ "IN: classes.tuple.tests TUPLE: point z y ;" eval ] unit-test [ ] [ "IN: classes.tuple.tests TUPLE: point z y ;" eval( -- ) ] unit-test
[ 2 ] [ "p" get tuple-size ] unit-test [ 2 ] [ "p" get tuple-size ] unit-test
@ -89,7 +89,7 @@ C: <empty> empty
[ t length ] [ object>> t eq? ] must-fail-with [ t length ] [ object>> t eq? ] must-fail-with
[ "<constructor-test>" ] [ "<constructor-test>" ]
[ "IN: classes.tuple.test TUPLE: constructor-test ; C: <constructor-test> constructor-test" eval word name>> ] unit-test [ "IN: classes.tuple.test TUPLE: constructor-test ; C: <constructor-test> constructor-test" eval( -- ) word name>> ] unit-test
TUPLE: size-test a b c d ; TUPLE: size-test a b c d ;
@ -102,7 +102,7 @@ GENERIC: <yo-momma> ( a -- b )
TUPLE: yo-momma ; TUPLE: yo-momma ;
[ ] [ "IN: classes.tuple.tests C: <yo-momma> yo-momma" eval ] unit-test [ ] [ "IN: classes.tuple.tests C: <yo-momma> yo-momma" eval( -- ) ] unit-test
[ f ] [ \ <yo-momma> generic? ] unit-test [ f ] [ \ <yo-momma> generic? ] unit-test
@ -204,7 +204,7 @@ C: <erg's-reshape-problem> erg's-reshape-problem
: cons-test-1 ( -- tuple ) \ erg's-reshape-problem new ; : cons-test-1 ( -- tuple ) \ erg's-reshape-problem new ;
: cons-test-2 ( a b c d -- tuple ) \ erg's-reshape-problem boa ; : cons-test-2 ( a b c d -- tuple ) \ erg's-reshape-problem boa ;
[ ] [ "IN: classes.tuple.tests TUPLE: erg's-reshape-problem a b c d e f ;" eval ] unit-test [ ] [ "IN: classes.tuple.tests TUPLE: erg's-reshape-problem a b c d e f ;" eval( -- ) ] unit-test
[ ] [ 1 2 3 4 5 6 cons-test-2 "a" set ] unit-test [ ] [ 1 2 3 4 5 6 cons-test-2 "a" set ] unit-test
@ -281,13 +281,13 @@ test-server-slot-values
] unit-test ] unit-test
[ [
"IN: classes.tuple.tests TUPLE: bad-superclass < word ;" eval "IN: classes.tuple.tests TUPLE: bad-superclass < word ;" eval( -- )
] must-fail ] must-fail
! Dynamically changing inheritance hierarchy ! Dynamically changing inheritance hierarchy
TUPLE: electronic-device ; TUPLE: electronic-device ;
[ ] [ "IN: classes.tuple.tests TUPLE: computer < electronic-device cpu ram ;" eval ] unit-test [ ] [ "IN: classes.tuple.tests TUPLE: computer < electronic-device cpu ram ;" eval( -- ) ] unit-test
[ f ] [ electronic-device laptop class<= ] unit-test [ f ] [ electronic-device laptop class<= ] unit-test
[ t ] [ server electronic-device class<= ] unit-test [ t ] [ server electronic-device class<= ] unit-test
@ -303,17 +303,17 @@ TUPLE: electronic-device ;
[ f ] [ "server" get laptop? ] unit-test [ f ] [ "server" get laptop? ] unit-test
[ t ] [ "server" get server? ] unit-test [ t ] [ "server" get server? ] unit-test
[ ] [ "IN: classes.tuple.tests TUPLE: computer cpu ram ;" eval ] unit-test [ ] [ "IN: classes.tuple.tests TUPLE: computer cpu ram ;" eval( -- ) ] unit-test
[ f ] [ "laptop" get electronic-device? ] unit-test [ f ] [ "laptop" get electronic-device? ] unit-test
[ t ] [ "laptop" get computer? ] unit-test [ t ] [ "laptop" get computer? ] unit-test
[ ] [ "IN: classes.tuple.tests TUPLE: computer < electronic-device cpu ram disk ;" eval ] unit-test [ ] [ "IN: classes.tuple.tests TUPLE: computer < electronic-device cpu ram disk ;" eval( -- ) ] unit-test
test-laptop-slot-values test-laptop-slot-values
test-server-slot-values test-server-slot-values
[ ] [ "IN: classes.tuple.tests TUPLE: electronic-device voltage ;" eval ] unit-test [ ] [ "IN: classes.tuple.tests TUPLE: electronic-device voltage ;" eval( -- ) ] unit-test
test-laptop-slot-values test-laptop-slot-values
test-server-slot-values test-server-slot-values
@ -326,7 +326,7 @@ TUPLE: make-me-some-accessors voltage grounded? ;
[ ] [ "laptop" get 220 >>voltage drop ] unit-test [ ] [ "laptop" get 220 >>voltage drop ] unit-test
[ ] [ "server" get 110 >>voltage drop ] unit-test [ ] [ "server" get 110 >>voltage drop ] unit-test
[ ] [ "IN: classes.tuple.tests TUPLE: electronic-device voltage grounded? ;" eval ] unit-test [ ] [ "IN: classes.tuple.tests TUPLE: electronic-device voltage grounded? ;" eval( -- ) ] unit-test
test-laptop-slot-values test-laptop-slot-values
test-server-slot-values test-server-slot-values
@ -334,7 +334,7 @@ test-server-slot-values
[ 220 ] [ "laptop" get voltage>> ] unit-test [ 220 ] [ "laptop" get voltage>> ] unit-test
[ 110 ] [ "server" get voltage>> ] unit-test [ 110 ] [ "server" get voltage>> ] unit-test
[ ] [ "IN: classes.tuple.tests TUPLE: electronic-device grounded? voltage ;" eval ] unit-test [ ] [ "IN: classes.tuple.tests TUPLE: electronic-device grounded? voltage ;" eval( -- ) ] unit-test
test-laptop-slot-values test-laptop-slot-values
test-server-slot-values test-server-slot-values
@ -343,7 +343,7 @@ test-server-slot-values
[ 110 ] [ "server" get voltage>> ] unit-test [ 110 ] [ "server" get voltage>> ] unit-test
! Reshaping superclass and subclass simultaneously ! Reshaping superclass and subclass simultaneously
[ ] [ "IN: classes.tuple.tests TUPLE: electronic-device voltage ; TUPLE: computer < electronic-device cpu ram ;" eval ] unit-test [ ] [ "IN: classes.tuple.tests TUPLE: electronic-device voltage ; TUPLE: computer < electronic-device cpu ram ;" eval( -- ) ] unit-test
test-laptop-slot-values test-laptop-slot-values
test-server-slot-values test-server-slot-values
@ -364,11 +364,11 @@ C: <test2> test2
test-a/b test-a/b
[ ] [ "IN: classes.tuple.tests TUPLE: test1 a x ; TUPLE: test2 < test1 b y ;" eval ] unit-test [ ] [ "IN: classes.tuple.tests TUPLE: test1 a x ; TUPLE: test2 < test1 b y ;" eval( -- ) ] unit-test
test-a/b test-a/b
[ ] [ "IN: classes.tuple.tests TUPLE: test1 a ; TUPLE: test2 < test1 b ;" eval ] unit-test [ ] [ "IN: classes.tuple.tests TUPLE: test1 a ; TUPLE: test2 < test1 b ;" eval( -- ) ] unit-test
test-a/b test-a/b
@ -393,19 +393,19 @@ T{ move-up-2 f "a" "b" "c" } "move-up" set
test-move-up test-move-up
[ ] [ "IN: classes.tuple.tests TUPLE: move-up-1 a b c ; TUPLE: move-up-2 < move-up-1 ;" eval ] unit-test [ ] [ "IN: classes.tuple.tests TUPLE: move-up-1 a b c ; TUPLE: move-up-2 < move-up-1 ;" eval( -- ) ] unit-test
test-move-up test-move-up
[ ] [ "IN: classes.tuple.tests TUPLE: move-up-1 a c ; TUPLE: move-up-2 < move-up-1 b ;" eval ] unit-test [ ] [ "IN: classes.tuple.tests TUPLE: move-up-1 a c ; TUPLE: move-up-2 < move-up-1 b ;" eval( -- ) ] unit-test
test-move-up test-move-up
[ ] [ "IN: classes.tuple.tests TUPLE: move-up-1 c ; TUPLE: move-up-2 < move-up-1 b a ;" eval ] unit-test [ ] [ "IN: classes.tuple.tests TUPLE: move-up-1 c ; TUPLE: move-up-2 < move-up-1 b a ;" eval( -- ) ] unit-test
test-move-up test-move-up
[ ] [ "IN: classes.tuple.tests TUPLE: move-up-1 ; TUPLE: move-up-2 < move-up-1 a b c ;" eval ] unit-test [ ] [ "IN: classes.tuple.tests TUPLE: move-up-1 ; TUPLE: move-up-2 < move-up-1 a b c ;" eval( -- ) ] unit-test
! Constructors must be recompiled when changing superclass ! Constructors must be recompiled when changing superclass
TUPLE: constructor-update-1 xxx ; TUPLE: constructor-update-1 xxx ;
@ -416,7 +416,7 @@ C: <constructor-update-2> constructor-update-2
{ 3 1 } [ <constructor-update-2> ] must-infer-as { 3 1 } [ <constructor-update-2> ] must-infer-as
[ ] [ "IN: classes.tuple.tests TUPLE: constructor-update-1 xxx ttt www ;" eval ] unit-test [ ] [ "IN: classes.tuple.tests TUPLE: constructor-update-1 xxx ttt www ;" eval( -- ) ] unit-test
{ 5 1 } [ <constructor-update-2> ] must-infer-as { 5 1 } [ <constructor-update-2> ] must-infer-as
@ -431,7 +431,7 @@ UNION: redefinition-problem' redefinition-problem integer ;
TUPLE: redefinition-problem-2 ; TUPLE: redefinition-problem-2 ;
"IN: classes.tuple.tests TUPLE: redefinition-problem < redefinition-problem-2 ;" eval "IN: classes.tuple.tests TUPLE: redefinition-problem < redefinition-problem-2 ;" eval( -- )
[ t ] [ 3 redefinition-problem'? ] unit-test [ t ] [ 3 redefinition-problem'? ] unit-test
@ -472,7 +472,7 @@ USE: vocabs
] with-compilation-unit ] with-compilation-unit
] unit-test ] unit-test
[ "USE: words T{ word }" eval ] [ "USE: words T{ word }" eval( -- ) ]
[ error>> T{ no-method f word new } = ] [ error>> T{ no-method f word new } = ]
must-fail-with must-fail-with
@ -485,7 +485,7 @@ must-fail-with
[ t ] [ "forget-accessors-test" "classes.tuple.tests" lookup class? ] unit-test [ t ] [ "forget-accessors-test" "classes.tuple.tests" lookup class? ] unit-test
: accessor-exists? ( class name -- ? ) : accessor-exists? ( name -- ? )
[ "forget-accessors-test" "classes.tuple.tests" lookup ] dip [ "forget-accessors-test" "classes.tuple.tests" lookup ] dip
">>" append "accessors" lookup method >boolean ; ">>" append "accessors" lookup method >boolean ;
@ -520,13 +520,13 @@ TUPLE: another-forget-accessors-test ;
[ f ] [ [ f ] [
t parser-notes? [ t parser-notes? [
[ [
"IN: classes.tuple.tests TUPLE: shadow-1 a b ; TUPLE: shadow-2 < shadow-1 a b ;" eval "IN: classes.tuple.tests TUPLE: shadow-1 a b ; TUPLE: shadow-2 < shadow-1 a b ;" eval( -- )
] with-string-writer empty? ] with-string-writer empty?
] with-variable ] with-variable
] unit-test ] unit-test
! Missing error check ! Missing error check
[ "IN: classes.tuple.tests USE: words TUPLE: wrong-superclass < word ;" eval ] must-fail [ "IN: classes.tuple.tests USE: words TUPLE: wrong-superclass < word ;" eval( -- ) ] must-fail
! Class forget messyness ! Class forget messyness
TUPLE: subclass-forget-test ; TUPLE: subclass-forget-test ;
@ -535,7 +535,7 @@ TUPLE: subclass-forget-test-1 < subclass-forget-test ;
TUPLE: subclass-forget-test-2 < subclass-forget-test ; TUPLE: subclass-forget-test-2 < subclass-forget-test ;
TUPLE: subclass-forget-test-3 < subclass-forget-test-2 ; TUPLE: subclass-forget-test-3 < subclass-forget-test-2 ;
[ ] [ "IN: classes.tuple.tests FORGET: subclass-forget-test" eval ] unit-test [ ] [ "IN: classes.tuple.tests FORGET: subclass-forget-test" eval( -- ) ] unit-test
[ { subclass-forget-test-2 } ] [ { subclass-forget-test-2 } ]
[ subclass-forget-test-2 class-usages ] [ subclass-forget-test-2 class-usages ]
@ -549,7 +549,7 @@ unit-test
[ f ] [ subclass-forget-test-2 tuple-class? ] unit-test [ f ] [ subclass-forget-test-2 tuple-class? ] unit-test
[ subclass-forget-test-3 new ] must-fail [ subclass-forget-test-3 new ] must-fail
[ "IN: classes.tuple.tests TUPLE: subclass-forget-test-4 < subclass-forget-test-2 ;" eval ] must-fail [ "IN: classes.tuple.tests TUPLE: subclass-forget-test-4 < subclass-forget-test-2 ;" eval( -- ) ] must-fail
! More ! More
DEFER: subclass-reset-test DEFER: subclass-reset-test
@ -562,11 +562,11 @@ GENERIC: break-me ( obj -- )
[ ] [ [ M\ integer break-me forget ] with-compilation-unit ] unit-test [ ] [ [ M\ integer break-me forget ] with-compilation-unit ] unit-test
[ ] [ "IN: classes.tuple.tests TUPLE: subclass-reset-test ;" <string-reader> "subclass-reset-test" parse-stream drop ] unit-test [ ] [ "IN: classes.tuple.tests TUPLE: subclass-reset-test ;" <string-reader> "subclass-reset-test" parse-stream drop ] unit-test
[ ] [ "IN: classes.tuple.tests TUPLE: subclass-reset-test-1 < subclass-reset-test ;" eval ] unit-test [ ] [ "IN: classes.tuple.tests TUPLE: subclass-reset-test-1 < subclass-reset-test ;" eval( -- ) ] unit-test
[ ] [ "IN: classes.tuple.tests TUPLE: subclass-reset-test-2 < subclass-reset-test ;" eval ] unit-test [ ] [ "IN: classes.tuple.tests TUPLE: subclass-reset-test-2 < subclass-reset-test ;" eval( -- ) ] unit-test
[ ] [ "IN: classes.tuple.tests TUPLE: subclass-reset-test-3 < subclass-reset-test-2 ;" eval ] unit-test [ ] [ "IN: classes.tuple.tests TUPLE: subclass-reset-test-3 < subclass-reset-test-2 ;" eval( -- ) ] unit-test
[ ] [ "IN: classes.tuple.tests USE: kernel M: subclass-reset-test-1 break-me drop ;" eval ] unit-test [ ] [ "IN: classes.tuple.tests USE: kernel M: subclass-reset-test-1 break-me drop ;" eval( -- ) ] unit-test
[ ] [ "IN: classes.tuple.tests : subclass-reset-test ( -- ) ;" <string-reader> "subclass-reset-test" parse-stream drop ] unit-test [ ] [ "IN: classes.tuple.tests : subclass-reset-test ( -- ) ;" <string-reader> "subclass-reset-test" parse-stream drop ] unit-test
@ -576,7 +576,7 @@ GENERIC: break-me ( obj -- )
[ t ] [ \ break-me "methods" word-prop assoc-empty? ] unit-test [ t ] [ \ break-me "methods" word-prop assoc-empty? ] unit-test
[ ] [ "IN: classes.tuple.tests USE: math USE: kernel M: integer break-me drop ;" eval ] unit-test [ ] [ "IN: classes.tuple.tests USE: math USE: kernel M: integer break-me drop ;" eval( -- ) ] unit-test
[ f ] [ \ break-me "methods" word-prop assoc-empty? ] unit-test [ f ] [ \ break-me "methods" word-prop assoc-empty? ] unit-test
@ -632,7 +632,7 @@ TUPLE: reshape-test x ;
T{ reshape-test f "hi" } "tuple" set T{ reshape-test f "hi" } "tuple" set
[ ] [ "IN: classes.tuple.tests TUPLE: reshape-test { x read-only } ;" eval ] unit-test [ ] [ "IN: classes.tuple.tests TUPLE: reshape-test { x read-only } ;" eval( -- ) ] unit-test
[ f ] [ \ reshape-test \ (>>x) method ] unit-test [ f ] [ \ reshape-test \ (>>x) method ] unit-test
@ -640,11 +640,11 @@ T{ reshape-test f "hi" } "tuple" set
[ "hi" ] [ "tuple" get x>> ] unit-test [ "hi" ] [ "tuple" get x>> ] unit-test
[ ] [ "IN: classes.tuple.tests USE: math TUPLE: reshape-test { x integer read-only } ;" eval ] unit-test [ ] [ "IN: classes.tuple.tests USE: math TUPLE: reshape-test { x integer read-only } ;" eval( -- ) ] unit-test
[ 0 ] [ "tuple" get x>> ] unit-test [ 0 ] [ "tuple" get x>> ] unit-test
[ ] [ "IN: classes.tuple.tests USE: math TUPLE: reshape-test { x fixnum initial: 4 read-only } ;" eval ] unit-test [ ] [ "IN: classes.tuple.tests USE: math TUPLE: reshape-test { x fixnum initial: 4 read-only } ;" eval( -- ) ] unit-test
[ 0 ] [ "tuple" get x>> ] unit-test [ 0 ] [ "tuple" get x>> ] unit-test
@ -660,20 +660,20 @@ ERROR: error-class-test a b c ;
[ "( a b c -- * )" ] [ \ error-class-test stack-effect effect>string ] unit-test [ "( a b c -- * )" ] [ \ error-class-test stack-effect effect>string ] unit-test
[ f ] [ \ error-class-test "inline" word-prop ] unit-test [ f ] [ \ error-class-test "inline" word-prop ] unit-test
[ "IN: classes.tuple.tests ERROR: error-x ; : error-x 3 ;" eval ] [ "IN: classes.tuple.tests ERROR: error-x ; : error-x 3 ;" eval( -- ) ]
[ error>> error>> redefine-error? ] must-fail-with [ error>> error>> redefine-error? ] must-fail-with
DEFER: error-y DEFER: error-y
[ ] [ [ \ error-y dup class? [ forget-class ] [ drop ] if ] with-compilation-unit ] unit-test [ ] [ [ \ error-y dup class? [ forget-class ] [ drop ] if ] with-compilation-unit ] unit-test
[ ] [ "IN: classes.tuple.tests GENERIC: error-y ( a -- b )" eval ] unit-test [ ] [ "IN: classes.tuple.tests GENERIC: error-y ( a -- b )" eval( -- ) ] unit-test
[ f ] [ \ error-y tuple-class? ] unit-test [ f ] [ \ error-y tuple-class? ] unit-test
[ t ] [ \ error-y generic? ] unit-test [ t ] [ \ error-y generic? ] unit-test
[ ] [ "IN: classes.tuple.tests ERROR: error-y ;" eval ] unit-test [ ] [ "IN: classes.tuple.tests ERROR: error-y ;" eval( -- ) ] unit-test
[ t ] [ \ error-y tuple-class? ] unit-test [ t ] [ \ error-y tuple-class? ] unit-test
@ -694,7 +694,7 @@ DEFER: error-y
] unit-test ] unit-test
[ ] [ [ ] [
"IN: sequences TUPLE: reversed { seq read-only } ;" eval "IN: sequences TUPLE: reversed { seq read-only } ;" eval( -- )
] unit-test ] unit-test
TUPLE: bogus-hashcode-1 x ; TUPLE: bogus-hashcode-1 x ;
@ -735,14 +735,14 @@ SLOT: kex
DEFER: redefine-tuple-twice DEFER: redefine-tuple-twice
[ ] [ "IN: classes.tuple.tests TUPLE: redefine-tuple-twice ;" eval ] unit-test [ ] [ "IN: classes.tuple.tests TUPLE: redefine-tuple-twice ;" eval( -- ) ] unit-test
[ t ] [ \ redefine-tuple-twice symbol? ] unit-test [ t ] [ \ redefine-tuple-twice symbol? ] unit-test
[ ] [ "IN: classes.tuple.tests DEFER: redefine-tuple-twice" eval ] unit-test [ ] [ "IN: classes.tuple.tests DEFER: redefine-tuple-twice" eval( -- ) ] unit-test
[ t ] [ \ redefine-tuple-twice deferred? ] unit-test [ t ] [ \ redefine-tuple-twice deferred? ] unit-test
[ ] [ "IN: classes.tuple.tests TUPLE: redefine-tuple-twice ;" eval ] unit-test [ ] [ "IN: classes.tuple.tests TUPLE: redefine-tuple-twice ;" eval( -- ) ] unit-test
[ t ] [ \ redefine-tuple-twice symbol? ] unit-test [ t ] [ \ redefine-tuple-twice symbol? ] unit-test

6
core/classes/union/union-tests.factor
View File

@ -26,13 +26,13 @@ M: union-1 generic-update-test drop "union-1" ;
[ t ] [ union-1 number class<= ] unit-test [ t ] [ union-1 number class<= ] unit-test
[ "union-1" ] [ 1.0 generic-update-test ] unit-test [ "union-1" ] [ 1.0 generic-update-test ] unit-test
"IN: classes.union.tests USE: math USE: arrays UNION: union-1 rational array ;" eval "IN: classes.union.tests USE: math USE: arrays UNION: union-1 rational array ;" eval( -- )
[ t ] [ bignum union-1 class<= ] unit-test [ t ] [ bignum union-1 class<= ] unit-test
[ f ] [ union-1 number class<= ] unit-test [ f ] [ union-1 number class<= ] unit-test
[ "union-1" ] [ { 1.0 } generic-update-test ] unit-test [ "union-1" ] [ { 1.0 } generic-update-test ] unit-test
"IN: classes.union.tests USE: math PREDICATE: union-1 < integer even? ;" eval "IN: classes.union.tests USE: math PREDICATE: union-1 < integer even? ;" eval( -- )
[ f ] [ union-1 union-class? ] unit-test [ f ] [ union-1 union-class? ] unit-test
[ t ] [ union-1 predicate-class? ] unit-test [ t ] [ union-1 predicate-class? ] unit-test
@ -58,7 +58,7 @@ UNION: redefine-bug-2 redefine-bug-1 quotation ;
[ t ] [ fixnum redefine-bug-2 class<= ] unit-test [ t ] [ fixnum redefine-bug-2 class<= ] unit-test
[ t ] [ quotation redefine-bug-2 class<= ] unit-test [ t ] [ quotation redefine-bug-2 class<= ] unit-test
[ ] [ "IN: classes.union.tests USE: math UNION: redefine-bug-1 bignum ;" eval ] unit-test [ ] [ "IN: classes.union.tests USE: math UNION: redefine-bug-1 bignum ;" eval( -- ) ] unit-test
[ t ] [ bignum redefine-bug-1 class<= ] unit-test [ t ] [ bignum redefine-bug-1 class<= ] unit-test
[ f ] [ fixnum redefine-bug-2 class<= ] unit-test [ f ] [ fixnum redefine-bug-2 class<= ] unit-test

2
core/combinators/combinators-tests.factor
View File

@ -357,7 +357,7 @@ DEFER: corner-case-1
[ 4 ] [ 2 2 [ + ] curry 1array case ] unit-test [ 4 ] [ 2 2 [ + ] curry 1array case ] unit-test
: test-case-8 ( n -- ) : test-case-8 ( n -- string )
{ {
{ 1 [ "foo" ] } { 1 [ "foo" ] }
} case ; } case ;

2
core/compiler/units/units-tests.factor
View File

@ -56,6 +56,6 @@ observer add-definition-observer
DEFER: nesting-test DEFER: nesting-test
[ ] [ "IN: compiler.units.tests << : nesting-test ( -- ) ; >>" eval ] unit-test [ ] [ "IN: compiler.units.tests << : nesting-test ( -- ) ; >>" eval( -- ) ] unit-test
observer remove-definition-observer observer remove-definition-observer

4
core/continuations/continuations-tests.factor
View File

@ -3,7 +3,7 @@ continuations debugger parser memory arrays words
kernel.private accessors eval ; kernel.private accessors eval ;
IN: continuations.tests IN: continuations.tests
: (callcc1-test) ( -- ) : (callcc1-test) ( n obj -- n' obj )
[ 1- dup ] dip ?push [ 1- dup ] dip ?push
over 0 = [ "test-cc" get continue-with ] when over 0 = [ "test-cc" get continue-with ] when
(callcc1-test) ; (callcc1-test) ;
@ -59,7 +59,7 @@ IN: continuations.tests
! : callstack-overflow callstack-overflow f ; ! : callstack-overflow callstack-overflow f ;
! [ callstack-overflow ] must-fail ! [ callstack-overflow ] must-fail
: don't-compile-me ( -- ) { } [ ] each ; : don't-compile-me ( n -- ) { } [ ] each ;
: foo ( -- ) callstack "c" set 3 don't-compile-me ; : foo ( -- ) callstack "c" set 3 don't-compile-me ;
: bar ( -- a b ) 1 foo 2 ; : bar ( -- a b ) 1 foo 2 ;

18
core/generic/generic-tests.factor
View File

@ -65,11 +65,11 @@ M: number union-containment drop 2 ;
[ 2 ] [ 1.0 union-containment ] unit-test [ 2 ] [ 1.0 union-containment ] unit-test
! Testing recovery from bad method definitions ! Testing recovery from bad method definitions
"IN: generic.tests GENERIC: unhappy ( x -- x )" eval "IN: generic.tests GENERIC: unhappy ( x -- x )" eval( -- )
[ [
"IN: generic.tests M: dictionary unhappy ;" eval "IN: generic.tests M: dictionary unhappy ;" eval( -- )
] must-fail ] must-fail
[ ] [ "IN: generic.tests GENERIC: unhappy ( x -- x )" eval ] unit-test [ ] [ "IN: generic.tests GENERIC: unhappy ( x -- x )" eval( -- ) ] unit-test
GENERIC# complex-combination 1 ( a b -- c ) GENERIC# complex-combination 1 ( a b -- c )
M: string complex-combination drop ; M: string complex-combination drop ;
@ -177,7 +177,7 @@ M: f generic-forget-test-3 ;
[ ] [ [ "m" get forget ] with-compilation-unit ] unit-test [ ] [ [ "m" get forget ] with-compilation-unit ] unit-test
[ ] [ "IN: generic.tests M: f generic-forget-test-3 ;" eval ] unit-test [ ] [ "IN: generic.tests M: f generic-forget-test-3 ;" eval( -- ) ] unit-test
[ ] [ [ "m" get forget ] with-compilation-unit ] unit-test [ ] [ [ "m" get forget ] with-compilation-unit ] unit-test
@ -193,7 +193,7 @@ M: integer a-generic a-word ;
[ t ] [ "m" get \ a-word usage memq? ] unit-test [ t ] [ "m" get \ a-word usage memq? ] unit-test
[ ] [ "IN: generic.tests : a-generic ( -- ) ;" eval ] unit-test [ ] [ "IN: generic.tests : a-generic ( -- ) ;" eval( -- ) ] unit-test
[ f ] [ "m" get \ a-word usage memq? ] unit-test [ f ] [ "m" get \ a-word usage memq? ] unit-test
@ -207,25 +207,25 @@ M: integer a-generic a-word ;
M: boii jeah ; M: boii jeah ;
GENERIC: jeah* ( a -- b ) GENERIC: jeah* ( a -- b )
M: boii jeah* jeah ; M: boii jeah* jeah ;
"> eval "> eval( -- )
<" <"
IN: compiler.tests IN: compiler.tests
FORGET: boii FORGET: boii
"> eval "> eval( -- )
<" <"
IN: compiler.tests IN: compiler.tests
TUPLE: boii ; TUPLE: boii ;
M: boii jeah ; M: boii jeah ;
"> eval "> eval( -- )
] unit-test ] unit-test
! call-next-method cache test ! call-next-method cache test
GENERIC: c-n-m-cache ( a -- b ) GENERIC: c-n-m-cache ( a -- b )
! Force it to be unoptimized ! Force it to be unoptimized
M: fixnum c-n-m-cache { } [ ] like call call-next-method ; M: fixnum c-n-m-cache { } [ ] like call( -- ) call-next-method ;
M: integer c-n-m-cache 1 + ; M: integer c-n-m-cache 1 + ;
M: number c-n-m-cache ; M: number c-n-m-cache ;

2
core/generic/standard/standard-tests.factor
View File

@ -66,7 +66,7 @@ M: circle area radius>> sq pi * ;
GENERIC: perimiter ( shape -- n ) GENERIC: perimiter ( shape -- n )
: rectangle-perimiter ( n -- n ) + 2 * ; : rectangle-perimiter ( l w -- n ) + 2 * ;
M: rectangle perimiter M: rectangle perimiter
[ width>> ] [ height>> ] bi [ width>> ] [ height>> ] bi

4
core/kernel/kernel-tests.factor
View File

@ -27,7 +27,7 @@ IN: kernel.tests
[ ] [ :c ] unit-test [ ] [ :c ] unit-test
: (overflow-d-alt) ( -- ) 3 ; : (overflow-d-alt) ( -- n ) 3 ;
: overflow-d-alt ( -- ) (overflow-d-alt) overflow-d-alt ; : overflow-d-alt ( -- ) (overflow-d-alt) overflow-d-alt ;
@ -107,7 +107,7 @@ IN: kernel.tests
! Regression ! Regression
: (loop) ( a b c d -- ) : (loop) ( a b c d -- )
[ pick ] dip swap [ pick ] dip swap [ pick ] dip swap [ pick ] dip swap
< [ [ 1+ ] 3dip (loop) ] [ 2drop 2drop ] if ; inline < [ [ 1+ ] 3dip (loop) ] [ 2drop 2drop ] if ; inline recursive
: loop ( obj obj -- ) : loop ( obj obj -- )
H{ } values swap [ dup length swap ] dip 0 -roll (loop) ; H{ } values swap [ dup length swap ] dip 0 -roll (loop) ;

2
core/memory/memory-tests.factor
View File

@ -15,7 +15,7 @@ IN: memory.tests
[ [ ] instances ] must-infer [ [ ] instances ] must-infer
! Code GC wasn't kicking in when needed ! Code GC wasn't kicking in when needed
: leak-step ( -- ) 800000 f <array> 1quotation call drop ; : leak-step ( -- ) 800000 f <array> 1quotation call( -- obj ) drop ;
: leak-loop ( -- ) 100 [ leak-step ] times ; : leak-loop ( -- ) 100 [ leak-step ] times ;

94
core/parser/parser-tests.factor
View File

@ -10,43 +10,43 @@ IN: parser.tests
[ [
[ 1 [ 2 [ 3 ] 4 ] 5 ] [ 1 [ 2 [ 3 ] 4 ] 5 ]
[ "1\n[\n2\n[\n3\n]\n4\n]\n5" eval ] [ "1\n[\n2\n[\n3\n]\n4\n]\n5" eval( -- a b c ) ]
unit-test unit-test
[ t t f f ] [ t t f f ]
[ "t t f f" eval ] [ "t t f f" eval( -- ? ? ? ? ) ]
unit-test unit-test
[ "hello world" ] [ "hello world" ]
[ "\"hello world\"" eval ] [ "\"hello world\"" eval( -- string ) ]
unit-test unit-test
[ "\n\r\t\\" ] [ "\n\r\t\\" ]
[ "\"\\n\\r\\t\\\\\"" eval ] [ "\"\\n\\r\\t\\\\\"" eval( -- string ) ]
unit-test unit-test
[ "hello world" ] [ "hello world" ]
[ [
"IN: parser.tests : hello ( -- str ) \"hello world\" ;" "IN: parser.tests : hello ( -- str ) \"hello world\" ;"
eval "USE: parser.tests hello" eval eval( -- ) "USE: parser.tests hello" eval( -- string )
] unit-test ] unit-test
[ ] [ ]
[ "! This is a comment, people." eval ] [ "! This is a comment, people." eval( -- ) ]
unit-test unit-test
! Test escapes ! Test escapes
[ " " ] [ " " ]
[ "\"\\u000020\"" eval ] [ "\"\\u000020\"" eval( -- string ) ]
unit-test unit-test
[ "'" ] [ "'" ]
[ "\"\\u000027\"" eval ] [ "\"\\u000027\"" eval( -- string ) ]
unit-test unit-test
! Test EOL comments in multiline strings. ! Test EOL comments in multiline strings.
[ "Hello" ] [ "#! This calls until-eol.\n\"Hello\"" eval ] unit-test [ "Hello" ] [ "#! This calls until-eol.\n\"Hello\"" eval( -- string ) ] unit-test
[ word ] [ \ f class ] unit-test [ word ] [ \ f class ] unit-test
@ -68,7 +68,7 @@ IN: parser.tests
[ \ baz "declared-effect" word-prop terminated?>> ] [ \ baz "declared-effect" word-prop terminated?>> ]
unit-test unit-test
[ ] [ "IN: parser.tests USE: math : effect-parsing-test ( a b -- d ) - ;" eval ] unit-test [ ] [ "IN: parser.tests USE: math : effect-parsing-test ( a b -- d ) - ;" eval( -- ) ] unit-test
[ t ] [ [ t ] [
"effect-parsing-test" "parser.tests" lookup "effect-parsing-test" "parser.tests" lookup
@ -79,14 +79,14 @@ IN: parser.tests
[ \ effect-parsing-test "declared-effect" word-prop ] unit-test [ \ effect-parsing-test "declared-effect" word-prop ] unit-test
! Funny bug ! Funny bug
[ 2 ] [ "IN: parser.tests : \0. ( -- x ) 2 ; \0." eval ] unit-test [ 2 ] [ "IN: parser.tests : \0. ( -- x ) 2 ; \0." eval( -- n ) ] unit-test
[ "IN: parser.tests : missing-- ( a b ) ;" eval ] must-fail [ "IN: parser.tests : missing-- ( a b ) ;" eval( -- ) ] must-fail
! These should throw errors ! These should throw errors
[ "HEX: zzz" eval ] must-fail [ "HEX: zzz" eval( -- obj ) ] must-fail
[ "OCT: 999" eval ] must-fail [ "OCT: 999" eval( -- obj ) ] must-fail
[ "BIN: --0" eval ] must-fail [ "BIN: --0" eval( -- obj ) ] must-fail
! Another funny bug ! Another funny bug
[ t ] [ [ t ] [
@ -102,14 +102,14 @@ IN: parser.tests
] unit-test ] unit-test
DEFER: foo DEFER: foo
"IN: parser.tests USING: math prettyprint ; SYNTAX: foo 2 2 + . ;" eval "IN: parser.tests USING: math prettyprint ; SYNTAX: foo 2 2 + . ;" eval( -- )
[ ] [ "USE: parser.tests foo" eval ] unit-test [ ] [ "USE: parser.tests foo" eval( -- ) ] unit-test
"IN: parser.tests USING: math prettyprint ; : foo ( -- ) 2 2 + . ;" eval "IN: parser.tests USING: math prettyprint ; : foo ( -- ) 2 2 + . ;" eval( -- )
[ t ] [ [ t ] [
"USE: parser.tests \\ foo" eval "USE: parser.tests \\ foo" eval( -- word )
"foo" "parser.tests" lookup eq? "foo" "parser.tests" lookup eq?
] unit-test ] unit-test
@ -269,12 +269,12 @@ IN: parser.tests
] unit-test ] unit-test
[ ] [ [ ] [
"IN: parser.tests : <bogus-error> ( -- ) ; : bogus ( -- ) <bogus-error> ;" "IN: parser.tests : <bogus-error> ( -- ) ; : bogus ( -- error ) <bogus-error> ;"
<string-reader> "bogus-error" parse-stream drop <string-reader> "bogus-error" parse-stream drop
] unit-test ] unit-test
[ ] [ [ ] [
"IN: parser.tests TUPLE: bogus-error ; C: <bogus-error> bogus-error : bogus ( -- ) <bogus-error> ;" "IN: parser.tests TUPLE: bogus-error ; C: <bogus-error> bogus-error : bogus ( -- error ) <bogus-error> ;"
<string-reader> "bogus-error" parse-stream drop <string-reader> "bogus-error" parse-stream drop
] unit-test ] unit-test
@ -339,16 +339,16 @@ IN: parser.tests
] [ error>> error>> error>> redefine-error? ] must-fail-with ] [ error>> error>> error>> redefine-error? ] must-fail-with
[ ] [ [ ] [
"IN: parser.tests : foo ( x y -- z ) 1 2 ; : bar ( a -- b ) ;" eval "IN: parser.tests : foo ( x y -- z ) 1 2 ; : bar ( a -- b ) ;" eval( -- )
] unit-test ] unit-test
[ [
"IN: parser.tests : foo ( x y -- z) 1 2 ; : bar ( a -- b ) ;" eval "IN: parser.tests : foo ( x y -- z) 1 2 ; : bar ( a -- b ) ;" eval( -- )
] must-fail ] must-fail
] with-file-vocabs ] with-file-vocabs
[ ] [ [ ] [
"IN: parser.tests USE: kernel PREDICATE: foo < object ( x -- y ) ;" eval "IN: parser.tests USE: kernel PREDICATE: foo < object ( x -- y ) ;" eval( -- )
] unit-test ] unit-test
[ t ] [ [ t ] [
@ -422,31 +422,31 @@ IN: parser.tests
] unit-test ] unit-test
[ [
"USE: this-better-not-exist" eval "USE: this-better-not-exist" eval( -- )
] must-fail ] must-fail
[ ": foo ;" eval ] [ error>> error>> no-current-vocab? ] must-fail-with [ ": foo ;" eval( -- ) ] [ error>> error>> no-current-vocab? ] must-fail-with
[ 92 ] [ "CHAR: \\" eval ] unit-test [ 92 ] [ "CHAR: \\" eval( -- n ) ] unit-test
[ 92 ] [ "CHAR: \\\\" eval ] unit-test [ 92 ] [ "CHAR: \\\\" eval( -- n ) ] unit-test
[ ] [ [ ] [
{ {
"IN: parser.tests" "IN: parser.tests"
"USING: math arrays ;" "USING: math arrays kernel ;"
"GENERIC: change-combination ( a -- b )" "GENERIC: change-combination ( obj a -- b )"
"M: integer change-combination 1 ;" "M: integer change-combination 2drop 1 ;"
"M: array change-combination 2 ;" "M: array change-combination 2drop 2 ;"
} "\n" join <string-reader> "change-combination-test" parse-stream drop } "\n" join <string-reader> "change-combination-test" parse-stream drop
] unit-test ] unit-test
[ ] [ [ ] [
{ {
"IN: parser.tests" "IN: parser.tests"
"USING: math arrays ;" "USING: math arrays kernel ;"
"GENERIC# change-combination 1 ( a -- b )" "GENERIC# change-combination 1 ( obj a -- b )"
"M: integer change-combination 1 ;" "M: integer change-combination 2drop 1 ;"
"M: array change-combination 2 ;" "M: array change-combination 2drop 2 ;"
} "\n" join <string-reader> "change-combination-test" parse-stream drop } "\n" join <string-reader> "change-combination-test" parse-stream drop
] unit-test ] unit-test
@ -463,7 +463,7 @@ IN: parser.tests
] unit-test ] unit-test
[ [ ] ] [ [ [ ] ] [
"IN: parser.tests : staging-problem-test-1 ( -- ) 1 ; : staging-problem-test-2 ( -- ) staging-problem-test-1 ;" "IN: parser.tests : staging-problem-test-1 ( -- a ) 1 ; : staging-problem-test-2 ( -- a ) staging-problem-test-1 ;"
<string-reader> "staging-problem-test" parse-stream <string-reader> "staging-problem-test" parse-stream
] unit-test ] unit-test
@ -472,7 +472,7 @@ IN: parser.tests
[ t ] [ "staging-problem-test-2" "parser.tests" lookup >boolean ] unit-test [ t ] [ "staging-problem-test-2" "parser.tests" lookup >boolean ] unit-test
[ [ ] ] [ [ [ ] ] [
"IN: parser.tests << : staging-problem-test-1 ( -- ) 1 ; >> : staging-problem-test-2 ( -- ) staging-problem-test-1 ;" "IN: parser.tests << : staging-problem-test-1 ( -- a ) 1 ; >> : staging-problem-test-2 ( -- a ) staging-problem-test-1 ;"
<string-reader> "staging-problem-test" parse-stream <string-reader> "staging-problem-test" parse-stream
] unit-test ] unit-test
@ -480,10 +480,10 @@ IN: parser.tests
[ t ] [ "staging-problem-test-2" "parser.tests" lookup >boolean ] unit-test [ t ] [ "staging-problem-test-2" "parser.tests" lookup >boolean ] unit-test
[ "DEFER: blahy" eval ] [ error>> error>> no-current-vocab? ] must-fail-with [ "DEFER: blahy" eval( -- ) ] [ error>> error>> no-current-vocab? ] must-fail-with
[ [
"IN: parser.tests SYNTAX: blahy ; FORGET: blahy" eval "IN: parser.tests SYNTAX: blahy ; FORGET: blahy" eval( -- )
] [ ] [
error>> staging-violation? error>> staging-violation?
] must-fail-with ] must-fail-with
@ -491,12 +491,12 @@ IN: parser.tests
! Bogus error message ! Bogus error message
DEFER: blahy DEFER: blahy
[ "IN: parser.tests USE: kernel TUPLE: blahy < tuple ; : blahy ( -- ) ; TUPLE: blahy < tuple ; : blahy ( -- ) ;" eval ] [ "IN: parser.tests USE: kernel TUPLE: blahy < tuple ; : blahy ( -- ) ; TUPLE: blahy < tuple ; : blahy ( -- ) ;" eval( -- ) ]
[ error>> error>> def>> \ blahy eq? ] must-fail-with [ error>> error>> def>> \ blahy eq? ] must-fail-with
[ ] [ f lexer set f file set "Hello world" note. ] unit-test [ ] [ f lexer set f file set "Hello world" note. ] unit-test
[ "CHAR: \\u9999999999999" eval ] must-fail [ "CHAR: \\u9999999999999" eval( -- n ) ] must-fail
SYMBOLS: a b c ; SYMBOLS: a b c ;
@ -506,15 +506,15 @@ SYMBOLS: a b c ;
DEFER: blah DEFER: blah
[ ] [ "IN: parser.tests GENERIC: blah ( -- )" eval ] unit-test [ ] [ "IN: parser.tests GENERIC: blah ( -- )" eval( -- ) ] unit-test
[ ] [ "IN: parser.tests SYMBOLS: blah ;" eval ] unit-test [ ] [ "IN: parser.tests SYMBOLS: blah ;" eval( -- ) ] unit-test
[ f ] [ \ blah generic? ] unit-test [ f ] [ \ blah generic? ] unit-test
[ t ] [ \ blah symbol? ] unit-test [ t ] [ \ blah symbol? ] unit-test
DEFER: blah1 DEFER: blah1
[ "IN: parser.tests SINGLETONS: blah1 blah1 blah1 ;" eval ] [ "IN: parser.tests SINGLETONS: blah1 blah1 blah1 ;" eval( -- ) ]
[ error>> error>> def>> \ blah1 eq? ] [ error>> error>> def>> \ blah1 eq? ]
must-fail-with must-fail-with
@ -545,10 +545,10 @@ EXCLUDE: qualified.tests.bar => x ;
[ 3 ] [ x ] unit-test [ 3 ] [ x ] unit-test
[ 4 ] [ y ] unit-test [ 4 ] [ y ] unit-test
[ "IN: qualified.tests FROM: qualified.tests => doesnotexist ;" eval ] [ "IN: qualified.tests FROM: qualified.tests => doesnotexist ;" eval( -- ) ]
[ error>> no-word-error? ] must-fail-with [ error>> no-word-error? ] must-fail-with
[ "IN: qualified.tests RENAME: doesnotexist qualified.tests => blahx" eval ] [ "IN: qualified.tests RENAME: doesnotexist qualified.tests => blahx" eval( -- ) ]
[ error>> no-word-error? ] must-fail-with [ error>> no-word-error? ] must-fail-with
! Two similar bugs ! Two similar bugs

4
core/slots/slots-tests.factor
View File

@ -25,12 +25,12 @@ TUPLE: hello length ;
[ t ] [ r/w-test \ foo>> method "flushable" word-prop ] unit-test [ t ] [ r/w-test \ foo>> method "flushable" word-prop ] unit-test
! See if declarations are cleared on redefinition ! See if declarations are cleared on redefinition
[ ] [ "IN: slots.tests TUPLE: r/w-test { foo read-only } ;" eval ] unit-test [ ] [ "IN: slots.tests TUPLE: r/w-test { foo read-only } ;" eval( -- ) ] unit-test
[ t ] [ r/w-test \ foo>> method "foldable" word-prop ] unit-test [ t ] [ r/w-test \ foo>> method "foldable" word-prop ] unit-test
[ t ] [ r/w-test \ foo>> method "flushable" word-prop ] unit-test [ t ] [ r/w-test \ foo>> method "flushable" word-prop ] unit-test
[ ] [ "IN: slots.tests TUPLE: r/w-test foo ;" eval ] unit-test [ ] [ "IN: slots.tests TUPLE: r/w-test foo ;" eval( -- ) ] unit-test
[ f ] [ r/w-test \ foo>> method "foldable" word-prop ] unit-test [ f ] [ r/w-test \ foo>> method "foldable" word-prop ] unit-test
[ t ] [ r/w-test \ foo>> method "flushable" word-prop ] unit-test [ t ] [ r/w-test \ foo>> method "flushable" word-prop ] unit-test

2
core/slots/slots.factor
View File

@ -222,7 +222,7 @@ M: slot-spec make-slot
[ make-slot ] map ; [ make-slot ] map ;
: finalize-slots ( specs base -- specs ) : finalize-slots ( specs base -- specs )
over length [ + ] with map [ >>offset ] 2map ; over length iota [ + ] with map [ >>offset ] 2map ;
: slot-named ( name specs -- spec/f ) : slot-named ( name specs -- spec/f )
[ name>> = ] with find nip ; [ name>> = ] with find nip ;

10
core/source-files/errors/errors.factor
View File

@ -12,7 +12,7 @@ TUPLE: source-file-error error asset file line# ;
: group-by-source-file ( errors -- assoc ) : group-by-source-file ( errors -- assoc )
H{ } clone [ [ push-at ] curry [ dup file>> ] prepose each ] keep ; H{ } clone [ [ push-at ] curry [ dup file>> ] prepose each ] keep ;
TUPLE: error-type type word plural icon quot forget-quot ; TUPLE: error-type type word plural icon quot forget-quot { fatal? initial: t } ;
GENERIC: error-type ( error -- type ) GENERIC: error-type ( error -- type )
@ -34,12 +34,12 @@ error-types [ V{ } clone ] initialize
error-types get at icon>> ; error-types get at icon>> ;
: error-counts ( -- alist ) : error-counts ( -- alist )
error-types get [ nip dup quot>> call( -- seq ) length ] assoc-map ; error-types get
[ nip dup quot>> call( -- seq ) length ] assoc-map
[ [ fatal?>> ] [ 0 > ] bi* and ] assoc-filter ;
: error-summary ( -- ) : error-summary ( -- )
error-counts error-counts [
[ nip 0 > ] assoc-filter
[
over over
[ word>> write ] [ word>> write ]
[ " - show " write number>string write bl ] [ " - show " write number>string write bl ]

2
core/vocabs/loader/loader-tests.factor
View File

@ -143,7 +143,7 @@ IN: vocabs.loader.tests
forget-junk forget-junk
[ { } ] [ [ { } ] [
"IN: xabbabbja" eval "xabbabbja" vocab-files "IN: xabbabbja" eval( -- ) "xabbabbja" vocab-files
] unit-test ] unit-test
[ "xabbabbja" forget-vocab ] with-compilation-unit [ "xabbabbja" forget-vocab ] with-compilation-unit

2
core/words/alias/alias-tests.factor
View File

@ -2,5 +2,5 @@ USING: math eval tools.test effects ;
IN: words.alias.tests IN: words.alias.tests
ALIAS: foo + ALIAS: foo +
[ ] [ "IN: words.alias.tests CONSTANT: foo 5" eval ] unit-test [ ] [ "IN: words.alias.tests CONSTANT: foo 5" eval( -- ) ] unit-test
[ (( -- value )) ] [ \ foo stack-effect ] unit-test [ (( -- value )) ] [ \ foo stack-effect ] unit-test

24
core/words/words-tests.factor
View File

@ -6,7 +6,7 @@ IN: words.tests
[ 4 ] [ [ 4 ] [
[ [
"poo" "words.tests" create [ 2 2 + ] define "poo" "words.tests" create [ 2 2 + ] (( -- n )) define-declared
] with-compilation-unit ] with-compilation-unit
"poo" "words.tests" lookup execute "poo" "words.tests" lookup execute
] unit-test ] unit-test
@ -51,7 +51,7 @@ SYMBOL: a-symbol
! See if redefining a generic as a colon def clears some ! See if redefining a generic as a colon def clears some
! word props. ! word props.
GENERIC: testing ( a -- b ) GENERIC: testing ( a -- b )
"IN: words.tests : testing ( -- ) ;" eval "IN: words.tests : testing ( -- ) ;" eval( -- )
[ f ] [ \ testing generic? ] unit-test [ f ] [ \ testing generic? ] unit-test
@ -88,7 +88,7 @@ DEFER: calls-a-gensym
[ [
\ calls-a-gensym \ calls-a-gensym
gensym dup "x" set 1quotation gensym dup "x" set 1quotation
define (( x -- x )) define-declared
] with-compilation-unit ] with-compilation-unit
] unit-test ] unit-test
@ -116,10 +116,10 @@ DEFER: x
[ ] [ "no-loc" "words.tests" create drop ] unit-test [ ] [ "no-loc" "words.tests" create drop ] unit-test
[ f ] [ "no-loc" "words.tests" lookup where ] unit-test [ f ] [ "no-loc" "words.tests" lookup where ] unit-test
[ ] [ "IN: words.tests : no-loc-2 ( -- ) ;" eval ] unit-test [ ] [ "IN: words.tests : no-loc-2 ( -- ) ;" eval( -- ) ] unit-test
[ f ] [ "no-loc-2" "words.tests" lookup where ] unit-test [ f ] [ "no-loc-2" "words.tests" lookup where ] unit-test
[ ] [ "IN: words.tests : test-last ( -- ) ;" eval ] unit-test [ ] [ "IN: words.tests : test-last ( -- ) ;" eval( -- ) ] unit-test
[ "test-last" ] [ word name>> ] unit-test [ "test-last" ] [ word name>> ] unit-test
! regression ! regression
@ -146,15 +146,15 @@ SYMBOL: quot-uses-b
[ forget ] with-compilation-unit [ forget ] with-compilation-unit
] when* ] when*
[ "IN: words.tests : undef-test ( -- ) ; << undef-test >>" eval ] [ "IN: words.tests : undef-test ( -- ) ; << undef-test >>" eval( -- ) ]
[ error>> undefined? ] must-fail-with [ error>> undefined? ] must-fail-with
[ ] [ [ ] [
"IN: words.tests GENERIC: symbol-generic ( -- )" eval "IN: words.tests GENERIC: symbol-generic ( -- )" eval( -- )
] unit-test ] unit-test
[ ] [ [ ] [
"IN: words.tests SYMBOL: symbol-generic" eval "IN: words.tests SYMBOL: symbol-generic" eval( -- )
] unit-test ] unit-test
[ t ] [ "symbol-generic" "words.tests" lookup symbol? ] unit-test [ t ] [ "symbol-generic" "words.tests" lookup symbol? ] unit-test
@ -174,14 +174,14 @@ SYMBOL: quot-uses-b
[ f ] [ "symbol-generic" "words.tests" lookup generic? ] unit-test [ f ] [ "symbol-generic" "words.tests" lookup generic? ] unit-test
! Regressions ! Regressions
[ ] [ "IN: words.tests : decl-forget-test ( -- ) ; foldable" eval ] unit-test [ ] [ "IN: words.tests : decl-forget-test ( -- ) ; foldable" eval( -- ) ] unit-test
[ t ] [ "decl-forget-test" "words.tests" lookup "foldable" word-prop ] unit-test [ t ] [ "decl-forget-test" "words.tests" lookup "foldable" word-prop ] unit-test
[ ] [ "IN: words.tests : decl-forget-test ( -- ) ;" eval ] unit-test [ ] [ "IN: words.tests : decl-forget-test ( -- ) ;" eval( -- ) ] unit-test
[ f ] [ "decl-forget-test" "words.tests" lookup "foldable" word-prop ] unit-test [ f ] [ "decl-forget-test" "words.tests" lookup "foldable" word-prop ] unit-test
[ ] [ "IN: words.tests : decl-forget-test ( -- ) ; flushable" eval ] unit-test [ ] [ "IN: words.tests : decl-forget-test ( -- ) ; flushable" eval( -- ) ] unit-test
[ t ] [ "decl-forget-test" "words.tests" lookup "flushable" word-prop ] unit-test [ t ] [ "decl-forget-test" "words.tests" lookup "flushable" word-prop ] unit-test
[ ] [ "IN: words.tests : decl-forget-test ( -- ) ;" eval ] unit-test [ ] [ "IN: words.tests : decl-forget-test ( -- ) ;" eval( -- ) ] unit-test
[ f ] [ "decl-forget-test" "words.tests" lookup "flushable" word-prop ] unit-test [ f ] [ "decl-forget-test" "words.tests" lookup "flushable" word-prop ] unit-test
[ { } ] [ { } ]

8
extra/4DNav/file-chooser/file-chooser.factor
View File

@ -92,11 +92,9 @@ file-chooser H{
; ;
: fc-load-file ( file-chooser file -- ) : fc-load-file ( file-chooser file -- )
dupd [ selected-file>> ] [ name>> ] bi* swap set-model over [ name>> ] [ selected-file>> ] bi* set-model
[ path>> value>> ] [ [ path>> value>> ] [ selected-file>> value>> ] bi append ] [ hook>> ] bi
[ selected-file>> value>> append ] call( path -- )
[ hook>> ] tri
call
; inline ; inline
! : fc-ok-action ( file-chooser -- quot ) ! : fc-ok-action ( file-chooser -- quot )

4
extra/bank/bank.factor
View File

@ -54,7 +54,7 @@ C: <transaction> transaction
: process-day ( account date -- ) : process-day ( account date -- )
2dup accumulate-interest ?pay-interest ; 2dup accumulate-interest ?pay-interest ;
: each-day ( quot start end -- ) : each-day ( quot: ( -- ) start end -- )
2dup before? [ 2dup before? [
[ dup [ over [ swap call ] dip ] dip 1 days time+ ] dip each-day [ dup [ over [ swap call ] dip ] dip 1 days time+ ] dip each-day
] [ ] [
@ -63,7 +63,7 @@ C: <transaction> transaction
: process-to-date ( account date -- account ) : process-to-date ( account date -- account )
over interest-last-paid>> 1 days time+ over interest-last-paid>> 1 days time+
[ dupd process-day ] spin each-day ; inline [ dupd process-day ] spin each-day ;
: inserting-transactions ( account transactions -- account ) : inserting-transactions ( account transactions -- account )
[ [ date>> process-to-date ] keep >>transaction ] each ; [ [ date>> process-to-date ] keep >>transaction ] each ;

2
extra/benchmark/base64/base64.factor
View File

@ -5,7 +5,7 @@ IN: benchmark.base64
: base64-benchmark ( -- ) : base64-benchmark ( -- )
65535 [ 255 bitand ] "" map-as 65535 [ 255 bitand ] "" map-as
100 [ >base64 base64> ] times 20 [ >base64 base64> ] times
drop ; drop ;
MAIN: base64-benchmark MAIN: base64-benchmark

44
extra/benchmark/benchmark.factor
View File

@ -1,21 +1,35 @@
! Copyright (C) 2007, 2008 Slava Pestov. ! Copyright (C) 2007, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: kernel vocabs vocabs.loader tools.time tools.vocabs USING: kernel vocabs vocabs.loader tools.time tools.vocabs
arrays assocs io.styles io help.markup prettyprint sequences arrays assocs io.styles io help.markup prettyprint sequences
continuations debugger math ; continuations debugger math namespaces ;
IN: benchmark IN: benchmark
: run-benchmark ( vocab -- result ) <PRIVATE
SYMBOL: timings
SYMBOL: errors
PRIVATE>
: run-benchmark ( vocab -- )
[ "=== " write vocab-name print flush ] [ [ "=== " write vocab-name print flush ] [
[ [ require ] [ [ run ] benchmark ] bi ] curry [ [ require ] [ [ run ] benchmark ] [ ] tri timings ]
[ error. f ] recover [ swap errors ]
recover get set-at
] bi ; ] bi ;
: run-benchmarks ( -- assoc ) : run-benchmarks ( -- timings errors )
"benchmark" all-child-vocabs-seq [
[ dup run-benchmark ] { } map>assoc ; V{ } clone timings set
V{ } clone errors set
"benchmark" all-child-vocabs-seq
[ run-benchmark ] each
timings get
errors get
] with-scope ;
: benchmarks. ( assoc -- ) : timings. ( assocs -- )
standard-table-style [ standard-table-style [
[ [
[ "Benchmark" write ] with-cell [ "Benchmark" write ] with-cell
@ -24,13 +38,21 @@ IN: benchmark
[ [
[ [
[ [ 1array $vocab-link ] with-cell ] [ [ 1array $vocab-link ] with-cell ]
[ [ 1000000 /f pprint-cell ] [ [ "failed" write ] with-cell ] if* ] bi* [ 1000000 /f pprint-cell ]
bi*
] with-row ] with-row
] assoc-each ] assoc-each
] tabular-output nl ; ] tabular-output nl ;
: benchmark-errors. ( errors -- )
[
[ "=== " write vocab-name print ]
[ error. ]
bi*
] assoc-each ;
: benchmarks ( -- ) : benchmarks ( -- )
run-benchmarks benchmarks. ; run-benchmarks [ timings. ] [ benchmark-errors. ] bi* ;
MAIN: benchmarks MAIN: benchmarks

2
extra/benchmark/beust1/beust1.factor
View File

@ -8,7 +8,7 @@ IN: benchmark.beust1
1 [a,b] [ number>string all-unique? ] count ; inline 1 [a,b] [ number>string all-unique? ] count ; inline
: beust ( -- ) : beust ( -- )
10000000 count-numbers 2000000 count-numbers
number>string " unique numbers." append print ; number>string " unique numbers." append print ;
MAIN: beust MAIN: beust

2
extra/benchmark/beust2/beust2.factor
View File

@ -34,7 +34,7 @@ IN: benchmark.beust2
:: beust ( -- ) :: beust ( -- )
[let | i! [ 0 ] | [let | i! [ 0 ] |
10000000000 [ i 1+ i! ] count-numbers 5000000000 [ i 1+ i! ] count-numbers
i number>string " unique numbers." append print i number>string " unique numbers." append print
] ; ] ;

2
extra/benchmark/fib6/fib6.factor
View File

@ -9,6 +9,6 @@ USING: math kernel alien ;
] alien-callback ] alien-callback
"int" { "int" } "cdecl" alien-indirect ; "int" { "int" } "cdecl" alien-indirect ;
: fib-main ( -- ) 34 fib drop ; : fib-main ( -- ) 32 fib drop ;
MAIN: fib-main MAIN: fib-main

4
extra/benchmark/md5/md5.factor
View File

@ -1,7 +1,7 @@
USING: checksums checksums.md5 io.files kernel ; USING: checksums checksums.md5 sequences byte-arrays kernel ;
IN: benchmark.md5 IN: benchmark.md5
: md5-file ( -- ) : md5-file ( -- )
"vocab:mime/multipart/multipart-tests.factor" md5 checksum-file drop ; 2000000 iota >byte-array md5 checksum-bytes drop ;
MAIN: md5-file MAIN: md5-file

Some files were not shown because too many files have changed in this diff Show More