Merge branch 'master' of git://factorcode.org/git/factor
commit
86cf61f300
|
@ -8,7 +8,7 @@ sequences system libc alien.strings io.encodings.utf8 ;
|
||||||
|
|
||||||
[ { "blah" 123 } ] [ { "blah" xyz } expand-constants ] unit-test
|
[ { "blah" 123 } ] [ { "blah" xyz } expand-constants ] unit-test
|
||||||
|
|
||||||
: foo ( -- n ) "fdafd" f dlsym [ 123 ] unless* ;
|
: foo ( -- n ) &: fdafd [ 123 ] unless* ;
|
||||||
|
|
||||||
[ 123 ] [ foo ] unit-test
|
[ 123 ] [ foo ] unit-test
|
||||||
|
|
||||||
|
|
|
@ -77,6 +77,11 @@ HELP: C-ENUM:
|
||||||
{ $code "C-ENUM: red green blue ;" ": red 0 ; : green 1 ; : blue 2 ;" }
|
{ $code "C-ENUM: red green blue ;" ": red 0 ; : green 1 ; : blue 2 ;" }
|
||||||
} ;
|
} ;
|
||||||
|
|
||||||
|
HELP: &:
|
||||||
|
{ $syntax "&: symbol" }
|
||||||
|
{ $values { "symbol" "A C library symbol name" } }
|
||||||
|
{ $description "Pushes the address of a symbol named " { $snippet "symbol" } " from the current library, set with " { $link POSTPONE: LIBRARY: } "." } ;
|
||||||
|
|
||||||
HELP: typedef
|
HELP: typedef
|
||||||
{ $values { "old" "a string" } { "new" "a string" } }
|
{ $values { "old" "a string" } { "new" "a string" } }
|
||||||
{ $description "Alises the C type " { $snippet "old" } " under the name " { $snippet "new" } "." }
|
{ $description "Alises the C type " { $snippet "old" } " under the name " { $snippet "new" } "." }
|
||||||
|
|
|
@ -3,7 +3,8 @@
|
||||||
USING: accessors arrays alien alien.c-types alien.structs
|
USING: accessors arrays alien alien.c-types alien.structs
|
||||||
alien.arrays alien.strings kernel math namespaces parser
|
alien.arrays alien.strings kernel math namespaces parser
|
||||||
sequences words quotations math.parser splitting grouping
|
sequences words quotations math.parser splitting grouping
|
||||||
effects assocs combinators lexer strings.parser alien.parser ;
|
effects assocs combinators lexer strings.parser alien.parser
|
||||||
|
fry ;
|
||||||
IN: alien.syntax
|
IN: alien.syntax
|
||||||
|
|
||||||
: DLL" lexer get skip-blank parse-string dlopen parsed ; parsing
|
: DLL" lexer get skip-blank parse-string dlopen parsed ; parsing
|
||||||
|
@ -33,3 +34,7 @@ IN: alien.syntax
|
||||||
dup length
|
dup length
|
||||||
[ [ create-in ] dip 1quotation define ] 2each ;
|
[ [ create-in ] dip 1quotation define ] 2each ;
|
||||||
parsing
|
parsing
|
||||||
|
|
||||||
|
: &:
|
||||||
|
scan "c-library" get
|
||||||
|
'[ _ _ load-library dlsym ] over push-all ; parsing
|
||||||
|
|
|
@ -12,5 +12,6 @@ namespaces eval kernel vocabs.loader io ;
|
||||||
ignore-cli-args? not script get and
|
ignore-cli-args? not script get and
|
||||||
[ run-script ] [ "run" get run ] if*
|
[ run-script ] [ "run" get run ] if*
|
||||||
output-stream get [ stream-flush ] when*
|
output-stream get [ stream-flush ] when*
|
||||||
|
0 exit
|
||||||
] [ print-error 1 exit ] recover
|
] [ print-error 1 exit ] recover
|
||||||
] set-boot-quot
|
] set-boot-quot
|
||||||
|
|
|
@ -7,4 +7,5 @@ io ;
|
||||||
(command-line) parse-command-line
|
(command-line) parse-command-line
|
||||||
"run" get run
|
"run" get run
|
||||||
output-stream get [ stream-flush ] when*
|
output-stream get [ stream-flush ] when*
|
||||||
|
0 exit
|
||||||
] set-boot-quot
|
] set-boot-quot
|
||||||
|
|
|
@ -102,6 +102,8 @@ SYMBOL: bootstrap-time
|
||||||
] if
|
] if
|
||||||
] [
|
] [
|
||||||
drop
|
drop
|
||||||
load-help? off
|
[
|
||||||
"resource:basis/bootstrap/bootstrap-error.factor" run-file
|
load-help? off
|
||||||
|
"resource:basis/bootstrap/bootstrap-error.factor" run-file
|
||||||
|
] with-scope
|
||||||
] recover
|
] recover
|
||||||
|
|
|
@ -1,5 +1,5 @@
|
||||||
USING: debugger quotations help.markup help.syntax strings alien
|
USING: debugger quotations help.markup help.syntax strings alien
|
||||||
core-foundation ;
|
core-foundation core-foundation.strings core-foundation.arrays ;
|
||||||
IN: cocoa.application
|
IN: cocoa.application
|
||||||
|
|
||||||
HELP: <NSString>
|
HELP: <NSString>
|
||||||
|
@ -30,10 +30,6 @@ HELP: cocoa-app
|
||||||
{ $values { "quot" quotation } }
|
{ $values { "quot" quotation } }
|
||||||
{ $description "Initializes Cocoa, calls the quotation, and starts the Cocoa event loop." } ;
|
{ $description "Initializes Cocoa, calls the quotation, and starts the Cocoa event loop." } ;
|
||||||
|
|
||||||
HELP: do-event
|
|
||||||
{ $values { "app" "an " { $snippet "NSApplication" } } { "?" "a boolean" } }
|
|
||||||
{ $description "Processes a pending event in the queue, if any, returning a boolean indicating if there was one. Does not block." } ;
|
|
||||||
|
|
||||||
HELP: add-observer
|
HELP: add-observer
|
||||||
{ $values { "observer" "an " { $snippet "NSObject" } } { "selector" string } { "name" "an " { $snippet "NSString" } } { "object" "an " { $snippet "NSObject" } } }
|
{ $values { "observer" "an " { $snippet "NSObject" } } { "selector" string } { "name" "an " { $snippet "NSString" } } { "object" "an " { $snippet "NSObject" } } }
|
||||||
{ $description "Registers an observer with the " { $snippet "NSNotificationCenter" } " singleton." } ;
|
{ $description "Registers an observer with the " { $snippet "NSNotificationCenter" } " singleton." } ;
|
||||||
|
@ -52,7 +48,6 @@ HELP: objc-error
|
||||||
ARTICLE: "cocoa-application-utils" "Cocoa application utilities"
|
ARTICLE: "cocoa-application-utils" "Cocoa application utilities"
|
||||||
"Utilities:"
|
"Utilities:"
|
||||||
{ $subsection NSApp }
|
{ $subsection NSApp }
|
||||||
{ $subsection do-event }
|
|
||||||
{ $subsection add-observer }
|
{ $subsection add-observer }
|
||||||
{ $subsection remove-observer }
|
{ $subsection remove-observer }
|
||||||
{ $subsection install-delegate }
|
{ $subsection install-delegate }
|
||||||
|
|
|
@ -1,7 +1,8 @@
|
||||||
! Copyright (C) 2006, 2008 Slava Pestov
|
! Copyright (C) 2006, 2008 Slava Pestov
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
USING: alien alien.syntax io kernel namespaces core-foundation
|
USING: alien alien.syntax io kernel namespaces core-foundation
|
||||||
core-foundation.run-loop cocoa.messages cocoa cocoa.classes
|
core-foundation.arrays core-foundation.data
|
||||||
|
core-foundation.strings cocoa.messages cocoa cocoa.classes
|
||||||
cocoa.runtime sequences threads init summary kernel.private
|
cocoa.runtime sequences threads init summary kernel.private
|
||||||
assocs ;
|
assocs ;
|
||||||
IN: cocoa.application
|
IN: cocoa.application
|
||||||
|
@ -34,13 +35,6 @@ FUNCTION: void NSBeep ( ) ;
|
||||||
: with-cocoa ( quot -- )
|
: with-cocoa ( quot -- )
|
||||||
[ NSApp drop call ] with-autorelease-pool ; inline
|
[ NSApp drop call ] with-autorelease-pool ; inline
|
||||||
|
|
||||||
: next-event ( app -- event )
|
|
||||||
NSAnyEventMask f CFRunLoopDefaultMode 1
|
|
||||||
-> nextEventMatchingMask:untilDate:inMode:dequeue: ;
|
|
||||||
|
|
||||||
: do-event ( app -- ? )
|
|
||||||
dup next-event [ dupd -> sendEvent: -> updateWindows t ] [ drop f ] if* ;
|
|
||||||
|
|
||||||
: add-observer ( observer selector name object -- )
|
: add-observer ( observer selector name object -- )
|
||||||
[
|
[
|
||||||
[ NSNotificationCenter -> defaultCenter ] 2dip
|
[ NSNotificationCenter -> defaultCenter ] 2dip
|
||||||
|
|
|
@ -2,8 +2,8 @@
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
USING: compiler io kernel cocoa.runtime cocoa.subclassing
|
USING: compiler io kernel cocoa.runtime cocoa.subclassing
|
||||||
cocoa.messages cocoa.types sequences words vocabs parser
|
cocoa.messages cocoa.types sequences words vocabs parser
|
||||||
core-foundation namespaces assocs hashtables compiler.units
|
core-foundation.bundles namespaces assocs hashtables
|
||||||
lexer init ;
|
compiler.units lexer init ;
|
||||||
IN: cocoa
|
IN: cocoa
|
||||||
|
|
||||||
: (remember-send) ( selector variable -- )
|
: (remember-send) ( selector variable -- )
|
||||||
|
|
|
@ -1,7 +1,8 @@
|
||||||
! Copyright (C) 2006, 2008 Slava Pestov
|
! Copyright (C) 2006, 2008 Slava Pestov
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
USING: kernel cocoa cocoa.messages cocoa.classes
|
USING: kernel cocoa cocoa.messages cocoa.classes
|
||||||
cocoa.application sequences splitting core-foundation ;
|
cocoa.application sequences splitting core-foundation
|
||||||
|
core-foundation.strings ;
|
||||||
IN: cocoa.dialogs
|
IN: cocoa.dialogs
|
||||||
|
|
||||||
: <NSOpenPanel> ( -- panel )
|
: <NSOpenPanel> ( -- panel )
|
||||||
|
|
|
@ -1,5 +1,8 @@
|
||||||
USING: cocoa.application cocoa.messages cocoa.classes cocoa.runtime
|
! Copyright (C) 2008 Slava Pestov.
|
||||||
kernel cocoa core-foundation alien.c-types ;
|
! 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 ;
|
||||||
IN: cocoa.nibs
|
IN: cocoa.nibs
|
||||||
|
|
||||||
: load-nib ( name -- )
|
: load-nib ( name -- )
|
||||||
|
|
|
@ -1,8 +1,8 @@
|
||||||
! Copyright (C) 2006, 2008 Slava Pestov.
|
! Copyright (C) 2006, 2008 Slava Pestov.
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
USING: alien.accessors arrays kernel cocoa.messages
|
USING: alien.accessors arrays kernel cocoa.messages
|
||||||
cocoa.classes cocoa.application cocoa core-foundation sequences
|
cocoa.classes cocoa.application sequences cocoa core-foundation
|
||||||
;
|
core-foundation.strings core-foundation.arrays ;
|
||||||
IN: cocoa.pasteboard
|
IN: cocoa.pasteboard
|
||||||
|
|
||||||
: NSStringPboardType "NSStringPboardType" ;
|
: NSStringPboardType "NSStringPboardType" ;
|
||||||
|
|
|
@ -3,7 +3,7 @@
|
||||||
USING: strings arrays hashtables assocs sequences
|
USING: strings arrays hashtables assocs sequences
|
||||||
cocoa.messages cocoa.classes cocoa.application cocoa kernel
|
cocoa.messages cocoa.classes cocoa.application cocoa kernel
|
||||||
namespaces io.backend math cocoa.enumeration byte-arrays
|
namespaces io.backend math cocoa.enumeration byte-arrays
|
||||||
combinators alien.c-types core-foundation ;
|
combinators alien.c-types core-foundation core-foundation.data ;
|
||||||
IN: cocoa.plists
|
IN: cocoa.plists
|
||||||
|
|
||||||
GENERIC: >plist ( value -- plist )
|
GENERIC: >plist ( value -- plist )
|
||||||
|
|
|
@ -55,10 +55,9 @@ PRIVATE>
|
||||||
: with-multisample ( quot -- )
|
: with-multisample ( quot -- )
|
||||||
t +multisample+ pick with-variable ; inline
|
t +multisample+ pick with-variable ; inline
|
||||||
|
|
||||||
: <PixelFormat> ( -- pixelfmt )
|
: <PixelFormat> ( attributes -- pixelfmt )
|
||||||
NSOpenGLPixelFormat -> alloc [
|
NSOpenGLPixelFormat -> alloc swap [
|
||||||
NSOpenGLPFAWindow ,
|
%
|
||||||
NSOpenGLPFADoubleBuffer ,
|
|
||||||
NSOpenGLPFADepthSize , 16 ,
|
NSOpenGLPFADepthSize , 16 ,
|
||||||
+software-renderer+ get [
|
+software-renderer+ get [
|
||||||
NSOpenGLPFARendererID , kCGLRendererGenericFloatID ,
|
NSOpenGLPFARendererID , kCGLRendererGenericFloatID ,
|
||||||
|
@ -74,7 +73,8 @@ PRIVATE>
|
||||||
-> autorelease ;
|
-> autorelease ;
|
||||||
|
|
||||||
: <GLView> ( class dim -- view )
|
: <GLView> ( class dim -- view )
|
||||||
[ -> alloc 0 0 ] dip first2 <NSRect> <PixelFormat>
|
[ -> alloc 0 0 ] dip first2 <NSRect>
|
||||||
|
NSOpenGLPFAWindow NSOpenGLPFADoubleBuffer 2array <PixelFormat>
|
||||||
-> initWithFrame:pixelFormat:
|
-> initWithFrame:pixelFormat:
|
||||||
dup 1 -> setPostsBoundsChangedNotifications:
|
dup 1 -> setPostsBoundsChangedNotifications:
|
||||||
dup 1 -> setPostsFrameChangedNotifications: ;
|
dup 1 -> setPostsFrameChangedNotifications: ;
|
||||||
|
|
|
@ -83,14 +83,14 @@ FUNCTION: tiny ffi_test_17 int x ;
|
||||||
|
|
||||||
{ 1 1 } [ indirect-test-1 ] must-infer-as
|
{ 1 1 } [ indirect-test-1 ] must-infer-as
|
||||||
|
|
||||||
[ 3 ] [ "ffi_test_1" f dlsym indirect-test-1 ] unit-test
|
[ 3 ] [ &: ffi_test_1 indirect-test-1 ] unit-test
|
||||||
|
|
||||||
: indirect-test-1' ( ptr -- )
|
: indirect-test-1' ( ptr -- )
|
||||||
"int" { } "cdecl" alien-indirect drop ;
|
"int" { } "cdecl" alien-indirect drop ;
|
||||||
|
|
||||||
{ 1 0 } [ indirect-test-1' ] must-infer-as
|
{ 1 0 } [ indirect-test-1' ] must-infer-as
|
||||||
|
|
||||||
[ ] [ "ffi_test_1" f dlsym indirect-test-1' ] unit-test
|
[ ] [ &: ffi_test_1 indirect-test-1' ] unit-test
|
||||||
|
|
||||||
[ -1 indirect-test-1 ] must-fail
|
[ -1 indirect-test-1 ] must-fail
|
||||||
|
|
||||||
|
@ -100,7 +100,7 @@ FUNCTION: tiny ffi_test_17 int x ;
|
||||||
{ 3 1 } [ indirect-test-2 ] must-infer-as
|
{ 3 1 } [ indirect-test-2 ] must-infer-as
|
||||||
|
|
||||||
[ 5 ]
|
[ 5 ]
|
||||||
[ 2 3 "ffi_test_2" f dlsym indirect-test-2 ]
|
[ 2 3 &: ffi_test_2 indirect-test-2 ]
|
||||||
unit-test
|
unit-test
|
||||||
|
|
||||||
: indirect-test-3 ( a b c d ptr -- result )
|
: indirect-test-3 ( a b c d ptr -- result )
|
||||||
|
|
|
@ -0,0 +1,11 @@
|
||||||
|
USING: help.syntax help.markup arrays alien ;
|
||||||
|
IN: core-foundation.arrays
|
||||||
|
|
||||||
|
HELP: CF>array
|
||||||
|
{ $values { "alien" "a " { $snippet "CFArray" } } { "array" "an array of " { $link alien } " instances" } }
|
||||||
|
{ $description "Creates a Factor array from a Core Foundation array." } ;
|
||||||
|
|
||||||
|
HELP: <CFArray>
|
||||||
|
{ $values { "seq" "a sequence of " { $link alien } " instances" } { "alien" "a " { $snippet "CFArray" } } }
|
||||||
|
{ $description "Creates a Core Foundation array from a Factor array." } ;
|
||||||
|
|
|
@ -0,0 +1,22 @@
|
||||||
|
! Copyright (C) 2008 Slava Pestov.
|
||||||
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
|
USING: alien.syntax kernel sequences ;
|
||||||
|
IN: core-foundation.arrays
|
||||||
|
|
||||||
|
TYPEDEF: void* CFArrayRef
|
||||||
|
|
||||||
|
FUNCTION: CFArrayRef CFArrayCreateMutable ( CFAllocatorRef allocator, CFIndex capacity, void* callbacks ) ;
|
||||||
|
|
||||||
|
FUNCTION: void* CFArrayGetValueAtIndex ( CFArrayRef array, CFIndex idx ) ;
|
||||||
|
|
||||||
|
FUNCTION: void CFArraySetValueAtIndex ( CFArrayRef array, CFIndex index, void* value ) ;
|
||||||
|
|
||||||
|
FUNCTION: CFIndex CFArrayGetCount ( CFArrayRef array ) ;
|
||||||
|
|
||||||
|
: CF>array ( alien -- array )
|
||||||
|
dup CFArrayGetCount [ CFArrayGetValueAtIndex ] with map ;
|
||||||
|
|
||||||
|
: <CFArray> ( seq -- alien )
|
||||||
|
[ f swap length f CFArrayCreateMutable ] keep
|
||||||
|
[ length ] keep
|
||||||
|
[ [ dupd ] dip CFArraySetValueAtIndex ] 2each ;
|
|
@ -0,0 +1,2 @@
|
||||||
|
unportable
|
||||||
|
bindings
|
|
@ -0,0 +1,11 @@
|
||||||
|
USING: help.syntax help.markup ;
|
||||||
|
IN: core-foundation.bundles
|
||||||
|
|
||||||
|
HELP: <CFBundle>
|
||||||
|
{ $values { "string" "a pathname string" } { "bundle" "a " { $snippet "CFBundle" } } }
|
||||||
|
{ $description "Creates a new " { $snippet "CFBundle" } "." } ;
|
||||||
|
|
||||||
|
HELP: load-framework
|
||||||
|
{ $values { "name" "a pathname string" } }
|
||||||
|
{ $description "Loads a Core Foundation framework." } ;
|
||||||
|
|
|
@ -0,0 +1,23 @@
|
||||||
|
! Copyright (C) 2008 Slava Pestov.
|
||||||
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
|
USING: alien.syntax kernel sequences core-foundation
|
||||||
|
core-foundation.urls ;
|
||||||
|
IN: core-foundation.bundles
|
||||||
|
|
||||||
|
TYPEDEF: void* CFBundleRef
|
||||||
|
|
||||||
|
FUNCTION: CFBundleRef CFBundleCreate ( CFAllocatorRef allocator, CFURLRef bundleURL ) ;
|
||||||
|
|
||||||
|
FUNCTION: Boolean CFBundleLoadExecutable ( CFBundleRef bundle ) ;
|
||||||
|
|
||||||
|
: <CFBundle> ( string -- bundle )
|
||||||
|
t <CFFileSystemURL> [
|
||||||
|
f swap CFBundleCreate
|
||||||
|
] keep CFRelease ;
|
||||||
|
|
||||||
|
: load-framework ( name -- )
|
||||||
|
dup <CFBundle> [
|
||||||
|
CFBundleLoadExecutable drop
|
||||||
|
] [
|
||||||
|
"Cannot load bundle named " prepend throw
|
||||||
|
] ?if ;
|
|
@ -0,0 +1,2 @@
|
||||||
|
unportable
|
||||||
|
bindings
|
|
@ -1,42 +1,6 @@
|
||||||
USING: alien strings arrays help.markup help.syntax destructors ;
|
USING: alien strings arrays help.markup help.syntax destructors ;
|
||||||
IN: core-foundation
|
IN: core-foundation
|
||||||
|
|
||||||
HELP: CF>array
|
|
||||||
{ $values { "alien" "a " { $snippet "CFArray" } } { "array" "an array of " { $link alien } " instances" } }
|
|
||||||
{ $description "Creates a Factor array from a Core Foundation array." } ;
|
|
||||||
|
|
||||||
HELP: <CFArray>
|
|
||||||
{ $values { "seq" "a sequence of " { $link alien } " instances" } { "alien" "a " { $snippet "CFArray" } } }
|
|
||||||
{ $description "Creates a Core Foundation array from a Factor array." } ;
|
|
||||||
|
|
||||||
HELP: <CFString>
|
|
||||||
{ $values { "string" string } { "alien" "a " { $snippet "CFString" } } }
|
|
||||||
{ $description "Creates a Core Foundation string from a Factor string." } ;
|
|
||||||
|
|
||||||
HELP: CF>string
|
|
||||||
{ $values { "alien" "a " { $snippet "CFString" } } { "string" string } }
|
|
||||||
{ $description "Creates a Factor string from a Core Foundation string." } ;
|
|
||||||
|
|
||||||
HELP: CF>string-array
|
|
||||||
{ $values { "alien" "a " { $snippet "CFArray" } " of " { $snippet "CFString" } " instances" } { "seq" string } }
|
|
||||||
{ $description "Creates an array of Factor strings from a " { $snippet "CFArray" } " of " { $snippet "CFString" } "s." } ;
|
|
||||||
|
|
||||||
HELP: <CFFileSystemURL>
|
|
||||||
{ $values { "string" "a pathname string" } { "dir?" "a boolean indicating if the pathname is a directory" } { "url" "a " { $snippet "CFURL" } } }
|
|
||||||
{ $description "Creates a new " { $snippet "CFURL" } " pointing to the given local pathname." } ;
|
|
||||||
|
|
||||||
HELP: <CFURL>
|
|
||||||
{ $values { "string" "a URL string" } { "url" "a " { $snippet "CFURL" } } }
|
|
||||||
{ $description "Creates a new " { $snippet "CFURL" } "." } ;
|
|
||||||
|
|
||||||
HELP: <CFBundle>
|
|
||||||
{ $values { "string" "a pathname string" } { "bundle" "a " { $snippet "CFBundle" } } }
|
|
||||||
{ $description "Creates a new " { $snippet "CFBundle" } "." } ;
|
|
||||||
|
|
||||||
HELP: load-framework
|
|
||||||
{ $values { "name" "a pathname string" } }
|
|
||||||
{ $description "Loads a Core Foundation framework." } ;
|
|
||||||
|
|
||||||
HELP: &CFRelease
|
HELP: &CFRelease
|
||||||
{ $values { "alien" "Pointer to a Core Foundation object" } }
|
{ $values { "alien" "Pointer to a Core Foundation object" } }
|
||||||
{ $description "Marks the given Core Foundation object for unconditional release via " { $link CFRelease } " at the end of the enclosing " { $link with-destructors } " scope." } ;
|
{ $description "Marks the given Core Foundation object for unconditional release via " { $link CFRelease } " at the end of the enclosing " { $link with-destructors } " scope." } ;
|
||||||
|
@ -46,24 +10,3 @@ HELP: |CFRelease
|
||||||
{ $description "Marks the given Core Foundation object for release via " { $link CFRelease } " in the event of an error at the end of the enclosing " { $link with-destructors } " scope." } ;
|
{ $description "Marks the given Core Foundation object for release via " { $link CFRelease } " in the event of an error at the end of the enclosing " { $link with-destructors } " scope." } ;
|
||||||
|
|
||||||
{ CFRelease |CFRelease &CFRelease } related-words
|
{ CFRelease |CFRelease &CFRelease } related-words
|
||||||
|
|
||||||
ARTICLE: "core-foundation" "Core foundation utilities"
|
|
||||||
"The " { $vocab-link "core-foundation" } " vocabulary defines bindings for some frequently-used Core Foundation functions. It also provides some utility words."
|
|
||||||
$nl
|
|
||||||
"Strings:"
|
|
||||||
{ $subsection <CFString> }
|
|
||||||
{ $subsection CF>string }
|
|
||||||
"Arrays:"
|
|
||||||
{ $subsection <CFArray> }
|
|
||||||
{ $subsection CF>array }
|
|
||||||
{ $subsection CF>string-array }
|
|
||||||
"URLs:"
|
|
||||||
{ $subsection <CFFileSystemURL> }
|
|
||||||
{ $subsection <CFURL> }
|
|
||||||
"Frameworks:"
|
|
||||||
{ $subsection load-framework }
|
|
||||||
"Memory management:"
|
|
||||||
{ $subsection &CFRelease }
|
|
||||||
{ $subsection |CFRelease } ;
|
|
||||||
|
|
||||||
ABOUT: "core-foundation"
|
|
||||||
|
|
|
@ -1,212 +1,24 @@
|
||||||
! Copyright (C) 2006, 2008 Slava Pestov
|
! Copyright (C) 2006, 2008 Slava Pestov
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
USING: alien alien.c-types alien.strings alien.syntax kernel
|
USING: alien.syntax destructors accessors kernel ;
|
||||||
math sequences io.encodings.utf8 destructors accessors
|
|
||||||
combinators byte-arrays ;
|
|
||||||
IN: core-foundation
|
IN: core-foundation
|
||||||
|
|
||||||
TYPEDEF: void* CFAllocatorRef
|
|
||||||
TYPEDEF: void* CFArrayRef
|
|
||||||
TYPEDEF: void* CFDataRef
|
|
||||||
TYPEDEF: void* CFDictionaryRef
|
|
||||||
TYPEDEF: void* CFMutableDictionaryRef
|
|
||||||
TYPEDEF: void* CFNumberRef
|
|
||||||
TYPEDEF: void* CFBundleRef
|
|
||||||
TYPEDEF: void* CFSetRef
|
|
||||||
TYPEDEF: void* CFStringRef
|
|
||||||
TYPEDEF: void* CFURLRef
|
|
||||||
TYPEDEF: void* CFUUIDRef
|
|
||||||
TYPEDEF: void* CFTypeRef
|
TYPEDEF: void* CFTypeRef
|
||||||
TYPEDEF: void* CFFileDescriptorRef
|
|
||||||
|
TYPEDEF: void* CFAllocatorRef
|
||||||
|
: kCFAllocatorDefault f ; inline
|
||||||
|
|
||||||
TYPEDEF: bool Boolean
|
TYPEDEF: bool Boolean
|
||||||
TYPEDEF: long CFIndex
|
TYPEDEF: long CFIndex
|
||||||
TYPEDEF: int SInt32
|
TYPEDEF: int SInt32
|
||||||
TYPEDEF: uint UInt32
|
TYPEDEF: uint UInt32
|
||||||
TYPEDEF: ulong CFTypeID
|
TYPEDEF: ulong CFTypeID
|
||||||
TYPEDEF: UInt32 CFOptionFlags
|
TYPEDEF: UInt32 CFOptionFlags
|
||||||
TYPEDEF: double CFTimeInterval
|
|
||||||
TYPEDEF: double CFAbsoluteTime
|
|
||||||
TYPEDEF: int CFFileDescriptorNativeDescriptor
|
|
||||||
TYPEDEF: void* CFFileDescriptorCallBack
|
|
||||||
|
|
||||||
TYPEDEF: int CFNumberType
|
|
||||||
: kCFNumberSInt8Type 1 ; inline
|
|
||||||
: kCFNumberSInt16Type 2 ; inline
|
|
||||||
: kCFNumberSInt32Type 3 ; inline
|
|
||||||
: kCFNumberSInt64Type 4 ; inline
|
|
||||||
: kCFNumberFloat32Type 5 ; inline
|
|
||||||
: kCFNumberFloat64Type 6 ; inline
|
|
||||||
: kCFNumberCharType 7 ; inline
|
|
||||||
: kCFNumberShortType 8 ; inline
|
|
||||||
: kCFNumberIntType 9 ; inline
|
|
||||||
: kCFNumberLongType 10 ; inline
|
|
||||||
: kCFNumberLongLongType 11 ; inline
|
|
||||||
: kCFNumberFloatType 12 ; inline
|
|
||||||
: kCFNumberDoubleType 13 ; inline
|
|
||||||
: kCFNumberCFIndexType 14 ; inline
|
|
||||||
: kCFNumberNSIntegerType 15 ; inline
|
|
||||||
: kCFNumberCGFloatType 16 ; inline
|
|
||||||
: kCFNumberMaxType 16 ; inline
|
|
||||||
|
|
||||||
TYPEDEF: int CFPropertyListMutabilityOptions
|
|
||||||
: kCFPropertyListImmutable 0 ; inline
|
|
||||||
: kCFPropertyListMutableContainers 1 ; inline
|
|
||||||
: kCFPropertyListMutableContainersAndLeaves 2 ; inline
|
|
||||||
|
|
||||||
FUNCTION: CFArrayRef CFArrayCreateMutable ( CFAllocatorRef allocator, CFIndex capacity, void* callbacks ) ;
|
|
||||||
|
|
||||||
FUNCTION: void* CFArrayGetValueAtIndex ( CFArrayRef array, CFIndex idx ) ;
|
|
||||||
|
|
||||||
FUNCTION: void CFArraySetValueAtIndex ( CFArrayRef array, CFIndex index, void* value ) ;
|
|
||||||
|
|
||||||
FUNCTION: CFIndex CFArrayGetCount ( CFArrayRef array ) ;
|
|
||||||
|
|
||||||
: kCFURLPOSIXPathStyle 0 ; inline
|
|
||||||
: kCFAllocatorDefault f ; inline
|
|
||||||
|
|
||||||
FUNCTION: CFURLRef CFURLCreateWithFileSystemPath ( CFAllocatorRef allocator, CFStringRef filePath, int pathStyle, Boolean isDirectory ) ;
|
|
||||||
|
|
||||||
FUNCTION: CFURLRef CFURLCreateWithString ( CFAllocatorRef allocator, CFStringRef string, CFURLRef base ) ;
|
|
||||||
|
|
||||||
FUNCTION: CFURLRef CFURLCopyFileSystemPath ( CFURLRef url, int pathStyle ) ;
|
|
||||||
|
|
||||||
TYPEDEF: int CFStringEncoding
|
|
||||||
: kCFStringEncodingMacRoman HEX: 0 ;
|
|
||||||
: kCFStringEncodingWindowsLatin1 HEX: 0500 ;
|
|
||||||
: kCFStringEncodingISOLatin1 HEX: 0201 ;
|
|
||||||
: kCFStringEncodingNextStepLatin HEX: 0B01 ;
|
|
||||||
: kCFStringEncodingASCII HEX: 0600 ;
|
|
||||||
: kCFStringEncodingUnicode HEX: 0100 ;
|
|
||||||
: kCFStringEncodingUTF8 HEX: 08000100 ;
|
|
||||||
: kCFStringEncodingNonLossyASCII HEX: 0BFF ;
|
|
||||||
: kCFStringEncodingUTF16 HEX: 0100 ;
|
|
||||||
: kCFStringEncodingUTF16BE HEX: 10000100 ;
|
|
||||||
: kCFStringEncodingUTF16LE HEX: 14000100 ;
|
|
||||||
: kCFStringEncodingUTF32 HEX: 0c000100 ;
|
|
||||||
: kCFStringEncodingUTF32BE HEX: 18000100 ;
|
|
||||||
: kCFStringEncodingUTF32LE HEX: 1c000100 ;
|
|
||||||
|
|
||||||
FUNCTION: CFStringRef CFStringCreateFromExternalRepresentation (
|
|
||||||
CFAllocatorRef alloc,
|
|
||||||
CFDataRef data,
|
|
||||||
CFStringEncoding encoding
|
|
||||||
) ;
|
|
||||||
|
|
||||||
FUNCTION: CFStringRef CFStringCreateWithBytes (
|
|
||||||
CFAllocatorRef alloc,
|
|
||||||
UInt8* bytes,
|
|
||||||
CFIndex numBytes,
|
|
||||||
CFStringEncoding encoding,
|
|
||||||
Boolean isExternalRepresentation
|
|
||||||
) ;
|
|
||||||
|
|
||||||
FUNCTION: CFIndex CFStringGetLength ( CFStringRef theString ) ;
|
|
||||||
|
|
||||||
FUNCTION: void CFStringGetCharacters ( void* theString, CFIndex start, CFIndex length, void* buffer ) ;
|
|
||||||
|
|
||||||
FUNCTION: Boolean CFStringGetCString (
|
|
||||||
CFStringRef theString,
|
|
||||||
char* buffer,
|
|
||||||
CFIndex bufferSize,
|
|
||||||
CFStringEncoding encoding
|
|
||||||
) ;
|
|
||||||
|
|
||||||
FUNCTION: CFStringRef CFStringCreateWithCString (
|
|
||||||
CFAllocatorRef alloc,
|
|
||||||
char* cStr,
|
|
||||||
CFStringEncoding encoding
|
|
||||||
) ;
|
|
||||||
|
|
||||||
FUNCTION: CFNumberRef CFNumberCreate ( CFAllocatorRef allocator, CFNumberType theType, void* valuePtr ) ;
|
|
||||||
|
|
||||||
FUNCTION: CFDataRef CFDataCreate ( CFAllocatorRef allocator, uchar* bytes, CFIndex length ) ;
|
|
||||||
|
|
||||||
FUNCTION: CFBundleRef CFBundleCreate ( CFAllocatorRef allocator, CFURLRef bundleURL ) ;
|
|
||||||
|
|
||||||
FUNCTION: Boolean CFBundleLoadExecutable ( CFBundleRef bundle ) ;
|
|
||||||
|
|
||||||
FUNCTION: CFTypeRef CFRetain ( CFTypeRef cf ) ;
|
FUNCTION: CFTypeRef CFRetain ( CFTypeRef cf ) ;
|
||||||
|
|
||||||
FUNCTION: void CFRelease ( CFTypeRef cf ) ;
|
FUNCTION: void CFRelease ( CFTypeRef cf ) ;
|
||||||
|
|
||||||
FUNCTION: CFTypeID CFGetTypeID ( CFTypeRef cf ) ;
|
|
||||||
|
|
||||||
: CF>array ( alien -- array )
|
|
||||||
dup CFArrayGetCount [ CFArrayGetValueAtIndex ] with map ;
|
|
||||||
|
|
||||||
: <CFArray> ( seq -- alien )
|
|
||||||
[ f swap length f CFArrayCreateMutable ] keep
|
|
||||||
[ length ] keep
|
|
||||||
[ [ dupd ] dip CFArraySetValueAtIndex ] 2each ;
|
|
||||||
|
|
||||||
: <CFString> ( string -- alien )
|
|
||||||
f swap utf8 string>alien kCFStringEncodingUTF8 CFStringCreateWithCString
|
|
||||||
[ "CFStringCreateWithCString failed" throw ] unless* ;
|
|
||||||
|
|
||||||
: CF>string ( alien -- string )
|
|
||||||
dup CFStringGetLength 4 * 1 + <byte-array> [
|
|
||||||
dup length
|
|
||||||
kCFStringEncodingUTF8
|
|
||||||
CFStringGetCString
|
|
||||||
[ "CFStringGetCString failed" throw ] unless
|
|
||||||
] keep utf8 alien>string ;
|
|
||||||
|
|
||||||
: CF>string-array ( alien -- seq )
|
|
||||||
CF>array [ CF>string ] map ;
|
|
||||||
|
|
||||||
: <CFStringArray> ( seq -- alien )
|
|
||||||
[ <CFString> ] map [ <CFArray> ] [ [ CFRelease ] each ] bi ;
|
|
||||||
|
|
||||||
: <CFFileSystemURL> ( string dir? -- url )
|
|
||||||
[ <CFString> f over kCFURLPOSIXPathStyle ] dip
|
|
||||||
CFURLCreateWithFileSystemPath swap CFRelease ;
|
|
||||||
|
|
||||||
: <CFURL> ( string -- url )
|
|
||||||
<CFString>
|
|
||||||
[ f swap f CFURLCreateWithString ] keep
|
|
||||||
CFRelease ;
|
|
||||||
|
|
||||||
: <CFBundle> ( string -- bundle )
|
|
||||||
t <CFFileSystemURL> [
|
|
||||||
f swap CFBundleCreate
|
|
||||||
] keep CFRelease ;
|
|
||||||
|
|
||||||
GENERIC: <CFNumber> ( number -- alien )
|
|
||||||
|
|
||||||
M: integer <CFNumber>
|
|
||||||
[ f kCFNumberLongLongType ] dip <longlong> CFNumberCreate ;
|
|
||||||
|
|
||||||
M: float <CFNumber>
|
|
||||||
[ f kCFNumberDoubleType ] dip <double> CFNumberCreate ;
|
|
||||||
|
|
||||||
M: t <CFNumber>
|
|
||||||
drop f kCFNumberIntType 1 <int> CFNumberCreate ;
|
|
||||||
|
|
||||||
M: f <CFNumber>
|
|
||||||
drop f kCFNumberIntType 0 <int> CFNumberCreate ;
|
|
||||||
|
|
||||||
: <CFData> ( byte-array -- alien )
|
|
||||||
[ f ] dip dup length CFDataCreate ;
|
|
||||||
|
|
||||||
FUNCTION: CFFileDescriptorRef CFFileDescriptorCreate (
|
|
||||||
CFAllocatorRef allocator,
|
|
||||||
CFFileDescriptorNativeDescriptor fd,
|
|
||||||
Boolean closeOnInvalidate,
|
|
||||||
CFFileDescriptorCallBack callout,
|
|
||||||
CFFileDescriptorContext* context
|
|
||||||
) ;
|
|
||||||
|
|
||||||
FUNCTION: void CFFileDescriptorEnableCallBacks (
|
|
||||||
CFFileDescriptorRef f,
|
|
||||||
CFOptionFlags callBackTypes
|
|
||||||
) ;
|
|
||||||
|
|
||||||
: load-framework ( name -- )
|
|
||||||
dup <CFBundle> [
|
|
||||||
CFBundleLoadExecutable drop
|
|
||||||
] [
|
|
||||||
"Cannot load bundle named " prepend throw
|
|
||||||
] ?if ;
|
|
||||||
|
|
||||||
TUPLE: CFRelease-destructor alien disposed ;
|
TUPLE: CFRelease-destructor alien disposed ;
|
||||||
|
|
||||||
M: CFRelease-destructor dispose* alien>> CFRelease ;
|
M: CFRelease-destructor dispose* alien>> CFRelease ;
|
||||||
|
|
|
@ -0,0 +1,58 @@
|
||||||
|
! Copyright (C) 2008 Joe Groff.
|
||||||
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
|
USING: alien.syntax alien.c-types sequences kernel math ;
|
||||||
|
IN: core-foundation.data
|
||||||
|
|
||||||
|
TYPEDEF: void* CFDataRef
|
||||||
|
TYPEDEF: void* CFDictionaryRef
|
||||||
|
TYPEDEF: void* CFMutableDictionaryRef
|
||||||
|
TYPEDEF: void* CFNumberRef
|
||||||
|
TYPEDEF: void* CFSetRef
|
||||||
|
TYPEDEF: void* CFUUIDRef
|
||||||
|
|
||||||
|
TYPEDEF: int CFNumberType
|
||||||
|
: kCFNumberSInt8Type 1 ; inline
|
||||||
|
: kCFNumberSInt16Type 2 ; inline
|
||||||
|
: kCFNumberSInt32Type 3 ; inline
|
||||||
|
: kCFNumberSInt64Type 4 ; inline
|
||||||
|
: kCFNumberFloat32Type 5 ; inline
|
||||||
|
: kCFNumberFloat64Type 6 ; inline
|
||||||
|
: kCFNumberCharType 7 ; inline
|
||||||
|
: kCFNumberShortType 8 ; inline
|
||||||
|
: kCFNumberIntType 9 ; inline
|
||||||
|
: kCFNumberLongType 10 ; inline
|
||||||
|
: kCFNumberLongLongType 11 ; inline
|
||||||
|
: kCFNumberFloatType 12 ; inline
|
||||||
|
: kCFNumberDoubleType 13 ; inline
|
||||||
|
: kCFNumberCFIndexType 14 ; inline
|
||||||
|
: kCFNumberNSIntegerType 15 ; inline
|
||||||
|
: kCFNumberCGFloatType 16 ; inline
|
||||||
|
: kCFNumberMaxType 16 ; inline
|
||||||
|
|
||||||
|
TYPEDEF: int CFPropertyListMutabilityOptions
|
||||||
|
: kCFPropertyListImmutable 0 ; inline
|
||||||
|
: kCFPropertyListMutableContainers 1 ; inline
|
||||||
|
: kCFPropertyListMutableContainersAndLeaves 2 ; inline
|
||||||
|
|
||||||
|
FUNCTION: CFNumberRef CFNumberCreate ( CFAllocatorRef allocator, CFNumberType theType, void* valuePtr ) ;
|
||||||
|
|
||||||
|
FUNCTION: CFDataRef CFDataCreate ( CFAllocatorRef allocator, uchar* bytes, CFIndex length ) ;
|
||||||
|
|
||||||
|
FUNCTION: CFTypeID CFGetTypeID ( CFTypeRef cf ) ;
|
||||||
|
|
||||||
|
GENERIC: <CFNumber> ( number -- alien )
|
||||||
|
|
||||||
|
M: integer <CFNumber>
|
||||||
|
[ f kCFNumberLongLongType ] dip <longlong> CFNumberCreate ;
|
||||||
|
|
||||||
|
M: float <CFNumber>
|
||||||
|
[ f kCFNumberDoubleType ] dip <double> CFNumberCreate ;
|
||||||
|
|
||||||
|
M: t <CFNumber>
|
||||||
|
drop f kCFNumberIntType 1 <int> CFNumberCreate ;
|
||||||
|
|
||||||
|
M: f <CFNumber>
|
||||||
|
drop f kCFNumberIntType 0 <int> CFNumberCreate ;
|
||||||
|
|
||||||
|
: <CFData> ( byte-array -- alien )
|
||||||
|
[ f ] dip dup length CFDataCreate ;
|
|
@ -0,0 +1,2 @@
|
||||||
|
unportable
|
||||||
|
bindings
|
|
@ -0,0 +1,32 @@
|
||||||
|
! Copyright (C) 2008 Slava Pestov.
|
||||||
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
|
USING: alien.syntax kernel math.bitwise core-foundation ;
|
||||||
|
IN: core-foundation.file-descriptors
|
||||||
|
|
||||||
|
TYPEDEF: void* CFFileDescriptorRef
|
||||||
|
TYPEDEF: int CFFileDescriptorNativeDescriptor
|
||||||
|
TYPEDEF: void* CFFileDescriptorCallBack
|
||||||
|
|
||||||
|
FUNCTION: CFFileDescriptorRef CFFileDescriptorCreate (
|
||||||
|
CFAllocatorRef allocator,
|
||||||
|
CFFileDescriptorNativeDescriptor fd,
|
||||||
|
Boolean closeOnInvalidate,
|
||||||
|
CFFileDescriptorCallBack callout,
|
||||||
|
CFFileDescriptorContext* context
|
||||||
|
) ;
|
||||||
|
|
||||||
|
: kCFFileDescriptorReadCallBack 1 ; inline
|
||||||
|
: kCFFileDescriptorWriteCallBack 2 ; inline
|
||||||
|
|
||||||
|
FUNCTION: void CFFileDescriptorEnableCallBacks (
|
||||||
|
CFFileDescriptorRef f,
|
||||||
|
CFOptionFlags callBackTypes
|
||||||
|
) ;
|
||||||
|
|
||||||
|
: enable-all-callbacks ( fd -- )
|
||||||
|
{ kCFFileDescriptorReadCallBack kCFFileDescriptorWriteCallBack } flags
|
||||||
|
CFFileDescriptorEnableCallBacks ;
|
||||||
|
|
||||||
|
: <CFFileDescriptor> ( fd callback -- handle )
|
||||||
|
[ f swap ] [ t swap ] bi* f CFFileDescriptorCreate
|
||||||
|
[ "CFFileDescriptorCreate failed" throw ] unless* ;
|
|
@ -0,0 +1,2 @@
|
||||||
|
unportable
|
||||||
|
bindings
|
|
@ -2,11 +2,11 @@
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
USING: alien alien.c-types alien.strings alien.syntax kernel
|
USING: alien alien.c-types alien.strings alien.syntax kernel
|
||||||
math sequences namespaces make assocs init accessors
|
math sequences namespaces make assocs init accessors
|
||||||
continuations combinators core-foundation
|
continuations combinators io.encodings.utf8 destructors locals
|
||||||
core-foundation.run-loop core-foundation.run-loop.thread
|
arrays specialized-arrays.direct.alien
|
||||||
io.encodings.utf8 destructors locals arrays
|
specialized-arrays.direct.int specialized-arrays.direct.longlong
|
||||||
specialized-arrays.direct.alien specialized-arrays.direct.int
|
core-foundation core-foundation.run-loop core-foundation.strings
|
||||||
specialized-arrays.direct.longlong ;
|
core-foundation.time ;
|
||||||
IN: core-foundation.fsevents
|
IN: core-foundation.fsevents
|
||||||
|
|
||||||
: kFSEventStreamCreateFlagUseCFTypes 2 ; inline
|
: kFSEventStreamCreateFlagUseCFTypes 2 ; inline
|
||||||
|
@ -118,7 +118,7 @@ FUNCTION: CFStringRef FSEventStreamCopyDescription ( FSEventStreamRef streamRef
|
||||||
FSEventStreamCreate ;
|
FSEventStreamCreate ;
|
||||||
|
|
||||||
: kCFRunLoopCommonModes ( -- string )
|
: kCFRunLoopCommonModes ( -- string )
|
||||||
"kCFRunLoopCommonModes" f dlsym *void* ;
|
&: kCFRunLoopCommonModes *void* ;
|
||||||
|
|
||||||
: schedule-event-stream ( event-stream -- )
|
: schedule-event-stream ( event-stream -- )
|
||||||
CFRunLoopGetMain
|
CFRunLoopGetMain
|
||||||
|
|
|
@ -1,6 +1,10 @@
|
||||||
! Copyright (C) 2008 Slava Pestov
|
! Copyright (C) 2008 Slava Pestov
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
USING: alien alien.syntax core-foundation kernel namespaces ;
|
USING: accessors alien alien.syntax kernel math namespaces
|
||||||
|
sequences destructors combinators threads heaps deques calendar
|
||||||
|
core-foundation core-foundation.strings
|
||||||
|
core-foundation.file-descriptors core-foundation.timers
|
||||||
|
core-foundation.time ;
|
||||||
IN: core-foundation.run-loop
|
IN: core-foundation.run-loop
|
||||||
|
|
||||||
: kCFRunLoopRunFinished 1 ; inline
|
: kCFRunLoopRunFinished 1 ; inline
|
||||||
|
@ -32,6 +36,24 @@ FUNCTION: void CFRunLoopAddSource (
|
||||||
CFStringRef mode
|
CFStringRef mode
|
||||||
) ;
|
) ;
|
||||||
|
|
||||||
|
FUNCTION: void CFRunLoopRemoveSource (
|
||||||
|
CFRunLoopRef rl,
|
||||||
|
CFRunLoopSourceRef source,
|
||||||
|
CFStringRef mode
|
||||||
|
) ;
|
||||||
|
|
||||||
|
FUNCTION: void CFRunLoopAddTimer (
|
||||||
|
CFRunLoopRef rl,
|
||||||
|
CFRunLoopTimerRef timer,
|
||||||
|
CFStringRef mode
|
||||||
|
) ;
|
||||||
|
|
||||||
|
FUNCTION: void CFRunLoopRemoveTimer (
|
||||||
|
CFRunLoopRef rl,
|
||||||
|
CFRunLoopTimerRef timer,
|
||||||
|
CFStringRef mode
|
||||||
|
) ;
|
||||||
|
|
||||||
: CFRunLoopDefaultMode ( -- alien )
|
: CFRunLoopDefaultMode ( -- alien )
|
||||||
#! Ugly, but we don't have static NSStrings
|
#! Ugly, but we don't have static NSStrings
|
||||||
\ CFRunLoopDefaultMode get-global dup expired? [
|
\ CFRunLoopDefaultMode get-global dup expired? [
|
||||||
|
@ -39,3 +61,80 @@ FUNCTION: void CFRunLoopAddSource (
|
||||||
"kCFRunLoopDefaultMode" <CFString>
|
"kCFRunLoopDefaultMode" <CFString>
|
||||||
dup \ CFRunLoopDefaultMode set-global
|
dup \ CFRunLoopDefaultMode set-global
|
||||||
] when ;
|
] when ;
|
||||||
|
|
||||||
|
TUPLE: run-loop fds sources timers ;
|
||||||
|
|
||||||
|
: <run-loop> ( -- run-loop )
|
||||||
|
V{ } clone V{ } clone V{ } clone \ run-loop boa ;
|
||||||
|
|
||||||
|
SYMBOL: expiry-check
|
||||||
|
|
||||||
|
: run-loop ( -- run-loop )
|
||||||
|
\ run-loop get-global not expiry-check get expired? or
|
||||||
|
[
|
||||||
|
31337 <alien> expiry-check set-global
|
||||||
|
<run-loop> dup \ run-loop set-global
|
||||||
|
] [ \ run-loop get-global ] if ;
|
||||||
|
|
||||||
|
: add-source-to-run-loop ( source -- )
|
||||||
|
[ run-loop sources>> push ]
|
||||||
|
[
|
||||||
|
CFRunLoopGetMain
|
||||||
|
swap CFRunLoopDefaultMode
|
||||||
|
CFRunLoopAddSource
|
||||||
|
] bi ;
|
||||||
|
|
||||||
|
: create-fd-source ( CFFileDescriptor -- source )
|
||||||
|
f swap 0 CFFileDescriptorCreateRunLoopSource ;
|
||||||
|
|
||||||
|
: add-fd-to-run-loop ( fd callback -- )
|
||||||
|
[
|
||||||
|
<CFFileDescriptor> |CFRelease
|
||||||
|
[ run-loop fds>> push ]
|
||||||
|
[ create-fd-source |CFRelease add-source-to-run-loop ]
|
||||||
|
bi
|
||||||
|
] with-destructors ;
|
||||||
|
|
||||||
|
: add-timer-to-run-loop ( timer -- )
|
||||||
|
[ run-loop timers>> push ]
|
||||||
|
[
|
||||||
|
CFRunLoopGetMain
|
||||||
|
swap CFRunLoopDefaultMode
|
||||||
|
CFRunLoopAddTimer
|
||||||
|
] bi ;
|
||||||
|
|
||||||
|
<PRIVATE
|
||||||
|
|
||||||
|
: ((reset-timer)) ( timer counter timestamp -- )
|
||||||
|
nip >CFAbsoluteTime CFRunLoopTimerSetNextFireDate ;
|
||||||
|
|
||||||
|
: (reset-timer) ( timer counter -- )
|
||||||
|
yield {
|
||||||
|
{ [ dup 0 = ] [ now ((reset-timer)) ] }
|
||||||
|
{ [ run-queue deque-empty? not ] [ 1- (reset-timer) ] }
|
||||||
|
{ [ sleep-queue heap-empty? ] [ 5 minutes hence ((reset-timer)) ] }
|
||||||
|
[ sleep-queue heap-peek nip micros>timestamp ((reset-timer)) ]
|
||||||
|
} cond ;
|
||||||
|
|
||||||
|
: reset-timer ( timer -- )
|
||||||
|
10 (reset-timer) ;
|
||||||
|
|
||||||
|
PRIVATE>
|
||||||
|
|
||||||
|
: reset-run-loop ( -- )
|
||||||
|
run-loop
|
||||||
|
[ timers>> [ reset-timer ] each ]
|
||||||
|
[ fds>> [ enable-all-callbacks ] each ] bi ;
|
||||||
|
|
||||||
|
: timer-callback ( -- callback )
|
||||||
|
"void" { "CFRunLoopTimerRef" "void*" } "cdecl"
|
||||||
|
[ 2drop reset-run-loop yield ] alien-callback ;
|
||||||
|
|
||||||
|
: init-thread-timer ( -- )
|
||||||
|
timer-callback <CFTimer> add-timer-to-run-loop ;
|
||||||
|
|
||||||
|
: run-one-iteration ( us -- handled? )
|
||||||
|
reset-run-loop
|
||||||
|
CFRunLoopDefaultMode
|
||||||
|
swap [ microseconds ] [ 5 minutes ] if* >CFTimeInterval
|
||||||
|
t CFRunLoopRunInMode kCFRunLoopRunHandledSource = ;
|
||||||
|
|
|
@ -1 +0,0 @@
|
||||||
Vocabulary with init hook for running CoreFoundation event loop
|
|
|
@ -1,16 +0,0 @@
|
||||||
! Copyright (C) 2008 Slava Pestov
|
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
|
||||||
USING: calendar core-foundation.run-loop init kernel threads ;
|
|
||||||
IN: core-foundation.run-loop.thread
|
|
||||||
|
|
||||||
! Load this vocabulary if you need a run loop running.
|
|
||||||
|
|
||||||
: run-loop-thread ( -- )
|
|
||||||
CFRunLoopDefaultMode 0 f CFRunLoopRunInMode
|
|
||||||
kCFRunLoopRunHandledSource = [ 1 seconds sleep ] unless
|
|
||||||
run-loop-thread ;
|
|
||||||
|
|
||||||
: start-run-loop-thread ( -- )
|
|
||||||
[ run-loop-thread t ] "CFRunLoop dispatcher" spawn-server drop ;
|
|
||||||
|
|
||||||
[ start-run-loop-thread ] "core-foundation.run-loop.thread" add-init-hook
|
|
|
@ -0,0 +1,14 @@
|
||||||
|
USING: help.syntax help.markup strings ;
|
||||||
|
IN: core-foundation.strings
|
||||||
|
|
||||||
|
HELP: <CFString>
|
||||||
|
{ $values { "string" string } { "alien" "a " { $snippet "CFString" } } }
|
||||||
|
{ $description "Creates a Core Foundation string from a Factor string." } ;
|
||||||
|
|
||||||
|
HELP: CF>string
|
||||||
|
{ $values { "alien" "a " { $snippet "CFString" } } { "string" string } }
|
||||||
|
{ $description "Creates a Factor string from a Core Foundation string." } ;
|
||||||
|
|
||||||
|
HELP: CF>string-array
|
||||||
|
{ $values { "alien" "a " { $snippet "CFArray" } " of " { $snippet "CFString" } " instances" } { "seq" string } }
|
||||||
|
{ $description "Creates an array of Factor strings from a " { $snippet "CFArray" } " of " { $snippet "CFString" } "s." } ;
|
|
@ -1,6 +1,6 @@
|
||||||
! Copyright (C) 2008 Slava Pestov.
|
! Copyright (C) 2008 Slava Pestov.
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
USING: core-foundation tools.test kernel ;
|
USING: core-foundation.strings core-foundation tools.test kernel ;
|
||||||
IN: core-foundation
|
IN: core-foundation
|
||||||
|
|
||||||
[ ] [ "Hello" <CFString> CFRelease ] unit-test
|
[ ] [ "Hello" <CFString> CFRelease ] unit-test
|
|
@ -0,0 +1,66 @@
|
||||||
|
! Copyright (C) 2008 Slava Pestov.
|
||||||
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
|
USING: alien.syntax alien.strings kernel sequences byte-arrays
|
||||||
|
io.encodings.utf8 math core-foundation core-foundation.arrays ;
|
||||||
|
IN: core-foundation.strings
|
||||||
|
|
||||||
|
TYPEDEF: void* CFStringRef
|
||||||
|
|
||||||
|
TYPEDEF: int CFStringEncoding
|
||||||
|
: kCFStringEncodingMacRoman HEX: 0 ;
|
||||||
|
: kCFStringEncodingWindowsLatin1 HEX: 0500 ;
|
||||||
|
: kCFStringEncodingISOLatin1 HEX: 0201 ;
|
||||||
|
: kCFStringEncodingNextStepLatin HEX: 0B01 ;
|
||||||
|
: kCFStringEncodingASCII HEX: 0600 ;
|
||||||
|
: kCFStringEncodingUnicode HEX: 0100 ;
|
||||||
|
: kCFStringEncodingUTF8 HEX: 08000100 ;
|
||||||
|
: kCFStringEncodingNonLossyASCII HEX: 0BFF ;
|
||||||
|
: kCFStringEncodingUTF16 HEX: 0100 ;
|
||||||
|
: kCFStringEncodingUTF16BE HEX: 10000100 ;
|
||||||
|
: kCFStringEncodingUTF16LE HEX: 14000100 ;
|
||||||
|
: kCFStringEncodingUTF32 HEX: 0c000100 ;
|
||||||
|
: kCFStringEncodingUTF32BE HEX: 18000100 ;
|
||||||
|
: kCFStringEncodingUTF32LE HEX: 1c000100 ;
|
||||||
|
|
||||||
|
FUNCTION: CFStringRef CFStringCreateWithBytes (
|
||||||
|
CFAllocatorRef alloc,
|
||||||
|
UInt8* bytes,
|
||||||
|
CFIndex numBytes,
|
||||||
|
CFStringEncoding encoding,
|
||||||
|
Boolean isExternalRepresentation
|
||||||
|
) ;
|
||||||
|
|
||||||
|
FUNCTION: CFIndex CFStringGetLength ( CFStringRef theString ) ;
|
||||||
|
|
||||||
|
FUNCTION: void CFStringGetCharacters ( void* theString, CFIndex start, CFIndex length, void* buffer ) ;
|
||||||
|
|
||||||
|
FUNCTION: Boolean CFStringGetCString (
|
||||||
|
CFStringRef theString,
|
||||||
|
char* buffer,
|
||||||
|
CFIndex bufferSize,
|
||||||
|
CFStringEncoding encoding
|
||||||
|
) ;
|
||||||
|
|
||||||
|
FUNCTION: CFStringRef CFStringCreateWithCString (
|
||||||
|
CFAllocatorRef alloc,
|
||||||
|
char* cStr,
|
||||||
|
CFStringEncoding encoding
|
||||||
|
) ;
|
||||||
|
|
||||||
|
: <CFString> ( string -- alien )
|
||||||
|
f swap utf8 string>alien kCFStringEncodingUTF8 CFStringCreateWithCString
|
||||||
|
[ "CFStringCreateWithCString failed" throw ] unless* ;
|
||||||
|
|
||||||
|
: CF>string ( alien -- string )
|
||||||
|
dup CFStringGetLength 4 * 1 + <byte-array> [
|
||||||
|
dup length
|
||||||
|
kCFStringEncodingUTF8
|
||||||
|
CFStringGetCString
|
||||||
|
[ "CFStringGetCString failed" throw ] unless
|
||||||
|
] keep utf8 alien>string ;
|
||||||
|
|
||||||
|
: CF>string-array ( alien -- seq )
|
||||||
|
CF>array [ CF>string ] map ;
|
||||||
|
|
||||||
|
: <CFStringArray> ( seq -- alien )
|
||||||
|
[ <CFString> ] map [ <CFArray> ] [ [ CFRelease ] each ] bi ;
|
|
@ -0,0 +1,2 @@
|
||||||
|
unportable
|
||||||
|
bindings
|
|
@ -0,0 +1,14 @@
|
||||||
|
! Copyright (C) 2008 Slava Pestov.
|
||||||
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
|
USING: calendar alien.syntax ;
|
||||||
|
IN: core-foundation.time
|
||||||
|
|
||||||
|
TYPEDEF: double CFTimeInterval
|
||||||
|
TYPEDEF: double CFAbsoluteTime
|
||||||
|
|
||||||
|
: >CFTimeInterval ( duration -- interval )
|
||||||
|
duration>seconds ; inline
|
||||||
|
|
||||||
|
: >CFAbsoluteTime ( timestamp -- time )
|
||||||
|
T{ timestamp { year 2001 } { month 1 } { day 1 } } time-
|
||||||
|
duration>seconds ; inline
|
|
@ -0,0 +1,2 @@
|
||||||
|
unportable
|
||||||
|
bindings
|
|
@ -0,0 +1,35 @@
|
||||||
|
! Copyright (C) 2008 Slava Pestov.
|
||||||
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
|
USING: alien.syntax system math kernel calendar core-foundation
|
||||||
|
core-foundation.time ;
|
||||||
|
IN: core-foundation.timers
|
||||||
|
|
||||||
|
TYPEDEF: void* CFRunLoopTimerRef
|
||||||
|
TYPEDEF: void* CFRunLoopTimerCallBack
|
||||||
|
TYPEDEF: void* CFRunLoopTimerContext
|
||||||
|
|
||||||
|
FUNCTION: CFRunLoopTimerRef CFRunLoopTimerCreate (
|
||||||
|
CFAllocatorRef allocator,
|
||||||
|
CFAbsoluteTime fireDate,
|
||||||
|
CFTimeInterval interval,
|
||||||
|
CFOptionFlags flags,
|
||||||
|
CFIndex order,
|
||||||
|
CFRunLoopTimerCallBack callout,
|
||||||
|
CFRunLoopTimerContext* context
|
||||||
|
) ;
|
||||||
|
|
||||||
|
: <CFTimer> ( callback -- timer )
|
||||||
|
[ f now >CFAbsoluteTime 60 0 0 ] dip f CFRunLoopTimerCreate ;
|
||||||
|
|
||||||
|
FUNCTION: void CFRunLoopTimerInvalidate (
|
||||||
|
CFRunLoopTimerRef timer
|
||||||
|
) ;
|
||||||
|
|
||||||
|
FUNCTION: Boolean CFRunLoopTimerIsValid (
|
||||||
|
CFRunLoopTimerRef timer
|
||||||
|
) ;
|
||||||
|
|
||||||
|
FUNCTION: void CFRunLoopTimerSetNextFireDate (
|
||||||
|
CFRunLoopTimerRef timer,
|
||||||
|
CFAbsoluteTime fireDate
|
||||||
|
) ;
|
|
@ -0,0 +1,2 @@
|
||||||
|
unportable
|
||||||
|
bindings
|
|
@ -0,0 +1,10 @@
|
||||||
|
USING: help.syntax help.markup ;
|
||||||
|
IN: core-foundation.urls
|
||||||
|
|
||||||
|
HELP: <CFFileSystemURL>
|
||||||
|
{ $values { "string" "a pathname string" } { "dir?" "a boolean indicating if the pathname is a directory" } { "url" "a " { $snippet "CFURL" } } }
|
||||||
|
{ $description "Creates a new " { $snippet "CFURL" } " pointing to the given local pathname." } ;
|
||||||
|
|
||||||
|
HELP: <CFURL>
|
||||||
|
{ $values { "string" "a URL string" } { "url" "a " { $snippet "CFURL" } } }
|
||||||
|
{ $description "Creates a new " { $snippet "CFURL" } "." } ;
|
|
@ -0,0 +1,24 @@
|
||||||
|
! Copyright (C) 2008 Slava Pestov.
|
||||||
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
|
USING: alien.syntax kernel core-foundation.strings
|
||||||
|
core-foundation ;
|
||||||
|
IN: core-foundation.urls
|
||||||
|
|
||||||
|
: kCFURLPOSIXPathStyle 0 ; inline
|
||||||
|
|
||||||
|
TYPEDEF: void* CFURLRef
|
||||||
|
|
||||||
|
FUNCTION: CFURLRef CFURLCreateWithFileSystemPath ( CFAllocatorRef allocator, CFStringRef filePath, int pathStyle, Boolean isDirectory ) ;
|
||||||
|
|
||||||
|
FUNCTION: CFURLRef CFURLCreateWithString ( CFAllocatorRef allocator, CFStringRef string, CFURLRef base ) ;
|
||||||
|
|
||||||
|
FUNCTION: CFURLRef CFURLCopyFileSystemPath ( CFURLRef url, int pathStyle ) ;
|
||||||
|
|
||||||
|
: <CFFileSystemURL> ( string dir? -- url )
|
||||||
|
[ <CFString> f over kCFURLPOSIXPathStyle ] dip
|
||||||
|
CFURLCreateWithFileSystemPath swap CFRelease ;
|
||||||
|
|
||||||
|
: <CFURL> ( string -- url )
|
||||||
|
<CFString>
|
||||||
|
[ f swap f CFURLCreateWithString ] keep
|
||||||
|
CFRelease ;
|
|
@ -2,12 +2,13 @@
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
USING: alien alien.c-types alien.strings alien.syntax kernel
|
USING: alien alien.c-types alien.strings alien.syntax kernel
|
||||||
layouts sequences system unix environment io.encodings.utf8
|
layouts sequences system unix environment io.encodings.utf8
|
||||||
unix.utilities vocabs.loader combinators alien.accessors ;
|
unix.utilities vocabs.loader combinators alien.accessors
|
||||||
|
alien.syntax ;
|
||||||
IN: environment.unix
|
IN: environment.unix
|
||||||
|
|
||||||
HOOK: environ os ( -- void* )
|
HOOK: environ os ( -- void* )
|
||||||
|
|
||||||
M: unix environ ( -- void* ) "environ" f dlsym ;
|
M: unix environ ( -- void* ) &: environ ;
|
||||||
|
|
||||||
M: unix os-env ( key -- value ) getenv ;
|
M: unix os-env ( key -- value ) getenv ;
|
||||||
|
|
||||||
|
|
|
@ -7,6 +7,7 @@ math.order hashtables byte-arrays destructors
|
||||||
io.encodings
|
io.encodings
|
||||||
io.encodings.string
|
io.encodings.string
|
||||||
io.encodings.ascii
|
io.encodings.ascii
|
||||||
|
io.encodings.utf8
|
||||||
io.encodings.8-bit
|
io.encodings.8-bit
|
||||||
io.encodings.binary
|
io.encodings.binary
|
||||||
io.streams.duplex
|
io.streams.duplex
|
||||||
|
@ -40,11 +41,11 @@ GENERIC: >post-data ( object -- post-data )
|
||||||
|
|
||||||
M: post-data >post-data ;
|
M: post-data >post-data ;
|
||||||
|
|
||||||
M: string >post-data "application/octet-stream" <post-data> ;
|
M: string >post-data utf8 encode "application/octet-stream" <post-data> ;
|
||||||
|
|
||||||
M: byte-array >post-data "application/octet-stream" <post-data> ;
|
M: byte-array >post-data "application/octet-stream" <post-data> ;
|
||||||
|
|
||||||
M: assoc >post-data assoc>query "application/x-www-form-urlencoded" <post-data> ;
|
M: assoc >post-data assoc>query ascii encode "application/x-www-form-urlencoded" <post-data> ;
|
||||||
|
|
||||||
M: f >post-data ;
|
M: f >post-data ;
|
||||||
|
|
||||||
|
@ -52,12 +53,13 @@ M: f >post-data ;
|
||||||
[ >post-data ] change-post-data ;
|
[ >post-data ] change-post-data ;
|
||||||
|
|
||||||
: write-post-data ( request -- request )
|
: write-post-data ( request -- request )
|
||||||
dup method>> "POST" = [ dup post-data>> raw>> write ] when ;
|
dup method>> [ "POST" = ] [ "PUT" = ] bi or [ dup post-data>> raw>> write ] when ;
|
||||||
|
|
||||||
: write-request ( request -- )
|
: write-request ( request -- )
|
||||||
unparse-post-data
|
unparse-post-data
|
||||||
write-request-line
|
write-request-line
|
||||||
write-request-header
|
write-request-header
|
||||||
|
binary encode-output
|
||||||
write-post-data
|
write-post-data
|
||||||
flush
|
flush
|
||||||
drop ;
|
drop ;
|
||||||
|
@ -153,7 +155,7 @@ SYMBOL: redirects
|
||||||
|
|
||||||
PRIVATE>
|
PRIVATE>
|
||||||
|
|
||||||
: success? ( code -- ? ) 200 = ;
|
: success? ( code -- ? ) 200 299 between? ;
|
||||||
|
|
||||||
ERROR: download-failed response ;
|
ERROR: download-failed response ;
|
||||||
|
|
||||||
|
|
|
@ -143,8 +143,9 @@ HELP: <process-stream>
|
||||||
{ $description "Launches a process and redirects its input and output via a pair of pipes which may be read and written as a stream of the given encoding." } ;
|
{ $description "Launches a process and redirects its input and output via a pair of pipes which may be read and written as a stream of the given encoding." } ;
|
||||||
|
|
||||||
HELP: wait-for-process
|
HELP: wait-for-process
|
||||||
{ $values { "process" process } { "status" integer } }
|
{ $values { "process" process } { "status" object } }
|
||||||
{ $description "If the process is still running, waits for it to exit, otherwise outputs the exit code immediately. Can be called multiple times on the same process." } ;
|
{ $description "If the process is still running, waits for it to exit, otherwise outputs the status code immediately. Can be called multiple times on the same process." }
|
||||||
|
{ $notes "The status code is operating system specific; it may be an integer, or another object (the latter is the case on Unix if the process was killed by a signal). However, one cross-platform behavior code can rely on is that a status code of 0 indicates success." } ;
|
||||||
|
|
||||||
ARTICLE: "io.launcher.descriptors" "Launch descriptors"
|
ARTICLE: "io.launcher.descriptors" "Launch descriptors"
|
||||||
"Words which launch processes can take either a command line string, a sequence of command line arguments, or a " { $link process } "."
|
"Words which launch processes can take either a command line string, a sequence of command line arguments, or a " { $link process } "."
|
||||||
|
|
|
@ -157,7 +157,7 @@ M: process-failed error.
|
||||||
process>> . ;
|
process>> . ;
|
||||||
|
|
||||||
: wait-for-success ( process -- )
|
: wait-for-success ( process -- )
|
||||||
dup wait-for-process dup zero?
|
dup wait-for-process dup 0 =
|
||||||
[ 2drop ] [ process-failed ] if ;
|
[ 2drop ] [ process-failed ] if ;
|
||||||
|
|
||||||
: try-process ( desc -- )
|
: try-process ( desc -- )
|
||||||
|
|
|
@ -1,14 +1,20 @@
|
||||||
! Copyright (C) 2008 Slava Pestov.
|
! Copyright (C) 2008 Slava Pestov.
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
|
USING: threads io.backend namespaces init math kernel ;
|
||||||
IN: io.thread
|
IN: io.thread
|
||||||
USING: threads io.backend namespaces init math ;
|
|
||||||
|
! The Cocoa UI backend stops the I/O thread and takes over
|
||||||
|
! completely.
|
||||||
|
SYMBOL: io-thread-running?
|
||||||
|
|
||||||
: io-thread ( -- )
|
: io-thread ( -- )
|
||||||
sleep-time io-multiplex yield ;
|
sleep-time io-multiplex yield ;
|
||||||
|
|
||||||
: start-io-thread ( -- )
|
: start-io-thread ( -- )
|
||||||
[ io-thread t ]
|
[ [ io-thread-running? get-global ] [ io-thread ] [ ] while ]
|
||||||
"I/O wait" spawn-server
|
"I/O wait" spawn drop ;
|
||||||
\ io-thread set-global ;
|
|
||||||
|
|
||||||
[ start-io-thread ] "io.thread" add-init-hook
|
[
|
||||||
|
t io-thread-running? set-global
|
||||||
|
start-io-thread
|
||||||
|
] "io.thread" add-init-hook
|
||||||
|
|
|
@ -1,11 +1,11 @@
|
||||||
! Copyright (C) 2004, 2008 Slava Pestov.
|
! Copyright (C) 2004, 2008 Slava Pestov.
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
USING: alien alien.c-types generic assocs kernel kernel.private
|
USING: alien alien.c-types alien.syntax generic assocs kernel
|
||||||
math io.ports sequences strings sbufs threads unix
|
kernel.private math io.ports sequences strings sbufs threads
|
||||||
vectors io.buffers io.backend io.encodings math.parser
|
unix vectors io.buffers io.backend io.encodings math.parser
|
||||||
continuations system libc qualified namespaces make io.timeouts
|
continuations system libc qualified namespaces make io.timeouts
|
||||||
io.encodings.utf8 destructors accessors summary combinators
|
io.encodings.utf8 destructors accessors summary combinators
|
||||||
locals unix.time fry ;
|
locals unix.time fry io.unix.multiplexers ;
|
||||||
QUALIFIED: io
|
QUALIFIED: io
|
||||||
IN: io.unix.backend
|
IN: io.unix.backend
|
||||||
|
|
||||||
|
@ -37,38 +37,6 @@ M: fd dispose
|
||||||
|
|
||||||
M: fd handle-fd dup check-disposed fd>> ;
|
M: fd handle-fd dup check-disposed fd>> ;
|
||||||
|
|
||||||
! I/O multiplexers
|
|
||||||
TUPLE: mx fd reads writes ;
|
|
||||||
|
|
||||||
: new-mx ( class -- obj )
|
|
||||||
new
|
|
||||||
H{ } clone >>reads
|
|
||||||
H{ } clone >>writes ; inline
|
|
||||||
|
|
||||||
GENERIC: add-input-callback ( thread fd mx -- )
|
|
||||||
|
|
||||||
M: mx add-input-callback reads>> push-at ;
|
|
||||||
|
|
||||||
GENERIC: add-output-callback ( thread fd mx -- )
|
|
||||||
|
|
||||||
M: mx add-output-callback writes>> push-at ;
|
|
||||||
|
|
||||||
GENERIC: remove-input-callbacks ( fd mx -- callbacks )
|
|
||||||
|
|
||||||
M: mx remove-input-callbacks reads>> delete-at* drop ;
|
|
||||||
|
|
||||||
GENERIC: remove-output-callbacks ( fd mx -- callbacks )
|
|
||||||
|
|
||||||
M: mx remove-output-callbacks writes>> delete-at* drop ;
|
|
||||||
|
|
||||||
GENERIC: wait-for-events ( ms mx -- )
|
|
||||||
|
|
||||||
: input-available ( fd mx -- )
|
|
||||||
reads>> delete-at* drop [ resume ] each ;
|
|
||||||
|
|
||||||
: output-available ( fd mx -- )
|
|
||||||
writes>> delete-at* drop [ resume ] each ;
|
|
||||||
|
|
||||||
M: fd cancel-operation ( fd -- )
|
M: fd cancel-operation ( fd -- )
|
||||||
dup disposed>> [ drop ] [
|
dup disposed>> [ drop ] [
|
||||||
fd>>
|
fd>>
|
||||||
|
@ -184,11 +152,11 @@ M: stdin dispose*
|
||||||
M: stdin refill
|
M: stdin refill
|
||||||
[ buffer>> ] [ dup wait-for-stdin ] bi* refill-stdin f ;
|
[ buffer>> ] [ dup wait-for-stdin ] bi* refill-stdin f ;
|
||||||
|
|
||||||
: control-write-fd ( -- fd ) "control_write" f dlsym *uint ;
|
: control-write-fd ( -- fd ) &: control_write *uint ;
|
||||||
|
|
||||||
: size-read-fd ( -- fd ) "size_read" f dlsym *uint ;
|
: size-read-fd ( -- fd ) &: size_read *uint ;
|
||||||
|
|
||||||
: data-read-fd ( -- fd ) "stdin_read" f dlsym *uint ;
|
: data-read-fd ( -- fd ) &: stdin_read *uint ;
|
||||||
|
|
||||||
: <stdin> ( -- stdin )
|
: <stdin> ( -- stdin )
|
||||||
stdin new
|
stdin new
|
||||||
|
@ -207,10 +175,10 @@ TUPLE: mx-port < port mx ;
|
||||||
: <mx-port> ( mx -- port )
|
: <mx-port> ( mx -- port )
|
||||||
dup fd>> mx-port <port> swap >>mx ;
|
dup fd>> mx-port <port> swap >>mx ;
|
||||||
|
|
||||||
: multiplexer-error ( n -- )
|
: multiplexer-error ( n -- n )
|
||||||
0 < [
|
dup 0 < [
|
||||||
err_no [ EAGAIN = ] [ EINTR = ] bi or
|
err_no [ EAGAIN = ] [ EINTR = ] bi or
|
||||||
[ (io-error) ] unless
|
[ drop 0 ] [ (io-error) ] if
|
||||||
] when ;
|
] when ;
|
||||||
|
|
||||||
: ?flag ( n mask symbol -- n )
|
: ?flag ( n mask symbol -- n )
|
||||||
|
|
|
@ -1,16 +1,12 @@
|
||||||
! Copyright (C) 2008 Slava Pestov.
|
! Copyright (C) 2008 Slava Pestov.
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
IN: io.unix.bsd
|
|
||||||
USING: namespaces system kernel accessors assocs continuations
|
USING: namespaces system kernel accessors assocs continuations
|
||||||
unix io.backend io.unix.backend io.unix.select ;
|
unix io.backend io.unix.backend io.unix.multiplexers
|
||||||
|
io.unix.multiplexers.kqueue ;
|
||||||
|
IN: io.unix.bsd
|
||||||
|
|
||||||
M: bsd init-io ( -- )
|
M: bsd init-io ( -- )
|
||||||
<select-mx> mx set-global ;
|
<kqueue-mx> mx set-global ;
|
||||||
! <kqueue-mx> kqueue-mx set-global
|
|
||||||
! kqueue-mx get-global <mx-port> <mx-task>
|
|
||||||
! dup io-task-fd
|
|
||||||
! [ mx get-global reads>> set-at ]
|
|
||||||
! [ mx get-global writes>> set-at ] 2bi ;
|
|
||||||
|
|
||||||
! M: bsd (monitor) ( path recursive? mailbox -- )
|
! M: bsd (monitor) ( path recursive? mailbox -- )
|
||||||
! swap [ "Recursive kqueue monitors not supported" throw ] when
|
! swap [ "Recursive kqueue monitors not supported" throw ] when
|
||||||
|
|
|
@ -49,7 +49,7 @@ M: epoll-mx remove-output-callbacks ( fd mx -- seq )
|
||||||
|
|
||||||
: wait-event ( mx us -- n )
|
: wait-event ( mx us -- n )
|
||||||
[ [ fd>> ] [ events>> ] bi [ underlying>> ] [ length ] bi ] [ 1000 /i ] bi*
|
[ [ fd>> ] [ events>> ] bi [ underlying>> ] [ length ] bi ] [ 1000 /i ] bi*
|
||||||
epoll_wait dup multiplexer-error ;
|
epoll_wait multiplexer-error ;
|
||||||
|
|
||||||
: handle-event ( event mx -- )
|
: handle-event ( event mx -- )
|
||||||
[ epoll-event-fd ] dip
|
[ epoll-event-fd ] dip
|
||||||
|
|
|
@ -58,8 +58,7 @@ M: kqueue-mx remove-output-callbacks ( fd mx -- seq )
|
||||||
[
|
[
|
||||||
[ fd>> f 0 ]
|
[ fd>> f 0 ]
|
||||||
[ events>> [ underlying>> ] [ length ] bi ] bi
|
[ events>> [ underlying>> ] [ length ] bi ] bi
|
||||||
] dip kevent
|
] dip kevent multiplexer-error ;
|
||||||
dup multiplexer-error ;
|
|
||||||
|
|
||||||
: handle-kevent ( mx kevent -- )
|
: handle-kevent ( mx kevent -- )
|
||||||
[ kevent-ident swap ] [ kevent-filter ] bi {
|
[ kevent-ident swap ] [ kevent-filter ] bi {
|
||||||
|
|
|
@ -2,7 +2,8 @@ IN: io.unix.launcher.tests
|
||||||
USING: io.files tools.test io.launcher arrays io namespaces
|
USING: io.files tools.test io.launcher arrays io namespaces
|
||||||
continuations math io.encodings.binary io.encodings.ascii
|
continuations math io.encodings.binary io.encodings.ascii
|
||||||
accessors kernel sequences io.encodings.utf8 destructors
|
accessors kernel sequences io.encodings.utf8 destructors
|
||||||
io.streams.duplex ;
|
io.streams.duplex locals concurrency.promises threads
|
||||||
|
unix.process ;
|
||||||
|
|
||||||
[ ] [
|
[ ] [
|
||||||
[ "launcher-test-1" temp-file delete-file ] ignore-errors
|
[ "launcher-test-1" temp-file delete-file ] ignore-errors
|
||||||
|
@ -121,3 +122,17 @@ io.streams.duplex ;
|
||||||
input-stream get contents
|
input-stream get contents
|
||||||
] with-stream
|
] with-stream
|
||||||
] unit-test
|
] unit-test
|
||||||
|
|
||||||
|
! Killed processes were exiting with code 0 on FreeBSD
|
||||||
|
[ f ] [
|
||||||
|
[let | p [ <promise> ]
|
||||||
|
s [ <promise> ] |
|
||||||
|
[
|
||||||
|
"sleep 1000" run-detached
|
||||||
|
[ p fulfill ] [ wait-for-process s fulfill ] bi
|
||||||
|
] in-thread
|
||||||
|
|
||||||
|
p ?promise handle>> 9 kill drop
|
||||||
|
s ?promise 0 =
|
||||||
|
]
|
||||||
|
] unit-test
|
||||||
|
|
|
@ -92,14 +92,16 @@ M: unix kill-process* ( pid -- )
|
||||||
processes get swap [ nip swap handle>> = ] curry
|
processes get swap [ nip swap handle>> = ] curry
|
||||||
assoc-find 2drop ;
|
assoc-find 2drop ;
|
||||||
|
|
||||||
|
TUPLE: signal n ;
|
||||||
|
|
||||||
|
: code>status ( code -- obj )
|
||||||
|
dup WIFEXITED [ WEXITSTATUS ] [ WTERMSIG signal boa ] if ;
|
||||||
|
|
||||||
M: unix wait-for-processes ( -- ? )
|
M: unix wait-for-processes ( -- ? )
|
||||||
-1 0 <int> tuck WNOHANG waitpid
|
-1 0 <int> tuck WNOHANG waitpid
|
||||||
dup 0 <= [
|
dup 0 <= [
|
||||||
2drop t
|
2drop t
|
||||||
] [
|
] [
|
||||||
find-process dup [
|
find-process dup
|
||||||
swap *int WEXITSTATUS notify-exit f
|
[ swap *int code>status notify-exit f ] [ 2drop f ] if
|
||||||
] [
|
|
||||||
2drop f
|
|
||||||
] if
|
|
||||||
] if ;
|
] if ;
|
||||||
|
|
|
@ -1,7 +1,7 @@
|
||||||
! Copyright (C) 2008 Slava Pestov.
|
! Copyright (C) 2008 Slava Pestov.
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
USING: kernel io.backend io.monitors io.unix.backend
|
USING: kernel system namespaces io.backend io.unix.backend
|
||||||
io.unix.epoll io.unix.linux.monitors system namespaces ;
|
io.unix.multiplexers io.unix.multiplexers.epoll ;
|
||||||
IN: io.unix.linux
|
IN: io.unix.linux
|
||||||
|
|
||||||
M: linux init-io ( -- )
|
M: linux init-io ( -- )
|
||||||
|
|
|
@ -2,10 +2,10 @@
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
USING: kernel io.backend io.monitors io.monitors.recursive
|
USING: kernel io.backend io.monitors io.monitors.recursive
|
||||||
io.files io.buffers io.monitors io.ports io.timeouts
|
io.files io.buffers io.monitors io.ports io.timeouts
|
||||||
io.unix.backend io.unix.select io.encodings.utf8
|
io.unix.backend io.encodings.utf8 unix.linux.inotify assocs
|
||||||
unix.linux.inotify assocs namespaces make threads continuations
|
namespaces make threads continuations init math math.bitwise
|
||||||
init math math.bitwise sets alien alien.strings alien.c-types
|
sets alien alien.strings alien.c-types vocabs.loader accessors
|
||||||
vocabs.loader accessors system hashtables destructors unix ;
|
system hashtables destructors unix ;
|
||||||
IN: io.unix.linux.monitors
|
IN: io.unix.linux.monitors
|
||||||
|
|
||||||
SYMBOL: watches
|
SYMBOL: watches
|
||||||
|
|
|
@ -1,10 +1,10 @@
|
||||||
! Copyright (C) 2008 Slava Pestov.
|
! Copyright (C) 2008 Slava Pestov.
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
|
USING: io.backend system namespaces io.unix.multiplexers
|
||||||
|
io.unix.multiplexers.run-loop ;
|
||||||
IN: io.unix.macosx
|
IN: io.unix.macosx
|
||||||
USING: io.unix.backend io.unix.bsd io.unix.kqueue io.backend
|
|
||||||
namespaces system ;
|
|
||||||
|
|
||||||
M: macosx init-io ( -- )
|
M: macosx init-io ( -- )
|
||||||
<kqueue-mx> mx set-global ;
|
<run-loop-mx> mx set-global ;
|
||||||
|
|
||||||
macosx set-io-backend
|
macosx set-io-backend
|
||||||
|
|
0
basis/core-foundation/run-loop/thread/authors.txt → basis/io/unix/multiplexers/epoll/authors.txt
Normal file → Executable file
0
basis/core-foundation/run-loop/thread/authors.txt → basis/io/unix/multiplexers/epoll/authors.txt
Normal file → Executable file
|
@ -0,0 +1,66 @@
|
||||||
|
! Copyright (C) 2008 Slava Pestov.
|
||||||
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
|
USING: accessors alien.c-types kernel destructors bit-arrays
|
||||||
|
sequences assocs struct-arrays math namespaces locals fry unix
|
||||||
|
unix.linux.epoll unix.time io.ports io.unix.backend
|
||||||
|
io.unix.multiplexers ;
|
||||||
|
IN: io.unix.multiplexers.epoll
|
||||||
|
|
||||||
|
TUPLE: epoll-mx < mx events ;
|
||||||
|
|
||||||
|
: max-events ( -- n )
|
||||||
|
#! We read up to 256 events at a time. This is an arbitrary
|
||||||
|
#! constant...
|
||||||
|
256 ; inline
|
||||||
|
|
||||||
|
: <epoll-mx> ( -- mx )
|
||||||
|
epoll-mx new-mx
|
||||||
|
max-events epoll_create dup io-error >>fd
|
||||||
|
max-events "epoll-event" <struct-array> >>events ;
|
||||||
|
|
||||||
|
M: epoll-mx dispose fd>> close-file ;
|
||||||
|
|
||||||
|
: make-event ( fd events -- event )
|
||||||
|
"epoll-event" <c-object>
|
||||||
|
[ set-epoll-event-events ] keep
|
||||||
|
[ set-epoll-event-fd ] keep ;
|
||||||
|
|
||||||
|
:: do-epoll-ctl ( fd mx what events -- )
|
||||||
|
mx fd>> what fd fd events make-event epoll_ctl io-error ;
|
||||||
|
|
||||||
|
: do-epoll-add ( fd mx events -- )
|
||||||
|
EPOLL_CTL_ADD swap EPOLLONESHOT bitor do-epoll-ctl ;
|
||||||
|
|
||||||
|
: do-epoll-del ( fd mx events -- )
|
||||||
|
EPOLL_CTL_DEL swap do-epoll-ctl ;
|
||||||
|
|
||||||
|
M: epoll-mx add-input-callback ( thread fd mx -- )
|
||||||
|
[ EPOLLIN do-epoll-add ] [ call-next-method ] 2bi ;
|
||||||
|
|
||||||
|
M: epoll-mx add-output-callback ( thread fd mx -- )
|
||||||
|
[ EPOLLOUT do-epoll-add ] [ call-next-method ] 2bi ;
|
||||||
|
|
||||||
|
M: epoll-mx remove-input-callbacks ( fd mx -- seq )
|
||||||
|
2dup reads>> key? [
|
||||||
|
[ call-next-method ] [ EPOLLIN do-epoll-del ] 2bi
|
||||||
|
] [ 2drop f ] if ;
|
||||||
|
|
||||||
|
M: epoll-mx remove-output-callbacks ( fd mx -- seq )
|
||||||
|
2dup writes>> key? [
|
||||||
|
[ EPOLLOUT do-epoll-del ] [ call-next-method ] 2bi
|
||||||
|
] [ 2drop f ] if ;
|
||||||
|
|
||||||
|
: wait-event ( mx us -- n )
|
||||||
|
[ [ fd>> ] [ events>> ] bi [ underlying>> ] [ length ] bi ] [ 1000 /i ] bi*
|
||||||
|
epoll_wait multiplexer-error ;
|
||||||
|
|
||||||
|
: handle-event ( event mx -- )
|
||||||
|
[ epoll-event-fd ] dip
|
||||||
|
[ EPOLLIN EPOLLOUT bitor do-epoll-del ]
|
||||||
|
[ input-available ] [ output-available ] 2tri ;
|
||||||
|
|
||||||
|
: handle-events ( mx n -- )
|
||||||
|
[ dup events>> ] dip head-slice swap '[ _ handle-event ] each ;
|
||||||
|
|
||||||
|
M: epoll-mx wait-for-events ( us mx -- )
|
||||||
|
swap 60000000 or dupd wait-event handle-events ;
|
|
@ -0,0 +1 @@
|
||||||
|
Slava Pestov
|
|
@ -0,0 +1,76 @@
|
||||||
|
! Copyright (C) 2008 Slava Pestov.
|
||||||
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
|
USING: accessors alien.c-types combinators destructors
|
||||||
|
io.unix.backend kernel math.bitwise sequences struct-arrays unix
|
||||||
|
unix.kqueue unix.time assocs io.unix.multiplexers ;
|
||||||
|
IN: io.unix.multiplexers.kqueue
|
||||||
|
|
||||||
|
TUPLE: kqueue-mx < mx events ;
|
||||||
|
|
||||||
|
: max-events ( -- n )
|
||||||
|
#! We read up to 256 events at a time. This is an arbitrary
|
||||||
|
#! constant...
|
||||||
|
256 ; inline
|
||||||
|
|
||||||
|
: <kqueue-mx> ( -- mx )
|
||||||
|
kqueue-mx new-mx
|
||||||
|
kqueue dup io-error >>fd
|
||||||
|
max-events "kevent" <struct-array> >>events ;
|
||||||
|
|
||||||
|
M: kqueue-mx dispose fd>> close-file ;
|
||||||
|
|
||||||
|
: make-kevent ( fd filter flags -- event )
|
||||||
|
"kevent" <c-object>
|
||||||
|
[ set-kevent-flags ] keep
|
||||||
|
[ set-kevent-filter ] keep
|
||||||
|
[ set-kevent-ident ] keep ;
|
||||||
|
|
||||||
|
: register-kevent ( kevent mx -- )
|
||||||
|
fd>> swap 1 f 0 f kevent io-error ;
|
||||||
|
|
||||||
|
M: kqueue-mx add-input-callback ( thread fd mx -- )
|
||||||
|
[ call-next-method ] [
|
||||||
|
[ EVFILT_READ { EV_ADD EV_ONESHOT } flags make-kevent ] dip
|
||||||
|
register-kevent
|
||||||
|
] 2bi ;
|
||||||
|
|
||||||
|
M: kqueue-mx add-output-callback ( thread fd mx -- )
|
||||||
|
[ call-next-method ] [
|
||||||
|
[ EVFILT_WRITE { EV_ADD EV_ONESHOT } flags make-kevent ] dip
|
||||||
|
register-kevent
|
||||||
|
] 2bi ;
|
||||||
|
|
||||||
|
M: kqueue-mx remove-input-callbacks ( fd mx -- seq )
|
||||||
|
2dup reads>> key? [
|
||||||
|
[ call-next-method ] [
|
||||||
|
[ EVFILT_READ EV_DELETE make-kevent ] dip
|
||||||
|
register-kevent
|
||||||
|
] 2bi
|
||||||
|
] [ 2drop f ] if ;
|
||||||
|
|
||||||
|
M: kqueue-mx remove-output-callbacks ( fd mx -- seq )
|
||||||
|
2dup writes>> key? [
|
||||||
|
[
|
||||||
|
[ EVFILT_WRITE EV_DELETE make-kevent ] dip
|
||||||
|
register-kevent
|
||||||
|
] [ call-next-method ] 2bi
|
||||||
|
] [ 2drop f ] if ;
|
||||||
|
|
||||||
|
: wait-kevent ( mx timespec -- n )
|
||||||
|
[
|
||||||
|
[ fd>> f 0 ]
|
||||||
|
[ events>> [ underlying>> ] [ length ] bi ] bi
|
||||||
|
] dip kevent multiplexer-error ;
|
||||||
|
|
||||||
|
: handle-kevent ( mx kevent -- )
|
||||||
|
[ kevent-ident swap ] [ kevent-filter ] bi {
|
||||||
|
{ EVFILT_READ [ input-available ] }
|
||||||
|
{ EVFILT_WRITE [ output-available ] }
|
||||||
|
} case ;
|
||||||
|
|
||||||
|
: handle-kevents ( mx n -- )
|
||||||
|
[ dup events>> ] dip head-slice [ handle-kevent ] with each ;
|
||||||
|
|
||||||
|
M: kqueue-mx wait-for-events ( us mx -- )
|
||||||
|
swap dup [ make-timespec ] when
|
||||||
|
dupd wait-kevent handle-kevents ;
|
|
@ -0,0 +1 @@
|
||||||
|
unportable
|
|
@ -0,0 +1,35 @@
|
||||||
|
! Copyright (C) 2008 Slava Pestov.
|
||||||
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
|
USING: kernel accessors assocs sequences threads ;
|
||||||
|
IN: io.unix.multiplexers
|
||||||
|
|
||||||
|
TUPLE: mx fd reads writes ;
|
||||||
|
|
||||||
|
: new-mx ( class -- obj )
|
||||||
|
new
|
||||||
|
H{ } clone >>reads
|
||||||
|
H{ } clone >>writes ; inline
|
||||||
|
|
||||||
|
GENERIC: add-input-callback ( thread fd mx -- )
|
||||||
|
|
||||||
|
M: mx add-input-callback reads>> push-at ;
|
||||||
|
|
||||||
|
GENERIC: add-output-callback ( thread fd mx -- )
|
||||||
|
|
||||||
|
M: mx add-output-callback writes>> push-at ;
|
||||||
|
|
||||||
|
GENERIC: remove-input-callbacks ( fd mx -- callbacks )
|
||||||
|
|
||||||
|
M: mx remove-input-callbacks reads>> delete-at* drop ;
|
||||||
|
|
||||||
|
GENERIC: remove-output-callbacks ( fd mx -- callbacks )
|
||||||
|
|
||||||
|
M: mx remove-output-callbacks writes>> delete-at* drop ;
|
||||||
|
|
||||||
|
GENERIC: wait-for-events ( ms mx -- )
|
||||||
|
|
||||||
|
: input-available ( fd mx -- )
|
||||||
|
reads>> delete-at* drop [ resume ] each ;
|
||||||
|
|
||||||
|
: output-available ( fd mx -- )
|
||||||
|
writes>> delete-at* drop [ resume ] each ;
|
|
@ -0,0 +1,33 @@
|
||||||
|
! Copyright (C) 2008 Slava Pestov.
|
||||||
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
|
USING: kernel arrays namespaces math accessors alien locals
|
||||||
|
destructors system threads io.unix.multiplexers
|
||||||
|
io.unix.multiplexers.kqueue core-foundation
|
||||||
|
core-foundation.run-loop ;
|
||||||
|
IN: io.unix.multiplexers.run-loop
|
||||||
|
|
||||||
|
TUPLE: run-loop-mx kqueue-mx ;
|
||||||
|
|
||||||
|
: file-descriptor-callback ( -- callback )
|
||||||
|
"void" { "CFFileDescriptorRef" "CFOptionFlags" "void*" }
|
||||||
|
"cdecl" [
|
||||||
|
3drop
|
||||||
|
0 mx get kqueue-mx>> wait-for-events
|
||||||
|
reset-run-loop
|
||||||
|
yield
|
||||||
|
] alien-callback ;
|
||||||
|
|
||||||
|
: <run-loop-mx> ( -- mx )
|
||||||
|
[
|
||||||
|
<kqueue-mx> |dispose
|
||||||
|
dup fd>> file-descriptor-callback add-fd-to-run-loop
|
||||||
|
run-loop-mx boa
|
||||||
|
] with-destructors ;
|
||||||
|
|
||||||
|
M: run-loop-mx add-input-callback kqueue-mx>> add-input-callback ;
|
||||||
|
M: run-loop-mx add-output-callback kqueue-mx>> add-output-callback ;
|
||||||
|
M: run-loop-mx remove-input-callbacks kqueue-mx>> remove-input-callbacks ;
|
||||||
|
M: run-loop-mx remove-output-callbacks kqueue-mx>> remove-output-callbacks ;
|
||||||
|
|
||||||
|
M: run-loop-mx wait-for-events ( us mx -- )
|
||||||
|
swap run-one-iteration [ 0 swap wait-for-events ] [ drop ] if ;
|
|
@ -0,0 +1 @@
|
||||||
|
unportable
|
|
@ -0,0 +1 @@
|
||||||
|
Slava Pestov
|
|
@ -0,0 +1,56 @@
|
||||||
|
! Copyright (C) 2004, 2008 Slava Pestov.
|
||||||
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
|
USING: alien.c-types kernel bit-arrays sequences assocs unix
|
||||||
|
math namespaces accessors math.order locals unix.time fry
|
||||||
|
io.ports io.unix.backend io.unix.multiplexers ;
|
||||||
|
IN: io.unix.multiplexers.select
|
||||||
|
|
||||||
|
TUPLE: select-mx < mx read-fdset write-fdset ;
|
||||||
|
|
||||||
|
! Factor's bit-arrays are an array of bytes, OS X expects
|
||||||
|
! FD_SET to be an array of cells, so we have to account for
|
||||||
|
! byte order differences on big endian platforms
|
||||||
|
: munge ( i -- i' )
|
||||||
|
little-endian? [ BIN: 11000 bitxor ] unless ; inline
|
||||||
|
|
||||||
|
: <select-mx> ( -- mx )
|
||||||
|
select-mx new-mx
|
||||||
|
FD_SETSIZE 8 * <bit-array> >>read-fdset
|
||||||
|
FD_SETSIZE 8 * <bit-array> >>write-fdset ;
|
||||||
|
|
||||||
|
: clear-nth ( n seq -- ? )
|
||||||
|
[ nth ] [ [ f ] 2dip set-nth ] 2bi ;
|
||||||
|
|
||||||
|
:: check-fd ( fd fdset mx quot -- )
|
||||||
|
fd munge fdset clear-nth [ fd mx quot call ] when ; inline
|
||||||
|
|
||||||
|
: check-fdset ( fds fdset mx quot -- )
|
||||||
|
[ check-fd ] 3curry each ; inline
|
||||||
|
|
||||||
|
: init-fdset ( fds fdset -- )
|
||||||
|
'[ t swap munge _ set-nth ] each ;
|
||||||
|
|
||||||
|
: read-fdset/tasks ( mx -- seq fdset )
|
||||||
|
[ reads>> keys ] [ read-fdset>> ] bi ;
|
||||||
|
|
||||||
|
: write-fdset/tasks ( mx -- seq fdset )
|
||||||
|
[ writes>> keys ] [ write-fdset>> ] bi ;
|
||||||
|
|
||||||
|
: max-fd ( assoc -- n )
|
||||||
|
dup assoc-empty? [ drop 0 ] [ keys supremum ] if ;
|
||||||
|
|
||||||
|
: num-fds ( mx -- n )
|
||||||
|
[ reads>> max-fd ] [ writes>> max-fd ] bi max 1+ ;
|
||||||
|
|
||||||
|
: init-fdsets ( mx -- nfds read write except )
|
||||||
|
[ num-fds ]
|
||||||
|
[ read-fdset/tasks [ init-fdset ] [ underlying>> ] bi ]
|
||||||
|
[ write-fdset/tasks [ init-fdset ] [ underlying>> ] bi ] tri
|
||||||
|
f ;
|
||||||
|
|
||||||
|
M:: select-mx wait-for-events ( us mx -- )
|
||||||
|
mx
|
||||||
|
[ init-fdsets us dup [ make-timeval ] when select multiplexer-error drop ]
|
||||||
|
[ [ read-fdset/tasks ] keep [ input-available ] check-fdset ]
|
||||||
|
[ [ write-fdset/tasks ] keep [ output-available ] check-fdset ]
|
||||||
|
tri ;
|
|
@ -0,0 +1 @@
|
||||||
|
unportable
|
|
@ -50,7 +50,7 @@ TUPLE: select-mx < mx read-fdset write-fdset ;
|
||||||
|
|
||||||
M:: select-mx wait-for-events ( us mx -- )
|
M:: select-mx wait-for-events ( us mx -- )
|
||||||
mx
|
mx
|
||||||
[ init-fdsets us dup [ make-timeval ] when select multiplexer-error ]
|
[ init-fdsets us dup [ make-timeval ] when select multiplexer-error drop ]
|
||||||
[ [ read-fdset/tasks ] keep [ input-available ] check-fdset ]
|
[ [ read-fdset/tasks ] keep [ input-available ] check-fdset ]
|
||||||
[ [ write-fdset/tasks ] keep [ output-available ] check-fdset ]
|
[ [ write-fdset/tasks ] keep [ output-available ] check-fdset ]
|
||||||
tri ;
|
tri ;
|
||||||
|
|
|
@ -2,8 +2,8 @@
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
USING: kernel opengl.gl alien.c-types continuations namespaces
|
USING: kernel opengl.gl alien.c-types continuations namespaces
|
||||||
assocs alien alien.strings libc opengl math sequences combinators
|
assocs alien alien.strings libc opengl math sequences combinators
|
||||||
combinators.lib macros arrays io.encodings.ascii fry
|
macros arrays io.encodings.ascii fry specialized-arrays.uint
|
||||||
specialized-arrays.uint destructors accessors ;
|
destructors accessors ;
|
||||||
IN: opengl.shaders
|
IN: opengl.shaders
|
||||||
|
|
||||||
: with-gl-shader-source-ptr ( string quot -- )
|
: with-gl-shader-source-ptr ( string quot -- )
|
|
@ -61,12 +61,6 @@ TUPLE: alien-callback-params < alien-node-params quot xt ;
|
||||||
! Quotation which coerces return value to required type
|
! Quotation which coerces return value to required type
|
||||||
return-prep-quot infer-quot-here ;
|
return-prep-quot infer-quot-here ;
|
||||||
|
|
||||||
! Callbacks are registered in a global hashtable. If you clear
|
|
||||||
! this hashtable, they will all be blown away by code GC, beware
|
|
||||||
SYMBOL: callbacks
|
|
||||||
|
|
||||||
[ H{ } clone callbacks set-global ] "alien.compiler" add-init-hook
|
|
||||||
|
|
||||||
: register-callback ( word -- ) callbacks get conjoin ;
|
: register-callback ( word -- ) callbacks get conjoin ;
|
||||||
|
|
||||||
: callback-bottom ( params -- )
|
: callback-bottom ( params -- )
|
||||||
|
|
|
@ -107,3 +107,8 @@ M: quit-responder call-responder*
|
||||||
"tools.deploy.test.8" shake-and-bake
|
"tools.deploy.test.8" shake-and-bake
|
||||||
run-temp-image
|
run-temp-image
|
||||||
] unit-test
|
] unit-test
|
||||||
|
|
||||||
|
[ ] [
|
||||||
|
"tools.deploy.test.9" shake-and-bake
|
||||||
|
run-temp-image
|
||||||
|
] unit-test
|
||||||
|
|
|
@ -365,6 +365,7 @@ SYMBOL: deploy-vocab
|
||||||
init-hooks get values concat %
|
init-hooks get values concat %
|
||||||
,
|
,
|
||||||
strip-io? [ \ flush , ] unless
|
strip-io? [ \ flush , ] unless
|
||||||
|
[ 0 exit ] %
|
||||||
] [ ] make
|
] [ ] make
|
||||||
set-boot-quot ;
|
set-boot-quot ;
|
||||||
|
|
||||||
|
|
|
@ -19,12 +19,8 @@ IN: cocoa.application
|
||||||
|
|
||||||
[ [ die ] 19 setenv ] "cocoa.application" add-init-hook
|
[ [ die ] 19 setenv ] "cocoa.application" add-init-hook
|
||||||
|
|
||||||
"stop-after-last-window?" get
|
|
||||||
|
|
||||||
H{ } clone \ pool [
|
H{ } clone \ pool [
|
||||||
global [
|
global [
|
||||||
"stop-after-last-window?" "ui" lookup set
|
|
||||||
|
|
||||||
! Only keeps those methods that we actually call
|
! Only keeps those methods that we actually call
|
||||||
sent-messages get super-sent-messages get assoc-union
|
sent-messages get super-sent-messages get assoc-union
|
||||||
objc-methods [ assoc-intersect pool-values ] change
|
objc-methods [ assoc-intersect pool-values ] change
|
||||||
|
|
|
@ -1,14 +1,15 @@
|
||||||
USING: tools.deploy.config ;
|
USING: tools.deploy.config ;
|
||||||
H{
|
H{
|
||||||
{ deploy-threads? t }
|
{ deploy-unicode? f }
|
||||||
{ deploy-c-types? f }
|
|
||||||
{ deploy-ui? f }
|
|
||||||
{ deploy-word-props? f }
|
|
||||||
{ deploy-word-defs? f }
|
|
||||||
{ deploy-math? t }
|
|
||||||
{ deploy-io 3 }
|
|
||||||
{ deploy-name "tools.deploy.test.3" }
|
{ deploy-name "tools.deploy.test.3" }
|
||||||
{ deploy-compiler? t }
|
{ deploy-ui? f }
|
||||||
{ deploy-reflection 1 }
|
|
||||||
{ "stop-after-last-window?" t }
|
{ "stop-after-last-window?" t }
|
||||||
|
{ deploy-word-defs? f }
|
||||||
|
{ deploy-reflection 1 }
|
||||||
|
{ deploy-compiler? t }
|
||||||
|
{ deploy-threads? t }
|
||||||
|
{ deploy-io 3 }
|
||||||
|
{ deploy-math? t }
|
||||||
|
{ deploy-word-props? f }
|
||||||
|
{ deploy-c-types? f }
|
||||||
}
|
}
|
||||||
|
|
|
@ -0,0 +1,10 @@
|
||||||
|
USING: alien kernel math ;
|
||||||
|
IN: tools.deploy.test.9
|
||||||
|
|
||||||
|
: callback-test ( -- callback )
|
||||||
|
"int" { "int" } "cdecl" [ 1 + ] alien-callback ;
|
||||||
|
|
||||||
|
: indirect-test ( -- )
|
||||||
|
10 callback-test "int" { "int" } "cdecl" alien-indirect 11 assert= ;
|
||||||
|
|
||||||
|
MAIN: indirect-test
|
|
@ -0,0 +1,15 @@
|
||||||
|
USING: tools.deploy.config ;
|
||||||
|
H{
|
||||||
|
{ deploy-unicode? f }
|
||||||
|
{ deploy-name "tools.deploy.test.9" }
|
||||||
|
{ deploy-ui? f }
|
||||||
|
{ "stop-after-last-window?" t }
|
||||||
|
{ deploy-word-defs? f }
|
||||||
|
{ deploy-reflection 1 }
|
||||||
|
{ deploy-compiler? t }
|
||||||
|
{ deploy-threads? f }
|
||||||
|
{ deploy-io 1 }
|
||||||
|
{ deploy-math? t }
|
||||||
|
{ deploy-word-props? f }
|
||||||
|
{ deploy-c-types? f }
|
||||||
|
}
|
|
@ -3,11 +3,11 @@ USING: help.markup help.syntax sequences.private ;
|
||||||
|
|
||||||
HELP: disassemble
|
HELP: disassemble
|
||||||
{ $values { "obj" "a word or a pair of addresses" } }
|
{ $values { "obj" "a word or a pair of addresses" } }
|
||||||
{ $description "Disassembles either a compiled word definition or an arbitrary memory range (in the case " { $snippet "obj" } " is a pair of integers) by attaching " { $snippet "gdb" } " to the Factor VM and capturing the output." }
|
{ $description "Disassembles either a compiled word definition or an arbitrary memory range (in the case " { $snippet "obj" } " is a pair of integers)." }
|
||||||
{ $notes "In some cases the Factor compiler emits data inline with code, which can confuse " { $snippet "gdb" } ". This occurs in words which call " { $link dispatch } ", where the jump table addresses are compiled inline. Also on the ARM architecture, various pointers are often compiled inline, and the preceeding instruction jumps over the inline pinter." } ;
|
{ $notes "In some cases the Factor compiler emits data inline with code, which can confuse the disassembler. This occurs in words which call " { $link dispatch } ", where the jump table addresses are compiled inline." } ;
|
||||||
|
|
||||||
ARTICLE: "tools.disassembler" "Disassembling words"
|
ARTICLE: "tools.disassembler" "Disassembling words"
|
||||||
"The " { $vocab-link "tools.disassembler" } " vocabulary integrates Factor with the GNU debugger (" { $snippet "gdb" } ") for viewing the assembly code generated by the compiler. It can be used on both Unix and Windows as long as a working copy of " { $snippet "gdb" } " is installed and available in the " { $snippet "PATH" } "."
|
"The " { $vocab-link "tools.disassembler" } " vocabulary provides support for disassembling compiled word definitions. It uses the " { $snippet "libudis86" } " library on x86-32 and x86-64, and " { $snippet "gdb" } " on PowerPC."
|
||||||
{ $subsection disassemble } ;
|
{ $subsection disassemble } ;
|
||||||
|
|
||||||
ABOUT: "tools.disassembler"
|
ABOUT: "tools.disassembler"
|
||||||
|
|
|
@ -1,43 +1,24 @@
|
||||||
! Copyright (C) 2008 Slava Pestov, Jorge Acereda Macia.
|
! Copyright (C) 2008 Slava Pestov.
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
USING: io.files io words alien kernel math.parser alien.syntax
|
USING: tr arrays sequences io words generic system combinators
|
||||||
io.launcher system assocs arrays sequences namespaces make
|
vocabs.loader kernel ;
|
||||||
qualified system math compiler.codegen.fixup
|
|
||||||
io.encodings.ascii accessors generic tr ;
|
|
||||||
IN: tools.disassembler
|
IN: tools.disassembler
|
||||||
|
|
||||||
: in-file ( -- path ) "gdb-in.txt" temp-file ;
|
GENERIC: disassemble ( obj -- )
|
||||||
|
|
||||||
: out-file ( -- path ) "gdb-out.txt" temp-file ;
|
SYMBOL: disassembler-backend
|
||||||
|
|
||||||
GENERIC: make-disassemble-cmd ( obj -- )
|
HOOK: disassemble* disassembler-backend ( from to -- lines )
|
||||||
|
|
||||||
M: word make-disassemble-cmd
|
|
||||||
word-xt code-format - 2array make-disassemble-cmd ;
|
|
||||||
|
|
||||||
M: pair make-disassemble-cmd
|
|
||||||
in-file ascii [
|
|
||||||
"attach " write
|
|
||||||
current-process-handle number>string print
|
|
||||||
"disassemble " write
|
|
||||||
[ number>string write bl ] each
|
|
||||||
] with-file-writer ;
|
|
||||||
|
|
||||||
M: method-spec make-disassemble-cmd
|
|
||||||
first2 method make-disassemble-cmd ;
|
|
||||||
|
|
||||||
: gdb-binary ( -- string ) "gdb" ;
|
|
||||||
|
|
||||||
: run-gdb ( -- lines )
|
|
||||||
<process>
|
|
||||||
+closed+ >>stdin
|
|
||||||
out-file >>stdout
|
|
||||||
[ gdb-binary , "-x" , in-file , "-batch" , ] { } make >>command
|
|
||||||
try-process
|
|
||||||
out-file ascii file-lines ;
|
|
||||||
|
|
||||||
TR: tabs>spaces "\t" "\s" ;
|
TR: tabs>spaces "\t" "\s" ;
|
||||||
|
|
||||||
: disassemble ( obj -- )
|
M: pair disassemble first2 disassemble* [ tabs>spaces print ] each ;
|
||||||
make-disassemble-cmd run-gdb
|
|
||||||
[ tabs>spaces ] map [ print ] each ;
|
M: word disassemble word-xt 2array disassemble ;
|
||||||
|
|
||||||
|
M: method-spec disassemble first2 method disassemble ;
|
||||||
|
|
||||||
|
cpu x86? os unix? and
|
||||||
|
"tools.disassembler.udis"
|
||||||
|
"tools.disassembler.gdb" ?
|
||||||
|
require
|
||||||
|
|
|
@ -0,0 +1,36 @@
|
||||||
|
! Copyright (C) 2008 Slava Pestov, Jorge Acereda Macia.
|
||||||
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
|
USING: io.files io words alien kernel math.parser alien.syntax
|
||||||
|
io.launcher system assocs arrays sequences namespaces make
|
||||||
|
qualified system math io.encodings.ascii accessors
|
||||||
|
tools.disassembler ;
|
||||||
|
IN: tools.disassembler.gdb
|
||||||
|
|
||||||
|
SINGLETON: gdb-disassembler
|
||||||
|
|
||||||
|
: in-file ( -- path ) "gdb-in.txt" temp-file ;
|
||||||
|
|
||||||
|
: out-file ( -- path ) "gdb-out.txt" temp-file ;
|
||||||
|
|
||||||
|
: make-disassemble-cmd ( from to -- )
|
||||||
|
in-file ascii [
|
||||||
|
"attach " write
|
||||||
|
current-process-handle number>string print
|
||||||
|
"disassemble " write
|
||||||
|
[ number>string write bl ] bi@
|
||||||
|
] with-file-writer ;
|
||||||
|
|
||||||
|
: gdb-binary ( -- string ) "gdb" ;
|
||||||
|
|
||||||
|
: run-gdb ( -- lines )
|
||||||
|
<process>
|
||||||
|
+closed+ >>stdin
|
||||||
|
out-file >>stdout
|
||||||
|
[ gdb-binary , "-x" , in-file , "-batch" , ] { } make >>command
|
||||||
|
try-process
|
||||||
|
out-file ascii file-lines ;
|
||||||
|
|
||||||
|
M: gdb-disassembler disassemble*
|
||||||
|
make-disassemble-cmd run-gdb ;
|
||||||
|
|
||||||
|
gdb-disassembler disassembler-backend set-global
|
|
@ -0,0 +1 @@
|
||||||
|
unportable
|
|
@ -0,0 +1 @@
|
||||||
|
unportable
|
|
@ -0,0 +1,89 @@
|
||||||
|
! Copyright (C) 2008 Slava Pestov, Jorge Acereda Macia.
|
||||||
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
|
USING: tools.disassembler namespaces combinators
|
||||||
|
alien alien.syntax alien.c-types lexer parser kernel
|
||||||
|
sequences layouts math math.parser system make fry arrays ;
|
||||||
|
IN: tools.disassembler.udis
|
||||||
|
|
||||||
|
<<
|
||||||
|
"libudis86" {
|
||||||
|
{ [ os macosx? ] [ "libudis86.0.dylib" ] }
|
||||||
|
{ [ os unix? ] [ "libudis86.so.0" ] }
|
||||||
|
{ [ os winnt? ] [ "libudis86.dll" ] }
|
||||||
|
} cond "cdecl" add-library
|
||||||
|
>>
|
||||||
|
|
||||||
|
LIBRARY: libudis86
|
||||||
|
|
||||||
|
TYPEDEF: char[592] ud
|
||||||
|
|
||||||
|
FUNCTION: void ud_translate_intel ( ud* u ) ;
|
||||||
|
FUNCTION: void ud_translate_att ( ud* u ) ;
|
||||||
|
|
||||||
|
: UD_SYN_INTEL &: ud_translate_intel ; inline
|
||||||
|
: UD_SYN_ATT &: ud_translate_att ; inline
|
||||||
|
: UD_EOI -1 ; inline
|
||||||
|
: UD_INP_CACHE_SZ 32 ; inline
|
||||||
|
: UD_VENDOR_AMD 0 ; inline
|
||||||
|
: UD_VENDOR_INTEL 1 ; inline
|
||||||
|
|
||||||
|
FUNCTION: void ud_init ( ud* u ) ;
|
||||||
|
FUNCTION: void ud_set_mode ( ud* u, uint8_t mode ) ;
|
||||||
|
FUNCTION: void ud_set_pc ( ud* u, ulonglong pc ) ;
|
||||||
|
FUNCTION: void ud_set_input_buffer ( ud* u, uint8_t* offset, size_t size ) ;
|
||||||
|
FUNCTION: void ud_set_vendor ( ud* u, uint vendor ) ;
|
||||||
|
FUNCTION: void ud_set_syntax ( ud* u, void* syntax ) ;
|
||||||
|
FUNCTION: void ud_input_skip ( ud* u, size_t size ) ;
|
||||||
|
FUNCTION: int ud_input_end ( ud* u ) ;
|
||||||
|
FUNCTION: uint ud_decode ( ud* u ) ;
|
||||||
|
FUNCTION: uint ud_disassemble ( ud* u ) ;
|
||||||
|
FUNCTION: char* ud_insn_asm ( ud* u ) ;
|
||||||
|
FUNCTION: void* ud_insn_ptr ( ud* u ) ;
|
||||||
|
FUNCTION: ulonglong ud_insn_off ( ud* u ) ;
|
||||||
|
FUNCTION: char* ud_insn_hex ( ud* u ) ;
|
||||||
|
FUNCTION: uint ud_insn_len ( ud* u ) ;
|
||||||
|
FUNCTION: char* ud_lookup_mnemonic ( int c ) ;
|
||||||
|
|
||||||
|
: <ud> ( -- ud )
|
||||||
|
"ud" <c-object>
|
||||||
|
dup ud_init
|
||||||
|
dup cell-bits ud_set_mode
|
||||||
|
dup UD_SYN_INTEL ud_set_syntax ;
|
||||||
|
|
||||||
|
SINGLETON: udis-disassembler
|
||||||
|
|
||||||
|
: buf/len ( from to -- buf len ) [ drop <alien> ] [ swap - ] 2bi ;
|
||||||
|
|
||||||
|
: format-disassembly ( lines -- lines' )
|
||||||
|
dup [ second length ] map supremum
|
||||||
|
'[
|
||||||
|
[
|
||||||
|
[ first >hex cell 2 * CHAR: 0 pad-left % ": " % ]
|
||||||
|
[ second _ CHAR: \s pad-right % " " % ]
|
||||||
|
[ third % ]
|
||||||
|
tri
|
||||||
|
] "" make
|
||||||
|
] map ;
|
||||||
|
|
||||||
|
: (disassemble) ( ud -- lines )
|
||||||
|
[
|
||||||
|
dup '[
|
||||||
|
_ ud_disassemble 0 =
|
||||||
|
[ f ] [
|
||||||
|
_
|
||||||
|
[ ud_insn_off ]
|
||||||
|
[ ud_insn_hex ]
|
||||||
|
[ ud_insn_asm ]
|
||||||
|
tri 3array , t
|
||||||
|
] if
|
||||||
|
] loop
|
||||||
|
] { } make ;
|
||||||
|
|
||||||
|
M: udis-disassembler disassemble* ( from to -- buffer )
|
||||||
|
[ <ud> ] 2dip {
|
||||||
|
[ drop ud_set_pc ]
|
||||||
|
[ buf/len ud_set_input_buffer ]
|
||||||
|
[ 2drop (disassemble) format-disassembly ]
|
||||||
|
} 3cleave ;
|
||||||
|
|
||||||
|
udis-disassembler disassembler-backend set-global
|
|
@ -5,8 +5,6 @@ IN: ui.backend
|
||||||
|
|
||||||
SYMBOL: ui-backend
|
SYMBOL: ui-backend
|
||||||
|
|
||||||
HOOK: do-events ui-backend ( -- )
|
|
||||||
|
|
||||||
HOOK: set-title ui-backend ( string world -- )
|
HOOK: set-title ui-backend ( string world -- )
|
||||||
|
|
||||||
HOOK: set-fullscreen* ui-backend ( ? world -- )
|
HOOK: set-fullscreen* ui-backend ( ? world -- )
|
||||||
|
@ -17,11 +15,17 @@ HOOK: (open-window) ui-backend ( world -- )
|
||||||
|
|
||||||
HOOK: (close-window) ui-backend ( handle -- )
|
HOOK: (close-window) ui-backend ( handle -- )
|
||||||
|
|
||||||
|
HOOK: (open-offscreen-buffer) ui-backend ( world -- )
|
||||||
|
|
||||||
|
HOOK: (close-offscreen-buffer) ui-backend ( handle -- )
|
||||||
|
|
||||||
HOOK: raise-window* ui-backend ( world -- )
|
HOOK: raise-window* ui-backend ( world -- )
|
||||||
|
|
||||||
HOOK: select-gl-context ui-backend ( handle -- )
|
GENERIC: select-gl-context ( handle -- )
|
||||||
|
|
||||||
HOOK: flush-gl-context ui-backend ( handle -- )
|
GENERIC: flush-gl-context ( handle -- )
|
||||||
|
|
||||||
|
HOOK: offscreen-pixels ui-backend ( world -- alien w h )
|
||||||
|
|
||||||
HOOK: beep ui-backend ( -- )
|
HOOK: beep ui-backend ( -- )
|
||||||
|
|
||||||
|
|
|
@ -3,21 +3,22 @@
|
||||||
USING: accessors math arrays assocs cocoa cocoa.application
|
USING: accessors math arrays assocs cocoa cocoa.application
|
||||||
command-line kernel memory namespaces cocoa.messages
|
command-line kernel memory namespaces cocoa.messages
|
||||||
cocoa.runtime cocoa.subclassing cocoa.pasteboard cocoa.types
|
cocoa.runtime cocoa.subclassing cocoa.pasteboard cocoa.types
|
||||||
cocoa.windows cocoa.classes cocoa.application cocoa.nibs
|
cocoa.windows cocoa.classes cocoa.nibs sequences system ui
|
||||||
sequences system ui ui.backend ui.clipboards ui.gadgets
|
ui.backend ui.clipboards ui.gadgets ui.gadgets.worlds
|
||||||
ui.gadgets.worlds ui.cocoa.views core-foundation threads
|
ui.cocoa.views core-foundation core-foundation.run-loop threads
|
||||||
math.geometry.rect fry ;
|
math.geometry.rect fry libc generalizations alien.c-types
|
||||||
|
cocoa.views combinators io.thread ;
|
||||||
IN: ui.cocoa
|
IN: ui.cocoa
|
||||||
|
|
||||||
TUPLE: handle view window ;
|
TUPLE: handle ;
|
||||||
|
TUPLE: window-handle < handle view window ;
|
||||||
|
TUPLE: offscreen-handle < handle context buffer ;
|
||||||
|
|
||||||
C: <handle> handle
|
C: <window-handle> window-handle
|
||||||
|
C: <offscreen-handle> offscreen-handle
|
||||||
|
|
||||||
SINGLETON: cocoa-ui-backend
|
SINGLETON: cocoa-ui-backend
|
||||||
|
|
||||||
M: cocoa-ui-backend do-events ( -- )
|
|
||||||
[ NSApp '[ _ do-event ] loop ui-wait ] with-autorelease-pool ;
|
|
||||||
|
|
||||||
TUPLE: pasteboard handle ;
|
TUPLE: pasteboard handle ;
|
||||||
|
|
||||||
C: <pasteboard> pasteboard
|
C: <pasteboard> pasteboard
|
||||||
|
@ -39,7 +40,8 @@ M: pasteboard set-clipboard-contents
|
||||||
: gadget-window ( world -- )
|
: gadget-window ( world -- )
|
||||||
dup <FactorView>
|
dup <FactorView>
|
||||||
2dup swap world>NSRect <ViewWindow>
|
2dup swap world>NSRect <ViewWindow>
|
||||||
[ [ -> release ] [ install-window-delegate ] bi* ] [ <handle> ] 2bi
|
[ [ -> release ] [ install-window-delegate ] bi* ]
|
||||||
|
[ <window-handle> ] 2bi
|
||||||
>>handle drop ;
|
>>handle drop ;
|
||||||
|
|
||||||
M: cocoa-ui-backend set-title ( string world -- )
|
M: cocoa-ui-backend set-title ( string world -- )
|
||||||
|
@ -88,11 +90,39 @@ M: cocoa-ui-backend raise-window* ( world -- )
|
||||||
NSApp 1 -> activateIgnoringOtherApps:
|
NSApp 1 -> activateIgnoringOtherApps:
|
||||||
] when* ;
|
] when* ;
|
||||||
|
|
||||||
M: cocoa-ui-backend select-gl-context ( handle -- )
|
: pixel-size ( pixel-format -- size )
|
||||||
view>> -> openGLContext -> makeCurrentContext ;
|
0 <int> [ NSOpenGLPFAColorSize 0 -> getValues:forAttribute:forVirtualScreen: ]
|
||||||
|
keep *int -3 shift ;
|
||||||
|
|
||||||
M: cocoa-ui-backend flush-gl-context ( handle -- )
|
: offscreen-buffer ( world pixel-format -- alien w h pitch )
|
||||||
view>> -> openGLContext -> flushBuffer ;
|
[ dim>> first2 ] [ pixel-size ] bi*
|
||||||
|
{ [ * * malloc ] [ 2drop ] [ drop nip ] [ nip * ] } 3cleave ;
|
||||||
|
|
||||||
|
: gadget-offscreen-context ( world -- context buffer )
|
||||||
|
NSOpenGLPFAOffScreen 1array <PixelFormat>
|
||||||
|
[ nip NSOpenGLContext -> alloc swap f -> initWithFormat:shareContext: dup ]
|
||||||
|
[ offscreen-buffer ] 2bi
|
||||||
|
4 npick [ -> setOffScreen:width:height:rowbytes: ] dip ;
|
||||||
|
|
||||||
|
M: cocoa-ui-backend (open-offscreen-buffer) ( world -- )
|
||||||
|
dup gadget-offscreen-context <offscreen-handle> >>handle drop ;
|
||||||
|
|
||||||
|
M: cocoa-ui-backend (close-offscreen-buffer) ( handle -- )
|
||||||
|
[ context>> -> release ]
|
||||||
|
[ buffer>> free ] bi ;
|
||||||
|
|
||||||
|
GENERIC: (gl-context) ( handle -- context )
|
||||||
|
M: window-handle (gl-context) view>> -> openGLContext ;
|
||||||
|
M: offscreen-handle (gl-context) context>> ;
|
||||||
|
|
||||||
|
M: handle select-gl-context ( handle -- )
|
||||||
|
(gl-context) -> makeCurrentContext ;
|
||||||
|
|
||||||
|
M: handle flush-gl-context ( handle -- )
|
||||||
|
(gl-context) -> flushBuffer ;
|
||||||
|
|
||||||
|
M: cocoa-ui-backend offscreen-pixels ( world -- alien w h )
|
||||||
|
[ handle>> buffer>> ] [ dim>> first2 neg ] bi ;
|
||||||
|
|
||||||
M: cocoa-ui-backend beep ( -- )
|
M: cocoa-ui-backend beep ( -- )
|
||||||
NSBeep ;
|
NSBeep ;
|
||||||
|
@ -102,8 +132,8 @@ CLASS: {
|
||||||
{ +name+ "FactorApplicationDelegate" }
|
{ +name+ "FactorApplicationDelegate" }
|
||||||
}
|
}
|
||||||
|
|
||||||
{ "applicationDidFinishLaunching:" "void" { "id" "SEL" "id" }
|
{ "applicationDidUpdate:" "void" { "id" "SEL" "id" }
|
||||||
[ 3drop event-loop ]
|
[ 3drop reset-run-loop ]
|
||||||
} ;
|
} ;
|
||||||
|
|
||||||
: install-app-delegate ( -- )
|
: install-app-delegate ( -- )
|
||||||
|
@ -121,6 +151,9 @@ M: cocoa-ui-backend ui
|
||||||
init-clipboard
|
init-clipboard
|
||||||
cocoa-init-hook get call
|
cocoa-init-hook get call
|
||||||
start-ui
|
start-ui
|
||||||
|
f io-thread-running? set-global
|
||||||
|
init-thread-timer
|
||||||
|
reset-run-loop
|
||||||
NSApp -> run
|
NSApp -> run
|
||||||
] ui-running
|
] ui-running
|
||||||
] with-cocoa ;
|
] with-cocoa ;
|
||||||
|
|
|
@ -1,10 +1,10 @@
|
||||||
! Copyright (C) 2006, 2007 Slava Pestov.
|
! Copyright (C) 2006, 2008 Slava Pestov.
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
USING: alien.syntax cocoa cocoa.nibs cocoa.application
|
USING: alien.syntax cocoa cocoa.nibs cocoa.application
|
||||||
cocoa.classes cocoa.dialogs cocoa.pasteboard cocoa.subclassing
|
cocoa.classes cocoa.dialogs cocoa.pasteboard cocoa.subclassing
|
||||||
core-foundation help.topics kernel memory namespaces parser
|
core-foundation core-foundation.strings help.topics kernel
|
||||||
system ui ui.tools.browser ui.tools.listener ui.tools.workspace
|
memory namespaces parser system ui ui.tools.browser
|
||||||
ui.cocoa eval locals ;
|
ui.tools.listener ui.tools.workspace ui.cocoa eval locals ;
|
||||||
IN: ui.cocoa.tools
|
IN: ui.cocoa.tools
|
||||||
|
|
||||||
: finder-run-files ( alien -- )
|
: finder-run-files ( alien -- )
|
||||||
|
|
|
@ -4,7 +4,7 @@ USING: accessors alien alien.c-types arrays assocs cocoa kernel
|
||||||
math cocoa.messages cocoa.subclassing cocoa.classes cocoa.views
|
math cocoa.messages cocoa.subclassing cocoa.classes cocoa.views
|
||||||
cocoa.application cocoa.pasteboard cocoa.types cocoa.windows
|
cocoa.application cocoa.pasteboard cocoa.types cocoa.windows
|
||||||
sequences ui ui.gadgets ui.gadgets.worlds ui.gestures
|
sequences ui ui.gadgets ui.gadgets.worlds ui.gestures
|
||||||
core-foundation threads combinators math.geometry.rect ;
|
core-foundation.strings threads combinators math.geometry.rect ;
|
||||||
IN: ui.cocoa.views
|
IN: ui.cocoa.views
|
||||||
|
|
||||||
: send-mouse-moved ( view event -- )
|
: send-mouse-moved ( view event -- )
|
||||||
|
|
Some files were not shown because too many files have changed in this diff Show More
Loading…
Reference in New Issue