diff --git a/.gitignore b/.gitignore index 22dda8efb4..b52c593b49 100644 --- a/.gitignore +++ b/.gitignore @@ -25,3 +25,5 @@ build-support/wordsize .#* *.swo checksums.txt +*.so +a.out diff --git a/basis/alien/parser/parser.factor b/basis/alien/parser/parser.factor index 193893fabc..df1dd15bfb 100644 --- a/basis/alien/parser/parser.factor +++ b/basis/alien/parser/parser.factor @@ -1,7 +1,7 @@ -! Copyright (C) 2008 Slava Pestov. +! Copyright (C) 2008, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: alien alien.c-types arrays assocs effects grouping kernel -parser sequences splitting words fry locals ; +parser sequences splitting words fry locals lexer namespaces ; IN: alien.parser : parse-arglist ( parameters return -- types effect ) @@ -12,8 +12,15 @@ IN: alien.parser : function-quot ( return library function types -- quot ) '[ _ _ _ _ alien-invoke ] ; -:: define-function ( return library function parameters -- ) +:: make-function ( return library function parameters -- word quot effect ) function create-in dup reset-generic return library function - parameters return parse-arglist [ function-quot ] dip - define-declared ; + parameters return parse-arglist [ function-quot ] dip ; + +: (FUNCTION:) ( -- word quot effect ) + scan "c-library" get scan ";" parse-tokens + [ "()" subseq? not ] filter + make-function ; + +: define-function ( return library function parameters -- ) + make-function define-declared ; diff --git a/basis/alien/syntax/syntax.factor b/basis/alien/syntax/syntax.factor index 6a1bf7f635..0cc6d51446 100644 --- a/basis/alien/syntax/syntax.factor +++ b/basis/alien/syntax/syntax.factor @@ -16,9 +16,7 @@ SYNTAX: BAD-ALIEN parsed ; SYNTAX: LIBRARY: scan "c-library" set ; SYNTAX: FUNCTION: - scan "c-library" get scan ";" parse-tokens - [ "()" subseq? not ] filter - define-function ; + (FUNCTION:) define-declared ; SYNTAX: TYPEDEF: scan scan typedef ; diff --git a/basis/bootstrap/finish-bootstrap.factor b/basis/bootstrap/finish-bootstrap.factor index 36f6291bc6..ab08aa87a9 100644 --- a/basis/bootstrap/finish-bootstrap.factor +++ b/basis/bootstrap/finish-bootstrap.factor @@ -8,7 +8,7 @@ namespaces eval kernel vocabs.loader io ; (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* diff --git a/basis/compiler/errors/errors-docs.factor b/basis/compiler/errors/errors-docs.factor index c10e33b745..6dbe5193aa 100644 --- a/basis/compiler/errors/errors-docs.factor +++ b/basis/compiler/errors/errors-docs.factor @@ -2,33 +2,4 @@ IN: compiler.errors USING: help.markup help.syntax vocabs.loader words io quotations words.symbol ; -ARTICLE: "compiler-errors" "Compiler warnings and errors" -"After loading a vocabulary, you might see messages like:" -{ $code - ":errors - print 2 compiler errors" - ":warnings - print 50 compiler warnings" -} -"These messages arise from the compiler's stack effect checker. Production code should not have any warnings and errors in it. Warning and error conditions are documented in " { $link "inference-errors" } "." -$nl -"Words to view warnings and errors:" -{ $subsection :warnings } -{ $subsection :errors } -{ $subsection :linkage } -"Compiler warnings and errors are reported using the " { $link "tools.errors" } " mechanism and are shown in the " { $link "ui.tools.error-list" } "." ; - -HELP: compiler-error -{ $values { "error" "an error" } { "word" word } } -{ $description "Saves the error for future persual via " { $link :errors } ", " { $link :warnings } " and " { $link :linkage } "." } ; - -HELP: :errors -{ $description "Prints all serious compiler errors from the most recent compile to " { $link output-stream } "." } ; - -HELP: :warnings -{ $description "Prints all ignorable compiler warnings from the most recent compile to " { $link output-stream } "." } ; - -HELP: :linkage -{ $description "Prints all C library interface linkage errors from the most recent compile to " { $link output-stream } "." } ; - -{ :errors :warnings } related-words - ABOUT: "compiler-errors" diff --git a/basis/compiler/errors/errors.factor b/basis/compiler/errors/errors.factor index e3174470fb..22ae8d97ff 100644 --- a/basis/compiler/errors/errors.factor +++ b/basis/compiler/errors/errors.factor @@ -1,7 +1,6 @@ ! Copyright (C) 2007, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors source-files.errors kernel namespaces assocs -tools.errors ; +USING: accessors source-files.errors kernel namespaces assocs ; IN: compiler.errors TUPLE: compiler-error < source-file-error ; @@ -44,6 +43,7 @@ T{ error-type { 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 : ( error word -- compiler-error ) @@ -52,12 +52,3 @@ T{ error-type : compiler-error ( error word -- ) compiler-errors get-global pick [ [ [ ] keep ] dip set-at ] [ delete-at drop ] if ; - -: compiler-errors. ( type -- ) - errors-of-type values errors. ; - -: :errors ( -- ) +compiler-error+ compiler-errors. ; - -: :warnings ( -- ) +compiler-warning+ compiler-errors. ; - -: :linkage ( -- ) +linkage-error+ compiler-errors. ; diff --git a/basis/compiler/tests/folding.factor b/basis/compiler/tests/folding.factor index c2de317e83..fe2f801de2 100644 --- a/basis/compiler/tests/folding.factor +++ b/basis/compiler/tests/folding.factor @@ -12,7 +12,7 @@ IN: compiler.tests IN: compiler.tests.folding GENERIC: foldable-generic ( a -- b ) foldable M: integer foldable-generic f ; - "> (( -- )) eval + "> eval( -- ) ] unit-test [ ] [ @@ -20,7 +20,7 @@ IN: compiler.tests USING: math arrays ; IN: compiler.tests.folding : fold-test ( -- x ) 10 foldable-generic ; - "> (( -- )) eval + "> eval( -- ) ] unit-test [ t ] [ diff --git a/basis/compiler/tests/redefine1.factor b/basis/compiler/tests/redefine1.factor index db45c6af17..8145ad628b 100644 --- a/basis/compiler/tests/redefine1.factor +++ b/basis/compiler/tests/redefine1.factor @@ -11,7 +11,7 @@ M: integer method-redefine-generic-1 3 + ; [ 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 @@ -27,7 +27,7 @@ M: integer method-redefine-generic-2 3 + ; [ 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 @@ -43,10 +43,10 @@ M: integer method-redefine-generic-2 3 + ; [ 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 ( -- ) ; @@ -59,7 +59,7 @@ M: integer method-redefine-generic-2 3 + ; [ 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 @@ -67,7 +67,7 @@ M: integer method-redefine-generic-2 3 + ; [ 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 diff --git a/basis/compiler/tests/redefine10.factor b/basis/compiler/tests/redefine10.factor index de14a068ab..faae7b8ed1 100644 --- a/basis/compiler/tests/redefine10.factor +++ b/basis/compiler/tests/redefine10.factor @@ -13,7 +13,7 @@ IN: compiler.tests MIXIN: my-mixin INSTANCE: fixnum my-mixin : my-inline ( a -- b ) dup my-mixin instance? [ 1 + ] when ; - "> (( -- )) eval + "> eval( -- ) ] unit-test [ ] [ @@ -21,7 +21,7 @@ IN: compiler.tests USE: math IN: compiler.tests.redefine10 INSTANCE: float my-mixin - "> (( -- )) eval + "> eval( -- ) ] unit-test [ 2.0 ] [ diff --git a/basis/compiler/tests/redefine11.factor b/basis/compiler/tests/redefine11.factor index 2135d31606..57f9f9caf0 100644 --- a/basis/compiler/tests/redefine11.factor +++ b/basis/compiler/tests/redefine11.factor @@ -17,7 +17,7 @@ IN: compiler.tests M: my-mixin my-generic drop 0 ; M: object my-generic drop 1 ; : my-inline ( -- b ) { } my-generic ; - "> (( -- )) eval + "> eval( -- ) ] unit-test [ ] [ diff --git a/basis/compiler/tests/redefine12.factor b/basis/compiler/tests/redefine12.factor index 2ff16f0cca..ccf6c88e70 100644 --- a/basis/compiler/tests/redefine12.factor +++ b/basis/compiler/tests/redefine12.factor @@ -15,6 +15,6 @@ M: object g drop t ; 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 diff --git a/basis/compiler/tests/redefine2.factor b/basis/compiler/tests/redefine2.factor index b61f53d14c..6a7b7a6941 100644 --- a/basis/compiler/tests/redefine2.factor +++ b/basis/compiler/tests/redefine2.factor @@ -5,7 +5,7 @@ arrays words assocs eval words.symbol ; 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 diff --git a/basis/compiler/tests/redefine3.factor b/basis/compiler/tests/redefine3.factor index 0835f8cfba..87ab100879 100644 --- a/basis/compiler/tests/redefine3.factor +++ b/basis/compiler/tests/redefine3.factor @@ -18,7 +18,7 @@ M: empty-mixin sheeple drop "wake up" ; [ 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 diff --git a/basis/compiler/tests/redefine4.factor b/basis/compiler/tests/redefine4.factor index 29d5da6394..88b40f0c5a 100644 --- a/basis/compiler/tests/redefine4.factor +++ b/basis/compiler/tests/redefine4.factor @@ -7,6 +7,6 @@ USING: io.streams.string kernel tools.test eval ; [ "" ] [ [ 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 diff --git a/basis/compiler/tests/redefine5.factor b/basis/compiler/tests/redefine5.factor index 8db28b52d5..c390f9a1ec 100644 --- a/basis/compiler/tests/redefine5.factor +++ b/basis/compiler/tests/redefine5.factor @@ -14,7 +14,7 @@ IN: compiler.tests GENERIC: my-generic ( a -- b ) M: object my-generic [ <=> ] sort ; : my-inline ( a -- b ) my-generic ; - "> (( -- )) eval + "> eval( -- ) ] unit-test [ ] [ @@ -23,7 +23,7 @@ IN: compiler.tests IN: compiler.tests.redefine5 TUPLE: my-tuple ; M: my-tuple my-generic drop 0 ; - "> (( -- )) eval + "> eval( -- ) ] unit-test [ 0 ] [ diff --git a/basis/compiler/tests/redefine6.factor b/basis/compiler/tests/redefine6.factor index df9c35dc42..7f1be973e7 100644 --- a/basis/compiler/tests/redefine6.factor +++ b/basis/compiler/tests/redefine6.factor @@ -14,7 +14,7 @@ IN: compiler.tests MIXIN: my-mixin M: my-mixin my-generic drop 0 ; : my-inline ( a -- b ) { my-mixin } declare my-generic ; - "> (( -- )) eval + "> eval( -- ) ] unit-test [ ] [ @@ -24,7 +24,7 @@ IN: compiler.tests TUPLE: my-tuple ; M: my-tuple my-generic drop 1 ; INSTANCE: my-tuple my-mixin - "> (( -- )) eval + "> eval( -- ) ] unit-test [ 1 ] [ diff --git a/basis/compiler/tests/redefine7.factor b/basis/compiler/tests/redefine7.factor index fd6d5a9564..d6dfdf20fd 100644 --- a/basis/compiler/tests/redefine7.factor +++ b/basis/compiler/tests/redefine7.factor @@ -13,7 +13,7 @@ IN: compiler.tests MIXIN: my-mixin INSTANCE: fixnum my-mixin : my-inline ( a -- b ) dup my-mixin? [ 1 + ] when ; - "> (( -- )) eval + "> eval( -- ) ] unit-test [ ] [ @@ -21,7 +21,7 @@ IN: compiler.tests USE: math IN: compiler.tests.redefine7 INSTANCE: float my-mixin - "> (( -- )) eval + "> eval( -- ) ] unit-test [ 2.0 ] [ diff --git a/basis/compiler/tests/redefine8.factor b/basis/compiler/tests/redefine8.factor index 8a8d832dbf..3499c5070a 100644 --- a/basis/compiler/tests/redefine8.factor +++ b/basis/compiler/tests/redefine8.factor @@ -16,7 +16,7 @@ IN: compiler.tests ! 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 [ ] [ @@ -24,7 +24,7 @@ IN: compiler.tests USE: math IN: compiler.tests.redefine8 INSTANCE: float my-mixin - "> (( -- )) eval + "> eval( -- ) ] unit-test [ 2.0 ] [ diff --git a/basis/compiler/tests/redefine9.factor b/basis/compiler/tests/redefine9.factor index 63cf002cc9..25ed5f15db 100644 --- a/basis/compiler/tests/redefine9.factor +++ b/basis/compiler/tests/redefine9.factor @@ -16,7 +16,7 @@ IN: compiler.tests ! 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 [ ] [ @@ -25,7 +25,7 @@ IN: compiler.tests IN: compiler.tests.redefine9 TUPLE: my-tuple ; INSTANCE: my-tuple my-mixin - "> (( -- )) eval + "> eval( -- ) ] unit-test [ diff --git a/basis/compiler/tests/simple.factor b/basis/compiler/tests/simple.factor index 23fee84ae2..769182a8b1 100644 --- a/basis/compiler/tests/simple.factor +++ b/basis/compiler/tests/simple.factor @@ -237,6 +237,6 @@ M: f single-combination-test-2 single-combination-test-4 ; 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>>" (( -- obj )) eval + "USING: prettyprint words accessors ; IN: compiler.tests.foo : (recursive) ( -- ) (recursive) (recursive) ; inline recursive : recursive ( -- ) (recursive) ; \\ (recursive) optimized>>" eval( -- obj ) ] unit-test ] times diff --git a/basis/compiler/tree/cleanup/cleanup-tests.factor b/basis/compiler/tree/cleanup/cleanup-tests.factor index c533f78916..c596be263a 100755 --- a/basis/compiler/tree/cleanup/cleanup-tests.factor +++ b/basis/compiler/tree/cleanup/cleanup-tests.factor @@ -302,7 +302,7 @@ cell-bits 32 = [ ] unit-test [ t ] [ - [ 1000 [ 1+ ] map ] { 1+ fixnum+ } inlined? + [ 1000 iota [ 1+ ] map ] { 1+ fixnum+ } inlined? ] unit-test : rec ( a -- b ) diff --git a/basis/compiler/tree/normalization/normalization-tests.factor b/basis/compiler/tree/normalization/normalization-tests.factor index 2097f4ebdd..680ae0b170 100644 --- a/basis/compiler/tree/normalization/normalization-tests.factor +++ b/basis/compiler/tree/normalization/normalization-tests.factor @@ -17,13 +17,13 @@ sequences accessors tools.test kernel math ; [ 2 ] [ [ 3 [ drop ] [ 2drop 3 ] if ] build-tree count-introductions ] unit-test -: foo ( a b -- b a ) 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 diff --git a/basis/cpu/ppc/bootstrap.factor b/basis/cpu/ppc/bootstrap.factor index ec7bf8f341..1431d471c1 100644 --- a/basis/cpu/ppc/bootstrap.factor +++ b/basis/cpu/ppc/bootstrap.factor @@ -310,7 +310,7 @@ CONSTANT: rs-reg 30 4 ds-reg 0 LWZ 5 ds-reg -4 LWZU 5 0 4 CMP - 2 swap execute ! magic number + 2 swap execute( offset -- ) ! magic number \ f tag-number 3 LI 3 ds-reg 0 STW ; @@ -341,7 +341,7 @@ CONSTANT: rs-reg 30 : jit-math ( insn -- ) 3 ds-reg 0 LWZ 4 ds-reg -4 LWZU - [ 5 3 4 ] dip execute + [ 5 3 4 ] dip execute( dst src1 src2 -- ) 5 ds-reg 0 STW ; [ \ ADD jit-math ] f f f \ fixnum+fast define-sub-primitive diff --git a/basis/cpu/x86/bootstrap.factor b/basis/cpu/x86/bootstrap.factor index f5829d76ea..b63d31364b 100644 --- a/basis/cpu/x86/bootstrap.factor +++ b/basis/cpu/x86/bootstrap.factor @@ -334,7 +334,7 @@ big-endian off ! 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 ; @@ -355,7 +355,7 @@ big-endian off ! 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 diff --git a/basis/delegate/delegate-tests.factor b/basis/delegate/delegate-tests.factor index 34ff4ba079..f6a40d8dc8 100644 --- a/basis/delegate/delegate-tests.factor +++ b/basis/delegate/delegate-tests.factor @@ -35,7 +35,7 @@ M: hello bing hello-test ; [ 3 ] [ 1 0 2 whoa ] unit-test [ 3 ] [ 1 0 f 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 @@ -63,22 +63,22 @@ CONSULT: beta hey value>> 1- ; [ 0 ] [ 1 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 one ] unit-test [ 0 ] [ 1 two ] unit-test [ 0 ] [ 1 three ] unit-test [ 0 ] [ 1 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 one ] unit-test [ -1 ] [ 1 two ] unit-test [ -1 ] [ 1 three ] unit-test [ -1 ] [ 1 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 ; diff --git a/basis/editors/gedit/authors.txt b/basis/editors/gedit/authors.txt new file mode 100644 index 0000000000..7c1b2f2279 --- /dev/null +++ b/basis/editors/gedit/authors.txt @@ -0,0 +1 @@ +Doug Coleman diff --git a/basis/editors/gedit/gedit.factor b/basis/editors/gedit/gedit.factor new file mode 100644 index 0000000000..97ea0e1cb3 --- /dev/null +++ b/basis/editors/gedit/gedit.factor @@ -0,0 +1,17 @@ +! Copyright (C) 2008 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: editors io.launcher kernel make math.parser namespaces +sequences ; +IN: editors.gedit + +: gedit-path ( -- path ) + \ gedit-path get-global [ + "gedit" + ] unless* ; + +: gedit ( file line -- ) + [ + gedit-path , number>string "+" prepend , , + ] { } make run-detached drop ; + +[ gedit ] edit-hook set-global diff --git a/basis/editors/gedit/summary.txt b/basis/editors/gedit/summary.txt new file mode 100644 index 0000000000..ebb7189c9f --- /dev/null +++ b/basis/editors/gedit/summary.txt @@ -0,0 +1 @@ +gedit integration diff --git a/unmaintained/openal/macosx/tags.txt b/basis/editors/gedit/tags.txt similarity index 100% rename from unmaintained/openal/macosx/tags.txt rename to basis/editors/gedit/tags.txt diff --git a/basis/eval/eval-tests.factor b/basis/eval/eval-tests.factor index 675921944a..d27e661193 100644 --- a/basis/eval/eval-tests.factor +++ b/basis/eval/eval-tests.factor @@ -1,4 +1,6 @@ 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 diff --git a/basis/fry/fry-tests.factor b/basis/fry/fry-tests.factor index 89fbaf31b6..88ecae66ad 100644 --- a/basis/fry/fry-tests.factor +++ b/basis/fry/fry-tests.factor @@ -56,7 +56,7 @@ sequences eval accessors ; 3 '[ [ [ _ 1array ] call 1array ] call 1array ] call ] unit-test -[ "USING: fry locals.backend ; f '[ load-local _ ]" (( -- quot )) 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 } } ] [ diff --git a/basis/generalizations/generalizations-docs.factor b/basis/generalizations/generalizations-docs.factor index 2088e468c6..3671511194 100644 --- a/basis/generalizations/generalizations-docs.factor +++ b/basis/generalizations/generalizations-docs.factor @@ -272,8 +272,8 @@ HELP: nweave HELP: n*quot { $values - { "n" integer } { "seq" sequence } - { "seq'" sequence } + { "n" integer } { "quot" quotation } + { "quot'" quotation } } { $examples { $example "USING: generalizations prettyprint math ;" diff --git a/basis/generalizations/generalizations.factor b/basis/generalizations/generalizations.factor index 0aa042d4f2..edee44acc6 100644 --- a/basis/generalizations/generalizations.factor +++ b/basis/generalizations/generalizations.factor @@ -7,7 +7,7 @@ IN: generalizations << -: n*quot ( n seq -- seq' ) concat >quotation ; +: n*quot ( n quot -- quot' ) concat >quotation ; : repeat ( n obj quot -- ) swapd times ; inline @@ -94,4 +94,4 @@ MACRO: nweave ( n -- ) : 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 diff --git a/basis/hash2/hash2-tests.factor b/basis/hash2/hash2-tests.factor index 15bbcb36ef..682680bc50 100644 --- a/basis/hash2/hash2-tests.factor +++ b/basis/hash2/hash2-tests.factor @@ -6,9 +6,9 @@ IN: hash2.tests : sample-hash ( -- hash ) 5 - dup 2 3 "foo" roll set-hash2 - dup 4 2 "bar" roll set-hash2 - dup 4 7 "other" roll set-hash2 ; + [ [ 2 3 "foo" ] dip set-hash2 ] keep + [ [ 4 2 "bar" ] dip set-hash2 ] keep + [ [ 4 7 "other" ] dip set-hash2 ] keep ; [ "foo" ] [ 2 3 sample-hash hash2 ] unit-test [ "bar" ] [ 4 2 sample-hash hash2 ] unit-test diff --git a/basis/hash2/hash2.factor b/basis/hash2/hash2.factor index ffe6926130..aadc0d45a2 100644 --- a/basis/hash2/hash2.factor +++ b/basis/hash2/hash2.factor @@ -1,4 +1,6 @@ -USING: kernel sequences arrays math vectors ; +! Copyright (C) 2007 Daniel Ehrenberg +! See http://factorcode.org/license.txt for BSD license. +USING: kernel sequences arrays math vectors locals ; IN: hash2 ! Little ad-hoc datastructure used to map two numbers @@ -22,8 +24,8 @@ IN: hash2 : assoc2 ( a b alist -- value ) (assoc2) dup [ third ] when ; inline -: set-assoc2 ( value a b alist -- alist ) - [ rot 3array ] dip ?push ; inline +:: set-assoc2 ( value a b alist -- alist ) + { a b value } alist ?push ; inline : hash2@ ( a b hash2 -- a b bucket hash2 ) [ 2dup hashcode2 ] dip [ length mod ] keep ; inline @@ -31,8 +33,8 @@ IN: hash2 : hash2 ( a b hash2 -- value/f ) hash2@ nth dup [ assoc2 ] [ 3drop f ] if ; -: set-hash2 ( a b value hash2 -- ) - [ -rot ] dip hash2@ [ set-assoc2 ] change-nth ; +:: set-hash2 ( a b value hash2 -- ) + value a b hash2 hash2@ [ set-assoc2 ] change-nth ; : alist>hash2 ( alist size -- hash2 ) [ over [ first3 ] dip set-hash2 ] reduce ; inline diff --git a/basis/help/crossref/crossref-tests.factor b/basis/help/crossref/crossref-tests.factor index 44122a3a64..95d4612cbe 100644 --- a/basis/help/crossref/crossref-tests.factor +++ b/basis/help/crossref/crossref-tests.factor @@ -4,7 +4,7 @@ definitions assocs sequences kernel namespaces parser arrays 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 ] [ @@ -23,7 +23,7 @@ io.streams.string continuations debugger compiler.units eval ; ] 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 [ ] [ diff --git a/basis/help/definitions/definitions-tests.factor b/basis/help/definitions/definitions-tests.factor index 783a95dd5c..c3365fe53f 100644 --- a/basis/help/definitions/definitions-tests.factor +++ b/basis/help/definitions/definitions-tests.factor @@ -32,7 +32,7 @@ IN: help.definitions.tests "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 diff --git a/basis/help/syntax/syntax-tests.factor b/basis/help/syntax/syntax-tests.factor index db94f53b01..7618e9cdeb 100644 --- a/basis/help/syntax/syntax-tests.factor +++ b/basis/help/syntax/syntax-tests.factor @@ -4,12 +4,12 @@ IN: help.syntax.tests [ [ "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 diff --git a/basis/help/topics/topics-tests.factor b/basis/help/topics/topics-tests.factor index f4f17a10e5..ac9223b5d2 100644 --- a/basis/help/topics/topics-tests.factor +++ b/basis/help/topics/topics-tests.factor @@ -29,7 +29,7 @@ SYMBOL: foo } "\n" join [ "testfile" source-file file set - (( -- )) eval + eval( -- ) ] with-scope ] unit-test diff --git a/basis/http/client/client.factor b/basis/http/client/client.factor index 307fdd5031..d1997c73f9 100644 --- a/basis/http/client/client.factor +++ b/basis/http/client/client.factor @@ -184,6 +184,12 @@ ERROR: download-failed response ; : http-put ( post-data url -- response data ) http-request ; +: ( url -- request ) + "DELETE" ; + +: http-delete ( url -- response data ) + http-request ; + USING: vocabs vocabs.loader ; "debugger" vocab [ "http.client.debugger" require ] when diff --git a/basis/io/crlf/crlf-tests.factor b/basis/io/crlf/crlf-tests.factor new file mode 100644 index 0000000000..2412945ab3 --- /dev/null +++ b/basis/io/crlf/crlf-tests.factor @@ -0,0 +1,8 @@ +IN: io.crlf.tests +USING: io.crlf tools.test io.streams.string io ; + +[ "Hello, world." ] [ "Hello, world." [ read-crlf ] with-string-reader ] unit-test +[ "Hello, world." ] [ "Hello, world.\r\n" [ read-crlf ] with-string-reader ] unit-test +[ "Hello, world.\r" [ read-crlf ] with-string-reader ] must-fail +[ f ] [ "" [ read-crlf ] with-string-reader ] unit-test +[ "" ] [ "\r\n" [ read-crlf ] with-string-reader ] unit-test diff --git a/basis/io/crlf/crlf.factor b/basis/io/crlf/crlf.factor index 53dddce199..29f10300de 100644 --- a/basis/io/crlf/crlf.factor +++ b/basis/io/crlf/crlf.factor @@ -1,6 +1,6 @@ ! 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 ( -- ) @@ -8,4 +8,4 @@ IN: io.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* ; diff --git a/basis/io/launcher/unix/parser/parser-tests.factor b/basis/io/launcher/unix/parser/parser-tests.factor index 07502e87a4..90504ccac2 100644 --- a/basis/io/launcher/unix/parser/parser-tests.factor +++ b/basis/io/launcher/unix/parser/parser-tests.factor @@ -10,13 +10,13 @@ USING: io.launcher.unix.parser tools.test ; [ V{ "abc" "def" } ] [ "abc def" tokenize-command ] unit-test [ V{ "abc def" } ] [ "abc\\ def" tokenize-command ] unit-test [ V{ "abc\\" "def" } ] [ "abc\\\\ def" tokenize-command ] unit-test -[ V{ "abc\\ def" } ] [ "'abc\\\\ def'" tokenize-command ] unit-test -[ V{ "abc\\ def" } ] [ " 'abc\\\\ def'" tokenize-command ] unit-test -[ V{ "abc\\ def" "hey" } ] [ "'abc\\\\ def' hey" tokenize-command ] unit-test -[ V{ "abc def" "hey" } ] [ "'abc def' \"hey\"" tokenize-command ] unit-test -[ "'abc def' \"hey" tokenize-command ] must-fail -[ "'abc def" tokenize-command ] must-fail -[ V{ "abc def" "h\"ey" } ] [ "'abc def' \"h\\\"ey\" " tokenize-command ] unit-test +[ V{ "abc\\ def" } ] [ "\"abc\\\\ def\"" tokenize-command ] unit-test +[ V{ "abc\\ def" } ] [ " \"abc\\\\ def\"" tokenize-command ] unit-test +[ V{ "abc\\ def" "hey" } ] [ "\"abc\\\\ def\" hey" tokenize-command ] unit-test +[ V{ "abc def" "hey" } ] [ "\"abc def\" \"hey\"" tokenize-command ] unit-test +[ "\"abc def\" \"hey" tokenize-command ] must-fail +[ "\"abc def" tokenize-command ] must-fail +[ V{ "abc def" "h\"ey" } ] [ "\"abc def\" \"h\\\"ey\" " tokenize-command ] unit-test [ V{ diff --git a/basis/io/launcher/unix/parser/parser.factor b/basis/io/launcher/unix/parser/parser.factor index 97e6dee95f..bcc5f965e9 100644 --- a/basis/io/launcher/unix/parser/parser.factor +++ b/basis/io/launcher/unix/parser/parser.factor @@ -1,33 +1,17 @@ ! Copyright (C) 2008 Slava Pestov ! See http://factorcode.org/license.txt for BSD license. -USING: peg peg.parsers kernel sequences strings words ; +USING: peg peg.ebnf arrays sequences strings kernel ; IN: io.launcher.unix.parser ! Our command line parser. Supported syntax: ! foo bar baz -- simple tokens ! foo\ bar -- escaping the space -! 'foo bar' -- quotation ! "foo bar" -- quotation -: 'escaped-char' ( -- parser ) - "\\" token any-char 2seq [ second ] action ; - -: 'quoted-char' ( delimiter -- parser' ) - 'escaped-char' - swap [ member? not ] curry satisfy - 2choice ; inline - -: 'quoted' ( delimiter -- parser ) - dup 'quoted-char' repeat0 swap dup surrounded-by ; - -: 'unquoted' ( -- parser ) " '\"" 'quoted-char' repeat1 ; - -: 'argument' ( -- parser ) - "\"" 'quoted' - "'" 'quoted' - 'unquoted' 3choice - [ >string ] action ; - -PEG: tokenize-command ( command -- ast/f ) - 'argument' " " token repeat1 list-of - " " token repeat0 tuck pack - just ; +EBNF: tokenize-command +space = " " +escaped-char = "\" .:ch => [[ ch ]] +quoted = '"' (escaped-char | [^"])*:a '"' => [[ a ]] +unquoted = (escaped-char | [^ "])+ +argument = (quoted | unquoted) => [[ >string ]] +command = space* (argument:a space* => [[ a ]])+:c !(.) => [[ c ]] +;EBNF diff --git a/basis/io/launcher/windows/nt/nt-tests.factor b/basis/io/launcher/windows/nt/nt-tests.factor index 04202365fd..53b3d3ce7e 100755 --- a/basis/io/launcher/windows/nt/nt-tests.factor +++ b/basis/io/launcher/windows/nt/nt-tests.factor @@ -98,7 +98,7 @@ IN: io.launcher.windows.nt.tests console-vm "-script" "env.factor" 3array >>command ascii contents - ] with-directory eval + ] with-directory eval( -- alist ) os-envs = ] unit-test @@ -110,7 +110,7 @@ IN: io.launcher.windows.nt.tests +replace-environment+ >>environment-mode os-envs >>environment ascii contents - ] with-directory eval + ] with-directory eval( -- alist ) os-envs = ] unit-test @@ -121,7 +121,7 @@ IN: io.launcher.windows.nt.tests console-vm "-script" "env.factor" 3array >>command { { "A" "B" } } >>environment ascii contents - ] with-directory eval + ] with-directory eval( -- alist ) "A" swap at ] unit-test @@ -133,7 +133,7 @@ IN: io.launcher.windows.nt.tests { { "USERPROFILE" "XXX" } } >>environment +prepend-environment+ >>environment-mode ascii contents - ] with-directory eval + ] with-directory eval( -- alist ) "USERPROFILE" swap at "XXX" = ] unit-test diff --git a/basis/io/sockets/sockets.factor b/basis/io/sockets/sockets.factor index 8dce527553..a0beb1f421 100644 --- a/basis/io/sockets/sockets.factor +++ b/basis/io/sockets/sockets.factor @@ -192,7 +192,7 @@ M: object (client) ( remote -- client-in client-out local ) ] with-destructors ; : ( remote encoding -- stream local ) - [ (client) -rot ] dip swap ; + [ (client) ] dip swap [ ] dip ; SYMBOL: local-address diff --git a/basis/listener/listener-tests.factor b/basis/listener/listener-tests.factor index 12b639c262..7ed082234a 100644 --- a/basis/listener/listener-tests.factor +++ b/basis/listener/listener-tests.factor @@ -25,7 +25,7 @@ SYNTAX: hello "Hi" print ; "\\ + 1 2 3 4" parse-interactive "cont" get continue-with ] ignore-errors - "USE: debugger :1" (( -- quot )) eval + "USE: debugger :1" eval( -- quot ) ] callcc1 ] unit-test ] with-file-vocabs diff --git a/basis/lists/lists.factor b/basis/lists/lists.factor index 4b0abb7f2d..fecb76f1c0 100644 --- a/basis/lists/lists.factor +++ b/basis/lists/lists.factor @@ -106,7 +106,8 @@ PRIVATE> : deep-sequence>cons ( sequence -- cons ) [ ] keep nil - [ tuck same? [ deep-sequence>cons ] when swons ] with reduce ; + [ [ nip ] [ same? ] 2bi [ deep-sequence>cons ] when swons ] + with reduce ; vector) ( acc list quot: ( elt -- elt' ) -- acc ) diff --git a/basis/locals/locals-tests.factor b/basis/locals/locals-tests.factor index 42ea3322f1..d472a8b22b 100644 --- a/basis/locals/locals-tests.factor +++ b/basis/locals/locals-tests.factor @@ -261,7 +261,7 @@ M:: fixnum next-method-test ( a -- b ) a call-next-method 1 + ; CONSTANT: new-definition "USING: math ;\nIN: locals.tests\n: a-word-with-locals ( -- x ) 2 3 + ;\n" -[ ] [ new-definition (( -- )) eval ] unit-test +[ ] [ new-definition eval( -- ) ] unit-test [ t ] [ [ \ a-word-with-locals see ] with-string-writer @@ -461,7 +461,7 @@ M:: integer lambda-method-forget-test ( a -- b ) ; [ "USING: locals fry math ; 1 '[ [let | A [ 10 ] | A _ + ] ]" - (( -- )) eval call + eval( -- ) call ] [ error>> >r/r>-in-fry-error? ] must-fail-with :: (funny-macro-test) ( obj quot -- ? ) obj { quot } 1&& ; inline @@ -473,10 +473,10 @@ M:: integer lambda-method-forget-test ( a -- b ) ; [ f ] [ 2 funny-macro-test ] unit-test ! 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 @@ -491,19 +491,19 @@ M:: integer lambda-method-forget-test ( a -- b ) ; [ 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 diff --git a/basis/macros/macros-tests.factor b/basis/macros/macros-tests.factor index 40b3d59b39..bf483f72ea 100644 --- a/basis/macros/macros-tests.factor +++ b/basis/macros/macros-tests.factor @@ -13,11 +13,11 @@ 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 diff --git a/basis/match/match.factor b/basis/match/match.factor index b21d8c6d73..ec0cb8c9e6 100644 --- a/basis/match/match.factor +++ b/basis/match/match.factor @@ -62,8 +62,7 @@ MACRO: match-cond ( assoc -- ) } cond ; : match-replace ( object pattern1 pattern2 -- result ) - -rot - match [ "Pattern does not match" throw ] unless* + [ match [ "Pattern does not match" throw ] unless* ] dip swap [ replace-patterns ] bind ; : ?1-tail ( seq -- tail/f ) diff --git a/extra/math/matrices/authors.txt b/basis/math/matrices/authors.txt similarity index 100% rename from extra/math/matrices/authors.txt rename to basis/math/matrices/authors.txt diff --git a/extra/math/matrices/elimination/authors.txt b/basis/math/matrices/elimination/authors.txt similarity index 100% rename from extra/math/matrices/elimination/authors.txt rename to basis/math/matrices/elimination/authors.txt diff --git a/extra/math/matrices/elimination/elimination-tests.factor b/basis/math/matrices/elimination/elimination-tests.factor similarity index 100% rename from extra/math/matrices/elimination/elimination-tests.factor rename to basis/math/matrices/elimination/elimination-tests.factor diff --git a/extra/math/matrices/elimination/elimination.factor b/basis/math/matrices/elimination/elimination.factor similarity index 100% rename from extra/math/matrices/elimination/elimination.factor rename to basis/math/matrices/elimination/elimination.factor diff --git a/extra/math/matrices/elimination/summary.txt b/basis/math/matrices/elimination/summary.txt similarity index 100% rename from extra/math/matrices/elimination/summary.txt rename to basis/math/matrices/elimination/summary.txt diff --git a/extra/math/matrices/matrices-tests.factor b/basis/math/matrices/matrices-tests.factor similarity index 100% rename from extra/math/matrices/matrices-tests.factor rename to basis/math/matrices/matrices-tests.factor diff --git a/extra/math/matrices/matrices.factor b/basis/math/matrices/matrices.factor similarity index 100% rename from extra/math/matrices/matrices.factor rename to basis/math/matrices/matrices.factor diff --git a/extra/math/matrices/summary.txt b/basis/math/matrices/summary.txt similarity index 100% rename from extra/math/matrices/summary.txt rename to basis/math/matrices/summary.txt diff --git a/basis/memoize/memoize-tests.factor b/basis/memoize/memoize-tests.factor index 22b4406f32..d82abe5b07 100644 --- a/basis/memoize/memoize-tests.factor +++ b/basis/memoize/memoize-tests.factor @@ -9,7 +9,7 @@ MEMO: fib ( m -- n ) [ 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 ; @@ -17,7 +17,7 @@ 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 diff --git a/basis/mirrors/mirrors-tests.factor b/basis/mirrors/mirrors-tests.factor index b5bac614ff..ed1f423bb0 100644 --- a/basis/mirrors/mirrors-tests.factor +++ b/basis/mirrors/mirrors-tests.factor @@ -56,6 +56,6 @@ TUPLE: color ! Test reshaping with a mirror 1 2 3 color boa "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 diff --git a/basis/opengl/textures/textures.factor b/basis/opengl/textures/textures.factor index 6bed17f7ab..d103e90bee 100755 --- a/basis/opengl/textures/textures.factor +++ b/basis/opengl/textures/textures.factor @@ -45,7 +45,7 @@ TUPLE: single-texture image dim loc texture-coords texture display-list disposed : adjust-texture-dim ( dim -- dim' ) non-power-of-2-textures? get [ - [ next-power-of-2 ] map + [ dup 1 = [ next-power-of-2 ] unless ] map ] unless ; : (tex-image) ( image bitmap -- ) diff --git a/basis/peg/ebnf/ebnf-tests.factor b/basis/peg/ebnf/ebnf-tests.factor index cc414a798e..58102cffc3 100644 --- a/basis/peg/ebnf/ebnf-tests.factor +++ b/basis/peg/ebnf/ebnf-tests.factor @@ -445,11 +445,11 @@ foo= 'd' ] unit-test { } [ - "USING: kernel peg.ebnf ; \"a\\n\" [EBNF foo='a' '\n' => [[ drop \"\n\" ]] EBNF] drop" (( -- )) eval + "USING: kernel peg.ebnf ; \"a\\n\" [EBNF foo='a' '\n' => [[ drop \"\n\" ]] EBNF] drop" eval( -- ) ] unit-test [ - "USING: peg.ebnf ; " (( -- )) eval drop + "USING: peg.ebnf ; " eval( -- ) drop ] must-fail { t } [ @@ -521,12 +521,12 @@ Tok = Spaces (Number | Special ) "\\" [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 diff --git a/basis/prettyprint/prettyprint-tests.factor b/basis/prettyprint/prettyprint-tests.factor index afec29ff61..a660d4a311 100644 --- a/basis/prettyprint/prettyprint-tests.factor +++ b/basis/prettyprint/prettyprint-tests.factor @@ -2,8 +2,8 @@ USING: arrays definitions io.streams.string io.streams.duplex 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 @@ -254,7 +254,7 @@ M: class-see-layout class-see-layout ; ! 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 diff --git a/basis/refs/authors.txt b/basis/refs/authors.txt index 1901f27a24..22d592c1dd 100755 --- a/basis/refs/authors.txt +++ b/basis/refs/authors.txt @@ -1 +1,2 @@ Slava Pestov +Alex Chapman diff --git a/basis/refs/refs-docs.factor b/basis/refs/refs-docs.factor index a219f0ba8b..9c10641c4c 100644 --- a/basis/refs/refs-docs.factor +++ b/basis/refs/refs-docs.factor @@ -1,38 +1,90 @@ -! Copyright (C) 2007 Slava Pestov +! Copyright (C) 2007 Slava Pestov, 2009 Alex Chapman ! See http://factorcode.org/license.txt for BSD license. -USING: help.markup help.syntax kernel ; +USING: boxes help.markup help.syntax kernel math namespaces ; IN: refs -ARTICLE: "refs" "References to assoc entries" -"A " { $emphasis "reference" } " is an object encapsulating an assoc and a key; the reference then refers to either the key itself, or the value associated to the key. References can be read, written, and deleted. References are defined in the " { $vocab-link "refs" } " vocabulary." +ARTICLE: "refs" "References" +"References provide a uniform way of accessing and changing values. Some examples of referenced values are variables, tuple slots, and keys or values of assocs. References can be read, written, and deleted. References are defined in the " { $vocab-link "refs" } " vocabulary, and new reference types can be made by implementing the " { $link "refs-protocol" } "." { $subsection get-ref } { $subsection set-ref } +{ $subsection set-ref* } { $subsection delete-ref } -"References to keys:" +"References to objects:" +{ $subsection obj-ref } +{ $subsection } +"References to assoc keys:" { $subsection key-ref } { $subsection } -"References to values:" +"References to assoc values:" { $subsection value-ref } { $subsection } +"References to variables:" +{ $subsection var-ref } +{ $subsection } +{ $subsection global-var-ref } +{ $subsection } +"References to tuple slots:" +{ $subsection slot-ref } +{ $subsection } +"Using boxes as references:" +{ $subsection "box-refs" } "References are used by the UI inspector." ; ABOUT: "refs" +ARTICLE: "refs-protocol" "Reference Protocol" +"To use a class of objects as references you must implement the reference protocol for that class, and mark your class as an instance of the " { $link ref } " mixin class. All references must implement these two words:" +{ $subsection get-ref } +{ $subsection set-ref } +"References may also implement:" +{ $subsection delete-ref } ; + +ARTICLE: "box-refs" "Using Boxes as References" +"Boxes are elements of the " { $link ref } " mixin class, so any box may be used as a reference. Bear in mind that boxes will still throw an error if you call " { $link get-ref } " on an empty box." ; + HELP: ref -{ $class-description "A class whose instances identify a key or value location in an associative structure. Instances of this clas are never used directly; only instances of " { $link key-ref } " and " { $link value-ref } " should be created." } ; +{ $class-description "A mixin class whose instances encapsulate a value which can be read, written, and deleted. Instantiable members of this class include:" { $link obj-ref } ", " { $link var-ref } ", " { $link global-var-ref } ", " { $link slot-ref } ", " { $link box } ", " { $link key-ref } ", and " { $link value-ref } "." } ; HELP: delete-ref { $values { "ref" ref } } -{ $description "Deletes the association entry pointed at by this reference." } ; +{ $description "Deletes the value pointed to by this reference. In most references this simply sets the value to f, but in some cases it is more destructive, such as in " { $link value-ref } " and " { $link key-ref } ", where it actually deletes the entry from the underlying assoc." } ; HELP: get-ref { $values { "ref" ref } { "obj" object } } -{ $description "Outputs the key or the value pointed at by this reference." } ; +{ $description "Outputs the value pointed at by this reference." } ; HELP: set-ref { $values { "obj" object } { "ref" ref } } -{ $description "Stores a new key or value at by this reference." } ; +{ $description "Stores a new value at this reference." } ; +HELP: obj-ref +{ $class-description "Instances of this class contain a value which can be changed using the " { $link "refs-protocol" } ". New object references are created by calling " { $link } "." } ; + +HELP: +{ $values { "obj" object } { "obj-ref" obj-ref } } +{ $description "Creates a reference which contains the value it references." } ; + +HELP: var-ref +{ $class-description "Instances of this class reference a variable as defined by the " { $vocab-link "namespaces" } " vocabulary. New variable references are created by calling " { $link } "." } ; + +HELP: +{ $values { "var" object } { "var-ref" var-ref } } +{ $description "Creates a reference to the given variable. Note that this reference behaves just like any variable when it comes to dynamic scope. For example, if you use " { $link set-ref } " in an inner scope and then leave that scope, then calling " { $link get-ref } " may not return the expected value. If this is not what you want, try using an " { $link obj-ref } " instead." } ; + +HELP: global-var-ref +{ $class-description "Instances of this class reference a global variable. New global references are created by calling " { $link } "." } ; + +HELP: +{ $values { "var" object } { "global-var-ref" global-var-ref } } +{ $description "Creates a reference to a global variable." } ; + +HELP: slot-ref +{ $class-description "Instances of this class identify a particular slot of a particular instance of a tuple. New slot references are created by calling " { $link } "." } ; + +HELP: +{ $values { "tuple" tuple } { "slot" integer } { "slot-ref" slot-ref } } +{ $description "Creates a reference to the value in a particular slot of the given tuple. The slot must be given as an integer, where the first user-defined slot is number 2. This is mostly just a proof of concept until we have a way of generating this slot number from a slot name." } ; + HELP: key-ref { $class-description "Instances of this class identify a key in an associative structure. New key references are created by calling " { $link } "." } ; @@ -47,6 +99,37 @@ HELP: { $values { "assoc" "an assoc" } { "key" object } { "value-ref" value-ref } } { $description "Creates a reference to the value associated with " { $snippet "key" } " in " { $snippet "assoc" } "." } ; -{ get-ref set-ref delete-ref } related-words +{ get-ref set-ref delete-ref set-ref* } related-words + +{ } related-words -{ } related-words +HELP: set-ref* +{ $values { "ref" ref } { "obj" object } } +{ $description "Just like " { $link set-ref } ", but leave the ref on the stack." } ; + +HELP: ref-on +{ $values { "ref" ref } } +{ $description "Sets the value of the ref to t." } ; + +HELP: ref-off +{ $values { "ref" ref } } +{ $description "Sets the value of the ref to f." } ; + +HELP: ref-inc +{ $values { "ref" ref } } +{ $description "Increment the value of the ref by 1." } ; + +HELP: ref-dec +{ $values { "ref" ref } } +{ $description "Decrement the value of the ref by 1." } ; + +HELP: take +{ $values { "ref" ref } { "obj" object } } +{ $description "Retrieve the value of the ref and then delete it, returning the value." } ; + +{ ref-on ref-off ref-inc ref-dec take } related-words +{ take delete-ref } related-words +{ on ref-on } related-words +{ off ref-off } related-words +{ inc ref-inc } related-words +{ dec ref-dec } related-words diff --git a/basis/refs/refs-tests.factor b/basis/refs/refs-tests.factor index 1d921854e9..bf58aaf43d 100644 --- a/basis/refs/refs-tests.factor +++ b/basis/refs/refs-tests.factor @@ -1,5 +1,7 @@ -USING: refs tools.test kernel ; +USING: boxes kernel namespaces refs tools.test ; +IN: refs.tests +! assoc-refs [ 3 ] [ H{ { "a" 3 } } "a" get-ref ] unit-test @@ -20,3 +22,84 @@ USING: refs tools.test kernel ; set-ref ] keep ] unit-test + +SYMBOLS: lion giraffe elephant rabbit ; + +! obj-refs +[ rabbit ] [ rabbit get-ref ] unit-test +[ rabbit ] [ f rabbit set-ref* get-ref ] unit-test +[ rabbit ] [ rabbit take ] unit-test +[ rabbit f ] [ rabbit [ take ] keep get-ref ] unit-test +[ lion ] [ rabbit dup [ drop lion ] change-ref get-ref ] unit-test + +! var-refs +[ giraffe ] [ [ giraffe rabbit set rabbit get-ref ] with-scope ] unit-test + +[ rabbit ] +[ + [ + lion rabbit set [ + rabbit rabbit set rabbit get-ref + ] with-scope + ] with-scope +] unit-test + +[ rabbit ] [ + rabbit + [ + lion rabbit set [ + rabbit rabbit set get-ref + ] with-scope + ] with-scope +] unit-test + +[ elephant ] [ + rabbit + [ + elephant rabbit set [ + rabbit rabbit set + ] with-scope + get-ref + ] with-scope +] unit-test + +[ rabbit ] [ + rabbit + [ + elephant set-ref* [ + rabbit set-ref* get-ref + ] with-scope + ] with-scope +] unit-test + +[ elephant ] [ + rabbit + [ + elephant set-ref* [ + rabbit set-ref* + ] with-scope + get-ref + ] with-scope +] unit-test + +! Top Hats +[ lion ] [ lion rabbit set-global rabbit get-ref ] unit-test +[ giraffe ] [ rabbit giraffe set-ref* get-ref ] unit-test + +! Tuple refs +TUPLE: foo bar ; +C: foo + +: test-tuple ( -- tuple ) + rabbit ; + +: test-slot-ref ( -- slot-ref ) + test-tuple 2 ; ! hack! + +[ rabbit ] [ test-slot-ref get-ref ] unit-test +[ lion ] [ test-slot-ref lion set-ref* get-ref ] unit-test + +! Boxes as refs +[ rabbit ] [ rabbit set-ref* get-ref ] unit-test +[ rabbit set-ref* lion set-ref* ] must-fail +[ get-ref ] must-fail diff --git a/basis/refs/refs.factor b/basis/refs/refs.factor index 0164a1ea57..668cdd65c3 100644 --- a/basis/refs/refs.factor +++ b/basis/refs/refs.factor @@ -1,22 +1,77 @@ -! Copyright (C) 2007, 2008 Slava Pestov +! Copyright (C) 2007, 2008 Slava Pestov, 2009 Alex Chapman ! See http://factorcode.org/license.txt for BSD license. -USING: classes.tuple kernel assocs accessors ; +USING: kernel assocs accessors boxes math namespaces ; IN: refs -TUPLE: ref assoc key ; +MIXIN: ref -: >ref< ( ref -- key value ) [ key>> ] [ assoc>> ] bi ; inline - -: delete-ref ( ref -- ) >ref< delete-at ; GENERIC: get-ref ( ref -- obj ) GENERIC: set-ref ( obj ref -- ) +GENERIC: delete-ref ( ref -- ) -TUPLE: key-ref < ref ; +! works like >>slot words +: set-ref* ( ref obj -- ref ) over set-ref ; + +! very similar to change, on, off, +@, inc, and dec from namespaces +: change-ref ( ref quot -- ) + [ [ get-ref ] keep ] dip dip set-ref ; inline +: ref-on ( ref -- ) t swap set-ref ; +: ref-off ( ref -- ) f swap set-ref ; +: ref-+@ ( n ref -- ) [ 0 or + ] change-ref ; +: ref-inc ( ref -- ) 1 swap ref-+@ ; +: ref-dec ( ref -- ) -1 swap ref-+@ ; + +: take ( ref -- obj ) + dup get-ref swap delete-ref ; + +! delete-ref defaults to setting ref to f +M: ref delete-ref ref-off ; + +TUPLE: obj-ref obj ; +C: obj-ref +M: obj-ref get-ref obj>> ; +M: obj-ref set-ref (>>obj) ; +INSTANCE: obj-ref ref + +TUPLE: var-ref var ; +C: var-ref +M: var-ref get-ref var>> get ; +M: var-ref set-ref var>> set ; +INSTANCE: var-ref ref + +TUPLE: global-var-ref var ; +C: global-var-ref +M: global-var-ref get-ref var>> get-global ; +M: global-var-ref set-ref var>> set-global ; +INSTANCE: global-var-ref ref + +USE: slots.private +TUPLE: slot-ref tuple slot ; +C: slot-ref +: >slot-ref< ( slot-ref -- tuple slot ) [ tuple>> ] [ slot>> ] bi ; inline +M: slot-ref get-ref >slot-ref< slot ; +M: slot-ref set-ref >slot-ref< set-slot ; +INSTANCE: slot-ref ref + +M: box get-ref box> ; +M: box set-ref >box ; +M: box delete-ref box> drop ; +INSTANCE: box ref + +TUPLE: assoc-ref assoc key ; + +: >assoc-ref< ( assoc-ref -- key value ) [ key>> ] [ assoc>> ] bi ; inline + +M: assoc-ref delete-ref ( assoc-ref -- ) >assoc-ref< delete-at ; + +TUPLE: key-ref < assoc-ref ; C: key-ref M: key-ref get-ref key>> ; -M: key-ref set-ref >ref< rename-at ; +M: key-ref set-ref >assoc-ref< rename-at ; +INSTANCE: key-ref ref -TUPLE: value-ref < ref ; +TUPLE: value-ref < assoc-ref ; C: value-ref -M: value-ref get-ref >ref< at ; -M: value-ref set-ref >ref< set-at ; +M: value-ref get-ref >assoc-ref< at ; +M: value-ref set-ref >assoc-ref< set-at ; +INSTANCE: value-ref ref diff --git a/basis/regexp/regexp-tests.factor b/basis/regexp/regexp-tests.factor index ae013a7719..0479b104cc 100644 --- a/basis/regexp/regexp-tests.factor +++ b/basis/regexp/regexp-tests.factor @@ -262,11 +262,11 @@ IN: regexp-tests ! Comment inside a regular expression [ t ] [ "ac" "a(?#boo)c" 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)?" first-match >string ] unit-test [ "abc" ] [ "abc" "(a|ab)(bc)?" first-match >string ] unit-test diff --git a/basis/smtp/authors.txt b/basis/smtp/authors.txt index 159b1e91e9..ad5e36ed58 100644 --- a/basis/smtp/authors.txt +++ b/basis/smtp/authors.txt @@ -1,3 +1,5 @@ Elie Chaftari Dirk Vleugels Slava Pestov +Doug Coleman +Daniel Ehrenberg diff --git a/basis/smtp/server/server.factor b/basis/smtp/server/server.factor index 5d7791292b..dbff4fd214 100644 --- a/basis/smtp/server/server.factor +++ b/basis/smtp/server/server.factor @@ -36,6 +36,7 @@ SYMBOL: data-mode : process ( -- ) read-crlf { + { [ dup not ] [ f ] } { [ dup [ "HELO" head? ] [ "EHLO" head? ] bi or ] [ "220 and..?\r\n" write flush t ] diff --git a/basis/smtp/smtp-docs.factor b/basis/smtp/smtp-docs.factor index 453f4009e2..0b13113427 100644 --- a/basis/smtp/smtp-docs.factor +++ b/basis/smtp/smtp-docs.factor @@ -1,7 +1,7 @@ ! 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 @@ -41,7 +41,9 @@ HELP: email { { $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." diff --git a/basis/smtp/smtp-tests.factor b/basis/smtp/smtp-tests.factor index 8a9107b905..df6510afbf 100644 --- a/basis/smtp/smtp-tests.factor +++ b/basis/smtp/smtp-tests.factor @@ -16,7 +16,7 @@ IN: smtp.tests [ { "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" } check-response ] @@ -51,7 +51,7 @@ IN: smtp.tests [ { { "Content-Transfer-Encoding" "base64" } - { "Content-Type" "Text/plain; charset=utf-8" } + { "Content-Type" "text/plain; charset=UTF-8" } { "From" "Doug " } { "MIME-Version" "1.0" } { "Subject" "Factor rules" } diff --git a/basis/smtp/smtp.factor b/basis/smtp/smtp.factor index 03b9d8af11..bfba9ea28a 100644 --- a/basis/smtp/smtp.factor +++ b/basis/smtp/smtp.factor @@ -1,12 +1,12 @@ ! 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 @@ -44,6 +44,8 @@ TUPLE: email { cc array } { bcc array } { subject string } + { content-type string initial: "text/plain" } + { encoding word initial: utf8 } { body string } ; : ( -- email ) email new ; inline @@ -85,8 +87,8 @@ M: message-contains-dot summary ( obj -- string ) "." over member? [ message-contains-dot ] when ; -: send-body ( body -- ) - utf8 encode +: send-body ( email -- ) + [ body>> ] [ encoding>> ] bi encode >base64-lines write crlf "." command ; @@ -162,9 +164,8 @@ M: plain-auth send-auth : encode-header ( string -- string' ) dup aux>> [ - "=?utf-8?B?" - swap utf8 encode >base64 - "?=" 3append + utf8 encode >base64 + "=?utf-8?B?" "?=" surround ] when ; ERROR: invalid-header-string string ; @@ -195,24 +196,23 @@ ERROR: invalid-header-string string ; ! 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 -- ) [ @@ -227,7 +227,7 @@ ERROR: invalid-header-string string ; data get-ok swap write-headers crlf - body>> send-body get-ok + send-body get-ok quit get-ok ] with-smtp-connection ; diff --git a/basis/sorting/slots/slots-docs.factor b/basis/sorting/slots/slots-docs.factor index cc89d497e7..beb378d4bd 100644 --- a/basis/sorting/slots/slots-docs.factor +++ b/basis/sorting/slots/slots-docs.factor @@ -6,19 +6,21 @@ IN: sorting.slots HELP: compare-slots { $values - { "sort-specs" "a sequence of accessors ending with a comparator" } - { "<=>" { $link +lt+ } " " { $link +eq+ } " or " { $link +gt+ } } + { "obj1" object } + { "obj2" object } + { "sort-specs" "a sequence of accessors ending with a comparator" } + { "<=>" { $link +lt+ } " " { $link +eq+ } " or " { $link +gt+ } } } { $description "Compares two objects using a chain of intrinsic linear orders such that if two objects are " { $link +eq+ } ", then the next comparator is tried. The comparators are slot-name/comparator pairs." } ; -HELP: sort-by-slots +HELP: sort-by { $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 - "Sort by slot c, then b descending:" + "Sort by slot a, then b descending:" { $example "USING: accessors math.order prettyprint sorting.slots ;" "IN: scratchpad" @@ -27,32 +29,18 @@ HELP: sort-by-slots " T{ sort-me f 2 3 } T{ sort-me f 3 2 }" " T{ sort-me f 4 3 } T{ sort-me f 2 1 }" "}" - "{ { a>> <=> } { b>> >=< } } sort-by-slots ." + "{ { a>> <=> } { b>> >=< } } sort-by ." "{\n T{ sort-me { a 2 } { b 3 } }\n T{ sort-me { a 2 } { b 1 } }\n T{ sort-me { a 3 } { b 2 } }\n T{ sort-me { a 4 } { b 3 } }\n}" } } ; -HELP: split-by-slots -{ $values - { "accessor-seqs" "a sequence of sequences of tuple accessors" } - { "quot" quotation } -} -{ $description "Splits a sequence of tuples into a sequence of slices of tuples that have the same values in all slots in the accessor sequence. This word is only useful for splitting a sorted sequence, but is more efficient than partitioning in such a case." } ; - -HELP: sort-by -{ $values - { "seq" sequence } { "sort-seq" "a sequence of comparators" } - { "sortedseq" sequence } -} -{ $description "Sorts a sequence by comparing elements by comparators, using subsequent comparators when there is a tie." } ; - ARTICLE: "sorting.slots" "Sorting by slots" "The " { $vocab-link "sorting.slots" } " vocabulary can sort tuples by slot in ascending or descending order, using subsequent slots as tie-breakers." $nl "Comparing two objects by a sequence of slots:" { $subsection compare-slots } "Sorting a sequence of tuples by a slot/comparator pairs:" -{ $subsection sort-by-slots } -"Sorting a sequence by a sequence of comparators:" -{ $subsection sort-by } ; +{ $subsection sort-by } +{ $subsection sort-keys-by } +{ $subsection sort-values-by } ; ABOUT: "sorting.slots" diff --git a/basis/sorting/slots/slots-tests.factor b/basis/sorting/slots/slots-tests.factor index 83900461c3..5ebd4438fe 100644 --- a/basis/sorting/slots/slots-tests.factor +++ b/basis/sorting/slots/slots-tests.factor @@ -24,7 +24,7 @@ TUPLE: tuple2 d ; T{ sort-test f 1 1 11 } T{ sort-test f 2 5 3 } T{ sort-test f 2 5 2 } - } { { a>> <=> } { b>> >=< } { c>> <=> } } sort-by-slots + } { { a>> <=> } { b>> >=< } { c>> <=> } } sort-by ] unit-test [ @@ -42,43 +42,14 @@ TUPLE: tuple2 d ; T{ sort-test f 1 1 11 } T{ sort-test f 2 5 3 } T{ sort-test f 2 5 2 } - } { { a>> human<=> } { b>> human>=< } { c>> <=> } } sort-by-slots + } { { a>> human<=> } { b>> human>=< } { c>> <=> } } sort-by ] unit-test -[ - { - { - T{ sort-test { a 1 } { b 1 } { c 10 } } - T{ sort-test { a 1 } { b 1 } { c 11 } } - } - { T{ sort-test { a 1 } { b 3 } { c 9 } } } - { - T{ sort-test { a 2 } { b 5 } { c 3 } } - T{ sort-test { a 2 } { b 5 } { c 2 } } - } - } -] [ - { - T{ sort-test f 1 3 9 } - T{ sort-test f 1 1 10 } - T{ sort-test f 1 1 11 } - T{ sort-test f 2 5 3 } - T{ sort-test f 2 5 2 } - } - { { a>> human<=> } { b>> <=> } } [ sort-by-slots ] keep - [ but-last-slice ] map split-by-slots [ >array ] map -] unit-test - -: split-test ( seq -- seq' ) - { { a>> } { b>> } } split-by-slots ; - -[ split-test ] must-infer +[ { } ] +[ { } { { a>> <=> } { b>> >=< } { c>> <=> } } sort-by ] unit-test [ { } ] -[ { } { { a>> <=> } { b>> >=< } { c>> <=> } } sort-by-slots ] unit-test - -[ { } ] -[ { } { } sort-by-slots ] unit-test +[ { } { } sort-by ] unit-test [ { @@ -97,55 +68,7 @@ TUPLE: tuple2 d ; T{ sort-test f 6 f f T{ tuple2 f 3 } } T{ sort-test f 5 f f T{ tuple2 f 3 } } T{ sort-test f 6 f f T{ tuple2 f 2 } } - } { { tuple2>> d>> <=> } { a>> <=> } } sort-by-slots -] unit-test - -[ - { - { - T{ sort-test - { a 6 } - { tuple2 T{ tuple2 { d 1 } } } - } - } - { - T{ sort-test - { a 6 } - { tuple2 T{ tuple2 { d 2 } } } - } - } - { - T{ sort-test - { a 5 } - { tuple2 T{ tuple2 { d 3 } } } - } - } - { - T{ sort-test - { a 6 } - { tuple2 T{ tuple2 { d 3 } } } - } - T{ sort-test - { a 6 } - { tuple2 T{ tuple2 { d 3 } } } - } - } - { - T{ sort-test - { a 5 } - { tuple2 T{ tuple2 { d 4 } } } - } - } - } -] [ - { - T{ sort-test { a 6 } { tuple2 T{ tuple2 { d 1 } } } } - T{ sort-test { a 6 } { tuple2 T{ tuple2 { d 2 } } } } - T{ sort-test { a 5 } { tuple2 T{ tuple2 { d 3 } } } } - T{ sort-test { a 6 } { tuple2 T{ tuple2 { d 3 } } } } - T{ sort-test { a 6 } { tuple2 T{ tuple2 { d 3 } } } } - T{ sort-test { a 5 } { tuple2 T{ tuple2 { d 4 } } } } - } { { tuple2>> d>> } { a>> } } split-by-slots [ >array ] map + } { { tuple2>> d>> <=> } { a>> <=> } } sort-by ] unit-test @@ -159,3 +82,15 @@ TUPLE: tuple2 d ; { { 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 diff --git a/basis/sorting/slots/slots.factor b/basis/sorting/slots/slots.factor index efec960c27..e3b4bc88ca 100644 --- a/basis/sorting/slots/slots.factor +++ b/basis/sorting/slots/slots.factor @@ -1,45 +1,28 @@ ! Copyright (C) 2009 Slava Pestov, Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: combinators.short-circuit fry kernel macros math.order -sequences words sorting sequences.deep assocs splitting.monotonic -math ; +USING: arrays fry kernel math.order sequences sorting ; IN: sorting.slots -/f ) + execute( obj1 obj2 -- <=> ) dup +eq+ eq? [ drop f ] when ; -: short-circuit-comparator ( obj1 obj2 word -- comparator/? ) - execute dup +eq+ eq? [ drop f ] when ; inline +: execute-accessor ( obj1 obj2 word -- obj1' obj2' ) + '[ _ execute( tuple -- value ) ] bi@ ; -: slot-comparator ( seq -- quot ) - [ - but-last-slice - [ '[ [ _ execute ] bi@ ] ] map concat - ] [ - peek - '[ @ _ short-circuit-comparator ] - ] bi ; - -PRIVATE> - -MACRO: compare-slots ( sort-specs -- <=> ) +: compare-slots ( obj1 obj2 sort-specs -- <=> ) #! sort-spec: { accessors comparator } - [ slot-comparator ] map '[ _ 2|| +eq+ or ] ; + [ + dup array? [ + unclip-last-slice + [ [ execute-accessor ] each ] dip + ] when execute-comparator + ] with with map-find drop +eq+ or ; -MACRO: sort-by-slots ( sort-specs -- quot ) - '[ [ _ compare-slots ] sort ] ; +: sort-by-with ( seq sort-specs quot -- seq' ) + swap '[ _ bi@ _ compare-slots ] sort ; inline -MACRO: compare-seq ( seq -- quot ) - [ '[ _ short-circuit-comparator ] ] map '[ _ 2|| +eq+ or ] ; +: sort-by ( seq sort-specs -- seq' ) [ ] sort-by-with ; -MACRO: sort-by ( sort-seq -- quot ) - '[ [ _ compare-seq ] sort ] ; +: sort-keys-by ( seq sort-seq -- seq' ) [ first ] sort-by-with ; -MACRO: sort-keys-by ( sort-seq -- quot ) - '[ [ first ] bi@ _ compare-seq ] sort ; - -MACRO: sort-values-by ( sort-seq -- quot ) - '[ [ second ] bi@ _ compare-seq ] sort ; - -MACRO: split-by-slots ( accessor-seqs -- quot ) - [ [ '[ [ _ execute ] bi@ ] ] map concat [ = ] compose ] map - '[ [ _ 2&& ] slice monotonic-slice ] ; +: sort-values-by ( seq sort-seq -- seq' ) [ second ] sort-by-with ; diff --git a/basis/stack-checker/stack-checker-tests.factor b/basis/stack-checker/stack-checker-tests.factor index d8f61661d5..6b9e9fd8b6 100644 --- a/basis/stack-checker/stack-checker-tests.factor +++ b/basis/stack-checker/stack-checker-tests.factor @@ -524,7 +524,7 @@ ERROR: custom-error ; { 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 @@ -536,7 +536,7 @@ M: object inference-invalidation-d inference-invalidation-c 2drop ; \ 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 diff --git a/basis/tools/annotations/annotations-tests.factor b/basis/tools/annotations/annotations-tests.factor index 0c92cb567b..bbd2ac2ca8 100644 --- a/basis/tools/annotations/annotations-tests.factor +++ b/basis/tools/annotations/annotations-tests.factor @@ -18,7 +18,7 @@ M: integer some-generic 1+ ; [ 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 @@ -33,7 +33,7 @@ M: object another-generic ; \ 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 diff --git a/basis/tools/completion/completion.factor b/basis/tools/completion/completion.factor index 14cec8e85f..99def097a2 100644 --- a/basis/tools/completion/completion.factor +++ b/basis/tools/completion/completion.factor @@ -3,20 +3,20 @@ USING: accessors kernel arrays sequences math namespaces strings io fry vectors words assocs combinators sorting unicode.case unicode.categories math.order vocabs -tools.vocabs unicode.data ; +tools.vocabs unicode.data locals ; IN: tools.completion -: (fuzzy) ( accum ch i full -- accum i ? ) - index-from - [ - [ swap push ] 2keep 1+ t +:: (fuzzy) ( accum i full ch -- accum i full ? ) + ch i full index-from [ + :> i i accum push + accum i 1+ full t ] [ - drop f -1 f + f -1 full f ] if* ; : fuzzy ( full short -- indices ) - dup length -rot 0 -rot - [ -rot [ (fuzzy) ] keep swap ] all? 3drop ; + dup [ length 0 ] curry 2dip + [ (fuzzy) ] all? 3drop ; : (runs) ( runs n seq -- runs n ) [ diff --git a/basis/tools/deploy/shaker/shaker.factor b/basis/tools/deploy/shaker/shaker.factor index 2fc1ada108..37eec5eae2 100755 --- a/basis/tools/deploy/shaker/shaker.factor +++ b/basis/tools/deploy/shaker/shaker.factor @@ -357,7 +357,7 @@ IN: tools.deploy.shaker V{ } set-namestack V{ } set-catchstack "Saving final image" show - [ save-image-and-exit ] call-clear ; + save-image-and-exit ; SYMBOL: deploy-vocab @@ -421,10 +421,10 @@ SYMBOL: deploy-vocab : 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 diff --git a/basis/tools/errors/errors-docs.factor b/basis/tools/errors/errors-docs.factor index 9fc324b231..96b13b69b6 100644 --- a/basis/tools/errors/errors-docs.factor +++ b/basis/tools/errors/errors-docs.factor @@ -1,5 +1,35 @@ IN: tools.errors -USING: help.markup help.syntax source-files.errors ; +USING: help.markup help.syntax source-files.errors words io +compiler.errors ; + +ARTICLE: "compiler-errors" "Compiler warnings and errors" +"After loading a vocabulary, you might see messages like:" +{ $code + ":errors - print 2 compiler errors" + ":warnings - print 50 compiler warnings" +} +"These messages arise from the compiler's stack effect checker. Production code should not have any warnings and errors in it. Warning and error conditions are documented in " { $link "inference-errors" } "." +$nl +"Words to view warnings and errors:" +{ $subsection :warnings } +{ $subsection :errors } +{ $subsection :linkage } +"Compiler warnings and errors are reported using the " { $link "tools.errors" } " mechanism and are shown in the " { $link "ui.tools.error-list" } "." ; + +HELP: compiler-error +{ $values { "error" "an error" } { "word" word } } +{ $description "Saves the error for future persual via " { $link :errors } ", " { $link :warnings } " and " { $link :linkage } "." } ; + +HELP: :errors +{ $description "Prints all serious compiler errors from the most recent compile to " { $link output-stream } "." } ; + +HELP: :warnings +{ $description "Prints all ignorable compiler warnings from the most recent compile to " { $link output-stream } "." } ; + +HELP: :linkage +{ $description "Prints all C library interface linkage errors from the most recent compile to " { $link output-stream } "." } ; + +{ :errors :warnings :linkage } related-words HELP: errors. { $values { "errors" "a sequence of " { $link source-file-error } " instances" } } diff --git a/basis/tools/errors/errors.factor b/basis/tools/errors/errors.factor index a8708fd229..0a28bdec08 100644 --- a/basis/tools/errors/errors.factor +++ b/basis/tools/errors/errors.factor @@ -1,35 +1,28 @@ ! Copyright (C) 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: assocs debugger io kernel sequences source-files.errors -summary accessors continuations make math.parser io.styles namespaces ; +summary accessors continuations make math.parser io.styles namespaces +compiler.errors ; IN: tools.errors #! 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>> [ % ": " % ] [ "" % ] if* ] + [ line#>> [ # ] when* ] bi + ] "" make + ; + +M: source-file-error error. + [ summary print nl ] [ error>> error. ] bi ; : errors. ( errors -- ) group-by-source-file sort-errors @@ -38,3 +31,12 @@ M: source-file-error error. [ [ nl ] [ error. ] interleave ] bi* ] assoc-each ; + +: compiler-errors. ( type -- ) + errors-of-type values errors. ; + +: :errors ( -- ) +compiler-error+ compiler-errors. ; + +: :warnings ( -- ) +compiler-warning+ compiler-errors. ; + +: :linkage ( -- ) +linkage-error+ compiler-errors. ; \ No newline at end of file diff --git a/basis/tools/files/files.factor b/basis/tools/files/files.factor index 8d882099de..146a119a63 100755 --- a/basis/tools/files/files.factor +++ b/basis/tools/files/files.factor @@ -75,7 +75,7 @@ M: object file-spec>string ( file-listing spec -- string ) : list-files-slow ( listing-tool -- array ) [ path>> ] [ sort>> ] [ specs>> ] tri '[ [ dup name>> file-info file-listing boa ] map - _ [ sort-by-slots ] when* + _ [ sort-by ] when* [ _ [ file-spec>string ] with map ] map ] with-directory-entries ; inline diff --git a/basis/tools/scaffold/scaffold.factor b/basis/tools/scaffold/scaffold.factor index 73e896d5ff..f35da24266 100755 --- a/basis/tools/scaffold/scaffold.factor +++ b/basis/tools/scaffold/scaffold.factor @@ -5,7 +5,8 @@ io.encodings.utf8 hashtables kernel namespaces sequences vocabs.loader io combinators calendar accessors math.parser io.streams.string ui.tools.operations quotations strings arrays prettyprint words vocabs sorting sets classes math alien urls -splitting ascii combinators.short-circuit alarms words.symbol ; +splitting ascii combinators.short-circuit alarms words.symbol +system ; IN: tools.scaffold SYMBOL: developer-name @@ -24,6 +25,9 @@ ERROR: no-vocab vocab ; : contains-separator? ( string -- ? ) [ path-separator? ] any? ; +: ensure-vocab-exists ( string -- string ) + dup vocabs member? [ no-vocab ] unless ; + : check-vocab-name ( string -- string ) [ ] [ contains-dot? [ vocab-name-contains-dot ] when ] @@ -234,6 +238,7 @@ PRIVATE> [ (help.) ] [ nl vocabulary>> link-vocab ] bi ; : scaffold-help ( vocab -- ) + ensure-vocab-exists [ dup "-docs.factor" vocab/suffix>path scaffolding? [ set-scaffold-docs-file @@ -268,6 +273,7 @@ PRIVATE> PRIVATE> : scaffold-tests ( vocab -- ) + ensure-vocab-exists dup "-tests.factor" vocab/suffix>path scaffolding? [ set-scaffold-tests-file @@ -296,8 +302,10 @@ SYMBOL: examples-flag [ home ] dip append-path [ touch-file ] [ "Click to edit: " write . ] bi ; -: scaffold-factor-boot-rc ( -- ) ".factor-boot-rc" scaffold-rc ; +: scaffold-factor-boot-rc ( -- ) + os windows? "factor-boot-rc" ".factor-boot-rc" ? scaffold-rc ; -: scaffold-factor-rc ( -- ) ".factor-rc" scaffold-rc ; +: scaffold-factor-rc ( -- ) + os windows? "factor-rc" ".factor-rc" ? scaffold-rc ; : scaffold-emacs ( -- ) ".emacs" scaffold-rc ; diff --git a/basis/tools/test/test.factor b/basis/tools/test/test.factor index 0741b90984..b98f58b143 100644 --- a/basis/tools/test/test.factor +++ b/basis/tools/test/test.factor @@ -129,13 +129,13 @@ TEST: must-infer 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. ; diff --git a/basis/ui/backend/x11/x11.factor b/basis/ui/backend/x11/x11.factor index d4b2959297..fb78abe917 100755 --- a/basis/ui/backend/x11/x11.factor +++ b/basis/ui/backend/x11/x11.factor @@ -3,11 +3,11 @@ USING: accessors alien alien.c-types arrays ui ui.private ui.gadgets ui.gadgets.private ui.gestures ui.backend ui.clipboards ui.gadgets.worlds ui.render ui.event-loop assocs kernel math -namespaces opengl sequences strings x11.xlib x11.events x11.xim -x11.glx x11.clipboard x11.constants x11.windows io.encodings.string -io.encodings.ascii io.encodings.utf8 combinators command-line -math.vectors classes.tuple opengl.gl threads math.rectangles -environment ascii ; +namespaces opengl sequences strings x11 x11.xlib x11.events x11.xim +x11.glx x11.clipboard x11.constants x11.windows x11.io +io.encodings.string io.encodings.ascii io.encodings.utf8 combinators +command-line math.vectors classes.tuple opengl.gl threads +math.rectangles environment ascii ; IN: ui.backend.x11 SINGLETON: x11-ui-backend @@ -196,7 +196,7 @@ M: world client-event QueuedAfterFlush events-queued 0 > [ next-event dup None XFilterEvent 0 = [ drop wait-event ] unless - ] [ ui-wait wait-event ] if ; + ] [ wait-for-display wait-event ] if ; M: x11-ui-backend do-events wait-event dup XAnyEvent-window window dup diff --git a/basis/ui/gadgets/gadgets.factor b/basis/ui/gadgets/gadgets.factor index bc07006d62..32d6c0c8a6 100644 --- a/basis/ui/gadgets/gadgets.factor +++ b/basis/ui/gadgets/gadgets.factor @@ -3,7 +3,7 @@ USING: accessors arrays hashtables kernel models math namespaces make sequences quotations math.vectors combinators sorting binary-search vectors dlists deques models threads -concurrency.flags math.order math.rectangles fry ; +concurrency.flags math.order math.rectangles fry locals ; IN: ui.gadgets ! Values for orientation slot @@ -66,8 +66,8 @@ M: gadget children-on nip children>> ; : ((fast-children-on)) ( gadget dim axis -- <=> ) [ swap loc>> v- ] dip v. 0 <=> ; -: (fast-children-on) ( dim axis children -- i ) - -rot '[ _ _ ((fast-children-on)) ] search drop ; +:: (fast-children-on) ( dim axis children -- i ) + children [ dim axis ((fast-children-on)) ] search drop ; PRIVATE> diff --git a/basis/ui/gadgets/paragraphs/paragraphs-tests.factor b/basis/ui/gadgets/paragraphs/paragraphs-tests.factor index fcc121e584..c8494216b4 100644 --- a/basis/ui/gadgets/paragraphs/paragraphs-tests.factor +++ b/basis/ui/gadgets/paragraphs/paragraphs-tests.factor @@ -27,7 +27,7 @@ INSTANCE: fake-break word-break [ { 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 diff --git a/basis/ui/text/text-docs.factor b/basis/ui/text/text-docs.factor index 4ac2fbbaa8..c2732754f6 100644 --- a/basis/ui/text/text-docs.factor +++ b/basis/ui/text/text-docs.factor @@ -46,7 +46,7 @@ HELP: offset>x HELP: line-metrics { $values { "font" font } { "string" string } { "metrics" line-metrics } } -{ $contract "Outputs a " { $link line-metrics } " object with text measurements." } ; +{ $contract "Outputs a " { $link metrics } " object with text measurements." } ; ARTICLE: "text-rendering" "Rendering text" "The " { $vocab-link "ui.text" } " vocabulary provides a cross-platform interface to the operating system's native font rendering engine. Currently, it uses Core Text on Mac OS X and FreeType on Windows and X11." diff --git a/basis/ui/tools/error-list/error-list.factor b/basis/ui/tools/error-list/error-list.factor index 7efe023f9a..6a63a70cf8 100644 --- a/basis/ui/tools/error-list/error-list.factor +++ b/basis/ui/tools/error-list/error-list.factor @@ -26,7 +26,7 @@ MEMO: error-icon ( type -- image-name ) : ( -- model gadget ) #! Linkage errors are not shown by default. - error-types get keys [ dup +linkage-error+ eq? not ] { } map>assoc + error-types get [ fatal?>> ] assoc-map [ [ [ error-icon ] dip ] assoc-map ] [ ] bi ; @@ -80,7 +80,7 @@ M: error-renderer row-columns { [ error-type error-icon ] [ line#>> [ number>string ] [ "" ] if* ] - [ asset>> unparse-short ] + [ asset>> [ unparse-short ] [ "" ] if* ] [ error>> summary ] } cleave ] output>array ; diff --git a/basis/ui/tools/listener/listener.factor b/basis/ui/tools/listener/listener.factor index 57689b002b..6484b8e1c4 100644 --- a/basis/ui/tools/listener/listener.factor +++ b/basis/ui/tools/listener/listener.factor @@ -358,9 +358,8 @@ interactor "completion" f { } 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 ; diff --git a/basis/urls/encoding/encoding-docs.factor b/basis/urls/encoding/encoding-docs.factor index f8b435441f..82ab3d1f69 100644 --- a/basis/urls/encoding/encoding-docs.factor +++ b/basis/urls/encoding/encoding-docs.factor @@ -7,7 +7,11 @@ HELP: url-decode HELP: url-encode { $values { "str" string } { "encoded" string } } -{ $description "URL-encodes a string." } ; +{ $description "URL-encodes a string, excluding certain characters, such as \"/\"." } ; + +HELP: url-encode-full +{ $values { "str" string } { "encoded" string } } +{ $description "URL-encodes a string, including all reserved characters, such as \"/\"." } ; HELP: url-quotable? { $values { "ch" "a character" } { "?" "a boolean" } } diff --git a/basis/urls/encoding/encoding.factor b/basis/urls/encoding/encoding.factor index 15b71ac0db..a5f5d62bfc 100644 --- a/basis/urls/encoding/encoding.factor +++ b/basis/urls/encoding/encoding.factor @@ -14,6 +14,25 @@ IN: urls.encoding [ "/_-.:" member? ] } 1|| ; foldable +! see http://tools.ietf.org/html/rfc3986#section-2.2 +: gen-delim? ( ch -- ? ) + ":/?#[]@" member? ; foldable + +: sub-delim? ( ch -- ? ) + "!$&'()*+,;=" member? ; foldable + +: reserved? ( ch -- ? ) + [ gen-delim? ] [ sub-delim? ] bi or ; foldable + +! see http://tools.ietf.org/html/rfc3986#section-2.3 +: unreserved? ( ch -- ? ) + { + [ letter? ] + [ LETTER? ] + [ digit? ] + [ "-._~" member? ] + } 1|| ; foldable + [ dup url-quotable? [ , ] [ push-utf8 ] if ] each ] "" make ; +: url-encode-full ( str -- encoded ) + [ + [ dup unreserved? [ , ] [ push-utf8 ] if ] each + ] "" make ; + ( dwFlags dwDataSize struct rgodf-array -- alien ) [ "DIDATAFORMAT" heap-size "DIOBJECTDATAFORMAT" heap-size ] 4 ndip @@ -78,9 +80,10 @@ SYMBOLS: "DIDATAFORMAT" (DIDATAFORMAT) ; : (malloc-guid-symbol) ( symbol guid -- ) - global swap '[ [ - _ execute [ byte-length malloc ] [ over byte-array>memory ] bi - ] unless* ] change-at ; + '[ + _ execute( -- value ) + [ byte-length malloc ] [ over byte-array>memory ] bi + ] initialize ; : define-guid-constants ( -- ) { @@ -105,7 +108,7 @@ SYMBOLS: } [ first2 (malloc-guid-symbol) ] each ; : define-joystick-format-constant ( -- ) - c_dfDIJoystick2 global [ [ + c_dfDIJoystick2 [ DIDF_ABSAXIS "DIJOYSTATE2" heap-size "DIJOYSTATE2" { @@ -274,10 +277,10 @@ SYMBOLS: { GUID_Slider_malloced "rglFSlider" 0 { DIDFT_OPTIONAL DIDFT_AXIS DIDFT_ANYINSTANCE } DIDOI_ASPECTFORCE } { GUID_Slider_malloced "rglFSlider" 1 { DIDFT_OPTIONAL DIDFT_AXIS DIDFT_ANYINSTANCE } DIDOI_ASPECTFORCE } } - ] unless* ] change-at ; + ] initialize ; : define-mouse-format-constant ( -- ) - c_dfDIMouse2 global [ [ + c_dfDIMouse2 [ DIDF_RELAXIS "DIMOUSESTATE2" heap-size "DIMOUSESTATE2" { @@ -293,13 +296,13 @@ SYMBOLS: { GUID_Button_malloced "rgbButtons" 6 { DIDFT_OPTIONAL DIDFT_ANYINSTANCE DIDFT_BUTTON } 0 } { GUID_Button_malloced "rgbButtons" 7 { DIDFT_OPTIONAL DIDFT_ANYINSTANCE DIDFT_BUTTON } 0 } } - ] unless* ] change-at ; + ] initialize ; ! Not a standard DirectInput format. Included for cross-platform niceness. ! This format returns the keyboard keys in USB HID order rather than Windows ! order : define-hid-keyboard-format-constant ( -- ) - c_dfDIKeyboard_HID global [ [ + c_dfDIKeyboard_HID [ DIDF_RELAXIS 256 f { @@ -560,10 +563,10 @@ SYMBOLS: { GUID_Key_malloced f 254 { DIDFT_OPTIONAL DIDFT_BUTTON [ 0 DIDFT_MAKEINSTANCE ] } 0 } { GUID_Key_malloced f 255 { DIDFT_OPTIONAL DIDFT_BUTTON [ 0 DIDFT_MAKEINSTANCE ] } 0 } } - ] unless* ] change-at ; + ] initialize ; : define-keyboard-format-constant ( -- ) - c_dfDIKeyboard global [ [ + c_dfDIKeyboard [ DIDF_RELAXIS 256 f { @@ -824,7 +827,7 @@ SYMBOLS: { GUID_Key_malloced f 254 { DIDFT_OPTIONAL DIDFT_BUTTON [ 254 DIDFT_MAKEINSTANCE ] } 0 } { GUID_Key_malloced f 255 { DIDFT_OPTIONAL DIDFT_BUTTON [ 255 DIDFT_MAKEINSTANCE ] } 0 } } - ] unless* ] change-at ; + ] initialize ; : define-format-constants ( -- ) define-joystick-format-constant @@ -837,7 +840,9 @@ SYMBOLS: define-format-constants ; [ define-constants ] "windows.dinput.constants" add-init-hook -define-constants + +: uninitialize ( variable quot -- ) + [ global ] dip '[ _ when* f ] change-at ; inline : free-dinput-constants ( -- ) { @@ -846,10 +851,11 @@ define-constants GUID_Slider_malloced GUID_Button_malloced GUID_Key_malloced GUID_POV_malloced GUID_Unknown_malloced GUID_SysMouse_malloced GUID_SysKeyboard_malloced GUID_Joystick_malloced GUID_SysMouseEm_malloced GUID_SysMouseEm2_malloced GUID_SysKeyboardEm_malloced GUID_SysKeyboardEm2_malloced - } [ global [ [ free ] when* f ] change-at ] each + } [ [ free ] uninitialize ] each + { c_dfDIKeyboard c_dfDIKeyboard_HID c_dfDIMouse2 c_dfDIJoystick2 - } [ global [ [ DIDATAFORMAT-rgodf free ] when* f ] change-at ] each ; + } [ [ DIDATAFORMAT-rgodf free ] uninitialize ] each ; PRIVATE> diff --git a/basis/windows/gdi32/gdi32.factor b/basis/windows/gdi32/gdi32.factor index 794aa0e32e..9b7cd2e35e 100755 --- a/basis/windows/gdi32/gdi32.factor +++ b/basis/windows/gdi32/gdi32.factor @@ -1501,7 +1501,6 @@ DESTRUCTOR: DeleteObject FUNCTION: BOOL ExtTextOutW ( HDC hdc, int X, int Y, UINT fuOptions, RECT* lprc, LPCTSTR lpString, UINT cbCount, INT* lpDx ) ; ALIAS: ExtTextOut ExtTextOutW ! FUNCTION: FillPath -FUNCTION: int FillRect ( HDC hDC, RECT* lprc, HBRUSH hbr ) ; ! FUNCTION: FillRgn ! FUNCTION: FixBrushOrgEx ! FUNCTION: FlattenPath diff --git a/basis/windows/kernel32/kernel32.factor b/basis/windows/kernel32/kernel32.factor index 36acc5e346..4d3dd81a0e 100755 --- a/basis/windows/kernel32/kernel32.factor +++ b/basis/windows/kernel32/kernel32.factor @@ -1477,7 +1477,7 @@ ALIAS: LoadLibraryEx LoadLibraryExW ! FUNCTION: LoadLibraryW ! FUNCTION: LoadModule ! FUNCTION: LoadResource -! FUNCTION: LocalAlloc +FUNCTION: HLOCAL LocalAlloc ( UINT uFlags, SIZE_T uBytes ) ; ! FUNCTION: LocalCompact ! FUNCTION: LocalFileTimeToFileTime ! FUNCTION: LocalFlags diff --git a/basis/windows/user32/user32.factor b/basis/windows/user32/user32.factor index 9daac21697..f3bc1becb2 100644 --- a/basis/windows/user32/user32.factor +++ b/basis/windows/user32/user32.factor @@ -807,7 +807,7 @@ FUNCTION: UINT EnumClipboardFormats ( UINT format ) ; ! 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 diff --git a/basis/x11/authors.txt b/basis/x11/authors.txt new file mode 100644 index 0000000000..db8d84451d --- /dev/null +++ b/basis/x11/authors.txt @@ -0,0 +1,2 @@ +Eduardo Cavazos +Slava Pestov diff --git a/basis/x11/clipboard/clipboard.factor b/basis/x11/clipboard/clipboard.factor index 87b91624af..20bf66c704 100644 --- a/basis/x11/clipboard/clipboard.factor +++ b/basis/x11/clipboard/clipboard.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: alien alien.c-types alien.strings alien.syntax arrays kernel math namespaces sequences io.encodings.string -io.encodings.utf8 io.encodings.ascii x11.xlib x11.constants +io.encodings.utf8 io.encodings.ascii x11 x11.xlib x11.constants specialized-arrays.int accessors ; IN: x11.clipboard diff --git a/basis/x11/events/events.factor b/basis/x11/events/events.factor index 07650a9da7..5673dd7f76 100644 --- a/basis/x11/events/events.factor +++ b/basis/x11/events/events.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: alien alien.c-types arrays hashtables io kernel math math.order namespaces prettyprint sequences strings combinators -x11.xlib ; +x11 x11.xlib ; IN: x11.events GENERIC: expose-event ( event window -- ) diff --git a/basis/x11/glx/glx.factor b/basis/x11/glx/glx.factor index e6001d3e59..dc6157b87f 100644 --- a/basis/x11/glx/glx.factor +++ b/basis/x11/glx/glx.factor @@ -2,8 +2,9 @@ ! See http://factorcode.org/license.txt for BSD license. ! ! based on glx.h from xfree86, and some of glxtokens.h -USING: alien alien.c-types alien.syntax x11.xlib namespaces make -kernel sequences parser words specialized-arrays.int accessors ; +USING: alien alien.c-types alien.syntax x11 x11.xlib x11.syntax +namespaces make kernel sequences parser words specialized-arrays.int +accessors ; IN: x11.glx LIBRARY: glx @@ -36,52 +37,52 @@ TYPEDEF: XID GLXFBConfigID TYPEDEF: void* GLXContext ! typedef struct __GLXcontextRec *GLXContext; TYPEDEF: void* GLXFBConfig ! typedef struct __GLXFBConfigRec *GLXFBConfig; -FUNCTION: XVisualInfo* glXChooseVisual ( Display* dpy, int screen, int* attribList ) ; -FUNCTION: void glXCopyContext ( Display* dpy, GLXContext src, GLXContext dst, ulong mask ) ; -FUNCTION: GLXContext glXCreateContext ( Display* dpy, XVisualInfo* vis, GLXContext shareList, bool direct ) ; -FUNCTION: GLXPixmap glXCreateGLXPixmap ( Display* dpy, XVisualInfo* vis, Pixmap pixmap ) ; -FUNCTION: void glXDestroyContext ( Display* dpy, GLXContext ctx ) ; -FUNCTION: void glXDestroyGLXPixmap ( Display* dpy, GLXPixmap pix ) ; -FUNCTION: int glXGetConfig ( Display* dpy, XVisualInfo* vis, int attrib, int* value ) ; -FUNCTION: GLXContext glXGetCurrentContext ( ) ; -FUNCTION: GLXDrawable glXGetCurrentDrawable ( ) ; -FUNCTION: bool glXIsDirect ( Display* dpy, GLXContext ctx ) ; -FUNCTION: bool glXMakeCurrent ( Display* dpy, GLXDrawable drawable, GLXContext ctx ) ; -FUNCTION: bool glXQueryExtension ( Display* dpy, int* errorBase, int* eventBase ) ; -FUNCTION: bool glXQueryVersion ( Display* dpy, int* major, int* minor ) ; -FUNCTION: void glXSwapBuffers ( Display* dpy, GLXDrawable drawable ) ; -FUNCTION: void glXUseXFont ( Font font, int first, int count, int listBase ) ; -FUNCTION: void glXWaitGL ( ) ; -FUNCTION: void glXWaitX ( ) ; -FUNCTION: char* glXGetClientString ( Display* dpy, int name ) ; -FUNCTION: char* glXQueryServerString ( Display* dpy, int screen, int name ) ; -FUNCTION: char* glXQueryExtensionsString ( Display* dpy, int screen ) ; +X-FUNCTION: XVisualInfo* glXChooseVisual ( Display* dpy, int screen, int* attribList ) ; +X-FUNCTION: void glXCopyContext ( Display* dpy, GLXContext src, GLXContext dst, ulong mask ) ; +X-FUNCTION: GLXContext glXCreateContext ( Display* dpy, XVisualInfo* vis, GLXContext shareList, bool direct ) ; +X-FUNCTION: GLXPixmap glXCreateGLXPixmap ( Display* dpy, XVisualInfo* vis, Pixmap pixmap ) ; +X-FUNCTION: void glXDestroyContext ( Display* dpy, GLXContext ctx ) ; +X-FUNCTION: void glXDestroyGLXPixmap ( Display* dpy, GLXPixmap pix ) ; +X-FUNCTION: int glXGetConfig ( Display* dpy, XVisualInfo* vis, int attrib, int* value ) ; +X-FUNCTION: GLXContext glXGetCurrentContext ( ) ; +X-FUNCTION: GLXDrawable glXGetCurrentDrawable ( ) ; +X-FUNCTION: bool glXIsDirect ( Display* dpy, GLXContext ctx ) ; +X-FUNCTION: bool glXMakeCurrent ( Display* dpy, GLXDrawable drawable, GLXContext ctx ) ; +X-FUNCTION: bool glXQueryExtension ( Display* dpy, int* errorBase, int* eventBase ) ; +X-FUNCTION: bool glXQueryVersion ( Display* dpy, int* major, int* minor ) ; +X-FUNCTION: void glXSwapBuffers ( Display* dpy, GLXDrawable drawable ) ; +X-FUNCTION: void glXUseXFont ( Font font, int first, int count, int listBase ) ; +X-FUNCTION: void glXWaitGL ( ) ; +X-FUNCTION: void glXWaitX ( ) ; +X-FUNCTION: char* glXGetClientString ( Display* dpy, int name ) ; +X-FUNCTION: char* glXQueryServerString ( Display* dpy, int screen, int name ) ; +X-FUNCTION: char* glXQueryExtensionsString ( Display* dpy, int screen ) ; ! New for GLX 1.3 -FUNCTION: GLXFBConfig* glXGetFBConfigs ( Display* dpy, int screen, int* nelements ) ; -FUNCTION: GLXFBConfig* glXChooseFBConfig ( Display* dpy, int screen, int* attrib_list, int* nelements ) ; -FUNCTION: int glXGetFBConfigAttrib ( Display* dpy, GLXFBConfig config, int attribute, int* value ) ; -FUNCTION: XVisualInfo* glXGetVisualFromFBConfig ( Display* dpy, GLXFBConfig config ) ; -FUNCTION: GLXWindow glXCreateWindow ( Display* dpy, GLXFBConfig config, Window win, int* attrib_list ) ; -FUNCTION: void glXDestroyWindow ( Display* dpy, GLXWindow win ) ; -FUNCTION: GLXPixmap glXCreatePixmap ( Display* dpy, GLXFBConfig config, Pixmap pixmap, int* attrib_list ) ; -FUNCTION: void glXDestroyPixmap ( Display* dpy, GLXPixmap pixmap ) ; -FUNCTION: GLXPbuffer glXCreatePbuffer ( Display* dpy, GLXFBConfig config, int* attrib_list ) ; -FUNCTION: void glXDestroyPbuffer ( Display* dpy, GLXPbuffer pbuf ) ; -FUNCTION: void glXQueryDrawable ( Display* dpy, GLXDrawable draw, int attribute, uint* value ) ; -FUNCTION: GLXContext glXCreateNewContext ( Display* dpy, GLXFBConfig config, int render_type, GLXContext share_list, bool direct ) ; -FUNCTION: bool glXMakeContextCurrent ( Display* display, GLXDrawable draw, GLXDrawable read, GLXContext ctx ) ; -FUNCTION: GLXDrawable glXGetCurrentReadDrawable ( ) ; -FUNCTION: Display* glXGetCurrentDisplay ( ) ; -FUNCTION: int glXQueryContext ( Display* dpy, GLXContext ctx, int attribute, int* value ) ; -FUNCTION: void glXSelectEvent ( Display* dpy, GLXDrawable draw, ulong event_mask ) ; -FUNCTION: void glXGetSelectedEvent ( Display* dpy, GLXDrawable draw, ulong* event_mask ) ; +X-FUNCTION: GLXFBConfig* glXGetFBConfigs ( Display* dpy, int screen, int* nelements ) ; +X-FUNCTION: GLXFBConfig* glXChooseFBConfig ( Display* dpy, int screen, int* attrib_list, int* nelements ) ; +X-FUNCTION: int glXGetFBConfigAttrib ( Display* dpy, GLXFBConfig config, int attribute, int* value ) ; +X-FUNCTION: XVisualInfo* glXGetVisualFromFBConfig ( Display* dpy, GLXFBConfig config ) ; +X-FUNCTION: GLXWindow glXCreateWindow ( Display* dpy, GLXFBConfig config, Window win, int* attrib_list ) ; +X-FUNCTION: void glXDestroyWindow ( Display* dpy, GLXWindow win ) ; +X-FUNCTION: GLXPixmap glXCreatePixmap ( Display* dpy, GLXFBConfig config, Pixmap pixmap, int* attrib_list ) ; +X-FUNCTION: void glXDestroyPixmap ( Display* dpy, GLXPixmap pixmap ) ; +X-FUNCTION: GLXPbuffer glXCreatePbuffer ( Display* dpy, GLXFBConfig config, int* attrib_list ) ; +X-FUNCTION: void glXDestroyPbuffer ( Display* dpy, GLXPbuffer pbuf ) ; +X-FUNCTION: void glXQueryDrawable ( Display* dpy, GLXDrawable draw, int attribute, uint* value ) ; +X-FUNCTION: GLXContext glXCreateNewContext ( Display* dpy, GLXFBConfig config, int render_type, GLXContext share_list, bool direct ) ; +X-FUNCTION: bool glXMakeContextCurrent ( Display* display, GLXDrawable draw, GLXDrawable read, GLXContext ctx ) ; +X-FUNCTION: GLXDrawable glXGetCurrentReadDrawable ( ) ; +X-FUNCTION: Display* glXGetCurrentDisplay ( ) ; +X-FUNCTION: int glXQueryContext ( Display* dpy, GLXContext ctx, int attribute, int* value ) ; +X-FUNCTION: void glXSelectEvent ( Display* dpy, GLXDrawable draw, ulong event_mask ) ; +X-FUNCTION: void glXGetSelectedEvent ( Display* dpy, GLXDrawable draw, ulong* event_mask ) ; ! GLX 1.4 and later -FUNCTION: void* glXGetProcAddress ( char* procname ) ; +X-FUNCTION: void* glXGetProcAddress ( char* procname ) ; ! GLX_ARB_get_proc_address extension -FUNCTION: void* glXGetProcAddressARB ( char* procname ) ; +X-FUNCTION: void* glXGetProcAddressARB ( char* procname ) ; ! GLX Events ! (also skipped for now. only has GLXPbufferClobberEvent, the rest is handled by xlib methinks) diff --git a/basis/x11/io/authors.txt b/basis/x11/io/authors.txt new file mode 100644 index 0000000000..d4f5d6b3ae --- /dev/null +++ b/basis/x11/io/authors.txt @@ -0,0 +1 @@ +Slava Pestov \ No newline at end of file diff --git a/basis/x11/io/io.factor b/basis/x11/io/io.factor new file mode 100644 index 0000000000..0e618cd323 --- /dev/null +++ b/basis/x11/io/io.factor @@ -0,0 +1,16 @@ +! Copyright (C) 2009 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: io.backend calendar threads kernel ; +IN: x11.io + +HOOK: init-x-io io-backend ( -- ) + +M: object init-x-io ; + +HOOK: wait-for-display io-backend ( -- ) + +M: object wait-for-display 10 milliseconds sleep ; + +HOOK: awaken-event-loop io-backend ( -- ) + +M: object awaken-event-loop ; \ No newline at end of file diff --git a/basis/x11/io/unix/authors.txt b/basis/x11/io/unix/authors.txt new file mode 100644 index 0000000000..d4f5d6b3ae --- /dev/null +++ b/basis/x11/io/unix/authors.txt @@ -0,0 +1 @@ +Slava Pestov \ No newline at end of file diff --git a/basis/x11/io/unix/tags.txt b/basis/x11/io/unix/tags.txt new file mode 100644 index 0000000000..6bf68304bb --- /dev/null +++ b/basis/x11/io/unix/tags.txt @@ -0,0 +1 @@ +unportable diff --git a/basis/x11/io/unix/unix.factor b/basis/x11/io/unix/unix.factor new file mode 100644 index 0000000000..821beb91a5 --- /dev/null +++ b/basis/x11/io/unix/unix.factor @@ -0,0 +1,15 @@ +! Copyright (C) 2009 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: io.backend.unix io.backend.unix.multiplexers +namespaces system x11 x11.xlib x11.io +accessors threads sequences kernel ; +IN: x11.io.unix + +SYMBOL: dpy-fd + +M: unix init-x-io dpy get XConnectionNumber dpy-fd set-global ; + +M: unix wait-for-display dpy-fd get +input+ wait-for-fd ; + +M: unix awaken-event-loop + dpy-fd get [ fd>> mx get remove-input-callbacks [ resume ] each ] when* ; \ No newline at end of file diff --git a/basis/x11/syntax/authors.txt b/basis/x11/syntax/authors.txt new file mode 100644 index 0000000000..d4f5d6b3ae --- /dev/null +++ b/basis/x11/syntax/authors.txt @@ -0,0 +1 @@ +Slava Pestov \ No newline at end of file diff --git a/basis/x11/syntax/syntax.factor b/basis/x11/syntax/syntax.factor new file mode 100644 index 0000000000..db2adab5dc --- /dev/null +++ b/basis/x11/syntax/syntax.factor @@ -0,0 +1,9 @@ +! Copyright (C) 2009 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: alien.syntax alien.parser words x11.io sequences kernel ; +IN: x11.syntax + +SYNTAX: X-FUNCTION: + (FUNCTION:) + [ \ awaken-event-loop suffix ] dip + define-declared ; \ No newline at end of file diff --git a/basis/x11/windows/windows.factor b/basis/x11/windows/windows.factor index 8085907bef..87a212bd8e 100644 --- a/basis/x11/windows/windows.factor +++ b/basis/x11/windows/windows.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2005, 2006 Eduardo Cavazos and Slava Pestov ! See http://factorcode.org/license.txt for BSD license. USING: alien alien.c-types hashtables kernel math math.vectors -math.bitwise namespaces sequences x11.xlib x11.constants x11.glx +math.bitwise namespaces sequences x11 x11.xlib x11.constants x11.glx arrays fry ; IN: x11.windows @@ -29,6 +29,8 @@ IN: x11.windows : window-attributes ( visinfo -- attributes ) "XSetWindowAttributes" + 0 over set-XSetWindowAttributes-background_pixel + 0 over set-XSetWindowAttributes-border_pixel [ [ create-colormap ] dip set-XSetWindowAttributes-colormap ] keep event-mask over set-XSetWindowAttributes-event_mask ; diff --git a/basis/x11/x11.factor b/basis/x11/x11.factor new file mode 100644 index 0000000000..09328c6f6e --- /dev/null +++ b/basis/x11/x11.factor @@ -0,0 +1,36 @@ +! Copyright (C) 2005, 2009 Eduardo Cavazos, Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: alien.strings continuations io +io.encodings.ascii kernel namespaces x11.xlib x11.io +vocabs vocabs.loader ; +IN: x11 + +SYMBOL: dpy +SYMBOL: scr +SYMBOL: root + +: init-locale ( -- ) + LC_ALL "" setlocale [ "setlocale() failed" print flush ] unless + XSupportsLocale [ "XSupportsLocale() failed" print flush ] unless ; + +: flush-dpy ( -- ) dpy get XFlush drop ; + +: x-atom ( string -- atom ) [ dpy get ] dip 0 XInternAtom ; + +: check-display ( alien -- alien' ) + [ "Cannot connect to X server - check $DISPLAY" throw ] unless* ; + +: init-x ( display-string -- ) + init-locale + dup [ ascii string>alien ] when + XOpenDisplay check-display dpy set-global + dpy get XDefaultScreen scr set-global + dpy get scr get XRootWindow root set-global + init-x-io ; + +: close-x ( -- ) dpy get XCloseDisplay drop ; + +: with-x ( display-string quot -- ) + [ init-x ] dip [ close-x ] [ ] cleanup ; inline + +"io.backend.unix" vocab [ "x11.io.unix" require ] when \ No newline at end of file diff --git a/basis/x11/xim/xim.factor b/basis/x11/xim/xim.factor index e4aaef9bbd..54f20a28dd 100644 --- a/basis/x11/xim/xim.factor +++ b/basis/x11/xim/xim.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: alien alien.c-types alien.strings arrays byte-arrays hashtables io io.encodings.string kernel math namespaces -sequences strings continuations x11.xlib specialized-arrays.uint +sequences strings continuations x11 x11.xlib specialized-arrays.uint accessors io.encodings.utf16n ; IN: x11.xim diff --git a/basis/x11/xlib/xlib.factor b/basis/x11/xlib/xlib.factor index 1a2cf09129..638f5c8d56 100644 --- a/basis/x11/xlib/xlib.factor +++ b/basis/x11/xlib/xlib.factor @@ -13,7 +13,7 @@ USING: kernel arrays alien alien.c-types alien.strings alien.syntax math math.bitwise words sequences namespaces -continuations io io.encodings.ascii ; +continuations io io.encodings.ascii x11.syntax ; IN: x11.xlib LIBRARY: xlib @@ -71,26 +71,26 @@ C-STRUCT: Display { "void*" "free_funcs" } { "int" "fd" } ; -FUNCTION: Display* XOpenDisplay ( void* display_name ) ; +X-FUNCTION: Display* XOpenDisplay ( void* display_name ) ; ! 2.2 Obtaining Information about the Display, Image Formats, or Screens -FUNCTION: ulong XBlackPixel ( Display* display, int screen_number ) ; -FUNCTION: ulong XWhitePixel ( Display* display, int screen_number ) ; -FUNCTION: Colormap XDefaultColormap ( Display* display, int screen_number ) ; -FUNCTION: int XDefaultDepth ( Display* display, int screen_number ) ; -FUNCTION: GC XDefaultGC ( Display* display, int screen_number ) ; -FUNCTION: int XDefaultScreen ( Display* display ) ; -FUNCTION: Window XRootWindow ( Display* display, int screen_number ) ; -FUNCTION: Window XDefaultRootWindow ( Display* display ) ; -FUNCTION: int XProtocolVersion ( Display* display ) ; -FUNCTION: int XProtocolRevision ( Display* display ) ; -FUNCTION: int XQLength ( Display* display ) ; -FUNCTION: int XScreenCount ( Display* display ) ; -FUNCTION: int XConnectionNumber ( Display* display ) ; +X-FUNCTION: ulong XBlackPixel ( Display* display, int screen_number ) ; +X-FUNCTION: ulong XWhitePixel ( Display* display, int screen_number ) ; +X-FUNCTION: Colormap XDefaultColormap ( Display* display, int screen_number ) ; +X-FUNCTION: int XDefaultDepth ( Display* display, int screen_number ) ; +X-FUNCTION: GC XDefaultGC ( Display* display, int screen_number ) ; +X-FUNCTION: int XDefaultScreen ( Display* display ) ; +X-FUNCTION: Window XRootWindow ( Display* display, int screen_number ) ; +X-FUNCTION: Window XDefaultRootWindow ( Display* display ) ; +X-FUNCTION: int XProtocolVersion ( Display* display ) ; +X-FUNCTION: int XProtocolRevision ( Display* display ) ; +X-FUNCTION: int XQLength ( Display* display ) ; +X-FUNCTION: int XScreenCount ( Display* display ) ; +X-FUNCTION: int XConnectionNumber ( Display* display ) ; ! 2.5 Closing the Display -FUNCTION: int XCloseDisplay ( Display* display ) ; +X-FUNCTION: int XCloseDisplay ( Display* display ) ; ! ! 3 - Window Functions @@ -147,17 +147,17 @@ CONSTANT: StaticGravity 10 ! 3.3 - Creating Windows -FUNCTION: Window XCreateWindow ( Display* display, Window parent, int x, int y, uint width, uint height, uint border_width, int depth, uint class, Visual* visual, ulong valuemask, XSetWindowAttributes* attributes ) ; -FUNCTION: Window XCreateSimpleWindow ( Display* display, Window parent, int x, int y, uint width, uint height, uint border_width, ulong border, ulong background ) ; -FUNCTION: Status XDestroyWindow ( Display* display, Window w ) ; -FUNCTION: Status XMapWindow ( Display* display, Window window ) ; -FUNCTION: Status XMapSubwindows ( Display* display, Window window ) ; -FUNCTION: Status XUnmapWindow ( Display* display, Window w ) ; -FUNCTION: Status XUnmapSubwindows ( Display* display, Window w ) ; +X-FUNCTION: Window XCreateWindow ( Display* display, Window parent, int x, int y, uint width, uint height, uint border_width, int depth, uint class, Visual* visual, ulong valuemask, XSetWindowAttributes* attributes ) ; +X-FUNCTION: Window XCreateSimpleWindow ( Display* display, Window parent, int x, int y, uint width, uint height, uint border_width, ulong border, ulong background ) ; +X-FUNCTION: Status XDestroyWindow ( Display* display, Window w ) ; +X-FUNCTION: Status XMapWindow ( Display* display, Window window ) ; +X-FUNCTION: Status XMapSubwindows ( Display* display, Window window ) ; +X-FUNCTION: Status XUnmapWindow ( Display* display, Window w ) ; +X-FUNCTION: Status XUnmapSubwindows ( Display* display, Window w ) ; ! 3.5 Mapping Windows -FUNCTION: int XMapRaised ( Display* display, Window w ) ; +X-FUNCTION: int XMapRaised ( Display* display, Window w ) ; ! 3.7 - Configuring Windows @@ -178,25 +178,25 @@ C-STRUCT: XWindowChanges { "Window" "sibling" } { "int" "stack_mode" } ; -FUNCTION: Status XConfigureWindow ( Display* display, Window w, uint value_mask, XWindowChanges* values ) ; -FUNCTION: Status XMoveWindow ( Display* display, Window w, int x, int y ) ; -FUNCTION: Status XResizeWindow ( Display* display, Window w, uint width, uint height ) ; -FUNCTION: Status XSetWindowBorderWidth ( Display* display, ulong w, uint width ) ; +X-FUNCTION: Status XConfigureWindow ( Display* display, Window w, uint value_mask, XWindowChanges* values ) ; +X-FUNCTION: Status XMoveWindow ( Display* display, Window w, int x, int y ) ; +X-FUNCTION: Status XResizeWindow ( Display* display, Window w, uint width, uint height ) ; +X-FUNCTION: Status XSetWindowBorderWidth ( Display* display, ulong w, uint width ) ; ! 3.8 Changing Window Stacking Order -FUNCTION: Status XRaiseWindow ( Display* display, Window w ) ; -FUNCTION: Status XLowerWindow ( Display* display, Window w ) ; +X-FUNCTION: Status XRaiseWindow ( Display* display, Window w ) ; +X-FUNCTION: Status XLowerWindow ( Display* display, Window w ) ; ! 3.9 - Changing Window Attributes -FUNCTION: Status XChangeWindowAttributes ( +X-FUNCTION: Status XChangeWindowAttributes ( Display* display, Window w, ulong valuemask, XSetWindowAttributes* attr ) ; -FUNCTION: Status XSetWindowBackground ( +X-FUNCTION: Status XSetWindowBackground ( Display* display, Window w, ulong background_pixel ) ; -FUNCTION: Status XDefineCursor ( Display* display, Window w, Cursor cursor ) ; -FUNCTION: Status XUndefineCursor ( Display* display, Window w ) ; +X-FUNCTION: Status XDefineCursor ( Display* display, Window w, Cursor cursor ) ; +X-FUNCTION: Status XUndefineCursor ( Display* display, Window w ) ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! 4 - Window Information Functions @@ -204,7 +204,7 @@ FUNCTION: Status XUndefineCursor ( Display* display, Window w ) ; ! 4.1 - Obtaining Window Information -FUNCTION: Status XQueryTree ( +X-FUNCTION: Status XQueryTree ( Display* display, Window w, Window* root_return, @@ -236,13 +236,13 @@ C-STRUCT: XWindowAttributes { "Bool" "override_redirect" } { "Screen*" "screen" } ; -FUNCTION: Status XGetWindowAttributes ( Display* display, Window w, XWindowAttributes* attr ) ; +X-FUNCTION: Status XGetWindowAttributes ( Display* display, Window w, XWindowAttributes* attr ) ; CONSTANT: IsUnmapped 0 CONSTANT: IsUnviewable 1 CONSTANT: IsViewable 2 -FUNCTION: Status XGetGeometry ( +X-FUNCTION: Status XGetGeometry ( Display* display, Drawable d, Window* root_return, @@ -255,27 +255,27 @@ FUNCTION: Status XGetGeometry ( ! 4.2 - Translating Screen Coordinates -FUNCTION: Bool XQueryPointer ( Display* display, Window w, Window* root_return, Window* child_return, int* root_x_return, int* root_y_return, int* win_x_return, int* win_y_return, uint* mask_return ) ; +X-FUNCTION: Bool XQueryPointer ( Display* display, Window w, Window* root_return, Window* child_return, int* root_x_return, int* root_y_return, int* win_x_return, int* win_y_return, uint* mask_return ) ; ! 4.3 - Properties and Atoms -FUNCTION: Atom XInternAtom ( Display* display, char* atom_name, Bool only_if_exists ) ; +X-FUNCTION: Atom XInternAtom ( Display* display, char* atom_name, Bool only_if_exists ) ; -FUNCTION: char* XGetAtomName ( Display* display, Atom atom ) ; +X-FUNCTION: char* XGetAtomName ( Display* display, Atom atom ) ; ! 4.4 - Obtaining and Changing Window Properties -FUNCTION: int XGetWindowProperty ( Display* display, Window w, Atom property, long long_offset, long long_length, Bool delete, Atom req_type, Atom* actual_type_return, int* actual_format_return, ulong* nitems_return, ulong* bytes_after_return, char** prop_return ) ; +X-FUNCTION: int XGetWindowProperty ( Display* display, Window w, Atom property, long long_offset, long long_length, Bool delete, Atom req_type, Atom* actual_type_return, int* actual_format_return, ulong* nitems_return, ulong* bytes_after_return, char** prop_return ) ; -FUNCTION: int XChangeProperty ( Display* display, Window w, Atom property, Atom type, int format, int mode, void* data, int nelements ) ; +X-FUNCTION: int XChangeProperty ( Display* display, Window w, Atom property, Atom type, int format, int mode, void* data, int nelements ) ; ! 4.5 Selections -FUNCTION: int XSetSelectionOwner ( Display* display, Atom selection, Window owner, Time time ) ; +X-FUNCTION: int XSetSelectionOwner ( Display* display, Atom selection, Window owner, Time time ) ; -FUNCTION: Window XGetSelectionOwner ( Display* display, Atom selection ) ; +X-FUNCTION: Window XGetSelectionOwner ( Display* display, Atom selection ) ; -FUNCTION: int XConvertSelection ( Display* display, Atom selection, Atom target, Atom property, Window requestor, Time time ) ; +X-FUNCTION: int XConvertSelection ( Display* display, Atom selection, Atom target, Atom property, Window requestor, Time time ) ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! @@ -284,8 +284,8 @@ FUNCTION: int XConvertSelection ( Display* display, Atom selection, Atom target, ! 5.1 - Creating and Freeing Pixmaps -FUNCTION: Pixmap XCreatePixmap ( Display* display, Drawable d, uint width, uint height, uint depth ) ; -FUNCTION: int XFreePixmap ( Display* display, Pixmap pixmap ) ; +X-FUNCTION: Pixmap XCreatePixmap ( Display* display, Drawable d, uint width, uint height, uint depth ) ; +X-FUNCTION: int XFreePixmap ( Display* display, Pixmap pixmap ) ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! @@ -300,13 +300,13 @@ C-STRUCT: XColor { "char" "flags" } { "char" "pad" } ; -FUNCTION: Status XLookupColor ( Display* display, Colormap colormap, char* color_name, XColor* exact_def_return, XColor* screen_def_return ) ; -FUNCTION: Status XAllocColor ( Display* display, Colormap colormap, XColor* screen_in_out ) ; -FUNCTION: Status XQueryColor ( Display* display, Colormap colormap, XColor* def_in_out ) ; +X-FUNCTION: Status XLookupColor ( Display* display, Colormap colormap, char* color_name, XColor* exact_def_return, XColor* screen_def_return ) ; +X-FUNCTION: Status XAllocColor ( Display* display, Colormap colormap, XColor* screen_in_out ) ; +X-FUNCTION: Status XQueryColor ( Display* display, Colormap colormap, XColor* def_in_out ) ; ! 6.4 Creating, Copying, and Destroying Colormaps -FUNCTION: Colormap XCreateColormap ( Display* display, Window w, Visual* visual, int alloc ) ; +X-FUNCTION: Colormap XCreateColormap ( Display* display, Window w, Visual* visual, int alloc ) ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! 7 - Graphics Context Functions @@ -378,27 +378,27 @@ C-STRUCT: XGCValues { "int" "dash_offset" } { "char" "dashes" } ; -FUNCTION: GC XCreateGC ( Display* display, Window d, ulong valuemask, XGCValues* values ) ; -FUNCTION: int XChangeGC ( Display* display, GC gc, ulong valuemask, XGCValues* values ) ; -FUNCTION: Status XGetGCValues ( Display* display, GC gc, ulong valuemask, XGCValues* values_return ) ; -FUNCTION: Status XSetForeground ( Display* display, GC gc, ulong foreground ) ; -FUNCTION: Status XSetBackground ( Display* display, GC gc, ulong background ) ; -FUNCTION: Status XSetFunction ( Display* display, GC gc, int function ) ; -FUNCTION: Status XSetSubwindowMode ( Display* display, GC gc, int subwindow_mode ) ; +X-FUNCTION: GC XCreateGC ( Display* display, Window d, ulong valuemask, XGCValues* values ) ; +X-FUNCTION: int XChangeGC ( Display* display, GC gc, ulong valuemask, XGCValues* values ) ; +X-FUNCTION: Status XGetGCValues ( Display* display, GC gc, ulong valuemask, XGCValues* values_return ) ; +X-FUNCTION: Status XSetForeground ( Display* display, GC gc, ulong foreground ) ; +X-FUNCTION: Status XSetBackground ( Display* display, GC gc, ulong background ) ; +X-FUNCTION: Status XSetFunction ( Display* display, GC gc, int function ) ; +X-FUNCTION: Status XSetSubwindowMode ( Display* display, GC gc, int subwindow_mode ) ; -FUNCTION: GContext XGContextFromGC ( GC gc ) ; +X-FUNCTION: GContext XGContextFromGC ( GC gc ) ; -FUNCTION: Status XSetFont ( Display* display, GC gc, Font font ) ; +X-FUNCTION: Status XSetFont ( Display* display, GC gc, Font font ) ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! 8 - Graphics Functions ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -FUNCTION: Status XClearWindow ( Display* display, Window w ) ; -FUNCTION: Status XDrawPoint ( Display* display, Drawable d, GC gc, int x, int y ) ; -FUNCTION: Status XDrawLine ( Display* display, Drawable d, GC gc, int x1, int y1, int x2, int y2 ) ; -FUNCTION: Status XDrawArc ( Display* display, Drawable d, GC gc, int x, int y, uint width, uint height, int angle1, int angle2 ) ; -FUNCTION: Status XFillArc ( Display* display, Drawable d, GC gc, int x, int y, uint width, uint height, int angle1, int angle2 ) ; +X-FUNCTION: Status XClearWindow ( Display* display, Window w ) ; +X-FUNCTION: Status XDrawPoint ( Display* display, Drawable d, GC gc, int x, int y ) ; +X-FUNCTION: Status XDrawLine ( Display* display, Drawable d, GC gc, int x1, int y1, int x2, int y2 ) ; +X-FUNCTION: Status XDrawArc ( Display* display, Drawable d, GC gc, int x, int y, uint width, uint height, int angle1, int angle2 ) ; +X-FUNCTION: Status XFillArc ( Display* display, Drawable d, GC gc, int x, int y, uint width, uint height, int angle1, int angle2 ) ; ! 8.5 - Font Metrics @@ -410,9 +410,9 @@ C-STRUCT: XCharStruct { "short" "descent" } { "ushort" "attributes" } ; -FUNCTION: Font XLoadFont ( Display* display, char* name ) ; -FUNCTION: XFontStruct* XQueryFont ( Display* display, XID font_ID ) ; -FUNCTION: XFontStruct* XLoadQueryFont ( Display* display, char* name ) ; +X-FUNCTION: Font XLoadFont ( Display* display, char* name ) ; +X-FUNCTION: XFontStruct* XQueryFont ( Display* display, XID font_ID ) ; +X-FUNCTION: XFontStruct* XLoadQueryFont ( Display* display, char* name ) ; C-STRUCT: XFontStruct { "XExtData*" "ext_data" } @@ -432,11 +432,11 @@ C-STRUCT: XFontStruct { "int" "ascent" } { "int" "descent" } ; -FUNCTION: int XTextWidth ( XFontStruct* font_struct, char* string, int count ) ; +X-FUNCTION: int XTextWidth ( XFontStruct* font_struct, char* string, int count ) ; ! 8.6 - Drawing Text -FUNCTION: Status XDrawString ( +X-FUNCTION: Status XDrawString ( Display* display, Drawable d, GC gc, @@ -479,8 +479,8 @@ C-STRUCT: XImage { "XPointer" "obdata" } { "XImage-funcs" "f" } ; -FUNCTION: XImage* XGetImage ( Display* display, Drawable d, int x, int y, uint width, uint height, ulong plane_mask, int format ) ; -FUNCTION: int XDestroyImage ( XImage *ximage ) ; +X-FUNCTION: XImage* XGetImage ( Display* display, Drawable d, int x, int y, uint width, uint height, ulong plane_mask, int format ) ; +X-FUNCTION: int XDestroyImage ( XImage *ximage ) ; : XImage-size ( ximage -- size ) [ XImage-height ] [ XImage-bytes_per_line ] bi * ; @@ -492,12 +492,12 @@ FUNCTION: int XDestroyImage ( XImage *ximage ) ; ! 9 - Window and Session Manager Functions ! -FUNCTION: Status XReparentWindow ( Display* display, Window w, Window parent, int x, int y ) ; -FUNCTION: Status XAddToSaveSet ( Display* display, Window w ) ; -FUNCTION: Status XRemoveFromSaveSet ( Display* display, Window w ) ; -FUNCTION: Status XGrabServer ( Display* display ) ; -FUNCTION: Status XUngrabServer ( Display* display ) ; -FUNCTION: Status XKillClient ( Display* display, XID resource ) ; +X-FUNCTION: Status XReparentWindow ( Display* display, Window w, Window parent, int x, int y ) ; +X-FUNCTION: Status XAddToSaveSet ( Display* display, Window w ) ; +X-FUNCTION: Status XRemoveFromSaveSet ( Display* display, Window w ) ; +X-FUNCTION: Status XGrabServer ( Display* display ) ; +X-FUNCTION: Status XUngrabServer ( Display* display ) ; +X-FUNCTION: Status XKillClient ( Display* display, XID resource ) ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! 10 - Events @@ -1066,11 +1066,11 @@ C-UNION: XEvent ! 11 - Event Handling Functions ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -FUNCTION: Status XSelectInput ( Display* display, Window w, long event_mask ) ; -FUNCTION: Status XFlush ( Display* display ) ; -FUNCTION: Status XSync ( Display* display, int discard ) ; -FUNCTION: Status XNextEvent ( Display* display, XEvent* event ) ; -FUNCTION: Status XMaskEvent ( Display* display, long event_mask, XEvent* event_return ) ; +X-FUNCTION: Status XSelectInput ( Display* display, Window w, long event_mask ) ; +X-FUNCTION: Status XFlush ( Display* display ) ; +X-FUNCTION: Status XSync ( Display* display, int discard ) ; +X-FUNCTION: Status XNextEvent ( Display* display, XEvent* event ) ; +X-FUNCTION: Status XMaskEvent ( Display* display, long event_mask, XEvent* event_return ) ; ! 11.3 - Event Queue Management @@ -1078,16 +1078,16 @@ CONSTANT: QueuedAlready 0 CONSTANT: QueuedAfterReading 1 CONSTANT: QueuedAfterFlush 2 -FUNCTION: int XEventsQueued ( Display* display, int mode ) ; -FUNCTION: int XPending ( Display* display ) ; +X-FUNCTION: int XEventsQueued ( Display* display, int mode ) ; +X-FUNCTION: int XPending ( Display* display ) ; ! 11.6 - Sending Events to Other Applications -FUNCTION: Status XSendEvent ( Display* display, Window w, Bool propagate, long event_mask, XEvent* event_send ) ; +X-FUNCTION: Status XSendEvent ( Display* display, Window w, Bool propagate, long event_mask, XEvent* event_send ) ; ! 11.8 - Handling Protocol Errors -FUNCTION: int XSetErrorHandler ( void* handler ) ; +X-FUNCTION: int XSetErrorHandler ( void* handler ) ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! 12 - Input Device Functions @@ -1095,7 +1095,7 @@ FUNCTION: int XSetErrorHandler ( void* handler ) ; CONSTANT: None 0 -FUNCTION: int XGrabPointer ( +X-FUNCTION: int XGrabPointer ( Display* display, Window grab_window, Bool owner_events, @@ -1106,16 +1106,16 @@ FUNCTION: int XGrabPointer ( Cursor cursor, Time time ) ; -FUNCTION: Status XUngrabPointer ( Display* display, Time time ) ; -FUNCTION: Status XChangeActivePointerGrab ( Display* display, uint event_mask, Cursor cursor, Time time ) ; -FUNCTION: Status XGrabKey ( Display* display, int keycode, uint modifiers, Window grab_window, Bool owner_events, int pointer_mode, int keyboard_mode ) ; -FUNCTION: Status XSetInputFocus ( Display* display, Window focus, int revert_to, Time time ) ; +X-FUNCTION: Status XUngrabPointer ( Display* display, Time time ) ; +X-FUNCTION: Status XChangeActivePointerGrab ( Display* display, uint event_mask, Cursor cursor, Time time ) ; +X-FUNCTION: Status XGrabKey ( Display* display, int keycode, uint modifiers, Window grab_window, Bool owner_events, int pointer_mode, int keyboard_mode ) ; +X-FUNCTION: Status XSetInputFocus ( Display* display, Window focus, int revert_to, Time time ) ; -FUNCTION: Status XGetInputFocus ( Display* display, +X-FUNCTION: Status XGetInputFocus ( Display* display, Window* focus_return, int* revert_to_return ) ; -FUNCTION: Status XWarpPointer ( Display* display, Window src_w, Window dest_w, int src_x, int src_y, uint src_width, uint src_height, int dest_x, int dest_y ) ; +X-FUNCTION: Status XWarpPointer ( Display* display, Window src_w, Window dest_w, int src_x, int src_y, uint src_width, uint src_height, int dest_x, int dest_y ) ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! 14 - Inter-Client Communication Functions @@ -1123,15 +1123,15 @@ FUNCTION: Status XWarpPointer ( Display* display, Window src_w, Window dest_w, i ! 14.1 Client to Window Manager Communication -FUNCTION: Status XFetchName ( Display* display, Window w, char** window_name_return ) ; -FUNCTION: Status XGetTransientForHint ( Display* display, Window w, Window* prop_window_return ) ; +X-FUNCTION: Status XFetchName ( Display* display, Window w, char** window_name_return ) ; +X-FUNCTION: Status XGetTransientForHint ( Display* display, Window w, Window* prop_window_return ) ; ! 14.1.1. Manipulating Top-Level Windows -FUNCTION: Status XIconifyWindow ( +X-FUNCTION: Status XIconifyWindow ( Display* display, Window w, int screen_number ) ; -FUNCTION: Status XWithdrawWindow ( +X-FUNCTION: Status XWithdrawWindow ( Display* display, Window w, int screen_number ) ; ! 14.1.6 - Setting and Reading the WM_HINTS Property @@ -1173,10 +1173,10 @@ C-STRUCT: XSizeHints ! 14.1.10. Setting and Reading the WM_PROTOCOLS Property -FUNCTION: Status XSetWMProtocols ( +X-FUNCTION: Status XSetWMProtocols ( Display* display, Window w, Atom* protocols, int count ) ; -FUNCTION: Status XGetWMProtocols ( +X-FUNCTION: Status XGetWMProtocols ( Display* display, Window w, Atom** protocols_return, @@ -1188,9 +1188,9 @@ FUNCTION: Status XGetWMProtocols ( ! 16.1 Keyboard Utility Functions -FUNCTION: KeySym XLookupKeysym ( XKeyEvent* key_event, int index ) ; +X-FUNCTION: KeySym XLookupKeysym ( XKeyEvent* key_event, int index ) ; -FUNCTION: int XLookupString ( +X-FUNCTION: int XLookupString ( XKeyEvent* event_struct, void* buffer_return, int bytes_buffer, @@ -1227,7 +1227,7 @@ C-STRUCT: XVisualInfo ! Appendix D - Compatibility Functions ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -FUNCTION: Status XSetStandardProperties ( +X-FUNCTION: Status XSetStandardProperties ( Display* display, Window w, char* window_name, @@ -1314,10 +1314,10 @@ CONSTANT: XA_LAST_PREDEFINED 68 ! The rest of the stuff is not from the book. ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -FUNCTION: void XFree ( void* data ) ; -FUNCTION: int XStoreName ( Display* display, Window w, char* window_name ) ; -FUNCTION: void XSetWMNormalHints ( Display* display, Window w, XSizeHints* hints ) ; -FUNCTION: int XBell ( Display* display, int percent ) ; +X-FUNCTION: void XFree ( void* data ) ; +X-FUNCTION: int XStoreName ( Display* display, Window w, char* window_name ) ; +X-FUNCTION: void XSetWMNormalHints ( Display* display, Window w, XSizeHints* hints ) ; +X-FUNCTION: int XBell ( Display* display, int percent ) ; ! !!! INPUT METHODS @@ -1381,23 +1381,23 @@ CONSTANT: XLookupChars 2 CONSTANT: XLookupKeySym 3 CONSTANT: XLookupBoth 4 -FUNCTION: Bool XFilterEvent ( XEvent* event, Window w ) ; +X-FUNCTION: Bool XFilterEvent ( XEvent* event, Window w ) ; -FUNCTION: XIM XOpenIM ( Display* dpy, void* rdb, char* res_name, char* res_class ) ; +X-FUNCTION: XIM XOpenIM ( Display* dpy, void* rdb, char* res_name, char* res_class ) ; -FUNCTION: Status XCloseIM ( XIM im ) ; +X-FUNCTION: Status XCloseIM ( XIM im ) ; -FUNCTION: XIC XCreateIC ( XIM im, char* key1, Window value1, char* key2, Window value2, char* key3, int value3, char* key4, char* value4, char* key5, char* value5, int key6 ) ; +X-FUNCTION: XIC XCreateIC ( XIM im, char* key1, Window value1, char* key2, Window value2, char* key3, int value3, char* key4, char* value4, char* key5, char* value5, int key6 ) ; -FUNCTION: void XDestroyIC ( XIC ic ) ; +X-FUNCTION: void XDestroyIC ( XIC ic ) ; -FUNCTION: void XSetICFocus ( XIC ic ) ; +X-FUNCTION: void XSetICFocus ( XIC ic ) ; -FUNCTION: void XUnsetICFocus ( XIC ic ) ; +X-FUNCTION: void XUnsetICFocus ( XIC ic ) ; -FUNCTION: int XwcLookupString ( XIC ic, XKeyPressedEvent* event, ulong* buffer_return, int bytes_buffer, KeySym* keysym_return, Status* status_return ) ; +X-FUNCTION: int XwcLookupString ( XIC ic, XKeyPressedEvent* event, ulong* buffer_return, int bytes_buffer, KeySym* keysym_return, Status* status_return ) ; -FUNCTION: int Xutf8LookupString ( XIC ic, XKeyPressedEvent* event, char* buffer_return, int bytes_buffer, KeySym* keysym_return, Status* status_return ) ; +X-FUNCTION: int Xutf8LookupString ( XIC ic, XKeyPressedEvent* event, char* buffer_return, int bytes_buffer, KeySym* keysym_return, Status* status_return ) ; ! !!! category of setlocale CONSTANT: LC_ALL 0 @@ -1407,37 +1407,8 @@ CONSTANT: LC_MONETARY 3 CONSTANT: LC_NUMERIC 4 CONSTANT: LC_TIME 5 -FUNCTION: char* setlocale ( int category, char* name ) ; +X-FUNCTION: char* setlocale ( int category, char* name ) ; -FUNCTION: Bool XSupportsLocale ( ) ; +X-FUNCTION: Bool XSupportsLocale ( ) ; -FUNCTION: char* XSetLocaleModifiers ( char* modifier_list ) ; - -SYMBOL: dpy -SYMBOL: scr -SYMBOL: root - -: init-locale ( -- ) - LC_ALL "" setlocale [ "setlocale() failed" print flush ] unless - XSupportsLocale [ "XSupportsLocale() failed" print flush ] unless ; - -: flush-dpy ( -- ) dpy get XFlush drop ; - -: x-atom ( string -- atom ) dpy get swap 0 XInternAtom ; - -: check-display ( alien -- alien' ) - [ - "Cannot connect to X server - check $DISPLAY" throw - ] unless* ; - -: initialize-x ( display-string -- ) - init-locale - dup [ ascii string>alien ] when - XOpenDisplay check-display dpy set-global - dpy get XDefaultScreen scr set-global - dpy get scr get XRootWindow root set-global ; - -: close-x ( -- ) dpy get XCloseDisplay drop ; - -: with-x ( display-string quot -- ) - [ initialize-x ] dip [ close-x ] [ ] cleanup ; inline +X-FUNCTION: char* XSetLocaleModifiers ( char* modifier_list ) ; diff --git a/core/classes/classes-tests.factor b/core/classes/classes-tests.factor index f5ea84afa5..08746d1ba7 100644 --- a/core/classes/classes-tests.factor +++ b/core/classes/classes-tests.factor @@ -29,10 +29,10 @@ M: method-forget-class method-forget-test ; ] 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 diff --git a/core/classes/mixin/mixin-tests.factor b/core/classes/mixin/mixin-tests.factor index 1beafd003a..cd11591d6c 100644 --- a/core/classes/mixin/mixin-tests.factor +++ b/core/classes/mixin/mixin-tests.factor @@ -42,7 +42,7 @@ INSTANCE: integer mx1 [ 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 diff --git a/core/classes/tuple/parser/parser-tests.factor b/core/classes/tuple/parser/parser-tests.factor index 9d0c268add..b95507c78b 100644 --- a/core/classes/tuple/parser/parser-tests.factor +++ b/core/classes/tuple/parser/parser-tests.factor @@ -50,20 +50,20 @@ TUPLE: test-8 { b integer read-only } ; 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 @@ -71,14 +71,14 @@ 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 @@ -107,7 +107,7 @@ TUPLE: parsing-corner-case x ; " f" " 3" "}" - } "\n" join (( -- tuple )) eval + } "\n" join eval( -- tuple ) ] unit-test [ T{ parsing-corner-case f 3 } ] [ @@ -116,7 +116,7 @@ TUPLE: parsing-corner-case x ; "T{ parsing-corner-case" " { x 3 }" "}" - } "\n" join (( -- tuple )) eval + } "\n" join eval( -- tuple ) ] unit-test [ T{ parsing-corner-case f 3 } ] [ @@ -125,7 +125,7 @@ TUPLE: parsing-corner-case x ; "T{ parsing-corner-case {" " x 3 }" "}" - } "\n" join (( -- tuple )) eval + } "\n" join eval( -- tuple ) ] unit-test @@ -133,12 +133,12 @@ TUPLE: parsing-corner-case x ; { "USE: classes.tuple.parser.tests T{ parsing-corner-case" " { x 3 }" - } "\n" join (( -- tuple )) eval + } "\n" join eval( -- tuple ) ] [ error>> unexpected-eof? ] must-fail-with [ { "USE: classes.tuple.parser.tests T{ parsing-corner-case {" " x 3 }" - } "\n" join (( -- tuple )) eval + } "\n" join eval( -- tuple ) ] [ error>> unexpected-eof? ] must-fail-with diff --git a/core/classes/tuple/tuple-tests.factor b/core/classes/tuple/tuple-tests.factor index 451420268d..68cdc20c53 100644 --- a/core/classes/tuple/tuple-tests.factor +++ b/core/classes/tuple/tuple-tests.factor @@ -27,7 +27,7 @@ C: redefinition-test [ t ] [ "redefinition-test" get redefinition-test? ] unit-test -"IN: classes.tuple.tests TUPLE: redefinition-test ;" (( -- )) eval +"IN: classes.tuple.tests TUPLE: redefinition-test ;" eval( -- ) [ t ] [ "redefinition-test" get redefinition-test? ] unit-test @@ -39,7 +39,7 @@ C: point [ ] [ 100 200 "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 @@ -51,7 +51,7 @@ C: point [ 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 @@ -89,7 +89,7 @@ C: empty [ t length ] [ object>> t eq? ] must-fail-with [ "" ] -[ "IN: classes.tuple.test TUPLE: constructor-test ; C: constructor-test" (( -- )) eval word name>> ] unit-test +[ "IN: classes.tuple.test TUPLE: constructor-test ; C: constructor-test" eval( -- ) word name>> ] unit-test TUPLE: size-test a b c d ; @@ -102,7 +102,7 @@ GENERIC: ( a -- b ) TUPLE: yo-momma ; -[ ] [ "IN: classes.tuple.tests C: yo-momma" (( -- )) eval ] unit-test +[ ] [ "IN: classes.tuple.tests C: yo-momma" eval( -- ) ] unit-test [ f ] [ \ generic? ] unit-test @@ -204,7 +204,7 @@ C: erg's-reshape-problem : 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 @@ -281,13 +281,13 @@ test-server-slot-values ] 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 @@ -303,17 +303,17 @@ TUPLE: electronic-device ; [ 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 @@ -326,7 +326,7 @@ TUPLE: make-me-some-accessors voltage grounded? ; [ ] [ "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 @@ -334,7 +334,7 @@ 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 @@ -343,7 +343,7 @@ 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 @@ -364,11 +364,11 @@ C: test2 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 @@ -393,19 +393,19 @@ T{ move-up-2 f "a" "b" "c" } "move-up" set 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 ; @@ -416,7 +416,7 @@ C: constructor-update-2 { 3 1 } [ ] 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 } [ ] must-infer-as @@ -431,7 +431,7 @@ UNION: redefinition-problem' redefinition-problem integer ; 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 @@ -472,7 +472,7 @@ USE: vocabs ] 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 @@ -520,13 +520,13 @@ TUPLE: another-forget-accessors-test ; [ 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 ; @@ -535,7 +535,7 @@ TUPLE: subclass-forget-test-1 < 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 ] @@ -549,7 +549,7 @@ unit-test [ 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 @@ -562,11 +562,11 @@ GENERIC: break-me ( obj -- ) [ ] [ [ M\ integer break-me forget ] with-compilation-unit ] unit-test [ ] [ "IN: classes.tuple.tests TUPLE: subclass-reset-test ;" "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 ( -- ) ;" "subclass-reset-test" parse-stream drop ] unit-test @@ -576,7 +576,7 @@ GENERIC: break-me ( obj -- ) [ t ] [ \ break-me "methods" word-prop assoc-empty? ] unit-test -[ ] [ "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 @@ -632,7 +632,7 @@ TUPLE: reshape-test x ; 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 @@ -640,11 +640,11 @@ T{ reshape-test f "hi" } "tuple" set [ "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 @@ -660,20 +660,20 @@ ERROR: error-class-test a b c ; [ "( 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 @@ -694,7 +694,7 @@ DEFER: error-y ] 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 ; @@ -735,14 +735,14 @@ SLOT: kex 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 diff --git a/core/classes/union/union-tests.factor b/core/classes/union/union-tests.factor index 47f726c03b..52550b2356 100644 --- a/core/classes/union/union-tests.factor +++ b/core/classes/union/union-tests.factor @@ -26,13 +26,13 @@ M: union-1 generic-update-test drop "union-1" ; [ 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 @@ -58,7 +58,7 @@ UNION: redefine-bug-2 redefine-bug-1 quotation ; [ 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 diff --git a/core/compiler/units/units-tests.factor b/core/compiler/units/units-tests.factor index d3a390dc56..03c68815cc 100644 --- a/core/compiler/units/units-tests.factor +++ b/core/compiler/units/units-tests.factor @@ -56,6 +56,6 @@ observer add-definition-observer 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 diff --git a/core/generic/generic-tests.factor b/core/generic/generic-tests.factor index d0a7b28bc6..37f5cf40ae 100755 --- a/core/generic/generic-tests.factor +++ b/core/generic/generic-tests.factor @@ -65,11 +65,11 @@ M: number union-containment drop 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 ; @@ -177,7 +177,7 @@ M: f generic-forget-test-3 ; [ ] [ [ "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 @@ -193,7 +193,7 @@ M: integer a-generic a-word ; [ 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 @@ -207,18 +207,18 @@ M: integer a-generic a-word ; 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 diff --git a/core/parser/parser-tests.factor b/core/parser/parser-tests.factor index 491bc1884a..2add8663d8 100644 --- a/core/parser/parser-tests.factor +++ b/core/parser/parser-tests.factor @@ -10,43 +10,43 @@ IN: parser.tests [ [ 1 [ 2 [ 3 ] 4 ] 5 ] - [ "1\n[\n2\n[\n3\n]\n4\n]\n5" (( -- a b c )) 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\"" (( -- string )) eval ] + [ "\"hello world\"" eval( -- string ) ] unit-test [ "\n\r\t\\" ] - [ "\"\\n\\r\\t\\\\\"" (( -- string )) eval ] + [ "\"\\n\\r\\t\\\\\"" eval( -- string ) ] unit-test [ "hello world" ] [ "IN: parser.tests : hello ( -- str ) \"hello world\" ;" - (( -- )) eval "USE: parser.tests hello" (( -- string )) 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\"" (( -- string )) eval ] + [ "\"\\u000020\"" eval( -- string ) ] unit-test [ "'" ] - [ "\"\\u000027\"" (( -- string )) eval ] + [ "\"\\u000027\"" eval( -- string ) ] unit-test ! Test EOL comments in multiline strings. - [ "Hello" ] [ "#! This calls until-eol.\n\"Hello\"" (( -- string )) eval ] unit-test + [ "Hello" ] [ "#! This calls until-eol.\n\"Hello\"" eval( -- string ) ] unit-test [ word ] [ \ f class ] unit-test @@ -68,7 +68,7 @@ IN: parser.tests [ \ 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 @@ -79,14 +79,14 @@ IN: parser.tests [ \ effect-parsing-test "declared-effect" word-prop ] unit-test ! Funny bug - [ 2 ] [ "IN: parser.tests : \0. ( -- x ) 2 ; \0." (( -- n )) 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" (( -- obj )) eval ] must-fail - [ "OCT: 999" (( -- obj )) eval ] must-fail - [ "BIN: --0" (( -- obj )) 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 ] [ @@ -102,14 +102,14 @@ IN: parser.tests ] 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" (( -- word )) eval + "USE: parser.tests \\ foo" eval( -- word ) "foo" "parser.tests" lookup eq? ] unit-test @@ -339,16 +339,16 @@ IN: parser.tests ] [ 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 ] [ @@ -422,13 +422,13 @@ IN: parser.tests ] 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: \\" (( -- n )) eval ] unit-test -[ 92 ] [ "CHAR: \\\\" (( -- n )) eval ] unit-test +[ 92 ] [ "CHAR: \\" eval( -- n ) ] unit-test +[ 92 ] [ "CHAR: \\\\" eval( -- n ) ] unit-test [ ] [ { @@ -480,10 +480,10 @@ IN: parser.tests [ 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 @@ -491,12 +491,12 @@ IN: parser.tests ! 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" (( -- n )) eval ] must-fail +[ "CHAR: \\u9999999999999" eval( -- n ) ] must-fail SYMBOLS: a b c ; @@ -506,15 +506,15 @@ 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 @@ -545,10 +545,10 @@ EXCLUDE: qualified.tests.bar => x ; [ 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 diff --git a/core/parser/parser.factor b/core/parser/parser.factor index 38cb4869ab..9876818d26 100644 --- a/core/parser/parser.factor +++ b/core/parser/parser.factor @@ -180,6 +180,7 @@ SYMBOL: interactive-vocabs "math.order" "memory" "namespaces" + "parser" "prettyprint" "see" "sequences" @@ -191,6 +192,7 @@ SYMBOL: interactive-vocabs "tools.annotations" "tools.crossref" "tools.disassembler" + "tools.errors" "tools.memory" "tools.profiler" "tools.test" diff --git a/core/slots/slots-tests.factor b/core/slots/slots-tests.factor index d76f1ffb07..7ac8446842 100644 --- a/core/slots/slots-tests.factor +++ b/core/slots/slots-tests.factor @@ -25,12 +25,12 @@ TUPLE: hello length ; [ 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 diff --git a/core/slots/slots.factor b/core/slots/slots.factor index a353f50947..63c0319c1c 100755 --- a/core/slots/slots.factor +++ b/core/slots/slots.factor @@ -222,7 +222,7 @@ M: slot-spec make-slot [ 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 ; diff --git a/core/source-files/errors/errors.factor b/core/source-files/errors/errors.factor index e179c99913..f6f4f4825a 100644 --- a/core/source-files/errors/errors.factor +++ b/core/source-files/errors/errors.factor @@ -12,7 +12,7 @@ TUPLE: source-file-error error asset file line# ; : 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 ) @@ -34,12 +34,12 @@ error-types [ V{ } clone ] initialize 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 ] diff --git a/core/vocabs/loader/loader-tests.factor b/core/vocabs/loader/loader-tests.factor index b43ab08c2c..f7c8a89e8c 100644 --- a/core/vocabs/loader/loader-tests.factor +++ b/core/vocabs/loader/loader-tests.factor @@ -143,7 +143,7 @@ IN: vocabs.loader.tests forget-junk [ { } ] [ - "IN: xabbabbja" (( -- )) eval "xabbabbja" vocab-files + "IN: xabbabbja" eval( -- ) "xabbabbja" vocab-files ] unit-test [ "xabbabbja" forget-vocab ] with-compilation-unit diff --git a/core/words/alias/alias-tests.factor b/core/words/alias/alias-tests.factor index e0bfba5cc1..c4bc8519a9 100644 --- a/core/words/alias/alias-tests.factor +++ b/core/words/alias/alias-tests.factor @@ -2,5 +2,5 @@ USING: math eval tools.test effects ; IN: words.alias.tests ALIAS: foo + -[ ] [ "IN: words.alias.tests CONSTANT: foo 5" (( -- )) eval ] unit-test +[ ] [ "IN: words.alias.tests CONSTANT: foo 5" eval( -- ) ] unit-test [ (( -- value )) ] [ \ foo stack-effect ] unit-test diff --git a/core/words/words-tests.factor b/core/words/words-tests.factor index 7eb1025039..3ba5e1f693 100755 --- a/core/words/words-tests.factor +++ b/core/words/words-tests.factor @@ -51,7 +51,7 @@ SYMBOL: a-symbol ! 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 @@ -116,10 +116,10 @@ DEFER: x [ ] [ "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 @@ -146,15 +146,15 @@ SYMBOL: quot-uses-b [ 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 @@ -174,14 +174,14 @@ SYMBOL: quot-uses-b [ 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 [ { } ] diff --git a/extra/4DNav/file-chooser/file-chooser.factor b/extra/4DNav/file-chooser/file-chooser.factor index 033ae755cb..51bebc3877 100755 --- a/extra/4DNav/file-chooser/file-chooser.factor +++ b/extra/4DNav/file-chooser/file-chooser.factor @@ -92,11 +92,9 @@ file-chooser H{ ; : fc-load-file ( file-chooser file -- ) - dupd [ selected-file>> ] [ name>> ] bi* swap set-model - [ path>> value>> ] - [ selected-file>> value>> append ] - [ hook>> ] tri - call + over [ name>> ] [ selected-file>> ] bi* set-model + [ [ path>> value>> ] [ selected-file>> value>> ] bi append ] [ hook>> ] bi + call( path -- ) ; inline ! : fc-ok-action ( file-chooser -- quot ) @@ -111,7 +109,7 @@ file-chooser H{ : line-selected-action ( file-chooser -- ) dup list>> list-value dup directory? - [ fc-change-directory ] [ fc-load-file ] if ; inline + [ fc-change-directory ] [ fc-load-file ] if ; : present-dir-element ( element -- string ) [ name>> ] [ directory? ] bi [ "-> " prepend ] when ; diff --git a/extra/bank/bank.factor b/extra/bank/bank.factor index f06bc2fb81..31a4b75eb2 100644 --- a/extra/bank/bank.factor +++ b/extra/bank/bank.factor @@ -54,7 +54,7 @@ C: transaction : 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 ] [ @@ -63,7 +63,7 @@ C: transaction : 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 ; diff --git a/extra/benchmark/base64/base64.factor b/extra/benchmark/base64/base64.factor index f6e5f7ca39..350a29f865 100644 --- a/extra/benchmark/base64/base64.factor +++ b/extra/benchmark/base64/base64.factor @@ -5,7 +5,7 @@ IN: benchmark.base64 : base64-benchmark ( -- ) 65535 [ 255 bitand ] "" map-as - 100 [ >base64 base64> ] times + 20 [ >base64 base64> ] times drop ; MAIN: base64-benchmark diff --git a/extra/benchmark/benchmark.factor b/extra/benchmark/benchmark.factor index 489dc5e73f..ca48e6208c 100755 --- a/extra/benchmark/benchmark.factor +++ b/extra/benchmark/benchmark.factor @@ -1,21 +1,35 @@ -! Copyright (C) 2007, 2008 Slava Pestov. +! Copyright (C) 2007, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. 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 ) + + +: 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 @@ -24,13 +38,21 @@ IN: benchmark [ [ [ [ 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 diff --git a/extra/benchmark/beust1/beust1.factor b/extra/benchmark/beust1/beust1.factor index 9849ac2dbe..d94c1d1335 100644 --- a/extra/benchmark/beust1/beust1.factor +++ b/extra/benchmark/beust1/beust1.factor @@ -8,7 +8,7 @@ IN: benchmark.beust1 1 [a,b] [ number>string all-unique? ] count ; inline : beust ( -- ) - 10000000 count-numbers + 2000000 count-numbers number>string " unique numbers." append print ; MAIN: beust diff --git a/extra/benchmark/beust2/beust2.factor b/extra/benchmark/beust2/beust2.factor index f96dc77961..d269ef3503 100755 --- a/extra/benchmark/beust2/beust2.factor +++ b/extra/benchmark/beust2/beust2.factor @@ -34,7 +34,7 @@ IN: benchmark.beust2 :: beust ( -- ) [let | i! [ 0 ] | - 10000000000 [ i 1+ i! ] count-numbers + 5000000000 [ i 1+ i! ] count-numbers i number>string " unique numbers." append print ] ; diff --git a/extra/benchmark/fib6/fib6.factor b/extra/benchmark/fib6/fib6.factor index 64d1b6c533..f81b6a21a2 100755 --- a/extra/benchmark/fib6/fib6.factor +++ b/extra/benchmark/fib6/fib6.factor @@ -9,6 +9,6 @@ USING: math kernel alien ; ] alien-callback "int" { "int" } "cdecl" alien-indirect ; -: fib-main ( -- ) 34 fib drop ; +: fib-main ( -- ) 32 fib drop ; MAIN: fib-main diff --git a/extra/benchmark/md5/md5.factor b/extra/benchmark/md5/md5.factor index 5030cb6904..de60049c84 100644 --- a/extra/benchmark/md5/md5.factor +++ b/extra/benchmark/md5/md5.factor @@ -1,7 +1,7 @@ -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 diff --git a/extra/benchmark/random/random.factor b/extra/benchmark/random/random.factor index d2eb4cdab5..4eab7c1669 100755 --- a/extra/benchmark/random/random.factor +++ b/extra/benchmark/random/random.factor @@ -11,6 +11,6 @@ IN: benchmark.random ] with-file-writer ; : random-main ( -- ) - 1000000 write-random-numbers ; + 300000 write-random-numbers ; MAIN: random-main diff --git a/extra/benchmark/sha1/sha1.factor b/extra/benchmark/sha1/sha1.factor index 8e19ba9a8f..c1a7af2966 100644 --- a/extra/benchmark/sha1/sha1.factor +++ b/extra/benchmark/sha1/sha1.factor @@ -1,7 +1,7 @@ -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 diff --git a/extra/benchmark/sum-file/sum-file.factor b/extra/benchmark/sum-file/sum-file.factor index bb7aebba62..b1f27830ee 100644 --- a/extra/benchmark/sum-file/sum-file.factor +++ b/extra/benchmark/sum-file/sum-file.factor @@ -9,6 +9,6 @@ IN: benchmark.sum-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 diff --git a/unmaintained/morse/authors.txt b/extra/couchdb/authors.txt similarity index 100% rename from unmaintained/morse/authors.txt rename to extra/couchdb/authors.txt diff --git a/extra/couchdb/couchdb-tests.factor b/extra/couchdb/couchdb-tests.factor new file mode 100644 index 0000000000..d7161a14cd --- /dev/null +++ b/extra/couchdb/couchdb-tests.factor @@ -0,0 +1,46 @@ +! Copyright (C) 2008 Alex Chapman +! See http://factorcode.org/license.txt for BSD license. +USING: accessors assocs couchdb kernel namespaces sequences strings tools.test ; +IN: couchdb.tests + +! You must have a CouchDB server (currently only the version from svn will +! work) running on localhost and listening on the default port for these tests +! to work. + + "factor-test" [ + [ ] [ couch get create-db ] unit-test + [ couch get create-db ] must-fail + [ ] [ couch get delete-db ] unit-test + [ couch get delete-db ] must-fail + [ ] [ couch get ensure-db ] unit-test + [ ] [ couch get ensure-db ] unit-test + [ 0 ] [ couch get db-info "doc_count" swap at ] unit-test + [ ] [ couch get compact-db ] unit-test + [ t ] [ couch get server>> next-uuid string? ] unit-test + [ ] [ H{ + { "Subject" "I like Planktion" } + { "Tags" { "plankton" "baseball" "decisions" } } + { "Body" + "I decided today that I don't like baseball. I like plankton." } + { "Author" "Rusty" } + { "PostedDate" "2006-08-15T17:30:12Z-04:00" } + } save-doc ] unit-test + [ t ] [ couch get all-docs "rows" swap at first "id" swap at dup "id" set string? ] unit-test + [ t ] [ "id" get dup load-doc id> = ] unit-test + [ ] [ "id" get load-doc save-doc ] unit-test + [ "Rusty" ] [ "id" get load-doc "Author" swap at ] unit-test + [ ] [ "id" get load-doc "Alex" "Author" pick set-at save-doc ] unit-test + [ "Alex" ] [ "id" get load-doc "Author" swap at ] unit-test + [ 1 ] [ "function(doc) { emit(null, doc) }" temp-view-map "total_rows" swap at ] unit-test + [ ] [ H{ + { "_id" "_design/posts" } + { "language" "javascript" } + { "views" H{ + { "all" H{ { "map" "function(doc) { emit(null, doc) }" } } } + } + } + } save-doc ] unit-test + [ t ] [ "id" get load-doc delete-doc string? ] unit-test + [ "id" get load-doc ] must-fail + [ ] [ couch get delete-db ] unit-test +] with-couch diff --git a/extra/couchdb/couchdb.factor b/extra/couchdb/couchdb.factor new file mode 100644 index 0000000000..da71acb074 --- /dev/null +++ b/extra/couchdb/couchdb.factor @@ -0,0 +1,200 @@ +! Copyright (C) 2008, 2009 Alex Chapman +! See http://factorcode.org/license.txt for BSD license. +USING: accessors arrays assocs continuations debugger hashtables http +http.client io io.encodings.string io.encodings.utf8 json.reader +json.writer kernel make math math.parser namespaces sequences strings +urls urls.encoding vectors ; +IN: couchdb + +! NOTE: This code only works with the latest couchdb (0.9.*), because old +! versions didn't provide the /_uuids feature which this code relies on when +! creating new documents. + +SYMBOL: couch +: with-couch ( db quot -- ) + couch swap with-variable ; inline + +! errors +TUPLE: couchdb-error { data assoc } ; +C: couchdb-error + +M: couchdb-error error. ( error -- ) + "CouchDB Error: " write data>> + "error" over at [ print ] when* + "reason" swap at [ print ] when* ; + +PREDICATE: file-exists-error < couchdb-error + data>> "error" swap at "file_exists" = ; + +! http tools +: couch-http-request ( request -- data ) + [ http-request ] [ + dup download-failed? [ + response>> body>> json> throw + ] [ + rethrow + ] if + ] recover nip ; + +: couch-request ( request -- assoc ) + couch-http-request json> ; + +: couch-get ( url -- assoc ) + couch-request ; + +: couch-put ( post-data url -- assoc ) + couch-request ; + +: couch-post ( post-data url -- assoc ) + couch-request ; + +: couch-delete ( url -- assoc ) + couch-request ; + +: response-ok ( assoc -- assoc ) + "ok" over delete-at* and t assert= ; + +: response-ok* ( assoc -- ) + response-ok drop ; + +! server +TUPLE: server { host string } { port integer } { uuids vector } { uuids-to-cache integer } ; + +: default-couch-host ( -- host ) "localhost" ; inline +: default-couch-port ( -- port ) 5984 ; inline +: default-uuids-to-cache ( -- n ) 100 ; inline + +: ( host port -- server ) + V{ } clone default-uuids-to-cache server boa ; + +: ( -- server ) + default-couch-host default-couch-port ; + +: (server-url) ( server -- ) + "http://" % [ host>> % ] [ CHAR: : , port>> number>string % ] bi CHAR: / , ; inline + +: server-url ( server -- url ) + [ (server-url) ] "" make ; + +: all-dbs ( server -- dbs ) + server-url "_all_dbs" append couch-get ; + +: uuids-url ( server -- url ) + [ dup server-url % "_uuids?count=" % uuids-to-cache>> number>string % ] "" make ; + +: uuids-get ( server -- uuids ) + uuids-url couch-get "uuids" swap at >vector ; + +: get-uuids ( server -- server ) + dup uuids-get [ nip ] curry change-uuids ; + +: ensure-uuids ( server -- server ) + dup uuids>> empty? [ get-uuids ] when ; + +: next-uuid ( server -- uuid ) + ensure-uuids uuids>> pop ; + +! db +TUPLE: db { server server } { name string } ; +C: db + +: (db-url) ( db -- ) + [ server>> server-url % ] [ name>> % ] bi CHAR: / , ; inline + +: db-url ( db -- url ) + [ (db-url) ] "" make ; + +: create-db ( db -- ) + f swap db-url couch-put response-ok* ; + +: ensure-db ( db -- ) + [ create-db ] [ + dup file-exists-error? [ 2drop ] [ rethrow ] if + ] recover ; + +: delete-db ( db -- ) + db-url couch-delete drop ; + +: db-info ( db -- info ) + db-url couch-get ; + +: compact-db ( db -- ) + f swap db-url "_compact" append couch-post response-ok* ; + +: all-docs ( db -- docs ) + ! TODO: queries. Maybe pass in a hashtable with options + db-url "_all_docs" append couch-get ; + +: ( assoc -- post-data ) + >json utf8 encode "application/json" swap >>data ; + +! documents +: id> ( assoc -- id ) "_id" swap at ; +: >id ( assoc id -- assoc ) "_id" pick set-at ; +: rev> ( assoc -- rev ) "_rev" swap at ; +: >rev ( assoc rev -- assoc ) "_rev" pick set-at ; +: attachments> ( assoc -- attachments ) "_attachments" swap at ; +: >attachments ( assoc attachments -- assoc ) "_attachments" pick set-at ; + +: copy-key ( to from to-key from-key -- ) + rot at spin set-at ; + +: copy-id ( to from -- ) + "_id" "id" copy-key ; + +: copy-rev ( to from -- ) + "_rev" "rev" copy-key ; + +: id-url ( id -- url ) + couch get db-url swap url-encode-full append ; + +: doc-url ( assoc -- url ) + id> id-url ; + +: temp-view ( view -- results ) + couch get db-url "_temp_view" append couch-post ; + +: temp-view-map ( map -- results ) + "map" H{ } clone [ set-at ] keep temp-view ; + +: save-doc-as ( assoc id -- ) + [ dup ] dip id-url couch-put response-ok + [ copy-id ] [ copy-rev ] 2bi ; + +: save-new-doc ( assoc -- ) + couch get server>> next-uuid save-doc-as ; + +: save-doc ( assoc -- ) + dup id> [ save-doc-as ] [ save-new-doc ] if* ; + +: load-doc ( id -- assoc ) + id-url couch-get ; + +: delete-doc ( assoc -- deletion-revision ) + [ + [ doc-url % ] + [ "?rev=" % "_rev" swap at % ] bi + ] "" make couch-delete response-ok "rev" swap at ; + +: remove-keys ( assoc keys -- ) + swap [ delete-at ] curry each ; + +: remove-couch-info ( assoc -- ) + { "_id" "_rev" "_attachments" } remove-keys ; + +! : construct-attachment ( content-type data -- assoc ) +! H{ } clone "name" pick set-at "content-type" pick set-at ; +! +! : add-attachment ( assoc name attachment -- ) +! pick attachments> [ H{ } clone ] unless* +! +! : attach ( assoc name content-type data -- ) +! construct-attachment H{ } clone + +! TODO: +! - startkey, limit, descending, etc. +! - loading specific revisions +! - views +! - attachments +! - bulk insert/update +! - ...? diff --git a/extra/dns/util/util.factor b/extra/dns/util/util.factor index 5b2e63838a..f47eb7010c 100644 --- a/extra/dns/util/util.factor +++ b/extra/dns/util/util.factor @@ -28,4 +28,4 @@ TUPLE: packet data addr socket ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -: 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 diff --git a/extra/fuel/eval/eval.factor b/extra/fuel/eval/eval.factor index c3b1a8a3f2..019b9105bc 100644 --- a/extra/fuel/eval/eval.factor +++ b/extra/fuel/eval/eval.factor @@ -21,7 +21,7 @@ SYMBOL: fuel-eval-res-flag 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 @@ -29,7 +29,7 @@ t fuel-eval-res-flag set-global 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? [ @@ -39,35 +39,32 @@ t fuel-eval-res-flag set-global [ 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 - -: (fuel-eval-each) ( lines -- ) - [ 1vector (fuel-eval) ] each ; inline + [ [ parse-lines ] with-compilation-unit call( -- ) ] curry + [ print-error ] recover ; : (fuel-eval-usings) ( usings -- ) - [ "USING: " prepend " ;" append ] map - (fuel-eval-each) fuel-forget-error fuel-forget-output ; + [ "USE: " prepend ] map + (fuel-eval) fuel-forget-error fuel-forget-output ; : (fuel-eval-in) ( in -- ) - [ dup "IN: " prepend 1vector (fuel-eval) in set ] when* ; inline + [ dup "IN: " prepend 1array (fuel-eval) in set ] when* ; : (fuel-eval-in-context) ( lines in usings -- ) (fuel-begin-eval) diff --git a/extra/fuel/fuel.factor b/extra/fuel/fuel.factor index 403708e880..413aefdc76 100644 --- a/extra/fuel/fuel.factor +++ b/extra/fuel/fuel.factor @@ -104,7 +104,7 @@ PRIVATE> : 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 ; diff --git a/unmaintained/synth/authors.txt b/extra/jamshred/authors.txt similarity index 100% rename from unmaintained/synth/authors.txt rename to extra/jamshred/authors.txt diff --git a/extra/jamshred/deploy.factor b/extra/jamshred/deploy.factor new file mode 100644 index 0000000000..9a18cf1f9b --- /dev/null +++ b/extra/jamshred/deploy.factor @@ -0,0 +1,12 @@ +USING: tools.deploy.config ; +V{ + { deploy-ui? t } + { deploy-io 1 } + { deploy-reflection 1 } + { deploy-compiler? t } + { deploy-math? t } + { deploy-word-props? f } + { deploy-c-types? f } + { "stop-after-last-window?" t } + { deploy-name "Jamshred" } +} diff --git a/unmaintained/synth/buffers/authors.txt b/extra/jamshred/game/authors.txt similarity index 100% rename from unmaintained/synth/buffers/authors.txt rename to extra/jamshred/game/authors.txt diff --git a/extra/jamshred/game/game.factor b/extra/jamshred/game/game.factor new file mode 100644 index 0000000000..9cb5bc7c3a --- /dev/null +++ b/extra/jamshred/game/game.factor @@ -0,0 +1,40 @@ +! Copyright (C) 2007, 2008 Alex Chapman +! See http://factorcode.org/license.txt for BSD license. +USING: accessors kernel opengl arrays sequences jamshred.log jamshred.player jamshred.sound jamshred.tunnel math math.constants math.vectors ; +IN: jamshred.game + +TUPLE: jamshred sounds tunnel players running quit ; + +: ( -- jamshred ) + "Player 1" pick + 2dup swap play-in-tunnel 1array f f jamshred boa ; + +: jamshred-player ( jamshred -- player ) + ! TODO: support more than one player + players>> first ; + +: jamshred-update ( jamshred -- ) + dup running>> [ + jamshred-player update-player + ] [ drop ] if ; + +: toggle-running ( jamshred -- ) + dup running>> [ + f >>running drop + ] [ + [ jamshred-player moved ] + [ t >>running drop ] bi + ] if ; + +: mouse-moved ( x-radians y-radians jamshred -- ) + jamshred-player -rot turn-player ; + +: units-per-full-roll ( -- n ) 50 ; + +: jamshred-roll ( jamshred n -- ) + [ jamshred-player ] dip 2 pi * * units-per-full-roll / roll-player ; + +: mouse-scroll-x ( jamshred x -- ) jamshred-roll ; + +: mouse-scroll-y ( jamshred y -- ) + neg swap jamshred-player change-player-speed ; diff --git a/unmaintained/synth/example/authors.txt b/extra/jamshred/gl/authors.txt similarity index 100% rename from unmaintained/synth/example/authors.txt rename to extra/jamshred/gl/authors.txt diff --git a/extra/jamshred/gl/gl.factor b/extra/jamshred/gl/gl.factor new file mode 100644 index 0000000000..bae275e96a --- /dev/null +++ b/extra/jamshred/gl/gl.factor @@ -0,0 +1,112 @@ +! Copyright (C) 2007, 2008 Alex Chapman +! See http://factorcode.org/license.txt for BSD license. +USING: accessors alien.c-types jamshred.game jamshred.oint +jamshred.player jamshred.tunnel kernel math math.constants +math.functions math.vectors opengl opengl.gl opengl.glu +opengl.demo-support sequences specialized-arrays.float ; +IN: jamshred.gl + +: min-vertices ( -- n ) 6 ; inline +: max-vertices ( -- n ) 32 ; inline + +: n-vertices ( -- n ) 32 ; inline + +! render enough of the tunnel that it looks continuous +: n-segments-ahead ( -- n ) 60 ; inline +: n-segments-behind ( -- n ) 40 ; inline + +: wall-drawing-offset ( -- n ) + #! so that we can't see through the wall, we draw it a bit further away + 0.15 ; + +: wall-drawing-radius ( segment -- r ) + radius>> wall-drawing-offset + ; + +: wall-up ( segment -- v ) + [ wall-drawing-radius ] [ up>> ] bi n*v ; + +: wall-left ( segment -- v ) + [ wall-drawing-radius ] [ left>> ] bi n*v ; + +: segment-vertex ( theta segment -- vertex ) + [ + [ wall-up swap sin v*n ] [ wall-left swap cos v*n ] 2bi v+ + ] [ + location>> v+ + ] bi ; + +: segment-vertex-normal ( vertex segment -- normal ) + location>> swap v- normalize ; + +: segment-vertex-and-normal ( segment theta -- vertex normal ) + swap [ segment-vertex ] keep dupd segment-vertex-normal ; + +: equally-spaced-radians ( n -- seq ) + #! return a sequence of n numbers between 0 and 2pi + dup [ / pi 2 * * ] curry map ; + +: draw-segment-vertex ( segment theta -- ) + over color>> gl-color segment-vertex-and-normal + gl-normal gl-vertex ; + +: draw-vertex-pair ( theta next-segment segment -- ) + rot tuck draw-segment-vertex draw-segment-vertex ; + +: draw-segment ( next-segment segment -- ) + GL_QUAD_STRIP [ + [ draw-vertex-pair ] 2curry + n-vertices equally-spaced-radians float-array{ 0.0 } append swap each + ] do-state ; + +: draw-segments ( segments -- ) + 1 over length pick subseq swap [ draw-segment ] 2each ; + +: segments-to-render ( player -- segments ) + dup nearest-segment>> number>> dup n-segments-behind - + swap n-segments-ahead + rot tunnel>> sub-tunnel ; + +: draw-tunnel ( player -- ) + segments-to-render draw-segments ; + +: init-graphics ( -- ) + GL_DEPTH_TEST glEnable + GL_SCISSOR_TEST glDisable + 1.0 glClearDepth + 0.0 0.0 0.0 0.0 glClearColor + GL_PROJECTION glMatrixMode glPushMatrix + GL_MODELVIEW glMatrixMode glPushMatrix + GL_LEQUAL glDepthFunc + GL_LIGHTING glEnable + GL_LIGHT0 glEnable + GL_FOG glEnable + GL_FOG_DENSITY 0.09 glFogf + GL_FRONT GL_AMBIENT_AND_DIFFUSE glColorMaterial + GL_COLOR_MATERIAL glEnable + GL_LIGHT0 GL_POSITION float-array{ 0.0 0.0 0.0 1.0 } underlying>> glLightfv + GL_LIGHT0 GL_AMBIENT float-array{ 0.2 0.2 0.2 1.0 } underlying>> glLightfv + GL_LIGHT0 GL_DIFFUSE float-array{ 1.0 1.0 1.0 1.0 } underlying>> glLightfv + GL_LIGHT0 GL_SPECULAR float-array{ 1.0 1.0 1.0 1.0 } underlying>> glLightfv ; + +: cleanup-graphics ( -- ) + GL_DEPTH_TEST glDisable + GL_SCISSOR_TEST glEnable + GL_MODELVIEW glMatrixMode glPopMatrix + GL_PROJECTION glMatrixMode glPopMatrix + GL_LIGHTING glDisable + GL_LIGHT0 glDisable + GL_FOG glDisable + GL_COLOR_MATERIAL glDisable ; + +: pre-draw ( width height -- ) + GL_COLOR_BUFFER_BIT GL_DEPTH_BUFFER_BIT bitor glClear + GL_PROJECTION glMatrixMode glLoadIdentity + dup 0 = [ 2drop ] [ / >float 45.0 swap 0.1 100.0 gluPerspective ] if + GL_MODELVIEW glMatrixMode glLoadIdentity ; + +: player-view ( player -- ) + [ location>> ] + [ [ location>> ] [ forward>> ] bi v+ ] + [ up>> ] tri gl-look-at ; + +: draw-jamshred ( jamshred width height -- ) + pre-draw jamshred-player [ player-view ] [ draw-tunnel ] bi ; diff --git a/extra/jamshred/jamshred.factor b/extra/jamshred/jamshred.factor new file mode 100644 index 0000000000..49624e2947 --- /dev/null +++ b/extra/jamshred/jamshred.factor @@ -0,0 +1,94 @@ +! Copyright (C) 2007, 2008 Alex Chapman +! See http://factorcode.org/license.txt for BSD license. +USING: accessors arrays calendar jamshred.game jamshred.gl jamshred.player jamshred.log kernel math math.constants math.rectangles math.vectors namespaces sequences threads ui ui.backend ui.gadgets ui.gadgets.worlds ui.gestures ui.render ; +IN: jamshred + +TUPLE: jamshred-gadget < gadget { jamshred jamshred } last-hand-loc ; + +: ( jamshred -- gadget ) + jamshred-gadget new swap >>jamshred ; + +: default-width ( -- x ) 800 ; +: default-height ( -- y ) 600 ; + +M: jamshred-gadget pref-dim* + drop default-width default-height 2array ; + +M: jamshred-gadget draw-gadget* ( gadget -- ) + [ jamshred>> ] [ dim>> first2 draw-jamshred ] bi ; + +: jamshred-loop ( gadget -- ) + dup jamshred>> quit>> [ + drop + ] [ + [ jamshred>> jamshred-update ] + [ relayout-1 ] + [ 100 milliseconds sleep jamshred-loop ] tri + ] if ; + +: fullscreen ( gadget -- ) + find-world t swap set-fullscreen* ; + +: no-fullscreen ( gadget -- ) + find-world f swap set-fullscreen* ; + +: toggle-fullscreen ( world -- ) + [ fullscreen? not ] keep set-fullscreen* ; + +M: jamshred-gadget graft* ( gadget -- ) + [ find-gl-context init-graphics ] + [ [ jamshred-loop ] curry in-thread ] bi ; + +M: jamshred-gadget ungraft* ( gadget -- ) + dup find-gl-context cleanup-graphics jamshred>> t swap (>>quit) ; + +: jamshred-restart ( jamshred-gadget -- ) + >>jamshred drop ; + +: pix>radians ( n m -- theta ) + / pi 4 * * ; ! 2 / / pi 2 * * ; + +: x>radians ( x gadget -- theta ) + #! translate motion of x pixels to an angle + dim>> first pix>radians neg ; + +: y>radians ( y gadget -- theta ) + #! translate motion of y pixels to an angle + dim>> second pix>radians ; + +: (handle-mouse-motion) ( jamshred-gadget mouse-motion -- ) + dupd [ first swap x>radians ] [ second swap y>radians ] 2bi + rot jamshred>> mouse-moved ; + +: handle-mouse-motion ( jamshred-gadget -- ) + hand-loc get [ + over last-hand-loc>> [ + v- (handle-mouse-motion) + ] [ 2drop ] if* + ] 2keep >>last-hand-loc drop ; + +: handle-mouse-scroll ( jamshred-gadget -- ) + jamshred>> scroll-direction get + [ first mouse-scroll-x ] + [ second mouse-scroll-y ] 2bi ; + +: quit ( gadget -- ) + [ no-fullscreen ] [ close-window ] bi ; + +jamshred-gadget H{ + { T{ key-down f f "r" } [ jamshred-restart ] } + { T{ key-down f f " " } [ jamshred>> toggle-running ] } + { T{ key-down f f "f" } [ find-world toggle-fullscreen ] } + { T{ key-down f f "UP" } [ jamshred>> jamshred-player 1 swap change-player-speed ] } + { T{ key-down f f "DOWN" } [ jamshred>> jamshred-player -1 swap change-player-speed ] } + { T{ key-down f f "LEFT" } [ jamshred>> 1 jamshred-roll ] } + { T{ key-down f f "RIGHT" } [ jamshred>> -1 jamshred-roll ] } + { T{ key-down f f "q" } [ quit ] } + { motion [ handle-mouse-motion ] } + { mouse-scroll [ handle-mouse-scroll ] } +} set-gestures + +: jamshred-window ( -- ) + [ "Jamshred" open-window ] with-ui ; + +MAIN: jamshred-window diff --git a/extra/jamshred/log/log.factor b/extra/jamshred/log/log.factor new file mode 100644 index 0000000000..f2517d1ec3 --- /dev/null +++ b/extra/jamshred/log/log.factor @@ -0,0 +1,10 @@ +USING: kernel logging ; +IN: jamshred.log + +LOG: (jamshred-log) DEBUG + +: with-jamshred-log ( quot -- ) + "jamshred" swap with-logging ; inline + +: jamshred-log ( message -- ) + [ (jamshred-log) ] with-jamshred-log ; ! ugly... diff --git a/extra/jamshred/oint/authors.txt b/extra/jamshred/oint/authors.txt new file mode 100644 index 0000000000..e9c193bac7 --- /dev/null +++ b/extra/jamshred/oint/authors.txt @@ -0,0 +1 @@ +Alex Chapman diff --git a/extra/jamshred/oint/oint-tests.factor b/extra/jamshred/oint/oint-tests.factor new file mode 100644 index 0000000000..401935fd01 --- /dev/null +++ b/extra/jamshred/oint/oint-tests.factor @@ -0,0 +1,8 @@ +USING: jamshred.oint tools.test ; +IN: jamshred.oint-tests + +[ { 0 -1 -1 } ] [ { 0 1 -1 } { 0 -1 0 } reflect ] unit-test +[ { 0 1 0 } ] [ { 1 1 0 } { 1 0 0 } proj-perp ] unit-test +[ { 1 0 0 } ] [ { 1 1 0 } { 0 1 0 } proj-perp ] unit-test +[ { 1/2 -1/2 0 } ] [ { 1 0 0 } { 1 1 0 } proj-perp ] unit-test +[ { -1/2 1/2 0 } ] [ { 0 1 0 } { 1 1 0 } proj-perp ] unit-test diff --git a/extra/jamshred/oint/oint.factor b/extra/jamshred/oint/oint.factor new file mode 100644 index 0000000000..ae72bd847c --- /dev/null +++ b/extra/jamshred/oint/oint.factor @@ -0,0 +1,73 @@ +! Copyright (C) 2007, 2008 Alex Chapman +! See http://factorcode.org/license.txt for BSD license. +USING: accessors arrays kernel locals math math.constants math.functions math.matrices math.vectors math.quaternions random sequences ; +IN: jamshred.oint + +! An oint is a point with three linearly independent unit vectors +! given relative to that point. In jamshred a player's location and +! direction are given by the player's oint. Similarly, a tunnel +! segment's location and orientation are given by an oint. + +TUPLE: oint location forward up left ; +C: oint + +: rotation-quaternion ( theta axis -- quaternion ) + swap 2 / dup cos swap sin rot n*v first3 rect> [ rect> ] dip 2array ; + +: rotate-vector ( q qrecip v -- v ) + v>q swap q* q* q>v ; + +: rotate-oint ( oint theta axis -- ) + rotation-quaternion dup qrecip pick + [ forward>> rotate-vector >>forward ] + [ up>> rotate-vector >>up ] + [ left>> rotate-vector >>left ] 3tri drop ; + +: left-pivot ( oint theta -- ) + over left>> rotate-oint ; + +: up-pivot ( oint theta -- ) + over up>> rotate-oint ; + +: forward-pivot ( oint theta -- ) + over forward>> rotate-oint ; + +: random-float+- ( n -- m ) + #! find a random float between -n/2 and n/2 + dup 10000 * >fixnum random 10000 / swap 2 / - ; + +: random-turn ( oint theta -- ) + 2 / 2dup random-float+- left-pivot random-float+- up-pivot ; + +: location+ ( v oint -- ) + [ location>> v+ ] [ (>>location) ] bi ; + +: go-forward ( distance oint -- ) + [ forward>> n*v ] [ location+ ] bi ; + +: distance-vector ( oint oint -- vector ) + [ location>> ] bi@ swap v- ; + +: distance ( oint oint -- distance ) + distance-vector norm ; + +: scalar-projection ( v1 v2 -- n ) + #! the scalar projection of v1 onto v2 + tuck v. swap norm / ; + +: proj-perp ( u v -- w ) + dupd proj v- ; + +: perpendicular-distance ( oint oint -- distance ) + tuck distance-vector swap 2dup left>> scalar-projection abs + -rot up>> scalar-projection abs + ; + +:: reflect ( v n -- v' ) + #! bounce v on a surface with normal n + v v n v. n n v. / 2 * n n*v v- ; + +: half-way ( p1 p2 -- p3 ) + over v- 2 v/n v+ ; + +: half-way-between-oints ( o1 o2 -- p ) + [ location>> ] bi@ half-way ; diff --git a/extra/jamshred/player/authors.txt b/extra/jamshred/player/authors.txt new file mode 100644 index 0000000000..e9c193bac7 --- /dev/null +++ b/extra/jamshred/player/authors.txt @@ -0,0 +1 @@ +Alex Chapman diff --git a/extra/jamshred/player/player.factor b/extra/jamshred/player/player.factor new file mode 100644 index 0000000000..d33b78f29c --- /dev/null +++ b/extra/jamshred/player/player.factor @@ -0,0 +1,137 @@ +! Copyright (C) 2007, 2008 Alex Chapman +! See http://factorcode.org/license.txt for BSD license. +USING: accessors colors.constants combinators jamshred.log jamshred.oint jamshred.sound jamshred.tunnel kernel locals math math.constants math.order math.ranges math.vectors math.matrices sequences shuffle specialized-arrays.float strings system ; +IN: jamshred.player + +TUPLE: player < oint + { name string } + { sounds sounds } + tunnel + nearest-segment + { last-move integer } + { speed float } ; + +! speeds are in GL units / second +: default-speed ( -- speed ) 1.0 ; +: max-speed ( -- speed ) 30.0 ; + +: ( name sounds -- player ) + [ float-array{ 0 0 5 } float-array{ 0 0 -1 } float-array{ 0 1 0 } float-array{ -1 0 0 } ] 2dip + f f 0 default-speed player boa ; + +: turn-player ( player x-radians y-radians -- ) + [ over ] dip left-pivot up-pivot ; + +: roll-player ( player z-radians -- ) + forward-pivot ; + +: to-tunnel-start ( player -- ) + [ tunnel>> first dup location>> ] + [ tuck (>>location) (>>nearest-segment) ] bi ; + +: play-in-tunnel ( player segments -- ) + >>tunnel to-tunnel-start ; + +: update-nearest-segment ( player -- ) + [ tunnel>> ] [ dup nearest-segment>> nearest-segment ] + [ (>>nearest-segment) ] tri ; + +: update-time ( player -- seconds-passed ) + millis swap [ last-move>> - 1000 / ] [ (>>last-move) ] 2bi ; + +: moved ( player -- ) millis swap (>>last-move) ; + +: speed-range ( -- range ) + max-speed [0,b] ; + +: change-player-speed ( inc player -- ) + [ + speed-range clamp-to-range ] change-speed drop ; + +: multiply-player-speed ( n player -- ) + [ * speed-range clamp-to-range ] change-speed drop ; + +: distance-to-move ( seconds-passed player -- distance ) + speed>> * ; + +: bounce ( d-left player -- d-left' player ) + { + [ dup nearest-segment>> bounce-off-wall ] + [ sounds>> bang ] + [ 3/4 swap multiply-player-speed ] + [ ] + } cleave ; + +:: (distance) ( heading player -- current next location heading ) + player nearest-segment>> + player [ tunnel>> ] [ nearest-segment>> ] bi heading heading-segment + player location>> heading ; + +: distance-to-heading-segment ( heading player -- distance ) + (distance) distance-to-next-segment ; + +: distance-to-heading-segment-area ( heading player -- distance ) + (distance) distance-to-next-segment-area ; + +: distance-to-collision ( player -- distance ) + dup nearest-segment>> (distance-to-collision) ; + +: almost-to-collision ( player -- distance ) + distance-to-collision 0.1 - dup 0 < [ drop 0 ] when ; + +: from ( player -- radius distance-from-centre ) + [ nearest-segment>> dup radius>> swap ] [ location>> ] bi + distance-from-centre ; + +: distance-from-wall ( player -- distance ) from - ; +: fraction-from-centre ( player -- fraction ) from swap / ; +: fraction-from-wall ( player -- fraction ) + fraction-from-centre 1 swap - ; + +: update-nearest-segment2 ( heading player -- ) + 2dup distance-to-heading-segment-area 0 <= [ + [ tunnel>> ] [ nearest-segment>> rot heading-segment ] + [ (>>nearest-segment) ] tri + ] [ + 2drop + ] if ; + +:: move-player-on-heading ( d-left player distance heading -- d-left' player ) + [let* | d-to-move [ d-left distance min ] + move-v [ d-to-move heading n*v ] | + move-v player location+ + heading player update-nearest-segment2 + d-left d-to-move - player ] ; + +: distance-to-move-freely ( player -- distance ) + [ almost-to-collision ] + [ [ forward>> ] keep distance-to-heading-segment-area ] bi min ; + +: ?move-player-freely ( d-left player -- d-left' player ) + over 0 > [ + ! must make sure we are moving a significant distance, otherwise + ! we can recurse endlessly due to floating-point imprecision. + ! (at least I /think/ that's what causes it...) + dup distance-to-move-freely dup 0.1 > [ + over forward>> move-player-on-heading ?move-player-freely + ] [ drop ] if + ] when ; + +: drag-heading ( player -- heading ) + [ forward>> ] [ nearest-segment>> forward>> proj ] bi ; + +: drag-player ( d-left player -- d-left' player ) + dup [ [ drag-heading ] keep distance-to-heading-segment-area ] + [ drag-heading move-player-on-heading ] bi ; + +: (move-player) ( d-left player -- d-left' player ) + ?move-player-freely over 0 > [ + ! bounce + drag-player + (move-player) + ] when ; + +: move-player ( player -- ) + [ update-time ] [ distance-to-move ] [ (move-player) 2drop ] tri ; + +: update-player ( player -- ) + [ move-player ] [ nearest-segment>> "white" named-color swap (>>color) ] bi ; diff --git a/extra/jamshred/sound/sound.factor b/extra/jamshred/sound/sound.factor new file mode 100644 index 0000000000..6a9b331f33 --- /dev/null +++ b/extra/jamshred/sound/sound.factor @@ -0,0 +1,15 @@ +! Copyright (C) 2008 Alex Chapman +! See http://factorcode.org/license.txt for BSD license. +USING: accessors io.pathnames kernel openal sequences ; +IN: jamshred.sound + +TUPLE: sounds bang ; + +: assign-sound ( source wav-path -- ) + resource-path create-buffer-from-wav AL_BUFFER swap set-source-param ; + +: ( -- sounds ) + init-openal 1 gen-sources first sounds boa + dup bang>> "extra/jamshred/sound/bang.wav" assign-sound ; + +: bang ( sounds -- ) bang>> source-play check-error ; diff --git a/extra/jamshred/summary.txt b/extra/jamshred/summary.txt new file mode 100644 index 0000000000..e26fc1cf8b --- /dev/null +++ b/extra/jamshred/summary.txt @@ -0,0 +1 @@ +A simple 3d tunnel racing game diff --git a/extra/jamshred/tags.txt b/extra/jamshred/tags.txt new file mode 100644 index 0000000000..8ae5957a4b --- /dev/null +++ b/extra/jamshred/tags.txt @@ -0,0 +1,2 @@ +applications +games diff --git a/extra/jamshred/tunnel/authors.txt b/extra/jamshred/tunnel/authors.txt new file mode 100644 index 0000000000..e9c193bac7 --- /dev/null +++ b/extra/jamshred/tunnel/authors.txt @@ -0,0 +1 @@ +Alex Chapman diff --git a/extra/jamshred/tunnel/tunnel-tests.factor b/extra/jamshred/tunnel/tunnel-tests.factor new file mode 100644 index 0000000000..8e2f1a6fab --- /dev/null +++ b/extra/jamshred/tunnel/tunnel-tests.factor @@ -0,0 +1,45 @@ +! Copyright (C) 2007, 2008 Alex Chapman +! See http://factorcode.org/license.txt for BSD license. +USING: accessors arrays jamshred.oint jamshred.tunnel kernel math.vectors sequences specialized-arrays.float tools.test ; +IN: jamshred.tunnel.tests + +[ 0 ] [ T{ segment f { 0 0 0 } f f f 0 } + T{ segment f { 1 1 1 } f f f 1 } + T{ oint f { 0 0 0.25 } } + nearer-segment number>> ] unit-test + +[ 0 ] [ T{ oint f { 0 0 0 } } find-nearest-segment number>> ] unit-test +[ 1 ] [ T{ oint f { 0 0 -1 } } find-nearest-segment number>> ] unit-test +[ 2 ] [ T{ oint f { 0 0.1 -2.1 } } find-nearest-segment number>> ] unit-test + +[ 3 ] [ T{ oint f { 0 0 -3.25 } } 0 nearest-segment-forward number>> ] unit-test + +[ float-array{ 0 0 0 } ] [ T{ oint f { 0 0 -0.25 } } over first nearest-segment location>> ] unit-test + +: test-segment-oint ( -- oint ) + { 0 0 0 } { 0 0 -1 } { 0 1 0 } { -1 0 0 } ; + +[ { -1 0 0 } ] [ test-segment-oint { 1 0 0 } vector-to-centre ] unit-test +[ { 1 0 0 } ] [ test-segment-oint { -1 0 0 } vector-to-centre ] unit-test +[ { 0 -1 0 } ] [ test-segment-oint { 0 1 0 } vector-to-centre ] unit-test +[ { 0 1 0 } ] [ test-segment-oint { 0 -1 0 } vector-to-centre ] unit-test +[ { -1 0 0 } ] [ test-segment-oint { 1 0 -1 } vector-to-centre ] unit-test +[ { 1 0 0 } ] [ test-segment-oint { -1 0 -1 } vector-to-centre ] unit-test +[ { 0 -1 0 } ] [ test-segment-oint { 0 1 -1 } vector-to-centre ] unit-test +[ { 0 1 0 } ] [ test-segment-oint { 0 -1 -1 } vector-to-centre ] unit-test + +: simplest-straight-ahead ( -- oint segment ) + { 0 0 0 } { 0 0 -1 } { 0 1 0 } { -1 0 0 } + initial-segment ; + +[ { 0.0 0.0 0.0 } ] [ simplest-straight-ahead sideways-heading ] unit-test +[ { 0.0 0.0 0.0 } ] [ simplest-straight-ahead sideways-relative-location ] unit-test + +: simple-collision-up ( -- oint segment ) + { 0 0 0 } { 0 1 0 } { 0 0 1 } { -1 0 0 } + initial-segment ; + +[ { 0.0 1.0 0.0 } ] [ simple-collision-up sideways-heading ] unit-test +[ { 0.0 0.0 0.0 } ] [ simple-collision-up sideways-relative-location ] unit-test +[ { 0.0 1.0 0.0 } ] +[ simple-collision-up collision-vector 0 0 0 3array v+ ] unit-test diff --git a/extra/jamshred/tunnel/tunnel.factor b/extra/jamshred/tunnel/tunnel.factor new file mode 100644 index 0000000000..4c4b3e6812 --- /dev/null +++ b/extra/jamshred/tunnel/tunnel.factor @@ -0,0 +1,165 @@ +! Copyright (C) 2007, 2008 Alex Chapman +! See http://factorcode.org/license.txt for BSD license. +USING: accessors arrays colors combinators kernel locals math math.constants math.matrices math.order math.ranges math.vectors math.quadratic random sequences specialized-arrays.float vectors jamshred.oint ; +IN: jamshred.tunnel + +: n-segments ( -- n ) 5000 ; inline + +TUPLE: segment < oint number color radius ; +C: segment + +: segment-number++ ( segment -- ) + [ number>> 1+ ] keep (>>number) ; + +: random-color ( -- color ) + { 100 100 100 } [ random 100 / >float ] map first3 1.0 ; + +: tunnel-segment-distance ( -- n ) 0.4 ; +: random-rotation-angle ( -- theta ) pi 20 / ; + +: random-segment ( previous-segment -- segment ) + clone dup random-rotation-angle random-turn + tunnel-segment-distance over go-forward + random-color >>color dup segment-number++ ; + +: (random-segments) ( segments n -- segments ) + dup 0 > [ + [ dup peek random-segment over push ] dip 1- (random-segments) + ] [ drop ] if ; + +: default-segment-radius ( -- r ) 1 ; + +: initial-segment ( -- segment ) + float-array{ 0 0 0 } float-array{ 0 0 -1 } float-array{ 0 1 0 } float-array{ -1 0 0 } + 0 random-color default-segment-radius ; + +: random-segments ( n -- segments ) + initial-segment 1vector swap (random-segments) ; + +: simple-segment ( n -- segment ) + [ float-array{ 0 0 -1 } n*v float-array{ 0 0 -1 } float-array{ 0 1 0 } float-array{ -1 0 0 } ] keep + random-color default-segment-radius ; + +: simple-segments ( n -- segments ) + [ simple-segment ] map ; + +: ( -- segments ) + n-segments random-segments ; + +: ( -- segments ) + n-segments simple-segments ; + +: sub-tunnel ( from to segments -- segments ) + #! return segments between from and to, after clamping from and to to + #! valid values + [ sequence-index-range [ clamp-to-range ] curry bi@ ] keep ; + +: nearer-segment ( segment segment oint -- segment ) + #! return whichever of the two segments is nearer to the oint + [ 2dup ] dip tuck distance [ distance ] dip < -rot ? ; + +: (find-nearest-segment) ( nearest next oint -- nearest ? ) + #! find the nearest of 'next' and 'nearest' to 'oint', and return + #! t if the nearest hasn't changed + pick [ nearer-segment dup ] dip = ; + +: find-nearest-segment ( oint segments -- segment ) + dup first swap rest-slice rot [ (find-nearest-segment) ] curry + find 2drop ; + +: nearest-segment-forward ( segments oint start -- segment ) + rot dup length swap find-nearest-segment ; + +: nearest-segment-backward ( segments oint start -- segment ) + swapd 1+ 0 spin find-nearest-segment ; + +: nearest-segment ( segments oint start-segment -- segment ) + #! find the segment nearest to 'oint', and return it. + #! start looking at segment 'start-segment' + number>> over [ + [ nearest-segment-forward ] 3keep nearest-segment-backward + ] dip nearer-segment ; + +: get-segment ( segments n -- segment ) + over sequence-index-range clamp-to-range swap nth ; + +: next-segment ( segments current-segment -- segment ) + number>> 1+ get-segment ; + +: previous-segment ( segments current-segment -- segment ) + number>> 1- get-segment ; + +: heading-segment ( segments current-segment heading -- segment ) + #! the next segment on the given heading + over forward>> v. 0 <=> { + { +gt+ [ next-segment ] } + { +lt+ [ previous-segment ] } + { +eq+ [ nip ] } ! current segment + } case ; + +:: distance-to-next-segment ( current next location heading -- distance ) + [let | cf [ current forward>> ] | + cf next location>> v. cf location v. - cf heading v. / ] ; + +:: distance-to-next-segment-area ( current next location heading -- distance ) + [let | cf [ current forward>> ] + h [ next current half-way-between-oints ] | + cf h v. cf location v. - cf heading v. / ] ; + +: vector-to-centre ( seg loc -- v ) + over location>> swap v- swap forward>> proj-perp ; + +: distance-from-centre ( seg loc -- distance ) + vector-to-centre norm ; + +: wall-normal ( seg oint -- n ) + location>> vector-to-centre normalize ; + +: distant ( -- n ) 1000 ; + +: max-real ( a b -- c ) + #! sometimes collision-coefficient yields complex roots, so we ignore these (hack) + dup real? [ + over real? [ max ] [ nip ] if + ] [ + drop dup real? [ drop distant ] unless + ] if ; + +:: collision-coefficient ( v w r -- c ) + v norm 0 = [ + distant + ] [ + [let* | a [ v dup v. ] + b [ v w v. 2 * ] + c [ w dup v. r sq - ] | + c b a quadratic max-real ] + ] if ; + +: sideways-heading ( oint segment -- v ) + [ forward>> ] bi@ proj-perp ; + +: sideways-relative-location ( oint segment -- loc ) + [ [ location>> ] bi@ v- ] keep forward>> proj-perp ; + +: (distance-to-collision) ( oint segment -- distance ) + [ sideways-heading ] [ sideways-relative-location ] + [ nip radius>> ] 2tri collision-coefficient ; + +: collision-vector ( oint segment -- v ) + dupd (distance-to-collision) swap forward>> n*v ; + +: bounce-forward ( segment oint -- ) + [ wall-normal ] [ forward>> swap reflect ] [ (>>forward) ] tri ; + +: bounce-left ( segment oint -- ) + #! must be done after forward + [ forward>> vneg ] dip [ left>> swap reflect ] + [ forward>> proj-perp normalize ] [ (>>left) ] tri ; + +: bounce-up ( segment oint -- ) + #! must be done after forward and left! + nip [ forward>> ] [ left>> cross ] [ (>>up) ] tri ; + +: bounce-off-wall ( oint segment -- ) + swap [ bounce-forward ] [ bounce-left ] [ bounce-up ] 2tri ; + diff --git a/extra/mason/build/build-tests.factor b/extra/mason/build/build-tests.factor index 1e3705629f..4f5825e4dd 100644 --- a/extra/mason/build/build-tests.factor +++ b/extra/mason/build/build-tests.factor @@ -1,5 +1,2 @@ USING: mason.build tools.test sequences ; IN: mason.build.tests - -{ create-build-dir enter-build-dir clone-builds-factor record-id } -[ must-infer ] each diff --git a/extra/mason/build/build.factor b/extra/mason/build/build.factor index 90ca1d31ff..199d48dec0 100644 --- a/extra/mason/build/build.factor +++ b/extra/mason/build/build.factor @@ -1,8 +1,9 @@ -! 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 @@ -14,20 +15,21 @@ 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 diff --git a/extra/mason/child/child-tests.factor b/extra/mason/child/child-tests.factor index 27bb42ed07..2d5a7c6635 100644 --- a/extra/mason/child/child-tests.factor +++ b/extra/mason/child/child-tests.factor @@ -1,5 +1,5 @@ IN: mason.child.tests -USING: mason.child mason.config tools.test namespaces ; +USING: mason.child mason.config tools.test namespaces io kernel sequences ; [ { "make" "winnt-x86-32" } ] [ [ @@ -40,3 +40,23 @@ USING: mason.child mason.config tools.test namespaces ; 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 diff --git a/extra/mason/child/child.factor b/extra/mason/child/child.factor index feb11933fb..8132e62078 100755 --- a/extra/mason/child/child.factor +++ b/extra/mason/child/child.factor @@ -1,9 +1,10 @@ ! 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 ) @@ -58,29 +59,18 @@ IN: mason.child 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? ( -- ? ) +MACRO: recover-cond ( alist -- ) + dup { [ length 1 = ] [ first callable? ] } 1&& + [ first ] [ [ first first2 ] [ rest ] bi '[ _ _ [ _ recover-cond ] recover-else ] ] if ; + +: build-child ( -- status ) + copy-image { - [ 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 - - [ 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 + { [ 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 diff --git a/extra/mason/cleanup/cleanup.factor b/extra/mason/cleanup/cleanup.factor index a273696f51..3e6209fed0 100755 --- a/extra/mason/cleanup/cleanup.factor +++ b/extra/mason/cleanup/cleanup.factor @@ -5,13 +5,14 @@ io.directories.hierarchy io.files io.launcher kernel 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 [ diff --git a/extra/mason/common/common.factor b/extra/mason/common/common.factor index 1aade3bcae..285a684f06 100755 --- a/extra/mason/common/common.factor +++ b/extra/mason/common/common.factor @@ -4,15 +4,27 @@ USING: kernel namespaces sequences splitting system accessors 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 + [ 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 ; @@ -23,7 +35,7 @@ M: unix really-delete-tree delete-tree ; swap >>command 15 minutes >>timeout - try-process ; + try-output-process ; :: upload-safely ( local username host remote -- ) [let* | temp [ remote ".incomplete" append ] @@ -68,7 +80,7 @@ SYMBOL: stamp : 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 ) @@ -98,8 +110,8 @@ CONSTANT: benchmark-time-file "benchmark-time" 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 diff --git a/extra/mason/config/config.factor b/extra/mason/config/config.factor index 51b09543f4..5ec44df0a9 100644 --- a/extra/mason/config/config.factor +++ b/extra/mason/config/config.factor @@ -11,12 +11,17 @@ builds-dir get-global [ 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 @@ -34,6 +39,12 @@ target-os get-global [ ! 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. diff --git a/extra/mason/email/email-tests.factor b/extra/mason/email/email-tests.factor index 5bde9a9cfe..e2afe01a56 100644 --- a/extra/mason/email/email-tests.factor +++ b/extra/mason/email/email-tests.factor @@ -5,7 +5,6 @@ USING: mason.email mason.common mason.config namespaces tools.test ; [ "linux" target-os set "x86.64" target-cpu set - status-error status set - subject prefix-subject + status-error subject prefix-subject ] with-scope ] unit-test diff --git a/extra/mason/email/email.factor b/extra/mason/email/email.factor index f25f7e5cfa..23203e5222 100644 --- a/extra/mason/email/email.factor +++ b/extra/mason/email/email.factor @@ -1,35 +1,35 @@ -! 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 -- ) 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 ; diff --git a/extra/mason/help/help.factor b/extra/mason/help/help.factor index 9a4e2be996..9ed9653a08 100644 --- a/extra/mason/help/help.factor +++ b/extra/mason/help/help.factor @@ -1,4 +1,4 @@ -! 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 ; @@ -6,7 +6,7 @@ IN: mason.help : 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 ( -- ) @@ -16,11 +16,8 @@ IN: mason.help 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 diff --git a/extra/mason/mason.factor b/extra/mason/mason.factor index 299a2f4e1f..d425985e76 100644 --- a/extra/mason/mason.factor +++ b/extra/mason/mason.factor @@ -6,7 +6,8 @@ mason.email mason.updates namespaces threads ; 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 diff --git a/extra/mason/notify/authors.txt b/extra/mason/notify/authors.txt new file mode 100644 index 0000000000..d4f5d6b3ae --- /dev/null +++ b/extra/mason/notify/authors.txt @@ -0,0 +1 @@ +Slava Pestov \ No newline at end of file diff --git a/extra/mason/notify/notify.factor b/extra/mason/notify/notify.factor new file mode 100644 index 0000000000..6bf4ae090d --- /dev/null +++ b/extra/mason/notify/notify.factor @@ -0,0 +1,48 @@ +! 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 + + 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 diff --git a/extra/mason/release/archive/archive.factor b/extra/mason/release/archive/archive.factor index fff8b83c23..79d6993a91 100755 --- a/extra/mason/release/archive/archive.factor +++ b/extra/mason/release/archive/archive.factor @@ -18,23 +18,23 @@ IN: mason.release.archive : 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 ] } @@ -44,5 +44,5 @@ IN: mason.release.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 diff --git a/extra/mason/release/release.factor b/extra/mason/release/release.factor index bbb47ba0d3..fc4ad0b08a 100644 --- a/extra/mason/release/release.factor +++ b/extra/mason/release/release.factor @@ -1,16 +1,17 @@ -! 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 diff --git a/extra/mason/release/upload/upload.factor b/extra/mason/release/upload/upload.factor index 68f2ffcdb5..d3e11c3fc3 100644 --- a/extra/mason/release/upload/upload.factor +++ b/extra/mason/release/upload/upload.factor @@ -8,14 +8,13 @@ IN: mason.release.upload : 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 ; diff --git a/extra/mason/report/report-tests.factor b/extra/mason/report/report-tests.factor index 7f5c4f1d30..a9e8e2802b 100644 --- a/extra/mason/report/report-tests.factor +++ b/extra/mason/report/report-tests.factor @@ -1,2 +1,4 @@ IN: mason.report.tests USING: mason.report tools.test ; + +{ 0 0 } [ [ ] with-report ] must-infer-as \ No newline at end of file diff --git a/extra/mason/report/report.factor b/extra/mason/report/report.factor index 52e1608885..0839652d55 100644 --- a/extra/mason/report/report.factor +++ b/extra/mason/report/report.factor @@ -1,74 +1,131 @@ -! 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 +

Build report for <->/<->

+ + + + +
Build machine:<->
Build directory:<->
GIT ID:<->
+ XML] ; : with-report ( quot -- ) - [ "report" utf8 ] dip '[ common-report @ ] with-file-writer ; inline + [ "report" utf8 ] dip + '[ + common-report + _ call( -- xml ) + [XML <-><-> 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 +

<-what->

+ Build output: + 
<-output->
+ Launcher error: + 
<-error->
+ 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 ; -: test-failed-report ( error -- ) +: 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 + } [ + execute( -- string ) + dup utf8 file-contents milli-seconds>time + [XML <-><-> XML] + ] map [XML

Timings

<->
XML] ; + +: error-dump ( heading vocabs-file messages-file -- xml ) + [ eval-file ] dip over empty? [ 3drop f ] [ + [ ] + [ [ [XML
  • <->
    • XML] ] map [XML
      <->
    XML] ] + [ utf8 file-contents ] + tri* + [XML

    <->

    <-> Details: 
    <->
    XML] + ] if ; + +: benchmarks-table ( assoc -- xml ) [ - "Tests failed:" print nl - "test-log" 100 cat-n nl - error. - ] with-report ; + 1000000 /f + [XML <-><-> XML] + ] { } assoc>map [XML

    Benchmarks

    <->
    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. + [ + timings-table - nl + "Load failures" + load-everything-vocabs-file + load-everything-errors-file + error-dump - load-everything-vocabs-file eval-file [ - "== Did not pass load-everything:" print . - load-everything-errors-file cat - ] unless-empty + "Compiler warnings and errors" + compiler-errors-file + compiler-error-messages-file + error-dump - compiler-errors-file eval-file [ - "== Vocabularies with compiler errors:" print . - ] unless-empty + "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 - test-all-vocabs-file eval-file [ - "== Did not pass test-all:" print . - test-all-errors-file cat - ] unless-empty + "Benchmark errors" + benchmark-error-vocabs-file + benchmark-error-messages-file + error-dump + + "Benchmark timings" + benchmarks-file eval-file benchmarks-table + ] output>array + ] with-report ; - help-lint-vocabs-file eval-file [ - "== Did not pass help-lint:" print . - help-lint-errors-file cat - ] unless-empty +: 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&& ; - "== Benchmarks:" print - benchmarks-file eval-file benchmarks. - ] with-report ; \ No newline at end of file +: success ( -- status ) + successful-report build-clean? status-clean status-dirty ? ; \ No newline at end of file diff --git a/extra/mason/test/test.factor b/extra/mason/test/test.factor index 4c212b07fb..912fbaa17a 100644 --- a/extra/mason/test/test.factor +++ b/extra/mason/test/test.factor @@ -1,10 +1,10 @@ -! 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 ( -- ) @@ -20,7 +20,9 @@ M: word word-vocabulary vocabulary>> ; 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 ( -- ) @@ -42,7 +44,11 @@ M: method-body word-vocabulary "method-generic" word-prop word-vocabulary ; 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 diff --git a/extra/mason/twitter/authors.txt b/extra/mason/twitter/authors.txt new file mode 100644 index 0000000000..d4f5d6b3ae --- /dev/null +++ b/extra/mason/twitter/authors.txt @@ -0,0 +1 @@ +Slava Pestov \ No newline at end of file diff --git a/extra/mason/twitter/twitter.factor b/extra/mason/twitter/twitter.factor new file mode 100644 index 0000000000..21f1bcabc3 --- /dev/null +++ b/extra/mason/twitter/twitter.factor @@ -0,0 +1,14 @@ +! 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 diff --git a/extra/math/function-tools/function-tools.factor b/extra/math/function-tools/function-tools.factor index 11e57d2639..78c726d370 100644 --- a/extra/math/function-tools/function-tools.factor +++ b/extra/math/function-tools/function-tools.factor @@ -9,10 +9,10 @@ IN: math.function-tools [ 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 diff --git a/extra/morse/authors.txt b/extra/morse/authors.txt new file mode 100644 index 0000000000..e9c193bac7 --- /dev/null +++ b/extra/morse/authors.txt @@ -0,0 +1 @@ +Alex Chapman diff --git a/unmaintained/morse/morse-docs.factor b/extra/morse/morse-docs.factor similarity index 100% rename from unmaintained/morse/morse-docs.factor rename to extra/morse/morse-docs.factor diff --git a/unmaintained/morse/morse-tests.factor b/extra/morse/morse-tests.factor similarity index 100% rename from unmaintained/morse/morse-tests.factor rename to extra/morse/morse-tests.factor diff --git a/unmaintained/morse/morse.factor b/extra/morse/morse.factor similarity index 94% rename from unmaintained/morse/morse.factor rename to extra/morse/morse.factor index 2951c96077..54abce9395 100644 --- a/unmaintained/morse/morse.factor +++ b/extra/morse/morse.factor @@ -1,8 +1,8 @@ ! Copyright (C) 2007, 2008 Alex Chapman ! See http://factorcode.org/license.txt for BSD license. -USING: accessors assocs combinators hashtables kernel lists math +USING: accessors ascii assocs combinators hashtables kernel lists math namespaces make openal parser-combinators promises sequences -strings symbols synth synth.buffers unicode.case ; +strings synth synth.buffers unicode.case ; IN: morse ( -- buffer ) half-sample-freq <8bit-mono-buffer> ; @@ -160,7 +160,7 @@ SYMBOLS: source dot-buffer dash-buffer intra-char-gap-buffer letter-gap-buffer ; init-openal 1 gen-sources first source set make-buffers call source get source-play - ] with-scope ; + ] with-scope ; inline : play-char ( ch -- ) [ intra-char-gap ] [ @@ -176,7 +176,7 @@ PRIVATE> : play-as-morse* ( str unit-length -- ) [ [ letter-gap ] [ ch>morse play-char ] interleave - ] swap playing-morse ; + ] swap playing-morse ; inline : play-as-morse ( str -- ) - 0.05 play-as-morse* ; + 0.05 play-as-morse* ; inline diff --git a/unmaintained/morse/summary.txt b/extra/morse/summary.txt similarity index 100% rename from unmaintained/morse/summary.txt rename to extra/morse/summary.txt diff --git a/unmaintained/morse/tags.txt b/extra/morse/tags.txt similarity index 100% rename from unmaintained/morse/tags.txt rename to extra/morse/tags.txt diff --git a/unmaintained/openal/authors.txt b/extra/openal/authors.txt similarity index 100% rename from unmaintained/openal/authors.txt rename to extra/openal/authors.txt diff --git a/unmaintained/openal/backend/authors.txt b/extra/openal/backend/authors.txt similarity index 100% rename from unmaintained/openal/backend/authors.txt rename to extra/openal/backend/authors.txt diff --git a/unmaintained/openal/backend/backend.factor b/extra/openal/backend/backend.factor similarity index 100% rename from unmaintained/openal/backend/backend.factor rename to extra/openal/backend/backend.factor diff --git a/unmaintained/openal/example/authors.txt b/extra/openal/example/authors.txt similarity index 100% rename from unmaintained/openal/example/authors.txt rename to extra/openal/example/authors.txt diff --git a/extra/openal/example/example.factor b/extra/openal/example/example.factor new file mode 100644 index 0000000000..4d979a8fa7 --- /dev/null +++ b/extra/openal/example/example.factor @@ -0,0 +1,33 @@ +! Copyright (C) 2007 Chris Double. +! See http://factorcode.org/license.txt for BSD license. +USING: calendar kernel openal sequences threads ; +IN: openal.example + +: play-hello ( -- ) + init-openal + 1 gen-sources + first dup AL_BUFFER alutCreateBufferHelloWorld set-source-param + source-play + 1000 milliseconds sleep ; + +: (play-file) ( source -- ) + 100 milliseconds sleep + dup source-playing? [ (play-file) ] [ drop ] if ; + +: play-file ( filename -- ) + init-openal + create-buffer-from-file + 1 gen-sources + first dup [ AL_BUFFER rot set-source-param ] dip + dup source-play + check-error + (play-file) ; + +: play-wav ( filename -- ) + init-openal + create-buffer-from-wav + 1 gen-sources + first dup [ AL_BUFFER rot set-source-param ] dip + dup source-play + check-error + (play-file) ; diff --git a/unmaintained/openal/macosx/authors.txt b/extra/openal/macosx/authors.txt similarity index 100% rename from unmaintained/openal/macosx/authors.txt rename to extra/openal/macosx/authors.txt diff --git a/unmaintained/openal/macosx/macosx.factor b/extra/openal/macosx/macosx.factor similarity index 84% rename from unmaintained/openal/macosx/macosx.factor rename to extra/openal/macosx/macosx.factor index abc0d65fb9..81d360eca1 100644 --- a/unmaintained/openal/macosx/macosx.factor +++ b/extra/openal/macosx/macosx.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2007 Chris Double. ! See http://factorcode.org/license.txt for BSD license. USING: alien.c-types kernel alien alien.syntax shuffle -combinators.lib openal.backend namespaces system ; +openal.backend namespaces system generalizations ; IN: openal.macosx LIBRARY: alut @@ -10,5 +10,5 @@ FUNCTION: void alutLoadWAVFile ( ALbyte* fileName, ALenum* format, void** data, M: macosx load-wav-file ( path -- format data size frequency ) 0 f 0 0 - [ alutLoadWAVFile ] 4keep + [ alutLoadWAVFile ] 4 nkeep [ [ [ *int ] dip *void* ] dip *int ] dip *int ; diff --git a/extra/openal/macosx/tags.txt b/extra/openal/macosx/tags.txt new file mode 100644 index 0000000000..6bf68304bb --- /dev/null +++ b/extra/openal/macosx/tags.txt @@ -0,0 +1 @@ +unportable diff --git a/unmaintained/openal/openal.factor b/extra/openal/openal.factor similarity index 96% rename from unmaintained/openal/openal.factor rename to extra/openal/openal.factor index 8533308f26..6e9721b0fe 100644 --- a/unmaintained/openal/openal.factor +++ b/extra/openal/openal.factor @@ -1,8 +1,8 @@ ! Copyright (C) 2007 Chris Double. ! See http://factorcode.org/license.txt for BSD license. -USING: kernel arrays alien system combinators alien.syntax namespaces +USING: kernel accessors arrays alien system combinators alien.syntax namespaces alien.c-types sequences vocabs.loader shuffle - openal.backend specialized-arrays.uint ; + openal.backend specialized-arrays.uint alien.libraries generalizations ; IN: openal << "alut" { @@ -245,13 +245,11 @@ SYMBOL: init f init set-global ] unless ; -: ( n -- byte-array ) "ALuint" ; - : gen-sources ( size -- seq ) - dup 2dup underlying>> alGenSources swap ; + dup [ alGenSources ] keep ; : gen-buffers ( size -- seq ) - dup 2dup underlying>> alGenBuffers swap ; + dup [ alGenBuffers ] keep ; : gen-buffer ( -- buffer ) 1 gen-buffers first ; @@ -264,10 +262,10 @@ os macosx? "openal.macosx" "openal.other" ? require : create-buffer-from-wav ( filename -- buffer ) gen-buffer dup rot load-wav-file - [ alBufferData ] 4keep alutUnloadWAV ; + [ alBufferData ] 4 nkeep alutUnloadWAV ; : queue-buffers ( source buffers -- ) - [ length ] [ >uint-array underlying>> ] bi alSourceQueueBuffers ; + [ length ] [ >uint-array ] bi alSourceQueueBuffers ; : queue-buffer ( source buffer -- ) 1array queue-buffers ; diff --git a/unmaintained/openal/other/authors.txt b/extra/openal/other/authors.txt similarity index 100% rename from unmaintained/openal/other/authors.txt rename to extra/openal/other/authors.txt diff --git a/unmaintained/openal/other/other.factor b/extra/openal/other/other.factor similarity index 60% rename from unmaintained/openal/other/other.factor rename to extra/openal/other/other.factor index d0429fb3c3..0936c94150 100644 --- a/unmaintained/openal/other/other.factor +++ b/extra/openal/other/other.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2007 Chris Double. ! See http://factorcode.org/license.txt for BSD license. -USING: openal.backend alien.c-types kernel alien alien.syntax -shuffle combinators.lib ; +USING: alien.c-types alien.syntax combinators generalizations +kernel openal.backend ; IN: openal.other LIBRARY: alut @@ -9,6 +9,6 @@ LIBRARY: alut FUNCTION: void alutLoadWAVFile ( ALbyte* fileName, ALenum* format, void** data, ALsizei* size, ALsizei* frequency, ALboolean* looping ) ; M: object load-wav-file ( filename -- format data size frequency ) - 0 f 0 0 - [ 0 alutLoadWAVFile ] 4keep - >r >r >r *int r> *void* r> *int r> *int ; + 0 f 0 0 + [ 0 alutLoadWAVFile ] 4 nkeep + { [ *int ] [ *void* ] [ *int ] [ *int ] } spread ; diff --git a/unmaintained/openal/summary.txt b/extra/openal/summary.txt similarity index 100% rename from unmaintained/openal/summary.txt rename to extra/openal/summary.txt diff --git a/unmaintained/openal/tags.txt b/extra/openal/tags.txt similarity index 100% rename from unmaintained/openal/tags.txt rename to extra/openal/tags.txt diff --git a/extra/project-euler/018/018.factor b/extra/project-euler/018/018.factor index a4aded7096..9c7c4fee74 100644 --- a/extra/project-euler/018/018.factor +++ b/extra/project-euler/018/018.factor @@ -66,7 +66,7 @@ IN: project-euler.018 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> diff --git a/extra/project-euler/032/032.factor b/extra/project-euler/032/032.factor index 5ff5234679..64c9ec445e 100755 --- a/extra/project-euler/032/032.factor +++ b/extra/project-euler/032/032.factor @@ -27,7 +27,9 @@ IN: project-euler.032 integer ] map ; + 9 factorial iota [ + 9 permutation [ 1+ ] map 10 digits>integer + ] map ; : 1and4 ( n -- ? ) number>string 1 cut-slice 4 cut-slice diff --git a/extra/project-euler/150/150.factor b/extra/project-euler/150/150.factor index e013e16575..314698534f 100644 --- a/extra/project-euler/150/150.factor +++ b/extra/project-euler/150/150.factor @@ -50,13 +50,13 @@ IN: project-euler.150 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 - diff --git a/extra/synth/authors.txt b/extra/synth/authors.txt new file mode 100644 index 0000000000..e9c193bac7 --- /dev/null +++ b/extra/synth/authors.txt @@ -0,0 +1 @@ +Alex Chapman diff --git a/extra/synth/buffers/authors.txt b/extra/synth/buffers/authors.txt new file mode 100644 index 0000000000..e9c193bac7 --- /dev/null +++ b/extra/synth/buffers/authors.txt @@ -0,0 +1 @@ +Alex Chapman diff --git a/unmaintained/synth/buffers/buffers.factor b/extra/synth/buffers/buffers.factor similarity index 89% rename from unmaintained/synth/buffers/buffers.factor rename to extra/synth/buffers/buffers.factor index b0128ca52a..671ebead63 100644 --- a/unmaintained/synth/buffers/buffers.factor +++ b/extra/synth/buffers/buffers.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2008 Alex Chapman ! See http://factorcode.org/license.txt for BSD license. -USING: accessors alien.c-types combinators kernel locals math math.ranges openal sequences sequences.merged ; +USING: accessors alien.c-types combinators kernel locals math math.ranges openal sequences sequences.merged specialized-arrays.uchar specialized-arrays.short ; IN: synth.buffers TUPLE: buffer sample-freq 8bit? id ; @@ -57,11 +57,11 @@ M: 8bit-stereo-buffer buffer-data M: 16bit-stereo-buffer buffer-data interleaved-stereo-data 16bit-buffer-data ; -: telephone-sample-freq 8000 ; -: half-sample-freq 22050 ; -: cd-sample-freq 44100 ; -: digital-sample-freq 48000 ; -: professional-sample-freq 88200 ; +: telephone-sample-freq ( -- n ) 8000 ; +: half-sample-freq ( -- n ) 22050 ; +: cd-sample-freq ( -- n ) 44100 ; +: digital-sample-freq ( -- n ) 48000 ; +: professional-sample-freq ( -- n ) 88200 ; : send-buffer ( buffer -- buffer ) { diff --git a/extra/synth/example/authors.txt b/extra/synth/example/authors.txt new file mode 100644 index 0000000000..e9c193bac7 --- /dev/null +++ b/extra/synth/example/authors.txt @@ -0,0 +1 @@ +Alex Chapman diff --git a/unmaintained/synth/example/example.factor b/extra/synth/example/example.factor similarity index 100% rename from unmaintained/synth/example/example.factor rename to extra/synth/example/example.factor diff --git a/unmaintained/synth/summary.txt b/extra/synth/summary.txt similarity index 100% rename from unmaintained/synth/summary.txt rename to extra/synth/summary.txt diff --git a/unmaintained/synth/synth.factor b/extra/synth/synth.factor similarity index 100% rename from unmaintained/synth/synth.factor rename to extra/synth/synth.factor diff --git a/extra/advice/advice-docs.factor b/unmaintained/advice/advice-docs.factor similarity index 100% rename from extra/advice/advice-docs.factor rename to unmaintained/advice/advice-docs.factor diff --git a/extra/advice/advice-tests.factor b/unmaintained/advice/advice-tests.factor similarity index 100% rename from extra/advice/advice-tests.factor rename to unmaintained/advice/advice-tests.factor diff --git a/extra/advice/advice.factor b/unmaintained/advice/advice.factor similarity index 100% rename from extra/advice/advice.factor rename to unmaintained/advice/advice.factor diff --git a/extra/advice/authors.txt b/unmaintained/advice/authors.txt similarity index 100% rename from extra/advice/authors.txt rename to unmaintained/advice/authors.txt diff --git a/extra/advice/summary.txt b/unmaintained/advice/summary.txt similarity index 100% rename from extra/advice/summary.txt rename to unmaintained/advice/summary.txt diff --git a/extra/advice/tags.txt b/unmaintained/advice/tags.txt similarity index 100% rename from extra/advice/tags.txt rename to unmaintained/advice/tags.txt diff --git a/unmaintained/openal/example/example.factor b/unmaintained/openal/example/example.factor deleted file mode 100644 index ae0b50afff..0000000000 --- a/unmaintained/openal/example/example.factor +++ /dev/null @@ -1,34 +0,0 @@ -! Copyright (C) 2007 Chris Double. -! See http://factorcode.org/license.txt for BSD license. -! -IN: openal.example -USING: openal kernel alien threads sequences calendar ; - -: play-hello ( -- ) - init-openal - 1 gen-sources - first dup AL_BUFFER alutCreateBufferHelloWorld set-source-param - source-play - 1000 milliseconds sleep ; - -: (play-file) ( source -- ) - 100 milliseconds sleep - dup source-playing? [ (play-file) ] [ drop ] if ; - -: play-file ( filename -- ) - init-openal - create-buffer-from-file - 1 gen-sources - first dup >r AL_BUFFER rot set-source-param r> - dup source-play - check-error - (play-file) ; - -: play-wav ( filename -- ) - init-openal - create-buffer-from-wav - 1 gen-sources - first dup >r AL_BUFFER rot set-source-param r> - dup source-play - check-error - (play-file) ; \ No newline at end of file diff --git a/vm/data_gc.c b/vm/data_gc.c index a91eff6783..2252d07541 100755 --- a/vm/data_gc.c +++ b/vm/data_gc.c @@ -149,20 +149,23 @@ void copy_roots(void) copy_registered_locals(); copy_stack_elements(extra_roots_region,extra_roots); - save_stacks(); - F_CONTEXT *stacks = stack_chain; - - while(stacks) + if(!performing_compaction) { - copy_stack_elements(stacks->datastack_region,stacks->datastack); - copy_stack_elements(stacks->retainstack_region,stacks->retainstack); + save_stacks(); + F_CONTEXT *stacks = stack_chain; - copy_handle(&stacks->catchstack_save); - copy_handle(&stacks->current_callback_save); + while(stacks) + { + copy_stack_elements(stacks->datastack_region,stacks->datastack); + copy_stack_elements(stacks->retainstack_region,stacks->retainstack); - mark_active_blocks(stacks); + copy_handle(&stacks->catchstack_save); + copy_handle(&stacks->current_callback_save); - stacks = stacks->next; + mark_active_blocks(stacks); + + stacks = stacks->next; + } } int i; diff --git a/vm/data_gc.h b/vm/data_gc.h index 354c9398a5..feae26706d 100755 --- a/vm/data_gc.h +++ b/vm/data_gc.h @@ -5,6 +5,7 @@ DLLEXPORT void minor_gc(void); 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 diff --git a/vm/image.c b/vm/image.c index a1987180d0..9cc97df0d9 100755 --- a/vm/image.c +++ b/vm/image.c @@ -187,7 +187,9 @@ void primitive_save_image_and_exit(void) userenv[i] = F; /* do a full GC + code heap compaction */ + performing_compaction = true; compact_code_heap(); + performing_compaction = false; UNREGISTER_C_STRING(path);