[ "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
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 ;
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
#! 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
: 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
] times* 2drop
] "add-method" set-word-property
+object [ drop t ] "predicate" set-word-property
+
object 100 "priority" set-word-property
: 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# -- )
: 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 )
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
[
[
\ dup ,
- unswons "predicate" word-property ,
+ unswons "predicate" word-property append,
[ drop t ] ,
union-predicate ,
\ ifte ,
] 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 ;
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
: 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.
: 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>
: 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 )
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 ;
SYMBOL: save-effect
! A value has the following slots:
-
GENERIC: literal-value ( value -- obj )
GENERIC: value= ( literal value -- ? )
GENERIC: 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.
: 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 ;
#! 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 ;
#! 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 ;
] ifte ;
: infer-call ( -- )
- 1 ensure-d
+ [ general-list ] ensure-d
dataflow-drop,
gensym dup [
drop pop-d dup
: 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
#! 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 ;
: 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 ;
! 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
[ 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 ] ]
[ 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>
--- /dev/null
+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
USE: namespaces
USE: kernel
USE: math-internals
+USE: generic
[
[ 1 | 2 ]
[ 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
[ [ 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
[ [ ] ] [ 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
USE: unparser
USE: lists
USE: kernel
+USE: generic
+USE: words
[ [ 1 [ 2 [ 3 ] 4 ] 5 ] ]
[ "1\n[\n2\n[\n3\n]\n4\n]\n5" ]
[ 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
"dataflow"
"interpreter"
"hsv"
+ "alien"
] [
test
] each
return (DLL*)UNTAG(tagged);
}
-#ifdef FFI
CELL unbox_alien(void)
{
return untag_alien(dpop())->ptr;
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;
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)
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);
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)
extern XT primitives[];
-#define PRIMITIVE_COUNT 191
+#define PRIMITIVE_COUNT 193
CELL primitive_to_xt(CELL primitive);
projects / factor.git / commitdiff