type inference work; class\/ and class/\ words

library/cons.factor

@@ -66,16 +66,12 @@ BUILTIN: cons 2
     #! Last element of a list.
     last* car ;
 
-: tail ( list -- tail )
-    #! Return the cdr of the last cons cell, or f.
-    dup [ last* cdr ] when ;
-
 UNION: general-list f cons ;
 
 PREDICATE: general-list list ( list -- ? )
     #! Proper list test. A proper list is either f, or a cons
     #! cell whose cdr is a proper list.
-    tail not ;
+    dup [ last* cdr ] when not ;
 
 : all? ( list pred -- ? )
     #! Push if the predicate returns true for each element of

library/generic/builtin.factor

@@ -39,10 +39,6 @@ USE: vectors
 ! Builtin metaclass for builtin types: fixnum, word, cons, etc.
 SYMBOL: builtin
 
-! Vector in global namespace mapping type numbers to
-! builtin classes.
-SYMBOL: types
-
 builtin [
     "builtin-type" word-property unit
 ] "builtin-supertypes" set-word-property
@@ -54,23 +50,20 @@ builtin [
 
 builtin 50 "priority" set-word-property
 
-: add-builtin-table types get set-vector-nth ;
-
 : builtin-predicate ( type# symbol -- )
     over f type = [
         nip [ not ] "predicate" set-word-property
     ] [
         dup predicate-word
-        [ rot [ swap type eq? ] cons define-compound ] keep 
+        [ rot [ swap type eq? ] cons define-compound ] keep
         unit "predicate" set-word-property
     ] ifte ;
 
 : builtin-class ( type# symbol -- )
-    2dup swap add-builtin-table
+    dup intern-symbol
-    dup undefined? [ dup define-symbol ] when
     2dup builtin-predicate
-    dup builtin "metaclass" set-word-property
+    [ swap "builtin-type" set-word-property ] keep
-    swap "builtin-type" set-word-property ;
+    builtin define-class ;
 
 : BUILTIN:
     #! Followed by type name and type number. Define a built-in
@@ -78,7 +71,7 @@ builtin 50 "priority" set-word-property
     CREATE scan-word swap builtin-class ; parsing
 
 : builtin-type ( n -- symbol )
-    types get vector-nth ;
+    unit classes get hash ;
 
 : type-name ( n -- string )
     builtin-type word-name ;
@@ -87,5 +80,3 @@ builtin 50 "priority" set-word-property
     #! Analogous to the type primitive. Pushes the builtin
     #! class of an object.
     type builtin-type ;
-
-global [ num-types <vector> types set ] bind

library/generic/generic.factor

@@ -82,10 +82,10 @@ USE: math-internals
 : class-ord ( class -- n ) metaclass "priority" word-property ;
 
 : class< ( cls1 cls2 -- ? )
-    swap car class-ord swap car class-ord < ;
+    swap class-ord swap class-ord < ;
 
 : sort-methods ( methods -- alist )
-    hash>alist [ class< ] sort ;
+    hash>alist [ 2car class< ] sort ;
 
 : add-method ( vtable definition class -- )
     #! Add the method entry to the vtable. Unlike define-method,
@@ -153,3 +153,38 @@ DEFER: add-traits-dispatch
     #! M: foo bar begins a definition of the bar generic word
     #! specialized to the foo type.
     scan-word  dup define-method  scan-word swap [ ] ; parsing
+
+! Maps lists of builtin type numbers to class objects.
+SYMBOL: classes
+
+SYMBOL: object
+
+: type-union ( list list -- list )
+    append prune [ > ] sort ;
+
+: class\/ ( class class -- class )
+    #! Return a class that both classes are subclasses of.
+    swap builtin-supertypes
+    swap builtin-supertypes
+    type-union classes get hash [ object ] unless* ;
+
+: class/\ ( class class -- class )
+    #! Return a class that is a subclass of both, or raise an
+    #! error if this is impossible.
+    over builtin-supertypes
+    over builtin-supertypes
+    intersection dup [
+        nip nip classes get hash [ object ] unless*
+    ] [
+        drop [
+            word-name , " and " , word-name ,
+            " do not intersect" ,
+        ] make-string throw
+    ] ifte ;
+
+: define-class ( class metaclass -- )
+    dupd "metaclass" set-word-property
+    dup builtin-supertypes [ > ] sort
+    classes get set-hash ;
+
+global [ <namespace> classes set ] bind

library/generic/object.factor

@@ -40,8 +40,6 @@ USE: math
 ! Catch-all metaclass for providing a default method.
 SYMBOL: object
 
-object object "metaclass" set-word-property
-
 object [
     drop num-types count
 ] "builtin-supertypes" set-word-property
@@ -56,3 +54,5 @@ object [
 object [ drop t ] "predicate" set-word-property
 
 object 100 "priority" set-word-property
+
+object object define-class

library/generic/predicate.factor

@@ -73,7 +73,7 @@ predicate 25 "priority" set-word-property
 : PREDICATE: ( -- class predicate definition )
     #! Followed by a superclass name, then a class name.
     scan-word
-    CREATE
+    CREATE dup intern-symbol
     dup rot "superclass" set-word-property
     dup predicate "metaclass" set-word-property
     dup predicate-word

library/generic/union.factor

@@ -74,7 +74,8 @@ union 30 "priority" set-word-property
 : UNION: ( -- class predicate definition )
     #! Followed by a class name, then a list of union members.
     CREATE
-    dup union "metaclass" set-word-property
+    dup intern-symbol
+    dup union define-class
     dup predicate-word
     [ dupd unit "predicate" set-word-property ] keep
     [ define-union ] [ ] ; parsing

library/inference/branches.factor

@@ -54,17 +54,13 @@ USE: hashtables
     #! shorter, pad it with unknown results at the bottom.
     dup longest-vector swap [ dupd add-inputs nip ] map nip ;
 
-: unify-classes ( class class -- class )
-    #! Return a class that both classes are subclasses of.
-    2dup = [ drop ] [ 2drop object ] ifte ;
-
 : unify-results ( obj obj -- obj )
     #! Replace values with unknown result if they differ,
     #! otherwise retain them.
     2dup = [
         drop
     ] [
-        value-class swap value-class unify-classes <computed>
+        value-class swap value-class class\/ <computed>
     ] ifte ;
 
 : unify-stacks ( list -- stack )

library/lists.factor

@@ -192,3 +192,11 @@ M: cons hashcode ( cons -- hash ) 4 cons-hashcode ;
 : head ( list n -- list )
     #! Return the first n elements of the list.
     dup 0 > [ >r uncons r> pred head cons ] [ 2drop f ] ifte ;
+
+: tail ( list n -- tail )
+    #! Return the rest of the list, from the nth index onward.
+    [ cdr ] times ;
+
+: intersection ( list list -- list )
+    #! Make a list of elements that occur in both lists.
+    [ over contains? ] subset nip ;

library/test/alien.factor

@@ -5,4 +5,7 @@ USE: test
 
 [ t ] [ 0 <alien> 0 <alien> = ] unit-test
 [ f ] [ 0 <alien> local-alien? ] unit-test
+[ f ] [ 0 <alien> 1024 <local-alien> = ] unit-test
+[ f ] [ 0 <alien> 1024 <alien> = ] unit-test
+[ f ] [ "hello" 1024 <alien> = ] unit-test
 [ t ] [ 1024 <local-alien> local-alien? ] unit-test

library/test/generic.factor

@@ -7,6 +7,7 @@ USE: kernel
 USE: math
 USE: words
 USE: lists
+USE: vectors
 
 TRAITS: test-traits
 C: test-traits ;
@@ -124,3 +125,14 @@ GENERIC: gooey
 M: very-funny gooey sq ;
 
 [ 1/4 ] [ 1/2 gooey ] unit-test
+
+[ object ] [ object object class/\ ] unit-test
+[ fixnum ] [ fixnum object class/\ ] unit-test
+[ fixnum ] [ object fixnum class/\ ] unit-test
+[ fixnum ] [ fixnum fixnum class/\ ] unit-test
+[ fixnum ] [ fixnum integer class/\ ] unit-test
+[ fixnum ] [ integer fixnum class/\ ] unit-test
+[ vector fixnum class/\ ] unit-test-fails
+[ integer ] [ fixnum bignum class\/ ] unit-test
+[ integer ] [ fixnum integer class\/ ] unit-test
+[ rational ] [ ratio integer class\/ ] unit-test

library/words.factor

@@ -61,6 +61,9 @@ PREDICATE: word undefined ( obj -- ? ) word-primitive 0 = ;
 : define-compound ( word def -- ) 1 swap define ;
 : define-symbol   ( word -- ) 2 over define ;
 
+: intern-symbol ( word -- )
+    dup undefined? [ define-symbol ] [ drop ] ifte ;
+
 : word-name       ( word -- str ) "name" word-property ;
 : word-vocabulary ( word -- str ) "vocabulary" word-property ;
 : stack-effect    ( word -- str ) "stack-effect" word-property ;