add CALLBACK: syntax that defines a typedef and an alien-callback constructor word for function pointer types. update some code in iokit.hid and windows.dinput to use CALLBACK: instead of TYPEDEF:/word pairs

basis/alien/parser/parser.factor

@@ -25,7 +25,7 @@ IN: alien.parser
     [ parse-c-type ] if ; 
 
 : reset-c-type ( word -- )
-    { "c-type" "pointer-c-type" } reset-props ;
+    { "c-type" "pointer-c-type" "callback-effect" "callback-abi" } reset-props ;
 
 : CREATE-C-TYPE ( -- word )
     scan current-vocab create dup reset-c-type ;
@@ -55,16 +55,37 @@ IN: alien.parser
     return library function
     parameters return parse-arglist [ function-quot ] dip ;
 
+: parse-arg-tokens ( -- tokens )
+    ";" parse-tokens [ "()" subseq? not ] filter ;
+
 : (FUNCTION:) ( -- word quot effect )
-    scan "c-library" get scan ";" parse-tokens
+    scan "c-library" get scan parse-arg-tokens make-function ;
-    [ "()" subseq? not ] filter
-    make-function ;
 
 : define-function ( return library function parameters -- )
     make-function define-declared ;
 
+: callback-quot ( return types abi -- quot )
+    [ [ ] 3curry dip alien-callback ] 3curry ;
+
+:: make-callback-type ( abi return! type-name! parameters -- word quot effect )
+    return type-name normalize-c-arg type-name! return!
+    type-name current-vocab create :> type-word 
+    type-word [ reset-generic ] [ reset-c-type ] bi
+    void* type-word typedef
+    parameters return parse-arglist :> callback-effect :> types
+    type-word callback-effect "callback-effect" set-word-prop
+    type-word abi "callback-abi" set-word-prop
+    type-word return types abi callback-quot (( quot -- alien )) ;
+
+: (CALLBACK:) ( abi -- word quot effect )
+    scan scan parse-arg-tokens make-callback-type ;
+
 PREDICATE: alien-function-word < word
     def>> {
         [ length 5 = ]
         [ last \ alien-invoke eq? ]
     } 1&& ;
+
+PREDICATE: alien-callback-type-word < typedef-word
+    "callback-effect" word-prop ;
+

basis/alien/syntax/syntax-docs.factor

@@ -81,6 +81,10 @@ HELP: C-ENUM:
     { $code "CONSTANT: red 0" "CONSTANT: green 1" "CONSTANT: blue 2" }
 } ;
 
+HELP: CALLBACK:
+{ $syntax "CALLBACK: return name ( parameters ) ;" }
+{ $values { "return" "a C return type" } { "name" "a type name" } { "parameters" "a comma-separated sequence of type/name pairs; " { $snippet "type1 arg1, type2 arg2, ..." } } }
+
 HELP: &:
 { $syntax "&: symbol" }
 { $values { "symbol" "A C library symbol name" } }

basis/alien/syntax/syntax.factor

@@ -18,6 +18,12 @@ SYNTAX: LIBRARY: scan "c-library" set ;
 SYNTAX: FUNCTION:
     (FUNCTION:) define-declared ;
 
+SYNTAX: CALLBACK:
+    "cdecl" (CALLBACK:) define-inline ;
+
+SYNTAX: STDCALL-CALLBACK:
+    "stdcall" (CALLBACK:) define-inline ;
+
 SYNTAX: TYPEDEF:
     scan-c-type CREATE-C-TYPE typedef ;
 

basis/iokit/hid/hid.factor

@@ -130,30 +130,11 @@ TYPEDEF: void* IOHIDTransactionRef
 TYPEDEF: UInt32 IOHIDValueScaleType
 TYPEDEF: UInt32 IOHIDTransactionDirectionType
 
-TYPEDEF: void* IOHIDCallback
+CALLBACK: void IOHIDCallback ( void* context, IOReturn result, void* sender ) ;
-: IOHIDCallback ( quot -- alien )
+CALLBACK: void IOHIDReportCallback ( void* context, IOReturn result, void* sender, IOHIDReportType type, UInt32 reportID, uchar* report, CFIndex reportLength ) ;
-    [ "void" { "void*" "IOReturn" "void*" } "cdecl" ]
+CALLBACK: void IOHIDValueCallback ( void* context, IOReturn result, void* sender, IOHIDValueRef value ) ;
-    dip alien-callback ; inline
+CALLBACK: void IOHIDValueMultipleCallback ( void* context, IOReturn result, void* sender, CFDictionaryRef multiple ) ;
-
+CALLBACK: void IOHIDDeviceCallback ( void* context, IOReturn result, void* sender, IOHIDDeviceRef device ) ;
-TYPEDEF: void* IOHIDReportCallback
-: IOHIDReportCallback ( quot -- alien )
-    [ "void" { "void*" "IOReturn" "void*" "IOHIDReportType" "UInt32" "uchar*" "CFIndex" } "cdecl" ]
-    dip alien-callback ; inline
-
-TYPEDEF: void* IOHIDValueCallback
-: IOHIDValueCallback ( quot -- alien )
-    [ "void" { "void*" "IOReturn" "void*" "IOHIDValueRef" } "cdecl" ]
-    dip alien-callback ; inline
-
-TYPEDEF: void* IOHIDValueMultipleCallback
-: IOHIDValueMultipleCallback ( quot -- alien )
-    [ "void" { "void*" "IOReturn" "void*" "CFDictionaryRef" } "cdecl" ]
-    dip alien-callback ; inline
-
-TYPEDEF: void* IOHIDDeviceCallback
-: IOHIDDeviceCallback ( quot -- alien )
-    [ "void" { "void*" "IOReturn" "void*" "IOHIDDeviceRef" } "cdecl" ]
-    dip alien-callback ; inline
 
 ! IOHIDDevice
 

basis/windows/dinput/dinput.factor

@@ -5,35 +5,6 @@ IN: windows.dinput
 
 LIBRARY: dinput
 
-TYPEDEF: void* LPDIENUMDEVICESCALLBACKW
-: LPDIENUMDEVICESCALLBACKW ( quot -- alien )
-    [ "BOOL" { "LPCDIDEVICEINSTANCEW" "LPVOID" } "stdcall" ]
-    dip alien-callback ; inline
-TYPEDEF: void* LPDIENUMDEVICESBYSEMANTICSCBW
-: LPDIENUMDEVICESBYSEMANTICSCBW ( quot -- alien )
-    [ "BOOL" { "LPCDIDEVICEINSTANCEW" "IDirectInputDevice8W*" "DWORD" "DWORD" "LPVOID" } "stdcall" ]
-    dip alien-callback ; inline
-TYPEDEF: void* LPDICONFIGUREDEVICESCALLBACK
-: LPDICONFIGUREDEVICESCALLBACK ( quot -- alien )
-    [ "BOOL" { "IUnknown*" "LPVOID" } "stdcall" ]
-    dip alien-callback ; inline
-TYPEDEF: void* LPDIENUMEFFECTSCALLBACKW
-: LPDIENUMEFFECTSCALLBACKW ( quot -- alien )
-    [ "BOOL" { "LPCDIEFFECTINFOW" "LPVOID" } "stdcall" ]
-    dip alien-callback ; inline
-TYPEDEF: void* LPDIENUMCREATEDEFFECTOBJECTSCALLBACK
-: LPDIENUMCREATEDEFFECTOBJECTSCALLBACK ( quot -- callback )
-    [ "BOOL" { "LPDIRECTINPUTEFFECT" "LPVOID" } "stdcall" ]
-    dip alien-callback ; inline
-TYPEDEF: void* LPDIENUMEFFECTSINFILECALLBACK
-: LPDIENUMEFFECTSINFILECALLBACK ( quot -- callback )
-    [ "BOOL" { "LPCDIFILEEFFECT" "LPVOID" } "stdcall" ]
-    dip alien-callback ; inline
-TYPEDEF: void* LPDIENUMDEVICEOBJECTSCALLBACKW
-: LPDIENUMDEVICEOBJECTSCALLBACKW ( quot -- callback )
-    [ "BOOL" { "LPCDIDEVICEOBJECTINSTANCEW" "LPVOID" } "stdcall" ]
-    dip alien-callback ; inline
-
 TYPEDEF: DWORD D3DCOLOR
 
 STRUCT: DIDEVICEINSTANCEW
@@ -326,6 +297,27 @@ STRUCT: DIJOYSTATE2
 TYPEDEF: DIJOYSTATE2* LPDIJOYSTATE2
 TYPEDEF: DIJOYSTATE2* LPCDIJOYSTATE2
 
+STDCALL-CALLBACK: BOOL LPDIENUMDEVICESCALLBACKW (
+    LPCDIDEVICEINSTANCEW lpddi,
+    LPVOID pvRef
+) ;
+STDCALL-CALLBACK: BOOL LPDICONFIGUREDEVICESCALLBACK (
+    IUnknown* lpDDSTarget,
+    LPVOID pvRef
+) ;
+STDCALL-CALLBACK: BOOL LPDIENUMEFFECTSCALLBACKW (
+    LPCDIEFFECTINFOW pdei,
+    LPVOID pvRef
+) ;
+STDCALL-CALLBACK: BOOL LPDIENUMEFFECTSINFILECALLBACK (
+    LPCDIFILEEFFECT lpDiFileEf,
+    LPVOID pvRef
+) ;
+STDCALL-CALLBACK: BOOL LPDIENUMDEVICEOBJECTSCALLBACKW (
+    LPCDIDEVICEOBJECTINSTANCEW lpddoi,
+    LPVOID pvRef
+) ;
+
 COM-INTERFACE: IDirectInputEffect IUnknown {E7E1F7C0-88D2-11D0-9AD0-00A0C9A06E35}
     HRESULT Initialize ( HINSTANCE hinst, DWORD dwVersion, REFGUID rguid )
     HRESULT GetEffectGuid ( LPGUID pguid )
@@ -338,6 +330,11 @@ COM-INTERFACE: IDirectInputEffect IUnknown {E7E1F7C0-88D2-11D0-9AD0-00A0C9A06E35
     HRESULT Unload ( )
     HRESULT Escape ( LPDIEFFESCAPE pesc ) ;
 
+STDCALL-CALLBACK: BOOL LPDIENUMCREATEDEFFECTOBJECTSCALLBACK (
+    IDirectInputEffect* peff,
+    LPVOID pvRef
+) ;
+
 COM-INTERFACE: IDirectInputDevice8W IUnknown {54D41081-DC15-4833-A41B-748F73A38179}
     HRESULT GetCapabilities ( LPDIDEVCAPS lpDIDeviceCaps )
     HRESULT EnumObjects ( LPDIENUMDEVICEOBJECTSCALLBACKW lpCallback, LPVOID pvRef, DWORD dwFlags )
@@ -369,6 +366,14 @@ COM-INTERFACE: IDirectInputDevice8W IUnknown {54D41081-DC15-4833-A41B-748F73A381
     HRESULT SetActionMap ( LPDIACTIONFORMATW lpdiActionFormat, LPCWSTR lpwszUserName, DWORD dwFlags )
     HRESULT GetImageInfo ( LPDIDEVICEIMAGEINFOHEADERW lpdiDeviceImageInfoHeader ) ;
 
+STDCALL-CALLBACK: BOOL LPDIENUMDEVICESBYSEMANTICSCBW (
+    LPCDIDEVICEINSTANCEW lpddi, 
+    IDirectInputDevice8W* lpdid,
+    DWORD dwFlags,
+    DWORD dwRemaining,
+    LPVOID pvRef
+) ;
+
 COM-INTERFACE: IDirectInput8W IUnknown {BF798031-483A-4DA2-AA99-5D64ED369700}
     HRESULT CreateDevice ( REFGUID rguid, IDirectInputDevice8W** lplpDevice, LPUNKNOWN pUnkOuter )
     HRESULT EnumDevices ( DWORD dwDevType, LPDIENUMDEVICESCALLBACKW lpCallback, LPVOID pvRef, DWORD dwFlags )