New initialize-alien word

basis/core-foundation/run-loop/run-loop.factor

@@ -56,25 +56,17 @@ FUNCTION: void CFRunLoopRemoveTimer (
 
 : CFRunLoopDefaultMode ( -- alien )
     #! Ugly, but we don't have static NSStrings
-    \ CFRunLoopDefaultMode get-global dup expired? [
-        drop
+    \ CFRunLoopDefaultMode [
         "kCFRunLoopDefaultMode" <CFString>
-        dup \ CFRunLoopDefaultMode set-global
-    ] when ;
+    ] initialize-alien ;
 
 TUPLE: run-loop fds sources timers ;
 
 : <run-loop> ( -- run-loop )
     V{ } clone V{ } clone V{ } clone \ run-loop boa ;
 
-SYMBOL: expiry-check
-
 : run-loop ( -- run-loop )
-    \ run-loop get-global not expiry-check get expired? or
-    [
-        31337 <alien> expiry-check set-global
-        <run-loop> dup \ run-loop set-global
-    ] [ \ run-loop get-global ] if ;
+    \ run-loop [ <run-loop> ] initialize-alien ;
 
 : add-source-to-run-loop ( source -- )
     [ run-loop sources>> push ]

basis/io/sockets/secure/openssl/openssl.factor

@@ -143,16 +143,11 @@ TUPLE: ssl-handle file handle connected disposed ;
 
 SYMBOL: default-secure-context
 
-: context-expired? ( context -- ? )
-    dup [ handle>> expired? ] [ drop t ] if ;
-
 : current-secure-context ( -- ctx )
     secure-context get [
-        default-secure-context get dup context-expired? [
-            drop
-            <secure-config> <secure-context> default-secure-context set-global
-            current-secure-context
-        ] when
+        default-secure-context [
+            <secure-config> <secure-context>
+        ] initialize-alien
     ] unless* ;
 
 : <ssl-handle> ( fd -- ssl )
@@ -189,8 +184,7 @@ M: openssl check-certificate ( host ssl -- )
     ] [ 2drop ] if ;
 
 : get-session ( addrspec -- session/f )
-    current-secure-context sessions>> at
-    dup expired? [ drop f ] when ;
+    current-secure-context sessions>> at ;
 
 : save-session ( session addrspec -- )
     current-secure-context sessions>> set-at ;

basis/libc/libc.factor

@@ -26,15 +26,8 @@ IN: libc
 : (realloc) ( alien size -- newalien )
     "void*" "libc" "realloc" { "void*" "ulong" } alien-invoke ;
 
-SYMBOL: malloc-expiry
-
 : mallocs ( -- assoc )
-    malloc-expiry get-global expired? [
-        -1 <alien> malloc-expiry set-global
-        H{ } clone dup \ mallocs set-global
-    ] [
-        \ mallocs get-global
-    ] if ;
+    \ mallocs [ H{ } clone ] initialize-alien ;
 
 PRIVATE>
 

basis/ui/text/freetype/freetype.factor

@@ -18,8 +18,7 @@ M: freetype-renderer finish-text-rendering drop ;
 DEFER: init-freetype
 
 : freetype ( -- alien )
-    \ freetype get-global expired? [ init-freetype ] when
-    \ freetype get-global ;
+    \ freetype [ init-freetype ] initialize-alien ;
 
 TUPLE: freetype-font < identity-tuple
 ascent descent height handle widths ;

core/alien/alien-tests.factor

@@ -74,3 +74,15 @@ cell 8 = [
 [ f ] [ DLL" fadfasdfsada" dll-valid? ] unit-test
 
 [ f ] [ "does not exist" DLL" fadsfasfdsaf" dlsym ] unit-test
+
+SYMBOL: initialize-test
+
+f initialize-test set-global
+
+[ 31337 ] [ initialize-test [ 31337 ] initialize-alien ] unit-test
+
+[ 31337 ] [ initialize-test [ 69 ] initialize-alien ] unit-test
+
+[ ] [ initialize-test get BAD-ALIEN >>alien drop ] unit-test
+
+[ 7575 ] [ initialize-test [ 7575 ] initialize-alien ] unit-test

core/alien/alien.factor

@@ -86,3 +86,17 @@ ERROR: alien-invoke-error library symbol ;
 SYMBOL: callbacks
 
 [ H{ } clone callbacks set-global ] "alien" add-init-hook
+
+<PRIVATE
+
+TUPLE: expiry-check object alien ;
+
+: recompute-value? ( check -- ? )
+    dup [ alien>> expired? ] [ drop t ] if ;
+
+PRIVATE>
+
+: initialize-alien ( symbol quot -- )
+    swap dup get-global dup recompute-value?
+    [ drop [ call dup 31337 <alien> expiry-check boa ] dip set-global ]
+    [ 2nip object>> ] if ; inline