Merge branch 'master' of factorcode.org:/git/factor
Joe Groff
commit
3993dace22
|
|
@ -30,3 +30,17 @@ IN: alarms.tests
|
|||
1/2 seconds sleep
|
||||
stop-alarm
|
||||
] unit-test
|
||||
|
||||
[ { 1 } ] [
|
||||
{ 0 }
|
||||
dup '[ 0 _ [ 1 + ] change-nth ] 3 seconds later
|
||||
[ stop-alarm ] [ start-alarm ] bi
|
||||
4 seconds sleep
|
||||
] unit-test
|
||||
|
||||
[ { 0 } ] [
|
||||
{ 0 }
|
||||
dup '[ 3 seconds sleep 1 _ set-first ] 1 seconds later
|
||||
2 seconds sleep stop-alarm
|
||||
1/2 seconds sleep
|
||||
] unit-test
|
||||
|
|
|
|||
|
|
@ -9,9 +9,10 @@ TUPLE: alarm
|
|||
{ 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
|
||||
|
||||
|
|
@ -21,39 +22,44 @@ M: real >nanoseconds >integer ;
|
|||
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 )
|
||||
|
|
@ -63,14 +69,20 @@ PRIVATE>
|
|||
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
|
||||
|
||||
|
|
|
|||
|
|
@ -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>
|
||||
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
|
@ -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 )
|
||||
[
|
||||
|
|
|
|||
|
|
@ -763,6 +763,14 @@ mingw? [
|
|||
[ S{ test-struct-11 f 7 -3 } ]
|
||||
[ 3 4 7 fastcall-struct-return-iii-callback fastcall-struct-return-iii-indirect ] unit-test
|
||||
|
||||
: x64-regression-1 ( -- c )
|
||||
int { int int int int int } cdecl [ + + + + ] alien-callback ;
|
||||
|
||||
: x64-regression-2 ( x x x x x c -- y )
|
||||
int { int int int int int } cdecl alien-indirect ; inline
|
||||
|
||||
[ 661 ] [ 100 500 50 10 1 x64-regression-1 x64-regression-2 ] unit-test
|
||||
|
||||
! Stack allocation
|
||||
: blah ( -- x ) { RECT } [ 1.5 >>x 2.0 >>y [ x>> ] [ y>> ] bi * >fixnum ] with-scoped-allocation ;
|
||||
|
||||
|
|
|
|||
|
|
@ -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 } ;
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
|
|
|||
|
|
@ -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 )
|
||||
|
|
|
|||
|
|
@ -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 )
|
||||
{
|
||||
|
|
|
|||
|
|
@ -58,14 +58,10 @@ M: x86.64 %set-vm-field ( src offset -- )
|
|||
M: x86.64 %vm-field-ptr ( dst offset -- )
|
||||
[ vm-reg ] dip [+] LEA ;
|
||||
|
||||
! Must be a volatile register not used for parameter passing or
|
||||
! integer return
|
||||
HOOK: temp-reg cpu ( -- reg )
|
||||
|
||||
M: x86.64 %prologue ( n -- )
|
||||
temp-reg -7 [RIP+] LEA
|
||||
R11 -7 [RIP+] LEA
|
||||
dup PUSH
|
||||
temp-reg PUSH
|
||||
R11 PUSH
|
||||
stack-reg swap 3 cells - SUB ;
|
||||
|
||||
M: x86.64 %prepare-jump
|
||||
|
|
|
|||
|
|
@ -45,6 +45,4 @@ M: x86.64 dummy-int-params? f ;
|
|||
|
||||
M: x86.64 dummy-fp-params? f ;
|
||||
|
||||
M: x86.64 temp-reg R8 ;
|
||||
|
||||
M: x86.64 %prepare-var-args RAX RAX XOR ;
|
||||
|
|
|
|||
|
|
@ -23,5 +23,3 @@ M: x86.64 dummy-stack-params? f ;
|
|||
M: x86.64 dummy-int-params? t ;
|
||||
|
||||
M: x86.64 dummy-fp-params? t ;
|
||||
|
||||
M: x86.64 temp-reg R11 ;
|
||||
|
|
|
|||
|
|
@ -583,7 +583,7 @@ M:: x86 %store-stack-param ( src n rep -- )
|
|||
#! 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 ;
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
|
|
|||
|
|
@ -1,8 +1,8 @@
|
|||
! 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
|
||||
|
|
@ -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?
|
||||
|
||||
|
|
|
|||
|
|
@ -1,9 +1,11 @@
|
|||
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
|
||||
|
|
@ -51,16 +53,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 ;
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -6,7 +6,7 @@ windows.time windows.types windows accessors alien.c-types
|
|||
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
|
||||
|
|
@ -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 -- )
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
! 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
|
||||
|
|
@ -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 -- )
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
|
|
|||
|
|
@ -7,7 +7,7 @@ ERROR: unknown-gl-platform ;
|
|||
<< {
|
||||
{ [ os windows? ] [ "opengl.gl.windows" ] }
|
||||
{ [ os macosx? ] [ "opengl.gl.macosx" ] }
|
||||
{ [ os unix? ] [ "opengl.gl.unix" ] }
|
||||
{ [ os unix? ] [ "opengl.gl.x11" ] }
|
||||
[ unknown-gl-platform ]
|
||||
} cond use-vocab >>
|
||||
|
||||
|
|
|
|||
|
|
@ -1,5 +1,5 @@
|
|||
USING: alien kernel x11.glx ;
|
||||
IN: opengl.gl.unix
|
||||
IN: opengl.gl.x11
|
||||
|
||||
: gl-function-context ( -- context ) glXGetCurrentContext ; inline
|
||||
: gl-function-address ( name -- address ) glXGetProcAddressARB ; inline
|
||||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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> ;
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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 )
|
||||
|
|
|
|||
|
|
@ -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 -- 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 }
|
||||
|
|
|
|||
|
|
@ -0,0 +1,7 @@
|
|||
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
|
||||
|
|
@ -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 )
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
||||
|
|
|
|||
|
|
@ -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>
|
||||
[ 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{
|
||||
|
|
|
|||
|
|
@ -1,14 +1,15 @@
|
|||
! 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
|
||||
|
|
@ -60,7 +61,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
|
||||
|
|
|
|||
|
|
@ -65,7 +65,7 @@ SYMBOL: blink-interval
|
|||
: 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 ;
|
||||
|
||||
|
|
|
|||
|
|
@ -5,10 +5,7 @@ ui.tools.listener ui.tools.browser ui.tools.common ui.tools.error-list
|
|||
ui.tools.walker ui.commands ui.gestures ui ui.private ;
|
||||
IN: ui.tools
|
||||
|
||||
: main ( -- )
|
||||
restore-windows? [ restore-windows ] [ listener-window ] if ;
|
||||
|
||||
MAIN: main
|
||||
MAIN: listener-window
|
||||
|
||||
\ refresh-all H{ { +nullary+ t } { +listener+ t } } define-command
|
||||
|
||||
|
|
|
|||
|
|
@ -1,11 +1,12 @@
|
|||
! Copyright (C) 2006, 2009 Slava Pestov.
|
||||
! Copyright (C) 2006, 2010 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: arrays assocs io kernel math models namespaces make dlists
|
||||
deques sequences threads words continuations init
|
||||
combinators combinators.short-circuit hashtables concurrency.flags
|
||||
sets accessors calendar fry destructors ui.gadgets ui.gadgets.private
|
||||
ui.gadgets.worlds ui.gadgets.tracks ui.gestures ui.backend ui.render
|
||||
strings classes.tuple classes.tuple.parser lexer vocabs.parser parser ;
|
||||
USING: arrays assocs boxes io kernel math models namespaces make
|
||||
dlists deques sequences threads words continuations init
|
||||
combinators combinators.short-circuit hashtables
|
||||
concurrency.flags sets accessors calendar fry destructors
|
||||
ui.gadgets ui.gadgets.private ui.gadgets.worlds
|
||||
ui.gadgets.tracks ui.gestures ui.backend ui.render strings
|
||||
classes.tuple classes.tuple.parser lexer vocabs.parser parser ;
|
||||
IN: ui
|
||||
|
||||
<PRIVATE
|
||||
|
|
@ -82,12 +83,7 @@ M: world graft*
|
|||
[ [ clean-up-broken-window ] [ ui-error ] bi* ] recover
|
||||
] bi ;
|
||||
|
||||
: reset-world ( world -- )
|
||||
#! This is used when a window is being closed, but also
|
||||
#! when restoring saved worlds on image startup.
|
||||
f >>handle unfocus-world ;
|
||||
|
||||
: (ungraft-world) ( world -- )
|
||||
M: world ungraft*
|
||||
{
|
||||
[ set-gl-context ]
|
||||
[ text-handle>> [ dispose ] when* ]
|
||||
|
|
@ -96,38 +92,21 @@ M: world graft*
|
|||
[ hand-gadget close-global ]
|
||||
[ end-world ]
|
||||
[ [ <reversed> [ [ dispose ] when* ] each V{ } clone ] change-window-resources drop ]
|
||||
[ [ (close-window) f ] change-handle drop ]
|
||||
[ unfocus-world ]
|
||||
} cleave ;
|
||||
|
||||
M: world ungraft*
|
||||
[ (ungraft-world) ]
|
||||
[ handle>> (close-window) ]
|
||||
[ reset-world ] tri ;
|
||||
|
||||
: init-ui ( -- )
|
||||
<box> drag-timer set-global
|
||||
f hand-gadget set-global
|
||||
f hand-clicked set-global
|
||||
f hand-world set-global
|
||||
f world set-global
|
||||
<dlist> \ graft-queue set-global
|
||||
<dlist> \ layout-queue set-global
|
||||
<dlist> \ gesture-queue set-global
|
||||
V{ } clone windows set-global ;
|
||||
|
||||
: restore-gadget-later ( gadget -- )
|
||||
dup graft-state>> {
|
||||
{ { f f } [ ] }
|
||||
{ { f t } [ ] }
|
||||
{ { t t } [ { f f } >>graft-state ] }
|
||||
{ { t f } [ dup unqueue-graft { f f } >>graft-state ] }
|
||||
} case graft-later ;
|
||||
|
||||
: restore-gadget ( gadget -- )
|
||||
dup restore-gadget-later
|
||||
children>> [ restore-gadget ] each ;
|
||||
|
||||
: restore-world ( world -- )
|
||||
{
|
||||
[ reset-world ]
|
||||
[ f >>text-handle f >>images drop ]
|
||||
[ restore-gadget ]
|
||||
} cleave ;
|
||||
|
||||
: update-hand ( world -- )
|
||||
dup hand-world get-global eq?
|
||||
[ hand-loc get-global swap move-hand ] [ drop ] if ;
|
||||
|
|
@ -188,16 +167,6 @@ PRIVATE>
|
|||
: start-ui ( quot -- )
|
||||
call( -- ) notify-ui-thread start-ui-thread ;
|
||||
|
||||
: restore-windows ( -- )
|
||||
[
|
||||
windows get [ values ] [ delete-all ] bi
|
||||
[ restore-world ] each
|
||||
forget-rollover
|
||||
] (with-ui) ;
|
||||
|
||||
: restore-windows? ( -- ? )
|
||||
windows get empty? not ;
|
||||
|
||||
: ?attributes ( gadget title/attributes -- attributes )
|
||||
dup string? [ world-attributes new swap >>title ] [ clone ] if
|
||||
swap [ [ [ 1array ] [ f ] if* ] curry unless* ] curry change-gadgets ;
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
||||
|
|
|
|||
|
|
@ -2,10 +2,10 @@
|
|||
! 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 ;
|
||||
|
|
@ -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
|
||||
|
||||
|
|
|
|||
Loading…
Reference in New Issue