From 80c1553a5a6f5cb540d5bdb84ea6445d2d4ce590 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 20 Aug 2005 02:22:15 +0000 Subject: [PATCH] added foldable, flushable declarations in all relevant places --- TODO.FACTOR.txt | 2 - library/bootstrap/primitives.factor | 364 +++++++------- library/collections/arrays.factor | 2 +- library/collections/assoc.factor | 6 - library/collections/cons.factor | 18 +- library/collections/hashtables.factor | 15 +- library/collections/namespaces.factor | 8 +- library/collections/sequence-eq.factor | 2 +- library/collections/sequences-epilogue.factor | 44 +- library/collections/sequences.factor | 29 +- library/collections/slicing.factor | 38 +- library/collections/strings-epilogue.factor | 8 +- library/collections/strings.factor | 6 +- library/collections/vectors-epilogue.factor | 6 +- library/inference/known-words.factor | 458 +++++++++++++++++- library/kernel.factor | 6 +- library/math/integer.factor | 5 +- library/math/math.factor | 2 +- library/math/pow.factor | 2 +- library/math/random.factor | 3 +- library/test/lists/assoc.factor | 4 - 21 files changed, 736 insertions(+), 292 deletions(-) diff --git a/TODO.FACTOR.txt b/TODO.FACTOR.txt index 4860d4299b..f3d54afd2d 100644 --- a/TODO.FACTOR.txt +++ b/TODO.FACTOR.txt @@ -1,6 +1,4 @@ -- fix bootstrap failure - flushing optimization -- add foldable, flushable, inline to all relevant library words - new prettyprinter - limit output to n lines - limit sequences to n elements diff --git a/library/bootstrap/primitives.factor b/library/bootstrap/primitives.factor index 36b589ae1d..720ca33d53 100644 --- a/library/bootstrap/primitives.factor +++ b/library/bootstrap/primitives.factor @@ -26,192 +26,185 @@ vocabularies get [ reveal ] bind -: set-stack-effect ( { vocab word effect } -- ) - 3unseq >r unit search r> dup string? [ - "stack-effect" set-word-prop - ] [ - "infer-effect" set-word-prop - ] ifte ; - -: make-primitive ( { vocab word effect } n -- ) - >r dup 2unseq create r> f define set-stack-effect ; +: make-primitive ( { vocab word } n -- ) + >r 2unseq create r> f define ; { - { "execute" "words" [ [ word ] [ ] ] } - { "call" "kernel" [ [ general-list ] [ ] ] } - { "ifte" "kernel" [ [ object general-list general-list ] [ ] ] } - { "dispatch" "kernel-internals" [ [ fixnum vector ] [ ] ] } - { "cons" "lists" [ [ object object ] [ cons ] ] } - { "" "vectors" [ [ integer ] [ vector ] ] } - { "rehash-string" "strings" [ [ string ] [ ] ] } - { "" "strings" [ [ integer ] [ sbuf ] ] } - { "sbuf>string" "strings" [ [ sbuf ] [ string ] ] } - { ">fixnum" "math" [ [ number ] [ fixnum ] ] } - { ">bignum" "math" [ [ number ] [ bignum ] ] } - { ">float" "math" [ [ number ] [ float ] ] } - { "(fraction>)" "math-internals" [ [ integer integer ] [ rational ] ] } - { "str>float" "parser" [ [ string ] [ float ] ] } - { "(unparse-float)" "unparser" [ [ float ] [ string ] ] } - { "float>bits" "math" [ [ real ] [ integer ] ] } - { "double>bits" "math" [ [ real ] [ integer ] ] } - { "bits>float" "math" [ [ integer ] [ float ] ] } - { "bits>double" "math" [ [ integer ] [ float ] ] } - { "" "math-internals" [ [ real real ] [ number ] ] } - { "fixnum+" "math-internals" [ [ fixnum fixnum ] [ integer ] ] } - { "fixnum-" "math-internals" [ [ fixnum fixnum ] [ integer ] ] } - { "fixnum*" "math-internals" [ [ fixnum fixnum ] [ integer ] ] } - { "fixnum/i" "math-internals" [ [ fixnum fixnum ] [ integer ] ] } - { "fixnum/f" "math-internals" [ [ fixnum fixnum ] [ integer ] ] } - { "fixnum-mod" "math-internals" [ [ fixnum fixnum ] [ fixnum ] ] } - { "fixnum/mod" "math-internals" [ [ fixnum fixnum ] [ integer fixnum ] ] } - { "fixnum-bitand" "math-internals" [ [ fixnum fixnum ] [ fixnum ] ] } - { "fixnum-bitor" "math-internals" [ [ fixnum fixnum ] [ fixnum ] ] } - { "fixnum-bitxor" "math-internals" [ [ fixnum fixnum ] [ fixnum ] ] } - { "fixnum-bitnot" "math-internals" [ [ fixnum ] [ fixnum ] ] } - { "fixnum-shift" "math-internals" [ [ fixnum fixnum ] [ integer ] ] } - { "fixnum<" "math-internals" [ [ fixnum fixnum ] [ boolean ] ] } - { "fixnum<=" "math-internals" [ [ fixnum fixnum ] [ boolean ] ] } - { "fixnum>" "math-internals" [ [ fixnum fixnum ] [ boolean ] ] } - { "fixnum>=" "math-internals" [ [ fixnum fixnum ] [ boolean ] ] } - { "bignum=" "math-internals" [ [ bignum bignum ] [ boolean ] ] } - { "bignum+" "math-internals" [ [ bignum bignum ] [ bignum ] ] } - { "bignum-" "math-internals" [ [ bignum bignum ] [ bignum ] ] } - { "bignum*" "math-internals" [ [ bignum bignum ] [ bignum ] ] } - { "bignum/i" "math-internals" [ [ bignum bignum ] [ bignum ] ] } - { "bignum/f" "math-internals" [ [ bignum bignum ] [ bignum ] ] } - { "bignum-mod" "math-internals" [ [ bignum bignum ] [ bignum ] ] } - { "bignum/mod" "math-internals" [ [ bignum bignum ] [ bignum bignum ] ] } - { "bignum-bitand" "math-internals" [ [ bignum bignum ] [ bignum ] ] } - { "bignum-bitor" "math-internals" [ [ bignum bignum ] [ bignum ] ] } - { "bignum-bitxor" "math-internals" [ [ bignum bignum ] [ bignum ] ] } - { "bignum-bitnot" "math-internals" [ [ bignum ] [ bignum ] ] } - { "bignum-shift" "math-internals" [ [ bignum bignum ] [ bignum ] ] } - { "bignum<" "math-internals" [ [ bignum bignum ] [ boolean ] ] } - { "bignum<=" "math-internals" [ [ bignum bignum ] [ boolean ] ] } - { "bignum>" "math-internals" [ [ bignum bignum ] [ boolean ] ] } - { "bignum>=" "math-internals" [ [ bignum bignum ] [ boolean ] ] } - { "float=" "math-internals" [ [ bignum bignum ] [ boolean ] ] } - { "float+" "math-internals" [ [ float float ] [ float ] ] } - { "float-" "math-internals" [ [ float float ] [ float ] ] } - { "float*" "math-internals" [ [ float float ] [ float ] ] } - { "float/f" "math-internals" [ [ float float ] [ float ] ] } - { "float<" "math-internals" [ [ float float ] [ boolean ] ] } - { "float<=" "math-internals" [ [ float float ] [ boolean ] ] } - { "float>" "math-internals" [ [ float float ] [ boolean ] ] } - { "float>=" "math-internals" [ [ float float ] [ boolean ] ] } - { "facos" "math-internals" [ [ real ] [ float ] ] } - { "fasin" "math-internals" [ [ real ] [ float ] ] } - { "fatan" "math-internals" [ [ real ] [ float ] ] } - { "fatan2" "math-internals" [ [ real real ] [ float ] ] } - { "fcos" "math-internals" [ [ real ] [ float ] ] } - { "fexp" "math-internals" [ [ real ] [ float ] ] } - { "fcosh" "math-internals" [ [ real ] [ float ] ] } - { "flog" "math-internals" [ [ real ] [ float ] ] } - { "fpow" "math-internals" [ [ real real ] [ float ] ] } - { "fsin" "math-internals" [ [ real ] [ float ] ] } - { "fsinh" "math-internals" [ [ real ] [ float ] ] } - { "fsqrt" "math-internals" [ [ real ] [ float ] ] } - { "" "words" [ [ ] [ word ] ] } - { "update-xt" "words" [ [ word ] [ ] ] } - { "compiled?" "words" [ [ word ] [ boolean ] ] } - { "drop" "kernel" [ [ object ] [ ] ] } - { "dup" "kernel" [ [ object ] [ object object ] ] } - { "swap" "kernel" [ [ object object ] [ object object ] ] } - { "over" "kernel" [ [ object object ] [ object object object ] ] } - { "pick" "kernel" [ [ object object object ] [ object object object object ] ] } - { ">r" "kernel" [ [ object ] [ ] ] } - { "r>" "kernel" [ [ ] [ object ] ] } - { "eq?" "kernel" [ [ object object ] [ boolean ] ] } - { "getenv" "kernel-internals" [ [ fixnum ] [ object ] ] } - { "setenv" "kernel-internals" [ [ object fixnum ] [ ] ] } - { "stat" "io" [ [ string ] [ general-list ] ] } - { "(directory)" "io" [ [ string ] [ general-list ] ] } - { "gc" "memory" [ [ fixnum ] [ ] ] } - { "gc-time" "memory" [ [ string ] [ ] ] } - { "save-image" "memory" [ [ string ] [ ] ] } - { "datastack" "kernel" " -- ds " } - { "callstack" "kernel" " -- cs " } - { "set-datastack" "kernel" " ds -- " } - { "set-callstack" "kernel" " cs -- " } - { "exit" "kernel" [ [ integer ] [ ] ] } - { "room" "memory" [ [ ] [ integer integer integer integer general-list ] ] } - { "os-env" "kernel" [ [ string ] [ object ] ] } - { "millis" "kernel" [ [ ] [ integer ] ] } - { "(random-int)" "math" [ [ ] [ integer ] ] } - { "type" "kernel" [ [ object ] [ fixnum ] ] } - { "tag" "kernel-internals" [ [ object ] [ fixnum ] ] } - { "cwd" "io" [ [ ] [ string ] ] } - { "cd" "io" [ [ string ] [ ] ] } - { "compiled-offset" "assembler" [ [ ] [ integer ] ] } - { "set-compiled-offset" "assembler" [ [ integer ] [ ] ] } - { "literal-top" "assembler" [ [ ] [ integer ] ] } - { "set-literal-top" "assembler" [ [ integer ] [ ] ] } - { "address" "memory" [ [ object ] [ integer ] ] } - { "dlopen" "alien" [ [ string ] [ dll ] ] } - { "dlsym" "alien" [ [ string object ] [ integer ] ] } - { "dlclose" "alien" [ [ dll ] [ ] ] } - { "" "alien" [ [ integer ] [ alien ] ] } - { "" "kernel-internals" [ [ integer ] [ byte-array ] ] } - { "" "alien" [ [ integer c-ptr ] [ displaced-alien ] ] } - { "alien-signed-cell" "alien" [ [ c-ptr integer ] [ integer ] ] } - { "set-alien-signed-cell" "alien" [ [ integer c-ptr integer ] [ ] ] } - { "alien-unsigned-cell" "alien" [ [ c-ptr integer ] [ integer ] ] } - { "set-alien-unsigned-cell" "alien" [ [ integer c-ptr integer ] [ ] ] } - { "alien-signed-8" "alien" [ [ c-ptr integer ] [ integer ] ] } - { "set-alien-signed-8" "alien" [ [ integer c-ptr integer ] [ ] ] } - { "alien-unsigned-8" "alien" [ [ c-ptr integer ] [ integer ] ] } - { "set-alien-unsigned-8" "alien" [ [ integer c-ptr integer ] [ ] ] } - { "alien-signed-4" "alien" [ [ c-ptr integer ] [ integer ] ] } - { "set-alien-signed-4" "alien" [ [ integer c-ptr integer ] [ ] ] } - { "alien-unsigned-4" "alien" [ [ c-ptr integer ] [ integer ] ] } - { "set-alien-unsigned-4" "alien" [ [ integer c-ptr integer ] [ ] ] } - { "alien-signed-2" "alien" [ [ c-ptr integer ] [ integer ] ] } - { "set-alien-signed-2" "alien" [ [ integer c-ptr integer ] [ ] ] } - { "alien-unsigned-2" "alien" [ [ c-ptr integer ] [ integer ] ] } - { "set-alien-unsigned-2" "alien" [ [ integer c-ptr integer ] [ ] ] } - { "alien-signed-1" "alien" [ [ c-ptr integer ] [ integer ] ] } - { "set-alien-signed-1" "alien" [ [ integer c-ptr integer ] [ ] ] } - { "alien-unsigned-1" "alien" [ [ c-ptr integer ] [ integer ] ] } - { "set-alien-unsigned-1" "alien" [ [ integer c-ptr integer ] [ ] ] } - { "alien-float" "alien" [ [ c-ptr integer ] [ float ] ] } - { "set-alien-float" "alien" [ [ float c-ptr integer ] [ ] ] } - { "alien-double" "alien" [ [ c-ptr integer ] [ float ] ] } - { "set-alien-double" "alien" [ [ float c-ptr integer ] [ ] ] } - { "alien-c-string" "alien" [ [ c-ptr integer ] [ string ] ] } - { "set-alien-c-string" "alien" [ [ string c-ptr integer ] [ ] ] } - { "throw" "errors" [ [ object ] [ ] ] } - { "string>memory" "kernel-internals" [ [ string integer ] [ ] ] } - { "memory>string" "kernel-internals" [ [ integer integer ] [ string ] ] } - { "alien-address" "alien" [ [ alien ] [ integer ] ] } - { "slot" "kernel-internals" [ [ object fixnum ] [ object ] ] } - { "set-slot" "kernel-internals" [ [ object object fixnum ] [ ] ] } - { "integer-slot" "kernel-internals" [ [ object fixnum ] [ integer ] ] } - { "set-integer-slot" "kernel-internals" [ [ integer object fixnum ] [ ] ] } - { "char-slot" "kernel-internals" [ [ object fixnum ] [ fixnum ] ] } - { "set-char-slot" "kernel-internals" [ [ integer object fixnum ] [ ] ] } - { "resize-array" "kernel-internals" [ [ integer array ] [ array ] ] } - { "resize-string" "strings" [ [ integer string ] [ string ] ] } - { "" "hashtables" [ [ number ] [ hashtable ] ] } - { "" "kernel-internals" [ [ number ] [ array ] ] } - { "" "kernel-internals" [ [ number ] [ tuple ] ] } - { "begin-scan" "memory" [ [ ] [ ] ] } - { "next-object" "memory" [ [ ] [ object ] ] } - { "end-scan" "memory" [ [ ] [ ] ] } - { "size" "memory" [ [ object ] [ fixnum ] ] } - { "die" "kernel" [ [ ] [ ] ] } - { "flush-icache" "assembler" f } - [ "fopen" "io-internals" [ [ string string ] [ alien ] ] ] - { "fgetc" "io-internals" [ [ alien ] [ object ] ] } - { "fwrite" "io-internals" [ [ string alien ] [ ] ] } - { "fflush" "io-internals" [ [ alien ] [ ] ] } - { "fclose" "io-internals" [ [ alien ] [ ] ] } - { "expired?" "alien" [ [ object ] [ boolean ] ] } - { "" "kernel" [ [ object ] [ wrapper ] ] } -} dup length 3 swap [ + ] map-with [ - make-primitive -] 2each + { "execute" "words" } + { "call" "kernel" } + { "ifte" "kernel" } + { "dispatch" "kernel-internals" } + { "cons" "lists" } + { "" "vectors" } + { "rehash-string" "strings" } + { "" "strings" } + { "sbuf>string" "strings" } + { ">fixnum" "math" } + { ">bignum" "math" } + { ">float" "math" } + { "(fraction>)" "math-internals" } + { "str>float" "parser" } + { "(unparse-float)" "unparser" } + { "float>bits" "math" } + { "double>bits" "math" } + { "bits>float" "math" } + { "bits>double" "math" } + { "" "math-internals" } + { "fixnum+" "math-internals" } + { "fixnum-" "math-internals" } + { "fixnum*" "math-internals" } + { "fixnum/i" "math-internals" } + { "fixnum/f" "math-internals" } + { "fixnum-mod" "math-internals" } + { "fixnum/mod" "math-internals" } + { "fixnum-bitand" "math-internals" } + { "fixnum-bitor" "math-internals" } + { "fixnum-bitxor" "math-internals" } + { "fixnum-bitnot" "math-internals" } + { "fixnum-shift" "math-internals" } + { "fixnum<" "math-internals" } + { "fixnum<=" "math-internals" } + { "fixnum>" "math-internals" } + { "fixnum>=" "math-internals" } + { "bignum=" "math-internals" } + { "bignum+" "math-internals" } + { "bignum-" "math-internals" } + { "bignum*" "math-internals" } + { "bignum/i" "math-internals" } + { "bignum/f" "math-internals" } + { "bignum-mod" "math-internals" } + { "bignum/mod" "math-internals" } + { "bignum-bitand" "math-internals" } + { "bignum-bitor" "math-internals" } + { "bignum-bitxor" "math-internals" } + { "bignum-bitnot" "math-internals" } + { "bignum-shift" "math-internals" } + { "bignum<" "math-internals" } + { "bignum<=" "math-internals" } + { "bignum>" "math-internals" } + { "bignum>=" "math-internals" } + { "float=" "math-internals" } + { "float+" "math-internals" } + { "float-" "math-internals" } + { "float*" "math-internals" } + { "float/f" "math-internals" } + { "float<" "math-internals" } + { "float<=" "math-internals" } + { "float>" "math-internals" } + { "float>=" "math-internals" } + { "facos" "math-internals" } + { "fasin" "math-internals" } + { "fatan" "math-internals" } + { "fatan2" "math-internals" } + { "fcos" "math-internals" } + { "fexp" "math-internals" } + { "fcosh" "math-internals" } + { "flog" "math-internals" } + { "fpow" "math-internals" } + { "fsin" "math-internals" } + { "fsinh" "math-internals" } + { "fsqrt" "math-internals" } + { "" "words" } + { "update-xt" "words" } + { "compiled?" "words" } + { "drop" "kernel" } + { "dup" "kernel" } + { "swap" "kernel" } + { "over" "kernel" } + { "pick" "kernel" } + { ">r" "kernel" } + { "r>" "kernel" } + { "eq?" "kernel" } + { "getenv" "kernel-internals" } + { "setenv" "kernel-internals" } + { "stat" "io" } + { "(directory)" "io" } + { "gc" "memory" } + { "gc-time" "memory" } + { "save-image" "memory" } + { "datastack" "kernel" } + { "callstack" "kernel" } + { "set-datastack" "kernel" } + { "set-callstack" "kernel" } + { "exit" "kernel" } + { "room" "memory" } + { "os-env" "kernel" } + { "millis" "kernel" } + { "(random-int)" "math" } + { "type" "kernel" } + { "tag" "kernel-internals" } + { "cwd" "io" } + { "cd" "io" } + { "compiled-offset" "assembler" } + { "set-compiled-offset" "assembler" } + { "literal-top" "assembler" } + { "set-literal-top" "assembler" } + { "address" "memory" } + { "dlopen" "alien" } + { "dlsym" "alien" } + { "dlclose" "alien" } + { "" "alien" } + { "" "kernel-internals" } + { "" "alien" } + { "alien-signed-cell" "alien" } + { "set-alien-signed-cell" "alien" } + { "alien-unsigned-cell" "alien" } + { "set-alien-unsigned-cell" "alien" } + { "alien-signed-8" "alien" } + { "set-alien-signed-8" "alien" } + { "alien-unsigned-8" "alien" } + { "set-alien-unsigned-8" "alien" } + { "alien-signed-4" "alien" } + { "set-alien-signed-4" "alien" } + { "alien-unsigned-4" "alien" } + { "set-alien-unsigned-4" "alien" } + { "alien-signed-2" "alien" } + { "set-alien-signed-2" "alien" } + { "alien-unsigned-2" "alien" } + { "set-alien-unsigned-2" "alien" } + { "alien-signed-1" "alien" } + { "set-alien-signed-1" "alien" } + { "alien-unsigned-1" "alien" } + { "set-alien-unsigned-1" "alien" } + { "alien-float" "alien" } + { "set-alien-float" "alien" } + { "alien-double" "alien" } + { "set-alien-double" "alien" } + { "alien-c-string" "alien" } + { "set-alien-c-string" "alien" } + { "throw" "errors" } + { "string>memory" "kernel-internals" } + { "memory>string" "kernel-internals" } + { "alien-address" "alien" } + { "slot" "kernel-internals" } + { "set-slot" "kernel-internals" } + { "integer-slot" "kernel-internals" } + { "set-integer-slot" "kernel-internals" } + { "char-slot" "kernel-internals" } + { "set-char-slot" "kernel-internals" } + { "resize-array" "kernel-internals" } + { "resize-string" "strings" } + { "" "hashtables" } + { "" "kernel-internals" } + { "" "kernel-internals" } + { "begin-scan" "memory" } + { "next-object" "memory" } + { "end-scan" "memory" } + { "size" "memory" } + { "die" "kernel" } + { "flush-icache" "assembler" } + { "fopen" "io-internals" } + { "fgetc" "io-internals" } + { "fwrite" "io-internals" } + { "fflush" "io-internals" } + { "fclose" "io-internals" } + { "expired?" "alien" } + { "" "kernel" } +} dup length 3 swap [ + ] map-with [ make-primitive ] 2each + +: set-stack-effect ( { vocab word effect } -- ) + 3unseq >r unit search r> "stack-effect" set-word-prop ; -! These need a more descriptive comment. { { "drop" "kernel" " x -- " } { "dup" "kernel" " x -- x x " } @@ -220,6 +213,11 @@ vocabularies get [ { "pick" "kernel" " x y z -- x y z x " } { ">r" "kernel" " x -- r: x " } { "r>" "kernel" " r: x -- x " } + { "datastack" "kernel" " -- ds " } + { "callstack" "kernel" " -- cs " } + { "set-datastack" "kernel" " ds -- " } + { "set-callstack" "kernel" " cs -- " } + { "flush-icache" "assembler" " -- " } } [ set-stack-effect ] each diff --git a/library/collections/arrays.factor b/library/collections/arrays.factor index 5053511705..970e39712d 100644 --- a/library/collections/arrays.factor +++ b/library/collections/arrays.factor @@ -42,4 +42,4 @@ M: byte-array resize resize-array ; #! since you can fool the runtime and corrupt memory by #! specifying an incorrect size. Note that this word is also #! handled specially by the compiler's type inferencer. - [ 2 set-slot ] keep ; + [ 2 set-slot ] keep ; flushable diff --git a/library/collections/assoc.factor b/library/collections/assoc.factor index 2959adb23a..56fd83ce9c 100644 --- a/library/collections/assoc.factor +++ b/library/collections/assoc.factor @@ -2,12 +2,6 @@ ! See http://factor.sf.net/license.txt for BSD license. IN: lists USING: kernel sequences ; -: assoc? ( list -- ? ) - #! Push if the list appears to be an alist. An association - #! list is a list of conses where the car of each cons is a - #! key, and the cdr is a value. - dup list? [ [ cons? ] all? ] [ drop f ] ifte ; - : assoc* ( key alist -- [[ key value ]] ) #! Look up a key/value pair. [ car = ] find-with nip ; diff --git a/library/collections/cons.factor b/library/collections/cons.factor index 9e71d246e3..818185dedd 100644 --- a/library/collections/cons.factor +++ b/library/collections/cons.factor @@ -18,7 +18,7 @@ M: general-list >list ( list -- list ) ; : last ( list -- last ) #! Last cons of a list. - dup cdr cons? [ cdr last ] when ; + dup cdr cons? [ cdr last ] when ; foldable PREDICATE: general-list list ( list -- ? ) #! Proper list test. A proper list is either f, or a cons @@ -28,30 +28,32 @@ PREDICATE: general-list list ( list -- ? ) : uncons ( [[ car cdr ]] -- car cdr ) dup car swap cdr ; inline : unswons ( [[ car cdr ]] -- cdr car ) dup cdr swap car ; inline -: swons ( cdr car -- [[ car cdr ]] ) swap cons ; -: unit ( a -- [ a ] ) f cons ; -: 2list ( a b -- [ a b ] ) unit cons ; -: 2unlist ( [ a b ] -- a b ) uncons car ; +: swons ( cdr car -- [[ car cdr ]] ) swap cons ; inline +: unit ( a -- [ a ] ) f cons ; inline +: 2list ( a b -- [ a b ] ) unit cons ; inline +: 2unlist ( [ a b ] -- a b ) uncons car ; inline : 2car ( cons cons -- car car ) swap car swap car ; inline : 2cdr ( cons cons -- car car ) swap cdr swap cdr ; inline : unpair ( list -- list1 list2 ) [ uncons uncons unpair rot swons >r cons r> ] [ f f ] ifte* ; + flushable : ( -- queue ) #! Make a new functional queue. - [[ [ ] [ ] ]] ; + [[ [ ] [ ] ]] ; foldable : queue-empty? ( queue -- ? ) - uncons or not ; + uncons or not ; foldable : enque ( obj queue -- queue ) - uncons >r cons r> cons ; + uncons >r cons r> cons ; foldable : deque ( queue -- obj queue ) uncons [ uncons swapd cons ] [ reverse uncons f swons ] ifte* ; + foldable M: cons = ( obj cons -- ? ) 2dup eq? [ diff --git a/library/collections/hashtables.factor b/library/collections/hashtables.factor index 984a6d5c75..88b34ea49d 100644 --- a/library/collections/hashtables.factor +++ b/library/collections/hashtables.factor @@ -50,9 +50,9 @@ IN: hashtables : hash* ( key table -- [[ key value ]] ) #! Look up a value in the hashtable. - 2dup (hashcode) swap hash-bucket assoc* ; + 2dup (hashcode) swap hash-bucket assoc* ; flushable -: hash ( key table -- value ) hash* cdr ; +: hash ( key table -- value ) hash* cdr ; flushable : set-hash* ( key hash quot -- ) #! Apply the quotation to yield a new association list. @@ -71,6 +71,7 @@ IN: hashtables : hash>alist ( hash -- alist ) #! Push a list of key/value pairs in a hashtable. [ ] swap [ hash-bucket [ swons ] each ] each-bucket ; + flushable : (set-hash) ( value key hash -- ) dup hash-size+ [ set-assoc ] set-hash* ; @@ -106,13 +107,13 @@ IN: hashtables : alist>hash ( alist -- hash ) dup length 1 max swap - [ unswons pick set-hash ] each ; + [ unswons pick set-hash ] each ; foldable : hash-keys ( hash -- list ) - hash>alist [ car ] map ; + hash>alist [ car ] map ; flushable : hash-values ( hash -- alist ) - hash>alist [ cdr ] map ; + hash>alist [ cdr ] map ; flushable : hash-each ( hash quot -- | quot: [[ k v ]] -- ) swap hash-array [ swap each ] each-with ; inline @@ -134,7 +135,7 @@ IN: hashtables ] [ r> 2drop f ] ifte - ] hash-all-with? ; + ] hash-all-with? ; flushable : hash-subset ( hash quot -- hash | quot: [[ k v ]] -- ? ) >r hash>alist r> subset alist>hash ; inline @@ -174,7 +175,7 @@ M: hashtable hashcode ( hash -- n ) [ pick set-hash ] 2each ; inline : ?hash ( key hash/f -- value/f ) - dup [ hash ] [ 2drop f ] ifte ; + dup [ hash ] [ 2drop f ] ifte ; flushable : ?set-hash ( value key hash/f -- hash ) [ 1 ] unless* [ set-hash ] keep ; diff --git a/library/collections/namespaces.factor b/library/collections/namespaces.factor index e5d9c51747..8e544dbbc9 100644 --- a/library/collections/namespaces.factor +++ b/library/collections/namespaces.factor @@ -30,7 +30,7 @@ strings vectors words ; : namespace ( -- namespace ) #! Push the current namespace. - namestack car ; + namestack car ; inline : >n ( namespace -- n:namespace ) #! Push a namespace on the name stack. @@ -44,7 +44,7 @@ strings vectors words ; : ( -- n ) #! Create a new namespace. - 23 ; + 23 ; flushable : (get) ( var ns -- value ) #! Internal word for searching the namestack. @@ -56,12 +56,12 @@ strings vectors words ; ] ?ifte ] [ 2drop f - ] ifte ; + ] ifte ; flushable : get ( variable -- value ) #! Push the value of a variable by searching the namestack #! from the top down. - namestack (get) ; + namestack (get) ; flushable : set ( value variable -- ) namespace set-hash ; diff --git a/library/collections/sequence-eq.factor b/library/collections/sequence-eq.factor index 049c2e6cdc..073bab0eee 100644 --- a/library/collections/sequence-eq.factor +++ b/library/collections/sequence-eq.factor @@ -23,7 +23,7 @@ UNION: sequence array string sbuf vector ; swap >list swap >list = ] [ 2dup length= [ 0 (sequence=) ] [ 2drop f ] ifte - ] ifte ; + ] ifte ; flushable M: sequence = ( obj seq -- ? ) 2dup eq? [ diff --git a/library/collections/sequences-epilogue.factor b/library/collections/sequences-epilogue.factor index 810d871f7a..6c5b1486b2 100644 --- a/library/collections/sequences-epilogue.factor +++ b/library/collections/sequences-epilogue.factor @@ -108,15 +108,15 @@ M: object empty? ( seq -- ? ) length 0 = ; M: object >list ( seq -- list ) dup length 0 rot (>list) ; -: conjunction ( v -- ? ) [ ] all? ; -: disjunction ( v -- ? ) [ ] contains? ; +: conjunction ( v -- ? ) [ ] all? ; flushable +: disjunction ( v -- ? ) [ ] contains? ; flushable -: index ( obj seq -- n ) [ = ] find-with drop ; -: index* ( obj i seq -- n ) [ = ] find-with* drop ; -: member? ( obj seq -- ? ) [ = ] contains-with? ; -: memq? ( obj seq -- ? ) [ eq? ] contains-with? ; -: remove ( obj list -- list ) [ = not ] subset-with ; -: remq ( obj list -- list ) [ eq? not ] subset-with ; +: index ( obj seq -- n ) [ = ] find-with drop ; flushable +: index* ( obj i seq -- n ) [ = ] find-with* drop ; flushable +: member? ( obj seq -- ? ) [ = ] contains-with? ; flushable +: memq? ( obj seq -- ? ) [ eq? ] contains-with? ; flushable +: remove ( obj list -- list ) [ = not ] subset-with ; flushable +: remq ( obj list -- list ) [ eq? not ] subset-with ; flushable : copy-into ( start to from -- ) dup length [ >r pick r> + pick set-nth ] 2each 2drop ; @@ -128,15 +128,15 @@ M: object >list ( seq -- list ) dup length 0 rot (>list) ; : append ( s1 s2 -- s1+s2 ) #! Outputs a new sequence of the same type as s1. - swap [ swap nappend ] immutable ; + swap [ swap nappend ] immutable ; flushable : add ( seq elt -- seq ) #! Outputs a new sequence of the same type as seq. - swap [ push ] immutable ; + swap [ push ] immutable ; flushable : append3 ( s1 s2 s3 -- s1+s2+s3 ) #! Return a new sequence of the same type as s1. - rot [ [ rot nappend ] keep swap nappend ] immutable ; + rot [ [ rot nappend ] keep swap nappend ] immutable ; flushable : concat ( seq -- seq ) #! Append a sequence of sequences together. The new sequence @@ -144,7 +144,7 @@ M: object >list ( seq -- list ) dup length 0 rot (>list) ; dup empty? [ [ 1024 swap [ dupd nappend ] each ] keep first like - ] unless ; + ] unless ; flushable M: object peek ( sequence -- element ) #! Get value at end of sequence. @@ -160,7 +160,7 @@ M: object peek ( sequence -- element ) : prune ( seq -- seq ) [ dup length swap [ over push-new ] each - ] keep like ; + ] keep like ; flushable : >pop> ( stack -- stack ) dup pop drop ; @@ -172,7 +172,7 @@ M: object peek ( sequence -- element ) dup length swap [ over push 2dup push ] each nip >pop> concat - ] ifte ; + ] ifte ; flushable M: object reverse-slice ( seq -- seq ) ; @@ -180,17 +180,17 @@ M: object reverse ( seq -- seq ) [ ] keep like ; ! Set theoretic operations : seq-intersect ( seq1 seq2 -- seq1/\seq2 ) - [ swap member? ] subset-with ; + [ swap member? ] subset-with ; flushable : seq-diff ( seq1 seq2 -- seq2-seq1 ) - [ swap member? not ] subset-with ; + [ swap member? not ] subset-with ; flushable : seq-union ( seq1 seq2 -- seq1\/seq2 ) - append prune ; + append prune ; flushable : contained? ( seq1 seq2 -- ? ) #! Is every element of seq1 in seq2 - swap [ swap member? ] all-with? ; + swap [ swap member? ] all-with? ; flushable ! Lexicographic comparison : (lexi) ( seq seq i limit -- n ) @@ -202,24 +202,24 @@ M: object reverse ( seq -- seq ) [ ] keep like ; ] [ r> drop - >r 3drop r> ] ifte - ] ifte ; + ] ifte ; flushable : lexi ( s1 s2 -- n ) #! Lexicographically compare two sequences of numbers #! (usually strings). Negative if s1s2. - 0 pick length pick length min (lexi) ; + 0 pick length pick length min (lexi) ; flushable : flip ( seq -- seq ) #! An example illustrates this word best: #! { { 1 2 3 } { 4 5 6 } } ==> { { 1 2 } { 3 4 } { 5 6 } } dup empty? [ dup first length [ swap [ nth ] map-with ] map-with - ] unless ; + ] unless ; flushable : max-length ( seq -- n ) #! Longest sequence length in a sequence of sequences. - 0 [ length max ] reduce ; + 0 [ length max ] reduce ; flushable IN: kernel diff --git a/library/collections/sequences.factor b/library/collections/sequences.factor index a21f81fabe..7b4dd85a1e 100644 --- a/library/collections/sequences.factor +++ b/library/collections/sequences.factor @@ -11,19 +11,18 @@ USING: errors generic kernel math math-internals strings vectors ; ! kernel-internals vocabulary, so don't use them unless you have ! a good reason. -GENERIC: empty? ( sequence -- ? ) -GENERIC: length ( sequence -- n ) -GENERIC: set-length ( n sequence -- ) -GENERIC: nth ( n sequence -- obj ) -GENERIC: set-nth ( value n sequence -- obj ) -GENERIC: thaw ( seq -- mutable-seq ) -GENERIC: like ( seq seq -- seq ) -GENERIC: reverse ( seq -- seq ) -GENERIC: reverse-slice ( seq -- seq ) -GENERIC: peek ( seq -- elt ) -GENERIC: head ( n seq -- seq ) -GENERIC: tail ( n seq -- seq ) -GENERIC: concat ( seq -- seq ) +GENERIC: empty? ( sequence -- ? ) flushable +GENERIC: length ( sequence -- n ) flushable +GENERIC: set-length ( n sequence -- ) flushable +GENERIC: nth ( n sequence -- obj ) flushable +GENERIC: set-nth ( value n sequence -- obj ) flushable +GENERIC: thaw ( seq -- mutable-seq ) flushable +GENERIC: like ( seq seq -- seq ) flushable +GENERIC: reverse ( seq -- seq ) flushable +GENERIC: reverse-slice ( seq -- seq ) flushable +GENERIC: peek ( seq -- elt ) flushable +GENERIC: head ( n seq -- seq ) flushable +GENERIC: tail ( n seq -- seq ) flushable GENERIC: resize ( n seq -- seq ) : immutable ( seq quot -- seq | quot: seq -- ) @@ -56,10 +55,10 @@ G: find ( seq quot -- i elt | quot: elt -- ? ) : 2nth ( s s n -- x x ) tuck swap nth >r swap nth r> ; inline : 2unseq ( { x y } -- x y ) - dup first swap second ; + dup first swap second ; inline : 3unseq ( { x y z } -- x y z ) - dup first over second rot third ; + dup first over second rot third ; inline TUPLE: bounds-error index seq ; : bounds-error throw ; diff --git a/library/collections/slicing.factor b/library/collections/slicing.factor index 264cae583b..ebd81d4a47 100644 --- a/library/collections/slicing.factor +++ b/library/collections/slicing.factor @@ -6,64 +6,64 @@ strings vectors ; : head-slice ( n seq -- slice ) #! n is an index from the start of the sequence. - 0 -rot ; + 0 -rot ; flushable : head-slice* ( n seq -- slice ) #! n is an index from the end of the sequence. - [ length swap - ] keep head-slice ; + [ length swap - ] keep head-slice ; flushable : tail-slice ( n seq -- slice ) #! n is an index from the start of the sequence. - [ length ] keep ; + [ length ] keep ; flushable : tail-slice* ( n seq -- slice ) #! n is an index from the end of the sequence. - [ length swap - ] keep tail-slice ; + [ length swap - ] keep tail-slice ; flushable : subseq ( from to seq -- seq ) #! Makes a new sequence with the same contents and type as #! the slice of another sequence. - [ ] keep like ; + [ ] keep like ; flushable M: object head ( index seq -- seq ) [ head-slice ] keep like ; : head* ( n seq -- seq ) - [ head-slice* ] keep like ; + [ head-slice* ] keep like ; flushable M: object tail ( index seq -- seq ) [ tail-slice ] keep like ; : tail* ( n seq -- seq ) - [ tail-slice* ] keep like ; + [ tail-slice* ] keep like ; flushable : length< ( seq seq -- ? ) - swap length swap length < ; + swap length swap length < ; flushable : head? ( seq begin -- ? ) 2dup length< [ 2drop f ] [ dup length rot head-slice sequence= - ] ifte ; + ] ifte ; flushable : ?head ( seq begin -- str ? ) - 2dup head? [ length swap tail t ] [ drop f ] ifte ; + 2dup head? [ length swap tail t ] [ drop f ] ifte ; flushable : tail? ( seq end -- ? ) 2dup length< [ 2drop f ] [ dup length rot tail-slice* sequence= - ] ifte ; + ] ifte ; flushable : ?tail ( seq end -- seq ? ) - 2dup tail? [ length swap head* t ] [ drop f ] ifte ; + 2dup tail? [ length swap head* t ] [ drop f ] ifte ; flushable : cut ( index seq -- seq seq ) #! Returns 2 sequences, that when concatenated yield the #! original sequence. - [ head ] 2keep tail ; + [ head ] 2keep tail ; flushable : group-advance subseq , >r tuck + swap r> ; @@ -78,7 +78,7 @@ M: object tail ( index seq -- seq ) : group ( n seq -- list ) #! Split a sequence into element chunks. - [ 0 -rot (group) ] make-list ; + [ 0 -rot (group) ] make-list ; flushable : start-step ( subseq seq n -- subseq slice ) pick length dupd + rot ; @@ -92,20 +92,20 @@ M: object tail ( index seq -- seq ) ] [ r> r> 1 + start* ] ifte - ] ifte ; + ] ifte ; flushable : start ( subseq seq -- n ) #! The index of a subsequence in a sequence. - 0 start* ; + 0 start* ; flushable -: subseq? ( subseq seq -- ? ) start -1 > ; +: subseq? ( subseq seq -- ? ) start -1 > ; flushable : split1 ( seq subseq -- before after ) dup pick start dup -1 = [ 2drop f ] [ [ swap length + over tail ] keep rot head swap - ] ifte ; + ] ifte ; flushable : split-next ( index seq subseq -- next ) pick >r dup pick r> start* dup -1 = [ @@ -124,4 +124,4 @@ M: object tail ( index seq -- seq ) : split ( seq subseq -- list ) #! Split the sequence at each occurrence of subseq, and push #! a list of the pieces. - [ 0 -rot (split) ] make-list ; + [ 0 -rot (split) ] make-list ; flushable diff --git a/library/collections/strings-epilogue.factor b/library/collections/strings-epilogue.factor index 6c15b67457..dd5ebc4df4 100644 --- a/library/collections/strings-epilogue.factor +++ b/library/collections/strings-epilogue.factor @@ -12,14 +12,16 @@ sequences strings ; : padding ( string count char -- string ) >r swap length - dup 0 <= [ r> 2drop "" ] [ r> fill ] ifte ; + flushable : pad-left ( string count char -- string ) - pick >r padding r> append ; + pick >r padding r> append ; flushable : pad-right ( string count char -- string ) - pick >r padding r> swap append ; + pick >r padding r> swap append ; flushable -: ch>string ( ch -- str ) 1 [ push ] keep (sbuf>string) ; +: ch>string ( ch -- str ) + 1 [ push ] keep (sbuf>string) ; flushable : >sbuf ( seq -- sbuf ) dup length [ swap nappend ] keep ; inline diff --git a/library/collections/strings.factor b/library/collections/strings.factor index 64ce5d8808..400f0aeb56 100644 --- a/library/collections/strings.factor +++ b/library/collections/strings.factor @@ -5,7 +5,7 @@ USING: generic kernel kernel-internals lists math sequences ; M: string nth ( n str -- ch ) bounds-check char-slot ; -GENERIC: >string ( seq -- string ) +GENERIC: >string ( seq -- string ) flushable M: string >string ; @@ -19,7 +19,7 @@ PREDICATE: integer printable CHAR: \s CHAR: ~ between? ; : quotable? ( ch -- ? ) #! In a string literal, can this character be used without #! escaping? - dup printable? swap "\"\\" member? not and ; + dup printable? swap "\"\\" member? not and ; foldable : url-quotable? ( ch -- ? ) #! In a URL, can this character be used without @@ -27,4 +27,4 @@ PREDICATE: integer printable CHAR: \s CHAR: ~ between? ; dup letter? over LETTER? or over digit? or - swap "/_?." member? or ; + swap "/_?." member? or ; foldable diff --git a/library/collections/vectors-epilogue.factor b/library/collections/vectors-epilogue.factor index 36750cf78a..dcb4a81d37 100644 --- a/library/collections/vectors-epilogue.factor +++ b/library/collections/vectors-epilogue.factor @@ -23,6 +23,6 @@ M: vector like drop >vector ; : (2vector) [ swapd push ] keep (1vector) ; inline : (3vector) [ >r rot r> push ] keep (2vector) ; inline -: 1vector ( x -- { x } ) 1 (1vector) ; -: 2vector ( x y -- { x y } ) 2 (2vector) ; -: 3vector ( x y z -- { x y z } ) 3 (3vector) ; +: 1vector ( x -- { x } ) 1 (1vector) ; flushable +: 2vector ( x y -- { x y } ) 2 (2vector) ; flushable +: 3vector ( x y z -- { x y z } ) 3 (3vector) ; flushable diff --git a/library/inference/known-words.factor b/library/inference/known-words.factor index de99cb50ce..e0970d503a 100644 --- a/library/inference/known-words.factor +++ b/library/inference/known-words.factor @@ -1,7 +1,7 @@ IN: inference -USING: errors generic hashtables interpreter kernel -kernel-internals lists math math-internals parser sequences -vectors words ; +USING: alien assembler errors generic hashtables interpreter io +io-internals kernel kernel-internals lists math math-internals +memory parser sequences strings unparser vectors words ; ! Primitive combinators \ call [ @@ -81,3 +81,455 @@ vectors words ; \ bitnot [ [ integer ] [ integer ] ] "infer-effect" set-word-prop \ real [ [ number ] [ real ] ] "infer-effect" set-word-prop \ imaginary [ [ number ] [ real ] ] "infer-effect" set-word-prop + +! Stack effects for all primitives +\ execute [ [ word ] [ ] ] "infer-effect" set-word-prop + +\ call [ [ general-list ] [ ] ] "infer-effect" set-word-prop + +\ ifte [ [ object general-list general-list ] [ ] ] "infer-effect" set-word-prop + +\ dispatch [ [ fixnum vector ] [ ] ] "infer-effect" set-word-prop + +\ cons [ [ object object ] [ cons ] ] "infer-effect" set-word-prop +\ cons t "foldable" set-word-prop +\ cons t "flushable" set-word-prop + +\ [ [ integer ] [ vector ] ] "infer-effect" set-word-prop +\ t "flushable" set-word-prop + +\ rehash-string [ [ string ] [ ] ] "infer-effect" set-word-prop + +\ [ [ integer ] [ sbuf ] ] "infer-effect" set-word-prop +\ t "flushable" set-word-prop + +\ sbuf>string [ [ sbuf ] [ string ] ] "infer-effect" set-word-prop +\ sbuf>string t "flushable" set-word-prop + +\ >fixnum [ [ number ] [ fixnum ] ] "infer-effect" set-word-prop +\ >fixnum t "flushable" set-word-prop +\ >fixnum t "foldable" set-word-prop + +\ >bignum [ [ number ] [ bignum ] ] "infer-effect" set-word-prop +\ >bignum t "flushable" set-word-prop +\ >bignum t "foldable" set-word-prop + +\ >float [ [ number ] [ float ] ] "infer-effect" set-word-prop +\ >float t "flushable" set-word-prop +\ >float t "foldable" set-word-prop + +\ (fraction>) [ [ integer integer ] [ rational ] ] "infer-effect" set-word-prop +\ (fraction>) t "flushable" set-word-prop +\ (fraction>) t "foldable" set-word-prop + +\ str>float [ [ string ] [ float ] ] "infer-effect" set-word-prop +\ str>float t "flushable" set-word-prop +\ str>float t "foldable" set-word-prop + +\ (unparse-float) [ [ float ] [ string ] ] "infer-effect" set-word-prop +\ (unparse-float) t "flushable" set-word-prop +\ (unparse-float) t "foldable" set-word-prop + +\ float>bits [ [ real ] [ integer ] ] "infer-effect" set-word-prop +\ float>bits t "flushable" set-word-prop +\ float>bits t "foldable" set-word-prop + +\ double>bits [ [ real ] [ integer ] ] "infer-effect" set-word-prop +\ double>bits t "flushable" set-word-prop +\ double>bits t "foldable" set-word-prop + +\ bits>float [ [ integer ] [ float ] ] "infer-effect" set-word-prop +\ bits>float t "flushable" set-word-prop +\ bits>float t "foldable" set-word-prop + +\ bits>double [ [ integer ] [ float ] ] "infer-effect" set-word-prop +\ bits>double t "flushable" set-word-prop +\ bits>double t "foldable" set-word-prop + +\ [ [ real real ] [ number ] ] "infer-effect" set-word-prop +\ t "flushable" set-word-prop +\ t "foldable" set-word-prop + +\ fixnum+ [ [ fixnum fixnum ] [ integer ] ] "infer-effect" set-word-prop +\ fixnum+ t "flushable" set-word-prop +\ fixnum+ t "foldable" set-word-prop + +\ fixnum- [ [ fixnum fixnum ] [ integer ] ] "infer-effect" set-word-prop +\ fixnum- t "flushable" set-word-prop +\ fixnum- t "foldable" set-word-prop + +\ fixnum* [ [ fixnum fixnum ] [ integer ] ] "infer-effect" set-word-prop +\ fixnum* t "flushable" set-word-prop +\ fixnum* t "foldable" set-word-prop + +\ fixnum/i [ [ fixnum fixnum ] [ integer ] ] "infer-effect" set-word-prop +\ fixnum/i t "flushable" set-word-prop +\ fixnum/i t "foldable" set-word-prop + +\ fixnum/f [ [ fixnum fixnum ] [ integer ] ] "infer-effect" set-word-prop +\ fixnum/f t "flushable" set-word-prop +\ fixnum/f t "foldable" set-word-prop + +\ fixnum-mod [ [ fixnum fixnum ] [ fixnum ] ] "infer-effect" set-word-prop +\ fixnum-mod t "flushable" set-word-prop +\ fixnum-mod t "foldable" set-word-prop + +\ fixnum/mod [ [ fixnum fixnum ] [ integer fixnum ] ] "infer-effect" set-word-prop +\ fixnum/mod t "flushable" set-word-prop +\ fixnum/mod t "foldable" set-word-prop + +\ fixnum-bitand [ [ fixnum fixnum ] [ fixnum ] ] "infer-effect" set-word-prop +\ fixnum-bitand t "flushable" set-word-prop +\ fixnum-bitand t "foldable" set-word-prop + +\ fixnum-bitor [ [ fixnum fixnum ] [ fixnum ] ] "infer-effect" set-word-prop +\ fixnum-bitor t "flushable" set-word-prop +\ fixnum-bitor t "foldable" set-word-prop + +\ fixnum-bitxor [ [ fixnum fixnum ] [ fixnum ] ] "infer-effect" set-word-prop +\ fixnum-bitxor t "flushable" set-word-prop +\ fixnum-bitxor t "foldable" set-word-prop + +\ fixnum-bitnot [ [ fixnum ] [ fixnum ] ] "infer-effect" set-word-prop +\ fixnum-bitnot t "flushable" set-word-prop +\ fixnum-bitnot t "foldable" set-word-prop + +\ fixnum-shift [ [ fixnum fixnum ] [ integer ] ] "infer-effect" set-word-prop +\ fixnum-shift t "flushable" set-word-prop +\ fixnum-shift t "foldable" set-word-prop + +\ fixnum< [ [ fixnum fixnum ] [ boolean ] ] "infer-effect" set-word-prop +\ fixnum< t "flushable" set-word-prop +\ fixnum< t "foldable" set-word-prop + +\ fixnum<= [ [ fixnum fixnum ] [ boolean ] ] "infer-effect" set-word-prop +\ fixnum<= t "flushable" set-word-prop +\ fixnum<= t "foldable" set-word-prop + +\ fixnum> [ [ fixnum fixnum ] [ boolean ] ] "infer-effect" set-word-prop +\ fixnum> t "flushable" set-word-prop +\ fixnum> t "foldable" set-word-prop + +\ fixnum>= [ [ fixnum fixnum ] [ boolean ] ] "infer-effect" set-word-prop +\ fixnum>= t "flushable" set-word-prop +\ fixnum>= t "foldable" set-word-prop + +\ bignum= [ [ bignum bignum ] [ boolean ] ] "infer-effect" set-word-prop +\ bignum= t "flushable" set-word-prop +\ bignum= t "foldable" set-word-prop + +\ bignum+ [ [ bignum bignum ] [ bignum ] ] "infer-effect" set-word-prop +\ bignum+ t "flushable" set-word-prop +\ bignum+ t "foldable" set-word-prop + +\ bignum- [ [ bignum bignum ] [ bignum ] ] "infer-effect" set-word-prop +\ bignum- t "flushable" set-word-prop +\ bignum- t "foldable" set-word-prop + +\ bignum* [ [ bignum bignum ] [ bignum ] ] "infer-effect" set-word-prop +\ bignum* t "flushable" set-word-prop +\ bignum* t "foldable" set-word-prop + +\ bignum/i [ [ bignum bignum ] [ bignum ] ] "infer-effect" set-word-prop +\ bignum/i t "flushable" set-word-prop +\ bignum/i t "foldable" set-word-prop + +\ bignum/f [ [ bignum bignum ] [ bignum ] ] "infer-effect" set-word-prop +\ bignum/f t "flushable" set-word-prop +\ bignum/f t "foldable" set-word-prop + +\ bignum-mod [ [ bignum bignum ] [ bignum ] ] "infer-effect" set-word-prop +\ bignum-mod t "flushable" set-word-prop +\ bignum-mod t "foldable" set-word-prop + +\ bignum/mod [ [ bignum bignum ] [ bignum bignum ] ] "infer-effect" set-word-prop +\ bignum/mod t "flushable" set-word-prop +\ bignum/mod t "foldable" set-word-prop + +\ bignum-bitand [ [ bignum bignum ] [ bignum ] ] "infer-effect" set-word-prop +\ bignum-bitand t "flushable" set-word-prop +\ bignum-bitand t "foldable" set-word-prop + +\ bignum-bitor [ [ bignum bignum ] [ bignum ] ] "infer-effect" set-word-prop +\ bignum-bitor t "flushable" set-word-prop +\ bignum-bitor t "foldable" set-word-prop + +\ bignum-bitxor [ [ bignum bignum ] [ bignum ] ] "infer-effect" set-word-prop +\ bignum-bitxor t "flushable" set-word-prop +\ bignum-bitxor t "foldable" set-word-prop + +\ bignum-bitnot [ [ bignum ] [ bignum ] ] "infer-effect" set-word-prop +\ bignum-bitnot t "flushable" set-word-prop +\ bignum-bitnot t "foldable" set-word-prop + +\ bignum-shift [ [ bignum bignum ] [ bignum ] ] "infer-effect" set-word-prop +\ bignum-shift t "flushable" set-word-prop +\ bignum-shift t "foldable" set-word-prop + +\ bignum< [ [ bignum bignum ] [ boolean ] ] "infer-effect" set-word-prop +\ bignum< t "flushable" set-word-prop +\ bignum< t "foldable" set-word-prop + +\ bignum<= [ [ bignum bignum ] [ boolean ] ] "infer-effect" set-word-prop +\ bignum<= t "flushable" set-word-prop +\ bignum<= t "foldable" set-word-prop + +\ bignum> [ [ bignum bignum ] [ boolean ] ] "infer-effect" set-word-prop +\ bignum> t "flushable" set-word-prop +\ bignum> t "foldable" set-word-prop + +\ bignum>= [ [ bignum bignum ] [ boolean ] ] "infer-effect" set-word-prop +\ bignum>= t "flushable" set-word-prop +\ bignum>= t "foldable" set-word-prop + +\ float= [ [ bignum bignum ] [ boolean ] ] "infer-effect" set-word-prop +\ float= t "flushable" set-word-prop +\ float= t "foldable" set-word-prop + +\ float+ [ [ float float ] [ float ] ] "infer-effect" set-word-prop +\ float+ t "flushable" set-word-prop +\ float+ t "foldable" set-word-prop + +\ float- [ [ float float ] [ float ] ] "infer-effect" set-word-prop +\ float- t "flushable" set-word-prop +\ float- t "foldable" set-word-prop + +\ float* [ [ float float ] [ float ] ] "infer-effect" set-word-prop +\ float* t "flushable" set-word-prop +\ float* t "foldable" set-word-prop + +\ float/f [ [ float float ] [ float ] ] "infer-effect" set-word-prop +\ float/f t "flushable" set-word-prop +\ float/f t "foldable" set-word-prop + +\ float< [ [ float float ] [ boolean ] ] "infer-effect" set-word-prop +\ float< t "flushable" set-word-prop +\ float< t "foldable" set-word-prop + +\ float<= [ [ float float ] [ boolean ] ] "infer-effect" set-word-prop +\ float<= t "flushable" set-word-prop +\ float<= t "foldable" set-word-prop + +\ float> [ [ float float ] [ boolean ] ] "infer-effect" set-word-prop +\ float> t "flushable" set-word-prop +\ float> t "foldable" set-word-prop + +\ float>= [ [ float float ] [ boolean ] ] "infer-effect" set-word-prop +\ float>= t "flushable" set-word-prop +\ float>= t "foldable" set-word-prop + +\ facos [ [ real ] [ float ] ] "infer-effect" set-word-prop +\ facos t "flushable" set-word-prop +\ facos t "foldable" set-word-prop + +\ fasin [ [ real ] [ float ] ] "infer-effect" set-word-prop +\ fasin t "flushable" set-word-prop +\ fasin t "foldable" set-word-prop + +\ fatan [ [ real ] [ float ] ] "infer-effect" set-word-prop +\ fatan t "flushable" set-word-prop +\ fatan t "foldable" set-word-prop + +\ fatan2 [ [ real real ] [ float ] ] "infer-effect" set-word-prop +\ fatan2 t "flushable" set-word-prop +\ fatan2 t "foldable" set-word-prop + +\ fcos [ [ real ] [ float ] ] "infer-effect" set-word-prop +\ fcos t "flushable" set-word-prop +\ fcos t "foldable" set-word-prop + +\ fexp [ [ real ] [ float ] ] "infer-effect" set-word-prop +\ fexp t "flushable" set-word-prop +\ fexp t "foldable" set-word-prop + +\ fcosh [ [ real ] [ float ] ] "infer-effect" set-word-prop +\ fcosh t "flushable" set-word-prop +\ fcosh t "foldable" set-word-prop + +\ flog [ [ real ] [ float ] ] "infer-effect" set-word-prop +\ flog t "flushable" set-word-prop +\ flog t "foldable" set-word-prop + +\ fpow [ [ real real ] [ float ] ] "infer-effect" set-word-prop +\ fpow t "flushable" set-word-prop +\ fpow t "foldable" set-word-prop + +\ fsin [ [ real ] [ float ] ] "infer-effect" set-word-prop +\ fsin t "flushable" set-word-prop +\ fsin t "foldable" set-word-prop + +\ fsinh [ [ real ] [ float ] ] "infer-effect" set-word-prop +\ fsinh t "flushable" set-word-prop +\ fsinh t "foldable" set-word-prop + +\ fsqrt [ [ real ] [ float ] ] "infer-effect" set-word-prop +\ fsqrt t "flushable" set-word-prop +\ fsqrt t "foldable" set-word-prop + +\ [ [ ] [ word ] ] "infer-effect" set-word-prop +\ t "flushable" set-word-prop + +\ update-xt [ [ word ] [ ] ] "infer-effect" set-word-prop +\ compiled? [ [ word ] [ boolean ] ] "infer-effect" set-word-prop +\ drop [ [ object ] [ ] ] "infer-effect" set-word-prop +\ dup [ [ object ] [ object object ] ] "infer-effect" set-word-prop +\ swap [ [ object object ] [ object object ] ] "infer-effect" set-word-prop +\ over [ [ object object ] [ object object object ] ] "infer-effect" set-word-prop +\ pick [ [ object object object ] [ object object object object ] ] "infer-effect" set-word-prop +\ >r [ [ object ] [ ] ] "infer-effect" set-word-prop +\ r> [ [ ] [ object ] ] "infer-effect" set-word-prop + +\ eq? [ [ object object ] [ boolean ] ] "infer-effect" set-word-prop +\ eq? t "flushable" set-word-prop +\ eq? t "foldable" set-word-prop + +\ getenv [ [ fixnum ] [ object ] ] "infer-effect" set-word-prop +\ setenv [ [ object fixnum ] [ ] ] "infer-effect" set-word-prop +\ stat [ [ string ] [ general-list ] ] "infer-effect" set-word-prop +\ (directory) [ [ string ] [ general-list ] ] "infer-effect" set-word-prop +\ gc [ [ fixnum ] [ ] ] "infer-effect" set-word-prop +\ gc-time [ [ string ] [ ] ] "infer-effect" set-word-prop +\ save-image [ [ string ] [ ] ] "infer-effect" set-word-prop +\ exit [ [ integer ] [ ] ] "infer-effect" set-word-prop +\ room [ [ ] [ integer integer integer integer general-list ] ] "infer-effect" set-word-prop +\ os-env [ [ string ] [ object ] ] "infer-effect" set-word-prop +\ millis [ [ ] [ integer ] ] "infer-effect" set-word-prop +\ (random-int) [ [ ] [ integer ] ] "infer-effect" set-word-prop +\ type [ [ object ] [ fixnum ] ] "infer-effect" set-word-prop +\ type t "flushable" set-word-prop +\ type t "foldable" set-word-prop + +\ tag [ [ object ] [ fixnum ] ] "infer-effect" set-word-prop +\ tag t "flushable" set-word-prop +\ tag t "foldable" set-word-prop + +\ cwd [ [ ] [ string ] ] "infer-effect" set-word-prop +\ cd [ [ string ] [ ] ] "infer-effect" set-word-prop + +\ compiled-offset [ [ ] [ integer ] ] "infer-effect" set-word-prop +\ compiled-offset t "flushable" set-word-prop + +\ set-compiled-offset [ [ integer ] [ ] ] "infer-effect" set-word-prop + +\ literal-top [ [ ] [ integer ] ] "infer-effect" set-word-prop +\ literal-top t "flushable" set-word-prop + +\ set-literal-top [ [ integer ] [ ] ] "infer-effect" set-word-prop + +\ address [ [ object ] [ integer ] ] "infer-effect" set-word-prop +\ address t "flushable" set-word-prop + +\ dlopen [ [ string ] [ dll ] ] "infer-effect" set-word-prop +\ dlsym [ [ string object ] [ integer ] ] "infer-effect" set-word-prop +\ dlclose [ [ dll ] [ ] ] "infer-effect" set-word-prop + +\ [ [ integer ] [ alien ] ] "infer-effect" set-word-prop +\ t "flushable" set-word-prop + +\ [ [ integer ] [ byte-array ] ] "infer-effect" set-word-prop +\ t "flushable" set-word-prop + +\ [ [ integer c-ptr ] [ displaced-alien ] ] "infer-effect" set-word-prop +\ t "flushable" set-word-prop + +\ alien-signed-cell [ [ c-ptr integer ] [ integer ] ] "infer-effect" set-word-prop +\ alien-signed-cell t "flushable" set-word-prop + +\ set-alien-signed-cell [ [ integer c-ptr integer ] [ ] ] "infer-effect" set-word-prop +\ alien-unsigned-cell [ [ c-ptr integer ] [ integer ] ] "infer-effect" set-word-prop +\ alien-unsigned-cell t "flushable" set-word-prop + +\ set-alien-unsigned-cell [ [ integer c-ptr integer ] [ ] ] "infer-effect" set-word-prop +\ alien-signed-8 [ [ c-ptr integer ] [ integer ] ] "infer-effect" set-word-prop +\ alien-signed-8 t "flushable" set-word-prop + +\ set-alien-signed-8 [ [ integer c-ptr integer ] [ ] ] "infer-effect" set-word-prop +\ alien-unsigned-8 [ [ c-ptr integer ] [ integer ] ] "infer-effect" set-word-prop +\ alien-unsigned-8 t "flushable" set-word-prop + +\ set-alien-unsigned-8 [ [ integer c-ptr integer ] [ ] ] "infer-effect" set-word-prop +\ alien-signed-4 [ [ c-ptr integer ] [ integer ] ] "infer-effect" set-word-prop +\ alien-signed-4 t "flushable" set-word-prop + +\ set-alien-signed-4 [ [ integer c-ptr integer ] [ ] ] "infer-effect" set-word-prop +\ alien-unsigned-4 [ [ c-ptr integer ] [ integer ] ] "infer-effect" set-word-prop +\ alien-unsigned-4 t "flushable" set-word-prop + +\ set-alien-unsigned-4 [ [ integer c-ptr integer ] [ ] ] "infer-effect" set-word-prop +\ alien-signed-2 [ [ c-ptr integer ] [ integer ] ] "infer-effect" set-word-prop +\ alien-signed-2 t "flushable" set-word-prop + +\ set-alien-signed-2 [ [ integer c-ptr integer ] [ ] ] "infer-effect" set-word-prop +\ alien-unsigned-2 [ [ c-ptr integer ] [ integer ] ] "infer-effect" set-word-prop +\ alien-unsigned-2 t "flushable" set-word-prop + +\ set-alien-unsigned-2 [ [ integer c-ptr integer ] [ ] ] "infer-effect" set-word-prop +\ alien-signed-1 [ [ c-ptr integer ] [ integer ] ] "infer-effect" set-word-prop +\ alien-signed-1 t "flushable" set-word-prop + +\ set-alien-signed-1 [ [ integer c-ptr integer ] [ ] ] "infer-effect" set-word-prop +\ alien-unsigned-1 [ [ c-ptr integer ] [ integer ] ] "infer-effect" set-word-prop +\ alien-unsigned-1 t "flushable" set-word-prop + +\ set-alien-unsigned-1 [ [ integer c-ptr integer ] [ ] ] "infer-effect" set-word-prop +\ alien-float [ [ c-ptr integer ] [ float ] ] "infer-effect" set-word-prop +\ alien-float t "flushable" set-word-prop + +\ set-alien-float [ [ float c-ptr integer ] [ ] ] "infer-effect" set-word-prop +\ alien-double [ [ c-ptr integer ] [ float ] ] "infer-effect" set-word-prop +\ alien-double t "flushable" set-word-prop + +\ set-alien-double [ [ float c-ptr integer ] [ ] ] "infer-effect" set-word-prop +\ alien-c-string [ [ c-ptr integer ] [ string ] ] "infer-effect" set-word-prop +\ alien-c-string t "flushable" set-word-prop + +\ set-alien-c-string [ [ string c-ptr integer ] [ ] ] "infer-effect" set-word-prop +\ throw [ [ object ] [ ] ] "infer-effect" set-word-prop +\ string>memory [ [ string integer ] [ ] ] "infer-effect" set-word-prop +\ memory>string [ [ integer integer ] [ string ] ] "infer-effect" set-word-prop +\ alien-address [ [ alien ] [ integer ] ] "infer-effect" set-word-prop + +\ slot [ [ object fixnum ] [ object ] ] "infer-effect" set-word-prop +\ slot t "flushable" set-word-prop + +\ set-slot [ [ object object fixnum ] [ ] ] "infer-effect" set-word-prop + +\ integer-slot [ [ object fixnum ] [ integer ] ] "infer-effect" set-word-prop +\ integer-slot t "flushable" set-word-prop + +\ set-integer-slot [ [ integer object fixnum ] [ ] ] "infer-effect" set-word-prop + +\ char-slot [ [ object fixnum ] [ fixnum ] ] "infer-effect" set-word-prop +\ char-slot t "flushable" set-word-prop + +\ set-char-slot [ [ integer object fixnum ] [ ] ] "infer-effect" set-word-prop +\ resize-array [ [ integer array ] [ array ] ] "infer-effect" set-word-prop +\ resize-string [ [ integer string ] [ string ] ] "infer-effect" set-word-prop + +\ [ [ number ] [ hashtable ] ] "infer-effect" set-word-prop +\ t "flushable" set-word-prop + +\ [ [ number ] [ array ] ] "infer-effect" set-word-prop +\ t "flushable" set-word-prop + +\ [ [ number ] [ tuple ] ] "infer-effect" set-word-prop +\ t "flushable" set-word-prop + +\ begin-scan [ [ ] [ ] ] "infer-effect" set-word-prop +\ next-object [ [ ] [ object ] ] "infer-effect" set-word-prop +\ end-scan [ [ ] [ ] ] "infer-effect" set-word-prop + +\ size [ [ object ] [ fixnum ] ] "infer-effect" set-word-prop +\ size t "flushable" set-word-prop + +\ die [ [ ] [ ] ] "infer-effect" set-word-prop +\ fopen [ [ string string ] [ alien ] ] "infer-effect" set-word-prop +\ fgetc [ [ alien ] [ object ] ] "infer-effect" set-word-prop +\ fwrite [ [ string alien ] [ ] ] "infer-effect" set-word-prop +\ fflush [ [ alien ] [ ] ] "infer-effect" set-word-prop +\ fclose [ [ alien ] [ ] ] "infer-effect" set-word-prop +\ expired? [ [ object ] [ boolean ] ] "infer-effect" set-word-prop + +\ [ [ object ] [ wrapper ] ] "infer-effect" set-word-prop +\ t "flushable" set-word-prop +\ t "foldable" set-word-prop diff --git a/library/kernel.factor b/library/kernel.factor index d47c23ff43..dd686b87c9 100644 --- a/library/kernel.factor +++ b/library/kernel.factor @@ -25,13 +25,13 @@ USING: generic kernel-internals vectors ; UNION: boolean POSTPONE: f POSTPONE: t ; COMPLEMENT: general-t f -GENERIC: hashcode ( obj -- n ) +GENERIC: hashcode ( obj -- n ) flushable M: object hashcode drop 0 ; -GENERIC: = ( obj obj -- ? ) +GENERIC: = ( obj obj -- ? ) flushable M: object = eq? ; -GENERIC: clone ( obj -- obj ) +GENERIC: clone ( obj -- obj ) flushable M: object clone ; : set-boot ( quot -- ) diff --git a/library/math/integer.factor b/library/math/integer.factor index 391d936aa3..e89514e0b2 100644 --- a/library/math/integer.factor +++ b/library/math/integer.factor @@ -15,16 +15,17 @@ UNION: integer fixnum bignum ; : gcd ( x y -- a d ) #! Compute the greatest common divisor d and multiplier a #! such that a*x=d mod y. - swap 0 1 2swap (gcd) abs ; + swap 0 1 2swap (gcd) abs ; foldable : mod-inv ( x n -- y ) #! Compute the multiplicative inverse of x mod n. - gcd 1 = [ "Non-trivial divisor found" throw ] unless ; + gcd 1 = [ "Non-trivial divisor found" throw ] unless ; foldable : bitroll ( n s w -- n ) #! Roll n by s bits to the right, wrapping around after #! w bits. [ mod shift ] 3keep over 0 >= [ - ] [ + ] ifte shift bitor ; + foldable IN: math-internals diff --git a/library/math/math.factor b/library/math/math.factor index b71e899f49..4e575e4d33 100644 --- a/library/math/math.factor +++ b/library/math/math.factor @@ -52,7 +52,7 @@ GENERIC: ceiling ( n -- n ) foldable : sgn ( n -- -1/0/1 ) #! Push the sign of a real number. - dup 0 = [ drop 0 ] [ 1 < -1 1 ? ] ifte ; inline + dup 0 = [ drop 0 ] [ 1 < -1 1 ? ] ifte ; foldable GENERIC: abs ( z -- |z| ) diff --git a/library/math/pow.factor b/library/math/pow.factor index cd174e2c8c..172eb67a82 100644 --- a/library/math/pow.factor +++ b/library/math/pow.factor @@ -14,7 +14,7 @@ USING: errors kernel math math-internals ; drop fsqrt 0 swap rect> ] [ swap fsqrt swap 2 / polar> - ] ifte ; + ] ifte ; foldable : norm ( vec -- n ) norm-sq sqrt ; diff --git a/library/math/random.factor b/library/math/random.factor index 3341d1b06c..e9e642ed7c 100644 --- a/library/math/random.factor +++ b/library/math/random.factor @@ -16,4 +16,5 @@ IN: math USING: kernel ; (random-int) 2dup swap mod (random-int-0) ] ifte ; inline -: random-int ( min max -- n ) dupd swap - random-int-0 + ; +: random-int ( min max -- n ) + dupd swap - random-int-0 + ; flushable diff --git a/library/test/lists/assoc.factor b/library/test/lists/assoc.factor index 292ff9a5c4..5a7f85de0e 100644 --- a/library/test/lists/assoc.factor +++ b/library/test/lists/assoc.factor @@ -13,10 +13,6 @@ USE: test [[ [ 1 2 ] [ 2 1 ] ]] ] "assoc" set -[ t ] [ "assoc" get assoc? ] unit-test -[ f ] [ [[ 1 [[ 2 [[ 3 4 ]] ]] ]] assoc? ] unit-test -[ f ] [ "assoc" assoc? ] unit-test - [ f ] [ "monkey" f assoc ] unit-test [ f ] [ "donkey" "assoc" get assoc ] unit-test [ 1 ] [ "monkey" "assoc" get assoc ] unit-test