STRUCT: complex-holder
{ z complex-float } ;
-: <complex-holder> ( z -- alien )
- complex-holder <struct-boa> ;
+C: <complex-holder> complex-holder
{ } [
C{ 1.0 2.0 } <complex-holder> "h" set
STRUCT: T-class { real N-type } { imaginary N-type } ;
: <T> ( z -- alien )
- >rect T-class <struct-boa> >c-ptr ;
+ >rect T-class boa >c-ptr ;
: *T ( alien -- z )
T-class memory>struct [ real>> ] [ imaginary>> ] bi rect> ; inline
get-time gmtoff>> 3600 /mod 60 /mod ;
: current-timeval ( -- timeval )
- timeval <struct> [ f gettimeofday io-error ] keep ; inline
+ timeval new [ f gettimeofday io-error ] keep ; inline
: system-micros ( -- n )
current-timeval timeval>micros ;
[ nip >integer ]
[ - 1000 * >integer ] 2bi
]
- } cleave \ SYSTEMTIME <struct-boa> ;
+ } cleave \ SYSTEMTIME boa ;
: SYSTEMTIME>timestamp ( SYSTEMTIME -- timestamp )
{
} cleave instant <timestamp> ;
M: windows gmt-offset
- TIME_ZONE_INFORMATION <struct>
+ TIME_ZONE_INFORMATION new
dup GetTimeZoneInformation {
{ TIME_ZONE_ID_INVALID [ win32-error ] }
{ TIME_ZONE_ID_UNKNOWN [ Bias>> ] }
} case neg 60 /mod 0 ;
M: windows now-gmt
- SYSTEMTIME <struct> [ GetSystemTime ] keep SYSTEMTIME>timestamp ;
+ SYSTEMTIME new [ GetSystemTime ] keep SYSTEMTIME>timestamp ;
: offset-of ( field struct -- offset )
struct-slots slot-named offset>> ; inline
+! XXX: make this faster
M: struct hashcode*
nip dup >c-ptr [ struct-slot-values hashcode ] [ drop 0 ] if ; inline
: <super> ( receiver -- super )
[ ] [ object_getClass class_getSuperclass ] bi
- objc-super <struct-boa> ;
+ objc-super boa ;
TUPLE: selector-tuple name object ;
{ location NSUInteger }
{ length NSUInteger } ;
+C: <NSRange> NSRange
+
TYPEDEF: NSRange _NSRange
! The "lL" type encodings refer to 32-bit values even in 64-bit mode
TYPEDEF: uint ulong32
TYPEDEF: void* unknown_type
-: <NSRange> ( location length -- size )
- NSRange <struct-boa> ;
-
STRUCT: NSFastEnumerationState
{ state ulong }
{ itemsPtr id* }
: fastcall-struct-return-ii-callback ( -- ptr )
test-struct-11 { int int } fastcall
- [ [ + ] [ - ] 2bi test-struct-11 <struct-boa> ] alien-callback ;
+ [ [ + ] [ - ] 2bi test-struct-11 boa ] alien-callback ;
: fastcall-struct-return-iii-callback ( -- ptr )
test-struct-11 { int int int } fastcall
- [ [ drop + ] [ - nip ] 3bi test-struct-11 <struct-boa> ] alien-callback ;
+ [ [ drop + ] [ - nip ] 3bi test-struct-11 boa ] alien-callback ;
{ 8 } [
3 4 fastcall-ii-callback [ fastcall-ii-indirect ] with-callback
: zlib-inflate-init ( -- z_stream_s )
- z_stream <struct>
+ z_stream new
dup ZLIB_VERSION over byte-length inflateInit_ zlib-error ;
! window can be 0, 15, 32, 47 (others?)
: zlib-inflate-init2 ( window -- z_stream_s )
- [ z_stream <struct> dup ] dip
+ [ z_stream new dup ] dip
ZLIB_VERSION pick byte-length inflateInit2_ zlib-error ;
: zlib-inflate-end ( z_stream -- )
inflate zlib-error ;
: zlib-inflate-get-header ( z_stream -- gz_header )
- gz_header <struct> [ inflateGetHeader zlib-error ] keep ;
+ gz_header new [ inflateGetHeader zlib-error ] keep ;
{ location CFIndex }
{ length CFIndex } ;
-: <CFRange> ( location length -- range )
- CFRange <struct-boa> ;
+C: <CFRange> CFRange
FUNCTION: CFTypeRef CFRetain ( CFTypeRef cf )
FUNCTION: CFStringRef FSEventStreamCopyDescription ( FSEventStreamRef streamRef )
: make-FSEventStreamContext ( info -- alien )
- FSEventStreamContext <struct>
+ FSEventStreamContext new
swap >>info ;
:: <FSEventStream> ( callback info paths latency flags -- event-stream )
kLSUnknownCreator
swap <CFString> &CFRelease
f
- FSRef <struct>
+ FSRef new
[ f LSFindApplicationForInfo cf-error ] keep
fsref>string
] with-destructors ;
{ x CGFloat }
{ y CGFloat } ;
-: <CGPoint> ( x y -- point )
- CGPoint <struct-boa> ;
+C: <CGPoint> CGPoint
STRUCT: CGSize
{ w CGFloat }
{ h CGFloat } ;
-: <CGSize> ( w h -- size )
- CGSize <struct-boa> ;
+C: <CGSize> CGSize
STRUCT: CGRect
{ origin CGPoint }
size>> h<< ; inline
: <CGRect> ( x y w h -- rect )
- [ CGPoint <struct-boa> ] [ CGSize <struct-boa> ] 2bi*
- CGRect <struct-boa> ;
+ [ CGPoint boa ] [ CGSize boa ] 2bi* CGRect boa ;
: CGRect-x-y ( alien -- origin-x origin-y )
[ CGRect-x ] [ CGRect-y ] bi ;
get-global IDirectInputDevice8W::SetDataFormat check-ole32-error ; inline
: <buffer-size-diprop> ( size -- DIPROPDWORD )
- DIPROPDWORD <struct> [
+ DIPROPDWORD new [
diph>>
DIPROPDWORD heap-size >>dwSize
DIPROPHEADER heap-size >>dwHeaderSize
MOUSE-BUFFER-SIZE DIDEVICEOBJECTDATA <c-array> +mouse-buffer+ set-global ;
: device-info ( device -- DIDEVICEIMAGEINFOW )
- DIDEVICEINSTANCEW <struct>
+ DIDEVICEINSTANCEW new
DIDEVICEINSTANCEW heap-size >>dwSize
[ IDirectInputDevice8W::GetDeviceInfo check-ole32-error ] keep ; inline
: device-caps ( device -- DIDEVCAPS )
- DIDEVCAPS <struct>
+ DIDEVCAPS new
DIDEVCAPS heap-size >>dwSize
[ IDirectInputDevice8W::GetCapabilities check-ole32-error ] keep ; inline
{ 0 0 } >>dim ;
: (device-notification-filter) ( -- DEV_BROADCAST_DEVICEW )
- DEV_BROADCAST_DEVICEW <struct>
+ DEV_BROADCAST_DEVICEW new
DEV_BROADCAST_DEVICEW heap-size >>dbcc_size
DBT_DEVTYP_DEVICEINTERFACE >>dbcc_devicetype ;
IDirectInputDevice8W::GetDeviceState check-ole32-error ;
: (read-controller) ( handle template -- state )
- swap [ DIJOYSTATE2 <struct> [ get-device-state ] keep ]
+ swap [ DIJOYSTATE2 new [ get-device-state ] keep ]
[ fill-controller-state ] [ drop f ] with-acquisition ;
M: dinput-game-input-backend read-controller
if ;
M: xinput-game-input-backend read-controller
- XINPUT_STATE <struct> [ XInputGetState drop ] keep
+ XINPUT_STATE new [ XInputGetState drop ] keep
fill-controller-state ;
M: xinput-game-input-backend calibrate-controller drop ;
M: xinput-game-input-backend vibrate-controller
- [ >vibration ] bi@ XINPUT_VIBRATION <struct-boa> XInputSetState drop ;
+ [ >vibration ] bi@ XINPUT_VIBRATION boa XInputSetState drop ;
M: xinput-game-input-backend read-keyboard
+keyboard-device+ get
<PRIVATE
-: <GpRect> ( x y w h -- rect )
- GpRect <struct-boa> ; inline
+C: <GpRect> GpRect
: stream>gdi+-bitmap ( stream -- bitmap )
stream>IStream &com-release
M: epoll-mx dispose* fd>> close-file ;
: make-event ( fd events -- event )
- epoll-event <struct>
+ epoll-event new
swap >>events
tuck data>> fd<< ;
M: kqueue-mx dispose* fd>> close-file ;
: make-kevent ( fd filter flags -- event )
- \ kevent <struct>
+ \ kevent new
swap >>flags
swap >>filter
swap >>ident ;
fd>> SEEK_CUR 0 lseek -1 = not ;
M: unix handle-length
- fd>> \ stat <struct> [ fstat -1 = not ] keep
+ fd>> \ stat new [ fstat -1 = not ] keep
swap [ st_size>> ] [ drop f ] if ;
ERROR: io-timeout ;
M: linux (directory-entries)
[
- dirent <struct>
+ dirent new
'[ _ _ next-dirent ] [ >directory-entry ] produce nip
] with-unix-directory ;
M: unix (directory-entries)
[
- dirent <struct>
+ dirent new
'[ _ _ next-dirent ] [ >directory-entry ] produce nip
] with-unix-directory ;
M: windows (directory-entries)
"\\" ?tail drop "\\*" append
- WIN32_FIND_DATA <struct>
+ WIN32_FIND_DATA new
find-first-file over
[ >windows-directory-entry ] 2dip
[
M: freebsd new-file-system-info freebsd-file-system-info new ;
M: freebsd file-system-statfs
- \ statfs <struct> [ statfs-func io-error ] keep ;
+ \ statfs new [ statfs-func io-error ] keep ;
M: freebsd file-system-statvfs
- \ statvfs <struct> [ statvfs-func io-error ] keep ;
+ \ statvfs new [ statvfs-func io-error ] keep ;
M: freebsd statfs>file-system-info
{
M: linux new-file-system-info linux-file-system-info new ;
M: linux file-system-statfs
- \ statfs64 <struct> [ statfs64 io-error ] keep ;
+ \ statfs64 new [ statfs64 io-error ] keep ;
M: linux statfs>file-system-info
{
} cleave ;
M: linux file-system-statvfs
- \ statvfs64 <struct> [ statvfs64 io-error ] keep ;
+ \ statvfs64 new [ statvfs64 io-error ] keep ;
M: linux statvfs>file-system-info
{
M: macosx new-file-system-info macosx-file-system-info new ;
M: macosx file-system-statfs
- \ statfs64 <struct> [ statfs64-func io-error ] keep ;
+ \ statfs64 new [ statfs64-func io-error ] keep ;
M: macosx file-system-statvfs
- \ statvfs <struct> [ statvfs-func io-error ] keep ;
+ \ statvfs new [ statvfs-func io-error ] keep ;
M: macosx statfs>file-system-info
{
unix-1970 time- duration>microseconds make-timeval ;
: timestamps>byte-array ( timestamps -- byte-array )
- [ [ timestamp>timeval ] [ \ timeval <struct> ] if* ] map
+ [ [ timestamp>timeval ] [ \ timeval new ] if* ] map
timeval >c-array ;
PRIVATE>
} cleave ;
: find-first-file-stat ( path -- WIN32_FIND_DATA )
- WIN32_FIND_DATA <struct> [
+ WIN32_FIND_DATA new [
FindFirstFile check-invalid-handle
FindClose win32-error=0/f
] keep ;
: get-file-information ( handle -- BY_HANDLE_FILE_INFORMATION )
[
- BY_HANDLE_FILE_INFORMATION <struct>
+ BY_HANDLE_FILE_INFORMATION new
[ GetFileInformationByHandle win32-error=0/f ] keep
] keep CloseHandle win32-error=0/f ;
}
: default-security-attributes ( -- obj )
- SECURITY_ATTRIBUTES <struct>
+ SECURITY_ATTRIBUTES new
SECURITY_ATTRIBUTES heap-size >>nLength ;
TUPLE: FileArgs
[ dup handle>> refill ] with-destructors drop ;
: make-fd-set ( socket -- fd_set )
- fd_set <struct> swap 1array void* >c-array >>fd_array 1 >>fd_count ;
+ fd_set new swap 1array void* >c-array >>fd_array 1 >>fd_count ;
: select-sets ( socket event -- read-fds write-fds except-fds )
[ make-fd-set ] dip +input+ = [ f f ] [ f swap f ] if ;
<PRIVATE
: windows-file-size ( path -- size )
- normalize-path 0 WIN32_FILE_ATTRIBUTE_DATA <struct>
+ normalize-path 0 WIN32_FILE_ATTRIBUTE_DATA new
[ GetFileAttributesEx win32-error=0/f ] keep
[ nFileSizeLow>> ] [ nFileSizeHigh>> ] bi >64bit ;
[ StreamSize>> ] bi 2array ;
: file-streams-rest ( streams handle -- streams )
- WIN32_FIND_STREAM_DATA <struct>
+ WIN32_FIND_STREAM_DATA new
[ FindNextStream ] 2keep
rot zero? [
GetLastError ERROR_HANDLE_EOF = [ win32-error ] unless
: file-streams ( path -- streams )
normalize-path
FindStreamInfoStandard
- WIN32_FIND_STREAM_DATA <struct>
+ WIN32_FIND_STREAM_DATA new
0
[ FindFirstStream ] keepd
over INVALID_HANDLE_VALUE = [
: default-CreateProcess-args ( -- obj )
CreateProcess-args new
- STARTUPINFO <struct>
+ STARTUPINFO new
dup class-of heap-size >>cb
>>lpStartupInfo
- PROCESS_INFORMATION <struct> >>lpProcessInformation
+ PROCESS_INFORMATION new >>lpProcessInformation
TRUE >>bInheritHandles
0 >>dwCreateFlags ;
M: ipv4 sockaddr-size drop sockaddr-in heap-size ;
-M: ipv4 empty-sockaddr drop sockaddr-in <struct> ;
+M: ipv4 empty-sockaddr drop sockaddr-in new ;
: make-sockaddr-part ( inet -- sockaddr )
- sockaddr-in <struct>
+ sockaddr-in new
AF_INET >>family
swap
port>> 0 or htons >>port ; inline
M: ipv6 sockaddr-size drop sockaddr-in6 heap-size ;
-M: ipv6 empty-sockaddr drop sockaddr-in6 <struct> ;
+M: ipv6 empty-sockaddr drop sockaddr-in6 new ;
: make-sockaddr-in6-part ( inet -- sockaddr )
- sockaddr-in6 <struct>
+ sockaddr-in6 new
AF_INET6 >>family
swap
port>> 0 or htons >>port ; inline
HOOK: addrinfo-error-string io-backend ( n -- string )
: prepare-addrinfo ( -- addrinfo )
- addrinfo <struct>
+ addrinfo new
PF_UNSPEC >>family
IPPROTO_TCP >>protocol ;
M: local sockaddr-size drop sockaddr-un heap-size ;
-M: local empty-sockaddr drop sockaddr-un <struct> ;
+M: local empty-sockaddr drop sockaddr-un new ;
M: local make-sockaddr
path>> absolute-path
dup length 1 + max-un-path > [ "Path too long" throw ] when
- sockaddr-un <struct>
+ sockaddr-un new
AF_UNIX >>family
swap utf8 string>alien >>path ;
: ctype-ioctl-inout ( handle id bytes type -- out )
[ call-ioctl-out ] dip deref ; inline
: struct-ioctl ( handle id struct-class -- out )
- <struct> call-ioctl-out ; inline
+ new call-ioctl-out ; inline
! EV IOC G/S - evdev ioctl get/set
! EVIOCGVERSION EVIOCGID EVIOCGREP EVIOCSREP
{ 8 } [ halves heap-size ] unit-test
{ 3.0 } [
- halves <struct>
+ halves new
3.0 >>dick
dick>>
] unit-test
dup uint-4 cast-array ;
: <sfmt-state> ( seed n m mask parity -- sfmt )
- sfmt-state <struct>
+ sfmt-state new
swap >>parity
swap >>mask
swap >>m
] unit-test
: make-point ( x y -- struct )
- test-struct <struct-boa> ;
+ test-struct boa ;
{ 5/4 } [
2 <test-struct-array>
IN: system-info.windows
: system-info ( -- SYSTEM_INFO )
- SYSTEM_INFO <struct> [ GetSystemInfo ] keep ;
+ SYSTEM_INFO new [ GetSystemInfo ] keep ;
: page-size ( -- n )
system-info dwPageSize>> ;
system-info dwOemId>> 0xffff0000 bitand ;
: os-version-struct ( -- os-version )
- OSVERSIONINFO <struct>
+ OSVERSIONINFO new
OSVERSIONINFO heap-size >>dwOSVersionInfoSize
dup GetVersionEx win32-error=0/f ;
get-processor-power-information first MaxMhz>> 1,000,000 * ;
: memory-status ( -- MEMORYSTATUSEX )
- MEMORYSTATUSEX <struct>
+ MEMORYSTATUSEX new
MEMORYSTATUSEX heap-size >>dwLength
dup GlobalMemoryStatusEx win32-error=0/f ;
[ {
[ Width>> ] [ Height>> ] [ Colors>> ] [ Reserved>> ]
[ Planes>> ] [ BitsPerPixel>> ] [ ImageSize>> ]
- } cleave ] [ 1 + ] bi* group-directory-entry <struct-boa> >c-ptr ; inline
+ } cleave ] [ 1 + ] bi* group-directory-entry boa >c-ptr ; inline
: ico-icon ( directory-entry bytes -- subbytes )
[ [ ImageOffset>> dup ] [ ImageSize>> + ] bi ] dip subseq ; inline
0 CreateToolhelp32Snapshot dup win32-error=0/f ;
: default-process-entry ( -- obj )
- PROCESSENTRY32 <struct> PROCESSENTRY32 heap-size >>dwSize ;
+ PROCESSENTRY32 new PROCESSENTRY32 heap-size >>dwSize ;
: first-process ( handle -- PROCESSENTRY32 )
default-process-entry
: query-information-process ( HANDLE -- PROCESS_BASIC_INFORMATION )
0
- PROCESS_BASIC_INFORMATION <struct> [
+ PROCESS_BASIC_INFORMATION new [
dup byte-length
f
NtQueryInformationProcess drop
: gadget-cursor-location ( gadget -- rectangle )
[ screen-loc ] [ cursor-loc&dim ] bi [ v+ ] dip
[ first2 [ >fixnum ] bi@ ] bi@
- cairo_rectangle_int_t <struct-boa> ;
+ cairo_rectangle_int_t boa ;
: update-cursor-location ( im-context gadget -- )
gadget-cursor-location gtk_im_context_set_cursor_location ;
[ value>> ] [ 0 ] if* ;
: >pfd ( attributes -- pfd )
- [ PIXELFORMATDESCRIPTOR <struct> ] dip
+ [ PIXELFORMATDESCRIPTOR new ] dip
{
[ drop PIXELFORMATDESCRIPTOR c:heap-size >>nSize ]
[ drop 1 >>nVersion ]
] if ;
: make-TRACKMOUSEEVENT ( hWnd -- alien )
- TRACKMOUSEEVENT <struct>
+ TRACKMOUSEEVENT new
swap >>hwndTrack
TRACKMOUSEEVENT c:heap-size >>cbSize ;
] if ;
:: register-window-class ( class-name-ptr -- )
- WNDCLASSEX <struct> f GetModuleHandle
+ WNDCLASSEX new f GetModuleHandle
class-name-ptr pick GetClassInfoEx 0 = [
WNDCLASSEX c:heap-size >>cbSize
flags{ CS_HREDRAW CS_VREDRAW CS_OWNDC } >>style
: set-pixel-format ( pixel-format hdc -- )
swap handle>>
- PIXELFORMATDESCRIPTOR <struct> SetPixelFormat win32-error=0/f ;
+ PIXELFORMATDESCRIPTOR new SetPixelFormat win32-error=0/f ;
: setup-gl ( world -- )
[ get-dc ] keep
: fullscreen-RECT ( hwnd -- RECT )
MONITOR_DEFAULTTONEAREST MonitorFromWindow
- MONITORINFOEX <struct>
+ MONITORINFOEX new
MONITORINFOEX c:heap-size >>cbSize
[ GetMonitorInfo win32-error=0/f ] keep rcMonitor>> ;
: client-area>RECT ( hwnd -- RECT )
- RECT <struct>
+ RECT new
[ GetClientRect win32-error=0/f ]
[ >c-ptr POINT cast-array [ ClientToScreen drop ] with each ]
[ nip ] 2tri ;
: hwnd>RECT ( hwnd -- RECT )
- RECT <struct> [ GetWindowRect win32-error=0/f ] keep ;
+ RECT new [ GetWindowRect win32-error=0/f ] keep ;
M: windows-ui-backend (grab-input)
0 ShowCursor drop
: add-tray-icon ( title -- )
NIM_ADD
- NOTIFYICONDATA <struct>
+ NOTIFYICONDATA new
NOTIFYICONDATA heap-size >>cbSize
NOTIFYICON_VERSION_4 over timeout-version>> uVersion<<
NIF_TIP NIF_ICON bitor >>uFlags
: remove-tray-icon ( -- )
NIM_DELETE
- NOTIFYICONDATA <struct>
+ NOTIFYICONDATA new
NOTIFYICONDATA heap-size >>cbSize
world get handle>> hWnd>> >>hWnd
Shell_NotifyIcon win32-error=0/f ;
[ dpy get ] 2dip [ set-title-old ] [ set-title-new ] 3bi ;
: make-fullscreen-msg ( window ? -- msg )
- XClientMessageEvent <struct>
+ XClientMessageEvent new
ClientMessage >>type
dpy get >>display
XA_NET_WM_STATE >>message_type
tri ;
: make-raise-window-msg ( window -- msg )
- XClientMessageEvent <struct>
+ XClientMessageEvent new
ClientMessage >>type
1 >>send_event
dpy get >>display
M: x11-ui-backend system-alert
"\n\n" glue xmessage ;
-: black ( -- xcolor ) 0 0 0 0 0 0 XColor <struct-boa> ; inline
+: black ( -- xcolor ) 0 0 0 0 0 0 XColor boa ; inline
M:: x11-ui-backend (grab-input) ( handle -- )
handle window>> :> wnd
<rect> ;
: layout-extents ( layout -- ink-rect logical-rect )
- PangoRectangle <struct>
- PangoRectangle <struct>
+ PangoRectangle new
+ PangoRectangle new
[ pango_layout_get_extents ] 2keep
[ PangoRectangle>rect ] bi@ ;
gr_mem>> utf8 alien>strings ;
: (group-struct) ( id -- group-struct id group-struct byte-array length void* )
- [ unix.ffi:group <struct> ] dip over 4096
+ [ unix.ffi:group new ] dip over 4096
[ <byte-array> ] keep f void* <ref> ;
: check-group-struct ( group-struct ptr -- group-struct/f )
dup 0 = [ drop ] [ (throw-errno) ] if ;
: posix-spawn-file-actions-init ( -- posix_spawn_file_actions_t )
- posix_spawn_file_actions_t <struct>
+ posix_spawn_file_actions_t new
[ posix_spawn_file_actions_init check-posix ] keep ;
: posix-spawn-file-actions-destroy ( posix_spawn_file_actions_t -- )
<< "unix.stat." os name>> append require >>
: file-status ( pathname -- stat )
- \ stat <struct> [ [ stat-func ] unix-system-call drop ] keep ;
+ \ stat new [ [ stat-func ] unix-system-call drop ] keep ;
: link-status ( pathname -- stat )
- \ stat <struct> [ [ lstat ] unix-system-call drop ] keep ;
+ \ stat new [ [ lstat ] unix-system-call drop ] keep ;
{ nsec long } ;
: <timeval> ( sec usec -- timeval )
- timeval <struct>
+ timeval new
swap >>usec
swap >>sec ; inline
: make-timeval ( us -- timeval )
- [ timeval <struct> ] dip [
+ [ timeval new ] dip [
1000000 /mod [ >>sec ] [ >>usec ] bi*
] unless-zero ;
: make-timespec ( nanos -- timespec )
- [ timespec <struct> ] dip [
+ [ timespec new ] dip [
1000000000 /mod [ >>sec ] [ >>nsec ] bi*
] unless-zero ;
: touch ( filename -- ) f [ utime ] unix-system-call drop ;
: change-file-times ( filename access modification -- )
- utimbuf <struct>
+ utimbuf new
swap >>modtime
swap >>actime
[ utime ] unix-system-call drop ;
[ fourth (flags) ]
[ 4 swap nth (flag) ]
} cleave
- DIOBJECTDATAFORMAT <struct-boa> ;
+ DIOBJECTDATAFORMAT boa ;
: make-DIOBJECTDATAFORMAT-arrays ( struct array -- values vars )
[ [ <DIOBJECTDATAFORMAT> ] [ first ] bi ] with
MACRO: <DIDATAFORMAT> ( dwFlags dwDataSize struct rgodf-array -- alien )
[ DIDATAFORMAT heap-size DIOBJECTDATAFORMAT heap-size ] 4dip
[ nip length ] [ make-DIOBJECTDATAFORMAT-array-quot ] 2bi
- '[ _ _ _ _ _ @ DIDATAFORMAT <struct-boa> ] ;
+ '[ _ _ _ _ _ @ DIDATAFORMAT boa ] ;
: (malloc-guid-symbol) ( symbol guid -- )
'[ _ malloc-byte-array ] initialize ;
IN: windows.dragdrop-listener
: handle-data-object ( handler: ( hdrop -- x ) data-object -- filenames )
- FORMATETC <struct>
+ FORMATETC new
CF_HDROP >>cfFormat
f >>ptd
DVASPECT_CONTENT >>dwAspect
-1 >>lindex
TYMED_HGLOBAL >>tymed
- STGMEDIUM <struct>
+ STGMEDIUM new
[ IDataObject::GetData ] keep swap succeeded? [
dup data>>
[ rot execute( hdrop -- x ) ] with-global-lock
] with map ;
! : point-from-hdrop ( hdrop -- loc )
-! POINT <struct> [ DragQueryPoint drop ] keep [ x>> ] [ y>> ] bi 2array ;
+! POINT new [ DragQueryPoint drop ] keep [ x>> ] [ y>> ] bi 2array ;
: handle-wm-dropfiles ( hdrop -- )
<alien> [ filenames-from-hdrop dropped-files set-global ] [ DragFinish ] bi
{ cyTopHeight int }
{ cyBottomHeight int } ;
+C: <MARGINS> MARGINS
+
STRUCT: DWM_BLURBEHIND
{ dwFlags DWORD }
{ fEnable BOOL }
{ hRgnBlur HANDLE }
{ fTransitionOnMaximized BOOL } ;
-: <MARGINS> ( l r t b -- MARGINS )
- MARGINS <struct-boa> ; inline
-
: full-window-margins ( -- MARGINS )
-1 -1 -1 -1 <MARGINS> ; inline
BOOL { HMONITOR HDC LPRECT LPARAM } stdcall [
4dup 4array .
3drop
- MONITORINFOEX <struct> dup byte-length >>cbSize
+ MONITORINFOEX new dup byte-length >>cbSize
[ GetMonitorInfo win32-error=0/f ] keep ... flush
TRUE
] alien-callback ;
FUNCTION: DWORD GetNetworkParams ( PFIXED_INFO pFixedInfo, PULONG pOutBufLen )
: get-fixed-info ( -- FIXED_INFO )
- FIXED_INFO <struct> dup byte-length ulong <ref>
+ FIXED_INFO new dup byte-length ulong <ref>
[ GetNetworkParams n>win32-error-check ] keepd ;
: dns-server-ips ( -- sequence )
: (bitmap-info) ( dim -- BITMAPINFO )
[
- BITMAPINFO <struct>
+ BITMAPINFO new
dup bmiHeader>>
BITMAPINFOHEADER heap-size >>biSize
] dip
$[ "{01234567-89ab-cdef-0123-456789abcdef}" length ]
: create-guid ( -- GUID )
- GUID <struct> dup CoCreateGuid check-ole32-error ;
+ GUID new dup CoCreateGuid check-ole32-error ;
: string>guid ( string -- guid )
"{-}" split harvest
[ first3 [ hex> ] tri@ ]
[ 3 tail concat 2 group [ hex> ] B{ } map-as ] bi
- GUID <struct-boa> ;
+ GUID boa ;
: guid>string ( guid -- string )
[
dup 0 = [ drop ] [ win32-powrprof-error ] if ;
: get-power-capabilities ( -- struct )
- SYSTEM_POWER_CAPABILITIES <struct>
+ SYSTEM_POWER_CAPABILITIES new
[ GetPwrCapabilities win32-error=0/f ] keep ;
: get-processor-power-information ( -- structs )
[ CloseHandle drop ] finally ; inline
: lookup-privilege ( string -- luid )
- [ f ] dip LUID <struct>
+ [ f ] dip LUID new
[ LookupPrivilegeValue win32-error=0/f ] keep ;
:: make-token-privileges ( name enabled? -- obj )
- TOKEN_PRIVILEGES <struct>
+ TOKEN_PRIVILEGES new
1 >>PrivilegeCount
LUID_AND_ATTRIBUTES malloc-struct &free
enabled? [ SE_PRIVILEGE_ENABLED >>Attributes ] when
0 DWORD <ref> dup :> max-value
0 DWORD <ref> dup :> max-value-data
0 DWORD <ref> dup :> security-descriptor
- FILETIME <struct> dup :> last-write-time
+ FILETIME new dup :> last-write-time
RegQueryInfoKey :> ret
ret ERROR_SUCCESS = [
key
: shell32-file-info ( path -- err struct )
normalize-path
0
- SHFILEINFO <struct>
+ SHFILEINFO new
[ dup byte-length SHGFI_EXETYPE SHGetFileInfoW ] keep ;
SINGLETONS:
f >>pwcsName
STGTY_STREAM >>type
stream stream-size >>cbSize
- FILETIME <struct> >>mtime
- FILETIME <struct> >>ctime
- FILETIME <struct> >>atime
+ FILETIME new >>mtime
+ FILETIME new >>ctime
+ FILETIME new >>atime
STGM_READWRITE >>grfMode
0 >>grfLocksSupported
GUID_NULL >>clsid
[ windows-1601 ] dip 10,000,000 /i +second ;
: windows-time ( -- n )
- FILETIME <struct> [ GetSystemTimeAsFileTime ] keep
+ FILETIME new [ GetSystemTimeAsFileTime ] keep
FILETIME>windows-time ;
: timestamp>windows-time ( timestamp -- n )
>gmt windows-1601 (time-) 10,000,000 * >integer ;
: windows-time>FILETIME ( n -- FILETIME )
- [ FILETIME <struct> ] dip
+ [ FILETIME new ] dip
[ 32 bits >>dwLowDateTime ] [ -32 shift >>dwHighDateTime ] bi ;
: timestamp>FILETIME ( timestamp -- FILETIME/f )
{ dwDamageMask DWORD } ;
: <RECT> ( loc dim -- RECT )
- dupd v+ [ first2 ] bi@ RECT <struct-boa> ;
+ dupd v+ [ first2 ] bi@ RECT boa ;
TYPEDEF: RECT* PRECT
TYPEDEF: RECT* LPRECT
[ cx>> ] [ cy>> ] bi 2array ;
: dc-metrics ( dc -- metrics )
- TEXTMETRICW <struct>
+ TEXTMETRICW new
[ GetTextMetrics drop ] keep
TEXTMETRIC>metrics ;
1 XChangeProperty drop ;
: send-notify ( evt prop -- )
- XSelectionEvent <struct>
+ XSelectionEvent new
SelectionNotify >>type
swap >>property
over display>> >>display
GENERIC: client-event ( event window -- )
: next-event ( -- event )
- dpy get XEvent <struct> [ XNextEvent drop ] keep ;
+ dpy get XEvent new [ XNextEvent drop ] keep ;
: mask-event ( mask -- event )
- [ dpy get ] dip XEvent <struct> [ XMaskEvent drop ] keep ;
+ [ dpy get ] dip XEvent new [ XMaskEvent drop ] keep ;
: events-queued ( mode -- n ) [ dpy get ] dip XEventsQueued ;
}
: window-attributes ( visinfo -- attributes )
- XSetWindowAttributes <struct>
+ XSetWindowAttributes new
0 >>background_pixel
0 >>border_pixel
event-mask >>event_mask
swap create-colormap >>colormap ;
: set-size-hints ( window -- )
- XSizeHints <struct>
+ XSizeHints new
USPosition >>flags
[ dpy get ] 2dip XSetWMNormalHints ;
SPECIALIZED-ARRAY: body
: <body> ( location velocity mass -- body )
- [ days-per-year v*n ] [ solar-mass * ] bi* body <struct-boa> ; inline
+ [ days-per-year v*n ] [ solar-mass * ] bi* body boa ; inline
: <jupiter> ( -- body )
double-4{ 4.84143144246472090e00 -1.16032004402742839e00 -1.03622044471123109e-01 0.0 }
[ x>> max ] [ y>> max ] [ z>> max ] change-xyz ; inline
: <zero-point> ( -- point )
- 0 0 0 point <struct-boa> ; inline
+ 0 0 0 point boa ; inline
: max-points ( points -- point )
<zero-point> [ max-point ] reduce ; inline
:: fake-data ( -- rgb yuv )
1600 :> w
1200 :> h
- yuv-buffer <struct> :> buffer
+ yuv-buffer new :> buffer
w h * 3 * <byte-array> :> rgb
rgb buffer
w >>y_width
! cpVect.h
TYPED: cpv ( x y -- v: cpVect )
- cpVect <struct-boa> ; inline
+ cpVect boa ; inline
TYPED: cpvzero ( -- v: cpVect )
0.0 0.0 cpv ; inline
{ t cpFloat } ;
TYPED: cpBBNew ( l b r t -- cpbb: cpBB )
- cpBB <struct-boa> ; inline
+ cpBB boa ; inline
TYPED: cpBBintersects ( a: cpBB b: cpBB -- ? )
{
MACRO: (vectored-element>) ( struct-class -- quot: ( elt -- struct ) )
[ struct-slots [ name>> reader-word 1quotation ] map ] keep
- '[ _ cleave _ <struct-boa> ] ;
+ '[ _ cleave _ boa ] ;
SLOT: (n)
SLOT: (vectored)
[ enumerate-cuda-devices ] dip '[ 0 _ with-cuda-context ] each ; inline
: cuda-device-properties ( n -- properties )
- [ CUdevprop <struct> ] dip
+ [ CUdevprop new ] dip
[ cuDeviceGetProperties cuda-error ] keepd ;
: cuda-devices ( -- assoc )
M: windows open-file-dialog
[
- BROWSEINFO <struct>
+ BROWSEINFO new
GetDesktopWindow >>hwndOwner
"Select a file or folder" utf8 malloc-string &free >>lpszTitle
BIF_BROWSEINCLUDEFILES >>ulFlags
particle [ p>> ] [ v>> ] bi dt v*n v+
gravity dt dt * particle m>> 2 * / v*n v+ :> p'
p' particle p>> v- dt v/n :> v'
- p' v' particle m>> particle_t <struct-boa> ; inline
+ p' v' particle m>> particle_t boa ; inline
CONSTANT: initial-particles
particle_t-array{
{ T{ button-down } [ [
hand-loc get float >c-array
world get dim>> float >c-array v/ 2 v*n 1 v-n { 1 -1 } v*
- float-array{ 0 0.2 } 2.0 particle_t <struct-boa> suffix
+ float-array{ 0 0.2 } 2.0 particle_t boa suffix
] change-particles drop ] }
} set-gestures
SPECIALIZED-VECTOR: game-loop-benchmark
: <game-loop-benchmark> ( benchmark-data-pair tick frame -- obj )
- \ game-loop-benchmark <struct>
+ \ game-loop-benchmark new
swap >>frame#
swap >>tick#
swap >>benchmark-data-pair ; inline
: object>datum ( obj -- datum )
object>bytes [ malloc-byte-array &free ] [ length ] bi
- datum <struct-boa> ;
+ datum boa ;
: datum>object* ( datum -- obj ? )
[ dptr>> ] [ dsize>> ] bi over
[ string>number ] map ; inline
: <bunny-vertex> ( vertex -- struct )
- bunny-vertex-struct <struct>
+ bunny-vertex-struct new
swap first3 0.0 float-4-boa >>vertex ; inline
: (read-line-tokens) ( seq stream -- seq )
{
{ ID_TYPE_UID [ user-name "user:" prepend ] }
{ ID_TYPE_GID [ group-name "group:" prepend ] }
- ! [ uuid_string_t <struct> [ mbr_uuid_to_string io-error ] keep ]
+ ! [ uuid_string_t new [ mbr_uuid_to_string io-error ] keep ]
} case ;
: acl-error ( n -- ) -1 = [ throw-errno ] when ; inline
: <fs-ref> ( path -- fs-ref )
utf8 string>alien
kFSPathMakeRefDoNotFollowLeafSymlink
- FSRef <struct>
+ FSRef new
[ f FSPathMakeRefWithOptions check-err ] keep ;
PRIVATE>
absolute-path native-string>alien B{ 0 0 } append
malloc-byte-array &free
- SHFILEOPSTRUCTW <struct>
+ SHFILEOPSTRUCTW new
f >>hwnd
FO_DELETE >>wFunc
swap >>pFrom
stream>> in>> handle>> fd>> ;
: get-fd-termios ( fd -- serial )
- termios <struct> [ tcgetattr io-error ] keep ;
+ termios new [ tcgetattr io-error ] keep ;
: set-termios ( serial -- )
[ serial-fd get-fd-termios ] keep termios<< ;
: get-comm-state ( duplex -- dcb )
in>> handle>>
- DCB <struct> [ GetCommState win32-error=0/f ] keep ;
+ DCB new [ GetCommState win32-error=0/f ] keep ;
: set-comm-state ( duplex dcb -- )
[ in>> handle>> ] dip
: sections-array ( segment-commands -- sections-array )
[
dup first segment_command_64?
- [ section_64 ] [ section ] if <struct> ,
+ [ section_64 ] [ section ] if new ,
segment-commands [ segment-sections [ , ] each ] each
] { } make ;
STRUCT: xoshiro-256-star-star { s0 ulonglong } { s1 ulonglong } { s2 ulonglong } { s3 ulonglong } ;
: <xoshiro-256-star-star> ( s0 s1 s2 s3 -- obj )
- xoshiro-256-star-star <struct>
+ xoshiro-256-star-star new
swap >>s3
swap >>s2
swap >>s1
: setup-game-vars ( -- )
get-screen-width 2 /
get-screen-height 2 /
- Vector2 <struct-boa> player set ;
+ Vector2 boa player set ;
! Make this cleaner
: change-player-position ( -- )
60 set-target-fps ;
: button-rec ( -- button )
- 50 50 100 100 Rectangle <struct-boa> ;
+ 50 50 100 100 Rectangle boa ;
: white-background ( -- )
RAYWHITE clear-background ;
screen-width screen-height "raylib [models] example - mesh-picking" init-window ;
: make-camera ( -- camera )
- Camera3D <struct>
+ Camera3D new
20 30 20 <Vector3> >>position
0 10 0 <Vector3> >>target
0 1.6 0 <Vector3> >>up
TUPLE: hit-state name color nearest-hit ;
: <hit-state> ( -- obj )
"None" WHITE
- RayCollision <struct>
+ RayCollision new
most-positive-finite-float >>distance
f >>hit
hit-state boa ;
! LOG_ALL set-trace-log-level
[
make-camera :> camera
- Ray <struct> :> ray
+ Ray new :> ray
init-assets :> ( tower triangle )
f :> bary!
PRIVATE>
M: unix (terminal-size)
- stdout-handle fileno TIOCGWINSZ winsize <struct>
+ stdout-handle fileno TIOCGWINSZ winsize new
[ ioctl ] keep swap 0 < [
drop 0 0
] [
PRIVATE>
M: macosx (terminal-size)
- stdout-handle fileno TIOCGWINSZ winsize <struct>
+ stdout-handle fileno TIOCGWINSZ winsize new
[ ioctl ] keep swap 0 < [
drop 0 0
] [
M: windows (terminal-size)
STD_OUTPUT_HANDLE GetStdHandle
- CONSOLE_SCREEN_BUFFER_INFO <struct>
+ CONSOLE_SCREEN_BUFFER_INFO new
[ GetConsoleScreenBufferInfo ] keep swap zero? [
drop 0 0
] [
M: macosx adjust-time-monotonic
timestamp>timeval
- \ timeval <struct>
+ \ timeval new
[ adjtime io-error ] keep dup binary-zero? [
drop instant
] [
IN: time.unix
: timestamp>timezone ( timestamp -- timezone )
- gmt-offset>> duration>minutes 1 \ timezone <struct-boa> ; inline
+ gmt-offset>> duration>minutes 1 \ timezone boa ; inline
M: unix set-system-time
[ unix-1970 time- duration>microseconds >integer make-timeval ]
{ stop benchmark-data } ;
: <benchmark-data> ( -- benchmark-data )
- \ benchmark-data <struct>
+ \ benchmark-data new
nano-count >>time
data-room >>data-room
code-room >>code-room
callback-room >>callback-room ; inline
: <benchmark-data-pair> ( start stop -- benchmark-data-pair )
- \ benchmark-data-pair <struct>
+ \ benchmark-data-pair new
swap >>stop
swap >>start ; inline
GetDesktopWindow hwnd>hmonitor ;
:: (monitor-info>devmodes) ( monitor-info n -- )
- DEVMODE <struct>
+ DEVMODE new
DEVMODE heap-size >>dmSize
flags{ DM_BITSPERPEL DM_PELSWIDTH DM_PELSHEIGHT } >>dmFields
:> devmode
[ 0 (monitor-info>devmodes) ] { } make ;
: hmonitor>monitor-info ( HMONITOR -- monitor-info )
- MONITORINFOEX <struct>
+ MONITORINFOEX new
MONITORINFOEX heap-size >>cbSize
[ GetMonitorInfo win32-error=0/f ] keep ;
desktop-hmonitor hmonitor>monitor-info ;
: desktop-RECT ( -- RECT )
- GetDesktopWindow RECT <struct> [ GetWindowRect win32-error=0/f ] keep ;
+ GetDesktopWindow RECT new [ GetWindowRect win32-error=0/f ] keep ;
ERROR: display-change-error n ;
projects / factor.git / commitdiff