pop-literal nip >>library
pop-literal nip >>return
! Quotation which coerces parameters to required types
- dup param-prep-quot recursive-state get infer-quot
+ dup param-prep-quot infer-quot-here
! Set ABI
dup library>> library [ abi>> ] [ "cdecl" ] if* >>abi
! Magic #: consume exactly the number of inputs
! Add node to IR
dup #alien-invoke,
! Quotation which coerces return value to required type
- return-prep-quot recursive-state get infer-quot ;
+ return-prep-quot infer-quot-here ;
: infer-alien-indirect ( -- )
alien-indirect-params new
pop-parameters >>parameters
pop-literal nip >>return
! Quotation which coerces parameters to required types
- dup param-prep-quot [ dip ] curry recursive-state get infer-quot
+ dup param-prep-quot [ dip ] curry infer-quot-here
! Magic #: consume the function pointer, too
dup 1 alien-stack
! Add node to IR
dup #alien-indirect,
! Quotation which coerces return value to required type
- return-prep-quot recursive-state get infer-quot ;
+ return-prep-quot infer-quot-here ;
! Callbacks are registered in a global hashtable. If you clear
! this hashtable, they will all be blown away by code GC, beware
: callback-bottom ( params -- )
xt>> [ [ register-callback ] [ word-xt drop <alien> ] bi ] curry
- recursive-state get infer-quot ;
+ infer-quot-here ;
: infer-alien-callback ( -- )
alien-callback-params new
: terminate ( -- )
terminated? on meta-d get clone meta-r get clone #terminate, ;
+: infer-quot-here ( quot -- )
+ [ apply-object terminated? get not ] all? drop ;
+
: infer-quot ( quot rstate -- )
recursive-state get [
recursive-state set
- [ apply-object terminated? get not ] all? drop
+ infer-quot-here
] dip recursive-state set ;
: infer-quot-recursive ( quot word label -- )
2array recursive-state get swap prefix infer-quot ;
: time-bomb ( error -- )
- '[ _ throw ] recursive-state get infer-quot ;
+ '[ _ throw ] infer-quot-here ;
: bad-call ( -- )
"call must be given a callable" time-bomb ;
dup [ known [ curried? ] [ composed? ] bi or ] contains? [
output-d
[ rot [ drop call ] [ nip call ] if ]
- recursive-state get infer-quot
+ infer-quot-here
] [
[ #drop, ] [ [ literal ] map (infer-if) ] bi
] if ;
M: curried infer-call*
swap push-d
- [ uncurry ] recursive-state get infer-quot
+ [ uncurry ] infer-quot-here
[ quot>> known pop-d [ set-known ] keep ]
[ obj>> known pop-d [ set-known ] keep ] bi
push-d infer-call ;
M: composed infer-call*
swap push-d
- [ uncompose ] recursive-state get infer-quot
+ [ uncompose ] infer-quot-here
[ quot2>> known pop-d [ set-known ] keep ]
[ quot1>> known pop-d [ set-known ] keep ] bi
push-d push-d
GENERIC: infer ( quot -- effect )
M: callable infer ( quot -- effect )
- [ recursive-state get infer-quot ] with-infer drop ;
+ [ infer-quot-here ] with-infer drop ;
: infer. ( quot -- )
#! Safe to call from inference transforms.
recursive-state get at ;
: local-recursive-state ( -- assoc )
- recursive-state get dup keys
- [ dup word? [ inline? ] when not ] find drop
+ recursive-state get dup
+ [ first dup word? [ inline? ] when not ] find drop
[ head-slice ] when* ;
: inline-recursive-label ( word -- label/f )