diff --git a/TODO.FACTOR.txt b/TODO.FACTOR.txt index 86e5218c39..143a0a3f4a 100644 --- a/TODO.FACTOR.txt +++ b/TODO.FACTOR.txt @@ -1,9 +1,6 @@ + compiler: -- investigate why : foo t or ; doesn't partially evaluate -- investigate why ' doesn't infer - recursive? and tree-contains? should handle vectors -- type inference and recursion flaw - type inference fails with some assembler words; displaced, register and other predicates need to inherit from list not cons, and need stronger branch partial eval @@ -17,6 +14,7 @@ - make see work with union, builtin, predicate - doc comments of generics +- proper ordering for classes + ffi: diff --git a/examples/dejong.factor b/examples/dejong.factor index 2b890b92dd..ecb1967da9 100644 --- a/examples/dejong.factor +++ b/examples/dejong.factor @@ -39,7 +39,7 @@ SYMBOL: d : white ( -- rgb ) HEX: ffffffff ; -: pixel ( #{ x y } color -- ) +: pixel ( #{ x y }# color -- ) >r >r surface get r> >rect r> pixelColor ; : iterate-dejong ( x y -- x y ) diff --git a/examples/factoroids.factor b/examples/factoroids.factor index 0e09903a13..b462e9d59c 100644 --- a/examples/factoroids.factor +++ b/examples/factoroids.factor @@ -163,11 +163,11 @@ C: plasma ( actor dy -- plasma ) : player-fire ( -- ) #! Do nothing if player is dead. player-actor [ - #{ 0 -6 } player-shots cons@ + #{ 0 -6 }# player-shots cons@ ] when* ; : enemy-fire ( actor -- ) - #{ 0 5 } enemy-shots cons@ ; + #{ 0 5 }# enemy-shots cons@ ; ! Background of stars TRAITS: particle diff --git a/examples/infix.factor b/examples/infix.factor index bcdd97ef01..8deaa27314 100644 --- a/examples/infix.factor +++ b/examples/infix.factor @@ -14,7 +14,7 @@ SYMBOL: exprs DEFER: infix : >e exprs get vector-push ; : e> exprs get vector-pop ; -: e@ exprs get dup vector-empty? [ drop f ] [ vector-peek ] ifte ; +: e@ exprs get dup vector-length 0 = [ drop f ] [ vector-peek ] ifte ; : e, ( obj -- ) dup cons? [ [ e, ] each ] [ , ] ifte ; : end ( -- ) exprs get [ e, ] vector-each ; : >postfix ( op -- ) e@ word? [ e> e> -rot 3list ] when >e ; diff --git a/examples/mandel.factor b/examples/mandel.factor index 916b3cd1be..0e2ecf6888 100644 --- a/examples/mandel.factor +++ b/examples/mandel.factor @@ -72,7 +72,7 @@ SYMBOL: center height get 150000 zoom-fact get * / y-inc set nb-iter get max-color min cols set ; -: c ( #{ i j } -- c ) +: c ( #{ i j }# -- c ) >rect >r x-inc get * center get real x-inc get width get 2 / * - + >float r> diff --git a/library/assoc.factor b/library/assoc.factor index ed5001c8b3..6815f6bb6f 100644 --- a/library/assoc.factor +++ b/library/assoc.factor @@ -2,7 +2,7 @@ ! $Id$ ! -! Copyright (C) 2004 Slava Pestov. +! Copyright (C) 2004, 2005 Slava Pestov. ! ! Redistribution and use in source and binary forms, with or without ! modification, are permitted provided that the following conditions are met: @@ -51,7 +51,7 @@ USE: kernel : remove-assoc ( key alist -- alist ) #! Remove all key/value pairs with this key. - [ dupd car = not ] subset nip ; + [ car = not ] subset-with ; : acons ( value key alist -- alist ) #! Adds the key/value pair to the alist. Existing pairs with @@ -83,11 +83,7 @@ USE: kernel : zip ( list list -- list ) #! Make a new list containing pairs of corresponding #! elements from the two given lists. - dup [ - 2uncons zip >r cons r> cons - ] [ - 2drop [ ] - ] ifte ; + dup [ 2uncons zip >r cons r> cons ] [ 2drop [ ] ] ifte ; : unzip ( assoc -- keys values ) #! Split an association list into two lists of keys and diff --git a/library/bootstrap/init.factor b/library/bootstrap/init.factor index bc0854d8aa..c9df175781 100644 --- a/library/bootstrap/init.factor +++ b/library/bootstrap/init.factor @@ -36,7 +36,6 @@ USE: words : boot ( -- ) #! Initialize an interpreter with the basic services. init-namespaces - init-threads init-stdio "HOME" os-env [ "." ] unless* "~" set init-search-path ; diff --git a/library/combinators.factor b/library/combinators.factor index 2c83e2a7c1..1620c6452a 100644 --- a/library/combinators.factor +++ b/library/combinators.factor @@ -56,6 +56,16 @@ IN: kernel #! condition and execute the 'false' quotation. pick [ drop call ] [ nip nip call ] ifte ; inline +: ?ifte ( default cond true false -- ) + #! If cond is true, drop default and apply true + #! quotation to cond. Otherwise, drop cond, and apply false + #! to default. + >r >r dup [ + nip r> r> drop call + ] [ + drop r> drop r> call + ] ifte ; inline + : unless ( cond quot -- ) #! Execute a quotation only when the condition is f. The #! condition is popped off the stack. @@ -72,6 +82,12 @@ IN: kernel #! value than it produces. over [ drop ] [ nip call ] ifte ; inline +: ?unless ( default cond false -- ) + #! If cond is true, drop default and leave cond on the + #! stack. Otherwise, drop default, and apply false + #! quotation to default. + >r dup [ nip r> drop ] [ drop r> call ] ifte ; inline + : when ( cond quot -- ) #! Execute a quotation only when the condition is not f. The #! condition is popped off the stack. @@ -89,31 +105,15 @@ IN: kernel #! value than it produces. dupd [ drop ] ifte ; inline -: forever ( quot -- ) - #! The code is evaluated in an infinite loop. Typically, a - #! continuation is used to escape the infinite loop. - #! - #! This combinator will not compile. - dup slip forever ; - -: ?ifte ( default cond true false -- ) - #! If cond is true, drop default and apply true - #! quotation to cond. Otherwise, drop cond, and apply false - #! to default. - >r >r dup [ - nip r> r> drop call - ] [ - drop r> drop r> call - ] ifte ; inline - : ?when ( default cond true -- ) #! If cond is true, drop default and apply true #! quotation to cond. Otherwise, drop cond, and leave #! default on the stack. >r dup [ nip r> call ] [ r> 2drop ] ifte ; inline -: ?unless ( default cond false -- ) - #! If cond is true, drop default and leave cond on the - #! stack. Otherwise, drop default, and apply false - #! quotation to default. - >r dup [ nip r> drop ] [ drop r> call ] ifte ; inline +: forever ( quot -- ) + #! The code is evaluated in an infinite loop. Typically, a + #! continuation is used to escape the infinite loop. + #! + #! This combinator will not compile. + dup slip forever ; diff --git a/library/cons.factor b/library/cons.factor index 21c5abd1d3..95243bad29 100644 --- a/library/cons.factor +++ b/library/cons.factor @@ -103,7 +103,7 @@ PREDICATE: general-list list ( list -- ? ) : with ( obj quot elt -- obj quot ) #! Utility word for each-with, map-with. - pick pick >r >r swap call r> r> ; + pick pick >r >r swap call r> r> ; inline : each-with ( obj list quot -- ) #! Push each element of a proper list in turn, and apply a @@ -121,3 +121,6 @@ PREDICATE: general-list list ( list -- ? ) ] [ drop ] ifte ; inline + +: subset-with ( obj list quot -- list ) + swap [ with rot ] subset nip nip ; inline diff --git a/library/generic/predicate.factor b/library/generic/predicate.factor index e6426b6cac..8f243576c7 100644 --- a/library/generic/predicate.factor +++ b/library/generic/predicate.factor @@ -2,7 +2,7 @@ ! $Id$ ! -! Copyright (C) 2004 Slava Pestov. +! Copyright (C) 2004, 2005 Slava Pestov. ! ! Redistribution and use in source and binary forms, with or without ! modification, are permitted provided that the following conditions are met: @@ -74,22 +74,17 @@ predicate [ ] "class<" set-word-property : define-predicate ( class predicate definition -- ) - rot "superclass" word-property "predicate" word-property + pick "superclass" word-property "predicate" word-property [ \ dup , append, , [ drop f ] , \ ifte , ] make-list - define-compound ; + define-compound + predicate define-class ; : PREDICATE: ( -- class predicate definition ) #! Followed by a superclass name, then a class name. scan-word CREATE dup intern-symbol dup rot "superclass" set-word-property - dup predicate "metaclass" set-word-property dup predicate-word +! 2dup swap "predicate" set-word-property [ dupd unit "predicate" set-word-property ] keep [ define-predicate ] [ ] ; parsing - -PREDICATE: compound generic ( word -- ? ) - "combination" word-property ; - -PREDICATE: compound promise ( obj -- ? ) - "promise" word-property ; diff --git a/library/lists.factor b/library/lists.factor index 7cab567d56..c7e021ef82 100644 --- a/library/lists.factor +++ b/library/lists.factor @@ -2,7 +2,7 @@ ! $Id$ ! -! Copyright (C) 2003, 2004 Slava Pestov. +! Copyright (C) 2003, 2005 Slava Pestov. ! ! Redistribution and use in source and binary forms, with or without ! modification, are permitted provided that the following conditions are met: @@ -132,7 +132,7 @@ DEFER: tree-contains? : remove ( obj list -- list ) #! Remove all occurrences of the object from the list. - [ dupd = not ] subset nip ; + [ = not ] subset-with ; : length ( list -- length ) 0 swap [ drop 1 + ] each ; diff --git a/library/math/complex.factor b/library/math/complex.factor index 5caf6b9254..fdc482fe03 100644 --- a/library/math/complex.factor +++ b/library/math/complex.factor @@ -35,11 +35,11 @@ USE: kernel-internals USE: math USE: math-internals -GENERIC: real ( #{ re im } -- re ) +GENERIC: real ( #{ re im }# -- re ) M: real real ; M: complex real 0 slot %real ; -GENERIC: imaginary ( #{ re im } -- im ) +GENERIC: imaginary ( #{ re im }# -- im ) M: real imaginary drop 0 ; M: complex imaginary 1 slot %real ; diff --git a/library/math/constants.factor b/library/math/constants.factor index 9b68d43ec6..cc73722929 100644 --- a/library/math/constants.factor +++ b/library/math/constants.factor @@ -28,8 +28,8 @@ IN: math USE: kernel -: i #{ 0 1 } ; inline -: -i #{ 0 -1 } ; inline +: i #{ 0 1 }# ; inline +: -i #{ 0 -1 }# ; inline : inf 1.0 0.0 / ; inline : -inf -1.0 0.0 / ; inline : e 2.7182818284590452354 ; inline diff --git a/library/math/math-combinators.factor b/library/math/math-combinators.factor index 5d61794463..ae666d2136 100644 --- a/library/math/math-combinators.factor +++ b/library/math/math-combinators.factor @@ -54,16 +54,16 @@ USE: kernel : fac ( n -- n! ) 1 swap [ 1 + * ] times* ; -: 2times-succ ( #{ a b } #{ c d } -- z ) - #! Lexicographically add #{ 0 1 } to a complex number. - #! If d + 1 == b, return #{ c+1 0 }. Otherwise, #{ c d+1 }. +: 2times-succ ( #{ a b }# #{ c d }# -- z ) + #! Lexicographically add #{ 0 1 }# to a complex number. + #! If d + 1 == b, return #{ c+1 0 }#. Otherwise, #{ c d+1 }#. 2dup imaginary 1 + swap imaginary = [ nip real 1 + ] [ nip >rect 1 + rect> ] ifte ; inline -: 2times<= ( #{ a b } #{ c d } -- ? ) +: 2times<= ( #{ a b }# #{ c d }# -- ? ) swap real swap real <= ; inline : (2times) ( limit n quot -- ) @@ -73,9 +73,9 @@ USE: kernel rot pick dupd 2times-succ pick 3slip (2times) ] ifte ; inline -: 2times* ( #{ w h } quot -- ) +: 2times* ( #{ w h }# quot -- ) #! Apply a quotation to each pair of complex numbers - #! #{ a b } such that a < w, b < h. + #! #{ a b }# such that a < w, b < h. 0 swap (2times) ; inline : (repeat) ( i n quot -- ) diff --git a/library/sdl/sdl-utils.factor b/library/sdl/sdl-utils.factor index 84ab7c2120..137d6deba1 100644 --- a/library/sdl/sdl-utils.factor +++ b/library/sdl/sdl-utils.factor @@ -68,7 +68,7 @@ SYMBOL: surface : clear-surface ( color -- ) >r surface get 0 0 width get height get r> boxColor ; -: pixel-step ( quot #{ x y } -- ) +: pixel-step ( quot #{ x y }# -- ) tuck >r call >r surface get r> r> >rect rot pixelColor ; inline diff --git a/library/syntax/parse-syntax.factor b/library/syntax/parse-syntax.factor index d20992b784..2853219c64 100644 --- a/library/syntax/parse-syntax.factor +++ b/library/syntax/parse-syntax.factor @@ -55,7 +55,7 @@ USE: unparser ! ( and #! then add "stack-effect" and "documentation" ! properties to the current word if it is set. -! Constants +! Booleans : t t swons ; parsing : f f swons ; parsing @@ -75,6 +75,10 @@ USE: unparser : {{ f ; parsing : }} alist>hash swons ; parsing +! Complex numbers +: #{ f ; parsing +: }# 2unlist swap rect> swons ; parsing + ! Do not execute parsing word : POSTPONE: ( -- ) scan-word swons ; parsing @@ -101,11 +105,13 @@ USE: unparser #! Create a word with no definition. Used for mutually #! recursive words. CREATE drop ; parsing + : FORGET: scan-word forget ; parsing : USE: #! Add vocabulary to search path. scan "use" cons@ ; parsing + : IN: #! Set vocabulary for new definitions. scan dup "use" cons@ "in" set ; parsing @@ -127,14 +133,6 @@ USE: unparser [ parse-string "col" get ] make-string swap "col" set swons ; parsing -: expect ( word -- ) - dup scan = [ drop ] [ "Expected " swap cat2 throw ] ifte ; - -: #{ - #! Complex literal - #{ real imaginary #} - scan str>number scan str>number rect> "}" expect swons ; - parsing - ! Comments : ( #! Stack comment. diff --git a/library/syntax/prettyprint.factor b/library/syntax/prettyprint.factor index 11fd9c179d..0af1918ff5 100644 --- a/library/syntax/prettyprint.factor +++ b/library/syntax/prettyprint.factor @@ -2,7 +2,7 @@ ! $Id$ ! -! Copyright (C) 2003, 2004 Slava Pestov. +! Copyright (C) 2003, 2005 Slava Pestov. ! ! Redistribution and use in source and binary forms, with or without ! modification, are permitted provided that the following conditions are met: diff --git a/library/syntax/unparser.factor b/library/syntax/unparser.factor index e9337af832..f56641ec2c 100644 --- a/library/syntax/unparser.factor +++ b/library/syntax/unparser.factor @@ -98,7 +98,7 @@ M: complex unparse ( num -- str ) real unparse , " " , imaginary unparse , - " }" , + " }#" , ] make-string ; : ch>ascii-escape ( ch -- esc ) diff --git a/library/test/compiler/ifte.factor b/library/test/compiler/ifte.factor index be661b9c8b..8271d18dec 100644 --- a/library/test/compiler/ifte.factor +++ b/library/test/compiler/ifte.factor @@ -37,12 +37,12 @@ USE: math-internals : dead-code-rec t [ - #{ 3 2 } + #{ 3 2 }# ] [ dead-code-rec ] ifte ; compiled -[ #{ 3 2 } ] [ dead-code-rec ] unit-test +[ #{ 3 2 }# ] [ dead-code-rec ] unit-test : one-rec [ f one-rec ] [ "hi" ] ifte ; compiled diff --git a/library/test/compiler/optimizer.factor b/library/test/compiler/optimizer.factor index 7d592684d1..a7a746f661 100644 --- a/library/test/compiler/optimizer.factor +++ b/library/test/compiler/optimizer.factor @@ -9,12 +9,12 @@ USE: lists : foo 1 2 3 ; -! [ [ ] ] [ \ foo word-parameter dataflow kill-set ] unit-test -! -! [ [ [ + ] [ - ] ] ] [ [ 3 4 1 2 > [ + ] [ - ] ifte ] dataflow kill-set ] unit-test -! -! [ [ [ 1 ] [ 2 ] ] ] [ [ [ 1 ] [ 2 ] ifte ] dataflow kill-set ] unit-test -! -! [ [ [ 1 ] [ 2 ] ] ] [ [ t [ 1 ] [ 2 ] ifte ] dataflow kill-set ] unit-test -! -! [ [ t t f ] ] [ [ 1 2 ] [ 1 2 3 ] [ f ] map kill-mask ] unit-test +[ [ ] ] [ \ foo word-parameter dataflow kill-set ] unit-test + +[ [ [ + ] [ - ] ] ] [ [ 3 4 1 2 > [ + ] [ - ] ifte ] dataflow kill-set ] unit-test + +[ [ [ 1 ] [ 2 ] ] ] [ [ [ 1 ] [ 2 ] ifte ] dataflow kill-set ] unit-test + +[ [ [ 1 ] [ 2 ] ] ] [ [ [ 1 ] [ 2 ] ifte ] dataflow kill-set ] unit-test + +[ [ t t f ] ] [ [ 1 2 ] [ 1 2 3 ] [ f ] map kill-mask ] unit-test diff --git a/library/test/hashtables.factor b/library/test/hashtables.factor index c951e54669..cf7648aa5a 100644 --- a/library/test/hashtables.factor +++ b/library/test/hashtables.factor @@ -39,11 +39,11 @@ unit-test 16 "testhash" set -t #{ 2 3 } "testhash" get set-hash +t #{ 2 3 }# "testhash" get set-hash f 100 fac "testhash" get set-hash { } { [ { } ] } "testhash" get set-hash -[ t ] [ #{ 2 3 } "testhash" get hash ] unit-test +[ t ] [ #{ 2 3 }# "testhash" get hash ] unit-test [ f ] [ 100 fac "testhash" get hash* cdr ] unit-test [ { } ] [ { [ { } ] } vector-clone "testhash" get hash* cdr ] unit-test diff --git a/library/test/interpreter.factor b/library/test/interpreter.factor index 19fdcc01c2..52806eaf0f 100644 --- a/library/test/interpreter.factor +++ b/library/test/interpreter.factor @@ -44,8 +44,8 @@ USE: kernel [ "XYZ" "XuZ" = ] test-interpreter ] unit-test -[ { #{ 1 1.5 } { } #{ 1 1.5 } { } } ] [ - [ #{ 1 1.5 } { } 2dup ] test-interpreter +[ { #{ 1 1.5 }# { } #{ 1 1.5 }# { } } ] [ + [ #{ 1 1.5 }# { } 2dup ] test-interpreter ] unit-test [ { 4 } ] [ diff --git a/library/test/lists/combinators.factor b/library/test/lists/combinators.factor index 54e4650b3f..bbf0875e48 100644 --- a/library/test/lists/combinators.factor +++ b/library/test/lists/combinators.factor @@ -40,3 +40,5 @@ USE: strings [ f ] [ [ 1 2 3 ] [ 10 > ] some? ] unit-test [ [ 2 3 4 ] ] [ 1 [ 1 2 3 ] [ + ] map-with ] unit-test + +[ [ 3 ] ] [ 2 [ 1 2 3 ] [ < ] subset-with ] unit-test diff --git a/library/test/lists/namespaces.factor b/library/test/lists/namespaces.factor index 45708b0bd1..190e781399 100644 --- a/library/test/lists/namespaces.factor +++ b/library/test/lists/namespaces.factor @@ -29,9 +29,9 @@ USE: test "x" get ] unit-test -[ [ "xyz" #{ 3 2 } 1/5 [ { } ] ] ] [ +[ [ "xyz" #{ 3 2 }# 1/5 [ { } ] ] ] [ [ "xyz" , "xyz" unique, - #{ 3 2 } , #{ 3 2 } unique, + #{ 3 2 }# , #{ 3 2 }# unique, 1/5 , 1/5 unique, [ { } unique, ] make-list , ] make-list ] unit-test diff --git a/library/test/math/complex.factor b/library/test/math/complex.factor index 0ee0b8bcb7..4e084394d5 100644 --- a/library/test/math/complex.factor +++ b/library/test/math/complex.factor @@ -3,47 +3,47 @@ USE: kernel USE: math USE: test -[ f ] [ #{ 5 12.5 } 5 ] [ = ] test-word -[ t ] [ #{ 1.0 2.0 } #{ 1 2 } ] [ = ] test-word -[ f ] [ #{ 1.0 2.3 } #{ 1 2 } ] [ = ] test-word +[ f ] [ #{ 5 12.5 }# 5 ] [ = ] test-word +[ t ] [ #{ 1.0 2.0 }# #{ 1 2 }# ] [ = ] test-word +[ f ] [ #{ 1.0 2.3 }# #{ 1 2 }# ] [ = ] test-word -[ #{ 2 5 } ] [ 2 5 ] [ rect> ] test-word -[ 2 5 ] [ #{ 2 5 } ] [ >rect ] test-word -[ #{ 1/2 1 } ] [ 1/2 i ] [ + ] test-word -[ #{ 1/2 1 } ] [ i 1/2 ] [ + ] test-word -[ t ] [ #{ 11 64 } #{ 11 64 } ] [ = ] test-word -[ #{ 2 1 } ] [ 2 i ] [ + ] test-word -[ #{ 2 1 } ] [ i 2 ] [ + ] test-word -[ #{ 5 4 } ] [ #{ 2 2 } #{ 3 2 } ] [ + ] test-word -[ 5 ] [ #{ 2 2 } #{ 3 -2 } ] [ + ] test-word -[ #{ 1.0 1 } ] [ 1.0 i ] [ + ] test-word +[ #{ 2 5 }# ] [ 2 5 ] [ rect> ] test-word +[ 2 5 ] [ #{ 2 5 }# ] [ >rect ] test-word +[ #{ 1/2 1 }# ] [ 1/2 i ] [ + ] test-word +[ #{ 1/2 1 }# ] [ i 1/2 ] [ + ] test-word +[ t ] [ #{ 11 64 }# #{ 11 64 }# ] [ = ] test-word +[ #{ 2 1 }# ] [ 2 i ] [ + ] test-word +[ #{ 2 1 }# ] [ i 2 ] [ + ] test-word +[ #{ 5 4 }# ] [ #{ 2 2 }# #{ 3 2 }# ] [ + ] test-word +[ 5 ] [ #{ 2 2 }# #{ 3 -2 }# ] [ + ] test-word +[ #{ 1.0 1 }# ] [ 1.0 i ] [ + ] test-word -[ #{ 1/2 -1 } ] [ 1/2 i ] [ - ] test-word -[ #{ -1/2 1 } ] [ i 1/2 ] [ - ] test-word -[ #{ 1/3 1/4 } ] [ 1 3 / 1 2 / i * + 1 4 / i * ] [ - ] test-word -[ #{ -1/3 -1/4 } ] [ 1 4 / i * 1 3 / 1 2 / i * + ] [ - ] test-word -[ #{ 1/5 1/4 } ] [ #{ 3/5 1/2 } #{ 2/5 1/4 } ] [ - ] test-word -[ 4 ] [ #{ 5 10/3 } #{ 1 10/3 } ] [ - ] test-word -[ #{ 1.0 -1 } ] [ 1.0 i ] [ - ] test-word +[ #{ 1/2 -1 }# ] [ 1/2 i ] [ - ] test-word +[ #{ -1/2 1 }# ] [ i 1/2 ] [ - ] test-word +[ #{ 1/3 1/4 }# ] [ 1 3 / 1 2 / i * + 1 4 / i * ] [ - ] test-word +[ #{ -1/3 -1/4 }# ] [ 1 4 / i * 1 3 / 1 2 / i * + ] [ - ] test-word +[ #{ 1/5 1/4 }# ] [ #{ 3/5 1/2 }# #{ 2/5 1/4 }# ] [ - ] test-word +[ 4 ] [ #{ 5 10/3 }# #{ 1 10/3 }# ] [ - ] test-word +[ #{ 1.0 -1 }# ] [ 1.0 i ] [ - ] test-word -[ #{ 0 1 } ] [ i 1 ] [ * ] test-word -[ #{ 0 1 } ] [ 1 i ] [ * ] test-word -[ #{ 0 1.0 } ] [ 1.0 i ] [ * ] test-word +[ #{ 0 1 }# ] [ i 1 ] [ * ] test-word +[ #{ 0 1 }# ] [ 1 i ] [ * ] test-word +[ #{ 0 1.0 }# ] [ 1.0 i ] [ * ] test-word [ -1 ] [ i i ] [ * ] test-word -[ #{ 0 1 } ] [ 1 i ] [ * ] test-word -[ #{ 0 1 } ] [ i 1 ] [ * ] test-word -[ #{ 0 1/2 } ] [ 1/2 i ] [ * ] test-word -[ #{ 0 1/2 } ] [ i 1/2 ] [ * ] test-word -[ 2 ] [ #{ 1 1 } #{ 1 -1 } ] [ * ] test-word +[ #{ 0 1 }# ] [ 1 i ] [ * ] test-word +[ #{ 0 1 }# ] [ i 1 ] [ * ] test-word +[ #{ 0 1/2 }# ] [ 1/2 i ] [ * ] test-word +[ #{ 0 1/2 }# ] [ i 1/2 ] [ * ] test-word +[ 2 ] [ #{ 1 1 }# #{ 1 -1 }# ] [ * ] test-word [ 1 ] [ i -i ] [ * ] test-word [ -1 ] [ i -i ] [ / ] test-word -[ #{ 0 1 } ] [ 1 -i ] [ / ] test-word -[ t ] [ #{ 12 13 } #{ 13 14 } / #{ 13 14 } * #{ 12 13 } ] [ = ] test-word +[ #{ 0 1 }# ] [ 1 -i ] [ / ] test-word +[ t ] [ #{ 12 13 }# #{ 13 14 }# / #{ 13 14 }# * #{ 12 13 }# ] [ = ] test-word -[ #{ -3 4 } ] [ #{ 3 -4 } ] [ neg ] test-word +[ #{ -3 4 }# ] [ #{ 3 -4 }# ] [ neg ] test-word -[ 5 ] [ #{ 3 4 } abs ] unit-test +[ 5 ] [ #{ 3 4 }# abs ] unit-test [ 5 ] [ -5.0 abs ] unit-test ! Make sure arguments are sane diff --git a/library/test/math/irrational.factor b/library/test/math/irrational.factor index 41daa8b4c6..75985eabd7 100644 --- a/library/test/math/irrational.factor +++ b/library/test/math/irrational.factor @@ -9,7 +9,7 @@ USE: test [ 0.25 ] [ 2 -2 fpow ] unit-test [ 4.0 ] [ 16 sqrt ] unit-test -[ #{ 0 4.0 } ] [ -16 sqrt ] unit-test +[ #{ 0 4.0 }# ] [ -16 sqrt ] unit-test [ 4.0 ] [ 2 2 ^ ] unit-test [ 0.25 ] [ 2 -2 ^ ] unit-test diff --git a/library/test/math/math-combinators.factor b/library/test/math/math-combinators.factor index 6587bdc0bc..dec33d53d1 100644 --- a/library/test/math/math-combinators.factor +++ b/library/test/math/math-combinators.factor @@ -6,15 +6,15 @@ USE: test [ 0 1 2 3 4 ] [ 5 [ ] times* ] unit-test [ ] [ 0 [ ] times* ] unit-test -[ #{ 1 1 } ] [ #{ 2 3 } #{ 1 0 } 2times-succ ] unit-test -[ #{ 1 2 } ] [ #{ 2 3 } #{ 1 1 } 2times-succ ] unit-test -[ #{ 2 0 } ] [ #{ 3 3 } #{ 1 2 } 2times-succ ] unit-test -[ #{ 2 1 } ] [ #{ 3 3 } #{ 2 0 } 2times-succ ] unit-test -[ #{ 2 0 } ] [ #{ 2 2 } #{ 1 1 } 2times-succ ] unit-test +[ #{ 1 1 }# ] [ #{ 2 3 }# #{ 1 0 }# 2times-succ ] unit-test +[ #{ 1 2 }# ] [ #{ 2 3 }# #{ 1 1 }# 2times-succ ] unit-test +[ #{ 2 0 }# ] [ #{ 3 3 }# #{ 1 2 }# 2times-succ ] unit-test +[ #{ 2 1 }# ] [ #{ 3 3 }# #{ 2 0 }# 2times-succ ] unit-test +[ #{ 2 0 }# ] [ #{ 2 2 }# #{ 1 1 }# 2times-succ ] unit-test -[ #{ 0 0 } #{ 0 1 } #{ 1 0 } #{ 1 1 } ] -[ #{ 2 2 } [ ] 2times* ] unit-test +[ #{ 0 0 }# #{ 0 1 }# #{ 1 0 }# #{ 1 1 }# ] +[ #{ 2 2 }# [ ] 2times* ] unit-test -[ #{ 0 0 } #{ 0 1 } #{ 0 2 } #{ 1 0 } #{ 1 1 } #{ 1 2 } - #{ 2 0 } #{ 2 1 } #{ 2 2 } ] -[ #{ 3 3 } [ ] 2times* ] unit-test +[ #{ 0 0 }# #{ 0 1 }# #{ 0 2 }# #{ 1 0 }# #{ 1 1 }# #{ 1 2 }# + #{ 2 0 }# #{ 2 1 }# #{ 2 2 }# ] +[ #{ 3 3 }# [ ] 2times* ] unit-test diff --git a/library/test/parser.factor b/library/test/parser.factor index 3c4fc60ea3..39e0a81d8e 100644 --- a/library/test/parser.factor +++ b/library/test/parser.factor @@ -58,7 +58,7 @@ test-word [ 2 ] [ "[[ 1 2 ]]" parse car cdr ] unit-test [ "hello" ] [ "[[ 1 \"hello\" ]]" parse car cdr ] unit-test -[ #{ 1 2 } ] [ "[[ 1 #{ 1 2 } ]]" parse car cdr ] unit-test +[ #{ 1 2 }# ] [ "[[ 1 #{ 1 2 }# ]]" parse car cdr ] unit-test ! Test EOL comments in multiline strings. [ [ "Hello" ] ] [ "#! This calls until-eol.\n\"Hello\"" parse ] unit-test diff --git a/library/test/unparser.factor b/library/test/unparser.factor index e540ff9dfa..99c12fde8d 100644 --- a/library/test/unparser.factor +++ b/library/test/unparser.factor @@ -26,7 +26,7 @@ test-word [ "f" ] [ f unparse ] unit-test [ "t" ] [ t unparse ] unit-test [ "car" ] [ \ car unparse ] unit-test -[ "#{ 1/2 2/3 }" ] [ #{ 1/2 2/3 } unparse ] unit-test +[ "#{ 1/2 2/3 }#" ] [ #{ 1/2 2/3 }# unparse ] unit-test [ "1267650600228229401496703205376" ] [ 1 100 shift unparse ] unit-test [ ] [ { 1 2 3 } unparse drop ] unit-test diff --git a/library/test/vectors.factor b/library/test/vectors.factor index 909c0d7f8f..33904da9b5 100644 --- a/library/test/vectors.factor +++ b/library/test/vectors.factor @@ -11,7 +11,7 @@ USE: namespaces [ 3 ] [ { t f t } vector-length ] unit-test [ 3 { } vector-nth ] unit-test-fails -[ 3 #{ 1 2 } vector-nth ] unit-test-fails +[ 3 #{ 1 2 }# vector-nth ] unit-test-fails [ "hey" [ 1 2 ] set-vector-length ] unit-test-fails [ "hey" { 1 2 } set-vector-length ] unit-test-fails diff --git a/library/threads.factor b/library/threads.factor index c9d2471ea1..f0b61d50e5 100644 --- a/library/threads.factor +++ b/library/threads.factor @@ -2,7 +2,7 @@ ! $Id$ ! -! Copyright (C) 2004 Slava Pestov. +! Copyright (C) 2004, 2005 Slava Pestov. ! ! Redistribution and use in source and binary forms, with or without ! modification, are permitted provided that the following conditions are met: @@ -35,14 +35,8 @@ USE: namespaces ! Core of the multitasker. Used by io-internals.factor and ! in-thread.factor. -: run-queue ( -- queue ) - 9 getenv ; - -: set-run-queue ( queue -- ) - 9 setenv ; - -: init-threads ( -- ) - f set-run-queue ; +: run-queue ( -- queue ) 9 getenv ; +: set-run-queue ( queue -- ) 9 setenv ; : next-thread ( -- quot ) #! Get and remove the next quotation from the run queue. diff --git a/library/tools/interpreter.factor b/library/tools/interpreter.factor index ae65b3039b..c6a8297c10 100644 --- a/library/tools/interpreter.factor +++ b/library/tools/interpreter.factor @@ -72,7 +72,7 @@ SYMBOL: meta-cf meta-cf get not ; : done? ( -- ? ) - done-cf? meta-r get vector-empty? and ; + done-cf? meta-r get vector-length 0 = and ; ! Callframe. : up ( -- ) diff --git a/library/vectors.factor b/library/vectors.factor index 25c87c0b49..dc8ec5be54 100644 --- a/library/vectors.factor +++ b/library/vectors.factor @@ -66,9 +66,6 @@ BUILTIN: vector 11 #! capacity. dup dup >r set-vector-length r> ; -: vector-empty? ( obj -- ? ) - vector-length 0 = ; - : vector-push ( obj vector -- ) #! Push a value on the end of a vector. dup vector-length swap set-vector-nth ; @@ -165,12 +162,9 @@ M: vector = ( obj vec -- ? ) ] ifte ] ifte ; -: ?vector-nth ( n vec -- obj/f ) - 2dup vector-length >= [ 2drop f ] [ vector-nth ] ifte ; - M: vector hashcode ( vec -- n ) - 0 swap 4 [ - over ?vector-nth hashcode rot bitxor swap + 0 swap dup vector-length 4 min [ + over vector-nth hashcode rot bitxor swap ] times* drop ; : vector-head ( n vector -- list ) diff --git a/library/words.factor b/library/words.factor index 3500233bc3..8530e879eb 100644 --- a/library/words.factor +++ b/library/words.factor @@ -73,6 +73,15 @@ PREDICATE: word primitive ( obj -- ? ) word-primitive 2 > ; PREDICATE: word symbol ( obj -- ? ) word-primitive 2 = ; PREDICATE: word undefined ( obj -- ? ) word-primitive 0 = ; +! These should really be somewhere in library/generic/, but +! during bootstrap, we cannot execute parsing words after they +! are defined by code loaded into the target image. +PREDICATE: compound generic ( word -- ? ) + "combination" word-property ; + +PREDICATE: compound promise ( obj -- ? ) + "promise" word-property ; + : define ( word primitive parameter -- ) pick set-word-parameter over set-word-primitive