big generic word cleanup; kill-literals optimization; continuations overhaul

CHANGES.html

@@ -30,6 +30,7 @@
 
 <ul>
 <li>The distinct <code>t</code> type is gone. Now, the <code>t</code> object is just a symbol.</li>
+<li>Hashtables did not obey the rule that equal objects must have equal hashcodes, so using hashtables as hashtable keys did not work.</li>
 </ul>
 
 </ul>

TODO.FACTOR.txt

@@ -1,3 +1,5 @@
+- quot>interp needs to go
+
 + ui:
 
 - fix up the min thumb size hack
@@ -61,7 +63,6 @@
 
 + sequences:
 
-- typemap keys need to be arrays
 - split: return vectors
 - specialized arrays
 - instances: do not use make-list

library/bootstrap/boot-stage1.factor

@@ -81,8 +81,6 @@ sequences io vectors words ;
         "/library/generic/standard-combination.factor"
         "/library/generic/slots.factor"
         "/library/generic/math-combination.factor"
-        "/library/generic/predicate.factor"
-        "/library/generic/union.factor"
         "/library/generic/tuple.factor"
 
         "/library/syntax/generic.factor"

library/bootstrap/image.factor

@@ -14,9 +14,6 @@ USING: arrays errors generic hashtables kernel lists
 math namespaces parser prettyprint sequences
 sequences-internals io strings vectors words ;
 
-! If true in current namespace, we are bootstrapping.
-SYMBOL: bootstrapping?
-
 ! The image being constructed; a vector of word-size integers
 SYMBOL: image
 
@@ -292,6 +289,7 @@ M: hashtable ' ( hashtable -- pointer )
         "Object cache size: " write objects get hash-size .
         image get
         \ word global remove-hash
+        namespace global [ "foobar" set ] bind
     ] with-scope ;
 
 : make-image ( name -- )

library/bootstrap/primitives.factor

@@ -12,7 +12,7 @@ words ;
 
 ! These symbols need the same hashcode in the target as in the
 ! host.
-{ vocabularies object null typemap builtins }
+{ vocabularies typemap builtins }
 
 ! Bring up a bare cross-compiling vocabulary.
 "syntax" vocab
@@ -251,18 +251,18 @@ FORGET: set-stack-effect
 ! word system.
 : builtin-predicate ( class predicate -- )
     [
-        over types first dup
+        over "type" word-prop dup
         tag-mask < \ tag \ type ? , , \ eq? ,
     ] [ ] make define-predicate ;
 
 : register-builtin ( class -- )
-    dup types first builtins get set-nth ;
+    dup "type" word-prop builtins get set-nth ;
 
 : define-builtin ( symbol type# predicate slotspec -- )
     >r >r >r
     dup intern-symbol
-    dup r> 1 <vector> [ push ] keep "types" set-word-prop
-    dup builtin define-class
+    dup r> "type" set-word-prop
+    dup define-class
     dup r> builtin-predicate
     dup r> intern-slots 2dup "slots" set-word-prop
     define-slots
@@ -271,15 +271,9 @@ FORGET: set-stack-effect
 {{ }} clone typemap set
 num-types <array> builtins set
 
-! Catch-all metaclass for providing a default method.
-object num-types >vector "types" set-word-prop
-object [ drop t ] "predicate" set-word-prop
-object object define-class
-
-! Null metaclass with no instances.
-null { } "types" set-word-prop
-null [ drop f ] "predicate" set-word-prop
-null null define-class
+! These symbols are needed by the code that executes below
+"object" "generic" create drop
+"null" "generic" create drop
 
 "fixnum?" "math" create t "inline" set-word-prop
 "fixnum" "math" create 0 "fixnum?" "math" create { } define-builtin
@@ -383,6 +377,15 @@ null null define-class
 f "f" "!syntax" lookup builtins get remove [ ] subset
 define-union
 
+! Catch-all class for providing a default method.
+"object" "generic" create [ drop t ] "predicate" set-word-prop
+"object" "generic" create dup define-symbol
+f builtins get [ ] subset define-union
+
+! Null class with no instances.
+"null" "generic" create [ drop f ] "predicate" set-word-prop
+"null" "generic" create dup define-symbol f @{ }@ define-union
+
 FORGET: builtin-predicate
 FORGET: register-builtin
 FORGET: define-builtin

library/collections/cons.factor

@@ -47,5 +47,3 @@ M: cons = ( obj cons -- ? )
     ] ifte ;
 
 M: f = ( obj f -- ? ) eq? ;
-
-M: cons hashcode ( cons -- hash ) car hashcode ;

library/collections/hashtables.factor

@@ -154,11 +154,8 @@ M: hashtable = ( obj hash -- ? )
     ] ifte ;
 
 M: hashtable hashcode ( hash -- n )
-    dup bucket-count 0 number= [
-        drop 0
-    ] [
-        0 swap hash-bucket hashcode
-    ] ifte ;
+    #! Poor.
+    hash-size ;
 
 : cache ( key hash quot -- value | quot: key -- value )
     pick pick hash [
@@ -176,3 +173,20 @@ M: hashtable hashcode ( hash -- n )
 
 : ?set-hash ( value key hash/f -- hash )
     [ 1 <hashtable> ] unless* [ set-hash ] keep ;
+
+: hash-intersect ( hash1 hash2 -- hash1/\hash2 )
+    #! Remove all keys from hash2 not in hash1.
+    [ car swap hash ] hash-subset-with ;
+
+: hash-diff ( hash1 hash2 -- hash2-hash1 )
+    #! Remove all keys from hash2 in hash1.
+    [ car swap hash not ] hash-subset-with ;
+
+: hash-update ( hash1 hash2 -- )
+    #! Add all key/value pairs from hash2 to hash1.
+    [ unswons rot set-hash ] hash-each-with ;
+
+: hash-union ( hash1 hash2 -- hash1\/hash2 )
+    #! Make a new hashtable with all key/value pairs from
+    #! hash1 and hash2. Values in hash2 take precedence.
+    >r clone dup r> hash-update ;

library/collections/namespaces.factor

@@ -133,3 +133,8 @@ SYMBOL: hash-buffer
         (closure)
         hash-buffer get hash-keys
     ] with-scope ;
+
+IN: lists
+
+: alist>quot ( default alist -- quot )
+    [ unswons [ % , , \ ifte , ] [ ] make ] each ;

library/collections/sequence-eq.factor

@@ -8,12 +8,10 @@ vectors ;
 ! defined tuples that respond to the sequence protocol.
 UNION: sequence array string sbuf vector ;
 
-: length= ( seq seq -- ? ) length swap length number= ; flushable
-
 : sequence= ( seq seq -- ? )
     #! Check if two sequences have the same length and elements,
     #! but not necessarily the same class.
-    2dup length= [
+    2dup [ length ] 2apply = [
         dup length [ >r 2dup r> 2nth-unsafe = ] all? 2nip
     ] [
         2drop f
@@ -26,6 +24,10 @@ M: sequence = ( obj seq -- ? )
         over type over type eq? [ sequence= ] [ 2drop f ] ifte
     ] ifte ;
 
+M: sequence hashcode ( seq -- n )
+    #! Poor
+    length ;
+
 M: string = ( obj str -- ? )
     over string? [
         over hashcode over hashcode number=

library/collections/sequences-epilogue.factor

@@ -36,6 +36,9 @@ M: object >list ( seq -- list ) dup length 0 rot (>list) ;
 : memq?   ( obj seq -- ? )     [ eq? ] contains-with? ; flushable
 : remove  ( obj list -- list ) [ = not ] subset-with ; flushable
 
+: remove-all ( seq1 seq2 -- seq2-seq1 )
+    [ swap member? not ] subset-with ; flushable
+
 : move ( to from seq -- )
     pick pick number=
     [ 3drop ] [ [ nth swap ] keep set-nth ] ifte ; inline
@@ -48,6 +51,7 @@ M: object >list ( seq -- list ) dup length 0 rot (>list) ;
     ] when ;
 
 : delete ( elt seq -- )
+    #! Delete all occurrences of elt from seq.
     0 0 rot (delete) nip set-length drop ;
 
 : copy-into-check ( start to from -- )
@@ -56,10 +60,13 @@ M: object >list ( seq -- list ) dup length 0 rot (>list) ;
     ] when ;
 
 : copy-into ( start to from -- )
+    #! Copy all elements in 'from' to 'to', storing at
+    #! consecutive indices numbered from 'start'.
     3dup copy-into-check
     dup length [ >r pick r> + pick set-nth-unsafe ] 2each 2drop ;
 
 : nappend ( to from -- )
+    #! Add all elements of 'from' at the end of 'to'.
     >r dup length swap r>
     over length over length + pick set-length
     copy-into ;
@@ -118,20 +125,6 @@ M: object reverse-slice ( seq -- seq ) <reversed> ;
 
 M: object reverse ( seq -- seq ) [ <reversed> ] keep like ;
 
-! Set theoretic operations
-: seq-intersect ( seq1 seq2 -- seq1/\seq2 )
-    [ swap member? ] subset-with ; flushable
-
-: seq-diff ( seq1 seq2 -- seq2-seq1 )
-    [ swap member? not ] subset-with ; flushable
-
-: seq-union ( seq1 seq2 -- seq1\/seq2 )
-    append prune ; flushable
-
-: contained? ( seq1 seq2 -- ? )
-    #! Is every element of seq1 in seq2
-    swap [ swap member? ] all-with? ; flushable
-
 ! Lexicographic comparison
 : lexi ( s1 s2 -- n )
     #! Lexicographically compare two sequences of numbers

library/collections/slicing.factor

@@ -24,10 +24,8 @@ M: object tail ( index seq -- seq ) [ tail-slice ] keep like ;
 
 : tail* ( n seq -- seq ) [ tail-slice* ] keep like ; flushable
 
-: length< ( seq seq -- ? ) swap length swap length < ; flushable
-
 : head? ( seq begin -- ? )
-    2dup length< [
+    2dup [ length ] 2apply < [
         2drop f
     ] [
         dup length rot head-slice sequence=
@@ -37,7 +35,7 @@ M: object tail ( index seq -- seq ) [ tail-slice ] keep like ;
     2dup head? [ length swap tail t ] [ drop f ] ifte ; flushable
 
 : tail? ( seq end -- ? )
-    2dup length< [
+    2dup [ length ] 2apply < [
         2drop f
     ] [
         dup length rot tail-slice* sequence=

library/collections/vectors.factor

@@ -16,9 +16,6 @@ M: vector set-nth-unsafe ( obj n vec -- )
 M: vector set-nth ( obj n vec -- )
     growable-check 2dup ensure set-nth-unsafe ;
 
-M: vector hashcode ( vec -- n )
-    dup length 0 number= [ drop 0 ] [ first hashcode ] ifte ;
-
 : >vector ( list -- vector )
     dup length <vector> [ swap nappend ] keep ; inline
 

library/compiler/compiler.factor

@@ -46,6 +46,7 @@ words ;
 \ split-blocks profile
 \ simplify profile
 \ keep-optimizing profile
+\ literals profile
 \ kill-set profile
 \ kill-node profile
 \ infer-classes profile

library/continuations.factor

@@ -1,7 +1,7 @@
 ! Copyright (C) 2003, 2005 Slava Pestov.
 ! See http://factor.sf.net/license.txt for BSD license.
 IN: kernel
-USING: errors lists namespaces sequences words vectors ;
+USING: arrays errors lists namespaces sequences words vectors ;
 
 TUPLE: interp data call name catch ;
 
@@ -21,7 +21,7 @@ TUPLE: interp data call name catch ;
     #! Make a continuation that executes the quotation.
     #! The quotation should not return, or a call stack
     #! underflow will be signalled.
-    { } swap 1 <vector> [ push ] keep f f <interp> ;
+    { } f rot 2array >vector f f <interp> ;
 
 : continue ( continuation -- )
     #! Restore a continuation.

library/generic/generic.factor

@@ -1,7 +1,7 @@
 ! Copyright (C) 2004, 2005 Slava Pestov.
 ! See http://factor.sf.net/license.txt for BSD license.
 IN: generic
-USING: errors hashtables kernel kernel-internals lists
+USING: arrays errors hashtables kernel kernel-internals lists
 namespaces parser sequences strings words vectors math
 math-internals ;
 
@@ -10,16 +10,9 @@ math-internals ;
 ! Maps lists of builtin type numbers to class objects.
 SYMBOL: typemap
 
-! Forward definitions.
-SYMBOL: object
-SYMBOL: null
-
 ! Global vector mapping type numbers to builtin class objects.
 SYMBOL: builtins
 
-! Builtin metaclass
-SYMBOL: builtin
-
 : type>class ( n -- symbol ) builtins get nth ;
 
 : predicate-word ( word -- word )
@@ -35,26 +28,44 @@ SYMBOL: builtin
         3drop
     ] ifte ;
 
-: metaclass ( class -- metaclass )
-    "metaclass" word-prop ;
+: superclass "superclass" word-prop ;
+
+: members "members" word-prop ;
+
+: (flatten) ( class -- )
+    dup members [ [ (flatten) ] each ] [ dup set ] ?ifte ;
+
+: flatten ( class -- classes )
+    #! Outputs a sequence of classes whose union is this class.
+    [ (flatten) ] make-hash ;
+
+DEFER: types
+
+: (types) ( class -- )
+    #! Only valid for a flattened class.
+    dup superclass [ types % ] [ "type" word-prop , ] ?ifte ;
 
 : types ( class -- types )
-    dup "types" word-prop [ ] [
-        "superclass" word-prop [ types ] [ [ ] ] ifte*
-    ] ?ifte ;
+    [ flatten hash-keys [ (types) ] each ] { } make prune ;
 
-: 2types ( class class -- seq seq ) swap types swap types ;
+DEFER: class<
 
-: custom-class< metaclass "class<" word-prop ;
+: superclass< ( cls1 cls2 -- ? )
+    >r superclass r> over [ class< ] [ 2drop f ] ifte ;
+
+: (class<) ( cls1 cls2 -- ? )
+    [ flatten hash-keys ] 2apply
+    swap [ swap [ class< ] contains-with? ] all-with? ;
 
 : class< ( cls1 cls2 -- ? )
     #! Test if class1 is a subclass of class2.
     @{
         @{ [ 2dup eq? ] [ 2drop t ] }@
-        @{ [ over types empty? ] [ 2drop t ] }@
-        @{ [ dup types empty? ] [ 2drop f ] }@
-        @{ [ dup custom-class< ] [ dup custom-class< call ] }@
-        @{ [ t ] [ 2types contained? ] }@
+        @{ [ over flatten hash-size 0 = ] [ 2drop t ] }@
+        @{ [ over superclass ] [ >r superclass r> class< ] }@
+        @{ [ dup superclass ] [ superclass< ] }@
+        @{ [ 2dup [ members ] 2apply or not ] [ 2drop f ] }@
+        @{ [ t ] [ (class<) ] }@
     }@ cond ;
 
 : class-compare ( cls1 cls2 -- -1/0/1 )
@@ -64,16 +75,28 @@ SYMBOL: builtin
     "methods" word-prop hash>alist [ 2car class-compare ] sort ;
 
 : order ( generic -- list )
-    "methods" word-prop hash-keys [ class-compare ] sort ;
+    methods [ car ] map ;
+
+PREDICATE: compound generic ( word -- ? )
+    "combination" word-prop ;
+
+M: generic definer drop \ G: ;
 
 : make-generic ( word -- )
     dup dup "combination" word-prop call define-compound ;
 
-: define-method ( class generic definition -- )
-    -rot
-    over metaclass word? [
-        over word-name " is not a class" append throw
+: class? ( word -- ? ) "class" word-prop ;
+
+: check-method ( class generic -- )
+    dup generic? [
+        dup word-name " is not a generic word" append throw
     ] unless
+    over "class" word-prop [
+        over word-name " is not a class" append throw
+    ] unless 2drop ;
+
+: define-method ( definition class generic -- )
+    >r reintern r> 2dup check-method
     [ "methods" word-prop set-hash ] keep make-generic ;
 
 : forget-method ( class generic -- )
@@ -100,41 +123,41 @@ SYMBOL: builtin
     dupd "combination" set-word-prop
     dup init-methods make-generic ;
 
-PREDICATE: compound generic ( word -- ? )
-    "combination" word-prop ;
+: lookup-union ( class-set -- class )
+    #! The class set is a hashtable with equal keys/values.
+    typemap get hash [ object ] unless* ;
 
-M: generic definer drop \ G: ;
-
-: lookup-union ( typelist -- class )
-    number-sort typemap get hash [ object ] unless* ;
-
-: class-or ( class class -- class )
-    #! Return a class that both classes are subclasses of.
-    2dup class< [
-        nip
+: (builtin-supertypes) ( class -- )
+    dup members [
+        [ (builtin-supertypes) ] each
     ] [
-        2dup swap class< [
-            drop
+        dup superclass [
+            (builtin-supertypes)
         ] [
-            2types seq-union lookup-union
-        ] ifte
-    ] ifte ;
+            dup set
+        ] ?ifte
+    ] ?ifte ;
+
+: builtin-supertypes ( class -- classes )
+    #! Outputs a sequence of builtin classes whose union is the
+    #! smallest union of builtin classes that contains this
+    #! class.
+    [ (builtin-supertypes) ] make-hash ;
+
+: (class-and) ( class class -- class )
+    [ builtin-supertypes ] 2apply hash-intersect lookup-union ;
 
 : class-and ( class class -- class )
     #! Return a class that is a subclass of both, or null in
     #! the degenerate case.
-    2dup class< [
-        drop
-    ] [
-        2dup swap class< [
-            nip 
-        ] [
-            2types seq-intersect lookup-union
-        ] ifte
-    ] ifte ;
+    @{
+        @{ [ 2dup class< ] [ drop ] }@
+        @{ [ 2dup swap class< ] [ nip ] }@
+        @{ [ t ] [ (class-and) ] }@
+    }@ cond ;
 
 : classes-intersect? ( class class -- ? )
-    class-and null = not ;
+    class-and flatten hash-size 0 > ;
 
 : min-class ( class seq -- class/f )
     #! Is this class the smallest class in the sequence?
@@ -142,9 +165,9 @@ M: generic definer drop \ G: ;
     [ class-compare neg ] sort
     tuck [ class< ] all-with? [ first ] [ drop f ] ifte ;
 
-: define-class ( class metaclass -- )
-    dupd "metaclass" set-word-prop
-    dup types number-sort typemap get set-hash ;
+: define-class ( class -- )
+    dup t "class" set-word-prop
+    dup flatten typemap get set-hash ;
 
 : implementors ( class -- list )
     #! Find a list of generics that implement a method
@@ -153,4 +176,30 @@ M: generic definer drop \ G: ;
 
 : classes ( -- list )
     #! Output a list of all defined classes.
-    [ metaclass ] word-subset ;
+    [ class? ] word-subset ;
+
+! Predicate classes for generalized predicate dispatch.
+: define-predicate-class ( class predicate definition -- )
+    pick define-class
+    3dup nip "definition" set-word-prop
+    pick superclass "predicate" word-prop
+    [ \ dup , % , [ drop f ] , \ ifte , ] [ ] make
+    define-predicate ;
+
+PREDICATE: word predicate "definition" word-prop ;
+
+! Union classes for dispatch on multiple classes.
+: union-predicate ( members -- list )
+    [
+        "predicate" word-prop \ dup swons [ drop t ] cons
+    ] map [ drop f ] swap alist>quot ;
+
+: set-members ( class members -- )
+    [ reintern ] map "members" set-word-prop ;
+
+: define-union ( class predicate members -- )
+    #! We have to turn the f object into the f word, same for t.
+    3dup nip set-members pick define-class
+    union-predicate define-predicate ;
+
+PREDICATE: word union members ;

library/generic/math-combination.factor

@@ -38,13 +38,16 @@ TUPLE: no-math-method left right generic ;
         literalize [ no-math-method ] cons
     ] ?ifte ;
 
+: object-method ( generic -- quot )
+    object reintern applicable-method ;
+
 : math-method ( word left right -- quot )
     swap type>class swap type>class 2dup and [
         2dup math-upgrade >r
         math-class-max over order min-class applicable-method
         r> swap append
     ] [
-        2drop object applicable-method
+        2drop object-method
     ] ifte ;
 
 : math-vtable ( picker quot -- )
@@ -62,7 +65,7 @@ TUPLE: no-math-method left right generic ;
         dup type>class math-class? [
             \ dup [ >r 2dup r> math-method ] math-vtable
         ] [
-            over object applicable-method
+            over object-method
         ] ifte nip
     ] math-vtable nip ;
 

library/generic/predicate.factor

@@ -1,25 +0,0 @@
-! Copyright (C) 2004, 2005 Slava Pestov.
-! See http://factor.sf.net/license.txt for BSD license.
-IN: generic
-USING: errors hashtables kernel lists namespaces parser
-sequences strings words vectors ;
-
-! Predicate metaclass for generalized predicate dispatch.
-SYMBOL: predicate
-
-predicate [
-    over metaclass over metaclass eq? [
-        >r "superclass" word-prop r> class<
-    ] [
-        2drop f
-    ] ifte
-] "class<" set-word-prop
-
-: define-predicate-class ( class predicate definition -- )
-    3dup nip "definition" set-word-prop
-    pick predicate "metaclass" set-word-prop
-    pick "superclass" word-prop "predicate" word-prop
-    [ \ dup , % , [ drop f ] , \ ifte , ] [ ] make
-    define-predicate ;
-
-PREDICATE: word predicate metaclass predicate = ;

library/generic/slots.factor

@@ -11,7 +11,7 @@ parser sequences strings words ;
     #! Just like:
     #! GENERIC: generic
     #! M: class generic def ;
-    over define-generic define-method ;
+    over define-generic -rot define-method ;
 
 : define-slot-word ( class slot word quot -- )
     over [

library/generic/standard-combination.factor

@@ -17,13 +17,10 @@ namespaces sequences vectors words ;
 : class-predicates ( picker assoc -- assoc )
     [ uncons >r "predicate" word-prop append r> cons ] map-with ;
 
-: alist>quot ( default alist -- quot )
-    [ unswons [ % , , \ ifte , ] [ ] make ] each ;
-
-: sort-methods ( assoc -- vtable )
+: sort-methods ( assoc n -- vtable )
     #! Input is a predicate -> method association.
-    num-types [
-        type>class [ object ] unless*
+    [
+        type>class [ object reintern ] unless*
         swap [ car classes-intersect? ] subset-with
     ] map-with ;
 
@@ -38,17 +35,16 @@ namespaces sequences vectors words ;
         nip car cdr [ ]
     ] ifte ;
 
-: vtable-methods ( picker alist-seq n -- alist-seq )
-    [
-        type>class [ object ] unless*
-        swap simplify-alist
+: vtable-methods ( picker alist-seq -- alist-seq )
+    dup length [
+        type>class [ swap simplify-alist ] [ car cdr [ ] ] ifte*
         >r over r> class-predicates alist>quot
     ] 2map nip ;
 
 : <vtable> ( picker word n -- vtable )
     #! n is vtable size; either num-types or num-tags.
-    >r 2dup empty-method \ object swons >r methods r> swons
-    sort-methods r> vtable-methods ;
+    >r 2dup empty-method \ object reintern
+    swons >r methods r> swons r> sort-methods vtable-methods ;
 
 : small-generic ( picker word -- def )
     2dup methods class-predicates >r empty-method r> alist>quot ;

library/generic/tuple.factor

@@ -67,8 +67,8 @@ words ;
     >r create-in
     dup intern-symbol
     dup tuple-predicate
-    dup tuple "superclass" set-word-prop
-    dup tuple "metaclass" set-word-prop
+    dup \ tuple reintern "superclass" set-word-prop
+    dup define-class
     dup r> tuple-slots
     default-constructor ;
 
@@ -77,13 +77,8 @@ M: tuple clone ( tuple -- tuple )
     (clone) dup delegate clone over set-delegate ;
 
 M: tuple hashcode ( vec -- n )
-    #! If the capacity is two, then all we have is the class
-    #! slot and delegate.
-    dup array-capacity 2 number= [
-        drop 0
-    ] [
-        2 swap array-nth hashcode
-    ] ifte ;
+    #! Poor.
+    array-capacity ;
 
 M: tuple = ( obj tuple -- ? )
     2dup eq? [
@@ -92,9 +87,7 @@ M: tuple = ( obj tuple -- ? )
         over tuple? [ array= ] [ 2drop f ] ifte
     ] ifte ;
 
-tuple [ 2drop f ] "class<" set-word-prop
-
-PREDICATE: word tuple-class metaclass tuple = ;
+PREDICATE: word tuple-class "tuple-size" word-prop ;
 
 : is? ( obj pred -- ? | pred: obj -- ? )
     #! Tests if the object satisfies the predicate, or if

library/generic/union.factor

@@ -1,24 +0,0 @@
-! Copyright (C) 2004, 2005 Slava Pestov.
-! See http://factor.sf.net/license.txt for BSD license.
-IN: generic
-USING: errors hashtables kernel lists namespaces parser
-sequences strings words vectors ;
-
-! Union metaclass for dispatch on multiple classes.
-SYMBOL: union
-
-: union-predicate ( members -- list )
-    [
-        "predicate" word-prop \ dup swons [ drop t ] cons
-    ] map [ drop f ] swap alist>quot ;
-
-: set-members ( class members -- )
-    2dup [ types ] map concat "types" set-word-prop
-    "members" set-word-prop ;
-
-: define-union ( class predicate members -- )
-    #! We have to turn the f object into the f word, same for t.
-    3dup nip set-members pick union define-class
-    union-predicate define-predicate ;
-
-PREDICATE: word union metaclass union = ;

library/inference/kill-literals.factor

@@ -1,121 +1,75 @@
 ! Copyright (C) 2004, 2005 Slava Pestov.
 ! See http://factor.sf.net/license.txt for BSD license.
 IN: optimizer
-USING: generic hashtables inference kernel lists
-matrices namespaces sequences vectors ;
+USING: arrays generic hashtables inference kernel
+namespaces sequences ;
+
+: node-union ( node quot -- hash | quot: node -- seq )
+    #! Build a hash with equal keys/values, effectively taking
+    #! the set union over all return values of the quotation.
+    [
+        swap [ swap call [ dup set ] each ] each-node-with
+    ] make-hash ; inline
 
 GENERIC: literals* ( node -- seq )
 
-: literals ( node -- seq )
-    [ [ literals* % ] each-node ] { } make prune ;
+: literals ( node -- hash )
+    [ literals* ] node-union ;
 
-GENERIC: can-kill* ( literal node -- ? )
+GENERIC: live-values* ( node -- seq )
 
-: can-kill? ( literal node -- ? )
-    dup [
-        2dup can-kill* [
-            node-successor can-kill?
-        ] [
-            2drop f
-        ] ifte
-    ] [
-        2drop t
-    ] ifte ;
+: live-values ( node -- hash )
+    #! All values that are returned or passed to calls.
+    [ live-values* ] node-union ;
 
-: kill-set ( node -- list )
+GENERIC: returns*
+
+: returns ( node -- hash )
+    #! Trace all control flow paths, build a hash of
+    #! final #return nodes.
+    [ returns* ] node-union ;
+
+: kill-set ( node -- seq )
     #! Push a list of literals that may be killed in the IR.
-    dup literals [ swap can-kill? ] subset-with ;
+    dup live-values swap literals hash-diff hash-keys ;
 
 : remove-values ( values node -- )
-    2dup [ node-in-d seq-diff ] keep set-node-in-d
-    2dup [ node-out-d seq-diff ] keep set-node-out-d
-    2dup [ node-in-r seq-diff ] keep set-node-in-r
-    [ node-out-r seq-diff ] keep set-node-out-r ;
+    2dup [ node-in-d remove-all ] keep set-node-in-d
+    2dup [ node-out-d remove-all ] keep set-node-out-d
+    2dup [ node-in-r remove-all ] keep set-node-in-r
+    [ node-out-r remove-all ] keep set-node-out-r ;
 
 : kill-node ( literals node -- )
     [ remove-values ] each-node-with ;
 
 ! Generic nodes
-M: node literals* ( node -- ) drop { } ;
+M: node literals* ( node -- seq ) drop @{ }@ ;
 
-M: node can-kill* ( literal node -- ? )
-    uses-value? not ;
+M: node live-values* ( node -- seq ) node-values ;
+
+M: node returns* ( node -- seq ) drop @{ }@ ;
 
 ! #shuffle
-M: #shuffle literals* ( node -- )
+M: #shuffle literals* ( node -- seq )
     node-out-d [ literal? ] subset ;
 
-M: #shuffle can-kill* ( literal node -- ? ) 2drop t ;
-
-! #call-label
-M: #call-label can-kill* ( literal node -- ? ) 2drop t ;
-
-! #merge
-M: #merge can-kill* ( literal node -- ? ) 2drop t ;
-
-! #entry
-M: #entry can-kill* ( literal node -- ? ) 2drop t ;
-
-! #values
-M: #values can-kill* ( literal node -- ? ) 2drop t ;
-
 ! #return
-SYMBOL: branch-returns
+M: #return returns* 1array ;
 
-GENERIC: returns*
+M: #return live-values* ( node -- seq )
+    #! Values returned by local labels can be killed.
+    dup node-param [ drop @{ }@ ] [ delegate live-values* ] ifte ;
 
+! nodes that don't use their input values directly
+UNION: #killable #shuffle #call-label #merge #entry #values ;
+
+M: #killable live-values* ( node -- seq ) drop @{ }@ ;
+
+! branching
 UNION: #branch #ifte #dispatch ;
 
-M: #branch returns*
-    node-children [ last-node returns* ] each ;
-
-M: #return returns* , ;
-
-M: node returns* node-successor returns* ;
-
-: returns ( node -- seq )
-    #! Trace all control flow paths, build a sequence of
-    #! final #return nodes.
-    [ returns* ] { } make ;
-
-: branch-values ( branches -- )
-    returns [ node-in-d ] map unify-lengths flip \ returns set ;
-
-M: #return can-kill* ( literal node -- ? )
-    #! Values returned by local labels can be killed.
-    dup node-param [
-        dupd uses-value? [
-            \ returns get
-            [ memq? ] subset-with
-            [ [ eq? ] monotonic? ] all?
-        ] [
-            drop t
-        ] ifte
-    ] [
-        delegate can-kill*
-    ] ifte ;
-
-: can-kill-branches? ( literal node -- ? )
-    #! Check if the literal appears in either branch. This
-    #! assumes that the last element of each branch is a #return
-    #! node.
-    2dup uses-value? [
-        2drop f
-    ] [
-        [
-            dup branch-values
-            node-children [ can-kill? ] all-with?
-        ] with-scope
-    ] ifte ;
-
-! #ifte
-M: #ifte can-kill* ( literal node -- ? )
-    can-kill-branches? ;
-
-! #dispatch
-M: #dispatch can-kill* ( literal node -- ? )
-    can-kill-branches? ;
-
-! #label
-M: #label can-kill* ( literal node -- ? )
-    node-child can-kill? ;
+M: #branch live-values* ( node -- seq )
+    #! This assumes that the last element of each branch is a
+    #! #return node.
+    returns hash-keys [ node-in-d ] map unify-lengths flip
+    [ [ eq? ] monotonic? not ] subset concat ;

library/inference/shuffle.factor

@@ -34,14 +34,14 @@ TUPLE: shuffle in-d in-r out-d out-r ;
     [ split-shuffle ] keep shuffle* join-shuffle ;
 
 : fix-compose-d ( s1 s2 -- )
-    over shuffle-out-d over shuffle-in-d length< [
+    over shuffle-out-d over shuffle-in-d [ length ] 2apply < [
         over shuffle-out-d length over shuffle-in-d head*
         [ pick shuffle-in-d append pick set-shuffle-in-d ] keep
         pick shuffle-out-d append pick set-shuffle-out-d
     ] when 2drop ;
 
 : fix-compose-r ( s1 s2 -- )
-    over shuffle-out-r over shuffle-in-r length< [
+    over shuffle-out-r over shuffle-in-r [ length ] 2apply < [
         over shuffle-out-r length over shuffle-in-r head*
         [ pick shuffle-in-r append pick set-shuffle-in-r ] keep
         pick shuffle-out-r append pick set-shuffle-out-r

library/io/files.factor

@@ -12,7 +12,7 @@ USING: kernel lists namespaces sequences strings ;
 : directory? ( file -- ? ) stat car ;
 
 : directory ( dir -- list )
-    (directory) { "." ".." } swap seq-diff string-sort ;
+    (directory) { "." ".." } swap remove-all string-sort ;
 
 : file-length ( file -- length ) stat third ;
 

library/kernel.factor

@@ -72,6 +72,9 @@ M: wrapper = ( obj wrapper -- ? )
 : 3keep ( x y z quot -- x y z | quot: x y z -- )
     >r 3dup r> swap >r swap >r swap >r call r> r> r> ; inline
 
+: 2apply ( x y quot -- | quot: x/y -- )
+    tuck 2slip call ; inline
+
 : ifte* ( cond true false -- | true: cond -- | false: -- )
     #! [ X ] [ Y ] ifte* ==> dup [ X ] [ drop Y ] ifte
     pick [ drop call ] [ 2nip call ] ifte ; inline

library/syntax/generic.factor

@@ -40,7 +40,7 @@ syntax words ;
 : M: ( -- class generic [ ] )
     #! M: foo bar begins a definition of the bar generic word
     #! specialized to the foo type.
-    scan-word scan-word [ define-method ] [ ] ; parsing
+    scan-word scan-word [ -rot define-method ] [ ] ; parsing
 
 : C:
     #! Followed by a tuple name, then constructor code, then ;

library/syntax/parse-stream.factor

@@ -1,7 +1,7 @@
 ! Copyright (C) 2004, 2005 Slava Pestov.
 ! See http://factor.sf.net/license.txt for BSD license.
 IN: parser
-USING: kernel lists namespaces sequences io words ;
+USING: io kernel lists math namespaces sequences words ;
 
 : file-vocabs ( -- )
     "scratchpad" "in" set
@@ -10,7 +10,7 @@ USING: kernel lists namespaces sequences io words ;
 : parse-lines ( lines -- quot )
     [
         dup length [ ]
-        [ line-number set (parse) ] 2reduce
+        [ 1 + line-number set (parse) ] 2reduce
         reverse
     ] with-parser ;
 

library/syntax/prettyprint.factor

@@ -226,7 +226,6 @@ M: string pprint* ( str -- str ) "\"" pprint-string ;
 M: sbuf pprint* ( str -- str ) "SBUF\" " pprint-string ;
 
 M: word pprint* ( word -- )
-    dup interned? [ "( uninterned )" f text ] unless
     dup "pprint-before-hook" word-prop call
     dup pprint-word
     "pprint-after-hook" word-prop call ;
@@ -360,6 +359,7 @@ M: wrapper pprint* ( wrapper -- )
 {
     { POSTPONE: [ POSTPONE: ] }
     { POSTPONE: { POSTPONE: } }
+    { POSTPONE: @{ POSTPONE: }@ }
     { POSTPONE: {{ POSTPONE: }} }
     { POSTPONE: [[ POSTPONE: ]] }
     { POSTPONE: [[ POSTPONE: ]] }

library/syntax/see.factor

@@ -81,7 +81,7 @@ GENERIC: class. ( word -- )
 
 : methods. ( class -- )
     #! List all methods implemented for this class.
-    dup metaclass [
+    dup class? [
         dup implementors [
             dup in. tuck "methods" word-prop hash* method.
         ] each-with
@@ -92,11 +92,11 @@ GENERIC: class. ( word -- )
 M: union class.
     \ UNION: pprint-word
     dup pprint-word
-    "members" word-prop pprint-elements pprint-; newline ;
+    members pprint-elements pprint-; newline ;
 
 M: predicate class.
     \ PREDICATE: pprint-word
-    dup "superclass" word-prop pprint-word
+    dup superclass pprint-word
     dup pprint-word
     <block
     "definition" word-prop pprint-elements

library/test/collections/hashtables.factor

@@ -146,3 +146,34 @@ f 100000000000000000000000000 "testhash" get set-hash
 [ 5 ] [ 2 "cache-test" get [ 3 + ] cache ] unit-test
 [ 4 ] [ 1 "cache-test" get [ 3 + ] cache ] unit-test
 [ 5 ] [ 2 "cache-test" get [ 3 + ] cache ] unit-test
+
+[
+    {{ [[ "factor" "rocks" ]] [[ 3 4 ]] }}
+] [
+    {{ [[ "factor" "rocks" ]] [[ "dup" "sq" ]] [[ 3 4 ]] }}
+    {{ [[ "factor" "rocks" ]] [[ 1 2 ]] [[ 2 3 ]] [[ 3 4 ]] }}
+    hash-intersect
+] unit-test
+
+[
+    {{ [[ 1 2 ]] [[ 2 3 ]] }}
+] [
+    {{ [[ "factor" "rocks" ]] [[ "dup" "sq" ]] [[ 3 4 ]] }}
+    {{ [[ "factor" "rocks" ]] [[ 1 2 ]] [[ 2 3 ]] [[ 3 4 ]] }}
+    hash-diff
+] unit-test
+
+[
+    t
+] [
+    {{ [[ "hello" "world" ]] }}
+    clone
+    100 [ 1 + over set-bucket-count hashcode ] map-with [ = ] monotonic?
+] unit-test
+
+[
+    {{ [[ 1 2 ]] [[ 2 3 ]] [[ 6 5 ]] }}
+] [
+    {{ [[ 2 4 ]] [[ 6 5 ]] }} {{ [[ 1 2 ]] [[ 2 3 ]] }}
+    hash-union
+] unit-test

library/test/collections/sequences.factor

@@ -98,10 +98,7 @@ unit-test
 [ f ] [ 3 [ 1 2 3 ] tail ] unit-test
 [ [ 3 ] ] [ 2 [ 1 2 3 ] tail ] unit-test
 
-[ [ 1 3 ] ] [ [ 2 ] [ 1 2 3 ] seq-diff ] unit-test
-
-[ t ] [ [ 1 2 3 ] [ 1 2 3 4 5 ] contained? ] unit-test
-[ f ] [ [ 1 2 3 6 ] [ 1 2 3 4 5 ] contained? ] unit-test
+[ [ 1 3 ] ] [ [ 2 ] [ 1 2 3 ] remove-all ] unit-test
 
 [ t ] [ [ 1 2 3 ] [ 1 2 3 ] sequence= ] unit-test
 [ t ] [ [ 1 2 3 ] { 1 2 3 } sequence= ] unit-test

library/test/continuations.factor

@@ -34,3 +34,11 @@ USE: test
     ] with-continuation "cc" get interp-data ;
 
 [ 5 { } ] [ multishot-test ] unit-test
+
+[ ] [
+    [
+        global [ "x" set ] bind
+        [ global [ "x" get ] bind continue ] quot>interp
+        continue
+    ] with-continuation global [ "x" off ] bind
+] unit-test

library/test/generic.factor

@@ -1,19 +1,6 @@
+USING: hashtables namespaces generic test kernel math words
+lists vectors alien sequences prettyprint io parser strings ;
 IN: temporary
-USE: hashtables
-USE: namespaces
-USE: generic
-USE: test
-USE: kernel
-USE: math
-USE: words
-USE: lists
-USE: vectors
-USE: alien
-USE: sequences
-USE: prettyprint
-USE: io
-USE: parser
-USE: strings
 
 GENERIC: class-of
 
@@ -80,6 +67,8 @@ M: very-funny gooey sq ;
 
 [ 1/4 ] [ 1/2 gooey ] unit-test
 
+[ cons ] [ [ 1 2 ] class ] unit-test
+
 [ object ] [ object object class-and ] unit-test
 [ fixnum ] [ fixnum object class-and ] unit-test
 [ fixnum ] [ object fixnum class-and ] unit-test
@@ -87,14 +76,9 @@ M: very-funny gooey sq ;
 [ fixnum ] [ fixnum integer class-and ] unit-test
 [ fixnum ] [ integer fixnum class-and ] unit-test
 [ null ] [ vector fixnum class-and ] unit-test
-[ integer ] [ fixnum bignum class-or ] unit-test
-[ integer ] [ fixnum integer class-or ] unit-test
-[ rational ] [ ratio integer class-or ] unit-test
 [ number ] [ number object class-and ] unit-test
 [ number ] [ object number class-and ] unit-test
 
-[ cons ] [ [ 1 2 ] class ] unit-test
-
 [ t ] [ \ fixnum \ integer class< ] unit-test
 [ t ] [ \ fixnum \ fixnum class< ] unit-test
 [ f ] [ \ integer \ fixnum class< ] unit-test
@@ -114,10 +98,16 @@ M: very-funny gooey sq ;
 [ f ] [ \ reversed \ slice class< ] unit-test
 [ f ] [ \ slice \ reversed class< ] unit-test
 
+TUPLE: a ;
+TUPLE: b ;
+UNION: c a b ;
+
+[ t ] [ \ c \ tuple class< ] unit-test
+[ f ] [ \ tuple \ c class< ] unit-test
+
 DEFER: bah
 FORGET: bah
 UNION: bah fixnum alien ;
-[ bah ] [ fixnum alien class-or ] unit-test
 [ bah ] [ \ bah? "predicating" word-prop ] unit-test
 
 DEFER: complement-test

library/tools/debugger.factor

@@ -132,7 +132,7 @@ M: object error. ( error -- ) . ;
 
 : init-error-handler ( -- )
     [ die ] quot>interp >c ( last resort )
-    [ print-error die ] quot>interp >c
+    [ global [ print-error ] bind die ] quot>interp >c
     ( kernel calls on error )
     [
         datastack dupd callstack namestack catchstack

library/tools/inspector.factor

@@ -38,7 +38,9 @@ SYMBOL: inspector-slots
     flip
     [ " | " join ] map ;
 
-: vocab-banner ( word -- )
+GENERIC: extra-banner ( obj -- )
+
+M: word extra-banner ( word -- )
     dup word-vocabulary [
         dup interned? [
             "This word is located in the " write
@@ -52,15 +54,6 @@ SYMBOL: inspector-slots
         "The word is a uniquely generated symbol." print
     ] ifte ;
 
-GENERIC: extra-banner ( obj -- )
-
-M: word extra-banner ( obj -- )
-    dup vocab-banner
-    metaclass [
-        "This is a class whose behavior is specifed by the " write
-        pprint " metaclass." print
-    ] when* ;
-
 M: object extra-banner ( obj -- ) drop ;
 
 : inspect-banner ( obj -- )

library/vocabularies.factor

@@ -4,6 +4,9 @@ IN: words
 USING: hashtables errors kernel lists namespaces strings
 sequences ;
 
+! If true in current namespace, we are bootstrapping.
+SYMBOL: bootstrapping?
+
 SYMBOL: vocabularies
 
 : word ( -- word ) \ word global hash ;
@@ -75,13 +78,19 @@ SYMBOL: vocabularies
     #! Test if the word is a member of its vocabulary.
     dup word-name over word-vocabulary lookup eq? ;
 
+: reintern ( word -- word )
+    dup word-name swap word-vocabulary
+    bootstrapping? get [
+        dup "syntax" = [ drop "!syntax" ] when
+    ] when lookup ;
+
 "scratchpad" "in" set
 [
+    "scratchpad"
     "syntax" "arrays" "compiler" "errors" "generic" "hashtables"
     "help" "inference" "inspector" "interpreter" "io"
     "jedit" "kernel" "listener" "lists" "math"
     "memory" "namespaces" "parser" "prettyprint" "queues"
     "sequences" "shells" "strings" "styles"
     "test" "threads" "vectors" "words"
-    "scratchpad"
 ] "use" set

native/run.c

@@ -2,7 +2,7 @@
 
 INLINE void execute(F_WORD* word)
 {
-	call_into_factor((XT)word->xt,word);
+	((XT)(word->xt))(word);
 }
 
 void run(void)