.#*
*.swo
checksums.txt
+*.so
+a.out
(command-line) parse-command-line
load-vocab-roots
run-user-init
- "e" get [ eval ] when*
+ "e" get [ eval( -- ) ] when*
ignore-cli-args? not script get and
[ run-script ] [ "run" get run ] if*
output-stream get [ stream-flush ] when*
{ icon "vocab:ui/tools/error-list/icons/linkage-error.tiff" }
{ quot [ +linkage-error+ errors-of-type values ] }
{ forget-quot [ compiler-errors get delete-at ] }
+ { fatal? f }
} define-error-type
: <compiler-error> ( error word -- compiler-error )
IN: compiler.tests.folding
GENERIC: foldable-generic ( a -- b ) foldable
M: integer foldable-generic f <array> ;
- "> eval
+ "> eval( -- )
] unit-test
[ ] [
USING: math arrays ;
IN: compiler.tests.folding
: fold-test ( -- x ) 10 foldable-generic ;
- "> eval
+ "> eval( -- )
] unit-test
[ t ] [
[ 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
[ 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
[ t ] [ \ hey 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 ] [ \ there optimized>> ] unit-test
-[ ] [ "IN: compiler.tests : hey ( -- ) ;" eval ] unit-test
+[ ] [ "IN: compiler.tests : hey ( -- ) ;" eval( -- ) ] unit-test
[ t ] [ \ there optimized>> ] unit-test
: good ( -- ) ;
[ 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 ] [ \ bad optimized>> ] 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 ] [ \ bad optimized>> ] unit-test
MIXIN: my-mixin
INSTANCE: fixnum my-mixin
: my-inline ( a -- b ) dup my-mixin instance? [ 1 + ] when ;
- "> eval
+ "> eval( -- )
] unit-test
[ ] [
USE: math
IN: compiler.tests.redefine10
INSTANCE: float my-mixin
- "> eval
+ "> eval( -- )
] unit-test
[ 2.0 ] [
M: my-mixin my-generic drop 0 ;
M: object my-generic drop 1 ;
: my-inline ( -- b ) { } my-generic ;
- "> eval
+ "> eval( -- )
] unit-test
[ ] [
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
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 ] [ 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
-[ ] [ "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
[ f ] [ object \ sheeple method \ sheeple-test "compiled-uses" word-prop key? ] 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
GENERIC: my-generic ( a -- b )
M: object my-generic [ <=> ] sort ;
: my-inline ( a -- b ) my-generic ;
- "> eval
+ "> eval( -- )
] unit-test
[ ] [
IN: compiler.tests.redefine5
TUPLE: my-tuple ;
M: my-tuple my-generic drop 0 ;
- "> eval
+ "> eval( -- )
] unit-test
[ 0 ] [
MIXIN: my-mixin
M: my-mixin my-generic drop 0 ;
: my-inline ( a -- b ) { my-mixin } declare my-generic ;
- "> eval
+ "> eval( -- )
] unit-test
[ ] [
TUPLE: my-tuple ;
M: my-tuple my-generic drop 1 ;
INSTANCE: my-tuple my-mixin
- "> eval
+ "> eval( -- )
] unit-test
[ 1 ] [
MIXIN: my-mixin
INSTANCE: fixnum my-mixin
: my-inline ( a -- b ) dup my-mixin? [ 1 + ] when ;
- "> eval
+ "> eval( -- )
] unit-test
[ ] [
USE: math
IN: compiler.tests.redefine7
INSTANCE: float my-mixin
- "> eval
+ "> eval( -- )
] unit-test
[ 2.0 ] [
! We add the bogus quotation here to hinder inlining
! since otherwise we cannot trigger this bug.
M: my-mixin my-generic 1 + [ [ <=> ] sort ] drop ;
- "> eval
+ "> eval( -- )
] unit-test
[ ] [
USE: math
IN: compiler.tests.redefine8
INSTANCE: float my-mixin
- "> eval
+ "> eval( -- )
] unit-test
[ 2.0 ] [
! We add the bogus quotation here to hinder inlining
! since otherwise we cannot trigger this bug.
M: my-mixin my-generic 1 + [ [ <=> ] sort ] drop ;
- "> eval
+ "> eval( -- )
] unit-test
[ ] [
IN: compiler.tests.redefine9
TUPLE: my-tuple ;
INSTANCE: my-tuple my-mixin
- "> eval
+ "> eval( -- )
] unit-test
[
10 [
[ "compiler.tests.foo" forget-vocab ] with-compilation-unit
[ 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
] times
[ dup annotate-entry-test-1 1+ ] dip (annotate-entry-test-2)
] 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 ] [
[ { bignum } declare annotate-entry-test-2 ]
] unit-test
[ t ] [
- [ 1000 [ 1+ ] map ] { 1+ fixnum+ } inlined?
+ [ 1000 iota [ 1+ ] map ] { 1+ fixnum+ } inlined?
] unit-test
: rec ( a -- b )
[ t ] [
[ { integer integer } declare + drop ]
{ + +-integer-integer } inlined?
-] unit-test
\ No newline at end of file
+] 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? ] find nip child>> first in-d>> length ;
-[ 0 2 ] [
- [ foo ] build-tree
+[ 1 3 ] [
+ [ [ swap ] foo ] build-tree
[ recursive-inputs ]
[ analyze-recursive normalize recursive-inputs ] bi
] unit-test
[ ] [ [ [ 1 ] [ 2 ] if + * ] test-normalization ] unit-test
DEFER: bbb
-: aaa ( x -- ) dup [ dup [ bbb ] dip aaa ] [ drop ] if ; inline recursive
-: bbb ( x -- ) [ drop 0 ] dip aaa ; inline recursive
+: aaa ( obj x -- obj ) dup [ dup [ bbb ] dip aaa ] [ drop ] if ; inline recursive
+: bbb ( obj x -- obj ) [ drop 0 ] dip aaa ; inline recursive
[ ] [ [ bbb ] test-normalization ] unit-test
-: ccc ( -- ) ccc drop 1 ; inline recursive
+: ccc ( obj -- 1 ) ccc drop 1 ; inline recursive
[ ] [ [ ccc ] test-normalization ] unit-test
DEFER: eee
-: ddd ( -- ) eee ; inline recursive
-: eee ( -- ) swap ddd ; inline recursive
+: ddd ( a b -- a b ) eee ; inline recursive
+: eee ( a b -- a b ) swap ddd ; inline recursive
[ ] [ [ eee ] test-normalization ] unit-test
: (littledan-3-test) ( x -- )
length 1+ f <array> (littledan-3-test) ; inline recursive
-: littledan-3-test ( x -- )
+: littledan-3-test ( -- )
0 f <array> (littledan-3-test) ; inline
[ ] [ [ littledan-3-test ] final-classes drop ] unit-test
[ V{ 0 } ] [ [ { } length ] final-literals ] unit-test
-[ V{ 1 } ] [ [ { } length 1+ f <array> length ] final-literals ] unit-test
\ No newline at end of file
+[ V{ 1 } ] [ [ { } length 1+ f <array> length ] final-literals ] unit-test
\ (each-integer) label-is-loop?
] unit-test
-: loop-test-2 ( a -- )
+: loop-test-2 ( a b -- a' )
dup [ 1+ loop-test-2 1- ] [ drop ] if ; inline recursive
[ t ] [
concurrency.count-downs concurrency.promises locals kernel\r
threads ;\r
\r
-:: exchanger-test ( -- )\r
+:: exchanger-test ( -- string )\r
[let |\r
ex [ <exchanger> ]\r
c [ 2 <count-down> ]\r
\r
[ f ] [ flag-test-1 ] unit-test\r
\r
-:: flag-test-2 ( -- )\r
+:: flag-test-2 ( -- ? )\r
[let | f [ <flag> ] |\r
[ 1 seconds sleep f raise-flag ] "Flag test" spawn drop\r
f lower-flag\r
4 ds-reg 0 LWZ\r
5 ds-reg -4 LWZU\r
5 0 4 CMP\r
- 2 swap execute ! magic number\r
+ 2 swap execute( offset -- ) ! magic number\r
\ f tag-number 3 LI\r
3 ds-reg 0 STW ;\r
\r
: jit-math ( insn -- )\r
3 ds-reg 0 LWZ\r
4 ds-reg -4 LWZU\r
- [ 5 3 4 ] dip execute\r
+ [ 5 3 4 ] dip execute( dst src1 src2 -- )\r
5 ds-reg 0 STW ;\r
\r
[ \ ADD jit-math ] f f f \ fixnum+fast define-sub-primitive\r
! compare with second value
ds-reg [] temp0 CMP
! move t if true
- [ temp1 temp3 ] dip execute
+ [ temp1 temp3 ] dip execute( dst src -- )
! store
ds-reg [] temp1 MOV ;
! pop stack
ds-reg bootstrap-cell SUB
! 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
[ 3 ] [ 1 0 <hello> 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{ } ] [ bee protocol-consult ] unit-test
[ 0 ] [ 1 <hey> three ] unit-test
[ { hey } ] [ alpha 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 \ 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 } ] [ beta protocol-users ] unit-test
[ 2 ] [ 1 <hey> one ] unit-test
[ 0 ] [ 1 <hey> two ] unit-test
[ 0 ] [ 1 <hey> three ] 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
[ -1 ] [ 1 <hey> two ] unit-test
[ -1 ] [ 1 <hey> three ] 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
TUPLE: slot-protocol-test-1 a b ;
seq-delegate
sequence-protocol \ protocol-consult word-prop
key?
-] unit-test
\ No newline at end of file
+] unit-test
IN: eval.tests
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
3 '[ [ [ _ 1array ] call 1array ] call 1array ] call
] 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
[ { { "a" 1 } { "b" 2 } { "c" 3 } { "d" 4 } } ] [
"x" [ 1+ ] schange\r
"x" sget number>string "text/html" <content> ;\r
\r
-: url-responder-mock-test ( -- )\r
+: url-responder-mock-test ( -- string )\r
[\r
<request>\r
"GET" >>method\r
[ write-response-body drop ] with-string-writer\r
] with-destructors ;\r
\r
-: sessions-mock-test ( -- )\r
+: sessions-mock-test ( -- string )\r
[\r
<request>\r
"GET" >>method\r
\r
HELP: n*quot\r
{ $values\r
- { "n" integer } { "seq" sequence }\r
- { "seq'" sequence }\r
+ { "n" integer } { "quot" quotation }\r
+ { "quot'" quotation }\r
}\r
{ $examples\r
{ $example "USING: generalizations prettyprint math ;"\r
<<
-: n*quot ( n seq -- seq' ) <repetition> concat >quotation ;
+: n*quot ( n quot -- seq' ) <repetition> concat >quotation ;
: repeat ( n obj quot -- ) swapd times ; inline
: nappend-as ( n exemplar -- seq )
[ narray concat ] dip like ; inline
-: nappend ( n -- seq ) narray concat ; inline
\ No newline at end of file
+: nappend ( n -- seq ) narray concat ; inline
[ t ] [ 1 2 { 1 2 } 2= ] unit-test
[ f ] [ 1 3 { 1 2 } 2= ] unit-test
-: sample-hash ( -- )
+: sample-hash ( -- hash )
5 <hash2>
dup 2 3 "foo" roll set-hash2
dup 4 2 "bar" roll set-hash2
: sort-entries ( entries -- entries' )
[ [ key>> ] compare ] sort ;
-: delete-test ( n -- ? )
+: delete-test ( n -- obj1 obj2 )
[
random-alist
<min-heap> [ heap-push-all ] keep
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
[ $subsection ] [
] 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
[ ] [
"hello" "help.definitions.tests" lookup "help" word-prop
] 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
[
[ "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
] unit-test
[ { "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
] unit-test
} "\n" join
[
"testfile" source-file file set
- eval
+ eval( -- )
] with-scope
] unit-test
--- /dev/null
+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
! Copyright (C) 2009 Daniel Ehrenberg, Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
-USING: io kernel ;
+USING: io kernel sequences ;
IN: io.crlf
: crlf ( -- )
: read-crlf ( -- seq )
"\r" read-until
- [ CHAR: \r assert= read1 CHAR: \n assert= ] when* ;
+ [ CHAR: \r assert= read1 CHAR: \n assert= ] [ f like ] if* ;
<process>
console-vm "-script" "env.factor" 3array >>command
ascii <process-reader> contents
- ] with-directory eval
+ ] with-directory eval( -- alist )
os-envs =
] unit-test
+replace-environment+ >>environment-mode
os-envs >>environment
ascii <process-reader> contents
- ] with-directory eval
+ ] with-directory eval( -- alist )
os-envs =
] unit-test
console-vm "-script" "env.factor" 3array >>command
{ { "A" "B" } } >>environment
ascii <process-reader> contents
- ] with-directory eval
+ ] with-directory eval( -- alist )
"A" swap at
] unit-test
{ { "USERPROFILE" "XXX" } } >>environment
+prepend-environment+ >>environment-mode
ascii <process-reader> contents
- ] with-directory eval
+ ] with-directory eval( -- alist )
"USERPROFILE" swap at "XXX" =
] unit-test
"\\ + 1 2 3 4" parse-interactive
"cont" get continue-with
] ignore-errors
- "USE: debugger :1" eval
+ "USE: debugger :1" eval( -- quot )
] callcc1
] unit-test
] with-file-vocabs
[
[ ] [
- "IN: listener.tests : hello ( -- )\n\"world\" ;" parse-interactive
+ "IN: listener.tests : hello ( -- string )\n\"world\" ;" parse-interactive
drop
] unit-test
] with-file-vocabs
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 ] [
[ \ a-word-with-locals see ] with-string-writer
[
"USING: locals fry math ; 1 '[ [let | A [ 10 ] | A _ + ] ]"
- eval call
+ eval( -- ) call
] [ error>> >r/r>-in-fry-error? ] must-fail-with
:: (funny-macro-test) ( obj quot -- ? ) obj { quot } 1&& ; inline
[ f ] [ 2 funny-macro-test ] unit-test
! 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 | a" eval ] [ error>> unexpected-eof? ] must-fail-with
-[ "USE: locals [|" 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 [|" eval( -- ) ] [ error>> unexpected-eof? ] must-fail-with
[ 25 ] [ 5 [| a | { [ a sq ] } cond ] call ] unit-test
[ 25 ] [ 5 [| | { [| a | a sq ] } ] call first 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
:: ed's-test-case ( a -- b )
{ [ a ed's-bug ] } && ;
-[ t ] [ \ ed's-test-case optimized>> ] unit-test
\ No newline at end of file
+[ t ] [ \ ed's-test-case optimized>> ] unit-test
[ t ] [ \ see-test macro? ] unit-test
[ 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 =
] 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
0 pick interval-contains? over first \ recip eq? and [
2drop t
] [
- [ [ random-element ] dip first execute ] 2keep
- second execute interval-contains?
+ [ [ random-element ] dip first execute( a -- b ) ] 2keep
+ second execute( a -- b ) interval-contains?
] if ;
-[ t ] [ 80000 [ drop unary-test ] all? ] unit-test
+[ t ] [ 80000 iota [ drop unary-test ] all? ] unit-test
: random-binary-op ( -- pair )
{
0 pick interval-contains? over first { / /i mod rem } member? and [
3drop t
] [
- [ [ [ random-element ] bi@ ] dip first execute ] 3keep
- second execute interval-contains?
+ [ [ [ random-element ] bi@ ] dip first execute( a b -- c ) ] 3keep
+ second execute( a b -- c ) interval-contains?
] if ;
-[ t ] [ 80000 [ drop binary-test ] all? ] unit-test
+[ t ] [ 80000 iota [ drop binary-test ] all? ] unit-test
: random-comparison ( -- pair )
{
[ [ [ random-element ] bi@ ] dip first execute ] 3keep
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] interval-abs 0 10 [a,b] = ] unit-test
! Test that commutative interval ops really are
-: random-interval-or-empty ( -- )
+: random-interval-or-empty ( -- obj )
10 random 0 = [ empty-interval ] [ random-interval ] if ;
: random-commutative-op ( -- op )
} random ;
[ t ] [
- 80000 [
+ 80000 iota [
drop
random-interval-or-empty random-interval-or-empty
random-commutative-op
[ 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 ;
[ [ \ see-test see ] with-string-writer ]
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
! Test reshaping with a mirror
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
"ad" parser4
] 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
[
- "USING: peg.ebnf ; <EBNF foo='a' foo='b' EBNF>" eval drop
+ "USING: peg.ebnf ; <EBNF foo='a' foo='b' EBNF>" eval( -- ) drop
] must-fail
{ t } [
"\\" [EBNF foo="\\" EBNF]
] unit-test
-[ "USE: peg.ebnf [EBNF EBNF]" eval ] must-fail
+[ "USE: peg.ebnf [EBNF EBNF]" eval( -- ) ] must-fail
[ <" USE: peg.ebnf [EBNF
lol = a
lol = b
- EBNF] "> eval
+ EBNF] "> eval( -- )
] [
error>> [ redefined-rule? ] [ name>> "lol" = ] bi and
] must-fail-with
: random-string ( -- str )
1000000 random ; ! [ CHAR: a CHAR: z [a,b] random ] "" replicate-as ;
-: random-assocs ( -- hash phash )
+: random-assocs ( n -- hash phash )
[ random-string ] replicate
[ H{ } clone [ '[ swap _ set-at ] each-index ] keep ]
[ PH{ } clone swap [ spin new-at ] each-index ]
: ok? ( assoc1 assoc2 -- ? )
[ assoc= ] [ [ assoc-size ] bi@ = ] 2bi and ;
-: test-persistent-hashtables-1 ( n -- )
+: test-persistent-hashtables-1 ( n -- ? )
random-assocs ok? ;
[ t ] [ 10 test-persistent-hashtables-1 ] unit-test
[ t ] [ 10000 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
dup keys [
[ nip over delete-at ] [ swap pluck-at nip ] 3bi
kernel math namespaces parser prettyprint prettyprint.config
prettyprint.sections sequences tools.test vectors words
effects splitting generic.standard prettyprint.private
-continuations generic compiler.units tools.walker eval
-accessors make vocabs.parser see ;
+continuations generic compiler.units tools.continuations
+tools.continuations.private eval accessors make vocabs.parser see ;
IN: prettyprint.tests
[ "4" ] [ 4 unparse ] unit-test
[ \ blah see ] with-string-writer "\n" ?tail drop 6 tail*
] unit-test
-: check-see ( expect name -- )
+: check-see ( expect name -- ? )
[
use [ clone ] change
GENERIC: method-layout ( a -- b )
M: complex method-layout
+ drop
"aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
;
[
{
- "USING: math prettyprint.tests ;"
+ "USING: kernel math prettyprint.tests ;"
"M: complex method-layout"
+ " drop"
" \"aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa\""
" ;"
""
"string-layout-test" string-layout check-see
] unit-test
-: narrow-test ( -- str )
+: narrow-test ( -- array )
{
"USING: arrays combinators continuations kernel sequences ;"
"IN: prettyprint.tests"
- ": narrow-layout ( obj -- )"
+ ": narrow-layout ( obj1 obj2 -- obj3 )"
" {"
" { [ dup continuation? ] [ append ] }"
" { [ dup not ] [ drop reverse ] }"
- " { [ dup pair? ] [ delete ] }"
+ " { [ dup pair? ] [ [ delete ] keep ] }"
" } cond ;"
} ;
"narrow-layout" narrow-test check-see
] unit-test
-: another-narrow-test ( -- str )
+: another-narrow-test ( -- array )
{
"IN: prettyprint.tests"
": another-narrow-layout ( -- obj )"
! Regression
[ t ] [
"IN: prettyprint.tests\nGENERIC: generic-decl-test ( a -- b ) flushable\n"
- dup eval
+ dup eval( -- )
"generic-decl-test" "prettyprint.tests" lookup
[ see ] with-string-writer =
] unit-test
-[ [ + ] ] [
- [ \ + (step-into-execute) ] (remove-breakpoints)
-] unit-test
-
-[ [ (step-into-execute) ] ] [
- [ (step-into-execute) ] (remove-breakpoints)
-] unit-test
+[ [ + ] ] [ [ \ + (step-into-execute) ] (remove-breakpoints) ] unit-test
+[ [ (step-into-execute) ] ] [ [ (step-into-execute) ] (remove-breakpoints) ] unit-test
+
[ [ 2 2 + . ] ] [
[ 2 2 \ + (step-into-execute) . ] (remove-breakpoints)
] unit-test
100 [ 100 random ] replicate ;
: test-rng ( seed quot -- )
- [ <mersenne-twister> ] dip with-random ;
+ [ <mersenne-twister> ] dip with-random ; inline
[ f ] [ 1234 [ randoms randoms = ] test-rng ] unit-test
: regexp-parses ( string -- )
[ [ ] ] dip '[ _ parse-regexp drop ] unit-test ;
-: regexp-fails ( string -- )
+: regexp-fails ( string -- regexp )
'[ _ parse-regexp ] must-fail ;
{
! Comment inside a regular expression
[ 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
[ "abc" ] [ "abc" "(a|ab)(bc)?" <regexp> first-match >string ] unit-test
Elie Chaftari
Dirk Vleugels
Slava Pestov
+Doug Coleman
+Daniel Ehrenberg
: process ( -- )
read-crlf {
+ { [ dup not ] [ f ] }
{
[ dup [ "HELO" head? ] [ "EHLO" head? ] bi or ]
[ "220 and..?\r\n" write flush t ]
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors kernel quotations help.syntax help.markup
-io.sockets strings calendar ;
+io.sockets strings calendar io.encodings.utf8 ;
IN: smtp
HELP: smtp-domain
{ { $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 "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." }
}
"The " { $slot "from" } " and " { $slot "to" } " slots are required; the rest are optional."
[ { "hello" "." "world" } validate-message ] must-fail
[ "aGVsbG8Kd29ybGQ=\r\n.\r\n" ] [
- "hello\nworld" [ send-body ] with-string-writer
+ T{ email { body "hello\nworld" } } [ send-body ] with-string-writer
] unit-test
[ { "500 syntax error" } <response> check-response ]
[
{
{ "Content-Transfer-Encoding" "base64" }
- { "Content-Type" "Text/plain; charset=utf-8" }
+ { "Content-Type" "text/plain; charset=UTF-8" }
{ "From" "Doug <erg@factorcode.org>" }
{ "MIME-Version" "1.0" }
{ "Subject" "Factor rules" }
! 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.
-USING: arrays namespaces make io io.encodings.string
-io.encodings.utf8 io.timeouts io.sockets io.sockets.secure
-io.encodings.ascii kernel logging sequences combinators
-splitting assocs strings math.order math.parser random system
-calendar summary calendar.format accessors sets hashtables
-base64 debugger classes prettyprint io.crlf ;
+USING: arrays namespaces make io io.encodings.string io.encodings.utf8
+io.encodings.iana io.timeouts io.sockets io.sockets.secure
+io.encodings.ascii kernel logging sequences combinators splitting
+assocs strings math.order math.parser random system calendar summary
+calendar.format accessors sets hashtables base64 debugger classes
+prettyprint io.crlf words ;
IN: smtp
SYMBOL: smtp-domain
{ cc array }
{ bcc array }
{ subject string }
+ { content-type string initial: "text/plain" }
+ { encoding word initial: utf8 }
{ body string } ;
: <email> ( -- email ) email new ; inline
"." over member?
[ message-contains-dot ] when ;
-: send-body ( body -- )
- utf8 encode
+: send-body ( email -- )
+ [ body>> ] [ encoding>> ] bi encode
>base64-lines write crlf
"." command ;
! This could be much smarter.
" " split1-last swap or "<" ?head drop ">" ?tail drop ;
-: utf8-mime-header ( -- alist )
- {
- { "MIME-Version" "1.0" }
- { "Content-Transfer-Encoding" "base64" }
- { "Content-Type" "Text/plain; charset=utf-8" }
- } ;
+: email-content-type ( email -- content-type )
+ [ content-type>> ] [ encoding>> encoding>name ] bi "; charset=" glue ;
-: 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 ]
[ to>> ", " join "To" set ]
[ cc>> ", " join [ "Cc" set ] unless-empty ]
[ subject>> "Subject" set ]
+ [ email-content-type "Content-Type" set ]
} cleave
- now timestamp>rfc822 "Date" set
- message-id "Message-Id" set
- ] { } make-assoc utf8-mime-header append ;
+ ] { } make-assoc ;
: (send-email) ( headers email -- )
[
data get-ok
swap write-headers
crlf
- body>> send-body get-ok
+ send-body get-ok
quit get-ok
] with-smtp-connection ;
HELP: sort-by-slots
{ $values
{ "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." }
{ $examples
HELP: sort-by
{ $values
{ "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." } ;
{ { 3 2 1 } { 1 2 3 } { 1 3 2 } { 1 } }
{ length-test<=> <=> } sort-by
] 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
<PRIVATE
: 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 )
[
but-last-slice
- [ '[ [ _ execute ] bi@ ] ] map concat
+ [ '[ [ _ execute( tuple -- value ) ] bi@ ] ] map concat
] [
peek
'[ @ _ short-circuit-comparator ]
#! sort-spec: { accessors comparator }
[ slot-comparator ] map '[ _ 2|| +eq+ or ] ;
-MACRO: sort-by-slots ( sort-specs -- quot )
- '[ [ _ compare-slots ] sort ] ;
+: sort-by-slots ( seq sort-specs -- seq' )
+ '[ _ compare-slots ] sort ;
MACRO: compare-seq ( seq -- quot )
[ '[ _ short-circuit-comparator ] ] map '[ _ 2|| +eq+ or ] ;
-MACRO: sort-by ( sort-seq -- quot )
- '[ [ _ compare-seq ] sort ] ;
+: sort-by ( seq sort-seq -- seq' )
+ '[ _ compare-seq ] sort ;
-MACRO: sort-keys-by ( sort-seq -- quot )
+: sort-keys-by ( seq sort-seq -- seq' )
'[ [ first ] bi@ _ compare-seq ] sort ;
-MACRO: sort-values-by ( sort-seq -- quot )
+: sort-values-by ( seq sort-seq -- seq' )
'[ [ second ] bi@ _ compare-seq ] sort ;
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 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
\ 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
[ forget-test ] must-infer
[ ] [ [ \ forget-test forget ] with-compilation-unit ] unit-test
-[ forget-test ] must-infer
\ No newline at end of file
+[ forget-test ] must-infer
[ [ 3 throw ] "A" suspend ] [ 3 = ] must-fail-with
-:: spawn-namespace-test ( -- )
+:: spawn-namespace-test ( -- ? )
[let | p [ <promise> ] g [ gensym ] |
[
g "x" set
[ 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
\ 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
V{ } set-namestack
V{ } set-catchstack
"Saving final image" show
- [ save-image-and-exit ] call-clear ;
+ save-image-and-exit ;
SYMBOL: deploy-vocab
[:c]
[print-error]
'[
- [ _ execute ] [
- _ execute nl
- _ execute
+ [ _ execute( obj -- ) ] [
+ _ execute( obj -- ) nl
+ _ execute( obj -- )
] recover
] %
] if
: deploy-error-handler ( quot -- )
[
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
! 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
] recover ; inline
#! Tools for source-files.errors. Used by tools.tests and others
#! for error reporting
-M: source-file-error summary
- error>> summary ;
-
M: source-file-error compute-restarts
error>> compute-restarts ;
M: source-file-error error-help
error>> error-help ;
-M: source-file-error error.
+M: source-file-error summary
[
- [
- [
- [ file>> [ % ": " % ] when* ]
- [ line#>> [ # "\n" % ] when* ] bi
- ] "" make
- ] [
- [
- presented set
- bold font-style set
- ] H{ } make-assoc
- ] bi format
- ] [ error>> error. ] bi ;
+ [ file>> [ % ": " % ] [ "<Listener input>" % ] if* ]
+ [ line#>> [ # ] when* ] bi
+ ] "" make
+ ;
+
+M: source-file-error error.
+ [ summary print nl ] [ error>> error. ] bi ;
: errors. ( errors -- )
group-by-source-file sort-errors
TEST: must-fail-with
TEST: must-fail
-M: test-failure summary
- asset>> [ [ experiment. ] with-string-writer ] [ "Top-level form" ] if* ;
-
M: test-failure error. ( error -- )
- [ call-next-method ]
- [ traceback-button. ]
- bi ;
+ {
+ [ summary print nl ]
+ [ asset>> [ experiment. nl ] when* ]
+ [ error>> error. ]
+ [ traceback-button. ]
+ } cleave ;
: :test-failures ( -- ) test-failures get errors. ;
[ { 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
: <error-toggle> ( -- model gadget )
#! 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> ]
[ <mapping> ] bi ;
{
[ error-type error-icon ]
[ line#>> [ number>string ] [ "" ] if* ]
- [ asset>> unparse-short ]
+ [ asset>> [ unparse-short ] [ "" ] if* ]
[ error>> summary ]
} cleave
] output>array ;
} define-command-map
: ui-error-summary ( -- )
- all-errors [
- [ error-type ] map prune
- [ error-icon-path 1array \ $image prefix " " 2array ] { } map-as
+ error-counts keys [
+ [ icon>> 1array \ $image prefix " " 2array ] { } map-as
{ "Press " { $command tool "common" show-error-list } " to view errors." }
append print-element nl
] unless-empty ;
USING: alien.syntax kernel math windows.types math.bitwise ;
IN: windows.advapi32
+
LIBRARY: advapi32
CONSTANT: PROV_RSA_FULL 1
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 {
CONSTANT: TokenUser 1
CONSTANT: TokenSandBoxInert 15
! } 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: READ_CONTROL HEX: 00020000
CONSTANT: WRITE_DAC HEX: 00040000
TOKEN_ADJUST_DEFAULT
} 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 ;
! : A_SHAFinal ;
PTOKEN_PRIVILEGES PreviousState,
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 ;
! : AreAllAccessesGranted ;
! : AreAnyAccessesGranted ;
! : GetExplicitEntriesFromAclA ;
! : GetExplicitEntriesFromAclW ;
! : GetFileSecurityA ;
-! : GetFileSecurityW ;
+FUNCTION: BOOL GetFileSecurityW ( LPCTSTR lpFileName, SECURITY_INFORMATION RequestedInformation, PSECURITY_DESCRIPTOR pSecurityDescriptor, DWORD nLength, LPDWORD lpnLengthNeeded ) ;
+ALIAS: GetFileSecurity GetFileSecurityW
! : GetInformationCodeAuthzLevelW ;
! : GetInformationCodeAuthzPolicyW ;
! : GetInheritanceSourceA ;
! : GetMultipleTrusteeW ;
! : GetNamedSecurityInfoA ;
! : GetNamedSecurityInfoExA ;
-! : GetNamedSecurityInfoExW ;
-! : GetNamedSecurityInfoW ;
+! FUNCTION: DWORD GetNamedSecurityInfoExW
+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 ;
! : GetOldestEventLogRecord ;
! : GetOverlappedAccessResults ;
! : GetPrivateObjectSecurity ;
-! : GetSecurityDescriptorControl ;
-! : GetSecurityDescriptorDacl ;
-! : GetSecurityDescriptorGroup ;
-! : GetSecurityDescriptorLength ;
-! : GetSecurityDescriptorOwner ;
-! : GetSecurityDescriptorRMControl ;
-! : GetSecurityDescriptorSacl ;
+FUNCTION: BOOL GetSecurityDescriptorControl ( PSECURITY_DESCRIPTOR pSecurityDescriptor, PSECURITY_DESCRIPTOR_CONTROL pControl, LPDWORD lpdwRevision ) ;
+FUNCTION: BOOL GetSecurityDescriptorDacl ( PSECURITY_DESCRIPTOR pSecurityDescriptor, LPBOOL lpbDaclPresent, PACL* pDacl, LPBOOL lpDaclDefaulted ) ;
+FUNCTION: BOOL GetSecurityDescriptorGroup ( PSECURITY_DESCRIPTOR pSecurityDescriptor, PSID* pGroup, LPBOOL lpGroupDefaulted ) ;
+FUNCTION: BOOL GetSecurityDescriptorLength ( PSECURITY_DESCRIPTOR pSecurityDescriptor ) ;
+FUNCTION: BOOL GetSecurityDescriptorOwner ( PSECURITY_DESCRIPTOR pSecurityDescriptor, PSID* pOwner, LPBOOL lpOwnerDefaulted ) ;
+FUNCTION: BOOL GetSecurityDescriptorRMControl ( PSECURITY_DESCRIPTOR pSecurityDescriptor, PUCHAR RMControl ) ;
+FUNCTION: BOOL GetSecurityDescriptorSacl ( PSECURITY_DESCRIPTOR pSecurityDescriptor, LPBOOL lpbSaclPresent, PACL* pSacl, LPBOOL lpSaclDefaulted ) ;
! : GetSecurityInfo ;
! : GetSecurityInfoExA ;
! : GetSecurityInfoExW ;
! : ImpersonateNamedPipeClient ;
! : ImpersonateSelf ;
FUNCTION: BOOL InitializeAcl ( PACL pAcl, DWORD nAclLength, DWORD dwAclRevision ) ;
-! : InitializeSecurityDescriptor ;
+FUNCTION: BOOL InitializeSecurityDescriptor ( PSECURITY_DESCRIPTOR pSecurityDescriptor, DWORD dwRevision ) ;
! : InitializeSid ;
! : InitiateSystemShutdownA ;
! : InitiateSystemShutdownExA ;
! : RegConnectRegistryW ;
! : RegCreateKeyA ;
! : RegCreateKeyExA ;
-! : RegCreateKeyExW ;
-! : RegCreateKeyW ;
+FUNCTION: LONG RegCreateKeyExW ( HKEY hKey, LPCTSTR lpSubKey, DWORD Reserved, LPTSTR lpClass, DWORD dwOptions, REGSAM samDesired, LPSECURITY_ATTRIBUTES lpSecurityAttributes, PHKEY phkResult, LPDWORD lpdwDisposition ) ;
+! : RegCreateKeyW
! : RegDeleteKeyA ;
! : RegDeleteKeyW ;
! : RegDeleteValueA ;
! : RegLoadKeyA ;
! : RegLoadKeyW ;
! : RegNotifyChangeKeyValue ;
-! : RegOpenCurrentUser ;
+FUNCTION: LONG RegOpenCurrentUser ( REGSAM samDesired, PHKEY phkResult ) ;
! : RegOpenKeyA ;
! : RegOpenKeyExA ;
! : RegOpenKeyExW ;
! : RegQueryMultipleValuesW ;
! : RegQueryValueA ;
! : RegQueryValueExA ;
-! : RegQueryValueExW ;
+FUNCTION: LONG RegQueryValueExW ( HKEY hKey, LPCTSTR lpValueName, LPWORD lpReserved, LPDWORD lpType, LPBYTE lpData, LPDWORD lpcbData ) ;
! : RegQueryValueW ;
! : RegReplaceKeyA ;
! : RegReplaceKeyW ;
! : SetEntriesInAccessListA ;
! : SetEntriesInAccessListW ;
! : SetEntriesInAclA ;
-! : SetEntriesInAclW ;
+FUNCTION: DWORD SetEntriesInAclW ( ULONG cCountOfExplicitEntries, PEXPLICIT_ACCESS pListOfExplicitEntries, PACL OldAcl, PACL* NewAcl ) ;
+ALIAS: SetEntriesInAcl SetEntriesInAclW
! : SetEntriesInAuditListA ;
! : SetEntriesInAuditListW ;
! : SetFileSecurityA ;
! : SetNamedSecurityInfoA ;
! : SetNamedSecurityInfoExA ;
! : 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 ;
! : SetPrivateObjectSecurityEx ;
! : SetSecurityDescriptorControl ;
FUNCTION: BOOL ExtTextOutW ( HDC hdc, int X, int Y, UINT fuOptions, RECT* lprc, LPCTSTR lpString, UINT cbCount, INT* lpDx ) ;
ALIAS: ExtTextOut ExtTextOutW
! FUNCTION: FillPath
-FUNCTION: int FillRect ( HDC hDC, RECT* lprc, HBRUSH hbr ) ;
! FUNCTION: FillRgn
! FUNCTION: FixBrushOrgEx
! FUNCTION: FlattenPath
! FUNCTION: LoadLibraryW
! FUNCTION: LoadModule
! FUNCTION: LoadResource
-! FUNCTION: LocalAlloc
+FUNCTION: HLOCAL LocalAlloc ( UINT uFlags, SIZE_T uBytes ) ;
! FUNCTION: LocalCompact
! FUNCTION: LocalFileTimeToFileTime
! FUNCTION: LocalFlags
! FUNCTION: EqualRect
! FUNCTION: ExcludeUpdateRgn
! FUNCTION: ExitWindowsEx
-! FUNCTION: FillRect
+FUNCTION: int FillRect ( HDC hDC, RECT* lprc, HBRUSH hbr ) ;
FUNCTION: HWND FindWindowA ( char* lpClassName, char* lpWindowName ) ;
FUNCTION: HWND FindWindowExA ( HWND hwndParent, HWND childAfter, char* lpClassName, char* lpWindowName ) ;
! FUNCTION: FindWindowExW
] unit-test
! 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
-[ ] [ "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 USE: kernel USE: classes.algebra forget-me tuple class<= drop" eval( -- ) ] unit-test
+[ ] [ "IN: classes.tests FORGET: forget-me" eval( -- ) ] unit-test
[ 0 ] [
[ word? ] instances
[ [ name>> "forget-me" = ] [ vocabulary>> "classes.tests" = ] bi and ] count
[ t ] [ mx1 integer 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
[ f ] [ mx1 number class<= ] unit-test
[ ] [ "IN: classes.mixin.tests.a" <string-reader> "move-mixin-test-1" parse-stream drop ] unit-test
-[ { string } ] [ move-instance-declaration-mixin members ] unit-test
\ No newline at end of file
+[ { string } ] [ move-instance-declaration-mixin members ] unit-test
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? ]
must-fail-with
-[ "IN: classes.tuple.parser.tests TUPLE: foo :" eval ]
+[ "IN: classes.tuple.parser.tests TUPLE: foo :" eval( -- ) ]
[ error>> invalid-slot-name? ]
must-fail-with
-[ "IN: classes.tuple.parser.tests TUPLE: foo" eval ]
+[ "IN: classes.tuple.parser.tests TUPLE: foo" eval( -- ) ]
[ error>> unexpected-eof? ]
must-fail-with
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? ]
must-fail-with
] times
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? ]
must-fail-with
[ f ] [ \ foo tuple-class? ] unit-test
] 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? ]
must-fail-with
" f"
" 3"
"}"
- } "\n" join eval
+ } "\n" join eval( -- tuple )
] unit-test
[ T{ parsing-corner-case f 3 } ] [
"T{ parsing-corner-case"
" { x 3 }"
"}"
- } "\n" join eval
+ } "\n" join eval( -- tuple )
] unit-test
[ T{ parsing-corner-case f 3 } ] [
"T{ parsing-corner-case {"
" x 3 }"
"}"
- } "\n" join eval
+ } "\n" join eval( -- tuple )
] unit-test
{
"USE: classes.tuple.parser.tests T{ parsing-corner-case"
" { x 3 }"
- } "\n" join eval
+ } "\n" join eval( -- tuple )
] [ error>> unexpected-eof? ] must-fail-with
[
{
"USE: classes.tuple.parser.tests T{ parsing-corner-case {"
" x 3 }"
- } "\n" join eval
+ } "\n" join eval( -- tuple )
] [ error>> unexpected-eof? ] must-fail-with
[ 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
[ ] [ 100 200 <point> "p" set ] unit-test
! 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
[ 200 ] [ "p" get y>> ] 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
[ t length ] [ object>> t eq? ] must-fail-with
[ "<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: 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
: cons-test-1 ( -- tuple ) \ erg's-reshape-problem new ;
: 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
] unit-test
[
- "IN: classes.tuple.tests TUPLE: bad-superclass < word ;" eval
+ "IN: classes.tuple.tests TUPLE: bad-superclass < word ;" eval( -- )
] must-fail
! Dynamically changing inheritance hierarchy
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
[ t ] [ server electronic-device class<= ] unit-test
[ f ] [ "server" get laptop? ] 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
[ 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-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-server-slot-values
[ ] [ "laptop" get 220 >>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-server-slot-values
[ 220 ] [ "laptop" 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-server-slot-values
[ 110 ] [ "server" get voltage>> ] unit-test
! 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-server-slot-values
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
-[ ] [ "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-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
-[ ] [ "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
-[ ] [ "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
-[ ] [ "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
TUPLE: constructor-update-1 xxx ;
{ 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
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
] with-compilation-unit
] unit-test
-[ "USE: words T{ word }" eval ]
+[ "USE: words T{ word }" eval( -- ) ]
[ error>> T{ no-method f word new } = ]
must-fail-with
[ 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
">>" append "accessors" lookup method >boolean ;
[ f ] [
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-variable
] unit-test
! 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
TUPLE: subclass-forget-test ;
TUPLE: subclass-forget-test-2 < subclass-forget-test ;
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 class-usages ]
[ f ] [ subclass-forget-test-2 tuple-class? ] unit-test
[ 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
DEFER: subclass-reset-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-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-3 < subclass-reset-test-2 ;" 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-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
[ 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
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
[ "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
-[ ] [ "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
[ "( a b c -- * )" ] [ \ error-class-test stack-effect effect>string ] 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
DEFER: error-y
[ ] [ [ \ 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
[ 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
] unit-test
[ ] [
- "IN: sequences TUPLE: reversed { seq read-only } ;" eval
+ "IN: sequences TUPLE: reversed { seq read-only } ;" eval( -- )
] unit-test
TUPLE: bogus-hashcode-1 x ;
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
-[ ] [ "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
-[ ] [ "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
\ No newline at end of file
+[ t ] [ \ redefine-tuple-twice symbol? ] unit-test
[ t ] [ union-1 number class<= ] 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
[ f ] [ union-1 number class<= ] 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
[ t ] [ union-1 predicate-class? ] unit-test
[ t ] [ fixnum 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
[ f ] [ fixnum redefine-bug-2 class<= ] unit-test
[ 4 ] [ 2 2 [ + ] curry 1array case ] unit-test
-: test-case-8 ( n -- )
+: test-case-8 ( n -- string )
{
{ 1 [ "foo" ] }
} case ;
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
\ No newline at end of file
+observer remove-definition-observer
kernel.private accessors eval ;
IN: continuations.tests
-: (callcc1-test) ( -- )
+: (callcc1-test) ( n obj -- n' obj )
[ 1- dup ] dip ?push
over 0 = [ "test-cc" get continue-with ] when
(callcc1-test) ;
! : callstack-overflow callstack-overflow f ;
! [ callstack-overflow ] must-fail
-: don't-compile-me ( -- ) { } [ ] each ;
+: don't-compile-me ( n -- ) { } [ ] each ;
: foo ( -- ) callstack "c" set 3 don't-compile-me ;
: bar ( -- a b ) 1 foo 2 ;
[ 2 ] [ 1.0 union-containment ] unit-test
! 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
-[ ] [ "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 )
M: string complex-combination drop ;
[ ] [ [ "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
[ 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
M: boii jeah ;
GENERIC: jeah* ( a -- b )
M: boii jeah* jeah ;
- "> eval
+ "> eval( -- )
<"
IN: compiler.tests
FORGET: boii
- "> eval
+ "> eval( -- )
<"
IN: compiler.tests
TUPLE: boii ;
M: boii jeah ;
- "> eval
+ "> eval( -- )
] unit-test
! call-next-method cache test
GENERIC: c-n-m-cache ( a -- b )
! 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: number c-n-m-cache ;
[ ] [ "IN: generic.tests.a" <string-reader> "move-method-test-1" parse-stream drop ] unit-test
-[ { string } ] [ \ move-method-generic order ] unit-test
\ No newline at end of file
+[ { string } ] [ \ move-method-generic order ] unit-test
GENERIC: perimiter ( shape -- n )
-: rectangle-perimiter ( n -- n ) + 2 * ;
+: rectangle-perimiter ( l w -- n ) + 2 * ;
M: rectangle perimiter
[ width>> ] [ height>> ] bi
[ ] [ :c ] unit-test
-: (overflow-d-alt) ( -- ) 3 ;
+: (overflow-d-alt) ( -- n ) 3 ;
: overflow-d-alt ( -- ) (overflow-d-alt) overflow-d-alt ;
! Regression
: (loop) ( a b c d -- )
[ pick ] dip swap [ pick ] dip swap
- < [ [ 1+ ] 3dip (loop) ] [ 2drop 2drop ] if ; inline
+ < [ [ 1+ ] 3dip (loop) ] [ 2drop 2drop ] if ; inline recursive
: loop ( obj obj -- )
H{ } values swap [ dup length swap ] dip 0 -roll (loop) ;
[ 3 -1 5/6 ] [ 1 2 3 4 5 6 [ + ] [ - ] [ / ] 2tri* ] unit-test
-[ { 1 2 } { 3 4 } { 5 6 } ] [ 1 2 3 4 5 6 [ 2array ] 2tri@ ] unit-test
\ No newline at end of file
+[ { 1 2 } { 3 4 } { 5 6 } ] [ 1 2 3 4 5 6 [ 2array ] 2tri@ ] unit-test
[ [ ] instances ] must-infer
! 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 ;
[
[ 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
[ t t f f ]
- [ "t t f f" eval ]
+ [ "t t f f" eval( -- ? ? ? ? ) ]
unit-test
[ "hello world" ]
- [ "\"hello world\"" eval ]
+ [ "\"hello world\"" eval( -- string ) ]
unit-test
[ "\n\r\t\\" ]
- [ "\"\\n\\r\\t\\\\\"" eval ]
+ [ "\"\\n\\r\\t\\\\\"" eval( -- string ) ]
unit-test
[ "hello world" ]
[
"IN: parser.tests : hello ( -- str ) \"hello world\" ;"
- eval "USE: parser.tests hello" eval
+ eval( -- ) "USE: parser.tests hello" eval( -- string )
] unit-test
[ ]
- [ "! This is a comment, people." eval ]
+ [ "! This is a comment, people." eval( -- ) ]
unit-test
! Test escapes
[ " " ]
- [ "\"\\u000020\"" eval ]
+ [ "\"\\u000020\"" eval( -- string ) ]
unit-test
[ "'" ]
- [ "\"\\u000027\"" eval ]
+ [ "\"\\u000027\"" eval( -- string ) ]
unit-test
! 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
[ \ baz "declared-effect" word-prop terminated?>> ]
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 ] [
"effect-parsing-test" "parser.tests" lookup
[ \ effect-parsing-test "declared-effect" word-prop ] unit-test
! 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
- [ "HEX: zzz" eval ] must-fail
- [ "OCT: 999" eval ] must-fail
- [ "BIN: --0" eval ] must-fail
+ [ "HEX: zzz" eval( -- obj ) ] must-fail
+ [ "OCT: 999" eval( -- obj ) ] must-fail
+ [ "BIN: --0" eval( -- obj ) ] must-fail
! Another funny bug
[ t ] [
] unit-test
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 ] [
- "USE: parser.tests \\ foo" eval
+ "USE: parser.tests \\ foo" eval( -- word )
"foo" "parser.tests" lookup eq?
] 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
] 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
] unit-test
] [ 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
[
- "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
] 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
[ t ] [
] unit-test
[
- "USE: this-better-not-exist" eval
+ "USE: this-better-not-exist" eval( -- )
] 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 ] unit-test
+[ 92 ] [ "CHAR: \\" eval( -- n ) ] unit-test
+[ 92 ] [ "CHAR: \\\\" eval( -- n ) ] unit-test
[ ] [
{
"IN: parser.tests"
- "USING: math arrays ;"
- "GENERIC: change-combination ( a -- b )"
- "M: integer change-combination 1 ;"
- "M: array change-combination 2 ;"
+ "USING: math arrays kernel ;"
+ "GENERIC: change-combination ( obj a -- b )"
+ "M: integer change-combination 2drop 1 ;"
+ "M: array change-combination 2drop 2 ;"
} "\n" join <string-reader> "change-combination-test" parse-stream drop
] unit-test
[ ] [
{
"IN: parser.tests"
- "USING: math arrays ;"
- "GENERIC# change-combination 1 ( a -- b )"
- "M: integer change-combination 1 ;"
- "M: array change-combination 2 ;"
+ "USING: math arrays kernel ;"
+ "GENERIC# change-combination 1 ( obj a -- b )"
+ "M: integer change-combination 2drop 1 ;"
+ "M: array change-combination 2drop 2 ;"
} "\n" join <string-reader> "change-combination-test" parse-stream drop
] 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
] 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
] 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?
] must-fail-with
! Bogus error message
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
[ ] [ 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 ;
DEFER: blah
-[ ] [ "IN: parser.tests GENERIC: blah ( -- )" eval ] unit-test
-[ ] [ "IN: parser.tests SYMBOLS: blah ;" eval ] unit-test
+[ ] [ "IN: parser.tests GENERIC: blah ( -- )" eval( -- ) ] unit-test
+[ ] [ "IN: parser.tests SYMBOLS: blah ;" eval( -- ) ] unit-test
[ f ] [ \ blah generic? ] unit-test
[ t ] [ \ blah symbol? ] unit-test
DEFER: blah1
-[ "IN: parser.tests SINGLETONS: blah1 blah1 blah1 ;" eval ]
+[ "IN: parser.tests SINGLETONS: blah1 blah1 blah1 ;" eval( -- ) ]
[ error>> error>> def>> \ blah1 eq? ]
must-fail-with
[ 3 ] [ x ] 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
-[ "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
! Two similar bugs
[ t ] [ r/w-test \ foo>> method "flushable" word-prop ] unit-test
! 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 "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
[ t ] [ r/w-test \ foo>> method "flushable" word-prop ] unit-test
[ make-slot ] map ;
: finalize-slots ( specs base -- specs )
- over length [ + ] with map [ >>offset ] 2map ;
+ over length iota [ + ] with map [ >>offset ] 2map ;
: slot-named ( name specs -- spec/f )
[ name>> = ] with find nip ;
: group-by-source-file ( errors -- assoc )
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 )
error-types get at icon>> ;
: 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-counts
- [ nip 0 > ] assoc-filter
- [
+ error-counts [
over
[ word>> write ]
[ " - show " write number>string write bl ]
forget-junk
[ { } ] [
- "IN: xabbabbja" eval "xabbabbja" vocab-files
+ "IN: xabbabbja" eval( -- ) "xabbabbja" vocab-files
] unit-test
[ "xabbabbja" forget-vocab ] with-compilation-unit
IN: words.alias.tests
ALIAS: foo +
-[ ] [ "IN: words.alias.tests CONSTANT: foo 5" eval ] unit-test
-[ (( -- value )) ] [ \ foo stack-effect ] unit-test
\ No newline at end of file
+[ ] [ "IN: words.alias.tests CONSTANT: foo 5" eval( -- ) ] unit-test
+[ (( -- value )) ] [ \ foo stack-effect ] unit-test
[ 4 ] [
[
- "poo" "words.tests" create [ 2 2 + ] define
+ "poo" "words.tests" create [ 2 2 + ] (( -- n )) define-declared
] with-compilation-unit
"poo" "words.tests" lookup execute
] unit-test
! See if redefining a generic as a colon def clears some
! word props.
GENERIC: testing ( a -- b )
-"IN: words.tests : testing ( -- ) ;" eval
+"IN: words.tests : testing ( -- ) ;" eval( -- )
[ f ] [ \ testing generic? ] unit-test
[
\ calls-a-gensym
gensym dup "x" set 1quotation
- define
+ (( x -- x )) define-declared
] with-compilation-unit
] unit-test
[ ] [ "no-loc" "words.tests" create drop ] 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
-[ ] [ "IN: words.tests : test-last ( -- ) ;" eval ] unit-test
+[ ] [ "IN: words.tests : test-last ( -- ) ;" eval( -- ) ] unit-test
[ "test-last" ] [ word name>> ] unit-test
! regression
[ forget ] with-compilation-unit
] when*
-[ "IN: words.tests : undef-test ( -- ) ; << undef-test >>" eval ]
+[ "IN: words.tests : undef-test ( -- ) ; << undef-test >>" eval( -- ) ]
[ error>> undefined? ] must-fail-with
[ ] [
- "IN: words.tests GENERIC: symbol-generic ( -- )" eval
+ "IN: words.tests GENERIC: symbol-generic ( -- )" eval( -- )
] unit-test
[ ] [
- "IN: words.tests SYMBOL: symbol-generic" eval
+ "IN: words.tests SYMBOL: symbol-generic" eval( -- )
] unit-test
[ t ] [ "symbol-generic" "words.tests" lookup symbol? ] unit-test
[ f ] [ "symbol-generic" "words.tests" lookup generic? ] unit-test
! 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
-[ ] [ "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
-[ ] [ "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
-[ ] [ "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
[ { } ]
;\r
\r
: fc-load-file ( file-chooser file -- )\r
- dupd [ selected-file>> ] [ name>> ] bi* swap set-model \r
- [ path>> value>> ] \r
- [ selected-file>> value>> append ] \r
- [ hook>> ] tri\r
- call\r
+ over [ name>> ] [ selected-file>> ] bi* set-model \r
+ [ [ path>> value>> ] [ selected-file>> value>> ] bi append ] [ hook>> ] bi\r
+ call( path -- )\r
; inline\r
\r
! : fc-ok-action ( file-chooser -- quot )\r
+++ /dev/null
-IN: advice
-USING: help.markup help.syntax tools.annotations words coroutines ;
-
-HELP: make-advised
-{ $values { "word" "a word to annotate in preparation of advising" } }
-{ $description "Prepares a word for being advised. This is done by: "
- { $list
- { "Annotating it to call the appropriate words before, around, and after the original body " }
- { "Adding " { $snippet "before" } ", " { $snippet "around" } ", and " { $snippet "after" } " properties, which will contain the advice" }
- { "Adding an " { $snippet "advised" } "property, which can later be used to determine if a given word is defined (see " { $link advised? } ")" }
- }
-}
-{ $see-also advised? annotate } ;
-
-HELP: advised?
-{ $values { "word" "a word" } { "?" "t or f, indicating if " { $snippet "word" } " is advised" } }
-{ $description "Determines whether or not the given word has any advice on it." } ;
-
-HELP: ad-do-it
-{ $values { "input" "an object" } { "result" "an object" } }
-{ $description "Calls either the next applicable around advice or the main body, returning back to the point it was called from when finished. This word should only be called from inside advice." }
-{ $see-also coyield } ;
-
-ARTICLE: "advice" "Advice"
-"Advice is a simple way of adding additition functionality to words by adding 'hooks' to a word, which can act before, after, or around the calling of the word." ;
-
-ABOUT: "advice"
\ No newline at end of file
+++ /dev/null
-! Copyright (C) 2008 James Cash
-! See http://factorcode.org/license.txt for BSD license.
-USING: kernel sequences io io.streams.string math tools.test advice math.parser
-parser namespaces multiline eval words assocs ;
-IN: advice.tests
-
-[
- [ ad-do-it ] must-fail
-
- : foo ( -- str ) "foo" ;
- \ foo make-advised
-
- { "bar" "foo" } [
- [ "bar" ] "barify" \ foo advise-before
- foo
- ] unit-test
-
- { "bar" "foo" "baz" } [
- [ "baz" ] "bazify" \ foo advise-after
- foo
- ] unit-test
-
- { "foo" "baz" } [
- "barify" \ foo before remove-advice
- foo
- ] unit-test
-
- : bar ( a -- b ) 1+ ;
- \ bar make-advised
-
- { 11 } [
- [ 2 * ] "double" \ bar advise-before
- 5 bar
- ] unit-test
-
- { 11/3 } [
- [ 3 / ] "third" \ bar advise-after
- 5 bar
- ] unit-test
-
- { -2 } [
- [ -1 * ad-do-it 3 + ] "frobnobicate" \ bar advise-around
- 5 bar
- ] unit-test
-
- : add ( a b -- c ) + ;
- \ add make-advised
-
- { 10 } [
- [ [ 2 * ] bi@ ] "double-args" \ add advise-before
- 2 3 add
- ] unit-test
-
- { 21 } [
- [ 3 * ad-do-it 1- ] "around1" \ add advise-around
- 2 3 add
- ] unit-test
-
-! { 9 } [
-! [ [ 1- ] bi@ ad-do-it 2 / ] "around2" \ add advise-around
-! 2 3 add
-! ] unit-test
-
-! { { "around1" "around2" } } [
-! \ add around word-prop keys
-! ] unit-test
-
- { 5 f } [
- \ add unadvise
- 2 3 add \ add advised?
- ] unit-test
-
-! : quux ( a b -- c ) * ;
-
-! { f t 3+3/4 } [
-! <" USING: advice kernel math ;
-! IN: advice.tests
-! \ quux advised?
-! ADVISE: quux halve before [ 2 / ] bi@ ;
-! \ quux advised?
-! 3 5 quux"> eval
-! ] unit-test
-
-! { 3+3/4 "1+1/2 2+1/2 3+3/4" } [
-! <" USING: advice kernel math math.parser io io.streams.string ;
-! IN: advice.tests
-! ADVISE: quux log around
-! 2dup [ number>string write " " write ] bi@
-! ad-do-it
-! dup number>string write ;
-! [ 3 5 quux ] with-string-writer"> eval
-! ] unit-test
-
-] with-scope
\ No newline at end of file
+++ /dev/null
-! Copyright (C) 2008 James Cash
-! See http://factorcode.org/license.txt for BSD license.
-USING: kernel sequences fry words assocs linked-assocs tools.annotations
-coroutines lexer parser quotations arrays namespaces continuations ;
-IN: advice
-
-SYMBOLS: before after around advised in-advice? ;
-
-: advised? ( word -- ? )
- advised word-prop ;
-
-DEFER: make-advised
-
-<PRIVATE
-: init-around-co ( quot -- coroutine )
- \ coreset suffix cocreate ;
-PRIVATE>
-
-: advise ( quot name word loc -- )
- dup around eq? [ [ init-around-co ] 3dip ] when
- over advised? [ over make-advised ] unless
- word-prop set-at ;
-
-: advise-before ( quot name word -- ) before advise ;
-
-: advise-after ( quot name word -- ) after advise ;
-
-: advise-around ( quot name word -- ) around advise ;
-
-: get-advice ( word type -- seq )
- word-prop values ;
-
-: call-before ( word -- )
- before get-advice [ call ] each ;
-
-: call-after ( word -- )
- after get-advice [ call ] each ;
-
-: call-around ( main word -- )
- t in-advice? [
- around get-advice tuck
- [ [ coresume ] each ] [ call ] [ <reversed> [ coresume ] each ] tri*
- ] with-variable ;
-
-: remove-advice ( name word loc -- )
- word-prop delete-at ;
-
-: ad-do-it ( input -- result )
- in-advice? get [ "ad-do-it should only be called inside 'around' advice" throw ] unless coyield ;
-
-: make-advised ( word -- )
- [ dup '[ [ _ ] dip over dup '[ _ call-before _ _ call-around _ call-after ] ] annotate ]
- [ { before after around } [ <linked-hash> swap set-word-prop ] with each ]
- [ t advised set-word-prop ] tri ;
-
-: unadvise ( word -- )
- [ reset ] [ { before after around advised } [ f swap set-word-prop ] with each ] bi ;
-
-SYNTAX: ADVISE: ! word adname location => word adname quot loc
- scan-word scan scan-word parse-definition swap [ spin ] dip advise ;
-
-SYNTAX: UNADVISE:
- scan-word parsed \ unadvise parsed ;
\ No newline at end of file
+++ /dev/null
-James Cash
+++ /dev/null
-Implmentation of advice/aspects
+++ /dev/null
-extensions
: process-day ( account date -- )
2dup accumulate-interest ?pay-interest ;
-: each-day ( quot start end -- )
+: each-day ( quot: ( -- ) start end -- )
2dup before? [
[ dup [ over [ swap call ] dip ] dip 1 days time+ ] dip each-day
] [
: process-to-date ( account date -- account )
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 )
[ [ date>> process-to-date ] keep >>transaction ] each ;
: base64-benchmark ( -- )
65535 [ 255 bitand ] "" map-as
- 100 [ >base64 base64> ] times
+ 20 [ >base64 base64> ] times
drop ;
MAIN: base64-benchmark
-! Copyright (C) 2007, 2008 Slava Pestov.
+! Copyright (C) 2007, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel vocabs vocabs.loader tools.time tools.vocabs
arrays assocs io.styles io help.markup prettyprint sequences
-continuations debugger math ;
+continuations debugger math namespaces ;
IN: benchmark
-: run-benchmark ( vocab -- result )
+<PRIVATE
+
+SYMBOL: timings
+SYMBOL: errors
+
+PRIVATE>
+
+: run-benchmark ( vocab -- )
[ "=== " write vocab-name print flush ] [
- [ [ require ] [ [ run ] benchmark ] bi ] curry
- [ error. f ] recover
+ [ [ require ] [ [ run ] benchmark ] [ ] tri timings ]
+ [ swap errors ]
+ recover get set-at
] bi ;
-: run-benchmarks ( -- assoc )
- "benchmark" all-child-vocabs-seq
- [ dup run-benchmark ] { } map>assoc ;
+: run-benchmarks ( -- timings errors )
+ [
+ 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 [
[
[ "Benchmark" write ] with-cell
[
[
[ [ 1array $vocab-link ] with-cell ]
- [ [ 1000000 /f pprint-cell ] [ [ "failed" write ] with-cell ] if* ] bi*
+ [ 1000000 /f pprint-cell ]
+ bi*
] with-row
] assoc-each
] tabular-output nl ;
+: benchmark-errors. ( errors -- )
+ [
+ [ "=== " write vocab-name print ]
+ [ error. ]
+ bi*
+ ] assoc-each ;
+
: benchmarks ( -- )
- run-benchmarks benchmarks. ;
+ run-benchmarks [ timings. ] [ benchmark-errors. ] bi* ;
MAIN: benchmarks
1 [a,b] [ number>string all-unique? ] count ; inline
: beust ( -- )
- 10000000 count-numbers
+ 2000000 count-numbers
number>string " unique numbers." append print ;
MAIN: beust
:: beust ( -- )
[let | i! [ 0 ] |
- 10000000000 [ i 1+ i! ] count-numbers
+ 5000000000 [ i 1+ i! ] count-numbers
i number>string " unique numbers." append print
] ;
] alien-callback\r
"int" { "int" } "cdecl" alien-indirect ;\r
\r
-: fib-main ( -- ) 34 fib drop ;\r
+: fib-main ( -- ) 32 fib drop ;\r
\r
MAIN: fib-main\r
-USING: checksums checksums.md5 io.files kernel ;
+USING: checksums checksums.md5 sequences byte-arrays kernel ;
IN: benchmark.md5
: md5-file ( -- )
- "vocab:mime/multipart/multipart-tests.factor" md5 checksum-file drop ;
+ 2000000 iota >byte-array md5 checksum-bytes drop ;
MAIN: md5-file
] with-file-writer ;
: random-main ( -- )
- 1000000 write-random-numbers ;
+ 300000 write-random-numbers ;
MAIN: random-main
-USING: checksums checksums.sha1 io.files kernel ;
+USING: checksums checksums.sha1 sequences byte-arrays kernel ;
IN: benchmark.sha1
: sha1-file ( -- )
- "vocab:mime/multipart/multipart-tests.factor" sha1 checksum-file drop ;
+ 2000000 iota >byte-array sha1 checksum-bytes drop ;
MAIN: sha1-file
ascii [ 0 sum-file-loop ] with-file-reader . ;
: sum-file-main ( -- )
- random-numbers-path sum-file ;
+ 5 [ random-numbers-path sum-file ] times ;
MAIN: sum-file-main
: coresume ( v co -- result )
[
>>exitcc
- resumecc>> call
+ resumecc>> call( -- )
#! At this point, the coroutine quotation must have terminated
- #! normally (without calling coyield, coreset, or coterminate). This shouldn't happen.
+ #! normally (without calling coyield, coreset, or coterminate).
+ #! This shouldn't happen.
f over
] callcc1 2nip ;
: coreset ( v -- )
current-coro get dup
originalcc>> >>resumecc
- exitcc>> continue-with ;
\ No newline at end of file
+ exitcc>> continue-with ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-: forever ( quot -- ) [ call ] [ forever ] bi ; inline recursive
\ No newline at end of file
+: forever ( quot: ( -- ) -- ) [ call ] [ forever ] bi ; inline recursive
\ No newline at end of file
t fuel-eval-res-flag set-global
: fuel-eval-restartable? ( -- ? )
- fuel-eval-res-flag get-global ; inline
+ fuel-eval-res-flag get-global ;
: fuel-push-status ( -- )
in get use get clone restarts get-global clone
fuel-status-stack get push ;
: fuel-pop-restarts ( restarts -- )
- fuel-eval-restartable? [ drop ] [ clone restarts set-global ] if ; inline
+ fuel-eval-restartable? [ drop ] [ clone restarts set-global ] if ;
: fuel-pop-status ( -- )
fuel-status-stack get empty? [
[ restarts>> fuel-pop-restarts ] tri
] unless ;
-: fuel-forget-error ( -- ) f error set-global ; inline
-: fuel-forget-result ( -- ) f fuel-eval-result set-global ; inline
-: fuel-forget-output ( -- ) f fuel-eval-output set-global ; inline
+: fuel-forget-error ( -- ) f error set-global ;
+: fuel-forget-result ( -- ) f fuel-eval-result set-global ;
+: fuel-forget-output ( -- ) f fuel-eval-output set-global ;
: fuel-forget-status ( -- )
- fuel-forget-error fuel-forget-result fuel-forget-output ; inline
+ fuel-forget-error fuel-forget-result fuel-forget-output ;
: fuel-send-retort ( -- )
error get fuel-eval-result get-global fuel-eval-output get-global
3array fuel-pprint flush nl "<~FUEL~>" write nl flush ;
: (fuel-begin-eval) ( -- )
- fuel-push-status fuel-forget-status ; inline
+ fuel-push-status fuel-forget-status ;
: (fuel-end-eval) ( output -- )
- fuel-eval-output set-global fuel-send-retort fuel-pop-status ; inline
+ fuel-eval-output set-global fuel-send-retort fuel-pop-status ;
: (fuel-eval) ( lines -- )
- [ [ parse-lines ] with-compilation-unit call ] curry
- [ print-error ] recover ; inline
+ [ [ parse-lines ] with-compilation-unit call( -- ) ] curry
+ [ print-error ] recover ;
: (fuel-eval-each) ( lines -- )
- [ 1vector (fuel-eval) ] each ; inline
+ [ (fuel-eval) ] each ;
: (fuel-eval-usings) ( usings -- )
- [ "USING: " prepend " ;" append ] map
+ [ "USE: " prepend ] map
(fuel-eval-each) fuel-forget-error fuel-forget-output ;
: (fuel-eval-in) ( in -- )
- [ dup "IN: " prepend 1vector (fuel-eval) in set ] when* ; inline
+ [ dup "IN: " prepend (fuel-eval) in set ] when* ;
: (fuel-eval-in-context) ( lines in usings -- )
(fuel-begin-eval)
- [ (fuel-eval-usings) (fuel-eval-in) (fuel-eval) ] with-string-writer
+ [ (fuel-eval-usings) (fuel-eval-in) "\n" join (fuel-eval) ] with-string-writer
(fuel-end-eval) ;
: fuel-vocab-summary ( name -- )
(fuel-vocab-summary) fuel-eval-set-result ;
-: fuel-index ( quot -- ) call format-index fuel-eval-set-result ;
+: fuel-index ( quot -- ) call( -- seq ) format-index fuel-eval-set-result ;
: fuel-get-vocabs/tag ( tag -- )
(fuel-get-vocabs/tag) fuel-eval-set-result ;
+++ /dev/null
-William Schlieper
+++ /dev/null
-! See http://factorcode.org/license.txt for BSD licence.
-USING: help.markup help.syntax ;
-
-IN: graph-theory
-
-ARTICLE: "graph-protocol" "Graph protocol"
-"All graphs must be instances of the graph mixin:"
-{ $subsection graph }
-"All graphs must implement a method on the following generic word:"
-{ $subsection vertices }
-"At least one of the following two generic words must have a method; the " { $link graph } " mixin has default definitions which are mutually recursive:"
-{ $subsection adjlist }
-{ $subsection adj? }
-"All mutable graphs must implement a method on the following generic word:"
-{ $subsection add-blank-vertex }
-"All mutable undirected graphs must implement a method on the following generic word:"
-{ $subsection add-edge }
-"Mutable directed graphs should not implement the above word, as it has a default definition defined in terms of the following generic word:"
-{ $subsection add-edge* }
-"The following two words have default definitions, but are available as generics to allow implementations to optimize them:"
-{ $subsection num-vertices }
-{ $subsection num-edges } ;
-
-HELP: graph
-{ $class-description "A mixin class whose instances are graphs. Custom implementations of the graph protocol should be declared as instances of this mixin for all graph functionality to work correctly:"
- { $code "INSTANCE: hex-board graph" }
-} ;
-
-{ vertices num-vertices num-edges } related-words
-
-HELP: vertices
-{ $values { "graph" graph } { "seq" "The vertices" } }
-{ $description "Returns the vertices of the graph." } ;
-
-HELP: num-vertices
-{ $values { "graph" graph } { "n" "The number of vertices" } }
-{ $description "Returns the number of vertices in the graph." } ;
-
-HELP: num-edges
-{ $values { "graph" "A graph" } { "n" "The number of edges" } }
-{ $description "Returns the number of edges in the graph." } ;
-
-{ adjlist adj? } related-words
-
-HELP: adjlist
-{ $values
- { "from" "The index of a vertex" }
- { "graph" "The graph to be examined" }
- { "seq" "The adjacency list" } }
-{ $description "Returns a sequence of vertices that this vertex links to" } ;
-
-HELP: adj?
-{ $values
- { "from" "The index of a vertex" }
- { "to" "The index of a vertex" }
- { "graph" "A graph" }
- { "?" "A boolean" } }
-{ $description "Returns a boolean describing whether there is an edge in the graph between from and to." } ;
-
-{ add-blank-vertex add-blank-vertices add-edge add-edge* } related-words
-
-HELP: add-blank-vertex
-{ $values
- { "index" "A vertex index" }
- { "graph" "A graph" } }
-{ $description "Adds a vertex to the graph." } ;
-
-HELP: add-blank-vertices
-{ $values
- { "seq" "A sequence of vertex indices" }
- { "graph" "A graph" } }
-{ $description "Adds vertices with indices in seq to the graph." } ;
-
-HELP: add-edge*
-{ $values
- { "from" "The index of a vertex" }
- { "to" "The index of another vertex" }
- { "graph" "A graph" } }
-{ $description "Adds a one-way edge to the graph, between " { $snippet "from" } " and " { $snippet "to" } "."
- $nl
- "If you want to add a two-way edge, use " { $link add-edge } " instead." } ;
-
-HELP: add-edge
-{ $values
- { "u" "The index of a vertex" }
- { "v" "The index of another vertex" }
- { "graph" "A graph" } }
-{ $description "Adds a two-way edge to the graph, between " { $snippet "u" } " and " { $snippet "v" } "."
- $nl
- "If you want to add a one-way edge, use " { $link add-edge* } " instead." } ;
-
-{ depth-first full-depth-first dag? topological-sort } related-words
-
-HELP: depth-first
-{ $values
- { "v" "The vertex to start the search at" }
- { "graph" "The graph to search" }
- { "pre" "A quotation of the form ( n -- )" }
- { "post" "A quotation of the form ( n -- )" }
- { "?list" "A list of booleans describing the vertices visited in the search" }
- { "?" "A boolean describing whether or not the end-search error was thrown" } }
-{ $description "Performs a depth-first search on " { $emphasis "graph" } ". The variable " { $emphasis "graph" } " can be accessed in both quotations."
- $nl
- "The " { $emphasis "pre" } " quotation is run before the recursive application of depth-first."
- $nl
- "The " { $emphasis "post" } " quotation is run after the recursive application of depth-first."
- $nl
- { $emphasis "?list" } " is a list of booleans, " { $link t } " for every vertex visted during the search, and " { $link f } " for every vertex not visited." } ;
-
-HELP: full-depth-first
-{ $values
- { "graph" "The graph to search" }
- { "pre" "A quotation of the form ( n -- )" }
- { "post" "A quotation of the form ( n -- )" }
- { "tail" "A quotation of the form ( -- )" }
- { "?" "A boolean describing whether or not the end-search error was thrown" } }
-{ $description "Performs a depth-first search on " { $emphasis "graph" } ". The variable " { $emphasis "graph" } "can be accessed in both quotations."
- $nl
- "The " { $emphasis "pre" } " quotation is run before the recursive application of depth-first."
- $nl
- "The " { $emphasis "post" } " quotation is run after the recursive application of depth-first."
- $nl
- "The " { $emphasis "tail" } " quotation is run after each time the depth-first search runs out of nodes. On an undirected graph this will be each connected subgroup but on a directed graph it can be more complex." } ;
-
-HELP: dag?
-{ $values
- { "graph" graph }
- { "?" "A boolean indicating if the graph is acyclic" } }
-{ $description "Using a depth-first search, determines if the specified directed graph is a directed acyclic graph. An undirected graph will produce a false result, as the algorithm does not eliminate cycles of length 2, which will include any edge that goes both ways." } ;
-
-HELP: topological-sort
-{ $values
- { "graph" graph }
- { "seq/f" "Either a sequence of values or f" } }
-{ $description "Using a depth-first search, topologically sorts the specified directed graph. Returns f if the graph contains any cycles, and a topologically sorted sequence otherwise." } ;
+++ /dev/null
-! Copyright (C) 2008 William Schlieper <schlieper@unc.edu>
-! See http://factorcode.org/license.txt for BSD license.
-
-USING: kernel combinators fry continuations sequences arrays vectors assocs hashtables heaps namespaces ;
-
-IN: graph-theory
-
-MIXIN: graph
-SYMBOL: visited?
-ERROR: end-search ;
-
-GENERIC: vertices ( graph -- seq ) flushable
-
-GENERIC: num-vertices ( graph -- n ) flushable
-
-GENERIC: num-edges ( graph -- n ) flushable
-
-GENERIC: adjlist ( from graph -- seq ) flushable
-
-GENERIC: adj? ( from to graph -- ? ) flushable
-
-GENERIC: add-blank-vertex ( index graph -- )
-
-GENERIC: delete-blank-vertex ( index graph -- )
-
-GENERIC: add-edge* ( from to graph -- )
-
-GENERIC: add-edge ( u v graph -- )
-
-GENERIC: delete-edge* ( from to graph -- )
-
-GENERIC: delete-edge ( u v graph -- )
-
-M: graph num-vertices
- vertices length ;
-
-M: graph num-edges
- [ vertices ] [ '[ _ adjlist length ] map sum ] bi ;
-
-M: graph adjlist
- [ vertices ] [ swapd '[ _ swap _ adj? ] filter ] bi ;
-
-M: graph adj?
- swapd adjlist index >boolean ;
-
-M: graph add-edge
- [ add-edge* ] [ swapd add-edge* ] 3bi ;
-
-M: graph delete-edge
- [ delete-edge* ] [ swapd delete-edge* ] 3bi ;
-
-: add-blank-vertices ( seq graph -- )
- '[ _ add-blank-vertex ] each ;
-
-: delete-vertex ( index graph -- )
- [ adjlist ]
- [ '[ _ _ 3dup adj? [ delete-edge* ] [ 3drop ] if ] each ]
- [ delete-blank-vertex ] 2tri ;
-
-<PRIVATE
-
-: search-wrap ( quot graph -- ? )
- [ [ graph set ] [ vertices [ f 2array ] map >hashtable visited? set ] bi
- [ t ] compose [ dup end-search? [ drop f ] [ rethrow ] if ] recover ] with-scope ; inline
-
-: (depth-first) ( v pre post -- )
- { [ 2drop visited? get t -rot set-at ]
- [ drop call ]
- [ [ graph get adjlist ] 2dip
- '[ dup visited? get at [ drop ] [ _ _ (depth-first) ] if ] each ]
- [ nip call ] } 3cleave ; inline
-
-PRIVATE>
-
-: depth-first ( v graph pre post -- ?list ? )
- '[ _ _ (depth-first) visited? get ] swap search-wrap ; inline
-
-: full-depth-first ( graph pre post tail -- ? )
- '[ [ visited? get [ nip not ] assoc-find ]
- [ drop _ _ (depth-first) @ ]
- while 2drop ] swap search-wrap ; inline
-
-: dag? ( graph -- ? )
- V{ } clone swap [ 2dup swap push dupd
- '[ _ swap graph get adj? not ] all?
- [ end-search ] unless ]
- [ drop dup pop* ] [ ] full-depth-first nip ;
-
-: topological-sort ( graph -- seq/f )
- dup dag?
- [ V{ } swap [ drop ] [ prefix ] [ ] full-depth-first drop ]
- [ drop f ] if ;
+++ /dev/null
-! Copyright (C) 2008 William Schlieper <schlieper@unc.edu>
-! See http://factorcode.org/license.txt for BSD license.
-
-USING: accessors kernel graph-theory ;
-
-IN: graph-theory.reversals
-
-TUPLE: reversal graph ;
-
-GENERIC: reverse-graph ( graph -- reversal )
-
-M: graph reverse-graph reversal boa ;
-
-M: reversal reverse-graph graph>> ;
-
-INSTANCE: reversal graph
-
-M: reversal vertices
- graph>> vertices ;
-
-M: reversal adj?
- swapd graph>> adj? ;
+++ /dev/null
-! Copyright (C) 2008 William Schlieper <schlieper@unc.edu>
-! See http://factorcode.org/license.txt for BSD license.
-
-USING: accessors kernel sequences arrays vectors sets assocs hashtables graph-theory namespaces fry ;
-
-IN: graph-theory.sparse
-
-TUPLE: sparse-graph alist ;
-
-: <sparse-graph> ( -- sparse-graph )
- H{ } clone sparse-graph boa ;
-
-: >sparse-graph ( graph -- sparse-graph )
- [ vertices ] keep
- '[ dup _ adjlist 2array ] map >hashtable sparse-graph boa ;
-
-INSTANCE: sparse-graph graph
-
-M: sparse-graph vertices
- alist>> keys ;
-
-M: sparse-graph adjlist
- alist>> at ;
-
-M: sparse-graph add-blank-vertex
- alist>> V{ } clone -rot set-at ;
-
-M: sparse-graph delete-blank-vertex
- alist>> delete-at ;
-
-M: sparse-graph add-edge*
- alist>> swapd at adjoin ;
-
-M: sparse-graph delete-edge*
- alist>> swapd at delete ;
+++ /dev/null
-Graph-theoretic algorithms
+++ /dev/null
-collections
IN: lint.tests
! Don't write code like this
-: lint1 ( -- ) [ "hi" print ] [ ] if ; ! when
+: lint1 ( obj -- ) [ "hi" print ] [ ] if ; ! when
[ { { lint1 { [ [ ] if ] } } } ] [ \ lint1 lint-word ] unit-test
-! Copyright (C) 2008 Eduardo Cavazos, Slava Pestov.
+! Copyright (C) 2008, 2009 Eduardo Cavazos, Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: arrays calendar io.directories io.encodings.utf8
+USING: arrays kernel calendar io.directories io.encodings.utf8
io.files io.launcher mason.child mason.cleanup mason.common
-mason.help mason.release mason.report namespaces prettyprint ;
+mason.help mason.release mason.report mason.email mason.notify
+namespaces prettyprint ;
IN: mason.build
QUALIFIED: continuations
: enter-build-dir ( -- ) build-dir set-current-directory ;
: clone-builds-factor ( -- )
- "git" "clone" builds/factor 3array try-process ;
+ "git" "clone" builds/factor 3array try-output-process ;
-: record-id ( -- )
- "factor" [ git-id ] with-directory "git-id" to-file ;
+: begin-build ( -- )
+ "factor" [ git-id ] with-directory
+ [ "git-id" to-file ] [ notify-begin-build ] bi ;
: build ( -- )
create-build-dir
enter-build-dir
clone-builds-factor
[
- record-id
+ begin-build
build-child
- upload-help
- release
+ [ notify-report ]
+ [ status-clean eq? [ upload-help release ] when ] bi
] [ cleanup ] [ ] continuations:cleanup ;
MAIN: build
boot-cmd
] with-scope
] unit-test
+
+[ [ "Hi" print ] [ drop 3 ] [ 4 ] recover-else ] must-infer
+
+[ 4 ] [ [ "Hi" print ] [ drop 3 ] [ 4 ] recover-else ] unit-test
+
+[ 3 ] [ [ "Hi" throw ] [ drop 3 ] [ 4 ] recover-else ] unit-test
+
+[ "A" ] [
+ {
+ { [ 3 throw ] [ { "X" "Y" "Z" "A" } nth ] }
+ [ "B" ]
+ } recover-cond
+] unit-test
+
+[ "B" ] [
+ {
+ { [ ] [ ] }
+ [ "B" ]
+ } recover-cond
+] unit-test
\ No newline at end of file
! Copyright (C) 2008, 2009 Eduardo Cavazos, Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors arrays calendar combinators.short-circuit
+USING: accessors arrays calendar combinators.short-circuit fry
continuations debugger io.directories io.files io.launcher
io.pathnames io.encodings.ascii kernel make mason.common mason.config
-mason.platform mason.report mason.email namespaces sequences ;
+mason.platform mason.report mason.notify namespaces sequences
+quotations macros ;
IN: mason.child
: make-cmd ( -- args )
try-process
] with-directory ;
-: return-with ( obj -- * ) return-continuation get continue-with ;
+: recover-else ( try catch else -- )
+ [ [ '[ @ f t ] ] [ '[ @ f ] ] bi* recover ] dip '[ drop @ ] when ; inline
-: build-clean? ( -- ? )
- {
- [ load-everything-vocabs-file eval-file empty? ]
- [ test-all-vocabs-file eval-file empty? ]
- [ help-lint-vocabs-file eval-file empty? ]
- [ compiler-errors-file eval-file empty? ]
- } 0&& ;
-
-: build-child ( -- )
- [
- return-continuation set
-
- copy-image
+MACRO: recover-cond ( alist -- )
+ dup { [ length 1 = ] [ first callable? ] } 1&&
+ [ first ] [ [ first first2 ] [ rest ] bi '[ _ _ [ _ recover-cond ] recover-else ] ] if ;
- [ make-vm ] [ compile-failed-report status-error return-with ] recover
- [ boot ] [ boot-failed-report status-error return-with ] recover
- [ test ] [ test-failed-report status-error return-with ] recover
-
- successful-report
-
- build-clean? status-clean status-dirty ? return-with
- ] callcc1
- status set
- email-report ;
\ No newline at end of file
+: build-child ( -- status )
+ copy-image
+ {
+ { [ notify-make-vm make-vm ] [ compile-failed ] }
+ { [ notify-boot boot ] [ boot-failed ] }
+ { [ notify-test test ] [ test-failed ] }
+ [ success ]
+ } recover-cond ;
\ No newline at end of file
mason.common mason.config mason.platform namespaces ;
IN: mason.cleanup
+: compress ( filename -- )
+ dup exists? [ "bzip2" swap 2array try-output-process ] [ drop ] if ;
+
: compress-image ( -- )
- "bzip2" boot-image-name 2array try-process ;
+ boot-image-name compress ;
: compress-test-log ( -- )
- "test-log" exists? [
- { "bzip2" "test-log" } try-process
- ] when ;
+ "test-log" compress ;
: cleanup ( -- )
builder-debug get [
math.functions make io io.files io.pathnames io.directories
io.directories.hierarchy io.launcher io.encodings.utf8 prettyprint
combinators.short-circuit parser combinators calendar
-calendar.format arrays mason.config locals system ;
+calendar.format arrays mason.config locals system debugger ;
IN: mason.common
+ERROR: output-process-error output process ;
+
+M: output-process-error error.
+ [ "Process:" print process>> . nl ]
+ [ "Output:" print output>> print ]
+ bi ;
+
+: try-output-process ( command -- )
+ >process +stdout+ >>stderr utf8 <process-reader*>
+ [ contents ] [ dup wait-for-process ] bi*
+ 0 = [ 2drop ] [ output-process-error ] if ;
+
HOOK: really-delete-tree os ( path -- )
M: windows really-delete-tree
#! Workaround: Cygwin GIT creates read-only files for
#! some reason.
- [ { "chmod" "ug+rw" "-R" } swap (normalize-path) suffix try-process ]
+ [ { "chmod" "ug+rw" "-R" } swap (normalize-path) suffix try-output-process ]
[ delete-tree ]
bi ;
<process>
swap >>command
15 minutes >>timeout
- try-process ;
+ try-output-process ;
:: upload-safely ( local username host remote -- )
[let* | temp [ remote ".incomplete" append ]
: prepare-build-machine ( -- )
builds-dir get make-directories
builds-dir get
- [ { "git" "clone" "git://factorcode.org/git/factor.git" } try-process ]
+ [ { "git" "clone" "git://factorcode.org/git/factor.git" } try-output-process ]
with-directory ;
: git-id ( -- id )
CONSTANT: html-help-time-file "html-help-time"
CONSTANT: benchmarks-file "benchmarks"
-
-SYMBOL: status
+CONSTANT: benchmark-error-messages-file "benchmark-error-messages"
+CONSTANT: benchmark-error-vocabs-file "benchmark-error-vocabs"
SYMBOL: status-error ! didn't bootstrap, or crashed
SYMBOL: status-dirty ! bootstrapped but not all tests passed
home "builds" append-path builds-dir set-global
] unless
-! Who sends build reports.
+! Who sends build report e-mails.
SYMBOL: builder-from
-! Who receives build reports.
+! Who receives build report e-mails.
SYMBOL: builder-recipients
+! (Optional) twitter credentials for status updates.
+SYMBOL: builder-twitter-username
+
+SYMBOL: builder-twitter-password
+
! (Optional) CPU architecture to build for.
SYMBOL: target-cpu
! Keep test-log around?
SYMBOL: builder-debug
+! Host to send status notifications to.
+SYMBOL: status-host
+
+! Username to log in.
+SYMBOL: status-username
+
SYMBOL: upload-help?
! The below are only needed if upload-help is true.
-! Copyright (C) 2008 Eduardo Cavazos, Slava Pestov.
+! Copyright (C) 2008, 2009 Eduardo Cavazos, Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel namespaces accessors combinators make smtp
-debugger prettyprint io io.streams.string io.encodings.utf8
-io.files io.sockets
+USING: kernel namespaces accessors combinators make smtp debugger
+prettyprint io io.streams.string io.encodings.utf8 io.files io.sockets
mason.common mason.platform mason.config ;
IN: mason.email
: prefix-subject ( str -- str' )
[ "mason on " % platform % ": " % % ] "" make ;
-: email-status ( body subject -- )
+: email-status ( body content-type subject -- )
<email>
builder-from get >>from
builder-recipients get >>to
swap prefix-subject >>subject
+ swap >>content-type
swap >>body
send-email ;
-: subject ( -- str )
- status get {
+: subject ( status -- str )
+ {
{ status-clean [ "clean" ] }
{ status-dirty [ "dirty" ] }
{ status-error [ "error" ] }
} case ;
-: email-report ( -- )
- "report" utf8 file-contents subject email-status ;
+: email-report ( report status -- )
+ [ "text/html" ] dip subject email-status ;
: email-error ( error callstack -- )
[
"Fatal error on " write host-name print nl
[ error. ] [ callstack. ] bi*
- ] with-string-writer "fatal error"
+ ] with-string-writer "text/plain" "fatal error"
email-status ;
-! Copyright (C) 2008 Slava Pestov.
+! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays help.html io.directories io.files io.launcher
kernel make mason.common mason.config namespaces sequences ;
: make-help-archive ( -- )
"factor/temp" [
- { "tar" "cfz" "docs.tar.gz" "docs" } try-process
+ { "tar" "cfz" "docs.tar.gz" "docs" } try-output-process
] with-directory ;
: upload-help-archive ( -- )
help-directory get "/docs.tar.gz" append
upload-safely ;
-: (upload-help) ( -- )
+: upload-help ( -- )
upload-help? get [
make-help-archive
upload-help-archive
- ] when ;
-
-: upload-help ( -- )
- status get status-clean eq? [ (upload-help) ] when ;
+ ] when ;
\ No newline at end of file
IN: mason
: build-loop-error ( error -- )
- error-continuation get call>> email-error ;
+ [ "Build loop error:" print flush error. flush ]
+ [ error-continuation get call>> email-error ] bi ;
: build-loop-fatal ( error -- )
"FATAL BUILDER ERROR:" print
--- /dev/null
+Slava Pestov
\ No newline at end of file
--- /dev/null
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: arrays accessors io io.sockets io.encodings.utf8 io.files
+io.launcher kernel make mason.config mason.common mason.email
+mason.twitter namespaces sequences ;
+IN: mason.notify
+
+: status-notify ( input-file args -- )
+ status-host get [
+ [
+ "ssh" , status-host get , "-l" , status-username get ,
+ "./mason-notify" ,
+ host-name ,
+ target-cpu get ,
+ target-os get ,
+ ] { } make prepend
+ <process>
+ swap >>command
+ swap [ +closed+ ] unless* >>stdin
+ try-output-process
+ ] [ 2drop ] if ;
+
+: notify-begin-build ( git-id -- )
+ [ "Starting build of GIT ID " write print flush ]
+ [ f swap "git-id" swap 2array status-notify ]
+ bi ;
+
+: notify-make-vm ( -- )
+ "Compiling VM" print flush
+ f { "make-vm" } status-notify ;
+
+: notify-boot ( -- )
+ "Bootstrapping" print flush
+ f { "boot" } status-notify ;
+
+: notify-test ( -- )
+ "Running tests" print flush
+ f { "test" } status-notify ;
+
+: notify-report ( status -- )
+ [ "Build finished with status: " write print flush ]
+ [
+ [ "report" utf8 file-contents ] dip email-report
+ "report" { "report" } status-notify
+ ] bi ;
+
+: notify-release ( archive-name -- )
+ "Uploaded " prepend [ print flush ] [ mason-tweet ] bi ;
\ No newline at end of file
: archive-name ( -- string ) base-name extension append ;
-: make-windows-archive ( -- )
- [ "zip" , "-r" , archive-name , "factor" , ] { } make try-process ;
+: make-windows-archive ( archive-name -- )
+ [ "zip" , "-r" , , "factor" , ] { } make try-output-process ;
-: make-macosx-archive ( -- )
- { "mkdir" "dmg-root" } try-process
- { "cp" "-R" "factor" "dmg-root" } try-process
+: make-macosx-archive ( archive-name -- )
+ { "mkdir" "dmg-root" } try-output-process
+ { "cp" "-R" "factor" "dmg-root" } try-output-process
{ "hdiutil" "create"
"-srcfolder" "dmg-root"
"-fs" "HFS+"
"-volname" "factor" }
- archive-name suffix try-process
+ swap suffix try-output-process
"dmg-root" really-delete-tree ;
-: make-unix-archive ( -- )
- [ "tar" , "-cvzf" , archive-name , "factor" , ] { } make try-process ;
+: make-unix-archive ( archive-name -- )
+ [ "tar" , "-cvzf" , , "factor" , ] { } make try-output-process ;
-: make-archive ( -- )
+: make-archive ( archive-name -- )
target-os get {
{ "winnt" [ make-windows-archive ] }
{ "macosx" [ make-macosx-archive ] }
: releases ( -- path )
builds-dir get "releases" append-path dup make-directories ;
-: save-archive ( -- )
- archive-name releases move-file-into ;
\ No newline at end of file
+: save-archive ( archive-name -- )
+ releases move-file-into ;
\ No newline at end of file
-! Copyright (C) 2008 Eduardo Cavazos.
+! Copyright (C) 2008, 2009 Eduardo Cavazos, Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel debugger namespaces sequences splitting
+USING: kernel debugger namespaces sequences splitting combinators
combinators io io.files io.launcher prettyprint bootstrap.image
mason.common mason.release.branch mason.release.tidy
-mason.release.archive mason.release.upload ;
+mason.release.archive mason.release.upload mason.notify ;
IN: mason.release
-: (release) ( -- )
+: release ( -- )
update-clean-branch
tidy
- make-archive
- upload
- save-archive ;
-
-: release ( -- ) status get status-clean eq? [ (release) ] when ;
\ No newline at end of file
+ archive-name {
+ [ make-archive ]
+ [ upload ]
+ [ save-archive ]
+ [ notify-release ]
+ } cleave ;
\ No newline at end of file
: remote-location ( -- dest )
upload-directory get "/" platform 3append ;
-: remote-archive-name ( -- dest )
- remote-location "/" archive-name 3append ;
+: remote-archive-name ( archive-name -- dest )
+ [ remote-location "/" ] dip 3append ;
-: upload ( -- )
+: upload ( archive-name -- )
upload-to-factorcode? get [
- archive-name
upload-username get
upload-host get
- remote-archive-name
+ pick remote-archive-name
upload-safely
- ] when ;
+ ] [ drop ] if ;
IN: mason.report.tests
USING: mason.report tools.test ;
+
+{ 0 0 } [ [ ] with-report ] must-infer-as
\ No newline at end of file
-! Copyright (C) 2008 Eduardo Cavazos, Slava Pestov.
+! Copyright (C) 2008, 2009 Eduardo Cavazos, Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel namespaces debugger fry io io.files io.sockets
-io.encodings.utf8 prettyprint benchmark mason.common
-mason.platform mason.config sequences ;
+USING: benchmark combinators.smart debugger fry io assocs
+io.encodings.utf8 io.files io.sockets io.streams.string kernel
+locals mason.common mason.config mason.platform math namespaces
+prettyprint sequences xml.syntax xml.writer combinators.short-circuit ;
IN: mason.report
-: time. ( file -- )
- [ write ": " write ] [ eval-file milli-seconds>time print ] bi ;
-
-: common-report ( -- )
- "Build machine: " write host-name print
- "CPU: " write target-cpu get print
- "OS: " write target-os get print
- "Build directory: " write build-dir print
- "git id: " write "git-id" eval-file print nl ;
+: common-report ( -- xml )
+ target-os get
+ target-cpu get
+ host-name
+ build-dir
+ "git-id" eval-file
+ [XML
+ <h1>Build report for <->/<-></h1>
+ <table>
+ <tr><td>Build machine:</td><td><-></td></tr>
+ <tr><td>Build directory:</td><td><-></td></tr>
+ <tr><td>GIT ID:</td><td><-></td></tr>
+ </table>
+ XML] ;
: with-report ( quot -- )
- [ "report" utf8 ] dip '[ common-report @ ] with-file-writer ; inline
+ [ "report" utf8 ] dip
+ '[
+ common-report
+ _ call( -- xml )
+ [XML <html><body><-><-></body></html> XML]
+ pprint-xml
+ ] with-file-writer ; inline
-: compile-failed-report ( error -- )
+:: failed-report ( error file what -- status )
[
- "VM compile failed:" print nl
- "compile-log" cat nl
- error.
- ] with-report ;
+ error [ error. ] with-string-writer :> error
+ file utf8 file-contents 400 short tail* :> output
+
+ [XML
+ <h2><-what-></h2>
+ Build output:
+ <pre><-output-></pre>
+ Launcher error:
+ <pre><-error-></pre>
+ XML]
+ ] with-report
+ status-error ;
-: boot-failed-report ( error -- )
- [
- "Bootstrap failed:" print nl
- "boot-log" 100 cat-n nl
- error.
- ] with-report ;
+: compile-failed ( error -- status )
+ "compile-log" "VM compilation failed" failed-report ;
+
+: boot-failed ( error -- status )
+ "boot-log" "Bootstrap failed" failed-report ;
+
+: test-failed ( error -- status )
+ "test-log" "Tests failed" failed-report ;
+
+: timings-table ( -- xml )
+ {
+ boot-time-file
+ load-time-file
+ test-time-file
+ help-lint-time-file
+ benchmark-time-file
+ html-help-time-file
+ } [
+ dup utf8 file-contents milli-seconds>time
+ [XML <tr><td><-></td><td><-></td></tr> XML]
+ ] map [XML <h2>Timings</h2> <table><-></table> XML] ;
+
+: error-dump ( heading vocabs-file messages-file -- xml )
+ [ eval-file ] dip over empty? [ 3drop f ] [
+ [ ]
+ [ [ [XML <li><-></li> XML] ] map [XML <ul><-></ul> XML] ]
+ [ utf8 file-contents ]
+ tri*
+ [XML <h1><-></h1> <-> Details: <pre><-></pre> XML]
+ ] if ;
-: test-failed-report ( error -- )
+: benchmarks-table ( assoc -- xml )
[
- "Tests failed:" print nl
- "test-log" 100 cat-n nl
- error.
- ] with-report ;
+ 1000000 /f
+ [XML <tr><td><-></td><td><-></td></tr> XML]
+ ] { } assoc>map [XML <h2>Benchmarks</h2> <table><-></table> XML] ;
: successful-report ( -- )
[
- boot-time-file time.
- load-time-file time.
- test-time-file time.
- help-lint-time-file time.
- benchmark-time-file time.
- html-help-time-file time.
-
- nl
-
- load-everything-vocabs-file eval-file [
- "== Did not pass load-everything:" print .
- load-everything-errors-file cat
- ] unless-empty
-
- compiler-errors-file eval-file [
- "== Vocabularies with compiler errors:" print .
- ] unless-empty
-
- test-all-vocabs-file eval-file [
- "== Did not pass test-all:" print .
- test-all-errors-file cat
- ] unless-empty
-
- help-lint-vocabs-file eval-file [
- "== Did not pass help-lint:" print .
- help-lint-errors-file cat
- ] unless-empty
-
- "== Benchmarks:" print
- benchmarks-file eval-file benchmarks.
- ] with-report ;
\ No newline at end of file
+ [
+ timings-table
+
+ "Load failures"
+ load-everything-vocabs-file
+ load-everything-errors-file
+ error-dump
+
+ "Compiler warnings and errors"
+ compiler-errors-file
+ compiler-error-messages-file
+ error-dump
+
+ "Unit test failures"
+ test-all-vocabs-file
+ test-all-errors-file
+ error-dump
+
+ "Help lint failures"
+ help-lint-vocabs-file
+ help-lint-errors-file
+ error-dump
+
+ "Benchmark errors"
+ benchmark-error-vocabs-file
+ benchmark-error-messages-file
+ error-dump
+
+ "Benchmark timings"
+ benchmarks-file eval-file benchmarks-table
+ ] output>array
+ ] with-report ;
+
+: build-clean? ( -- ? )
+ {
+ [ load-everything-vocabs-file eval-file empty? ]
+ [ test-all-vocabs-file eval-file empty? ]
+ [ help-lint-vocabs-file eval-file empty? ]
+ [ compiler-errors-file eval-file empty? ]
+ [ benchmark-error-vocabs-file eval-file empty? ]
+ } 0&& ;
+
+: success ( -- status )
+ successful-report build-clean? status-clean status-dirty ? ;
\ No newline at end of file
-! Copyright (C) 2008 Eduardo Cavazos, Slava Pestov.
+! Copyright (C) 2008, 2009 Eduardo Cavazos, Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors assocs benchmark bootstrap.stage2
-compiler.errors generic help.html help.lint io.directories
+USING: accessors assocs benchmark bootstrap.stage2 compiler.errors
+source-files.errors generic help.html help.lint io.directories
io.encodings.utf8 io.files kernel mason.common math namespaces
-prettyprint sequences sets sorting tools.test tools.time
-tools.vocabs words system io tools.errors locals ;
+prettyprint sequences sets sorting tools.test tools.time tools.vocabs
+words system io tools.errors locals ;
IN: mason.test
: do-load ( -- )
M: method-body word-vocabulary "method-generic" word-prop word-vocabulary ;
:: do-step ( errors summary-file details-file -- )
- errors [ file>> ] map prune natural-sort summary-file to-file
+ errors
+ [ error-type +linkage-error+ eq? not ] filter
+ [ file>> ] map prune natural-sort summary-file to-file
errors details-file utf8 [ errors. ] with-file-writer ;
: do-compile-errors ( -- )
do-step ;
: do-benchmarks ( -- )
- run-benchmarks benchmarks-file to-file ;
+ run-benchmarks
+ [ benchmarks-file to-file ] [
+ [ keys benchmark-error-vocabs-file to-file ]
+ [ benchmark-error-messages-file utf8 [ benchmark-errors. ] with-file-writer ] bi
+ ] bi* ;
: benchmark-ms ( quot -- ms )
benchmark 1000 /i ; inline
--- /dev/null
+Slava Pestov
\ No newline at end of file
--- /dev/null
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: debugger fry kernel mason.config namespaces twitter ;
+IN: mason.twitter
+
+: mason-tweet ( message -- )
+ builder-twitter-username get builder-twitter-password get and
+ [
+ [
+ builder-twitter-username get twitter-username set
+ builder-twitter-password get twitter-password set
+ '[ _ tweet ] try
+ ] with-scope
+ ] [ drop ] if ;
\ No newline at end of file
[ bi - ] 2curry ; inline
: eval ( x func -- pt )
- dupd call 2array ; inline
+ dupd call( x -- y ) 2array ; inline
: eval-inverse ( y func -- pt )
- dupd call swap 2array ; inline
+ dupd call( y -- x ) swap 2array ; inline
: eval3d ( x y func -- pt )
- [ 2dup ] dip call 3array ; inline
+ [ 2dup ] dip call( x y -- z ) 3array ; inline
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
-USING: arrays kernel sequences namespaces make math math.ranges
-math.vectors vectors ;
+USING: kernel math math.ranges math.vectors namespaces
+sequences ;
IN: math.numerical-integration
SYMBOL: num-steps
length 2 / 2 - { 2 4 } <repetition> concat
{ 1 4 } { 1 } surround ;
-: integrate-simpson ( from to f -- x )
+: integrate-simpson ( from to quot -- x )
[ setup-simpson-range dup ] dip
map dup generate-simpson-weights
- v. swap [ third ] keep first - 6 / * ;
+ v. swap [ third ] keep first - 6 / * ; inline
: range ( r from to -- n )
over - 1 + rot [
-rot [ over + pick call drop ] each 2drop f
- ] bshift 2nip ;
+ ] bshift 2nip ; inline
[ 55 ] [
0 sum set
91 71 52 38 17 14 91 43 58 50 27 29 48
63 66 04 68 89 53 67 30 73 16 69 87 40 31
04 62 98 27 23 09 70 98 73 93 38 53 60 04 23
- } 15 [ 1+ cut swap ] map nip ;
+ } 15 iota [ 1+ cut swap ] map nip ;
PRIVATE>
<PRIVATE
: source-032 ( -- seq )
- 9 factorial [ 9 permutation [ 1+ ] map 10 digits>integer ] map ;
+ 9 factorial iota [
+ 9 permutation [ 1+ ] map 10 digits>integer
+ ] map ;
: 1and4 ( n -- ? )
number>string 1 cut-slice 4 cut-slice
615949 * 797807 + 20 2^ rem dup 19 2^ - ; inline
: sums-triangle ( -- seq )
- 0 1000 [ 1+ [ next ] replicate partial-sums ] map nip ;
+ 0 1000 iota [ 1+ [ next ] replicate partial-sums ] map nip ;
:: (euler150) ( m -- n )
[let | table [ sums-triangle ] |
m [| x |
x 1+ [| y |
- m x - [| z |
+ m x - iota [| z |
x z + table nth-unsafe
[ y z + 1+ swap nth-unsafe ]
[ y swap nth-unsafe ] bi -
: <counter-app> ( -- responder )
counter-app new-dispatcher
- [ 1+ ] <counter-action> "inc" add-responder
- [ 1- ] <counter-action> "dec" add-responder
+ [ 1 + ] <counter-action> "inc" add-responder
+ [ 1 - ] <counter-action> "dec" add-responder
<display-action> "" add-responder ;
! Deployment example
--- /dev/null
+IN: advice
+USING: help.markup help.syntax tools.annotations words coroutines ;
+
+HELP: make-advised
+{ $values { "word" "a word to annotate in preparation of advising" } }
+{ $description "Prepares a word for being advised. This is done by: "
+ { $list
+ { "Annotating it to call the appropriate words before, around, and after the original body " }
+ { "Adding " { $snippet "before" } ", " { $snippet "around" } ", and " { $snippet "after" } " properties, which will contain the advice" }
+ { "Adding an " { $snippet "advised" } "property, which can later be used to determine if a given word is defined (see " { $link advised? } ")" }
+ }
+}
+{ $see-also advised? annotate } ;
+
+HELP: advised?
+{ $values { "word" "a word" } { "?" "t or f, indicating if " { $snippet "word" } " is advised" } }
+{ $description "Determines whether or not the given word has any advice on it." } ;
+
+HELP: ad-do-it
+{ $values { "input" "an object" } { "result" "an object" } }
+{ $description "Calls either the next applicable around advice or the main body, returning back to the point it was called from when finished. This word should only be called from inside advice." }
+{ $see-also coyield } ;
+
+ARTICLE: "advice" "Advice"
+"Advice is a simple way of adding additition functionality to words by adding 'hooks' to a word, which can act before, after, or around the calling of the word." ;
+
+ABOUT: "advice"
\ No newline at end of file
--- /dev/null
+! Copyright (C) 2008 James Cash
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel sequences io io.streams.string math tools.test advice math.parser
+parser namespaces multiline eval words assocs ;
+IN: advice.tests
+
+[
+ [ ad-do-it ] must-fail
+
+ : foo ( -- str ) "foo" ;
+ \ foo make-advised
+
+ { "bar" "foo" } [
+ [ "bar" ] "barify" \ foo advise-before
+ foo
+ ] unit-test
+
+ { "bar" "foo" "baz" } [
+ [ "baz" ] "bazify" \ foo advise-after
+ foo
+ ] unit-test
+
+ { "foo" "baz" } [
+ "barify" \ foo before remove-advice
+ foo
+ ] unit-test
+
+ : bar ( a -- b ) 1 + ;
+ \ bar make-advised
+
+ { 11 } [
+ [ 2 * ] "double" \ bar advise-before
+ 5 bar
+ ] unit-test
+
+ { 11/3 } [
+ [ 3 / ] "third" \ bar advise-after
+ 5 bar
+ ] unit-test
+
+ { -2 } [
+ [ -1 * ad-do-it 3 + ] "frobnobicate" \ bar advise-around
+ 5 bar
+ ] unit-test
+
+ : add ( a b -- c ) + ;
+ \ add make-advised
+
+ { 10 } [
+ [ [ 2 * ] bi@ ] "double-args" \ add advise-before
+ 2 3 add
+ ] unit-test
+
+ { 21 } [
+ [ 3 * ad-do-it 1- ] "around1" \ add advise-around
+ 2 3 add
+ ] unit-test
+
+! { 9 } [
+! [ [ 1- ] bi@ ad-do-it 2 / ] "around2" \ add advise-around
+! 2 3 add
+! ] unit-test
+
+! { { "around1" "around2" } } [
+! \ add around word-prop keys
+! ] unit-test
+
+ { 5 f } [
+ \ add unadvise
+ 2 3 add \ add advised?
+ ] unit-test
+
+! : quux ( a b -- c ) * ;
+
+! { f t 3+3/4 } [
+! <" USING: advice kernel math ;
+! IN: advice.tests
+! \ quux advised?
+! ADVISE: quux halve before [ 2 / ] bi@ ;
+! \ quux advised?
+! 3 5 quux"> eval
+! ] unit-test
+
+! { 3+3/4 "1+1/2 2+1/2 3+3/4" } [
+! <" USING: advice kernel math math.parser io io.streams.string ;
+! IN: advice.tests
+! ADVISE: quux log around
+! 2dup [ number>string write " " write ] bi@
+! ad-do-it
+! dup number>string write ;
+! [ 3 5 quux ] with-string-writer"> eval
+! ] unit-test
+
+] with-scope
--- /dev/null
+! Copyright (C) 2008 James Cash
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel sequences fry words assocs linked-assocs tools.annotations
+coroutines lexer parser quotations arrays namespaces continuations
+summary ;
+IN: advice
+
+SYMBOLS: before after around advised in-advice? ;
+
+: advised? ( word -- ? )
+ advised word-prop ;
+
+DEFER: make-advised
+
+<PRIVATE
+: init-around-co ( quot -- coroutine )
+ \ coreset suffix cocreate ;
+PRIVATE>
+
+: advise ( quot name word loc -- )
+ dup around eq? [ [ init-around-co ] 3dip ] when
+ over advised? [ over make-advised ] unless
+ word-prop set-at ;
+
+: advise-before ( quot name word -- ) before advise ;
+
+: advise-after ( quot name word -- ) after advise ;
+
+: advise-around ( quot name word -- ) around advise ;
+
+: get-advice ( word type -- seq )
+ word-prop values ;
+
+: call-before ( word -- )
+ before get-advice [ call ] each ;
+
+: call-after ( word -- )
+ after get-advice [ call ] each ;
+
+: call-around ( main word -- )
+ t in-advice? [
+ around get-advice tuck
+ [ [ coresume ] each ] [ call ] [ <reversed> [ coresume ] each ] tri*
+ ] with-variable ;
+
+: remove-advice ( name word loc -- )
+ word-prop delete-at ;
+
+ERROR: ad-do-it-error ;
+
+M: ad-do-it-error summary
+ drop "ad-do-it should only be called inside 'around' advice" ;
+
+: ad-do-it ( input -- result )
+ in-advice? get [ ad-do-it-error ] unless coyield ;
+
+: make-advised ( word -- )
+ [ dup '[ [ _ ] dip over dup '[ _ call-before _ _ call-around _ call-after ] ] annotate ]
+ [ { before after around } [ <linked-hash> swap set-word-prop ] with each ]
+ [ t advised set-word-prop ] tri ;
+
+: unadvise ( word -- )
+ [ reset ] [ { before after around advised } [ f swap set-word-prop ] with each ] bi ;
+
+SYNTAX: ADVISE: ! word adname location => word adname quot loc
+ scan-word scan scan-word parse-definition swap [ spin ] dip advise ;
+
+SYNTAX: UNADVISE:
+ scan-word parsed \ unadvise parsed ;
--- /dev/null
+James Cash
--- /dev/null
+Implmentation of advice/aspects
--- /dev/null
+extensions
--- /dev/null
+William Schlieper
--- /dev/null
+! See http://factorcode.org/license.txt for BSD licence.
+USING: help.markup help.syntax ;
+
+IN: graph-theory
+
+ARTICLE: "graph-protocol" "Graph protocol"
+"All graphs must be instances of the graph mixin:"
+{ $subsection graph }
+"All graphs must implement a method on the following generic word:"
+{ $subsection vertices }
+"At least one of the following two generic words must have a method; the " { $link graph } " mixin has default definitions which are mutually recursive:"
+{ $subsection adjlist }
+{ $subsection adj? }
+"All mutable graphs must implement a method on the following generic word:"
+{ $subsection add-blank-vertex }
+"All mutable undirected graphs must implement a method on the following generic word:"
+{ $subsection add-edge }
+"Mutable directed graphs should not implement the above word, as it has a default definition defined in terms of the following generic word:"
+{ $subsection add-edge* }
+"The following two words have default definitions, but are available as generics to allow implementations to optimize them:"
+{ $subsection num-vertices }
+{ $subsection num-edges } ;
+
+HELP: graph
+{ $class-description "A mixin class whose instances are graphs. Custom implementations of the graph protocol should be declared as instances of this mixin for all graph functionality to work correctly:"
+ { $code "INSTANCE: hex-board graph" }
+} ;
+
+{ vertices num-vertices num-edges } related-words
+
+HELP: vertices
+{ $values { "graph" graph } { "seq" "The vertices" } }
+{ $description "Returns the vertices of the graph." } ;
+
+HELP: num-vertices
+{ $values { "graph" graph } { "n" "The number of vertices" } }
+{ $description "Returns the number of vertices in the graph." } ;
+
+HELP: num-edges
+{ $values { "graph" "A graph" } { "n" "The number of edges" } }
+{ $description "Returns the number of edges in the graph." } ;
+
+{ adjlist adj? } related-words
+
+HELP: adjlist
+{ $values
+ { "from" "The index of a vertex" }
+ { "graph" "The graph to be examined" }
+ { "seq" "The adjacency list" } }
+{ $description "Returns a sequence of vertices that this vertex links to" } ;
+
+HELP: adj?
+{ $values
+ { "from" "The index of a vertex" }
+ { "to" "The index of a vertex" }
+ { "graph" "A graph" }
+ { "?" "A boolean" } }
+{ $description "Returns a boolean describing whether there is an edge in the graph between from and to." } ;
+
+{ add-blank-vertex add-blank-vertices add-edge add-edge* } related-words
+
+HELP: add-blank-vertex
+{ $values
+ { "index" "A vertex index" }
+ { "graph" "A graph" } }
+{ $description "Adds a vertex to the graph." } ;
+
+HELP: add-blank-vertices
+{ $values
+ { "seq" "A sequence of vertex indices" }
+ { "graph" "A graph" } }
+{ $description "Adds vertices with indices in seq to the graph." } ;
+
+HELP: add-edge*
+{ $values
+ { "from" "The index of a vertex" }
+ { "to" "The index of another vertex" }
+ { "graph" "A graph" } }
+{ $description "Adds a one-way edge to the graph, between " { $snippet "from" } " and " { $snippet "to" } "."
+ $nl
+ "If you want to add a two-way edge, use " { $link add-edge } " instead." } ;
+
+HELP: add-edge
+{ $values
+ { "u" "The index of a vertex" }
+ { "v" "The index of another vertex" }
+ { "graph" "A graph" } }
+{ $description "Adds a two-way edge to the graph, between " { $snippet "u" } " and " { $snippet "v" } "."
+ $nl
+ "If you want to add a one-way edge, use " { $link add-edge* } " instead." } ;
+
+{ depth-first full-depth-first dag? topological-sort } related-words
+
+HELP: depth-first
+{ $values
+ { "v" "The vertex to start the search at" }
+ { "graph" "The graph to search" }
+ { "pre" "A quotation of the form ( n -- )" }
+ { "post" "A quotation of the form ( n -- )" }
+ { "?list" "A list of booleans describing the vertices visited in the search" }
+ { "?" "A boolean describing whether or not the end-search error was thrown" } }
+{ $description "Performs a depth-first search on " { $emphasis "graph" } ". The variable " { $emphasis "graph" } " can be accessed in both quotations."
+ $nl
+ "The " { $emphasis "pre" } " quotation is run before the recursive application of depth-first."
+ $nl
+ "The " { $emphasis "post" } " quotation is run after the recursive application of depth-first."
+ $nl
+ { $emphasis "?list" } " is a list of booleans, " { $link t } " for every vertex visted during the search, and " { $link f } " for every vertex not visited." } ;
+
+HELP: full-depth-first
+{ $values
+ { "graph" "The graph to search" }
+ { "pre" "A quotation of the form ( n -- )" }
+ { "post" "A quotation of the form ( n -- )" }
+ { "tail" "A quotation of the form ( -- )" }
+ { "?" "A boolean describing whether or not the end-search error was thrown" } }
+{ $description "Performs a depth-first search on " { $emphasis "graph" } ". The variable " { $emphasis "graph" } "can be accessed in both quotations."
+ $nl
+ "The " { $emphasis "pre" } " quotation is run before the recursive application of depth-first."
+ $nl
+ "The " { $emphasis "post" } " quotation is run after the recursive application of depth-first."
+ $nl
+ "The " { $emphasis "tail" } " quotation is run after each time the depth-first search runs out of nodes. On an undirected graph this will be each connected subgroup but on a directed graph it can be more complex." } ;
+
+HELP: dag?
+{ $values
+ { "graph" graph }
+ { "?" "A boolean indicating if the graph is acyclic" } }
+{ $description "Using a depth-first search, determines if the specified directed graph is a directed acyclic graph. An undirected graph will produce a false result, as the algorithm does not eliminate cycles of length 2, which will include any edge that goes both ways." } ;
+
+HELP: topological-sort
+{ $values
+ { "graph" graph }
+ { "seq/f" "Either a sequence of values or f" } }
+{ $description "Using a depth-first search, topologically sorts the specified directed graph. Returns f if the graph contains any cycles, and a topologically sorted sequence otherwise." } ;
--- /dev/null
+! Copyright (C) 2008 William Schlieper <schlieper@unc.edu>
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel combinators fry continuations sequences arrays
+vectors assocs hashtables heaps namespaces ;
+IN: graph-theory
+
+MIXIN: graph
+SYMBOL: visited?
+ERROR: end-search ;
+
+GENERIC: vertices ( graph -- seq ) flushable
+
+GENERIC: num-vertices ( graph -- n ) flushable
+
+GENERIC: num-edges ( graph -- n ) flushable
+
+GENERIC: adjlist ( from graph -- seq ) flushable
+
+GENERIC: adj? ( from to graph -- ? ) flushable
+
+GENERIC: add-blank-vertex ( index graph -- )
+
+GENERIC: delete-blank-vertex ( index graph -- )
+
+GENERIC: add-edge* ( from to graph -- )
+
+GENERIC: add-edge ( u v graph -- )
+
+GENERIC: delete-edge* ( from to graph -- )
+
+GENERIC: delete-edge ( u v graph -- )
+
+M: graph num-vertices
+ vertices length ;
+
+M: graph num-edges
+ [ vertices ] [ '[ _ adjlist length ] sigma ] bi ;
+
+M: graph adjlist
+ [ vertices ] [ swapd '[ _ swap _ adj? ] filter ] bi ;
+
+M: graph adj?
+ swapd adjlist index >boolean ;
+
+M: graph add-edge
+ [ add-edge* ] [ swapd add-edge* ] 3bi ;
+
+M: graph delete-edge
+ [ delete-edge* ] [ swapd delete-edge* ] 3bi ;
+
+: add-blank-vertices ( seq graph -- )
+ '[ _ add-blank-vertex ] each ;
+
+: delete-vertex ( index graph -- )
+ [ adjlist ]
+ [ '[ _ _ 3dup adj? [ delete-edge* ] [ 3drop ] if ] each ]
+ [ delete-blank-vertex ] 2tri ;
+
+<PRIVATE
+
+: search-wrap ( quot graph -- ? )
+ [ [ graph set ] [ vertices [ f 2array ] map >hashtable visited? set ] bi
+ [ t ] compose [ dup end-search? [ drop f ] [ rethrow ] if ] recover ] with-scope ; inline
+
+: (depth-first) ( v pre post -- )
+ { [ 2drop visited? get t -rot set-at ]
+ [ drop call ]
+ [ [ graph get adjlist ] 2dip
+ '[ dup visited? get at [ drop ] [ _ _ (depth-first) ] if ] each ]
+ [ nip call ] } 3cleave ; inline
+
+PRIVATE>
+
+: depth-first ( v graph pre post -- ?list ? )
+ '[ _ _ (depth-first) visited? get ] swap search-wrap ; inline
+
+: full-depth-first ( graph pre post tail -- ? )
+ '[ [ visited? get [ nip not ] assoc-find ]
+ [ drop _ _ (depth-first) @ ]
+ while 2drop ] swap search-wrap ; inline
+
+: dag? ( graph -- ? )
+ V{ } clone swap [ 2dup swap push dupd
+ '[ _ swap graph get adj? not ] all?
+ [ end-search ] unless ]
+ [ drop dup pop* ] [ ] full-depth-first nip ;
+
+: topological-sort ( graph -- seq/f )
+ dup dag?
+ [ V{ } clone swap [ drop ] [ prefix ] [ ] full-depth-first drop ]
+ [ drop f ] if ;
--- /dev/null
+! Copyright (C) 2008 William Schlieper <schlieper@unc.edu>
+! See http://factorcode.org/license.txt for BSD license.
+
+USING: accessors kernel graph-theory ;
+
+IN: graph-theory.reversals
+
+TUPLE: reversal graph ;
+
+GENERIC: reverse-graph ( graph -- reversal )
+
+M: graph reverse-graph reversal boa ;
+
+M: reversal reverse-graph graph>> ;
+
+INSTANCE: reversal graph
+
+M: reversal vertices
+ graph>> vertices ;
+
+M: reversal adj?
+ swapd graph>> adj? ;
--- /dev/null
+! Copyright (C) 2008 William Schlieper <schlieper@unc.edu>
+! See http://factorcode.org/license.txt for BSD license.
+
+USING: accessors kernel sequences arrays vectors sets assocs hashtables graph-theory namespaces fry ;
+
+IN: graph-theory.sparse
+
+TUPLE: sparse-graph alist ;
+
+: <sparse-graph> ( -- sparse-graph )
+ H{ } clone sparse-graph boa ;
+
+: >sparse-graph ( graph -- sparse-graph )
+ [ vertices ] keep
+ '[ dup _ adjlist 2array ] map >hashtable sparse-graph boa ;
+
+INSTANCE: sparse-graph graph
+
+M: sparse-graph vertices
+ alist>> keys ;
+
+M: sparse-graph adjlist
+ alist>> at ;
+
+M: sparse-graph add-blank-vertex
+ alist>> V{ } clone -rot set-at ;
+
+M: sparse-graph delete-blank-vertex
+ alist>> delete-at ;
+
+M: sparse-graph add-edge*
+ alist>> swapd at adjoin ;
+
+M: sparse-graph delete-edge*
+ alist>> swapd at delete ;
--- /dev/null
+Graph-theoretic algorithms
--- /dev/null
+collections
copy_handle(&stacks->catchstack_save);
copy_handle(&stacks->current_callback_save);
- mark_active_blocks(stacks);
+ if(!performing_compaction)
+ mark_active_blocks(stacks);
stacks = stacks->next;
}
F_ZONE *newspace;
bool performing_gc;
+bool performing_compaction;
CELL collecting_gen;
/* if true, we collecting AGING space for the second time, so if it is still
userenv[i] = F;
/* do a full GC + code heap compaction */
+ performing_compaction = true;
compact_code_heap();
+ performing_compaction = false;
UNREGISTER_C_STRING(path);
projects / factor.git / commitdiff