windows.directx.dinput: use macros to define format constants to avoid holding onto...

diff --git a/basis/windows/directx/dinput/constants/constants.factor b/basis/windows/directx/dinput/constants/constants.factor
index ba4d750174ddb7a1a63dd62509fd67bb76352063..18f391a285cb44243e80727dfdb0675de5a7b7c7 100644 (file)
--- a/basis/windows/directx/dinput/constants/constants.factor
+++ b/basis/windows/directx/dinput/constants/constants.factor
@@ -3,7 +3,7 @@ windows.com.syntax alien alien.c-types alien.data alien.syntax
 kernel system namespaces combinators sequences fry math accessors
 macros words quotations libc continuations generalizations
 splitting locals assocs init specialized-arrays memoize
-classes.struct strings arrays ;
+classes.struct strings arrays literals ;
 SPECIALIZED-ARRAY: DIOBJECTDATAFORMAT
 IN: windows.directx.dinput.constants
 
@@ -20,12 +20,13 @@ SYMBOLS:
 
 <PRIVATE
 
+<<
+
 MEMO: c-type* ( name -- c-type ) c-type ;
 MEMO: heap-size* ( c-type -- n ) heap-size ;
 
 GENERIC: array-base-type ( c-type -- c-type' )
 M: object array-base-type ;
-M: string array-base-type "[" split1 drop ;
 M: array array-base-type first ;
 
 : (field-spec-of) ( field struct -- field-spec )
@@ -45,61 +46,59 @@ M: array array-base-type first ;
 : (flags) ( array -- n )
     0 [ (flag) bitor ] reduce ;
 
-: <DIOBJECTDATAFORMAT> ( struct {pguid-var,field,index,dwType-flags,dwFlags} -- alien )
+: <DIOBJECTDATAFORMAT>-quot ( struct {pguid-var,field,index,dwType-flags,dwFlags} -- quot )
     {
-        [ first dup word? [ get ] when ]
+        [ first dup word? [ '[ _ get ] ] [ drop [ f ] ] if ]
         [ second rot [ (offsetof) ] [ (sizeof) ] 2bi ]
         [ third * + ]
         [ fourth (flags) ]
         [ 4 swap nth (flag) ]
     } cleave
-    DIOBJECTDATAFORMAT <struct-boa> ;
+    '[ @ _ _ _ DIOBJECTDATAFORMAT <struct-boa> ] ;
 
-:: make-DIOBJECTDATAFORMAT-array ( struct array -- alien )
-    array length malloc-DIOBJECTDATAFORMAT-array :> alien
+:: make-DIOBJECTDATAFORMAT-array-quot ( struct array -- quot )
+    array length '[ _ malloc-DIOBJECTDATAFORMAT-array ]
     array [| args i |
-        struct args <DIOBJECTDATAFORMAT>
-        i alien set-nth
-    ] each-index
-    alien ;
+        struct args <DIOBJECTDATAFORMAT>-quot
+        i '[ _ pick set-nth ] compose compose
+    ] each-index ;
 
-: <DIDATAFORMAT> ( dwFlags dwDataSize struct rgodf-array -- alien )
-    [ DIDATAFORMAT heap-size DIOBJECTDATAFORMAT heap-size ] 4 ndip
-    [ nip length ] [ make-DIOBJECTDATAFORMAT-array ] 2bi
-    DIDATAFORMAT <struct-boa> ;
+>>
 
-: initialize ( symbol quot -- )
-    call swap set-global ; inline
+MACRO: <DIDATAFORMAT> ( dwFlags dwDataSize struct rgodf-array -- alien )
+    [ DIDATAFORMAT heap-size DIOBJECTDATAFORMAT heap-size ] 4 ndip
+    [ nip length ] [ make-DIOBJECTDATAFORMAT-array-quot ] 2bi
+    '[ _ _ _ _ _ @ DIDATAFORMAT <struct-boa> ] ;
 
 : (malloc-guid-symbol) ( symbol guid -- )
-    '[ _ execute( -- value ) malloc-byte-array ] initialize ;
+    '[ _ malloc-byte-array ] initialize ;
 
 : define-guid-constants ( -- )
     {
-        { GUID_XAxis_malloced          GUID_XAxis }
-        { GUID_YAxis_malloced          GUID_YAxis }
-        { GUID_ZAxis_malloced          GUID_ZAxis }
-        { GUID_RxAxis_malloced         GUID_RxAxis }
-        { GUID_RyAxis_malloced         GUID_RyAxis }
-        { GUID_RzAxis_malloced         GUID_RzAxis }
-        { GUID_Slider_malloced         GUID_Slider }
-        { GUID_Button_malloced         GUID_Button }
-        { GUID_Key_malloced            GUID_Key }
-        { GUID_POV_malloced            GUID_POV }
-        { GUID_Unknown_malloced        GUID_Unknown }
-        { GUID_SysMouse_malloced       GUID_SysMouse }
-        { GUID_SysKeyboard_malloced    GUID_SysKeyboard }
-        { GUID_Joystick_malloced       GUID_Joystick }
-        { GUID_SysMouseEm_malloced     GUID_SysMouseEm }
-        { GUID_SysMouseEm2_malloced    GUID_SysMouseEm2 }
-        { GUID_SysKeyboardEm_malloced  GUID_SysKeyboardEm }
-        { GUID_SysKeyboardEm2_malloced GUID_SysKeyboardEm2 }
+        { GUID_XAxis_malloced          $ GUID_XAxis }
+        { GUID_YAxis_malloced          $ GUID_YAxis }
+        { GUID_ZAxis_malloced          $ GUID_ZAxis }
+        { GUID_RxAxis_malloced         $ GUID_RxAxis }
+        { GUID_RyAxis_malloced         $ GUID_RyAxis }
+        { GUID_RzAxis_malloced         $ GUID_RzAxis }
+        { GUID_Slider_malloced         $ GUID_Slider }
+        { GUID_Button_malloced         $ GUID_Button }
+        { GUID_Key_malloced            $ GUID_Key }
+        { GUID_POV_malloced            $ GUID_POV }
+        { GUID_Unknown_malloced        $ GUID_Unknown }
+        { GUID_SysMouse_malloced       $ GUID_SysMouse }
+        { GUID_SysKeyboard_malloced    $ GUID_SysKeyboard }
+        { GUID_Joystick_malloced       $ GUID_Joystick }
+        { GUID_SysMouseEm_malloced     $ GUID_SysMouseEm }
+        { GUID_SysMouseEm2_malloced    $ GUID_SysMouseEm2 }
+        { GUID_SysKeyboardEm_malloced  $ GUID_SysKeyboardEm }
+        { GUID_SysKeyboardEm2_malloced $ GUID_SysKeyboardEm2 }
     } [ first2 (malloc-guid-symbol) ] each ;
 
 : define-joystick-format-constant ( -- )
     c_dfDIJoystick2 [
         DIDF_ABSAXIS
-        DIJOYSTATE2 heap-size
+        $[ DIJOYSTATE2 heap-size ]
         DIJOYSTATE2 {
             { GUID_XAxis_malloced  "lX"           0 { DIDFT_OPTIONAL DIDFT_AXIS   DIDFT_ANYINSTANCE } 0 }
             { GUID_YAxis_malloced  "lY"           0 { DIDFT_OPTIONAL DIDFT_AXIS   DIDFT_ANYINSTANCE } 0 }
@@ -271,7 +270,7 @@ M: array array-base-type first ;
 : define-mouse-format-constant ( -- )
     c_dfDIMouse2 [
         DIDF_RELAXIS
-        DIMOUSESTATE2 heap-size
+        $[ DIMOUSESTATE2 heap-size ]
         DIMOUSESTATE2 {
             { GUID_XAxis_malloced  "lX"         0 {                DIDFT_ANYINSTANCE DIDFT_AXIS   } 0 }
             { GUID_YAxis_malloced  "lY"         0 {                DIDFT_ANYINSTANCE DIDFT_AXIS   } 0 }
@@ -828,10 +827,11 @@ M: array array-base-type first ;
     define-guid-constants
     define-format-constants ;
 
-[ define-constants ] "windows.directx.dinput.constants" add-startup-hook
+! [ define-constants ] "windows.directx.dinput.constants" add-startup-hook
 
 : uninitialize ( variable quot -- )
-    '[ _ when* f ] change-global ; inline
+    [ '[ _ when* f ] change-global ]
+    [ drop global delete-at ] 2bi ; inline
 
 : free-dinput-constants ( -- )
     {