alien-callback and alien-indirect now call the prep quotation

TODO.FACTOR.txt

@@ -5,7 +5,6 @@
 
 + ui:
 
-- input operation: copy
 - doc/handbook/alien.facts formatting wrong (erg)
 - docs: mention that 'like' may destroy the underlying sequence
 - live search: timer delay would be nice

library/compiler/alien/alien-callback.factor

@@ -54,11 +54,18 @@ M: alien-callback-error summary
         %callback-value
     ] if-void ;
 
+: alien-callback-quot* ( node -- quot )
+    [
+        \ init-error-handler ,
+        dup alien-callback-quot %
+        alien-callback-return
+        [ ] [ c-type c-type-prep % ] if-void
+    ] [ ] make ;
+
 : generate-callback ( node -- )
     [ alien-callback-xt ] keep [
         dup alien-callback-parameters registers>objects
-        dup alien-callback-quot \ init-error-handler add*
+        dup alien-callback-quot* %alien-callback
-        %alien-callback
         unbox-return
         %return
     ] generate-1 ;

library/compiler/alien/alien-indirect.factor

@@ -19,10 +19,12 @@ M: alien-indirect-error summary
 "infer-effect" set-word-prop
 
 \ alien-indirect [
-    empty-node <alien-indirect> dup node,
+    empty-node <alien-indirect>
     pop-literal nip over set-alien-indirect-abi
     pop-literal nip over set-alien-indirect-parameters
     pop-literal nip swap set-alien-indirect-return
+    dup alien-indirect-parameters prep-alien-parameters
+    dup node,
 ] "infer" set-word-prop
 
 : generate-indirect-cleanup ( node -- )

library/compiler/alien/alien-invoke.factor

@@ -28,20 +28,6 @@ M: alien-invoke-error summary
     [ alien-invoke-dlsym dlsym drop ]
     [ inference-warning ] recover ;
 
-: (make-prep-quot) ( parameters -- )
-    dup empty? [
-        drop
-    ] [
-        unclip c-type c-type-prep %
-        \ >r , (make-prep-quot) \ r> ,
-    ] if ;
-
-: make-prep-quot ( parameters -- quot )
-    [ <reversed> (make-prep-quot) ] [ ] make ;
-
-: prep-alien-invoke ( node -- )
-    alien-invoke-parameters make-prep-quot infer-quot ;
-
 \ alien-invoke [ string object string object ] [ ] <effect>
 "infer-effect" set-word-prop
 
@@ -51,7 +37,7 @@ M: alien-invoke-error summary
     pop-literal nip over set-alien-invoke-function
     pop-literal nip over set-alien-invoke-library
     pop-literal nip over set-alien-invoke-return
-    dup prep-alien-invoke
+    dup alien-invoke-parameters prep-alien-parameters
     dup ensure-dlsym
     dup node,
     alien-invoke-stack

library/compiler/alien/compiler.factor

@@ -2,7 +2,8 @@
 ! See http://factorcode.org/license.txt for BSD license.
 IN: alien
 USING: arrays compiler generic hashtables kernel
-kernel-internals math namespaces sequences words ;
+kernel-internals math namespaces sequences words
+inference ;
 
 : parameter-size c-size cell align ;
 
@@ -57,3 +58,14 @@ kernel-internals math namespaces sequences words ;
 
 : if-void ( type true false -- )
     pick "void" = [ drop nip call ] [ nip call ] if ; inline
+
+: make-prep-quot ( parameters -- )
+    dup empty? [
+        drop
+    ] [
+        unclip c-type c-type-prep %
+        \ >r , make-prep-quot \ r> ,
+    ] if ;
+
+: prep-alien-parameters ( parameters -- quot )
+    [ <reversed> make-prep-quot ] [ ] make infer-quot ;

library/compiler/alien/primitive-types.factor

@@ -85,7 +85,7 @@ bootstrap-cell
 "bool" define-primitive-type
 
 [ alien-float ]
-[ set-alien-float ]
+[ >r >r >float r> r> set-alien-float ]
 4
 "box_float"
 "unbox_float"
@@ -95,7 +95,7 @@ T{ float-regs f 4 } "float" c-type set-c-type-reg-class
 [ >float ] "float" c-type set-c-type-prep
 
 [ alien-double ]
-[ set-alien-double ]
+[ >r >r >float r> r> set-alien-double ]
 8
 "box_double"
 "unbox_double"

library/compiler/test/alien-objects.factor

@@ -1,5 +1,6 @@
 IN: temporary
-USING: alien arrays kernel kernel-internals namespaces test ;
+USING: alien arrays kernel kernel-internals namespaces test
+errors sequences ;
 
 [ t ] [ 0 <alien> 0 <alien> = ] unit-test
 [ f ] [ 0 <alien> 1024 <alien> = ] unit-test