From 0b42f11683c5852e2b7072ccfb66fa76603eec4b Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Mon, 8 Dec 2008 19:30:10 -0800 Subject: [PATCH 01/64] cocoa backend for offscreen world rendering --- basis/cocoa/views/views.factor | 7 +++-- basis/ui/backend/backend.factor | 8 ++++-- basis/ui/cocoa/cocoa.factor | 49 +++++++++++++++++++++++++++------ 3 files changed, 52 insertions(+), 12 deletions(-) diff --git a/basis/cocoa/views/views.factor b/basis/cocoa/views/views.factor index be67f03184..f8e95dad40 100644 --- a/basis/cocoa/views/views.factor +++ b/basis/cocoa/views/views.factor @@ -55,8 +55,11 @@ PRIVATE> : with-multisample ( quot -- ) t +multisample+ pick with-variable ; inline -: ( -- pixelfmt ) + + +: ( attributes -- pixelfmt ) NSOpenGLPixelFormat -> alloc [ + % NSOpenGLPFAWindow , NSOpenGLPFADoubleBuffer , NSOpenGLPFADepthSize , 16 , @@ -74,7 +77,7 @@ PRIVATE> -> autorelease ; : ( class dim -- view ) - [ -> alloc 0 0 ] dip first2 + [ -> alloc 0 0 ] dip first2 { } -> initWithFrame:pixelFormat: dup 1 -> setPostsBoundsChangedNotifications: dup 1 -> setPostsFrameChangedNotifications: ; diff --git a/basis/ui/backend/backend.factor b/basis/ui/backend/backend.factor index 0840d07cbc..8d5109ac7f 100644 --- a/basis/ui/backend/backend.factor +++ b/basis/ui/backend/backend.factor @@ -17,11 +17,15 @@ HOOK: (open-window) ui-backend ( world -- ) HOOK: (close-window) ui-backend ( handle -- ) +HOOK: (open-offscreen-buffer) ui-backend ( world -- ) + +HOOK: (close-offscreen-buffer) ui-backend ( handle -- ) + HOOK: raise-window* ui-backend ( world -- ) -HOOK: select-gl-context ui-backend ( handle -- ) +GENERIC: select-gl-context ( handle -- ) -HOOK: flush-gl-context ui-backend ( handle -- ) +GENERIC: flush-gl-context ( handle -- ) HOOK: beep ui-backend ( -- ) diff --git a/basis/ui/cocoa/cocoa.factor b/basis/ui/cocoa/cocoa.factor index a9b3b03b75..8861f8ffa2 100644 --- a/basis/ui/cocoa/cocoa.factor +++ b/basis/ui/cocoa/cocoa.factor @@ -5,12 +5,19 @@ command-line kernel memory namespaces cocoa.messages cocoa.runtime cocoa.subclassing cocoa.pasteboard cocoa.types cocoa.windows cocoa.classes cocoa.application sequences system ui ui.backend ui.clipboards ui.gadgets ui.gadgets.worlds -ui.cocoa.views core-foundation threads math.geometry.rect fry ; +ui.cocoa.views core-foundation threads math.geometry.rect fry +libc generalizations ; IN: ui.cocoa -TUPLE: handle view window ; +TUPLE: handle ; +TUPLE: window-handle < handle view window ; +TUPLE: offscreen-handle < handle context buffer ; -C: handle +C: window-handle +C: offscreen-handle + +M: offscreen-handle window>> f ; +M: offscreen-handle view>> f ; SINGLETON: cocoa-ui-backend @@ -38,7 +45,8 @@ M: pasteboard set-clipboard-contents : gadget-window ( world -- ) dup 2dup swap world>NSRect - [ [ -> release ] [ install-window-delegate ] bi* ] [ ] 2bi + [ [ -> release ] [ install-window-delegate ] bi* ] + [ ] 2bi >>handle drop ; M: cocoa-ui-backend set-title ( string world -- ) @@ -87,11 +95,36 @@ M: cocoa-ui-backend raise-window* ( world -- ) NSApp 1 -> activateIgnoringOtherApps: ] when* ; -M: cocoa-ui-backend select-gl-context ( handle -- ) - view>> -> openGLContext -> makeCurrentContext ; +: pixel-size ( pixel-format -- size ) + 0 [ NSOpenGLPFAColorSize 0 -> getValues:forAttribute:forVirtualScreen: ] + keep *int -3 shift ; -M: cocoa-ui-backend flush-gl-context ( handle -- ) - view>> -> openGLContext -> flushBuffer ; +: offscreen-buffer ( world pixel-format -- alien w h pitch ) + [ dim>> first2 ] [ pixel-size ] bi* + { [ * * malloc ] [ 2drop ] [ drop nip ] [ nip * ] } cleave ; + +: gadget-offscreen-context ( world -- context buffer ) + { NSOpenGLPFAOffscreen } + [ NSOpenGLContext -> alloc swap f -> initWithFormat:shareContext: ] + [ offscreen-buffer ] bi + 4 npick [ setOffScreen:width:height:rowbytes: ] dip ; + +M: cocoa-ui-backend (open-offscreen-buffer) ( world -- ) + dup gadget-offscreen-context >>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 beep ( -- ) NSBeep ; From 02e961ac7750d7902f5858b54226b805aae46340 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Mon, 8 Dec 2008 21:00:47 -0800 Subject: [PATCH 02/64] cocoa ui compile fixes --- basis/cocoa/views/views.factor | 4 +--- basis/ui/cocoa/cocoa.factor | 14 +++++++------- 2 files changed, 8 insertions(+), 10 deletions(-) diff --git a/basis/cocoa/views/views.factor b/basis/cocoa/views/views.factor index f8e95dad40..dded68df4d 100644 --- a/basis/cocoa/views/views.factor +++ b/basis/cocoa/views/views.factor @@ -55,10 +55,8 @@ PRIVATE> : with-multisample ( quot -- ) t +multisample+ pick with-variable ; inline - - : ( attributes -- pixelfmt ) - NSOpenGLPixelFormat -> alloc [ + NSOpenGLPixelFormat -> alloc swap [ % NSOpenGLPFAWindow , NSOpenGLPFADoubleBuffer , diff --git a/basis/ui/cocoa/cocoa.factor b/basis/ui/cocoa/cocoa.factor index 811d35a8a1..e4fa95d08d 100644 --- a/basis/ui/cocoa/cocoa.factor +++ b/basis/ui/cocoa/cocoa.factor @@ -6,7 +6,7 @@ cocoa.runtime cocoa.subclassing cocoa.pasteboard cocoa.types cocoa.windows cocoa.classes cocoa.application sequences system ui ui.backend ui.clipboards ui.gadgets ui.gadgets.worlds ui.cocoa.views core-foundation threads math.geometry.rect fry -libc generalizations ; +libc generalizations alien.c-types cocoa.views combinators ; IN: ui.cocoa TUPLE: handle ; @@ -16,8 +16,8 @@ TUPLE: offscreen-handle < handle context buffer ; C: window-handle C: offscreen-handle -M: offscreen-handle window>> f ; -M: offscreen-handle view>> f ; +M: offscreen-handle window>> drop f ; +M: offscreen-handle view>> drop f ; SINGLETON: cocoa-ui-backend @@ -101,13 +101,13 @@ M: cocoa-ui-backend raise-window* ( world -- ) : offscreen-buffer ( world pixel-format -- alien w h pitch ) [ dim>> first2 ] [ pixel-size ] bi* - { [ * * malloc ] [ 2drop ] [ drop nip ] [ nip * ] } cleave ; + { [ * * malloc ] [ 2drop ] [ drop nip ] [ nip * ] } 3cleave ; : gadget-offscreen-context ( world -- context buffer ) - { NSOpenGLPFAOffscreen } - [ NSOpenGLContext -> alloc swap f -> initWithFormat:shareContext: ] + { NSOpenGLPFAOffScreen } + [ NSOpenGLContext -> alloc swap f -> initWithFormat:shareContext: dup ] [ offscreen-buffer ] bi - 4 npick [ setOffScreen:width:height:rowbytes: ] dip ; + 4 npick [ -> setOffScreen:width:height:rowbytes: ] dip ; M: cocoa-ui-backend (open-offscreen-buffer) ( world -- ) dup gadget-offscreen-context >>handle drop ; From 4307234550b1a03ea79b26bd88b5e3092f24b290 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Mon, 8 Dec 2008 23:13:26 -0800 Subject: [PATCH 03/64] literals vocab. you can interpolate CONSTANT-WORD values into a literal sequence with { $ CONSTANT-WORD } . --- extra/literals/literals-tests.factor | 12 ++++++++++++ extra/literals/literals.factor | 4 ++++ 2 files changed, 16 insertions(+) create mode 100644 extra/literals/literals-tests.factor create mode 100644 extra/literals/literals.factor diff --git a/extra/literals/literals-tests.factor b/extra/literals/literals-tests.factor new file mode 100644 index 0000000000..b88a286a59 --- /dev/null +++ b/extra/literals/literals-tests.factor @@ -0,0 +1,12 @@ +USING: kernel literals tools.test ; +IN: literals.tests + +<< +: five 5 ; +: seven-eleven 7 11 ; +: six-six-six 6 6 6 ; +>> + +[ { 5 } ] [ { $ five } ] unit-test +[ { 7 11 } ] [ { $ seven-eleven } ] unit-test +[ { 6 6 6 } ] [ { $ six-six-six } ] unit-test diff --git a/extra/literals/literals.factor b/extra/literals/literals.factor new file mode 100644 index 0000000000..d46f492cd4 --- /dev/null +++ b/extra/literals/literals.factor @@ -0,0 +1,4 @@ +USING: continuations kernel parser words ; +IN: literals + +: $ scan-word [ execute ] curry with-datastack ; parsing From ec98a6c83db990301c44cfc902a35c494e7a69e7 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Tue, 9 Dec 2008 09:22:23 -0800 Subject: [PATCH 04/64] offscreen-world widgets and offscreen pixel format fixes --- basis/cocoa/views/views.factor | 5 ++-- basis/ui/cocoa/cocoa.factor | 7 +++--- basis/ui/gadgets/worlds/worlds.factor | 11 +++++++-- basis/ui/ui.factor | 33 ++++++++++++++++++--------- extra/graphics/bitmap/bitmap.factor | 8 +++++++ 5 files changed, 45 insertions(+), 19 deletions(-) diff --git a/basis/cocoa/views/views.factor b/basis/cocoa/views/views.factor index dded68df4d..03cafd0a0a 100644 --- a/basis/cocoa/views/views.factor +++ b/basis/cocoa/views/views.factor @@ -58,8 +58,6 @@ PRIVATE> : ( attributes -- pixelfmt ) NSOpenGLPixelFormat -> alloc swap [ % - NSOpenGLPFAWindow , - NSOpenGLPFADoubleBuffer , NSOpenGLPFADepthSize , 16 , +software-renderer+ get [ NSOpenGLPFARendererID , kCGLRendererGenericFloatID , @@ -75,7 +73,8 @@ PRIVATE> -> autorelease ; : ( class dim -- view ) - [ -> alloc 0 0 ] dip first2 { } + [ -> alloc 0 0 ] dip first2 + NSOpenGLPFAWindow NSOpenGLPFADoubleBuffer 2array -> initWithFrame:pixelFormat: dup 1 -> setPostsBoundsChangedNotifications: dup 1 -> setPostsFrameChangedNotifications: ; diff --git a/basis/ui/cocoa/cocoa.factor b/basis/ui/cocoa/cocoa.factor index e4fa95d08d..cafe928b3c 100644 --- a/basis/ui/cocoa/cocoa.factor +++ b/basis/ui/cocoa/cocoa.factor @@ -16,6 +16,7 @@ TUPLE: offscreen-handle < handle context buffer ; C: window-handle C: offscreen-handle +! XXX gross! M: offscreen-handle window>> drop f ; M: offscreen-handle view>> drop f ; @@ -104,9 +105,9 @@ M: cocoa-ui-backend raise-window* ( world -- ) { [ * * malloc ] [ 2drop ] [ drop nip ] [ nip * ] } 3cleave ; : gadget-offscreen-context ( world -- context buffer ) - { NSOpenGLPFAOffScreen } - [ NSOpenGLContext -> alloc swap f -> initWithFormat:shareContext: dup ] - [ offscreen-buffer ] bi + NSOpenGLPFAOffScreen 1array + [ 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 -- ) diff --git a/basis/ui/gadgets/worlds/worlds.factor b/basis/ui/gadgets/worlds/worlds.factor index 68a2a18210..d442e16ac4 100644 --- a/basis/ui/gadgets/worlds/worlds.factor +++ b/basis/ui/gadgets/worlds/worlds.factor @@ -13,6 +13,8 @@ title status fonts handle window-loc ; +TUPLE: offscreen-world < world ; + : find-world ( gadget -- world/f ) [ world? ] find-parent ; : show-status ( string/f gadget -- ) @@ -38,8 +40,8 @@ M: world request-focus-on ( child gadget -- ) 2dup eq? [ 2drop ] [ dup focused?>> (request-focus) ] if ; -: ( gadget title status -- world ) - { 0 1 } world new-track +: new-world ( gadget title status class -- world ) + { 0 1 } swap new-track t >>root? t >>active? H{ } clone >>fonts @@ -49,6 +51,11 @@ M: world request-focus-on ( child gadget -- ) swap 1 track-add dup request-focus ; +: ( gadget title status -- world ) + world new-world ; +: ( gadget title status -- world ) + offscreen-world new-world ; + M: world layout* dup call-next-method dup glass>> [ diff --git a/basis/ui/ui.factor b/basis/ui/ui.factor index de2eb71307..3674f48efe 100644 --- a/basis/ui/ui.factor +++ b/basis/ui/ui.factor @@ -60,23 +60,34 @@ SYMBOL: stop-after-last-window? focus-path f swap focus-gestures ; M: world graft* - dup (open-window) - dup title>> over set-title - request-focus ; + [ (open-window) ] + [ [ title>> ] keep set-title ] + [ request-focus ] tri ; : reset-world ( world -- ) #! This is used when a window is being closed, but also #! when restoring saved worlds on image startup. - dup fonts>> clear-assoc - dup unfocus-world - f >>handle drop ; + [ fonts>> clear-assoc ] + [ unfocus-world ] + [ f >>handle drop ] tri ; + +: (ungraft-world) ( world -- ) + [ free-fonts ] + [ hand-clicked close-global ] + [ hand-gadget close-global ] tri ; M: world ungraft* - dup free-fonts - dup hand-clicked close-global - dup hand-gadget close-global - dup handle>> (close-window) - reset-world ; + [ (ungraft-world) ] + [ handle>> (close-window) ] + [ reset-world ] tri ; + +M: offscreen-world graft* + (open-offscreen-buffer) ; + +M: offscreen-world ungraft* + [ (ungraft-world) ] + [ handle>> (close-offscreen-buffer) ] + [ reset-world ] tri ; : find-window ( quot -- world ) windows get values diff --git a/extra/graphics/bitmap/bitmap.factor b/extra/graphics/bitmap/bitmap.factor index 4c35e3d7d0..e3191b3866 100755 --- a/extra/graphics/bitmap/bitmap.factor +++ b/extra/graphics/bitmap/bitmap.factor @@ -23,6 +23,14 @@ TUPLE: bitmap magic size reserved offset header-length width swap [ >>array ] [ >>color-index ] bi 24 >>bit-count ; +: bgra>bitmap ( array height width -- bitmap ) + bitmap new + 2over * 4 * >>size-image + swap >>height + swap >>width + swap [ >>array ] [ >>color-index ] bi + 32 >>bit-count ; + : 8bit>array ( bitmap -- array ) [ rgb-quads>> 4 [ 3 head-slice ] map ] [ color-index>> >array ] bi [ swap nth ] with map concat ; From c861ed9e2c4f00e6770df5d370e19670a6b958f1 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Tue, 9 Dec 2008 09:30:05 -0800 Subject: [PATCH 05/64] reenable BGRA case in draw-image --- extra/graphics/bitmap/bitmap.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extra/graphics/bitmap/bitmap.factor b/extra/graphics/bitmap/bitmap.factor index e3191b3866..ae37ef0c5c 100755 --- a/extra/graphics/bitmap/bitmap.factor +++ b/extra/graphics/bitmap/bitmap.factor @@ -132,7 +132,7 @@ M: bitmap draw-image ( bitmap -- ) [ [ height>> abs ] keep bit-count>> { - ! { 32 [ GL_BGRA GL_UNSIGNED_INT_8_8_8_8 ] } ! broken + { 32 [ GL_BGRA GL_UNSIGNED_BYTE ] } { 24 [ GL_BGR GL_UNSIGNED_BYTE ] } { 8 [ GL_BGR GL_UNSIGNED_BYTE ] } { 4 [ GL_BGR GL_UNSIGNED_BYTE ] } From 98c0daae2a7d9aed759b81e005c3ff561420810a Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Tue, 9 Dec 2008 10:07:57 -0800 Subject: [PATCH 06/64] Move offscreen-world widget and support words into ui.offscreen vocab --- basis/ui/backend/backend.factor | 2 ++ basis/ui/cocoa/cocoa.factor | 17 ++++++++--------- basis/ui/ui.factor | 8 -------- extra/ui/offscreen/offscreen.factor | 24 ++++++++++++++++++++++++ 4 files changed, 34 insertions(+), 17 deletions(-) create mode 100644 extra/ui/offscreen/offscreen.factor diff --git a/basis/ui/backend/backend.factor b/basis/ui/backend/backend.factor index 8d5109ac7f..7b808bb2be 100644 --- a/basis/ui/backend/backend.factor +++ b/basis/ui/backend/backend.factor @@ -27,6 +27,8 @@ GENERIC: select-gl-context ( handle -- ) GENERIC: flush-gl-context ( handle -- ) +GENERIC: offscreen-pixels ( handle -- alien ) + HOOK: beep ui-backend ( -- ) : with-gl-context ( handle quot -- ) diff --git a/basis/ui/cocoa/cocoa.factor b/basis/ui/cocoa/cocoa.factor index cafe928b3c..6e19f3ffe6 100644 --- a/basis/ui/cocoa/cocoa.factor +++ b/basis/ui/cocoa/cocoa.factor @@ -16,10 +16,6 @@ TUPLE: offscreen-handle < handle context buffer ; C: window-handle C: offscreen-handle -! XXX gross! -M: offscreen-handle window>> drop f ; -M: offscreen-handle view>> drop f ; - SINGLETON: cocoa-ui-backend M: cocoa-ui-backend do-events ( -- ) @@ -117,15 +113,18 @@ 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>> ; +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 ; + (gl-context) -> makeCurrentContext ; M: handle flush-gl-context ( handle -- ) - gl-context -> flushBuffer ; + (gl-context) -> flushBuffer ; + +M: offscreen-handle offscreen-pixels ( handle -- alien ) + buffer>> ; M: cocoa-ui-backend beep ( -- ) NSBeep ; diff --git a/basis/ui/ui.factor b/basis/ui/ui.factor index 3674f48efe..cf2a657439 100644 --- a/basis/ui/ui.factor +++ b/basis/ui/ui.factor @@ -81,14 +81,6 @@ M: world ungraft* [ handle>> (close-window) ] [ reset-world ] tri ; -M: offscreen-world graft* - (open-offscreen-buffer) ; - -M: offscreen-world ungraft* - [ (ungraft-world) ] - [ handle>> (close-offscreen-buffer) ] - [ reset-world ] tri ; - : find-window ( quot -- world ) windows get values [ gadget-child swap call ] with find-last nip ; inline diff --git a/extra/ui/offscreen/offscreen.factor b/extra/ui/offscreen/offscreen.factor new file mode 100644 index 0000000000..c246453082 --- /dev/null +++ b/extra/ui/offscreen/offscreen.factor @@ -0,0 +1,24 @@ +USING: accessors graphics.bitmap kernel math sequences +ui.gadgets ui.gadgets.worlds ui ui.backend ; +IN: ui.offscreen + +TUPLE: offscreen-world < 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 [ open-world-window ] keep ; + +: offscreen-world>bitmap ( world -- bitmap ) + [ handle>> offscreen-pixels ] [ dim>> first2 neg ] bi + bgra>bitmap ; + From 4f6ed727d0b1bd7ead23699d5c4d283a33774d80 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Tue, 9 Dec 2008 10:19:14 -0800 Subject: [PATCH 07/64] Tweak windows and x11 backends to work with changes made for offscreen rendering --- basis/ui/windows/windows.factor | 4 ++-- basis/ui/x11/x11.factor | 4 ++-- 2 files changed, 4 insertions(+), 4 deletions(-) diff --git a/basis/ui/windows/windows.factor b/basis/ui/windows/windows.factor index 1481287e95..f6f449625f 100755 --- a/basis/ui/windows/windows.factor +++ b/basis/ui/windows/windows.factor @@ -498,10 +498,10 @@ M: windows-ui-backend (open-window) ( world -- ) dupd (>>handle) hWnd>> show-window ; -M: windows-ui-backend select-gl-context ( handle -- ) +M: win select-gl-context ( handle -- ) [ hDC>> ] keep hRC>> wglMakeCurrent win32-error=0/f ; -M: windows-ui-backend flush-gl-context ( handle -- ) +M: win flush-gl-context ( handle -- ) hDC>> SwapBuffers win32-error=0/f ; ! Move window to front diff --git a/basis/ui/x11/x11.factor b/basis/ui/x11/x11.factor index b65236d1f9..6d6243449b 100755 --- a/basis/ui/x11/x11.factor +++ b/basis/ui/x11/x11.factor @@ -248,12 +248,12 @@ M: x11-ui-backend raise-window* ( world -- ) dpy get swap window>> XRaiseWindow drop ] when* ; -M: x11-ui-backend select-gl-context ( handle -- ) +M: x11-handle select-gl-context ( handle -- ) dpy get swap dup window>> swap glx>> glXMakeCurrent [ "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-ui-backend ui ( -- ) From c3c50d2cda143b8cb3e72472fcf992869d9c93cf Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Tue, 9 Dec 2008 14:50:54 -0800 Subject: [PATCH 08/64] suppress error when clicking the keyboard in key-caps --- extra/key-caps/key-caps.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extra/key-caps/key-caps.factor b/extra/key-caps/key-caps.factor index 0865b0ada2..05edb205d2 100755 --- a/extra/key-caps/key-caps.factor +++ b/extra/key-caps/key-caps.factor @@ -139,7 +139,7 @@ TUPLE: key-caps-gadget < gadget keys alarm ; : make-key-gadget ( scancode dim array -- ) [ swap [ - " " [ ] + " " [ drop ] swap [ first >>loc ] [ second >>dim ] bi ] [ execute ] bi* ] dip set-nth ; From a0618d46b930578baa3e17cb181db1122455496d Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Tue, 9 Dec 2008 15:27:30 -0800 Subject: [PATCH 09/64] do-offscreen combinator for managing resources while running a gadget offscreen. tweak bgr[a]>bitmap to copy the pixel memory --- extra/graphics/bitmap/bitmap.factor | 33 ++++++++++++++++------------- extra/ui/offscreen/offscreen.factor | 13 +++++++++--- 2 files changed, 28 insertions(+), 18 deletions(-) diff --git a/extra/graphics/bitmap/bitmap.factor b/extra/graphics/bitmap/bitmap.factor index ae37ef0c5c..9bb8db0f6d 100755 --- a/extra/graphics/bitmap/bitmap.factor +++ b/extra/graphics/bitmap/bitmap.factor @@ -4,32 +4,35 @@ USING: alien arrays byte-arrays combinators summary io.backend graphics.viewer io io.binary io.files kernel libc math math.functions math.bitwise namespaces opengl opengl.gl -prettyprint sequences strings ui ui.gadgets.panes -io.encodings.binary accessors grouping ; +prettyprint sequences strings ui ui.gadgets.panes fry +io.encodings.binary accessors grouping macros alien.c-types ; IN: graphics.bitmap -! Currently can only handle 24bit bitmaps. +! Currently can only handle 24/32bit bitmaps. ! Handles row-reversed bitmaps (their height is negative) TUPLE: bitmap magic size reserved offset header-length width height planes bit-count compression size-image x-pels y-pels color-used color-important rgb-quads color-index array ; +: (array-copy) ( bitmap array -- bitmap array' ) + over size-image>> abs memory>byte-array ; + +MACRO: (nbits>bitmap) ( bits -- ) + [ -3 shift ] keep '[ + bitmap new + 2over * _ * >>size-image + swap >>height + swap >>width + swap (array-copy) [ >>array ] [ >>color-index ] bi + _ >>bit-count + ] ; + : bgr>bitmap ( array height width -- bitmap ) - bitmap new - 2over * 3 * >>size-image - swap >>height - swap >>width - swap [ >>array ] [ >>color-index ] bi - 24 >>bit-count ; + 24 (nbits>bitmap) ; : bgra>bitmap ( array height width -- bitmap ) - bitmap new - 2over * 4 * >>size-image - swap >>height - swap >>width - swap [ >>array ] [ >>color-index ] bi - 32 >>bit-count ; + 32 (nbits>bitmap) ; : 8bit>array ( bitmap -- array ) [ rgb-quads>> 4 [ 3 head-slice ] map ] diff --git a/extra/ui/offscreen/offscreen.factor b/extra/ui/offscreen/offscreen.factor index c246453082..9fe8577a52 100644 --- a/extra/ui/offscreen/offscreen.factor +++ b/extra/ui/offscreen/offscreen.factor @@ -1,5 +1,5 @@ -USING: accessors graphics.bitmap kernel math sequences -ui.gadgets ui.gadgets.worlds ui ui.backend ; +USING: accessors continuations graphics.bitmap kernel math +sequences ui.gadgets ui.gadgets.worlds ui ui.backend ; IN: ui.offscreen TUPLE: offscreen-world < world ; @@ -16,9 +16,16 @@ M: offscreen-world ungraft* [ reset-world ] tri ; : open-offscreen ( gadget -- world ) - "" f [ open-world-window ] keep ; + "" f [ open-world-window ] keep + notify-queued ; + +: close-offscreen ( world -- ) + ungraft notify-queued ; : offscreen-world>bitmap ( world -- bitmap ) [ handle>> offscreen-pixels ] [ dim>> first2 neg ] bi bgra>bitmap ; +: do-offscreen ( gadget quot: ( offscreen-world -- ) -- ) + [ open-offscreen ] dip + over [ slip ] [ close-offscreen ] [ ] cleanup ; From 347eb5647bc6c765911ff59d911a824ebf508535 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Tue, 9 Dec 2008 18:55:54 -0800 Subject: [PATCH 10/64] windows backend for ui.offscreen --- basis/ui/windows/windows.factor | 53 +++++++++++++++++++++++--- basis/windows/opengl32/opengl32.factor | 8 ++-- 2 files changed, 52 insertions(+), 9 deletions(-) diff --git a/basis/ui/windows/windows.factor b/basis/ui/windows/windows.factor index f6f449625f..e696c3fa6f 100755 --- a/basis/ui/windows/windows.factor +++ b/basis/ui/windows/windows.factor @@ -69,9 +69,11 @@ M: pasteboard set-clipboard-contents drop copy ; clipboard set-global selection set-global ; -! world-handle is a -TUPLE: win hWnd hDC hRC world title ; +TUPLE: win-base hDC hRC ; +TUPLE: win hWnd < win-base world title ; +TUPLE: win-offscreen < win-base hBitmap bits ; C: win +C: win-offscreen SYMBOLS: msg-obj class-name-ptr mouse-captured ; @@ -478,7 +480,7 @@ M: windows-ui-backend do-events f class-name-ptr set-global f msg-obj set-global ; -: setup-pixel-format ( hdc -- ) +: setup-pixel-format ( hdc flags -- ) 16 make-pfd [ ChoosePixelFormat dup win32-error=0/f ] 2keep swapd SetPixelFormat win32-error=0/f ; @@ -489,7 +491,7 @@ M: windows-ui-backend do-events [ wglMakeCurrent win32-error=0/f ] keep ; : setup-gl ( hwnd -- hDC hRC ) - get-dc dup setup-pixel-format dup get-rc ; + get-dc dup windowed-pfd-dwFlags setup-pixel-format dup get-rc ; M: windows-ui-backend (open-window) ( world -- ) [ create-window dup setup-gl ] keep @@ -498,12 +500,51 @@ M: windows-ui-backend (open-window) ( world -- ) dupd (>>handle) hWnd>> show-window ; -M: win select-gl-context ( handle -- ) +M: win-base select-gl-context ( handle -- ) [ hDC>> ] keep hRC>> wglMakeCurrent win32-error=0/f ; -M: win flush-gl-context ( handle -- ) +M: win-base flush-gl-context ( handle -- ) hDC>> SwapBuffers win32-error=0/f ; +: (bitmap-info) ( dim -- BITMAPINFO ) + "BITMAPINFO" [ + 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 swap 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 + swap (bitmap-info) DIB_RGB_COLORS f + [ 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 + >>handle drop ; +M: windows-ui-backend (close-offscreen-buffer) ( handle -- ) + [ hDC>> DeleteObject drop ] + [ hBitmap>> DeleteObject drop ] bi ; + +M: win-offscreen offscreen-pixels ( handle -- alien ) + bits>> ; + ! Move window to front M: windows-ui-backend raise-window* ( world -- ) handle>> [ diff --git a/basis/windows/opengl32/opengl32.factor b/basis/windows/opengl32/opengl32.factor index df09d9327a..c09b30164f 100644 --- a/basis/windows/opengl32/opengl32.factor +++ b/basis/windows/opengl32/opengl32.factor @@ -71,15 +71,17 @@ IN: windows.opengl32 : WGL_SWAP_UNDERLAY14 HEX: 20000000 ; inline : WGL_SWAP_UNDERLAY15 HEX: 40000000 ; inline -: pfd-dwFlags ( -- n ) +: windowed-pfd-dwFlags ( -- n ) { PFD_DRAW_TO_WINDOW PFD_SUPPORT_OPENGL PFD_DOUBLEBUFFER } flags ; +: offscreen-pfd-dwFlags ( -- n ) + { PFD_DRAW_TO_BITMAP PFD_SUPPORT_OPENGL PFD_SUPPORT_GDI } flags ; ! TODO: compare to http://www.nullterminator.net/opengl32.html -: make-pfd ( bits -- pfd ) +: make-pfd ( flags bits -- pfd ) "PIXELFORMATDESCRIPTOR" "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 From 3e587c2f89811e9434aa7d3fd7b95e1832312cb7 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Wed, 10 Dec 2008 00:31:57 -0600 Subject: [PATCH 11/64] gitter compilin' --- basis/ui/windows/windows.factor | 9 ++++----- basis/windows/gdi32/gdi32.factor | 16 ++++++++++++---- basis/windows/types/types.factor | 23 +++++++++++++++++++++++ 3 files changed, 39 insertions(+), 9 deletions(-) mode change 100644 => 100755 basis/windows/gdi32/gdi32.factor mode change 100644 => 100755 basis/windows/types/types.factor diff --git a/basis/ui/windows/windows.factor b/basis/ui/windows/windows.factor index ab895c10dd..145cba82a3 100755 --- a/basis/ui/windows/windows.factor +++ b/basis/ui/windows/windows.factor @@ -71,7 +71,7 @@ M: pasteboard set-clipboard-contents drop copy ; selection set-global ; TUPLE: win-base hDC hRC ; -TUPLE: win hWnd < win-base world title ; +TUPLE: win < win-base hWnd world title ; TUPLE: win-offscreen < win-base hBitmap bits ; C: win C: win-offscreen @@ -495,7 +495,7 @@ M: windows-ui-backend do-events 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 ] keep [ swap hWnd>> register-window ] 2keep dupd (>>handle) @@ -526,7 +526,7 @@ M: win-base flush-gl-context ( handle -- ) : make-offscreen-dc-and-bitmap ( dim -- hDC hBitmap bits ) f CreateCompatibleDC - swap (bitmap-info) DIB_RGB_COLORS f + dup rot (bitmap-info) DIB_RGB_COLORS f [ f 0 CreateDIBSection ] keep *void* [ 2dup SelectObject drop ] dip ; @@ -540,13 +540,12 @@ M: windows-ui-backend (open-offscreen-buffer) ( world -- ) dup dim>> setup-offscreen-gl >>handle drop ; M: windows-ui-backend (close-offscreen-buffer) ( handle -- ) - [ hDC>> DeleteObject drop ] + [ hDC>> DeleteDC drop ] [ hBitmap>> DeleteObject drop ] bi ; M: win-offscreen offscreen-pixels ( handle -- alien ) bits>> ; -! Move window to front M: windows-ui-backend raise-window* ( world -- ) handle>> [ hWnd>> SetFocus drop diff --git a/basis/windows/gdi32/gdi32.factor b/basis/windows/gdi32/gdi32.factor old mode 100644 new mode 100755 index b9ba51844c..2ccd6b39f4 --- a/basis/windows/gdi32/gdi32.factor +++ b/basis/windows/gdi32/gdi32.factor @@ -26,6 +26,14 @@ IN: windows.gdi32 : DC_BRUSH 18 ; inline : DC_PEN 19 ; inline +: BI_RGB 0 ; inline +: BI_RLE8 1 ; inline +: BI_RLE4 2 ; inline +: BI_BITFIELDS 3 ; inline + +: DIB_RGB_COLORS 0 ; inline +: DIB_PAL_COLORS 1 ; inline + LIBRARY: gdi32 ! FUNCTION: AbortPath @@ -75,13 +83,13 @@ FUNCTION: int ChoosePixelFormat ( HDC hDC, PFD* ppfd ) ; ! FUNCTION: CreateColorSpaceA ! FUNCTION: CreateColorSpaceW ! FUNCTION: CreateCompatibleBitmap -! FUNCTION: CreateCompatibleDC +FUNCTION: HDC CreateCompatibleDC ( HDC hdc ) ; ! FUNCTION: CreateDCA ! FUNCTION: CreateDCW ! FUNCTION: CreateDIBitmap ! FUNCTION: CreateDIBPatternBrush ! FUNCTION: CreateDIBPatternBrushPt -! FUNCTION: CreateDIBSection +FUNCTION: HBITMAP CreateDIBSection ( HDC hdc, BITMAPINFO* pbmi, UINT iUsage, void** ppvBits, HANDLE hSection, DWORD dwOffset ) ; ! FUNCTION: CreateDiscardableBitmap ! FUNCTION: CreateEllipticRgn ! FUNCTION: CreateEllipticRgnIndirect @@ -169,7 +177,7 @@ FUNCTION: HRGN CreateRectRgn ( int x, int y, int w, int h ) ; ! FUNCTION: DdEntry8 ! FUNCTION: DdEntry9 ! FUNCTION: DeleteColorSpace -! FUNCTION: DeleteDC +FUNCTION: BOOL DeleteDC ( HDC hdc ) ; ! FUNCTION: DeleteEnhMetaFile ! FUNCTION: DeleteMetaFile FUNCTION: BOOL DeleteObject ( HGDIOBJ hObject ) ; @@ -552,7 +560,7 @@ FUNCTION: HGDIOBJ GetStockObject ( int fnObject ) ; ! FUNCTION: SelectClipPath FUNCTION: int SelectClipRgn ( HDC hDC, HRGN hrgn ) ; ! FUNCTION: SelectFontLocal -! FUNCTION: SelectObject +FUNCTION: HGDIOBJ SelectObject ( HDC hdc, HGDIOBJ hgdiobj ) ; ! FUNCTION: SelectPalette ! FUNCTION: SetAbortProc ! FUNCTION: SetArcDirection diff --git a/basis/windows/types/types.factor b/basis/windows/types/types.factor old mode 100644 new mode 100755 index 63ee6627c4..8cc18d4039 --- a/basis/windows/types/types.factor +++ b/basis/windows/types/types.factor @@ -253,6 +253,29 @@ C-STRUCT: RECT ! { "BYTE[32]" "rgbReserved" } ! ; +C-STRUCT: BITMAPINFOHEADER + { "DWORD" "biSize" } + { "LONG" "biWidth" } + { "LONG" "biHeight" } + { "WORD" "biPlanes" } + { "WORD" "biBitCount" } + { "DWORD" "biCompression" } + { "DWORD" "biSizeImage" } + { "LONG" "biXPelsPerMeter" } + { "LONG" "biYPelsPerMeter" } + { "DWORD" "biClrUsed" } + { "DWORD" "biClrImportant" } ; + +C-STRUCT: RGBQUAD + { "BYTE" "rgbBlue" } + { "BYTE" "rgbGreen" } + { "BYTE" "rgbRed" } + { "BYTE" "rgbReserved" } ; + +C-STRUCT: BITMAPINFO + { "BITMAPINFOHEADER" "bmiHeader" } + { "RGBQUAD[1]" "bmiColors" } ; + TYPEDEF: void* LPPAINTSTRUCT TYPEDEF: void* PAINTSTRUCT From 6fd87b747c445a9736a2c68206320113f6ad3d2e Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Wed, 10 Dec 2008 00:55:33 -0600 Subject: [PATCH 12/64] windows offscreen tweaks --- basis/ui/windows/windows.factor | 4 ++-- basis/windows/opengl32/opengl32.factor | 2 +- 2 files changed, 3 insertions(+), 3 deletions(-) mode change 100644 => 100755 basis/windows/opengl32/opengl32.factor diff --git a/basis/ui/windows/windows.factor b/basis/ui/windows/windows.factor index 145cba82a3..23d4104778 100755 --- a/basis/ui/windows/windows.factor +++ b/basis/ui/windows/windows.factor @@ -482,7 +482,7 @@ M: windows-ui-backend do-events f msg-obj set-global ; : setup-pixel-format ( hdc flags -- ) - 16 make-pfd [ ChoosePixelFormat dup win32-error=0/f ] 2keep + 32 make-pfd [ ChoosePixelFormat dup win32-error=0/f ] 2keep swapd SetPixelFormat win32-error=0/f ; : get-dc ( hWnd -- hDC ) GetDC dup win32-error=0/f ; @@ -516,7 +516,7 @@ M: win-base flush-gl-context ( handle -- ) [ nip 1 swap set-BITMAPINFOHEADER-biPlanes ] [ nip 32 swap set-BITMAPINFOHEADER-biBitCount ] [ nip BI_RGB swap set-BITMAPINFOHEADER-biCompression ] - [ [ first2 * 4 * ] dip swap set-BITMAPINFOHEADER-biSizeImage ] + [ [ first2 * 4 * ] dip set-BITMAPINFOHEADER-biSizeImage ] [ nip 72 swap set-BITMAPINFOHEADER-biXPelsPerMeter ] [ nip 72 swap set-BITMAPINFOHEADER-biYPelsPerMeter ] [ nip 0 swap set-BITMAPINFOHEADER-biClrUsed ] diff --git a/basis/windows/opengl32/opengl32.factor b/basis/windows/opengl32/opengl32.factor old mode 100644 new mode 100755 index c09b30164f..63384e8858 --- a/basis/windows/opengl32/opengl32.factor +++ b/basis/windows/opengl32/opengl32.factor @@ -74,7 +74,7 @@ IN: windows.opengl32 : 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 PFD_SUPPORT_GDI } flags ; + { PFD_DRAW_TO_BITMAP PFD_SUPPORT_OPENGL } flags ; ! TODO: compare to http://www.nullterminator.net/opengl32.html : make-pfd ( flags bits -- pfd ) From cd0f46c6685093ef92747478f2f8c5d9c29288dc Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Wed, 10 Dec 2008 01:05:03 -0600 Subject: [PATCH 13/64] GdiFlush when selecting gl context to make offscreen rendering work --- basis/ui/windows/windows.factor | 3 ++- basis/windows/gdi32/gdi32.factor | 2 +- 2 files changed, 3 insertions(+), 2 deletions(-) diff --git a/basis/ui/windows/windows.factor b/basis/ui/windows/windows.factor index 23d4104778..ca5d77e9f9 100755 --- a/basis/ui/windows/windows.factor +++ b/basis/ui/windows/windows.factor @@ -502,7 +502,8 @@ M: windows-ui-backend (open-window) ( world -- ) hWnd>> show-window ; M: win-base select-gl-context ( handle -- ) - [ hDC>> ] keep hRC>> wglMakeCurrent win32-error=0/f ; + [ hDC>> ] keep hRC>> wglMakeCurrent win32-error=0/f + GdiFlush drop ; M: win-base flush-gl-context ( handle -- ) hDC>> SwapBuffers win32-error=0/f ; diff --git a/basis/windows/gdi32/gdi32.factor b/basis/windows/gdi32/gdi32.factor index 2ccd6b39f4..32e4f3cd8a 100755 --- a/basis/windows/gdi32/gdi32.factor +++ b/basis/windows/gdi32/gdi32.factor @@ -321,7 +321,7 @@ FUNCTION: BOOL DeleteObject ( HGDIOBJ hObject ) ; ! FUNCTION: GdiEntry8 ! FUNCTION: GdiEntry9 ! FUNCTION: GdiFixUpHandle -! FUNCTION: GdiFlush +FUNCTION: BOOL GdiFlush ( ) ; ! FUNCTION: GdiFullscreenControl ! FUNCTION: GdiGetBatchLimit ! FUNCTION: GdiGetCharDimensions From 3629b9e5bdfc7a0a1ef1cbf718c80c30aeecfd1a Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Wed, 10 Dec 2008 08:49:50 -0600 Subject: [PATCH 14/64] win32 offscreen refinements --- basis/ui/backend/backend.factor | 2 +- basis/ui/cocoa/cocoa.factor | 4 ++-- basis/ui/windows/windows.factor | 18 +++++++++++++++--- extra/ui/offscreen/offscreen.factor | 8 +++++--- 4 files changed, 23 insertions(+), 9 deletions(-) mode change 100644 => 100755 basis/ui/backend/backend.factor diff --git a/basis/ui/backend/backend.factor b/basis/ui/backend/backend.factor old mode 100644 new mode 100755 index 7b808bb2be..aa84419d64 --- a/basis/ui/backend/backend.factor +++ b/basis/ui/backend/backend.factor @@ -27,7 +27,7 @@ GENERIC: select-gl-context ( handle -- ) GENERIC: flush-gl-context ( handle -- ) -GENERIC: offscreen-pixels ( handle -- alien ) +HOOK: offscreen-pixels ui-backend ( world -- alien w h ) HOOK: beep ui-backend ( -- ) diff --git a/basis/ui/cocoa/cocoa.factor b/basis/ui/cocoa/cocoa.factor index 1338983164..b4025b72b2 100755 --- a/basis/ui/cocoa/cocoa.factor +++ b/basis/ui/cocoa/cocoa.factor @@ -123,8 +123,8 @@ M: handle select-gl-context ( handle -- ) M: handle flush-gl-context ( handle -- ) (gl-context) -> flushBuffer ; -M: offscreen-handle offscreen-pixels ( handle -- alien ) - buffer>> ; +M: cocoa-ui-backend offscreen-pixels ( world -- alien w h ) + [ handle>> buffer>> ] [ dim>> first2 neg ] ; M: cocoa-ui-backend beep ( -- ) NSBeep ; diff --git a/basis/ui/windows/windows.factor b/basis/ui/windows/windows.factor index ca5d77e9f9..8e60ad1bc5 100755 --- a/basis/ui/windows/windows.factor +++ b/basis/ui/windows/windows.factor @@ -6,7 +6,7 @@ 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 +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 @@ -544,8 +544,20 @@ M: windows-ui-backend (close-offscreen-buffer) ( handle -- ) [ hDC>> DeleteDC drop ] [ hBitmap>> DeleteObject drop ] bi ; -M: win-offscreen offscreen-pixels ( handle -- alien ) - bits>> ; +! 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>> [ diff --git a/extra/ui/offscreen/offscreen.factor b/extra/ui/offscreen/offscreen.factor index 779ecc0c31..33d4a92f37 100755 --- a/extra/ui/offscreen/offscreen.factor +++ b/extra/ui/offscreen/offscreen.factor @@ -23,9 +23,11 @@ M: offscreen-world ungraft* ungraft notify-queued ; : offscreen-world>bitmap ( world -- bitmap ) - [ handle>> offscreen-pixels ] [ dim>> first2 neg ] bi - bgra>bitmap ; + offscreen-pixels bgra>bitmap ; : do-offscreen ( gadget quot: ( offscreen-world -- ) -- ) [ open-offscreen ] dip - over [ slip ] [ close-offscreen ] [ ] cleanup ; + over [ slip ] [ close-offscreen ] [ ] cleanup ; inline + +: gadget>bitmap ( gadget -- bitmap ) + [ offscreen-world>bitmap ] do-offscreen ; From dc5727a212afe2d4fd93c36f492271ee98067ea5 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Wed, 10 Dec 2008 07:28:33 -0800 Subject: [PATCH 15/64] oops --- basis/ui/cocoa/cocoa.factor | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/basis/ui/cocoa/cocoa.factor b/basis/ui/cocoa/cocoa.factor index b4025b72b2..fecbb52a25 100755 --- a/basis/ui/cocoa/cocoa.factor +++ b/basis/ui/cocoa/cocoa.factor @@ -3,7 +3,7 @@ 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 sequences system +cocoa.windows cocoa.classes cocoa.nibs sequences system ui ui.backend ui.clipboards ui.gadgets ui.gadgets.worlds ui.cocoa.views core-foundation threads math.geometry.rect fry libc generalizations alien.c-types cocoa.views combinators ; @@ -124,7 +124,7 @@ M: handle flush-gl-context ( handle -- ) (gl-context) -> flushBuffer ; M: cocoa-ui-backend offscreen-pixels ( world -- alien w h ) - [ handle>> buffer>> ] [ dim>> first2 neg ] ; + [ handle>> buffer>> ] [ dim>> first2 neg ] bi ; M: cocoa-ui-backend beep ( -- ) NSBeep ; From 88856fac215a790ba27a7bc6a3855894a68d9e79 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Wed, 10 Dec 2008 12:22:17 -0800 Subject: [PATCH 16/64] OSX VM requires function from Cocoa framework, so link against it even when building for X11 --- vm/Config.macosx | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/vm/Config.macosx b/vm/Config.macosx index 54078cfe8d..e5aac32b54 100644 --- a/vm/Config.macosx +++ b/vm/Config.macosx @@ -6,7 +6,7 @@ PLAF_DLL_OBJS += vm/os-macosx.o vm/mach_signal.o 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 From e6145c71c0bb8e230f07f2f661db25476087f26e Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 10 Dec 2008 17:26:54 -0600 Subject: [PATCH 17/64] Change a -rot usage to 2dip --- core/sequences/sequences.factor | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/core/sequences/sequences.factor b/core/sequences/sequences.factor index e364359928..7bb509cb67 100644 --- a/core/sequences/sequences.factor +++ b/core/sequences/sequences.factor @@ -343,7 +343,7 @@ PRIVATE> [ (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 @@ -538,12 +538,12 @@ M: sequence <=> : 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 ; From e57b28b6e13066b13fe6450afb408af3d3f86488 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 10 Dec 2008 17:30:07 -0600 Subject: [PATCH 18/64] Check for signal exit status --- basis/io/launcher/launcher.factor | 2 +- basis/io/unix/launcher/launcher-tests.factor | 17 ++++++++++++++++- basis/io/unix/launcher/launcher.factor | 12 +++++++----- basis/unix/process/process.factor | 4 ++-- 4 files changed, 26 insertions(+), 9 deletions(-) diff --git a/basis/io/launcher/launcher.factor b/basis/io/launcher/launcher.factor index 0ed10e63c3..7bafb95376 100644 --- a/basis/io/launcher/launcher.factor +++ b/basis/io/launcher/launcher.factor @@ -157,7 +157,7 @@ M: process-failed error. process>> . ; : wait-for-success ( process -- ) - dup wait-for-process dup zero? + dup wait-for-process dup 0 = [ 2drop ] [ process-failed ] if ; : try-process ( desc -- ) diff --git a/basis/io/unix/launcher/launcher-tests.factor b/basis/io/unix/launcher/launcher-tests.factor index 33988c273b..68ca821ed4 100644 --- a/basis/io/unix/launcher/launcher-tests.factor +++ b/basis/io/unix/launcher/launcher-tests.factor @@ -2,7 +2,8 @@ IN: io.unix.launcher.tests 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 @@ -121,3 +122,17 @@ io.streams.duplex ; input-stream get contents ] with-stream ] unit-test + +! Killed processes were exiting with code 0 on FreeBSD +[ f ] [ + [let | p [ ] + s [ ] | + [ + "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 diff --git a/basis/io/unix/launcher/launcher.factor b/basis/io/unix/launcher/launcher.factor index e80a372aef..729c1545d8 100644 --- a/basis/io/unix/launcher/launcher.factor +++ b/basis/io/unix/launcher/launcher.factor @@ -92,14 +92,16 @@ M: unix kill-process* ( pid -- ) 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 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 ; diff --git a/basis/unix/process/process.factor b/basis/unix/process/process.factor index 175425f948..7d5f9eb330 100644 --- a/basis/unix/process/process.factor +++ b/basis/unix/process/process.factor @@ -74,7 +74,7 @@ FUNCTION: int setpriority ( int which, int who, int prio ) ; HEX: 7f bitand ; inline : WIFEXITED ( status -- ? ) - WTERMSIG zero? ; inline + WTERMSIG 0 = ; inline : WEXITSTATUS ( status -- value ) HEX: ff00 bitand -8 shift ; inline @@ -86,7 +86,7 @@ FUNCTION: int setpriority ( int which, int who, int prio ) ; HEX: 80 ; inline : WCOREDUMP ( status -- ? ) - WCOREFLAG bitand zero? not ; inline + WCOREFLAG bitand 0 = not ; inline : WIFSTOPPED ( status -- ? ) HEX: ff bitand HEX: 7f = ; inline From f86caab386b508eabd551a56f1f2e5afd6fe52ab Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 10 Dec 2008 17:33:29 -0600 Subject: [PATCH 19/64] Fix compile error --- basis/ui/x11/x11.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/basis/ui/x11/x11.factor b/basis/ui/x11/x11.factor index b4a0427ccd..563b98aa34 100755 --- a/basis/ui/x11/x11.factor +++ b/basis/ui/x11/x11.factor @@ -137,7 +137,7 @@ M: world focus-out-event M: world selection-notify-event [ handle>> window>> selection-from-event ] keep - world user-input ; + user-input ; : supported-type? ( atom -- ? ) { "UTF8_STRING" "STRING" "TEXT" } From 51ee6be0475045e8fc7bd4498af3120575a131d7 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 10 Dec 2008 19:16:49 -0600 Subject: [PATCH 20/64] Clarify wait-for-process docs --- basis/io/launcher/launcher-docs.factor | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/basis/io/launcher/launcher-docs.factor b/basis/io/launcher/launcher-docs.factor index 45bbec20e3..3585214735 100644 --- a/basis/io/launcher/launcher-docs.factor +++ b/basis/io/launcher/launcher-docs.factor @@ -143,8 +143,9 @@ HELP: { $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 } "." From cefdec0644294c91d204e628a7fa1ad2cf6a8e39 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 10 Dec 2008 19:35:18 -0600 Subject: [PATCH 21/64] Use udis on x86 --- .../disassembler/disassembler-docs.factor | 6 +- basis/tools/disassembler/disassembler.factor | 52 ++++------- basis/tools/disassembler/gdb/gdb.factor | 36 ++++++++ basis/tools/disassembler/gdb/tags.txt | 1 + basis/tools/disassembler/udis/udis.factor | 91 +++++++++++++++++++ 5 files changed, 148 insertions(+), 38 deletions(-) create mode 100644 basis/tools/disassembler/gdb/gdb.factor create mode 100644 basis/tools/disassembler/gdb/tags.txt create mode 100644 basis/tools/disassembler/udis/udis.factor diff --git a/basis/tools/disassembler/disassembler-docs.factor b/basis/tools/disassembler/disassembler-docs.factor index f03861a8ed..7d193d0aac 100644 --- a/basis/tools/disassembler/disassembler-docs.factor +++ b/basis/tools/disassembler/disassembler-docs.factor @@ -3,11 +3,11 @@ USING: help.markup help.syntax sequences.private ; HELP: disassemble { $values { "obj" "a word or a pair of addresses" } } -{ $description "Disassembles either a compiled word definition or an arbitrary memory range (in the case " { $snippet "obj" } " is a pair of integers) by attaching " { $snippet "gdb" } " to the Factor VM and capturing the output." } -{ $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." } ; +{ $description "Disassembles either a compiled word definition or an arbitrary memory range (in the case " { $snippet "obj" } " is a pair of integers)." } +{ $notes "In some cases the Factor compiler emits data inline with code, which can confuse the disassembler. This occurs in words which call " { $link dispatch } ", where the jump table addresses are compiled inline." } ; ARTICLE: "tools.disassembler" "Disassembling words" -"The " { $vocab-link "tools.disassembler" } " vocabulary integrates Factor with the GNU debugger (" { $snippet "gdb" } ") for viewing the assembly code generated by the compiler. It can be used on both Unix and Windows as long as a working copy of " { $snippet "gdb" } " is installed and available in the " { $snippet "PATH" } "." +"The " { $vocab-link "tools.disassembler" } " vocabulary provides support for disassembling compiled word definitions. It uses the " { $snippet "libudis86" } " library on x86-32 and x86-64, and " { $snippet "gdb" } " on PowerPC." { $subsection disassemble } ; ABOUT: "tools.disassembler" diff --git a/basis/tools/disassembler/disassembler.factor b/basis/tools/disassembler/disassembler.factor index 76e1f0f1b8..fac340845b 100644 --- a/basis/tools/disassembler/disassembler.factor +++ b/basis/tools/disassembler/disassembler.factor @@ -1,43 +1,25 @@ -! 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 ; 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 -- ) - -M: word make-disassemble-cmd - word-xt code-format - 2array make-disassemble-cmd ; - -M: pair make-disassemble-cmd - in-file ascii [ - "attach " write - current-process-handle number>string print - "disassemble " write - [ number>string write bl ] each - ] with-file-writer ; - -M: method-spec make-disassemble-cmd - first2 method make-disassemble-cmd ; - -: gdb-binary ( -- string ) "gdb" ; - -: run-gdb ( -- lines ) - - +closed+ >>stdin - out-file >>stdout - [ gdb-binary , "-x" , in-file , "-batch" , ] { } make >>command - try-process - out-file ascii file-lines ; +HOOK: disassemble* disassembler-backend ( from to -- lines ) TR: tabs>spaces "\t" "\s" ; -: disassemble ( obj -- ) - make-disassemble-cmd run-gdb - [ tabs>spaces ] map [ print ] each ; +M: pair disassemble first2 disassemble* [ tabs>spaces print ] each ; + +M: word disassemble word-xt 2array disassemble ; + +M: method-spec disassemble first2 method disassemble ; + +cpu { + { x86.32 [ "tools.disassembler.udis" ] } + { x86.64 [ "tools.disassembler.udis" ] } + { ppc [ "tools.disassembler.gdb" ] } +} case require diff --git a/basis/tools/disassembler/gdb/gdb.factor b/basis/tools/disassembler/gdb/gdb.factor new file mode 100644 index 0000000000..65d0e2f43a --- /dev/null +++ b/basis/tools/disassembler/gdb/gdb.factor @@ -0,0 +1,36 @@ +! Copyright (C) 2008 Slava Pestov, Jorge Acereda Macia. +! See http://factorcode.org/license.txt for BSD license. +USING: io.files io words alien kernel math.parser alien.syntax +io.launcher system assocs arrays sequences namespaces make +qualified system math io.encodings.ascii accessors +tools.disassembler ; +IN: tools.disassembler.gdb + +SINGLETON: gdb-disassembler + +: in-file ( -- path ) "gdb-in.txt" temp-file ; + +: out-file ( -- path ) "gdb-out.txt" temp-file ; + +: make-disassemble-cmd ( from to -- ) + in-file ascii [ + "attach " write + current-process-handle number>string print + "disassemble " write + [ number>string write bl ] bi@ + ] with-file-writer ; + +: gdb-binary ( -- string ) "gdb" ; + +: run-gdb ( -- lines ) + + +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 diff --git a/basis/tools/disassembler/gdb/tags.txt b/basis/tools/disassembler/gdb/tags.txt new file mode 100644 index 0000000000..6bf68304bb --- /dev/null +++ b/basis/tools/disassembler/gdb/tags.txt @@ -0,0 +1 @@ +unportable diff --git a/basis/tools/disassembler/udis/udis.factor b/basis/tools/disassembler/udis/udis.factor new file mode 100644 index 0000000000..113c07c8c3 --- /dev/null +++ b/basis/tools/disassembler/udis/udis.factor @@ -0,0 +1,91 @@ +! 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 + +<< : & scan "c-library" get load-library dlsym parsed ; parsing >> + +<< +"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" + 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 ] [ 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 ) + [ ] 2dip { + [ drop ud_set_pc ] + [ buf/len ud_set_input_buffer ] + [ 2drop (disassemble) format-disassembly ] + } 3cleave ; + +udis-disassembler disassembler-backend set-global From 2103c591e617d4edca1dadf919cb660642afb9cb Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 10 Dec 2008 19:36:07 -0600 Subject: [PATCH 22/64] Add unportable tag for tools.disassembler.udis --- basis/tools/disassembler/udis/tags.txt | 1 + 1 file changed, 1 insertion(+) create mode 100644 basis/tools/disassembler/udis/tags.txt diff --git a/basis/tools/disassembler/udis/tags.txt b/basis/tools/disassembler/udis/tags.txt new file mode 100644 index 0000000000..6bf68304bb --- /dev/null +++ b/basis/tools/disassembler/udis/tags.txt @@ -0,0 +1 @@ +unportable From f020fd39ec6d53e7838a998c352885c302813afa Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 10 Dec 2008 19:45:42 -0600 Subject: [PATCH 23/64] Fix ui.gestures help lint --- basis/ui/gestures/gestures-docs.factor | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/basis/ui/gestures/gestures-docs.factor b/basis/ui/gestures/gestures-docs.factor index 602d3fd425..5e7bd51bec 100644 --- a/basis/ui/gestures/gestures-docs.factor +++ b/basis/ui/gestures/gestures-docs.factor @@ -1,5 +1,5 @@ -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 @@ -22,8 +22,8 @@ HELP: propagate-gesture { $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." } ; +{ $values { "string" string } { "world" world } } +{ $description "Calls " { $link user-input* } " on every parent of the world's currently-focused child." } ; HELP: motion { $class-description "Mouse motion gesture." } From d327786cb9a3f5a287f7916d98dbe8c9d58d1af5 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 10 Dec 2008 20:10:47 -0600 Subject: [PATCH 24/64] kqueue and epoll code wasn't checking for EINTR properly, leading to hangs --- basis/io/unix/backend/backend.factor | 6 +++--- basis/io/unix/epoll/epoll.factor | 2 +- basis/io/unix/kqueue/kqueue.factor | 3 +-- 3 files changed, 5 insertions(+), 6 deletions(-) diff --git a/basis/io/unix/backend/backend.factor b/basis/io/unix/backend/backend.factor index 1666d60c83..7f4e03ef09 100644 --- a/basis/io/unix/backend/backend.factor +++ b/basis/io/unix/backend/backend.factor @@ -207,10 +207,10 @@ TUPLE: mx-port < port mx ; : ( mx -- port ) dup fd>> mx-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 ) diff --git a/basis/io/unix/epoll/epoll.factor b/basis/io/unix/epoll/epoll.factor index e8d33787f3..93d0b4aa99 100644 --- a/basis/io/unix/epoll/epoll.factor +++ b/basis/io/unix/epoll/epoll.factor @@ -49,7 +49,7 @@ M: epoll-mx remove-output-callbacks ( fd mx -- seq ) : 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 diff --git a/basis/io/unix/kqueue/kqueue.factor b/basis/io/unix/kqueue/kqueue.factor index b4e2b7af6f..be99d17572 100644 --- a/basis/io/unix/kqueue/kqueue.factor +++ b/basis/io/unix/kqueue/kqueue.factor @@ -58,8 +58,7 @@ M: kqueue-mx remove-output-callbacks ( fd mx -- seq ) [ [ 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 { From 537af9ed9b92ddb3ccd7c9a2ebd70b9409610ac2 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 10 Dec 2008 20:23:37 -0600 Subject: [PATCH 25/64] Fix docs again --- basis/ui/gadgets/worlds/worlds-docs.factor | 4 ++++ basis/ui/gestures/gestures-docs.factor | 4 ---- 2 files changed, 4 insertions(+), 4 deletions(-) diff --git a/basis/ui/gadgets/worlds/worlds-docs.factor b/basis/ui/gadgets/worlds/worlds-docs.factor index 35781fa568..60e4e58ed5 100644 --- a/basis/ui/gadgets/worlds/worlds-docs.factor +++ b/basis/ui/gadgets/worlds/worlds-docs.factor @@ -2,6 +2,10 @@ USING: ui.gadgets ui.render ui.gestures ui.backend help.markup 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." } ; diff --git a/basis/ui/gestures/gestures-docs.factor b/basis/ui/gestures/gestures-docs.factor index 5e7bd51bec..f6495a14c3 100644 --- a/basis/ui/gestures/gestures-docs.factor +++ b/basis/ui/gestures/gestures-docs.factor @@ -21,10 +21,6 @@ HELP: propagate-gesture { $values { "gesture" "a gesture" } { "gadget" gadget } } { $description "Calls " { $link handle-gesture } " on every parent of " { $snippet "gadget" } "." } ; -HELP: user-input -{ $values { "string" string } { "world" world } } -{ $description "Calls " { $link user-input* } " on every parent of the world's currently-focused child." } ; - HELP: motion { $class-description "Mouse motion gesture." } { $examples { $code "T{ motion }" } } ; From f849e41c7ec8e54eaed2a55ae5b182858278d81f Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 10 Dec 2008 20:23:37 -0600 Subject: [PATCH 26/64] Fix select MX --- basis/io/unix/select/select.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/basis/io/unix/select/select.factor b/basis/io/unix/select/select.factor index 27231aee5a..a6b61001a6 100644 --- a/basis/io/unix/select/select.factor +++ b/basis/io/unix/select/select.factor @@ -50,7 +50,7 @@ TUPLE: select-mx < mx read-fdset write-fdset ; 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 ; From 717bceb6ff68ba3014461ca83485f8dd508ce82e Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 10 Dec 2008 20:24:22 -0600 Subject: [PATCH 27/64] Use kqueue on BSD --- basis/io/unix/bsd/bsd.factor | 11 +++-------- basis/io/unix/macosx/macosx.factor | 5 +---- 2 files changed, 4 insertions(+), 12 deletions(-) diff --git a/basis/io/unix/bsd/bsd.factor b/basis/io/unix/bsd/bsd.factor index 50b4b610da..e1583478db 100644 --- a/basis/io/unix/bsd/bsd.factor +++ b/basis/io/unix/bsd/bsd.factor @@ -1,16 +1,11 @@ ! 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.kqueue ; +IN: io.unix.bsd M: bsd init-io ( -- ) - mx set-global ; -! kqueue-mx set-global -! kqueue-mx get-global -! dup io-task-fd -! [ mx get-global reads>> set-at ] -! [ mx get-global writes>> set-at ] 2bi ; + mx set-global ; ! M: bsd (monitor) ( path recursive? mailbox -- ) ! swap [ "Recursive kqueue monitors not supported" throw ] when diff --git a/basis/io/unix/macosx/macosx.factor b/basis/io/unix/macosx/macosx.factor index ef52b676fb..388d266b48 100644 --- a/basis/io/unix/macosx/macosx.factor +++ b/basis/io/unix/macosx/macosx.factor @@ -1,10 +1,7 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. IN: io.unix.macosx -USING: io.unix.backend io.unix.bsd io.unix.kqueue io.backend +USING: io.unix.backend io.unix.bsd io.backend namespaces system ; -M: macosx init-io ( -- ) - mx set-global ; - macosx set-io-backend From 0cc4dc4e0a492526183b48b1e12bfd49721f4df8 Mon Sep 17 00:00:00 2001 From: Philipp Winkler Date: Wed, 10 Dec 2008 21:30:33 -0800 Subject: [PATCH 28/64] Allow post data to be send on PUT as well as POST actions. Allow any message between 200 and 299 to mean success. --- basis/http/client/client.factor | 10 ++++++---- 1 file changed, 6 insertions(+), 4 deletions(-) diff --git a/basis/http/client/client.factor b/basis/http/client/client.factor index 119fa23567..108ae5ecc4 100644 --- a/basis/http/client/client.factor +++ b/basis/http/client/client.factor @@ -7,6 +7,7 @@ math.order hashtables byte-arrays destructors io.encodings io.encodings.string io.encodings.ascii +io.encodings.utf8 io.encodings.8-bit io.encodings.binary io.streams.duplex @@ -40,11 +41,11 @@ GENERIC: >post-data ( object -- post-data ) M: post-data >post-data ; -M: string >post-data "application/octet-stream" ; +M: string >post-data utf8 encode "application/octet-stream" ; M: byte-array >post-data "application/octet-stream" ; -M: assoc >post-data assoc>query "application/x-www-form-urlencoded" ; +M: assoc >post-data assoc>query ascii encode "application/x-www-form-urlencoded" ; M: f >post-data ; @@ -52,12 +53,13 @@ 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 ; @@ -153,7 +155,7 @@ SYMBOL: redirects PRIVATE> -: success? ( code -- ? ) 200 = ; +: success? ( code -- ? ) 200 299 between? ; ERROR: download-failed response ; From c679ae025b82095defd05a2a32518209aaaecb2f Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 11 Dec 2008 00:03:58 -0600 Subject: [PATCH 29/64] Rename tools.disassembler.udis:& to alien.syntax:&: and fix it to survive image save/load --- basis/alien/c-types/c-types-tests.factor | 2 +- basis/alien/syntax/syntax-docs.factor | 5 +++++ basis/alien/syntax/syntax.factor | 7 ++++++- basis/compiler/tests/alien.factor | 6 +++--- basis/core-foundation/fsevents/fsevents.factor | 2 +- basis/environment/unix/unix.factor | 5 +++-- basis/io/unix/backend/backend.factor | 12 ++++++------ basis/tools/disassembler/udis/udis.factor | 6 ++---- 8 files changed, 27 insertions(+), 18 deletions(-) diff --git a/basis/alien/c-types/c-types-tests.factor b/basis/alien/c-types/c-types-tests.factor index f57d102452..31542b2699 100644 --- a/basis/alien/c-types/c-types-tests.factor +++ b/basis/alien/c-types/c-types-tests.factor @@ -8,7 +8,7 @@ sequences system libc alien.strings io.encodings.utf8 ; [ { "blah" 123 } ] [ { "blah" xyz } expand-constants ] unit-test -: foo ( -- n ) "fdafd" f dlsym [ 123 ] unless* ; +: foo ( -- n ) &: fdafd [ 123 ] unless* ; [ 123 ] [ foo ] unit-test diff --git a/basis/alien/syntax/syntax-docs.factor b/basis/alien/syntax/syntax-docs.factor index 586bb97402..a3215cd8c6 100644 --- a/basis/alien/syntax/syntax-docs.factor +++ b/basis/alien/syntax/syntax-docs.factor @@ -77,6 +77,11 @@ HELP: C-ENUM: { $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" } "." } diff --git a/basis/alien/syntax/syntax.factor b/basis/alien/syntax/syntax.factor index b0ba10a316..15d82884f9 100644 --- a/basis/alien/syntax/syntax.factor +++ b/basis/alien/syntax/syntax.factor @@ -3,7 +3,8 @@ 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 @@ -33,3 +34,7 @@ IN: alien.syntax dup length [ [ create-in ] dip 1quotation define ] 2each ; parsing + +: &: + scan "c-library" get + '[ _ _ load-library dlsym ] over push-all ; parsing diff --git a/basis/compiler/tests/alien.factor b/basis/compiler/tests/alien.factor index 230a7bf542..1b21e40bac 100644 --- a/basis/compiler/tests/alien.factor +++ b/basis/compiler/tests/alien.factor @@ -83,14 +83,14 @@ FUNCTION: tiny ffi_test_17 int x ; { 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 @@ -100,7 +100,7 @@ FUNCTION: tiny ffi_test_17 int x ; { 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 ) diff --git a/basis/core-foundation/fsevents/fsevents.factor b/basis/core-foundation/fsevents/fsevents.factor index d4d5e88512..b3c1444043 100644 --- a/basis/core-foundation/fsevents/fsevents.factor +++ b/basis/core-foundation/fsevents/fsevents.factor @@ -118,7 +118,7 @@ FUNCTION: CFStringRef FSEventStreamCopyDescription ( FSEventStreamRef streamRef FSEventStreamCreate ; : kCFRunLoopCommonModes ( -- string ) - "kCFRunLoopCommonModes" f dlsym *void* ; + &: kCFRunLoopCommonModes *void* ; : schedule-event-stream ( event-stream -- ) CFRunLoopGetMain diff --git a/basis/environment/unix/unix.factor b/basis/environment/unix/unix.factor index c2dddc25ab..7da19ee47b 100644 --- a/basis/environment/unix/unix.factor +++ b/basis/environment/unix/unix.factor @@ -2,12 +2,13 @@ ! 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 ; diff --git a/basis/io/unix/backend/backend.factor b/basis/io/unix/backend/backend.factor index 7f4e03ef09..954a0a61de 100644 --- a/basis/io/unix/backend/backend.factor +++ b/basis/io/unix/backend/backend.factor @@ -1,8 +1,8 @@ ! 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 ; @@ -184,11 +184,11 @@ M: stdin dispose* 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 new diff --git a/basis/tools/disassembler/udis/udis.factor b/basis/tools/disassembler/udis/udis.factor index 113c07c8c3..c5b5c80d13 100644 --- a/basis/tools/disassembler/udis/udis.factor +++ b/basis/tools/disassembler/udis/udis.factor @@ -5,8 +5,6 @@ alien alien.syntax alien.c-types lexer parser kernel sequences layouts math math.parser system make fry arrays ; IN: tools.disassembler.udis -<< : & scan "c-library" get load-library dlsym parsed ; parsing >> - << "libudis86" { { [ os macosx? ] [ "libudis86.0.dylib" ] } @@ -22,8 +20,8 @@ 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_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 From e795571639f0309424e37fd01a00cedcbe6c78af Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Thu, 11 Dec 2008 16:50:37 -0800 Subject: [PATCH 30/64] seed of X11 offscreen backend --- basis/ui/gadgets/worlds/worlds.factor | 4 -- basis/ui/x11/x11.factor | 28 ++++++++++++-- basis/x11/glx/glx.factor | 12 +++--- basis/x11/windows/windows.factor | 28 +++++++++++++- basis/x11/xlib/xlib.factor | 54 +++++++++++++++++++++++++++ extra/ui/offscreen/offscreen.factor | 3 +- 6 files changed, 113 insertions(+), 16 deletions(-) diff --git a/basis/ui/gadgets/worlds/worlds.factor b/basis/ui/gadgets/worlds/worlds.factor index 9290af1f64..732a438203 100644 --- a/basis/ui/gadgets/worlds/worlds.factor +++ b/basis/ui/gadgets/worlds/worlds.factor @@ -13,8 +13,6 @@ title status fonts handle window-loc ; -TUPLE: offscreen-world < world ; - : find-world ( gadget -- world/f ) [ world? ] find-parent ; : show-status ( string/f gadget -- ) @@ -53,8 +51,6 @@ M: world request-focus-on ( child gadget -- ) : ( gadget title status -- world ) world new-world ; -: ( gadget title status -- world ) - offscreen-world new-world ; M: world layout* dup call-next-method diff --git a/basis/ui/x11/x11.factor b/basis/ui/x11/x11.factor index e5a3a8306b..b65185967a 100755 --- a/basis/ui/x11/x11.factor +++ b/basis/ui/x11/x11.factor @@ -14,9 +14,12 @@ SINGLETON: x11-ui-backend : XA_NET_WM_NAME ( -- atom ) "_NET_WM_NAME" x-atom ; -TUPLE: x11-handle window glx xic ; +TUPLE: x11-handle-base glx ; +TUPLE: x11-handle < x11-handle-base xic window ; +TUPLE: x11-pixmap-handle < x11-handle-base pixmap glx-pixmap ; C: x11-handle +C: x11-pixmap-handle M: world expose-event nip relayout ; @@ -185,7 +188,7 @@ M: world client-event : gadget-window ( world -- ) dup window-loc>> over rect-dim glx-window - over "Factor" create-xic + over "Factor" create-xic rot 2dup window>> register-window >>handle drop ; @@ -250,12 +253,31 @@ M: x11-ui-backend raise-window* ( world -- ) 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-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 >>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 [ diff --git a/basis/x11/glx/glx.factor b/basis/x11/glx/glx.factor index 1fab283242..e0b786ce7d 100644 --- a/basis/x11/glx/glx.factor +++ b/basis/x11/glx/glx.factor @@ -84,13 +84,13 @@ FUNCTION: void* glXGetProcAddress ( char* procname ) ; FUNCTION: void* glXGetProcAddressARB ( char* procname ) ; ! GLX Events -! (also skipped for now. only has GLXPbufferClobberEvent, the rest is handled by xlib methinks +! (also skipped for now. only has GLXPbufferClobberEvent, the rest is handled by xlib methinks) -: choose-visual ( -- XVisualInfo* ) - dpy get scr get +: choose-visual ( flags -- XVisualInfo* ) + [ dpy get scr get ] dip [ + % GLX_RGBA , - GLX_DOUBLEBUFFER , GLX_DEPTH_SIZE , 16 , 0 , ] int-array{ } make underlying>> @@ -98,8 +98,8 @@ FUNCTION: void* glXGetProcAddressARB ( char* procname ) ; [ "Could not get a double-buffered GLX RGBA visual" throw ] unless* ; : create-glx ( XVisualInfo* -- GLXContext ) - >r dpy get r> f 1 glXCreateContext + [ dpy get ] dip f 1 glXCreateContext [ "Failed to create GLX context" throw ] unless* ; : destroy-glx ( GLXContext -- ) - dpy get swap glXDestroyContext ; \ No newline at end of file + dpy get swap glXDestroyContext ; diff --git a/basis/x11/windows/windows.factor b/basis/x11/windows/windows.factor index aed45655f6..3c41a78584 100644 --- a/basis/x11/windows/windows.factor +++ b/basis/x11/windows/windows.factor @@ -1,7 +1,8 @@ ! Copyright (C) 2005, 2006 Eduardo Cavazos and Slava Pestov ! See http://factorcode.org/license.txt for BSD license. USING: alien alien.c-types hashtables kernel math math.vectors -math.bitwise namespaces sequences x11.xlib x11.constants x11.glx ; +math.bitwise namespaces sequences x11.xlib x11.constants x11.glx +arrays fry ; IN: x11.windows : create-window-mask ( -- n ) @@ -50,11 +51,30 @@ IN: x11.windows dup r> auto-position ; : glx-window ( loc dim -- window glx ) - choose-visual + GLX_DOUBLEBUFFER 1array choose-visual [ create-window ] keep [ create-glx ] keep XFree ; +: create-pixmap ( dim visual -- pixmap ) + [ [ { 0 0 } swap ] dip create-window ] [ + drop [ dpy get ] 2dip first2 24 XCreatePixmap + [ "Failed to create offscreen pixmap" throw ] unless* + ] 2bi ; + +: (create-glx-pixmap) ( pixmap visual -- pixmap glx-pixmap ) + [ drop ] [ + [ dpy get ] 2dip swap glXCreateGLXPixmap + [ "Failed to create offscreen GLXPixmap" throw ] unless* + ] 2bi ; + +: create-glx-pixmap ( dim visual -- pixmap glx-pixmap ) + [ create-pixmap ] [ (create-glx-pixmap) ] bi ; + +: glx-pixmap ( dim -- glx pixmap glx-pixmap ) + { } choose-visual + [ nip create-glx ] [ create-glx-pixmap ] [ nip XFree ] 2tri ; + : destroy-window ( win -- ) dpy get swap XDestroyWindow drop ; @@ -65,3 +85,7 @@ IN: x11.windows : map-window ( win -- ) dpy get swap XMapWindow drop ; : unmap-window ( win -- ) dpy get swap XUnmapWindow drop ; + +: pixmap-bits ( dim pixmap -- alien ) + swap first2 '[ dpy get _ 0 0 _ _ AllPlanes ZPixmap XGetImage ] call + [ XImage-pixels ] [ XDestroyImage drop ] bi ; diff --git a/basis/x11/xlib/xlib.factor b/basis/x11/xlib/xlib.factor index 555eb573fc..996932e697 100644 --- a/basis/x11/xlib/xlib.factor +++ b/basis/x11/xlib/xlib.factor @@ -272,6 +272,17 @@ FUNCTION: Window XGetSelectionOwner ( Display* display, Atom selection ) ; FUNCTION: int XConvertSelection ( Display* display, Atom selection, Atom target, Atom property, Window requestor, Time time ) ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! 5 - Pixmap and Cursor Functions +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +! 5.1 - Creating and Freeing Pixmaps + +FUNCTION: Pixmap XCreatePixmap ( Display* display, Drawable d, uint width, uint height, uint depth ) ; +FUNCTION: int XFreePixmap ( Display* display, Pixmap pixmap ) ; + + ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! 6 - Color Management Functions ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! @@ -429,6 +440,49 @@ FUNCTION: Status XDrawString ( char* string, int length ) ; +! 8.7 - Transferring Images between Client and Server + +: XYBitmap 0 ; inline +: XYPixmap 1 ; inline +: ZPixmap 2 ; inline +: AllPlanes -1 ; inline + +C-STRUCT: XImage-funcs + { "void*" "create_image" } + { "void*" "destroy_image" } + { "void*" "get_pixel" } + { "void*" "put_pixel" } + { "void*" "sub_image" } + { "void*" "add_pixel" } ; + +C-STRUCT: XImage + { "int" "width" } + { "int" "height" } + { "int" "xoffset" } + { "int" "format" } + { "char*" "data" } + { "int" "byte_order" } + { "int" "bitmap_unit" } + { "int" "bitmap_bit_order" } + { "int" "bitmap_pad" } + { "int" "depth" } + { "int" "bytes_per_line" } + { "int" "bits_per_pixel" } + { "ulong" "red_mask" } + { "ulong" "green_mask" } + { "ulong" "blue_mask" } + { "XPointer" "obdata" } + { "XImage-funcs" "f" } ; + +FUNCTION: XImage* XGetImage ( Display* display, Drawable d, int x, int y, uint width, uint height, ulong plane_mask, int format ) ; +FUNCTION: int XDestroyImage ( XImage *ximage ) ; + +: XImage-size ( ximage -- size ) + [ XImage-height ] [ XImage-bytes_per_line ] bi * ; + +: XImage-pixels ( ximage -- byte-array ) + [ XImage-data ] [ XImage-size ] bi memory>byte-array ; + ! ! 9 - Window and Session Manager Functions ! diff --git a/extra/ui/offscreen/offscreen.factor b/extra/ui/offscreen/offscreen.factor index 33d4a92f37..be6638bed8 100755 --- a/extra/ui/offscreen/offscreen.factor +++ b/extra/ui/offscreen/offscreen.factor @@ -16,7 +16,8 @@ M: offscreen-world ungraft* [ reset-world ] tri ; : open-offscreen ( gadget -- world ) - "" f [ open-world-window ] keep + "" f + [ open-world-window dup relayout-1 ] keep notify-queued ; : close-offscreen ( world -- ) From b7bad6b2bbddafb3ba2f871ff91e20d606f359ea Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Thu, 11 Dec 2008 18:32:40 -0800 Subject: [PATCH 31/64] Metadata and docs for ui.offscreen --- extra/ui/offscreen/authors.txt | 1 + extra/ui/offscreen/offscreen-docs.factor | 63 ++++++++++++++++++++++++ extra/ui/offscreen/offscreen.factor | 5 +- extra/ui/offscreen/summary.txt | 1 + extra/ui/offscreen/tags.txt | 3 ++ 5 files changed, 72 insertions(+), 1 deletion(-) create mode 100644 extra/ui/offscreen/authors.txt create mode 100644 extra/ui/offscreen/offscreen-docs.factor create mode 100644 extra/ui/offscreen/summary.txt create mode 100644 extra/ui/offscreen/tags.txt diff --git a/extra/ui/offscreen/authors.txt b/extra/ui/offscreen/authors.txt new file mode 100644 index 0000000000..f13c9c1e77 --- /dev/null +++ b/extra/ui/offscreen/authors.txt @@ -0,0 +1 @@ +Joe Groff diff --git a/extra/ui/offscreen/offscreen-docs.factor b/extra/ui/offscreen/offscreen-docs.factor new file mode 100644 index 0000000000..5d800981bf --- /dev/null +++ b/extra/ui/offscreen/offscreen-docs.factor @@ -0,0 +1,63 @@ +! Copyright (C) 2008 Joe Groff. +! See http://factorcode.org/license.txt for BSD license. +USING: help.markup help.syntax kernel quotations ui.gadgets +graphics.bitmap strings ui.gadgets.worlds ; +IN: ui.offscreen + +HELP: +{ $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" diff --git a/extra/ui/offscreen/offscreen.factor b/extra/ui/offscreen/offscreen.factor index be6638bed8..3897df71fa 100755 --- a/extra/ui/offscreen/offscreen.factor +++ b/extra/ui/offscreen/offscreen.factor @@ -1,5 +1,6 @@ USING: accessors continuations graphics.bitmap kernel math -sequences ui.gadgets ui.gadgets.worlds ui ui.backend ; +sequences ui.gadgets ui.gadgets.worlds ui ui.backend +destructors ; IN: ui.offscreen TUPLE: offscreen-world < world ; @@ -23,6 +24,8 @@ M: offscreen-world ungraft* : close-offscreen ( world -- ) ungraft notify-queued ; +M: offscreen-world dispose close-offscreen ; + : offscreen-world>bitmap ( world -- bitmap ) offscreen-pixels bgra>bitmap ; diff --git a/extra/ui/offscreen/summary.txt b/extra/ui/offscreen/summary.txt new file mode 100644 index 0000000000..51ef124d97 --- /dev/null +++ b/extra/ui/offscreen/summary.txt @@ -0,0 +1 @@ +Offscreen world gadgets for rendering UI elements to bitmaps diff --git a/extra/ui/offscreen/tags.txt b/extra/ui/offscreen/tags.txt new file mode 100644 index 0000000000..b796ebde91 --- /dev/null +++ b/extra/ui/offscreen/tags.txt @@ -0,0 +1,3 @@ +unportable +ui +graphics From e9d80dcb637c01dd4614d63215affa854dc44edf Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 11 Dec 2008 22:48:19 -0600 Subject: [PATCH 32/64] Move Unix I/O multiplexers to io.unix.multiplexers, new run loop-based multiplexer integrates a kqueue with a CFRunLoop on Mac OS X --- basis/core-foundation/core-foundation.factor | 15 +++- .../core-foundation/fsevents/fsevents.factor | 8 +- .../core-foundation/run-loop/run-loop.factor | 6 ++ .../run-loop/thread/summary.txt | 1 - .../run-loop/thread/thread.factor | 16 ---- basis/io/unix/backend/backend.factor | 34 +-------- basis/io/unix/bsd/bsd.factor | 3 +- basis/io/unix/linux/linux.factor | 4 +- basis/io/unix/linux/monitors/monitors.factor | 8 +- basis/io/unix/macosx/macosx.factor | 7 +- .../unix/multiplexers/epoll}/authors.txt | 0 basis/io/unix/multiplexers/epoll/epoll.factor | 66 ++++++++++++++++ .../unix/multiplexers/epoll}/tags.txt | 0 basis/io/unix/multiplexers/kqueue/authors.txt | 1 + .../io/unix/multiplexers/kqueue/kqueue.factor | 76 +++++++++++++++++++ basis/io/unix/multiplexers/kqueue/tags.txt | 1 + .../io/unix/multiplexers/multiplexers.factor | 35 +++++++++ .../multiplexers/run-loop/run-loop.factor | 57 ++++++++++++++ basis/io/unix/multiplexers/run-loop/tags.txt | 1 + basis/io/unix/multiplexers/select/authors.txt | 1 + .../io/unix/multiplexers/select/select.factor | 56 ++++++++++++++ basis/io/unix/multiplexers/select/tags.txt | 1 + 22 files changed, 332 insertions(+), 65 deletions(-) delete mode 100644 basis/core-foundation/run-loop/thread/summary.txt delete mode 100644 basis/core-foundation/run-loop/thread/thread.factor rename basis/{core-foundation/run-loop/thread => io/unix/multiplexers/epoll}/authors.txt (100%) mode change 100644 => 100755 create mode 100644 basis/io/unix/multiplexers/epoll/epoll.factor rename basis/{core-foundation/run-loop/thread => io/unix/multiplexers/epoll}/tags.txt (100%) create mode 100755 basis/io/unix/multiplexers/kqueue/authors.txt create mode 100644 basis/io/unix/multiplexers/kqueue/kqueue.factor create mode 100644 basis/io/unix/multiplexers/kqueue/tags.txt create mode 100644 basis/io/unix/multiplexers/multiplexers.factor create mode 100644 basis/io/unix/multiplexers/run-loop/run-loop.factor create mode 100644 basis/io/unix/multiplexers/run-loop/tags.txt create mode 100755 basis/io/unix/multiplexers/select/authors.txt create mode 100644 basis/io/unix/multiplexers/select/select.factor create mode 100644 basis/io/unix/multiplexers/select/tags.txt diff --git a/basis/core-foundation/core-foundation.factor b/basis/core-foundation/core-foundation.factor index 48d7b7e483..40dd4710a1 100644 --- a/basis/core-foundation/core-foundation.factor +++ b/basis/core-foundation/core-foundation.factor @@ -1,8 +1,8 @@ ! 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 ; +math math.bitwise sequences io.encodings.utf8 destructors +accessors combinators byte-arrays ; IN: core-foundation TYPEDEF: void* CFAllocatorRef @@ -195,11 +195,22 @@ FUNCTION: CFFileDescriptorRef CFFileDescriptorCreate ( CFFileDescriptorContext* context ) ; +: kCFFileDescriptorReadCallBack 1 ; inline +: kCFFileDescriptorWriteCallBack 2 ; inline + FUNCTION: void CFFileDescriptorEnableCallBacks ( CFFileDescriptorRef f, CFOptionFlags callBackTypes ) ; +: enable-all-callbacks ( fd -- ) + { kCFFileDescriptorReadCallBack kCFFileDescriptorWriteCallBack } flags + CFFileDescriptorEnableCallBacks ; + +: ( fd callback -- handle ) + [ f swap ] [ t swap ] bi* f CFFileDescriptorCreate + [ "CFFileDescriptorCreate failed" throw ] unless* ; + : load-framework ( name -- ) dup [ CFBundleLoadExecutable drop diff --git a/basis/core-foundation/fsevents/fsevents.factor b/basis/core-foundation/fsevents/fsevents.factor index b3c1444043..67c2dcfa35 100644 --- a/basis/core-foundation/fsevents/fsevents.factor +++ b/basis/core-foundation/fsevents/fsevents.factor @@ -3,10 +3,10 @@ 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 ; +core-foundation.run-loop io.encodings.utf8 destructors locals +arrays specialized-arrays.direct.alien +specialized-arrays.direct.int specialized-arrays.direct.longlong +; IN: core-foundation.fsevents : kFSEventStreamCreateFlagUseCFTypes 2 ; inline diff --git a/basis/core-foundation/run-loop/run-loop.factor b/basis/core-foundation/run-loop/run-loop.factor index 39f4101301..d254bf3adc 100644 --- a/basis/core-foundation/run-loop/run-loop.factor +++ b/basis/core-foundation/run-loop/run-loop.factor @@ -32,6 +32,12 @@ FUNCTION: void CFRunLoopAddSource ( CFStringRef mode ) ; +FUNCTION: void CFRunLoopRemoveSource ( + CFRunLoopRef rl, + CFRunLoopSourceRef source, + CFStringRef mode +) ; + : CFRunLoopDefaultMode ( -- alien ) #! Ugly, but we don't have static NSStrings \ CFRunLoopDefaultMode get-global dup expired? [ diff --git a/basis/core-foundation/run-loop/thread/summary.txt b/basis/core-foundation/run-loop/thread/summary.txt deleted file mode 100644 index e5818b3d78..0000000000 --- a/basis/core-foundation/run-loop/thread/summary.txt +++ /dev/null @@ -1 +0,0 @@ -Vocabulary with init hook for running CoreFoundation event loop diff --git a/basis/core-foundation/run-loop/thread/thread.factor b/basis/core-foundation/run-loop/thread/thread.factor deleted file mode 100644 index aeeff312cb..0000000000 --- a/basis/core-foundation/run-loop/thread/thread.factor +++ /dev/null @@ -1,16 +0,0 @@ -! Copyright (C) 2008 Slava Pestov -! See http://factorcode.org/license.txt for BSD license. -USING: calendar core-foundation.run-loop init kernel threads ; -IN: core-foundation.run-loop.thread - -! Load this vocabulary if you need a run loop running. - -: run-loop-thread ( -- ) - CFRunLoopDefaultMode 0 f CFRunLoopRunInMode - kCFRunLoopRunHandledSource = [ 1 seconds sleep ] unless - run-loop-thread ; - -: start-run-loop-thread ( -- ) - [ run-loop-thread t ] "CFRunLoop dispatcher" spawn-server drop ; - -[ start-run-loop-thread ] "core-foundation.run-loop.thread" add-init-hook diff --git a/basis/io/unix/backend/backend.factor b/basis/io/unix/backend/backend.factor index 954a0a61de..41bd03a58b 100644 --- a/basis/io/unix/backend/backend.factor +++ b/basis/io/unix/backend/backend.factor @@ -5,7 +5,7 @@ kernel.private math io.ports sequences strings sbufs threads unix vectors io.buffers io.backend io.encodings math.parser continuations system libc qualified namespaces make io.timeouts io.encodings.utf8 destructors accessors summary combinators -locals unix.time fry ; +locals unix.time fry io.unix.multiplexers ; QUALIFIED: io IN: io.unix.backend @@ -37,38 +37,6 @@ M: fd dispose M: fd handle-fd dup check-disposed fd>> ; -! I/O multiplexers -TUPLE: mx fd reads writes ; - -: new-mx ( class -- obj ) - new - H{ } clone >>reads - H{ } clone >>writes ; inline - -GENERIC: add-input-callback ( thread fd mx -- ) - -M: mx add-input-callback reads>> push-at ; - -GENERIC: add-output-callback ( thread fd mx -- ) - -M: mx add-output-callback writes>> push-at ; - -GENERIC: remove-input-callbacks ( fd mx -- callbacks ) - -M: mx remove-input-callbacks reads>> delete-at* drop ; - -GENERIC: remove-output-callbacks ( fd mx -- callbacks ) - -M: mx remove-output-callbacks writes>> delete-at* drop ; - -GENERIC: wait-for-events ( ms mx -- ) - -: input-available ( fd mx -- ) - reads>> delete-at* drop [ resume ] each ; - -: output-available ( fd mx -- ) - writes>> delete-at* drop [ resume ] each ; - M: fd cancel-operation ( fd -- ) dup disposed>> [ drop ] [ fd>> diff --git a/basis/io/unix/bsd/bsd.factor b/basis/io/unix/bsd/bsd.factor index e1583478db..83f063d713 100644 --- a/basis/io/unix/bsd/bsd.factor +++ b/basis/io/unix/bsd/bsd.factor @@ -1,7 +1,8 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: namespaces system kernel accessors assocs continuations -unix io.backend io.unix.backend io.unix.kqueue ; +unix io.backend io.unix.backend io.unix.multiplexers +io.unix.multiplexers.kqueue ; IN: io.unix.bsd M: bsd init-io ( -- ) diff --git a/basis/io/unix/linux/linux.factor b/basis/io/unix/linux/linux.factor index be5b83f1b0..fd24e0ac02 100644 --- a/basis/io/unix/linux/linux.factor +++ b/basis/io/unix/linux/linux.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: kernel io.backend io.monitors io.unix.backend -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 ( -- ) diff --git a/basis/io/unix/linux/monitors/monitors.factor b/basis/io/unix/linux/monitors/monitors.factor index f27d48c6b0..3964a25a04 100644 --- a/basis/io/unix/linux/monitors/monitors.factor +++ b/basis/io/unix/linux/monitors/monitors.factor @@ -2,10 +2,10 @@ ! See http://factorcode.org/license.txt for BSD license. USING: kernel io.backend io.monitors io.monitors.recursive io.files io.buffers io.monitors io.ports io.timeouts -io.unix.backend io.unix.select io.encodings.utf8 -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 diff --git a/basis/io/unix/macosx/macosx.factor b/basis/io/unix/macosx/macosx.factor index 388d266b48..75f42b7394 100644 --- a/basis/io/unix/macosx/macosx.factor +++ b/basis/io/unix/macosx/macosx.factor @@ -1,7 +1,10 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. +USING: io.backend system namespaces io.unix.multiplexers +io.unix.multiplexers.run-loop ; IN: io.unix.macosx -USING: io.unix.backend io.unix.bsd io.backend -namespaces system ; + +M: macosx init-io ( -- ) + mx set-global ; macosx set-io-backend diff --git a/basis/core-foundation/run-loop/thread/authors.txt b/basis/io/unix/multiplexers/epoll/authors.txt old mode 100644 new mode 100755 similarity index 100% rename from basis/core-foundation/run-loop/thread/authors.txt rename to basis/io/unix/multiplexers/epoll/authors.txt diff --git a/basis/io/unix/multiplexers/epoll/epoll.factor b/basis/io/unix/multiplexers/epoll/epoll.factor new file mode 100644 index 0000000000..08e20d4b95 --- /dev/null +++ b/basis/io/unix/multiplexers/epoll/epoll.factor @@ -0,0 +1,66 @@ +! Copyright (C) 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors alien.c-types kernel destructors bit-arrays +sequences assocs struct-arrays math namespaces locals fry unix +unix.linux.epoll unix.time io.ports io.unix.backend +io.unix.multiplexers ; +IN: io.unix.multiplexers.epoll + +TUPLE: epoll-mx < mx events ; + +: max-events ( -- n ) + #! We read up to 256 events at a time. This is an arbitrary + #! constant... + 256 ; inline + +: ( -- mx ) + epoll-mx new-mx + max-events epoll_create dup io-error >>fd + max-events "epoll-event" >>events ; + +M: epoll-mx dispose fd>> close-file ; + +: make-event ( fd events -- event ) + "epoll-event" + [ 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 ; diff --git a/basis/core-foundation/run-loop/thread/tags.txt b/basis/io/unix/multiplexers/epoll/tags.txt similarity index 100% rename from basis/core-foundation/run-loop/thread/tags.txt rename to basis/io/unix/multiplexers/epoll/tags.txt diff --git a/basis/io/unix/multiplexers/kqueue/authors.txt b/basis/io/unix/multiplexers/kqueue/authors.txt new file mode 100755 index 0000000000..1901f27a24 --- /dev/null +++ b/basis/io/unix/multiplexers/kqueue/authors.txt @@ -0,0 +1 @@ +Slava Pestov diff --git a/basis/io/unix/multiplexers/kqueue/kqueue.factor b/basis/io/unix/multiplexers/kqueue/kqueue.factor new file mode 100644 index 0000000000..a66e86a6a7 --- /dev/null +++ b/basis/io/unix/multiplexers/kqueue/kqueue.factor @@ -0,0 +1,76 @@ +! Copyright (C) 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors alien.c-types combinators destructors +io.unix.backend kernel math.bitwise sequences struct-arrays unix +unix.kqueue unix.time assocs io.unix.multiplexers ; +IN: io.unix.multiplexers.kqueue + +TUPLE: kqueue-mx < mx events ; + +: max-events ( -- n ) + #! We read up to 256 events at a time. This is an arbitrary + #! constant... + 256 ; inline + +: ( -- mx ) + kqueue-mx new-mx + kqueue dup io-error >>fd + max-events "kevent" >>events ; + +M: kqueue-mx dispose fd>> close-file ; + +: make-kevent ( fd filter flags -- event ) + "kevent" + [ 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 ; diff --git a/basis/io/unix/multiplexers/kqueue/tags.txt b/basis/io/unix/multiplexers/kqueue/tags.txt new file mode 100644 index 0000000000..6bf68304bb --- /dev/null +++ b/basis/io/unix/multiplexers/kqueue/tags.txt @@ -0,0 +1 @@ +unportable diff --git a/basis/io/unix/multiplexers/multiplexers.factor b/basis/io/unix/multiplexers/multiplexers.factor new file mode 100644 index 0000000000..1c9fb134e7 --- /dev/null +++ b/basis/io/unix/multiplexers/multiplexers.factor @@ -0,0 +1,35 @@ +! Copyright (C) 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: kernel accessors assocs sequences threads ; +IN: io.unix.multiplexers + +TUPLE: mx fd reads writes ; + +: new-mx ( class -- obj ) + new + H{ } clone >>reads + H{ } clone >>writes ; inline + +GENERIC: add-input-callback ( thread fd mx -- ) + +M: mx add-input-callback reads>> push-at ; + +GENERIC: add-output-callback ( thread fd mx -- ) + +M: mx add-output-callback writes>> push-at ; + +GENERIC: remove-input-callbacks ( fd mx -- callbacks ) + +M: mx remove-input-callbacks reads>> delete-at* drop ; + +GENERIC: remove-output-callbacks ( fd mx -- callbacks ) + +M: mx remove-output-callbacks writes>> delete-at* drop ; + +GENERIC: wait-for-events ( ms mx -- ) + +: input-available ( fd mx -- ) + reads>> delete-at* drop [ resume ] each ; + +: output-available ( fd mx -- ) + writes>> delete-at* drop [ resume ] each ; diff --git a/basis/io/unix/multiplexers/run-loop/run-loop.factor b/basis/io/unix/multiplexers/run-loop/run-loop.factor new file mode 100644 index 0000000000..baaf910f37 --- /dev/null +++ b/basis/io/unix/multiplexers/run-loop/run-loop.factor @@ -0,0 +1,57 @@ +! Copyright (C) 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: kernel namespaces math accessors threads alien locals +destructors combinators core-foundation core-foundation.run-loop +io.unix.multiplexers io.unix.multiplexers.kqueue ; +IN: io.unix.multiplexers.run-loop + +TUPLE: run-loop-mx kqueue-mx fd source ; + +: kqueue-callback ( -- callback ) + "void" { "CFFileDescriptorRef" "CFOptionFlags" "void*" } + "cdecl" [ + 3drop + 0 mx get kqueue-mx>> wait-for-events + mx get fd>> enable-all-callbacks + yield + ] + alien-callback ; + +SYMBOL: kqueue-run-loop-source + +: create-kqueue-source ( fd -- source ) + f swap 0 CFFileDescriptorCreateRunLoopSource ; + +: add-kqueue-to-run-loop ( mx -- ) + CFRunLoopGetMain swap source>> CFRunLoopDefaultMode CFRunLoopAddSource ; + +: remove-kqueue-from-run-loop ( source -- ) + CFRunLoopGetMain swap source>> CFRunLoopDefaultMode CFRunLoopRemoveSource ; + +: ( -- mx ) + [ + |dispose + dup fd>> kqueue-callback |dispose + dup create-kqueue-source run-loop-mx boa + dup add-kqueue-to-run-loop + ] with-destructors ; + +M: run-loop-mx dispose + [ + { + [ fd>> &dispose drop ] + [ source>> &dispose drop ] + [ remove-kqueue-from-run-loop ] + [ kqueue-mx>> &dispose drop ] + } cleave + ] 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 -- ) + mx fd>> enable-all-callbacks + CFRunLoopDefaultMode us [ 1000000 /f ] [ 60 ] if* t CFRunLoopRunInMode + kCFRunLoopRunHandledSource = [ 0 mx wait-for-events ] when ; diff --git a/basis/io/unix/multiplexers/run-loop/tags.txt b/basis/io/unix/multiplexers/run-loop/tags.txt new file mode 100644 index 0000000000..6bf68304bb --- /dev/null +++ b/basis/io/unix/multiplexers/run-loop/tags.txt @@ -0,0 +1 @@ +unportable diff --git a/basis/io/unix/multiplexers/select/authors.txt b/basis/io/unix/multiplexers/select/authors.txt new file mode 100755 index 0000000000..1901f27a24 --- /dev/null +++ b/basis/io/unix/multiplexers/select/authors.txt @@ -0,0 +1 @@ +Slava Pestov diff --git a/basis/io/unix/multiplexers/select/select.factor b/basis/io/unix/multiplexers/select/select.factor new file mode 100644 index 0000000000..915daac2d3 --- /dev/null +++ b/basis/io/unix/multiplexers/select/select.factor @@ -0,0 +1,56 @@ +! Copyright (C) 2004, 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: alien.c-types kernel bit-arrays sequences assocs unix +math namespaces accessors math.order locals unix.time fry +io.ports io.unix.backend io.unix.multiplexers ; +IN: io.unix.multiplexers.select + +TUPLE: select-mx < mx read-fdset write-fdset ; + +! Factor's bit-arrays are an array of bytes, OS X expects +! FD_SET to be an array of cells, so we have to account for +! byte order differences on big endian platforms +: munge ( i -- i' ) + little-endian? [ BIN: 11000 bitxor ] unless ; inline + +: ( -- mx ) + select-mx new-mx + FD_SETSIZE 8 * >>read-fdset + FD_SETSIZE 8 * >>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 ; diff --git a/basis/io/unix/multiplexers/select/tags.txt b/basis/io/unix/multiplexers/select/tags.txt new file mode 100644 index 0000000000..6bf68304bb --- /dev/null +++ b/basis/io/unix/multiplexers/select/tags.txt @@ -0,0 +1 @@ +unportable From e5ef3d9b95ac9f7f29b5fd54ee35b9f946b85bb5 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Thu, 11 Dec 2008 21:49:45 -0800 Subject: [PATCH 33/64] don't need dispose on offscreen-world, and it breaks compiling --- extra/ui/offscreen/offscreen.factor | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/extra/ui/offscreen/offscreen.factor b/extra/ui/offscreen/offscreen.factor index 3897df71fa..89c1c7f860 100755 --- a/extra/ui/offscreen/offscreen.factor +++ b/extra/ui/offscreen/offscreen.factor @@ -1,3 +1,4 @@ +! (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 ; @@ -24,8 +25,6 @@ M: offscreen-world ungraft* : close-offscreen ( world -- ) ungraft notify-queued ; -M: offscreen-world dispose close-offscreen ; - : offscreen-world>bitmap ( world -- bitmap ) offscreen-pixels bgra>bitmap ; From 46a1089fd8584a55050b325967d8b8b82648ddb6 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 12 Dec 2008 00:33:05 -0600 Subject: [PATCH 34/64] Split up core-foundation vocabulary since it was getting out of hand --- .../core-foundation/arrays/arrays-docs.factor | 11 + basis/core-foundation/arrays/arrays.factor | 22 ++ basis/core-foundation/arrays/tags.txt | 2 + .../bundles/bundles-docs.factor | 11 + basis/core-foundation/bundles/bundles.factor | 23 ++ basis/core-foundation/bundles/tags.txt | 2 + .../core-foundation-docs.factor | 57 ----- basis/core-foundation/core-foundation.factor | 209 +----------------- basis/core-foundation/data/data.factor | 58 +++++ basis/core-foundation/data/tags.txt | 2 + .../file-descriptors/file-descriptors.factor | 32 +++ .../core-foundation/file-descriptors/tags.txt | 2 + .../core-foundation/fsevents/fsevents.factor | 5 +- .../core-foundation/run-loop/run-loop.factor | 4 +- .../strings/strings-docs.factor | 14 ++ .../strings/strings-tests.factor | 9 + basis/core-foundation/strings/strings.factor | 66 ++++++ basis/core-foundation/strings/tags.txt | 2 + basis/core-foundation/urls/tags.txt | 2 + basis/core-foundation/urls/urls-docs.factor | 10 + basis/core-foundation/urls/urls.factor | 24 ++ .../multiplexers/run-loop/run-loop.factor | 5 +- 22 files changed, 306 insertions(+), 266 deletions(-) create mode 100644 basis/core-foundation/arrays/arrays-docs.factor create mode 100644 basis/core-foundation/arrays/arrays.factor create mode 100644 basis/core-foundation/arrays/tags.txt create mode 100644 basis/core-foundation/bundles/bundles-docs.factor create mode 100644 basis/core-foundation/bundles/bundles.factor create mode 100644 basis/core-foundation/bundles/tags.txt create mode 100644 basis/core-foundation/data/data.factor create mode 100644 basis/core-foundation/data/tags.txt create mode 100644 basis/core-foundation/file-descriptors/file-descriptors.factor create mode 100644 basis/core-foundation/file-descriptors/tags.txt create mode 100644 basis/core-foundation/strings/strings-docs.factor create mode 100644 basis/core-foundation/strings/strings-tests.factor create mode 100644 basis/core-foundation/strings/strings.factor create mode 100644 basis/core-foundation/strings/tags.txt create mode 100644 basis/core-foundation/urls/tags.txt create mode 100644 basis/core-foundation/urls/urls-docs.factor create mode 100644 basis/core-foundation/urls/urls.factor diff --git a/basis/core-foundation/arrays/arrays-docs.factor b/basis/core-foundation/arrays/arrays-docs.factor new file mode 100644 index 0000000000..36d14a8660 --- /dev/null +++ b/basis/core-foundation/arrays/arrays-docs.factor @@ -0,0 +1,11 @@ +USING: help.syntax help.markup arrays alien ; +IN: core-foundation.arrays + +HELP: CF>array +{ $values { "alien" "a " { $snippet "CFArray" } } { "array" "an array of " { $link alien } " instances" } } +{ $description "Creates a Factor array from a Core Foundation array." } ; + +HELP: +{ $values { "seq" "a sequence of " { $link alien } " instances" } { "alien" "a " { $snippet "CFArray" } } } +{ $description "Creates a Core Foundation array from a Factor array." } ; + diff --git a/basis/core-foundation/arrays/arrays.factor b/basis/core-foundation/arrays/arrays.factor new file mode 100644 index 0000000000..3708059f2b --- /dev/null +++ b/basis/core-foundation/arrays/arrays.factor @@ -0,0 +1,22 @@ +! Copyright (C) 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: alien.syntax kernel sequences ; +IN: core-foundation.arrays + +TYPEDEF: void* CFArrayRef + +FUNCTION: CFArrayRef CFArrayCreateMutable ( CFAllocatorRef allocator, CFIndex capacity, void* callbacks ) ; + +FUNCTION: void* CFArrayGetValueAtIndex ( CFArrayRef array, CFIndex idx ) ; + +FUNCTION: void CFArraySetValueAtIndex ( CFArrayRef array, CFIndex index, void* value ) ; + +FUNCTION: CFIndex CFArrayGetCount ( CFArrayRef array ) ; + +: CF>array ( alien -- array ) + dup CFArrayGetCount [ CFArrayGetValueAtIndex ] with map ; + +: ( seq -- alien ) + [ f swap length f CFArrayCreateMutable ] keep + [ length ] keep + [ [ dupd ] dip CFArraySetValueAtIndex ] 2each ; diff --git a/basis/core-foundation/arrays/tags.txt b/basis/core-foundation/arrays/tags.txt new file mode 100644 index 0000000000..2320bdd648 --- /dev/null +++ b/basis/core-foundation/arrays/tags.txt @@ -0,0 +1,2 @@ +unportable +bindings diff --git a/basis/core-foundation/bundles/bundles-docs.factor b/basis/core-foundation/bundles/bundles-docs.factor new file mode 100644 index 0000000000..baa1b4d5df --- /dev/null +++ b/basis/core-foundation/bundles/bundles-docs.factor @@ -0,0 +1,11 @@ +USING: help.syntax help.markup ; +IN: core-foundation.bundles + +HELP: +{ $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." } ; + diff --git a/basis/core-foundation/bundles/bundles.factor b/basis/core-foundation/bundles/bundles.factor new file mode 100644 index 0000000000..790f1766c3 --- /dev/null +++ b/basis/core-foundation/bundles/bundles.factor @@ -0,0 +1,23 @@ +! Copyright (C) 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: alien.syntax kernel sequences core-foundation +core-foundation.urls ; +IN: core-foundation.bundles + +TYPEDEF: void* CFBundleRef + +FUNCTION: CFBundleRef CFBundleCreate ( CFAllocatorRef allocator, CFURLRef bundleURL ) ; + +FUNCTION: Boolean CFBundleLoadExecutable ( CFBundleRef bundle ) ; + +: ( string -- bundle ) + t [ + f swap CFBundleCreate + ] keep CFRelease ; + +: load-framework ( name -- ) + dup [ + CFBundleLoadExecutable drop + ] [ + "Cannot load bundle named " prepend throw + ] ?if ; diff --git a/basis/core-foundation/bundles/tags.txt b/basis/core-foundation/bundles/tags.txt new file mode 100644 index 0000000000..2320bdd648 --- /dev/null +++ b/basis/core-foundation/bundles/tags.txt @@ -0,0 +1,2 @@ +unportable +bindings diff --git a/basis/core-foundation/core-foundation-docs.factor b/basis/core-foundation/core-foundation-docs.factor index d577c523cf..c1783cb92b 100644 --- a/basis/core-foundation/core-foundation-docs.factor +++ b/basis/core-foundation/core-foundation-docs.factor @@ -1,42 +1,6 @@ USING: alien strings arrays help.markup help.syntax destructors ; IN: core-foundation -HELP: CF>array -{ $values { "alien" "a " { $snippet "CFArray" } } { "array" "an array of " { $link alien } " instances" } } -{ $description "Creates a Factor array from a Core Foundation array." } ; - -HELP: -{ $values { "seq" "a sequence of " { $link alien } " instances" } { "alien" "a " { $snippet "CFArray" } } } -{ $description "Creates a Core Foundation array from a Factor array." } ; - -HELP: -{ $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: -{ $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: -{ $values { "string" "a URL string" } { "url" "a " { $snippet "CFURL" } } } -{ $description "Creates a new " { $snippet "CFURL" } "." } ; - -HELP: -{ $values { "string" "a pathname string" } { "bundle" "a " { $snippet "CFBundle" } } } -{ $description "Creates a new " { $snippet "CFBundle" } "." } ; - -HELP: load-framework -{ $values { "name" "a pathname string" } } -{ $description "Loads a Core Foundation framework." } ; - HELP: &CFRelease { $values { "alien" "Pointer to a Core Foundation object" } } { $description "Marks the given Core Foundation object for unconditional release via " { $link CFRelease } " at the end of the enclosing " { $link with-destructors } " scope." } ; @@ -46,24 +10,3 @@ HELP: |CFRelease { $description "Marks the given Core Foundation object for release via " { $link CFRelease } " in the event of an error at the end of the enclosing " { $link with-destructors } " scope." } ; { CFRelease |CFRelease &CFRelease } related-words - -ARTICLE: "core-foundation" "Core foundation utilities" -"The " { $vocab-link "core-foundation" } " vocabulary defines bindings for some frequently-used Core Foundation functions. It also provides some utility words." -$nl -"Strings:" -{ $subsection } -{ $subsection CF>string } -"Arrays:" -{ $subsection } -{ $subsection CF>array } -{ $subsection CF>string-array } -"URLs:" -{ $subsection } -{ $subsection } -"Frameworks:" -{ $subsection load-framework } -"Memory management:" -{ $subsection &CFRelease } -{ $subsection |CFRelease } ; - -ABOUT: "core-foundation" diff --git a/basis/core-foundation/core-foundation.factor b/basis/core-foundation/core-foundation.factor index 40dd4710a1..0f64c0666f 100644 --- a/basis/core-foundation/core-foundation.factor +++ b/basis/core-foundation/core-foundation.factor @@ -1,23 +1,13 @@ ! 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 math.bitwise 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 @@ -26,198 +16,11 @@ 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 ; - -: ( seq -- alien ) - [ f swap length f CFArrayCreateMutable ] keep - [ length ] keep - [ [ dupd ] dip CFArraySetValueAtIndex ] 2each ; - -: ( string -- alien ) - f swap utf8 string>alien kCFStringEncodingUTF8 CFStringCreateWithCString - [ "CFStringCreateWithCString failed" throw ] unless* ; - -: CF>string ( alien -- string ) - dup CFStringGetLength 4 * 1 + [ - dup length - kCFStringEncodingUTF8 - CFStringGetCString - [ "CFStringGetCString failed" throw ] unless - ] keep utf8 alien>string ; - -: CF>string-array ( alien -- seq ) - CF>array [ CF>string ] map ; - -: ( seq -- alien ) - [ ] map [ ] [ [ CFRelease ] each ] bi ; - -: ( string dir? -- url ) - [ f over kCFURLPOSIXPathStyle ] dip - CFURLCreateWithFileSystemPath swap CFRelease ; - -: ( string -- url ) - - [ f swap f CFURLCreateWithString ] keep - CFRelease ; - -: ( string -- bundle ) - t [ - f swap CFBundleCreate - ] keep CFRelease ; - -GENERIC: ( number -- alien ) - -M: integer - [ f kCFNumberLongLongType ] dip CFNumberCreate ; - -M: float - [ f kCFNumberDoubleType ] dip CFNumberCreate ; - -M: t - drop f kCFNumberIntType 1 CFNumberCreate ; - -M: f - drop f kCFNumberIntType 0 CFNumberCreate ; - -: ( byte-array -- alien ) - [ f ] dip dup length CFDataCreate ; - -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 ; - -: ( fd callback -- handle ) - [ f swap ] [ t swap ] bi* f CFFileDescriptorCreate - [ "CFFileDescriptorCreate failed" throw ] unless* ; - -: load-framework ( name -- ) - dup [ - CFBundleLoadExecutable drop - ] [ - "Cannot load bundle named " prepend throw - ] ?if ; - TUPLE: CFRelease-destructor alien disposed ; M: CFRelease-destructor dispose* alien>> CFRelease ; diff --git a/basis/core-foundation/data/data.factor b/basis/core-foundation/data/data.factor new file mode 100644 index 0000000000..043fb905ad --- /dev/null +++ b/basis/core-foundation/data/data.factor @@ -0,0 +1,58 @@ +! Copyright (C) 2008 Joe Groff. +! See http://factorcode.org/license.txt for BSD license. +USING: alien.syntax alien.c-types sequences kernel math ; +IN: core-foundation.data + +TYPEDEF: void* CFDataRef +TYPEDEF: void* CFDictionaryRef +TYPEDEF: void* CFMutableDictionaryRef +TYPEDEF: void* CFNumberRef +TYPEDEF: void* CFSetRef +TYPEDEF: void* CFUUIDRef + +TYPEDEF: int CFNumberType +: kCFNumberSInt8Type 1 ; inline +: kCFNumberSInt16Type 2 ; inline +: kCFNumberSInt32Type 3 ; inline +: kCFNumberSInt64Type 4 ; inline +: kCFNumberFloat32Type 5 ; inline +: kCFNumberFloat64Type 6 ; inline +: kCFNumberCharType 7 ; inline +: kCFNumberShortType 8 ; inline +: kCFNumberIntType 9 ; inline +: kCFNumberLongType 10 ; inline +: kCFNumberLongLongType 11 ; inline +: kCFNumberFloatType 12 ; inline +: kCFNumberDoubleType 13 ; inline +: kCFNumberCFIndexType 14 ; inline +: kCFNumberNSIntegerType 15 ; inline +: kCFNumberCGFloatType 16 ; inline +: kCFNumberMaxType 16 ; inline + +TYPEDEF: int CFPropertyListMutabilityOptions +: kCFPropertyListImmutable 0 ; inline +: kCFPropertyListMutableContainers 1 ; inline +: kCFPropertyListMutableContainersAndLeaves 2 ; inline + +FUNCTION: CFNumberRef CFNumberCreate ( CFAllocatorRef allocator, CFNumberType theType, void* valuePtr ) ; + +FUNCTION: CFDataRef CFDataCreate ( CFAllocatorRef allocator, uchar* bytes, CFIndex length ) ; + +FUNCTION: CFTypeID CFGetTypeID ( CFTypeRef cf ) ; + +GENERIC: ( number -- alien ) + +M: integer + [ f kCFNumberLongLongType ] dip CFNumberCreate ; + +M: float + [ f kCFNumberDoubleType ] dip CFNumberCreate ; + +M: t + drop f kCFNumberIntType 1 CFNumberCreate ; + +M: f + drop f kCFNumberIntType 0 CFNumberCreate ; + +: ( byte-array -- alien ) + [ f ] dip dup length CFDataCreate ; diff --git a/basis/core-foundation/data/tags.txt b/basis/core-foundation/data/tags.txt new file mode 100644 index 0000000000..2320bdd648 --- /dev/null +++ b/basis/core-foundation/data/tags.txt @@ -0,0 +1,2 @@ +unportable +bindings diff --git a/basis/core-foundation/file-descriptors/file-descriptors.factor b/basis/core-foundation/file-descriptors/file-descriptors.factor new file mode 100644 index 0000000000..29c4219678 --- /dev/null +++ b/basis/core-foundation/file-descriptors/file-descriptors.factor @@ -0,0 +1,32 @@ +! Copyright (C) 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: alien.syntax kernel math.bitwise core-foundation ; +IN: core-foundation.file-descriptors + +TYPEDEF: void* CFFileDescriptorRef +TYPEDEF: int CFFileDescriptorNativeDescriptor +TYPEDEF: void* CFFileDescriptorCallBack + +FUNCTION: CFFileDescriptorRef CFFileDescriptorCreate ( + CFAllocatorRef allocator, + CFFileDescriptorNativeDescriptor fd, + Boolean closeOnInvalidate, + CFFileDescriptorCallBack callout, + CFFileDescriptorContext* context +) ; + +: kCFFileDescriptorReadCallBack 1 ; inline +: kCFFileDescriptorWriteCallBack 2 ; inline + +FUNCTION: void CFFileDescriptorEnableCallBacks ( + CFFileDescriptorRef f, + CFOptionFlags callBackTypes +) ; + +: enable-all-callbacks ( fd -- ) + { kCFFileDescriptorReadCallBack kCFFileDescriptorWriteCallBack } flags + CFFileDescriptorEnableCallBacks ; + +: ( fd callback -- handle ) + [ f swap ] [ t swap ] bi* f CFFileDescriptorCreate + [ "CFFileDescriptorCreate failed" throw ] unless* ; diff --git a/basis/core-foundation/file-descriptors/tags.txt b/basis/core-foundation/file-descriptors/tags.txt new file mode 100644 index 0000000000..2320bdd648 --- /dev/null +++ b/basis/core-foundation/file-descriptors/tags.txt @@ -0,0 +1,2 @@ +unportable +bindings diff --git a/basis/core-foundation/fsevents/fsevents.factor b/basis/core-foundation/fsevents/fsevents.factor index 67c2dcfa35..7ed040b455 100644 --- a/basis/core-foundation/fsevents/fsevents.factor +++ b/basis/core-foundation/fsevents/fsevents.factor @@ -2,11 +2,10 @@ ! 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 io.encodings.utf8 destructors locals +continuations combinators io.encodings.utf8 destructors locals arrays specialized-arrays.direct.alien specialized-arrays.direct.int specialized-arrays.direct.longlong -; +core-foundation core-foundation.run-loop core-foundation.strings ; IN: core-foundation.fsevents : kFSEventStreamCreateFlagUseCFTypes 2 ; inline diff --git a/basis/core-foundation/run-loop/run-loop.factor b/basis/core-foundation/run-loop/run-loop.factor index d254bf3adc..b7e565e70f 100644 --- a/basis/core-foundation/run-loop/run-loop.factor +++ b/basis/core-foundation/run-loop/run-loop.factor @@ -1,6 +1,8 @@ ! Copyright (C) 2008 Slava Pestov ! See http://factorcode.org/license.txt for BSD license. -USING: alien alien.syntax core-foundation kernel namespaces ; +USING: alien alien.syntax kernel namespaces +core-foundation core-foundation.strings +core-foundation.file-descriptors ; IN: core-foundation.run-loop : kCFRunLoopRunFinished 1 ; inline diff --git a/basis/core-foundation/strings/strings-docs.factor b/basis/core-foundation/strings/strings-docs.factor new file mode 100644 index 0000000000..4c12fb5d52 --- /dev/null +++ b/basis/core-foundation/strings/strings-docs.factor @@ -0,0 +1,14 @@ +USING: help.syntax help.markup strings ; +IN: core-foundation.strings + +HELP: +{ $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." } ; diff --git a/basis/core-foundation/strings/strings-tests.factor b/basis/core-foundation/strings/strings-tests.factor new file mode 100644 index 0000000000..39d5ee6ac0 --- /dev/null +++ b/basis/core-foundation/strings/strings-tests.factor @@ -0,0 +1,9 @@ +! 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" CFRelease ] unit-test +[ "Hello" ] [ "Hello" [ CF>string ] [ CFRelease ] bi ] unit-test +[ "Hello\u003456" ] [ "Hello\u003456" [ CF>string ] [ CFRelease ] bi ] unit-test +[ "Hello\u013456" ] [ "Hello\u013456" [ CF>string ] [ CFRelease ] bi ] unit-test diff --git a/basis/core-foundation/strings/strings.factor b/basis/core-foundation/strings/strings.factor new file mode 100644 index 0000000000..2e6180c897 --- /dev/null +++ b/basis/core-foundation/strings/strings.factor @@ -0,0 +1,66 @@ +! Copyright (C) 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: alien.syntax alien.strings kernel sequences byte-arrays +io.encodings.utf8 math core-foundation core-foundation.arrays ; +IN: core-foundation.strings + +TYPEDEF: void* CFStringRef + +TYPEDEF: int CFStringEncoding +: kCFStringEncodingMacRoman HEX: 0 ; +: kCFStringEncodingWindowsLatin1 HEX: 0500 ; +: kCFStringEncodingISOLatin1 HEX: 0201 ; +: kCFStringEncodingNextStepLatin HEX: 0B01 ; +: kCFStringEncodingASCII HEX: 0600 ; +: kCFStringEncodingUnicode HEX: 0100 ; +: kCFStringEncodingUTF8 HEX: 08000100 ; +: kCFStringEncodingNonLossyASCII HEX: 0BFF ; +: kCFStringEncodingUTF16 HEX: 0100 ; +: kCFStringEncodingUTF16BE HEX: 10000100 ; +: kCFStringEncodingUTF16LE HEX: 14000100 ; +: kCFStringEncodingUTF32 HEX: 0c000100 ; +: kCFStringEncodingUTF32BE HEX: 18000100 ; +: kCFStringEncodingUTF32LE HEX: 1c000100 ; + +FUNCTION: CFStringRef CFStringCreateWithBytes ( + CFAllocatorRef alloc, + UInt8* bytes, + CFIndex numBytes, + CFStringEncoding encoding, + Boolean isExternalRepresentation +) ; + +FUNCTION: CFIndex CFStringGetLength ( CFStringRef theString ) ; + +FUNCTION: void CFStringGetCharacters ( void* theString, CFIndex start, CFIndex length, void* buffer ) ; + +FUNCTION: Boolean CFStringGetCString ( + CFStringRef theString, + char* buffer, + CFIndex bufferSize, + CFStringEncoding encoding +) ; + +FUNCTION: CFStringRef CFStringCreateWithCString ( + CFAllocatorRef alloc, + char* cStr, + CFStringEncoding encoding +) ; + +: ( string -- alien ) + f swap utf8 string>alien kCFStringEncodingUTF8 CFStringCreateWithCString + [ "CFStringCreateWithCString failed" throw ] unless* ; + +: CF>string ( alien -- string ) + dup CFStringGetLength 4 * 1 + [ + dup length + kCFStringEncodingUTF8 + CFStringGetCString + [ "CFStringGetCString failed" throw ] unless + ] keep utf8 alien>string ; + +: CF>string-array ( alien -- seq ) + CF>array [ CF>string ] map ; + +: ( seq -- alien ) + [ ] map [ ] [ [ CFRelease ] each ] bi ; diff --git a/basis/core-foundation/strings/tags.txt b/basis/core-foundation/strings/tags.txt new file mode 100644 index 0000000000..2320bdd648 --- /dev/null +++ b/basis/core-foundation/strings/tags.txt @@ -0,0 +1,2 @@ +unportable +bindings diff --git a/basis/core-foundation/urls/tags.txt b/basis/core-foundation/urls/tags.txt new file mode 100644 index 0000000000..2320bdd648 --- /dev/null +++ b/basis/core-foundation/urls/tags.txt @@ -0,0 +1,2 @@ +unportable +bindings diff --git a/basis/core-foundation/urls/urls-docs.factor b/basis/core-foundation/urls/urls-docs.factor new file mode 100644 index 0000000000..d017e70fa6 --- /dev/null +++ b/basis/core-foundation/urls/urls-docs.factor @@ -0,0 +1,10 @@ +USING: help.syntax help.markup ; +IN: core-foundation.urls + +HELP: +{ $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: +{ $values { "string" "a URL string" } { "url" "a " { $snippet "CFURL" } } } +{ $description "Creates a new " { $snippet "CFURL" } "." } ; diff --git a/basis/core-foundation/urls/urls.factor b/basis/core-foundation/urls/urls.factor new file mode 100644 index 0000000000..9f9d3a67cb --- /dev/null +++ b/basis/core-foundation/urls/urls.factor @@ -0,0 +1,24 @@ +! Copyright (C) 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: alien.syntax kernel core-foundation.strings +core-foundation ; +IN: core-foundation.urls + +: kCFURLPOSIXPathStyle 0 ; inline + +TYPEDEF: void* CFURLRef + +FUNCTION: CFURLRef CFURLCreateWithFileSystemPath ( CFAllocatorRef allocator, CFStringRef filePath, int pathStyle, Boolean isDirectory ) ; + +FUNCTION: CFURLRef CFURLCreateWithString ( CFAllocatorRef allocator, CFStringRef string, CFURLRef base ) ; + +FUNCTION: CFURLRef CFURLCopyFileSystemPath ( CFURLRef url, int pathStyle ) ; + +: ( string dir? -- url ) + [ f over kCFURLPOSIXPathStyle ] dip + CFURLCreateWithFileSystemPath swap CFRelease ; + +: ( string -- url ) + + [ f swap f CFURLCreateWithString ] keep + CFRelease ; diff --git a/basis/io/unix/multiplexers/run-loop/run-loop.factor b/basis/io/unix/multiplexers/run-loop/run-loop.factor index baaf910f37..593fe93ac4 100644 --- a/basis/io/unix/multiplexers/run-loop/run-loop.factor +++ b/basis/io/unix/multiplexers/run-loop/run-loop.factor @@ -1,8 +1,9 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: kernel namespaces math accessors threads alien locals -destructors combinators core-foundation core-foundation.run-loop -io.unix.multiplexers io.unix.multiplexers.kqueue ; +destructors combinators io.unix.multiplexers +io.unix.multiplexers.kqueue core-foundation +core-foundation.run-loop core-foundation.file-descriptors ; IN: io.unix.multiplexers.run-loop TUPLE: run-loop-mx kqueue-mx fd source ; From 38046364ac55438bf7a192e51c3c6b8da747dfba Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 12 Dec 2008 01:00:32 -0600 Subject: [PATCH 35/64] Fix memory test on OpenBSD --- core/memory/memory-tests.factor | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/core/memory/memory-tests.factor b/core/memory/memory-tests.factor index 6794825897..11a6a9d8a9 100644 --- a/core/memory/memory-tests.factor +++ b/core/memory/memory-tests.factor @@ -6,9 +6,10 @@ IN: memory.tests ! LOL [ ] [ vm + "-i=" image append "-generations=2" "-e=USING: memory io prettyprint system ; input-stream gc . 0 exit" - 3array try-process + 4array try-process ] unit-test [ [ ] instances ] must-infer From 36c36a7f83f546009e3a19f12b1694ba320b97b1 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 12 Dec 2008 01:11:37 -0600 Subject: [PATCH 36/64] Update code for core-foundation split, add core-foundation.timers --- .../cocoa/application/application-docs.factor | 2 +- basis/cocoa/application/application.factor | 7 ++--- basis/cocoa/cocoa.factor | 4 +-- basis/cocoa/dialogs/dialogs.factor | 3 ++- basis/cocoa/nibs/nibs.factor | 7 +++-- basis/cocoa/pasteboard/pasteboard.factor | 4 +-- basis/cocoa/plists/plists.factor | 2 +- .../core-foundation/run-loop/run-loop.factor | 18 ++++++++++--- basis/core-foundation/timers/timers.factor | 27 +++++++++++++++++++ basis/ui/cocoa/tools/tools.factor | 8 +++--- basis/ui/cocoa/views/views.factor | 2 +- 11 files changed, 64 insertions(+), 20 deletions(-) create mode 100644 basis/core-foundation/timers/timers.factor diff --git a/basis/cocoa/application/application-docs.factor b/basis/cocoa/application/application-docs.factor index 791613e876..e12b6eb276 100644 --- a/basis/cocoa/application/application-docs.factor +++ b/basis/cocoa/application/application-docs.factor @@ -1,5 +1,5 @@ USING: debugger quotations help.markup help.syntax strings alien -core-foundation ; +core-foundation core-foundation.strings core-foundation.arrays ; IN: cocoa.application HELP: diff --git a/basis/cocoa/application/application.factor b/basis/cocoa/application/application.factor index e2c853ea77..a52aaedce2 100644 --- a/basis/cocoa/application/application.factor +++ b/basis/cocoa/application/application.factor @@ -1,9 +1,10 @@ ! Copyright (C) 2006, 2008 Slava Pestov ! See http://factorcode.org/license.txt for BSD license. USING: alien alien.syntax io kernel namespaces core-foundation -core-foundation.run-loop cocoa.messages cocoa cocoa.classes -cocoa.runtime sequences threads init summary kernel.private -assocs ; +core-foundation.run-loop core-foundation.arrays +core-foundation.data core-foundation.strings cocoa.messages +cocoa cocoa.classes cocoa.runtime sequences threads init summary +kernel.private assocs ; IN: cocoa.application : ( str -- alien ) -> autorelease ; diff --git a/basis/cocoa/cocoa.factor b/basis/cocoa/cocoa.factor index ab86796236..44252a3b19 100644 --- a/basis/cocoa/cocoa.factor +++ b/basis/cocoa/cocoa.factor @@ -2,8 +2,8 @@ ! See http://factorcode.org/license.txt for BSD license. USING: compiler io kernel cocoa.runtime cocoa.subclassing cocoa.messages cocoa.types sequences words vocabs parser -core-foundation namespaces assocs hashtables compiler.units -lexer init ; +core-foundation.bundles namespaces assocs hashtables +compiler.units lexer init ; IN: cocoa : (remember-send) ( selector variable -- ) diff --git a/basis/cocoa/dialogs/dialogs.factor b/basis/cocoa/dialogs/dialogs.factor index 2b01c5d751..13f6f0b7d6 100644 --- a/basis/cocoa/dialogs/dialogs.factor +++ b/basis/cocoa/dialogs/dialogs.factor @@ -1,7 +1,8 @@ ! Copyright (C) 2006, 2008 Slava Pestov ! See http://factorcode.org/license.txt for BSD license. USING: kernel cocoa cocoa.messages cocoa.classes -cocoa.application sequences splitting core-foundation ; +cocoa.application sequences splitting core-foundation +core-foundation.strings ; IN: cocoa.dialogs : ( -- panel ) diff --git a/basis/cocoa/nibs/nibs.factor b/basis/cocoa/nibs/nibs.factor index 31dac2531b..a39cc794d0 100644 --- a/basis/cocoa/nibs/nibs.factor +++ b/basis/cocoa/nibs/nibs.factor @@ -1,5 +1,8 @@ -USING: cocoa.application cocoa.messages cocoa.classes cocoa.runtime -kernel cocoa core-foundation alien.c-types ; +! Copyright (C) 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: cocoa.application cocoa.messages cocoa.classes +cocoa.runtime kernel cocoa alien.c-types core-foundation +core-foundation.arrays ; IN: cocoa.nibs : load-nib ( name -- ) diff --git a/basis/cocoa/pasteboard/pasteboard.factor b/basis/cocoa/pasteboard/pasteboard.factor index b530ccbc37..888f5452e2 100644 --- a/basis/cocoa/pasteboard/pasteboard.factor +++ b/basis/cocoa/pasteboard/pasteboard.factor @@ -1,8 +1,8 @@ ! Copyright (C) 2006, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: alien.accessors arrays kernel cocoa.messages -cocoa.classes cocoa.application cocoa core-foundation sequences -; +cocoa.classes cocoa.application sequences cocoa core-foundation +core-foundation.strings core-foundation.arrays ; IN: cocoa.pasteboard : NSStringPboardType "NSStringPboardType" ; diff --git a/basis/cocoa/plists/plists.factor b/basis/cocoa/plists/plists.factor index bb73b8fac3..cf68f9864a 100644 --- a/basis/cocoa/plists/plists.factor +++ b/basis/cocoa/plists/plists.factor @@ -3,7 +3,7 @@ USING: strings arrays hashtables assocs sequences cocoa.messages cocoa.classes cocoa.application cocoa kernel namespaces io.backend math cocoa.enumeration byte-arrays -combinators alien.c-types core-foundation ; +combinators alien.c-types core-foundation core-foundation.data ; IN: cocoa.plists GENERIC: >plist ( value -- plist ) diff --git a/basis/core-foundation/run-loop/run-loop.factor b/basis/core-foundation/run-loop/run-loop.factor index b7e565e70f..475991a246 100644 --- a/basis/core-foundation/run-loop/run-loop.factor +++ b/basis/core-foundation/run-loop/run-loop.factor @@ -1,8 +1,8 @@ ! Copyright (C) 2008 Slava Pestov ! See http://factorcode.org/license.txt for BSD license. -USING: alien alien.syntax kernel namespaces -core-foundation core-foundation.strings -core-foundation.file-descriptors ; +USING: alien alien.syntax kernel namespaces core-foundation +core-foundation.strings core-foundation.file-descriptors +core-foundation.timers ; IN: core-foundation.run-loop : kCFRunLoopRunFinished 1 ; inline @@ -40,6 +40,18 @@ FUNCTION: void CFRunLoopRemoveSource ( 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? [ diff --git a/basis/core-foundation/timers/timers.factor b/basis/core-foundation/timers/timers.factor new file mode 100644 index 0000000000..eddeb87d1d --- /dev/null +++ b/basis/core-foundation/timers/timers.factor @@ -0,0 +1,27 @@ +! Copyright (C) 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: alien.syntax ; +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 +) ; + +FUNCTION: void CFRunLoopTimerInvalidate ( + CFRunLoopTimerRef timer +); + +FUNCTION: void CFRunLoopTimerSetNextFireDate ( + CFRunLoopTimerRef timer, + CFAbsoluteTime fireDate +) ; diff --git a/basis/ui/cocoa/tools/tools.factor b/basis/ui/cocoa/tools/tools.factor index ccaae0c1ab..a0755e9ec8 100644 --- a/basis/ui/cocoa/tools/tools.factor +++ b/basis/ui/cocoa/tools/tools.factor @@ -1,10 +1,10 @@ -! Copyright (C) 2006, 2007 Slava Pestov. +! Copyright (C) 2006, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: alien.syntax cocoa cocoa.nibs cocoa.application cocoa.classes cocoa.dialogs cocoa.pasteboard cocoa.subclassing -core-foundation help.topics kernel memory namespaces parser -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 -- ) diff --git a/basis/ui/cocoa/views/views.factor b/basis/ui/cocoa/views/views.factor index 7bb9679132..3201779cc5 100644 --- a/basis/ui/cocoa/views/views.factor +++ b/basis/ui/cocoa/views/views.factor @@ -4,7 +4,7 @@ USING: accessors alien alien.c-types arrays assocs cocoa kernel math cocoa.messages cocoa.subclassing cocoa.classes cocoa.views cocoa.application cocoa.pasteboard cocoa.types cocoa.windows sequences ui ui.gadgets ui.gadgets.worlds ui.gestures -core-foundation threads combinators math.geometry.rect ; +core-foundation.strings threads combinators math.geometry.rect ; IN: ui.cocoa.views : send-mouse-moved ( view event -- ) From 0ba2c964af790e9713e7836a7c4eac2c6c7100ae Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 12 Dec 2008 02:18:50 -0600 Subject: [PATCH 37/64] Remove obsolete file, add unit tests for core-foundation.run-loop, add word --- basis/core-foundation/core-foundation-tests.factor | 9 --------- basis/core-foundation/timers/timers.factor | 7 +++++-- .../io/unix/multiplexers/run-loop/run-loop-tests.factor | 5 +++++ 3 files changed, 10 insertions(+), 11 deletions(-) delete mode 100644 basis/core-foundation/core-foundation-tests.factor create mode 100644 basis/io/unix/multiplexers/run-loop/run-loop-tests.factor diff --git a/basis/core-foundation/core-foundation-tests.factor b/basis/core-foundation/core-foundation-tests.factor deleted file mode 100644 index c1d6788d50..0000000000 --- a/basis/core-foundation/core-foundation-tests.factor +++ /dev/null @@ -1,9 +0,0 @@ -! Copyright (C) 2008 Slava Pestov. -! See http://factorcode.org/license.txt for BSD license. -USING: core-foundation tools.test kernel ; -IN: core-foundation - -[ ] [ "Hello" CFRelease ] unit-test -[ "Hello" ] [ "Hello" [ CF>string ] [ CFRelease ] bi ] unit-test -[ "Hello\u003456" ] [ "Hello\u003456" [ CF>string ] [ CFRelease ] bi ] unit-test -[ "Hello\u013456" ] [ "Hello\u013456" [ CF>string ] [ CFRelease ] bi ] unit-test diff --git a/basis/core-foundation/timers/timers.factor b/basis/core-foundation/timers/timers.factor index eddeb87d1d..1d17d99a4d 100644 --- a/basis/core-foundation/timers/timers.factor +++ b/basis/core-foundation/timers/timers.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: alien.syntax ; +USING: alien.syntax system math kernel ; IN: core-foundation.timers TYPEDEF: void* CFRunLoopTimerRef @@ -17,9 +17,12 @@ FUNCTION: CFRunLoopTimerRef CFRunLoopTimerCreate ( CFRunLoopTimerContext* context ) ; +: ( callback -- timer ) + [ f millis 1000 /f 60 0 0 ] dip f CFRunLoopTimerCreate ; + FUNCTION: void CFRunLoopTimerInvalidate ( CFRunLoopTimerRef timer -); +) ; FUNCTION: void CFRunLoopTimerSetNextFireDate ( CFRunLoopTimerRef timer, diff --git a/basis/io/unix/multiplexers/run-loop/run-loop-tests.factor b/basis/io/unix/multiplexers/run-loop/run-loop-tests.factor new file mode 100644 index 0000000000..5f249c6881 --- /dev/null +++ b/basis/io/unix/multiplexers/run-loop/run-loop-tests.factor @@ -0,0 +1,5 @@ +USING: io.unix.multiplexers.run-loop tools.test +destructors ; +IN: io.unix.multiplexers.run-loop.tests + +[ ] [ dispose ] unit-test From 210c661d4da7a37621800c7d09ba0b78f8a19cbf Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 12 Dec 2008 02:41:10 -0600 Subject: [PATCH 38/64] Add unportable tag to core-foundation.timers --- basis/core-foundation/timers/tags.txt | 2 ++ basis/core-foundation/timers/timers.factor | 2 +- 2 files changed, 3 insertions(+), 1 deletion(-) create mode 100644 basis/core-foundation/timers/tags.txt diff --git a/basis/core-foundation/timers/tags.txt b/basis/core-foundation/timers/tags.txt new file mode 100644 index 0000000000..2320bdd648 --- /dev/null +++ b/basis/core-foundation/timers/tags.txt @@ -0,0 +1,2 @@ +unportable +bindings diff --git a/basis/core-foundation/timers/timers.factor b/basis/core-foundation/timers/timers.factor index 1d17d99a4d..049e80b20f 100644 --- a/basis/core-foundation/timers/timers.factor +++ b/basis/core-foundation/timers/timers.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: alien.syntax system math kernel ; +USING: alien.syntax system math kernel core-foundation ; IN: core-foundation.timers TYPEDEF: void* CFRunLoopTimerRef From d2a1a2326bfc73f66d4806fa5fe24e7e319e1c44 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 12 Dec 2008 18:44:43 -0600 Subject: [PATCH 39/64] Use gdb on Windows --- basis/tools/disassembler/disassembler.factor | 11 +++++------ 1 file changed, 5 insertions(+), 6 deletions(-) diff --git a/basis/tools/disassembler/disassembler.factor b/basis/tools/disassembler/disassembler.factor index fac340845b..2a717c084f 100644 --- a/basis/tools/disassembler/disassembler.factor +++ b/basis/tools/disassembler/disassembler.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: tr arrays sequences io words generic system combinators -vocabs.loader ; +vocabs.loader kernel ; IN: tools.disassembler GENERIC: disassemble ( obj -- ) @@ -18,8 +18,7 @@ M: word disassemble word-xt 2array disassemble ; M: method-spec disassemble first2 method disassemble ; -cpu { - { x86.32 [ "tools.disassembler.udis" ] } - { x86.64 [ "tools.disassembler.udis" ] } - { ppc [ "tools.disassembler.gdb" ] } -} case require +cpu x86? os unix? and +"tools.disassembler.udis" +"tools.disassembler.gdb" ? +require From 5e6f94ef62b5a875c51d0bdf0d0661c15995853c Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 12 Dec 2008 18:49:24 -0600 Subject: [PATCH 40/64] Update iokit for core-foundation split --- extra/iokit/iokit.factor | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/extra/iokit/iokit.factor b/extra/iokit/iokit.factor index 680723def9..2317d21ed5 100755 --- a/extra/iokit/iokit.factor +++ b/extra/iokit/iokit.factor @@ -1,5 +1,6 @@ -USING: alien.syntax alien.c-types core-foundation system -combinators kernel sequences debugger io accessors ; +USING: alien.syntax alien.c-types core-foundation +core-foundation.bundles system combinators kernel sequences +debugger io accessors ; IN: iokit << From d3c279469cd0c09a4673f2f08c39d549cfde0fec Mon Sep 17 00:00:00 2001 From: "Jose A. Ortega Ruiz" Date: Sat, 13 Dec 2008 01:54:18 +0100 Subject: [PATCH 41/64] FUEL: Asynchronous comms with Factor implemented. Help mode improvements. --- extra/fuel/fuel.factor | 3 +- misc/fuel/README | 9 +- misc/fuel/fuel-base.el | 2 + misc/fuel/fuel-connection.el | 186 +++++++++++++++++++++++++++++++ misc/fuel/fuel-debug.el | 5 +- misc/fuel/fuel-eval.el | 154 ++++++++++++-------------- misc/fuel/fuel-font-lock.el | 2 +- misc/fuel/fuel-help.el | 205 +++++++++++++++++++++++------------ misc/fuel/fuel-listener.el | 26 +++-- misc/fuel/fuel-mode.el | 23 ++-- 10 files changed, 439 insertions(+), 176 deletions(-) create mode 100644 misc/fuel/fuel-connection.el diff --git a/extra/fuel/fuel.factor b/extra/fuel/fuel.factor index d9db83b5e3..e2535ade30 100644 --- a/extra/fuel/fuel.factor +++ b/extra/fuel/fuel.factor @@ -151,7 +151,8 @@ M: source-file fuel-pprint path>> fuel-pprint ; : fuel-end-eval ( -- ) [ ] (fuel-end-eval) ; inline : fuel-get-edit-location ( defspec -- ) - where [ first2 [ (normalize-path) ] dip 2array fuel-eval-set-result ] when* ; + where [ first2 [ (normalize-path) ] dip 2array fuel-eval-set-result ] + when* ; : fuel-run-file ( path -- ) run-file ; inline diff --git a/misc/fuel/README b/misc/fuel/README index 18f6fa1e94..4dfb16da51 100644 --- a/misc/fuel/README +++ b/misc/fuel/README @@ -50,7 +50,7 @@ Quick key reference (Chords ending in a single letter accept also C- (e.g. C-cC-z is the same as C-cz)). -* In factor files: +* In factor source files: - C-cz : switch to listener - C-co : cycle between code, tests and docs factor files @@ -70,6 +70,13 @@ the same as C-cz)). - g : go to error - : 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 diff --git a/misc/fuel/fuel-base.el b/misc/fuel/fuel-base.el index a62d16cb32..9ea1790380 100644 --- a/misc/fuel/fuel-base.el +++ b/misc/fuel/fuel-base.el @@ -59,5 +59,7 @@ " ") len)) +(defsubst empty-string-p (str) (equal str "")) + (provide 'fuel-base) ;;; fuel-base.el ends here diff --git a/misc/fuel/fuel-connection.el b/misc/fuel/fuel-connection.el new file mode 100644 index 0000000000..191424589c --- /dev/null +++ b/misc/fuel/fuel-connection.el @@ -0,0 +1,186 @@ +;;; fuel-connection.el -- asynchronous comms with the fuel listener + +;; Copyright (C) 2008 Jose Antonio Ortega Ruiz +;; See http://factorcode.org/license.txt for BSD license. + +;; Author: Jose Antonio Ortega Ruiz +;; Keywords: languages, fuel, factor +;; Start date: Thu Dec 11, 2008 03:10 + +;;; Comentary: + +;; Handling communications via a comint buffer running a factor +;; listener. + +;;; Code: + + +;;; Default connection: + +(make-variable-buffer-local + (defvar fuel-con--connection nil)) + +(defun fuel-con--get-connection (buffer/proc) + (if (processp buffer/proc) + (fuel-con--get-connection (process-buffer buffer/proc)) + (with-current-buffer buffer/proc + (or fuel-con--connection + (setq fuel-con--connection + (fuel-con--setup-connection buffer/proc)))))) + + +;;; Request and connection datatypes: + +(defun fuel-con--connection-queue-request (c r) + (let ((reqs (assoc :requests c))) + (setcdr reqs (append (cdr reqs) (list r))))) + +(defun fuel-con--make-request (str cont &optional sender-buffer) + (list :fuel-connection-request + (cons :id (random)) + (cons :string str) + (cons :continuation cont) + (cons :buffer (or sender-buffer (current-buffer))))) + +(defsubst fuel-con--request-p (req) + (and (listp req) (eq (car req) :fuel-connection-request))) + +(defsubst fuel-con--request-id (req) + (cdr (assoc :id req))) + +(defsubst fuel-con--request-string (req) + (cdr (assoc :string req))) + +(defsubst fuel-con--request-continuation (req) + (cdr (assoc :continuation req))) + +(defsubst fuel-con--request-buffer (req) + (cdr (assoc :buffer req))) + +(defsubst fuel-con--request-deactivate (req) + (setcdr (assoc :continuation req) nil)) + +(defsubst fuel-con--request-deactivated-p (req) + (null (cdr (assoc :continuation req)))) + +(defsubst fuel-con--make-connection (buffer) + (list :fuel-connection + (list :requests) + (list :current) + (cons :completed (make-hash-table :weakness 'value)) + (cons :buffer buffer))) + +(defsubst fuel-con--connection-p (c) + (and (listp c) (eq (car c) :fuel-connection))) + +(defsubst fuel-con--connection-requests (c) + (cdr (assoc :requests c))) + +(defsubst fuel-con--connection-current-request (c) + (cdr (assoc :current c))) + +(defun fuel-con--connection-clean-current-request (c) + (let* ((cell (assoc :current c)) + (req (cdr cell))) + (when req + (puthash (fuel-con--request-id req) req (cdr (assoc :completed c))) + (setcdr cell nil)))) + +(defsubst fuel-con--connection-completed-p (c id) + (gethash id (cdr (assoc :completed c)))) + +(defsubst fuel-con--connection-buffer (c) + (cdr (assoc :buffer c))) + +(defun fuel-con--connection-pop-request (c) + (let ((reqs (assoc :requests c)) + (current (assoc :current c))) + (setcdr current (prog1 (cadr reqs) (setcdr reqs (cddr reqs)))) + (if (and current (fuel-con--request-deactivated-p current)) + (fuel-con--connection-pop-request c) + current))) + + +;;; Connection setup: + +(defun fuel-con--setup-connection (buffer) + (set-buffer buffer) + (let ((conn (fuel-con--make-connection buffer))) + (fuel-con--setup-comint) + (setq fuel-con--connection conn))) + +(defun fuel-con--setup-comint () + (add-hook 'comint-redirect-filter-functions + 'fuel-con--comint-redirect-filter t t)) + + +;;; Requests handling: + +(defun fuel-con--process-next (con) + (when (not (fuel-con--connection-current-request con)) + (let* ((buffer (fuel-con--connection-buffer con)) + (req (fuel-con--connection-pop-request con)) + (str (and req (fuel-con--request-string req)))) + (when (and buffer req str) + (set-buffer buffer) + (comint-redirect-send-command str + (get-buffer-create "*factor messages*") + nil + t))))) + +(defun fuel-con--comint-redirect-filter (str) + (if (not fuel-con--connection) + (format "\nERROR: No connection in buffer (%s)\n" str) + (let ((req (fuel-con--connection-current-request fuel-con--connection))) + (if (not req) (format "\nERROR: No current request (%s)\n" str) + (let ((cont (fuel-con--request-continuation req)) + (id (fuel-con--request-id req)) + (rstr (fuel-con--request-string req)) + (buffer (fuel-con--request-buffer req))) + (prog1 + (if (not cont) + (format "\nWARNING: Droping result for request %s:%S (%s)\n" + id rstr str) + (condition-case cerr + (with-current-buffer (or buffer (current-buffer)) + (funcall cont str) + (format "\nINFO: %s:%S processed\nINFO: %s\n" id rstr str)) + (error (format "\nERROR: continuation failed %s:%S \nERROR: %s\n" + id rstr cerr)))) + (fuel-con--connection-clean-current-request fuel-con--connection))))))) + + +;;; Message sending interface: + +(defun fuel-con--send-string (buffer/proc str cont &optional sender-buffer) + (save-current-buffer + (let ((con (fuel-con--get-connection buffer/proc))) + (unless con + (error "FUEL: couldn't find connection")) + (let ((req (fuel-con--make-request str cont sender-buffer))) + (fuel-con--connection-queue-request con req) + (fuel-con--process-next con) + req)))) + +(defvar fuel-connection-timeout 30000 + "Time limit, in msecs, blocking on synchronous evaluation requests") + +(defun fuel-con--send-string/wait (buffer/proc str cont &optional timeout sbuf) + (save-current-buffer + (let* ((con (fuel-con--get-connection buffer/proc)) + (req (fuel-con--send-string buffer/proc str cont sbuf)) + (id (and req (fuel-con--request-id req))) + (time (or timeout fuel-connection-timeout)) + (step 2)) + (when id + (while (and (> time 0) + (not (fuel-con--connection-completed-p con id))) + (sleep-for 0 step) + (setq time (- time step))) + (or (> time 0) + (fuel-con--request-deactivate req) + nil))))) + + +(provide 'fuel-connection) +;;; fuel-connection.el ends here diff --git a/misc/fuel/fuel-debug.el b/misc/fuel/fuel-debug.el index b3aad7f3dc..ad9f47ceb1 100644 --- a/misc/fuel/fuel-debug.el +++ b/misc/fuel/fuel-debug.el @@ -214,7 +214,7 @@ (buffer (if file (find-file-noselect file) (current-buffer)))) (with-current-buffer buffer (fuel-debug--display-retort - (fuel-eval--eval-string/context (format ":%s" n)) + (fuel-eval--send/wait (fuel-eval--cmd/string (format ":%s" n))) (format "Restart %s (%s) successful" n (nth (1- n) rs)))))))) (defun fuel-debug-show--compiler-info (info) @@ -224,7 +224,8 @@ (error "%s information not available" info)) (message "Retrieving %s info ..." info) (unless (fuel-debug--display-retort - (fuel-eval--eval-string info) "" (fuel-debug--buffer-file)) + (fuel-eval--send/wait (fuel-eval--cmd/string info)) + "" (fuel-debug--buffer-file)) (error "Sorry, no %s info available" info)))) diff --git a/misc/fuel/fuel-eval.el b/misc/fuel/fuel-eval.el index 62001cc48c..02bcb54d66 100644 --- a/misc/fuel/fuel-eval.el +++ b/misc/fuel/fuel-eval.el @@ -1,4 +1,4 @@ -;;; fuel-eval.el --- utilities for communication with fuel-listener +;;; fuel-eval.el --- evaluating Factor expressions ;; Copyright (C) 2008 Jose Antonio Ortega Ruiz ;; See http://factorcode.org/license.txt for BSD license. @@ -9,46 +9,16 @@ ;;; Commentary: -;; Protocols for handling communications via a comint buffer running a -;; factor listener. +;; Protocols for sending evaluations to the Factor listener. ;;; Code: (require 'fuel-base) (require 'fuel-syntax) +(require 'fuel-connection) -;;; Syncronous string sending: - -(defvar fuel-eval-log-max-length 16000) - -(defvar fuel-eval--default-proc-function nil) -(defsubst fuel-eval--default-proc () - (and fuel-eval--default-proc-function - (funcall fuel-eval--default-proc-function))) - -(defvar fuel-eval--proc nil) -(defvar fuel-eval--log t) - -(defun fuel-eval--send-string (str) - (let ((proc (or fuel-eval--proc (fuel-eval--default-proc)))) - (when proc - (with-current-buffer (get-buffer-create "*factor messages*") - (goto-char (point-max)) - (when (and (> fuel-eval-log-max-length 0) - (> (point) fuel-eval-log-max-length)) - (erase-buffer)) - (when fuel-eval--log (insert "\n>> " (fuel--shorten-str str 256))) - (newline) - (let ((beg (point))) - (comint-redirect-send-command-to-process str (current-buffer) proc nil t) - (with-current-buffer (process-buffer proc) - (while (not comint-redirect-completed) (sleep-for 0 1))) - (goto-char beg) - (current-buffer)))))) - - -;;; Evaluation protocol +;;; Retort and retort-error datatypes: (defsubst fuel-eval--retort-make (err result &optional output) (list err result output)) @@ -60,57 +30,14 @@ (defsubst fuel-eval--retort-p (ret) (listp ret)) (defsubst fuel-eval--make-parse-error-retort (str) - (fuel-eval--retort-make 'parse-retort-error nil str)) + (fuel-eval--retort-make (cons 'fuel-parse-retort-error str) nil)) -(defun fuel-eval--parse-retort (buffer) +(defun fuel-eval--parse-retort (str) (save-current-buffer - (set-buffer buffer) (condition-case nil - (read (current-buffer)) - (error (fuel-eval--make-parse-error-retort - (buffer-substring-no-properties (point) (point-max))))))) - -(defsubst fuel-eval--send/retort (str) - (fuel-eval--parse-retort (fuel-eval--send-string str))) - -(defsubst fuel-eval--eval-begin () - (fuel-eval--send/retort "fuel-begin-eval")) - -(defsubst fuel-eval--eval-end () - (fuel-eval--send/retort "fuel-begin-eval")) - -(defsubst fuel-eval--factor-array (strs) - (format "V{ %S }" (mapconcat 'identity strs " "))) - -(defsubst fuel-eval--eval-strings (strs &optional no-restart) - (let ((str (format "fuel-eval-%s %s fuel-eval" - (if no-restart "non-restartable" "restartable") - (fuel-eval--factor-array strs)))) - (fuel-eval--send/retort str))) - -(defsubst fuel-eval--eval-string (str &optional no-restart) - (fuel-eval--eval-strings (list str) no-restart)) - -(defun fuel-eval--eval-strings/context (strs &optional no-restart) - (let ((usings (fuel-syntax--usings-update))) - (fuel-eval--send/retort - (format "fuel-eval-%s %s %S %s fuel-eval-in-context" - (if no-restart "non-restartable" "restartable") - (fuel-eval--factor-array strs) - (or fuel-syntax--current-vocab "f") - (if usings (fuel-eval--factor-array usings) "f"))))) - -(defsubst fuel-eval--eval-string/context (str &optional no-restart) - (fuel-eval--eval-strings/context (list str) no-restart)) - -(defun fuel-eval--eval-region/context (begin end &optional no-restart) - (let ((lines (split-string (buffer-substring-no-properties begin end) - "[\f\n\r\v]+" t))) - (when (> (length lines) 0) - (fuel-eval--eval-strings/context lines no-restart)))) - - -;;; Error parsing + (let ((ret (car (read-from-string str)))) + (if (fuel-eval--retort-p ret) ret (error))) + (error (fuel-eval--make-parse-error-retort str))))) (defsubst fuel-eval--error-name (err) (car err)) @@ -137,6 +64,69 @@ (defsubst fuel-eval--error-line-text (err) (nth 3 (fuel-eval--error-lexer-p err))) + +;;; String sending:: + +(defvar fuel-eval-log-max-length 16000) + +(defvar fuel-eval--default-proc-function nil) +(defsubst fuel-eval--default-proc () + (and fuel-eval--default-proc-function + (funcall fuel-eval--default-proc-function))) + +(defvar fuel-eval--proc nil) + +(defvar fuel-eval--log t) + +(defvar fuel-eval--sync-retort nil) + +(defun fuel-eval--send/wait (str &optional timeout buffer) + (setq fuel-eval--sync-retort nil) + (fuel-con--send-string/wait (or fuel-eval--proc (fuel-eval--default-proc)) + str + '(lambda (s) + (setq fuel-eval--sync-retort + (fuel-eval--parse-retort s))) + timeout + buffer) + fuel-eval--sync-retort) + +(defun fuel-eval--send (str cont &optional buffer) + (fuel-con--send-string (or fuel-eval--proc (fuel-eval--default-proc)) + str + `(lambda (s) (,cont (fuel-eval--parse-retort s))) + buffer)) + + +;;; Evaluation protocol + +(defsubst fuel-eval--factor-array (strs) + (format "V{ %S }" (mapconcat 'identity strs " "))) + +(defun fuel-eval--cmd/lines (strs &optional no-rs in usings) + (unless (and in usings) (fuel-syntax--usings-update)) + (let* ((in (cond ((not in) (or fuel-syntax--current-vocab "f")) + ((eq in t) "fuel-scratchpad") + (in in))) + (usings (cond ((not usings) fuel-syntax--usings) + ((eq usings t) nil) + (usings usings)))) + (format "fuel-eval-%srestartable %s %S %s fuel-eval-in-context" + (if no-rs "non-" "") + (fuel-eval--factor-array strs) + in + (fuel-eval--factor-array usings)))) + +(defsubst fuel-eval--cmd/string (str &optional no-rs in usings) + (fuel-eval--cmd/lines (list str) no-rs in usings)) + +(defun fuel-eval--cmd/region (begin end &optional no-rs in usings) + (let ((lines (split-string (buffer-substring-no-properties begin end) + "[\f\n\r\v]+" t))) + (when (> (length lines) 0) + (fuel-eval--cmd/lines lines no-rs in usings)))) + + (provide 'fuel-eval) ;;; fuel-eval.el ends here diff --git a/misc/fuel/fuel-font-lock.el b/misc/fuel/fuel-font-lock.el index 4c710635ba..ba2a499b4b 100644 --- a/misc/fuel/fuel-font-lock.el +++ b/misc/fuel/fuel-font-lock.el @@ -57,7 +57,7 @@ (,fuel-syntax--type-definition-regex 2 'factor-font-lock-type-name) (,fuel-syntax--method-definition-regex (1 'factor-font-lock-type-name) (2 'factor-font-lock-word)) - (,fuel-syntax--parent-type-regex 1 'factor-font-lock-type) + (,fuel-syntax--parent-type-regex 1 'factor-font-lock-type-name) (,fuel-syntax--constructor-regex . 'factor-font-lock-constructor) (,fuel-syntax--setter-regex . 'factor-font-lock-setter-word) (,fuel-syntax--symbol-definition-regex 2 'factor-font-lock-symbol) diff --git a/misc/fuel/fuel-help.el b/misc/fuel/fuel-help.el index 1db9b25d69..227778934a 100644 --- a/misc/fuel/fuel-help.el +++ b/misc/fuel/fuel-help.el @@ -45,6 +45,11 @@ :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 @@ -70,10 +75,10 @@ (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))))))) @@ -101,92 +106,83 @@ displayed in the minibuffer." (message "Fuel Autodoc %s" (if fuel-autodoc-mode "enabled" "disabled"))) -;;;; Factor help mode: +;;; Help browser history: -(defvar fuel-help-mode-map (make-sparse-keymap) - "Keymap for Factor help mode.") +(defvar fuel-help--history + (list nil + (make-ring fuel-help-history-cache-size) + (make-ring fuel-help-history-cache-size))) -(define-key fuel-help-mode-map [(return)] 'fuel-help) +(defvar fuel-help--history-idx 0) -(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)) +(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)) -(defconst fuel-help--headlines-regexp (format "^%s" fuel-help--headlines)) +(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)))) -(defconst fuel-help--font-lock-keywords - `(,@fuel-font-lock--font-lock-keywords - (,fuel-help--headlines-regexp . 'fuel-help-font-lock-headlines))) +(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)))) -(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) - - (fuel-font-lock--font-lock-setup fuel-help--font-lock-keywords t) - - (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)))) - - (setq fuel-autodoc-mode-string "") - (fuel-autodoc-mode) - (run-mode-hooks 'fuel-help-mode-hook)) + +;;; 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))) -;;; Interface: see/help commands +;;; Interactive help commands: (defun fuel-help-short (&optional arg) "See a help summary of symbol at point. @@ -204,6 +200,79 @@ buffer." (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))) + + +;;;; Factor help mode: + +(defvar fuel-help-mode-map + (let ((map (make-sparse-keymap))) + (define-key map "\C-m" 'fuel-help) + (define-key map "q" 'bury-buffer) + (define-key map "b" 'fuel-help-previous) + (define-key map "f" 'fuel-help-next) + (define-key map (kbd "SPC") 'scroll-up) + (define-key map (kbd "S-SPC") 'scroll-down) + map)) + +(defconst fuel-help--headlines + (regexp-opt '("Class description" + "Definition" + "Errors" + "Examples" + "Generic word contract" + "Inputs and outputs" + "Methods" + "Notes" + "Parent topics:" + "See also" + "Syntax" + "Variable description" + "Variable value" + "Vocabulary" + "Warning" + "Word description") + t)) + +(defconst fuel-help--headlines-regexp (format "^%s" fuel-help--headlines)) + +(defconst fuel-help--font-lock-keywords + `(,@fuel-font-lock--font-lock-keywords + (,fuel-help--headlines-regexp . 'fuel-help-font-lock-headlines))) + +(defun fuel-help-mode () + "Major mode for browsing Factor documentation. +\\{fuel-help-mode-map}" + (interactive) + (kill-all-local-variables) + (use-local-map fuel-help-mode-map) + (setq mode-name "Factor Help") + (setq major-mode 'fuel-help-mode) + + (fuel-font-lock--font-lock-setup fuel-help--font-lock-keywords t) + + (setq fuel-autodoc-mode-string "") + (fuel-autodoc-mode) + + (run-mode-hooks 'fuel-help-mode-hook) + (toggle-read-only 1)) + (provide 'fuel-help) ;;; fuel-help.el ends here diff --git a/misc/fuel/fuel-listener.el b/misc/fuel/fuel-listener.el index 9fa330993c..c72f66b21c 100644 --- a/misc/fuel/fuel-listener.el +++ b/misc/fuel/fuel-listener.el @@ -66,7 +66,7 @@ buffer." (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) @@ -83,18 +83,18 @@ buffer." ;;; 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!")))))) ;;; Interface: starting fuel listener @@ -124,6 +124,8 @@ buffer." (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) diff --git a/misc/fuel/fuel-mode.el b/misc/fuel/fuel-mode.el index ea1d4b93ed..feaea1548e 100644 --- a/misc/fuel/fuel-mode.el +++ b/misc/fuel/fuel-mode.el @@ -45,16 +45,20 @@ With prefix argument, ask for the file to run." (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. @@ -62,7 +66,7 @@ Unless called with a prefix, switchs to the compilation results 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) @@ -105,8 +109,9 @@ With prefix, asks for the word to edit." (if word (format " (%s)" word) "")) word) word))) - (let* ((ret (fuel-eval--eval-string/context + (let* ((str (fuel-eval--cmd/string (format "\\ %s fuel-get-edit-location" word))) + (ret (fuel-eval--send/wait str)) (err (fuel-eval--retort-error ret)) (loc (fuel-eval--retort-result ret))) (when (or err (not loc) (not (listp loc)) (not (stringp (car loc)))) From a91dee7810a6eeb3003ced2c89e777c37bc7e64b Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 12 Dec 2008 19:48:17 -0600 Subject: [PATCH 42/64] Fix for native I/O backends that create callbacks in deployed apps; this affected tools.deploy.test[35] ever since run-loop multiplexer landed on OS X --- basis/stack-checker/alien/alien.factor | 6 ------ core/alien/alien.factor | 8 +++++++- core/io/backend/backend.factor | 4 +++- 3 files changed, 10 insertions(+), 8 deletions(-) diff --git a/basis/stack-checker/alien/alien.factor b/basis/stack-checker/alien/alien.factor index a38e9ea784..f52632040d 100644 --- a/basis/stack-checker/alien/alien.factor +++ b/basis/stack-checker/alien/alien.factor @@ -61,12 +61,6 @@ TUPLE: alien-callback-params < alien-node-params quot xt ; ! Quotation which coerces return value to required type return-prep-quot infer-quot-here ; -! Callbacks are registered in a global hashtable. If you clear -! this hashtable, they will all be blown away by code GC, beware -SYMBOL: callbacks - -[ H{ } clone callbacks set-global ] "alien.compiler" add-init-hook - : register-callback ( word -- ) callbacks get conjoin ; : callback-bottom ( params -- ) diff --git a/core/alien/alien.factor b/core/alien/alien.factor index 6a5dfe30df..c97e36e889 100644 --- a/core/alien/alien.factor +++ b/core/alien/alien.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2004, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: accessors assocs kernel math namespaces sequences system -kernel.private byte-arrays arrays ; +kernel.private byte-arrays arrays init ; IN: alien ! Some predicate classes used by the compiler for optimization @@ -72,3 +72,9 @@ ERROR: alien-invoke-error library symbol ; : alien-invoke ( ... return library function parameters -- ... ) 2over alien-invoke-error ; + +! Callbacks are registered in a global hashtable. If you clear +! this hashtable, they will all be blown away by code GC, beware. +SYMBOL: callbacks + +[ H{ } clone callbacks set-global ] "alien" add-init-hook diff --git a/core/io/backend/backend.factor b/core/io/backend/backend.factor index 5456f2251c..e2c6c3d464 100644 --- a/core/io/backend/backend.factor +++ b/core/io/backend/backend.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2007, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: init kernel system namespaces io io.encodings -io.encodings.utf8 init assocs splitting ; +io.encodings.utf8 init assocs splitting alien ; IN: io.backend SYMBOL: io-backend @@ -32,5 +32,7 @@ M: object normalize-directory normalize-path ; io-backend set-global init-io init-stdio "io.files" init-hooks get at call ; +! Note that we have 'alien' in our using list so that the alien +! init hook runs before this one. [ init-io embedded? [ init-stdio ] unless ] "io.backend" add-init-hook From 8433a9954adb9320066531738da00dce391443da Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 12 Dec 2008 19:48:34 -0600 Subject: [PATCH 43/64] Fix dispose method on run-loop-mx --- basis/io/unix/multiplexers/run-loop/run-loop.factor | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/basis/io/unix/multiplexers/run-loop/run-loop.factor b/basis/io/unix/multiplexers/run-loop/run-loop.factor index 593fe93ac4..7b80e461dc 100644 --- a/basis/io/unix/multiplexers/run-loop/run-loop.factor +++ b/basis/io/unix/multiplexers/run-loop/run-loop.factor @@ -40,8 +40,8 @@ SYMBOL: kqueue-run-loop-source M: run-loop-mx dispose [ { - [ fd>> &dispose drop ] - [ source>> &dispose drop ] + [ fd>> &CFRelease drop ] + [ source>> &CFRelease drop ] [ remove-kqueue-from-run-loop ] [ kqueue-mx>> &dispose drop ] } cleave From 2182bd6422bc87b96bd40f85ae5c06b1a88f82cc Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 12 Dec 2008 19:48:51 -0600 Subject: [PATCH 44/64] Add a new deploy test to test callbacks --- basis/tools/deploy/deploy-tests.factor | 5 +++++ basis/tools/deploy/test/3/deploy.factor | 19 ++++++++++--------- basis/tools/deploy/test/9/9.factor | 10 ++++++++++ basis/tools/deploy/test/9/deploy.factor | 15 +++++++++++++++ 4 files changed, 40 insertions(+), 9 deletions(-) create mode 100644 basis/tools/deploy/test/9/9.factor create mode 100644 basis/tools/deploy/test/9/deploy.factor diff --git a/basis/tools/deploy/deploy-tests.factor b/basis/tools/deploy/deploy-tests.factor index 71dc746fb5..a390ce56c4 100644 --- a/basis/tools/deploy/deploy-tests.factor +++ b/basis/tools/deploy/deploy-tests.factor @@ -107,3 +107,8 @@ M: quit-responder call-responder* "tools.deploy.test.8" shake-and-bake run-temp-image ] unit-test + +[ ] [ + "tools.deploy.test.9" shake-and-bake + run-temp-image +] unit-test diff --git a/basis/tools/deploy/test/3/deploy.factor b/basis/tools/deploy/test/3/deploy.factor index b38c5da676..c318ac4b6e 100644 --- a/basis/tools/deploy/test/3/deploy.factor +++ b/basis/tools/deploy/test/3/deploy.factor @@ -1,14 +1,15 @@ USING: tools.deploy.config ; H{ - { deploy-threads? t } - { deploy-c-types? f } - { deploy-ui? f } - { deploy-word-props? f } - { deploy-word-defs? f } - { deploy-math? t } - { deploy-io 3 } + { deploy-unicode? f } { deploy-name "tools.deploy.test.3" } - { deploy-compiler? t } - { deploy-reflection 1 } + { deploy-ui? f } { "stop-after-last-window?" t } + { deploy-word-defs? f } + { deploy-reflection 2 } + { deploy-compiler? t } + { deploy-threads? t } + { deploy-io 3 } + { deploy-math? t } + { deploy-word-props? f } + { deploy-c-types? f } } diff --git a/basis/tools/deploy/test/9/9.factor b/basis/tools/deploy/test/9/9.factor new file mode 100644 index 0000000000..a1cbd5bc66 --- /dev/null +++ b/basis/tools/deploy/test/9/9.factor @@ -0,0 +1,10 @@ +USING: alien kernel math ; +IN: tools.deploy.test.9 + +: callback-test ( -- callback ) + "int" { "int" } "cdecl" [ 1 + ] alien-callback ; + +: indirect-test ( -- ) + 10 callback-test "int" { "int" } "cdecl" alien-indirect 11 assert= ; + +MAIN: indirect-test diff --git a/basis/tools/deploy/test/9/deploy.factor b/basis/tools/deploy/test/9/deploy.factor new file mode 100644 index 0000000000..91b1da5697 --- /dev/null +++ b/basis/tools/deploy/test/9/deploy.factor @@ -0,0 +1,15 @@ +USING: tools.deploy.config ; +H{ + { deploy-unicode? f } + { deploy-name "tools.deploy.test.9" } + { deploy-ui? f } + { "stop-after-last-window?" t } + { deploy-word-defs? f } + { deploy-reflection 1 } + { deploy-compiler? t } + { deploy-threads? f } + { deploy-io 1 } + { deploy-math? t } + { deploy-word-props? f } + { deploy-c-types? f } +} From 115d6e792f9d7be08ee1865ebb02a0ec47b90620 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 12 Dec 2008 19:49:22 -0600 Subject: [PATCH 45/64] Change deploy descriptor back --- basis/tools/deploy/test/3/deploy.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/basis/tools/deploy/test/3/deploy.factor b/basis/tools/deploy/test/3/deploy.factor index c318ac4b6e..f3131237bf 100644 --- a/basis/tools/deploy/test/3/deploy.factor +++ b/basis/tools/deploy/test/3/deploy.factor @@ -5,7 +5,7 @@ H{ { deploy-ui? f } { "stop-after-last-window?" t } { deploy-word-defs? f } - { deploy-reflection 2 } + { deploy-reflection 1 } { deploy-compiler? t } { deploy-threads? t } { deploy-io 3 } From 8be42496b3722a36e316a3d10cbcc2e53325a535 Mon Sep 17 00:00:00 2001 From: "Jose A. Ortega Ruiz" Date: Sat, 13 Dec 2008 03:40:36 +0100 Subject: [PATCH 46/64] FUEL: Ooops, infinite recursion fix. --- misc/fuel/fuel-connection.el | 68 +++++++++++++++++++++++++++++------- misc/fuel/fuel-debug.el | 3 +- misc/fuel/fuel-help.el | 3 +- 3 files changed, 60 insertions(+), 14 deletions(-) diff --git a/misc/fuel/fuel-connection.el b/misc/fuel/fuel-connection.el index 191424589c..247657aa8c 100644 --- a/misc/fuel/fuel-connection.el +++ b/misc/fuel/fuel-connection.el @@ -96,7 +96,8 @@ (let ((reqs (assoc :requests c)) (current (assoc :current c))) (setcdr current (prog1 (cadr reqs) (setcdr reqs (cddr reqs)))) - (if (and current (fuel-con--request-deactivated-p current)) + (if (and (cdr current) + (fuel-con--request-deactivated-p (cdr current))) (fuel-con--connection-pop-request c) current))) @@ -113,6 +114,47 @@ (add-hook 'comint-redirect-filter-functions 'fuel-con--comint-redirect-filter t t)) + +;;; 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)))) + +(defsubst fuel-con--log-msg (type &rest args) + (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) "")) + ;;; Requests handling: @@ -123,30 +165,32 @@ (str (and req (fuel-con--request-string req)))) (when (and buffer req str) (set-buffer buffer) - (comint-redirect-send-command str - (get-buffer-create "*factor messages*") - nil - t))))) + (when fuel-con--log-verbose-p + (with-current-buffer (fuel-con--log-buffer) + (let ((inhibit-read-only t)) + (insert (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--comint-redirect-filter (str) (if (not fuel-con--connection) - (format "\nERROR: No connection in buffer (%s)\n" str) + (fuel-con--log-error "No connection in buffer (%s)" str) (let ((req (fuel-con--connection-current-request fuel-con--connection))) - (if (not req) (format "\nERROR: No current request (%s)\n" str) + (if (not req) (fuel-con--log-error "No current request (%s)" str) (let ((cont (fuel-con--request-continuation req)) (id (fuel-con--request-id req)) (rstr (fuel-con--request-string req)) (buffer (fuel-con--request-buffer req))) (prog1 (if (not cont) - (format "\nWARNING: Droping result for request %s:%S (%s)\n" - id rstr str) + (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) - (format "\nINFO: %s:%S processed\nINFO: %s\n" id rstr str)) - (error (format "\nERROR: continuation failed %s:%S \nERROR: %s\n" - id rstr cerr)))) + (fuel-con--log-info "<%s>: processed\n\t%s" id str)) + (error (fuel-con--log-error "<%s>: continuation failed %S \n\t%s" + id rstr cerr)))) (fuel-con--connection-clean-current-request fuel-con--connection))))))) diff --git a/misc/fuel/fuel-debug.el b/misc/fuel/fuel-debug.el index ad9f47ceb1..a7c06e4b3e 100644 --- a/misc/fuel/fuel-debug.el +++ b/misc/fuel/fuel-debug.el @@ -253,13 +253,14 @@ invoking restarts as needed. \\{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)) diff --git a/misc/fuel/fuel-help.el b/misc/fuel/fuel-help.el index 227778934a..1d39d1571d 100644 --- a/misc/fuel/fuel-help.el +++ b/misc/fuel/fuel-help.el @@ -261,6 +261,7 @@ buffer." \\{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) @@ -271,7 +272,7 @@ buffer." (fuel-autodoc-mode) (run-mode-hooks 'fuel-help-mode-hook) - (toggle-read-only 1)) + (setq buffer-read-only t)) (provide 'fuel-help) From b3428c61e6560511f4807464c45d02b66d04d563 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 12 Dec 2008 21:06:16 -0600 Subject: [PATCH 47/64] Better bootstrap error handling --- basis/bootstrap/stage2.factor | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) diff --git a/basis/bootstrap/stage2.factor b/basis/bootstrap/stage2.factor index fb7292b989..45a6c354a6 100644 --- a/basis/bootstrap/stage2.factor +++ b/basis/bootstrap/stage2.factor @@ -102,6 +102,8 @@ SYMBOL: bootstrap-time ] if ] [ drop - load-help? off - "resource:basis/bootstrap/bootstrap-error.factor" run-file + [ + load-help? off + "resource:basis/bootstrap/bootstrap-error.factor" run-file + ] with-scope ] recover From 50a78db9bdbac623b63f3b1ac7a8c08ebe50afc0 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 12 Dec 2008 21:06:46 -0600 Subject: [PATCH 48/64] Add words for working with CFTimeInterval and CFAbsoluteDate types --- basis/core-foundation/core-foundation.factor | 9 ++++++++- basis/core-foundation/timers/timers.factor | 8 ++++++-- 2 files changed, 14 insertions(+), 3 deletions(-) diff --git a/basis/core-foundation/core-foundation.factor b/basis/core-foundation/core-foundation.factor index 0f64c0666f..51173aff21 100644 --- a/basis/core-foundation/core-foundation.factor +++ b/basis/core-foundation/core-foundation.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2006, 2008 Slava Pestov ! See http://factorcode.org/license.txt for BSD license. -USING: alien.syntax destructors accessors kernel ; +USING: alien.syntax destructors accessors kernel calendar ; IN: core-foundation TYPEDEF: void* CFTypeRef @@ -30,3 +30,10 @@ M: CFRelease-destructor dispose* alien>> CFRelease ; : |CFRelease ( alien -- alien ) dup f CFRelease-destructor boa |dispose drop ; inline + +: >CFTimeInterval ( duration -- interval ) + duration>seconds ; inline + +: >CFAbsoluteTime ( timestamp -- time ) + T{ timestamp { year 2001 } { month 1 } { day 1 } } time- + duration>seconds ; inline diff --git a/basis/core-foundation/timers/timers.factor b/basis/core-foundation/timers/timers.factor index 049e80b20f..0acd92ced1 100644 --- a/basis/core-foundation/timers/timers.factor +++ b/basis/core-foundation/timers/timers.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: alien.syntax system math kernel core-foundation ; +USING: alien.syntax system math kernel core-foundation calendar ; IN: core-foundation.timers TYPEDEF: void* CFRunLoopTimerRef @@ -18,12 +18,16 @@ FUNCTION: CFRunLoopTimerRef CFRunLoopTimerCreate ( ) ; : ( callback -- timer ) - [ f millis 1000 /f 60 0 0 ] dip f CFRunLoopTimerCreate ; + [ 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 From bb45fa93a713356a27560e5ac53cfee6b87ea6a8 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 12 Dec 2008 23:56:19 -0600 Subject: [PATCH 49/64] Add a way to stop the io thread --- basis/io/thread/thread.factor | 16 +++++++++++----- 1 file changed, 11 insertions(+), 5 deletions(-) diff --git a/basis/io/thread/thread.factor b/basis/io/thread/thread.factor index fe86ba9e3d..7589d4918e 100644 --- a/basis/io/thread/thread.factor +++ b/basis/io/thread/thread.factor @@ -1,14 +1,20 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. +USING: threads io.backend namespaces init math kernel ; IN: io.thread -USING: threads io.backend namespaces init math ; + +! The Cocoa UI backend stops the I/O thread and takes over +! completely. +SYMBOL: io-thread-running? : io-thread ( -- ) sleep-time io-multiplex yield ; : start-io-thread ( -- ) - [ io-thread t ] - "I/O wait" spawn-server - \ io-thread set-global ; + [ [ io-thread-running? get-global ] [ io-thread ] [ ] while ] + "I/O wait" spawn drop ; -[ start-io-thread ] "io.thread" add-init-hook +[ + t io-thread-running? set-global + start-io-thread +] "io.thread" add-init-hook From 5ecffec1b940d2a963f8027da4170dc69ceb9820 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 12 Dec 2008 23:57:16 -0600 Subject: [PATCH 50/64] Clean up run loop I/O multiplexer and make most of it independent of the I/O system; the UI will use it too --- .../core-foundation/run-loop/run-loop.factor | 84 ++++++++++++++++++- .../multiplexers/run-loop/run-loop.factor | 47 +++-------- 2 files changed, 92 insertions(+), 39 deletions(-) diff --git a/basis/core-foundation/run-loop/run-loop.factor b/basis/core-foundation/run-loop/run-loop.factor index 475991a246..5f2ff7bd53 100644 --- a/basis/core-foundation/run-loop/run-loop.factor +++ b/basis/core-foundation/run-loop/run-loop.factor @@ -1,8 +1,9 @@ ! Copyright (C) 2008 Slava Pestov ! See http://factorcode.org/license.txt for BSD license. -USING: alien alien.syntax kernel namespaces core-foundation -core-foundation.strings core-foundation.file-descriptors -core-foundation.timers ; +USING: accessors alien alien.syntax kernel math namespaces +sequences destructors combinators threads heaps deques calendar +core-foundation core-foundation.strings +core-foundation.file-descriptors core-foundation.timers ; IN: core-foundation.run-loop : kCFRunLoopRunFinished 1 ; inline @@ -59,3 +60,80 @@ FUNCTION: void CFRunLoopRemoveTimer ( "kCFRunLoopDefaultMode" dup \ CFRunLoopDefaultMode set-global ] when ; + +TUPLE: run-loop fds sources timers ; + +: ( -- 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 expiry-check set-global + 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 -- ) + [ + |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 ; + +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 add-timer-to-run-loop ; + +: run-one-iteration ( us -- handled? ) + reset-run-loop + CFRunLoopDefaultMode + swap [ microseconds ] [ 5 minutes ] if* >CFTimeInterval + t CFRunLoopRunInMode kCFRunLoopRunHandledSource = ; diff --git a/basis/io/unix/multiplexers/run-loop/run-loop.factor b/basis/io/unix/multiplexers/run-loop/run-loop.factor index 7b80e461dc..4b2486d19f 100644 --- a/basis/io/unix/multiplexers/run-loop/run-loop.factor +++ b/basis/io/unix/multiplexers/run-loop/run-loop.factor @@ -1,50 +1,27 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: kernel namespaces math accessors threads alien locals -destructors combinators io.unix.multiplexers +USING: kernel arrays namespaces math accessors alien locals +destructors system threads io.unix.multiplexers io.unix.multiplexers.kqueue core-foundation -core-foundation.run-loop core-foundation.file-descriptors ; +core-foundation.run-loop ; IN: io.unix.multiplexers.run-loop -TUPLE: run-loop-mx kqueue-mx fd source ; +TUPLE: run-loop-mx kqueue-mx ; -: kqueue-callback ( -- callback ) +: file-descriptor-callback ( -- callback ) "void" { "CFFileDescriptorRef" "CFOptionFlags" "void*" } "cdecl" [ 3drop 0 mx get kqueue-mx>> wait-for-events - mx get fd>> enable-all-callbacks + reset-run-loop yield - ] - alien-callback ; - -SYMBOL: kqueue-run-loop-source - -: create-kqueue-source ( fd -- source ) - f swap 0 CFFileDescriptorCreateRunLoopSource ; - -: add-kqueue-to-run-loop ( mx -- ) - CFRunLoopGetMain swap source>> CFRunLoopDefaultMode CFRunLoopAddSource ; - -: remove-kqueue-from-run-loop ( source -- ) - CFRunLoopGetMain swap source>> CFRunLoopDefaultMode CFRunLoopRemoveSource ; + ] alien-callback ; : ( -- mx ) [ |dispose - dup fd>> kqueue-callback |dispose - dup create-kqueue-source run-loop-mx boa - dup add-kqueue-to-run-loop - ] with-destructors ; - -M: run-loop-mx dispose - [ - { - [ fd>> &CFRelease drop ] - [ source>> &CFRelease drop ] - [ remove-kqueue-from-run-loop ] - [ kqueue-mx>> &dispose drop ] - } cleave + 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 ; @@ -52,7 +29,5 @@ 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 -- ) - mx fd>> enable-all-callbacks - CFRunLoopDefaultMode us [ 1000000 /f ] [ 60 ] if* t CFRunLoopRunInMode - kCFRunLoopRunHandledSource = [ 0 mx wait-for-events ] when ; +M: run-loop-mx wait-for-events ( us mx -- ) + swap run-one-iteration [ 0 swap wait-for-events ] [ drop ] if ; From 323de69e88afcee35d2ebb1dbcb391da6d6d8199 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 12 Dec 2008 23:57:28 -0600 Subject: [PATCH 51/64] Remove obsolete tests --- basis/io/unix/multiplexers/run-loop/run-loop-tests.factor | 5 ----- 1 file changed, 5 deletions(-) delete mode 100644 basis/io/unix/multiplexers/run-loop/run-loop-tests.factor diff --git a/basis/io/unix/multiplexers/run-loop/run-loop-tests.factor b/basis/io/unix/multiplexers/run-loop/run-loop-tests.factor deleted file mode 100644 index 5f249c6881..0000000000 --- a/basis/io/unix/multiplexers/run-loop/run-loop-tests.factor +++ /dev/null @@ -1,5 +0,0 @@ -USING: io.unix.multiplexers.run-loop tools.test -destructors ; -IN: io.unix.multiplexers.run-loop.tests - -[ ] [ dispose ] unit-test From 053c15e476d7548551717b1a782650f875aa4628 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 12 Dec 2008 23:58:28 -0600 Subject: [PATCH 52/64] This is where all the recent I/O and core foundation work comes together: use core-foundation.run-loop to receive events on Mac OS X instead of weak-ass Squeak-style polling every 10ms --- basis/ui/backend/backend.factor | 2 -- basis/ui/cocoa/cocoa.factor | 19 ++++++++++--------- basis/ui/event-loop/event-loop.factor | 19 +++++++++++++++++++ basis/ui/ui.factor | 13 ------------- basis/ui/windows/windows.factor | 12 ++++++------ basis/ui/x11/x11.factor | 6 +++--- 6 files changed, 38 insertions(+), 33 deletions(-) create mode 100644 basis/ui/event-loop/event-loop.factor diff --git a/basis/ui/backend/backend.factor b/basis/ui/backend/backend.factor index aa84419d64..eaa0953d25 100755 --- a/basis/ui/backend/backend.factor +++ b/basis/ui/backend/backend.factor @@ -5,8 +5,6 @@ IN: ui.backend SYMBOL: ui-backend -HOOK: do-events ui-backend ( -- ) - HOOK: set-title ui-backend ( string world -- ) HOOK: set-fullscreen* ui-backend ( ? world -- ) diff --git a/basis/ui/cocoa/cocoa.factor b/basis/ui/cocoa/cocoa.factor index fecbb52a25..331c0a698c 100755 --- a/basis/ui/cocoa/cocoa.factor +++ b/basis/ui/cocoa/cocoa.factor @@ -3,10 +3,11 @@ 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.nibs sequences system -ui ui.backend ui.clipboards ui.gadgets ui.gadgets.worlds -ui.cocoa.views core-foundation threads math.geometry.rect fry -libc generalizations alien.c-types cocoa.views combinators ; +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 ; @@ -18,9 +19,6 @@ C: 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 @@ -134,8 +132,8 @@ CLASS: { { +name+ "FactorApplicationDelegate" } } -{ "applicationDidFinishLaunching:" "void" { "id" "SEL" "id" } - [ 3drop event-loop ] +{ "applicationDidUpdate:" "void" { "id" "SEL" "id" } + [ 3drop reset-run-loop ] } ; : install-app-delegate ( -- ) @@ -153,6 +151,9 @@ M: cocoa-ui-backend ui init-clipboard cocoa-init-hook get call start-ui + f io-thread-running? set-global + init-thread-timer + reset-run-loop NSApp -> run ] ui-running ] with-cocoa ; diff --git a/basis/ui/event-loop/event-loop.factor b/basis/ui/event-loop/event-loop.factor new file mode 100644 index 0000000000..fe6f4d7de5 --- /dev/null +++ b/basis/ui/event-loop/event-loop.factor @@ -0,0 +1,19 @@ +! Copyright (C) 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: ui.backend kernel namespaces sequences deques calendar +threads ; +IN: ui.event-loop + +: event-loop? ( -- ? ) + { + { [ stop-after-last-window? get not ] [ t ] } + { [ graft-queue deque-empty? not ] [ t ] } + { [ windows get-global empty? not ] [ t ] } + [ f ] + } cond ; + +HOOK: do-events ui-backend ( -- ) + +: event-loop ( quot -- ) [ event-loop? ] [ do-events ] [ ] while ; + +: ui-wait ( -- ) 10 milliseconds sleep ; diff --git a/basis/ui/ui.factor b/basis/ui/ui.factor index 1ee860c974..b6bc172c21 100644 --- a/basis/ui/ui.factor +++ b/basis/ui/ui.factor @@ -12,16 +12,6 @@ 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 ; @@ -155,9 +145,6 @@ SYMBOL: ui-hook ] assert-depth ] [ ui-error ] recover ; -: ui-wait ( -- ) - 10 milliseconds sleep ; - SYMBOL: ui-thread : ui-running ( quot -- ) diff --git a/basis/ui/windows/windows.factor b/basis/ui/windows/windows.factor index 35ee9f9a60..7f68bb5736 100755 --- a/basis/ui/windows/windows.factor +++ b/basis/ui/windows/windows.factor @@ -3,14 +3,14 @@ ! See http://factorcode.org/license.txt for BSD license. USING: alien alien.c-types alien.strings arrays assocs ui ui.gadgets ui.backend ui.clipboards ui.gadgets.worlds -ui.gestures io kernel math math.vectors namespaces make -sequences strings vectors words windows.kernel32 windows.gdi32 -windows.user32 windows.opengl32 windows.messages windows.types -windows.nt windows threads libc combinators fry +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 diff --git a/basis/ui/x11/x11.factor b/basis/ui/x11/x11.factor index 817e356712..9be3c2fd10 100755 --- a/basis/ui/x11/x11.factor +++ b/basis/ui/x11/x11.factor @@ -2,9 +2,9 @@ ! See http://factorcode.org/license.txt for BSD license. USING: accessors alien alien.c-types arrays ui ui.gadgets ui.gestures ui.backend ui.clipboards ui.gadgets.worlds ui.render -assocs kernel math namespaces opengl sequences strings x11.xlib -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 ; From a4ba0453b3a32de5200fc9a114bfc54500e861de Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 13 Dec 2008 00:00:39 -0600 Subject: [PATCH 53/64] Fix UI docs --- basis/ui/ui-docs.factor | 4 +--- 1 file changed, 1 insertion(+), 3 deletions(-) diff --git a/basis/ui/ui-docs.factor b/basis/ui/ui-docs.factor index 738d259cad..64a98fee03 100644 --- a/basis/ui/ui-docs.factor +++ b/basis/ui/ui-docs.factor @@ -143,9 +143,7 @@ ARTICLE: "ui-backend-init" "UI initialization and the event loop" } "The above word must call the following:" { $subsection start-ui } -"The " { $link ui } " word must not return until the event loop has stopped and the UI has been shut down." -$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:" From 7ad494d2dd2382e0711cff6f3d8cc32f2ad655e7 Mon Sep 17 00:00:00 2001 From: slava Date: Sat, 13 Dec 2008 00:09:36 -0600 Subject: [PATCH 54/64] Add Display structure --- basis/x11/xlib/xlib.factor | 7 ++++++- 1 file changed, 6 insertions(+), 1 deletion(-) diff --git a/basis/x11/xlib/xlib.factor b/basis/x11/xlib/xlib.factor index 555eb573fc..58b4995c40 100644 --- a/basis/x11/xlib/xlib.factor +++ b/basis/x11/xlib/xlib.factor @@ -31,7 +31,6 @@ TYPEDEF: XID KeySym TYPEDEF: ulong Atom TYPEDEF: char* XPointer -TYPEDEF: void* Display* TYPEDEF: void* Screen* TYPEDEF: void* GC TYPEDEF: void* Visual* @@ -66,6 +65,12 @@ TYPEDEF: void* Atom** ! 2 - Display Functions ! +! This struct is incomplete +C-STRUCT: Display +{ "void*" "ext_data" } +{ "void*" "free_funcs" } +{ "int" "fd" } ; + FUNCTION: Display* XOpenDisplay ( void* display_name ) ; ! 2.2 Obtaining Information about the Display, Image Formats, or Screens From 7bf857650c322290e5445e1d8113f4527f03adcf Mon Sep 17 00:00:00 2001 From: slava Date: Sat, 13 Dec 2008 03:49:22 -0600 Subject: [PATCH 55/64] Remove stop-after-last-window? option, it's obsolete, get ui.event-loop (only used on X11 and Windows) to load --- basis/tools/deploy/shaker/strip-cocoa.factor | 4 ---- basis/ui/event-loop/event-loop.factor | 7 +++---- basis/ui/tools/deploy/deploy.factor | 5 ----- basis/ui/ui.factor | 3 --- basis/ui/windows/windows.factor | 1 - 5 files changed, 3 insertions(+), 17 deletions(-) diff --git a/basis/tools/deploy/shaker/strip-cocoa.factor b/basis/tools/deploy/shaker/strip-cocoa.factor index 773b2d0f3b..df64443b7b 100644 --- a/basis/tools/deploy/shaker/strip-cocoa.factor +++ b/basis/tools/deploy/shaker/strip-cocoa.factor @@ -19,12 +19,8 @@ IN: cocoa.application [ [ die ] 19 setenv ] "cocoa.application" add-init-hook -"stop-after-last-window?" get - H{ } clone \ pool [ global [ - "stop-after-last-window?" "ui" lookup set - ! Only keeps those methods that we actually call sent-messages get super-sent-messages get assoc-union objc-methods [ assoc-intersect pool-values ] change diff --git a/basis/ui/event-loop/event-loop.factor b/basis/ui/event-loop/event-loop.factor index fe6f4d7de5..7c08d802f5 100644 --- a/basis/ui/event-loop/event-loop.factor +++ b/basis/ui/event-loop/event-loop.factor @@ -1,12 +1,11 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: ui.backend kernel namespaces sequences deques calendar -threads ; +USING: calendar combinators deques kernel namespaces sequences +threads ui ui.backend ui.gadgets ; IN: ui.event-loop : event-loop? ( -- ? ) { - { [ stop-after-last-window? get not ] [ t ] } { [ graft-queue deque-empty? not ] [ t ] } { [ windows get-global empty? not ] [ t ] } [ f ] @@ -14,6 +13,6 @@ IN: ui.event-loop HOOK: do-events ui-backend ( -- ) -: event-loop ( quot -- ) [ event-loop? ] [ do-events ] [ ] while ; +: event-loop ( -- ) [ event-loop? ] [ do-events ] [ ] while ; : ui-wait ( -- ) 10 milliseconds sleep ; diff --git a/basis/ui/tools/deploy/deploy.factor b/basis/ui/tools/deploy/deploy.factor index f233c9f162..38db81c3dc 100644 --- a/basis/ui/tools/deploy/deploy.factor +++ b/basis/ui/tools/deploy/deploy.factor @@ -18,10 +18,6 @@ TUPLE: deploy-gadget < pack vocab settings ; deploy-ui? get "Include user interface framework" add-gadget ; -: exit-when-windows-closed ( parent -- parent ) - "stop-after-last-window?" get - "Exit when last UI window closed" add-gadget ; - : io-settings ( parent -- parent ) "Input/output support:"