[ { "blah" 123 } ] [ { "blah" xyz } expand-constants ] unit-test
-: foo ( -- n ) "fdafd" f dlsym [ 123 ] unless* ;
+: foo ( -- n ) &: fdafd [ 123 ] unless* ;
[ 123 ] [ foo ] unit-test
{ $code "C-ENUM: red green blue ;" ": red 0 ; : green 1 ; : blue 2 ;" }
} ;
+HELP: &:
+{ $syntax "&: symbol" }
+{ $values { "symbol" "A C library symbol name" } }
+{ $description "Pushes the address of a symbol named " { $snippet "symbol" } " from the current library, set with " { $link POSTPONE: LIBRARY: } "." } ;
+
HELP: typedef
{ $values { "old" "a string" } { "new" "a string" } }
{ $description "Alises the C type " { $snippet "old" } " under the name " { $snippet "new" } "." }
USING: accessors arrays alien alien.c-types alien.structs
alien.arrays alien.strings kernel math namespaces parser
sequences words quotations math.parser splitting grouping
-effects assocs combinators lexer strings.parser alien.parser ;
+effects assocs combinators lexer strings.parser alien.parser
+fry ;
IN: alien.syntax
: DLL" lexer get skip-blank parse-string dlopen parsed ; parsing
dup length
[ [ create-in ] dip 1quotation define ] 2each ;
parsing
+
+: &:
+ scan "c-library" get
+ '[ _ _ load-library dlsym ] over push-all ; parsing
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
(command-line) parse-command-line
"run" get run
output-stream get [ stream-flush ] when*
+ 0 exit
] set-boot-quot
] if
] [
drop
- load-help? off
- "resource:basis/bootstrap/bootstrap-error.factor" run-file
+ [
+ load-help? off
+ "resource:basis/bootstrap/bootstrap-error.factor" run-file
+ ] with-scope
] recover
USING: debugger quotations help.markup help.syntax strings alien
-core-foundation ;
+core-foundation core-foundation.strings core-foundation.arrays ;
IN: cocoa.application
HELP: <NSString>
{ $values { "quot" quotation } }
{ $description "Initializes Cocoa, calls the quotation, and starts the Cocoa event loop." } ;
-HELP: do-event
-{ $values { "app" "an " { $snippet "NSApplication" } } { "?" "a boolean" } }
-{ $description "Processes a pending event in the queue, if any, returning a boolean indicating if there was one. Does not block." } ;
-
HELP: add-observer
{ $values { "observer" "an " { $snippet "NSObject" } } { "selector" string } { "name" "an " { $snippet "NSString" } } { "object" "an " { $snippet "NSObject" } } }
{ $description "Registers an observer with the " { $snippet "NSNotificationCenter" } " singleton." } ;
ARTICLE: "cocoa-application-utils" "Cocoa application utilities"
"Utilities:"
{ $subsection NSApp }
-{ $subsection do-event }
{ $subsection add-observer }
{ $subsection remove-observer }
{ $subsection install-delegate }
! Copyright (C) 2006, 2008 Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
USING: alien alien.syntax io kernel namespaces core-foundation
-core-foundation.run-loop cocoa.messages cocoa cocoa.classes
+core-foundation.arrays core-foundation.data
+core-foundation.strings cocoa.messages cocoa cocoa.classes
cocoa.runtime sequences threads init summary kernel.private
assocs ;
IN: cocoa.application
: 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
! See http://factorcode.org/license.txt for BSD license.
USING: compiler io kernel cocoa.runtime cocoa.subclassing
cocoa.messages cocoa.types sequences words vocabs parser
-core-foundation namespaces assocs hashtables compiler.units
-lexer init ;
+core-foundation.bundles namespaces assocs hashtables
+compiler.units lexer init ;
IN: cocoa
: (remember-send) ( selector variable -- )
! Copyright (C) 2006, 2008 Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
USING: kernel cocoa cocoa.messages cocoa.classes
-cocoa.application sequences splitting core-foundation ;
+cocoa.application sequences splitting core-foundation
+core-foundation.strings ;
IN: cocoa.dialogs
: <NSOpenPanel> ( -- panel )
-USING: cocoa.application cocoa.messages cocoa.classes cocoa.runtime
-kernel cocoa core-foundation alien.c-types ;
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: cocoa.application cocoa.messages cocoa.classes
+cocoa.runtime kernel cocoa alien.c-types core-foundation
+core-foundation.arrays ;
IN: cocoa.nibs
: load-nib ( name -- )
! Copyright (C) 2006, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: alien.accessors arrays kernel cocoa.messages
-cocoa.classes cocoa.application cocoa core-foundation sequences
-;
+cocoa.classes cocoa.application sequences cocoa core-foundation
+core-foundation.strings core-foundation.arrays ;
IN: cocoa.pasteboard
: NSStringPboardType "NSStringPboardType" ;
USING: strings arrays hashtables assocs sequences
cocoa.messages cocoa.classes cocoa.application cocoa kernel
namespaces io.backend math cocoa.enumeration byte-arrays
-combinators alien.c-types core-foundation ;
+combinators alien.c-types core-foundation core-foundation.data ;
IN: cocoa.plists
GENERIC: >plist ( value -- plist )
: with-multisample ( quot -- )
t +multisample+ pick with-variable ; inline
-: <PixelFormat> ( -- pixelfmt )
- NSOpenGLPixelFormat -> alloc [
- NSOpenGLPFAWindow ,
- NSOpenGLPFADoubleBuffer ,
+: <PixelFormat> ( attributes -- pixelfmt )
+ NSOpenGLPixelFormat -> alloc swap [
+ %
NSOpenGLPFADepthSize , 16 ,
+software-renderer+ get [
NSOpenGLPFARendererID , kCGLRendererGenericFloatID ,
-> autorelease ;
: <GLView> ( class dim -- view )
- [ -> alloc 0 0 ] dip first2 <NSRect> <PixelFormat>
+ [ -> alloc 0 0 ] dip first2 <NSRect>
+ NSOpenGLPFAWindow NSOpenGLPFADoubleBuffer 2array <PixelFormat>
-> initWithFrame:pixelFormat:
dup 1 -> setPostsBoundsChangedNotifications:
dup 1 -> setPostsFrameChangedNotifications: ;
{ 1 1 } [ indirect-test-1 ] must-infer-as
-[ 3 ] [ "ffi_test_1" f dlsym indirect-test-1 ] unit-test
+[ 3 ] [ &: ffi_test_1 indirect-test-1 ] unit-test
: indirect-test-1' ( ptr -- )
"int" { } "cdecl" alien-indirect drop ;
{ 1 0 } [ indirect-test-1' ] must-infer-as
-[ ] [ "ffi_test_1" f dlsym indirect-test-1' ] unit-test
+[ ] [ &: ffi_test_1 indirect-test-1' ] unit-test
[ -1 indirect-test-1 ] must-fail
{ 3 1 } [ indirect-test-2 ] must-infer-as
[ 5 ]
-[ 2 3 "ffi_test_2" f dlsym indirect-test-2 ]
+[ 2 3 &: ffi_test_2 indirect-test-2 ]
unit-test
: indirect-test-3 ( a b c d ptr -- result )
--- /dev/null
+USING: help.syntax help.markup arrays alien ;
+IN: core-foundation.arrays
+
+HELP: CF>array
+{ $values { "alien" "a " { $snippet "CFArray" } } { "array" "an array of " { $link alien } " instances" } }
+{ $description "Creates a Factor array from a Core Foundation array." } ;
+
+HELP: <CFArray>
+{ $values { "seq" "a sequence of " { $link alien } " instances" } { "alien" "a " { $snippet "CFArray" } } }
+{ $description "Creates a Core Foundation array from a Factor array." } ;
+
--- /dev/null
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: alien.syntax kernel sequences ;
+IN: core-foundation.arrays
+
+TYPEDEF: void* CFArrayRef
+
+FUNCTION: CFArrayRef CFArrayCreateMutable ( CFAllocatorRef allocator, CFIndex capacity, void* callbacks ) ;
+
+FUNCTION: void* CFArrayGetValueAtIndex ( CFArrayRef array, CFIndex idx ) ;
+
+FUNCTION: void CFArraySetValueAtIndex ( CFArrayRef array, CFIndex index, void* value ) ;
+
+FUNCTION: CFIndex CFArrayGetCount ( CFArrayRef array ) ;
+
+: CF>array ( alien -- array )
+ dup CFArrayGetCount [ CFArrayGetValueAtIndex ] with map ;
+
+: <CFArray> ( seq -- alien )
+ [ f swap length f CFArrayCreateMutable ] keep
+ [ length ] keep
+ [ [ dupd ] dip CFArraySetValueAtIndex ] 2each ;
--- /dev/null
+unportable
+bindings
--- /dev/null
+USING: help.syntax help.markup ;
+IN: core-foundation.bundles
+
+HELP: <CFBundle>
+{ $values { "string" "a pathname string" } { "bundle" "a " { $snippet "CFBundle" } } }
+{ $description "Creates a new " { $snippet "CFBundle" } "." } ;
+
+HELP: load-framework
+{ $values { "name" "a pathname string" } }
+{ $description "Loads a Core Foundation framework." } ;
+
--- /dev/null
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: alien.syntax kernel sequences core-foundation
+core-foundation.urls ;
+IN: core-foundation.bundles
+
+TYPEDEF: void* CFBundleRef
+
+FUNCTION: CFBundleRef CFBundleCreate ( CFAllocatorRef allocator, CFURLRef bundleURL ) ;
+
+FUNCTION: Boolean CFBundleLoadExecutable ( CFBundleRef bundle ) ;
+
+: <CFBundle> ( string -- bundle )
+ t <CFFileSystemURL> [
+ f swap CFBundleCreate
+ ] keep CFRelease ;
+
+: load-framework ( name -- )
+ dup <CFBundle> [
+ CFBundleLoadExecutable drop
+ ] [
+ "Cannot load bundle named " prepend throw
+ ] ?if ;
--- /dev/null
+unportable
+bindings
USING: alien strings arrays help.markup help.syntax destructors ;
IN: core-foundation
-HELP: CF>array
-{ $values { "alien" "a " { $snippet "CFArray" } } { "array" "an array of " { $link alien } " instances" } }
-{ $description "Creates a Factor array from a Core Foundation array." } ;
-
-HELP: <CFArray>
-{ $values { "seq" "a sequence of " { $link alien } " instances" } { "alien" "a " { $snippet "CFArray" } } }
-{ $description "Creates a Core Foundation array from a Factor array." } ;
-
-HELP: <CFString>
-{ $values { "string" string } { "alien" "a " { $snippet "CFString" } } }
-{ $description "Creates a Core Foundation string from a Factor string." } ;
-
-HELP: CF>string
-{ $values { "alien" "a " { $snippet "CFString" } } { "string" string } }
-{ $description "Creates a Factor string from a Core Foundation string." } ;
-
-HELP: CF>string-array
-{ $values { "alien" "a " { $snippet "CFArray" } " of " { $snippet "CFString" } " instances" } { "seq" string } }
-{ $description "Creates an array of Factor strings from a " { $snippet "CFArray" } " of " { $snippet "CFString" } "s." } ;
-
-HELP: <CFFileSystemURL>
-{ $values { "string" "a pathname string" } { "dir?" "a boolean indicating if the pathname is a directory" } { "url" "a " { $snippet "CFURL" } } }
-{ $description "Creates a new " { $snippet "CFURL" } " pointing to the given local pathname." } ;
-
-HELP: <CFURL>
-{ $values { "string" "a URL string" } { "url" "a " { $snippet "CFURL" } } }
-{ $description "Creates a new " { $snippet "CFURL" } "." } ;
-
-HELP: <CFBundle>
-{ $values { "string" "a pathname string" } { "bundle" "a " { $snippet "CFBundle" } } }
-{ $description "Creates a new " { $snippet "CFBundle" } "." } ;
-
-HELP: load-framework
-{ $values { "name" "a pathname string" } }
-{ $description "Loads a Core Foundation framework." } ;
-
HELP: &CFRelease
{ $values { "alien" "Pointer to a Core Foundation object" } }
{ $description "Marks the given Core Foundation object for unconditional release via " { $link CFRelease } " at the end of the enclosing " { $link with-destructors } " scope." } ;
{ $description "Marks the given Core Foundation object for release via " { $link CFRelease } " in the event of an error at the end of the enclosing " { $link with-destructors } " scope." } ;
{ CFRelease |CFRelease &CFRelease } related-words
-
-ARTICLE: "core-foundation" "Core foundation utilities"
-"The " { $vocab-link "core-foundation" } " vocabulary defines bindings for some frequently-used Core Foundation functions. It also provides some utility words."
-$nl
-"Strings:"
-{ $subsection <CFString> }
-{ $subsection CF>string }
-"Arrays:"
-{ $subsection <CFArray> }
-{ $subsection CF>array }
-{ $subsection CF>string-array }
-"URLs:"
-{ $subsection <CFFileSystemURL> }
-{ $subsection <CFURL> }
-"Frameworks:"
-{ $subsection load-framework }
-"Memory management:"
-{ $subsection &CFRelease }
-{ $subsection |CFRelease } ;
-
-ABOUT: "core-foundation"
+++ /dev/null
-! Copyright (C) 2008 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: core-foundation tools.test kernel ;
-IN: core-foundation
-
-[ ] [ "Hello" <CFString> CFRelease ] unit-test
-[ "Hello" ] [ "Hello" <CFString> [ CF>string ] [ CFRelease ] bi ] unit-test
-[ "Hello\u003456" ] [ "Hello\u003456" <CFString> [ CF>string ] [ CFRelease ] bi ] unit-test
-[ "Hello\u013456" ] [ "Hello\u013456" <CFString> [ CF>string ] [ CFRelease ] bi ] unit-test
! Copyright (C) 2006, 2008 Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
-USING: alien alien.c-types alien.strings alien.syntax kernel
-math sequences io.encodings.utf8 destructors accessors
-combinators byte-arrays ;
+USING: alien.syntax destructors accessors kernel ;
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 ;
+FUNCTION: void CFRelease ( CFTypeRef cf ) ;
TUPLE: CFRelease-destructor alien disposed ;
--- /dev/null
+! Copyright (C) 2008 Joe Groff.
+! See http://factorcode.org/license.txt for BSD license.
+USING: alien.syntax alien.c-types sequences kernel math ;
+IN: core-foundation.data
+
+TYPEDEF: void* CFDataRef
+TYPEDEF: void* CFDictionaryRef
+TYPEDEF: void* CFMutableDictionaryRef
+TYPEDEF: void* CFNumberRef
+TYPEDEF: void* CFSetRef
+TYPEDEF: void* CFUUIDRef
+
+TYPEDEF: int CFNumberType
+: kCFNumberSInt8Type 1 ; inline
+: kCFNumberSInt16Type 2 ; inline
+: kCFNumberSInt32Type 3 ; inline
+: kCFNumberSInt64Type 4 ; inline
+: kCFNumberFloat32Type 5 ; inline
+: kCFNumberFloat64Type 6 ; inline
+: kCFNumberCharType 7 ; inline
+: kCFNumberShortType 8 ; inline
+: kCFNumberIntType 9 ; inline
+: kCFNumberLongType 10 ; inline
+: kCFNumberLongLongType 11 ; inline
+: kCFNumberFloatType 12 ; inline
+: kCFNumberDoubleType 13 ; inline
+: kCFNumberCFIndexType 14 ; inline
+: kCFNumberNSIntegerType 15 ; inline
+: kCFNumberCGFloatType 16 ; inline
+: kCFNumberMaxType 16 ; inline
+
+TYPEDEF: int CFPropertyListMutabilityOptions
+: kCFPropertyListImmutable 0 ; inline
+: kCFPropertyListMutableContainers 1 ; inline
+: kCFPropertyListMutableContainersAndLeaves 2 ; inline
+
+FUNCTION: CFNumberRef CFNumberCreate ( CFAllocatorRef allocator, CFNumberType theType, void* valuePtr ) ;
+
+FUNCTION: CFDataRef CFDataCreate ( CFAllocatorRef allocator, uchar* bytes, CFIndex length ) ;
+
+FUNCTION: CFTypeID CFGetTypeID ( CFTypeRef cf ) ;
+
+GENERIC: <CFNumber> ( number -- alien )
+
+M: integer <CFNumber>
+ [ f kCFNumberLongLongType ] dip <longlong> CFNumberCreate ;
+
+M: float <CFNumber>
+ [ f kCFNumberDoubleType ] dip <double> CFNumberCreate ;
+
+M: t <CFNumber>
+ drop f kCFNumberIntType 1 <int> CFNumberCreate ;
+
+M: f <CFNumber>
+ drop f kCFNumberIntType 0 <int> CFNumberCreate ;
+
+: <CFData> ( byte-array -- alien )
+ [ f ] dip dup length CFDataCreate ;
--- /dev/null
+unportable
+bindings
--- /dev/null
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: alien.syntax kernel math.bitwise core-foundation ;
+IN: core-foundation.file-descriptors
+
+TYPEDEF: void* CFFileDescriptorRef
+TYPEDEF: int CFFileDescriptorNativeDescriptor
+TYPEDEF: void* CFFileDescriptorCallBack
+
+FUNCTION: CFFileDescriptorRef CFFileDescriptorCreate (
+ CFAllocatorRef allocator,
+ CFFileDescriptorNativeDescriptor fd,
+ Boolean closeOnInvalidate,
+ CFFileDescriptorCallBack callout,
+ CFFileDescriptorContext* context
+) ;
+
+: kCFFileDescriptorReadCallBack 1 ; inline
+: kCFFileDescriptorWriteCallBack 2 ; inline
+
+FUNCTION: void CFFileDescriptorEnableCallBacks (
+ CFFileDescriptorRef f,
+ CFOptionFlags callBackTypes
+) ;
+
+: enable-all-callbacks ( fd -- )
+ { kCFFileDescriptorReadCallBack kCFFileDescriptorWriteCallBack } flags
+ CFFileDescriptorEnableCallBacks ;
+
+: <CFFileDescriptor> ( fd callback -- handle )
+ [ f swap ] [ t swap ] bi* f CFFileDescriptorCreate
+ [ "CFFileDescriptorCreate failed" throw ] unless* ;
--- /dev/null
+unportable
+bindings
! See http://factorcode.org/license.txt for BSD license.
USING: alien alien.c-types alien.strings alien.syntax kernel
math sequences namespaces make assocs init accessors
-continuations combinators core-foundation
-core-foundation.run-loop core-foundation.run-loop.thread
-io.encodings.utf8 destructors locals arrays
-specialized-arrays.direct.alien specialized-arrays.direct.int
-specialized-arrays.direct.longlong ;
+continuations combinators io.encodings.utf8 destructors locals
+arrays specialized-arrays.direct.alien
+specialized-arrays.direct.int specialized-arrays.direct.longlong
+core-foundation core-foundation.run-loop core-foundation.strings
+core-foundation.time ;
IN: core-foundation.fsevents
: kFSEventStreamCreateFlagUseCFTypes 2 ; inline
FSEventStreamCreate ;
: kCFRunLoopCommonModes ( -- string )
- "kCFRunLoopCommonModes" f dlsym *void* ;
+ &: kCFRunLoopCommonModes *void* ;
: schedule-event-stream ( event-stream -- )
CFRunLoopGetMain
! Copyright (C) 2008 Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
-USING: alien alien.syntax core-foundation kernel namespaces ;
+USING: accessors alien alien.syntax kernel math namespaces
+sequences destructors combinators threads heaps deques calendar
+core-foundation core-foundation.strings
+core-foundation.file-descriptors core-foundation.timers
+core-foundation.time ;
IN: core-foundation.run-loop
: kCFRunLoopRunFinished 1 ; inline
CFStringRef mode
) ;
+FUNCTION: void CFRunLoopRemoveSource (
+ CFRunLoopRef rl,
+ CFRunLoopSourceRef source,
+ CFStringRef mode
+) ;
+
+FUNCTION: void CFRunLoopAddTimer (
+ CFRunLoopRef rl,
+ CFRunLoopTimerRef timer,
+ CFStringRef mode
+) ;
+
+FUNCTION: void CFRunLoopRemoveTimer (
+ CFRunLoopRef rl,
+ CFRunLoopTimerRef timer,
+ CFStringRef mode
+) ;
+
: CFRunLoopDefaultMode ( -- alien )
#! Ugly, but we don't have static NSStrings
\ CFRunLoopDefaultMode get-global dup expired? [
"kCFRunLoopDefaultMode" <CFString>
dup \ CFRunLoopDefaultMode set-global
] when ;
+
+TUPLE: run-loop fds sources timers ;
+
+: <run-loop> ( -- run-loop )
+ V{ } clone V{ } clone V{ } clone \ run-loop boa ;
+
+SYMBOL: expiry-check
+
+: run-loop ( -- run-loop )
+ \ run-loop get-global not expiry-check get expired? or
+ [
+ 31337 <alien> expiry-check set-global
+ <run-loop> dup \ run-loop set-global
+ ] [ \ run-loop get-global ] if ;
+
+: add-source-to-run-loop ( source -- )
+ [ run-loop sources>> push ]
+ [
+ CFRunLoopGetMain
+ swap CFRunLoopDefaultMode
+ CFRunLoopAddSource
+ ] bi ;
+
+: create-fd-source ( CFFileDescriptor -- source )
+ f swap 0 CFFileDescriptorCreateRunLoopSource ;
+
+: add-fd-to-run-loop ( fd callback -- )
+ [
+ <CFFileDescriptor> |CFRelease
+ [ run-loop fds>> push ]
+ [ create-fd-source |CFRelease add-source-to-run-loop ]
+ bi
+ ] with-destructors ;
+
+: add-timer-to-run-loop ( timer -- )
+ [ run-loop timers>> push ]
+ [
+ CFRunLoopGetMain
+ swap CFRunLoopDefaultMode
+ CFRunLoopAddTimer
+ ] bi ;
+
+<PRIVATE
+
+: ((reset-timer)) ( timer counter timestamp -- )
+ nip >CFAbsoluteTime CFRunLoopTimerSetNextFireDate ;
+
+: (reset-timer) ( timer counter -- )
+ yield {
+ { [ dup 0 = ] [ now ((reset-timer)) ] }
+ { [ run-queue deque-empty? not ] [ 1- (reset-timer) ] }
+ { [ sleep-queue heap-empty? ] [ 5 minutes hence ((reset-timer)) ] }
+ [ sleep-queue heap-peek nip micros>timestamp ((reset-timer)) ]
+ } cond ;
+
+: reset-timer ( timer -- )
+ 10 (reset-timer) ;
+
+PRIVATE>
+
+: reset-run-loop ( -- )
+ run-loop
+ [ timers>> [ reset-timer ] each ]
+ [ fds>> [ enable-all-callbacks ] each ] bi ;
+
+: timer-callback ( -- callback )
+ "void" { "CFRunLoopTimerRef" "void*" } "cdecl"
+ [ 2drop reset-run-loop yield ] alien-callback ;
+
+: init-thread-timer ( -- )
+ timer-callback <CFTimer> add-timer-to-run-loop ;
+
+: run-one-iteration ( us -- handled? )
+ reset-run-loop
+ CFRunLoopDefaultMode
+ swap [ microseconds ] [ 5 minutes ] if* >CFTimeInterval
+ t CFRunLoopRunInMode kCFRunLoopRunHandledSource = ;
+++ /dev/null
-Slava Pestov
+++ /dev/null
-Vocabulary with init hook for running CoreFoundation event loop
+++ /dev/null
-unportable
+++ /dev/null
-! Copyright (C) 2008 Slava Pestov
-! See http://factorcode.org/license.txt for BSD license.
-USING: calendar core-foundation.run-loop init kernel threads ;
-IN: core-foundation.run-loop.thread
-
-! Load this vocabulary if you need a run loop running.
-
-: run-loop-thread ( -- )
- CFRunLoopDefaultMode 0 f CFRunLoopRunInMode
- kCFRunLoopRunHandledSource = [ 1 seconds sleep ] unless
- run-loop-thread ;
-
-: start-run-loop-thread ( -- )
- [ run-loop-thread t ] "CFRunLoop dispatcher" spawn-server drop ;
-
-[ start-run-loop-thread ] "core-foundation.run-loop.thread" add-init-hook
--- /dev/null
+USING: help.syntax help.markup strings ;
+IN: core-foundation.strings
+
+HELP: <CFString>
+{ $values { "string" string } { "alien" "a " { $snippet "CFString" } } }
+{ $description "Creates a Core Foundation string from a Factor string." } ;
+
+HELP: CF>string
+{ $values { "alien" "a " { $snippet "CFString" } } { "string" string } }
+{ $description "Creates a Factor string from a Core Foundation string." } ;
+
+HELP: CF>string-array
+{ $values { "alien" "a " { $snippet "CFArray" } " of " { $snippet "CFString" } " instances" } { "seq" string } }
+{ $description "Creates an array of Factor strings from a " { $snippet "CFArray" } " of " { $snippet "CFString" } "s." } ;
--- /dev/null
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: core-foundation.strings core-foundation tools.test kernel ;
+IN: core-foundation
+
+[ ] [ "Hello" <CFString> CFRelease ] unit-test
+[ "Hello" ] [ "Hello" <CFString> [ CF>string ] [ CFRelease ] bi ] unit-test
+[ "Hello\u003456" ] [ "Hello\u003456" <CFString> [ CF>string ] [ CFRelease ] bi ] unit-test
+[ "Hello\u013456" ] [ "Hello\u013456" <CFString> [ CF>string ] [ CFRelease ] bi ] unit-test
--- /dev/null
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: alien.syntax alien.strings kernel sequences byte-arrays
+io.encodings.utf8 math core-foundation core-foundation.arrays ;
+IN: core-foundation.strings
+
+TYPEDEF: void* CFStringRef
+
+TYPEDEF: int CFStringEncoding
+: kCFStringEncodingMacRoman HEX: 0 ;
+: kCFStringEncodingWindowsLatin1 HEX: 0500 ;
+: kCFStringEncodingISOLatin1 HEX: 0201 ;
+: kCFStringEncodingNextStepLatin HEX: 0B01 ;
+: kCFStringEncodingASCII HEX: 0600 ;
+: kCFStringEncodingUnicode HEX: 0100 ;
+: kCFStringEncodingUTF8 HEX: 08000100 ;
+: kCFStringEncodingNonLossyASCII HEX: 0BFF ;
+: kCFStringEncodingUTF16 HEX: 0100 ;
+: kCFStringEncodingUTF16BE HEX: 10000100 ;
+: kCFStringEncodingUTF16LE HEX: 14000100 ;
+: kCFStringEncodingUTF32 HEX: 0c000100 ;
+: kCFStringEncodingUTF32BE HEX: 18000100 ;
+: kCFStringEncodingUTF32LE HEX: 1c000100 ;
+
+FUNCTION: CFStringRef CFStringCreateWithBytes (
+ CFAllocatorRef alloc,
+ UInt8* bytes,
+ CFIndex numBytes,
+ CFStringEncoding encoding,
+ Boolean isExternalRepresentation
+) ;
+
+FUNCTION: CFIndex CFStringGetLength ( CFStringRef theString ) ;
+
+FUNCTION: void CFStringGetCharacters ( void* theString, CFIndex start, CFIndex length, void* buffer ) ;
+
+FUNCTION: Boolean CFStringGetCString (
+ CFStringRef theString,
+ char* buffer,
+ CFIndex bufferSize,
+ CFStringEncoding encoding
+) ;
+
+FUNCTION: CFStringRef CFStringCreateWithCString (
+ CFAllocatorRef alloc,
+ char* cStr,
+ CFStringEncoding encoding
+) ;
+
+: <CFString> ( string -- alien )
+ f swap utf8 string>alien kCFStringEncodingUTF8 CFStringCreateWithCString
+ [ "CFStringCreateWithCString failed" throw ] unless* ;
+
+: CF>string ( alien -- string )
+ dup CFStringGetLength 4 * 1 + <byte-array> [
+ dup length
+ kCFStringEncodingUTF8
+ CFStringGetCString
+ [ "CFStringGetCString failed" throw ] unless
+ ] keep utf8 alien>string ;
+
+: CF>string-array ( alien -- seq )
+ CF>array [ CF>string ] map ;
+
+: <CFStringArray> ( seq -- alien )
+ [ <CFString> ] map [ <CFArray> ] [ [ CFRelease ] each ] bi ;
--- /dev/null
+unportable
+bindings
--- /dev/null
+! 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
--- /dev/null
+unportable
+bindings
--- /dev/null
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: alien.syntax system math kernel 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
+) ;
--- /dev/null
+unportable
+bindings
--- /dev/null
+USING: help.syntax help.markup ;
+IN: core-foundation.urls
+
+HELP: <CFFileSystemURL>
+{ $values { "string" "a pathname string" } { "dir?" "a boolean indicating if the pathname is a directory" } { "url" "a " { $snippet "CFURL" } } }
+{ $description "Creates a new " { $snippet "CFURL" } " pointing to the given local pathname." } ;
+
+HELP: <CFURL>
+{ $values { "string" "a URL string" } { "url" "a " { $snippet "CFURL" } } }
+{ $description "Creates a new " { $snippet "CFURL" } "." } ;
--- /dev/null
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: alien.syntax kernel core-foundation.strings
+core-foundation ;
+IN: core-foundation.urls
+
+: kCFURLPOSIXPathStyle 0 ; inline
+
+TYPEDEF: void* CFURLRef
+
+FUNCTION: CFURLRef CFURLCreateWithFileSystemPath ( CFAllocatorRef allocator, CFStringRef filePath, int pathStyle, Boolean isDirectory ) ;
+
+FUNCTION: CFURLRef CFURLCreateWithString ( CFAllocatorRef allocator, CFStringRef string, CFURLRef base ) ;
+
+FUNCTION: CFURLRef CFURLCopyFileSystemPath ( CFURLRef url, int pathStyle ) ;
+
+: <CFFileSystemURL> ( string dir? -- url )
+ [ <CFString> f over kCFURLPOSIXPathStyle ] dip
+ CFURLCreateWithFileSystemPath swap CFRelease ;
+
+: <CFURL> ( string -- url )
+ <CFString>
+ [ f swap f CFURLCreateWithString ] keep
+ CFRelease ;
! See http://factorcode.org/license.txt for BSD license.
USING: alien alien.c-types alien.strings alien.syntax kernel
layouts sequences system unix environment io.encodings.utf8
-unix.utilities vocabs.loader combinators alien.accessors ;
+unix.utilities vocabs.loader combinators alien.accessors
+alien.syntax ;
IN: environment.unix
HOOK: environ os ( -- void* )
-M: unix environ ( -- void* ) "environ" f dlsym ;
+M: unix environ ( -- void* ) &: environ ;
M: unix os-env ( key -- value ) getenv ;
io.encodings
io.encodings.string
io.encodings.ascii
+io.encodings.utf8
io.encodings.8-bit
io.encodings.binary
io.streams.duplex
M: post-data >post-data ;
-M: string >post-data "application/octet-stream" <post-data> ;
+M: string >post-data
utf8 encode "application/octet-stream" <post-data> ;
M: byte-array >post-data "application/octet-stream" <post-data> ;
-M: assoc >post-data assoc>query "application/x-www-form-urlencoded" <post-data> ;
+M: assoc >post-data assoc>query
ascii encode "application/x-www-form-urlencoded" <post-data> ;
M: f >post-data ;
[ >post-data ] change-post-data ;
: write-post-data ( request -- request )
- dup method>> "POST" = [ dup post-data>> raw>> write ] when ;
+ dup method>> [ "POST" = ] [ "PUT" = ] bi or [ dup post-data>> raw>> write ] when ;
: write-request ( request -- )
unparse-post-data
write-request-line
write-request-header
+ binary encode-output
write-post-data
flush
drop ;
PRIVATE>
-: success? ( code -- ? ) 200 = ;
+: success? ( code -- ? ) 200 299 between? ;
ERROR: download-failed response ;
{ $description "Launches a process and redirects its input and output via a pair of pipes which may be read and written as a stream of the given encoding." } ;
HELP: wait-for-process
-{ $values { "process" process } { "status" integer } }
-{ $description "If the process is still running, waits for it to exit, otherwise outputs the exit code immediately. Can be called multiple times on the same process." } ;
+{ $values { "process" process } { "status" object } }
+{ $description "If the process is still running, waits for it to exit, otherwise outputs the status code immediately. Can be called multiple times on the same process." }
+{ $notes "The status code is operating system specific; it may be an integer, or another object (the latter is the case on Unix if the process was killed by a signal). However, one cross-platform behavior code can rely on is that a status code of 0 indicates success." } ;
ARTICLE: "io.launcher.descriptors" "Launch descriptors"
"Words which launch processes can take either a command line string, a sequence of command line arguments, or a " { $link process } "."
process>> . ;
: wait-for-success ( process -- )
- dup wait-for-process dup zero?
+ dup wait-for-process dup 0 =
[ 2drop ] [ process-failed ] if ;
: try-process ( desc -- )
! Copyright (C) 2008 Slava Pestov.\r
! See http://factorcode.org/license.txt for BSD license.\r
+USING: threads io.backend namespaces init math kernel ;\r
IN: io.thread\r
-USING: threads io.backend namespaces init math ;\r
+\r
+! The Cocoa UI backend stops the I/O thread and takes over\r
+! completely.\r
+SYMBOL: io-thread-running?\r
\r
: io-thread ( -- )\r
sleep-time io-multiplex yield ;\r
\r
: start-io-thread ( -- )\r
- [ io-thread t ]\r
- "I/O wait" spawn-server\r
- \ io-thread set-global ;\r
+ [ [ io-thread-running? get-global ] [ io-thread ] [ ] while ]\r
+ "I/O wait" spawn drop ;\r
\r
-[ start-io-thread ] "io.thread" add-init-hook\r
+[\r
+ t io-thread-running? set-global\r
+ start-io-thread\r
+] "io.thread" add-init-hook\r
! Copyright (C) 2004, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: alien alien.c-types generic assocs kernel kernel.private
-math io.ports sequences strings sbufs threads unix
-vectors io.buffers io.backend io.encodings math.parser
+USING: alien alien.c-types alien.syntax generic assocs kernel
+kernel.private math io.ports sequences strings sbufs threads
+unix vectors io.buffers io.backend io.encodings math.parser
continuations system libc qualified namespaces make io.timeouts
io.encodings.utf8 destructors accessors summary combinators
-locals unix.time fry ;
+locals unix.time fry io.unix.multiplexers ;
QUALIFIED: io
IN: io.unix.backend
M: fd handle-fd dup check-disposed fd>> ;
-! I/O multiplexers
-TUPLE: mx fd reads writes ;
-
-: new-mx ( class -- obj )
- new
- H{ } clone >>reads
- H{ } clone >>writes ; inline
-
-GENERIC: add-input-callback ( thread fd mx -- )
-
-M: mx add-input-callback reads>> push-at ;
-
-GENERIC: add-output-callback ( thread fd mx -- )
-
-M: mx add-output-callback writes>> push-at ;
-
-GENERIC: remove-input-callbacks ( fd mx -- callbacks )
-
-M: mx remove-input-callbacks reads>> delete-at* drop ;
-
-GENERIC: remove-output-callbacks ( fd mx -- callbacks )
-
-M: mx remove-output-callbacks writes>> delete-at* drop ;
-
-GENERIC: wait-for-events ( ms mx -- )
-
-: input-available ( fd mx -- )
- reads>> delete-at* drop [ resume ] each ;
-
-: output-available ( fd mx -- )
- writes>> delete-at* drop [ resume ] each ;
-
M: fd cancel-operation ( fd -- )
dup disposed>> [ drop ] [
fd>>
M: stdin refill
[ buffer>> ] [ dup wait-for-stdin ] bi* refill-stdin f ;
-: control-write-fd ( -- fd ) "control_write" f dlsym *uint ;
+: control-write-fd ( -- fd ) &: control_write *uint ;
-: size-read-fd ( -- fd ) "size_read" f dlsym *uint ;
+: size-read-fd ( -- fd ) &: size_read *uint ;
-: data-read-fd ( -- fd ) "stdin_read" f dlsym *uint ;
+: data-read-fd ( -- fd ) &: stdin_read *uint ;
: <stdin> ( -- stdin )
stdin new
: <mx-port> ( mx -- port )
dup fd>> mx-port <port> swap >>mx ;
-: multiplexer-error ( n -- )
- 0 < [
+: multiplexer-error ( n -- n )
+ dup 0 < [
err_no [ EAGAIN = ] [ EINTR = ] bi or
- [ (io-error) ] unless
+ [ drop 0 ] [ (io-error) ] if
] when ;
: ?flag ( n mask symbol -- n )
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-IN: io.unix.bsd
USING: namespaces system kernel accessors assocs continuations
-unix io.backend io.unix.backend io.unix.select ;
+unix io.backend io.unix.backend io.unix.multiplexers
+io.unix.multiplexers.kqueue ;
+IN: io.unix.bsd
M: bsd init-io ( -- )
- <select-mx> mx set-global ;
-! <kqueue-mx> kqueue-mx set-global
-! kqueue-mx get-global <mx-port> <mx-task>
-! dup io-task-fd
-! [ mx get-global reads>> set-at ]
-! [ mx get-global writes>> set-at ] 2bi ;
+ <kqueue-mx> mx set-global ;
! M: bsd (monitor) ( path recursive? mailbox -- )
! swap [ "Recursive kqueue monitors not supported" throw ] when
: wait-event ( mx us -- n )
[ [ fd>> ] [ events>> ] bi [ underlying>> ] [ length ] bi ] [ 1000 /i ] bi*
- epoll_wait dup multiplexer-error ;
+ epoll_wait multiplexer-error ;
: handle-event ( event mx -- )
[ epoll-event-fd ] dip
[
[ fd>> f 0 ]
[ events>> [ underlying>> ] [ length ] bi ] bi
- ] dip kevent
- dup multiplexer-error ;
+ ] dip kevent multiplexer-error ;
: handle-kevent ( mx kevent -- )
[ kevent-ident swap ] [ kevent-filter ] bi {
USING: io.files tools.test io.launcher arrays io namespaces
continuations math io.encodings.binary io.encodings.ascii
accessors kernel sequences io.encodings.utf8 destructors
-io.streams.duplex ;
+io.streams.duplex locals concurrency.promises threads
+unix.process ;
[ ] [
[ "launcher-test-1" temp-file delete-file ] ignore-errors
input-stream get contents
] with-stream
] unit-test
+
+! Killed processes were exiting with code 0 on FreeBSD
+[ f ] [
+ [let | p [ <promise> ]
+ s [ <promise> ] |
+ [
+ "sleep 1000" run-detached
+ [ p fulfill ] [ wait-for-process s fulfill ] bi
+ ] in-thread
+
+ p ?promise handle>> 9 kill drop
+ s ?promise 0 =
+ ]
+] unit-test
processes get swap [ nip swap handle>> = ] curry
assoc-find 2drop ;
+TUPLE: signal n ;
+
+: code>status ( code -- obj )
+ dup WIFEXITED [ WEXITSTATUS ] [ WTERMSIG signal boa ] if ;
+
M: unix wait-for-processes ( -- ? )
-1 0 <int> tuck WNOHANG waitpid
dup 0 <= [
2drop t
] [
- find-process dup [
- swap *int WEXITSTATUS notify-exit f
- ] [
- 2drop f
- ] if
+ find-process dup
+ [ swap *int code>status notify-exit f ] [ 2drop f ] if
] if ;
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel io.backend io.monitors io.unix.backend
-io.unix.epoll io.unix.linux.monitors system namespaces ;
+USING: kernel system namespaces io.backend io.unix.backend
+io.unix.multiplexers io.unix.multiplexers.epoll ;
IN: io.unix.linux
M: linux init-io ( -- )
! See http://factorcode.org/license.txt for BSD license.
USING: kernel io.backend io.monitors io.monitors.recursive
io.files io.buffers io.monitors io.ports io.timeouts
-io.unix.backend io.unix.select io.encodings.utf8
-unix.linux.inotify assocs namespaces make threads continuations
-init math math.bitwise sets alien alien.strings alien.c-types
-vocabs.loader accessors system hashtables destructors unix ;
+io.unix.backend io.encodings.utf8 unix.linux.inotify assocs
+namespaces make threads continuations init math math.bitwise
+sets alien alien.strings alien.c-types vocabs.loader accessors
+system hashtables destructors unix ;
IN: io.unix.linux.monitors
SYMBOL: watches
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
+USING: io.backend system namespaces io.unix.multiplexers
+io.unix.multiplexers.run-loop ;
IN: io.unix.macosx
-USING: io.unix.backend io.unix.bsd io.unix.kqueue io.backend
-namespaces system ;
M: macosx init-io ( -- )
- <kqueue-mx> mx set-global ;
+ <run-loop-mx> mx set-global ;
macosx set-io-backend
--- /dev/null
+Slava Pestov
--- /dev/null
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors alien.c-types kernel destructors bit-arrays
+sequences assocs struct-arrays math namespaces locals fry unix
+unix.linux.epoll unix.time io.ports io.unix.backend
+io.unix.multiplexers ;
+IN: io.unix.multiplexers.epoll
+
+TUPLE: epoll-mx < mx events ;
+
+: max-events ( -- n )
+ #! We read up to 256 events at a time. This is an arbitrary
+ #! constant...
+ 256 ; inline
+
+: <epoll-mx> ( -- mx )
+ epoll-mx new-mx
+ max-events epoll_create dup io-error >>fd
+ max-events "epoll-event" <struct-array> >>events ;
+
+M: epoll-mx dispose fd>> close-file ;
+
+: make-event ( fd events -- event )
+ "epoll-event" <c-object>
+ [ set-epoll-event-events ] keep
+ [ set-epoll-event-fd ] keep ;
+
+:: do-epoll-ctl ( fd mx what events -- )
+ mx fd>> what fd fd events make-event epoll_ctl io-error ;
+
+: do-epoll-add ( fd mx events -- )
+ EPOLL_CTL_ADD swap EPOLLONESHOT bitor do-epoll-ctl ;
+
+: do-epoll-del ( fd mx events -- )
+ EPOLL_CTL_DEL swap do-epoll-ctl ;
+
+M: epoll-mx add-input-callback ( thread fd mx -- )
+ [ EPOLLIN do-epoll-add ] [ call-next-method ] 2bi ;
+
+M: epoll-mx add-output-callback ( thread fd mx -- )
+ [ EPOLLOUT do-epoll-add ] [ call-next-method ] 2bi ;
+
+M: epoll-mx remove-input-callbacks ( fd mx -- seq )
+ 2dup reads>> key? [
+ [ call-next-method ] [ EPOLLIN do-epoll-del ] 2bi
+ ] [ 2drop f ] if ;
+
+M: epoll-mx remove-output-callbacks ( fd mx -- seq )
+ 2dup writes>> key? [
+ [ EPOLLOUT do-epoll-del ] [ call-next-method ] 2bi
+ ] [ 2drop f ] if ;
+
+: wait-event ( mx us -- n )
+ [ [ fd>> ] [ events>> ] bi [ underlying>> ] [ length ] bi ] [ 1000 /i ] bi*
+ epoll_wait multiplexer-error ;
+
+: handle-event ( event mx -- )
+ [ epoll-event-fd ] dip
+ [ EPOLLIN EPOLLOUT bitor do-epoll-del ]
+ [ input-available ] [ output-available ] 2tri ;
+
+: handle-events ( mx n -- )
+ [ dup events>> ] dip head-slice swap '[ _ handle-event ] each ;
+
+M: epoll-mx wait-for-events ( us mx -- )
+ swap 60000000 or dupd wait-event handle-events ;
--- /dev/null
+unportable
--- /dev/null
+Slava Pestov
--- /dev/null
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors alien.c-types combinators destructors
+io.unix.backend kernel math.bitwise sequences struct-arrays unix
+unix.kqueue unix.time assocs io.unix.multiplexers ;
+IN: io.unix.multiplexers.kqueue
+
+TUPLE: kqueue-mx < mx events ;
+
+: max-events ( -- n )
+ #! We read up to 256 events at a time. This is an arbitrary
+ #! constant...
+ 256 ; inline
+
+: <kqueue-mx> ( -- mx )
+ kqueue-mx new-mx
+ kqueue dup io-error >>fd
+ max-events "kevent" <struct-array> >>events ;
+
+M: kqueue-mx dispose fd>> close-file ;
+
+: make-kevent ( fd filter flags -- event )
+ "kevent" <c-object>
+ [ set-kevent-flags ] keep
+ [ set-kevent-filter ] keep
+ [ set-kevent-ident ] keep ;
+
+: register-kevent ( kevent mx -- )
+ fd>> swap 1 f 0 f kevent io-error ;
+
+M: kqueue-mx add-input-callback ( thread fd mx -- )
+ [ call-next-method ] [
+ [ EVFILT_READ { EV_ADD EV_ONESHOT } flags make-kevent ] dip
+ register-kevent
+ ] 2bi ;
+
+M: kqueue-mx add-output-callback ( thread fd mx -- )
+ [ call-next-method ] [
+ [ EVFILT_WRITE { EV_ADD EV_ONESHOT } flags make-kevent ] dip
+ register-kevent
+ ] 2bi ;
+
+M: kqueue-mx remove-input-callbacks ( fd mx -- seq )
+ 2dup reads>> key? [
+ [ call-next-method ] [
+ [ EVFILT_READ EV_DELETE make-kevent ] dip
+ register-kevent
+ ] 2bi
+ ] [ 2drop f ] if ;
+
+M: kqueue-mx remove-output-callbacks ( fd mx -- seq )
+ 2dup writes>> key? [
+ [
+ [ EVFILT_WRITE EV_DELETE make-kevent ] dip
+ register-kevent
+ ] [ call-next-method ] 2bi
+ ] [ 2drop f ] if ;
+
+: wait-kevent ( mx timespec -- n )
+ [
+ [ fd>> f 0 ]
+ [ events>> [ underlying>> ] [ length ] bi ] bi
+ ] dip kevent multiplexer-error ;
+
+: handle-kevent ( mx kevent -- )
+ [ kevent-ident swap ] [ kevent-filter ] bi {
+ { EVFILT_READ [ input-available ] }
+ { EVFILT_WRITE [ output-available ] }
+ } case ;
+
+: handle-kevents ( mx n -- )
+ [ dup events>> ] dip head-slice [ handle-kevent ] with each ;
+
+M: kqueue-mx wait-for-events ( us mx -- )
+ swap dup [ make-timespec ] when
+ dupd wait-kevent handle-kevents ;
--- /dev/null
+unportable
--- /dev/null
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel accessors assocs sequences threads ;
+IN: io.unix.multiplexers
+
+TUPLE: mx fd reads writes ;
+
+: new-mx ( class -- obj )
+ new
+ H{ } clone >>reads
+ H{ } clone >>writes ; inline
+
+GENERIC: add-input-callback ( thread fd mx -- )
+
+M: mx add-input-callback reads>> push-at ;
+
+GENERIC: add-output-callback ( thread fd mx -- )
+
+M: mx add-output-callback writes>> push-at ;
+
+GENERIC: remove-input-callbacks ( fd mx -- callbacks )
+
+M: mx remove-input-callbacks reads>> delete-at* drop ;
+
+GENERIC: remove-output-callbacks ( fd mx -- callbacks )
+
+M: mx remove-output-callbacks writes>> delete-at* drop ;
+
+GENERIC: wait-for-events ( ms mx -- )
+
+: input-available ( fd mx -- )
+ reads>> delete-at* drop [ resume ] each ;
+
+: output-available ( fd mx -- )
+ writes>> delete-at* drop [ resume ] each ;
--- /dev/null
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel arrays namespaces math accessors alien locals
+destructors system threads io.unix.multiplexers
+io.unix.multiplexers.kqueue core-foundation
+core-foundation.run-loop ;
+IN: io.unix.multiplexers.run-loop
+
+TUPLE: run-loop-mx kqueue-mx ;
+
+: file-descriptor-callback ( -- callback )
+ "void" { "CFFileDescriptorRef" "CFOptionFlags" "void*" }
+ "cdecl" [
+ 3drop
+ 0 mx get kqueue-mx>> wait-for-events
+ reset-run-loop
+ yield
+ ] alien-callback ;
+
+: <run-loop-mx> ( -- mx )
+ [
+ <kqueue-mx> |dispose
+ dup fd>> file-descriptor-callback add-fd-to-run-loop
+ run-loop-mx boa
+ ] with-destructors ;
+
+M: run-loop-mx add-input-callback kqueue-mx>> add-input-callback ;
+M: run-loop-mx add-output-callback kqueue-mx>> add-output-callback ;
+M: run-loop-mx remove-input-callbacks kqueue-mx>> remove-input-callbacks ;
+M: run-loop-mx remove-output-callbacks kqueue-mx>> remove-output-callbacks ;
+
+M: run-loop-mx wait-for-events ( us mx -- )
+ swap run-one-iteration [ 0 swap wait-for-events ] [ drop ] if ;
--- /dev/null
+unportable
--- /dev/null
+Slava Pestov
--- /dev/null
+! Copyright (C) 2004, 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: alien.c-types kernel bit-arrays sequences assocs unix
+math namespaces accessors math.order locals unix.time fry
+io.ports io.unix.backend io.unix.multiplexers ;
+IN: io.unix.multiplexers.select
+
+TUPLE: select-mx < mx read-fdset write-fdset ;
+
+! Factor's bit-arrays are an array of bytes, OS X expects
+! FD_SET to be an array of cells, so we have to account for
+! byte order differences on big endian platforms
+: munge ( i -- i' )
+ little-endian? [ BIN: 11000 bitxor ] unless ; inline
+
+: <select-mx> ( -- mx )
+ select-mx new-mx
+ FD_SETSIZE 8 * <bit-array> >>read-fdset
+ FD_SETSIZE 8 * <bit-array> >>write-fdset ;
+
+: clear-nth ( n seq -- ? )
+ [ nth ] [ [ f ] 2dip set-nth ] 2bi ;
+
+:: check-fd ( fd fdset mx quot -- )
+ fd munge fdset clear-nth [ fd mx quot call ] when ; inline
+
+: check-fdset ( fds fdset mx quot -- )
+ [ check-fd ] 3curry each ; inline
+
+: init-fdset ( fds fdset -- )
+ '[ t swap munge _ set-nth ] each ;
+
+: read-fdset/tasks ( mx -- seq fdset )
+ [ reads>> keys ] [ read-fdset>> ] bi ;
+
+: write-fdset/tasks ( mx -- seq fdset )
+ [ writes>> keys ] [ write-fdset>> ] bi ;
+
+: max-fd ( assoc -- n )
+ dup assoc-empty? [ drop 0 ] [ keys supremum ] if ;
+
+: num-fds ( mx -- n )
+ [ reads>> max-fd ] [ writes>> max-fd ] bi max 1+ ;
+
+: init-fdsets ( mx -- nfds read write except )
+ [ num-fds ]
+ [ read-fdset/tasks [ init-fdset ] [ underlying>> ] bi ]
+ [ write-fdset/tasks [ init-fdset ] [ underlying>> ] bi ] tri
+ f ;
+
+M:: select-mx wait-for-events ( us mx -- )
+ mx
+ [ init-fdsets us dup [ make-timeval ] when select multiplexer-error drop ]
+ [ [ read-fdset/tasks ] keep [ input-available ] check-fdset ]
+ [ [ write-fdset/tasks ] keep [ output-available ] check-fdset ]
+ tri ;
--- /dev/null
+unportable
M:: select-mx wait-for-events ( us mx -- )
mx
- [ init-fdsets us dup [ make-timeval ] when select multiplexer-error ]
+ [ init-fdsets us dup [ make-timeval ] when select multiplexer-error drop ]
[ [ read-fdset/tasks ] keep [ input-available ] check-fdset ]
[ [ write-fdset/tasks ] keep [ output-available ] check-fdset ]
tri ;
--- /dev/null
+Joe Groff
\ No newline at end of file
--- /dev/null
+USING: help.markup help.syntax io kernel math quotations
+opengl.gl multiline assocs ;
+IN: opengl.capabilities
+
+HELP: gl-version
+{ $values { "version" "The version string from the OpenGL implementation" } }
+{ $description "Wrapper for " { $snippet "GL_VERSION glGetString" } " that removes the vendor-specific information from the version string." } ;
+
+HELP: gl-vendor-version
+{ $values { "version" "The vendor-specific version information from the OpenGL implementation" } }
+{ $description "Wrapper for " { $snippet "GL_VERSION glGetString" } " that returns only the vendor-specific information from the version string." } ;
+
+HELP: has-gl-version?
+{ $values { "version" "A version string" } { "?" "A boolean value" } }
+{ $description "Compares the version string returned by " { $link gl-version } " to " { $snippet "version" } ". Returns true if the implementation version meets or exceeds " { $snippet "version" } "." } ;
+
+HELP: require-gl-version
+{ $values { "version" "A version string" } }
+{ $description "Throws an exception if " { $link has-gl-version? } " returns false for " { $snippet "version" } "." } ;
+
+HELP: glsl-version
+{ $values { "version" "The GLSL version string from the OpenGL implementation" } }
+{ $description "Wrapper for " { $snippet "GL_SHADING_LANGUAGE_VERSION glGetString" } " that removes the vendor-specific information from the version string." } ;
+
+HELP: glsl-vendor-version
+{ $values { "version" "The vendor-specific GLSL version information from the OpenGL implementation" } }
+{ $description "Wrapper for " { $snippet "GL_SHADING_LANGUAGE_VERSION glGetString" } " that returns only the vendor-specific information from the version string." } ;
+
+HELP: has-glsl-version?
+{ $values { "version" "A version string" } { "?" "A boolean value" } }
+{ $description "Compares the version string returned by " { $link glsl-version } " to " { $snippet "version" } ". Returns true if the implementation version meets or exceeds " { $snippet "version" } "." } ;
+
+HELP: require-glsl-version
+{ $values { "version" "A version string" } }
+{ $description "Throws an exception if " { $link has-glsl-version? } " returns false for " { $snippet "version" } "." } ;
+
+HELP: gl-extensions
+{ $values { "seq" "A sequence of strings naming the implementation-supported OpenGL extensions" } }
+{ $description "Wrapper for " { $snippet "GL_EXTENSIONS glGetString" } " that returns a sequence of extension names supported by the OpenGL implementation." } ;
+
+HELP: has-gl-extensions?
+{ $values { "extensions" "A sequence of extension name strings" } { "?" "A boolean value" } }
+{ $description "Returns true if the set of " { $snippet "extensions" } " is a subset of the implementation-supported extensions returned by " { $link gl-extensions } "." } ;
+
+HELP: has-gl-version-or-extensions?
+{ $values { "version" "A version string" } { "extensions" "A sequence of extension name strings" } { "?" "a boolean" } }
+{ $description "Returns true if either " { $link has-gl-version? } " or " { $link has-gl-extensions? } " returns true for " { $snippet "version" } " or " { $snippet "extensions" } ", respectively. Intended for use when required OpenGL functionality can be verified either by a minimum version or a set of equivalent extensions." } ;
+
+HELP: require-gl-extensions
+{ $values { "extensions" "A sequence of extension name strings" } }
+{ $description "Throws an exception if " { $link has-gl-extensions? } " returns false for " { $snippet "extensions" } "." } ;
+
+HELP: require-gl-version-or-extensions
+{ $values { "version" "A version string" } { "extensions" "A sequence of extension name strings" } }
+{ $description "Throws an exception if neither " { $link has-gl-version? } " nor " { $link has-gl-extensions? } " returns true for " { $snippet "version" } " or " { $snippet "extensions" } ", respectively. Intended for use when required OpenGL functionality can be verified either by a minimum version or a set of equivalent extensions." } ;
+
+{ require-gl-version require-glsl-version require-gl-extensions require-gl-version-or-extensions has-gl-version? has-glsl-version? has-gl-extensions? has-gl-version-or-extensions? gl-version glsl-version gl-extensions } related-words
+
+ABOUT: "gl-utilities"
--- /dev/null
+! Copyright (C) 2008 Joe Groff.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel namespaces make sequences splitting opengl.gl
+continuations math.parser math arrays sets math.order ;
+IN: opengl.capabilities
+
+: (require-gl) ( thing require-quot make-error-quot -- )
+ -rot dupd call
+ [ 2drop ]
+ [ swap " " make throw ]
+ if ; inline
+
+: gl-extensions ( -- seq )
+ GL_EXTENSIONS glGetString " " split ;
+: has-gl-extensions? ( extensions -- ? )
+ gl-extensions swap [ over member? ] all? nip ;
+: (make-gl-extensions-error) ( required-extensions -- )
+ gl-extensions diff
+ "Required OpenGL extensions not supported:\n" %
+ [ " " % % "\n" % ] each ;
+: require-gl-extensions ( extensions -- )
+ [ has-gl-extensions? ]
+ [ (make-gl-extensions-error) ]
+ (require-gl) ;
+
+: version-seq ( version-string -- version-seq )
+ "." split [ string>number ] map ;
+
+: version-before? ( version1 version2 -- ? )
+ swap version-seq swap version-seq before=? ;
+
+: (gl-version) ( -- version vendor )
+ GL_VERSION glGetString " " split1 ;
+: gl-version ( -- version )
+ (gl-version) drop ;
+: gl-vendor-version ( -- version )
+ (gl-version) nip ;
+: has-gl-version? ( version -- ? )
+ gl-version version-before? ;
+: (make-gl-version-error) ( required-version -- )
+ "Required OpenGL version " % % " not supported (" % gl-version % " available)" % ;
+: require-gl-version ( version -- )
+ [ has-gl-version? ]
+ [ (make-gl-version-error) ]
+ (require-gl) ;
+
+: (glsl-version) ( -- version vendor )
+ GL_SHADING_LANGUAGE_VERSION glGetString " " split1 ;
+: glsl-version ( -- version )
+ (glsl-version) drop ;
+: glsl-vendor-version ( -- version )
+ (glsl-version) nip ;
+: has-glsl-version? ( version -- ? )
+ glsl-version version-before? ;
+: require-glsl-version ( version -- )
+ [ has-glsl-version? ]
+ [ "Required GLSL version " % % " not supported (" % glsl-version % " available)" % ]
+ (require-gl) ;
+
+: has-gl-version-or-extensions? ( version extensions -- ? )
+ has-gl-extensions? swap has-gl-version? or ;
+
+: require-gl-version-or-extensions ( version extensions -- )
+ 2array [ first2 has-gl-version-or-extensions? ] [
+ dup first (make-gl-version-error) "\n" %
+ second (make-gl-extensions-error) "\n" %
+ ] (require-gl) ;
--- /dev/null
+Testing for OpenGL versions and extensions
\ No newline at end of file
--- /dev/null
+opengl
+bindings
--- /dev/null
+Joe Groff
\ No newline at end of file
--- /dev/null
+USING: help.markup help.syntax io kernel math quotations
+opengl.gl multiline assocs ;
+IN: opengl.framebuffers
+
+HELP: gen-framebuffer
+{ $values { "id" integer } }
+{ $description "Wrapper for " { $link glGenFramebuffersEXT } " to handle the common case of generating a single framebuffer ID." } ;
+
+HELP: gen-renderbuffer
+{ $values { "id" integer } }
+{ $description "Wrapper for " { $link glGenRenderbuffersEXT } " to handle the common case of generating a single render buffer ID." } ;
+
+HELP: delete-framebuffer
+{ $values { "id" integer } }
+{ $description "Wrapper for " { $link glDeleteFramebuffersEXT } " to handle the common case of deleting a single framebuffer ID." } ;
+
+HELP: delete-renderbuffer
+{ $values { "id" integer } }
+{ $description "Wrapper for " { $link glDeleteRenderbuffersEXT } " to handle the common case of deleting a single render buffer ID." } ;
+
+{ gen-framebuffer delete-framebuffer } related-words
+{ gen-renderbuffer delete-renderbuffer } related-words
+
+HELP: framebuffer-incomplete?
+{ $values { "status/f" "The framebuffer error code, or " { $snippet "f" } " if the framebuffer is render-complete." } }
+{ $description "Checks the framebuffer currently bound by " { $link glBindFramebufferEXT } " or " { $link with-framebuffer } " to see if it is incomplete, i.e., it is not ready to be rendered to." } ;
+
+HELP: check-framebuffer
+{ $description "Checks the framebuffer currently bound by " { $link glBindFramebufferEXT } " or " { $link with-framebuffer } " with " { $link framebuffer-incomplete? } ", and throws a descriptive error if the framebuffer is incomplete." } ;
+
+HELP: with-framebuffer
+{ $values { "id" "The id of a framebuffer object." } { "quot" "a quotation" } }
+{ $description "Binds framebuffer " { $snippet "id" } " in the dynamic extent of " { $snippet "quot" } ", restoring the window framebuffer when finished." } ;
+
+ABOUT: "gl-utilities"
\ No newline at end of file
--- /dev/null
+! Copyright (C) 2008 Joe Groff.
+! See http://factorcode.org/license.txt for BSD license.
+USING: opengl opengl.gl combinators continuations kernel
+alien.c-types ;
+IN: opengl.framebuffers
+
+: gen-framebuffer ( -- id )
+ [ glGenFramebuffersEXT ] (gen-gl-object) ;
+: gen-renderbuffer ( -- id )
+ [ glGenRenderbuffersEXT ] (gen-gl-object) ;
+
+: delete-framebuffer ( id -- )
+ [ glDeleteFramebuffersEXT ] (delete-gl-object) ;
+: delete-renderbuffer ( id -- )
+ [ glDeleteRenderbuffersEXT ] (delete-gl-object) ;
+
+: framebuffer-incomplete? ( -- status/f )
+ GL_FRAMEBUFFER_EXT glCheckFramebufferStatusEXT
+ dup GL_FRAMEBUFFER_COMPLETE_EXT = f rot ? ;
+
+: framebuffer-error ( status -- * )
+ {
+ { GL_FRAMEBUFFER_COMPLETE_EXT [ "framebuffer complete" ] }
+ { GL_FRAMEBUFFER_UNSUPPORTED_EXT [ "framebuffer configuration unsupported" ] }
+ { GL_FRAMEBUFFER_INCOMPLETE_ATTACHMENT_EXT [ "framebuffer incomplete (incomplete attachment)" ] }
+ { GL_FRAMEBUFFER_INCOMPLETE_MISSING_ATTACHMENT_EXT [ "framebuffer incomplete (missing attachment)" ] }
+ { GL_FRAMEBUFFER_INCOMPLETE_DIMENSIONS_EXT [ "framebuffer incomplete (dimension mismatch)" ] }
+ { GL_FRAMEBUFFER_INCOMPLETE_FORMATS_EXT [ "framebuffer incomplete (format mismatch)" ] }
+ { GL_FRAMEBUFFER_INCOMPLETE_DRAW_BUFFER_EXT [ "framebuffer incomplete (draw buffer(s) have no attachment)" ] }
+ { GL_FRAMEBUFFER_INCOMPLETE_READ_BUFFER_EXT [ "framebuffer incomplete (read buffer has no attachment)" ] }
+ [ drop gl-error "unknown framebuffer error" ]
+ } case throw ;
+
+: check-framebuffer ( -- )
+ framebuffer-incomplete? [ framebuffer-error ] when* ;
+
+: with-framebuffer ( id quot -- )
+ GL_FRAMEBUFFER_EXT rot glBindFramebufferEXT
+ [ GL_FRAMEBUFFER_EXT 0 glBindFramebufferEXT ] [ ] cleanup ; inline
+
+: framebuffer-attachment ( attachment -- id )
+ GL_FRAMEBUFFER_EXT swap GL_FRAMEBUFFER_ATTACHMENT_OBJECT_NAME_EXT
+ 0 <uint> [ glGetFramebufferAttachmentParameterivEXT ] keep *uint ;
--- /dev/null
+Rendering to offscreen textures using the GL_EXT_framebuffer_object extension
\ No newline at end of file
--- /dev/null
+opengl
+bindings
--- /dev/null
+Joe Groff
\ No newline at end of file
--- /dev/null
+USING: help.markup help.syntax io kernel math quotations
+opengl.gl multiline assocs strings ;
+IN: opengl.shaders
+
+HELP: gl-shader
+{ $class-description { $snippet "gl-shader" } " is a predicate class comprising values returned by OpenGL to represent shader objects. The following words are provided for creating and manipulating these objects:"
+ { $list
+ { { $link <gl-shader> } " - Compile GLSL code into a shader object" }
+ { { $link gl-shader-ok? } " - Check whether a shader object compiled successfully" }
+ { { $link check-gl-shader } " - Throw an error unless a shader object compiled successfully" }
+ { { $link gl-shader-info-log } " - Retrieve the info log of messages generated by the GLSL compiler" }
+ { { $link delete-gl-shader } " - Invalidate a shader object" }
+ }
+ "The derived predicate classes " { $link vertex-shader } " and " { $link fragment-shader } " are also defined for the two standard kinds of shader defined by the OpenGL specification." } ;
+
+HELP: vertex-shader
+{ $class-description { $snippet "vertex-shader" } " is the predicate class of " { $link gl-shader } " objects that refer to shaders of type " { $snippet "GL_VERTEX_SHADER" } ". In addition to the " { $snippet "gl-shader" } " words, the following vertex shader-specific functions are defined:"
+ { $list
+ { { $link <vertex-shader> } " - Compile GLSL code into a vertex shader object "}
+ }
+} ;
+
+HELP: fragment-shader
+{ $class-description { $snippet "fragment-shader" } " is the predicate class of " { $link gl-shader } " objects that refer to shaders of type " { $snippet "GL_FRAGMENT_SHADER" } ". In addition to the " { $snippet "gl-shader" } " words, the following fragment shader-specific functions are defined:"
+ { $list
+ { { $link <fragment-shader> } " - Compile GLSL code into a fragment shader object "}
+ }
+} ;
+
+HELP: <gl-shader>
+{ $values { "source" "The GLSL source code to compile" } { "kind" "The kind of shader to compile, such as " { $snippet "GL_VERTEX_SHADER" } " or " { $snippet "GL_FRAGMENT_SHADER" } } { "shader" "a new " { $link gl-shader } } }
+{ $description "Tries to compile the given GLSL source into a shader object. The returned object can be checked for validity by " { $link check-gl-shader } " or " { $link gl-shader-ok? } ". Errors and warnings generated by the GLSL compiler will be collected in the info log, available from " { $link gl-shader-info-log } ".\n\nWhen the shader object is no longer needed, it should be deleted using " { $link delete-gl-shader } " or else be attached to a " { $link gl-program } " object deleted using " { $link delete-gl-program } "." } ;
+
+HELP: <vertex-shader>
+{ $values { "source" "The GLSL source code to compile" } { "vertex-shader" "a new " { $link vertex-shader } } }
+{ $description "Tries to compile the given GLSL source into a vertex shader object. Equivalent to " { $snippet "GL_VERTEX_SHADER <gl-shader>" } "." } ;
+
+HELP: <fragment-shader>
+{ $values { "source" "The GLSL source code to compile" } { "fragment-shader" "a new " { $link fragment-shader } } }
+{ $description "Tries to compile the given GLSL source into a fragment shader object. Equivalent to " { $snippet "GL_FRAGMENT_SHADER <gl-shader>" } "." } ;
+
+HELP: gl-shader-ok?
+{ $values { "shader" "A " { $link gl-shader } " object" } { "?" "a boolean" } }
+{ $description "Returns a boolean value indicating whether the given shader object compiled successfully. Compilation errors and warnings are available in the shader's info log, which can be gotten using " { $link gl-shader-info-log } "." } ;
+
+HELP: check-gl-shader
+{ $values { "shader" "A " { $link gl-shader } " object" } }
+{ $description "Throws an error containing the " { $link gl-shader-info-log } " for the shader object if it failed to compile. Otherwise, the shader object is left on the stack." } ;
+
+HELP: delete-gl-shader
+{ $values { "shader" "A " { $link gl-shader } " object" } }
+{ $description "Deletes the shader object, invalidating it and releasing any resources allocated for it by the OpenGL implementation." } ;
+
+HELP: gl-shader-info-log
+{ $values { "shader" "A " { $link gl-shader } " object" } { "shader" "a new " { $link gl-shader } } { "log" string } }
+{ $description "Retrieves the info log for " { $snippet "shader" } ", including any errors or warnings generated in compiling the shader object." } ;
+
+HELP: gl-program
+{ $class-description { $snippet "gl-program" } " is a predicate class comprising values returned by OpenGL to represent proram objects. The following words are provided for creating and manipulating these objects:"
+ { $list
+ { { $link <gl-program> } ", " { $link <simple-gl-program> } " - Link a set of shaders into a GLSL program" }
+ { { $link gl-program-ok? } " - Check whether a program object linked successfully" }
+ { { $link check-gl-program } " - Throw an error unless a program object linked successfully" }
+ { { $link gl-program-info-log } " - Retrieve the info log of messages generated by the GLSL linker" }
+ { { $link gl-program-shaders } " - Retrieve the set of shader objects composing the GLSL program" }
+ { { $link delete-gl-program } " - Invalidate a program object and all its attached shaders" }
+ { { $link with-gl-program } " - Use a program object" }
+ }
+} ;
+
+HELP: <gl-program>
+{ $values { "shaders" "A sequence of " { $link gl-shader } " objects." } { "program" "a new " { $link gl-program } } }
+{ $description "Creates a new GLSL program object, attaches all the shader objects in the " { $snippet "shaders" } " sequence, and attempts to link them. The returned object can be checked for validity by " { $link check-gl-program } " or " { $link gl-program-ok? } ". Errors and warnings generated by the GLSL linker will be collected in the info log, available from " { $link gl-program-info-log } ".\n\nWhen the program object and its attached shaders are no longer needed, it should be deleted using " { $link delete-gl-program } "." } ;
+
+HELP: <simple-gl-program>
+{ $values { "vertex-shader-source" "A string containing GLSL vertex shader source" } { "fragment-shader-source" "A string containing GLSL fragment shader source" } { "program" "a new " { $link gl-program } } }
+{ $description "Wrapper for " { $link <gl-program> } " for the simple case of compiling a single vertex shader and fragment shader and linking them into a GLSL program. Throws an exception if compiling or linking fails." } ;
+
+{ <gl-program> <simple-gl-program> } related-words
+
+HELP: gl-program-ok?
+{ $values { "program" "A " { $link gl-program } " object" } { "?" "a boolean" } }
+{ $description "Returns a boolean value indicating whether the given program object linked successfully. Link errors and warnings are available in the program's info log, which can be gotten using " { $link gl-program-info-log } "." } ;
+
+HELP: check-gl-program
+{ $values { "program" "A " { $link gl-program } " object" } }
+{ $description "Throws an error containing the " { $link gl-program-info-log } " for the program object if it failed to link. Otherwise, the program object is left on the stack." } ;
+
+HELP: gl-program-info-log
+{ $values { "program" "A " { $link gl-program } " object" } { "log" string } }
+{ $description "Retrieves the info log for " { $snippet "program" } ", including any errors or warnings generated in linking the program object." } ;
+
+HELP: delete-gl-program
+{ $values { "program" "A " { $link gl-program } " object" } }
+{ $description "Deletes the program object, invalidating it and releasing any resources allocated for it by the OpenGL implementation. Any attached " { $link gl-shader } "s are also deleted.\n\nIf the shader objects should be preserved, they should each be detached using " { $link detach-gl-program-shader } ". The program object can then be destroyed alone using " { $link delete-gl-program-only } "." } ;
+
+HELP: with-gl-program
+{ $values { "program" "A " { $link gl-program } " object" } { "quot" "A quotation with stack effect " { $snippet "( program -- )" } } }
+{ $description "Enables " { $snippet "program" } " for all OpenGL calls made in the dynamic extent of " { $snippet "quot" } ". " { $snippet "program" } " is left on the top of the stack when " { $snippet "quot" } " is called. The fixed-function pipeline is restored at the end of " { $snippet "quot" } "." } ;
+
+ABOUT: "gl-utilities"
--- /dev/null
+! Copyright (C) 2008 Joe Groff.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel opengl.gl alien.c-types continuations namespaces
+assocs alien alien.strings libc opengl math sequences combinators
+macros arrays io.encodings.ascii fry specialized-arrays.uint
+destructors accessors ;
+IN: opengl.shaders
+
+: with-gl-shader-source-ptr ( string quot -- )
+ swap ascii malloc-string [ <void*> swap call ] keep free ; inline
+
+: <gl-shader> ( source kind -- shader )
+ glCreateShader dup rot
+ [ 1 swap f glShaderSource ] with-gl-shader-source-ptr
+ [ glCompileShader ] keep
+ gl-error ;
+
+: (gl-shader?) ( object -- ? )
+ dup integer? [ glIsShader c-bool> ] [ drop f ] if ;
+
+: gl-shader-get-int ( shader enum -- value )
+ 0 <int> [ glGetShaderiv ] keep *int ;
+
+: gl-shader-ok? ( shader -- ? )
+ GL_COMPILE_STATUS gl-shader-get-int c-bool> ;
+
+: <vertex-shader> ( source -- vertex-shader )
+ GL_VERTEX_SHADER <gl-shader> ; inline
+
+: (vertex-shader?) ( object -- ? )
+ dup (gl-shader?)
+ [ GL_SHADER_TYPE gl-shader-get-int GL_VERTEX_SHADER = ]
+ [ drop f ] if ;
+
+: <fragment-shader> ( source -- fragment-shader )
+ GL_FRAGMENT_SHADER <gl-shader> ; inline
+
+: (fragment-shader?) ( object -- ? )
+ dup (gl-shader?)
+ [ GL_SHADER_TYPE gl-shader-get-int GL_FRAGMENT_SHADER = ]
+ [ drop f ] if ;
+
+: gl-shader-info-log-length ( shader -- log-length )
+ GL_INFO_LOG_LENGTH gl-shader-get-int ; inline
+
+: gl-shader-info-log ( shader -- log )
+ dup gl-shader-info-log-length dup [
+ 1 calloc &free
+ [ 0 <int> swap glGetShaderInfoLog ] keep
+ ascii alien>string
+ ] with-destructors ;
+
+: check-gl-shader ( shader -- shader )
+ dup gl-shader-ok? [ dup gl-shader-info-log throw ] unless ;
+
+: delete-gl-shader ( shader -- ) glDeleteShader ; inline
+
+PREDICATE: gl-shader < integer (gl-shader?) ;
+PREDICATE: vertex-shader < gl-shader (vertex-shader?) ;
+PREDICATE: fragment-shader < gl-shader (fragment-shader?) ;
+
+! Programs
+
+: <gl-program> ( shaders -- program )
+ glCreateProgram swap
+ [ dupd glAttachShader ] each
+ [ glLinkProgram ] keep
+ gl-error ;
+
+: (gl-program?) ( object -- ? )
+ dup integer? [ glIsProgram c-bool> ] [ drop f ] if ;
+
+: gl-program-get-int ( program enum -- value )
+ 0 <int> [ glGetProgramiv ] keep *int ;
+
+: gl-program-ok? ( program -- ? )
+ GL_LINK_STATUS gl-program-get-int c-bool> ;
+
+: gl-program-info-log-length ( program -- log-length )
+ GL_INFO_LOG_LENGTH gl-program-get-int ; inline
+
+: gl-program-info-log ( program -- log )
+ dup gl-program-info-log-length dup [
+ 1 calloc &free
+ [ 0 <int> swap glGetProgramInfoLog ] keep
+ ascii alien>string
+ ] with-destructors ;
+
+: check-gl-program ( program -- program )
+ dup gl-program-ok? [ dup gl-program-info-log throw ] unless ;
+
+: gl-program-shaders-length ( program -- shaders-length )
+ GL_ATTACHED_SHADERS gl-program-get-int ; inline
+
+: gl-program-shaders ( program -- shaders )
+ dup gl-program-shaders-length
+ 0 <int>
+ over <uint-array>
+ [ underlying>> glGetAttachedShaders ] keep ;
+
+: delete-gl-program-only ( program -- )
+ glDeleteProgram ; inline
+
+: detach-gl-program-shader ( program shader -- )
+ glDetachShader ; inline
+
+: delete-gl-program ( program -- )
+ dup gl-program-shaders [
+ 2dup detach-gl-program-shader delete-gl-shader
+ ] each delete-gl-program-only ;
+
+: with-gl-program ( program quot -- )
+ over glUseProgram [ 0 glUseProgram ] [ ] cleanup ; inline
+
+PREDICATE: gl-program < integer (gl-program?) ;
+
+: <simple-gl-program> ( vertex-shader-source fragment-shader-source -- program )
+ >r <vertex-shader> check-gl-shader
+ r> <fragment-shader> check-gl-shader
+ 2array <gl-program> check-gl-program ;
+
--- /dev/null
+OpenGL Shading Language (GLSL) support
\ No newline at end of file
--- /dev/null
+opengl
+bindings
\ No newline at end of file
! Quotation which coerces return value to required type
return-prep-quot infer-quot-here ;
-! Callbacks are registered in a global hashtable. If you clear
-! this hashtable, they will all be blown away by code GC, beware
-SYMBOL: callbacks
-
-[ H{ } clone callbacks set-global ] "alien.compiler" add-init-hook
-
: register-callback ( word -- ) callbacks get conjoin ;
: callback-bottom ( params -- )
"tools.deploy.test.8" shake-and-bake\r
run-temp-image\r
] unit-test\r
+\r
+[ ] [\r
+ "tools.deploy.test.9" shake-and-bake\r
+ run-temp-image\r
+] unit-test\r
init-hooks get values concat %
,
strip-io? [ \ flush , ] unless
+ [ 0 exit ] %
] [ ] make
set-boot-quot ;
[ [ 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
USING: tools.deploy.config ;
H{
- { deploy-threads? t }
- { deploy-c-types? f }
+ { deploy-unicode? f }
+ { deploy-name "tools.deploy.test.3" }
{ deploy-ui? f }
- { deploy-word-props? f }
+ { "stop-after-last-window?" t }
{ deploy-word-defs? f }
- { deploy-math? t }
- { deploy-io 3 }
- { deploy-name "tools.deploy.test.3" }
- { deploy-compiler? t }
{ deploy-reflection 1 }
- { "stop-after-last-window?" t }
+ { deploy-compiler? t }
+ { deploy-threads? t }
+ { deploy-io 3 }
+ { deploy-math? t }
+ { deploy-word-props? f }
+ { deploy-c-types? f }
}
--- /dev/null
+USING: alien kernel math ;
+IN: tools.deploy.test.9
+
+: callback-test ( -- callback )
+ "int" { "int" } "cdecl" [ 1 + ] alien-callback ;
+
+: indirect-test ( -- )
+ 10 callback-test "int" { "int" } "cdecl" alien-indirect 11 assert= ;
+
+MAIN: indirect-test
--- /dev/null
+USING: tools.deploy.config ;
+H{
+ { deploy-unicode? f }
+ { deploy-name "tools.deploy.test.9" }
+ { deploy-ui? f }
+ { "stop-after-last-window?" t }
+ { deploy-word-defs? f }
+ { deploy-reflection 1 }
+ { deploy-compiler? t }
+ { deploy-threads? f }
+ { deploy-io 1 }
+ { deploy-math? t }
+ { deploy-word-props? f }
+ { deploy-c-types? f }
+}
\r
HELP: disassemble\r
{ $values { "obj" "a word or a pair of addresses" } }\r
-{ $description "Disassembles either a compiled word definition or an arbitrary memory range (in the case " { $snippet "obj" } " is a pair of integers) by attaching " { $snippet "gdb" } " to the Factor VM and capturing the output." }\r
-{ $notes "In some cases the Factor compiler emits data inline with code, which can confuse " { $snippet "gdb" } ". This occurs in words which call " { $link dispatch } ", where the jump table addresses are compiled inline. Also on the ARM architecture, various pointers are often compiled inline, and the preceeding instruction jumps over the inline pinter." } ;\r
+{ $description "Disassembles either a compiled word definition or an arbitrary memory range (in the case " { $snippet "obj" } " is a pair of integers)." }\r
+{ $notes "In some cases the Factor compiler emits data inline with code, which can confuse the disassembler. This occurs in words which call " { $link dispatch } ", where the jump table addresses are compiled inline." } ;\r
\r
ARTICLE: "tools.disassembler" "Disassembling words"\r
-"The " { $vocab-link "tools.disassembler" } " vocabulary integrates Factor with the GNU debugger (" { $snippet "gdb" } ") for viewing the assembly code generated by the compiler. It can be used on both Unix and Windows as long as a working copy of " { $snippet "gdb" } " is installed and available in the " { $snippet "PATH" } "."\r
+"The " { $vocab-link "tools.disassembler" } " vocabulary provides support for disassembling compiled word definitions. It uses the " { $snippet "libudis86" } " library on x86-32 and x86-64, and " { $snippet "gdb" } " on PowerPC."\r
{ $subsection disassemble } ;\r
\r
ABOUT: "tools.disassembler"\r
-! Copyright (C) 2008 Slava Pestov, Jorge Acereda Macia.
+! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: io.files io words alien kernel math.parser alien.syntax
-io.launcher system assocs arrays sequences namespaces make
-qualified system math compiler.codegen.fixup
-io.encodings.ascii accessors generic tr ;
+USING: tr arrays sequences io words generic system combinators
+vocabs.loader kernel ;
IN: tools.disassembler
-: in-file ( -- path ) "gdb-in.txt" temp-file ;
+GENERIC: disassemble ( obj -- )
-: out-file ( -- path ) "gdb-out.txt" temp-file ;
+SYMBOL: disassembler-backend
-GENERIC: make-disassemble-cmd ( obj -- )
+HOOK: disassemble* disassembler-backend ( from to -- lines )
-M: word make-disassemble-cmd
- word-xt code-format - 2array make-disassemble-cmd ;
-
-M: pair make-disassemble-cmd
- in-file ascii [
- "attach " write
- current-process-handle number>string print
- "disassemble " write
- [ number>string write bl ] each
- ] with-file-writer ;
-
-M: method-spec make-disassemble-cmd
- first2 method make-disassemble-cmd ;
+TR: tabs>spaces "\t" "\s" ;
-: gdb-binary ( -- string ) "gdb" ;
+M: pair disassemble first2 disassemble* [ tabs>spaces print ] each ;
-: run-gdb ( -- lines )
- <process>
- +closed+ >>stdin
- out-file >>stdout
- [ gdb-binary , "-x" , in-file , "-batch" , ] { } make >>command
- try-process
- out-file ascii file-lines ;
+M: word disassemble word-xt 2array disassemble ;
-TR: tabs>spaces "\t" "\s" ;
+M: method-spec disassemble first2 method disassemble ;
-: disassemble ( obj -- )
- make-disassemble-cmd run-gdb
- [ tabs>spaces ] map [ print ] each ;
+cpu x86? os unix? and
+"tools.disassembler.udis"
+"tools.disassembler.gdb" ?
+require
--- /dev/null
+! Copyright (C) 2008 Slava Pestov, Jorge Acereda Macia.
+! See http://factorcode.org/license.txt for BSD license.
+USING: io.files io words alien kernel math.parser alien.syntax
+io.launcher system assocs arrays sequences namespaces make
+qualified system math io.encodings.ascii accessors
+tools.disassembler ;
+IN: tools.disassembler.gdb
+
+SINGLETON: gdb-disassembler
+
+: in-file ( -- path ) "gdb-in.txt" temp-file ;
+
+: out-file ( -- path ) "gdb-out.txt" temp-file ;
+
+: make-disassemble-cmd ( from to -- )
+ in-file ascii [
+ "attach " write
+ current-process-handle number>string print
+ "disassemble " write
+ [ number>string write bl ] bi@
+ ] with-file-writer ;
+
+: gdb-binary ( -- string ) "gdb" ;
+
+: run-gdb ( -- lines )
+ <process>
+ +closed+ >>stdin
+ out-file >>stdout
+ [ gdb-binary , "-x" , in-file , "-batch" , ] { } make >>command
+ try-process
+ out-file ascii file-lines ;
+
+M: gdb-disassembler disassemble*
+ make-disassemble-cmd run-gdb ;
+
+gdb-disassembler disassembler-backend set-global
--- /dev/null
+unportable
--- /dev/null
+unportable
--- /dev/null
+! Copyright (C) 2008 Slava Pestov, Jorge Acereda Macia.
+! See http://factorcode.org/license.txt for BSD license.
+USING: tools.disassembler namespaces combinators
+alien alien.syntax alien.c-types lexer parser kernel
+sequences layouts math math.parser system make fry arrays ;
+IN: tools.disassembler.udis
+
+<<
+"libudis86" {
+ { [ os macosx? ] [ "libudis86.0.dylib" ] }
+ { [ os unix? ] [ "libudis86.so.0" ] }
+ { [ os winnt? ] [ "libudis86.dll" ] }
+} cond "cdecl" add-library
+>>
+
+LIBRARY: libudis86
+
+TYPEDEF: char[592] ud
+
+FUNCTION: void ud_translate_intel ( ud* u ) ;
+FUNCTION: void ud_translate_att ( ud* u ) ;
+
+: UD_SYN_INTEL &: ud_translate_intel ; inline
+: UD_SYN_ATT &: ud_translate_att ; inline
+: UD_EOI -1 ; inline
+: UD_INP_CACHE_SZ 32 ; inline
+: UD_VENDOR_AMD 0 ; inline
+: UD_VENDOR_INTEL 1 ; inline
+
+FUNCTION: void ud_init ( ud* u ) ;
+FUNCTION: void ud_set_mode ( ud* u, uint8_t mode ) ;
+FUNCTION: void ud_set_pc ( ud* u, ulonglong pc ) ;
+FUNCTION: void ud_set_input_buffer ( ud* u, uint8_t* offset, size_t size ) ;
+FUNCTION: void ud_set_vendor ( ud* u, uint vendor ) ;
+FUNCTION: void ud_set_syntax ( ud* u, void* syntax ) ;
+FUNCTION: void ud_input_skip ( ud* u, size_t size ) ;
+FUNCTION: int ud_input_end ( ud* u ) ;
+FUNCTION: uint ud_decode ( ud* u ) ;
+FUNCTION: uint ud_disassemble ( ud* u ) ;
+FUNCTION: char* ud_insn_asm ( ud* u ) ;
+FUNCTION: void* ud_insn_ptr ( ud* u ) ;
+FUNCTION: ulonglong ud_insn_off ( ud* u ) ;
+FUNCTION: char* ud_insn_hex ( ud* u ) ;
+FUNCTION: uint ud_insn_len ( ud* u ) ;
+FUNCTION: char* ud_lookup_mnemonic ( int c ) ;
+
+: <ud> ( -- ud )
+ "ud" <c-object>
+ dup ud_init
+ dup cell-bits ud_set_mode
+ dup UD_SYN_INTEL ud_set_syntax ;
+
+SINGLETON: udis-disassembler
+
+: buf/len ( from to -- buf len ) [ drop <alien> ] [ swap - ] 2bi ;
+
+: format-disassembly ( lines -- lines' )
+ dup [ second length ] map supremum
+ '[
+ [
+ [ first >hex cell 2 * CHAR: 0 pad-left % ": " % ]
+ [ second _ CHAR: \s pad-right % " " % ]
+ [ third % ]
+ tri
+ ] "" make
+ ] map ;
+
+: (disassemble) ( ud -- lines )
+ [
+ dup '[
+ _ ud_disassemble 0 =
+ [ f ] [
+ _
+ [ ud_insn_off ]
+ [ ud_insn_hex ]
+ [ ud_insn_asm ]
+ tri 3array , t
+ ] if
+ ] loop
+ ] { } make ;
+
+M: udis-disassembler disassemble* ( from to -- buffer )
+ [ <ud> ] 2dip {
+ [ drop ud_set_pc ]
+ [ buf/len ud_set_input_buffer ]
+ [ 2drop (disassemble) format-disassembly ]
+ } 3cleave ;
+
+udis-disassembler disassembler-backend set-global
SYMBOL: ui-backend
-HOOK: do-events ui-backend ( -- )
-
HOOK: set-title ui-backend ( string world -- )
HOOK: set-fullscreen* ui-backend ( ? world -- )
HOOK: (close-window) ui-backend ( handle -- )
+HOOK: (open-offscreen-buffer) ui-backend ( world -- )
+
+HOOK: (close-offscreen-buffer) ui-backend ( handle -- )
+
HOOK: raise-window* ui-backend ( world -- )
-HOOK: select-gl-context ui-backend ( handle -- )
+GENERIC: select-gl-context ( handle -- )
+
+GENERIC: flush-gl-context ( handle -- )
-HOOK: flush-gl-context ui-backend ( handle -- )
+HOOK: offscreen-pixels ui-backend ( world -- alien w h )
HOOK: beep ui-backend ( -- )
USING: accessors math arrays assocs cocoa cocoa.application
command-line kernel memory namespaces cocoa.messages
cocoa.runtime cocoa.subclassing cocoa.pasteboard cocoa.types
-cocoa.windows cocoa.classes cocoa.application cocoa.nibs
-sequences system ui ui.backend ui.clipboards ui.gadgets
-ui.gadgets.worlds ui.cocoa.views core-foundation threads
-math.geometry.rect fry ;
+cocoa.windows cocoa.classes cocoa.nibs sequences system ui
+ui.backend ui.clipboards ui.gadgets ui.gadgets.worlds
+ui.cocoa.views core-foundation core-foundation.run-loop threads
+math.geometry.rect fry libc generalizations alien.c-types
+cocoa.views combinators io.thread ;
IN: ui.cocoa
-TUPLE: handle view window ;
+TUPLE: handle ;
+TUPLE: window-handle < handle view window ;
+TUPLE: offscreen-handle < handle context buffer ;
-C: <handle> handle
+C: <window-handle> window-handle
+C: <offscreen-handle> offscreen-handle
SINGLETON: cocoa-ui-backend
-M: cocoa-ui-backend do-events ( -- )
- [ NSApp '[ _ do-event ] loop ui-wait ] with-autorelease-pool ;
-
TUPLE: pasteboard handle ;
C: <pasteboard> pasteboard
: gadget-window ( world -- )
dup <FactorView>
2dup swap world>NSRect <ViewWindow>
- [ [ -> release ] [ install-window-delegate ] bi* ] [ <handle> ] 2bi
+ [ [ -> release ] [ install-window-delegate ] bi* ]
+ [ <window-handle> ] 2bi
>>handle drop ;
M: cocoa-ui-backend set-title ( string world -- )
NSApp 1 -> activateIgnoringOtherApps:
] when* ;
-M: cocoa-ui-backend select-gl-context ( handle -- )
- view>> -> openGLContext -> makeCurrentContext ;
+: pixel-size ( pixel-format -- size )
+ 0 <int> [ NSOpenGLPFAColorSize 0 -> getValues:forAttribute:forVirtualScreen: ]
+ keep *int -3 shift ;
+
+: offscreen-buffer ( world pixel-format -- alien w h pitch )
+ [ dim>> first2 ] [ pixel-size ] bi*
+ { [ * * malloc ] [ 2drop ] [ drop nip ] [ nip * ] } 3cleave ;
+
+: gadget-offscreen-context ( world -- context buffer )
+ NSOpenGLPFAOffScreen 1array <PixelFormat>
+ [ nip NSOpenGLContext -> alloc swap f -> initWithFormat:shareContext: dup ]
+ [ offscreen-buffer ] 2bi
+ 4 npick [ -> setOffScreen:width:height:rowbytes: ] dip ;
+
+M: cocoa-ui-backend (open-offscreen-buffer) ( world -- )
+ dup gadget-offscreen-context <offscreen-handle> >>handle drop ;
+
+M: cocoa-ui-backend (close-offscreen-buffer) ( handle -- )
+ [ context>> -> release ]
+ [ buffer>> free ] bi ;
+
+GENERIC: (gl-context) ( handle -- context )
+M: window-handle (gl-context) view>> -> openGLContext ;
+M: offscreen-handle (gl-context) context>> ;
+
+M: handle select-gl-context ( handle -- )
+ (gl-context) -> makeCurrentContext ;
+
+M: handle flush-gl-context ( handle -- )
+ (gl-context) -> flushBuffer ;
-M: cocoa-ui-backend flush-gl-context ( handle -- )
- view>> -> openGLContext -> flushBuffer ;
+M: cocoa-ui-backend offscreen-pixels ( world -- alien w h )
+ [ handle>> buffer>> ] [ dim>> first2 neg ] bi ;
M: cocoa-ui-backend beep ( -- )
NSBeep ;
{ +name+ "FactorApplicationDelegate" }
}
-{ "applicationDidFinishLaunching:" "void" { "id" "SEL" "id" }
- [ 3drop event-loop ]
+{ "applicationDidUpdate:" "void" { "id" "SEL" "id" }
+ [ 3drop reset-run-loop ]
} ;
: install-app-delegate ( -- )
init-clipboard
cocoa-init-hook get call
start-ui
+ f io-thread-running? set-global
+ init-thread-timer
+ reset-run-loop
NSApp -> run
] ui-running
] with-cocoa ;
-! Copyright (C) 2006, 2007 Slava Pestov.
+! Copyright (C) 2006, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: alien.syntax cocoa cocoa.nibs cocoa.application
cocoa.classes cocoa.dialogs cocoa.pasteboard cocoa.subclassing
-core-foundation help.topics kernel memory namespaces parser
-system ui ui.tools.browser ui.tools.listener ui.tools.workspace
-ui.cocoa eval locals ;
+core-foundation core-foundation.strings help.topics kernel
+memory namespaces parser system ui ui.tools.browser
+ui.tools.listener ui.tools.workspace ui.cocoa eval locals ;
IN: ui.cocoa.tools
: finder-run-files ( alien -- )
math cocoa.messages cocoa.subclassing cocoa.classes cocoa.views
cocoa.application cocoa.pasteboard cocoa.types cocoa.windows
sequences ui ui.gadgets ui.gadgets.worlds ui.gestures
-core-foundation threads combinators math.geometry.rect ;
+core-foundation.strings threads combinators math.geometry.rect ;
IN: ui.cocoa.views
: send-mouse-moved ( view event -- )
--- /dev/null
+IN: ui.event-loop.tests
+USING: ui.event-loop tools.test ;
+
+\ event-loop must-infer
--- /dev/null
+! 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 ;
help.syntax models opengl strings ;
IN: ui.gadgets.worlds
+HELP: user-input
+{ $values { "string" string } { "world" world } }
+{ $description "Calls " { $link user-input* } " on every parent of the world's currently-focused child." } ;
+
HELP: origin
{ $var-description "Within the dynamic extent of " { $link draw-world } ", holds the co-ordinate system origin for the gadget currently being drawn." } ;
2dup eq?
[ 2drop ] [ dup focused?>> (request-focus) ] if ;
-: <world> ( gadget title status -- world )
- { 0 1 } world new-track
+: new-world ( gadget title status class -- world )
+ { 0 1 } swap new-track
t >>root?
t >>active?
H{ } clone >>fonts
swap 1 track-add
dup request-focus ;
+: <world> ( gadget title status -- world )
+ world new-world ;
+
M: world layout*
dup call-next-method
dup glass>> [
-USING: ui.gadgets help.markup help.syntax hashtables
-strings kernel system ;
+USING: ui.gadgets ui.gadgets.worlds help.markup help.syntax
+hashtables strings kernel system ;
IN: ui.gestures
HELP: set-gestures
{ $values { "gesture" "a gesture" } { "gadget" gadget } }
{ $description "Calls " { $link handle-gesture } " on every parent of " { $snippet "gadget" } "." } ;
-HELP: user-input
-{ $values { "string" string } { "gadget" gadget } }
-{ $description "Calls " { $link user-input* } " on every parent of the gadget." } ;
-
HELP: motion
{ $class-description "Mouse motion gesture." }
{ $examples { $code "T{ motion }" } } ;
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 ;
<pile>
bundle-name
deploy-ui
- os macosx? [ exit-when-windows-closed ] when
io-settings
reflection-settings
advanced-settings
}
"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:"
IN: ui.tests
USING: ui tools.test ;
-\ event-loop must-infer
\ open-window must-infer
! 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 ;
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
] assert-depth
] [ ui-error ] recover ;
-: ui-wait ( -- )
- 10 milliseconds sleep ;
-
SYMBOL: ui-thread
: ui-running ( quot -- )
f windows set-global
[
ui-hook set
- stop-after-last-window? on
ui
] with-scope
] if ;
! See http://factorcode.org/license.txt for BSD license.
USING: alien alien.c-types alien.strings arrays assocs ui
ui.gadgets ui.backend ui.clipboards ui.gadgets.worlds
-ui.gestures io kernel math math.vectors namespaces make
-sequences strings vectors words windows.kernel32 windows.gdi32
-windows.user32 windows.opengl32 windows.messages windows.types
-windows.nt windows threads libc combinators
+ui.gestures ui.event-loop io kernel math math.vectors namespaces
+make sequences strings vectors words windows.kernel32
+windows.gdi32 windows.user32 windows.opengl32 windows.messages
+windows.types windows.nt windows threads libc combinators fry
combinators.short-circuit continuations command-line shuffle
opengl ui.render ascii math.bitwise locals symbols accessors
-math.geometry.rect math.order ascii calendar
-io.encodings.utf16n ;
+math.geometry.rect math.order ascii calendar io.encodings.utf16n
+;
IN: ui.windows
SINGLETON: windows-ui-backend
<pasteboard> clipboard set-global
<clipboard> selection set-global ;
-! world-handle is a <win>
-TUPLE: win hWnd hDC hRC world title ;
+TUPLE: win-base hDC hRC ;
+TUPLE: win < win-base hWnd world title ;
+TUPLE: win-offscreen < win-base hBitmap bits ;
C: <win> win
+C: <win-offscreen> win-offscreen
SYMBOLS: msg-obj class-name-ptr mouse-captured ;
f class-name-ptr set-global
f msg-obj set-global ;
-: setup-pixel-format ( hdc -- )
- 16 make-pfd [ ChoosePixelFormat dup win32-error=0/f ] 2keep
+: setup-pixel-format ( hdc flags -- )
+ 32 make-pfd [ ChoosePixelFormat dup win32-error=0/f ] 2keep
swapd SetPixelFormat win32-error=0/f ;
: get-dc ( hWnd -- hDC ) GetDC dup win32-error=0/f ;
[ wglMakeCurrent win32-error=0/f ] keep ;
: setup-gl ( hwnd -- hDC hRC )
- get-dc dup setup-pixel-format dup get-rc ;
+ get-dc dup windowed-pfd-dwFlags setup-pixel-format dup get-rc ;
M: windows-ui-backend (open-window) ( world -- )
- [ create-window dup setup-gl ] keep
+ [ create-window [ setup-gl ] keep ] keep
[ f <win> ] keep
[ swap hWnd>> register-window ] 2keep
dupd (>>handle)
hWnd>> show-window ;
-M: windows-ui-backend select-gl-context ( handle -- )
- [ hDC>> ] keep hRC>> wglMakeCurrent win32-error=0/f ;
+M: win-base select-gl-context ( handle -- )
+ [ hDC>> ] keep hRC>> wglMakeCurrent win32-error=0/f
+ GdiFlush drop ;
-M: windows-ui-backend flush-gl-context ( handle -- )
+M: win-base flush-gl-context ( handle -- )
hDC>> SwapBuffers win32-error=0/f ;
-! Move window to front
+: (bitmap-info) ( dim -- BITMAPINFO )
+ "BITMAPINFO" <c-object> [
+ BITMAPINFO-bmiHeader {
+ [ nip "BITMAPINFOHEADER" heap-size swap set-BITMAPINFOHEADER-biSize ]
+ [ [ first ] dip set-BITMAPINFOHEADER-biWidth ]
+ [ [ second ] dip set-BITMAPINFOHEADER-biHeight ]
+ [ nip 1 swap set-BITMAPINFOHEADER-biPlanes ]
+ [ nip 32 swap set-BITMAPINFOHEADER-biBitCount ]
+ [ nip BI_RGB swap set-BITMAPINFOHEADER-biCompression ]
+ [ [ first2 * 4 * ] dip set-BITMAPINFOHEADER-biSizeImage ]
+ [ nip 72 swap set-BITMAPINFOHEADER-biXPelsPerMeter ]
+ [ nip 72 swap set-BITMAPINFOHEADER-biYPelsPerMeter ]
+ [ nip 0 swap set-BITMAPINFOHEADER-biClrUsed ]
+ [ nip 0 swap set-BITMAPINFOHEADER-biClrImportant ]
+ } 2cleave
+ ] keep ;
+
+: make-offscreen-dc-and-bitmap ( dim -- hDC hBitmap bits )
+ f CreateCompatibleDC
+ dup rot (bitmap-info) DIB_RGB_COLORS f <void*>
+ [ f 0 CreateDIBSection ] keep *void*
+ [ 2dup SelectObject drop ] dip ;
+
+: setup-offscreen-gl ( dim -- hDC hRC hBitmap bits )
+ make-offscreen-dc-and-bitmap [
+ [ dup offscreen-pfd-dwFlags setup-pixel-format ]
+ [ get-rc ] bi
+ ] 2dip ;
+
+M: windows-ui-backend (open-offscreen-buffer) ( world -- )
+ dup dim>> setup-offscreen-gl <win-offscreen>
+ >>handle drop ;
+M: windows-ui-backend (close-offscreen-buffer) ( handle -- )
+ [ hDC>> DeleteDC drop ]
+ [ hBitmap>> DeleteObject drop ] bi ;
+
+! Windows 32-bit bitmaps don't actually use the alpha byte of
+! each pixel; it's left as zero
+
+: (make-opaque) ( byte-array -- byte-array' )
+ [ length 4 / ]
+ [ '[ 255 swap 4 * 3 + _ set-nth ] each ]
+ [ ] tri ;
+
+: (opaque-pixels) ( world -- pixels )
+ [ handle>> bits>> ] [ dim>> first2 * 4 * ] bi
+ memory>byte-array (make-opaque) ;
+
+M: windows-ui-backend offscreen-pixels ( world -- alien w h )
+ [ (opaque-pixels) ] [ dim>> first2 ] bi ;
+
M: windows-ui-backend raise-window* ( world -- )
handle>> [
hWnd>> SetFocus drop
M: windows-ui-backend ui
[
[
- stop-after-last-window? on
init-clipboard
init-win32-ui
start-ui
! See http://factorcode.org/license.txt for BSD license.
USING: accessors alien alien.c-types arrays ui ui.gadgets
ui.gestures ui.backend ui.clipboards ui.gadgets.worlds ui.render
-assocs kernel math namespaces opengl sequences strings x11.xlib
-x11.events x11.xim x11.glx x11.clipboard x11.constants
-x11.windows io.encodings.string io.encodings.ascii
+ui.event-loop assocs kernel math namespaces opengl sequences
+strings x11.xlib x11.events x11.xim x11.glx x11.clipboard
+x11.constants x11.windows io.encodings.string io.encodings.ascii
io.encodings.utf8 combinators command-line qualified
math.vectors classes.tuple opengl.gl threads math.geometry.rect
environment ascii ;
: XA_NET_WM_NAME ( -- atom ) "_NET_WM_NAME" x-atom ;
-TUPLE: x11-handle window glx xic ;
+TUPLE: x11-handle-base glx ;
+TUPLE: x11-handle < x11-handle-base xic window ;
+TUPLE: x11-pixmap-handle < x11-handle-base pixmap glx-pixmap ;
C: <x11-handle> x11-handle
+C: <x11-pixmap-handle> x11-pixmap-handle
M: world expose-event nip relayout ;
M: world selection-notify-event
[ handle>> window>> selection-from-event ] keep
- world user-input ;
+ user-input ;
: supported-type? ( atom -- ? )
{ "UTF8_STRING" "STRING" "TEXT" }
: gadget-window ( world -- )
dup window-loc>> over rect-dim glx-window
- over "Factor" create-xic <x11-handle>
+ over "Factor" create-xic rot <x11-handle>
2dup window>> register-window
>>handle drop ;
dpy get swap window>> XRaiseWindow drop
] when* ;
-M: x11-ui-backend select-gl-context ( handle -- )
+M: x11-handle select-gl-context ( handle -- )
dpy get swap
- dup window>> swap glx>> glXMakeCurrent
+ [ window>> ] [ glx>> ] bi glXMakeCurrent
[ "Failed to set current GLX context" throw ] unless ;
-M: x11-ui-backend flush-gl-context ( handle -- )
+M: x11-handle flush-gl-context ( handle -- )
dpy get swap window>> glXSwapBuffers ;
+M: x11-pixmap-handle select-gl-context ( handle -- )
+ dpy get swap
+ [ glx-pixmap>> ] [ glx>> ] bi glXMakeCurrent
+ [ "Failed to set current GLX context" throw ] unless ;
+
+M: x11-pixmap-handle flush-gl-context ( handle -- )
+ drop ;
+
+M: x11-ui-backend (open-offscreen-buffer) ( world -- )
+ dup dim>> glx-pixmap <x11-pixmap-handle> >>handle drop ;
+M: x11-ui-backend (close-offscreen-buffer) ( handle -- )
+ dpy get swap
+ [ glx-pixmap>> glXDestroyGLXPixmap ]
+ [ pixmap>> XFreePixmap drop ]
+ [ glx>> glXDestroyContext ] 2tri ;
+
+M: x11-ui-backend offscreen-pixels ( world -- alien w h )
+ [ [ dim>> ] [ handle>> pixmap>> ] bi pixmap-bits ] [ dim>> first2 ] bi ;
+
M: x11-ui-backend ui ( -- )
[
f [
[
- stop-after-last-window? on
init-clipboard
start-ui
event-loop
HEX: 7f bitand ; inline
: WIFEXITED ( status -- ? )
- WTERMSIG zero? ; inline
+ WTERMSIG 0 = ; inline
: WEXITSTATUS ( status -- value )
HEX: ff00 bitand -8 shift ; inline
HEX: 80 ; inline
: WCOREDUMP ( status -- ? )
- WCOREFLAG bitand zero? not ; inline
+ WCOREFLAG bitand 0 = not ; inline
: WIFSTOPPED ( status -- ? )
HEX: ff bitand HEX: 7f = ; inline
: DC_BRUSH 18 ; inline
: DC_PEN 19 ; inline
+: BI_RGB 0 ; inline
+: BI_RLE8 1 ; inline
+: BI_RLE4 2 ; inline
+: BI_BITFIELDS 3 ; inline
+
+: DIB_RGB_COLORS 0 ; inline
+: DIB_PAL_COLORS 1 ; inline
+
LIBRARY: gdi32
! FUNCTION: AbortPath
! FUNCTION: CreateColorSpaceA
! FUNCTION: CreateColorSpaceW
! FUNCTION: CreateCompatibleBitmap
-! FUNCTION: CreateCompatibleDC
+FUNCTION: HDC CreateCompatibleDC ( HDC hdc ) ;
! FUNCTION: CreateDCA
! FUNCTION: CreateDCW
! FUNCTION: CreateDIBitmap
! FUNCTION: CreateDIBPatternBrush
! FUNCTION: CreateDIBPatternBrushPt
-! FUNCTION: CreateDIBSection
+FUNCTION: HBITMAP CreateDIBSection ( HDC hdc, BITMAPINFO* pbmi, UINT iUsage, void** ppvBits, HANDLE hSection, DWORD dwOffset ) ;
! FUNCTION: CreateDiscardableBitmap
! FUNCTION: CreateEllipticRgn
! FUNCTION: CreateEllipticRgnIndirect
! FUNCTION: DdEntry8
! FUNCTION: DdEntry9
! FUNCTION: DeleteColorSpace
-! FUNCTION: DeleteDC
+FUNCTION: BOOL DeleteDC ( HDC hdc ) ;
! FUNCTION: DeleteEnhMetaFile
! FUNCTION: DeleteMetaFile
FUNCTION: BOOL DeleteObject ( HGDIOBJ hObject ) ;
! FUNCTION: GdiEntry8
! FUNCTION: GdiEntry9
! FUNCTION: GdiFixUpHandle
-! FUNCTION: GdiFlush
+FUNCTION: BOOL GdiFlush ( ) ;
! FUNCTION: GdiFullscreenControl
! FUNCTION: GdiGetBatchLimit
! FUNCTION: GdiGetCharDimensions
! FUNCTION: SelectClipPath
FUNCTION: int SelectClipRgn ( HDC hDC, HRGN hrgn ) ;
! FUNCTION: SelectFontLocal
-! FUNCTION: SelectObject
+FUNCTION: HGDIOBJ SelectObject ( HDC hdc, HGDIOBJ hgdiobj ) ;
! FUNCTION: SelectPalette
! FUNCTION: SetAbortProc
! FUNCTION: SetArcDirection
: WGL_SWAP_UNDERLAY14 HEX: 20000000 ; inline
: WGL_SWAP_UNDERLAY15 HEX: 40000000 ; inline
-: pfd-dwFlags ( -- n )
+: windowed-pfd-dwFlags ( -- n )
{ PFD_DRAW_TO_WINDOW PFD_SUPPORT_OPENGL PFD_DOUBLEBUFFER } flags ;
+: offscreen-pfd-dwFlags ( -- n )
+ { PFD_DRAW_TO_BITMAP PFD_SUPPORT_OPENGL } flags ;
! TODO: compare to http://www.nullterminator.net/opengl32.html
-: make-pfd ( bits -- pfd )
+: make-pfd ( flags bits -- pfd )
"PIXELFORMATDESCRIPTOR" <c-object>
"PIXELFORMATDESCRIPTOR" heap-size over set-PIXELFORMATDESCRIPTOR-nSize
1 over set-PIXELFORMATDESCRIPTOR-nVersion
- pfd-dwFlags over set-PIXELFORMATDESCRIPTOR-dwFlags
+ rot over set-PIXELFORMATDESCRIPTOR-dwFlags
PFD_TYPE_RGBA over set-PIXELFORMATDESCRIPTOR-iPixelType
[ set-PIXELFORMATDESCRIPTOR-cColorBits ] keep
16 over set-PIXELFORMATDESCRIPTOR-cDepthBits
! { "BYTE[32]" "rgbReserved" }
! ;
+C-STRUCT: BITMAPINFOHEADER
+ { "DWORD" "biSize" }
+ { "LONG" "biWidth" }
+ { "LONG" "biHeight" }
+ { "WORD" "biPlanes" }
+ { "WORD" "biBitCount" }
+ { "DWORD" "biCompression" }
+ { "DWORD" "biSizeImage" }
+ { "LONG" "biXPelsPerMeter" }
+ { "LONG" "biYPelsPerMeter" }
+ { "DWORD" "biClrUsed" }
+ { "DWORD" "biClrImportant" } ;
+
+C-STRUCT: RGBQUAD
+ { "BYTE" "rgbBlue" }
+ { "BYTE" "rgbGreen" }
+ { "BYTE" "rgbRed" }
+ { "BYTE" "rgbReserved" } ;
+
+C-STRUCT: BITMAPINFO
+ { "BITMAPINFOHEADER" "bmiHeader" }
+ { "RGBQUAD[1]" "bmiColors" } ;
+
TYPEDEF: void* LPPAINTSTRUCT
TYPEDEF: void* PAINTSTRUCT
FUNCTION: void* glXGetProcAddressARB ( char* procname ) ;
! GLX Events
-! (also skipped for now. only has GLXPbufferClobberEvent, the rest is handled by xlib methinks
+! (also skipped for now. only has GLXPbufferClobberEvent, the rest is handled by xlib methinks)
-: choose-visual ( -- XVisualInfo* )
- dpy get scr get
+: choose-visual ( flags -- XVisualInfo* )
+ [ dpy get scr get ] dip
[
+ %
GLX_RGBA ,
- GLX_DOUBLEBUFFER ,
GLX_DEPTH_SIZE , 16 ,
0 ,
] int-array{ } make underlying>>
[ "Could not get a double-buffered GLX RGBA visual" throw ] unless* ;
: create-glx ( XVisualInfo* -- GLXContext )
- >r dpy get r> f 1 glXCreateContext
+ [ dpy get ] dip f 1 glXCreateContext
[ "Failed to create GLX context" throw ] unless* ;
: destroy-glx ( GLXContext -- )
- dpy get swap glXDestroyContext ;
\ No newline at end of file
+ dpy get swap glXDestroyContext ;
! Copyright (C) 2005, 2006 Eduardo Cavazos and Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
USING: alien alien.c-types hashtables kernel math math.vectors
-math.bitwise namespaces sequences x11.xlib x11.constants x11.glx ;
+math.bitwise namespaces sequences x11.xlib x11.constants x11.glx
+arrays fry ;
IN: x11.windows
: create-window-mask ( -- n )
dup r> auto-position ;
: glx-window ( loc dim -- window glx )
- choose-visual
+ GLX_DOUBLEBUFFER 1array choose-visual
[ create-window ] keep
[ create-glx ] keep
XFree ;
+: create-pixmap ( dim visual -- pixmap )
+ [ [ { 0 0 } swap ] dip create-window ] [
+ drop [ dpy get ] 2dip first2 24 XCreatePixmap
+ [ "Failed to create offscreen pixmap" throw ] unless*
+ ] 2bi ;
+
+: (create-glx-pixmap) ( pixmap visual -- pixmap glx-pixmap )
+ [ drop ] [
+ [ dpy get ] 2dip swap glXCreateGLXPixmap
+ [ "Failed to create offscreen GLXPixmap" throw ] unless*
+ ] 2bi ;
+
+: create-glx-pixmap ( dim visual -- pixmap glx-pixmap )
+ [ create-pixmap ] [ (create-glx-pixmap) ] bi ;
+
+: glx-pixmap ( dim -- glx pixmap glx-pixmap )
+ { } choose-visual
+ [ nip create-glx ] [ create-glx-pixmap ] [ nip XFree ] 2tri ;
+
: destroy-window ( win -- )
dpy get swap XDestroyWindow drop ;
: map-window ( win -- ) dpy get swap XMapWindow drop ;
: unmap-window ( win -- ) dpy get swap XUnmapWindow drop ;
+
+: pixmap-bits ( dim pixmap -- alien )
+ swap first2 '[ dpy get _ 0 0 _ _ AllPlanes ZPixmap XGetImage ] call
+ [ XImage-pixels ] [ XDestroyImage drop ] bi ;
TYPEDEF: ulong Atom
TYPEDEF: char* XPointer
-TYPEDEF: void* Display*
TYPEDEF: void* Screen*
TYPEDEF: void* GC
TYPEDEF: void* Visual*
! 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
FUNCTION: int XConvertSelection ( Display* display, Atom selection, Atom target, Atom property, Window requestor, Time time ) ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+! 5 - Pixmap and Cursor Functions
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+! 5.1 - Creating and Freeing Pixmaps
+
+FUNCTION: Pixmap XCreatePixmap ( Display* display, Drawable d, uint width, uint height, uint depth ) ;
+FUNCTION: int XFreePixmap ( Display* display, Pixmap pixmap ) ;
+
+
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! 6 - Color Management Functions
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
char* string,
int length ) ;
+! 8.7 - Transferring Images between Client and Server
+
+: XYBitmap 0 ; inline
+: XYPixmap 1 ; inline
+: ZPixmap 2 ; inline
+: AllPlanes -1 ; inline
+
+C-STRUCT: XImage-funcs
+ { "void*" "create_image" }
+ { "void*" "destroy_image" }
+ { "void*" "get_pixel" }
+ { "void*" "put_pixel" }
+ { "void*" "sub_image" }
+ { "void*" "add_pixel" } ;
+
+C-STRUCT: XImage
+ { "int" "width" }
+ { "int" "height" }
+ { "int" "xoffset" }
+ { "int" "format" }
+ { "char*" "data" }
+ { "int" "byte_order" }
+ { "int" "bitmap_unit" }
+ { "int" "bitmap_bit_order" }
+ { "int" "bitmap_pad" }
+ { "int" "depth" }
+ { "int" "bytes_per_line" }
+ { "int" "bits_per_pixel" }
+ { "ulong" "red_mask" }
+ { "ulong" "green_mask" }
+ { "ulong" "blue_mask" }
+ { "XPointer" "obdata" }
+ { "XImage-funcs" "f" } ;
+
+FUNCTION: XImage* XGetImage ( Display* display, Drawable d, int x, int y, uint width, uint height, ulong plane_mask, int format ) ;
+FUNCTION: int XDestroyImage ( XImage *ximage ) ;
+
+: XImage-size ( ximage -- size )
+ [ XImage-height ] [ XImage-bytes_per_line ] bi * ;
+
+: XImage-pixels ( ximage -- byte-array )
+ [ XImage-data ] [ XImage-size ] bi memory>byte-array ;
+
!
! 9 - Window and Session Manager Functions
!
! Copyright (C) 2004, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors assocs kernel math namespaces sequences system
-kernel.private byte-arrays arrays ;
+kernel.private byte-arrays arrays init ;
IN: alien
! Some predicate classes used by the compiler for optimization
: alien-invoke ( ... return library function parameters -- ... )
2over alien-invoke-error ;
+
+! Callbacks are registered in a global hashtable. If you clear
+! this hashtable, they will all be blown away by code GC, beware.
+SYMBOL: callbacks
+
+[ H{ } clone callbacks set-global ] "alien" add-init-hook
! Copyright (C) 2007, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: init kernel system namespaces io io.encodings
-io.encodings.utf8 init assocs splitting ;
+io.encodings.utf8 init assocs splitting alien ;
IN: io.backend
SYMBOL: io-backend
io-backend set-global init-io init-stdio
"io.files" init-hooks get at call ;
+! Note that we have 'alien' in our using list so that the alien
+! init hook runs before this one.
[ init-io embedded? [ init-stdio ] unless ]
"io.backend" add-init-hook
! LOL
[ ] [
vm
+ "-i=" image append
"-generations=2"
"-e=USING: memory io prettyprint system ; input-stream gc . 0 exit"
- 3array try-process
+ 4array try-process
] unit-test
[ [ ] instances ] must-infer
[ (each) ] dip collect ; inline
: 2nth-unsafe ( n seq1 seq2 -- elt1 elt2 )
- [ over ] dip nth-unsafe [ nth-unsafe ] dip ; inline
+ [ over ] dip [ nth-unsafe ] 2bi@ ; inline
: (2each) ( seq1 seq2 quot -- n quot' )
[ [ min-length ] 2keep ] dip
: sequence-hashcode-step ( oldhash newpart -- newhash )
>fixnum swap [
- dup -2 fixnum-shift-fast swap 5 fixnum-shift-fast
+ [ -2 fixnum-shift-fast ] [ 5 fixnum-shift-fast ] bi
fixnum+fast fixnum+fast
] keep fixnum-bitxor ; inline
: sequence-hashcode ( n seq -- x )
- 0 -rot [ hashcode* sequence-hashcode-step ] with each ; inline
+ [ 0 ] 2dip [ hashcode* sequence-hashcode-step ] with each ; inline
M: reversed equal? over reversed? [ sequence= ] [ 2drop f ] if ;
USING: arrays bunny.model continuations destructors kernel
multiline opengl opengl.shaders opengl.capabilities opengl.gl
-sequences sequences.lib accessors combinators ;
+sequences accessors combinators ;
IN: bunny.cel-shaded
STRING: vertex-shader-source
http.client io io.encodings.ascii io.files kernel math
math.matrices math.parser math.vectors opengl
opengl.capabilities opengl.gl opengl.demo-support sequences
-sequences.lib splitting vectors words
-specialized-arrays.float specialized-arrays.uint ;
+splitting vectors words specialized-arrays.float
+specialized-arrays.uint ;
IN: bunny.model
: numbers ( str -- seq )
vneg normalize ;
: normal ( ns vs triple -- )
- [ n ] keep [ rot [ v+ ] change-nth ] each-with2 ;
+ [ n ] keep [ rot [ v+ ] change-nth ] with with each ;
: normals ( vs is -- ns )
over length { 0.0 0.0 0.0 } <array> -rot
] unless ;
: (draw-triangle) ( ns vs triple -- )
- [ dup roll nth gl-normal swap nth gl-vertex ] each-with2 ;
+ [ dup roll nth gl-normal swap nth gl-vertex ] with with each ;
: draw-triangles ( ns vs is -- )
- GL_TRIANGLES [ [ (draw-triangle) ] each-with2 ] do-state ;
+ GL_TRIANGLES [ [ (draw-triangle) ] with with each ] do-state ;
TUPLE: bunny-dlist list ;
TUPLE: bunny-buffers array element-array nv ni ;
combinators continuations debugger definitions eval help
io io.files io.streams.string kernel lexer listener listener.private
make math namespaces parser prettyprint prettyprint.config
-quotations sequences strings source-files vectors vocabs.loader ;
+quotations sequences strings source-files vectors vocabs vocabs.loader ;
IN: fuel
: 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-get-vocab-location ( vocab -- )
+ vocab-source-path [
+ (normalize-path) 1 2array fuel-eval-set-result
+ ] when* ;
+
+: fuel-get-vocabs ( -- )
+ vocabs fuel-eval-set-result ; inline
: fuel-run-file ( path -- ) run-file ; inline
USING: alien arrays byte-arrays combinators summary io.backend
graphics.viewer io io.binary io.files kernel libc math
math.functions math.bitwise namespaces opengl opengl.gl
-prettyprint sequences strings ui ui.gadgets.panes
-io.encodings.binary accessors grouping ;
+prettyprint sequences strings ui ui.gadgets.panes fry
+io.encodings.binary accessors grouping macros alien.c-types ;
IN: graphics.bitmap
-! Currently can only handle 24bit bitmaps.
+! Currently can only handle 24/32bit bitmaps.
! Handles row-reversed bitmaps (their height is negative)
TUPLE: bitmap magic size reserved offset header-length width
height planes bit-count compression size-image
x-pels y-pels color-used color-important rgb-quads color-index array ;
+: (array-copy) ( bitmap array -- bitmap array' )
+ over size-image>> abs memory>byte-array ;
+
+MACRO: (nbits>bitmap) ( bits -- )
+ [ -3 shift ] keep '[
+ bitmap new
+ 2over * _ * >>size-image
+ swap >>height
+ swap >>width
+ swap (array-copy) [ >>array ] [ >>color-index ] bi
+ _ >>bit-count
+ ] ;
+
: bgr>bitmap ( array height width -- bitmap )
- bitmap new
- 2over * 3 * >>size-image
- swap >>height
- swap >>width
- swap [ >>array ] [ >>color-index ] bi
- 24 >>bit-count ;
+ 24 (nbits>bitmap) ;
+
+: bgra>bitmap ( array height width -- bitmap )
+ 32 (nbits>bitmap) ;
: 8bit>array ( bitmap -- array )
[ rgb-quads>> 4 <sliced-groups> [ 3 head-slice ] map ]
[
[ height>> abs ] keep
bit-count>> {
- ! { 32 [ GL_BGRA GL_UNSIGNED_INT_8_8_8_8 ] } ! broken
+ { 32 [ GL_BGRA GL_UNSIGNED_BYTE ] }
{ 24 [ GL_BGR GL_UNSIGNED_BYTE ] }
{ 8 [ GL_BGR GL_UNSIGNED_BYTE ] }
{ 4 [ GL_BGR GL_UNSIGNED_BYTE ] }
-USING: alien.syntax alien.c-types core-foundation system
-combinators kernel sequences debugger io accessors ;
+USING: alien.syntax alien.c-types core-foundation
+core-foundation.bundles system combinators kernel sequences
+debugger io accessors ;
IN: iokit
<<
: make-key-gadget ( scancode dim array -- )
[
swap [
- " " [ ] <bevel-button>
+ " " [ drop ] <bevel-button>
swap [ first >>loc ] [ second >>dim ] bi
] [ execute ] bi*
] dip set-nth ;
--- /dev/null
+USING: kernel literals tools.test ;
+IN: literals.tests
+
+<<
+: five 5 ;
+: seven-eleven 7 11 ;
+: six-six-six 6 6 6 ;
+>>
+
+[ { 5 } ] [ { $ five } ] unit-test
+[ { 7 11 } ] [ { $ seven-eleven } ] unit-test
+[ { 6 6 6 } ] [ { $ six-six-six } ] unit-test
--- /dev/null
+USING: continuations kernel parser words ;
+IN: literals
+
+: $ scan-word [ execute ] curry with-datastack ; parsing
+++ /dev/null
-Joe Groff
\ No newline at end of file
+++ /dev/null
-USING: help.markup help.syntax io kernel math quotations
-opengl.gl multiline assocs ;
-IN: opengl.capabilities
-
-HELP: gl-version
-{ $values { "version" "The version string from the OpenGL implementation" } }
-{ $description "Wrapper for " { $snippet "GL_VERSION glGetString" } " that removes the vendor-specific information from the version string." } ;
-
-HELP: gl-vendor-version
-{ $values { "version" "The vendor-specific version information from the OpenGL implementation" } }
-{ $description "Wrapper for " { $snippet "GL_VERSION glGetString" } " that returns only the vendor-specific information from the version string." } ;
-
-HELP: has-gl-version?
-{ $values { "version" "A version string" } { "?" "A boolean value" } }
-{ $description "Compares the version string returned by " { $link gl-version } " to " { $snippet "version" } ". Returns true if the implementation version meets or exceeds " { $snippet "version" } "." } ;
-
-HELP: require-gl-version
-{ $values { "version" "A version string" } }
-{ $description "Throws an exception if " { $link has-gl-version? } " returns false for " { $snippet "version" } "." } ;
-
-HELP: glsl-version
-{ $values { "version" "The GLSL version string from the OpenGL implementation" } }
-{ $description "Wrapper for " { $snippet "GL_SHADING_LANGUAGE_VERSION glGetString" } " that removes the vendor-specific information from the version string." } ;
-
-HELP: glsl-vendor-version
-{ $values { "version" "The vendor-specific GLSL version information from the OpenGL implementation" } }
-{ $description "Wrapper for " { $snippet "GL_SHADING_LANGUAGE_VERSION glGetString" } " that returns only the vendor-specific information from the version string." } ;
-
-HELP: has-glsl-version?
-{ $values { "version" "A version string" } { "?" "A boolean value" } }
-{ $description "Compares the version string returned by " { $link glsl-version } " to " { $snippet "version" } ". Returns true if the implementation version meets or exceeds " { $snippet "version" } "." } ;
-
-HELP: require-glsl-version
-{ $values { "version" "A version string" } }
-{ $description "Throws an exception if " { $link has-glsl-version? } " returns false for " { $snippet "version" } "." } ;
-
-HELP: gl-extensions
-{ $values { "seq" "A sequence of strings naming the implementation-supported OpenGL extensions" } }
-{ $description "Wrapper for " { $snippet "GL_EXTENSIONS glGetString" } " that returns a sequence of extension names supported by the OpenGL implementation." } ;
-
-HELP: has-gl-extensions?
-{ $values { "extensions" "A sequence of extension name strings" } { "?" "A boolean value" } }
-{ $description "Returns true if the set of " { $snippet "extensions" } " is a subset of the implementation-supported extensions returned by " { $link gl-extensions } "." } ;
-
-HELP: has-gl-version-or-extensions?
-{ $values { "version" "A version string" } { "extensions" "A sequence of extension name strings" } { "?" "a boolean" } }
-{ $description "Returns true if either " { $link has-gl-version? } " or " { $link has-gl-extensions? } " returns true for " { $snippet "version" } " or " { $snippet "extensions" } ", respectively. Intended for use when required OpenGL functionality can be verified either by a minimum version or a set of equivalent extensions." } ;
-
-HELP: require-gl-extensions
-{ $values { "extensions" "A sequence of extension name strings" } }
-{ $description "Throws an exception if " { $link has-gl-extensions? } " returns false for " { $snippet "extensions" } "." } ;
-
-HELP: require-gl-version-or-extensions
-{ $values { "version" "A version string" } { "extensions" "A sequence of extension name strings" } }
-{ $description "Throws an exception if neither " { $link has-gl-version? } " nor " { $link has-gl-extensions? } " returns true for " { $snippet "version" } " or " { $snippet "extensions" } ", respectively. Intended for use when required OpenGL functionality can be verified either by a minimum version or a set of equivalent extensions." } ;
-
-{ require-gl-version require-glsl-version require-gl-extensions require-gl-version-or-extensions has-gl-version? has-glsl-version? has-gl-extensions? has-gl-version-or-extensions? gl-version glsl-version gl-extensions } related-words
-
-ABOUT: "gl-utilities"
+++ /dev/null
-! Copyright (C) 2008 Joe Groff.
-! See http://factorcode.org/license.txt for BSD license.
-USING: kernel namespaces make sequences splitting opengl.gl
-continuations math.parser math arrays sets math.order ;
-IN: opengl.capabilities
-
-: (require-gl) ( thing require-quot make-error-quot -- )
- -rot dupd call
- [ 2drop ]
- [ swap " " make throw ]
- if ; inline
-
-: gl-extensions ( -- seq )
- GL_EXTENSIONS glGetString " " split ;
-: has-gl-extensions? ( extensions -- ? )
- gl-extensions swap [ over member? ] all? nip ;
-: (make-gl-extensions-error) ( required-extensions -- )
- gl-extensions diff
- "Required OpenGL extensions not supported:\n" %
- [ " " % % "\n" % ] each ;
-: require-gl-extensions ( extensions -- )
- [ has-gl-extensions? ]
- [ (make-gl-extensions-error) ]
- (require-gl) ;
-
-: version-seq ( version-string -- version-seq )
- "." split [ string>number ] map ;
-
-: version-before? ( version1 version2 -- ? )
- swap version-seq swap version-seq before=? ;
-
-: (gl-version) ( -- version vendor )
- GL_VERSION glGetString " " split1 ;
-: gl-version ( -- version )
- (gl-version) drop ;
-: gl-vendor-version ( -- version )
- (gl-version) nip ;
-: has-gl-version? ( version -- ? )
- gl-version version-before? ;
-: (make-gl-version-error) ( required-version -- )
- "Required OpenGL version " % % " not supported (" % gl-version % " available)" % ;
-: require-gl-version ( version -- )
- [ has-gl-version? ]
- [ (make-gl-version-error) ]
- (require-gl) ;
-
-: (glsl-version) ( -- version vendor )
- GL_SHADING_LANGUAGE_VERSION glGetString " " split1 ;
-: glsl-version ( -- version )
- (glsl-version) drop ;
-: glsl-vendor-version ( -- version )
- (glsl-version) nip ;
-: has-glsl-version? ( version -- ? )
- glsl-version version-before? ;
-: require-glsl-version ( version -- )
- [ has-glsl-version? ]
- [ "Required GLSL version " % % " not supported (" % glsl-version % " available)" % ]
- (require-gl) ;
-
-: has-gl-version-or-extensions? ( version extensions -- ? )
- has-gl-extensions? swap has-gl-version? or ;
-
-: require-gl-version-or-extensions ( version extensions -- )
- 2array [ first2 has-gl-version-or-extensions? ] [
- dup first (make-gl-version-error) "\n" %
- second (make-gl-extensions-error) "\n" %
- ] (require-gl) ;
+++ /dev/null
-Testing for OpenGL versions and extensions
\ No newline at end of file
+++ /dev/null
-opengl
-bindings
+++ /dev/null
-Joe Groff
\ No newline at end of file
+++ /dev/null
-USING: help.markup help.syntax io kernel math quotations
-opengl.gl multiline assocs ;
-IN: opengl.framebuffers
-
-HELP: gen-framebuffer
-{ $values { "id" integer } }
-{ $description "Wrapper for " { $link glGenFramebuffersEXT } " to handle the common case of generating a single framebuffer ID." } ;
-
-HELP: gen-renderbuffer
-{ $values { "id" integer } }
-{ $description "Wrapper for " { $link glGenRenderbuffersEXT } " to handle the common case of generating a single render buffer ID." } ;
-
-HELP: delete-framebuffer
-{ $values { "id" integer } }
-{ $description "Wrapper for " { $link glDeleteFramebuffersEXT } " to handle the common case of deleting a single framebuffer ID." } ;
-
-HELP: delete-renderbuffer
-{ $values { "id" integer } }
-{ $description "Wrapper for " { $link glDeleteRenderbuffersEXT } " to handle the common case of deleting a single render buffer ID." } ;
-
-{ gen-framebuffer delete-framebuffer } related-words
-{ gen-renderbuffer delete-renderbuffer } related-words
-
-HELP: framebuffer-incomplete?
-{ $values { "status/f" "The framebuffer error code, or " { $snippet "f" } " if the framebuffer is render-complete." } }
-{ $description "Checks the framebuffer currently bound by " { $link glBindFramebufferEXT } " or " { $link with-framebuffer } " to see if it is incomplete, i.e., it is not ready to be rendered to." } ;
-
-HELP: check-framebuffer
-{ $description "Checks the framebuffer currently bound by " { $link glBindFramebufferEXT } " or " { $link with-framebuffer } " with " { $link framebuffer-incomplete? } ", and throws a descriptive error if the framebuffer is incomplete." } ;
-
-HELP: with-framebuffer
-{ $values { "id" "The id of a framebuffer object." } { "quot" "a quotation" } }
-{ $description "Binds framebuffer " { $snippet "id" } " in the dynamic extent of " { $snippet "quot" } ", restoring the window framebuffer when finished." } ;
-
-ABOUT: "gl-utilities"
\ No newline at end of file
+++ /dev/null
-! Copyright (C) 2008 Joe Groff.
-! See http://factorcode.org/license.txt for BSD license.
-USING: opengl opengl.gl combinators continuations kernel
-alien.c-types ;
-IN: opengl.framebuffers
-
-: gen-framebuffer ( -- id )
- [ glGenFramebuffersEXT ] (gen-gl-object) ;
-: gen-renderbuffer ( -- id )
- [ glGenRenderbuffersEXT ] (gen-gl-object) ;
-
-: delete-framebuffer ( id -- )
- [ glDeleteFramebuffersEXT ] (delete-gl-object) ;
-: delete-renderbuffer ( id -- )
- [ glDeleteRenderbuffersEXT ] (delete-gl-object) ;
-
-: framebuffer-incomplete? ( -- status/f )
- GL_FRAMEBUFFER_EXT glCheckFramebufferStatusEXT
- dup GL_FRAMEBUFFER_COMPLETE_EXT = f rot ? ;
-
-: framebuffer-error ( status -- * )
- {
- { GL_FRAMEBUFFER_COMPLETE_EXT [ "framebuffer complete" ] }
- { GL_FRAMEBUFFER_UNSUPPORTED_EXT [ "framebuffer configuration unsupported" ] }
- { GL_FRAMEBUFFER_INCOMPLETE_ATTACHMENT_EXT [ "framebuffer incomplete (incomplete attachment)" ] }
- { GL_FRAMEBUFFER_INCOMPLETE_MISSING_ATTACHMENT_EXT [ "framebuffer incomplete (missing attachment)" ] }
- { GL_FRAMEBUFFER_INCOMPLETE_DIMENSIONS_EXT [ "framebuffer incomplete (dimension mismatch)" ] }
- { GL_FRAMEBUFFER_INCOMPLETE_FORMATS_EXT [ "framebuffer incomplete (format mismatch)" ] }
- { GL_FRAMEBUFFER_INCOMPLETE_DRAW_BUFFER_EXT [ "framebuffer incomplete (draw buffer(s) have no attachment)" ] }
- { GL_FRAMEBUFFER_INCOMPLETE_READ_BUFFER_EXT [ "framebuffer incomplete (read buffer has no attachment)" ] }
- [ drop gl-error "unknown framebuffer error" ]
- } case throw ;
-
-: check-framebuffer ( -- )
- framebuffer-incomplete? [ framebuffer-error ] when* ;
-
-: with-framebuffer ( id quot -- )
- GL_FRAMEBUFFER_EXT rot glBindFramebufferEXT
- [ GL_FRAMEBUFFER_EXT 0 glBindFramebufferEXT ] [ ] cleanup ; inline
-
-: framebuffer-attachment ( attachment -- id )
- GL_FRAMEBUFFER_EXT swap GL_FRAMEBUFFER_ATTACHMENT_OBJECT_NAME_EXT
- 0 <uint> [ glGetFramebufferAttachmentParameterivEXT ] keep *uint ;
+++ /dev/null
-Rendering to offscreen textures using the GL_EXT_framebuffer_object extension
\ No newline at end of file
+++ /dev/null
-opengl
-bindings
+++ /dev/null
-Joe Groff
\ No newline at end of file
+++ /dev/null
-USING: help.markup help.syntax io kernel math quotations
-opengl.gl multiline assocs strings ;
-IN: opengl.shaders
-
-HELP: gl-shader
-{ $class-description { $snippet "gl-shader" } " is a predicate class comprising values returned by OpenGL to represent shader objects. The following words are provided for creating and manipulating these objects:"
- { $list
- { { $link <gl-shader> } " - Compile GLSL code into a shader object" }
- { { $link gl-shader-ok? } " - Check whether a shader object compiled successfully" }
- { { $link check-gl-shader } " - Throw an error unless a shader object compiled successfully" }
- { { $link gl-shader-info-log } " - Retrieve the info log of messages generated by the GLSL compiler" }
- { { $link delete-gl-shader } " - Invalidate a shader object" }
- }
- "The derived predicate classes " { $link vertex-shader } " and " { $link fragment-shader } " are also defined for the two standard kinds of shader defined by the OpenGL specification." } ;
-
-HELP: vertex-shader
-{ $class-description { $snippet "vertex-shader" } " is the predicate class of " { $link gl-shader } " objects that refer to shaders of type " { $snippet "GL_VERTEX_SHADER" } ". In addition to the " { $snippet "gl-shader" } " words, the following vertex shader-specific functions are defined:"
- { $list
- { { $link <vertex-shader> } " - Compile GLSL code into a vertex shader object "}
- }
-} ;
-
-HELP: fragment-shader
-{ $class-description { $snippet "fragment-shader" } " is the predicate class of " { $link gl-shader } " objects that refer to shaders of type " { $snippet "GL_FRAGMENT_SHADER" } ". In addition to the " { $snippet "gl-shader" } " words, the following fragment shader-specific functions are defined:"
- { $list
- { { $link <fragment-shader> } " - Compile GLSL code into a fragment shader object "}
- }
-} ;
-
-HELP: <gl-shader>
-{ $values { "source" "The GLSL source code to compile" } { "kind" "The kind of shader to compile, such as " { $snippet "GL_VERTEX_SHADER" } " or " { $snippet "GL_FRAGMENT_SHADER" } } { "shader" "a new " { $link gl-shader } } }
-{ $description "Tries to compile the given GLSL source into a shader object. The returned object can be checked for validity by " { $link check-gl-shader } " or " { $link gl-shader-ok? } ". Errors and warnings generated by the GLSL compiler will be collected in the info log, available from " { $link gl-shader-info-log } ".\n\nWhen the shader object is no longer needed, it should be deleted using " { $link delete-gl-shader } " or else be attached to a " { $link gl-program } " object deleted using " { $link delete-gl-program } "." } ;
-
-HELP: <vertex-shader>
-{ $values { "source" "The GLSL source code to compile" } { "vertex-shader" "a new " { $link vertex-shader } } }
-{ $description "Tries to compile the given GLSL source into a vertex shader object. Equivalent to " { $snippet "GL_VERTEX_SHADER <gl-shader>" } "." } ;
-
-HELP: <fragment-shader>
-{ $values { "source" "The GLSL source code to compile" } { "fragment-shader" "a new " { $link fragment-shader } } }
-{ $description "Tries to compile the given GLSL source into a fragment shader object. Equivalent to " { $snippet "GL_FRAGMENT_SHADER <gl-shader>" } "." } ;
-
-HELP: gl-shader-ok?
-{ $values { "shader" "A " { $link gl-shader } " object" } { "?" "a boolean" } }
-{ $description "Returns a boolean value indicating whether the given shader object compiled successfully. Compilation errors and warnings are available in the shader's info log, which can be gotten using " { $link gl-shader-info-log } "." } ;
-
-HELP: check-gl-shader
-{ $values { "shader" "A " { $link gl-shader } " object" } }
-{ $description "Throws an error containing the " { $link gl-shader-info-log } " for the shader object if it failed to compile. Otherwise, the shader object is left on the stack." } ;
-
-HELP: delete-gl-shader
-{ $values { "shader" "A " { $link gl-shader } " object" } }
-{ $description "Deletes the shader object, invalidating it and releasing any resources allocated for it by the OpenGL implementation." } ;
-
-HELP: gl-shader-info-log
-{ $values { "shader" "A " { $link gl-shader } " object" } { "shader" "a new " { $link gl-shader } } { "log" string } }
-{ $description "Retrieves the info log for " { $snippet "shader" } ", including any errors or warnings generated in compiling the shader object." } ;
-
-HELP: gl-program
-{ $class-description { $snippet "gl-program" } " is a predicate class comprising values returned by OpenGL to represent proram objects. The following words are provided for creating and manipulating these objects:"
- { $list
- { { $link <gl-program> } ", " { $link <simple-gl-program> } " - Link a set of shaders into a GLSL program" }
- { { $link gl-program-ok? } " - Check whether a program object linked successfully" }
- { { $link check-gl-program } " - Throw an error unless a program object linked successfully" }
- { { $link gl-program-info-log } " - Retrieve the info log of messages generated by the GLSL linker" }
- { { $link gl-program-shaders } " - Retrieve the set of shader objects composing the GLSL program" }
- { { $link delete-gl-program } " - Invalidate a program object and all its attached shaders" }
- { { $link with-gl-program } " - Use a program object" }
- }
-} ;
-
-HELP: <gl-program>
-{ $values { "shaders" "A sequence of " { $link gl-shader } " objects." } { "program" "a new " { $link gl-program } } }
-{ $description "Creates a new GLSL program object, attaches all the shader objects in the " { $snippet "shaders" } " sequence, and attempts to link them. The returned object can be checked for validity by " { $link check-gl-program } " or " { $link gl-program-ok? } ". Errors and warnings generated by the GLSL linker will be collected in the info log, available from " { $link gl-program-info-log } ".\n\nWhen the program object and its attached shaders are no longer needed, it should be deleted using " { $link delete-gl-program } "." } ;
-
-HELP: <simple-gl-program>
-{ $values { "vertex-shader-source" "A string containing GLSL vertex shader source" } { "fragment-shader-source" "A string containing GLSL fragment shader source" } { "program" "a new " { $link gl-program } } }
-{ $description "Wrapper for " { $link <gl-program> } " for the simple case of compiling a single vertex shader and fragment shader and linking them into a GLSL program. Throws an exception if compiling or linking fails." } ;
-
-{ <gl-program> <simple-gl-program> } related-words
-
-HELP: gl-program-ok?
-{ $values { "program" "A " { $link gl-program } " object" } { "?" "a boolean" } }
-{ $description "Returns a boolean value indicating whether the given program object linked successfully. Link errors and warnings are available in the program's info log, which can be gotten using " { $link gl-program-info-log } "." } ;
-
-HELP: check-gl-program
-{ $values { "program" "A " { $link gl-program } " object" } }
-{ $description "Throws an error containing the " { $link gl-program-info-log } " for the program object if it failed to link. Otherwise, the program object is left on the stack." } ;
-
-HELP: gl-program-info-log
-{ $values { "program" "A " { $link gl-program } " object" } { "log" string } }
-{ $description "Retrieves the info log for " { $snippet "program" } ", including any errors or warnings generated in linking the program object." } ;
-
-HELP: delete-gl-program
-{ $values { "program" "A " { $link gl-program } " object" } }
-{ $description "Deletes the program object, invalidating it and releasing any resources allocated for it by the OpenGL implementation. Any attached " { $link gl-shader } "s are also deleted.\n\nIf the shader objects should be preserved, they should each be detached using " { $link detach-gl-program-shader } ". The program object can then be destroyed alone using " { $link delete-gl-program-only } "." } ;
-
-HELP: with-gl-program
-{ $values { "program" "A " { $link gl-program } " object" } { "quot" "A quotation with stack effect " { $snippet "( program -- )" } } }
-{ $description "Enables " { $snippet "program" } " for all OpenGL calls made in the dynamic extent of " { $snippet "quot" } ". " { $snippet "program" } " is left on the top of the stack when " { $snippet "quot" } " is called. The fixed-function pipeline is restored at the end of " { $snippet "quot" } "." } ;
-
-ABOUT: "gl-utilities"
+++ /dev/null
-! Copyright (C) 2008 Joe Groff.
-! See http://factorcode.org/license.txt for BSD license.
-USING: kernel opengl.gl alien.c-types continuations namespaces
-assocs alien alien.strings libc opengl math sequences combinators
-combinators.lib macros arrays io.encodings.ascii fry
-specialized-arrays.uint destructors accessors ;
-IN: opengl.shaders
-
-: with-gl-shader-source-ptr ( string quot -- )
- swap ascii malloc-string [ <void*> swap call ] keep free ; inline
-
-: <gl-shader> ( source kind -- shader )
- glCreateShader dup rot
- [ 1 swap f glShaderSource ] with-gl-shader-source-ptr
- [ glCompileShader ] keep
- gl-error ;
-
-: (gl-shader?) ( object -- ? )
- dup integer? [ glIsShader c-bool> ] [ drop f ] if ;
-
-: gl-shader-get-int ( shader enum -- value )
- 0 <int> [ glGetShaderiv ] keep *int ;
-
-: gl-shader-ok? ( shader -- ? )
- GL_COMPILE_STATUS gl-shader-get-int c-bool> ;
-
-: <vertex-shader> ( source -- vertex-shader )
- GL_VERTEX_SHADER <gl-shader> ; inline
-
-: (vertex-shader?) ( object -- ? )
- dup (gl-shader?)
- [ GL_SHADER_TYPE gl-shader-get-int GL_VERTEX_SHADER = ]
- [ drop f ] if ;
-
-: <fragment-shader> ( source -- fragment-shader )
- GL_FRAGMENT_SHADER <gl-shader> ; inline
-
-: (fragment-shader?) ( object -- ? )
- dup (gl-shader?)
- [ GL_SHADER_TYPE gl-shader-get-int GL_FRAGMENT_SHADER = ]
- [ drop f ] if ;
-
-: gl-shader-info-log-length ( shader -- log-length )
- GL_INFO_LOG_LENGTH gl-shader-get-int ; inline
-
-: gl-shader-info-log ( shader -- log )
- dup gl-shader-info-log-length dup [
- 1 calloc &free
- [ 0 <int> swap glGetShaderInfoLog ] keep
- ascii alien>string
- ] with-destructors ;
-
-: check-gl-shader ( shader -- shader )
- dup gl-shader-ok? [ dup gl-shader-info-log throw ] unless ;
-
-: delete-gl-shader ( shader -- ) glDeleteShader ; inline
-
-PREDICATE: gl-shader < integer (gl-shader?) ;
-PREDICATE: vertex-shader < gl-shader (vertex-shader?) ;
-PREDICATE: fragment-shader < gl-shader (fragment-shader?) ;
-
-! Programs
-
-: <gl-program> ( shaders -- program )
- glCreateProgram swap
- [ dupd glAttachShader ] each
- [ glLinkProgram ] keep
- gl-error ;
-
-: (gl-program?) ( object -- ? )
- dup integer? [ glIsProgram c-bool> ] [ drop f ] if ;
-
-: gl-program-get-int ( program enum -- value )
- 0 <int> [ glGetProgramiv ] keep *int ;
-
-: gl-program-ok? ( program -- ? )
- GL_LINK_STATUS gl-program-get-int c-bool> ;
-
-: gl-program-info-log-length ( program -- log-length )
- GL_INFO_LOG_LENGTH gl-program-get-int ; inline
-
-: gl-program-info-log ( program -- log )
- dup gl-program-info-log-length dup [
- 1 calloc &free
- [ 0 <int> swap glGetProgramInfoLog ] keep
- ascii alien>string
- ] with-destructors ;
-
-: check-gl-program ( program -- program )
- dup gl-program-ok? [ dup gl-program-info-log throw ] unless ;
-
-: gl-program-shaders-length ( program -- shaders-length )
- GL_ATTACHED_SHADERS gl-program-get-int ; inline
-
-: gl-program-shaders ( program -- shaders )
- dup gl-program-shaders-length
- 0 <int>
- over <uint-array>
- [ underlying>> glGetAttachedShaders ] keep ;
-
-: delete-gl-program-only ( program -- )
- glDeleteProgram ; inline
-
-: detach-gl-program-shader ( program shader -- )
- glDetachShader ; inline
-
-: delete-gl-program ( program -- )
- dup gl-program-shaders [
- 2dup detach-gl-program-shader delete-gl-shader
- ] each delete-gl-program-only ;
-
-: with-gl-program ( program quot -- )
- over glUseProgram [ 0 glUseProgram ] [ ] cleanup ; inline
-
-PREDICATE: gl-program < integer (gl-program?) ;
-
-: <simple-gl-program> ( vertex-shader-source fragment-shader-source -- program )
- >r <vertex-shader> check-gl-shader
- r> <fragment-shader> check-gl-shader
- 2array <gl-program> check-gl-program ;
-
+++ /dev/null
-OpenGL Shading Language (GLSL) support
\ No newline at end of file
+++ /dev/null
-opengl
-bindings
\ No newline at end of file
--- /dev/null
+! Copyright (C) 2008 Joe Groff.
+! See http://factorcode.org/license.txt for BSD license.
+USING: help.markup help.syntax kernel quotations ui.gadgets
+graphics.bitmap strings ui.gadgets.worlds ;
+IN: ui.offscreen
+
+HELP: <offscreen-world>
+{ $values
+ { "gadget" gadget } { "title" string } { "status" "a boolean" }
+ { "world" offscreen-world }
+}
+{ $description "Constructs an " { $link offscreen-world } " gadget with " { $snippet "gadget" } " as its only child. Generally you should use " { $link open-offscreen } " or " { $link do-offscreen } " instead of calling this word directly." } ;
+
+HELP: close-offscreen
+{ $values
+ { "world" offscreen-world }
+}
+{ $description "Releases the resources used by the rendering buffer for " { $snippet "world" } "." } ;
+
+HELP: do-offscreen
+{ $values
+ { "gadget" gadget } { "quot" quotation }
+}
+{ $description "Constructs an " { $link offscreen-world } " around " { $snippet "gadget" } " with " { $link open-offscreen } ", calls " { $snippet "quotation" } " with the world on the top of the stack, and cleans up the world with " { $link close-offscreen } " at the end of " { $snippet "quotation" } "." } ;
+
+HELP: gadget>bitmap
+{ $values
+ { "gadget" gadget }
+ { "bitmap" bitmap }
+}
+{ $description "Renders " { $snippet "gadget" } " to an " { $link offscreen-world } " and creates a " { $link bitmap } " from its contents." } ;
+
+HELP: offscreen-world
+{ $class-description "The class of " { $link world } " objects that render to an offscreen buffer." } ;
+
+HELP: offscreen-world>bitmap
+{ $values
+ { "world" offscreen-world }
+ { "bitmap" bitmap }
+}
+{ $description "Saves a copy of the contents of " { $snippet "world" } " to a " { $link bitmap } " object." } ;
+
+HELP: open-offscreen
+{ $values
+ { "gadget" gadget }
+ { "world" offscreen-world }
+}
+{ $description "Creates and sets up an " { $link offscreen-world } " with " { $snippet "gadget" } " as its only child." } ;
+
+{ offscreen-world open-offscreen close-offscreen do-offscreen } related-words
+
+ARTICLE: "ui.offscreen" "Offscreen UI rendering"
+"The " { $vocab-link "ui.offscreen" } " provides words for rendering gadgets to an offscreen buffer so that bitmaps can be made from their contents."
+{ $subsection offscreen-world }
+"Opening gadgets offscreen:"
+{ $subsection open-offscreen }
+{ $subsection close-offscreen }
+{ $subsection do-offscreen }
+"Creating bitmaps from offscreen buffers:"
+{ $subsection offscreen-world>bitmap }
+{ $subsection gadget>bitmap } ;
+
+ABOUT: "ui.offscreen"
--- /dev/null
+! (c) 2008 Joe Groff, see license for details
+USING: accessors continuations graphics.bitmap kernel math
+sequences ui.gadgets ui.gadgets.worlds ui ui.backend
+destructors ;
+IN: ui.offscreen
+
+TUPLE: offscreen-world < world ;
+
+: <offscreen-world> ( gadget title status -- world )
+ offscreen-world new-world ;
+
+M: offscreen-world graft*
+ (open-offscreen-buffer) ;
+
+M: offscreen-world ungraft*
+ [ (ungraft-world) ]
+ [ handle>> (close-offscreen-buffer) ]
+ [ reset-world ] tri ;
+
+: open-offscreen ( gadget -- world )
+ "" f <offscreen-world>
+ [ open-world-window dup relayout-1 ] keep
+ notify-queued ;
+
+: close-offscreen ( world -- )
+ ungraft notify-queued ;
+
+: offscreen-world>bitmap ( world -- bitmap )
+ offscreen-pixels bgra>bitmap ;
+
+: do-offscreen ( gadget quot: ( offscreen-world -- ) -- )
+ [ open-offscreen ] dip
+ over [ slip ] [ close-offscreen ] [ ] cleanup ; inline
+
+: gadget>bitmap ( gadget -- bitmap )
+ [ offscreen-world>bitmap ] do-offscreen ;
--- /dev/null
+Offscreen world gadgets for rendering UI elements to bitmaps
--- /dev/null
+unportable
+ui
+graphics
(Chords ending in a single letter <x> accept also C-<x> (e.g. C-cC-z is
the same as C-cz)).
-* In factor files:
+* In factor source files:
- C-cz : switch to listener
- C-co : cycle between code, tests and docs factor files
- M-. : edit word at point in Emacs (also in listener)
+ - C-cC-ev : edit vocabulary
- C-cr, C-cC-er : eval region
- C-M-r, C-cC-ee : eval region, extending it to definition boundaries
- 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
(save-excursion
(beginning-of-line)
(when (> (fuel-syntax--brackets-depth) 0)
- (let ((op (fuel-syntax--brackets-start))
- (cl (fuel-syntax--brackets-end))
- (ln (line-number-at-pos)))
+ (let* ((op (fuel-syntax--brackets-start))
+ (cl (fuel-syntax--brackets-end))
+ (ln (line-number-at-pos))
+ (iop (fuel-syntax--indentation-at op)))
(when (> ln (line-number-at-pos op))
- (if (and (> cl 0) (= ln (line-number-at-pos cl)))
- (fuel-syntax--indentation-at op)
- (fuel-syntax--increased-indentation (fuel-syntax--indentation-at op))))))))
+ (if (and (> cl 0)
+ (= (- cl (point)) (current-indentation))
+ (= ln (line-number-at-pos cl)))
+ iop
+ (fuel-syntax--increased-indentation iop)))))))
(defun factor-mode--indent-definition ()
(save-excursion
" ")
len))
+(defsubst empty-string-p (str) (equal str ""))
+
(provide 'fuel-base)
;;; fuel-base.el ends here
--- /dev/null
+;;; fuel-connection.el -- asynchronous comms with the fuel listener
+
+;; Copyright (C) 2008 Jose Antonio Ortega Ruiz
+;; See http://factorcode.org/license.txt for BSD license.
+
+;; Author: Jose Antonio Ortega Ruiz <jao@gnu.org>
+;; Keywords: languages, fuel, factor
+;; Start date: Thu Dec 11, 2008 03:10
+
+;;; Comentary:
+
+;; Handling communications via a comint buffer running a factor
+;; listener.
+
+;;; Code:
+
+\f
+;;; Default connection:
+
+(make-variable-buffer-local
+ (defvar fuel-con--connection nil))
+
+(defun fuel-con--get-connection (buffer/proc)
+ (if (processp buffer/proc)
+ (fuel-con--get-connection (process-buffer buffer/proc))
+ (with-current-buffer buffer/proc
+ (or fuel-con--connection
+ (setq fuel-con--connection
+ (fuel-con--setup-connection buffer/proc))))))
+
+\f
+;;; Request and connection datatypes:
+
+(defun fuel-con--connection-queue-request (c r)
+ (let ((reqs (assoc :requests c)))
+ (setcdr reqs (append (cdr reqs) (list r)))))
+
+(defun fuel-con--make-request (str cont &optional sender-buffer)
+ (list :fuel-connection-request
+ (cons :id (random))
+ (cons :string str)
+ (cons :continuation cont)
+ (cons :buffer (or sender-buffer (current-buffer)))
+ (cons :output "")))
+
+(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)))
+
+(defun fuel-con--request-output (req &optional suffix)
+ (let ((cell (assoc :output req)))
+ (when suffix (setcdr cell (concat (cdr cell) suffix)))
+ (cdr cell)))
+
+(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 (cdr current)
+ (fuel-con--request-deactivated-p (cdr current)))
+ (fuel-con--connection-pop-request c)
+ (cdr current))))
+
+\f
+;;; Connection setup:
+
+(defun fuel-con--setup-connection (buffer)
+ (set-buffer buffer)
+ (let ((conn (fuel-con--make-connection buffer)))
+ (fuel-con--setup-comint)
+ (setq fuel-con--connection conn)))
+
+(defun fuel-con--setup-comint ()
+ (add-hook 'comint-redirect-filter-functions
+ 'fuel-con--comint-redirect-filter t t)
+ (add-hook 'comint-redirect-hook
+ 'fuel-con--comint-redirect-hook))
+
+\f
+;;; Logging:
+
+(defvar fuel-con--log-size 32000
+ "Maximum size of the Factor messages log.")
+
+(defvar fuel-con--log-verbose-p t
+ "Log level for Factor messages.")
+
+(define-derived-mode factor-messages-mode fundamental-mode "Factor Messages"
+ "Simple mode to log interactions with the factor listener"
+ (kill-all-local-variables)
+ (buffer-disable-undo)
+ (set (make-local-variable 'comint-redirect-subvert-readonly) t)
+ (add-hook 'after-change-functions
+ '(lambda (b e len)
+ (let ((inhibit-read-only t))
+ (when (> b fuel-con--log-size)
+ (delete-region (point-min) b))))
+ nil t)
+ (setq buffer-read-only t))
+
+(defun fuel-con--log-buffer ()
+ (or (get-buffer "*factor messages*")
+ (save-current-buffer
+ (set-buffer (get-buffer-create "*factor messages*"))
+ (factor-messages-mode)
+ (current-buffer))))
+
+(defun fuel-con--log-msg (type &rest args)
+ (with-current-buffer (fuel-con--log-buffer)
+ (let ((inhibit-read-only t))
+ (insert (format "\n%s: %s\n" type (apply 'format args))))))
+
+(defsubst fuel-con--log-warn (&rest args)
+ (apply 'fuel-con--log-msg 'WARNING args))
+
+(defsubst fuel-con--log-error (&rest args)
+ (apply 'fuel-con--log-msg 'ERROR args))
+
+(defsubst fuel-con--log-info (&rest args)
+ (if fuel-con--log-verbose-p (apply 'fuel-con--log-msg 'INFO args) ""))
+
+\f
+;;; Requests handling:
+
+(defun fuel-con--process-next (con)
+ (when (not (fuel-con--connection-current-request con))
+ (let* ((buffer (fuel-con--connection-buffer con))
+ (req (fuel-con--connection-pop-request con))
+ (str (and req (fuel-con--request-string req))))
+ (when (and buffer req str)
+ (set-buffer buffer)
+ (when fuel-con--log-verbose-p
+ (with-current-buffer (fuel-con--log-buffer)
+ (let ((inhibit-read-only t))
+ (fuel-con--log-info "<%s>: %s" (fuel-con--request-id req) str))))
+ (comint-redirect-send-command str (fuel-con--log-buffer) nil t)))))
+
+(defun fuel-con--process-completed-request (req)
+ (let ((str (fuel-con--request-output req))
+ (cont (fuel-con--request-continuation req))
+ (id (fuel-con--request-id req))
+ (rstr (fuel-con--request-string req))
+ (buffer (fuel-con--request-buffer req)))
+ (if (not cont)
+ (fuel-con--log-warn "<%s> Droping result for request %S (%s)"
+ id rstr str)
+ (condition-case cerr
+ (with-current-buffer (or buffer (current-buffer))
+ (funcall cont str)
+ (fuel-con--log-info "<%s>: processed\n\t%s" id str))
+ (error (fuel-con--log-error "<%s>: continuation failed %S \n\t%s"
+ id rstr cerr))))))
+
+(defun fuel-con--comint-redirect-filter (str)
+ (if (not fuel-con--connection)
+ (fuel-con--log-error "No connection in buffer (%s)" str)
+ (let ((req (fuel-con--connection-current-request fuel-con--connection)))
+ (if (not req) (fuel-con--log-error "No current request (%s)" str)
+ (fuel-con--request-output req str)
+ (fuel-con--log-info "<%s>: in progress" (fuel-con--request-id req)))))
+ ".\n")
+
+(defun fuel-con--comint-redirect-hook ()
+ (if (not fuel-con--connection)
+ (fuel-con--log-error "No connection in buffer")
+ (let ((req (fuel-con--connection-current-request fuel-con--connection)))
+ (if (not req) (fuel-con--log-error "No current request (%s)" str)
+ (fuel-con--process-completed-request req)
+ (fuel-con--connection-clean-current-request fuel-con--connection)))))
+
+\f
+;;; Message sending interface:
+
+(defun fuel-con--send-string (buffer/proc str cont &optional sender-buffer)
+ (save-current-buffer
+ (let ((con (fuel-con--get-connection buffer/proc)))
+ (unless con
+ (error "FUEL: couldn't find connection"))
+ (let ((req (fuel-con--make-request str cont sender-buffer)))
+ (fuel-con--connection-queue-request con req)
+ (fuel-con--process-next con)
+ req))))
+
+(defvar fuel-connection-timeout 30000
+ "Time limit, in msecs, blocking on synchronous evaluation requests")
+
+(defun fuel-con--send-string/wait (buffer/proc str cont &optional timeout sbuf)
+ (save-current-buffer
+ (let* ((con (fuel-con--get-connection buffer/proc))
+ (req (fuel-con--send-string buffer/proc str cont sbuf))
+ (id (and req (fuel-con--request-id req)))
+ (time (or timeout fuel-connection-timeout))
+ (step 2))
+ (when id
+ (while (and (> time 0)
+ (not (fuel-con--connection-completed-p con id)))
+ (sleep-for 0 step)
+ (setq time (- time step)))
+ (or (> time 0)
+ (fuel-con--request-deactivate req)
+ nil)))))
+
+\f
+(provide 'fuel-connection)
+;;; fuel-connection.el ends here
(buffer (if file (find-file-noselect file) (current-buffer))))
(with-current-buffer buffer
(fuel-debug--display-retort
- (fuel-eval--eval-string/context (format ":%s" n))
+ (fuel-eval--send/wait (fuel-eval--cmd/string (format ":%s" n)))
(format "Restart %s (%s) successful" n (nth (1- n) rs))))))))
(defun fuel-debug-show--compiler-info (info)
(error "%s information not available" info))
(message "Retrieving %s info ..." info)
(unless (fuel-debug--display-retort
- (fuel-eval--eval-string info) "" (fuel-debug--buffer-file))
+ (fuel-eval--send/wait (fuel-eval--cmd/string info))
+ "" (fuel-debug--buffer-file))
(error "Sorry, no %s info available" info))))
\f
\\{fuel-debug-mode-map}"
(interactive)
(kill-all-local-variables)
+ (buffer-disable-undo)
(setq major-mode 'factor-mode)
(setq mode-name "Fuel Debug")
(use-local-map fuel-debug-mode-map)
(fuel-debug--font-lock-setup)
(setq fuel-debug--file nil)
(setq fuel-debug--last-ret nil)
- (toggle-read-only 1)
+ (setq buffer-read-only t)
(run-hooks 'fuel-debug-mode-hook))
\f
-;;; fuel-eval.el --- utilities for communication with fuel-listener
+;;; fuel-eval.el --- evaluating Factor expressions
;; Copyright (C) 2008 Jose Antonio Ortega Ruiz
;; See http://factorcode.org/license.txt for BSD license.
;;; Commentary:
-;; Protocols for handling communications via a comint buffer running a
-;; factor listener.
+;; Protocols for sending evaluations to the Factor listener.
;;; Code:
(require 'fuel-base)
(require 'fuel-syntax)
+(require 'fuel-connection)
\f
-;;; Syncronous string sending:
-
-(defvar fuel-eval-log-max-length 16000)
-
-(defvar fuel-eval--default-proc-function nil)
-(defsubst fuel-eval--default-proc ()
- (and fuel-eval--default-proc-function
- (funcall fuel-eval--default-proc-function)))
-
-(defvar fuel-eval--proc nil)
-(defvar fuel-eval--log t)
-
-(defun fuel-eval--send-string (str)
- (let ((proc (or fuel-eval--proc (fuel-eval--default-proc))))
- (when proc
- (with-current-buffer (get-buffer-create "*factor messages*")
- (goto-char (point-max))
- (when (and (> fuel-eval-log-max-length 0)
- (> (point) fuel-eval-log-max-length))
- (erase-buffer))
- (when fuel-eval--log (insert "\n>> " (fuel--shorten-str str 256)))
- (newline)
- (let ((beg (point)))
- (comint-redirect-send-command-to-process str (current-buffer) proc nil t)
- (with-current-buffer (process-buffer proc)
- (while (not comint-redirect-completed) (sleep-for 0 1)))
- (goto-char beg)
- (current-buffer))))))
-
-\f
-;;; Evaluation protocol
+;;; Retort and retort-error datatypes:
(defsubst fuel-eval--retort-make (err result &optional output)
(list err result output))
(defsubst fuel-eval--retort-p (ret) (listp ret))
(defsubst fuel-eval--make-parse-error-retort (str)
- (fuel-eval--retort-make 'parse-retort-error nil str))
+ (fuel-eval--retort-make (cons 'fuel-parse-retort-error str) nil))
-(defun fuel-eval--parse-retort (buffer)
+(defun fuel-eval--parse-retort (str)
(save-current-buffer
- (set-buffer buffer)
(condition-case nil
- (read (current-buffer))
- (error (fuel-eval--make-parse-error-retort
- (buffer-substring-no-properties (point) (point-max)))))))
-
-(defsubst fuel-eval--send/retort (str)
- (fuel-eval--parse-retort (fuel-eval--send-string str)))
-
-(defsubst fuel-eval--eval-begin ()
- (fuel-eval--send/retort "fuel-begin-eval"))
-
-(defsubst fuel-eval--eval-end ()
- (fuel-eval--send/retort "fuel-begin-eval"))
-
-(defsubst fuel-eval--factor-array (strs)
- (format "V{ %S }" (mapconcat 'identity strs " ")))
-
-(defsubst fuel-eval--eval-strings (strs &optional no-restart)
- (let ((str (format "fuel-eval-%s %s fuel-eval"
- (if no-restart "non-restartable" "restartable")
- (fuel-eval--factor-array strs))))
- (fuel-eval--send/retort str)))
-
-(defsubst fuel-eval--eval-string (str &optional no-restart)
- (fuel-eval--eval-strings (list str) no-restart))
-
-(defun fuel-eval--eval-strings/context (strs &optional no-restart)
- (let ((usings (fuel-syntax--usings-update)))
- (fuel-eval--send/retort
- (format "fuel-eval-%s %s %S %s fuel-eval-in-context"
- (if no-restart "non-restartable" "restartable")
- (fuel-eval--factor-array strs)
- (or fuel-syntax--current-vocab "f")
- (if usings (fuel-eval--factor-array usings) "f")))))
-
-(defsubst fuel-eval--eval-string/context (str &optional no-restart)
- (fuel-eval--eval-strings/context (list str) no-restart))
-
-(defun fuel-eval--eval-region/context (begin end &optional no-restart)
- (let ((lines (split-string (buffer-substring-no-properties begin end)
- "[\f\n\r\v]+" t)))
- (when (> (length lines) 0)
- (fuel-eval--eval-strings/context lines no-restart))))
-
-\f
-;;; Error parsing
+ (let ((ret (car (read-from-string str))))
+ (if (fuel-eval--retort-p ret) ret (error)))
+ (error (fuel-eval--make-parse-error-retort str)))))
(defsubst fuel-eval--error-name (err) (car err))
(defsubst fuel-eval--error-line-text (err)
(nth 3 (fuel-eval--error-lexer-p err)))
+\f
+;;; String sending::
+
+(defvar fuel-eval-log-max-length 16000)
+
+(defvar fuel-eval--default-proc-function nil)
+(defsubst fuel-eval--default-proc ()
+ (and fuel-eval--default-proc-function
+ (funcall fuel-eval--default-proc-function)))
+
+(defvar fuel-eval--proc nil)
+
+(defvar fuel-eval--log t)
+
+(defvar fuel-eval--sync-retort nil)
+
+(defun fuel-eval--send/wait (str &optional timeout buffer)
+ (setq fuel-eval--sync-retort nil)
+ (fuel-con--send-string/wait (or fuel-eval--proc (fuel-eval--default-proc))
+ str
+ '(lambda (s)
+ (setq fuel-eval--sync-retort
+ (fuel-eval--parse-retort s)))
+ timeout
+ buffer)
+ fuel-eval--sync-retort)
+
+(defun fuel-eval--send (str cont &optional buffer)
+ (fuel-con--send-string (or fuel-eval--proc (fuel-eval--default-proc))
+ str
+ `(lambda (s) (,cont (fuel-eval--parse-retort s)))
+ buffer))
+
+\f
+;;; Evaluation protocol
+
+(defsubst fuel-eval--factor-array (strs)
+ (format "V{ %S }" (mapconcat 'identity strs " ")))
+
+(defun fuel-eval--cmd/lines (strs &optional no-rs in usings)
+ (unless (and in usings) (fuel-syntax--usings-update))
+ (let* ((in (cond ((not in) (or fuel-syntax--current-vocab "f"))
+ ((eq in t) "fuel-scratchpad")
+ (in in)))
+ (usings (cond ((not usings) fuel-syntax--usings)
+ ((eq usings t) nil)
+ (usings usings))))
+ (format "fuel-eval-%srestartable %s %S %s fuel-eval-in-context"
+ (if no-rs "non-" "")
+ (fuel-eval--factor-array strs)
+ in
+ (fuel-eval--factor-array usings))))
+
+(defsubst fuel-eval--cmd/string (str &optional no-rs in usings)
+ (fuel-eval--cmd/lines (list str) no-rs in usings))
+
+(defun fuel-eval--cmd/region (begin end &optional no-rs in usings)
+ (let ((lines (split-string (buffer-substring-no-properties begin end)
+ "[\f\n\r\v]+" t)))
+ (when (> (length lines) 0)
+ (fuel-eval--cmd/lines lines no-rs in usings))))
+
+
\f
(provide 'fuel-eval)
;;; fuel-eval.el ends here
(,fuel-syntax--type-definition-regex 2 'factor-font-lock-type-name)
(,fuel-syntax--method-definition-regex (1 'factor-font-lock-type-name)
(2 'factor-font-lock-word))
- (,fuel-syntax--parent-type-regex 1 'factor-font-lock-type)
+ (,fuel-syntax--parent-type-regex 1 'factor-font-lock-type-name)
(,fuel-syntax--constructor-regex . 'factor-font-lock-constructor)
(,fuel-syntax--setter-regex . 'factor-font-lock-setter-word)
(,fuel-syntax--symbol-definition-regex 2 'factor-font-lock-symbol)
:type 'hook
:group 'fuel-help)
+(defcustom fuel-help-history-cache-size 50
+ "Maximum number of pages to keep in the help browser cache."
+ :type 'integer
+ :group 'fuel-help)
+
(defface fuel-help-font-lock-headlines '((t (:bold t :weight bold)))
"Face for headlines in help buffers."
:group 'fuel-help
(let ((word (or word (fuel-syntax-symbol-at-point)))
(fuel-eval--log t))
(when word
- (let ((ret (fuel-eval--eval-string/context
- (format "\\ %s synopsis fuel-eval-set-result" word)
- t)))
- (when (not (fuel-eval--retort-error ret))
+ (let* ((str (format "\\ %s synopsis fuel-eval-set-result" word))
+ (cmd (fuel-eval--cmd/string str t t))
+ (ret (fuel-eval--send/wait cmd 20)))
+ (when (and ret (not (fuel-eval--retort-error ret)))
(if fuel-help-minibuffer-font-lock
(fuel-help--font-lock-str (fuel-eval--retort-result ret))
(fuel-eval--retort-result ret)))))))
(message "Fuel Autodoc %s" (if fuel-autodoc-mode "enabled" "disabled")))
\f
-;;;; Factor help mode:
-
-(defvar fuel-help-mode-map (make-sparse-keymap)
- "Keymap for Factor help mode.")
-
-(define-key fuel-help-mode-map [(return)] 'fuel-help)
-
-(defconst fuel-help--headlines
- (regexp-opt '("Class description"
- "Definition"
- "Examples"
- "Generic word contract"
- "Inputs and outputs"
- "Methods"
- "Notes"
- "Parent topics:"
- "See also"
- "Syntax"
- "Vocabulary"
- "Warning"
- "Word description")
- t))
+;;; Help browser history:
-(defconst fuel-help--headlines-regexp (format "^%s" fuel-help--headlines))
+(defvar fuel-help--history
+ (list nil
+ (make-ring fuel-help-history-cache-size)
+ (make-ring fuel-help-history-cache-size)))
-(defconst fuel-help--font-lock-keywords
- `(,@fuel-font-lock--font-lock-keywords
- (,fuel-help--headlines-regexp . 'fuel-help-font-lock-headlines)))
+(defvar fuel-help--history-idx 0)
-(defun fuel-help-mode ()
- "Major mode for displaying Factor documentation.
-\\{fuel-help-mode-map}"
- (interactive)
- (kill-all-local-variables)
- (use-local-map fuel-help-mode-map)
- (setq mode-name "Factor Help")
- (setq major-mode 'fuel-help-mode)
+(defun fuel-help--history-push (term)
+ (when (car fuel-help--history)
+ (ring-insert (nth 1 fuel-help--history) (car fuel-help--history)))
+ (setcar fuel-help--history term))
- (fuel-font-lock--font-lock-setup fuel-help--font-lock-keywords t)
+(defun fuel-help--history-next ()
+ (when (not (ring-empty-p (nth 2 fuel-help--history)))
+ (when (car fuel-help--history)
+ (ring-insert (nth 1 fuel-help--history) (car fuel-help--history)))
+ (setcar fuel-help--history (ring-remove (nth 2 fuel-help--history) 0))))
- (set (make-local-variable 'view-no-disable-on-exit) t)
- (view-mode)
- (setq view-exit-action
- (lambda (buffer)
- ;; Use `with-current-buffer' to make sure that `bury-buffer'
- ;; also removes BUFFER from the selected window.
- (with-current-buffer buffer
- (bury-buffer))))
+(defun fuel-help--history-previous ()
+ (when (not (ring-empty-p (nth 1 fuel-help--history)))
+ (when (car fuel-help--history)
+ (ring-insert (nth 2 fuel-help--history) (car fuel-help--history)))
+ (setcar fuel-help--history (ring-remove (nth 1 fuel-help--history) 0))))
- (setq fuel-autodoc-mode-string "")
- (fuel-autodoc-mode)
- (run-mode-hooks 'fuel-help-mode-hook))
+\f
+;;; Fuel help buffer and internals:
(defun fuel-help--help-buffer ()
(with-current-buffer (get-buffer-create "*fuel-help*")
(fuel-help-mode)
(current-buffer)))
-(defvar fuel-help--history nil)
+(defvar fuel-help--prompt-history nil)
-(defun fuel-help--show-help (&optional see)
- (let* ((def (fuel-syntax-symbol-at-point))
+(defun fuel-help--show-help (&optional see word)
+ (let* ((def (or word (fuel-syntax-symbol-at-point)))
(prompt (format "See%s help on%s: " (if see " short" "")
(if def (format " (%s)" def) "")))
(ask (or (not (memq major-mode '(factor-mode fuel-help-mode)))
(not def)
fuel-help-always-ask))
- (def (if ask (read-string prompt nil 'fuel-help--history def) def))
- (cmd (format "\\ %s %s" def (if see "see" "help")))
- (fuel-eval--log nil)
- (ret (fuel-eval--eval-string/context cmd t))
- (out (fuel-eval--retort-output ret)))
+ (def (if ask (read-string prompt nil 'fuel-help--prompt-history def)
+ def))
+ (cmd (format "\\ %s %s" def (if see "see" "help"))))
+ (message "Looking up '%s' ..." def)
+ (fuel-eval--send (fuel-eval--cmd/string cmd t t)
+ `(lambda (r) (fuel-help--show-help-cont ,def r)))))
+
+(defun fuel-help--show-help-cont (def ret)
+ (let ((out (fuel-eval--retort-output ret)))
(if (or (fuel-eval--retort-error ret) (empty-string-p out))
(message "No help for '%s'" def)
- (let ((hb (fuel-help--help-buffer))
- (inhibit-read-only t)
- (font-lock-verbose nil))
- (set-buffer hb)
- (erase-buffer)
- (insert out)
- (set-buffer-modified-p nil)
- (pop-to-buffer hb)
- (goto-char (point-min))))))
+ (fuel-help--insert-contents def out))))
+
+(defun fuel-help--insert-contents (def str &optional nopush)
+ (let ((hb (fuel-help--help-buffer))
+ (inhibit-read-only t)
+ (font-lock-verbose nil))
+ (set-buffer hb)
+ (erase-buffer)
+ (insert str)
+ (goto-char (point-min))
+ (when (re-search-forward (format "^%s" def) nil t)
+ (beginning-of-line)
+ (kill-region (point-min) (point))
+ (next-line)
+ (open-line 1))
+ (set-buffer-modified-p nil)
+ (unless nopush (fuel-help--history-push (cons def str)))
+ (pop-to-buffer hb)
+ (goto-char (point-min))
+ (message "%s" def)))
\f
-;;; Interface: see/help commands
+;;; Interactive help commands:
(defun fuel-help-short (&optional arg)
"See a help summary of symbol at point.
(interactive)
(fuel-help--show-help))
+(defun fuel-help-next ()
+ "Go to next page in help browser."
+ (interactive)
+ (let ((item (fuel-help--history-next))
+ (fuel-help-always-ask nil))
+ (unless item
+ (error "No next page"))
+ (fuel-help--insert-contents (car item) (cdr item) t)))
+
+(defun fuel-help-previous ()
+ "Go to next page in help browser."
+ (interactive)
+ (let ((item (fuel-help--history-previous))
+ (fuel-help-always-ask nil))
+ (unless item
+ (error "No previous page"))
+ (fuel-help--insert-contents (car item) (cdr item) t)))
+
+\f
+;;;; Factor help mode:
+
+(defvar fuel-help-mode-map
+ (let ((map (make-sparse-keymap)))
+ (define-key map "\C-m" 'fuel-help)
+ (define-key map "q" 'bury-buffer)
+ (define-key map "b" 'fuel-help-previous)
+ (define-key map "f" 'fuel-help-next)
+ (define-key map (kbd "SPC") 'scroll-up)
+ (define-key map (kbd "S-SPC") 'scroll-down)
+ map))
+
+(defconst fuel-help--headlines
+ (regexp-opt '("Class description"
+ "Definition"
+ "Errors"
+ "Examples"
+ "Generic word contract"
+ "Inputs and outputs"
+ "Methods"
+ "Notes"
+ "Parent topics:"
+ "See also"
+ "Syntax"
+ "Variable description"
+ "Variable value"
+ "Vocabulary"
+ "Warning"
+ "Word description")
+ t))
+
+(defconst fuel-help--headlines-regexp (format "^%s" fuel-help--headlines))
+
+(defconst fuel-help--font-lock-keywords
+ `(,@fuel-font-lock--font-lock-keywords
+ (,fuel-help--headlines-regexp . 'fuel-help-font-lock-headlines)))
+
+(defun fuel-help-mode ()
+ "Major mode for browsing Factor documentation.
+\\{fuel-help-mode-map}"
+ (interactive)
+ (kill-all-local-variables)
+ (buffer-disable-undo)
+ (use-local-map fuel-help-mode-map)
+ (setq mode-name "Factor Help")
+ (setq major-mode 'fuel-help-mode)
+
+ (fuel-font-lock--font-lock-setup fuel-help--font-lock-keywords t)
+
+ (setq fuel-autodoc-mode-string "")
+ (fuel-autodoc-mode)
+
+ (run-mode-hooks 'fuel-help-mode-hook)
+ (setq buffer-read-only t))
+
\f
(provide 'fuel-help)
;;; fuel-help.el ends here
(comint-exec fuel-listener-buffer "factor"
factor nil `("-run=fuel" ,(format "-i=%s" image)))
(fuel-listener--wait-for-prompt 20)
- (fuel-eval--send-string "USE: fuel")
+ (fuel-eval--send/wait "USE: fuel")
(message "FUEL listener up and running!"))))
(defun fuel-listener--process (&optional start)
;;; Prompt chasing
(defun fuel-listener--wait-for-prompt (&optional timeout)
- (let ((proc (get-buffer-process fuel-listener-buffer))
- (seen))
- (with-current-buffer fuel-listener-buffer
- (while (progn (goto-char comint-last-input-end)
- (not (or seen
- (setq seen
- (re-search-forward comint-prompt-regexp nil t))
- (not (accept-process-output proc timeout))))))
- (goto-char (point-max)))
- (unless seen
+ (let ((proc (get-buffer-process fuel-listener-buffer)))
+ (with-current-buffer fuel-listener-buffer
+ (goto-char (or comint-last-input-end (point-min)))
+ (let ((seen (re-search-forward comint-prompt-regexp nil t)))
+ (while (and (not seen)
+ (accept-process-output proc (or timeout 10) nil t))
+ (sleep-for 0 1)
+ (goto-char comint-last-input-end)
+ (setq seen (re-search-forward comint-prompt-regexp nil t)))
(pop-to-buffer fuel-listener-buffer)
- (error "No prompt found!"))))
+ (goto-char (point-max))
+ (unless seen (error "No prompt found!"))))))
\f
;;; Interface: starting fuel listener
(set (make-local-variable 'comint-prompt-read-only) t)
(setq fuel-listener--compilation-begin nil))
+(define-key fuel-listener-mode-map "\C-cz" 'run-factor)
+(define-key fuel-listener-mode-map "\C-c\C-z" 'run-factor)
(define-key fuel-listener-mode-map "\C-ch" 'fuel-help)
(define-key fuel-listener-mode-map "\M-." 'fuel-edit-word-at-point)
(define-key fuel-listener-mode-map "\C-ck" 'fuel-run-file)
(let* ((file (or (and arg (read-file-name "File: " nil (buffer-file-name) t))
(buffer-file-name)))
(file (expand-file-name file))
- (buffer (find-file-noselect file))
- (cmd (format "%S fuel-run-file" file)))
+ (buffer (find-file-noselect file)))
(when buffer
(with-current-buffer buffer
(message "Compiling %s ..." file)
- (let ((r (fuel-debug--display-retort (fuel-eval--eval-string/context cmd)
- (format "%s successfully compiled" file)
- nil
- file)))
- (if r (message "Compiling %s ... OK!" file) (message "")))))))
+ (fuel-eval--send (fuel-eval--cmd/string (format "%S fuel-run-file" file))
+ `(lambda (r) (fuel--run-file-cont r ,file)))))))
+
+(defun fuel--run-file-cont (ret file)
+ (if (fuel-debug--display-retort ret
+ (format "%s successfully compiled" file)
+ nil
+ file)
+ (message "Compiling %s ... OK!" file)
+ (message "")))
(defun fuel-eval-region (begin end &optional arg)
"Sends region to Fuel's listener for evaluation.
buffer in case of errors."
(interactive "r\nP")
(fuel-debug--display-retort
- (fuel-eval--eval-region/context begin end)
+ (fuel-eval--send/wait (fuel-eval--cmd/region begin end) 10000)
(format "%s%s"
(if fuel-syntax--current-vocab
(format "IN: %s " fuel-syntax--current-vocab)
(unless (< begin end) (error "No evaluable definition around point"))
(fuel-eval-region begin end arg))))
+(defun fuel--try-edit (ret)
+ (let* ((err (fuel-eval--retort-error ret))
+ (loc (fuel-eval--retort-result ret)))
+ (when (or err (not loc) (not (listp loc)) (not (stringp (car loc))))
+ (error "Couldn't find edit location for '%s'" word))
+ (unless (file-readable-p (car loc))
+ (error "Couldn't open '%s' for read" (car loc)))
+ (find-file-other-window (car loc))
+ (goto-line (if (numberp (cadr loc)) (cadr loc) 1))))
+
(defun fuel-edit-word-at-point (&optional arg)
"Opens a new window visiting the definition of the word at point.
With prefix, asks for the word to edit."
(if word (format " (%s)" word) ""))
word)
word)))
- (let* ((ret (fuel-eval--eval-string/context
- (format "\\ %s fuel-get-edit-location" word)))
- (err (fuel-eval--retort-error ret))
- (loc (fuel-eval--retort-result ret)))
- (when (or err (not loc) (not (listp loc)) (not (stringp (car loc))))
- (error "Couldn't find edit location for '%s'" word))
- (unless (file-readable-p (car loc))
- (error "Couldn't open '%s' for read" (car loc)))
- (find-file-other-window (car loc))
- (goto-line (if (numberp (cadr loc)) (cadr loc) 1)))))
+ (let ((str (fuel-eval--cmd/string
+ (format "\\ %s fuel-get-edit-location" word))))
+ (condition-case nil
+ (fuel--try-edit (fuel-eval--send/wait str))
+ (error (fuel-edit-vocabulary word))))))
+
+(defvar fuel--vocabs-prompt-history nil)
+
+(defun fuel--read-vocabulary-name ()
+ (let* ((str (fuel-eval--cmd/string "fuel-get-vocabs" t "fuel" t))
+ (vocabs (fuel-eval--retort-result (fuel-eval--send/wait str)))
+ (prompt "Vocabulary name: "))
+ (if vocabs
+ (completing-read prompt vocabs nil t nil fuel--vocabs-prompt-history)
+ (read-string prompt nil fuel--vocabs-prompt-history))))
+
+(defun fuel-edit-vocabulary (vocab)
+ "Visits vocabulary file in Emacs.
+When called interactively, asks for vocabulary with completion."
+ (interactive (list (fuel--read-vocabulary-name)))
+ (let* ((str (fuel-eval--cmd/string
+ (format "%S fuel-get-vocab-location" vocab) t "fuel" t)))
+ (fuel--try-edit (fuel-eval--send/wait str))))
\f
;;; Minor mode definition:
(define-key fuel-mode-map "\C-\M-r" 'fuel-eval-extended-region)
(fuel-mode--key ?e ?e 'fuel-eval-extended-region)
+(fuel-mode--key ?e ?v 'fuel-edit-vocabulary)
+
(define-key fuel-mode-map "\M-." 'fuel-edit-word-at-point)
(fuel-mode--key ?d ?a 'fuel-autodoc-mode)
DLL_EXTENSION = .dylib
ifdef X11
- LIBS = -lm -framework Foundation $(X11_UI_LIBS) -Wl,-dylib_file,/System/Library/Frameworks/OpenGL.framework/Versions/A/Libraries/libGL.dylib:/System/Library/Frameworks/OpenGL.framework/Versions/A/Libraries/libGL.dylib
+ LIBS = -lm -framework Cocoa $(X11_UI_LIBS) -Wl,-dylib_file,/System/Library/Frameworks/OpenGL.framework/Versions/A/Libraries/libGL.dylib:/System/Library/Frameworks/OpenGL.framework/Versions/A/Libraries/libGL.dylib
else
LIBS = -lm -framework Cocoa -framework AppKit
endif
projects / factor.git / commitdiff