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

stack-checker.alien: new word stack-shape which replaces alien-inputs/outputs

char-rename
Björn Lindqvist 2016-08-06 19:00:23 +02:00
parent a79309680c
commit 0c7b871de7
2 changed files with 12 additions and 11 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
basis/stack-checker/alien/alien-tests.factor
View File

@ -15,7 +15,7 @@ IN: stack-checker.alien.tests
V{ } clone literals set V{ } clone literals set
30 \ <value> set-global 30 \ <value> set-global
alien-node-params new int >>return { int int } >>parameters alien-node-params new int >>return { int int } >>parameters
alien-inputs/outputs inputs/outputs
] unit-test ] unit-test
{ {
@ -28,7 +28,7 @@ IN: stack-checker.alien.tests
V{ } clone literals set V{ } clone literals set
30 \ <value> set-global 30 \ <value> set-global
alien-indirect-params new int >>return { int int } >>parameters alien-indirect-params new int >>return { int int } >>parameters
alien-inputs/outputs inputs/outputs
] unit-test ] unit-test
! wrap-callback-quot ! wrap-callback-quot

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

@ -25,11 +25,13 @@ TUPLE: alien-callback-params < alien-node-params
: param-prep-quot ( params -- quot ) : param-prep-quot ( params -- quot )
parameters>> [ lookup-c-type c-type-unboxer-quot ] map deep-spread>quot ; parameters>> [ lookup-c-type c-type-unboxer-quot ] map deep-spread>quot ;
: alien-inputs/outputs ( params -- in-d out-d ) : stack-shape ( params -- in out )
[ [
[ parameters>> length ] [ parameters>> length ] [ alien-indirect-params? 1 0 ? ] bi +
[ alien-indirect-params? 1 0 ? ] bi + consume-d ] [ return>> void? 0 1 ? ] bi ;
] [ return>> void? 0 1 ? produce-d ] bi ;
: inputs/outputs ( params -- in-d out-d )
stack-shape [ consume-d ] [ produce-d ] bi* ;
: return-prep-quot ( params -- quot ) : return-prep-quot ( params -- quot )
return>> [ [ ] ] [ lookup-c-type c-type-boxer-quot ] if-void ; return>> [ [ ] ] [ lookup-c-type c-type-boxer-quot ] if-void ;
@ -67,7 +69,7 @@ TUPLE: alien-callback-params < alien-node-params
! Quotation which coerces parameters to required types ! Quotation which coerces parameters to required types
dup param-prep-quot infer-quot-here dup param-prep-quot infer-quot-here
! Consume inputs and outputs and add node to IR ! Consume inputs and outputs and add node to IR
dup dup alien-inputs/outputs #alien-invoke, dup dup inputs/outputs #alien-invoke,
! Quotation which coerces return value to required type ! Quotation which coerces return value to required type
infer-return ; infer-return ;
@ -80,7 +82,7 @@ TUPLE: alien-callback-params < alien-node-params
! Coerce parameters to required types ! Coerce parameters to required types
dup param-prep-quot '[ _ [ >c-ptr ] bi* ] infer-quot-here dup param-prep-quot '[ _ [ >c-ptr ] bi* ] infer-quot-here
! Consume inputs and outputs and add node to IR ! Consume inputs and outputs and add node to IR
dup dup alien-inputs/outputs #alien-indirect, dup dup inputs/outputs #alien-indirect,
! Quotation which coerces return value to required type ! Quotation which coerces return value to required type
infer-return ; infer-return ;
@ -94,7 +96,7 @@ TUPLE: alien-callback-params < alien-node-params
! Quotation which coerces parameters to required types ! Quotation which coerces parameters to required types
dup param-prep-quot infer-quot-here dup param-prep-quot infer-quot-here
! Consume inputs and outputs and add node to IR ! Consume inputs and outputs and add node to IR
dup dup alien-inputs/outputs #alien-assembly, dup dup inputs/outputs #alien-assembly,
! Quotation which coerces return value to required type ! Quotation which coerces return value to required type
infer-return ; infer-return ;
@ -126,8 +128,7 @@ M: callable wrap-callback-quot
'[ _ _ do-callback ] >quotation ; '[ _ _ do-callback ] >quotation ;
: callback-effect ( params -- effect ) : callback-effect ( params -- effect )
[ parameters>> length "x" <array> ] stack-shape [ "x" <array> ] bi@ <effect> ;
[ return>> void? { } { "x" } ? ] bi <effect> ;
: infer-callback-quot ( params quot -- child ) : infer-callback-quot ( params quot -- child )
[ [