Merge branch 'master' into new_ui

basis/bootstrap/finish-bootstrap.factor

@@ -12,5 +12,6 @@ namespaces eval kernel vocabs.loader io ;
         ignore-cli-args? not script get and
         [ run-script ] [ "run" get run ] if*
         output-stream get [ stream-flush ] when*
+        0 exit
     ] [ print-error 1 exit ] recover
 ] set-boot-quot

basis/bootstrap/finish-staging.factor

@@ -7,4 +7,5 @@ io ;
     (command-line) parse-command-line
     "run" get run
     output-stream get [ stream-flush ] when*
+    0 exit
 ] set-boot-quot

basis/bootstrap/stage2.factor

@@ -102,6 +102,8 @@ SYMBOL: bootstrap-time
     ] 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

basis/cocoa/application/application-docs.factor

@@ -1,5 +1,5 @@
 USING: debugger quotations help.markup help.syntax strings alien
-core-foundation ;
+core-foundation core-foundation.strings core-foundation.arrays ;
 IN: cocoa.application
 
 HELP: <NSString>

basis/cocoa/application/application.factor

@@ -1,9 +1,10 @@
 ! 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
+ core-foundation.arrays
-cocoa.runtime sequences threads init summary kernel.private
+core-foundation.data core-foundation.strings cocoa.messages
-assocs ;
+cocoa cocoa.classes cocoa.runtime sequences threads init summary
+kernel.private assocs ;
 IN: cocoa.application
 
 : <NSString> ( str -- alien ) <CFString> -> autorelease ;
@@ -34,13 +35,6 @@ FUNCTION: void NSBeep ( ) ;
 : with-cocoa ( quot -- )
     [ NSApp drop call ] with-autorelease-pool ; inline
 
-: next-event ( app -- event )
-    NSAnyEventMask f CFRunLoopDefaultMode 1
-    -> nextEventMatchingMask:untilDate:inMode:dequeue: ;
-
-: do-event ( app -- ? )
-    dup next-event [ dupd -> sendEvent: -> updateWindows t ] [ drop f ] if* ;
-
 : add-observer ( observer selector name object -- )
     [
         [ NSNotificationCenter -> defaultCenter ] 2dip

basis/cocoa/cocoa.factor

@@ -2,8 +2,8 @@
 ! 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
+core-foundation.bundles namespaces assocs hashtables
-lexer init ;
+compiler.units lexer init ;
 IN: cocoa
 
 : (remember-send) ( selector variable -- )

basis/cocoa/dialogs/dialogs.factor

@@ -1,7 +1,8 @@
 ! 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 )

basis/cocoa/nibs/nibs.factor

@@ -1,5 +1,8 @@
-USING: cocoa.application cocoa.messages cocoa.classes cocoa.runtime 
+! Copyright (C) 2008 Slava Pestov.
-kernel cocoa core-foundation alien.c-types ;
+! See http://factorcode.org/license.txt for BSD license.
+USING: cocoa.application cocoa.messages cocoa.classes
+cocoa.runtime kernel cocoa alien.c-types core-foundation
+core-foundation.arrays ;
 IN: cocoa.nibs
 
 : load-nib ( name -- )

basis/cocoa/pasteboard/pasteboard.factor

@@ -1,8 +1,8 @@
 ! 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" ;

basis/cocoa/plists/plists.factor

@@ -3,7 +3,7 @@
 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 )

basis/cocoa/views/views.factor

@@ -55,10 +55,9 @@ PRIVATE>
 : with-multisample ( quot -- )
     t +multisample+ pick with-variable ; inline
 
-: <PixelFormat> ( -- pixelfmt )
+: <PixelFormat> ( attributes -- pixelfmt )
-    NSOpenGLPixelFormat -> alloc [
+    NSOpenGLPixelFormat -> alloc swap [
-        NSOpenGLPFAWindow ,
+        %
-        NSOpenGLPFADoubleBuffer ,
         NSOpenGLPFADepthSize , 16 ,
         +software-renderer+ get [
             NSOpenGLPFARendererID , kCGLRendererGenericFloatID ,
@@ -74,7 +73,8 @@ PRIVATE>
     -> 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: ;

basis/core-foundation/arrays/arrays-docs.factor

@@ -0,0 +1,11 @@
+USING: help.syntax help.markup arrays alien ;
+IN: core-foundation.arrays
+
+HELP: CF>array
+{ $values { "alien" "a " { $snippet "CFArray" } } { "array" "an array of " { $link alien } " instances" } }
+{ $description "Creates a Factor array from a Core Foundation array." } ;
+
+HELP: <CFArray>
+{ $values { "seq" "a sequence of " { $link alien } " instances" } { "alien" "a " { $snippet "CFArray" } } }
+{ $description "Creates a Core Foundation array from a Factor array." } ;
+

basis/core-foundation/arrays/arrays.factor

@@ -0,0 +1,22 @@
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: alien.syntax kernel sequences ;
+IN: core-foundation.arrays
+
+TYPEDEF: void* CFArrayRef
+
+FUNCTION: CFArrayRef CFArrayCreateMutable ( CFAllocatorRef allocator, CFIndex capacity, void* callbacks ) ;
+
+FUNCTION: void* CFArrayGetValueAtIndex ( CFArrayRef array, CFIndex idx ) ;
+
+FUNCTION: void CFArraySetValueAtIndex ( CFArrayRef array, CFIndex index, void* value ) ;
+
+FUNCTION: CFIndex CFArrayGetCount ( CFArrayRef array ) ;
+
+: CF>array ( alien -- array )
+    dup CFArrayGetCount [ CFArrayGetValueAtIndex ] with map ;
+
+: <CFArray> ( seq -- alien )
+    [ f swap length f CFArrayCreateMutable ] keep
+    [ length ] keep
+    [ [ dupd ] dip CFArraySetValueAtIndex ] 2each ;

basis/core-foundation/arrays/tags.txt

@@ -0,0 +1,2 @@
+unportable
+bindings

basis/core-foundation/bundles/bundles-docs.factor

@@ -0,0 +1,11 @@
+USING: help.syntax help.markup ;
+IN: core-foundation.bundles
+
+HELP: <CFBundle>
+{ $values { "string" "a pathname string" } { "bundle" "a " { $snippet "CFBundle" } } }
+{ $description "Creates a new " { $snippet "CFBundle" } "." } ;
+
+HELP: load-framework
+{ $values { "name" "a pathname string" } }
+{ $description "Loads a Core Foundation framework." } ;
+

basis/core-foundation/bundles/bundles.factor

@@ -0,0 +1,23 @@
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: alien.syntax kernel sequences core-foundation
+core-foundation.urls ;
+IN: core-foundation.bundles
+
+TYPEDEF: void* CFBundleRef
+
+FUNCTION: CFBundleRef CFBundleCreate ( CFAllocatorRef allocator, CFURLRef bundleURL ) ;
+
+FUNCTION: Boolean CFBundleLoadExecutable ( CFBundleRef bundle ) ;
+
+: <CFBundle> ( string -- bundle )
+    t <CFFileSystemURL> [
+        f swap CFBundleCreate
+    ] keep CFRelease ;
+
+: load-framework ( name -- )
+    dup <CFBundle> [
+        CFBundleLoadExecutable drop
+    ] [
+        "Cannot load bundle named " prepend throw
+    ] ?if ;

basis/core-foundation/bundles/tags.txt

@@ -0,0 +1,2 @@
+unportable
+bindings

basis/core-foundation/core-foundation-docs.factor

@@ -1,42 +1,6 @@
 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." } ;
@@ -46,24 +10,3 @@ HELP: |CFRelease
 { $description "Marks the given Core Foundation object for release via " { $link CFRelease } " in the event of an error at the end of the enclosing " { $link with-destructors } " scope." } ;
 
 { 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"

basis/core-foundation/core-foundation.factor

@@ -1,212 +1,24 @@
 ! 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
+USING: alien.syntax destructors accessors kernel ;
-math sequences io.encodings.utf8 destructors accessors
-combinators byte-arrays ;
 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: uint UInt32
 TYPEDEF: ulong CFTypeID
 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 ;
-
 TUPLE: CFRelease-destructor alien disposed ;
 
 M: CFRelease-destructor dispose* alien>> CFRelease ;

basis/core-foundation/data/data.factor

@@ -0,0 +1,58 @@
+! Copyright (C) 2008 Joe Groff.
+! See http://factorcode.org/license.txt for BSD license.
+USING: alien.syntax alien.c-types sequences kernel math ;
+IN: core-foundation.data
+
+TYPEDEF: void* CFDataRef
+TYPEDEF: void* CFDictionaryRef
+TYPEDEF: void* CFMutableDictionaryRef
+TYPEDEF: void* CFNumberRef
+TYPEDEF: void* CFSetRef
+TYPEDEF: void* CFUUIDRef
+
+TYPEDEF: int CFNumberType
+: kCFNumberSInt8Type 1 ; inline
+: kCFNumberSInt16Type 2 ; inline
+: kCFNumberSInt32Type 3 ; inline
+: kCFNumberSInt64Type 4 ; inline
+: kCFNumberFloat32Type 5 ; inline
+: kCFNumberFloat64Type 6 ; inline
+: kCFNumberCharType 7 ; inline
+: kCFNumberShortType 8 ; inline
+: kCFNumberIntType 9 ; inline
+: kCFNumberLongType 10 ; inline
+: kCFNumberLongLongType 11 ; inline
+: kCFNumberFloatType 12 ; inline
+: kCFNumberDoubleType 13 ; inline
+: kCFNumberCFIndexType 14 ; inline
+: kCFNumberNSIntegerType 15 ; inline
+: kCFNumberCGFloatType 16 ; inline
+: kCFNumberMaxType 16 ; inline
+
+TYPEDEF: int CFPropertyListMutabilityOptions
+: kCFPropertyListImmutable                  0 ; inline
+: kCFPropertyListMutableContainers          1 ; inline
+: kCFPropertyListMutableContainersAndLeaves 2 ; inline
+
+FUNCTION: CFNumberRef CFNumberCreate ( CFAllocatorRef allocator, CFNumberType theType, void* valuePtr ) ;
+
+FUNCTION: CFDataRef CFDataCreate ( CFAllocatorRef allocator, uchar* bytes, CFIndex length ) ;
+
+FUNCTION: CFTypeID CFGetTypeID ( CFTypeRef cf ) ;
+
+GENERIC: <CFNumber> ( number -- alien )
+
+M: integer <CFNumber>
+    [ f kCFNumberLongLongType ] dip <longlong> CFNumberCreate ;
+
+M: float <CFNumber>
+    [ f kCFNumberDoubleType ] dip <double> CFNumberCreate ;
+
+M: t <CFNumber>
+    drop f kCFNumberIntType 1 <int> CFNumberCreate ;
+
+M: f <CFNumber>
+    drop f kCFNumberIntType 0 <int> CFNumberCreate ;
+
+: <CFData> ( byte-array -- alien )
+    [ f ] dip dup length CFDataCreate ;

basis/core-foundation/data/tags.txt

@@ -0,0 +1,2 @@
+unportable
+bindings

basis/core-foundation/file-descriptors/file-descriptors.factor

@@ -0,0 +1,32 @@
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: alien.syntax kernel math.bitwise core-foundation ;
+IN: core-foundation.file-descriptors
+
+TYPEDEF: void* CFFileDescriptorRef
+TYPEDEF: int CFFileDescriptorNativeDescriptor
+TYPEDEF: void* CFFileDescriptorCallBack
+
+FUNCTION: CFFileDescriptorRef CFFileDescriptorCreate (
+    CFAllocatorRef allocator,
+    CFFileDescriptorNativeDescriptor fd,
+    Boolean closeOnInvalidate,
+    CFFileDescriptorCallBack callout, 
+    CFFileDescriptorContext* context
+) ;
+
+: kCFFileDescriptorReadCallBack 1 ; inline
+: kCFFileDescriptorWriteCallBack 2 ; inline
+   
+FUNCTION: void CFFileDescriptorEnableCallBacks (
+    CFFileDescriptorRef f,
+    CFOptionFlags callBackTypes
+) ;
+
+: enable-all-callbacks ( fd -- )
+    { kCFFileDescriptorReadCallBack kCFFileDescriptorWriteCallBack } flags
+    CFFileDescriptorEnableCallBacks ;
+
+: <CFFileDescriptor> ( fd callback -- handle )
+    [ f swap ] [ t swap ] bi* f CFFileDescriptorCreate
+    [ "CFFileDescriptorCreate failed" throw ] unless* ;

basis/core-foundation/file-descriptors/tags.txt

@@ -0,0 +1,2 @@
+unportable
+bindings

basis/core-foundation/fsevents/fsevents.factor

@@ -2,11 +2,11 @@
 ! 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
+continuations combinators io.encodings.utf8 destructors locals
-core-foundation.run-loop core-foundation.run-loop.thread
+arrays specialized-arrays.direct.alien
-io.encodings.utf8 destructors locals arrays
+specialized-arrays.direct.int specialized-arrays.direct.longlong
-specialized-arrays.direct.alien specialized-arrays.direct.int
+core-foundation core-foundation.run-loop core-foundation.strings
-specialized-arrays.direct.longlong ;
+core-foundation.time ;
 IN: core-foundation.fsevents
 
 : kFSEventStreamCreateFlagUseCFTypes 2 ; inline

basis/core-foundation/run-loop/run-loop.factor

@@ -1,6 +1,10 @@
 ! 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
+core-foundation.time ;
 IN: core-foundation.run-loop
 
 : kCFRunLoopRunFinished 1 ; inline
@@ -32,6 +36,24 @@ FUNCTION: void CFRunLoopAddSource (
    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? [
@@ -39,3 +61,80 @@ FUNCTION: void CFRunLoopAddSource (
         "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 = ;

basis/core-foundation/run-loop/thread/summary.txt

@@ -1 +0,0 @@
-Vocabulary with init hook for running CoreFoundation event loop

basis/core-foundation/run-loop/thread/thread.factor

@@ -1,16 +0,0 @@
-! Copyright (C) 2008 Slava Pestov
-! See http://factorcode.org/license.txt for BSD license.
-USING: calendar core-foundation.run-loop init kernel threads ;
-IN: core-foundation.run-loop.thread
-
-! Load this vocabulary if you need a run loop running.
-
-: run-loop-thread ( -- )
-    CFRunLoopDefaultMode 0 f CFRunLoopRunInMode
-    kCFRunLoopRunHandledSource = [ 1 seconds sleep ] unless
-    run-loop-thread ;
-
-: start-run-loop-thread ( -- )
-    [ run-loop-thread t ] "CFRunLoop dispatcher" spawn-server drop ;
-
-[ start-run-loop-thread ] "core-foundation.run-loop.thread" add-init-hook

basis/core-foundation/strings/strings-docs.factor

@@ -0,0 +1,14 @@
+USING: help.syntax help.markup strings ;
+IN: core-foundation.strings
+
+HELP: <CFString>
+{ $values { "string" string } { "alien" "a " { $snippet "CFString" } } }
+{ $description "Creates a Core Foundation string from a Factor string." } ;
+
+HELP: CF>string
+{ $values { "alien" "a " { $snippet "CFString" } } { "string" string } }
+{ $description "Creates a Factor string from a Core Foundation string." } ;
+
+HELP: CF>string-array
+{ $values { "alien" "a " { $snippet "CFArray" } " of " { $snippet "CFString" } " instances" } { "seq" string } }
+{ $description "Creates an array of Factor strings from a " { $snippet "CFArray" } " of " { $snippet "CFString" } "s." } ;

basis/core-foundation/strings/strings-tests.factor

@@ -1,6 +1,6 @@
 ! Copyright (C) 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: core-foundation tools.test kernel ;
+USING: core-foundation.strings core-foundation tools.test kernel ;
 IN: core-foundation
 
 [ ] [ "Hello" <CFString> CFRelease ] unit-test

basis/core-foundation/strings/strings.factor

@@ -0,0 +1,66 @@
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: alien.syntax alien.strings kernel sequences byte-arrays
+io.encodings.utf8 math core-foundation core-foundation.arrays ;
+IN: core-foundation.strings
+
+TYPEDEF: void* CFStringRef
+
+TYPEDEF: int CFStringEncoding
+: kCFStringEncodingMacRoman HEX: 0 ;
+: kCFStringEncodingWindowsLatin1 HEX: 0500 ;
+: kCFStringEncodingISOLatin1 HEX: 0201 ;
+: kCFStringEncodingNextStepLatin HEX: 0B01 ;
+: kCFStringEncodingASCII HEX: 0600 ;
+: kCFStringEncodingUnicode HEX: 0100 ;
+: kCFStringEncodingUTF8 HEX: 08000100 ;
+: kCFStringEncodingNonLossyASCII HEX: 0BFF ;
+: kCFStringEncodingUTF16 HEX: 0100 ;
+: kCFStringEncodingUTF16BE HEX: 10000100 ;
+: kCFStringEncodingUTF16LE HEX: 14000100 ;
+: kCFStringEncodingUTF32 HEX: 0c000100 ;
+: kCFStringEncodingUTF32BE HEX: 18000100 ;
+: kCFStringEncodingUTF32LE HEX: 1c000100 ;
+
+FUNCTION: CFStringRef CFStringCreateWithBytes (
+   CFAllocatorRef alloc,
+   UInt8* bytes,
+   CFIndex numBytes,
+   CFStringEncoding encoding,
+   Boolean isExternalRepresentation
+) ;
+
+FUNCTION: CFIndex CFStringGetLength ( CFStringRef theString ) ;
+
+FUNCTION: void CFStringGetCharacters ( void* theString, CFIndex start, CFIndex length, void* buffer ) ;
+
+FUNCTION: Boolean CFStringGetCString (
+   CFStringRef theString,
+   char* buffer,
+   CFIndex bufferSize,
+   CFStringEncoding encoding
+) ;
+
+FUNCTION: CFStringRef CFStringCreateWithCString (
+   CFAllocatorRef alloc,
+   char* cStr,
+   CFStringEncoding encoding
+) ;
+
+: <CFString> ( string -- alien )
+    f swap utf8 string>alien kCFStringEncodingUTF8 CFStringCreateWithCString
+    [ "CFStringCreateWithCString failed" throw ] unless* ;
+
+: CF>string ( alien -- string )
+    dup CFStringGetLength 4 * 1 + <byte-array> [
+        dup length
+        kCFStringEncodingUTF8
+        CFStringGetCString
+        [ "CFStringGetCString failed" throw ] unless
+    ] keep utf8 alien>string ;
+
+: CF>string-array ( alien -- seq )
+    CF>array [ CF>string ] map ;
+
+: <CFStringArray> ( seq -- alien )
+    [ <CFString> ] map [ <CFArray> ] [ [ CFRelease ] each ] bi ;

basis/core-foundation/strings/tags.txt

@@ -0,0 +1,2 @@
+unportable
+bindings

basis/core-foundation/time/time.factor

@@ -0,0 +1,14 @@
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: calendar alien.syntax ;
+IN: core-foundation.time
+
+TYPEDEF: double CFTimeInterval
+TYPEDEF: double CFAbsoluteTime
+
+: >CFTimeInterval ( duration -- interval )
+    duration>seconds ; inline
+
+: >CFAbsoluteTime ( timestamp -- time )
+    T{ timestamp { year 2001 } { month 1 } { day 1 } } time-
+    duration>seconds ; inline

basis/core-foundation/timers/tags.txt

@@ -0,0 +1,2 @@
+unportable
+bindings

basis/core-foundation/timers/timers.factor

@@ -0,0 +1,35 @@
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: alien.syntax system math kernel calendar core-foundation
+core-foundation.time ;
+IN: core-foundation.timers
+
+TYPEDEF: void* CFRunLoopTimerRef
+TYPEDEF: void* CFRunLoopTimerCallBack
+TYPEDEF: void* CFRunLoopTimerContext
+
+FUNCTION: CFRunLoopTimerRef CFRunLoopTimerCreate (
+   CFAllocatorRef allocator,
+   CFAbsoluteTime fireDate,
+   CFTimeInterval interval,
+   CFOptionFlags flags,
+   CFIndex order,
+   CFRunLoopTimerCallBack callout,
+   CFRunLoopTimerContext* context
+) ;
+
+: <CFTimer> ( callback -- timer )
+    [ f now >CFAbsoluteTime 60 0 0 ] dip f CFRunLoopTimerCreate ;
+
+FUNCTION: void CFRunLoopTimerInvalidate (
+   CFRunLoopTimerRef timer
+) ;
+
+FUNCTION: Boolean CFRunLoopTimerIsValid (
+   CFRunLoopTimerRef timer
+) ;
+
+FUNCTION: void CFRunLoopTimerSetNextFireDate (
+   CFRunLoopTimerRef timer,
+   CFAbsoluteTime fireDate
+) ;

basis/core-foundation/urls/tags.txt

@@ -0,0 +1,2 @@
+unportable
+bindings

basis/core-foundation/urls/urls-docs.factor

@@ -0,0 +1,10 @@
+USING: help.syntax help.markup ;
+IN: core-foundation.urls
+
+HELP: <CFFileSystemURL>
+{ $values { "string" "a pathname string" } { "dir?" "a boolean indicating if the pathname is a directory" } { "url" "a " { $snippet "CFURL" } } }
+{ $description "Creates a new " { $snippet "CFURL" } " pointing to the given local pathname." } ;
+
+HELP: <CFURL>
+{ $values { "string" "a URL string" } { "url" "a " { $snippet "CFURL" } } }
+{ $description "Creates a new " { $snippet "CFURL" } "." } ;

basis/core-foundation/urls/urls.factor

@@ -0,0 +1,24 @@
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: alien.syntax kernel core-foundation.strings
+core-foundation ;
+IN: core-foundation.urls
+
+: kCFURLPOSIXPathStyle 0 ; inline
+
+TYPEDEF: void* CFURLRef
+
+FUNCTION: CFURLRef CFURLCreateWithFileSystemPath ( CFAllocatorRef allocator, CFStringRef filePath, int pathStyle, Boolean isDirectory ) ;
+
+FUNCTION: CFURLRef CFURLCreateWithString ( CFAllocatorRef allocator, CFStringRef string, CFURLRef base ) ;
+
+FUNCTION: CFURLRef CFURLCopyFileSystemPath ( CFURLRef url, int pathStyle ) ;
+
+: <CFFileSystemURL> ( string dir? -- url )
+    [ <CFString> f over kCFURLPOSIXPathStyle ] dip
+    CFURLCreateWithFileSystemPath swap CFRelease ;
+
+: <CFURL> ( string -- url )
+    <CFString>
+    [ f swap f CFURLCreateWithString ] keep
+    CFRelease ;

basis/io/thread/thread.factor

@@ -1,14 +1,20 @@
 ! Copyright (C) 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
+USING: threads io.backend namespaces init math kernel ;
 IN: io.thread
-USING: threads io.backend namespaces init math ;
+
+! The Cocoa UI backend stops the I/O thread and takes over
+! completely.
+SYMBOL: io-thread-running?
 
 : io-thread ( -- )
     sleep-time io-multiplex yield ;
 
 : start-io-thread ( -- )
-    [ io-thread t ]
+    [ [ io-thread-running? get-global ] [ io-thread ] [ ] while ]
-    "I/O wait" spawn-server
+    "I/O wait" spawn drop ;
-    \ io-thread set-global ;
 
-[ start-io-thread ] "io.thread" add-init-hook
+[
+    t io-thread-running? set-global
+    start-io-thread
+] "io.thread" add-init-hook

basis/io/unix/backend/backend.factor

@@ -5,7 +5,7 @@ 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
 
@@ -37,38 +37,6 @@ M: fd dispose
 
 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>>

basis/io/unix/bsd/bsd.factor

@@ -1,7 +1,8 @@
 ! Copyright (C) 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: namespaces system kernel accessors assocs continuations
-unix io.backend io.unix.backend io.unix.kqueue ;
+unix io.backend io.unix.backend io.unix.multiplexers
+io.unix.multiplexers.kqueue ;
 IN: io.unix.bsd
 
 M: bsd init-io ( -- )

basis/io/unix/linux/linux.factor

@@ -1,7 +1,7 @@
 ! Copyright (C) 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: kernel io.backend io.monitors io.unix.backend
+USING: kernel system namespaces io.backend io.unix.backend
-io.unix.epoll io.unix.linux.monitors system namespaces ;
+io.unix.multiplexers io.unix.multiplexers.epoll ;
 IN: io.unix.linux
 
 M: linux init-io ( -- )

basis/io/unix/linux/monitors/monitors.factor

@@ -2,10 +2,10 @@
 ! 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
+io.unix.backend io.encodings.utf8 unix.linux.inotify assocs
-unix.linux.inotify assocs namespaces make threads continuations
+namespaces make threads continuations init math math.bitwise
-init math math.bitwise sets alien alien.strings alien.c-types
+sets alien alien.strings alien.c-types vocabs.loader accessors
-vocabs.loader accessors system hashtables destructors unix ;
+system hashtables destructors unix ;
 IN: io.unix.linux.monitors
 
 SYMBOL: watches

basis/io/unix/macosx/macosx.factor

@@ -1,7 +1,10 @@
 ! 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.backend
+
-namespaces system ;
+M: macosx init-io ( -- )
+    <run-loop-mx> mx set-global ;
 
 macosx set-io-backend

basis/io/unix/multiplexers/epoll/epoll.factor

@@ -0,0 +1,66 @@
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors alien.c-types kernel destructors bit-arrays
+sequences assocs struct-arrays math namespaces locals fry unix
+unix.linux.epoll unix.time io.ports io.unix.backend
+io.unix.multiplexers ;
+IN: io.unix.multiplexers.epoll
+
+TUPLE: epoll-mx < mx events ;
+
+: max-events ( -- n )
+    #! We read up to 256 events at a time. This is an arbitrary
+    #! constant...
+    256 ; inline
+
+: <epoll-mx> ( -- mx )
+    epoll-mx new-mx
+        max-events epoll_create dup io-error >>fd
+        max-events "epoll-event" <struct-array> >>events ;
+
+M: epoll-mx dispose fd>> close-file ;
+
+: make-event ( fd events -- event )
+    "epoll-event" <c-object>
+    [ set-epoll-event-events ] keep
+    [ set-epoll-event-fd ] keep ;
+
+:: do-epoll-ctl ( fd mx what events -- )
+    mx fd>> what fd fd events make-event epoll_ctl io-error ;
+
+: do-epoll-add ( fd mx events -- )
+    EPOLL_CTL_ADD swap EPOLLONESHOT bitor do-epoll-ctl ;
+
+: do-epoll-del ( fd mx events -- )
+    EPOLL_CTL_DEL swap do-epoll-ctl ;
+
+M: epoll-mx add-input-callback ( thread fd mx -- )
+    [ EPOLLIN do-epoll-add ] [ call-next-method ] 2bi ;
+
+M: epoll-mx add-output-callback ( thread fd mx -- )
+    [ EPOLLOUT do-epoll-add ] [ call-next-method ] 2bi ;
+
+M: epoll-mx remove-input-callbacks ( fd mx -- seq )
+    2dup reads>> key? [
+        [ call-next-method ] [ EPOLLIN do-epoll-del ] 2bi
+    ] [ 2drop f ] if ;
+
+M: epoll-mx remove-output-callbacks ( fd mx -- seq )
+    2dup writes>> key? [
+        [ EPOLLOUT do-epoll-del ] [ call-next-method ] 2bi
+    ] [ 2drop f ] if ;
+
+: wait-event ( mx us -- n )
+    [ [ fd>> ] [ events>> ] bi [ underlying>> ] [ length ] bi ] [ 1000 /i ] bi*
+    epoll_wait multiplexer-error ;
+
+: handle-event ( event mx -- )
+    [ epoll-event-fd ] dip
+    [ EPOLLIN EPOLLOUT bitor do-epoll-del ]
+    [ input-available ] [ output-available ] 2tri ;
+
+: handle-events ( mx n -- )
+    [ dup events>> ] dip head-slice swap '[ _ handle-event ] each ;
+
+M: epoll-mx wait-for-events ( us mx -- )
+    swap 60000000 or dupd wait-event handle-events ;

basis/io/unix/multiplexers/kqueue/authors.txt

@@ -0,0 +1 @@
+Slava Pestov

basis/io/unix/multiplexers/kqueue/kqueue.factor

@@ -0,0 +1,76 @@
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors alien.c-types combinators destructors
+io.unix.backend kernel math.bitwise sequences struct-arrays unix
+unix.kqueue unix.time assocs io.unix.multiplexers ;
+IN: io.unix.multiplexers.kqueue
+
+TUPLE: kqueue-mx < mx events ;
+
+: max-events ( -- n )
+    #! We read up to 256 events at a time. This is an arbitrary
+    #! constant...
+    256 ; inline
+
+: <kqueue-mx> ( -- mx )
+    kqueue-mx new-mx
+        kqueue dup io-error >>fd
+        max-events "kevent" <struct-array> >>events ;
+
+M: kqueue-mx dispose fd>> close-file ;
+
+: make-kevent ( fd filter flags -- event )
+    "kevent" <c-object>
+    [ set-kevent-flags ] keep
+    [ set-kevent-filter ] keep
+    [ set-kevent-ident ] keep ;
+
+: register-kevent ( kevent mx -- )
+    fd>> swap 1 f 0 f kevent io-error ;
+
+M: kqueue-mx add-input-callback ( thread fd mx -- )
+    [ call-next-method ] [
+        [ EVFILT_READ { EV_ADD EV_ONESHOT } flags make-kevent ] dip
+        register-kevent
+    ] 2bi ;
+
+M: kqueue-mx add-output-callback ( thread fd mx -- )
+    [ call-next-method ] [
+        [ EVFILT_WRITE { EV_ADD EV_ONESHOT } flags make-kevent ] dip
+        register-kevent
+    ] 2bi ;
+
+M: kqueue-mx remove-input-callbacks ( fd mx -- seq )
+    2dup reads>> key? [
+        [ call-next-method ] [
+            [ EVFILT_READ EV_DELETE make-kevent ] dip
+            register-kevent
+        ] 2bi
+    ] [ 2drop f ] if ;
+
+M: kqueue-mx remove-output-callbacks ( fd mx -- seq )
+    2dup writes>> key? [
+        [
+            [ EVFILT_WRITE EV_DELETE make-kevent ] dip
+            register-kevent
+        ] [ call-next-method ] 2bi
+    ] [ 2drop f ] if ;
+
+: wait-kevent ( mx timespec -- n )
+    [
+        [ fd>> f 0 ]
+        [ events>> [ underlying>> ] [ length ] bi ] bi
+    ] dip kevent multiplexer-error ;
+
+: handle-kevent ( mx kevent -- )
+    [ kevent-ident swap ] [ kevent-filter ] bi {
+        { EVFILT_READ [ input-available ] }
+        { EVFILT_WRITE [ output-available ] }
+    } case ;
+
+: handle-kevents ( mx n -- )
+    [ dup events>> ] dip head-slice [ handle-kevent ] with each ;
+
+M: kqueue-mx wait-for-events ( us mx -- )
+    swap dup [ make-timespec ] when
+    dupd wait-kevent handle-kevents ;

basis/io/unix/multiplexers/kqueue/tags.txt

@@ -0,0 +1 @@
+unportable

basis/io/unix/multiplexers/multiplexers.factor

@@ -0,0 +1,35 @@
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel accessors assocs sequences threads ;
+IN: io.unix.multiplexers
+
+TUPLE: mx fd reads writes ;
+
+: new-mx ( class -- obj )
+    new
+        H{ } clone >>reads
+        H{ } clone >>writes ; inline
+
+GENERIC: add-input-callback ( thread fd mx -- )
+
+M: mx add-input-callback reads>> push-at ;
+
+GENERIC: add-output-callback ( thread fd mx -- )
+
+M: mx add-output-callback writes>> push-at ;
+
+GENERIC: remove-input-callbacks ( fd mx -- callbacks )
+
+M: mx remove-input-callbacks reads>> delete-at* drop ;
+
+GENERIC: remove-output-callbacks ( fd mx -- callbacks )
+
+M: mx remove-output-callbacks writes>> delete-at* drop ;
+
+GENERIC: wait-for-events ( ms mx -- )
+
+: input-available ( fd mx -- )
+    reads>> delete-at* drop [ resume ] each ;
+
+: output-available ( fd mx -- )
+    writes>> delete-at* drop [ resume ] each ;

basis/io/unix/multiplexers/run-loop/run-loop.factor

@@ -0,0 +1,33 @@
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel arrays namespaces math accessors alien locals
+destructors system threads io.unix.multiplexers
+io.unix.multiplexers.kqueue core-foundation
+core-foundation.run-loop ;
+IN: io.unix.multiplexers.run-loop
+
+TUPLE: run-loop-mx kqueue-mx ;
+
+: file-descriptor-callback ( -- callback )
+    "void" { "CFFileDescriptorRef" "CFOptionFlags" "void*" }
+    "cdecl" [
+        3drop
+        0 mx get kqueue-mx>> wait-for-events
+        reset-run-loop
+        yield
+    ] alien-callback ;
+
+: <run-loop-mx> ( -- mx )
+    [
+        <kqueue-mx> |dispose
+        dup fd>> file-descriptor-callback add-fd-to-run-loop
+        run-loop-mx boa
+    ] with-destructors ;
+
+M: run-loop-mx add-input-callback kqueue-mx>> add-input-callback ;
+M: run-loop-mx add-output-callback kqueue-mx>> add-output-callback ;
+M: run-loop-mx remove-input-callbacks kqueue-mx>> remove-input-callbacks ;
+M: run-loop-mx remove-output-callbacks kqueue-mx>> remove-output-callbacks ;
+
+M: run-loop-mx wait-for-events ( us mx -- )
+    swap run-one-iteration [ 0 swap wait-for-events ] [ drop ] if ;

basis/io/unix/multiplexers/run-loop/tags.txt

@@ -0,0 +1 @@
+unportable

basis/io/unix/multiplexers/select/authors.txt

@@ -0,0 +1 @@
+Slava Pestov

basis/io/unix/multiplexers/select/select.factor

@@ -0,0 +1,56 @@
+! Copyright (C) 2004, 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: alien.c-types kernel bit-arrays sequences assocs unix
+math namespaces accessors math.order locals unix.time fry
+io.ports io.unix.backend io.unix.multiplexers ;
+IN: io.unix.multiplexers.select
+
+TUPLE: select-mx < mx read-fdset write-fdset ;
+
+! Factor's bit-arrays are an array of bytes, OS X expects
+! FD_SET to be an array of cells, so we have to account for
+! byte order differences on big endian platforms
+: munge ( i -- i' )
+    little-endian? [ BIN: 11000 bitxor ] unless ; inline
+
+: <select-mx> ( -- mx )
+    select-mx new-mx
+        FD_SETSIZE 8 * <bit-array> >>read-fdset
+        FD_SETSIZE 8 * <bit-array> >>write-fdset ;
+
+: clear-nth ( n seq -- ? )
+    [ nth ] [ [ f ] 2dip set-nth ] 2bi ;
+
+:: check-fd ( fd fdset mx quot -- )
+    fd munge fdset clear-nth [ fd mx quot call ] when ; inline
+
+: check-fdset ( fds fdset mx quot -- )
+    [ check-fd ] 3curry each ; inline
+
+: init-fdset ( fds fdset -- )
+    '[ t swap munge _ set-nth ] each ;
+
+: read-fdset/tasks ( mx -- seq fdset )
+    [ reads>> keys ] [ read-fdset>> ] bi ;
+
+: write-fdset/tasks ( mx -- seq fdset )
+    [ writes>> keys ] [ write-fdset>> ] bi ;
+
+: max-fd ( assoc -- n )
+    dup assoc-empty? [ drop 0 ] [ keys supremum ] if ;
+
+: num-fds ( mx -- n )
+    [ reads>> max-fd ] [ writes>> max-fd ] bi max 1+ ;
+
+: init-fdsets ( mx -- nfds read write except )
+    [ num-fds ]
+    [ read-fdset/tasks [ init-fdset ] [ underlying>> ] bi ]
+    [ write-fdset/tasks [ init-fdset ] [ underlying>> ] bi ] tri
+    f ;
+
+M:: select-mx wait-for-events ( us mx -- )
+    mx
+    [ init-fdsets us dup [ make-timeval ] when select multiplexer-error drop ]
+    [ [ read-fdset/tasks ] keep [ input-available ] check-fdset ]
+    [ [ write-fdset/tasks ] keep [ output-available ] check-fdset ]
+    tri ;

basis/io/unix/multiplexers/select/tags.txt

@@ -0,0 +1 @@
+unportable

basis/stack-checker/alien/alien.factor

@@ -61,12 +61,6 @@ TUPLE: alien-callback-params < alien-node-params quot xt ;
     ! 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 -- )

basis/tools/deploy/deploy-tests.factor

@@ -107,3 +107,8 @@ M: quit-responder call-responder*
     "tools.deploy.test.8" shake-and-bake
     run-temp-image
 ] unit-test
+
+[ ] [
+    "tools.deploy.test.9" shake-and-bake
+    run-temp-image
+] unit-test

basis/tools/deploy/shaker/shaker.factor

@@ -365,6 +365,7 @@ SYMBOL: deploy-vocab
         init-hooks get values concat %
         ,
         strip-io? [ \ flush , ] unless
+        [ 0 exit ] %
     ] [ ] make
     set-boot-quot ;
 

basis/tools/deploy/shaker/strip-cocoa.factor

@@ -19,12 +19,8 @@ IN: cocoa.application
 
 [ [ die ] 19 setenv ] "cocoa.application" add-init-hook
 
-"stop-after-last-window?" get
-
 H{ } clone \ pool [
     global [
-        "stop-after-last-window?" "ui" lookup set
-
         ! Only keeps those methods that we actually call
         sent-messages get super-sent-messages get assoc-union
         objc-methods [ assoc-intersect pool-values ] change

basis/tools/deploy/test/3/deploy.factor

@@ -1,14 +1,15 @@
 USING: tools.deploy.config ;
 H{
-    { deploy-threads? t }
+    { deploy-unicode? f }
-    { deploy-c-types? f }
-    { deploy-ui? f }
-    { deploy-word-props? f }
-    { deploy-word-defs? f }
-    { deploy-math? t }
-    { deploy-io 3 }
     { deploy-name "tools.deploy.test.3" }
-    { deploy-compiler? t }
+    { deploy-ui? f }
-    { deploy-reflection 1 }
     { "stop-after-last-window?" t }
+    { deploy-word-defs? f }
+    { deploy-reflection 1 }
+    { deploy-compiler? t }
+    { deploy-threads? t }
+    { deploy-io 3 }
+    { deploy-math? t }
+    { deploy-word-props? f }
+    { deploy-c-types? f }
 }

basis/tools/deploy/test/9/9.factor

@@ -0,0 +1,10 @@
+USING: alien kernel math ;
+IN: tools.deploy.test.9
+
+: callback-test ( -- callback )
+    "int" { "int" } "cdecl" [ 1 + ] alien-callback ;
+
+: indirect-test ( -- )
+    10 callback-test "int" { "int" } "cdecl" alien-indirect 11 assert= ;
+
+MAIN: indirect-test

basis/tools/deploy/test/9/deploy.factor

@@ -0,0 +1,15 @@
+USING: tools.deploy.config ;
+H{
+    { deploy-unicode? f }
+    { deploy-name "tools.deploy.test.9" }
+    { deploy-ui? f }
+    { "stop-after-last-window?" t }
+    { deploy-word-defs? f }
+    { deploy-reflection 1 }
+    { deploy-compiler? t }
+    { deploy-threads? f }
+    { deploy-io 1 }
+    { deploy-math? t }
+    { deploy-word-props? f }
+    { deploy-c-types? f }
+}

basis/tools/disassembler/disassembler.factor

@@ -1,7 +1,7 @@
 ! Copyright (C) 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: tr arrays sequences io words generic system combinators
-vocabs.loader ;
+vocabs.loader kernel ;
 IN: tools.disassembler
 
 GENERIC: disassemble ( obj -- )
@@ -18,8 +18,7 @@ M: word disassemble word-xt 2array disassemble ;
 
 M: method-spec disassemble first2 method disassemble ;
 
-cpu {
+cpu x86? os unix? and
-    { x86.32 [ "tools.disassembler.udis" ] }
+"tools.disassembler.udis"
-    { x86.64 [ "tools.disassembler.udis" ] }
+"tools.disassembler.gdb" ?
-    { ppc [ "tools.disassembler.gdb" ] }
+require
-} case require

basis/ui/backend/backend.factor

@@ -5,8 +5,6 @@ IN: ui.backend
 
 SYMBOL: ui-backend
 
-HOOK: do-events ui-backend ( -- )
-
 HOOK: set-title ui-backend ( string world -- )
 
 HOOK: set-fullscreen* ui-backend ( ? world -- )
@@ -17,11 +15,17 @@ HOOK: (open-window) 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 -- )
 
-HOOK: flush-gl-context ui-backend ( handle -- )
+GENERIC: flush-gl-context ( handle -- )
+
+HOOK: offscreen-pixels ui-backend ( world -- alien w h )
 
 HOOK: beep ui-backend ( -- )
 

basis/ui/cocoa/cocoa.factor

@@ -3,21 +3,22 @@
 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
+cocoa.windows cocoa.classes cocoa.nibs sequences system ui
-sequences system ui ui.backend ui.clipboards ui.gadgets
+ui.backend ui.clipboards ui.gadgets ui.gadgets.worlds
-ui.gadgets.worlds ui.cocoa.views core-foundation threads
+ui.cocoa.views core-foundation core-foundation.run-loop threads
-math.geometry.rect fry ;
+math.geometry.rect fry libc generalizations alien.c-types
+cocoa.views combinators io.thread ;
 IN: ui.cocoa
 
-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
@@ -39,7 +40,8 @@ M: pasteboard set-clipboard-contents
 : 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 -- )
@@ -88,11 +90,39 @@ M: cocoa-ui-backend raise-window* ( world -- )
         NSApp 1 -> activateIgnoringOtherApps:
     ] when* ;
 
-M: cocoa-ui-backend select-gl-context ( handle -- )
+: pixel-size ( pixel-format -- size )
-    view>> -> openGLContext -> makeCurrentContext ;
+    0 <int> [ NSOpenGLPFAColorSize 0 -> getValues:forAttribute:forVirtualScreen: ]
+    keep *int -3 shift ;
 
-M: cocoa-ui-backend flush-gl-context ( handle -- )
+: offscreen-buffer ( world pixel-format -- alien w h pitch )
-    view>> -> openGLContext -> flushBuffer ;
+    [ dim>> first2 ] [ pixel-size ] bi*
+    { [ * * malloc ] [ 2drop ] [ drop nip ] [ nip * ] } 3cleave ;
+
+: gadget-offscreen-context ( world -- context buffer )
+    NSOpenGLPFAOffScreen 1array <PixelFormat>
+    [ nip NSOpenGLContext -> alloc swap f -> initWithFormat:shareContext: dup ]
+    [ offscreen-buffer ] 2bi
+    4 npick [ -> setOffScreen:width:height:rowbytes: ] dip ;
+
+M: cocoa-ui-backend (open-offscreen-buffer) ( world -- )
+    dup gadget-offscreen-context <offscreen-handle> >>handle drop ;
+
+M: cocoa-ui-backend (close-offscreen-buffer) ( handle -- )
+    [ context>> -> release ]
+    [ buffer>> free ] bi ;
+
+GENERIC: (gl-context) ( handle -- context )
+M: window-handle (gl-context) view>> -> openGLContext ;
+M: offscreen-handle (gl-context) context>> ;
+
+M: handle select-gl-context ( handle -- )
+    (gl-context) -> makeCurrentContext ;
+
+M: handle flush-gl-context ( handle -- )
+    (gl-context) -> flushBuffer ;
+
+M: cocoa-ui-backend offscreen-pixels ( world -- alien w h )
+    [ handle>> buffer>> ] [ dim>> first2 neg ] bi ;
 
 M: cocoa-ui-backend beep ( -- )
     NSBeep ;
@@ -102,8 +132,8 @@ CLASS: {
     { +name+ "FactorApplicationDelegate" }
 }
 
-{ "applicationDidFinishLaunching:" "void" { "id" "SEL" "id" }
+{  "applicationDidUpdate:" "void" { "id" "SEL" "id" }
-    [ 3drop event-loop ]
+    [ 3drop reset-run-loop ]
 } ;
 
 : install-app-delegate ( -- )
@@ -121,6 +151,9 @@ M: cocoa-ui-backend ui
             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 ;

basis/ui/cocoa/tools/tools.factor

@@ -1,10 +1,10 @@
-! Copyright (C) 2006, 2007 Slava Pestov.
+! Copyright (C) 2006, 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: alien.syntax cocoa cocoa.nibs cocoa.application
 cocoa.classes cocoa.dialogs cocoa.pasteboard cocoa.subclassing
-core-foundation help.topics kernel memory namespaces parser
+core-foundation core-foundation.strings help.topics kernel
-system ui ui.tools.browser ui.tools.listener ui.tools.workspace
+memory namespaces parser system ui ui.tools.browser
-ui.cocoa eval locals ;
+ui.tools.listener ui.tools.workspace ui.cocoa eval locals ;
 IN: ui.cocoa.tools
 
 : finder-run-files ( alien -- )

basis/ui/cocoa/views/views.factor

@@ -4,7 +4,7 @@ USING: accessors alien alien.c-types arrays assocs cocoa kernel
 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 -- )

basis/ui/event-loop/event-loop.factor

@@ -0,0 +1,18 @@
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: calendar combinators deques kernel namespaces sequences
+threads ui ui.backend ui.gadgets ;
+IN: ui.event-loop
+
+: event-loop? ( -- ? )
+    {
+        { [ graft-queue deque-empty? not ] [ t ] }
+        { [ windows get-global empty? not ] [ t ] }
+        [ f ]
+    } cond ;
+
+HOOK: do-events ui-backend ( -- )
+
+: event-loop ( -- ) [ event-loop? ] [ do-events ] [ ] while ;
+
+: ui-wait ( -- ) 10 milliseconds sleep ;

basis/ui/gadgets/worlds/worlds.factor

@@ -38,8 +38,8 @@ M: world request-focus-on ( child gadget -- )
     2dup eq?
     [ 2drop ] [ dup focused?>> (request-focus) ] if ;
 
-: <world> ( gadget title status -- world )
+: new-world ( gadget title status class -- world )
-    { 0 1 } world new-track
+    { 0 1 } swap new-track
         t >>root?
         t >>active?
         H{ } clone >>fonts
@@ -49,6 +49,9 @@ M: world request-focus-on ( child gadget -- )
         swap 1 track-add
     dup request-focus ;
 
+: <world> ( gadget title status -- world )
+    world new-world ;
+
 M: world layout*
     dup call-next-method
     dup glass>> [

basis/ui/tools/deploy/deploy.factor

@@ -18,10 +18,6 @@ TUPLE: deploy-gadget < pack vocab settings ;
     deploy-ui? get
     "Include user interface framework" <checkbox> add-gadget ;
 
-: exit-when-windows-closed ( parent -- parent )
-    "stop-after-last-window?" get
-    "Exit when last UI window closed" <checkbox> add-gadget ;
-
 : io-settings ( parent -- parent )
     "Input/output support:" <label> add-gadget
     deploy-io get deploy-io-options <radio-buttons> add-gadget ;
@@ -50,7 +46,6 @@ TUPLE: deploy-gadget < pack vocab settings ;
             <pile>
             bundle-name
             deploy-ui
-            os macosx? [ exit-when-windows-closed ] when
             io-settings
             reflection-settings
             advanced-settings

basis/ui/ui-docs.factor

@@ -143,9 +143,7 @@ ARTICLE: "ui-backend-init" "UI initialization and the event loop"
 }
 "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."
+"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 } "." ;
 
 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:"

basis/ui/ui.factor

@@ -10,18 +10,6 @@ IN: ui
 ! Assoc mapping aliens to gadgets
 SYMBOL: windows
 
-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 ;
@@ -60,23 +48,26 @@ SYMBOL: stop-after-last-window?
     focus-path f swap focus-gestures ;
 
 M: world graft*
-    dup (open-window)
+    [ (open-window) ]
-    dup title>> over set-title
+    [ [ title>> ] keep set-title ]
-    request-focus ;
+    [ 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
+    [ fonts>> clear-assoc ]
-    dup unfocus-world
+    [ unfocus-world ]
-    f >>handle drop ;
+    [ f >>handle drop ] tri ;
+
+: (ungraft-world) ( world -- )
+    [ free-fonts ]
+    [ hand-clicked close-global ]
+    [ hand-gadget close-global ] tri ;
 
 M: world ungraft*
-    dup free-fonts
+    [ (ungraft-world) ]
-    dup hand-clicked close-global
+    [ handle>> (close-window) ]
-    dup hand-gadget close-global
+    [ reset-world ] tri ;
-    dup handle>> (close-window)
-    reset-world ;
 
 : find-window ( quot -- world )
     windows get values
@@ -152,9 +143,6 @@ SYMBOL: ui-hook
         ] assert-depth
     ] [ ui-error ] recover ;
 
-: ui-wait ( -- )
-    10 milliseconds sleep ;
-
 SYMBOL: ui-thread
 
 : ui-running ( quot -- )
@@ -217,7 +205,6 @@ MAIN: ui
         f windows set-global
         [
             ui-hook set
-            stop-after-last-window? on
             ui
         ] with-scope
     ] if ;

basis/ui/windows/windows.factor

@@ -3,14 +3,14 @@
 ! 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
+ui.gestures ui.event-loop io kernel math math.vectors namespaces
-sequences strings vectors words windows.kernel32 windows.gdi32
+make sequences strings vectors words windows.kernel32
-windows.user32 windows.opengl32 windows.messages windows.types
+windows.gdi32 windows.user32 windows.opengl32 windows.messages
-windows.nt windows threads libc combinators
+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
+math.geometry.rect math.order ascii calendar io.encodings.utf16n
-io.encodings.utf16n ;
+;
 IN: ui.windows
 
 SINGLETON: windows-ui-backend
@@ -70,9 +70,11 @@ M: pasteboard set-clipboard-contents drop copy ;
     <pasteboard> clipboard set-global
     <clipboard> selection set-global ;
 
-! world-handle is a <win>
+TUPLE: win-base hDC hRC ;
-TUPLE: win hWnd hDC hRC world title ;
+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 ;
 
@@ -479,8 +481,8 @@ M: windows-ui-backend do-events
     f class-name-ptr set-global
     f msg-obj set-global ;
 
-: setup-pixel-format ( hdc -- )
+: setup-pixel-format ( hdc flags -- )
-    16 make-pfd [ ChoosePixelFormat dup win32-error=0/f ] 2keep
+    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 ;
@@ -490,22 +492,73 @@ M: windows-ui-backend do-events
     [ 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 -- )
+M: win-base select-gl-context ( handle -- )
-    [ hDC>> ] keep hRC>> wglMakeCurrent win32-error=0/f ;
+    [ 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
@@ -521,7 +574,6 @@ M: windows-ui-backend set-title ( string world -- )
 M: windows-ui-backend ui
     [
         [
-            stop-after-last-window? on
             init-clipboard
             init-win32-ui
             start-ui

basis/ui/x11/x11.factor

@@ -2,9 +2,9 @@
 ! 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
+ui.event-loop assocs kernel math namespaces opengl sequences
-x11.events x11.xim x11.glx x11.clipboard x11.constants
+strings x11.xlib x11.events x11.xim x11.glx x11.clipboard
-x11.windows io.encodings.string io.encodings.ascii
+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 ;
@@ -14,9 +14,12 @@ SINGLETON: x11-ui-backend
 
 : 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 ;
 
@@ -184,7 +187,7 @@ M: world client-event
 
 : 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 ;
 
@@ -247,19 +250,37 @@ M: x11-ui-backend raise-window* ( world -- )
         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 [
             [
-                stop-after-last-window? on
                 init-clipboard
                 start-ui
                 event-loop

basis/windows/gdi32/gdi32.factor

@@ -26,6 +26,14 @@ IN: windows.gdi32
 : 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
@@ -75,13 +83,13 @@ FUNCTION: int ChoosePixelFormat ( HDC hDC, PFD* ppfd ) ;
 ! 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
@@ -169,7 +177,7 @@ FUNCTION: HRGN CreateRectRgn ( int x, int y, int w, int h ) ;
 ! FUNCTION: DdEntry8
 ! FUNCTION: DdEntry9
 ! FUNCTION: DeleteColorSpace
-! FUNCTION: DeleteDC
+FUNCTION: BOOL DeleteDC ( HDC hdc ) ;
 ! FUNCTION: DeleteEnhMetaFile
 ! FUNCTION: DeleteMetaFile
 FUNCTION: BOOL DeleteObject ( HGDIOBJ hObject ) ;
@@ -313,7 +321,7 @@ FUNCTION: BOOL DeleteObject ( HGDIOBJ hObject ) ;
 ! FUNCTION: GdiEntry8
 ! FUNCTION: GdiEntry9
 ! FUNCTION: GdiFixUpHandle
-! FUNCTION: GdiFlush
+FUNCTION: BOOL GdiFlush ( ) ;
 ! FUNCTION: GdiFullscreenControl
 ! FUNCTION: GdiGetBatchLimit
 ! FUNCTION: GdiGetCharDimensions
@@ -552,7 +560,7 @@ FUNCTION: HGDIOBJ GetStockObject ( int fnObject ) ;
 ! 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

basis/windows/opengl32/opengl32.factor

@@ -71,15 +71,17 @@ IN: windows.opengl32
 : 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

basis/windows/types/types.factor

@@ -253,6 +253,29 @@ C-STRUCT: RECT
     ! { "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
 

basis/x11/glx/glx.factor

@@ -84,13 +84,13 @@ FUNCTION: void* glXGetProcAddress ( char* procname ) ;
 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* )
+: choose-visual ( flags -- XVisualInfo* )
-    dpy get scr get
+    [ dpy get scr get ] dip
     [
+        %
         GLX_RGBA ,
-        GLX_DOUBLEBUFFER ,
         GLX_DEPTH_SIZE , 16 ,
         0 ,
     ] int-array{ } make underlying>>
@@ -98,7 +98,7 @@ FUNCTION: void* glXGetProcAddressARB ( char* procname ) ;
     [ "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 -- )

basis/x11/windows/windows.factor

@@ -1,7 +1,8 @@
 ! 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 )
@@ -50,11 +51,30 @@ IN: x11.windows
     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 ;
 
@@ -65,3 +85,7 @@ IN: x11.windows
 : 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 ;

basis/x11/xlib/xlib.factor

@@ -31,7 +31,6 @@ TYPEDEF: XID KeySym
 TYPEDEF: ulong Atom
 
 TYPEDEF: char* XPointer
-TYPEDEF: void* Display*
 TYPEDEF: void* Screen*
 TYPEDEF: void* GC
 TYPEDEF: void* Visual*
@@ -66,6 +65,12 @@ TYPEDEF: void* Atom**
 ! 2 - Display Functions
 !
 
+! This struct is incomplete
+C-STRUCT: Display
+{ "void*" "ext_data" }
+{ "void*" "free_funcs" }
+{ "int" "fd" } ;
+
 FUNCTION: Display* XOpenDisplay ( void* display_name ) ;
 
 ! 2.2 Obtaining Information about the Display, Image Formats, or Screens
@@ -272,6 +277,17 @@ FUNCTION: Window XGetSelectionOwner ( Display* display, Atom selection ) ;
 
 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
 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
@@ -429,6 +445,49 @@ FUNCTION: Status XDrawString (
         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
 !

core/alien/alien.factor

@@ -1,7 +1,7 @@
 ! 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
@@ -72,3 +72,9 @@ ERROR: alien-invoke-error library symbol ;
 
 : 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

core/io/backend/backend.factor

@@ -1,7 +1,7 @@
 ! 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
@@ -32,5 +32,7 @@ M: object normalize-directory normalize-path ;
     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

core/memory/memory-tests.factor

@@ -6,9 +6,10 @@ IN: memory.tests
 ! 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

extra/fuel/fuel.factor

@@ -151,7 +151,8 @@ M: source-file fuel-pprint path>> fuel-pprint ;
 : 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
 

extra/graphics/bitmap/bitmap.factor

@@ -4,24 +4,35 @@
 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
+prettyprint sequences strings ui ui.gadgets.panes fry
-io.encodings.binary accessors grouping ;
+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
+    24 (nbits>bitmap) ;
-        2over * 3 * >>size-image
+
-        swap >>height
+: bgra>bitmap ( array height width -- bitmap )
-        swap >>width
+    32 (nbits>bitmap) ;
-        swap [ >>array ] [ >>color-index ] bi
-        24 >>bit-count ;
 
 : 8bit>array ( bitmap -- array )
     [ rgb-quads>> 4 <sliced-groups> [ 3 head-slice ] map ]
@@ -124,7 +135,7 @@ M: bitmap draw-image ( bitmap -- )
     [
         [ 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 ] }

extra/iokit/iokit.factor

@@ -1,5 +1,6 @@
-USING: alien.syntax alien.c-types core-foundation system
+USING: alien.syntax alien.c-types core-foundation
-combinators kernel sequences debugger io accessors ;
+core-foundation.bundles system combinators kernel sequences
+debugger io accessors ;
 IN: iokit
 
 <<

extra/key-caps/key-caps.factor

@@ -139,7 +139,7 @@ TUPLE: key-caps-gadget < gadget keys alarm ;
 : make-key-gadget ( scancode dim array -- )
     [ 
         swap [ 
-            " " [ ] <bevel-button>
+            " " [ drop ] <bevel-button>
             swap [ first >>loc ] [ second >>dim ] bi
         ] [ execute ] bi*
     ] dip set-nth ;

extra/literals/literals-tests.factor

@@ -0,0 +1,12 @@
+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

extra/literals/literals.factor

@@ -0,0 +1,4 @@
+USING: continuations kernel parser words ;
+IN: literals
+
+: $ scan-word [ execute ] curry with-datastack ; parsing

extra/ui/offscreen/authors.txt

@@ -0,0 +1 @@
+Joe Groff

extra/ui/offscreen/offscreen-docs.factor

@@ -0,0 +1,63 @@
+! 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"

extra/ui/offscreen/offscreen.factor

@@ -0,0 +1,36 @@
+! (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 ;

extra/ui/offscreen/summary.txt

@@ -0,0 +1 @@
+Offscreen world gadgets for rendering UI elements to bitmaps

extra/ui/offscreen/tags.txt

@@ -0,0 +1,3 @@
+unportable
+ui
+graphics

misc/fuel/README

@@ -50,7 +50,7 @@ Quick key reference
 (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
@@ -70,6 +70,13 @@ the same as C-cz)).
 
  - 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
 

misc/fuel/fuel-base.el

@@ -59,5 +59,7 @@
                                 " ")
                      len))
 
+(defsubst empty-string-p (str) (equal str ""))
+
 (provide 'fuel-base)
 ;;; fuel-base.el ends here

misc/fuel/fuel-connection.el

@@ -0,0 +1,186 @@
+;;; 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:
+
+
+;;; 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))))))
+
+
+;;; 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)))
+
+
+;;; 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))
+
+
+;;; 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)))))))
+
+
+;;; 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)))))
+
+
+(provide 'fuel-connection)
+;;; fuel-connection.el ends here

misc/fuel/fuel-debug.el

@@ -214,7 +214,7 @@
              (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)
@@ -224,7 +224,8 @@
       (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))))
 
 

misc/fuel/fuel-eval.el

@@ -1,4 +1,4 @@
-;;; 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.
@@ -9,46 +9,16 @@
 
 ;;; Commentary:
 
-;; Protocols for handling communications via a comint buffer running a
+;; Protocols for sending evaluations to the Factor listener.
-;; factor listener.
 
 ;;; Code:
 
 (require 'fuel-base)
 (require 'fuel-syntax)
+(require 'fuel-connection)
 
 
-;;; Syncronous string sending:
+;;; Retort and retort-error datatypes:
-
-(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))))))
-
-
-;;; Evaluation protocol
 
 (defsubst fuel-eval--retort-make (err result &optional output)
   (list err result output))
@@ -60,57 +30,14 @@
 (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))
+        (let ((ret (car (read-from-string str))))
-      (error (fuel-eval--make-parse-error-retort
+          (if (fuel-eval--retort-p ret) ret (error)))
-              (buffer-substring-no-properties (point) (point-max)))))))
+      (error (fuel-eval--make-parse-error-retort str)))))
-
-(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))))
-
-
-;;; Error parsing
 
 (defsubst fuel-eval--error-name (err) (car err))
 
@@ -137,6 +64,69 @@
 (defsubst fuel-eval--error-line-text (err)
   (nth 3 (fuel-eval--error-lexer-p err)))
 
+
+;;; 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))
+
+
+;;; 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))))
+
+
 
 (provide 'fuel-eval)
 ;;; fuel-eval.el ends here

misc/fuel/fuel-font-lock.el

@@ -57,7 +57,7 @@
     (,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)