steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Updating code to use with-out-parameters

db4
Slava Pestov 2010-05-23 03:07:47 -04:00
parent c9ad0856d5
commit 70a99e1cdb
34 changed files with 200 additions and 215 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

9
basis/checksums/openssl/openssl.factor
View File

@ -1,4 +1,4 @@
! 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
@ -47,9 +47,10 @@ M: evp-md-context dispose*
: 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>

10
basis/cocoa/messages/messages.factor
View File

@ -1,11 +1,11 @@
! 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
@ -216,7 +216,7 @@ ERROR: no-objc-type name ;
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

14
basis/cocoa/nibs/nibs.factor
View File

@ -1,8 +1,8 @@
! 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 -- )
@ -15,5 +15,7 @@ IN: cocoa.nibs
dup [ -> autorelease ] when ;
: nib-objects ( anNSNib -- objects/f )
f f <void*> [ -> instantiateNibWithOwner:topLevelObjects: ] keep
swap [ *void* CF>array ] [ drop f ] if ;
f
{ void* } [ -> instantiateNibWithOwner:topLevelObjects: ] [ ]
with-out-parameters
swap [ CF>array ] [ drop f ] if ;

8
basis/cocoa/plists/plists.factor
View File

@ -36,9 +36,11 @@ DEFER: plist>
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 )
[

21
basis/core-foundation/core-foundation.factor
View File

@ -8,23 +8,20 @@ TYPEDEF: void* CFTypeRef
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 } ;

3
basis/core-foundation/fsevents/fsevents.factor
View File

@ -119,8 +119,7 @@ FUNCTION: CFStringRef FSEventStreamCopyDescription ( FSEventStreamRef streamRef
flags
FSEventStreamCreate ;
: kCFRunLoopCommonModes ( -- string )
&: kCFRunLoopCommonModes *void* ;
C-GLOBAL: void* kCFRunLoopCommonModes
: schedule-event-stream ( event-stream -- )
CFRunLoopGetMain

17
basis/core-foundation/strings/strings.factor
View File

@ -1,8 +1,9 @@
! 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
@ -75,8 +76,12 @@ FUNCTION: CFStringRef CFStringCreateWithCString (
: 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 ;

10
basis/core-graphics/types/types.factor
View File

@ -8,12 +8,6 @@ IN: core-graphics.types
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 } ;
@ -30,7 +24,7 @@ STRUCT: CGSize
STRUCT: CGRect
{ origin CGPoint }
{ size CGSize } ;
{ size CGSize } ;
: CGPoint>loc ( CGPoint -- loc )
[ x>> ] [ y>> ] bi 2array ;
@ -40,7 +34,7 @@ STRUCT: CGRect
: CGRect>rect ( CGRect -- rect )
[ origin>> CGPoint>loc ]
[ size>> CGSize>dim ]
[ size>> CGSize>dim ]
bi <rect> ; inline
: CGRect-x ( CGRect -- x )

18
basis/core-text/core-text.factor
View File

@ -1,12 +1,12 @@
! 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
@ -50,8 +50,8 @@ ERROR: not-a-string object ;
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 )
{

5
basis/db/postgresql/lib/lib.factor
View File

@ -139,15 +139,14 @@ M: postgresql-malloc-destructor dispose ( obj -- )
[ 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

11
basis/db/sqlite/lib/lib.factor
View File

@ -27,16 +27,17 @@ ERROR: sqlite-sql-error < sql-error n string ;
: 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 ;

8
basis/game/input/x11/x11.factor
View File

@ -2,7 +2,7 @@
! See http://factorcode.org/license.txt for BSD license.
USING: accessors alien.c-types 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
@ -88,9 +88,9 @@ M: x11-game-input-backend read-keyboard
: 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?

14
basis/io/backend/windows/nt/nt.factor
View File

@ -51,16 +51,12 @@ M: winnt add-completion ( win32-handle -- )
] 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 ;

6
basis/io/backend/windows/nt/privileges/privileges.factor
View File

@ -13,8 +13,10 @@ TYPEDEF: TOKEN_PRIVILEGES* PTOKEN_PRIVILEGES
! 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

96
basis/io/files/info/windows/windows.factor
View File

@ -21,12 +21,8 @@ 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? [
@ -99,22 +95,18 @@ M: windows file-info ( path -- info )
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 ;
@ -136,13 +128,13 @@ ERROR: not-absolute-path ;
: (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 ;
@ -152,36 +144,29 @@ PRIVATE>
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 ;
{ { ushort path-length } }
[ path-length FindFirstVolume dup win32-error=0/f ]
[ utf16n alien>string ]
with-out-parameters swap ;
:: 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 ;
: 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
@ -202,11 +187,10 @@ M: winnt file-systems ( -- array )
: 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 -- )

17
basis/io/launcher/unix/unix.factor
View File

@ -1,10 +1,11 @@
! 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 )
@ -94,10 +95,10 @@ TUPLE: signal n ;
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 ;

2
basis/io/launcher/windows/windows.factor
View File

@ -159,7 +159,7 @@ M: windows kill-process* ( handle -- )
: exit-code ( process -- n )
hProcess>>
0 <ulong> [ GetExitCodeProcess ] keep *ulong
{ DWORD } [ GetExitCodeProcess ] [ ] with-out-parameters
swap win32-error=0/f ;
: process-exited ( process -- )

4
basis/io/sockets/windows/nt/nt.factor
View File

@ -17,7 +17,7 @@ M: winnt WSASocket-flags ( -- DWORD )
SIO_GET_EXTENSION_FUNCTION_POINTER
WSAID_CONNECTEX
GUID heap-size
void* <c-object>
{ void* }
[
void* heap-size
DWORD <c-object>
@ -26,7 +26,7 @@ M: winnt WSASocket-flags ( -- DWORD )
WSAIoctl SOCKET_ERROR = [
winsock-error-string throw
] when
] keep *void* ;
] [ ] with-out-parameters ;
TUPLE: ConnectEx-args port
s name namelen lpSendBuffer dwSendDataLength

9
basis/iokit/iokit.factor
View File

@ -1,4 +1,4 @@
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
@ -131,12 +131,11 @@ TUPLE: mach-error error-code error-string ;
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 ;

4
basis/opengl/framebuffers/framebuffers.factor
View File

@ -1,7 +1,7 @@
! 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 )
@ -51,4 +51,4 @@ IN: opengl.framebuffers
: framebuffer-attachment ( attachment -- id )
GL_FRAMEBUFFER swap GL_FRAMEBUFFER_ATTACHMENT_OBJECT_NAME
0 <uint> [ glGetFramebufferAttachmentParameteriv ] keep *uint ;
{ uint } [ glGetFramebufferAttachmentParameteriv ] [ ] with-out-parameters ;

12
basis/opengl/opengl.factor
View File

@ -2,11 +2,11 @@
! 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
@ -139,7 +139,7 @@ MACRO: all-enabled-client-state ( seq quot -- )
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

4
basis/opengl/shaders/shaders.factor
View File

@ -20,7 +20,7 @@ IN: opengl.shaders
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> ;
@ -79,7 +79,7 @@ PREDICATE: fragment-shader < gl-shader (fragment-shader?) ;
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> ;

18
basis/opengl/textures/textures.factor
View File

@ -1,11 +1,11 @@
! 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
@ -406,7 +406,7 @@ PRIVATE>
[ [ 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

24
basis/pango/cairo/cairo.factor
View File

@ -3,12 +3,13 @@
! See http://factorcode.org/license.txt for BSD license.
!
! pangocairo bindings, from pango/pangocairo.h
USING: arrays sequences alien alien.c-types alien.destructors
alien.libraries alien.syntax math math.functions math.vectors
destructors combinators colors fonts accessors assocs namespaces
kernel pango pango.fonts pango.layouts glib unicode.data images
cache init system math.rectangles fry memoize io.encodings.utf8
classes.struct cairo cairo.ffi ;
USING: arrays sequences alien alien.c-types alien.data
alien.destructors alien.libraries alien.syntax math
math.functions math.vectors destructors combinators colors fonts
accessors assocs namespaces kernel pango pango.fonts
pango.layouts glib unicode.data images cache init system
math.rectangles fry memoize io.encodings.utf8 classes.struct
cairo cairo.ffi ;
IN: pango.cairo
<< {
@ -136,16 +137,17 @@ SYMBOL: dpi
: line-offset>x ( layout n -- x )
#! n is an index into the UTF8 encoding of the text
[ drop first-line ] [ swap string>> >utf8-index ] 2bi
0 0 <int> [ pango_layout_line_index_to_x ] keep
*int pango>float ;
0 { int } [ pango_layout_line_index_to_x ] [ ] with-out-parameters
pango>float ;
: x>line-offset ( layout x -- n )
#! n is an index into the UTF8 encoding of the text
[
[ first-line ] dip
float>pango 0 <int> 0 <int>
[ pango_layout_line_x_to_index drop ] 2keep
[ *int ] bi@ swap
float>pango
{ int int }
[ pango_layout_line_x_to_index drop ] [ ] with-out-parameters
swap
] [ drop string>> ] 2bi utf8-index> + ;
: selection-start/end ( selection -- start end )

22
basis/random/windows/windows.factor
View File

@ -16,24 +16,22 @@ M: windows-crypto-context dispose ( tuple -- )
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 -- 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 }

5
basis/system-info/windows/nt/nt-tests.factor Normal file
View File

@ -0,0 +1,5 @@
USING: math.order strings ;
IN: system-info.windows.nt
[ t ] [ cpus 0 1024 between? ] unit-test
[ t ] [ username string? ] unit-test

2
basis/system-info/windows/nt/nt.factor
View File

@ -12,7 +12,7 @@ M: winnt cpus ( -- n )
: 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 )

17
basis/ui/backend/cocoa/cocoa.factor
View File

@ -1,14 +1,14 @@
! 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
@ -55,8 +55,11 @@ M: cocoa-ui-backend (free-pixel-format)
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 ;

8
basis/ui/backend/windows/windows.factor
View File

@ -59,16 +59,16 @@ PIXEL-FORMAT-ATTRIBUTE-TABLE: WGL_ARB { $ WGL_SUPPORT_OPENGL_ARB 1 } H{
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>
first <int> { int }
[ wglGetPixelFormatAttribivARB win32-error=0/f ]
keep *int
with-out-parameters
] if-empty ;
CONSTANT: pfd-flag-map H{

2
basis/ui/backend/x11/x11.factor
View File

@ -60,7 +60,7 @@ M: x11-ui-backend (pixel-format-attribute)
[ handle>> ] [ >glx-visual ] bi*
[ 2drop f ] [
first
0 <int> [ glXGetConfig drop ] keep *int
{ int } [ glXGetConfig drop ] with-out-parameters
] if-empty ;
CONSTANT: modifiers

3
basis/unix/process/process.factor
View File

@ -95,6 +95,3 @@ CONSTANT: WNOWAIT HEX: 1000000
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 ;

2
basis/windows/dwmapi/dwmapi.factor
View File

@ -34,5 +34,5 @@ CONSTANT: WM_DWMCOMPOSITIONCHANGED HEX: 31E
: composition-enabled? ( -- ? )
windows-major 6 >=
[ 0 <int> [ DwmIsCompositionEnabled drop ] keep *int c-bool> ]
[ { bool } [ DwmIsCompositionEnabled drop ] [ ] with-out-parameters ]
[ f ] if ;

4
basis/windows/offscreen/offscreen.factor
View File

@ -26,8 +26,8 @@ IN: windows.offscreen
: 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 ;

6
basis/windows/uniscribe/uniscribe.factor
View File

@ -20,14 +20,12 @@ 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