type inference work, and = for aliens

library/bootstrap/primitives.factor

@@ -239,6 +239,8 @@ vocabularies get [
     [ "errors" | "throw" ]
     [ "kernel-internals" | "string>memory" ]
     [ "kernel-internals" | "memory>string" ]
+    [ "alien" | "local-alien?" ]
+    [ "alien" | "alien-address" ]
 ] [
     unswons create swap succ [ f define ] keep
 ] each drop

library/compiler/alien.factor

@@ -42,6 +42,20 @@ USE: hashtables
 BUILTIN: dll   15
 BUILTIN: alien 16
 
+M: alien hashcode ( obj -- n )
+    alien-address ;
+
+M: alien = ( obj obj -- ? )
+    over alien? [
+        over local-alien? over local-alien? or [
+            eq?
+        ] [
+            alien-address swap alien-address =
+        ] ifte
+    ] [
+        2drop f
+    ] ifte ;
+
 : (library) ( name -- object )
     "libraries" get hash ;
 
@@ -76,7 +90,7 @@ SYMBOL: alien-returns
 SYMBOL: alien-parameters
 
 : infer-alien ( -- )
-    4 ensure-d
+    [ object object object object ] ensure-d
     dataflow-drop, pop-d literal-value
     dataflow-drop, pop-d literal-value
     dataflow-drop, pop-d literal-value alien-function >r

library/cons.factor

@@ -70,10 +70,12 @@ BUILTIN: cons 2
     #! Return the cdr of the last cons cell, or f.
     dup [ last* cdr ] when ;
 
-: list? ( list -- ? )
+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.
-    dup cons? [ tail ] when not ;
+    tail not ;
 
 : all? ( list pred -- ? )
     #! Push if the predicate returns true for each element of

library/generic/builtin.factor

@@ -57,9 +57,13 @@ builtin 50 "priority" set-word-property
 : add-builtin-table types get set-vector-nth ;
 
 : builtin-predicate ( type# symbol -- )
-    dup predicate-word
-    [ rot [ swap type eq? ] cons define-compound ] keep 
-    "predicate" set-word-property ;
+    over f type = [
+        nip [ not ] "predicate" set-word-property
+    ] [
+        dup predicate-word
+        [ rot [ swap type eq? ] cons define-compound ] keep 
+        unit "predicate" set-word-property
+    ] ifte ;
 
 : builtin-class ( type# symbol -- )
     2dup swap add-builtin-table

library/generic/object.factor

@@ -53,4 +53,6 @@ object [
     ] times* 2drop
 ] "add-method" set-word-property
 
+object [ drop t ] "predicate" set-word-property
+
 object 100 "priority" set-word-property

library/generic/predicate.factor

@@ -41,7 +41,7 @@ SYMBOL: predicate
 
 : predicate-dispatch ( existing definition class -- dispatch )
     [
-        \ dup , "predicate" word-property , , , \ ifte ,
+        \ dup , "predicate" word-property append, , , \ ifte ,
     ] make-list ;
 
 : predicate-method ( vtable definition class type# -- )
@@ -67,7 +67,7 @@ predicate 25 "priority" set-word-property
 
 : define-predicate ( class predicate definition -- )
     rot "superclass" word-property "predicate" word-property
-    [ \ dup , , , [ drop f ] , \ ifte , ] make-list
+    [ \ dup , append, , [ drop f ] , \ ifte , ] make-list
     define-compound ;
 
 : PREDICATE: ( -- class predicate definition )
@@ -77,5 +77,5 @@ predicate 25 "priority" set-word-property
     dup rot "superclass" set-word-property
     dup predicate "metaclass" set-word-property
     dup predicate-word
-    [ dupd "predicate" set-word-property ] keep
+    [ dupd unit "predicate" set-word-property ] keep
     [ define-predicate ] [ ] ; parsing

library/generic/union.factor

@@ -56,7 +56,7 @@ union 30 "priority" set-word-property
     [
         [
             \ dup ,
-            unswons "predicate" word-property ,
+            unswons "predicate" word-property append,
             [ drop t ] ,
             union-predicate ,
             \ ifte ,
@@ -66,6 +66,8 @@ union 30 "priority" set-word-property
     ] ifte* ;
 
 : define-union ( class predicate definition -- )
+    #! We have to turn the f object into the f word.
+    [ [ \ f ] unless* ] map
     [ union-predicate define-compound ] keep
     "members" set-word-property ;
 
@@ -74,5 +76,5 @@ union 30 "priority" set-word-property
     CREATE
     dup union "metaclass" set-word-property
     dup predicate-word
-    [ dupd "predicate" set-word-property ] keep
+    [ dupd unit "predicate" set-word-property ] keep
     [ define-union ] [ ] ; parsing

library/inference/branches.factor

@@ -41,10 +41,18 @@ USE: hashtables
 : longest-vector ( list -- length )
     [ vector-length ] map [ > ] top ;
 
+: computed-value-vector ( n -- vector )
+    [ drop object <computed> ] vector-project ;
+
+: add-inputs ( count stack -- count stack )
+    #! Add this many inputs to the given stack.
+    [ vector-length - dup ] keep
+    >r computed-value-vector dup r> vector-append ;
+
 : unify-lengths ( list -- list )
     #! Pad all vectors to the same length. If one vector is
     #! shorter, pad it with unknown results at the bottom.
-    dup longest-vector swap [ dupd ensure nip ] map nip ;
+    dup longest-vector swap [ dupd add-inputs nip ] map nip ;
 
 : unify-classes ( class class -- class )
     #! Return a class that both classes are subclasses of.
@@ -159,7 +167,7 @@ USE: hashtables
 
 : infer-ifte ( -- )
     #! Infer effects for both branches, unify.
-    3 ensure-d
+    [ object general-list general-list ] ensure-d
     dataflow-drop, pop-d
     dataflow-drop, pop-d swap 2list
     >r 1 meta-d get vector-tail* #ifte r>
@@ -174,7 +182,7 @@ USE: hashtables
 
 : infer-dispatch ( -- )
     #! Infer effects for all branches, unify.
-    2 ensure-d
+    [ object vector ] ensure-d
     dataflow-drop, pop-d vtable>list
     >r 1 meta-d get vector-tail* #dispatch r>
     pop-d drop ( n )

library/inference/dataflow.factor

@@ -94,16 +94,16 @@ SYMBOL: node-param
     meta-r get vector-tail* node-consume-r set
     meta-d get vector-tail* node-consume-d set ;
 
-: dataflow-inputs ( [ in | out ] node -- )
-    [ car 0 node-inputs ] bind ;
+: dataflow-inputs ( in node -- )
+    [ dup cons? [ length ] when 0 node-inputs ] bind ;
 
 : node-outputs ( d-count r-count -- )
     #! Execute in the node's namespace.
     meta-r get vector-tail* node-produce-r set
     meta-d get vector-tail* node-produce-d set ;
 
-: dataflow-outputs ( [ in | out ] node -- )
-    [ cdr 0 node-outputs ] bind ;
+: dataflow-outputs ( out node -- )
+    [ dup cons? [ length ] when 0 node-outputs ] bind ;
 
 : get-dataflow ( -- IR )
     dataflow-graph get reverse ;

library/inference/inference.factor

@@ -64,7 +64,6 @@ SYMBOL: recursive-label
 SYMBOL: save-effect
 
 ! A value has the following slots:
-
 GENERIC: literal-value ( value -- obj )
 GENERIC: value= ( literal value -- ? )
 GENERIC: value-class ( value -- class )
@@ -95,27 +94,20 @@ M: literal value-class ( value -- class )
 : value-recursion ( value -- rstate )
     [ recursive-state get ] bind ;
 
-: computed-value-vector ( n -- vector )
-    [ drop object <computed> ] vector-project ;
-
-: add-inputs ( count stack -- stack )
-    #! Add this many inputs to the given stack.
-    >r computed-value-vector dup r> vector-append ;
-
-: ensure ( count stack -- count stack )
-    #! Ensure stack has this many elements. Return number of
-    #! elements added.
-    2dup vector-length > [
-        [ vector-length - dup ] keep add-inputs
+: required-inputs ( typelist stack -- values )
+    >r dup length r> vector-length - dup 0 > [
+        head [ <computed> ] map
     ] [
-        >r drop 0 r>
+        2drop f
     ] ifte ;
 
-: ensure-d ( count -- )
-    #! Ensure count of unknown results are on the stack.
-    meta-d [ ensure ] change
-    d-in get swap [ object <computed> over vector-push ] times
-    drop ;
+: vector-prepend ( values stack -- stack )
+    >r list>vector dup r> vector-append ;
+
+: ensure-d ( typelist -- )
+    meta-d get required-inputs dup
+    meta-d [ vector-prepend ] change
+    d-in [ vector-prepend ] change ;
 
 : effect ( -- [ in | out ] )
     #! After inference is finished, collect information.
@@ -206,6 +198,6 @@ DEFER: apply-word
 : type-infer ( quot -- [ in-types out-types ] )
     [
         (infer)
-        d-in get [ value-class ] vector-map
-        meta-d get [ value-class ] vector-map 2list
+        d-in get [ value-class ] vector-map vector>list
+        meta-d get [ value-class ] vector-map vector>list 2list
     ] with-scope ;

library/inference/words.factor

@@ -43,26 +43,25 @@ USE: prettyprint
     #! Take input parameters, execute quotation, take output
     #! parameters, add node. The quotation is called with the
     #! stack effect.
-    >r dup car ensure-d >r dataflow, r> r> rot
-    [ pick swap dataflow-inputs ] keep
-    pick 2slip swap dataflow-outputs ; inline
+    >r dup car dup cons? [ [ drop object ] project ] unless ensure-d >r dataflow, r> r> rot
+    [ pick car swap dataflow-inputs ] keep
+    pick 2slip cdr swap
+    dataflow-outputs ; inline
 
-: consume-d ( count -- )
-    #! Remove count of elements.
-    [ pop-d drop ] times ;
+: consume-d ( typelist -- )
+    [ pop-d 2drop ] each ;
 
-: produce-d ( count -- )
-    #! Push count of unknown results.
-    [ object <computed> push-d ] times ;
+: produce-d ( typelist -- )
+    [ <computed> push-d ] each ;
 
 : (consume/produce) ( param op effect -- )
     [
         dup cdr cons? [
             ( new style )
-            
+            unswons consume-d car produce-d
         ] [
             ( old style, will go away shortly )
-            unswons consume-d produce-d
+            unswons [ pop-d drop ] times [ object <computed> push-d ] times
         ] ifte
     ] with-dataflow ;
 
@@ -77,7 +76,7 @@ USE: prettyprint
     #! side-effect-free and all parameters are literal), or
     #! simply apply its stack effect to the meta-interpreter.
     over "infer" word-property dup [
-        swap car ensure-d call drop
+        swap car dup cons? [ [ drop object ] project ] unless ensure-d call drop
     ] [
         drop consume/produce
     ] ifte ;
@@ -197,7 +196,7 @@ USE: prettyprint
     ] ifte ;
 
 : infer-call ( -- )
-    1 ensure-d
+    [ general-list ] ensure-d
     dataflow-drop,
     gensym dup [
         drop pop-d dup

library/kernel.factor

@@ -66,5 +66,5 @@ M: object = eq? ;
 : xor ( a b -- a^b ) dup not swap ? ; inline
 
 IN: syntax
-BUILTIN: f 6 FORGET: f?
-BUILTIN: t 7 FORGET: t?
+BUILTIN: f 6
+BUILTIN: t 7

library/list-namespaces.factor

@@ -60,3 +60,6 @@ SYMBOL: list-buffer
     #! Append an object to the currently constructing list, only
     #! if the object does not already occur in the list.
     list-buffer unique@ ;
+
+: append, ( list -- )
+    [ , ] each ;

library/lists.factor

@@ -188,3 +188,7 @@ M: cons hashcode ( cons -- hash ) 4 cons-hashcode ;
 
 : count ( n -- [ 0 ... n-1 ] )
     [ ] project ;
+
+: head ( list n -- list )
+    #! Return the first n elements of the list.
+    dup 0 > [ >r uncons r> pred head cons ] [ 2drop f ] ifte ;

library/primitives.factor

@@ -25,10 +25,14 @@
 ! OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF
 ! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
 
+IN: alien
+DEFER: alien
+
 USE: alien
 USE: compiler
 USE: errors
 USE: files
+USE: generic
 USE: io-internals
 USE: kernel
 USE: kernel-internals
@@ -47,9 +51,9 @@ USE: words
     [ execute                " word -- "                          f ]
     [ call                   " quot -- "                          [ 1 | 0 ] ]
     [ ifte                   " cond true false -- "               [ 3 | 0 ] ]
-    [ cons                   " car cdr -- [ car | cdr ] "         [ 2 | 1 ] ]
-    [ car                    " [ car | cdr ] -- car "             [ 1 | 1 ] ]
-    [ cdr                    " [ car | cdr ] -- cdr "             [ 1 | 1 ] ]
+    [ cons                   " car cdr -- [ car | cdr ] "         [ [ object object ] [ cons ] ] ]
+    [ car                    " [ car | cdr ] -- car "             [ [ cons ] [ object ] ] ]
+    [ cdr                    " [ car | cdr ] -- cdr "             [ [ cons ] [ object ] ] ]
     [ <vector>               " capacity -- vector"                [ 1 | 1 ] ]
     [ vector-length          " vector -- n "                      [ 1 | 1 ] ]
     [ set-vector-length      " n vector -- "                      [ 2 | 0 ] ]
@@ -230,6 +234,9 @@ USE: words
     [ throw                  " error -- "                         [ 1 | 0 ] ]
     [ string>memory          " str address -- "                   [ 2 | 0 ] ]
     [ memory>string          " address length -- str "            [ 2 | 1 ] ]
+    [ local-alien?           " alien -- ? "                       [ [ alien ] [ object ] ] ]
+    [ alien-address          " alien -- address "                 [ [ alien ] [ integer ] ] ]
+    [ memory>string          " address length -- str "            [ 2 | 1 ] ]
 ] [
     uncons dupd uncons car ( word word stack-effect infer-effect )
     >r "stack-effect" set-word-property r>

library/test/alien.factor

@@ -0,0 +1,8 @@
+IN: scratchpad
+USE: alien
+USE: kernel
+USE: test
+
+[ t ] [ 0 <alien> 0 <alien> = ] unit-test
+[ f ] [ 0 <alien> local-alien? ] unit-test
+[ t ] [ 1024 <local-alien> local-alien? ] unit-test

library/test/inference.factor

@@ -8,6 +8,7 @@ USE: lists
 USE: namespaces
 USE: kernel
 USE: math-internals
+USE: generic
 
 [
     [ 1 | 2 ]
@@ -20,20 +21,19 @@ USE: math-internals
     [ 3 | 4 ]
 ] "effects" set
 
-! [ t ] [
-!     "effects" get [
-!         dup [ 7 | 7 ] decompose compose [ 7 | 7 ] =
-!     ] all?
-! ] unit-test
-[ 6 ] [ 6 computed-value-vector vector-length ] unit-test
-
 [ 3 ] [ [ { 1 2 } { 1 2 3 } ] longest-vector ] unit-test
 
 [ t ] [
     [ { 1 2 } { 1 2 3 } ] unify-lengths [ vector-length ] map all=?
 ] unit-test
 
-[ [ sq ] ] [ [ sq ] [ sq ] unify-result ] unit-test
+[ [ sq ] ] [
+    [ sq ] f <literal> [ sq ] f <literal> unify-results literal-value
+] unit-test
+
+[ fixnum ] [
+    5 f <literal> 6 f <literal> unify-results value-class
+] unit-test
 
 [ [ 0 | 2 ] ] [ [ 2 "Hello" ] infer ] unit-test
 [ [ 1 | 2 ] ] [ [ dup ] infer ] unit-test
@@ -194,3 +194,10 @@ SYMBOL: sym-test
 [ [ 0 | 1 ] ] [ [ n> ] infer ] unit-test
 
 [ [ 1 | 1 ] ] [ [ get ] infer ] unit-test
+
+! Type inference.
+
+[ [ [ object ] [ ] ] ] [ [ drop ] type-infer ] unit-test
+[ [ [ object ] [ object object ] ] ] [ [ dup ] type-infer ] unit-test
+[ [ [ object object ] [ cons ] ] ] [ [ cons ] type-infer ] unit-test
+[ [ [ cons ] [ cons ] ] ] [ [ uncons cons ] type-infer ] unit-test

library/test/lists/lists.factor

@@ -54,3 +54,9 @@ USE: strings
 [ [ ]         ] [ 0   count ] unit-test
 [ [ ]         ] [ -10 count ] unit-test
 [ [ 0 1 2 3 ] ] [ 4   count ] unit-test
+
+[ f ] [ f 0 head ] unit-test
+[ f ] [ [ 1 ] 0 head ] unit-test
+[ [ 1 ] ] [ [ 1 ] 1 head ] unit-test
+[ [ 1 ] 2 head ] unit-test-fails
+[ [ 1 2 3 ] ] [ [ 1 2 3 4 ] 3 head ] unit-test

library/test/parser.factor

@@ -4,6 +4,8 @@ USE: test
 USE: unparser
 USE: lists
 USE: kernel
+USE: generic
+USE: words
 
 [ [ 1 [ 2 [ 3 ] 4 ] 5 ] ]
 [ "1\n[\n2\n[\n3\n]\n4\n]\n5" ]
@@ -64,3 +66,5 @@ test-word
 [ 4 ] [ "2 2 +" eval-catch ] unit-test
 [ "4\n" ] [ "2 2 + ." eval>string ] unit-test
 [ ] [ "fdafdf" eval-catch ] unit-test
+
+[ word ] [ \ f class ] unit-test

library/test/test.factor

@@ -111,6 +111,7 @@ USE: unparser
         "dataflow"
         "interpreter"
         "hsv"
+        "alien"
     ] [
         test
     ] each

native/ffi.c

@@ -9,7 +9,6 @@ DLL* untag_dll(CELL tagged)
 	return (DLL*)UNTAG(tagged);
 }
 
-#ifdef FFI
 CELL unbox_alien(void)
 {
 	return untag_alien(dpop())->ptr;
@@ -34,22 +33,16 @@ INLINE CELL alien_pointer(void)
 
 	return ptr + offset;
 }
-#endif
 
 void primitive_alien(void)
 {
-#ifdef FFI
 	CELL ptr = unbox_integer();
 	maybe_garbage_collection();
 	box_alien(ptr);
-#else
-	general_error(ERROR_FFI_DISABLED,F);
-#endif
 }
 
 void primitive_local_alien(void)
 {
-#ifdef FFI
 	CELL length = unbox_integer();
 	ALIEN* alien;
 	F_STRING* local;
@@ -59,91 +52,66 @@ void primitive_local_alien(void)
 	alien->ptr = (CELL)local + sizeof(F_STRING);
 	alien->local = true;
 	dpush(tag_object(alien));
-#else
-	general_error(ERROR_FFI_DISABLED,F);
-#endif
+}
+
+void primitive_local_alienp(void)
+{
+	box_boolean(untag_alien(dpop())->local);
+}
+
+void primitive_alien_address(void)
+{
+	box_cell(untag_alien(dpop())->ptr);
 }
 
 void primitive_alien_cell(void)
 {
-#ifdef FFI
 	box_integer(get(alien_pointer()));
-#else
-	general_error(ERROR_FFI_DISABLED,F);
-#endif
 }
 
 void primitive_set_alien_cell(void)
 {
-#ifdef FFI
 	CELL ptr = alien_pointer();
 	CELL value = unbox_integer();
 	put(ptr,value);
-#else
-	general_error(ERROR_FFI_DISABLED,F);
-#endif
 }
 
 void primitive_alien_4(void)
 {
-#ifdef FFI
 	CELL ptr = alien_pointer();
 	box_integer(*(int*)ptr);
-#else
-	general_error(ERROR_FFI_DISABLED,F);
-#endif
 }
 
 void primitive_set_alien_4(void)
 {
-#ifdef FFI
 	CELL ptr = alien_pointer();
 	CELL value = unbox_integer();
 	*(int*)ptr = value;
-#else
-	general_error(ERROR_FFI_DISABLED,F);
-#endif
 }
 
 void primitive_alien_2(void)
 {
-#ifdef FFI
 	CELL ptr = alien_pointer();
 	box_signed_2(*(uint16_t*)ptr);
-#else
-	general_error(ERROR_FFI_DISABLED,F);
-#endif
 }
 
 void primitive_set_alien_2(void)
 {
-#ifdef FFI
 	CELL ptr = alien_pointer();
 	CELL value = unbox_signed_2();
 	*(uint16_t*)ptr = value;
-#else
-	general_error(ERROR_FFI_DISABLED,F);
-#endif
 }
 
 void primitive_alien_1(void)
 {
-#ifdef FFI
 	box_signed_1(bget(alien_pointer()));
-#else
-	general_error(ERROR_FFI_DISABLED,F);
-#endif
 }
 
 void primitive_set_alien_1(void)
 {
-#ifdef FFI
 	CELL ptr = alien_pointer();
 	BYTE value = value = unbox_signed_1();
 	bput(ptr,value);
-#else
-	general_error(ERROR_FFI_DISABLED,F);
-#endif
 }
 
 void fixup_dll(DLL* dll)

native/ffi.h

@@ -26,6 +26,8 @@ void primitive_alien(void);
 void primitive_local_alien(void);
 DLLEXPORT CELL unbox_alien(void);
 DLLEXPORT void box_alien(CELL ptr);
+void primitive_local_alienp(void);
+void primitive_alien_address(void);
 void primitive_alien_cell(void);
 void primitive_set_alien_cell(void);
 void primitive_alien_4(void);

native/primitives.c

@@ -191,7 +191,9 @@ XT primitives[] = {
 	primitive_heap_stats,
 	primitive_throw,
 	primitive_string_to_memory,
-	primitive_memory_to_string
+	primitive_memory_to_string,
+	primitive_local_alienp,
+	primitive_alien_address,
 };
 
 CELL primitive_to_xt(CELL primitive)

native/primitives.h

@@ -1,4 +1,4 @@
 extern XT primitives[];
-#define PRIMITIVE_COUNT 191
+#define PRIMITIVE_COUNT 193
 
 CELL primitive_to_xt(CELL primitive);