diff --git a/TODO.FACTOR.txt b/TODO.FACTOR.txt index 0377795da4..c4fae85644 100644 --- a/TODO.FACTOR.txt +++ b/TODO.FACTOR.txt @@ -1,14 +1,22 @@ -- add a socket timeout -- compiling when* -- compiling unless* -- getenv/setenv: if literal arg, compile as a load/store -- inline words -- alist -vs- assoc terminology -- compiler: drop literal peephole optimization ++ inference/interpreter: + +- : bin 5 [ 5 bin bin 5 ] [ 2drop ] ifte ; +- combinator inference +- generic/2generic inference +- type inference - [ 2 2 . ] run fails +- some way to step over a word in the stepper +- step: print NEXT word to execute, not word that JUST executed +- cache stack effects +- once generic inference is done, can-compile is "has stack effect!" + compiler/ffi: +- compiling when* +- compiling each, etc. +- getenv/setenv: if literal arg, compile as a load/store +- inline words +- compiler: drop literal peephole optimization - is signed -vs- unsigned pointers an issue? - bitfields in C structs - SDL_Rect** type @@ -16,23 +24,9 @@ - float types - compile word twice; no more 'cannot compile' error! - perhaps /i should work with all numbers - -+ docs: - -- explain how log uses >polar and rect> -- simple i/o section -- unparse examples, and difference from prettyprint -- review doc formatting with latex2html -- recursion -vs- iteration in vectors chapter, and combinator - construction -- [, , ,] -- mention that , are usually in nested words -- finish namespaces docs -- mention word accessors/mutators -- to document: - continuations - streams - multitasking - unit testing +- assembler opcodes dispatch on operand types +- lifting +- save code in image + listener/plugin: @@ -48,7 +42,6 @@ - maple-like: press enter at old commands to evaluate there - completion in the listener - special completion for USE:/IN: -- inspector links when describe called without object path + kernel: @@ -57,37 +50,38 @@ - better i/o scheduler - >lower, >upper for strings - don't rehash strings on every startup +- remove sbufs +- cat, reverse-cat primitives +- first-class hashtables +- hash words in stage 2 of bootstrap +- rewrite accessors and mutators in Factor, with slot/set-slot primitive +- replace -export-dynamic with sundry-xt +- add a socket timeout + misc: +- alist -vs- assoc terminology - jedit ==> jedit-word, jedit takes a file name - 'cascading' styles - command line parsing cleanup - nicer way to combine two paths +- :get &get +- namestack, catchstack lists +- OOP +- room. prints code heap size +- refactor sort +- ditch java factor +- ditch object paths +- browser responder for word links in HTTPd; inspect responder for + objects +- use keep instead of tuck, try to remove usages of transp +- worddef props +- prettyprint: when unparse called due to recursion, write a link +- prettyprinter should output {{ ... }} syntax for hashtables +- FORGET: and forget + httpd: -- wiki responder: - - port to native - - text styles - log with date - basic authentication, using httpdAuth function from a config file +- basic authentication, using httpdAuth function from a config file - file responder; last-modified field - -+ java factor is going away: - -- compiled stack traces broken -- save classes to disk -- tail call optimization broken again -- don't compile inline words -- recursive words with code after ifte -- less unnecessary args to auxiliary methods -- inlining tail-recursive immediates -- direct stack access leaks memory on stack -- unnecessary local allocation: max is instance var, but several methods - get compiled. -- ditch expand -- when* compilation in jvm -- plugin should not exit jEdit on fatal errors -- java factor: equal numbers have non-equal hashcodes! -- FactorLib.equal() not very good diff --git a/library/platform/native/parse-syntax.factor b/library/platform/native/parse-syntax.factor index 9f0c1c7fa1..72b9629b2d 100644 --- a/library/platform/native/parse-syntax.factor +++ b/library/platform/native/parse-syntax.factor @@ -29,6 +29,7 @@ IN: parser USE: combinators USE: errors +USE: hashtables USE: kernel USE: lists USE: logic @@ -134,6 +135,10 @@ IN: syntax : { f ; parsing : } reverse list>vector parsed ; parsing +! Hashtables +: {{ f ; parsing +: }} alist>hash parsed ; parsing + ! Do not execute parsing word : POSTPONE: ( -- ) scan-word parsed ; parsing diff --git a/library/platform/native/primitives.factor b/library/platform/native/primitives.factor index 858f743893..4765523504 100644 --- a/library/platform/native/primitives.factor +++ b/library/platform/native/primitives.factor @@ -45,193 +45,195 @@ USE: vectors USE: words [ - [ execute | " word -- " ] - [ call | " quot -- " ] - [ ifte | " cond true false -- " ] - [ cons | " car cdr -- [ car | cdr ] " ] - [ car | " [ car | cdr ] -- car " ] - [ cdr | " [ car | cdr ] -- cdr " ] - [ | " capacity -- vector" ] - [ vector-length | " vector -- n " ] - [ set-vector-length | " n vector -- " ] - [ vector-nth | " n vector -- obj " ] - [ set-vector-nth | " obj n vector -- " ] - [ str-length | " str -- n " ] - [ str-nth | " n str -- ch " ] - [ str-compare | " str str -- -1/0/1 " ] - [ str= | " str str -- ? " ] - [ str-hashcode | " str -- n " ] - [ index-of* | " n str/ch str -- n " ] - [ substring | " start end str -- str "] - [ str-reverse | " str -- str " ] - [ | " capacity -- sbuf " ] - [ sbuf-length | " sbuf -- n " ] - [ set-sbuf-length | " n sbuf -- " ] - [ sbuf-nth | " n sbuf -- ch " ] - [ set-sbuf-nth | " ch n sbuf -- " ] - [ sbuf-append | " ch/str sbuf -- " ] - [ sbuf>str | " sbuf -- str " ] - [ sbuf-reverse | " sbuf -- " ] - [ sbuf-clone | " sbuf -- sbuf " ] - [ sbuf= | " sbuf sbuf -- ? " ] - [ sbuf-hashcode | " sbuf -- n " ] - [ arithmetic-type | " n n -- type " ] - [ number? | " obj -- ? " ] - [ >fixnum | " n -- fixnum " ] - [ >bignum | " n -- bignum " ] - [ >float | " n -- float " ] - [ numerator | " a/b -- a " ] - [ denominator | " a/b -- b " ] - [ fraction> | " a b -- a/b " ] - [ str>float | " str -- float " ] - [ unparse-float | " float -- str " ] - [ float>bits | " float -- n " ] - [ real | " #{ re im } -- re " ] - [ imaginary | " #{ re im } -- im " ] - [ rect> | " re im -- #{ re im } " ] - [ fixnum= | " x y -- ? " ] - [ fixnum+ | " x y -- x+y " ] - [ fixnum- | " x y -- x-y " ] - [ fixnum* | " x y -- x*y " ] - [ fixnum/i | " x y -- x/y " ] - [ fixnum/f | " x y -- x/y " ] - [ fixnum-mod | " x y -- x%y " ] - [ fixnum/mod | " x y -- x/y x%y " ] - [ fixnum-bitand | " x y -- x&y " ] - [ fixnum-bitor | " x y -- x|y " ] - [ fixnum-bitxor | " x y -- x^y " ] - [ fixnum-bitnot | " x -- ~x " ] - [ fixnum-shift | " x n -- x< | " x y -- ? " ] - [ fixnum>= | " x y -- ? " ] - [ bignum= | " x y -- ? " ] - [ bignum+ | " x y -- x+y " ] - [ bignum- | " x y -- x-y " ] - [ bignum* | " x y -- x*y " ] - [ bignum/i | " x y -- x/y " ] - [ bignum/f | " x y -- x/y " ] - [ bignum-mod | " x y -- x%y " ] - [ bignum/mod | " x y -- x/y x%y " ] - [ bignum-bitand | " x y -- x&y " ] - [ bignum-bitor | " x y -- x|y " ] - [ bignum-bitxor | " x y -- x^y " ] - [ bignum-bitnot | " x -- ~x " ] - [ bignum-shift | " x n -- x< | " x y -- ? " ] - [ bignum>= | " x y -- ? " ] - [ float= | " x y -- ? " ] - [ float+ | " x y -- x+y " ] - [ float- | " x y -- x-y " ] - [ float* | " x y -- x*y " ] - [ float/f | " x y -- x/y " ] - [ float< | " x y -- ? " ] - [ float<= | " x y -- ? " ] - [ float> | " x y -- ? " ] - [ float>= | " x y -- ? " ] - [ facos | " x -- y " ] - [ fasin | " x -- y " ] - [ fatan | " x -- y " ] - [ fatan2 | " x y -- z " ] - [ fcos | " x -- y " ] - [ fexp | " x -- y " ] - [ fcosh | " x -- y " ] - [ flog | " x -- y " ] - [ fpow | " x y -- z " ] - [ fsin | " x -- y " ] - [ fsinh | " x -- y " ] - [ fsqrt | " x -- y " ] - [ | " prim param plist -- word " ] - [ word-hashcode | " word -- n " ] - [ word-xt | " word -- xt " ] - [ set-word-xt | " xt word -- " ] - [ word-primitive | " word -- n " ] - [ set-word-primitive | " n word -- " ] - [ word-parameter | " word -- obj " ] - [ set-word-parameter | " obj word -- " ] - [ word-plist | " word -- alist" ] - [ set-word-plist | " alist word -- " ] - [ drop | " x -- " ] - [ dup | " x -- x x " ] - [ swap | " x y -- y x " ] - [ over | " x y -- x y x " ] - [ pick | " x y z -- x y z x " ] - [ nip | " x y -- y " ] - [ tuck | " x y -- y x y " ] - [ rot | " x y z -- y z x " ] - [ >r | " x -- r:x " ] - [ r> | " r:x -- x " ] - [ eq? | " x y -- ? " ] - [ getenv | " n -- obj " ] - [ setenv | " obj n -- " ] - [ open-file | " path r w -- port " ] - [ stat | " path -- [ dir? perm size mtime ] " ] - [ (directory) | " path -- list " ] - [ garbage-collection | " -- " ] - [ save-image | " path -- " ] - [ datastack | " -- ds " ] - [ callstack | " -- cs " ] - [ set-datastack | " ds -- " ] - [ set-callstack | " cs -- " ] - [ exit* | " n -- " ] - [ client-socket | " host port -- in out " ] - [ server-socket | " port -- server " ] - [ close-port | " port -- " ] - [ add-accept-io-task | " server callback -- " ] - [ accept-fd | " server -- host port in out " ] - [ can-read-line? | " port -- ? " ] - [ add-read-line-io-task | " port callback -- " ] - [ read-line-fd-8 | " port -- sbuf " ] - [ can-read-count? | " n port -- ? " ] - [ add-read-count-io-task | " n port callback -- " ] - [ read-count-fd-8 | " n port -- sbuf " ] - [ can-write? | " n port -- ? " ] - [ add-write-io-task | " port callback -- " ] - [ write-fd-8 | " ch/str port -- " ] - [ add-copy-io-task | " from to callback -- " ] - [ pending-io-error | " -- " ] - [ next-io-task | " -- callback " ] - [ room | " -- free total " ] - [ os-env | " str -- str " ] - [ millis | " -- n " ] - [ init-random | " -- " ] - [ (random-int) | " -- n " ] - [ type | " obj -- n " ] - [ size | " obj -- n " ] - [ call-profiling | " depth -- " ] - [ call-count | " word -- n " ] - [ set-call-count | " n word -- " ] - [ allot-profiling | " depth -- " ] - [ allot-count | " word -- n " ] - [ set-allot-count | " n word -- n " ] - [ cwd | " -- dir " ] - [ cd | " dir -- " ] - [ compiled-offset | " -- ptr " ] - [ set-compiled-offset | " ptr -- " ] - [ set-compiled-cell | " n ptr -- " ] - [ set-compiled-byte | " n ptr -- " ] - [ literal-top | " -- ptr " ] - [ set-literal-top | " ptr -- " ] - [ address | " obj -- ptr " ] - [ dlopen | " path -- dll " ] - [ dlsym | " name dll -- ptr " ] - [ dlsym-self | " name -- ptr " ] - [ dlclose | " dll -- " ] - [ | " ptr -- alien " ] - [ | " len -- alien " ] - [ alien-cell | " alien off -- n " ] - [ set-alien-cell | " n alien off -- " ] - [ alien-4 | " alien off -- n " ] - [ set-alien-4 | " n alien off -- " ] - [ alien-2 | " alien off -- n " ] - [ set-alien-2 | " n alien off -- " ] - [ alien-1 | " alien off -- n " ] - [ set-alien-1 | " n alien off -- " ] - [ heap-stats | " -- instances bytes " ] - [ throw | " error -- " ] + [ execute " word -- " f ] + [ call " quot -- " [ 1 | 0 ] ] + [ ifte " cond true false -- " [ 3 | 0 ] ] + [ cons " car cdr -- [ car | cdr ] " [ 2 | 1 ] ] + [ car " [ car | cdr ] -- car " [ 1 | 1 ] ] + [ cdr " [ car | cdr ] -- cdr " [ 1 | 1 ] ] + [ " capacity -- vector" [ 1 | 1 ] ] + [ vector-length " vector -- n " [ 1 | 1 ] ] + [ set-vector-length " n vector -- " [ 2 | 0 ] ] + [ vector-nth " n vector -- obj " [ 2 | 1 ] ] + [ set-vector-nth " obj n vector -- " [ 3 | 0 ] ] + [ str-length " str -- n " [ 1 | 1 ] ] + [ str-nth " n str -- ch " [ 2 | 1 ] ] + [ str-compare " str str -- -1/0/1 " [ 2 | 1 ] ] + [ str= " str str -- ? " [ 2 | 1 ] ] + [ str-hashcode " str -- n " [ 1 | 1 ] ] + [ index-of* " n str/ch str -- n " [ 3 | 1 ] ] + [ substring " start end str -- str " [ 3 | 1 ] ] + [ str-reverse " str -- str " [ 1 | 1 ] ] + [ " capacity -- sbuf " [ 1 | 1 ] ] + [ sbuf-length " sbuf -- n " [ 1 | 1 ] ] + [ set-sbuf-length " n sbuf -- " [ 2 | 1 ] ] + [ sbuf-nth " n sbuf -- ch " [ 2 | 1 ] ] + [ set-sbuf-nth " ch n sbuf -- " [ 3 | 0 ] ] + [ sbuf-append " ch/str sbuf -- " [ 2 | 1 ] ] + [ sbuf>str " sbuf -- str " [ 1 | 1 ] ] + [ sbuf-reverse " sbuf -- " [ 1 | 0 ] ] + [ sbuf-clone " sbuf -- sbuf " [ 1 | 1 ] ] + [ sbuf= " sbuf sbuf -- ? " [ 2 | 1 ] ] + [ sbuf-hashcode " sbuf -- n " [ 1 | 1 ] ] + [ arithmetic-type " n n -- type " [ 2 | 1 ] ] + [ number? " obj -- ? " [ 1 | 1 ] ] + [ >fixnum " n -- fixnum " [ 1 | 1 ] ] + [ >bignum " n -- bignum " [ 1 | 1 ] ] + [ >float " n -- float " [ 1 | 1 ] ] + [ numerator " a/b -- a " [ 1 | 1 ] ] + [ denominator " a/b -- b " [ 1 | 1 ] ] + [ fraction> " a b -- a/b " [ 1 | 1 ] ] + [ str>float " str -- float " [ 1 | 1 ] ] + [ unparse-float " float -- str " [ 1 | 1 ] ] + [ float>bits " float -- n " [ 1 | 1 ] ] + [ real " #{ re im } -- re " [ 1 | 1 ] ] + [ imaginary " #{ re im } -- im " [ 1 | 1 ] ] + [ rect> " re im -- #{ re im } " [ 2 | 1 ] ] + [ fixnum= " x y -- ? " [ 2 | 1 ] ] + [ fixnum+ " x y -- x+y " [ 2 | 1 ] ] + [ fixnum- " x y -- x-y " [ 2 | 1 ] ] + [ fixnum* " x y -- x*y " [ 2 | 1 ] ] + [ fixnum/i " x y -- x/y " [ 2 | 1 ] ] + [ fixnum/f " x y -- x/y " [ 2 | 1 ] ] + [ fixnum-mod " x y -- x%y " [ 2 | 1 ] ] + [ fixnum/mod " x y -- x/y x%y " [ 2 | 2 ] ] + [ fixnum-bitand " x y -- x&y " [ 2 | 1 ] ] + [ fixnum-bitor " x y -- x|y " [ 2 | 1 ] ] + [ fixnum-bitxor " x y -- x^y " [ 2 | 1 ] ] + [ fixnum-bitnot " x -- ~x " [ 1 | 1 ] ] + [ fixnum-shift " x n -- x< " x y -- ? " [ 2 | 1 ] ] + [ fixnum>= " x y -- ? " [ 2 | 1 ] ] + [ bignum= " x y -- ? " [ 2 | 1 ] ] + [ bignum+ " x y -- x+y " [ 2 | 1 ] ] + [ bignum- " x y -- x-y " [ 2 | 1 ] ] + [ bignum* " x y -- x*y " [ 2 | 1 ] ] + [ bignum/i " x y -- x/y " [ 2 | 1 ] ] + [ bignum/f " x y -- x/y " [ 2 | 1 ] ] + [ bignum-mod " x y -- x%y " [ 2 | 1 ] ] + [ bignum/mod " x y -- x/y x%y " [ 2 | 2 ] ] + [ bignum-bitand " x y -- x&y " [ 2 | 1 ] ] + [ bignum-bitor " x y -- x|y " [ 2 | 1 ] ] + [ bignum-bitxor " x y -- x^y " [ 2 | 1 ] ] + [ bignum-bitnot " x -- ~x " [ 1 | 1 ] ] + [ bignum-shift " x n -- x< " x y -- ? " [ 2 | 1 ] ] + [ bignum>= " x y -- ? " [ 2 | 1 ] ] + [ float= " x y -- ? " [ 2 | 1 ] ] + [ float+ " x y -- x+y " [ 2 | 1 ] ] + [ float- " x y -- x-y " [ 2 | 1 ] ] + [ float* " x y -- x*y " [ 2 | 1 ] ] + [ float/f " x y -- x/y " [ 2 | 1 ] ] + [ float< " x y -- ? " [ 2 | 1 ] ] + [ float<= " x y -- ? " [ 2 | 1 ] ] + [ float> " x y -- ? " [ 2 | 1 ] ] + [ float>= " x y -- ? " [ 2 | 1 ] ] + [ facos " x -- y " [ 1 | 1 ] ] + [ fasin " x -- y " [ 1 | 1 ] ] + [ fatan " x -- y " [ 1 | 1 ] ] + [ fatan2 " x y -- z " [ 2 | 1 ] ] + [ fcos " x -- y " [ 1 | 1 ] ] + [ fexp " x -- y " [ 1 | 1 ] ] + [ fcosh " x -- y " [ 1 | 1 ] ] + [ flog " x -- y " [ 1 | 1 ] ] + [ fpow " x y -- z " [ 2 | 1 ] ] + [ fsin " x -- y " [ 1 | 1 ] ] + [ fsinh " x -- y " [ 1 | 1 ] ] + [ fsqrt " x -- y " [ 1 | 1 ] ] + [ " prim param plist -- word " [ 3 | 1 ] ] + [ word-hashcode " word -- n " [ 1 | 1 ] ] + [ word-xt " word -- xt " [ 1 | 1 ] ] + [ set-word-xt " xt word -- " [ 2 | 0 ] ] + [ word-primitive " word -- n " [ 1 | 1 ] ] + [ set-word-primitive " n word -- " [ 2 | 0 ] ] + [ word-parameter " word -- obj " [ 1 | 1 ] ] + [ set-word-parameter " obj word -- " [ 2 | 0 ] ] + [ word-plist " word -- alist" [ 1 | 1 ] ] + [ set-word-plist " alist word -- " [ 2 | 0 ] ] + [ drop " x -- " [ 1 | 0 ] ] + [ dup " x -- x x " [ 1 | 2 ] ] + [ swap " x y -- y x " [ 2 | 2 ] ] + [ over " x y -- x y x " [ 2 | 3 ] ] + [ pick " x y z -- x y z x " [ 3 | 4 ] ] + [ nip " x y -- y " [ 2 | 1 ] ] + [ tuck " x y -- y x y " [ 2 | 3 ] ] + [ rot " x y z -- y z x " [ 3 | 3 ] ] + [ >r " x -- r:x " [ 1 | 0 ] ] + [ r> " r:x -- x " [ 0 | 1 ] ] + [ eq? " x y -- ? " [ 2 | 1 ] ] + [ getenv " n -- obj " [ 1 | 1 ] ] + [ setenv " obj n -- " [ 2 | 0 ] ] + [ open-file " path r w -- port " [ 3 | 1 ] ] + [ stat " path -- [ dir? perm size mtime ] " [ 1 | 1 ] ] + [ (directory) " path -- list " [ 1 | 1 ] ] + [ garbage-collection " -- " [ 0 | 0 ] ] + [ save-image " path -- " [ 1 | 0 ] ] + [ datastack " -- ds " f ] + [ callstack " -- cs " f ] + [ set-datastack " ds -- " f ] + [ set-callstack " cs -- " f ] + [ exit* " n -- " [ 1 | 0 ] ] + [ client-socket " host port -- in out " [ 2 | 2 ] ] + [ server-socket " port -- server " [ 1 | 1 ] ] + [ close-port " port -- " [ 1 | 0 ] ] + [ add-accept-io-task " server callback -- " [ 2 | 0 ] ] + [ accept-fd " server -- host port in out " [ 1 | 4 ] ] + [ can-read-line? " port -- ? " [ 1 | 1 ] ] + [ add-read-line-io-task " port callback -- " [ 2 | 0 ] ] + [ read-line-fd-8 " port -- sbuf " [ 1 | 1 ] ] + [ can-read-count? " n port -- ? " [ 2 | 1 ] ] + [ add-read-count-io-task " n port callback -- " [ 3 | 0 ] ] + [ read-count-fd-8 " n port -- sbuf " [ 2 | 1 ] ] + [ can-write? " n port -- ? " [ 2 | 1 ] ] + [ add-write-io-task " port callback -- " [ 2 | 0 ] ] + [ write-fd-8 " ch/str port -- " [ 2 | 0 ] ] + [ add-copy-io-task " from to callback -- " [ 3 | 1 ] ] + [ pending-io-error " -- " [ 0 | 0 ] ] + [ next-io-task " -- callback " [ 0 | 1 ] ] + [ room " -- free total " [ 0 | 2 ] ] + [ os-env " str -- str " [ 1 | 1 ] ] + [ millis " -- n " [ 0 | 1 ] ] + [ init-random " -- " [ 0 | 0 ] ] + [ (random-int) " -- n " [ 0 | 1 ] ] + [ type " obj -- n " [ 1 | 1 ] ] + [ size " obj -- n " [ 1 | 1 ] ] + [ call-profiling " depth -- " [ 1 | 0 ] ] + [ call-count " word -- n " [ 1 | 1 ] ] + [ set-call-count " n word -- " [ 2 | 0 ] ] + [ allot-profiling " depth -- " [ 1 | 0 ] ] + [ allot-count " word -- n " [ 1 | 1 ] ] + [ set-allot-count " n word -- n " [ 2 | 1 ] ] + [ cwd " -- dir " [ 0 | 1 ] ] + [ cd " dir -- " [ 1 | 0 ] ] + [ compiled-offset " -- ptr " [ 0 | 1 ] ] + [ set-compiled-offset " ptr -- " [ 1 | 0 ] ] + [ set-compiled-cell " n ptr -- " [ 2 | 0 ] ] + [ set-compiled-byte " n ptr -- " [ 2 | 0 ] ] + [ literal-top " -- ptr " [ 0 | 1 ] ] + [ set-literal-top " ptr -- " [ 1 | 0 ] ] + [ address " obj -- ptr " [ 1 | 1 ] ] + [ dlopen " path -- dll " [ 1 | 1 ] ] + [ dlsym " name dll -- ptr " [ 2 | 1 ] ] + [ dlsym-self " name -- ptr " [ 1 | 1 ] ] + [ dlclose " dll -- " [ 1 | 0 ] ] + [ " ptr -- alien " [ 1 | 1 ] ] + [ " len -- alien " [ 1 | 1 ] ] + [ alien-cell " alien off -- n " [ 2 | 1 ] ] + [ set-alien-cell " n alien off -- " [ 3 | 0 ] ] + [ alien-4 " alien off -- n " [ 2 | 1 ] ] + [ set-alien-4 " n alien off -- " [ 3 | 0 ] ] + [ alien-2 " alien off -- n " [ 2 | 1 ] ] + [ set-alien-2 " n alien off -- " [ 3 | 0 ] ] + [ alien-1 " alien off -- n " [ 2 | 1 ] ] + [ set-alien-1 " n alien off -- " [ 3 | 0 ] ] + [ heap-stats " -- instances bytes " [ 0 | 2 ] ] + [ throw " error -- " [ 1 | 0 ] ] ] [ - uncons "stack-effect" set-word-property + uncons dupd uncons car ( word word stack-effect infer-effect ) + >r "stack-effect" set-word-property r> + "infer-effect" set-word-property ] each diff --git a/library/prettyprint.factor b/library/prettyprint.factor index 370aa2d179..a2bf944d79 100644 --- a/library/prettyprint.factor +++ b/library/prettyprint.factor @@ -88,24 +88,18 @@ DEFER: prettyprint* dup prettyprint-newline ] unless ; -: check-recursion ( indent obj quot -- ) - >r over prettyprint-limit >= [ - r> drop drop "#< ... > " write - ] [ - r> call - ] ifte ; - : prettyprint-[ ( indent -- indent ) "[" write "]" write ; -: (prettyprint-list) ( indent list -- indent ) +: prettyprint-list ( indent list -- indent ) + #! Pretty-print a list, without [ and ]. [ uncons >r prettyprint-element r> dup cons? [ - (prettyprint-list) + prettyprint-list ] [ [ "|" write prettyprint-space prettyprint-element @@ -113,10 +107,6 @@ DEFER: prettyprint* ] ifte ] when* ; -: prettyprint-list ( indent list -- indent ) - #! Pretty-print a list, without [ and ]. - [ (prettyprint-list) ] check-recursion ; - : prettyprint-[] ( indent list -- indent ) swap prettyprint-[ swap prettyprint-list prettyprint-] ; @@ -128,7 +118,7 @@ DEFER: prettyprint* : prettyprint-vector ( indent list -- indent ) #! Pretty-print a vector, without { and }. - [ [ prettyprint-element ] vector-each ] check-recursion ; + [ prettyprint-element ] vector-each ; : prettyprint-{} ( indent vector -- indent ) dup vector-length 0 = [ @@ -181,14 +171,18 @@ DEFER: prettyprint* unparse write ; : prettyprint* ( indent obj -- indent ) - [ - [ f = ] [ prettyprint-object ] - [ cons? ] [ prettyprint-[] ] - [ vector? ] [ prettyprint-{} ] - [ comment? ] [ prettyprint-comment ] - [ word? ] [ prettyprint-word ] - [ drop t ] [ prettyprint-object ] - ] cond ; + over prettyprint-limit >= [ + unparse write + ] [ + [ + [ f = ] [ prettyprint-object ] + [ cons? ] [ prettyprint-[] ] + [ vector? ] [ prettyprint-{} ] + [ comment? ] [ prettyprint-comment ] + [ word? ] [ prettyprint-word ] + [ drop t ] [ prettyprint-object ] + ] cond + ] ifte ; : prettyprint ( obj -- ) 0 swap prettyprint* drop terpri ; @@ -203,15 +197,15 @@ DEFER: prettyprint* dup vocab-attrs write-attr ; : prettyprint-IN: ( indent word -- ) - "IN:" write prettyprint-space + \ IN: prettyprint-word prettyprint-space word-vocabulary prettyprint-vocab prettyprint-newline ; : prettyprint-: ( indent -- indent ) - ":" write prettyprint-space + \ : prettyprint-word prettyprint-space tab-size + ; : prettyprint-; ( indent -- indent ) - ";" write + \ ; prettyprint-word tab-size - ; : prettyprint-plist ( word -- ) diff --git a/library/tools/inference.factor b/library/tools/inference.factor index ed36784827..49d9ac2b27 100644 --- a/library/tools/inference.factor +++ b/library/tools/inference.factor @@ -258,43 +258,16 @@ DEFER: (infer) [ init-inference (infer) effect ] with-scope ; \ call [ pop-d (infer) ] "infer" set-word-property -\ call [ 1 | 0 ] "infer-effect" set-word-property - -\ ifte [ 3 | 0 ] "infer-effect" set-word-property \ ifte [ infer-ifte ] "infer" set-word-property \ >r [ pop-d push-r ] "infer" set-word-property -\ >r [ 1 | 0 ] "infer-effect" set-word-property \ r> [ pop-r push-d ] "infer" set-word-property -\ r> [ 0 | 1 ] "infer-effect" set-word-property \ drop t "meta-infer" set-word-property -\ drop [ 1 | 0 ] "infer-effect" set-word-property -\ nip t "meta-infer" set-word-property -\ nip [ 2 | 1 ] "infer-effect" set-word-property \ dup t "meta-infer" set-word-property -\ dup [ 1 | 2 ] "infer-effect" set-word-property -\ over t "meta-infer" set-word-property -\ over [ 2 | 3 ] "infer-effect" set-word-property -\ pick t "meta-infer" set-word-property -\ pick [ 3 | 4 ] "infer-effect" set-word-property \ swap t "meta-infer" set-word-property -\ swap [ 2 | 2 ] "infer-effect" set-word-property +\ over t "meta-infer" set-word-property +\ pick t "meta-infer" set-word-property +\ nip t "meta-infer" set-word-property +\ tuck t "meta-infer" set-word-property \ rot t "meta-infer" set-word-property -\ rot [ 3 | 3 ] "infer-effect" set-word-property - -\ type [ 1 | 1 ] "infer-effect" set-word-property -\ eq? [ 2 | 1 ] "infer-effect" set-word-property - -\ car [ 1 | 1 ] "infer-effect" set-word-property -\ cdr [ 1 | 1 ] "infer-effect" set-word-property -\ cons [ 2 | 1 ] "infer-effect" set-word-property - -\ fixnum+ [ 2 | 1 ] "infer-effect" set-word-property -\ fixnum- [ 2 | 1 ] "infer-effect" set-word-property -\ fixnum* [ 2 | 1 ] "infer-effect" set-word-property - -\ vector-nth [ 2 | 1 ] "infer-effect" set-word-property -\ set-vector-nth [ 3 | 0 ] "infer-effect" set-word-property -\ vector-length [ 1 | 1 ] "infer-effect" set-word-property -\ set-vector-length [ 2 | 0 ] "infer-effect" set-word-property