1/2 seconds sleep\r
stop-alarm\r
] unit-test\r
+\r
+[ { 1 } ] [\r
+ { 0 }\r
+ dup '[ 0 _ [ 1 + ] change-nth ] 3 seconds later\r
+ [ stop-alarm ] [ start-alarm ] bi\r
+ 4 seconds sleep\r
+] unit-test\r
+\r
+[ { 0 } ] [\r
+ { 0 }\r
+ dup '[ 3 seconds sleep 1 _ set-first ] 1 seconds later\r
+ 2 seconds sleep stop-alarm\r
+ 1/2 seconds sleep\r
+] unit-test\r
{ quot callable initial: [ ] }
start-nanos
delay-nanos
- interval-nanos integer
- { next-iteration-nanos integer }
- { stop? boolean } ;
+ interval-nanos
+ iteration-start-nanos
+ quotation-running?
+ thread ;
<PRIVATE
M: duration >nanoseconds duration>nanoseconds >integer ;
: set-next-alarm-time ( alarm -- alarm )
- ! start + delay + ceiling((now - start) / interval) * interval
+ ! start + delay + ceiling((now - (start + delay)) / interval) * interval
nano-count
over start-nanos>> -
- over delay-nanos>> [ + ] when*
+ over delay-nanos>> [ - ] when*
over interval-nanos>> / ceiling
over interval-nanos>> *
- over start-nanos>> + >>next-iteration-nanos ; inline
+ over start-nanos>> +
+ over delay-nanos>> [ + ] when*
+ >>iteration-start-nanos ;
+
+: stop-alarm? ( alarm -- ? )
+ thread>> self eq? not ;
DEFER: call-alarm-loop
: loop-alarm ( alarm -- )
nano-count over
- [ next-iteration-nanos>> - ] [ interval-nanos>> ] bi <
+ [ iteration-start-nanos>> - ] [ interval-nanos>> ] bi <
[ set-next-alarm-time ] dip
- [ dup next-iteration-nanos>> ] [ 0 ] if
- sleep-until call-alarm-loop ;
+ [ dup iteration-start-nanos>> ] [ 0 ] if
+ 0 or sleep-until call-alarm-loop ;
: maybe-loop-alarm ( alarm -- )
- dup { [ stop?>> ] [ interval-nanos>> not ] } 1||
+ dup { [ stop-alarm? ] [ interval-nanos>> not ] } 1||
[ drop ] [ loop-alarm ] if ;
: call-alarm-loop ( alarm -- )
- dup stop?>> [
+ dup stop-alarm? [
drop
] [
- [ quot>> call( -- ) ] keep
+ [
+ [ t >>quotation-running? drop ]
+ [ quot>> call( -- ) ]
+ [ f >>quotation-running? drop ] tri
+ ] keep
maybe-loop-alarm
] if ;
-: call-alarm ( alarm -- )
- [ delay-nanos>> ] [ ] bi
- '[ _ [ sleep ] when* _ call-alarm-loop ] "Alarm execution" spawn drop ;
-
PRIVATE>
: <alarm> ( quot delay-duration/f interval-duration/f -- alarm )
swap >>quot ; inline
: start-alarm ( alarm -- )
- f >>stop?
- nano-count >>start-nanos
- call-alarm ;
+ [
+ '[
+ _ nano-count >>start-nanos
+ [ delay-nanos>> [ sleep ] when* ]
+ [ nano-count >>iteration-start-nanos call-alarm-loop ] bi
+ ] "Alarm execution" spawn
+ ] keep thread<< ;
: stop-alarm ( alarm -- )
- t >>stop?
- f >>start-nanos
- drop ;
+ dup quotation-running?>> [
+ f >>thread drop
+ ] [
+ [ [ interrupt ] when* f ] change-thread drop
+ ] if ;
<PRIVATE
-! copyright (C) 2008 Slava Pestov
+! Copyright (C) 2008, 2010 Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
USING: accessors byte-arrays alien.c-types alien.data kernel
continuations destructors sequences io openssl openssl.libcrypto
: digest-value ( ctx -- value )
handle>>
- EVP_MAX_MD_SIZE <byte-array> 0 <int>
- [ EVP_DigestFinal_ex ssl-error ] 2keep
- *int memory>byte-array ;
+ { { int EVP_MAX_MD_SIZE } int }
+ [ EVP_DigestFinal_ex ssl-error ]
+ [ memory>byte-array ]
+ with-out-parameters ;
PRIVATE>
! Copyright (C) 2006, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors alien alien.c-types alien.strings arrays assocs
-classes.struct continuations combinators compiler
+USING: accessors alien alien.c-types alien.data alien.strings
+arrays assocs classes.struct continuations combinators compiler
core-graphics.types stack-checker kernel math namespaces make
quotations sequences strings words cocoa.runtime cocoa.types io
-macros memoize io.encodings.utf8 effects layouts libc
-lexer init core-foundation fry generalizations specialized-arrays ;
+macros memoize io.encodings.utf8 effects layouts libc lexer init
+core-foundation fry generalizations specialized-arrays ;
QUALIFIED-WITH: alien.c-types c
IN: cocoa.messages
objc-methods get set-at ;
: each-method-in-class ( class quot -- )
- [ 0 <uint> [ class_copyMethodList ] keep *uint ] dip
+ [ { uint } [ class_copyMethodList ] [ ] with-out-parameters ] dip
over 0 = [ 3drop ] [
[ <direct-void*-array> ] dip
[ each ] [ drop (free) ] 2bi
-! Copyright (C) 2008 Slava Pestov.
+! Copyright (C) 2008, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: cocoa.application cocoa.messages cocoa.classes
-cocoa.runtime kernel cocoa alien.c-types core-foundation
-core-foundation.arrays ;
+USING: alien.c-types alien.data cocoa.application cocoa.messages
+cocoa.classes cocoa.runtime cocoa core-foundation
+core-foundation.arrays kernel ;
IN: cocoa.nibs
: load-nib ( name -- )
dup [ -> autorelease ] when ;
: nib-objects ( anNSNib -- objects/f )
- f f <void*> [ -> instantiateNibWithOwner:topLevelObjects: ] keep
- swap [ *void* CF>array ] [ drop f ] if ;
\ No newline at end of file
+ f
+ { void* } [ -> instantiateNibWithOwner:topLevelObjects: ] [ ]
+ with-out-parameters
+ swap [ CF>array ] [ drop f ] if ;
\ No newline at end of file
NSFastEnumeration-map >hashtable ;
: (read-plist) ( NSData -- id )
- NSPropertyListSerialization swap kCFPropertyListImmutable f f <void*>
- [ -> propertyListFromData:mutabilityOption:format:errorDescription: ] keep
- *void* [ -> release "read-plist failed" throw ] when* ;
+ NSPropertyListSerialization swap kCFPropertyListImmutable f
+ { void* }
+ [ -> propertyListFromData:mutabilityOption:format:errorDescription: ] [ ]
+ with-out-parameters
+ [ -> release "read-plist failed" throw ] when* ;
MACRO: objc-class-case ( alist -- quot )
[
TYPEDEF: void* CFAllocatorRef
CONSTANT: kCFAllocatorDefault f
-TYPEDEF: bool Boolean
-TYPEDEF: long CFIndex
-TYPEDEF: uchar UInt8
-TYPEDEF: ushort UInt16
-TYPEDEF: uint UInt32
+TYPEDEF: bool Boolean
+TYPEDEF: long CFIndex
+TYPEDEF: uchar UInt8
+TYPEDEF: ushort UInt16
+TYPEDEF: uint UInt32
TYPEDEF: ulonglong UInt64
-TYPEDEF: char SInt8
-TYPEDEF: short SInt16
-TYPEDEF: int SInt32
-TYPEDEF: longlong SInt64
+TYPEDEF: char SInt8
+TYPEDEF: short SInt16
+TYPEDEF: int SInt32
+TYPEDEF: longlong SInt64
TYPEDEF: ulong CFTypeID
TYPEDEF: UInt32 CFOptionFlags
TYPEDEF: void* CFUUIDRef
-ALIAS: <CFIndex> <long>
-ALIAS: *CFIndex *long
-
STRUCT: CFRange
{ location CFIndex }
{ length CFIndex } ;
flags
FSEventStreamCreate ;
-: kCFRunLoopCommonModes ( -- string )
- &: kCFRunLoopCommonModes *void* ;
+C-GLOBAL: void* kCFRunLoopCommonModes
: schedule-event-stream ( event-stream -- )
CFRunLoopGetMain
-! Copyright (C) 2008, 2009 Slava Pestov.
+! Copyright (C) 2008, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: alien.c-types alien.syntax alien.strings io.encodings.string
-kernel sequences byte-arrays io.encodings.utf8 math core-foundation
-core-foundation.arrays destructors parser fry alien words ;
+USING: alien.c-types alien.data alien.syntax alien.strings
+io.encodings.string kernel sequences byte-arrays
+io.encodings.utf8 math core-foundation core-foundation.arrays
+destructors parser fry alien words ;
IN: core-foundation.strings
TYPEDEF: void* CFStringRef
: CF>string ( alien -- string )
dup CFStringGetLength
[ 0 swap <CFRange> kCFStringEncodingUTF8 0 f ] keep
- 4 * 1 + <byte-array> [ dup length 0 <CFIndex> [ CFStringGetBytes drop ] keep ] keep
- swap *CFIndex head-slice utf8 decode ;
+ 4 * 1 + <byte-array> [
+ dup length
+ { CFIndex } [ CFStringGetBytes drop ] [ ]
+ with-out-parameters
+ ] keep
+ swap head-slice utf8 decode ;
: CF>string-array ( alien -- seq )
CF>array [ CF>string ] map ;
SYMBOL: CGFloat
<< cell 4 = float double ? \ CGFloat typedef >>
-: <CGFloat> ( x -- alien )
- cell 4 = [ <float> ] [ <double> ] if ; inline
-
-: *CGFloat ( alien -- x )
- cell 4 = [ *float ] [ *double ] if ; inline
-
STRUCT: CGPoint
{ x CGFloat }
{ y CGFloat } ;
STRUCT: CGRect
{ origin CGPoint }
- { size CGSize } ;
+ { size CGSize } ;
: CGPoint>loc ( CGPoint -- loc )
[ x>> ] [ y>> ] bi 2array ;
: CGRect>rect ( CGRect -- rect )
[ origin>> CGPoint>loc ]
- [ size>> CGSize>dim ]
+ [ size>> CGSize>dim ]
bi <rect> ; inline
: CGRect-x ( CGRect -- x )
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: arrays alien alien.c-types alien.syntax kernel destructors
-accessors fry words hashtables strings sequences memoize assocs math
-math.order math.vectors math.rectangles math.functions locals init
-namespaces combinators fonts colors cache core-foundation
-core-foundation.strings core-foundation.attributed-strings
-core-foundation.utilities core-graphics core-graphics.types
-core-text.fonts ;
+USING: arrays alien alien.c-types alien.data alien.syntax kernel
+destructors accessors fry words hashtables strings sequences
+memoize assocs math math.order math.vectors math.rectangles
+math.functions locals init namespaces combinators fonts colors
+cache core-foundation core-foundation.strings
+core-foundation.attributed-strings core-foundation.utilities
+core-graphics core-graphics.types core-text.fonts ;
IN: core-text
TYPEDEF: void* CTLineRef
TUPLE: line < disposable line metrics image loc dim ;
: typographic-bounds ( line -- width ascent descent leading )
- 0 <CGFloat> 0 <CGFloat> 0 <CGFloat>
- [ CTLineGetTypographicBounds ] 3keep [ *CGFloat ] tri@ ; inline
+ { CGFloat CGFloat CGFloat }
+ [ CTLineGetTypographicBounds ] [ ] with-out-parameters ; inline
: store-typographic-bounds ( metrics width ascent descent leading -- metrics )
{
#! input values to callbacks; the callback has its own
#! stack frame set up, and we want to read the frame
#! set up by the caller.
- frame-reg swap 2 cells + [+] ;
+ [ frame-reg ] dip 2 cells + reserved-stack-space + [+] ;
M:: x86 %load-stack-param ( dst n rep -- )
dst n next-stack@ rep %copy ;
[ 3drop ] dip
[
memory>byte-array >string
- 0 <uint>
+ { uint }
[
PQunescapeBytea dup zero? [
postgresql-result-error-message throw
] [
&postgresql-free
] if
- ] keep
- *uint memory>byte-array
+ ] [ ] with-out-parameters memory>byte-array
] with-destructors
] [
drop pq-get-is-null nip [ f ] [ B{ } clone ] if
: sqlite-open ( path -- db )
normalize-path
- void* <c-object>
- [ sqlite3_open sqlite-check-result ] keep *void* ;
+ { void* } [ sqlite3_open sqlite-check-result ] [ ]
+ with-out-parameters ;
: sqlite-close ( db -- )
sqlite3_close sqlite-check-result ;
: sqlite-prepare ( db sql -- handle )
- utf8 encode dup length void* <c-object> void* <c-object>
- [ sqlite3_prepare_v2 sqlite-check-result ] 2keep
- drop *void* ;
+ utf8 encode dup length
+ { void* void* }
+ [ sqlite3_prepare_v2 sqlite-check-result ] [ drop ]
+ with-out-parameters ;
: sqlite-bind-parameter-index ( handle name -- index )
sqlite3_bind_parameter_index ;
! Copyright (C) 2010 Erik Charlebois, William Schlieper.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors alien.c-types arrays kernel game.input
+USING: accessors alien.c-types alien.data arrays kernel game.input
namespaces math classes bit-arrays system sequences vectors
-x11 x11.xlib assocs ;
+x11 x11.xlib assocs generalizations ;
IN: game.input.x11
SINGLETON: x11-game-input-backend
: query-pointer ( -- x y buttons )
dpy get dup XDefaultRootWindow
- 0 <int> 0 <int> 0 <int> 0 <int> 0 <int> 0 <int> 0 <int>
- [ XQueryPointer drop ] 3keep
- [ *int ] tri@ ;
+ { int int int int int int int }
+ [ XQueryPointer drop ] [ ] with-out-parameters
+ [ 4 ndrop ] 3dip ;
SYMBOL: mouse-reset?
-USING: alien alien.c-types arrays assocs combinators continuations
-destructors io io.backend io.ports io.timeouts io.backend.windows
-io.files.windows io.files.windows.nt io.files io.pathnames io.buffers
-io.streams.c io.streams.null libc kernel math namespaces sequences
-threads windows windows.errors windows.kernel32 strings splitting
-ascii system accessors locals classes.struct combinators.short-circuit ;
+USING: alien alien.c-types alien.data alien.syntax arrays assocs
+combinators continuations destructors io io.backend io.ports
+io.timeouts io.backend.windows io.files.windows
+io.files.windows.nt io.files io.pathnames io.buffers
+io.streams.c io.streams.null libc kernel math namespaces
+sequences threads windows windows.errors windows.kernel32
+strings splitting ascii system accessors locals classes.struct
+combinators.short-circuit ;
IN: io.backend.windows.nt
! Global variable with assoc mapping overlapped to threads
] with-timeout ;
:: wait-for-overlapped ( nanos -- bytes-transferred overlapped error? )
- master-completion-port get-global
- 0 <int> :> bytes
- f <void*> :> key
- f <void*> :> overlapped
nanos [ 1,000,000 /i ] [ INFINITE ] if* :> timeout
- bytes key overlapped timeout GetQueuedCompletionStatus zero? :> error?
-
- bytes *int
- overlapped *void* dup [ OVERLAPPED memory>struct ] when
- error? ;
+ master-completion-port get-global
+ { int void* pointer: OVERLAPPED }
+ [ timeout GetQueuedCompletionStatus zero? ] [ ] with-out-parameters
+ :> ( error? bytes key overlapped )
+ bytes overlapped error? ;
: resume-callback ( result overlapped -- )
>c-ptr pending-overlapped get-global delete-at* drop resume-with ;
! http://msdn.microsoft.com/msdnmag/issues/05/03/TokenPrivileges/
: (open-process-token) ( handle -- handle )
- flags{ TOKEN_ADJUST_PRIVILEGES TOKEN_QUERY } PHANDLE <c-object>
- [ OpenProcessToken win32-error=0/f ] keep *void* ;
+ flags{ TOKEN_ADJUST_PRIVILEGES TOKEN_QUERY }
+ { PHANDLE }
+ [ OpenProcessToken win32-error=0/f ] [ ]
+ with-out-parameters ;
: open-process-token ( -- handle )
#! remember to CloseHandle
combinators generalizations system alien.strings
io.encodings.utf16n sequences splitting windows.errors fry
continuations destructors calendar ascii
-combinators.short-circuit locals classes.struct
+combinators.short-circuit literals locals classes.struct
specialized-arrays alien.data ;
SPECIALIZED-ARRAY: ushort
IN: io.files.info.windows
TUPLE: windows-file-info < file-info attributes ;
: get-compressed-file-size ( path -- n )
- DWORD <c-object> [ GetCompressedFileSize ] keep
- over INVALID_FILE_SIZE = [
- win32-error-string throw
- ] [
- *uint >64bit
- ] if ;
+ { DWORD } [ GetCompressedFileSize ] [ ] with-out-parameters
+ over INVALID_FILE_SIZE = [ win32-error-string throw ] [ >64bit ] if ;
: set-windows-size-on-disk ( file-info path -- file-info )
over attributes>> +compressed+ swap member? [
M: windows link-info ( path -- info )
file-info ;
+CONSTANT: path-length $[ MAX_PATH 1 + ]
+
: volume-information ( normalized-path -- volume-name volume-serial max-component flags type )
- MAX_PATH 1 + [ <ushort-array> ] keep
- DWORD <c-object>
- DWORD <c-object>
- DWORD <c-object>
- MAX_PATH 1 + [ <ushort-array> ] keep
- [ GetVolumeInformation win32-error=0/f ] 7 nkeep
- drop 5 nrot drop
- [ utf16n alien>string ] 4 ndip
- utf16n alien>string ;
+ { { ushort path-length } DWORD DWORD DWORD { ushort path-length } }
+ [ [ path-length ] 4dip path-length GetVolumeInformation win32-error=0/f ]
+ [ [ utf16n alien>string ] 4dip utf16n alien>string ]
+ with-out-parameters ;
: file-system-space ( normalized-path -- available-space total-space free-space )
- ULARGE_INTEGER <c-object>
- ULARGE_INTEGER <c-object>
- ULARGE_INTEGER <c-object>
- [ GetDiskFreeSpaceEx win32-error=0/f ] 3keep ;
+ { ULARGE_INTEGER ULARGE_INTEGER ULARGE_INTEGER }
+ [ GetDiskFreeSpaceEx win32-error=0/f ] [ ]
+ with-out-parameters ;
: calculate-file-system-info ( file-system-info -- file-system-info' )
[ dup [ total-space>> ] [ free-space>> ] bi - >>used-space drop ] keep ;
: (file-system-info) ( path -- file-system-info )
dup [ volume-information ] [ file-system-space ] bi
\ win32-file-system-info new
- swap *ulonglong >>free-space
- swap *ulonglong >>total-space
- swap *ulonglong >>available-space
+ swap >>free-space
+ swap >>total-space
+ swap >>available-space
swap >>type
- swap *uint >>flags
- swap *uint >>max-component
- swap *uint >>device-serial
+ swap >>flags
+ swap >>max-component
+ swap >>device-serial
swap >>device-name
swap >>mount-point
calculate-file-system-info ;
M: winnt file-system-info ( path -- file-system-info )
normalize-path root-directory (file-system-info) ;
-:: volume>paths ( string -- array )
- 16384 :> names-buf-length
- names-buf-length <ushort-array> :> names
- 0 <uint> :> names-length
+CONSTANT: names-buf-length 16384
- string names names-buf-length names-length GetVolumePathNamesForVolumeName :> ret
- ret 0 = [
- ret win32-error-string throw
- ] [
- names names-length *uint ushort heap-size * head
- utf16n alien>string { CHAR: \0 } split
- ] if ;
+: volume>paths ( string -- array )
+ { { ushort names-buf-length } uint }
+ [ [ names-buf-length ] dip GetVolumePathNamesForVolumeName win32-error=0/f ]
+ [ head utf16n alien>string { CHAR: \0 } split ]
+ with-out-parameters ;
: find-first-volume ( -- string handle )
- MAX_PATH 1 + [ <ushort-array> ] keep
- dupd
- FindFirstVolume dup win32-error=0/f
- [ utf16n alien>string ] dip ;
-
-:: find-next-volume ( handle -- string/f )
- MAX_PATH 1 + :> buf-length
- buf-length <ushort-array> :> buf
-
- handle buf buf-length FindNextVolume :> ret
- ret 0 = [
- GetLastError ERROR_NO_MORE_FILES =
- [ f ] [ win32-error-string throw ] if
- ] [
- buf utf16n alien>string
- ] if ;
+ { { ushort path-length } }
+ [ path-length FindFirstVolume dup win32-error=0/f ]
+ [ utf16n alien>string ]
+ with-out-parameters swap ;
+
+: find-next-volume ( handle -- string/f )
+ { { ushort path-length } }
+ [ path-length FindNextVolume ]
+ [
+ swap 0 = [
+ GetLastError ERROR_NO_MORE_FILES =
+ [ drop f ] [ win32-error-string throw ] if
+ ] [ utf16n alien>string ] if
+ ] with-out-parameters ;
: find-volumes ( -- array )
find-first-volume
: file-times ( path -- timestamp timestamp timestamp )
[
normalize-path open-read &dispose handle>>
- FILETIME <struct>
- FILETIME <struct>
- FILETIME <struct>
- [ GetFileTime win32-error=0/f ] 3keep
- [ FILETIME>timestamp >local-time ] tri@
+ { FILETIME FILETIME FILETIME }
+ [ GetFileTime win32-error=0/f ]
+ [ [ FILETIME>timestamp >local-time ] tri@ ]
+ with-out-parameters
] with-destructors ;
: set-file-times ( path timestamp/f timestamp/f timestamp/f -- )
! Copyright (C) 2007, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors alien.c-types arrays assocs combinators
-continuations environment io io.backend io.backend.unix
-io.files io.files.private io.files.unix io.launcher io.pathnames
-io.ports kernel math namespaces sequences strings system threads
-unix unix.process unix.ffi simple-tokenizer ;
+USING: accessors alien.c-types alien.data arrays assocs
+combinators continuations environment io io.backend
+io.backend.unix io.files io.files.private io.files.unix
+io.launcher io.pathnames io.ports kernel math namespaces
+sequences strings system threads unix unix.process unix.ffi
+simple-tokenizer ;
IN: io.launcher.unix
: get-arguments ( process -- seq )
dup WIFSIGNALED [ WTERMSIG signal boa ] [ WEXITSTATUS ] if ;
M: unix wait-for-processes ( -- ? )
- 0 <int> -1 over WNOHANG waitpid
- dup 0 <= [
+ { int } [ -1 swap WNOHANG waitpid ] [ ] with-out-parameters
+ swap dup 0 <= [
2drop t
] [
find-process dup
- [ swap *int code>status notify-exit f ] [ 2drop f ] if
+ [ swap code>status notify-exit f ] [ 2drop f ] if
] if ;
! Copyright (C) 2007, 2010 Doug Coleman, Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: alien alien.c-types arrays continuations io
+USING: alien alien.c-types alien.data arrays continuations io
io.backend.windows io.pipes.windows.nt io.pathnames libc
io.ports windows.types math windows.kernel32 namespaces make
io.launcher kernel sequences windows.errors splitting system
: exit-code ( process -- n )
hProcess>>
- 0 <ulong> [ GetExitCodeProcess ] keep *ulong
+ { DWORD } [ GetExitCodeProcess ] [ ] with-out-parameters
swap win32-error=0/f ;
: process-exited ( process -- )
SIO_GET_EXTENSION_FUNCTION_POINTER
WSAID_CONNECTEX
GUID heap-size
- void* <c-object>
+ { void* }
[
void* heap-size
DWORD <c-object>
WSAIoctl SOCKET_ERROR = [
winsock-error-string throw
] when
- ] keep *void* ;
+ ] [ ] with-out-parameters ;
TUPLE: ConnectEx-args port
s name namelen lpSendBuffer dwSendDataLength
-USING: alien.syntax alien.c-types core-foundation
+USING: alien.syntax alien.c-types alien.data core-foundation
core-foundation.bundles core-foundation.dictionaries system
combinators kernel sequences io accessors unix.types ;
IN: iokit
dup KERN_SUCCESS = [ drop ] [ <mach-error> throw ] if ;
: master-port ( -- port )
- MACH_PORT_NULL 0 <uint> [ IOMasterPort mach-error ] keep *uint ;
+ MACH_PORT_NULL { uint } [ IOMasterPort mach-error ] [ ] with-out-parameters ;
: io-services-matching-dictionary ( nsdictionary -- iterator )
- master-port swap 0 <uint>
- [ IOServiceGetMatchingServices mach-error ] keep
- *uint ;
+ master-port swap
+ { uint } [ IOServiceGetMatchingServices mach-error ] [ ] with-out-parameters ;
: io-services-matching-service ( service -- iterator )
IOServiceMatching io-services-matching-dictionary ;
! Copyright (C) 2008 Joe Groff.
! See http://factorcode.org/license.txt for BSD license.
USING: opengl opengl.gl combinators continuations kernel
-alien.c-types ;
+alien.c-types alien.data ;
IN: opengl.framebuffers
: gen-framebuffer ( -- id )
: framebuffer-attachment ( attachment -- id )
GL_FRAMEBUFFER swap GL_FRAMEBUFFER_ATTACHMENT_OBJECT_NAME
- 0 <uint> [ glGetFramebufferAttachmentParameteriv ] keep *uint ;
+ { uint } [ glGetFramebufferAttachmentParameteriv ] [ ] with-out-parameters ;
+++ /dev/null
-USING: alien kernel x11.glx ;
-IN: opengl.gl.unix
-
-: gl-function-context ( -- context ) glXGetCurrentContext ; inline
-: gl-function-address ( name -- address ) glXGetProcAddressARB ; inline
-: gl-function-calling-convention ( -- str ) cdecl ; inline
--- /dev/null
+USING: alien kernel x11.glx ;
+IN: opengl.gl.x11
+
+: gl-function-context ( -- context ) glXGetCurrentContext ; inline
+: gl-function-address ( name -- address ) glXGetProcAddressARB ; inline
+: gl-function-calling-convention ( -- str ) cdecl ; inline
! Portions copyright (C) 2007 Eduardo Cavazos.
! Portions copyright (C) 2008 Joe Groff.
! See http://factorcode.org/license.txt for BSD license.
-USING: alien alien.c-types ascii calendar combinators.short-circuit
-continuations kernel libc math macros namespaces math.vectors
-math.parser opengl.gl combinators combinators.smart arrays
-sequences splitting words byte-arrays assocs vocabs
-colors colors.constants accessors generalizations
+USING: alien alien.c-types alien.data ascii calendar
+combinators.short-circuit continuations kernel libc math macros
+namespaces math.vectors math.parser opengl.gl combinators
+combinators.smart arrays sequences splitting words byte-arrays
+assocs vocabs colors colors.constants accessors generalizations
sequences.generalizations locals fry specialized-arrays ;
FROM: alien.c-types => float ;
SPECIALIZED-ARRAY: float
swap glPushAttrib call glPopAttrib ; inline
: (gen-gl-object) ( quot -- id )
- [ 1 0 <uint> ] dip keep *uint ; inline
+ [ 1 { uint } ] dip [ ] with-out-parameters ; inline
: (delete-gl-object) ( id quot -- )
[ 1 swap <uint> ] dip call ; inline
dup integer? [ glIsShader c-bool> ] [ drop f ] if ;
: gl-shader-get-int ( shader enum -- value )
- 0 <int> [ glGetShaderiv ] keep *int ;
+ { int } [ glGetShaderiv ] [ ] with-out-parameters ;
: gl-shader-ok? ( shader -- ? )
GL_COMPILE_STATUS gl-shader-get-int c-bool> ;
dup integer? [ glIsProgram c-bool> ] [ drop f ] if ;
: gl-program-get-int ( program enum -- value )
- 0 <int> [ glGetProgramiv ] keep *int ;
+ { int } [ glGetProgramiv ] [ ] with-out-parameters ;
: gl-program-ok? ( program -- ? )
GL_LINK_STATUS gl-program-get-int c-bool> ;
! Copyright (C) 2009, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors assocs cache colors.constants destructors
-kernel opengl opengl.gl opengl.capabilities combinators images
-images.tesselation grouping sequences math math.vectors
-generalizations fry arrays namespaces system
-locals literals specialized-arrays ;
-FROM: alien.c-types => float <float> <int> *float *int ;
+USING: accessors alien.data assocs cache colors.constants
+destructors kernel opengl opengl.gl opengl.capabilities
+combinators images images.tesselation grouping sequences math
+math.vectors generalizations fry arrays namespaces system locals
+literals specialized-arrays ;
+FROM: alien.c-types => int float ;
SPECIALIZED-ARRAY: float
IN: opengl.textures
[ [ max-texture-size tesselate ] dip <multi-texture> ] if ;
: get-texture-float ( target level enum -- value )
- 0 <float> [ glGetTexLevelParameterfv ] keep *float ; inline
-: get-texture-int ( target level enum -- value )
- 0 <int> [ glGetTexLevelParameteriv ] keep *int ; inline
+ { float } [ glGetTexLevelParameterfv ] [ ] with-out-parameters ; inline
+: get-texture-int ( target level enum -- value )
+ { int } [ glGetTexLevelParameteriv ] [ ] with-out-parameters ; inline
! Copyright (C) 2010 Anton Gorenko.
! See http://factorcode.org/license.txt for BSD license.
-USING: alien alien.c-types alien.libraries alien.syntax cairo.ffi
-combinators kernel system
+USING: alien alien.c-types alien.data alien.libraries
+alien.syntax cairo.ffi combinators kernel system
gir pango pango.ffi ;
<<
CONSTANT: factor-crypto-container "FactorCryptoContainer"
-:: (acquire-crypto-context) ( provider type flags -- handle ret )
- HCRYPTPROV <c-object> :> handle
- handle
- factor-crypto-container
- provider
- type
- flags
- CryptAcquireContextW handle swap ;
+:: (acquire-crypto-context) ( provider type flags -- ret handle )
+ { HCRYPTPROV } [
+ factor-crypto-container
+ provider
+ type
+ flags
+ CryptAcquireContextW
+ ] [ ] with-out-parameters ;
: acquire-crypto-context ( provider type -- handle )
CRYPT_MACHINE_KEYSET
(acquire-crypto-context)
- 0 = [
+ swap 0 = [
GetLastError NTE_BAD_KEYSET =
[ drop f ] [ win32-error-string throw ] if
- ] [
- *void*
- ] if ;
+ ] when ;
: create-crypto-context ( provider type -- handle )
flags{ CRYPT_MACHINE_KEYSET CRYPT_NEWKEYSET }
--- /dev/null
+USING: math.order strings system-info.backend
+system-info.windows system-info.windows.nt
+tools.test ;
+IN: system-info.windows.nt.tests
+
+[ t ] [ cpus 0 1024 between? ] unit-test
+[ t ] [ username string? ] unit-test
: memory-status ( -- MEMORYSTATUSEX )
MEMORYSTATUSEX <struct>
- dup class heap-size >>dwLength
+ MEMORYSTATUSEX heap-size >>dwLength
dup GlobalMemoryStatusEx win32-error=0/f ;
M: winnt memory-load ( -- n )
! Copyright (C) 2006, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors alien.c-types arrays assocs classes cocoa
-cocoa.application cocoa.classes cocoa.messages cocoa.nibs
+USING: accessors alien.c-types alien.data arrays assocs classes
+cocoa cocoa.application cocoa.classes cocoa.messages cocoa.nibs
cocoa.pasteboard cocoa.runtime cocoa.subclassing cocoa.types
cocoa.views cocoa.windows combinators command-line
core-foundation core-foundation.run-loop core-graphics
core-graphics.types destructors fry generalizations io.thread
-kernel libc literals locals math math.bitwise math.rectangles memory
-namespaces sequences threads ui colors
-ui.backend ui.backend.cocoa.views ui.clipboards ui.gadgets
+kernel libc literals locals math math.bitwise math.rectangles
+memory namespaces sequences threads ui colors ui.backend
+ui.backend.cocoa.views ui.clipboards ui.gadgets
ui.gadgets.worlds ui.pixel-formats ui.pixel-formats.private
ui.private words.symbol ;
IN: ui.backend.cocoa
M: cocoa-ui-backend (pixel-format-attribute)
[ handle>> ] [ >NSOpenGLPFA ] bi*
[ drop f ]
- [ first 0 <int> [ swap 0 -> getValues:forAttribute:forVirtualScreen: ] keep *int ]
- if-empty ;
+ [
+ first
+ { int } [ swap 0 -> getValues:forAttribute:forVirtualScreen: ] [ ]
+ with-out-parameters
+ ] if-empty ;
TUPLE: pasteboard handle ;
drop f ;
: arb-make-pixel-format ( world attributes -- pf )
- [ handle>> hDC>> ] dip >WGL_ARB-int-array f 1 0 <int> 0 <int>
- [ wglChoosePixelFormatARB win32-error=0/f ] 2keep drop *int ;
+ [ handle>> hDC>> ] dip >WGL_ARB-int-array f 1 { int int }
+ [ wglChoosePixelFormatARB win32-error=0/f ] [ ] with-out-parameters drop ;
: arb-pixel-format-attribute ( pixel-format attribute -- value )
>WGL_ARB
[ drop f ] [
[ [ world>> handle>> hDC>> ] [ handle>> ] bi 0 1 ] dip
- first <int> 0 <int>
- [ wglGetPixelFormatAttribivARB win32-error=0/f ]
- keep *int
+ first <int> { int }
+ [ wglGetPixelFormatAttribivARB win32-error=0/f ] [ ]
+ with-out-parameters
] if-empty ;
CONSTANT: pfd-flag-map H{
! Copyright (C) 2005, 2010 Eduardo Cavazos and Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors alien.c-types ascii assocs classes.struct combinators
-combinators.short-circuit command-line environment io.encodings.ascii
-io.encodings.string io.encodings.utf8 kernel literals locals math
-namespaces sequences specialized-arrays.instances.alien.c-types.uchar
+USING: accessors alien.c-types alien.data ascii assocs classes.struct
+combinators combinators.short-circuit command-line environment
+io.encodings.ascii io.encodings.string io.encodings.utf8 kernel
+literals locals math namespaces sequences specialized-arrays
strings ui ui.backend ui.clipboards ui.event-loop ui.gadgets
ui.gadgets.private ui.gadgets.worlds ui.gestures ui.pixel-formats
ui.pixel-formats.private ui.private x11 x11.clipboard x11.constants
x11.events x11.glx x11.io x11.windows x11.xim x11.xlib ;
FROM: unix.ffi => system ;
+SPECIALIZED-ARRAY: uchar
IN: ui.backend.x11
SINGLETON: x11-ui-backend
[ handle>> ] [ >glx-visual ] bi*
[ 2drop f ] [
first
- 0 <int> [ glXGetConfig drop ] keep *int
+ { int } [ glXGetConfig drop ] [ ] with-out-parameters
] if-empty ;
CONSTANT: modifiers
: start-blinking ( editor -- )
[ stop-blinking ] [
t >>blink
- dup '[ _ blink-caret ] blink-interval get every
+ dup '[ _ blink-caret ] blink-interval get delayed-every
>>blink-alarm drop
] bi ;
FUNCTION: pid_t wait ( int* status ) ;
FUNCTION: pid_t waitpid ( pid_t wpid, int* status, int options ) ;
-
-: wait-for-pid ( pid -- status )
- 0 <int> [ 0 waitpid drop ] keep *int WEXITSTATUS ;
: composition-enabled? ( -- ? )
windows-major 6 >=
- [ 0 <int> [ DwmIsCompositionEnabled drop ] keep *int c-bool> ]
+ [ { bool } [ DwmIsCompositionEnabled drop ] [ ] with-out-parameters ]
[ f ] if ;
: make-bitmap ( dim dc -- hBitmap bits )
[ nip ]
[
- swap (bitmap-info) DIB_RGB_COLORS f <void*>
- [ f 0 CreateDIBSection ] keep *void*
+ swap (bitmap-info) DIB_RGB_COLORS { void* }
+ [ f 0 CreateDIBSection ] [ ] with-out-parameters
] 2bi
[ [ SelectObject drop ] keep ] dip ;
! See http://factorcode.org/license.txt for BSD license.
USING: kernel assocs math sequences fry io.encodings.string
io.encodings.utf16n accessors arrays combinators destructors
-cache namespaces init fonts alien.c-types windows.usp10
-windows.offscreen windows.gdi32 windows.ole32 windows.types
-windows.fonts opengl.textures locals windows.errors
-classes.struct ;
+cache namespaces init fonts alien.c-types alien.data
+windows.usp10 windows.offscreen windows.gdi32 windows.ole32
+windows.types windows.fonts opengl.textures locals
+windows.errors classes.struct ;
IN: windows.uniscribe
TUPLE: script-string < disposable font string metrics ssa size image ;
swap ! icp
FALSE ! fTrailing
] if
- 0 <int> [ ScriptStringCPtoX ole32-error ] keep *int ;
+ { int } [ ScriptStringCPtoX ole32-error ] [ ] with-out-parameters ;
: x>line-offset ( x script-string -- n trailing )
ssa>> ! ssa
swap ! iX
- 0 <int> ! pCh
- 0 <int> ! piTrailing
- [ ScriptStringXtoCP ole32-error ] 2keep [ *int ] bi@ ;
+ { int int } [ ScriptStringXtoCP ole32-error ] [ ] with-out-parameters ;
<PRIVATE
projects / factor.git / commitdiff