clean up class<, class-and, class-or

CHANGES.html

@@ -24,6 +24,7 @@
 <ul>Everything else:
 <li>Object slots are now clickable in the inspector</li>
 <li>The matrices library has been greatly simplified. Matrices are now represented as vectors of vectors, and matrix words have been moved to the <code>math</code> vocabulary.</li>
+<li>More descriptive "out of bounds" errors.</li>
 </ul>
 
 <h1>Factor 0.76:</h1>

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

contrib/cont-responder/cont-numbers-game.factor

@@ -69,7 +69,7 @@ USE: namespaces
         </form>
       </body>
     </html>
-  ] 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 ;

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

examples/mandel.factor

@@ -87,12 +87,10 @@ USE: test
 : val 0.85 ;
 
 : <color-map> ( nb-cols -- map )
-    [
+    dup [
-        dup [
+        360 * swap 1 + / 360 / sat val
-            dup 360 * pick 1 + / 360 / sat val
+        hsv>rgb 1.0 scale-rgb
-            hsv>rgb 1.0 scale-rgb ,
+    ] map-with ;
-        ] repeat
-    ] make-vector nip ;
 
 : iter ( c z nb-iter -- x )
     over absq 4 >= over 0 = or [

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 ;

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 [
+    image get [ dup word? [ fixup-word ] when ] nmap ;
-        dup word? [ fixup-word ] when
-    ] map image set ;
 
 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 -- )
+: emit-chars ( seq -- )
-    tuck length - CHAR: \0 fill append ;
+    "big-endian" get [ [ reverse ] map ] unless
+    [ 0 [ swap 16 shift + ] reduce emit ] each ;
 
-: emit-chars ( str -- )
+: pack-string ( string -- seq )
-    "big-endian" get [ reverse ] unless
+    dup length 1 + char align CHAR: \0 pad-right char swap group ;
-    0 swap [ swap 16 shift + ] each emit ;
 
-: (pack-string) ( n list -- )
+: emit-string ( string -- ptr )
-    #! 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 -- )
     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 [ ] [
+    "objects" get [ emit-string ] cache ;
-        dup emit-string dup >r pool-object r>
-    ] ?ifte ;
 
 ( 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!
+    "objects" get [ emit-hashtable ] cache ;
-    dup pooled-object [ ] [
-        dup emit-hashtable [ pool-object ] keep
-    ] ?ifte ;
 
 ( End of the image )
 
-: vocabulary, ( hash -- )
+: words, ( -- )
-    dup hashtable? [
+    all-words [ emit-word ] each ;
-        [ cdr dup word? [ word, ] [ drop ] ifte ] hash-each
-    ] [
-        drop
-    ] ifte ;
-
-: vocabularies, ( vocabularies -- )
-    [ cdr vocabulary, ] hash-each ;
 
 : global, ( -- )
-    vocabularies get
-    dup vocabularies,
     <namespace> [
-        vocabularies set
+        { vocabularies typemap builtins crossref }
-        typemap [ ] change
+        [ [ ] change ] each
-        builtins [ ] change
-        crossref [ ] change
     ] 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
     <file-writer> [ (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

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
+USING: alien assembler compiler errors files generic generic
-hashtables generic alien assembler compiler errors files generic
+hashtables hashtables io io-internals kernel kernel
-io-internals kernel kernel-internals lists math math-internals
+kernel-internals lists lists math math math-internals memory
-parser profiler strings unparser vectors words hashtables
+namespaces parser parser profiler sequences strings unparser
-sequences ;
+vectors vectors words words ;
+
+"Creating primitives and basic runtime structures..." print
 
 ! This symbol needs the same hashcode in the target as in the
 ! host.

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

library/collections/sequences-epilogue.factor

@@ -208,7 +208,9 @@ M: object reverse ( seq -- seq ) [ <reversed> ] keep like ;
 : flip ( seq -- seq )
     #! An example illustrates this word best:
     #! { { 1 2 3 } { 4 5 6 } } ==> { { 1 2 } { 3 4 } { 5 6 } }
-    <flipped> [ 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 ) [ <reversed> ] 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 )

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 ;

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

library/generic/complement.factor

@@ -17,20 +17,14 @@ complement [
 complement [
     ( generic vtable definition class -- )
     drop num-types [
-        [
+        >r 3dup r> builtin-type
-            >r 3dup r> builtin-type
+        dup [ add-method ] [ 2drop 2drop ] ifte
-            dup [ add-method ] [ 2drop 2drop ] ifte
+    ] each 3drop
-        ] keep
-    ] repeat 3drop
 ] "add-method" set-word-prop
 
-complement 90 "priority" set-word-prop
+complement 50 "priority" set-word-prop
 
-complement [
+complement [ (class<) ] "class<" set-word-prop
-    swap "complement" word-prop
-    swap "complement" word-prop
-    class< not
-] "class<" set-word-prop
 
 : complement-predicate ( complement -- list )
     "predicate" word-prop [ not ] append ;

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 = [
+    over class-ord over class-ord - dup 0 = [
-        dup metaclass "class<" word-prop call
+        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
+    2dup class< [
-    swap builtin-supertypes
+        nip
-    seq-union lookup-union ;
+    ] [
+        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
+    2dup class< [
-    seq-intersect lookup-union ;
+        drop
+    ] [
+        2dup swap class< [
+            nip 
+        ] [
+            2types seq-intersect lookup-union
+        ] ifte
+    ] ifte ;
 
 : define-class ( class metaclass -- )
     dupd "metaclass" set-word-prop

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 40 "priority" set-word-prop
-null [ 2drop t ] "class<" set-word-prop
+null [ (class<) ] "class<" set-word-prop
 null null define-class

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

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
 

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 = ;
 

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 [
+union [ (class<) ] "class<" set-word-prop
-    swap builtin-supertypes swap builtin-supertypes contained?
-] "class<" set-word-prop
 
 : union-predicate ( definition -- list )
     [

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

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* [

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 ;

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
+        -rot length meta-d get
-        literal-inputs
+        literal-inputs [
-        host-word
+            apply-datastack
-        r> length meta-d get literal-outputs
+        ] [
+            [ "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

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

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)
+: apply-default ( 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.
     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 -- )
+M: word apply-object ( 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 -- )
     apply-default ;
 
-M: compound apply-word ( word -- )
+M: symbol apply-object ( word -- )
-    dup "inline" word-prop [
+    apply-literal ;
-        inline-compound
-    ] [
-        apply-default
-    ] ifte ;
 
 : (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 [

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 <diagonal> [ drop 1 ] nmap ;
+    dup zero-matrix dup 0 <diagonal> [ 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 ) <flipped> [ v. ] map-with ; inline
+: v.m ( v m -- v ) flip [ v. ] map-with ;
-: m.v ( m v -- v ) swap [ v. ] map-with ; inline
+: m.v ( m v -- v ) swap [ v. ] map-with ;
-: m.  ( m m -- m ) <flipped> swap [ m.v ] map-with ;
+: m.  ( m m -- m ) flip swap [ m.v ] map-with ;
 
-: trace ( matrix -- tr ) 0 swap <diagonal> product ;
+: trace ( matrix -- tr ) 0 <diagonal> product ;

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)

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> ;

library/syntax/parse-stream.factor

@@ -4,37 +4,25 @@ IN: parser
 USING: kernel lists namespaces sequences io ;
 
 : file-vocabs ( -- )
-    "file-in" get "in" set
+    "scratchpad" "in" set
-    "file-use" get "use" set ;
+    [ "syntax" "scratchpad" ] "use" set ;
 
-: (parse-stream) ( name stream -- quot )
+: (parse-stream) ( stream -- quot )
-    #! Uses the current namespace for temporary variables.
+    [ f swap [ (parse) ] read-lines reverse ] with-parser ;
-    [
-        >r file set f ( initial parse tree ) r>
-        [ (parse) ] read-lines reverse
-        file off
-        line-number off
-    ] 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 <file-reader> 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 <file-reader> (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

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 ;

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 ;

library/test/benchmark/empty-loop.factor

@@ -1,8 +1,5 @@
 IN: temporary
-USE: compiler
+USING: compiler kernel math sequences test ;
-USE: kernel
-USE: math
-USE: 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

library/test/benchmark/fac.factor

@@ -1,8 +1,5 @@
 IN: temporary
-USE: math
+USING: compiler kernel math sequences test ;
-USE: test
-USE: compiler
-USE: kernel
 
 : (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
 

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 [

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 <vector> swap [ [ dup pick set-nth ] keep ] repeat ; compiled
+    dup <vector> swap [ dup pick set-nth ] each ; compiled
 
 : copy-elt ( vec-y vec-x n -- )
     #! Copy nth element from vec-x to vec-y.

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
 

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 ]

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" ]]

library/test/image.factor

@@ -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

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

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 <flipped> { 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 <diagonal> >vector ] map-with
+    5 [ 2 - <diagonal> >vector ] map-with
 ] unit-test
 
 [ { t t t } ]

library/test/memory.factor

@@ -8,17 +8,15 @@ TUPLE: testing x y z ;
 
 [ ] [
     num-types [
-        [
+        builtin-type [
-            builtin-type [
+            dup \ cons = [
-                dup \ cons = [
+                ! too many conses!
-                    ! too many conses!
+                drop
-                    drop
+            ] [
-                ] [
+                "predicate" word-prop instances [
-                    "predicate" word-prop instances [
+                    class drop
-                        class drop
+                ] each
-                    ] each
+            ] ifte
-                ] ifte
+        ] when*
-            ] when*
+    ] each
-        ] keep
-    ] repeat
 ] unit-test

library/test/parse-number.factor

@@ -1,9 +1,9 @@
 IN: temporary
-USE: math
+USING: errors kernel math parser test unparser ;
-USE: parser
+
-USE: strings
+: parse-number ( str -- num )
-USE: test
+    #! Convert a string to a number; return f on error.
-USE: unparser
+    [ str>number ] [ [ drop f ] when ] catch ;
 
 [ f ]
 [ f parse-number ]

library/test/sequences.factor

@@ -70,7 +70,7 @@ unit-test
 
 [ { } ] [ { } flip ] unit-test
 
-[ { "b" "e" } ] [ 1 { { "a" "b" "c" } { "d" "e" "f" } } <column> >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

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"

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

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 ;

library/tools/jedit.factor

@@ -14,8 +14,8 @@ unparser words ;
 : jedit-server-info ( -- port auth )
     jedit-server-file <file-reader> [
         readln drop
-        readln parse-number
+        readln str>number
-        readln parse-number
+        readln str>number
     ] with-stream ;
 
 : make-jedit-request ( files params -- code )

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

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.

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>
-            >r origin get over rectangle-dim over v+ r>
+        { 1 1 0 } n*v tuck v- { 1 1 0 } v- >r v+ r>
-            { 1 1 0 } n*v tuck v- { 1 1 0 } v- >r v+ r>
+        rot draw-bevel
-            rot draw-bevel
+    ] each-with ;
-        ] 2keep
-    ] repeat drop ;
 
 M: gadget draw-gadget* ( gadget -- )
     dup

library/unix/io.factor

@@ -29,9 +29,7 @@ USING: namespaces ;
     swap -5 shift set-alien-unsigned-4 ;
 
 : clear-bits ( alien len -- )
-    bit-length [
+    bit-length [ 0 -rot set-alien-unsigned-cell ] each-with ;
-        0 pick pick set-alien-unsigned-cell
-    ] repeat drop ;
 
 ! Global variables
 SYMBOL: read-fdset

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"