steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Clean up recursive-state usage

db4
Slava Pestov 2008-11-03 03:06:11 -06:00
parent 0250d7c1d2
commit 2445a83cb9
6 changed files with 16 additions and 13 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

10
basis/stack-checker/alien/alien.factor
View File

@ -36,7 +36,7 @@ TUPLE: alien-callback-params < alien-node-params quot xt ;
pop-literal nip >>library pop-literal nip >>library
pop-literal nip >>return pop-literal nip >>return
! Quotation which coerces parameters to required types ! 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 ! Set ABI
dup library>> library [ abi>> ] [ "cdecl" ] if* >>abi dup library>> library [ abi>> ] [ "cdecl" ] if* >>abi
! Magic #: consume exactly the number of inputs ! Magic #: consume exactly the number of inputs
@ -44,7 +44,7 @@ TUPLE: alien-callback-params < alien-node-params quot xt ;
! Add node to IR ! Add node to IR
dup #alien-invoke, dup #alien-invoke,
! Quotation which coerces return value to required type ! 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 ( -- ) : infer-alien-indirect ( -- )
alien-indirect-params new alien-indirect-params new
@ -53,13 +53,13 @@ TUPLE: alien-callback-params < alien-node-params quot xt ;
pop-parameters >>parameters pop-parameters >>parameters
pop-literal nip >>return pop-literal nip >>return
! Quotation which coerces parameters to required types ! 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 ! Magic #: consume the function pointer, too
dup 1 alien-stack dup 1 alien-stack
! Add node to IR ! Add node to IR
dup #alien-indirect, dup #alien-indirect,
! Quotation which coerces return value to required type ! 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 ! Callbacks are registered in a global hashtable. If you clear
! this hashtable, they will all be blown away by code GC, beware ! this hashtable, they will all be blown away by code GC, beware
@ -71,7 +71,7 @@ SYMBOL: callbacks
: callback-bottom ( params -- ) : callback-bottom ( params -- )
xt>> [ [ register-callback ] [ word-xt drop <alien> ] bi ] curry xt>> [ [ register-callback ] [ word-xt drop <alien> ] bi ] curry
recursive-state get infer-quot ; infer-quot-here ;
: infer-alien-callback ( -- ) : infer-alien-callback ( -- )
alien-callback-params new alien-callback-params new

7
basis/stack-checker/backend/backend.factor
View File

@ -60,17 +60,20 @@ M: object apply-object push-literal ;
: terminate ( -- ) : terminate ( -- )
terminated? on meta-d get clone meta-r get clone #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 -- ) : infer-quot ( quot rstate -- )
recursive-state get [ recursive-state get [
recursive-state set recursive-state set
[ apply-object terminated? get not ] all? drop infer-quot-here
] dip recursive-state set ; ] dip recursive-state set ;
: infer-quot-recursive ( quot word label -- ) : infer-quot-recursive ( quot word label -- )
2array recursive-state get swap prefix infer-quot ; 2array recursive-state get swap prefix infer-quot ;
: time-bomb ( error -- ) : time-bomb ( error -- )
'[ _ throw ] recursive-state get infer-quot ; '[ _ throw ] infer-quot-here ;
: bad-call ( -- ) : bad-call ( -- )
"call must be given a callable" time-bomb ; "call must be given a callable" time-bomb ;

2
basis/stack-checker/branches/branches.factor
View File

@ -100,7 +100,7 @@ SYMBOL: quotations
dup [ known [ curried? ] [ composed? ] bi or ] contains? [ dup [ known [ curried? ] [ composed? ] bi or ] contains? [
output-d output-d
[ rot [ drop call ] [ nip call ] if ] [ rot [ drop call ] [ nip call ] if ]
recursive-state get infer-quot infer-quot-here
] [ ] [
[ #drop, ] [ [ literal ] map (infer-if) ] bi [ #drop, ] [ [ literal ] map (infer-if) ] bi
] if ; ] if ;

4
basis/stack-checker/known-words/known-words.factor
View File

@ -68,14 +68,14 @@ M: literal infer-call*
M: curried infer-call* M: curried infer-call*
swap push-d swap push-d
[ uncurry ] recursive-state get infer-quot [ uncurry ] infer-quot-here
[ quot>> known pop-d [ set-known ] keep ] [ quot>> known pop-d [ set-known ] keep ]
[ obj>> known pop-d [ set-known ] keep ] bi [ obj>> known pop-d [ set-known ] keep ] bi
push-d infer-call ; push-d infer-call ;
M: composed infer-call* M: composed infer-call*
swap push-d swap push-d
[ uncompose ] recursive-state get infer-quot [ uncompose ] infer-quot-here
[ quot2>> known pop-d [ set-known ] keep ] [ quot2>> known pop-d [ set-known ] keep ]
[ quot1>> known pop-d [ set-known ] keep ] bi [ quot1>> known pop-d [ set-known ] keep ] bi
push-d push-d push-d push-d

2
basis/stack-checker/stack-checker.factor
View File

@ -10,7 +10,7 @@ IN: stack-checker
GENERIC: infer ( quot -- effect ) GENERIC: infer ( quot -- effect )
M: callable infer ( quot -- effect ) M: callable infer ( quot -- effect )
[ recursive-state get infer-quot ] with-infer drop ; [ infer-quot-here ] with-infer drop ;
: infer. ( quot -- ) : infer. ( quot -- )
#! Safe to call from inference transforms. #! Safe to call from inference transforms.

4
basis/stack-checker/state/state.factor
View File

@ -75,8 +75,8 @@ SYMBOL: meta-r
recursive-state get at ; recursive-state get at ;
: local-recursive-state ( -- assoc ) : local-recursive-state ( -- assoc )
recursive-state get dup keys recursive-state get dup
[ dup word? [ inline? ] when not ] find drop [ first dup word? [ inline? ] when not ] find drop
[ head-slice ] when* ; [ head-slice ] when* ;
: inline-recursive-label ( word -- label/f ) : inline-recursive-label ( word -- label/f )