From b8d8685de8837dc868788ff5fb0423b8b5ef3338 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 1 Aug 2005 03:38:33 +0000 Subject: [PATCH] clean up class<, class-and, class-or --- CHANGES.html | 1 + TODO.FACTOR.txt | 1 - .../cont-responder/cont-numbers-game.factor | 2 +- contrib/crypto/md5.factor | 3 + examples/mandel.factor | 10 +-- examples/numbers-game.factor | 2 +- library/bootstrap/image.factor | 88 +++++++------------ library/bootstrap/primitives.factor | 12 +-- library/cli.factor | 2 +- library/collections/sequences-epilogue.factor | 6 +- library/combinators.factor | 4 + library/generic/builtin.factor | 2 +- library/generic/complement.factor | 16 ++-- library/generic/generic.factor | 38 ++++++-- library/generic/null.factor | 4 +- library/generic/object.factor | 4 +- library/generic/predicate.factor | 8 +- library/generic/tuple.factor | 6 +- library/generic/union.factor | 6 +- library/httpd/http-client.factor | 4 +- library/httpd/responder.factor | 6 +- library/inference/inference.factor | 13 ++- library/inference/partial-eval.factor | 15 ++-- library/inference/stack.factor | 12 ++- library/inference/words.factor | 75 +++++++--------- library/math/matrices.factor | 12 +-- library/math/random.factor | 2 - library/syntax/parse-numbers.factor | 4 - library/syntax/parse-stream.factor | 30 ++----- library/syntax/prettyprint.factor | 2 - library/syntax/unparser.factor | 3 - library/test/benchmark/empty-loop.factor | 9 +- library/test/benchmark/fac.factor | 9 +- library/test/benchmark/hashtables.factor | 6 +- library/test/benchmark/vectors.factor | 2 +- library/test/generic.factor | 10 +++ library/test/hashtables.factor | 2 +- library/test/httpd/httpd.factor | 3 - library/test/image.factor | 28 ------ library/test/inference.factor | 4 + library/test/math/matrices.factor | 9 +- library/test/memory.factor | 24 +++-- library/test/parse-number.factor | 10 +-- library/test/sequences.factor | 2 +- library/test/test.factor | 4 +- library/test/tuple.factor | 6 ++ library/tools/debugger.factor | 4 +- library/tools/jedit.factor | 4 +- library/tools/walker.factor | 10 +-- library/tools/word-tools.factor | 2 +- library/ui/paint.factor | 10 +-- library/unix/io.factor | 4 +- library/vocabularies.factor | 4 - 53 files changed, 251 insertions(+), 308 deletions(-) delete mode 100644 library/test/image.factor diff --git a/CHANGES.html b/CHANGES.html index 1790197245..29ee4c06db 100644 --- a/CHANGES.html +++ b/CHANGES.html @@ -24,6 +24,7 @@

Factor 0.76:

diff --git a/TODO.FACTOR.txt b/TODO.FACTOR.txt index d7b0e0db9f..188e4f1734 100644 --- a/TODO.FACTOR.txt +++ b/TODO.FACTOR.txt @@ -86,7 +86,6 @@ - delegating generic words with a non-standard picker - powerpc has weird callstack residue - instances: do not use make-list -- unions containing tuples do not work properly - method doc strings - clean up metaclasses - vectors: ensure its ok with bignum indices diff --git a/contrib/cont-responder/cont-numbers-game.factor b/contrib/cont-responder/cont-numbers-game.factor index ddde1ec541..469a510931 100644 --- a/contrib/cont-responder/cont-numbers-game.factor +++ b/contrib/cont-responder/cont-numbers-game.factor @@ -69,7 +69,7 @@ USE: namespaces - ] show [ "num" get ] bind parse-number ; + ] show [ "num" get ] bind str>number ; : guess-banner "I'm thinking of a number between 0 and 100." web-print ; diff --git a/contrib/crypto/md5.factor b/contrib/crypto/md5.factor index 469931d993..6a4facc233 100644 --- a/contrib/crypto/md5.factor +++ b/contrib/crypto/md5.factor @@ -178,6 +178,9 @@ SYMBOL: old-d : get-block ( string num -- string ) 64 * dup 64 + rot subseq ; +: hex-string ( str -- str ) + [ >hex 2 CHAR: 0 pad-left ] map concat ; + : get-md5 ( -- str ) [ [ a b c d ] [ get 4 >le % ] each diff --git a/examples/mandel.factor b/examples/mandel.factor index 065ae40939..27f4330448 100644 --- a/examples/mandel.factor +++ b/examples/mandel.factor @@ -87,12 +87,10 @@ USE: test : val 0.85 ; : ( nb-cols -- map ) - [ - dup [ - dup 360 * pick 1 + / 360 / sat val - hsv>rgb 1.0 scale-rgb , - ] repeat - ] make-vector nip ; + dup [ + 360 * swap 1 + / 360 / sat val + hsv>rgb 1.0 scale-rgb + ] map-with ; : iter ( c z nb-iter -- x ) over absq 4 >= over 0 = or [ diff --git a/examples/numbers-game.factor b/examples/numbers-game.factor index 00e45e2368..18ee288ce0 100644 --- a/examples/numbers-game.factor +++ b/examples/numbers-game.factor @@ -1,7 +1,7 @@ IN: numbers-game USING: kernel math parser random io ; -: read-number ( -- n ) readln parse-number ; +: read-number ( -- n ) readln str>number ; : guess-banner "I'm thinking of a number between 0 and 100." print ; diff --git a/library/bootstrap/image.factor b/library/bootstrap/image.factor index 10af2d9db9..401b10f91e 100644 --- a/library/bootstrap/image.factor +++ b/library/bootstrap/image.factor @@ -27,6 +27,8 @@ SYMBOL: boot-quot : emit ( cell -- ) image get push ; +: emit-seq ( seq -- ) image get swap nappend ; + : fixup ( value offset -- ) image get set-nth ; ( Object memory ) @@ -95,14 +97,6 @@ GENERIC: ' ( obj -- ptr ) : align-here ( -- ) here 8 mod 4 = [ 0 emit ] when ; -( Remember what objects we've compiled ) - -: pooled-object ( object -- pointer ) - "objects" get hash ; - -: pool-object ( object pointer -- ) - swap "objects" get set-hash ; - ( Fixnums ) : emit-fixnum ( n -- ) fixnum-tag immediate emit ; @@ -148,7 +142,7 @@ M: f ' ( obj -- ptr ) ( Words ) -: word, ( word -- ) +: emit-word ( word -- ) [ word-type >header , dup hashcode fixnum-tag immediate , @@ -157,7 +151,7 @@ M: f ' ( obj -- ptr ) dup word-def ' , dup word-props ' , ] make-vector - swap object-tag here-as pool-object + swap object-tag here-as swap "objects" get set-hash [ emit ] each ; : word-error ( word msg -- ) @@ -169,16 +163,18 @@ M: f ' ( obj -- ptr ) dup dup word-name swap word-vocabulary unit search [ ] [ dup "Missing DEFER: " word-error ] ?ifte ; +: pooled-object ( object -- ptr ) "objects" get hash ; + : fixup-word ( word -- offset ) - dup pooled-object [ ] [ "Not in image: " word-error ] ?ifte ; + dup pooled-object + [ ] [ "Not in image: " word-error ] ?ifte ; : fixup-words ( -- ) - image get [ - dup word? [ fixup-word ] when - ] map image set ; + image get [ dup word? [ fixup-word ] when ] nmap ; M: word ' ( word -- pointer ) - transfer-word dup pooled-object dup [ nip ] [ drop ] ifte ; + transfer-word dup pooled-object + dup [ nip ] [ drop ] ifte ; ( Conses ) @@ -189,37 +185,25 @@ M: cons ' ( c -- tagged ) ( Strings ) -: align-string ( n str -- ) - tuck length - CHAR: \0 fill append ; +: emit-chars ( seq -- ) + "big-endian" get [ [ reverse ] map ] unless + [ 0 [ swap 16 shift + ] reduce emit ] each ; -: emit-chars ( str -- ) - "big-endian" get [ reverse ] unless - 0 swap [ swap 16 shift + ] each emit ; +: pack-string ( string -- seq ) + dup length 1 + char align CHAR: \0 pad-right char swap group ; -: (pack-string) ( n list -- ) - #! Emit bytes for a string, with n characters per word. - [ - 2dup length > [ dupd align-string ] when - emit-chars - ] each drop ; - -: pack-string ( string -- ) - char tuck swap group (pack-string) ; - -: emit-string ( string -- ) +: emit-string ( string -- ptr ) object-tag here-as swap string-type >header emit dup length emit-fixnum dup hashcode emit-fixnum - "\0" append pack-string + pack-string emit-chars align-here ; M: string ' ( string -- pointer ) #! We pool strings so that each string is only written once #! to the image - dup pooled-object [ ] [ - dup emit-string dup >r pool-object r> - ] ?ifte ; + "objects" get [ emit-string ] cache ; ( Arrays and vectors ) @@ -228,7 +212,7 @@ M: string ' ( string -- pointer ) object-tag here-as >r >header emit dup length emit-fixnum - ( elements -- ) [ emit ] each + ( elements -- ) emit-seq align-here r> ; M: tuple ' ( tuple -- pointer ) @@ -255,31 +239,17 @@ M: vector ' ( vector -- pointer ) align-here r> ; M: hashtable ' ( hashtable -- pointer ) - #! Only hashtables are pooled, not vectors! - dup pooled-object [ ] [ - dup emit-hashtable [ pool-object ] keep - ] ?ifte ; + "objects" get [ emit-hashtable ] cache ; ( End of the image ) -: vocabulary, ( hash -- ) - dup hashtable? [ - [ cdr dup word? [ word, ] [ drop ] ifte ] hash-each - ] [ - drop - ] ifte ; - -: vocabularies, ( vocabularies -- ) - [ cdr vocabulary, ] hash-each ; +: words, ( -- ) + all-words [ emit-word ] each ; : global, ( -- ) - vocabularies get - dup vocabularies, [ - vocabularies set - typemap [ ] change - builtins [ ] change - crossref [ ] change + { vocabularies typemap builtins crossref } + [ [ ] change ] each ] extend ' global-offset fixup ; @@ -287,8 +257,13 @@ M: hashtable ' ( hashtable -- pointer ) boot-quot get swap append ' boot-quot-offset fixup ; : end ( quot -- ) + "Generating words..." print + words, + "Generating global namespace..." print global, + "Generating boot quotation..." print boot, + "Performing some word fixups..." print fixup-words here base - heap-size-offset fixup ; @@ -302,6 +277,7 @@ M: hashtable ' ( hashtable -- pointer ) ] ifte ; : write-image ( image file -- ) + "Writing image to " write dup write "..." print [ (write-image) ] with-stream ; : with-minimal-image ( quot -- image ) @@ -317,7 +293,7 @@ M: hashtable ' ( hashtable -- pointer ) [ begin call end ] with-minimal-image ; : make-image ( name -- ) - #! Make an image for the C interpreter. + #! Make a bootstrap image. [ boot-quot off "/library/bootstrap/boot-stage1.factor" run-resource diff --git a/library/bootstrap/primitives.factor b/library/bootstrap/primitives.factor index 608c2f9fa4..08f61b4286 100644 --- a/library/bootstrap/primitives.factor +++ b/library/bootstrap/primitives.factor @@ -1,11 +1,13 @@ ! Copyright (C) 2004, 2005 Slava Pestov. ! See http://factor.sf.net/license.txt for BSD license. IN: image -USING: kernel lists math memory namespaces parser words vectors -hashtables generic alien assembler compiler errors files generic -io-internals kernel kernel-internals lists math math-internals -parser profiler strings unparser vectors words hashtables -sequences ; +USING: alien assembler compiler errors files generic generic +hashtables hashtables io io-internals kernel kernel +kernel-internals lists lists math math math-internals memory +namespaces parser parser profiler sequences strings unparser +vectors vectors words words ; + +"Creating primitives and basic runtime structures..." print ! This symbol needs the same hashcode in the target as in the ! host. diff --git a/library/cli.factor b/library/cli.factor index ceeb97dccd..64fd4f8d0a 100644 --- a/library/cli.factor +++ b/library/cli.factor @@ -8,7 +8,7 @@ sequences strings ; ! on all other words already being defined. : ?run-file ( file -- ) - dup exists? [ (run-file) ] [ drop ] ifte ; + dup exists? [ run-file ] [ drop ] ifte ; : run-user-init ( -- ) #! Run user init file if it exists diff --git a/library/collections/sequences-epilogue.factor b/library/collections/sequences-epilogue.factor index 036fb9908e..8f591ad928 100644 --- a/library/collections/sequences-epilogue.factor +++ b/library/collections/sequences-epilogue.factor @@ -208,7 +208,9 @@ M: object reverse ( seq -- seq ) [ ] keep like ; : flip ( seq -- seq ) #! An example illustrates this word best: #! { { 1 2 3 } { 4 5 6 } } ==> { { 1 2 } { 3 4 } { 5 6 } } - [ dup like ] map ; + dup empty? [ + dup first length [ swap [ nth ] map-with ] map-with + ] unless ; : max-length ( seq -- n ) #! Longest sequence length in a sequence of sequences. @@ -224,8 +226,6 @@ M: object reverse ( seq -- seq ) [ ] keep like ; : copy-into ( to from -- ) dup length [ pick set-nth ] 2each drop ; -M: flipped set-nth ( elt n flipped -- ) nth swap copy-into ; - IN: kernel : depth ( -- n ) diff --git a/library/combinators.factor b/library/combinators.factor index a030dee844..ba462e4f19 100644 --- a/library/combinators.factor +++ b/library/combinators.factor @@ -1,6 +1,7 @@ ! Copyright (C) 2003, 2005 Slava Pestov. ! See http://factor.sf.net/license.txt for BSD license. IN: kernel +USING: words ; : slip ( quot x -- x | quot: -- ) >r call r> ; inline @@ -62,3 +63,6 @@ IN: kernel : with ( obj quot elt -- obj quot ) #! Utility word for each-with, map-with. pick pick >r >r swap call r> r> ; inline + +: keep-datastack ( quot -- ) + datastack slip set-datastack drop ; diff --git a/library/generic/builtin.factor b/library/generic/builtin.factor index 9fc91c25ce..b22bbe5601 100644 --- a/library/generic/builtin.factor +++ b/library/generic/builtin.factor @@ -22,7 +22,7 @@ builtin [ builtin 50 "priority" set-word-prop ! All builtin types are equivalent in ordering -builtin [ 2drop t ] "class<" set-word-prop +builtin [ (class<) ] "class<" set-word-prop : builtin-predicate ( class predicate -- ) 2dup register-predicate diff --git a/library/generic/complement.factor b/library/generic/complement.factor index 38aa439ddd..e5816df244 100644 --- a/library/generic/complement.factor +++ b/library/generic/complement.factor @@ -17,20 +17,14 @@ complement [ complement [ ( generic vtable definition class -- ) drop num-types [ - [ - >r 3dup r> builtin-type - dup [ add-method ] [ 2drop 2drop ] ifte - ] keep - ] repeat 3drop + >r 3dup r> builtin-type + dup [ add-method ] [ 2drop 2drop ] ifte + ] each 3drop ] "add-method" set-word-prop -complement 90 "priority" set-word-prop +complement 50 "priority" set-word-prop -complement [ - swap "complement" word-prop - swap "complement" word-prop - class< not -] "class<" set-word-prop +complement [ (class<) ] "class<" set-word-prop : complement-predicate ( complement -- list ) "predicate" word-prop [ not ] append ; diff --git a/library/generic/generic.factor b/library/generic/generic.factor index f10211455d..824cfd905c 100644 --- a/library/generic/generic.factor +++ b/library/generic/generic.factor @@ -32,14 +32,23 @@ M: object delegate drop f ; : set-vtable ( definition class vtable -- ) >r "builtin-type" word-prop r> set-nth ; +: 2types ( class class -- seq seq ) + swap builtin-supertypes swap builtin-supertypes ; + +: (class<) ( class class -- ? ) + 2types contained? ; + : class-ord ( class -- n ) metaclass "priority" word-prop ; +: metaclass= ( class class -- ? ) + swap metaclass swap metaclass = ; + : class< ( cls1 cls2 -- ? ) #! Test if class1 is a subclass of class2. - over metaclass over metaclass = [ - dup metaclass "class<" word-prop call + over class-ord over class-ord - dup 0 = [ + drop dup metaclass "class<" word-prop call ] [ - swap class-ord swap class-ord < + 0 < 2nip ] ifte ; : methods ( generic -- alist ) @@ -155,9 +164,15 @@ SYMBOL: object : class-or ( class class -- class ) #! Return a class that both classes are subclasses of. - swap builtin-supertypes - swap builtin-supertypes - seq-union lookup-union ; + 2dup class< [ + nip + ] [ + 2dup swap class< [ + drop + ] [ + 2types seq-union lookup-union + ] ifte + ] ifte ; : class-or-list ( list -- class ) #! Return a class that every class in the list is a @@ -169,8 +184,15 @@ SYMBOL: object : class-and ( class class -- class ) #! Return a class that is a subclass of both, or null in #! the degenerate case. - swap builtin-supertypes swap builtin-supertypes - seq-intersect lookup-union ; + 2dup class< [ + drop + ] [ + 2dup swap class< [ + nip + ] [ + 2types seq-intersect lookup-union + ] ifte + ] ifte ; : define-class ( class metaclass -- ) dupd "metaclass" set-word-prop diff --git a/library/generic/null.factor b/library/generic/null.factor index 602d80f16b..246a108dce 100644 --- a/library/generic/null.factor +++ b/library/generic/null.factor @@ -8,6 +8,6 @@ SYMBOL: null null [ drop [ ] ] "builtin-supertypes" set-word-prop null [ 2drop 2drop ] "add-method" set-word-prop null [ drop f ] "predicate" set-word-prop -null 100 "priority" set-word-prop -null [ 2drop t ] "class<" set-word-prop +null 40 "priority" set-word-prop +null [ (class<) ] "class<" set-word-prop null null define-class diff --git a/library/generic/object.factor b/library/generic/object.factor index e53c21513d..80b9edaa46 100644 --- a/library/generic/object.factor +++ b/library/generic/object.factor @@ -19,8 +19,8 @@ object [ object [ drop t ] "predicate" set-word-prop -object 100 "priority" set-word-prop +object 60 "priority" set-word-prop -object [ 2drop t ] "class<" set-word-prop +object [ (class<) ] "class<" set-word-prop object object define-class diff --git a/library/generic/predicate.factor b/library/generic/predicate.factor index b3bacd0c7e..7da8ca682c 100644 --- a/library/generic/predicate.factor +++ b/library/generic/predicate.factor @@ -31,13 +31,17 @@ predicate [ ] each 2drop 2drop ] "add-method" set-word-prop -predicate 5 "priority" set-word-prop +predicate 50 "priority" set-word-prop predicate [ 2dup = [ 2drop t ] [ - >r "superclass" word-prop r> class< + 2dup metaclass= [ + >r "superclass" word-prop r> class< + ] [ + 2drop f + ] ifte ] ifte ] "class<" set-word-prop diff --git a/library/generic/tuple.factor b/library/generic/tuple.factor index d1e1e2e3d5..c2ac0c7bbb 100644 --- a/library/generic/tuple.factor +++ b/library/generic/tuple.factor @@ -197,9 +197,11 @@ tuple [ drop tuple "builtin-type" word-prop unit ] "builtin-supertypes" set-word-prop -tuple 10 "priority" set-word-prop +tuple 50 "priority" set-word-prop -tuple [ 2drop t ] "class<" set-word-prop +tuple [ + 2dup metaclass= [ = ] [ 2drop f ] ifte +] "class<" set-word-prop PREDICATE: word tuple-class metaclass tuple = ; diff --git a/library/generic/union.factor b/library/generic/union.factor index d2e72c5c76..5f9a36f45c 100644 --- a/library/generic/union.factor +++ b/library/generic/union.factor @@ -18,11 +18,9 @@ union [ "members" word-prop [ >r 3dup r> add-method ] each 3drop ] "add-method" set-word-prop -union 55 "priority" set-word-prop +union 50 "priority" set-word-prop -union [ - swap builtin-supertypes swap builtin-supertypes contained? -] "class<" set-word-prop +union [ (class<) ] "class<" set-word-prop : union-predicate ( definition -- list ) [ diff --git a/library/httpd/http-client.factor b/library/httpd/http-client.factor index 8265010e9a..60e07e706b 100644 --- a/library/httpd/http-client.factor +++ b/library/httpd/http-client.factor @@ -6,7 +6,7 @@ io strings unparser ; : parse-host ( url -- host port ) #! Extract the host name and port number from an HTTP URL. - ":" split1 [ parse-number ] [ 80 ] ifte* ; + ":" split1 [ str>number ] [ 80 ] ifte* ; : parse-url ( url -- host resource ) "http://" ?head [ @@ -16,7 +16,7 @@ io strings unparser ; : parse-response ( line -- code ) "HTTP/" ?head [ " " split1 nip ] when - " " split1 drop parse-number ; + " " split1 drop str>number ; : read-response ( -- code header ) #! After sending a GET oR POST we read a response line and diff --git a/library/httpd/responder.factor b/library/httpd/responder.factor index 1fac90f1e0..1363a82b86 100644 --- a/library/httpd/responder.factor +++ b/library/httpd/responder.factor @@ -51,9 +51,6 @@ SYMBOL: responders "raw-query" get [ CHAR: ? , % ] when* ] make-string redirect ; -: content-length ( alist -- length ) - "Content-Length" swap assoc parse-number ; - : query>alist ( query -- alist ) dup [ "&" split [ @@ -64,7 +61,8 @@ SYMBOL: responders ] when ; : read-post-request ( header -- alist ) - content-length dup [ read query>alist ] when ; + "Content-Length" swap assoc dup + [ str>number read query>alist ] when ; : log-user-agent ( alist -- ) "User-Agent" swap assoc* [ diff --git a/library/inference/inference.factor b/library/inference/inference.factor index efb501ac97..bfbd9156a3 100644 --- a/library/inference/inference.factor +++ b/library/inference/inference.factor @@ -107,6 +107,17 @@ M: object apply-object apply-literal ; #! Stack effect of a quotation. [ infer-quot effect ] with-infer ; +: infer-from ( quot stack -- effect ) + #! Infer starting from a stack of values. + [ meta-d set infer-quot effect ] with-infer ; + +: (dataflow) ( quot -- dataflow ) + infer-quot #return node, dataflow-graph get ; + : dataflow ( quot -- dataflow ) #! Data flow of a quotation. - [ infer-quot #return node, dataflow-graph get ] with-infer ; + [ (dataflow) ] with-infer ; + +: dataflow-with ( quot stack -- effect ) + #! Infer starting from a stack of values. + [ meta-d set (dataflow) ] with-infer ; diff --git a/library/inference/partial-eval.factor b/library/inference/partial-eval.factor index 850c0a7212..996bd96cb0 100644 --- a/library/inference/partial-eval.factor +++ b/library/inference/partial-eval.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2005 Slava Pestov. ! See http://factor.sf.net/license.txt for BSD license. IN: inference -USING: generic interpreter kernel lists math namespaces +USING: errors generic interpreter kernel lists math namespaces sequences words ; : literal-inputs? ( in stack -- ) @@ -22,10 +22,13 @@ sequences words ; : infer-eval ( word -- ) dup partial-eval? [ dup "infer-effect" word-prop 2unlist - >r length meta-d get - literal-inputs - host-word - r> length meta-d get literal-outputs + -rot length meta-d get + literal-inputs [ + apply-datastack + ] [ + [ "infer-effect" word-prop consume/produce ] + [ length meta-d get literal-outputs ] ifte + ] catch ] [ dup "infer-effect" word-prop consume/produce ] ifte ; @@ -75,7 +78,7 @@ sequences words ; \ <= [ [ real real ] [ boolean ] ] "infer-effect" set-word-prop \ > [ [ real real ] [ boolean ] ] "infer-effect" set-word-prop \ >= [ [ real real ] [ boolean ] ] "infer-effect" set-word-prop -\ number= [ [ real real ] [ boolean ] ] "infer-effect" set-word-prop +\ number= [ [ object object ] [ boolean ] ] "infer-effect" set-word-prop \ + [ [ number number ] [ number ] ] "infer-effect" set-word-prop \ - [ [ number number ] [ number ] ] "infer-effect" set-word-prop \ * [ [ number number ] [ number ] ] "infer-effect" set-word-prop diff --git a/library/inference/stack.factor b/library/inference/stack.factor index 5e57b56588..aaefb6ec25 100644 --- a/library/inference/stack.factor +++ b/library/inference/stack.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2004, 2005 Slava Pestov. ! See http://factor.sf.net/license.txt for BSD license. IN: inference -USING: interpreter kernel namespaces words ; +USING: interpreter kernel namespaces sequences words ; \ >r [ \ >r #call @@ -19,9 +19,17 @@ USING: interpreter kernel namespaces words ; node, ] "infer" set-word-prop +: with-datastack ( stack word -- stack ) + datastack >r >r set-datastack r> execute + datastack r> [ push ] keep set-datastack 2nip ; + +: apply-datastack ( word -- ) + meta-d [ swap with-datastack ] change ; + : infer-shuffle ( word -- ) dup #call [ - over "infer-effect" word-prop [ host-word ] hairy-node + over "infer-effect" word-prop + [ apply-datastack ] hairy-node ] keep node, ; \ drop [ 1 #drop node, pop-d drop ] "infer" set-word-prop diff --git a/library/inference/words.factor b/library/inference/words.factor index 49a003b94c..caaae875bf 100644 --- a/library/inference/words.factor +++ b/library/inference/words.factor @@ -52,7 +52,7 @@ hashtables parser prettyprint ; word-def infer-quot ] ifte ; -: (infer-compound) ( word base-case -- effect ) +: infer-compound ( word base-case -- effect ) #! Infer a word's stack effect in a separate inferencer #! instance. [ @@ -62,66 +62,47 @@ hashtables parser prettyprint ; effect ] with-scope [ consume/produce ] keep ; -: infer-compound ( word -- ) +GENERIC: apply-word + +M: object apply-word ( word -- ) + #! A primitive with an unknown stack effect. + no-effect ; + +M: compound apply-word ( word -- ) + #! Infer a compound word's stack effect. [ - dup f (infer-compound) "infer-effect" set-word-prop + dup f infer-compound "infer-effect" set-word-prop ] [ [ swap t "no-effect" set-word-prop rethrow ] when* ] catch ; -GENERIC: (apply-word) - -M: object (apply-word) ( word -- ) - #! A primitive with an unknown stack effect. - no-effect ; - -M: primitive (apply-word) ( word -- ) - dup "infer-effect" word-prop [ - consume/produce - ] [ - no-effect - ] ifte ; - -M: compound (apply-word) ( word -- ) - #! Infer a compound word's stack effect. +: apply-default ( word -- ) dup "no-effect" word-prop [ no-effect ] [ - infer-compound + dup "infer-effect" word-prop [ + over "infer" word-prop [ + swap car ensure-d call drop + ] [ + consume/produce + ] ifte* + ] [ + apply-word + ] ifte* ] ifte ; -M: symbol (apply-word) ( word -- ) - apply-literal ; - -GENERIC: apply-word - -: apply-default ( word -- ) - dup "infer-effect" word-prop [ - over "infer" word-prop [ - swap car ensure-d call drop - ] [ - consume/produce - ] ifte* - ] [ - (apply-word) - ] ifte* ; - -M: word apply-word ( word -- ) +M: word apply-object ( word -- ) apply-default ; -M: compound apply-word ( word -- ) - dup "inline" word-prop [ - inline-compound - ] [ - apply-default - ] ifte ; +M: symbol apply-object ( word -- ) + apply-literal ; : (base-case) ( word label -- ) over "inline" word-prop [ over inline-block drop [ #call-label ] [ #call ] ?ifte node, ] [ - drop dup t (infer-compound) "base-case" set-word-prop + drop dup t infer-compound "base-case" set-word-prop ] ifte ; : base-case ( word label -- ) @@ -151,12 +132,16 @@ M: compound apply-word ( word -- ) ] ifte* ] ifte* ; -M: word apply-object ( word -- ) +M: compound apply-object ( word -- ) #! Apply the word's stack effect to the inferencer state. dup recursive-state get assoc [ recursive-word ] [ - apply-word + dup "inline" word-prop [ + inline-compound + ] [ + apply-default + ] ifte ] ifte* ; \ call [ diff --git a/library/math/matrices.factor b/library/math/matrices.factor index d2ba865779..9da6cd75f3 100644 --- a/library/math/matrices.factor +++ b/library/math/matrices.factor @@ -34,7 +34,7 @@ USING: kernel sequences vectors ; : set-axis ( x y axis -- v ) 2dup v* >r >r drop dup r> v* v- r> v+ ; -: v. ( v v -- x ) 0 -rot [ * + ] 2each ; inline +: v. ( v v -- x ) 0 -rot [ * + ] 2each ; : c. ( v v -- x ) 0 -rot [ conjugate * + ] 2each ; : norm-sq ( v -- n ) 0 [ absq + ] reduce ; @@ -61,7 +61,7 @@ USING: kernel sequences vectors ; : identity-matrix ( n -- matrix ) #! Make a nxn identity matrix. - dup zero-matrix 0 over [ drop 1 ] nmap ; + dup zero-matrix dup 0 [ drop 1 ] nmap ; ! Matrix operations : mneg ( m -- m ) [ vneg ] map ; @@ -84,8 +84,8 @@ USING: kernel sequences vectors ; : m> ( m m -- m ) [ v> ] 2map ; : m>= ( m m -- m ) [ v>= ] 2map ; -: v.m ( v m -- v ) [ v. ] map-with ; inline -: m.v ( m v -- v ) swap [ v. ] map-with ; inline -: m. ( m m -- m ) swap [ m.v ] map-with ; +: v.m ( v m -- v ) flip [ v. ] map-with ; +: m.v ( m v -- v ) swap [ v. ] map-with ; +: m. ( m m -- m ) flip swap [ m.v ] map-with ; -: trace ( matrix -- tr ) 0 swap product ; +: trace ( matrix -- tr ) 0 product ; diff --git a/library/math/random.factor b/library/math/random.factor index 2f5f6e1151..437d3eb735 100644 --- a/library/math/random.factor +++ b/library/math/random.factor @@ -2,8 +2,6 @@ ! See http://factor.sf.net/license.txt for BSD license. IN: math USING: kernel ; -: power-of-2? ( n -- ? ) dup dup neg bitand = ; - : (random-int-0) ( n bits val -- n ) 3dup - + 1 < [ 2drop (random-int) 2dup swap mod (random-int-0) diff --git a/library/syntax/parse-numbers.factor b/library/syntax/parse-numbers.factor index f487b97b03..030cdcd614 100644 --- a/library/syntax/parse-numbers.factor +++ b/library/syntax/parse-numbers.factor @@ -41,10 +41,6 @@ PREDICATE: string potential-float CHAR: . swap member? ; M: potential-float str>number ( str -- num ) str>float ; -: parse-number ( str -- num ) - #! Convert a string to a number; return f on error. - [ str>number ] [ [ drop f ] when ] catch ; - : bin> 2 base> ; : oct> 8 base> ; : dec> 10 base> ; diff --git a/library/syntax/parse-stream.factor b/library/syntax/parse-stream.factor index e9b13221c9..5437b10b67 100644 --- a/library/syntax/parse-stream.factor +++ b/library/syntax/parse-stream.factor @@ -4,37 +4,25 @@ IN: parser USING: kernel lists namespaces sequences io ; : file-vocabs ( -- ) - "file-in" get "in" set - "file-use" get "use" set ; + "scratchpad" "in" set + [ "syntax" "scratchpad" ] "use" set ; -: (parse-stream) ( name stream -- quot ) - #! Uses the current namespace for temporary variables. - [ - >r file set f ( initial parse tree ) r> - [ (parse) ] read-lines reverse - file off - line-number off - ] with-parser ; +: (parse-stream) ( stream -- quot ) + [ f swap [ (parse) ] read-lines reverse ] with-parser ; : parse-stream ( name stream -- quot ) - [ file-vocabs (parse-stream) ] with-scope ; + [ + swap file set file-vocabs + (parse-stream) + file off line-number off + ] with-scope ; : parse-file ( file -- quot ) dup parse-stream ; : run-file ( file -- ) - #! Run a file. The file is read with the default IN:/USE: - #! for files. parse-file call ; -: (parse-file) ( file -- quot ) - dup (parse-stream) ; - -: (run-file) ( file -- ) - #! Run a file. The file is read with the same IN:/USE: as - #! the current interactive interpreter. - (parse-file) call ; - : parse-resource ( path -- quot ) #! Resources are loaded from the resource-path variable, or #! the current directory if it is not set. Words defined in diff --git a/library/syntax/prettyprint.factor b/library/syntax/prettyprint.factor index b743764a17..c41c6da6d0 100644 --- a/library/syntax/prettyprint.factor +++ b/library/syntax/prettyprint.factor @@ -139,8 +139,6 @@ M: alien prettyprint* ( alien -- str ) : .s datastack reverse [.] flush ; : .r callstack reverse [.] flush ; -: .n namestack [.] flush ; -: .c catchstack [.] flush ; ! For integers only : .b >bin print ; diff --git a/library/syntax/unparser.factor b/library/syntax/unparser.factor index 5dc624c81a..c741ac5113 100644 --- a/library/syntax/unparser.factor +++ b/library/syntax/unparser.factor @@ -98,6 +98,3 @@ M: f unparse drop "f" ; M: dll unparse ( obj -- str ) [ "DLL\" " % dll-path unparse-string CHAR: " , ] make-string ; - -: hex-string ( str -- str ) - [ [ >hex 2 CHAR: 0 pad-left % ] each ] make-string ; diff --git a/library/test/benchmark/empty-loop.factor b/library/test/benchmark/empty-loop.factor index 10efe660c5..b0de42a23b 100644 --- a/library/test/benchmark/empty-loop.factor +++ b/library/test/benchmark/empty-loop.factor @@ -1,8 +1,5 @@ IN: temporary -USE: compiler -USE: kernel -USE: math -USE: test +USING: compiler kernel math sequences test ; : empty-loop-1 ( n -- ) [ ] times ; compiled @@ -10,5 +7,9 @@ USE: test : empty-loop-2 ( n -- ) [ ] repeat ; compiled +: empty-loop-3 ( n -- ) + [ drop ] each ; compiled + [ ] [ 5000000 empty-loop-1 ] unit-test [ ] [ 5000000 empty-loop-2 ] unit-test +[ ] [ 5000000 empty-loop-3 ] unit-test diff --git a/library/test/benchmark/fac.factor b/library/test/benchmark/fac.factor index 56de5debc0..457432406b 100644 --- a/library/test/benchmark/fac.factor +++ b/library/test/benchmark/fac.factor @@ -1,8 +1,5 @@ IN: temporary -USE: math -USE: test -USE: compiler -USE: kernel +USING: compiler kernel math sequences test ; : (fac) ( n! i -- n! ) dup 0 = [ @@ -16,10 +13,10 @@ USE: kernel : small-fac-benchmark #! This tests fixnum math. - 1 swap [ 10 fac 10 [ [ 1 + / ] keep ] repeat max ] times ; compiled + 1 swap [ 10 fac 10 [ 1 + / ] each max ] times ; compiled : big-fac-benchmark - 10000 fac 10000 [ [ 1 + / ] keep ] repeat ; compiled + 10000 fac 10000 [ 1 + / ] each ; compiled [ 1 ] [ big-fac-benchmark ] unit-test diff --git a/library/test/benchmark/hashtables.factor b/library/test/benchmark/hashtables.factor index 53a7a72290..57334e448b 100644 --- a/library/test/benchmark/hashtables.factor +++ b/library/test/benchmark/hashtables.factor @@ -1,10 +1,10 @@ -USING: compiler hashtables kernel math namespaces test ; +USING: compiler hashtables kernel math namespaces sequences test ; : store-hash ( hashtable n -- ) - [ [ >float dup pick set-hash ] keep ] repeat drop ; + [ >float dup pick set-hash ] each drop ; : lookup-hash ( hashtable n -- ) - [ [ >float over hash drop ] keep ] repeat drop ; + [ >float over hash drop ] each drop ; : hashtable-benchmark ( -- ) 100 [ diff --git a/library/test/benchmark/vectors.factor b/library/test/benchmark/vectors.factor index 86284bb708..99245f8a21 100644 --- a/library/test/benchmark/vectors.factor +++ b/library/test/benchmark/vectors.factor @@ -3,7 +3,7 @@ USING: compiler kernel math sequences test vectors ; ! http://inferno.bell-labs.com/cm/cs/who/bwk/interps/pap.html : fill-vector ( n -- vector ) - dup swap [ [ dup pick set-nth ] keep ] repeat ; compiled + dup swap [ dup pick set-nth ] each ; compiled : copy-elt ( vec-y vec-x n -- ) #! Copy nth element from vec-x to vec-y. diff --git a/library/test/generic.factor b/library/test/generic.factor index 0cbecc6234..da9ddfcbbe 100644 --- a/library/test/generic.factor +++ b/library/test/generic.factor @@ -92,6 +92,16 @@ M: very-funny gooey sq ; [ cons ] [ [ 1 2 ] class ] unit-test +[ t ] [ \ fixnum \ integer class< ] unit-test +[ t ] [ \ fixnum \ fixnum class< ] unit-test +[ f ] [ \ integer \ fixnum class< ] unit-test +[ t ] [ \ integer \ object class< ] unit-test +[ f ] [ \ integer \ null class< ] unit-test +[ t ] [ \ null \ object class< ] unit-test +[ t ] [ \ list \ general-list class< ] unit-test +[ t ] [ \ list \ object class< ] unit-test +[ t ] [ \ null \ list class< ] unit-test + [ t ] [ \ generic \ compound class< ] unit-test [ f ] [ \ compound \ generic class< ] unit-test diff --git a/library/test/hashtables.factor b/library/test/hashtables.factor index c1b2224591..802c5b5d97 100644 --- a/library/test/hashtables.factor +++ b/library/test/hashtables.factor @@ -12,7 +12,7 @@ USE: sequences : silly-key/value dup dup * swap ; -1000 [ [ silly-key/value "testhash" get set-hash ] keep ] repeat +1000 [ silly-key/value "testhash" get set-hash ] each [ f ] [ 1000 >list [ silly-key/value "testhash" get hash = not ] subset ] diff --git a/library/test/httpd/httpd.factor b/library/test/httpd/httpd.factor index 5289aa309c..0912ef2a3c 100644 --- a/library/test/httpd/httpd.factor +++ b/library/test/httpd/httpd.factor @@ -13,9 +13,6 @@ USE: lists [ "text/html" 12 file-response ] string-out ] unit-test -[ 5430 ] -[ f "Content-Length: 5430" header-line content-length ] unit-test - [ [ [[ "X-Spyware-Requested" "yes" ]] diff --git a/library/test/image.factor b/library/test/image.factor deleted file mode 100644 index 7793387719..0000000000 --- a/library/test/image.factor +++ /dev/null @@ -1,28 +0,0 @@ -IN: temporary -USE: test -USE: image -USE: namespaces -USE: io -USE: parser -USE: kernel -USE: generic -USE: math - -[ "ab\0\0" ] [ 4 "ab" align-string ] unit-test - -[ { 0 } ] [ - [ "\0\0\0\0" emit-chars ] with-minimal-image -] unit-test - -[ { 6815845 7077996 7274528 7798895 7471212 6553600 } ] -[ - [ - "big-endian" on - [ "hello world" pack-string ] with-minimal-image - ] with-scope -] unit-test - -[ "\0\0\0\0\u000f\u000e\r\u000c" ] -[ - [ image-magic 8 >be write ] string-out -] unit-test diff --git a/library/test/inference.factor b/library/test/inference.factor index 0dc5f7d178..01419231a4 100644 --- a/library/test/inference.factor +++ b/library/test/inference.factor @@ -195,6 +195,10 @@ M: real iterate drop ; [ [ 2 1 ] ] [ [ remove ] infer ] unit-test [ [ 1 1 ] ] [ [ prune ] infer ] unit-test +: bad-code "1234" car ; + +[ [ 0 1 ] ] [ [ bad-code ] infer ] unit-test + ! Type inference ! [ [ [ object ] [ ] ] ] [ [ drop ] infer ] unit-test diff --git a/library/test/math/matrices.factor b/library/test/math/matrices.factor index 1bf9f75762..cb1f47f00f 100644 --- a/library/test/math/matrices.factor +++ b/library/test/math/matrices.factor @@ -76,13 +76,6 @@ vectors ; m.v ] unit-test -[ - { { 8 2 3 } { 9 5 6 } } -] [ - { { 1 2 3 } { 4 5 6 } } clone - dup { 8 9 } 0 rot set-nth -] unit-test - [ { 0 0 1 } ] [ { 1 0 0 } { 0 1 0 } cross ] unit-test [ { 1 0 0 } ] [ { 0 1 0 } { 0 0 1 } cross ] unit-test [ { 0 1 0 } ] [ { 0 0 1 } { 1 0 0 } cross ] unit-test @@ -103,7 +96,7 @@ unit-test { { 7 } { 4 8 } { 1 5 9 } { 2 6 } { 3 } } ] [ { { 1 2 3 } { 4 5 6 } { 7 8 9 } } - 5 [ 2 - swap >vector ] map-with + 5 [ 2 - >vector ] map-with ] unit-test [ { t t t } ] diff --git a/library/test/memory.factor b/library/test/memory.factor index 3202b86e68..4e1710b0b4 100644 --- a/library/test/memory.factor +++ b/library/test/memory.factor @@ -8,17 +8,15 @@ TUPLE: testing x y z ; [ ] [ num-types [ - [ - builtin-type [ - dup \ cons = [ - ! too many conses! - drop - ] [ - "predicate" word-prop instances [ - class drop - ] each - ] ifte - ] when* - ] keep - ] repeat + builtin-type [ + dup \ cons = [ + ! too many conses! + drop + ] [ + "predicate" word-prop instances [ + class drop + ] each + ] ifte + ] when* + ] each ] unit-test diff --git a/library/test/parse-number.factor b/library/test/parse-number.factor index 5928452248..13c615324d 100644 --- a/library/test/parse-number.factor +++ b/library/test/parse-number.factor @@ -1,9 +1,9 @@ IN: temporary -USE: math -USE: parser -USE: strings -USE: test -USE: unparser +USING: errors kernel math parser test unparser ; + +: parse-number ( str -- num ) + #! Convert a string to a number; return f on error. + [ str>number ] [ [ drop f ] when ] catch ; [ f ] [ f parse-number ] diff --git a/library/test/sequences.factor b/library/test/sequences.factor index 32f09f9868..299404d1fd 100644 --- a/library/test/sequences.factor +++ b/library/test/sequences.factor @@ -70,7 +70,7 @@ unit-test [ { } ] [ { } flip ] unit-test -[ { "b" "e" } ] [ 1 { { "a" "b" "c" } { "d" "e" "f" } } >vector ] unit-test +[ { "b" "e" } ] [ 1 { { "a" "b" "c" } { "d" "e" "f" } } flip nth ] unit-test [ { { 1 4 } { 2 5 } { 3 6 } } ] [ { { 1 2 3 } { 4 5 6 } } flip ] unit-test diff --git a/library/test/test.factor b/library/test/test.factor index c00f80fdbe..e1356fb83d 100644 --- a/library/test/test.factor +++ b/library/test/test.factor @@ -17,8 +17,6 @@ M: assert error. : print-test ( input output -- ) "--> " write 2list . flush ; -: keep-datastack ( quot -- ) datastack slip set-datastack drop ; - : time ( code -- ) #! Evaluates the given code and prints the time taken to #! execute it. @@ -80,7 +78,7 @@ SYMBOL: failures "combinators" "continuations" "errors" "hashtables" "strings" "namespaces" "generic" "tuple" "files" "parser" - "parse-number" "image" "init" "io/io" + "parse-number" "init" "io/io" "listener" "vectors" "words" "unparser" "random" "stream" "math/bitops" "math/math-combinators" "math/rational" "math/float" diff --git a/library/test/tuple.factor b/library/test/tuple.factor index 947bf5025b..038b4ca4dd 100644 --- a/library/test/tuple.factor +++ b/library/test/tuple.factor @@ -81,3 +81,9 @@ TUPLE: delegate-clone ; [ << delegate-clone << empty f >> >> ] [ << delegate-clone << empty f >> >> clone ] unit-test + +[ t ] [ \ null \ delegate-clone class< ] unit-test +[ f ] [ \ object \ delegate-clone class< ] unit-test +[ f ] [ \ object \ delegate-clone class< ] unit-test +[ t ] [ \ delegate-clone \ tuple class< ] unit-test +[ f ] [ \ tuple \ delegate-clone class< ] unit-test diff --git a/library/tools/debugger.factor b/library/tools/debugger.factor index 986ff4ecbb..49bb88f7c6 100644 --- a/library/tools/debugger.factor +++ b/library/tools/debugger.factor @@ -87,13 +87,11 @@ M: object error. ( error -- ) . ; : :s ( -- ) "error-datastack" get reverse [.] ; : :r ( -- ) "error-callstack" get reverse [.] ; -: :n ( -- ) "error-namestack" get [.] ; -: :c ( -- ) "error-catchstack" get [.] ; : :get ( var -- value ) "error-namestack" get (get) ; : debug-help ( -- ) - [ :s :r :n :c ] [ unparse. bl ] each + [ :s :r ] [ unparse. bl ] each "show stacks at time of error." print \ :get unparse. " ( var -- value ) inspects the error namestack." print ; diff --git a/library/tools/jedit.factor b/library/tools/jedit.factor index cf556e7810..83468497aa 100644 --- a/library/tools/jedit.factor +++ b/library/tools/jedit.factor @@ -14,8 +14,8 @@ unparser words ; : jedit-server-info ( -- port auth ) jedit-server-file [ readln drop - readln parse-number - readln parse-number + readln str>number + readln str>number ] with-stream ; : make-jedit-request ( files params -- code ) diff --git a/library/tools/walker.factor b/library/tools/walker.factor index 9aa414aec8..050bfdaa51 100644 --- a/library/tools/walker.factor +++ b/library/tools/walker.factor @@ -17,14 +17,6 @@ sequences io strings vectors words ; #! executing quotation. meta-cf get . meta-executing get . meta-r get reverse [.] ; -: &n - #! Print stepper name stack. - meta-n get [.] ; - -: &c - #! Print stepper catch stack. - meta-c get [.] ; - : &get ( var -- value ) #! Get stepper variable value. meta-n get (get) ; @@ -50,7 +42,7 @@ sequences io strings vectors words ; set-callstack call ; : walk-banner ( -- ) - [ &s &r &n &c ] [ unparse. bl ] each + [ &s &r ] [ unparse. bl ] each "show stepper stacks." print \ &get unparse. " ( var -- value ) inspects the stepper namestack." print diff --git a/library/tools/word-tools.factor b/library/tools/word-tools.factor index 9b11506a8c..4b9b2336b5 100644 --- a/library/tools/word-tools.factor +++ b/library/tools/word-tools.factor @@ -8,7 +8,7 @@ hashtables parser ; : vocab-apropos ( substring vocab -- list ) #! Push a list of all words in a vocabulary whose names #! contain a string. - words [ word-name dupd subseq? ] subset nip ; + words [ word-name subseq? ] subset-with ; : vocab-apropos. ( substring vocab -- ) #! List all words in a vocabulary that contain a string. diff --git a/library/ui/paint.factor b/library/ui/paint.factor index 949ad32618..4ec8663e51 100644 --- a/library/ui/paint.factor +++ b/library/ui/paint.factor @@ -144,12 +144,10 @@ SYMBOL: bevel-2 M: bevel draw-boundary ( gadget boundary -- ) #! Ugly code. bevel-width [ - [ - >r origin get over rectangle-dim over v+ r> - { 1 1 0 } n*v tuck v- { 1 1 0 } v- >r v+ r> - rot draw-bevel - ] 2keep - ] repeat drop ; + >r origin get over rectangle-dim over v+ r> + { 1 1 0 } n*v tuck v- { 1 1 0 } v- >r v+ r> + rot draw-bevel + ] each-with ; M: gadget draw-gadget* ( gadget -- ) dup diff --git a/library/unix/io.factor b/library/unix/io.factor index 004f020c86..70ae15979d 100644 --- a/library/unix/io.factor +++ b/library/unix/io.factor @@ -29,9 +29,7 @@ USING: namespaces ; swap -5 shift set-alien-unsigned-4 ; : clear-bits ( alien len -- ) - bit-length [ - 0 pick pick set-alien-unsigned-cell - ] repeat drop ; + bit-length [ 0 -rot set-alien-unsigned-cell ] each-with ; ! Global variables SYMBOL: read-fdset diff --git a/library/vocabularies.factor b/library/vocabularies.factor index b8d7f6bb56..0d0e280e6f 100644 --- a/library/vocabularies.factor +++ b/library/vocabularies.factor @@ -81,10 +81,6 @@ SYMBOL: vocabularies dup word-name over word-vocabulary vocab ?hash eq? ; : init-search-path ( -- ) - ! For files - "scratchpad" "file-in" set - [ "syntax" "scratchpad" ] "file-use" set - ! For interactive "scratchpad" "in" set [ "compiler" "errors" "gadgets" "generic"