alien.data: document with-scoped-allocation and with-out-parameters, and add initial: syntax

basis/alien/data/data-docs.factor

@@ -1,7 +1,7 @@
 USING: alien alien.c-types help.syntax help.markup libc
 kernel.private byte-arrays math strings hashtables alien.syntax
 alien.strings sequences io.encodings.string debugger destructors
-vocabs.loader classes.struct ;
+vocabs.loader classes.struct quotations ;
 IN: alien.data
 
 HELP: <c-array>
@@ -44,6 +44,49 @@ HELP: malloc-byte-array
 
 { string>alien alien>string malloc-string } related-words
 
+HELP: with-scoped-allocation
+{ $values { "c-types" "a list of scoped allocation specifiers" } { "quot" quotation } }
+{ $description "Allocates values on the call stack, calls the quotation, then deallocates the values as soon as the quotation returns."
+$nl
+"A scoped allocation specifier is either:"
+{ $list
+    "a C type name,"
+    { "or a triple with shape " { $snippet "{ c-type initial: initial }" } ", where " { $snippet "c-type" } " is a C type name and " { $snippet "initial" } " is a literal value." }
+}
+"If no initial value is specified, the contents of the allocated memory are undefined." }
+{ $warning "Reading or writing a scoped allocation buffer outside of the given quotation will cause memory corruption." }
+{ $examples
+    { $example
+        "USING: accessors alien.c-types alien.data
+classes.struct kernel math math.functions
+prettyprint ;
+IN: scratchpad
+
+STRUCT: point { x int } { y int } ;
+
+: scoped-allocation-test ( -- x )
+    { point } [
+        3 >>x 4 >>y
+        [ x>> sq ] [ y>> sq ] bi + sqrt
+    ] with-scoped-allocation ;
+
+scoped-allocation-test ."
+"5.0"
+    }
+} ;
+
+HELP: with-out-parameters
+{ $values { "c-types" "a list of scoped allocation specifiers" } { "quot" quotation } { "finish" quotation } { "values..." "zero or more values" } }
+{ $description "Allocates values on the call stack, calls the quotation, then copies all stack allocated values to the data heap after the quotation returns."
+$nl
+"A scoped allocation specifier is either:"
+{ $list
+    "a C type name,"
+    { "or a triple with shape " { $snippet "{ c-type initial: initial }" } ", where " { $snippet "c-type" } " is a C type name and " { $snippet "initial" } " is a literal value." }
+}
+"If no initial value is specified, the contents of the allocated memory are undefined." }
+{ $warning "Reading or writing a scoped allocation buffer outside of the given quotation will cause memory corruption." } ;
+
 ARTICLE: "malloc" "Manual memory management"
 "Sometimes data passed to C functions must be allocated at a fixed address. See " { $link "byte-arrays-gc" } " for an explanation of when this is the case."
 $nl

basis/alien/data/data.factor

@@ -2,7 +2,8 @@
 USING: accessors alien alien.c-types alien.arrays alien.strings
 arrays byte-arrays cpu.architecture fry io io.encodings.binary
 io.files io.streams.memory kernel libc math math.functions 
-sequences words macros combinators generalizations ;
+sequences words macros combinators generalizations
+stack-checker.dependencies combinators.short-circuit ;
 QUALIFIED: math
 IN: alien.data
 
@@ -88,13 +89,34 @@ ERROR: local-allocation-error ;
     ! to still be abl to access scope-allocated data.
     ;
 
+MACRO: (simple-local-allot) ( c-type -- quot )
+    [ depends-on-c-type ]
+    [ dup '[ _ heap-size _ c-type-align (local-allot) ] ] bi ;
+
+: [hairy-local-allot] ( c-type initial -- quot )
+    over '[ _ (simple-local-allot) _ over 0 _ set-alien-value ] ;
+
+: hairy-local-allot? ( obj -- ? )
+    {
+        [ array? ]
+        [ length 3 = ]
+        [ second initial: eq? ]
+    } 1&& ;
+
+MACRO: (hairy-local-allot) ( obj -- quot )
+    dup hairy-local-allot?
+    [ first3 nip [hairy-local-allot] ]
+    [ '[ _ (simple-local-allot) ] ]
+    if ;
+
 MACRO: (local-allots) ( c-types -- quot )
-    [ '[ _ [ heap-size ] [ c-type-align ] bi (local-allot) ] ] map [ ] join ;
+    [ '[ _ (hairy-local-allot) ] ] map [ ] join ;
 
 MACRO: box-values ( c-types -- quot )
     [ c-type-boxer-quot ] map '[ _ spread ] ;
 
 MACRO: out-parameters ( c-types -- quot )
+    [ dup hairy-local-allot? [ first ] when ] map
     [ length ] [ [ '[ 0 _ alien-value ] ] map ] bi
     '[ _ nkeep _ spread ] ;
 
@@ -104,7 +126,7 @@ PRIVATE>
     [ [ (local-allots) ] [ box-values ] bi ] dip call
     (cleanup-allot) ; inline
 
-: with-out-parameters ( c-types quot finish -- values )
+: with-out-parameters ( c-types quot finish -- values... )
     [ [ drop (local-allots) ] [ swap out-parameters ] 2bi ] dip call
     (cleanup-allot) ; inline
 

basis/compiler/tests/alien.factor

@@ -776,10 +776,22 @@ mingw? [
 
 [ 3 ] [ blah ] unit-test
 
-: out-param-test ( -- b )
+: out-param-test-1 ( -- b )
     { int } [ [ 12 ] dip 0 int set-alien-value ] [ ] with-out-parameters ;
 
-[ 12 ] [ out-param-test ] unit-test
+[ 12 ] [ out-param-test-1 ] unit-test
+
+: out-param-test-2 ( -- b )
+    { { int initial: 12 } } [ drop ] [ ] with-out-parameters ;
+
+[ 12 ] [ out-param-test-2 ] unit-test
+
+: out-param-test-3 ( -- x y )
+    { { RECT initial: S{ RECT { x 3 } { y 4 } } } } [ drop ]
+    [ clone ] with-out-parameters
+    [ x>> ] [ y>> ] bi ;
+
+[ 3.0 4.0 ] [ out-param-test-3 ] unit-test
 
 : out-param-callback ( -- a )
     void { int pointer: int } cdecl