Merge branch 'master' of git://factorcode.org/git/factor

basis/documents/documents.factor

@@ -5,9 +5,9 @@ sequences strings splitting combinators unicode.categories
 math.order ;
 IN: documents
 
-: +col ( loc n -- newloc ) >r first2 r> + 2array ;
+: +col ( loc n -- newloc ) [ first2 ] dip + 2array ;
 
-: +line ( loc n -- newloc ) >r first2 swap r> + swap 2array ;
+: +line ( loc n -- newloc ) [ first2 swap ] dip + swap 2array ;
 
 : =col ( n loc -- newloc ) first swap 2array ;
 
@@ -31,10 +31,10 @@ TUPLE: document < model locs ;
 : doc-line ( n document -- string ) value>> nth ;
 
 : doc-lines ( from to document -- slice )
-    >r 1+ r> value>> <slice> ;
+    [ 1+ ] dip value>> <slice> ;
 
 : start-on-line ( document from line# -- n1 )
-    >r dup first r> = [ nip second ] [ 2drop 0 ] if ;
+    [ dup first ] dip = [ nip second ] [ 2drop 0 ] if ;
 
 : end-on-line ( document to line# -- n2 )
     over first over = [
@@ -47,12 +47,14 @@ TUPLE: document < model locs ;
     2over = [
         3drop
     ] [
-        >r [ first ] bi@ 1+ dup <slice> r> each
+        [ [ first ] bi@ 1+ dup <slice> ] dip each
     ] if ; inline
 
 : start/end-on-line ( from to line# -- n1 n2 )
-    tuck >r >r document get -rot start-on-line r> r>
+    tuck
-    document get -rot end-on-line ;
+    [ [ document get ] 2dip start-on-line ]
+    [ [ document get ] 2dip end-on-line ]
+    2bi* ;
 
 : (doc-range) ( from to line# -- )
     [ start/end-on-line ] keep document get doc-line <slice> , ;
@@ -60,16 +62,18 @@ TUPLE: document < model locs ;
 : doc-range ( from to document -- string )
     [
         document set 2dup [
-            >r 2dup r> (doc-range)
+            [ 2dup ] dip (doc-range)
         ] each-line 2drop
     ] { } make "\n" join ;
 
 : text+loc ( lines loc -- loc )
-    over >r over length 1 = [
+    over [
-        nip first2
+        over length 1 = [
-    ] [
+            nip first2
-        first swap length 1- + 0
+        ] [
-    ] if r> peek length + 2array ;
+            first swap length 1- + 0
+        ] if
+    ] dip peek length + 2array ;
 
 : prepend-first ( str seq -- )
     0 swap [ append ] change-nth ;
@@ -78,25 +82,25 @@ TUPLE: document < model locs ;
     [ length 1- ] keep [ prepend ] change-nth ;
 
 : loc-col/str ( loc document -- str col )
-    >r first2 swap r> nth swap ;
+    [ first2 swap ] dip nth swap ;
 
 : prepare-insert ( newinput from to lines -- newinput )
-    tuck loc-col/str tail-slice >r loc-col/str head-slice r>
+    tuck [ loc-col/str head-slice ] [ loc-col/str tail-slice ] 2bi*
     pick append-last over prepend-first ;
 
 : (set-doc-range) ( newlines from to lines -- )
     [ prepare-insert ] 3keep
-    >r [ first ] bi@ 1+ r>
+    [ [ first ] bi@ 1+ ] dip
     replace-slice ;
 
 : set-doc-range ( string from to document -- )
     [
-        >r >r >r string-lines r> [ text+loc ] 2keep r> r>
+        [ [ string-lines ] dip [ text+loc ] 2keep ] 2dip
         [ [ (set-doc-range) ] keep ] change-model
     ] keep update-locs ;
 
 : remove-doc-range ( from to document -- )
-    >r >r >r "" r> r> r> set-doc-range ;
+    [ "" ] 3dip set-doc-range ;
 
 : last-line# ( document -- line )
     value>> length 1- ;
@@ -111,7 +115,7 @@ TUPLE: document < model locs ;
     dupd doc-line length 2array ;
 
 : line-end? ( loc document -- ? )
-    >r first2 swap r> doc-line length = ;
+    [ first2 swap ] dip doc-line length = ;
 
 : doc-end ( document -- loc )
     [ last-line# ] keep line-end ;
@@ -123,7 +127,7 @@ TUPLE: document < model locs ;
         over first 0 < [
             2drop { 0 0 }
         ] [
-            >r first2 swap tuck r> validate-col 2array
+            [ first2 swap tuck ] dip validate-col 2array
         ] if
     ] if ;
 
@@ -131,7 +135,7 @@ TUPLE: document < model locs ;
     value>> "\n" join ;
 
 : set-doc-string ( string document -- )
-    >r string-lines V{ } like r> [ set-model ] keep
+    [ string-lines V{ } like ] dip [ set-model ] keep
     [ doc-end ] [ update-locs ] bi ;
 
 : clear-doc ( document -- )
@@ -141,17 +145,17 @@ GENERIC: prev-elt ( loc document elt -- newloc )
 GENERIC: next-elt ( loc document elt -- newloc )
 
 : prev/next-elt ( loc document elt -- start end )
-    3dup next-elt >r prev-elt r> ;
+    [ prev-elt ] [ next-elt ] 3bi ;
 
 : elt-string ( loc document elt -- string )
-    over >r prev/next-elt r> doc-range ;
+    [ prev/next-elt ] [ drop ] 2bi doc-range ;
 
 TUPLE: char-elt ;
 
 : (prev-char) ( loc document quot -- loc )
     -rot {
         { [ over { 0 0 } = ] [ drop ] }
-        { [ over second zero? ] [ >r first 1- r> line-end ] }
+        { [ over second zero? ] [ [ first 1- ] dip line-end ] }
         [ pick call ]
     } cond nip ; inline
 
@@ -175,14 +179,14 @@ M: one-char-elt prev-elt 2drop ;
 M: one-char-elt next-elt 2drop ;
 
 : (word-elt) ( loc document quot -- loc )
-    pick >r
+    pick [
-    >r >r first2 swap r> doc-line r> call
+        [ [ first2 swap ] dip doc-line ] dip call
-    r> =col ; inline
+    ] dip =col ; inline
 
 : ((word-elt)) ( n seq -- ? n seq ) [ ?nth blank? ] 2keep ;
 
 : break-detector ( ? -- quot )
-    [ >r blank? r> xor ] curry ; inline
+    [ [ blank? ] dip xor ] curry ; inline
 
 : (prev-word) ( ? col str -- col )
     rot break-detector find-last-from drop ?1+ ;
@@ -195,17 +199,17 @@ TUPLE: one-word-elt ;
 
 M: one-word-elt prev-elt
     drop
-    [ f -rot >r 1- r> (prev-word) ] (word-elt) ;
+    [ [ [ f ] dip 1- ] dip (prev-word) ] (word-elt) ;
 
 M: one-word-elt next-elt
     drop
-    [ f -rot (next-word) ] (word-elt) ;
+    [ [ f ] 2dip (next-word) ] (word-elt) ;
 
 TUPLE: word-elt ;
 
 M: word-elt prev-elt
     drop
-    [ [ >r 1- r> ((word-elt)) (prev-word) ] (word-elt) ]
+    [ [ [ 1- ] dip ((word-elt)) (prev-word) ] (word-elt) ]
     (prev-char) ;
 
 M: word-elt next-elt
@@ -219,7 +223,7 @@ M: one-line-elt prev-elt
     2drop first 0 2array ;
 
 M: one-line-elt next-elt
-    drop >r first dup r> doc-line length 2array ;
+    drop [ first dup ] dip doc-line length 2array ;
 
 TUPLE: line-elt ;
 

basis/help/definitions/definitions-tests.factor

@@ -34,7 +34,7 @@ IN: help.definitions.tests
 
     [ ] [ "IN: help.definitions.tests USING: help.syntax ; : xxx ; HELP: xxx ;" eval ] unit-test
 
-    [ ] [ "xxx" "help.definitions.tests" lookup help ] unit-test
+    [ ] [ "xxx" "help.definitions.tests" lookup print-topic ] unit-test
 
     [ ] [ "xxx" "help.definitions.tests" lookup >link synopsis print ] unit-test
 ] with-file-vocabs

basis/help/handbook/handbook-tests.factor

@@ -1,8 +1,8 @@
 IN: help.handbook.tests
 USING: help tools.test ;
 
-[ ] [ "article-index" help ] unit-test
+[ ] [ "article-index" print-topic ] unit-test
-[ ] [ "primitive-index" help ] unit-test
+[ ] [ "primitive-index" print-topic ] unit-test
-[ ] [ "error-index" help ] unit-test
+[ ] [ "error-index" print-topic ] unit-test
-[ ] [ "type-index" help ] unit-test
+[ ] [ "type-index" print-topic ] unit-test
-[ ] [ "class-index" help ] unit-test
+[ ] [ "class-index" print-topic ] unit-test

basis/help/lint/lint.factor

@@ -68,7 +68,7 @@ IN: help.lint
     ] each ;
 
 : check-rendering ( word element -- )
-    [ help ] with-string-writer drop ;
+    [ print-topic ] with-string-writer drop ;
 
 : all-word-help ( words -- seq )
     [ word-help ] filter ;

basis/help/markup/markup-tests.factor

@@ -6,12 +6,12 @@ TUPLE: blahblah quux ;
 
 [ "an int" ] [ [ { "int" } $instance ] with-string-writer ] unit-test
 
-[ ] [ \ quux>> help ] unit-test
+[ ] [ \ quux>> print-topic ] unit-test
-[ ] [ \ >>quux help ] unit-test
+[ ] [ \ >>quux print-topic ] unit-test
-[ ] [ \ blahblah? help ] unit-test
+[ ] [ \ blahblah? print-topic ] unit-test
 
 : fooey "fooey" throw ;
 
-[ ] [ \ fooey help ] unit-test
+[ ] [ \ fooey print-topic ] unit-test
 
-[ ] [ gensym help ] unit-test
+[ ] [ gensym print-topic ] unit-test

basis/listener/listener-docs.factor

@@ -30,7 +30,6 @@ HELP: hide-vars
 { $description "Removes a sequence of variables from the watch list." } ;
 
 HELP: hide-all-vars
-{ $values { "seq" "a sequence of variable names" } }
 { $description "Removes all variables from the watch list." } ;
 
 ARTICLE: "listener" "The listener"

basis/ui/cocoa/cocoa.factor

@@ -15,9 +15,7 @@ C: <handle> handle
 SINGLETON: cocoa-ui-backend
 
 M: cocoa-ui-backend do-events ( -- )
-    [
+    [ NSApp [ do-event ] curry loop ui-wait ] with-autorelease-pool ;
-        [ NSApp [ do-event ] curry loop ui-wait ] ui-try
-    ] with-autorelease-pool ;
 
 TUPLE: pasteboard handle ;
 

basis/ui/cocoa/views/views.factor

@@ -18,8 +18,8 @@ IN: ui.cocoa.views
     {
         { S+ HEX: 20000 }
         { C+ HEX: 40000 }
-        { A+ HEX: 80000 }
+        { A+ HEX: 100000 }
-        { M+ HEX: 100000 }
+        { M+ HEX: 80000 }
     } ;
 
 : key-codes
@@ -59,29 +59,26 @@ IN: ui.cocoa.views
 : key-event>gesture ( event -- modifiers keycode action? )
     dup event-modifiers swap key-code ;
 
-: send-key-event ( view event quot -- ? )
+: send-key-event ( view gesture -- )
-    >r key-event>gesture r> call swap window-focus
+    swap window-focus propagate-gesture ;
-    send-gesture ; inline
-
-: send-user-input ( view string -- )
-    CF>string swap window-focus user-input ;
 
 : interpret-key-event ( view event -- )
     NSArray swap -> arrayWithObject: -> interpretKeyEvents: ;
 
 : send-key-down-event ( view event -- )
-    2dup [ <key-down> ] send-key-event
+    [ key-event>gesture <key-down> send-key-event ]
-    [ interpret-key-event ] [ 2drop ] if ;
+    [ interpret-key-event ]
+    2bi ;
 
 : send-key-up-event ( view event -- )
-    [ <key-up> ] send-key-event drop ;
+    key-event>gesture <key-up> send-key-event ;
 
 : mouse-event>gesture ( event -- modifiers button )
     dup event-modifiers swap button ;
 
 : send-button-down$ ( view event -- )
-    [ mouse-event>gesture <button-down> ] 2keep
+    [ mouse-event>gesture <button-down> ]
-    mouse-location rot window send-button-down ;
+    [ mouse-location rot window send-button-down ] 2bi ;
 
 : send-button-up$ ( view event -- )
     [ mouse-event>gesture <button-up> ] 2keep
@@ -138,83 +135,83 @@ CLASS: {
 }
 
 { "mouseEntered:" "void" { "id" "SEL" "id" }
-    [ [ nip send-mouse-moved ] ui-try ]
+    [ nip send-mouse-moved ]
 }
 
 { "mouseExited:" "void" { "id" "SEL" "id" }
-    [ [ 3drop forget-rollover ] ui-try ]
+    [ 3drop forget-rollover ]
 }
 
 { "mouseMoved:" "void" { "id" "SEL" "id" }
-    [ [ nip send-mouse-moved ] ui-try ]
+    [ nip send-mouse-moved ]
 }
 
 { "mouseDragged:" "void" { "id" "SEL" "id" }
-    [ [ nip send-mouse-moved ] ui-try ]
+    [ nip send-mouse-moved ]
 }
 
 { "rightMouseDragged:" "void" { "id" "SEL" "id" }
-    [ [ nip send-mouse-moved ] ui-try ]
+    [ nip send-mouse-moved ]
 }
 
 { "otherMouseDragged:" "void" { "id" "SEL" "id" }
-    [ [ nip send-mouse-moved ] ui-try ]
+    [ nip send-mouse-moved ]
 }
 
 { "mouseDown:" "void" { "id" "SEL" "id" }
-    [ [ nip send-button-down$ ] ui-try ]
+    [ nip send-button-down$ ]
 }
 
 { "mouseUp:" "void" { "id" "SEL" "id" }
-    [ [ nip send-button-up$ ] ui-try ]
+    [ nip send-button-up$ ]
 }
 
 { "rightMouseDown:" "void" { "id" "SEL" "id" }
-    [ [ nip send-button-down$ ] ui-try ]
+    [ nip send-button-down$ ]
 }
 
 { "rightMouseUp:" "void" { "id" "SEL" "id" }
-    [ [ nip send-button-up$ ] ui-try ]
+    [ nip send-button-up$ ]
 }
 
 { "otherMouseDown:" "void" { "id" "SEL" "id" }
-    [ [ nip send-button-down$ ] ui-try ]
+    [ nip send-button-down$ ]
 }
 
 { "otherMouseUp:" "void" { "id" "SEL" "id" }
-    [ [ nip send-button-up$ ] ui-try ]
+    [ nip send-button-up$ ]
 }
 
 { "scrollWheel:" "void" { "id" "SEL" "id" }
-    [ [ nip send-wheel$ ] ui-try ]
+    [ nip send-wheel$ ]
 }
 
 { "keyDown:" "void" { "id" "SEL" "id" }
-    [ [ nip send-key-down-event ] ui-try ]
+    [ nip send-key-down-event ]
 }
 
 { "keyUp:" "void" { "id" "SEL" "id" }
-    [ [ nip send-key-up-event ] ui-try ]
+    [ nip send-key-up-event ]
 }
 
 { "cut:" "id" { "id" "SEL" "id" }
-    [ [ nip T{ cut-action } send-action$ ] ui-try ]
+    [ nip T{ cut-action } send-action$ ]
 }
 
 { "copy:" "id" { "id" "SEL" "id" }
-    [ [ nip T{ copy-action } send-action$ ] ui-try ]
+    [ nip T{ copy-action } send-action$ ]
 }
 
 { "paste:" "id" { "id" "SEL" "id" }
-    [ [ nip T{ paste-action } send-action$ ] ui-try ]
+    [ nip T{ paste-action } send-action$ ]
 }
 
 { "delete:" "id" { "id" "SEL" "id" }
-    [ [ nip T{ delete-action } send-action$ ] ui-try ]
+    [ nip T{ delete-action } send-action$ ]
 }
 
 { "selectAll:" "id" { "id" "SEL" "id" }
-    [ [ nip T{ select-all-action } send-action$ ] ui-try ]
+    [ nip T{ select-all-action } send-action$ ]
 }
 
 ! Multi-touch gestures: this is undocumented.
@@ -290,7 +287,7 @@ CLASS: {
 
 ! Text input
 { "insertText:" "void" { "id" "SEL" "id" }
-    [ [ nip send-user-input ] ui-try ]
+    [ nip CF>string swap window-focus user-input ]
 }
 
 { "hasMarkedText" "char" { "id" "SEL" }
@@ -335,11 +332,11 @@ CLASS: {
 
 ! Initialization
 { "updateFactorGadgetSize:" "void" { "id" "SEL" "id" }
-    [
+    [ 2drop dup view-dim swap window (>>dim) yield ]
-        [
+}
-            2drop dup view-dim swap window (>>dim) yield
+
-        ] ui-try
+{ "doCommandBySelector:" "void" { "id" "SEL" "SEL" }
-    ]
+    [ 3drop ]
 }
 
 { "initWithFrame:pixelFormat:" "id" { "id" "SEL" "NSRect" "id" }

basis/ui/gadgets/editors/editors.factor

@@ -356,7 +356,7 @@ M: editor gadget-text* editor-string % ;
     [ drop dup extend-selection dup mark>> click-loc ]
     [ select-elt ] if ;
 
-: insert-newline ( editor -- ) "\n" swap user-input ;
+: insert-newline ( editor -- ) "\n" swap user-input* drop ;
 
 : delete-next-character ( editor -- ) 
     T{ char-elt } editor-delete ;

basis/ui/gadgets/gadgets.factor

@@ -10,11 +10,9 @@ SYMBOL: ui-notify-flag
 
 : notify-ui-thread ( -- ) ui-notify-flag get-global raise-flag ;
 
-TUPLE: gadget < rect
+TUPLE: gadget < rect pref-dim parent children orientation focus
-       pref-dim parent children orientation focus
+visible? root? clipped? layout-state graft-state graft-node
-       visible? root? clipped? layout-state graft-state graft-node
+interior boundary model ;
-       interior boundary
-       model ;
 
 M: gadget equal? 2drop f ;
 

basis/ui/gadgets/panes/panes-tests.factor

@@ -40,7 +40,7 @@ IN: ui.gadgets.panes.tests
 [ t ] [ [ [ 1 2 3 ] pprint ] test-gadget-text ] unit-test
 [ t ] [ [ \ + describe ] test-gadget-text ] unit-test
 [ t ] [ [ \ = see ] test-gadget-text ] unit-test
-[ t ] [ [ \ = help ] test-gadget-text ] unit-test
+[ t ] [ [ \ = print-topic ] test-gadget-text ] unit-test
 
 [ t ] [
     [
@@ -84,16 +84,16 @@ ARTICLE: "test-article-1" "This is a test article"
 
 [ t ] [ [ "test-article-1" $title ] test-gadget-text ] unit-test
 
-[ t ] [ [ "test-article-1" help ] test-gadget-text ] unit-test
+[ t ] [ [ "test-article-1" print-topic ] test-gadget-text ] unit-test
 
 ARTICLE: "test-article-2" "This is a test article"
 "Hello world, how are you today."
 { $table { "a" "b" } { "c" "d" } } ;
 
-[ t ] [ [ "test-article-2" help ] test-gadget-text ] unit-test
+[ t ] [ [ "test-article-2" print-topic ] test-gadget-text ] unit-test
 
 <pane> [ \ = see ] with-pane
-<pane> [ \ = help ] with-pane
+<pane> [ \ = print-topic ] with-pane
 
 [ ] [
     \ = <model> [ see ] <pane-control> [ ] with-grafted-gadget

basis/ui/gadgets/slots/slots.factor

@@ -26,10 +26,10 @@ TUPLE: slot-editor < track ref text ;
 GENERIC: finish-editing ( slot-editor ref -- )
 
 M: key-ref finish-editing
-    drop T{ update-object } swap send-gesture drop ;
+    drop T{ update-object } swap propagate-gesture ;
 
 M: value-ref finish-editing
-    drop T{ update-slot } swap send-gesture drop ;
+    drop T{ update-slot } swap propagate-gesture ;
 
 : slot-editor-value ( slot-editor -- object )
     text>> control-value parse-fresh ;
@@ -55,14 +55,14 @@ M: value-ref finish-editing
 
 : delete ( slot-editor -- )
     dup ref>> delete-ref
-    T{ update-object } swap send-gesture drop ;
+    T{ update-object } swap propagate-gesture ;
 
 \ delete H{
     { +description+ "Delete the slot and close the slot editor." }
 } define-command
 
 : close ( slot-editor -- )
-    T{ update-slot } swap send-gesture drop ;
+    T{ update-slot } swap propagate-gesture ;
 
 \ close H{
     { +description+ "Close the slot editor without saving changes." }
@@ -92,7 +92,7 @@ TUPLE: editable-slot < track printer ref ;
 
 : <edit-button> ( -- gadget )
     "..."
-    [ T{ edit-slot } swap send-gesture drop ]
+    [ T{ edit-slot } swap propagate-gesture ]
     <roll-button> ;
 
 : display-slot ( gadget editable-slot -- )

basis/ui/gadgets/worlds/worlds.factor

@@ -103,10 +103,27 @@ world H{
     { T{ key-down f { C+ } "a" } [ T{ select-all-action } send-action ] }
     { T{ button-down f { C+ } 1 } [ drop T{ button-down f f 3 } button-gesture ] }
     { T{ button-down f { A+ } 1 } [ drop T{ button-down f f 2 } button-gesture ] }
+    { T{ button-down f { M+ } 1 } [ drop T{ button-down f f 2 } button-gesture ] }
     { T{ button-up f { C+ } 1 } [ drop T{ button-up f f 3 } button-gesture ] }
     { T{ button-up f { A+ } 1 } [ drop T{ button-up f f 2 } button-gesture ] }
+    { T{ button-up f { M+ } 1 } [ drop T{ button-up f f 2 } button-gesture ] }
 } set-gestures
 
+PREDICATE: specific-button-up < button-up #>> ;
+PREDICATE: specific-button-down < button-down #>> ;
+PREDICATE: specific-drag < drag #>> ;
+
+: generalize-gesture ( gesture -- )
+    clone f >># button-gesture ;
+
+M: world handle-gesture ( gesture gadget -- ? )
+    {
+        { [ over specific-button-up? ] [ drop generalize-gesture t ] }
+        { [ over specific-button-down? ] [ drop generalize-gesture t ] }
+        { [ over specific-drag? ] [ drop generalize-gesture t ] }
+        [ call-next-method ]
+    } cond ;
+
 : close-global ( world global -- )
     dup get-global find-world rot eq?
     [ f swap set-global ] [ drop ] if ;

basis/ui/gestures/gestures-docs.factor

@@ -15,14 +15,14 @@ $nl
 "The default implementation looks at the " { $snippet "\"gestures\"" } " word property of each superclass of the gadget's class." }
 { $notes "Methods should be defined on this word if you desire to handle an arbitrary set of gestures. To define handlers for a fixed set, it is easier to use " { $link set-gestures } "." } ;
 
-{ send-gesture handle-gesture set-gestures } related-words
+{ propagate-gesture handle-gesture set-gestures } related-words
 
-HELP: send-gesture
+HELP: propagate-gesture
 { $values { "gesture" "a gesture" } { "gadget" gadget } { "?" "a boolean" } }
-{ $description "Calls " { $link send-gesture } " on every parent of " { $snippet "gadget" } ". Outputs " { $link f } " if some parent handled the gesture, else outputs " { $link t } "." } ;
+{ $description "Calls " { $link handle-gesture } " on every parent of " { $snippet "gadget" } ". Outputs " { $link f } " if some parent handled the gesture, else outputs " { $link t } "." } ;
 
 HELP: user-input
-{ $values { "str" string } { "gadget" gadget } }
+{ $values { "string" string } { "gadget" gadget } }
 { $description "Calls " { $link user-input* } " on every parent of the gadget." } ;
 
 HELP: motion
@@ -90,10 +90,6 @@ HELP: select-all-action
 { $class-description "Gesture sent when the " { $emphasis "select all" } " standard window system action is invoked." }
 { $examples { $code "T{ select-all-action }" } } ;
 
-HELP: generalize-gesture
-{ $values { "gesture" "a gesture" } { "newgesture" "a new gesture" } }
-{ $description "Turns a " { $link button-down } ", " { $link button-up } " or " { $link drag } " action naming a specific mouse button into one which can apply regardless of which mouse button was pressed." } ;
-
 HELP: C+
 { $description "Control key modifier." } ;
 

basis/ui/gestures/gestures.factor

@@ -2,12 +2,10 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors arrays assocs kernel math models namespaces
 make sequences words strings system hashtables math.parser
-math.vectors classes.tuple classes ui.gadgets boxes calendar
+math.vectors classes.tuple classes  boxes calendar
-alarms symbols combinators sets columns ;
+alarms symbols combinators sets columns fry deques ui.gadgets ;
 IN: ui.gestures
 
-: set-gestures ( class hash -- ) "gestures" set-word-prop ;
-
 GENERIC: handle-gesture ( gesture gadget -- ? )
 
 M: object handle-gesture
@@ -15,13 +13,42 @@ M: object handle-gesture
     [ "gestures" word-prop ] map
     assoc-stack dup [ call f ] [ 2drop t ] if ;
 
-: send-gesture ( gesture gadget -- ? )
+: set-gestures ( class hash -- ) "gestures" set-word-prop ;
-    [ dupd handle-gesture ] each-parent nip ;
 
-: user-input ( str gadget -- )
+: gesture-queue ( -- deque ) \ gesture-queue get ;
-    over empty?
+
-    [ [ dupd user-input* ] each-parent ] unless
+GENERIC: send-queued-gesture ( request -- )
-    2drop ;
+
+TUPLE: send-gesture gesture gadget ;
+
+M: send-gesture send-queued-gesture
+    [ gesture>> ] [ gadget>> ] bi handle-gesture drop ;
+
+: queue-gesture ( ... class -- )
+    boa gesture-queue push-front notify-ui-thread ; inline
+
+: send-gesture ( gesture gadget -- )
+    \ send-gesture queue-gesture ;
+
+: each-gesture ( gesture seq -- ) [ send-gesture ] with each ;
+
+TUPLE: propagate-gesture gesture gadget ;
+
+M: propagate-gesture send-queued-gesture
+    [ gesture>> ] [ gadget>> ] bi
+    [ handle-gesture ] with each-parent drop ;
+
+: propagate-gesture ( gesture gadget -- )
+    \ propagate-gesture queue-gesture ;
+
+TUPLE: user-input string gadget ;
+
+M: user-input send-queued-gesture
+    [ string>> ] [ gadget>> ] bi
+    [ user-input* ] with each-parent drop ;
+
+: user-input ( string gadget -- )
+    '[ _ \ user-input queue-gesture ] unless-empty ;
 
 ! Gesture objects
 TUPLE: motion ;             C: <motion> motion
@@ -46,11 +73,8 @@ TUPLE: right-action ;       C: <right-action> right-action
 TUPLE: up-action ;          C: <up-action> up-action
 TUPLE: down-action ;        C: <down-action> down-action
 
-TUPLE: zoom-in-action ;  C: <zoom-in-action> zoom-in-action
+TUPLE: zoom-in-action ;     C: <zoom-in-action> zoom-in-action
-TUPLE: zoom-out-action ; C: <zoom-out-action> zoom-out-action
+TUPLE: zoom-out-action ;    C: <zoom-out-action> zoom-out-action
-
-: generalize-gesture ( gesture -- newgesture )
-    clone f >># ;
 
 ! Modifiers
 SYMBOLS: C+ A+ M+ S+ ;
@@ -58,7 +82,7 @@ SYMBOLS: C+ A+ M+ S+ ;
 TUPLE: key-down mods sym ;
 
 : <key-gesture> ( mods sym action? class -- mods' sym' )
-    >r [ S+ rot remove swap ] unless r> boa ; inline
+    [ [ [ S+ swap remove f like ] dip ] unless ] dip boa ; inline
 
 : <key-down> ( mods sym action? -- key-down )
     key-down <key-gesture> ;
@@ -100,11 +124,7 @@ SYMBOL: double-click-timeout
     hand-loc get hand-click-loc get = not ;
 
 : button-gesture ( gesture -- )
-    hand-clicked get-global 2dup send-gesture [
+    hand-clicked get-global propagate-gesture ;
-        >r generalize-gesture r> send-gesture drop
-    ] [
-        2drop
-    ] if ;
 
 : drag-gesture ( -- )
     hand-buttons get-global
@@ -130,14 +150,11 @@ SYMBOL: drag-timer
 
 : fire-motion ( -- )
     hand-buttons get-global empty? [
-        T{ motion } hand-gadget get-global send-gesture drop
+        T{ motion } hand-gadget get-global propagate-gesture
     ] [
         drag-gesture
     ] if ;
 
-: each-gesture ( gesture seq -- )
-    [ handle-gesture drop ] with each ;
-
 : hand-gestures ( new old -- )
     drop-prefix <reversed>
     T{ mouse-leave } swap each-gesture
@@ -145,15 +162,15 @@ SYMBOL: drag-timer
 
 : forget-rollover ( -- )
     f hand-world set-global
-    hand-gadget get-global >r
+    hand-gadget get-global
-    f hand-gadget set-global
+    [ f hand-gadget set-global f ] dip
-    f r> parents hand-gestures ;
+    parents hand-gestures ;
 
 : send-lose-focus ( gadget -- )
-    T{ lose-focus } swap handle-gesture drop ;
+    T{ lose-focus } swap send-gesture ;
 
 : send-gain-focus ( gadget -- )
-    T{ gain-focus } swap handle-gesture drop ;
+    T{ gain-focus } swap send-gesture ;
 
 : focus-child ( child gadget ? -- )
     [
@@ -219,9 +236,11 @@ SYMBOL: drag-timer
 
 : move-hand ( loc world -- )
     dup hand-world set-global
-    under-hand >r over hand-loc set-global
+    under-hand [
-    pick-up hand-gadget set-global
+        over hand-loc set-global
-    under-hand r> hand-gestures ;
+        pick-up hand-gadget set-global
+        under-hand
+    ] dip hand-gestures ;
 
 : send-button-down ( gesture loc world -- )
     move-hand
@@ -240,14 +259,13 @@ SYMBOL: drag-timer
 : send-wheel ( direction loc world -- )
     move-hand
     scroll-direction set-global
-    T{ mouse-scroll } hand-gadget get-global send-gesture
+    T{ mouse-scroll } hand-gadget get-global propagate-gesture ;
-    drop ;
 
 : world-focus ( world -- gadget )
     dup focus>> [ world-focus ] [ ] ?if ;
 
 : send-action ( world gesture -- )
-    swap world-focus send-gesture drop ;
+    swap world-focus propagate-gesture ;
 
 GENERIC: gesture>string ( gesture -- string/f )
 

basis/ui/tools/browser/browser.factor

@@ -67,10 +67,10 @@ M: browser-gadget definitions-changed ( assoc browser -- )
 \ browser-help H{ { +nullary+ t } } define-command
 
 browser-gadget "toolbar" f {
-    { T{ key-down f { A+ } "b" } com-back }
+    { T{ key-down f { A+ } "LEFT" } com-back }
-    { T{ key-down f { A+ } "f" } com-forward }
+    { T{ key-down f { A+ } "RIGHT" } com-forward }
-    { T{ key-down f { A+ } "h" } com-documentation }
+    { f com-documentation }
-    { T{ key-down f { A+ } "v" } com-vocabularies }
+    { f com-vocabularies }
     { T{ key-down f f "F1" } browser-help }
 } define-command-map
 

basis/ui/tools/debugger/debugger-docs.factor

@@ -8,7 +8,7 @@ HELP: <debugger>
     "Creates a gadget displaying a description of the error, along with buttons to print the contents of the stacks in the listener, and a list of restarts."
 } ;
 
-{ <debugger> debugger-window ui-try } related-words
+{ <debugger> debugger-window } related-words
 
 HELP: debugger-window
 { $values { "error" "an error" } }

basis/ui/tools/interactor/interactor.factor

@@ -164,7 +164,7 @@ M: interactor dispose drop ;
 : handle-interactive ( lines interactor -- quot/f ? )
     tuck try-parse {
         { [ dup quotation? ] [ nip t ] }
-        { [ dup not ] [ drop "\n" swap user-input f f ] }
+        { [ dup not ] [ drop "\n" swap user-input* drop f f ] }
         [ handle-parse-error f f ]
     } cond ;
 

basis/ui/tools/listener/listener.factor

@@ -1,11 +1,11 @@
 ! Copyright (C) 2005, 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: inspector help help.markup io io.styles
+USING: inspector help help.markup io io.styles kernel models
-kernel models namespaces parser quotations sequences  vocabs words
+namespaces parser quotations sequences vocabs words prettyprint
-prettyprint listener debugger threads boxes concurrency.flags
+listener debugger threads boxes concurrency.flags math arrays
-math arrays generic accessors combinators assocs fry ui.commands
+generic accessors combinators assocs fry ui.commands ui.gadgets
-ui.gadgets ui.gadgets.editors ui.gadgets.labelled
+ui.gadgets.editors ui.gadgets.labelled ui.gadgets.panes
-ui.gadgets.panes ui.gadgets.buttons ui.gadgets.scrollers
+ui.gadgets.buttons ui.gadgets.scrollers ui.gadgets.packs
 ui.gadgets.tracks ui.gadgets.borders ui.gestures ui.operations
 ui.tools.browser ui.tools.interactor ui.tools.inspector
 ui.tools.workspace ;
@@ -13,20 +13,12 @@ IN: ui.tools.listener
 
 TUPLE: listener-gadget < track input output ;
 
-: listener-output, ( listener -- listener )
-    <scrolling-pane>
-    [ >>output ] [ <scroller> 1 track-add ] bi ;
-
 : listener-streams ( listener -- input output )
     [ input>> ] [ output>> <pane-stream> ] bi ;
 
 : <listener-input> ( listener -- gadget )
     output>> <pane-stream> <interactor> ;
 
-: listener-input, ( listener -- listener )
-    dup <listener-input>
-    [ >>input ] [ 1 <border> { 1 1 } >>fill f track-add ] bi ;
-
 : welcome. ( -- )
     "If this is your first time with Factor, please read the " print
     "handbook" ($link) ". To see a list of keyboard shortcuts," print
@@ -109,7 +101,7 @@ M: engine-word word-completion-string
 
 : insert-word ( word -- )
     get-workspace listener>> input>>
-    [ >r word-completion-string r> user-input ]
+    [ >r word-completion-string r> user-input* drop ]
     [ interactor-use use-if-necessary ]
     2bi ;
 
@@ -156,11 +148,21 @@ M: engine-word word-completion-string
         [ wait-for-listener ]
     } cleave ;
 
+: init-listener ( listener -- listener )
+    <scrolling-pane> >>output
+    dup <listener-input> >>input ;
+
+: <listener-scroller> ( listener -- scroller )
+    <filled-pile>
+        over output>> add-gadget
+        swap input>> add-gadget
+    <scroller> ;
+
 : <listener-gadget> ( -- gadget )
     { 0 1 } listener-gadget new-track
         add-toolbar
-        listener-output,
+        init-listener
-        listener-input, ;
+        dup <listener-scroller> 1 track-add ;
 
 : listener-help ( -- ) "ui-listener" help-window ;
 
@@ -177,9 +179,9 @@ listener-gadget "misc" "Miscellaneous commands" {
 
 listener-gadget "toolbar" f {
     { f restart-listener }
-    { T{ key-down f { A+ } "a" } com-auto-use }
+    { T{ key-down f { A+ } "u" } com-auto-use }
-    { T{ key-down f { A+ } "c" } clear-output }
+    { T{ key-down f { A+ } "k" } clear-output }
-    { T{ key-down f { A+ } "C" } clear-stack }
+    { T{ key-down f { A+ } "K" } clear-stack }
     { T{ key-down f { C+ } "d" } com-end }
 } define-command-map
 

basis/ui/ui-docs.factor

@@ -47,11 +47,6 @@ HELP: (open-window)
 { $description "Opens a native window containing the given world. This grafts the world by calling " { $link graft } ". Each world can only be displayed in one top-level window at a time." }
 { $notes "This word should not be called directly by user code. Instead, use " { $link open-window } "." } ;
 
-HELP: ui-try
-{ $values { "quot" quotation } }
-{ $description "Calls the quotation. If it throws an error, opens a window with the error and restores the data stack." }
-{ $notes "This is essentially a graphical variant of " { $link try } "." } ;
-
 ARTICLE: "ui-glossary" "UI glossary"
 { $table
     { "color specifier"

basis/ui/ui-tests.factor

@@ -0,0 +1,5 @@
+IN: ui.tests
+USING: ui tools.test ;
+
+\ event-loop must-infer
+\ open-window must-infer

basis/ui/ui.factor

@@ -1,4 +1,4 @@
-! Copyright (C) 2006, 2007 Slava Pestov.
+! Copyright (C) 2006, 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: arrays assocs io kernel math models namespaces make
 prettyprint dlists deques sequences threads sequences words
@@ -87,6 +87,7 @@ SYMBOL: ui-hook
 : init-ui ( -- )
     <dlist> \ graft-queue set-global
     <dlist> \ layout-queue set-global
+    <dlist> \ gesture-queue set-global
     V{ } clone windows set-global ;
 
 : restore-gadget-later ( gadget -- )
@@ -138,14 +139,22 @@ SYMBOL: ui-hook
 : notify-queued ( -- )
     graft-queue [ notify ] slurp-deque ;
 
+: send-queued-gestures ( -- )
+    gesture-queue [ send-queued-gesture ] slurp-deque ;
+
 : update-ui ( -- )
-    [ notify-queued layout-queued redraw-worlds ] assert-depth ;
+    [
+        [
+            notify-queued
+            layout-queued
+            redraw-worlds
+            send-queued-gestures
+        ] assert-depth
+    ] [ ui-error ] recover ;
 
 : ui-wait ( -- )
     10 sleep ;
 
-: ui-try ( quot -- ) [ ui-error ] recover ;
-
 SYMBOL: ui-thread
 
 : ui-running ( quot -- )
@@ -156,11 +165,9 @@ SYMBOL: ui-thread
     \ ui-running get-global ;
 
 : update-ui-loop ( -- )
-    ui-running? ui-thread get-global self eq? and [
+    [ ui-running? ui-thread get-global self eq? and ]
-        ui-notify-flag get lower-flag
+    [ ui-notify-flag get lower-flag update-ui ]
-        [ update-ui ] ui-try
+    [ ] while ;
-        update-ui-loop
-    ] when ;
 
 : start-ui-thread ( -- )
     [ self ui-thread set-global update-ui-loop ]

basis/ui/windows/windows.factor

@@ -194,7 +194,7 @@ SYMBOLS: msg-obj class-name-ptr mouse-captured ;
 :: handle-wm-keydown ( hWnd uMsg wParam lParam -- )
     wParam exclude-key-wm-keydown? [
         wParam keystroke>gesture <key-down>
-        hWnd window-focus send-gesture drop
+        hWnd window-focus propagate-gesture
     ] unless ;
 
 :: handle-wm-char ( hWnd uMsg wParam lParam -- )
@@ -205,7 +205,7 @@ SYMBOLS: msg-obj class-name-ptr mouse-captured ;
 
 :: handle-wm-keyup ( hWnd uMsg wParam lParam -- )
     wParam keystroke>gesture <key-up>
-    hWnd window-focus send-gesture drop ;
+    hWnd window-focus propagate-gesture ;
 
 :: set-window-active ( hwnd uMsg wParam lParam ? -- n )
     ? hwnd window (>>active?)
@@ -381,11 +381,9 @@ SYMBOL: trace-messages?
 ! return 0 if you handle the message, else just let DefWindowProc return its val
 : ui-wndproc ( -- object )
     "uint" { "void*" "uint" "long" "long" } "stdcall" [
-        [
+        pick
-            pick
+        trace-messages? get-global [ dup windows-message-name name>> print flush ] when
-            trace-messages? get-global [ dup windows-message-name name>> print flush ] when
+        wm-handlers get-global at* [ call ] [ drop DefWindowProc ] if
-            wm-handlers get-global at* [ call ] [ drop DefWindowProc ] if
-        ] ui-try
      ] alien-callback ;
 
 : peek-message? ( msg -- ? ) f 0 0 PM_REMOVE PeekMessage zero? ;

basis/ui/x11/x11.factor

@@ -7,7 +7,7 @@ x11.events x11.xim x11.glx x11.clipboard x11.constants
 x11.windows io.encodings.string io.encodings.ascii
 io.encodings.utf8 combinators debugger command-line qualified
 math.vectors classes.tuple opengl.gl threads math.geometry.rect
-environment ;
+environment ascii ;
 IN: ui.x11
 
 SINGLETON: x11-ui-backend
@@ -67,20 +67,32 @@ M: world configure-event
 : event-modifiers ( event -- seq )
     XKeyEvent-state modifiers modifier ;
 
+: valid-input? ( string gesture -- ? )
+    over empty? [ 2drop f ] [
+        mods>> { f { S+ } } member? [
+            [ [ 127 = not ] [ CHAR: \s >= ] bi and ] all?
+        ] [
+            [ [ 127 = not ] [ CHAR: \s >= ] [ alpha? not ] tri and and ] all?
+        ] if
+    ] if ;
+
 : key-down-event>gesture ( event world -- string gesture )
     dupd
     handle>> xic>> lookup-string
     >r swap event-modifiers r> key-code <key-down> ;
 
 M: world key-down-event
-    [ key-down-event>gesture ] keep world-focus
+    [ key-down-event>gesture ] keep
-    [ send-gesture ] keep swap [ user-input ] [ 2drop ] if ;
+    world-focus
+    [ propagate-gesture drop ]
+    [ 2over valid-input? [ nip user-input ] [ 3drop ] if ]
+    3bi ;
 
 : key-up-event>gesture ( event -- gesture )
     dup event-modifiers swap 0 XLookupKeysym key-code <key-up> ;
 
 M: world key-up-event
-    >r key-up-event>gesture r> world-focus send-gesture drop ;
+    >r key-up-event>gesture r> world-focus propagate-gesture ;
 
 : mouse-event>gesture ( event -- modifiers button loc )
     dup event-modifiers over XButtonEvent-button
@@ -185,7 +197,7 @@ M: world client-event
 
 M: x11-ui-backend do-events
     wait-event dup XAnyEvent-window window dup
-    [ [ [ 2dup handle-event ] ui-try ] assert-depth ] when 2drop ;
+    [ handle-event ] [ 2drop ] if ;
 
 : x-clipboard@ ( gadget clipboard -- prop win )
     atom>> swap

extra/benchmark/fib6/fib6.factor

@@ -9,6 +9,6 @@ USING: math kernel alien ;
     ] alien-callback
     "int" { "int" } "cdecl" alien-indirect ;
 
-: fib-main ( -- ) 25 fib drop ;
+: fib-main ( -- ) 34 fib drop ;
 
 MAIN: fib-main

extra/cfdg/cfdg.factor

@@ -224,13 +224,13 @@ SYMBOL: dlist
 
 : delete-dlist ( -- ) dlist get [ dlist get 1 glDeleteLists dlist off ] when ;
 
-: cfdg-window* ( -- )
+: cfdg-window* ( -- slate )
   C[ display ] <slate>
     { 500 500 }       >>pdim
     C[ delete-dlist ] >>ungraft
   dup "CFDG" open-window ;
 
-: cfdg-window ( -- ) [ cfdg-window* ] with-ui ;
+: cfdg-window ( -- slate ) [ cfdg-window* ] with-ui ;
 
 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 

extra/ui/gadgets/broken/broken.factor

@@ -0,0 +1,26 @@
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel accessors ui ui.gadgets ui.gadgets.buttons ui.render ;
+IN: ui.gadgets.broken
+
+! An intentionally broken gadget -- used to test UI error handling,
+! make sure that one bad gadget doesn't bring the whole system down
+
+: <bad-button> ( -- button )
+    "Click me if you dare"
+    [ "Haha" throw ]
+    <bevel-button> ;
+
+TUPLE: bad-gadget < gadget ;
+
+M: bad-gadget draw-gadget* "Lulz" throw ;
+
+M: bad-gadget pref-dim* drop { 100 100 } ;
+
+: <bad-gadget> ( -- gadget ) bad-gadget new-gadget ;
+
+: bad-gadget-test ( -- )
+    <bad-button> "Test 1" open-window
+    <bad-gadget> "Test 2" open-window ;
+
+MAIN: bad-gadget-test

misc/factor.el

@@ -35,6 +35,7 @@
 
 (require 'font-lock)
 (require 'comint)
+(require 'view)
 
 ;;; Customization:
 
@@ -64,6 +65,30 @@ value from the existing code in the buffer."
   :type '(file :must-match t)
   :group 'factor)
 
+(defcustom factor-use-doc-window t
+  "When on, use a separate window to display help information.
+Disable to see that information in the factor-listener comint
+window."
+  :type 'boolean
+  :group 'factor)
+
+(defcustom factor-listener-use-other-window t
+  "Use a window other than the current buffer's when switching to
+the factor-listener buffer."
+  :type 'boolean
+  :group 'factor)
+
+(defcustom factor-listener-window-allow-split t
+  "Allow window splitting when switching to the factor-listener
+buffer."
+  :type 'boolean
+  :group 'factor)
+
+(defcustom factor-help-always-ask t
+  "When enabled, always ask for confirmation in help prompts."
+  :type 'boolean
+  :group 'factor)
+
 (defcustom factor-display-compilation-output t
   "Display the REPL buffer before compiling files."
   :type 'boolean
@@ -74,6 +99,11 @@ value from the existing code in the buffer."
   :type 'hook
   :group 'factor)
 
+(defcustom factor-help-mode-hook nil
+  "Hook run by `factor-help-mode'."
+  :type 'hook
+  :group 'factor)
+
 (defgroup factor-faces nil
   "Faces used in Factor mode"
   :group 'factor
@@ -125,6 +155,10 @@ value from the existing code in the buffer."
   "Face for parsing words."
   :group 'factor-faces)
 
+(defface factor-font-lock-help-mode-headlines '((t (:bold t :weight bold)))
+  "Face for headlines in help buffers."
+  :group 'factor-faces)
+
 
 ;;; Factor mode font lock:
 
@@ -429,18 +463,6 @@ value from the existing code in the buffer."
   (factor-send-region (search-backward ":")
                       (search-forward  ";")))
 
-(defun factor-see ()
-  (interactive)
-  (comint-send-string "*factor*" "\\ ")
-  (comint-send-string "*factor*" (thing-at-point 'sexp))
-  (comint-send-string "*factor*" " see\n"))
-
-(defun factor-help ()
-  (interactive)
-  (comint-send-string "*factor*" "\\ ")
-  (comint-send-string "*factor*" (thing-at-point 'sexp))
-  (comint-send-string "*factor*" " help\n"))
-
 (defun factor-edit ()
   (interactive)
   (comint-send-string "*factor*" "\\ ")
@@ -459,17 +481,6 @@ value from the existing code in the buffer."
 (defvar factor-mode-map (make-sparse-keymap)
   "Key map used by Factor mode.")
 
-(define-key factor-mode-map "\C-c\C-f" 'factor-run-file)
-(define-key factor-mode-map "\C-c\C-r" 'factor-send-region)
-(define-key factor-mode-map "\C-c\C-d" 'factor-send-definition)
-(define-key factor-mode-map "\C-c\C-s" 'factor-see)
-(define-key factor-mode-map "\C-ce"    'factor-edit)
-(define-key factor-mode-map "\C-c\C-h" 'factor-help)
-(define-key factor-mode-map "\C-cc"    'comment-region)
-(define-key factor-mode-map [return]   'newline-and-indent)
-(define-key factor-mode-map [tab]      'indent-for-tab-command)
-
-
 
 ;; Factor mode:
 
@@ -494,23 +505,118 @@ value from the existing code in the buffer."
 (add-to-list 'auto-mode-alist '("\\.factor\\'" . factor-mode))
 
 
-;;; Factor listener mode
+;;; Factor listener mode:
 
 ;;;###autoload
-(define-derived-mode factor-listener-mode comint-mode "Factor Listener")
+(define-derived-mode factor-listener-mode comint-mode "Factor Listener"
+  "Major mode for interacting with an inferior Factor listener process.
+\\{factor-listener-mode-map}"
+  (set (make-local-variable 'comint-prompt-regexp) "^( [^)]+ ) "))
 
-(define-key factor-listener-mode-map [f8] 'factor-refresh-all)
+(defvar factor--listener-buffer nil
+  "The buffer in which the Factor listener is running.")
+
+(defun factor--listener-start-process ()
+  "Start an inferior Factor listener process, using
+`factor-binary' and `factor-image'."
+  (setq factor--listener-buffer
+        (apply 'make-comint "factor" (expand-file-name factor-binary) nil
+               `("-run=listener" ,(format "-i=%s" (expand-file-name factor-image)))))
+  (with-current-buffer factor--listener-buffer
+    (factor-listener-mode)))
+
+(defun factor--listener-process ()
+  (or (and (buffer-live-p factor--listener-buffer)
+           (get-buffer-process factor--listener-buffer))
+      (progn (factor--listener-start-process)
+             (factor--listener-process))))
 
 ;;;###autoload
-(defun run-factor ()
+(defalias 'switch-to-factor 'run-factor)
-  "Start a factor listener inside emacs, or switch to it if it
+;;;###autoload
-already exists."
+(defun run-factor (&optional arg)
+  "Show the factor-listener buffer, starting the process if needed."
   (interactive)
-  (switch-to-buffer
+  (let ((buf (process-buffer (factor--listener-process)))
-   (make-comint-in-buffer "factor" nil (expand-file-name factor-binary) nil
+        (pop-up-windows factor-listener-window-allow-split))
-			  (concat "-i=" (expand-file-name factor-image))
+    (if factor-listener-use-other-window
-			  "-run=listener"))
+        (pop-to-buffer buf)
-  (factor-listener-mode))
+      (switch-to-buffer buf))))
+
+
+;;;; Factor help mode:
+
+(defvar factor-help-mode-map (make-sparse-keymap)
+  "Keymap for Factor help mode.")
+
+(defconst factor--help-headlines
+  (regexp-opt '("Parent topics:"
+                "Inputs and outputs"
+                "Word description"
+                "Generic word contract"
+                "Vocabulary"
+                "Definition")
+              t))
+
+(defconst factor--help-headlines-regexp (format "^%s" factor--help-headlines))
+
+(defconst factor--help-font-lock-keywords
+  `((,factor--help-headlines-regexp . 'factor-font-lock-help-mode-headlines)
+    ,@factor-font-lock-keywords))
+
+(defun factor-help-mode ()
+  "Major mode for displaying Factor help messages.
+\\{factor-help-mode-map}"
+  (interactive)
+  (kill-all-local-variables)
+  (use-local-map factor-help-mode-map)
+  (setq mode-name "Factor Help")
+  (setq major-mode 'factor-help-mode)
+  (set (make-local-variable 'font-lock-defaults)
+       '(factor--help-font-lock-keywords t nil nil nil))
+  (set (make-local-variable 'comint-redirect-subvert-readonly) 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))))
+  (run-mode-hooks 'factor-help-mode-hook))
+
+(defun factor--listener-help-buffer ()
+  (set-buffer (get-buffer-create "*factor-help*"))
+  (let ((inhibit-read-only t))
+    (delete-region (point-min) (point-max)))
+  (factor-help-mode)
+  (current-buffer))
+
+(defvar factor--help-history nil)
+
+(defun factor--listener-show-help (&optional see)
+  (let* ((def (thing-at-point 'sexp))
+         (prompt (format "%s (%s): " (if see "See" "Help") def))
+         (ask (or (not (eq major-mode 'factor-mode))
+                  (not def)
+                  factor-help-always-ask))
+         (cmd (format "\\ %s %s"
+                      (if ask (read-string prompt nil 'factor--help-history def) def)
+                      (if see "see" "help")))
+         (hb (factor--listener-help-buffer))
+         (proc (factor--listener-process)))
+    (comint-redirect-send-command-to-process cmd hb proc nil)
+    (pop-to-buffer hb)))
+
+(defun factor-see ()
+  (interactive)
+  (factor--listener-show-help t))
+
+(defun factor-help ()
+  (interactive)
+  (factor--listener-show-help))
+
+
 
 (defun factor-refresh-all ()
   "Reload source files and documentation for all loaded
@@ -519,6 +625,28 @@ vocabularies which have been modified on disk."
   (comint-send-string "*factor*" "refresh-all\n"))
 
 
+;;; Key bindings:
 
+(defmacro factor--define-key (key cmd)
+  `(progn
+     (define-key factor-mode-map [(control ?c) ,key] ,cmd)
+     (define-key factor-mode-map [(control ?c) (control ,key)] ,cmd)))
+
+(factor--define-key ?f 'factor-run-file)
+(factor--define-key ?r 'factor-send-region)
+(factor--define-key ?d 'factor-send-definition)
+(factor--define-key ?s 'factor-see)
+(factor--define-key ?e 'factor-edit)
+(factor--define-key ?z 'switch-to-factor)
+(factor--define-key ?c 'comment-region)
+
+(define-key factor-mode-map "\C-ch" 'factor-help)
+(define-key factor-mode-map "\C-m" 'newline-and-indent)
+(define-key factor-mode-map [tab] 'indent-for-tab-command)
+
+(define-key factor-listener-mode-map [f8] 'factor-refresh-all)
+
+
+
 (provide 'factor)
 ;;; factor.el ends here

vm/run.c

@@ -29,10 +29,35 @@ void save_stacks(void)
 	}
 }
 
+F_CONTEXT *alloc_context(void)
+{
+	F_CONTEXT *context;
+
+	if(unused_contexts)
+	{
+		context = unused_contexts;
+		unused_contexts = unused_contexts->next;
+	}
+	else
+	{
+		context = safe_malloc(sizeof(F_CONTEXT));
+		context->datastack_region = alloc_segment(ds_size);
+		context->retainstack_region = alloc_segment(rs_size);
+	}
+
+	return context;
+}
+
+void dealloc_context(F_CONTEXT *context)
+{
+	context->next = unused_contexts;
+	unused_contexts = context;
+}
+
 /* called on entry into a compiled callback */
 void nest_stacks(void)
 {
-	F_CONTEXT *new_stacks = safe_malloc(sizeof(F_CONTEXT));
+	F_CONTEXT *new_stacks = alloc_context();
 
 	new_stacks->callstack_bottom = (F_STACK_FRAME *)-1;
 	new_stacks->callstack_top = (F_STACK_FRAME *)-1;
@@ -54,9 +79,6 @@ void nest_stacks(void)
 	new_stacks->current_callback_save = userenv[CURRENT_CALLBACK_ENV];
 	new_stacks->catchstack_save = userenv[CATCHSTACK_ENV];
 
-	new_stacks->datastack_region = alloc_segment(ds_size);
-	new_stacks->retainstack_region = alloc_segment(rs_size);
-
 	new_stacks->next = stack_chain;
 	stack_chain = new_stacks;
 
@@ -67,9 +89,6 @@ void nest_stacks(void)
 /* called when leaving a compiled callback */
 void unnest_stacks(void)
 {
-	dealloc_segment(stack_chain->datastack_region);
-	dealloc_segment(stack_chain->retainstack_region);
-
 	ds = stack_chain->datastack_save;
 	rs = stack_chain->retainstack_save;
 
@@ -79,7 +98,7 @@ void unnest_stacks(void)
 
 	F_CONTEXT *old_stacks = stack_chain;
 	stack_chain = old_stacks->next;
-	free(old_stacks);
+	dealloc_context(old_stacks);
 }
 
 /* called on startup */
@@ -88,6 +107,7 @@ void init_stacks(CELL ds_size_, CELL rs_size_)
 	ds_size = ds_size_;
 	rs_size = rs_size_;
 	stack_chain = NULL;
+	unused_contexts = NULL;
 }
 
 bool stack_to_array(CELL bottom, CELL top)

vm/run.h

@@ -211,6 +211,8 @@ typedef struct _F_CONTEXT {
 
 DLLEXPORT F_CONTEXT *stack_chain;
 
+F_CONTEXT *unused_contexts;
+
 CELL ds_size, rs_size;
 
 #define ds_bot (stack_chain->datastack_region->start)