diff --git a/library/bootstrap/primitives.factor b/library/bootstrap/primitives.factor index 6d64f4bc7f..521e8c02c8 100644 --- a/library/bootstrap/primitives.factor +++ b/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 diff --git a/library/compiler/alien.factor b/library/compiler/alien.factor index 063277763b..54ab18c060 100644 --- a/library/compiler/alien.factor +++ b/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 diff --git a/library/cons.factor b/library/cons.factor index 0a9befa4e7..495abad07e 100644 --- a/library/cons.factor +++ b/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 diff --git a/library/generic/builtin.factor b/library/generic/builtin.factor index d6452cd7ca..b6bfe5bd85 100644 --- a/library/generic/builtin.factor +++ b/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 diff --git a/library/generic/object.factor b/library/generic/object.factor index 540e0595f8..95d55509a9 100644 --- a/library/generic/object.factor +++ b/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 diff --git a/library/generic/predicate.factor b/library/generic/predicate.factor index b08d9d54d1..aee58c001c 100644 --- a/library/generic/predicate.factor +++ b/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 diff --git a/library/generic/union.factor b/library/generic/union.factor index fdcaa3304f..7559a67a5d 100644 --- a/library/generic/union.factor +++ b/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 diff --git a/library/inference/branches.factor b/library/inference/branches.factor index 02e818ab51..14d9dd41ed 100644 --- a/library/inference/branches.factor +++ b/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 ] 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 ) diff --git a/library/inference/dataflow.factor b/library/inference/dataflow.factor index 772c8d60d9..2cca33d7d3 100644 --- a/library/inference/dataflow.factor +++ b/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 ; diff --git a/library/inference/inference.factor b/library/inference/inference.factor index ad3353da83..350af524d9 100644 --- a/library/inference/inference.factor +++ b/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 ] 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 [ ] 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 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 ; diff --git a/library/inference/words.factor b/library/inference/words.factor index 4064b251d1..7521986e12 100644 --- a/library/inference/words.factor +++ b/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 push-d ] times ; +: produce-d ( typelist -- ) + [ 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 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 diff --git a/library/kernel.factor b/library/kernel.factor index f1320e2f7a..eeb6966137 100644 --- a/library/kernel.factor +++ b/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 diff --git a/library/list-namespaces.factor b/library/list-namespaces.factor index 0e5551a837..0bab6cbfaa 100644 --- a/library/list-namespaces.factor +++ b/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 ; diff --git a/library/lists.factor b/library/lists.factor index 6fffa3ba60..cbac8bf161 100644 --- a/library/lists.factor +++ b/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 ; diff --git a/library/primitives.factor b/library/primitives.factor index 7f312ed683..c4cea98952 100644 --- a/library/primitives.factor +++ b/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 ] ] ] [ " 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> diff --git a/library/test/alien.factor b/library/test/alien.factor new file mode 100644 index 0000000000..46bff7d7a9 --- /dev/null +++ b/library/test/alien.factor @@ -0,0 +1,8 @@ +IN: scratchpad +USE: alien +USE: kernel +USE: test + +[ t ] [ 0 0 = ] unit-test +[ f ] [ 0 local-alien? ] unit-test +[ t ] [ 1024 local-alien? ] unit-test diff --git a/library/test/inference.factor b/library/test/inference.factor index 57f5b0fee3..27a5c80ffb 100644 --- a/library/test/inference.factor +++ b/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 [ sq ] f unify-results literal-value +] unit-test + +[ fixnum ] [ + 5 f 6 f 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 diff --git a/library/test/lists/lists.factor b/library/test/lists/lists.factor index cac9c7447a..d0ce247a65 100644 --- a/library/test/lists/lists.factor +++ b/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 diff --git a/library/test/parser.factor b/library/test/parser.factor index 95d44094fa..182f4300f6 100644 --- a/library/test/parser.factor +++ b/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 diff --git a/library/test/test.factor b/library/test/test.factor index 9bbd5a4ce5..89e4817eaa 100644 --- a/library/test/test.factor +++ b/library/test/test.factor @@ -111,6 +111,7 @@ USE: unparser "dataflow" "interpreter" "hsv" + "alien" ] [ test ] each diff --git a/native/ffi.c b/native/ffi.c index aa97cdf0e6..6b0831e638 100644 --- a/native/ffi.c +++ b/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) diff --git a/native/ffi.h b/native/ffi.h index 1a2d11f86f..ad3df14a62 100644 --- a/native/ffi.h +++ b/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); diff --git a/native/primitives.c b/native/primitives.c index 7de79c4c1e..68d6e970e9 100644 --- a/native/primitives.c +++ b/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) diff --git a/native/primitives.h b/native/primitives.h index c41f8b4796..bf3cca526c 100644 --- a/native/primitives.h +++ b/native/primitives.h @@ -1,4 +1,4 @@ extern XT primitives[]; -#define PRIMITIVE_COUNT 191 +#define PRIMITIVE_COUNT 193 CELL primitive_to_xt(CELL primitive);