compiler.tests.alien: wrap all callback tests in special

unit-test-with-destructor blocks, that way they dont leak memory in the
callback heap

diff --git a/basis/compiler/tests/alien.factor b/basis/compiler/tests/alien.factor
index 46fd171a4441882c6fd4c641eee529258921359d..efda89adaa3430cc2c949fc369ebf2ebd4256099 100755 (executable)
--- a/basis/compiler/tests/alien.factor
+++ b/basis/compiler/tests/alien.factor
@@ -1,6 +1,6 @@
 USING: accessors alien alien.c-types alien.libraries
 alien.syntax arrays classes.struct combinators
-compiler continuations effects generalizations io
+compiler continuations destructors effects fry generalizations io
 io.backend io.pathnames io.streams.string kernel
 math memory namespaces namespaces.private parser
 quotations sequences specialized-arrays stack-checker
@@ -13,6 +13,9 @@ SPECIALIZED-ARRAY: float
 SPECIALIZED-ARRAY: char
 IN: compiler.tests.alien
 
+: unit-test-with-destructors ( exp quot -- )
+    '[ _ with-destructors ] unit-test ; inline
+
 ! Make sure that invalid inputs don't pass the stack checker
 [ [ void { } "cdecl" alien-indirect ] infer ] must-fail
 [ [ "void" { } cdecl alien-indirect ] infer ] must-fail
@@ -338,63 +341,65 @@ FUNCTION: ulonglong ffi_test_38 ( ulonglong x, ulonglong y ) ;
 : callback-throws ( -- x )
     int { } cdecl [ "Hi" throw ] alien-callback ;
 
-[ t ] [ callback-throws alien? ] unit-test
+{ t } [ callback-throws alien? ] unit-test-with-destructors
 
 : callback-1 ( -- callback ) void { } cdecl [ ] alien-callback ;
 
 [ 0 1 ] [ [ callback-1 ] infer [ in>> length ] [ out>> length ] bi ] unit-test
 
-[ t ] [ callback-1 alien? ] unit-test
+{ t } [ callback-1 alien? ] unit-test-with-destructors
 
 : callback_test_1 ( ptr -- ) void { } cdecl alien-indirect ;
 
-[ ] [ callback-1 callback_test_1 ] unit-test
+{ } [ callback-1 callback_test_1 ] unit-test-with-destructors
 
 : callback-2 ( -- callback ) void { } cdecl [ [ 5 throw ] ignore-errors ] alien-callback ;
 
-[ ] [ callback-2 callback_test_1 ] unit-test
+{ } [ callback-2 callback_test_1 ] unit-test-with-destructors
 
 : callback-3 ( -- callback ) void { } cdecl [ 5 "x" set ] alien-callback ;
 
-[ t 3 5 ] [
+{ t 3 5 } [
     [
         namestack*
         3 "x" set callback-3 callback_test_1
         namestack* eq?
         "x" get "x" get-global
     ] with-scope
-] unit-test
+] unit-test-with-destructors
 
 : callback-5 ( -- callback )
     void { } cdecl [ gc ] alien-callback ;
 
-[ "testing" ] [
+{ "testing" } [
     "testing" callback-5 callback_test_1
-] unit-test
+] unit-test-with-destructors
 
 : callback-5b ( -- callback )
     void { } cdecl [ compact-gc ] alien-callback ;
 
 [ "testing" ] [
     "testing" callback-5b callback_test_1
-] unit-test
+] unit-test-with-destructors
 
 : callback-6 ( -- callback )
     void { } cdecl [ [ continue ] callcc0 ] alien-callback ;
 
-[ 1 2 3 ] [ callback-6 callback_test_1 1 2 3 ] unit-test
+[ 1 2 3 ] [
+    callback-6 callback_test_1 1 2 3
+] unit-test-with-destructors
 
 : callback-7 ( -- callback )
     void { } cdecl [ 1000000 sleep ] alien-callback ;
 
-[ 1 2 3 ] [ callback-7 callback_test_1 1 2 3 ] unit-test
+[ 1 2 3 ] [ callback-7 callback_test_1 1 2 3 ] unit-test-with-destructors
 
 [ f ] [ namespace global eq? ] unit-test
 
 : callback-8 ( -- callback )
     void { } cdecl [ [ ] in-thread yield ] alien-callback ;
 
-[ ] [ callback-8 callback_test_1 ] unit-test
+[ ] [ callback-8 callback_test_1 ] unit-test-with-destructors
 
 : callback-9 ( -- callback )
     int { int int int } cdecl [
@@ -407,9 +412,9 @@ FUNCTION: void ffi_test_36_point_5 ( ) ;
 
 FUNCTION: int ffi_test_37 ( void* func ) ;
 
-[ 1 ] [ callback-9 ffi_test_37 ] unit-test
+[ 1 ] [ callback-9 ffi_test_37 ] unit-test-with-destructors
 
-[ 7 ] [ callback-9 ffi_test_37 ] unit-test
+[ 7 ] [ callback-9 ffi_test_37 ] unit-test-with-destructors
 
 STRUCT: test_struct_13
 { x1 float }
@@ -463,12 +468,11 @@ STRUCT: double-rect
     void { void* void* double-rect } cdecl alien-indirect
     "example" get-global ;
 
-[ byte-array 1.0 2.0 3.0 4.0 ]
-[
+{ byte-array 1.0 2.0 3.0 4.0 } [
     1.0 2.0 3.0 4.0 <double-rect>
     double-rect-callback double-rect-test
     [ >c-ptr class-of ] [ >double-rect< ] bi
-] unit-test
+] unit-test-with-destructors
 
 STRUCT: test_struct_14
     { x1 double }
@@ -491,10 +495,10 @@ FUNCTION: test_struct_14 ffi_test_40 ( double x1, double x2 ) ;
 : callback-10-test ( x1 x2 callback -- result )
     test_struct_14 { double double } cdecl alien-indirect ;
 
-[ 1.0 2.0 ] [
+{ 1.0 2.0 } [
     1.0 2.0 callback-10 callback-10-test
     [ x1>> ] [ x2>> ] bi
-] unit-test
+] unit-test-with-destructors
 
 FUNCTION: test-struct-12 ffi_test_41 ( int a, double x ) ;
 
@@ -514,10 +518,10 @@ FUNCTION: test-struct-12 ffi_test_41 ( int a, double x ) ;
 : callback-11-test ( x1 x2 callback -- result )
     test-struct-12 { int double } cdecl alien-indirect ;
 
-[ 1 2.0 ] [
+{ 1 2.0 } [
     1 2.0 callback-11 callback-11-test
     [ a>> ] [ x>> ] bi
-] unit-test
+] unit-test-with-destructors
 
 STRUCT: test_struct_15
     { x float }
@@ -540,7 +544,7 @@ FUNCTION: test_struct_15 ffi_test_42 ( float x, float y ) ;
 
 [ 1.0 2.0 ] [
     1.0 2.0 callback-12 callback-12-test [ x>> ] [ y>> ] bi
-] unit-test
+] unit-test-with-destructors
 
 STRUCT: test_struct_16
     { x float }
@@ -561,10 +565,10 @@ FUNCTION: test_struct_16 ffi_test_43 ( float x, int a ) ;
 : callback-13-test ( x1 x2 callback -- result )
     test_struct_16 { float int } cdecl alien-indirect ;
 
-[ 1.0 2 ] [
+{ 1.0 2 } [
     1.0 2 callback-13 callback-13-test
     [ x>> ] [ a>> ] bi
-] unit-test
+] unit-test-with-destructors
 
 FUNCTION: test_struct_14 ffi_test_44 ( ) ; inline
 
@@ -619,8 +623,14 @@ FUNCTION: short ffi_test_48 ( bool-field-test x ) ;
     int { } cdecl alien-indirect ;
 
 <promise> "p" set
-[ thread-callback-1 thread-callback-invoker "p" get fulfill ] in-thread
-[ 200 ] [ thread-callback-2 thread-callback-invoker ] unit-test
+[
+    [
+        thread-callback-1 thread-callback-invoker "p" get fulfill
+    ] with-destructors
+] in-thread
+{ 200 } [
+    thread-callback-2 thread-callback-invoker
+] unit-test-with-destructors
 [ 100 ] [ "p" get ?promise ] unit-test
 
 ! More alien-assembly tests are in cpu.* vocabs
@@ -644,7 +654,7 @@ FUNCTION: short ffi_test_48 ( bool-field-test x ) ;
     [ int "f-fastcall" "ffi_test_51" { int int int } alien-invoke ]
     3dip
     int "f-fastcall" "ffi_test_51" { int int int } alien-invoke gc ;
-    
+
 [ 4 ] [ 3 ffi_test_49 ] unit-test
 [ 8 ] [ 3 4 ffi_test_50 ] unit-test
 [ 13 ] [ 3 4 5 ffi_test_51 ] unit-test
@@ -768,19 +778,29 @@ mingw? [
     test-struct-11 { int int int } fastcall
     [ [ drop + ] [ - nip ] 3bi test-struct-11 <struct-boa> ] alien-callback ;
 
-[ 8 ] [ 3 4 fastcall-ii-callback fastcall-ii-indirect ] unit-test
+{ 8 } [
+    3 4 fastcall-ii-callback fastcall-ii-indirect
+] unit-test-with-destructors
 
-[ 13 ] [ 3 4 5 fastcall-iii-callback fastcall-iii-indirect ] unit-test
+[ 13 ] [
+    3 4 5 fastcall-iii-callback fastcall-iii-indirect
+] unit-test-with-destructors
 
-[ 13 ] [ 3 4.0 5 fastcall-ifi-callback fastcall-ifi-indirect ] unit-test
+[ 13 ] [
+    3 4.0 5 fastcall-ifi-callback fastcall-ifi-indirect
+] unit-test-with-destructors
 
-[ 19 ] [ 3 4.0 5 6 fastcall-ifii-callback fastcall-ifii-indirect ] unit-test
+[ 19 ] [
+    3 4.0 5 6 fastcall-ifii-callback fastcall-ifii-indirect
+] unit-test-with-destructors
 
-[ S{ test-struct-11 f 7 -1 } ]
-[ 3 4 fastcall-struct-return-ii-callback fastcall-struct-return-ii-indirect ] unit-test
+[ S{ test-struct-11 f 7 -1 } ] [
+    3 4 fastcall-struct-return-ii-callback fastcall-struct-return-ii-indirect
+] unit-test-with-destructors
 
-[ S{ test-struct-11 f 7 -3 } ]
-[ 3 4 7 fastcall-struct-return-iii-callback fastcall-struct-return-iii-indirect ] unit-test
+[ S{ test-struct-11 f 7 -3 } ] [
+    3 4 7 fastcall-struct-return-iii-callback fastcall-struct-return-iii-indirect
+] unit-test-with-destructors
 
 : x64-regression-1 ( -- c )
     int { int int int int int } cdecl [ + + + + ] alien-callback ;
@@ -788,7 +808,9 @@ mingw? [
 : x64-regression-2 ( x x x x x c -- y )
     int { int int int int int } cdecl alien-indirect ; inline
 
-[ 661 ] [ 100 500 50 10 1 x64-regression-1 x64-regression-2 ] unit-test
+[ 661 ] [
+    100 500 50 10 1 x64-regression-1 x64-regression-2
+] unit-test-with-destructors
 
 ! Stack allocation
 : blah ( -- x ) { RECT } [ 1.5 >>x 2.0 >>y [ x>> ] [ y>> ] bi * >fixnum ] with-scoped-allocation ;
@@ -822,7 +844,9 @@ mingw? [
         alien-indirect
     ] with-out-parameters ;
 
-[ 12 ] [ 6 out-param-callback out-param-indirect ] unit-test
+[ 12 ] [
+    6 out-param-callback out-param-indirect
+] unit-test-with-destructors
 
 ! Alias analysis regression
 : aa-callback-1 ( -- c )
@@ -839,7 +863,7 @@ TUPLE: some-tuple x ;
         aa-callback-1
         aa-indirect-1 >>x
     ] compile-call
-] unit-test
+] unit-test-with-destructors
 
 ! GC maps regression
 : anton's-regression ( -- )