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

Merge branch 'master' into new_ui

db4
Slava Pestov 2008-12-13 05:00:55 -06:00
parent da94d8afae e79e6d6056
commit 9f2431996d
104 changed files with 1745 additions and 671 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
basis/bootstrap/finish-bootstrap.factor
View File

@ -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

1
basis/bootstrap/finish-staging.factor
View File

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

6
basis/bootstrap/stage2.factor
View File

@ -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

2
basis/cocoa/application/application-docs.factor
View File

@ -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>

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

@ -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
cocoa.runtime sequences threads init summary kernel.private
assocs ;
core-foundation.arrays
core-foundation.data core-foundation.strings cocoa.messages
cocoa cocoa.classes cocoa.runtime sequences threads init summary
kernel.private assocs ;
IN: cocoa.application
: <NSString> ( str -- alien ) <CFString> -> autorelease ;
@ -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

4
basis/cocoa/cocoa.factor
View File

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

3
basis/cocoa/dialogs/dialogs.factor
View File

@ -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 )

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

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

4
basis/cocoa/pasteboard/pasteboard.factor
View File

@ -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" ;

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

@ -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 )

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

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

11
basis/core-foundation/arrays/arrays-docs.factor Normal file
View File

@ -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." } ;

22
basis/core-foundation/arrays/arrays.factor Normal file
View File

@ -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 ;

2
basis/core-foundation/arrays/tags.txt Normal file
View File

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

11
basis/core-foundation/bundles/bundles-docs.factor Normal file
View File

@ -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." } ;

23
basis/core-foundation/bundles/bundles.factor Normal file
View File

@ -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 ;

2
basis/core-foundation/bundles/tags.txt Normal file
View File

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

57
basis/core-foundation/core-foundation-docs.factor
View File

@ -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"

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

@ -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
math sequences io.encodings.utf8 destructors accessors
combinators byte-arrays ;
USING: alien.syntax destructors accessors kernel ;
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 ;

58
basis/core-foundation/data/data.factor Normal file
View File

@ -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 ;

2
basis/core-foundation/data/tags.txt Normal file
View File

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

32
basis/core-foundation/file-descriptors/file-descriptors.factor Normal file
View File

@ -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* ;

2
basis/core-foundation/file-descriptors/tags.txt Normal file
View File

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

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

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

101
basis/core-foundation/run-loop/run-loop.factor
View File

@ -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 = ;

1
basis/core-foundation/run-loop/thread/summary.txt
View File

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

16
basis/core-foundation/run-loop/thread/thread.factor
View File

@ -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

14
basis/core-foundation/strings/strings-docs.factor Normal file
View File

@ -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." } ;

2
basis/core-foundation/core-foundation-tests.factor → basis/core-foundation/strings/strings-tests.factor
View File

@ -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

66
basis/core-foundation/strings/strings.factor Normal file
View File

@ -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 ;

2
basis/core-foundation/strings/tags.txt Normal file
View File

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

14
basis/core-foundation/time/time.factor Normal file
View File

@ -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

2
basis/core-foundation/timers/tags.txt Normal file
View File

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

35
basis/core-foundation/timers/timers.factor Normal file
View File

@ -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
) ;

2
basis/core-foundation/urls/tags.txt Normal file
View File

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

10
basis/core-foundation/urls/urls-docs.factor Normal file
View File

@ -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" } "." } ;

24
basis/core-foundation/urls/urls.factor Normal file
View File

@ -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 ;

16
basis/io/thread/thread.factor
View File

@ -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 ]
"I/O wait" spawn-server
\ io-thread set-global ;
[ [ io-thread-running? get-global ] [ io-thread ] [ ] while ]
"I/O wait" spawn drop ;
[ start-io-thread ] "io.thread" add-init-hook
[
t io-thread-running? set-global
start-io-thread
] "io.thread" add-init-hook

34
basis/io/unix/backend/backend.factor
View File

@ -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>>

3
basis/io/unix/bsd/bsd.factor
View File

@ -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 ( -- )

4
basis/io/unix/linux/linux.factor
View File

@ -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
io.unix.epoll io.unix.linux.monitors system namespaces ;
USING: kernel system namespaces io.backend io.unix.backend
io.unix.multiplexers io.unix.multiplexers.epoll ;
IN: io.unix.linux
M: linux init-io ( -- )

8
basis/io/unix/linux/monitors/monitors.factor
View File

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

7
basis/io/unix/macosx/macosx.factor
View File

@ -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

0
basis/core-foundation/run-loop/thread/authors.txt → basis/io/unix/multiplexers/epoll/authors.txt Normal file → Executable file
View File

66
basis/io/unix/multiplexers/epoll/epoll.factor Normal file
View File

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

0
basis/core-foundation/run-loop/thread/tags.txt → basis/io/unix/multiplexers/epoll/tags.txt
View File

1
basis/io/unix/multiplexers/kqueue/authors.txt Executable file
View File

@ -0,0 +1 @@
Slava Pestov

76
basis/io/unix/multiplexers/kqueue/kqueue.factor Normal file
View File

@ -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 ;

1
basis/io/unix/multiplexers/kqueue/tags.txt Normal file
View File

@ -0,0 +1 @@
unportable

35
basis/io/unix/multiplexers/multiplexers.factor Normal file
View File

@ -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 ;

33
basis/io/unix/multiplexers/run-loop/run-loop.factor Normal file
View File

@ -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 ;

1
basis/io/unix/multiplexers/run-loop/tags.txt Normal file
View File

@ -0,0 +1 @@
unportable

1
basis/io/unix/multiplexers/select/authors.txt Executable file
View File

@ -0,0 +1 @@
Slava Pestov

56
basis/io/unix/multiplexers/select/select.factor Normal file
View File

@ -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 ;

1
basis/io/unix/multiplexers/select/tags.txt Normal file
View File

@ -0,0 +1 @@
unportable

6
basis/stack-checker/alien/alien.factor
View File

@ -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 -- )

5
basis/tools/deploy/deploy-tests.factor
View File

@ -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

1
basis/tools/deploy/shaker/shaker.factor
View File

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

4
basis/tools/deploy/shaker/strip-cocoa.factor
View File

@ -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

19
basis/tools/deploy/test/3/deploy.factor
View File

@ -1,14 +1,15 @@
USING: tools.deploy.config ;
H{
{ deploy-threads? t }
{ deploy-c-types? f }
{ deploy-ui? f }
{ deploy-word-props? f }
{ deploy-word-defs? f }
{ deploy-math? t }
{ deploy-io 3 }
{ deploy-unicode? f }
{ deploy-name "tools.deploy.test.3" }
{ deploy-compiler? t }
{ deploy-reflection 1 }
{ deploy-ui? f }
{ "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 }
}

10
basis/tools/deploy/test/9/9.factor Normal file
View File

@ -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

15
basis/tools/deploy/test/9/deploy.factor Normal file
View File

@ -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 }
}

11
basis/tools/disassembler/disassembler.factor
View File

@ -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 {
{ x86.32 [ "tools.disassembler.udis" ] }
{ x86.64 [ "tools.disassembler.udis" ] }
{ ppc [ "tools.disassembler.gdb" ] }
} case require
cpu x86? os unix? and
"tools.disassembler.udis"
"tools.disassembler.gdb" ?
require

12
basis/ui/backend/backend.factor Normal file → Executable file
View File

@ -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 ( -- )

65
basis/ui/cocoa/cocoa.factor Normal file → Executable file
View File

@ -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
sequences system ui ui.backend ui.clipboards ui.gadgets
ui.gadgets.worlds ui.cocoa.views core-foundation threads
math.geometry.rect fry ;
cocoa.windows cocoa.classes cocoa.nibs sequences system ui
ui.backend ui.clipboards ui.gadgets ui.gadgets.worlds
ui.cocoa.views core-foundation core-foundation.run-loop threads
math.geometry.rect fry libc generalizations alien.c-types
cocoa.views combinators io.thread ;
IN: ui.cocoa
TUPLE: handle view window ;
TUPLE: handle ;
TUPLE: window-handle < handle view window ;
TUPLE: offscreen-handle < handle context buffer ;
C: <handle> handle
C: <window-handle> window-handle
C: <offscreen-handle> offscreen-handle
SINGLETON: cocoa-ui-backend
M: cocoa-ui-backend do-events ( -- )
[ NSApp '[ _ do-event ] loop ui-wait ] with-autorelease-pool ;
TUPLE: pasteboard handle ;
C: <pasteboard> pasteboard
@ -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 -- )
view>> -> openGLContext -> makeCurrentContext ;
: pixel-size ( pixel-format -- size )
0 <int> [ NSOpenGLPFAColorSize 0 -> getValues:forAttribute:forVirtualScreen: ]
keep *int -3 shift ;
M: cocoa-ui-backend flush-gl-context ( handle -- )
view>> -> openGLContext -> flushBuffer ;
: offscreen-buffer ( world pixel-format -- alien w h pitch )
[ dim>> first2 ] [ pixel-size ] bi*
{ [ * * malloc ] [ 2drop ] [ drop nip ] [ nip * ] } 3cleave ;
: gadget-offscreen-context ( world -- context buffer )
NSOpenGLPFAOffScreen 1array <PixelFormat>
[ nip NSOpenGLContext -> alloc swap f -> initWithFormat:shareContext: dup ]
[ offscreen-buffer ] 2bi
4 npick [ -> setOffScreen:width:height:rowbytes: ] dip ;
M: cocoa-ui-backend (open-offscreen-buffer) ( world -- )
dup gadget-offscreen-context <offscreen-handle> >>handle drop ;
M: cocoa-ui-backend (close-offscreen-buffer) ( handle -- )
[ context>> -> release ]
[ buffer>> free ] bi ;
GENERIC: (gl-context) ( handle -- context )
M: window-handle (gl-context) view>> -> openGLContext ;
M: offscreen-handle (gl-context) context>> ;
M: handle select-gl-context ( handle -- )
(gl-context) -> makeCurrentContext ;
M: handle flush-gl-context ( handle -- )
(gl-context) -> flushBuffer ;
M: cocoa-ui-backend 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" }
[ 3drop event-loop ]
{ "applicationDidUpdate:" "void" { "id" "SEL" "id" }
[ 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 ;

8
basis/ui/cocoa/tools/tools.factor
View File

@ -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
system ui ui.tools.browser ui.tools.listener ui.tools.workspace
ui.cocoa eval locals ;
core-foundation core-foundation.strings help.topics kernel
memory namespaces parser system ui ui.tools.browser
ui.tools.listener ui.tools.workspace ui.cocoa eval locals ;
IN: ui.cocoa.tools
: finder-run-files ( alien -- )

2
basis/ui/cocoa/views/views.factor
View File

@ -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 -- )

18
basis/ui/event-loop/event-loop.factor Normal file
View File

@ -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 ;

7
basis/ui/gadgets/worlds/worlds.factor
View File

@ -38,8 +38,8 @@ M: world request-focus-on ( child gadget -- )
2dup eq?
[ 2drop ] [ dup focused?>> (request-focus) ] if ;
: <world> ( gadget title status -- world )
{ 0 1 } world new-track
: new-world ( gadget title status class -- world )
{ 0 1 } swap new-track
t >>root?
t >>active?
H{ } clone >>fonts
@ -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>> [

5
basis/ui/tools/deploy/deploy.factor
View File

@ -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

4
basis/ui/ui-docs.factor
View File

@ -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."
$nl
"The event loop must not block, since otherwise other Factor threads and I/O will not run. Instead, it should poll for pending events, then call " { $link ui-wait } "." ;
"The " { $link ui } " word must not return until the event loop has stopped and the UI has been shut down." ;
ARTICLE: "ui-backend-windows" "UI backend window management"
"The high-level " { $link open-window } " word eventually calls a low-level word which you must implement:"

41
basis/ui/ui.factor
View File

@ -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)
dup title>> over set-title
request-focus ;
[ (open-window) ]
[ [ title>> ] keep set-title ]
[ request-focus ] tri ;
: reset-world ( world -- )
#! This is used when a window is being closed, but also
#! when restoring saved worlds on image startup.
dup fonts>> clear-assoc
dup unfocus-world
f >>handle drop ;
[ fonts>> clear-assoc ]
[ unfocus-world ]
[ f >>handle drop ] tri ;
: (ungraft-world) ( world -- )
[ free-fonts ]
[ hand-clicked close-global ]
[ hand-gadget close-global ] tri ;
M: world ungraft*
dup free-fonts
dup hand-clicked close-global
dup hand-gadget close-global
dup handle>> (close-window)
reset-world ;
[ (ungraft-world) ]
[ handle>> (close-window) ]
[ reset-world ] tri ;
: find-window ( quot -- world )
windows get values
@ -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 ;

86
basis/ui/windows/windows.factor
View File

@ -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
sequences strings vectors words windows.kernel32 windows.gdi32
windows.user32 windows.opengl32 windows.messages windows.types
windows.nt windows threads libc combinators
ui.gestures ui.event-loop io kernel math math.vectors namespaces
make sequences strings vectors words windows.kernel32
windows.gdi32 windows.user32 windows.opengl32 windows.messages
windows.types windows.nt windows threads libc combinators fry
combinators.short-circuit continuations command-line shuffle
opengl ui.render ascii math.bitwise locals symbols accessors
math.geometry.rect math.order ascii calendar
io.encodings.utf16n ;
math.geometry.rect math.order ascii calendar io.encodings.utf16n
;
IN: ui.windows
SINGLETON: windows-ui-backend
@ -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 hWnd hDC hRC world title ;
TUPLE: win-base hDC hRC ;
TUPLE: win < win-base hWnd world title ;
TUPLE: win-offscreen < win-base hBitmap bits ;
C: <win> win
C: <win-offscreen> win-offscreen
SYMBOLS: msg-obj class-name-ptr mouse-captured ;
@ -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 -- )
16 make-pfd [ ChoosePixelFormat dup win32-error=0/f ] 2keep
: setup-pixel-format ( hdc flags -- )
32 make-pfd [ ChoosePixelFormat dup win32-error=0/f ] 2keep
swapd SetPixelFormat win32-error=0/f ;
: get-dc ( hWnd -- hDC ) GetDC dup win32-error=0/f ;
@ -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 -- )
[ hDC>> ] keep hRC>> wglMakeCurrent win32-error=0/f ;
M: win-base select-gl-context ( handle -- )
[ hDC>> ] keep hRC>> wglMakeCurrent win32-error=0/f
GdiFlush drop ;
M: windows-ui-backend flush-gl-context ( handle -- )
M: win-base flush-gl-context ( handle -- )
hDC>> SwapBuffers win32-error=0/f ;
! Move window to front
: (bitmap-info) ( dim -- BITMAPINFO )
"BITMAPINFO" <c-object> [
BITMAPINFO-bmiHeader {
[ nip "BITMAPINFOHEADER" heap-size swap set-BITMAPINFOHEADER-biSize ]
[ [ first ] dip set-BITMAPINFOHEADER-biWidth ]
[ [ second ] dip set-BITMAPINFOHEADER-biHeight ]
[ nip 1 swap set-BITMAPINFOHEADER-biPlanes ]
[ nip 32 swap set-BITMAPINFOHEADER-biBitCount ]
[ nip BI_RGB swap set-BITMAPINFOHEADER-biCompression ]
[ [ first2 * 4 * ] dip set-BITMAPINFOHEADER-biSizeImage ]
[ nip 72 swap set-BITMAPINFOHEADER-biXPelsPerMeter ]
[ nip 72 swap set-BITMAPINFOHEADER-biYPelsPerMeter ]
[ nip 0 swap set-BITMAPINFOHEADER-biClrUsed ]
[ nip 0 swap set-BITMAPINFOHEADER-biClrImportant ]
} 2cleave
] keep ;
: make-offscreen-dc-and-bitmap ( dim -- hDC hBitmap bits )
f CreateCompatibleDC
dup rot (bitmap-info) DIB_RGB_COLORS f <void*>
[ f 0 CreateDIBSection ] keep *void*
[ 2dup SelectObject drop ] dip ;
: setup-offscreen-gl ( dim -- hDC hRC hBitmap bits )
make-offscreen-dc-and-bitmap [
[ dup offscreen-pfd-dwFlags setup-pixel-format ]
[ get-rc ] bi
] 2dip ;
M: windows-ui-backend (open-offscreen-buffer) ( world -- )
dup dim>> setup-offscreen-gl <win-offscreen>
>>handle drop ;
M: windows-ui-backend (close-offscreen-buffer) ( handle -- )
[ hDC>> DeleteDC drop ]
[ hBitmap>> DeleteObject drop ] bi ;
! Windows 32-bit bitmaps don't actually use the alpha byte of
! each pixel; it's left as zero
: (make-opaque) ( byte-array -- byte-array' )
[ length 4 / ]
[ '[ 255 swap 4 * 3 + _ set-nth ] each ]
[ ] tri ;
: (opaque-pixels) ( world -- pixels )
[ handle>> bits>> ] [ dim>> first2 * 4 * ] bi
memory>byte-array (make-opaque) ;
M: windows-ui-backend offscreen-pixels ( world -- alien w h )
[ (opaque-pixels) ] [ dim>> first2 ] bi ;
M: windows-ui-backend raise-window* ( world -- )
handle>> [
hWnd>> SetFocus drop
@ -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

39
basis/ui/x11/x11.factor
View File

@ -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
x11.events x11.xim x11.glx x11.clipboard x11.constants
x11.windows io.encodings.string io.encodings.ascii
ui.event-loop assocs kernel math namespaces opengl sequences
strings x11.xlib x11.events x11.xim x11.glx x11.clipboard
x11.constants x11.windows io.encodings.string io.encodings.ascii
io.encodings.utf8 combinators command-line qualified
math.vectors classes.tuple opengl.gl threads math.geometry.rect
environment ascii ;
@ -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

18
basis/windows/gdi32/gdi32.factor Normal file → Executable file
View File

@ -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

8
basis/windows/opengl32/opengl32.factor Normal file → Executable file
View File

@ -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

23
basis/windows/types/types.factor Normal file → Executable file
View File

@ -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

12
basis/x11/glx/glx.factor
View File

@ -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* )
dpy get scr get
: choose-visual ( flags -- XVisualInfo* )
[ dpy get scr get ] dip
[
%
GLX_RGBA ,
GLX_DOUBLEBUFFER ,
GLX_DEPTH_SIZE , 16 ,
0 ,
] int-array{ } make underlying>>
@ -98,8 +98,8 @@ 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 -- )
dpy get swap glXDestroyContext ;
dpy get swap glXDestroyContext ;

28
basis/x11/windows/windows.factor
View File

@ -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 ;

61
basis/x11/xlib/xlib.factor
View File

@ -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
!

8
core/alien/alien.factor
View File

@ -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

4
core/io/backend/backend.factor
View File

@ -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

3
core/memory/memory-tests.factor
View File

@ -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

3
extra/fuel/fuel.factor
View File

@ -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

31
extra/graphics/bitmap/bitmap.factor
View File

@ -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
io.encodings.binary accessors grouping ;
prettyprint sequences strings ui ui.gadgets.panes fry
io.encodings.binary accessors grouping macros alien.c-types ;
IN: graphics.bitmap
! Currently can only handle 24bit bitmaps.
! Currently can only handle 24/32bit bitmaps.
! Handles row-reversed bitmaps (their height is negative)
TUPLE: bitmap magic size reserved offset header-length width
height planes bit-count compression size-image
x-pels y-pels color-used color-important rgb-quads color-index array ;
: (array-copy) ( bitmap array -- bitmap array' )
over size-image>> abs memory>byte-array ;
MACRO: (nbits>bitmap) ( bits -- )
[ -3 shift ] keep '[
bitmap new
2over * _ * >>size-image
swap >>height
swap >>width
swap (array-copy) [ >>array ] [ >>color-index ] bi
_ >>bit-count
] ;
: bgr>bitmap ( array height width -- bitmap )
bitmap new
2over * 3 * >>size-image
swap >>height
swap >>width
swap [ >>array ] [ >>color-index ] bi
24 >>bit-count ;
24 (nbits>bitmap) ;
: bgra>bitmap ( array height width -- bitmap )
32 (nbits>bitmap) ;
: 8bit>array ( bitmap -- array )
[ rgb-quads>> 4 <sliced-groups> [ 3 head-slice ] map ]
@ -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 ] }

5
extra/iokit/iokit.factor
View File

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

2
extra/key-caps/key-caps.factor
View File

@ -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 ;

12
extra/literals/literals-tests.factor Normal file
View File

@ -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

4
extra/literals/literals.factor Normal file
View File

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

1
extra/ui/offscreen/authors.txt Normal file
View File

@ -0,0 +1 @@
Joe Groff

63
extra/ui/offscreen/offscreen-docs.factor Normal file
View File

@ -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"

36
extra/ui/offscreen/offscreen.factor Executable file
View File

@ -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 ;

1
extra/ui/offscreen/summary.txt Normal file
View File

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

3
extra/ui/offscreen/tags.txt Normal file
View File

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

9
misc/fuel/README
View File

@ -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

2
misc/fuel/fuel-base.el
View File

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

186
misc/fuel/fuel-connection.el Normal file
View File

@ -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

5
misc/fuel/fuel-debug.el
View File

@ -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))))

154
misc/fuel/fuel-eval.el
View File

@ -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
;; factor listener.
;; Protocols for sending evaluations to the Factor listener.
;;; Code:
(require 'fuel-base)
(require 'fuel-syntax)
(require 'fuel-connection)
;;; Syncronous string sending:
(defvar fuel-eval-log-max-length 16000)
(defvar fuel-eval--default-proc-function nil)
(defsubst fuel-eval--default-proc ()
(and fuel-eval--default-proc-function
(funcall fuel-eval--default-proc-function)))
(defvar fuel-eval--proc nil)
(defvar fuel-eval--log t)
(defun fuel-eval--send-string (str)
(let ((proc (or fuel-eval--proc (fuel-eval--default-proc))))
(when proc
(with-current-buffer (get-buffer-create "*factor messages*")
(goto-char (point-max))
(when (and (> fuel-eval-log-max-length 0)
(> (point) fuel-eval-log-max-length))
(erase-buffer))
(when fuel-eval--log (insert "\n>> " (fuel--shorten-str str 256)))
(newline)
(let ((beg (point)))
(comint-redirect-send-command-to-process str (current-buffer) proc nil t)
(with-current-buffer (process-buffer proc)
(while (not comint-redirect-completed) (sleep-for 0 1)))
(goto-char beg)
(current-buffer))))))
;;; Evaluation protocol
;;; Retort and retort-error datatypes:
(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))
(error (fuel-eval--make-parse-error-retort
(buffer-substring-no-properties (point) (point-max)))))))
(defsubst fuel-eval--send/retort (str)
(fuel-eval--parse-retort (fuel-eval--send-string str)))
(defsubst fuel-eval--eval-begin ()
(fuel-eval--send/retort "fuel-begin-eval"))
(defsubst fuel-eval--eval-end ()
(fuel-eval--send/retort "fuel-begin-eval"))
(defsubst fuel-eval--factor-array (strs)
(format "V{ %S }" (mapconcat 'identity strs " ")))
(defsubst fuel-eval--eval-strings (strs &optional no-restart)
(let ((str (format "fuel-eval-%s %s fuel-eval"
(if no-restart "non-restartable" "restartable")
(fuel-eval--factor-array strs))))
(fuel-eval--send/retort str)))
(defsubst fuel-eval--eval-string (str &optional no-restart)
(fuel-eval--eval-strings (list str) no-restart))
(defun fuel-eval--eval-strings/context (strs &optional no-restart)
(let ((usings (fuel-syntax--usings-update)))
(fuel-eval--send/retort
(format "fuel-eval-%s %s %S %s fuel-eval-in-context"
(if no-restart "non-restartable" "restartable")
(fuel-eval--factor-array strs)
(or fuel-syntax--current-vocab "f")
(if usings (fuel-eval--factor-array usings) "f")))))
(defsubst fuel-eval--eval-string/context (str &optional no-restart)
(fuel-eval--eval-strings/context (list str) no-restart))
(defun fuel-eval--eval-region/context (begin end &optional no-restart)
(let ((lines (split-string (buffer-substring-no-properties begin end)
"[\f\n\r\v]+" t)))
(when (> (length lines) 0)
(fuel-eval--eval-strings/context lines no-restart))))
;;; Error parsing
(let ((ret (car (read-from-string str))))
(if (fuel-eval--retort-p ret) ret (error)))
(error (fuel-eval--make-parse-error-retort str)))))
(defsubst fuel-eval--error-name (err) (car err))
@ -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

2
misc/fuel/fuel-font-lock.el
View File

@ -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)

Some files were not shown because too many files have changed in this diff Show More