[ { "blah" 123 } ] [ { "blah" xyz } expand-constants ] unit-test
-: foo ( -- n ) "fdafd" f dlsym [ 123 ] unless* ;
+: foo ( -- n ) &: fdafd [ 123 ] unless* ;
[ 123 ] [ foo ] unit-test
{ $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
{ $values { "old" "a string" } { "new" "a string" } }
{ $description "Alises the C type " { $snippet "old" } " under the name " { $snippet "new" } "." }
USING: accessors arrays alien alien.c-types alien.structs
alien.arrays alien.strings kernel math namespaces parser
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
: DLL" lexer get skip-blank parse-string dlopen parsed ; parsing
dup length
[ [ create-in ] dip 1quotation define ] 2each ;
parsing
+
+: &:
+ scan "c-library" get
+ '[ _ _ load-library dlsym ] over push-all ; parsing
] if
] [
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
USING: debugger quotations help.markup help.syntax strings alien
-core-foundation ;
+core-foundation core-foundation.strings core-foundation.arrays ;
IN: cocoa.application
HELP: <NSString>
! Copyright (C) 2006, 2008 Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
USING: alien alien.syntax io kernel namespaces core-foundation
-core-foundation.run-loop cocoa.messages cocoa cocoa.classes
-cocoa.runtime sequences threads init summary kernel.private
-assocs ;
+core-foundation.run-loop core-foundation.arrays
+core-foundation.data core-foundation.strings cocoa.messages
+cocoa cocoa.classes cocoa.runtime sequences threads init summary
+kernel.private assocs ;
IN: cocoa.application
: <NSString> ( str -- alien ) <CFString> -> autorelease ;
! See http://factorcode.org/license.txt for BSD license.
USING: compiler io kernel cocoa.runtime cocoa.subclassing
cocoa.messages cocoa.types sequences words vocabs parser
-core-foundation namespaces assocs hashtables compiler.units
-lexer init ;
+core-foundation.bundles namespaces assocs hashtables
+compiler.units lexer init ;
IN: cocoa
: (remember-send) ( selector variable -- )
! Copyright (C) 2006, 2008 Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
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
: <NSOpenPanel> ( -- panel )
-USING: cocoa.application cocoa.messages cocoa.classes cocoa.runtime
-kernel cocoa core-foundation alien.c-types ;
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: cocoa.application cocoa.messages cocoa.classes
+cocoa.runtime kernel cocoa alien.c-types core-foundation
+core-foundation.arrays ;
IN: cocoa.nibs
: load-nib ( name -- )
! Copyright (C) 2006, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
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
: NSStringPboardType "NSStringPboardType" ;
USING: strings arrays hashtables assocs sequences
cocoa.messages cocoa.classes cocoa.application cocoa kernel
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
GENERIC: >plist ( value -- plist )
: with-multisample ( quot -- )
t +multisample+ pick with-variable ; inline
-: <PixelFormat> ( -- pixelfmt )
- NSOpenGLPixelFormat -> alloc [
- NSOpenGLPFAWindow ,
- NSOpenGLPFADoubleBuffer ,
+: <PixelFormat> ( attributes -- pixelfmt )
+ NSOpenGLPixelFormat -> alloc swap [
+ %
NSOpenGLPFADepthSize , 16 ,
+software-renderer+ get [
NSOpenGLPFARendererID , kCGLRendererGenericFloatID ,
-> autorelease ;
: <GLView> ( class dim -- view )
- [ -> alloc 0 0 ] dip first2 <NSRect> <PixelFormat>
+ [ -> alloc 0 0 ] dip first2 <NSRect>
+ NSOpenGLPFAWindow NSOpenGLPFADoubleBuffer 2array <PixelFormat>
-> initWithFrame:pixelFormat:
dup 1 -> setPostsBoundsChangedNotifications:
dup 1 -> setPostsFrameChangedNotifications: ;
{ 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 -- )
"int" { } "cdecl" alien-indirect drop ;
{ 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
{ 3 1 } [ indirect-test-2 ] must-infer-as
[ 5 ]
-[ 2 3 "ffi_test_2" f dlsym indirect-test-2 ]
+[ 2 3 &: ffi_test_2 indirect-test-2 ]
unit-test
: indirect-test-3 ( a b c d ptr -- result )
--- /dev/null
+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." } ;
+
--- /dev/null
+! 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 ;
--- /dev/null
+unportable
+bindings
--- /dev/null
+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." } ;
+
--- /dev/null
+! 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 ;
--- /dev/null
+unportable
+bindings
USING: alien strings arrays help.markup help.syntax destructors ;
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
{ $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 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
-
-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"
+++ /dev/null
-! Copyright (C) 2008 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: core-foundation tools.test kernel ;
-IN: core-foundation
-
-[ ] [ "Hello" <CFString> CFRelease ] unit-test
-[ "Hello" ] [ "Hello" <CFString> [ CF>string ] [ CFRelease ] bi ] unit-test
-[ "Hello\u003456" ] [ "Hello\u003456" <CFString> [ CF>string ] [ CFRelease ] bi ] unit-test
-[ "Hello\u013456" ] [ "Hello\u013456" <CFString> [ CF>string ] [ CFRelease ] bi ] unit-test
! Copyright (C) 2006, 2008 Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
-USING: alien alien.c-types alien.strings alien.syntax kernel
-math sequences io.encodings.utf8 destructors accessors
-combinators byte-arrays ;
+USING: alien.syntax destructors accessors kernel calendar ;
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* CFFileDescriptorRef
+
+TYPEDEF: void* CFAllocatorRef
+: kCFAllocatorDefault f ; inline
+
TYPEDEF: bool Boolean
TYPEDEF: long CFIndex
TYPEDEF: int SInt32
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: 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 ;
+FUNCTION: void CFRelease ( CFTypeRef cf ) ;
TUPLE: CFRelease-destructor alien disposed ;
: |CFRelease ( alien -- alien )
dup f CFRelease-destructor boa |dispose drop ; inline
+
+: >CFTimeInterval ( duration -- interval )
+ duration>seconds ; inline
+
+: >CFAbsoluteTime ( timestamp -- time )
+ T{ timestamp { year 2001 } { month 1 } { day 1 } } time-
+ duration>seconds ; inline
--- /dev/null
+! 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 ;
--- /dev/null
+unportable
+bindings
--- /dev/null
+! 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* ;
--- /dev/null
+unportable
+bindings
! See http://factorcode.org/license.txt for BSD license.
USING: alien alien.c-types alien.strings alien.syntax kernel
math sequences namespaces make assocs init accessors
-continuations combinators core-foundation
-core-foundation.run-loop core-foundation.run-loop.thread
-io.encodings.utf8 destructors locals arrays
-specialized-arrays.direct.alien specialized-arrays.direct.int
-specialized-arrays.direct.longlong ;
+continuations combinators io.encodings.utf8 destructors locals
+arrays specialized-arrays.direct.alien
+specialized-arrays.direct.int specialized-arrays.direct.longlong
+core-foundation core-foundation.run-loop core-foundation.strings ;
IN: core-foundation.fsevents
: kFSEventStreamCreateFlagUseCFTypes 2 ; inline
FSEventStreamCreate ;
: kCFRunLoopCommonModes ( -- string )
- "kCFRunLoopCommonModes" f dlsym *void* ;
+ &: kCFRunLoopCommonModes *void* ;
: schedule-event-stream ( event-stream -- )
CFRunLoopGetMain
! Copyright (C) 2008 Slava Pestov
! 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 ;
IN: core-foundation.run-loop
: kCFRunLoopRunFinished 1 ; inline
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 )
#! Ugly, but we don't have static NSStrings
\ CFRunLoopDefaultMode get-global dup expired? [
"kCFRunLoopDefaultMode" <CFString>
dup \ CFRunLoopDefaultMode set-global
] 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 = ;
+++ /dev/null
-Slava Pestov
+++ /dev/null
-Vocabulary with init hook for running CoreFoundation event loop
+++ /dev/null
-unportable
+++ /dev/null
-! 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
--- /dev/null
+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." } ;
--- /dev/null
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: core-foundation.strings core-foundation tools.test kernel ;
+IN: core-foundation
+
+[ ] [ "Hello" <CFString> CFRelease ] unit-test
+[ "Hello" ] [ "Hello" <CFString> [ CF>string ] [ CFRelease ] bi ] unit-test
+[ "Hello\u003456" ] [ "Hello\u003456" <CFString> [ CF>string ] [ CFRelease ] bi ] unit-test
+[ "Hello\u013456" ] [ "Hello\u013456" <CFString> [ CF>string ] [ CFRelease ] bi ] unit-test
--- /dev/null
+! 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 ;
--- /dev/null
+unportable
+bindings
--- /dev/null
+unportable
+bindings
--- /dev/null
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: alien.syntax system math kernel core-foundation calendar ;
+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
+) ;
--- /dev/null
+unportable
+bindings
--- /dev/null
+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" } "." } ;
--- /dev/null
+! 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 ;
: shift-arg ( -- reg ) ECX ;
: div-arg ( -- reg ) EAX ;
: mod-arg ( -- reg ) EDX ;
+: arg ( -- reg ) EAX ;
: temp0 ( -- reg ) EAX ;
: temp1 ( -- reg ) EDX ;
: temp2 ( -- reg ) ECX ;
IN: bootstrap.x86
: stack-frame-size ( -- n ) 4 bootstrap-cells ;
+: arg ( -- reg ) RDI ;
<< "resource:basis/cpu/x86/64/bootstrap.factor" parse-file parsed >>
call
IN: bootstrap.x86
: stack-frame-size ( -- n ) 8 bootstrap-cells ;
+: arg ( -- reg ) RCX ;
<< "resource:basis/cpu/x86/64/bootstrap.factor" parse-file parsed >>
call
! Quotations and words
[
! load from stack
- temp0 ds-reg [] MOV
+ arg ds-reg [] MOV
! pop stack
ds-reg bootstrap-cell SUB
! call quotation
- temp0 quot-xt-offset [+] JMP
+ arg quot-xt-offset [+] JMP
] f f f \ (call) define-sub-primitive
[
! See http://factorcode.org/license.txt for BSD license.
USING: alien alien.c-types alien.strings alien.syntax kernel
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
HOOK: environ os ( -- void* )
-M: unix environ ( -- void* ) "environ" f dlsym ;
+M: unix environ ( -- void* ) &: environ ;
M: unix os-env ( key -- value ) getenv ;
io.encodings
io.encodings.string
io.encodings.ascii
+io.encodings.utf8
io.encodings.8-bit
io.encodings.binary
io.streams.duplex
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: 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 ;
[ >post-data ] change-post-data ;
: 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 -- )
unparse-post-data
write-request-line
write-request-header
+ binary encode-output
write-post-data
flush
drop ;
PRIVATE>
-: success? ( code -- ? ) 200 = ;
+: success? ( code -- ? ) 200 299 between? ;
ERROR: download-failed response ;
{ $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
-{ $values { "process" process } { "status" integer } }
-{ $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." } ;
+{ $values { "process" process } { "status" object } }
+{ $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"
"Words which launch processes can take either a command line string, a sequence of command line arguments, or a " { $link process } "."
process>> . ;
: wait-for-success ( process -- )
- dup wait-for-process dup zero?
+ dup wait-for-process dup 0 =
[ 2drop ] [ process-failed ] if ;
: try-process ( desc -- )
! Copyright (C) 2008 Slava Pestov.\r
! See http://factorcode.org/license.txt for BSD license.\r
+USING: threads io.backend namespaces init math kernel ;\r
IN: io.thread\r
-USING: threads io.backend namespaces init math ;\r
+\r
+! The Cocoa UI backend stops the I/O thread and takes over\r
+! completely.\r
+SYMBOL: io-thread-running?\r
\r
: io-thread ( -- )\r
sleep-time io-multiplex yield ;\r
\r
: start-io-thread ( -- )\r
- [ io-thread t ]\r
- "I/O wait" spawn-server\r
- \ io-thread set-global ;\r
+ [ [ io-thread-running? get-global ] [ io-thread ] [ ] while ]\r
+ "I/O wait" spawn drop ;\r
\r
-[ start-io-thread ] "io.thread" add-init-hook\r
+[\r
+ t io-thread-running? set-global\r
+ start-io-thread\r
+] "io.thread" add-init-hook\r
! Copyright (C) 2004, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: alien alien.c-types generic assocs kernel kernel.private
-math io.ports sequences strings sbufs threads unix
-vectors io.buffers io.backend io.encodings math.parser
+USING: alien alien.c-types alien.syntax generic assocs kernel
+kernel.private math io.ports sequences strings sbufs threads
+unix vectors io.buffers io.backend io.encodings math.parser
continuations system libc qualified namespaces make io.timeouts
io.encodings.utf8 destructors accessors summary combinators
-locals unix.time fry ;
+locals unix.time fry io.unix.multiplexers ;
QUALIFIED: io
IN: io.unix.backend
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 -- )
dup disposed>> [ drop ] [
fd>>
M: stdin refill
[ 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 new
: <mx-port> ( mx -- port )
dup fd>> mx-port <port> swap >>mx ;
-: multiplexer-error ( n -- )
- 0 < [
+: multiplexer-error ( n -- n )
+ dup 0 < [
err_no [ EAGAIN = ] [ EINTR = ] bi or
- [ (io-error) ] unless
+ [ drop 0 ] [ (io-error) ] if
] when ;
: ?flag ( n mask symbol -- n )
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-IN: io.unix.bsd
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 ( -- )
- <select-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 ;
+ <kqueue-mx> mx set-global ;
! M: bsd (monitor) ( path recursive? mailbox -- )
! swap [ "Recursive kqueue monitors not supported" throw ] when
: wait-event ( mx us -- n )
[ [ fd>> ] [ events>> ] bi [ underlying>> ] [ length ] bi ] [ 1000 /i ] bi*
- epoll_wait dup multiplexer-error ;
+ epoll_wait multiplexer-error ;
: handle-event ( event mx -- )
[ epoll-event-fd ] dip
USING: accessors alien.c-types alien.syntax combinators
io.backend io.files io.unix.files kernel math system unix
unix.statfs.freebsd unix.statvfs.freebsd unix.getfsstat.freebsd
-sequences grouping alien.strings io.encodings.utf8 ;
+sequences grouping alien.strings io.encodings.utf8
+specialized-arrays.direct.uint arrays ;
IN: io.unix.files.freebsd
TUPLE: freebsd-file-system-info < unix-file-system-info
[ statfs-f_asyncreads >>asyncreads ]
[ statfs-f_namemax >>name-max ]
[ statfs-f_owner >>owner ]
- [ statfs-f_fsid >>id ]
+ [ statfs-f_fsid 2 <direct-uint-array> >array >>id ]
[ statfs-f_fstypename utf8 alien>string >>type ]
[ statfs-f_mntfromname utf8 alien>string >>device-name ]
[ statfs-f_mntonname utf8 alien>string >>mount-point ]
USING: accessors alien.c-types alien.syntax combinators csv
io.backend io.encodings.utf8 io.files io.streams.string
io.unix.files kernel math.order namespaces sequences sorting
-system unix unix.statfs.linux unix.statvfs.linux ;
+system unix unix.statfs.linux unix.statvfs.linux
+specialized-arrays.direct.uint arrays ;
IN: io.unix.files.linux
TUPLE: linux-file-system-info < unix-file-system-info
[ statfs64-f_bavail >>blocks-available ]
[ statfs64-f_files >>files ]
[ statfs64-f_ffree >>files-free ]
- [ statfs64-f_fsid >>id ]
+ [ statfs64-f_fsid 2 <direct-uint-array> >array >>id ]
[ statfs64-f_namelen >>namelen ]
[ statfs64-f_frsize >>preferred-block-size ]
! [ statfs64-f_spare >>spare ]
USING: alien.syntax kernel unix.stat math unix
combinators system io.backend accessors alien.c-types
io.encodings.utf8 alien.strings unix.types io.unix.files
-io.files unix.statvfs.netbsd unix.getfsstat.netbsd
-grouping sequences io.encodings.utf8 ;
+io.files unix.statvfs.netbsd unix.getfsstat.netbsd arrays
+grouping sequences io.encodings.utf8 specialized-arrays.direct.uint ;
IN: io.unix.files.netbsd
TUPLE: netbsd-file-system-info < unix-file-system-info
[ statvfs-f_syncwrites >>sync-writes ]
[ statvfs-f_asyncreads >>async-reads ]
[ statvfs-f_asyncwrites >>async-writes ]
- [ statvfs-f_fsidx >>idx ]
+ [ statvfs-f_fsidx 2 <direct-uint-array> >array >>idx ]
[ statvfs-f_fsid >>id ]
[ statvfs-f_namemax >>name-max ]
[ statvfs-f_owner >>owner ]
USING: accessors alien.c-types alien.strings alien.syntax
combinators io.backend io.files io.unix.files kernel math
sequences system unix unix.getfsstat.openbsd grouping
-unix.statfs.openbsd unix.statvfs.openbsd unix.types ;
+unix.statfs.openbsd unix.statvfs.openbsd unix.types
+specialized-arrays.direct.uint arrays ;
IN: io.unix.files.openbsd
TUPLE: freebsd-file-system-info < unix-file-system-info
[ statfs-f_syncreads >>sync-reads ]
[ statfs-f_asyncwrites >>async-writes ]
[ statfs-f_asyncreads >>async-reads ]
- [ statfs-f_fsid >>id ]
+ [ statfs-f_fsid 2 <direct-uint-array> >array >>id ]
[ statfs-f_namemax >>name-max ]
[ statfs-f_owner >>owner ]
! [ statfs-f_spare >>spare ]
[
[ fd>> f 0 ]
[ events>> [ underlying>> ] [ length ] bi ] bi
- ] dip kevent
- dup multiplexer-error ;
+ ] dip kevent multiplexer-error ;
: handle-kevent ( mx kevent -- )
[ kevent-ident swap ] [ kevent-filter ] bi {
USING: io.files tools.test io.launcher arrays io namespaces
continuations math io.encodings.binary io.encodings.ascii
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
input-stream get contents
] with-stream
] 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
processes get swap [ nip swap handle>> = ] curry
assoc-find 2drop ;
+TUPLE: signal n ;
+
+: code>status ( code -- obj )
+ dup WIFEXITED [ WEXITSTATUS ] [ WTERMSIG signal boa ] if ;
+
M: unix wait-for-processes ( -- ? )
-1 0 <int> tuck WNOHANG waitpid
dup 0 <= [
2drop t
] [
- find-process dup [
- swap *int WEXITSTATUS notify-exit f
- ] [
- 2drop f
- ] if
+ find-process dup
+ [ swap *int code>status notify-exit f ] [ 2drop f ] if
] if ;
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel io.backend io.monitors io.unix.backend
-io.unix.epoll io.unix.linux.monitors system namespaces ;
+USING: kernel system namespaces io.backend io.unix.backend
+io.unix.multiplexers io.unix.multiplexers.epoll ;
IN: io.unix.linux
M: linux init-io ( -- )
! See http://factorcode.org/license.txt for BSD license.
USING: kernel io.backend io.monitors io.monitors.recursive
io.files io.buffers io.monitors io.ports io.timeouts
-io.unix.backend io.unix.select io.encodings.utf8
-unix.linux.inotify assocs namespaces make threads continuations
-init math math.bitwise sets alien alien.strings alien.c-types
-vocabs.loader accessors system hashtables destructors unix ;
+io.unix.backend io.encodings.utf8 unix.linux.inotify assocs
+namespaces make threads continuations init math math.bitwise
+sets alien alien.strings alien.c-types vocabs.loader accessors
+system hashtables destructors unix ;
IN: io.unix.linux.monitors
SYMBOL: watches
! Copyright (C) 2008 Slava Pestov.
! 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
-USING: io.unix.backend io.unix.bsd io.unix.kqueue io.backend
-namespaces system ;
M: macosx init-io ( -- )
- <kqueue-mx> mx set-global ;
+ <run-loop-mx> mx set-global ;
macosx set-io-backend
--- /dev/null
+Slava Pestov
--- /dev/null
+! 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 ;
--- /dev/null
+unportable
--- /dev/null
+Slava Pestov
--- /dev/null
+! 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 ;
--- /dev/null
+unportable
--- /dev/null
+! 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 ;
--- /dev/null
+! 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 ;
--- /dev/null
+unportable
--- /dev/null
+Slava Pestov
--- /dev/null
+! 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 ;
--- /dev/null
+unportable
M:: select-mx wait-for-events ( us 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 ]
[ [ write-fdset/tasks ] keep [ output-available ] check-fdset ]
tri ;
! Quotation which coerces return value to required type
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 ;
: callback-bottom ( params -- )
"tools.deploy.test.8" shake-and-bake\r
run-temp-image\r
] unit-test\r
+\r
+[ ] [\r
+ "tools.deploy.test.9" shake-and-bake\r
+ run-temp-image\r
+] unit-test\r
USING: tools.deploy.config ;
H{
- { deploy-threads? t }
- { deploy-c-types? f }
+ { deploy-unicode? f }
+ { deploy-name "tools.deploy.test.3" }
{ deploy-ui? f }
- { deploy-word-props? f }
+ { "stop-after-last-window?" t }
{ deploy-word-defs? f }
- { deploy-math? t }
- { deploy-io 3 }
- { deploy-name "tools.deploy.test.3" }
- { deploy-compiler? t }
{ deploy-reflection 1 }
- { "stop-after-last-window?" t }
+ { deploy-compiler? t }
+ { deploy-threads? t }
+ { deploy-io 3 }
+ { deploy-math? t }
+ { deploy-word-props? f }
+ { deploy-c-types? f }
}
--- /dev/null
+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
--- /dev/null
+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 }
+}
\r
HELP: disassemble\r
{ $values { "obj" "a word or a pair of addresses" } }\r
-{ $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." }\r
-{ $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." } ;\r
+{ $description "Disassembles either a compiled word definition or an arbitrary memory range (in the case " { $snippet "obj" } " is a pair of integers)." }\r
+{ $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." } ;\r
\r
ARTICLE: "tools.disassembler" "Disassembling words"\r
-"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" } "."\r
+"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."\r
{ $subsection disassemble } ;\r
\r
ABOUT: "tools.disassembler"\r
-! Copyright (C) 2008 Slava Pestov, Jorge Acereda Macia.
+! Copyright (C) 2008 Slava Pestov.
! 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 compiler.codegen.fixup
-io.encodings.ascii accessors generic tr ;
+USING: tr arrays sequences io words generic system combinators
+vocabs.loader kernel ;
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 ;
+TR: tabs>spaces "\t" "\s" ;
-: gdb-binary ( -- string ) "gdb" ;
+M: pair disassemble first2 disassemble* [ tabs>spaces print ] each ;
-: 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: word disassemble word-xt 2array disassemble ;
-TR: tabs>spaces "\t" "\s" ;
+M: method-spec disassemble first2 method disassemble ;
-: disassemble ( obj -- )
- make-disassemble-cmd run-gdb
- [ tabs>spaces ] map [ print ] each ;
+cpu x86? os unix? and
+"tools.disassembler.udis"
+"tools.disassembler.gdb" ?
+require
--- /dev/null
+! 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
--- /dev/null
+unportable
--- /dev/null
+unportable
--- /dev/null
+! 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
: file-system-spec ( file-system-info obj -- str )
{
- { device-name [ device-name>> ] }
- { mount-point [ mount-point>> ] }
- { type [ type>> ] }
+ { device-name [ device-name>> [ "" ] unless* ] }
+ { mount-point [ mount-point>> [ "" ] unless* ] }
+ { type [ type>> [ "" ] unless* ] }
{ available-space [ available-space>> [ 0 ] unless* ] }
{ free-space [ free-space>> [ 0 ] unless* ] }
{ used-space [ used-space>> [ 0 ] unless* ] }
SYMBOL: ui-backend
-HOOK: do-events ui-backend ( -- )
-
HOOK: set-title ui-backend ( string world -- )
HOOK: set-fullscreen* ui-backend ( ? world -- )
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: select-gl-context ui-backend ( handle -- )
+GENERIC: select-gl-context ( handle -- )
+
+GENERIC: flush-gl-context ( handle -- )
-HOOK: flush-gl-context ui-backend ( handle -- )
+HOOK: offscreen-pixels ui-backend ( world -- alien w h )
HOOK: beep ui-backend ( -- )
USING: accessors math arrays assocs cocoa cocoa.application
command-line kernel memory namespaces cocoa.messages
cocoa.runtime cocoa.subclassing cocoa.pasteboard cocoa.types
-cocoa.windows cocoa.classes cocoa.application cocoa.nibs
-sequences system ui ui.backend ui.clipboards ui.gadgets
-ui.gadgets.worlds ui.cocoa.views core-foundation threads
-math.geometry.rect fry ;
+cocoa.windows cocoa.classes cocoa.nibs sequences system ui
+ui.backend ui.clipboards ui.gadgets ui.gadgets.worlds
+ui.cocoa.views core-foundation core-foundation.run-loop threads
+math.geometry.rect fry libc generalizations alien.c-types
+cocoa.views combinators io.thread ;
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
-M: cocoa-ui-backend do-events ( -- )
- [ NSApp '[ _ do-event ] loop ui-wait ] with-autorelease-pool ;
-
TUPLE: pasteboard handle ;
C: <pasteboard> pasteboard
: gadget-window ( world -- )
dup <FactorView>
2dup swap world>NSRect <ViewWindow>
- [ [ -> release ] [ install-window-delegate ] bi* ] [ <handle> ] 2bi
+ [ [ -> release ] [ install-window-delegate ] bi* ]
+ [ <window-handle> ] 2bi
>>handle drop ;
M: cocoa-ui-backend set-title ( string world -- )
NSApp 1 -> activateIgnoringOtherApps:
] when* ;
-M: cocoa-ui-backend select-gl-context ( handle -- )
- view>> -> openGLContext -> makeCurrentContext ;
+: pixel-size ( pixel-format -- size )
+ 0 <int> [ NSOpenGLPFAColorSize 0 -> getValues:forAttribute:forVirtualScreen: ]
+ keep *int -3 shift ;
+
+: offscreen-buffer ( world pixel-format -- alien w h pitch )
+ [ 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 flush-gl-context ( handle -- )
- view>> -> openGLContext -> flushBuffer ;
+M: cocoa-ui-backend offscreen-pixels ( world -- alien w h )
+ [ handle>> buffer>> ] [ dim>> first2 neg ] bi ;
M: cocoa-ui-backend beep ( -- )
NSBeep ;
{ +name+ "FactorApplicationDelegate" }
}
-{ "applicationDidFinishLaunching:" "void" { "id" "SEL" "id" }
- [ 3drop event-loop ]
+{ "applicationDidUpdate:" "void" { "id" "SEL" "id" }
+ [ 3drop reset-run-loop ]
} ;
: install-app-delegate ( -- )
init-clipboard
cocoa-init-hook get call
start-ui
+ f io-thread-running? set-global
+ init-thread-timer
+ reset-run-loop
NSApp -> run
] ui-running
] with-cocoa ;
-! Copyright (C) 2006, 2007 Slava Pestov.
+! Copyright (C) 2006, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: alien.syntax cocoa cocoa.nibs cocoa.application
cocoa.classes cocoa.dialogs cocoa.pasteboard cocoa.subclassing
-core-foundation help.topics kernel memory namespaces parser
-system ui ui.tools.browser ui.tools.listener ui.tools.workspace
-ui.cocoa eval locals ;
+core-foundation core-foundation.strings help.topics kernel
+memory namespaces parser system ui ui.tools.browser
+ui.tools.listener ui.tools.workspace ui.cocoa eval locals ;
IN: ui.cocoa.tools
: finder-run-files ( alien -- )
math cocoa.messages cocoa.subclassing cocoa.classes cocoa.views
cocoa.application cocoa.pasteboard cocoa.types cocoa.windows
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
: send-mouse-moved ( view event -- )
dup event-modifiers swap key-code ;
: send-key-event ( view gesture -- )
- swap window-focus propagate-gesture ;
+ swap window propagate-key-gesture ;
: interpret-key-event ( view event -- )
NSArray swap -> arrayWithObject: -> interpretKeyEvents: ;
{ "writeSelectionToPasteboard:types:" "char" { "id" "SEL" "id" "id" }
[
CF>string-array NSStringPboardType swap member? [
- >r drop window-focus gadget-selection dup [
- r> set-pasteboard-string 1
- ] [
- r> 2drop 0
- ] if
- ] [
- 3drop 0
- ] if
+ [ drop window-focus gadget-selection ] dip over
+ [ set-pasteboard-string 1 ] [ 2drop 0 ] if
+ ] [ 3drop 0 ] if
]
}
{ "readSelectionFromPasteboard:" "char" { "id" "SEL" "id" }
[
pasteboard-string dup [
- [ drop window-focus ] dip swap user-input 1
- ] [
- 3drop 0
- ] if
+ [ drop window ] dip swap user-input 1
+ ] [ 3drop 0 ] if
]
}
! Text input
{ "insertText:" "void" { "id" "SEL" "id" }
- [ nip CF>string swap window-focus user-input ]
+ [ nip CF>string swap window user-input ]
}
{ "hasMarkedText" "char" { "id" "SEL" }
--- /dev/null
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: ui.backend kernel namespaces sequences deques calendar
+threads ;
+IN: ui.event-loop
+
+: event-loop? ( -- ? )
+ {
+ { [ stop-after-last-window? get not ] [ t ] }
+ { [ graft-queue deque-empty? not ] [ t ] }
+ { [ windows get-global empty? not ] [ t ] }
+ [ f ]
+ } cond ;
+
+HOOK: do-events ui-backend ( -- )
+
+: event-loop ( quot -- ) [ event-loop? ] [ do-events ] [ ] while ;
+
+: ui-wait ( -- ) 10 milliseconds sleep ;
help.syntax models opengl strings ;
IN: ui.gadgets.worlds
+HELP: user-input
+{ $values { "string" string } { "world" world } }
+{ $description "Calls " { $link user-input* } " on every parent of the world's currently-focused child." } ;
+
HELP: origin
{ $var-description "Within the dynamic extent of " { $link draw-world } ", holds the co-ordinate system origin for the gadget currently being drawn." } ;
2dup eq?
[ 2drop ] [ dup focused?>> (request-focus) ] if ;
-: <world> ( gadget title status -- world )
- { 0 1 } world new-track
+: new-world ( gadget title status class -- world )
+ { 0 1 } swap new-track
t >>root?
t >>active?
H{ } clone >>fonts
swap 1 track-add
dup request-focus ;
+: <world> ( gadget title status -- world )
+ world new-world ;
+
M: world layout*
dup call-next-method
dup glass>> [
-USING: ui.gadgets help.markup help.syntax hashtables
-strings kernel system ;
+USING: ui.gadgets ui.gadgets.worlds help.markup help.syntax
+hashtables strings kernel system ;
IN: ui.gestures
HELP: set-gestures
{ $values { "gesture" "a gesture" } { "gadget" gadget } }
{ $description "Calls " { $link handle-gesture } " on every parent of " { $snippet "gadget" } "." } ;
-HELP: user-input
-{ $values { "string" string } { "gadget" gadget } }
-{ $description "Calls " { $link user-input* } " on every parent of the gadget." } ;
-
HELP: motion
{ $class-description "Mouse motion gesture." }
{ $examples { $code "T{ motion }" } } ;
: propagate-gesture ( gesture gadget -- )
\ propagate-gesture queue-gesture ;
-TUPLE: user-input string gadget ;
+TUPLE: propagate-key-gesture gesture world ;
+
+: world-focus ( world -- gadget )
+ dup focus>> [ world-focus ] [ ] ?if ;
+
+M: propagate-key-gesture send-queued-gesture
+ [ gesture>> ] [ world>> world-focus ] bi
+ [ handle-gesture ] with each-parent drop ;
+
+: propagate-key-gesture ( gesture world -- )
+ \ propagate-key-gesture queue-gesture ;
+
+TUPLE: user-input string world ;
M: user-input send-queued-gesture
- [ string>> ] [ gadget>> ] bi
+ [ string>> ] [ world>> world-focus ] bi
[ user-input* ] with each-parent drop ;
-: user-input ( string gadget -- )
+: user-input ( string world -- )
'[ _ \ user-input queue-gesture ] unless-empty ;
! Gesture objects
scroll-direction set-global
T{ mouse-scroll } hand-gadget get-global propagate-gesture ;
-: world-focus ( world -- gadget )
- dup focus>> [ world-focus ] [ ] ?if ;
-
: send-action ( world gesture -- )
swap world-focus propagate-gesture ;
}
"The above word must call the following:"
{ $subsection start-ui }
-"The " { $link ui } " word must not return until the event loop has stopped and the UI has been shut down."
-$nl
-"The event loop must not block, since otherwise other Factor threads and I/O will not run. Instead, it should poll for pending events, then call " { $link ui-wait } "." ;
+"The " { $link ui } " word must not return until the event loop has stopped and the UI has been shut down." ;
ARTICLE: "ui-backend-windows" "UI backend window management"
"The high-level " { $link open-window } " word eventually calls a low-level word which you must implement:"
SYMBOL: stop-after-last-window?
-: event-loop? ( -- ? )
- {
- { [ stop-after-last-window? get not ] [ t ] }
- { [ graft-queue deque-empty? not ] [ t ] }
- { [ windows get-global empty? not ] [ t ] }
- [ f ]
- } cond ;
-
-: event-loop ( -- ) [ event-loop? ] [ do-events ] [ ] while ;
-
: window ( handle -- world ) windows get-global at ;
: window-focus ( handle -- gadget ) window world-focus ;
focus-path f swap focus-gestures ;
M: world graft*
- dup (open-window)
- dup title>> over set-title
- request-focus ;
+ [ (open-window) ]
+ [ [ title>> ] keep set-title ]
+ [ request-focus ] tri ;
: reset-world ( world -- )
#! This is used when a window is being closed, but also
#! when restoring saved worlds on image startup.
- dup fonts>> clear-assoc
- dup unfocus-world
- f >>handle drop ;
+ [ fonts>> clear-assoc ]
+ [ unfocus-world ]
+ [ f >>handle drop ] tri ;
+
+: (ungraft-world) ( world -- )
+ [ free-fonts ]
+ [ hand-clicked close-global ]
+ [ hand-gadget close-global ] tri ;
M: world ungraft*
- dup free-fonts
- dup hand-clicked close-global
- dup hand-gadget close-global
- dup handle>> (close-window)
- reset-world ;
+ [ (ungraft-world) ]
+ [ handle>> (close-window) ]
+ [ reset-world ] tri ;
: find-window ( quot -- world )
windows get values
graft-queue [ notify ] slurp-deque ;
: send-queued-gestures ( -- )
- gesture-queue [ send-queued-gesture ] slurp-deque ;
+ gesture-queue [ send-queued-gesture notify-queued ] slurp-deque ;
: update-ui ( -- )
[
] assert-depth
] [ ui-error ] recover ;
-: ui-wait ( -- )
- 10 milliseconds sleep ;
-
SYMBOL: ui-thread
: ui-running ( quot -- )
! See http://factorcode.org/license.txt for BSD license.
USING: alien alien.c-types alien.strings arrays assocs ui
ui.gadgets ui.backend ui.clipboards ui.gadgets.worlds
-ui.gestures io kernel math math.vectors namespaces make
-sequences strings vectors words windows.kernel32 windows.gdi32
-windows.user32 windows.opengl32 windows.messages windows.types
-windows.nt windows threads libc combinators
+ui.gestures ui.event-loop io kernel math math.vectors namespaces
+make sequences strings vectors words windows.kernel32
+windows.gdi32 windows.user32 windows.opengl32 windows.messages
+windows.types windows.nt windows threads libc combinators fry
combinators.short-circuit continuations command-line shuffle
opengl ui.render ascii math.bitwise locals symbols accessors
-math.geometry.rect math.order ascii calendar
-io.encodings.utf16n ;
+math.geometry.rect math.order ascii calendar io.encodings.utf16n
+;
IN: ui.windows
SINGLETON: windows-ui-backend
<pasteboard> clipboard set-global
<clipboard> selection set-global ;
-! world-handle is a <win>
-TUPLE: win hWnd hDC hRC world title ;
+TUPLE: win-base hDC hRC ;
+TUPLE: win < win-base hWnd world title ;
+TUPLE: win-offscreen < win-base hBitmap bits ;
C: <win> win
+C: <win-offscreen> win-offscreen
SYMBOLS: msg-obj class-name-ptr mouse-captured ;
: send-key-gesture ( sym action? quot hWnd -- )
[ [ key-modifiers ] 3dip call ] dip
- window-focus propagate-gesture ; inline
+ window propagate-key-gesture ; inline
: send-key-down ( sym action? hWnd -- )
[ [ <key-down> ] ] dip send-key-gesture ;
ctrl? alt? xor [
wParam 1string
[ f hWnd send-key-down ]
- [ hWnd window-focus user-input ] bi
+ [ hWnd window user-input ] bi
] unless
] unless ;
f class-name-ptr set-global
f msg-obj set-global ;
-: setup-pixel-format ( hdc -- )
- 16 make-pfd [ ChoosePixelFormat dup win32-error=0/f ] 2keep
+: setup-pixel-format ( hdc flags -- )
+ 32 make-pfd [ ChoosePixelFormat dup win32-error=0/f ] 2keep
swapd SetPixelFormat win32-error=0/f ;
: get-dc ( hWnd -- hDC ) GetDC dup win32-error=0/f ;
[ wglMakeCurrent win32-error=0/f ] keep ;
: setup-gl ( hwnd -- hDC hRC )
- get-dc dup setup-pixel-format dup get-rc ;
+ get-dc dup windowed-pfd-dwFlags setup-pixel-format dup get-rc ;
M: windows-ui-backend (open-window) ( world -- )
- [ create-window dup setup-gl ] keep
+ [ create-window [ setup-gl ] keep ] keep
[ f <win> ] keep
[ swap hWnd>> register-window ] 2keep
dupd (>>handle)
hWnd>> show-window ;
-M: windows-ui-backend select-gl-context ( handle -- )
- [ hDC>> ] keep hRC>> wglMakeCurrent win32-error=0/f ;
+M: win-base select-gl-context ( handle -- )
+ [ hDC>> ] keep hRC>> wglMakeCurrent win32-error=0/f
+ GdiFlush drop ;
-M: windows-ui-backend flush-gl-context ( handle -- )
+M: win-base flush-gl-context ( handle -- )
hDC>> SwapBuffers win32-error=0/f ;
-! Move window to front
+: (bitmap-info) ( dim -- BITMAPINFO )
+ "BITMAPINFO" <c-object> [
+ BITMAPINFO-bmiHeader {
+ [ nip "BITMAPINFOHEADER" heap-size swap set-BITMAPINFOHEADER-biSize ]
+ [ [ first ] dip set-BITMAPINFOHEADER-biWidth ]
+ [ [ second ] dip set-BITMAPINFOHEADER-biHeight ]
+ [ nip 1 swap set-BITMAPINFOHEADER-biPlanes ]
+ [ nip 32 swap set-BITMAPINFOHEADER-biBitCount ]
+ [ nip BI_RGB swap set-BITMAPINFOHEADER-biCompression ]
+ [ [ first2 * 4 * ] dip set-BITMAPINFOHEADER-biSizeImage ]
+ [ nip 72 swap set-BITMAPINFOHEADER-biXPelsPerMeter ]
+ [ nip 72 swap set-BITMAPINFOHEADER-biYPelsPerMeter ]
+ [ nip 0 swap set-BITMAPINFOHEADER-biClrUsed ]
+ [ nip 0 swap set-BITMAPINFOHEADER-biClrImportant ]
+ } 2cleave
+ ] keep ;
+
+: make-offscreen-dc-and-bitmap ( dim -- hDC hBitmap bits )
+ f CreateCompatibleDC
+ dup rot (bitmap-info) DIB_RGB_COLORS f <void*>
+ [ f 0 CreateDIBSection ] keep *void*
+ [ 2dup SelectObject drop ] dip ;
+
+: setup-offscreen-gl ( dim -- hDC hRC hBitmap bits )
+ make-offscreen-dc-and-bitmap [
+ [ dup offscreen-pfd-dwFlags setup-pixel-format ]
+ [ get-rc ] bi
+ ] 2dip ;
+
+M: windows-ui-backend (open-offscreen-buffer) ( world -- )
+ dup dim>> setup-offscreen-gl <win-offscreen>
+ >>handle drop ;
+M: windows-ui-backend (close-offscreen-buffer) ( handle -- )
+ [ hDC>> DeleteDC drop ]
+ [ hBitmap>> DeleteObject drop ] bi ;
+
+! Windows 32-bit bitmaps don't actually use the alpha byte of
+! each pixel; it's left as zero
+
+: (make-opaque) ( byte-array -- byte-array' )
+ [ length 4 / ]
+ [ '[ 255 swap 4 * 3 + _ set-nth ] each ]
+ [ ] tri ;
+
+: (opaque-pixels) ( world -- pixels )
+ [ handle>> bits>> ] [ dim>> first2 * 4 * ] bi
+ memory>byte-array (make-opaque) ;
+
+M: windows-ui-backend offscreen-pixels ( world -- alien w h )
+ [ (opaque-pixels) ] [ dim>> first2 ] bi ;
+
M: windows-ui-backend raise-window* ( world -- )
handle>> [
hWnd>> SetFocus drop
! See http://factorcode.org/license.txt for BSD license.
USING: accessors alien alien.c-types arrays ui ui.gadgets
ui.gestures ui.backend ui.clipboards ui.gadgets.worlds ui.render
-assocs kernel math namespaces opengl sequences strings x11.xlib
-x11.events x11.xim x11.glx x11.clipboard x11.constants
-x11.windows io.encodings.string io.encodings.ascii
+ui.event-loop assocs kernel math namespaces opengl sequences
+strings x11.xlib x11.events x11.xim x11.glx x11.clipboard
+x11.constants x11.windows io.encodings.string io.encodings.ascii
io.encodings.utf8 combinators command-line qualified
math.vectors classes.tuple opengl.gl threads math.geometry.rect
environment ascii ;
: XA_NET_WM_NAME ( -- atom ) "_NET_WM_NAME" x-atom ;
-TUPLE: x11-handle window glx xic ;
+TUPLE: x11-handle-base glx ;
+TUPLE: x11-handle < x11-handle-base xic window ;
+TUPLE: x11-pixmap-handle < x11-handle-base pixmap glx-pixmap ;
C: <x11-handle> x11-handle
+C: <x11-pixmap-handle> x11-pixmap-handle
M: world expose-event nip relayout ;
M: world key-down-event
[ key-down-event>gesture ] keep
- world-focus
- [ propagate-gesture drop ]
+ [ propagate-key-gesture drop ]
[ 2over valid-input? [ nip user-input ] [ 3drop ] if ]
3bi ;
dup event-modifiers swap 0 XLookupKeysym key-code <key-up> ;
M: world key-up-event
- [ key-up-event>gesture ] dip world-focus propagate-gesture ;
+ [ key-up-event>gesture ] dip propagate-key-gesture ;
: mouse-event>gesture ( event -- modifiers button loc )
[ event-modifiers ]
M: world selection-notify-event
[ handle>> window>> selection-from-event ] keep
- world-focus user-input ;
+ user-input ;
: supported-type? ( atom -- ? )
{ "UTF8_STRING" "STRING" "TEXT" }
: gadget-window ( world -- )
dup window-loc>> over rect-dim glx-window
- over "Factor" create-xic <x11-handle>
+ over "Factor" create-xic rot <x11-handle>
2dup window>> register-window
>>handle drop ;
dpy get swap window>> XRaiseWindow drop
] when* ;
-M: x11-ui-backend select-gl-context ( handle -- )
+M: x11-handle select-gl-context ( handle -- )
dpy get swap
- dup window>> swap glx>> glXMakeCurrent
+ [ window>> ] [ glx>> ] bi glXMakeCurrent
[ "Failed to set current GLX context" throw ] unless ;
-M: x11-ui-backend flush-gl-context ( handle -- )
+M: x11-handle flush-gl-context ( handle -- )
dpy get swap window>> glXSwapBuffers ;
+M: x11-pixmap-handle select-gl-context ( handle -- )
+ dpy get swap
+ [ glx-pixmap>> ] [ glx>> ] bi glXMakeCurrent
+ [ "Failed to set current GLX context" throw ] unless ;
+
+M: x11-pixmap-handle flush-gl-context ( handle -- )
+ drop ;
+
+M: x11-ui-backend (open-offscreen-buffer) ( world -- )
+ dup dim>> glx-pixmap <x11-pixmap-handle> >>handle drop ;
+M: x11-ui-backend (close-offscreen-buffer) ( handle -- )
+ dpy get swap
+ [ glx-pixmap>> glXDestroyGLXPixmap ]
+ [ pixmap>> XFreePixmap drop ]
+ [ glx>> glXDestroyContext ] 2tri ;
+
+M: x11-ui-backend offscreen-pixels ( world -- alien w h )
+ [ [ dim>> ] [ handle>> pixmap>> ] bi pixmap-bits ] [ dim>> first2 ] bi ;
+
M: x11-ui-backend ui ( -- )
[
f [
HEX: 7f bitand ; inline
: WIFEXITED ( status -- ? )
- WTERMSIG zero? ; inline
+ WTERMSIG 0 = ; inline
: WEXITSTATUS ( status -- value )
HEX: ff00 bitand -8 shift ; inline
HEX: 80 ; inline
: WCOREDUMP ( status -- ? )
- WCOREFLAG bitand zero? not ; inline
+ WCOREFLAG bitand 0 = not ; inline
: WIFSTOPPED ( status -- ? )
HEX: ff bitand HEX: 7f = ; inline
: DC_BRUSH 18 ; inline
: DC_PEN 19 ; inline
+: BI_RGB 0 ; inline
+: BI_RLE8 1 ; inline
+: BI_RLE4 2 ; inline
+: BI_BITFIELDS 3 ; inline
+
+: DIB_RGB_COLORS 0 ; inline
+: DIB_PAL_COLORS 1 ; inline
+
LIBRARY: gdi32
! FUNCTION: AbortPath
! FUNCTION: CreateColorSpaceA
! FUNCTION: CreateColorSpaceW
! FUNCTION: CreateCompatibleBitmap
-! FUNCTION: CreateCompatibleDC
+FUNCTION: HDC CreateCompatibleDC ( HDC hdc ) ;
! FUNCTION: CreateDCA
! FUNCTION: CreateDCW
! FUNCTION: CreateDIBitmap
! FUNCTION: CreateDIBPatternBrush
! FUNCTION: CreateDIBPatternBrushPt
-! FUNCTION: CreateDIBSection
+FUNCTION: HBITMAP CreateDIBSection ( HDC hdc, BITMAPINFO* pbmi, UINT iUsage, void** ppvBits, HANDLE hSection, DWORD dwOffset ) ;
! FUNCTION: CreateDiscardableBitmap
! FUNCTION: CreateEllipticRgn
! FUNCTION: CreateEllipticRgnIndirect
! FUNCTION: DdEntry8
! FUNCTION: DdEntry9
! FUNCTION: DeleteColorSpace
-! FUNCTION: DeleteDC
+FUNCTION: BOOL DeleteDC ( HDC hdc ) ;
! FUNCTION: DeleteEnhMetaFile
! FUNCTION: DeleteMetaFile
FUNCTION: BOOL DeleteObject ( HGDIOBJ hObject ) ;
! FUNCTION: GdiEntry8
! FUNCTION: GdiEntry9
! FUNCTION: GdiFixUpHandle
-! FUNCTION: GdiFlush
+FUNCTION: BOOL GdiFlush ( ) ;
! FUNCTION: GdiFullscreenControl
! FUNCTION: GdiGetBatchLimit
! FUNCTION: GdiGetCharDimensions
! FUNCTION: SelectClipPath
FUNCTION: int SelectClipRgn ( HDC hDC, HRGN hrgn ) ;
! FUNCTION: SelectFontLocal
-! FUNCTION: SelectObject
+FUNCTION: HGDIOBJ SelectObject ( HDC hdc, HGDIOBJ hgdiobj ) ;
! FUNCTION: SelectPalette
! FUNCTION: SetAbortProc
! FUNCTION: SetArcDirection
: WGL_SWAP_UNDERLAY14 HEX: 20000000 ; inline
: WGL_SWAP_UNDERLAY15 HEX: 40000000 ; inline
-: pfd-dwFlags ( -- n )
+: windowed-pfd-dwFlags ( -- n )
{ PFD_DRAW_TO_WINDOW PFD_SUPPORT_OPENGL PFD_DOUBLEBUFFER } flags ;
+: offscreen-pfd-dwFlags ( -- n )
+ { PFD_DRAW_TO_BITMAP PFD_SUPPORT_OPENGL } flags ;
! TODO: compare to http://www.nullterminator.net/opengl32.html
-: make-pfd ( bits -- pfd )
+: make-pfd ( flags bits -- pfd )
"PIXELFORMATDESCRIPTOR" <c-object>
"PIXELFORMATDESCRIPTOR" heap-size over set-PIXELFORMATDESCRIPTOR-nSize
1 over set-PIXELFORMATDESCRIPTOR-nVersion
- pfd-dwFlags over set-PIXELFORMATDESCRIPTOR-dwFlags
+ rot over set-PIXELFORMATDESCRIPTOR-dwFlags
PFD_TYPE_RGBA over set-PIXELFORMATDESCRIPTOR-iPixelType
[ set-PIXELFORMATDESCRIPTOR-cColorBits ] keep
16 over set-PIXELFORMATDESCRIPTOR-cDepthBits
! { "BYTE[32]" "rgbReserved" }
! ;
+C-STRUCT: BITMAPINFOHEADER
+ { "DWORD" "biSize" }
+ { "LONG" "biWidth" }
+ { "LONG" "biHeight" }
+ { "WORD" "biPlanes" }
+ { "WORD" "biBitCount" }
+ { "DWORD" "biCompression" }
+ { "DWORD" "biSizeImage" }
+ { "LONG" "biXPelsPerMeter" }
+ { "LONG" "biYPelsPerMeter" }
+ { "DWORD" "biClrUsed" }
+ { "DWORD" "biClrImportant" } ;
+
+C-STRUCT: RGBQUAD
+ { "BYTE" "rgbBlue" }
+ { "BYTE" "rgbGreen" }
+ { "BYTE" "rgbRed" }
+ { "BYTE" "rgbReserved" } ;
+
+C-STRUCT: BITMAPINFO
+ { "BITMAPINFOHEADER" "bmiHeader" }
+ { "RGBQUAD[1]" "bmiColors" } ;
+
TYPEDEF: void* LPPAINTSTRUCT
TYPEDEF: void* PAINTSTRUCT
FUNCTION: void* glXGetProcAddressARB ( char* procname ) ;
! GLX Events
-! (also skipped for now. only has GLXPbufferClobberEvent, the rest is handled by xlib methinks
+! (also skipped for now. only has GLXPbufferClobberEvent, the rest is handled by xlib methinks)
-: choose-visual ( -- XVisualInfo* )
- dpy get scr get
+: choose-visual ( flags -- XVisualInfo* )
+ [ dpy get scr get ] dip
[
+ %
GLX_RGBA ,
- GLX_DOUBLEBUFFER ,
GLX_DEPTH_SIZE , 16 ,
0 ,
] int-array{ } make underlying>>
[ "Could not get a double-buffered GLX RGBA visual" throw ] unless* ;
: create-glx ( XVisualInfo* -- GLXContext )
- >r dpy get r> f 1 glXCreateContext
+ [ dpy get ] dip f 1 glXCreateContext
[ "Failed to create GLX context" throw ] unless* ;
: destroy-glx ( GLXContext -- )
- dpy get swap glXDestroyContext ;
\ No newline at end of file
+ dpy get swap glXDestroyContext ;
! Copyright (C) 2005, 2006 Eduardo Cavazos and Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
USING: alien alien.c-types hashtables kernel math math.vectors
-math.bitwise namespaces sequences x11.xlib x11.constants x11.glx ;
+math.bitwise namespaces sequences x11.xlib x11.constants x11.glx
+arrays fry ;
IN: x11.windows
: create-window-mask ( -- n )
dup r> auto-position ;
: glx-window ( loc dim -- window glx )
- choose-visual
+ GLX_DOUBLEBUFFER 1array choose-visual
[ create-window ] keep
[ create-glx ] keep
XFree ;
+: create-pixmap ( dim visual -- pixmap )
+ [ [ { 0 0 } swap ] dip create-window ] [
+ drop [ dpy get ] 2dip first2 24 XCreatePixmap
+ [ "Failed to create offscreen pixmap" throw ] unless*
+ ] 2bi ;
+
+: (create-glx-pixmap) ( pixmap visual -- pixmap glx-pixmap )
+ [ drop ] [
+ [ dpy get ] 2dip swap glXCreateGLXPixmap
+ [ "Failed to create offscreen GLXPixmap" throw ] unless*
+ ] 2bi ;
+
+: create-glx-pixmap ( dim visual -- pixmap glx-pixmap )
+ [ create-pixmap ] [ (create-glx-pixmap) ] bi ;
+
+: glx-pixmap ( dim -- glx pixmap glx-pixmap )
+ { } choose-visual
+ [ nip create-glx ] [ create-glx-pixmap ] [ nip XFree ] 2tri ;
+
: destroy-window ( win -- )
dpy get swap XDestroyWindow drop ;
: map-window ( win -- ) dpy get swap XMapWindow drop ;
: unmap-window ( win -- ) dpy get swap XUnmapWindow drop ;
+
+: pixmap-bits ( dim pixmap -- alien )
+ swap first2 '[ dpy get _ 0 0 _ _ AllPlanes ZPixmap XGetImage ] call
+ [ XImage-pixels ] [ XDestroyImage drop ] bi ;
FUNCTION: int XConvertSelection ( Display* display, Atom selection, Atom target, Atom property, Window requestor, Time time ) ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+! 5 - Pixmap and Cursor Functions
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+! 5.1 - Creating and Freeing Pixmaps
+
+FUNCTION: Pixmap XCreatePixmap ( Display* display, Drawable d, uint width, uint height, uint depth ) ;
+FUNCTION: int XFreePixmap ( Display* display, Pixmap pixmap ) ;
+
+
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! 6 - Color Management Functions
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
char* string,
int length ) ;
+! 8.7 - Transferring Images between Client and Server
+
+: XYBitmap 0 ; inline
+: XYPixmap 1 ; inline
+: ZPixmap 2 ; inline
+: AllPlanes -1 ; inline
+
+C-STRUCT: XImage-funcs
+ { "void*" "create_image" }
+ { "void*" "destroy_image" }
+ { "void*" "get_pixel" }
+ { "void*" "put_pixel" }
+ { "void*" "sub_image" }
+ { "void*" "add_pixel" } ;
+
+C-STRUCT: XImage
+ { "int" "width" }
+ { "int" "height" }
+ { "int" "xoffset" }
+ { "int" "format" }
+ { "char*" "data" }
+ { "int" "byte_order" }
+ { "int" "bitmap_unit" }
+ { "int" "bitmap_bit_order" }
+ { "int" "bitmap_pad" }
+ { "int" "depth" }
+ { "int" "bytes_per_line" }
+ { "int" "bits_per_pixel" }
+ { "ulong" "red_mask" }
+ { "ulong" "green_mask" }
+ { "ulong" "blue_mask" }
+ { "XPointer" "obdata" }
+ { "XImage-funcs" "f" } ;
+
+FUNCTION: XImage* XGetImage ( Display* display, Drawable d, int x, int y, uint width, uint height, ulong plane_mask, int format ) ;
+FUNCTION: int XDestroyImage ( XImage *ximage ) ;
+
+: XImage-size ( ximage -- size )
+ [ XImage-height ] [ XImage-bytes_per_line ] bi * ;
+
+: XImage-pixels ( ximage -- byte-array )
+ [ XImage-data ] [ XImage-size ] bi memory>byte-array ;
+
!
! 9 - Window and Session Manager Functions
!
! Copyright (C) 2004, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors assocs kernel math namespaces sequences system
-kernel.private byte-arrays arrays ;
+kernel.private byte-arrays arrays init ;
IN: alien
! Some predicate classes used by the compiler for optimization
: alien-invoke ( ... return library function parameters -- ... )
2over alien-invoke-error ;
+
+! 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" add-init-hook
IN: byte-arrays.tests\r
-USING: tools.test byte-arrays ;\r
+USING: tools.test byte-arrays sequences kernel ;\r
\r
-[ B{ 1 2 3 0 0 0 } ] [ 6 B{ 1 2 3 } resize-byte-array ] unit-test\r
+[ 6 B{ 1 2 3 } ] [\r
+ 6 B{ 1 2 3 } resize-byte-array\r
+ [ length ] [ 3 head ] bi\r
+] unit-test\r
\r
[ B{ 1 2 } ] [ 2 B{ 1 2 3 4 5 6 7 8 9 } resize-byte-array ] unit-test\r
\r
! Copyright (C) 2007, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: init kernel system namespaces io io.encodings
-io.encodings.utf8 init assocs splitting ;
+io.encodings.utf8 init assocs splitting alien ;
IN: io.backend
SYMBOL: io-backend
io-backend set-global init-io init-stdio
"io.files" init-hooks get at call ;
+! Note that we have 'alien' in our using list so that the alien
+! init hook runs before this one.
[ init-io embedded? [ init-stdio ] unless ]
"io.backend" add-init-hook
! LOL
[ ] [
vm
+ "-i=" image append
"-generations=2"
"-e=USING: memory io prettyprint system ; input-stream gc . 0 exit"
- 3array try-process
+ 4array try-process
] unit-test
[ [ ] instances ] must-infer
[ (each) ] dip collect ; inline
: 2nth-unsafe ( n seq1 seq2 -- elt1 elt2 )
- [ over ] dip nth-unsafe [ nth-unsafe ] dip ; inline
+ [ over ] dip [ nth-unsafe ] 2bi@ ; inline
: (2each) ( seq1 seq2 quot -- n quot' )
[ [ min-length ] 2keep ] dip
: sequence-hashcode-step ( oldhash newpart -- newhash )
>fixnum swap [
- dup -2 fixnum-shift-fast swap 5 fixnum-shift-fast
+ [ -2 fixnum-shift-fast ] [ 5 fixnum-shift-fast ] bi
fixnum+fast fixnum+fast
] keep fixnum-bitxor ; inline
: sequence-hashcode ( n seq -- x )
- 0 -rot [ hashcode* sequence-hashcode-step ] with each ; inline
+ [ 0 ] 2dip [ hashcode* sequence-hashcode-step ] with each ; inline
M: reversed equal? over reversed? [ sequence= ] [ 2drop f ] if ;
USE: arrays
: array-length ( array -- len )
- { array } declare length>> ;
+ { array } declare length>> ; inline
: array-flip ( matrix -- newmatrix )
+ { array } declare
[ dup first array-length [ array-length min ] reduce ] keep
[ [ array-nth ] with { } map-as ] curry { } map-as ;
IN: benchmark
: run-benchmark ( vocab -- result )
- [ [ require ] [ [ run ] benchmark ] bi ] curry
- [ error. f ] recover ;
+ [ "=== " write vocab-name print flush ] [
+ [ [ require ] [ [ run ] benchmark ] bi ] curry
+ [ error. f ] recover
+ ] bi ;
: run-benchmarks ( -- assoc )
"benchmark" all-child-vocabs-seq
USING: accessors arrays fry kernel math math.vectors sequences
math.intervals
multi-methods
+ combinators.short-circuit
combinators.cleave.enhanced
multi-method-syntax ;
cond
2array ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+GENERIC: within? ( a b -- ? )
+
+METHOD: within? ( <pos> <rectangle> -- ? )
+ {
+ [ left to-the-right-of? ]
+ [ right to-the-left-of? ]
+ [ bottom above? ]
+ [ top below? ]
+ }
+ 2&& ;
: fuel-end-eval ( -- ) [ ] (fuel-end-eval) ; inline
: fuel-get-edit-location ( defspec -- )
- where [ first2 [ (normalize-path) ] dip 2array fuel-eval-set-result ] when* ;
+ where [ first2 [ (normalize-path) ] dip 2array fuel-eval-set-result ]
+ when* ;
: fuel-run-file ( path -- ) run-file ; inline
USING: alien arrays byte-arrays combinators summary io.backend
graphics.viewer io io.binary io.files kernel libc math
math.functions math.bitwise namespaces opengl opengl.gl
-prettyprint sequences strings ui ui.gadgets.panes
-io.encodings.binary accessors grouping ;
+prettyprint sequences strings ui ui.gadgets.panes fry
+io.encodings.binary accessors grouping macros alien.c-types ;
IN: graphics.bitmap
-! Currently can only handle 24bit bitmaps.
+! Currently can only handle 24/32bit bitmaps.
! Handles row-reversed bitmaps (their height is negative)
TUPLE: bitmap magic size reserved offset header-length width
height planes bit-count compression size-image
x-pels y-pels color-used color-important rgb-quads color-index array ;
+: (array-copy) ( bitmap array -- bitmap array' )
+ over size-image>> abs memory>byte-array ;
+
+MACRO: (nbits>bitmap) ( bits -- )
+ [ -3 shift ] keep '[
+ bitmap new
+ 2over * _ * >>size-image
+ swap >>height
+ swap >>width
+ swap (array-copy) [ >>array ] [ >>color-index ] bi
+ _ >>bit-count
+ ] ;
+
: bgr>bitmap ( array height width -- bitmap )
- bitmap new
- 2over * 3 * >>size-image
- swap >>height
- swap >>width
- swap [ >>array ] [ >>color-index ] bi
- 24 >>bit-count ;
+ 24 (nbits>bitmap) ;
+
+: bgra>bitmap ( array height width -- bitmap )
+ 32 (nbits>bitmap) ;
: 8bit>array ( bitmap -- array )
[ rgb-quads>> 4 <sliced-groups> [ 3 head-slice ] map ]
[
[ height>> abs ] keep
bit-count>> {
- ! { 32 [ GL_BGRA GL_UNSIGNED_INT_8_8_8_8 ] } ! broken
+ { 32 [ GL_BGRA GL_UNSIGNED_BYTE ] }
{ 24 [ GL_BGR GL_UNSIGNED_BYTE ] }
{ 8 [ GL_BGR GL_UNSIGNED_BYTE ] }
{ 4 [ GL_BGR GL_UNSIGNED_BYTE ] }
-USING: alien.syntax alien.c-types core-foundation system
-combinators kernel sequences debugger io accessors ;
+USING: alien.syntax alien.c-types core-foundation
+core-foundation.bundles system combinators kernel sequences
+debugger io accessors ;
IN: iokit
<<
: make-key-gadget ( scancode dim array -- )
[
swap [
- " " [ ] <bevel-button>
+ " " [ drop ] <bevel-button>
swap [ first >>loc ] [ second >>dim ] bi
] [ execute ] bi*
] dip set-nth ;
--- /dev/null
+USING: kernel literals tools.test ;
+IN: literals.tests
+
+<<
+: five 5 ;
+: seven-eleven 7 11 ;
+: six-six-six 6 6 6 ;
+>>
+
+[ { 5 } ] [ { $ five } ] unit-test
+[ { 7 11 } ] [ { $ seven-eleven } ] unit-test
+[ { 6 6 6 } ] [ { $ six-six-six } ] unit-test
--- /dev/null
+USING: continuations kernel parser words ;
+IN: literals
+
+: $ scan-word [ execute ] curry with-datastack ; parsing
IN: pong
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!
+! Inspired by this Ruby/Shoes version by why: http://gist.github.com/26431
+!
+! Which was based on this Nodebox version: http://billmill.org/pong.html
+! by Bill Mill.
+!
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: clamp-to-interval ( x interval -- x )
USE: syntax ! Switch back to core 'TUPLE:' instead of the one provided
! by multi-methods
-TUPLE: <pong> < gadget draw closed ;
+TUPLE: <pong> < gadget paused field ball player computer ;
-M: <pong> pref-dim* ( <pong> -- dim ) drop { 400 400 } ;
-M: <pong> draw-gadget* ( <pong> -- ) draw>> call ;
-M: <pong> ungraft* ( <pong> -- ) t >>closed drop ;
+: pong ( -- gadget )
+ <pong> new-gadget
+ T{ <play-field> { pos { 0 0 } } { dim { 400 400 } } } clone >>field
+ T{ <ball> { pos { 50 50 } } { vel { 3 4 } } } clone >>ball
+ T{ <paddle> { pos { 200 396 } } { dim { 75 4 } } } clone >>player
+ T{ <computer> { pos { 200 0 } } { dim { 75 4 } } } clone >>computer ;
+M: <pong> pref-dim* ( <pong> -- dim ) drop { 400 400 } ;
+M: <pong> ungraft* ( <pong> -- ) t >>paused drop ;
+
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-: make-draw-closure ( -- closure )
+M:: <pong> draw-gadget* ( PONG -- )
- ! Establish some bindings
+ PONG computer>> draw
+ PONG player>> draw
+ PONG ball>> draw ;
- [let | PLAY-FIELD [ T{ <play-field> { pos { 0 0 } } { dim { 400 400 } } } ]
- BALL [ T{ <ball> { pos { 50 50 } } { vel { 3 4 } } } ]
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
- PLAYER [ T{ <paddle> { pos { 200 396 } } { dim { 75 4 } } } ]
- COMPUTER [ T{ <computer> { pos { 200 0 } } { dim { 75 4 } } } ] |
+:: iterate-system ( GADGET -- )
- ! Define some internal words in terms of those bindings ...
+ [let | FIELD [ GADGET field>> ]
+ BALL [ GADGET ball>> ]
+ PLAYER [ GADGET player>> ]
+ COMPUTER [ GADGET computer>> ] |
[wlet | align-player-with-mouse [ ( -- )
- PLAYER PLAY-FIELD align-paddle-with-mouse ]
+ PLAYER FIELD align-paddle-with-mouse ]
move-ball [ ( -- ) BALL 1 move-for ]
BALL COMPUTER { [ below? ] [ in-between-horizontally? ] } && ]
bounce-off-wall? [ ( -- ? )
- BALL PLAY-FIELD in-between-horizontally? not ] |
-
- ! Note, we're returning a quotation.
- ! The quotation closes over the bindings established by the 'let'.
- ! Thus the name of the word 'make-draw-closure'.
- ! This closure is intended to be placed in the 'draw' slot of a
- ! <pong> gadget.
-
+ BALL FIELD in-between-horizontally? not ]
+
+ stop-game [ ( -- ) t GADGET (>>paused) ] |
+
+ BALL FIELD in-bounds?
[
- BALL PLAY-FIELD in-bounds?
- [
- align-player-with-mouse
-
- move-ball
-
- ! computer reaction
-
- BALL COMPUTER to-the-left-of? [ COMPUTER computer-move-left ] when
- BALL COMPUTER to-the-right-of? [ COMPUTER computer-move-right ] when
-
- ! check if ball bounced off something
-
- player-blocked-ball? [ BALL PLAYER bounce-off-paddle ] when
- computer-blocked-ball? [ BALL COMPUTER bounce-off-paddle ] when
- bounce-off-wall? [ BALL reverse-horizontal-velocity ] when
+ align-player-with-mouse
- ! draw the objects
-
- COMPUTER draw
- PLAYER draw
- BALL draw
-
- ]
- when
-
- ] ] ] ( -- closure ) ; ! The trailing stack effect here is a workaround.
- ! The stack effects in the wlet expression throw
- ! off the effect for the whole word, so we reset
- ! it to the correct one here.
+ move-ball
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ ! computer reaction
-:: pong-loop-step ( PONG -- ? )
- PONG closed>>
- [ f ]
- [ PONG relayout-1 25 milliseconds sleep t ]
- if ;
+ BALL COMPUTER to-the-left-of? [ COMPUTER computer-move-left ] when
+ BALL COMPUTER to-the-right-of? [ COMPUTER computer-move-right ] when
-:: start-pong-thread ( PONG -- ) [ [ PONG pong-loop-step ] loop ] in-thread ;
+ ! check if ball bounced off something
+
+ player-blocked-ball? [ BALL PLAYER bounce-off-paddle ] when
+ computer-blocked-ball? [ BALL COMPUTER bounce-off-paddle ] when
+ bounce-off-wall? [ BALL reverse-horizontal-velocity ] when
+ ]
+ [ stop-game ]
+ if
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ ] ] ( gadget -- ) ;
-: play-pong ( -- )
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
- <pong> new-gadget
- make-draw-closure >>draw
- dup "PONG" open-window
-
- start-pong-thread ;
+:: start-pong-thread ( GADGET -- )
+ f GADGET (>>paused)
+ [
+ [
+ GADGET paused>>
+ [ f ]
+ [ GADGET iterate-system GADGET relayout-1 25 milliseconds sleep t ]
+ if
+ ]
+ loop
+ ]
+ in-thread ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-: play-pong-main ( -- ) [ play-pong ] with-ui ;
+: pong-window ( -- ) pong [ "PONG" open-window ] [ start-pong-thread ] bi ;
+
+: pong-main ( -- ) [ pong-window ] with-ui ;
-MAIN: play-pong-main
\ No newline at end of file
+MAIN: pong-window
\ No newline at end of file
--- /dev/null
+! Copyright (C) 2008 Joe Groff.
+! See http://factorcode.org/license.txt for BSD license.
+USING: help.markup help.syntax kernel quotations ui.gadgets
+graphics.bitmap strings ui.gadgets.worlds ;
+IN: ui.offscreen
+
+HELP: <offscreen-world>
+{ $values
+ { "gadget" gadget } { "title" string } { "status" "a boolean" }
+ { "world" offscreen-world }
+}
+{ $description "Constructs an " { $link offscreen-world } " gadget with " { $snippet "gadget" } " as its only child. Generally you should use " { $link open-offscreen } " or " { $link do-offscreen } " instead of calling this word directly." } ;
+
+HELP: close-offscreen
+{ $values
+ { "world" offscreen-world }
+}
+{ $description "Releases the resources used by the rendering buffer for " { $snippet "world" } "." } ;
+
+HELP: do-offscreen
+{ $values
+ { "gadget" gadget } { "quot" quotation }
+}
+{ $description "Constructs an " { $link offscreen-world } " around " { $snippet "gadget" } " with " { $link open-offscreen } ", calls " { $snippet "quotation" } " with the world on the top of the stack, and cleans up the world with " { $link close-offscreen } " at the end of " { $snippet "quotation" } "." } ;
+
+HELP: gadget>bitmap
+{ $values
+ { "gadget" gadget }
+ { "bitmap" bitmap }
+}
+{ $description "Renders " { $snippet "gadget" } " to an " { $link offscreen-world } " and creates a " { $link bitmap } " from its contents." } ;
+
+HELP: offscreen-world
+{ $class-description "The class of " { $link world } " objects that render to an offscreen buffer." } ;
+
+HELP: offscreen-world>bitmap
+{ $values
+ { "world" offscreen-world }
+ { "bitmap" bitmap }
+}
+{ $description "Saves a copy of the contents of " { $snippet "world" } " to a " { $link bitmap } " object." } ;
+
+HELP: open-offscreen
+{ $values
+ { "gadget" gadget }
+ { "world" offscreen-world }
+}
+{ $description "Creates and sets up an " { $link offscreen-world } " with " { $snippet "gadget" } " as its only child." } ;
+
+{ offscreen-world open-offscreen close-offscreen do-offscreen } related-words
+
+ARTICLE: "ui.offscreen" "Offscreen UI rendering"
+"The " { $vocab-link "ui.offscreen" } " provides words for rendering gadgets to an offscreen buffer so that bitmaps can be made from their contents."
+{ $subsection offscreen-world }
+"Opening gadgets offscreen:"
+{ $subsection open-offscreen }
+{ $subsection close-offscreen }
+{ $subsection do-offscreen }
+"Creating bitmaps from offscreen buffers:"
+{ $subsection offscreen-world>bitmap }
+{ $subsection gadget>bitmap } ;
+
+ABOUT: "ui.offscreen"
--- /dev/null
+! (c) 2008 Joe Groff, see license for details
+USING: accessors continuations graphics.bitmap kernel math
+sequences ui.gadgets ui.gadgets.worlds ui ui.backend
+destructors ;
+IN: ui.offscreen
+
+TUPLE: offscreen-world < world ;
+
+: <offscreen-world> ( gadget title status -- world )
+ offscreen-world new-world ;
+
+M: offscreen-world graft*
+ (open-offscreen-buffer) ;
+
+M: offscreen-world ungraft*
+ [ (ungraft-world) ]
+ [ handle>> (close-offscreen-buffer) ]
+ [ reset-world ] tri ;
+
+: open-offscreen ( gadget -- world )
+ "" f <offscreen-world>
+ [ open-world-window dup relayout-1 ] keep
+ notify-queued ;
+
+: close-offscreen ( world -- )
+ ungraft notify-queued ;
+
+: offscreen-world>bitmap ( world -- bitmap )
+ offscreen-pixels bgra>bitmap ;
+
+: do-offscreen ( gadget quot: ( offscreen-world -- ) -- )
+ [ open-offscreen ] dip
+ over [ slip ] [ close-offscreen ] [ ] cleanup ; inline
+
+: gadget>bitmap ( gadget -- bitmap )
+ [ offscreen-world>bitmap ] do-offscreen ;
--- /dev/null
+Offscreen world gadgets for rendering UI elements to bitmaps
--- /dev/null
+unportable
+ui
+graphics
(Chords ending in a single letter <x> accept also C-<x> (e.g. C-cC-z is
the same as C-cz)).
-* In factor files:
+* In factor source files:
- C-cz : switch to listener
- C-co : cycle between code, tests and docs factor files
- g : go to error
- <digit> : invoke nth restart
+ - w/e/l : invoke :warnings, :errors, :linkage
- q : bury buffer
+* In the Help browser:
+
+ - RET : help for word at point
+ - f/b : next/previous page
+ - SPC/S-SPC : scroll up/down
+ - q: bury buffer
" ")
len))
+(defsubst empty-string-p (str) (equal str ""))
+
(provide 'fuel-base)
;;; fuel-base.el ends here
--- /dev/null
+;;; fuel-connection.el -- asynchronous comms with the fuel listener
+
+;; Copyright (C) 2008 Jose Antonio Ortega Ruiz
+;; See http://factorcode.org/license.txt for BSD license.
+
+;; Author: Jose Antonio Ortega Ruiz <jao@gnu.org>
+;; Keywords: languages, fuel, factor
+;; Start date: Thu Dec 11, 2008 03:10
+
+;;; Comentary:
+
+;; Handling communications via a comint buffer running a factor
+;; listener.
+
+;;; Code:
+
+\f
+;;; Default connection:
+
+(make-variable-buffer-local
+ (defvar fuel-con--connection nil))
+
+(defun fuel-con--get-connection (buffer/proc)
+ (if (processp buffer/proc)
+ (fuel-con--get-connection (process-buffer buffer/proc))
+ (with-current-buffer buffer/proc
+ (or fuel-con--connection
+ (setq fuel-con--connection
+ (fuel-con--setup-connection buffer/proc))))))
+
+\f
+;;; Request and connection datatypes:
+
+(defun fuel-con--connection-queue-request (c r)
+ (let ((reqs (assoc :requests c)))
+ (setcdr reqs (append (cdr reqs) (list r)))))
+
+(defun fuel-con--make-request (str cont &optional sender-buffer)
+ (list :fuel-connection-request
+ (cons :id (random))
+ (cons :string str)
+ (cons :continuation cont)
+ (cons :buffer (or sender-buffer (current-buffer)))))
+
+(defsubst fuel-con--request-p (req)
+ (and (listp req) (eq (car req) :fuel-connection-request)))
+
+(defsubst fuel-con--request-id (req)
+ (cdr (assoc :id req)))
+
+(defsubst fuel-con--request-string (req)
+ (cdr (assoc :string req)))
+
+(defsubst fuel-con--request-continuation (req)
+ (cdr (assoc :continuation req)))
+
+(defsubst fuel-con--request-buffer (req)
+ (cdr (assoc :buffer req)))
+
+(defsubst fuel-con--request-deactivate (req)
+ (setcdr (assoc :continuation req) nil))
+
+(defsubst fuel-con--request-deactivated-p (req)
+ (null (cdr (assoc :continuation req))))
+
+(defsubst fuel-con--make-connection (buffer)
+ (list :fuel-connection
+ (list :requests)
+ (list :current)
+ (cons :completed (make-hash-table :weakness 'value))
+ (cons :buffer buffer)))
+
+(defsubst fuel-con--connection-p (c)
+ (and (listp c) (eq (car c) :fuel-connection)))
+
+(defsubst fuel-con--connection-requests (c)
+ (cdr (assoc :requests c)))
+
+(defsubst fuel-con--connection-current-request (c)
+ (cdr (assoc :current c)))
+
+(defun fuel-con--connection-clean-current-request (c)
+ (let* ((cell (assoc :current c))
+ (req (cdr cell)))
+ (when req
+ (puthash (fuel-con--request-id req) req (cdr (assoc :completed c)))
+ (setcdr cell nil))))
+
+(defsubst fuel-con--connection-completed-p (c id)
+ (gethash id (cdr (assoc :completed c))))
+
+(defsubst fuel-con--connection-buffer (c)
+ (cdr (assoc :buffer c)))
+
+(defun fuel-con--connection-pop-request (c)
+ (let ((reqs (assoc :requests c))
+ (current (assoc :current c)))
+ (setcdr current (prog1 (cadr reqs) (setcdr reqs (cddr reqs))))
+ (if (and current (fuel-con--request-deactivated-p current))
+ (fuel-con--connection-pop-request c)
+ current)))
+
+\f
+;;; Connection setup:
+
+(defun fuel-con--setup-connection (buffer)
+ (set-buffer buffer)
+ (let ((conn (fuel-con--make-connection buffer)))
+ (fuel-con--setup-comint)
+ (setq fuel-con--connection conn)))
+
+(defun fuel-con--setup-comint ()
+ (add-hook 'comint-redirect-filter-functions
+ 'fuel-con--comint-redirect-filter t t))
+
+\f
+;;; Requests handling:
+
+(defun fuel-con--process-next (con)
+ (when (not (fuel-con--connection-current-request con))
+ (let* ((buffer (fuel-con--connection-buffer con))
+ (req (fuel-con--connection-pop-request con))
+ (str (and req (fuel-con--request-string req))))
+ (when (and buffer req str)
+ (set-buffer buffer)
+ (comint-redirect-send-command str
+ (get-buffer-create "*factor messages*")
+ nil
+ t)))))
+
+(defun fuel-con--comint-redirect-filter (str)
+ (if (not fuel-con--connection)
+ (format "\nERROR: No connection in buffer (%s)\n" str)
+ (let ((req (fuel-con--connection-current-request fuel-con--connection)))
+ (if (not req) (format "\nERROR: No current request (%s)\n" str)
+ (let ((cont (fuel-con--request-continuation req))
+ (id (fuel-con--request-id req))
+ (rstr (fuel-con--request-string req))
+ (buffer (fuel-con--request-buffer req)))
+ (prog1
+ (if (not cont)
+ (format "\nWARNING: Droping result for request %s:%S (%s)\n"
+ id rstr str)
+ (condition-case cerr
+ (with-current-buffer (or buffer (current-buffer))
+ (funcall cont str)
+ (format "\nINFO: %s:%S processed\nINFO: %s\n" id rstr str))
+ (error (format "\nERROR: continuation failed %s:%S \nERROR: %s\n"
+ id rstr cerr))))
+ (fuel-con--connection-clean-current-request fuel-con--connection)))))))
+
+\f
+;;; Message sending interface:
+
+(defun fuel-con--send-string (buffer/proc str cont &optional sender-buffer)
+ (save-current-buffer
+ (let ((con (fuel-con--get-connection buffer/proc)))
+ (unless con
+ (error "FUEL: couldn't find connection"))
+ (let ((req (fuel-con--make-request str cont sender-buffer)))
+ (fuel-con--connection-queue-request con req)
+ (fuel-con--process-next con)
+ req))))
+
+(defvar fuel-connection-timeout 30000
+ "Time limit, in msecs, blocking on synchronous evaluation requests")
+
+(defun fuel-con--send-string/wait (buffer/proc str cont &optional timeout sbuf)
+ (save-current-buffer
+ (let* ((con (fuel-con--get-connection buffer/proc))
+ (req (fuel-con--send-string buffer/proc str cont sbuf))
+ (id (and req (fuel-con--request-id req)))
+ (time (or timeout fuel-connection-timeout))
+ (step 2))
+ (when id
+ (while (and (> time 0)
+ (not (fuel-con--connection-completed-p con id)))
+ (sleep-for 0 step)
+ (setq time (- time step)))
+ (or (> time 0)
+ (fuel-con--request-deactivate req)
+ nil)))))
+
+\f
+(provide 'fuel-connection)
+;;; fuel-connection.el ends here
(buffer (if file (find-file-noselect file) (current-buffer))))
(with-current-buffer buffer
(fuel-debug--display-retort
- (fuel-eval--eval-string/context (format ":%s" n))
+ (fuel-eval--send/wait (fuel-eval--cmd/string (format ":%s" n)))
(format "Restart %s (%s) successful" n (nth (1- n) rs))))))))
(defun fuel-debug-show--compiler-info (info)
(error "%s information not available" info))
(message "Retrieving %s info ..." info)
(unless (fuel-debug--display-retort
- (fuel-eval--eval-string info) "" (fuel-debug--buffer-file))
+ (fuel-eval--send/wait (fuel-eval--cmd/string info))
+ "" (fuel-debug--buffer-file))
(error "Sorry, no %s info available" info))))
\f
-;;; fuel-eval.el --- utilities for communication with fuel-listener
+;;; fuel-eval.el --- evaluating Factor expressions
;; Copyright (C) 2008 Jose Antonio Ortega Ruiz
;; See http://factorcode.org/license.txt for BSD license.
;;; Commentary:
-;; Protocols for handling communications via a comint buffer running a
-;; factor listener.
+;; Protocols for sending evaluations to the Factor listener.
;;; Code:
(require 'fuel-base)
(require 'fuel-syntax)
+(require 'fuel-connection)
\f
-;;; Syncronous string sending:
-
-(defvar fuel-eval-log-max-length 16000)
-
-(defvar fuel-eval--default-proc-function nil)
-(defsubst fuel-eval--default-proc ()
- (and fuel-eval--default-proc-function
- (funcall fuel-eval--default-proc-function)))
-
-(defvar fuel-eval--proc nil)
-(defvar fuel-eval--log t)
-
-(defun fuel-eval--send-string (str)
- (let ((proc (or fuel-eval--proc (fuel-eval--default-proc))))
- (when proc
- (with-current-buffer (get-buffer-create "*factor messages*")
- (goto-char (point-max))
- (when (and (> fuel-eval-log-max-length 0)
- (> (point) fuel-eval-log-max-length))
- (erase-buffer))
- (when fuel-eval--log (insert "\n>> " (fuel--shorten-str str 256)))
- (newline)
- (let ((beg (point)))
- (comint-redirect-send-command-to-process str (current-buffer) proc nil t)
- (with-current-buffer (process-buffer proc)
- (while (not comint-redirect-completed) (sleep-for 0 1)))
- (goto-char beg)
- (current-buffer))))))
-
-\f
-;;; Evaluation protocol
+;;; Retort and retort-error datatypes:
(defsubst fuel-eval--retort-make (err result &optional output)
(list err result output))
(defsubst fuel-eval--retort-p (ret) (listp ret))
(defsubst fuel-eval--make-parse-error-retort (str)
- (fuel-eval--retort-make 'parse-retort-error nil str))
+ (fuel-eval--retort-make (cons 'fuel-parse-retort-error str) nil))
-(defun fuel-eval--parse-retort (buffer)
+(defun fuel-eval--parse-retort (str)
(save-current-buffer
- (set-buffer buffer)
(condition-case nil
- (read (current-buffer))
- (error (fuel-eval--make-parse-error-retort
- (buffer-substring-no-properties (point) (point-max)))))))
-
-(defsubst fuel-eval--send/retort (str)
- (fuel-eval--parse-retort (fuel-eval--send-string str)))
-
-(defsubst fuel-eval--eval-begin ()
- (fuel-eval--send/retort "fuel-begin-eval"))
-
-(defsubst fuel-eval--eval-end ()
- (fuel-eval--send/retort "fuel-begin-eval"))
-
-(defsubst fuel-eval--factor-array (strs)
- (format "V{ %S }" (mapconcat 'identity strs " ")))
-
-(defsubst fuel-eval--eval-strings (strs &optional no-restart)
- (let ((str (format "fuel-eval-%s %s fuel-eval"
- (if no-restart "non-restartable" "restartable")
- (fuel-eval--factor-array strs))))
- (fuel-eval--send/retort str)))
-
-(defsubst fuel-eval--eval-string (str &optional no-restart)
- (fuel-eval--eval-strings (list str) no-restart))
-
-(defun fuel-eval--eval-strings/context (strs &optional no-restart)
- (let ((usings (fuel-syntax--usings-update)))
- (fuel-eval--send/retort
- (format "fuel-eval-%s %s %S %s fuel-eval-in-context"
- (if no-restart "non-restartable" "restartable")
- (fuel-eval--factor-array strs)
- (or fuel-syntax--current-vocab "f")
- (if usings (fuel-eval--factor-array usings) "f")))))
-
-(defsubst fuel-eval--eval-string/context (str &optional no-restart)
- (fuel-eval--eval-strings/context (list str) no-restart))
-
-(defun fuel-eval--eval-region/context (begin end &optional no-restart)
- (let ((lines (split-string (buffer-substring-no-properties begin end)
- "[\f\n\r\v]+" t)))
- (when (> (length lines) 0)
- (fuel-eval--eval-strings/context lines no-restart))))
-
-\f
-;;; Error parsing
+ (let ((ret (car (read-from-string str))))
+ (if (fuel-eval--retort-p ret) ret (error)))
+ (error (fuel-eval--make-parse-error-retort str)))))
(defsubst fuel-eval--error-name (err) (car err))
(defsubst fuel-eval--error-line-text (err)
(nth 3 (fuel-eval--error-lexer-p err)))
+\f
+;;; String sending::
+
+(defvar fuel-eval-log-max-length 16000)
+
+(defvar fuel-eval--default-proc-function nil)
+(defsubst fuel-eval--default-proc ()
+ (and fuel-eval--default-proc-function
+ (funcall fuel-eval--default-proc-function)))
+
+(defvar fuel-eval--proc nil)
+
+(defvar fuel-eval--log t)
+
+(defvar fuel-eval--sync-retort nil)
+
+(defun fuel-eval--send/wait (str &optional timeout buffer)
+ (setq fuel-eval--sync-retort nil)
+ (fuel-con--send-string/wait (or fuel-eval--proc (fuel-eval--default-proc))
+ str
+ '(lambda (s)
+ (setq fuel-eval--sync-retort
+ (fuel-eval--parse-retort s)))
+ timeout
+ buffer)
+ fuel-eval--sync-retort)
+
+(defun fuel-eval--send (str cont &optional buffer)
+ (fuel-con--send-string (or fuel-eval--proc (fuel-eval--default-proc))
+ str
+ `(lambda (s) (,cont (fuel-eval--parse-retort s)))
+ buffer))
+
+\f
+;;; Evaluation protocol
+
+(defsubst fuel-eval--factor-array (strs)
+ (format "V{ %S }" (mapconcat 'identity strs " ")))
+
+(defun fuel-eval--cmd/lines (strs &optional no-rs in usings)
+ (unless (and in usings) (fuel-syntax--usings-update))
+ (let* ((in (cond ((not in) (or fuel-syntax--current-vocab "f"))
+ ((eq in t) "fuel-scratchpad")
+ (in in)))
+ (usings (cond ((not usings) fuel-syntax--usings)
+ ((eq usings t) nil)
+ (usings usings))))
+ (format "fuel-eval-%srestartable %s %S %s fuel-eval-in-context"
+ (if no-rs "non-" "")
+ (fuel-eval--factor-array strs)
+ in
+ (fuel-eval--factor-array usings))))
+
+(defsubst fuel-eval--cmd/string (str &optional no-rs in usings)
+ (fuel-eval--cmd/lines (list str) no-rs in usings))
+
+(defun fuel-eval--cmd/region (begin end &optional no-rs in usings)
+ (let ((lines (split-string (buffer-substring-no-properties begin end)
+ "[\f\n\r\v]+" t)))
+ (when (> (length lines) 0)
+ (fuel-eval--cmd/lines lines no-rs in usings))))
+
+
\f
(provide 'fuel-eval)
;;; fuel-eval.el ends here
(,fuel-syntax--type-definition-regex 2 'factor-font-lock-type-name)
(,fuel-syntax--method-definition-regex (1 'factor-font-lock-type-name)
(2 'factor-font-lock-word))
- (,fuel-syntax--parent-type-regex 1 'factor-font-lock-type)
+ (,fuel-syntax--parent-type-regex 1 'factor-font-lock-type-name)
(,fuel-syntax--constructor-regex . 'factor-font-lock-constructor)
(,fuel-syntax--setter-regex . 'factor-font-lock-setter-word)
(,fuel-syntax--symbol-definition-regex 2 'factor-font-lock-symbol)
:type 'hook
:group 'fuel-help)
+(defcustom fuel-help-history-cache-size 50
+ "Maximum number of pages to keep in the help browser cache."
+ :type 'integer
+ :group 'fuel-help)
+
(defface fuel-help-font-lock-headlines '((t (:bold t :weight bold)))
"Face for headlines in help buffers."
:group 'fuel-help
(let ((word (or word (fuel-syntax-symbol-at-point)))
(fuel-eval--log t))
(when word
- (let ((ret (fuel-eval--eval-string/context
- (format "\\ %s synopsis fuel-eval-set-result" word)
- t)))
- (when (not (fuel-eval--retort-error ret))
+ (let* ((str (format "\\ %s synopsis fuel-eval-set-result" word))
+ (cmd (fuel-eval--cmd/string str t t))
+ (ret (fuel-eval--send/wait cmd 20)))
+ (when (and ret (not (fuel-eval--retort-error ret)))
(if fuel-help-minibuffer-font-lock
(fuel-help--font-lock-str (fuel-eval--retort-result ret))
(fuel-eval--retort-result ret)))))))
(message "Fuel Autodoc %s" (if fuel-autodoc-mode "enabled" "disabled")))
\f
-;;;; Factor help mode:
-
-(defvar fuel-help-mode-map (make-sparse-keymap)
- "Keymap for Factor help mode.")
-
-(define-key fuel-help-mode-map [(return)] 'fuel-help)
-
-(defconst fuel-help--headlines
- (regexp-opt '("Class description"
- "Definition"
- "Examples"
- "Generic word contract"
- "Inputs and outputs"
- "Methods"
- "Notes"
- "Parent topics:"
- "See also"
- "Syntax"
- "Vocabulary"
- "Warning"
- "Word description")
- t))
+;;; Help browser history:
-(defconst fuel-help--headlines-regexp (format "^%s" fuel-help--headlines))
+(defvar fuel-help--history
+ (list nil
+ (make-ring fuel-help-history-cache-size)
+ (make-ring fuel-help-history-cache-size)))
-(defconst fuel-help--font-lock-keywords
- `(,@fuel-font-lock--font-lock-keywords
- (,fuel-help--headlines-regexp . 'fuel-help-font-lock-headlines)))
+(defvar fuel-help--history-idx 0)
-(defun fuel-help-mode ()
- "Major mode for displaying Factor documentation.
-\\{fuel-help-mode-map}"
- (interactive)
- (kill-all-local-variables)
- (use-local-map fuel-help-mode-map)
- (setq mode-name "Factor Help")
- (setq major-mode 'fuel-help-mode)
+(defun fuel-help--history-push (term)
+ (when (car fuel-help--history)
+ (ring-insert (nth 1 fuel-help--history) (car fuel-help--history)))
+ (setcar fuel-help--history term))
- (fuel-font-lock--font-lock-setup fuel-help--font-lock-keywords t)
+(defun fuel-help--history-next ()
+ (when (not (ring-empty-p (nth 2 fuel-help--history)))
+ (when (car fuel-help--history)
+ (ring-insert (nth 1 fuel-help--history) (car fuel-help--history)))
+ (setcar fuel-help--history (ring-remove (nth 2 fuel-help--history) 0))))
- (set (make-local-variable 'view-no-disable-on-exit) t)
- (view-mode)
- (setq view-exit-action
- (lambda (buffer)
- ;; Use `with-current-buffer' to make sure that `bury-buffer'
- ;; also removes BUFFER from the selected window.
- (with-current-buffer buffer
- (bury-buffer))))
+(defun fuel-help--history-previous ()
+ (when (not (ring-empty-p (nth 1 fuel-help--history)))
+ (when (car fuel-help--history)
+ (ring-insert (nth 2 fuel-help--history) (car fuel-help--history)))
+ (setcar fuel-help--history (ring-remove (nth 1 fuel-help--history) 0))))
- (setq fuel-autodoc-mode-string "")
- (fuel-autodoc-mode)
- (run-mode-hooks 'fuel-help-mode-hook))
+\f
+;;; Fuel help buffer and internals:
(defun fuel-help--help-buffer ()
(with-current-buffer (get-buffer-create "*fuel-help*")
(fuel-help-mode)
(current-buffer)))
-(defvar fuel-help--history nil)
+(defvar fuel-help--prompt-history nil)
-(defun fuel-help--show-help (&optional see)
- (let* ((def (fuel-syntax-symbol-at-point))
+(defun fuel-help--show-help (&optional see word)
+ (let* ((def (or word (fuel-syntax-symbol-at-point)))
(prompt (format "See%s help on%s: " (if see " short" "")
(if def (format " (%s)" def) "")))
(ask (or (not (memq major-mode '(factor-mode fuel-help-mode)))
(not def)
fuel-help-always-ask))
- (def (if ask (read-string prompt nil 'fuel-help--history def) def))
- (cmd (format "\\ %s %s" def (if see "see" "help")))
- (fuel-eval--log nil)
- (ret (fuel-eval--eval-string/context cmd t))
- (out (fuel-eval--retort-output ret)))
+ (def (if ask (read-string prompt nil 'fuel-help--prompt-history def)
+ def))
+ (cmd (format "\\ %s %s" def (if see "see" "help"))))
+ (message "Looking up '%s' ..." def)
+ (fuel-eval--send (fuel-eval--cmd/string cmd t t)
+ `(lambda (r) (fuel-help--show-help-cont ,def r)))))
+
+(defun fuel-help--show-help-cont (def ret)
+ (let ((out (fuel-eval--retort-output ret)))
(if (or (fuel-eval--retort-error ret) (empty-string-p out))
(message "No help for '%s'" def)
- (let ((hb (fuel-help--help-buffer))
- (inhibit-read-only t)
- (font-lock-verbose nil))
- (set-buffer hb)
- (erase-buffer)
- (insert out)
- (set-buffer-modified-p nil)
- (pop-to-buffer hb)
- (goto-char (point-min))))))
+ (fuel-help--insert-contents def out))))
+
+(defun fuel-help--insert-contents (def str &optional nopush)
+ (let ((hb (fuel-help--help-buffer))
+ (inhibit-read-only t)
+ (font-lock-verbose nil))
+ (set-buffer hb)
+ (erase-buffer)
+ (insert str)
+ (goto-char (point-min))
+ (when (re-search-forward (format "^%s" def) nil t)
+ (beginning-of-line)
+ (kill-region (point-min) (point))
+ (next-line)
+ (open-line 1))
+ (set-buffer-modified-p nil)
+ (unless nopush (fuel-help--history-push (cons def str)))
+ (pop-to-buffer hb)
+ (goto-char (point-min))
+ (message "%s" def)))
\f
-;;; Interface: see/help commands
+;;; Interactive help commands:
(defun fuel-help-short (&optional arg)
"See a help summary of symbol at point.
(interactive)
(fuel-help--show-help))
+(defun fuel-help-next ()
+ "Go to next page in help browser."
+ (interactive)
+ (let ((item (fuel-help--history-next))
+ (fuel-help-always-ask nil))
+ (unless item
+ (error "No next page"))
+ (fuel-help--insert-contents (car item) (cdr item) t)))
+
+(defun fuel-help-previous ()
+ "Go to next page in help browser."
+ (interactive)
+ (let ((item (fuel-help--history-previous))
+ (fuel-help-always-ask nil))
+ (unless item
+ (error "No previous page"))
+ (fuel-help--insert-contents (car item) (cdr item) t)))
+
+\f
+;;;; Factor help mode:
+
+(defvar fuel-help-mode-map
+ (let ((map (make-sparse-keymap)))
+ (define-key map "\C-m" 'fuel-help)
+ (define-key map "q" 'bury-buffer)
+ (define-key map "b" 'fuel-help-previous)
+ (define-key map "f" 'fuel-help-next)
+ (define-key map (kbd "SPC") 'scroll-up)
+ (define-key map (kbd "S-SPC") 'scroll-down)
+ map))
+
+(defconst fuel-help--headlines
+ (regexp-opt '("Class description"
+ "Definition"
+ "Errors"
+ "Examples"
+ "Generic word contract"
+ "Inputs and outputs"
+ "Methods"
+ "Notes"
+ "Parent topics:"
+ "See also"
+ "Syntax"
+ "Variable description"
+ "Variable value"
+ "Vocabulary"
+ "Warning"
+ "Word description")
+ t))
+
+(defconst fuel-help--headlines-regexp (format "^%s" fuel-help--headlines))
+
+(defconst fuel-help--font-lock-keywords
+ `(,@fuel-font-lock--font-lock-keywords
+ (,fuel-help--headlines-regexp . 'fuel-help-font-lock-headlines)))
+
+(defun fuel-help-mode ()
+ "Major mode for browsing Factor documentation.
+\\{fuel-help-mode-map}"
+ (interactive)
+ (kill-all-local-variables)
+ (use-local-map fuel-help-mode-map)
+ (setq mode-name "Factor Help")
+ (setq major-mode 'fuel-help-mode)
+
+ (fuel-font-lock--font-lock-setup fuel-help--font-lock-keywords t)
+
+ (setq fuel-autodoc-mode-string "")
+ (fuel-autodoc-mode)
+
+ (run-mode-hooks 'fuel-help-mode-hook)
+ (toggle-read-only 1))
+
\f
(provide 'fuel-help)
;;; fuel-help.el ends here
(comint-exec fuel-listener-buffer "factor"
factor nil `("-run=fuel" ,(format "-i=%s" image)))
(fuel-listener--wait-for-prompt 20)
- (fuel-eval--send-string "USE: fuel")
+ (fuel-eval--send/wait "USE: fuel")
(message "FUEL listener up and running!"))))
(defun fuel-listener--process (&optional start)
;;; Prompt chasing
(defun fuel-listener--wait-for-prompt (&optional timeout)
- (let ((proc (get-buffer-process fuel-listener-buffer))
- (seen))
- (with-current-buffer fuel-listener-buffer
- (while (progn (goto-char comint-last-input-end)
- (not (or seen
- (setq seen
- (re-search-forward comint-prompt-regexp nil t))
- (not (accept-process-output proc timeout))))))
- (goto-char (point-max)))
- (unless seen
+ (let ((proc (get-buffer-process fuel-listener-buffer)))
+ (with-current-buffer fuel-listener-buffer
+ (goto-char (or comint-last-input-end (point-min)))
+ (let ((seen (re-search-forward comint-prompt-regexp nil t)))
+ (while (and (not seen)
+ (accept-process-output proc (or timeout 10) nil t))
+ (sleep-for 0 1)
+ (goto-char comint-last-input-end)
+ (setq seen (re-search-forward comint-prompt-regexp nil t)))
(pop-to-buffer fuel-listener-buffer)
- (error "No prompt found!"))))
+ (goto-char (point-max))
+ (unless seen (error "No prompt found!"))))))
\f
;;; Interface: starting fuel listener
(set (make-local-variable 'comint-prompt-read-only) t)
(setq fuel-listener--compilation-begin nil))
+(define-key fuel-listener-mode-map "\C-cz" 'run-factor)
+(define-key fuel-listener-mode-map "\C-c\C-z" 'run-factor)
(define-key fuel-listener-mode-map "\C-ch" 'fuel-help)
(define-key fuel-listener-mode-map "\M-." 'fuel-edit-word-at-point)
(define-key fuel-listener-mode-map "\C-ck" 'fuel-run-file)
(let* ((file (or (and arg (read-file-name "File: " nil (buffer-file-name) t))
(buffer-file-name)))
(file (expand-file-name file))
- (buffer (find-file-noselect file))
- (cmd (format "%S fuel-run-file" file)))
+ (buffer (find-file-noselect file)))
(when buffer
(with-current-buffer buffer
(message "Compiling %s ..." file)
- (let ((r (fuel-debug--display-retort (fuel-eval--eval-string/context cmd)
- (format "%s successfully compiled" file)
- nil
- file)))
- (if r (message "Compiling %s ... OK!" file) (message "")))))))
+ (fuel-eval--send (fuel-eval--cmd/string (format "%S fuel-run-file" file))
+ `(lambda (r) (fuel--run-file-cont r ,file)))))))
+
+(defun fuel--run-file-cont (ret file)
+ (if (fuel-debug--display-retort ret
+ (format "%s successfully compiled" file)
+ nil
+ file)
+ (message "Compiling %s ... OK!" file)
+ (message "")))
(defun fuel-eval-region (begin end &optional arg)
"Sends region to Fuel's listener for evaluation.
buffer in case of errors."
(interactive "r\nP")
(fuel-debug--display-retort
- (fuel-eval--eval-region/context begin end)
+ (fuel-eval--send/wait (fuel-eval--cmd/region begin end) 10000)
(format "%s%s"
(if fuel-syntax--current-vocab
(format "IN: %s " fuel-syntax--current-vocab)
(if word (format " (%s)" word) ""))
word)
word)))
- (let* ((ret (fuel-eval--eval-string/context
+ (let* ((str (fuel-eval--cmd/string
(format "\\ %s fuel-get-edit-location" word)))
+ (ret (fuel-eval--send/wait str))
(err (fuel-eval--retort-error ret))
(loc (fuel-eval--retort-result ret)))
(when (or err (not loc) (not (listp loc)) (not (stringp (car loc))))
DLL_EXTENSION = .dylib
ifdef X11
- LIBS = -lm -framework Foundation $(X11_UI_LIBS) -Wl,-dylib_file,/System/Library/Frameworks/OpenGL.framework/Versions/A/Libraries/libGL.dylib:/System/Library/Frameworks/OpenGL.framework/Versions/A/Libraries/libGL.dylib
+ LIBS = -lm -framework Cocoa $(X11_UI_LIBS) -Wl,-dylib_file,/System/Library/Frameworks/OpenGL.framework/Versions/A/Libraries/libGL.dylib:/System/Library/Frameworks/OpenGL.framework/Versions/A/Libraries/libGL.dylib
else
LIBS = -lm -framework Cocoa -framework AppKit
endif
projects / factor.git / commitdiff