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

basis/compiler/tree/propagation/known-words/known-words.factor

@@ -138,6 +138,12 @@ most-negative-fixnum most-positive-fixnum [a,b]
 \ mod [ [ interval-mod ] [ real-valued ] binary-op ] each-derived-op
 \ rem [ [ interval-rem ] [ may-overflow real-valued ] binary-op ] each-derived-op
 
+{ /mod fixnum/mod } [
+    \ /i \ mod
+    [ "outputs" word-prop ] bi@
+    '[ _ _ 2bi ] "outputs" set-word-prop
+] each
+
 \ shift [ [ interval-shift-safe ] [ may-overflow integer-valued ] binary-op ] each-derived-op
 \ shift [ [ interval-shift-safe ] [ integer-valued ] binary-op ] each-fast-derived-op
 

basis/fry/fry-docs.factor

@@ -15,7 +15,7 @@ HELP: fry
 } ;
 
 HELP: '[
-{ $syntax "code... ]" }
+{ $syntax "'[ code... ]" }
 { $description "Literal fried quotation. Expands into code which takes values from the stack and substitutes them in place of the fry specifiers " { $link _ } " and " { $link @ } "." }
 { $examples "See " { $link "fry.examples" } "." } ;
 
@@ -49,6 +49,8 @@ $nl
     "{ 8 13 14 27 } [ even? ] 5 [ dup ] swap [ ? ] curry 3compose map"
     "{ 8 13 14 27 } [ even? dup 5 ? ] map"
 }
+"The following is a no-op:"
+{ $code "'[ @ ]" }
 "Here are some built-in combinators rewritten in terms of fried quotations:"
 { $table
     { { $link literalize } { $snippet ": literalize '[ _ ] ;" } }
@@ -74,18 +76,21 @@ ARTICLE: "fry.limitations" "Fried quotation limitations"
 "As with " { $vocab-link "locals" } ", fried quotations cannot contain " { $link >r } " and " { $link r> } ". This is not a real limitation in practice, since " { $link dip } " can be used instead." ;
 
 ARTICLE: "fry" "Fried quotations"
-"A " { $emphasis "fried quotation" } " differs from a literal quotation in that when it is evaluated, instead of just pushing itself on the stack, it consumes zero or more stack values and inserts them into the quotation."
+"The " { $vocab-link "fry" } " vocabulary implements " { $emphasis "fried quotation" } ". Conceptually, fried quotations are quotations with ``holes'' (more formally, " { $emphasis "fry specifiers" } "), and the holes are filled in when the fried quotation is pushed on the stack."
 $nl
-"Fried quotations are denoted with a special parsing word:"
+"Fried quotations are started by a special parsing word:"
 { $subsection POSTPONE: '[ }
-"Fried quotations contain zero or more " { $emphasis "fry specifiers" } ":"
+"There are two types of fry specifiers; the first can hold a value, and the second ``splices'' a quotation, as if it were inserted without surrounding brackets:"
 { $subsection _ }
 { $subsection @ }
-"When a fried quotation is being evaluated, values are consumed from the stack and spliced into the quotation from right to left."
+"The holes are filled in with the top of stack going in the rightmost hole, the second item on the stack going in the second hole from the right, and so on."
 { $subsection "fry.examples" }
 { $subsection "fry.philosophy" }
 { $subsection "fry.limitations" }
-"Quotations can also be fried without using a parsing word:"
+"Fry is implemented as a parsing word which reads a quotation and scans for occurrences of " { $link _ } " and " { $link @ } "; these words are not actually executed, and doing so raises an error (this can happen if they're accidentally used outside of a fry)."
-{ $subsection fry } ;
+$nl
+"Fried quotations can also be constructed without using a parsing word; this is useful when meta-programming:"
+{ $subsection fry }
+"Fried quotations are an abstraction on top of the " { $link "compositional-combinators" } "; their use is encouraged over the combinators, because often the fry form is shorter and clearer than the combinator form." ;
 
 ABOUT: "fry"

basis/help/cookbook/cookbook.factor

@@ -1,5 +1,6 @@
 USING: help.markup help.syntax io kernel math namespaces parser
-prettyprint sequences vocabs.loader namespaces stack-checker ;
+prettyprint sequences vocabs.loader namespaces stack-checker
+help ;
 IN: help.cookbook
 
 ARTICLE: "cookbook-syntax" "Basic syntax cookbook"
@@ -324,6 +325,19 @@ ARTICLE: "cookbook-pitfalls" "Pitfalls to avoid"
     { "If " { $link run-file } " throws a stack depth assertion, it means that the top-level form in the file left behind values on the stack. The stack depth is compared before and after loading a source file, since this type of situation is almost always an error. If you have a legitimate need to load a source file which returns data in some manner, define a word in the source file which produces this data on the stack and call the word after loading the file." }
 } ;
 
+ARTICLE: "cookbook-next" "Next steps"
+"Once you have read through " { $link "first-program" } " and " { $link "cookbook" } ", the best way to keep learning Factor is to start looking at some simple example programs. Here are a few particularly nice vocabularies which should keep you busy for a little while:"
+{ $list
+    { $vocab-link "base64" }
+    { $vocab-link "roman" }
+    { $vocab-link "rot13" }
+    { $vocab-link "smtp" }
+    { $vocab-link "time-server" }
+    { $vocab-link "tools.hexdump" }
+    { $vocab-link "webapps.counter" }
+}
+"If you see code in there that you do not understand, use " { $link see } " and " { $link help } " to explore." ;
+
 ARTICLE: "cookbook" "Factor cookbook"
 "The Factor cookbook is a high-level overview of the most important concepts required to program in Factor."
 { $subsection "cookbook-syntax" }
@@ -336,6 +350,7 @@ ARTICLE: "cookbook" "Factor cookbook"
 { $subsection "cookbook-scripts" }
 { $subsection "cookbook-compiler" }
 { $subsection "cookbook-philosophy" }
-{ $subsection "cookbook-pitfalls" } ;
+{ $subsection "cookbook-pitfalls" }
+{ $subsection "cookbook-next" } ;
 
 ABOUT: "cookbook"

basis/help/handbook/handbook.factor

@@ -65,6 +65,11 @@ $nl
     { "word"                  { "the basic unit of code, analogous to a function or procedure in other programming languages. See " { $link "words" } } }
 } ;
 
+ARTICLE: "tail-call-opt" "Tail-call optimization"
+"If the last action performed is the execution of a word, the current quotation is not saved on the call stack; this is known as " { $emphasis "tail-call optimization" } " and the Factor implementation guarantees that it will be performed."
+$nl
+"Tail-call optimization allows iterative algorithms to be implemented in an efficient manner using recursion, without the need for any kind of primitive looping construct in the language. However, in practice, most iteration is performed via combinators such as " { $link while } ", " { $link each } ", " { $link map } ", " { $link assoc-each } ", and so on. The definitions of these combinators do bottom-out in recursive words, however." ;
+
 ARTICLE: "evaluator" "Evaluation semantics"
 { $link "quotations" } " are evaluated sequentially from beginning to end. When the end is reached, the quotation returns to its caller. As each object in the quotation is evaluated in turn, an action is taken based on its type:"
 { $list
@@ -72,7 +77,7 @@ ARTICLE: "evaluator" "Evaluation semantics"
     { "a " { $link wrapper } " - the wrapped object is pushed on the data stack. Wrappers are used to push word objects directly on the stack when they would otherwise execute. See the " { $link POSTPONE: \ } " parsing word." }
     { "All other types of objects are pushed on the data stack." }
 }
-"If the last action performed is the execution of a word, the current quotation is not saved on the call stack; this is known as " { $snippet "tail-recursion" } " and allows iterative algorithms to execute without incurring unbounded call stack usage."
+{ $subsection "tail-call-opt" }
 { $see-also "compiler" } ;
 
 ARTICLE: "objects" "Objects"

basis/help/help-docs.factor

@@ -129,12 +129,17 @@ HELP: $title
 { $values { "topic" "a help article name or a word" } }
 { $description "Prints a help article's title, or a word's " { $link summary } ", depending on the type of " { $snippet "topic" } "." } ;
 
+HELP: print-topic
+{ $values { "topic" "an article name or a word" } }
+{ $description
+    "Displays a help topic on " { $link output-stream } "."
+} ;
+
 HELP: help
 { $values { "topic" "an article name or a word" } }
 { $description
-    "Displays a help article or documentation associated to a word on " { $link output-stream } "."
+    "Displays a help topic."
 } ;
-
 HELP: about
 { $values { "vocab" "a vocabulary specifier" } }
 { $description

basis/help/help.factor

@@ -89,10 +89,17 @@ M: word set-article-parent swap "help-parent" set-word-prop ;
         ] with-nesting
     ] with-style nl ;
 
-: help ( topic -- )
+: print-topic ( topic -- )
     last-element off dup $title
     article-content print-content nl ;
 
+SYMBOL: help-hook
+
+help-hook global [ [ print-topic ] or ] change-at
+
+: help ( topic -- )
+    help-hook get call ;
+
 : about ( vocab -- )
     dup require
     dup vocab [ ] [

basis/listener/listener-docs.factor

@@ -1,34 +1,39 @@
 USING: help.markup help.syntax kernel io system prettyprint ;
 IN: listener
 
+ARTICLE: "listener-watch" "Watching variables in the listener"
+"The listener prints the concepts of the data and retain stacks after every expression. It can also print values of dynamic variables which are added to a watch list:"
+{ $subsection visible-vars }
+"To add or remove a single variable:"
+{ $subsection show-var }
+{ $subsection hide-var }
+"To add and remove multiple variables:"
+{ $subsection show-vars }
+{ $subsection hide-vars } ;
+
 ARTICLE: "listener" "The listener"
 "The listener evaluates Factor expressions read from a stream. The listener is the primary interface to the Factor runtime. Typically, you write Factor code in a text editor, then load it using the listener and test it."
 $nl
 "The classical first program can be run in the listener:"
 { $example "\"Hello, world\" print" "Hello, world" }
-"Multi-line phrases are supported:"
+"Multi-line expressions are supported:"
 { $example "{ 1 2 3 } [\n    .\n] each" "1\n2\n3" }
 "The listener knows when to expect more input by looking at the height of the stack. Parsing words such as " { $link POSTPONE: { } " leave elements on the parser stack, and corresponding words such as " { $link POSTPONE: } } " pop them."
-$nl
+{ $subsection "listener-watch" }
-"A very common operation is to inspect the contents of the data stack in the listener:"
-{ $subsection .s }
-"Note that calls to " { $link .s } " can also be included inside words as a debugging aid, however a more convenient way to achieve this is to use the annotation facility. See " { $link "tools.annotations" } "."
-$nl
 "You can start a nested listener or exit a listener using the following words:"
 { $subsection listener }
 { $subsection bye }
-"The following variables can be rebound inside a nested scope to customize the behavior of a listener; this can be done to create a development tool with a custom interaction loop:"
-{ $subsection listener-hook }
 "Finally, the multi-line expression reading word can be used independently of the rest of the listener:"
 { $subsection read-quot } ;
 
 ABOUT: "listener"
 
+<PRIVATE
+
 HELP: quit-flag
 { $var-description "Variable set to true by " { $link bye } " word; it forces the next iteration of the " { $link listener } " loop to end." } ;
 
-HELP: listener-hook
+PRIVATE>
-{ $var-description "Variable holding a quotation called by the listener before reading an input expression. The UI sets this variable to a quotation which updates the stack display in a listener gadget." } ;
 
 HELP: read-quot
 { $values { "quot/f" "a parsed quotation, or " { $link f } " indicating end of file" } }

basis/listener/listener.factor

@@ -3,16 +3,10 @@
 USING: arrays hashtables io kernel math math.parser memory
 namespaces parser lexer sequences strings io.styles
 vectors words generic system combinators continuations debugger
-definitions compiler.units accessors colors ;
+definitions compiler.units accessors colors prettyprint fry
-
+sets ;
 IN: listener
 
-SYMBOL: quit-flag
-
-SYMBOL: listener-hook
-
-[ ] listener-hook set-global
-
 GENERIC: stream-read-quot ( stream -- quot/f )
 
 : parse-lines-interactive ( lines -- quot/f )
@@ -38,18 +32,57 @@ M: object stream-read-quot
 
 : read-quot ( -- quot/f ) input-stream get stream-read-quot ;
 
+<PRIVATE
+
+SYMBOL: quit-flag
+
+PRIVATE>
+
 : bye ( -- ) quit-flag on ;
 
-: prompt. ( -- )
+SYMBOL: visible-vars
-    "( " in get " )" 3append
+
-    H{ { background T{ rgba f 1 0.7 0.7 1 } } } format bl flush ;
+: show-var ( sym -- ) visible-vars  [ swap suffix ] change ;
+
+: show-vars ( seq -- ) visible-vars [ swap union ] change ;
+
+: hide-var ( sym -- ) visible-vars [ remove ] change ;
+
+: hide-vars ( seq -- ) visible-vars [ swap diff ] change ;
 
 SYMBOL: error-hook
 
 [ print-error-and-restarts ] error-hook set-global
 
+<PRIVATE
+
+: title. ( string -- )
+    H{ { foreground T{ rgba f 0.3 0.3 0.3 1 } } } format nl ;
+
+: visible-vars. ( -- )
+    visible-vars get [
+        nl "--- Watched variables:" title.
+        standard-table-style [
+            [
+                [
+                    [ [ short. ] with-cell ]
+                    [ [ get short. ] with-cell ]
+                    bi
+                ] with-row
+            ] each
+        ] tabular-output
+    ] unless-empty ;
+
+: stacks. ( -- )
+    datastack [ nl "--- Data stack:" title. stack. ] unless-empty
+    retainstack [ nl "--- Retain stack:" title. stack. ] unless-empty ;
+
+: prompt. ( -- )
+    "( " in get auto-use? get [ " - auto" append ] when " )" 3append
+    H{ { background T{ rgba f 1 0.7 0.7 1 } } } format bl flush ;
+
 : listen ( -- )
-    listener-hook get call prompt.
+    visible-vars. stacks. prompt.
     [ read-quot [ [ error-hook get call ] recover ] [ bye ] if* ]
     [
         dup lexer-error? [
@@ -62,6 +95,8 @@ SYMBOL: error-hook
 : until-quit ( -- )
     quit-flag get [ quit-flag off ] [ listen until-quit ] if ;
 
+PRIVATE>
+
 : listener ( -- )
     [ until-quit ] with-interactive-vocabs ;
 

basis/math/bitwise/bitwise-docs.factor

@@ -310,8 +310,9 @@ ARTICLE: "math-bitfields" "Constructing bit fields"
 "Some applications, such as binary communication protocols and assemblers, need to construct integers from elaborate bit field specifications. Hand-coding this using " { $link shift } " and " { $link bitor } " results in repetitive code. A higher-level facility exists to factor out this repetition:"
 { $subsection bitfield } ;
 
-ARTICLE: "math.bitwise" "Bitwise arithmetic"
+ARTICLE: "math.bitwise" "Additional bitwise arithmetic"
-"The " { $vocab-link "math.bitwise" } " vocabulary can implements bitwise arithmetic words that are useful for efficiency, low-level programming, and interfacing with C libraries." $nl
+"The " { $vocab-link "math.bitwise" } " vocabulary provides bitwise arithmetic words extending " { $link "bitwise-arithmetic" } ". They are useful for efficiency, low-level programming, and interfacing with C libraries."
+$nl
 "Setting and clearing bits:"
 { $subsection set-bit }
 { $subsection clear-bit }

basis/prettyprint/backend/backend.factor

@@ -217,14 +217,24 @@ M: vector pprint* pprint-object ;
 M: byte-vector pprint* pprint-object ;
 M: hashtable pprint* pprint-object ;
 
+GENERIC: valid-callable? ( obj -- ? )
+
+M: object valid-callable? drop f ;
+
+M: quotation valid-callable? drop t ;
+
+M: curry valid-callable? quot>> valid-callable? ;
+
+M: compose valid-callable?
+    [ first>> ] [ second>> ] bi [ valid-callable? ] both? ;
+
 M: curry pprint*
-    dup quot>> callable? [ pprint-object ] [
+    dup valid-callable? [ pprint-object ] [
         "( invalid curry )" swap present-text
     ] if ;
 
 M: compose pprint*
-    dup [ first>> callable? ] [ second>> callable? ] bi and
+    dup valid-callable? [ pprint-object ] [
-    [ pprint-object ] [
         "( invalid compose )" swap present-text
     ] if ;
 

basis/prettyprint/prettyprint-docs.factor

@@ -17,7 +17,8 @@ ARTICLE: "prettyprint-stacks" "Prettyprinting stacks"
 "Prettyprinting any stack:"
 { $subsection stack. }
 "Prettyprinting any call stack:"
-{ $subsection callstack. } ;
+{ $subsection callstack. }
+"Note that calls to " { $link .s } " can also be included inside words as a debugging aid, however a more convenient way to achieve this is to use the annotation facility. See " { $link "tools.annotations" } "." ;
 
 ARTICLE: "prettyprint-variables" "Prettyprint control variables"
 "The following variables affect the " { $link . } " and " { $link pprint } " words if set in the current dynamic scope:"

basis/prettyprint/prettyprint-tests.factor

@@ -365,3 +365,8 @@ M: started-out-hustlin' ended-up-ballin' ; inline
 [ "USING: prettyprint.tests ;\nM: started-out-hustlin' ended-up-ballin' ; inline\n" ] [
     [ { started-out-hustlin' ended-up-ballin' } see ] with-string-writer
 ] unit-test
+
+[ "( invalid curry )" ] [ 1 2 curry unparse ] unit-test
+[ "( invalid curry )" ] [ 1 2 3 curry curry unparse ] unit-test
+[ "( invalid compose )" ] [ 1 2 compose unparse ] unit-test
+[ "( invalid compose )" ] [ [ 1 ] 2 3 curry compose unparse ] unit-test

basis/tools/deploy/shaker/shaker.factor

@@ -266,7 +266,7 @@ IN: tools.deploy.shaker
                 layouts:tag-numbers
                 layouts:type-numbers
                 lexer-factory
-                listener:listener-hook
+                print-use-hook
                 root-cache
                 vocab-roots
                 vocabs:dictionary

basis/ui/gadgets/buttons/buttons.factor

@@ -2,10 +2,11 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors arrays kernel math models namespaces sequences
 strings quotations assocs combinators classes colors
-classes.tuple opengl opengl.gl math.vectors ui.commands ui.gadgets
+classes.tuple locals alien.c-types fry opengl opengl.gl
-ui.gadgets.borders ui.gadgets.labels ui.gadgets.theme
+math.vectors ui.commands ui.gadgets ui.gadgets.borders
-ui.gadgets.tracks ui.gadgets.packs ui.gadgets.worlds ui.gestures
+ui.gadgets.labels ui.gadgets.theme ui.gadgets.tracks
-ui.render math.geometry.rect locals alien.c-types ;
+ui.gadgets.packs ui.gadgets.worlds ui.gestures ui.render
+math.geometry.rect ;
 IN: ui.gadgets.buttons
 
 TUPLE: button < border pressed? selected? quot ;
@@ -27,7 +28,7 @@ TUPLE: button < border pressed? selected? quot ;
     relayout-1 ;
 
 : if-clicked ( button quot -- )
-    >r dup button-update dup button-rollover? r> [ drop ] if ;
+    [ dup button-update dup button-rollover? ] dip [ drop ] if ;
 
 : button-clicked ( button -- ) dup quot>> if-clicked ;
 
@@ -219,9 +220,8 @@ M: radio-control model-changed
     over value>> = >>selected?
     relayout-1 ;
 
-: <radio-controls> ( parent model assoc quot -- parent )
+: <radio-controls> ( assoc model parent quot: ( value model label -- ) -- parent )
-    #! quot has stack effect ( value model label -- )
+    '[ _ swap _ call add-gadget ] assoc-each ; inline
-    swapd [ swapd call add-gadget ] 2curry assoc-each ; inline
 
 : radio-button-theme ( gadget -- gadget )
     { 5 5 } >>gap
@@ -232,8 +232,7 @@ M: radio-control model-changed
 
 : <radio-buttons> ( model assoc -- gadget )
     <filled-pile>
-        -rot
+        spin [ <radio-button> ] <radio-controls>
-        [ <radio-button> ] <radio-controls>
         { 5 5 } >>gap ;
 
 : <toggle-button> ( value model label -- gadget )
@@ -241,20 +240,19 @@ M: radio-control model-changed
 
 : <toggle-buttons> ( model assoc -- gadget )
     <shelf>
-        -rot
+        spin [ <toggle-button> ] <radio-controls> ;
-        [ <toggle-button> ] <radio-controls> ;
 
 : command-button-quot ( target command -- quot )
-    [ invoke-command drop ] 2curry ;
+    '[ _ _ invoke-command drop ] ;
 
 : <command-button> ( target gesture command -- button )
-    [ command-string ] keep
+    [ command-string swap ] keep command-button-quot <bevel-button> ;
-    swapd
-    command-button-quot
-    <bevel-button> ;
 
 : <toolbar> ( target -- toolbar )
     <shelf>
         swap
         "toolbar" over class command-map commands>> swap
-        [ -rot <command-button> add-gadget ] curry assoc-each ;
+        '[ [ _ ] 2dip <command-button> add-gadget ] assoc-each ;
+
+: add-toolbar ( track -- track )
+    dup <toolbar> f track-add ;

basis/ui/gadgets/editors/editors.factor

@@ -2,17 +2,17 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors arrays documents io kernel math models
 namespaces make opengl opengl.gl sequences strings io.styles
-math.vectors sorting colors combinators assocs math.order
+math.vectors sorting colors combinators assocs math.order fry
-ui.clipboards ui.commands ui.gadgets ui.gadgets.borders
+calendar alarms ui.clipboards ui.commands ui.gadgets
-ui.gadgets.buttons ui.gadgets.labels ui.gadgets.scrollers
+ui.gadgets.borders ui.gadgets.buttons ui.gadgets.labels
-ui.gadgets.theme ui.gadgets.wrappers ui.render ui.gestures
+ui.gadgets.scrollers ui.gadgets.theme ui.gadgets.wrappers
-math.geometry.rect ;
+ui.render ui.gestures math.geometry.rect ;
 IN: ui.gadgets.editors
 
 TUPLE: editor < gadget
 font color caret-color selection-color
 caret mark
-focused? ;
+focused? blink blink-alarm ;
 
 : <loc> ( -- loc ) { 0 0 } <model> ;
 
@@ -45,6 +45,28 @@ focused? ;
     dup deactivate-model
     swap model>> remove-loc ;
 
+: blink-caret ( editor -- )
+    [ not ] change-blink relayout-1 ;
+
+SYMBOL: blink-interval
+
+750 milliseconds blink-interval set-global
+
+: start-blinking ( editor -- )
+    t >>blink
+    dup '[ _ blink-caret ] blink-interval get every >>blink-alarm drop ;
+
+: stop-blinking ( editor -- )
+    [ [ cancel-alarm ] when* f ] change-blink-alarm drop ;
+
+: restart-blinking ( editor -- )
+    dup focused?>> [
+        [ stop-blinking ]
+        [ start-blinking ]
+        [ relayout-1 ]
+        tri
+    ] [ drop ] if ;
+
 M: editor graft*
     dup
     dup caret>> activate-editor-model
@@ -52,6 +74,7 @@ M: editor graft*
 
 M: editor ungraft*
     dup
+    dup stop-blinking
     dup caret>> deactivate-editor-model
     dup mark>> deactivate-editor-model ;
 
@@ -64,14 +87,14 @@ M: editor ungraft*
     caret>> set-model ;
 
 : change-caret ( editor quot -- )
-    over >r >r dup editor-caret* swap model>> r> call r>
+    [ [ [ editor-caret* ] [ model>> ] bi ] dip call ] [ drop ] 2bi
     set-caret ; inline
 
 : mark>caret ( editor -- )
-    dup editor-caret* swap mark>> set-model ;
+    [ editor-caret* ] [ mark>> ] bi set-model ;
 
 : change-caret&mark ( editor quot -- )
-    over >r change-caret r> mark>caret ; inline
+    [ change-caret ] [ drop mark>caret ] 2bi ; inline
 
 : editor-line ( n editor -- str ) control-value nth ;
 
@@ -85,8 +108,8 @@ M: editor ungraft*
 
 : point>loc ( point editor -- loc )
     [
-        >r first2 r> tuck y>line dup ,
+        [ first2 ] dip tuck y>line dup ,
-        >r dup editor-font* r>
+        [ dup editor-font* ] dip
         rot editor-line x>offset ,
     ] { } make ;
 
@@ -94,11 +117,17 @@ M: editor ungraft*
     [ hand-rel ] keep point>loc ;
 
 : click-loc ( editor model -- )
-    >r clicked-loc r> set-model ;
+    [ clicked-loc ] dip set-model ;
 
-: focus-editor ( editor -- ) t >>focused? relayout-1 ;
+: focus-editor ( editor -- )
+    dup start-blinking
+    t >>focused?
+    relayout-1 ;
 
-: unfocus-editor ( editor -- ) f >>focused? relayout-1 ;
+: unfocus-editor ( editor -- )
+    dup stop-blinking
+    f >>focused?
+    relayout-1 ;
 
 : (offset>x) ( font col# str -- x )
     swap head-slice string-width ;
@@ -106,7 +135,7 @@ M: editor ungraft*
 : offset>x ( col# line# editor -- x )
     [ editor-line ] keep editor-font* -rot (offset>x) ;
 
-: loc>x ( loc editor -- x ) >r first2 swap r> offset>x ;
+: loc>x ( loc editor -- x ) [ first2 swap ] dip offset>x ;
 
 : line>y ( lines# editor -- y )
     line-height * ;
@@ -126,7 +155,7 @@ M: editor ungraft*
     ] [ drop ] if ;
 
 : draw-caret ( -- )
-    editor get focused?>> [
+    editor get [ focused?>> ] [ blink>> ] bi and [
         editor get
         [ caret-color>> gl-color ]
         [
@@ -143,7 +172,7 @@ M: editor ungraft*
     line-translation gl-translate ;
 
 : draw-line ( editor str -- )
-    >r font>> r> { 0 0 } draw-string ;
+    [ font>> ] dip { 0 0 } draw-string ;
 
 : first-visible-line ( editor -- n )
     clip get rect-loc second origin get second -
@@ -169,7 +198,7 @@ M: editor ungraft*
     rot control-value <slice> ;
 
 : with-editor-translation ( n quot -- )
-    >r line-translation origin get v+ r> with-translation ;
+    [ line-translation origin get v+ ] dip with-translation ;
     inline
 
 : draw-lines ( -- )
@@ -199,7 +228,7 @@ M: editor ungraft*
     editor get selection-start/end
     over first [
         2dup [
-            >r 2dup r> draw-selected-line
+            [ 2dup ] dip draw-selected-line
             1 translate-lines
         ] each-line 2drop
     ] with-editor-translation ;
@@ -217,7 +246,7 @@ M: editor pref-dim*
     drop relayout ;
 
 : caret/mark-changed ( model editor -- )
-    nip [ relayout-1 ] [ scroll>caret ] bi ;
+    nip [ restart-blinking ] [ scroll>caret ] bi ;
 
 M: editor model-changed
     {
@@ -247,7 +276,9 @@ M: editor user-input*
 M: editor gadget-text* editor-string % ;
 
 : extend-selection ( editor -- )
-    dup request-focus dup caret>> click-loc ;
+    dup request-focus
+    dup restart-blinking
+    dup caret>> click-loc ;
 
 : mouse-elt ( -- element )
     hand-click# get {
@@ -259,14 +290,15 @@ M: editor gadget-text* editor-string % ;
     editor-mark* before? ;
 
 : drag-selection-caret ( loc editor element -- loc )
-    >r [ drag-direction? ] 2keep
+    [
-    model>>
+        [ drag-direction? ] 2keep model>>
-    r> prev/next-elt ? ;
+    ] dip prev/next-elt ? ;
 
 : drag-selection-mark ( loc editor element -- loc )
-    >r [ drag-direction? not ] 2keep
+    [
-    nip dup editor-mark* swap model>>
+        [ drag-direction? not ] keep
-    r> prev/next-elt ? ;
+        [ editor-mark* ] [ model>> ] bi
+    ] dip prev/next-elt ? ;
 
 : drag-caret&mark ( editor -- caret mark )
     dup clicked-loc swap mouse-elt
@@ -285,15 +317,16 @@ M: editor gadget-text* editor-string % ;
     over gadget-selection? [
         drop nip remove-selection
     ] [
-        over >r >r dup editor-caret* swap model>>
+        [ [ [ editor-caret* ] [ model>> ] bi ] dip call ]
-        r> call r> model>> remove-doc-range
+        [ drop model>> ]
+        2bi remove-doc-range
     ] if ; inline
 
 : editor-delete ( editor elt -- )
-    swap [ over >r rot next-elt r> swap ] delete/backspace ;
+    swap [ over [ rot next-elt ] dip swap ] delete/backspace ;
 
 : editor-backspace ( editor elt -- )
-    swap [ over >r rot prev-elt r> ] delete/backspace ;
+    swap [ over [ rot prev-elt ] dip ] delete/backspace ;
 
 : editor-select-prev ( editor elt -- )
     swap [ rot prev-elt ] change-caret ;
@@ -311,9 +344,8 @@ M: editor gadget-text* editor-string % ;
     tuck caret>> set-model mark>> set-model ;
 
 : select-elt ( editor elt -- )
-    over >r
+    [ [ [ editor-caret* ] [ model>> ] bi ] dip prev/next-elt ] [ drop ] 2bi
-    >r dup editor-caret* swap model>> r> prev/next-elt
+    editor-select ;
-    r> editor-select ;
 
 : start-of-document ( editor -- ) T{ doc-elt } editor-prev ;
 
@@ -453,7 +485,7 @@ editor "caret-motion" f {
     T{ doc-elt } editor-select-next ;
 
 editor "selection" f {
-    { T{ button-down f { S+ } } extend-selection }
+    { T{ button-down f { S+ } 1 } extend-selection }
     { T{ drag } drag-selection }
     { T{ gain-focus } focus-editor }
     { T{ lose-focus } unfocus-editor }

basis/ui/gadgets/frames/frames.factor

@@ -1,4 +1,4 @@
-! Copyright (C) 2005, 2007 Slava Pestov.
+! Copyright (C) 2005, 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: arrays generic kernel math namespaces sequences words
 splitting grouping math.vectors ui.gadgets.grids ui.gadgets
@@ -11,16 +11,16 @@ TUPLE: frame < grid ;
 
 : <frame-grid> ( -- grid ) 9 [ <gadget> ] replicate 3 group ;
 
-: @center 1 1 ;
+: @center 1 1 ; inline
-: @left 0 1 ;
+: @left 0 1 ; inline
-: @right 2 1 ;
+: @right 2 1 ; inline
-: @top 1 0 ;
+: @top 1 0 ; inline
-: @bottom 1 2 ;
+: @bottom 1 2 ; inline
 
-: @top-left 0 0 ;
+: @top-left 0 0 ; inline
-: @top-right 2 0 ;
+: @top-right 2 0 ; inline
-: @bottom-left 0 2 ;
+: @bottom-left 0 2 ; inline
-: @bottom-right 2 2 ;
+: @bottom-right 2 2 ; inline
 
 : new-frame ( class -- frame )
     <frame-grid> swap new-grid ; inline
@@ -28,13 +28,12 @@ TUPLE: frame < grid ;
 : <frame> ( -- frame )
     frame new-frame ;
 
-: (fill-center) ( vec n -- )
+: (fill-center) ( n vec -- )
-    over first pick third v+ [v-] 1 rot set-nth ;
+    [ [ first ] [ third ] bi v+ [v-] ] keep set-second ;
 
-: fill-center ( horiz vert dim -- )
+: fill-center ( dim horiz vert -- )
-    tuck (fill-center) (fill-center) ;
+    [ over ] dip [ (fill-center) ] 2bi@ ;
 
 M: frame layout*
     dup compute-grid
-    [ rot rect-dim fill-center ] 3keep
+    [ [ rect-dim ] 2dip fill-center ] [ grid-layout ] 3bi ;
-    grid-layout ;

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

@@ -0,0 +1,9 @@
+USING: accessors tools.test ui.gadgets ui.gadgets.labels ;
+IN: ui.gadgets.labels.tests
+
+[ { 119 14 } ] [
+    <gadget> { 100 14 } >>dim
+    <gadget> { 14 14 } >>dim
+    label-on-right { 5 5 } >>gap
+    pref-dim
+] unit-test

basis/ui/gadgets/panes/panes.factor

@@ -363,7 +363,11 @@ M: f sloppy-pick-up*
     dup hand-rel over sloppy-pick-up >>caret
     dup relayout-1 ;
 
-: begin-selection ( pane -- ) move-caret f >>mark drop ;
+: begin-selection ( pane -- )
+    f >>selecting?
+    move-caret
+    f >>mark
+    drop ;
 
 : extend-selection ( pane -- )
     hand-moved? [
@@ -389,6 +393,7 @@ M: f sloppy-pick-up*
     ] if ;
 
 : select-to-caret ( pane -- )
+    t >>selecting?
     dup mark>> [ caret>mark ] unless
     move-caret
     dup request-focus

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

@@ -2,7 +2,8 @@ USING: ui.gadgets ui.gadgets.scrollers namespaces tools.test
 kernel models models.compose models.range ui.gadgets.viewports
 ui.gadgets.labels ui.gadgets.grids ui.gadgets.frames
 ui.gadgets.sliders math math.vectors arrays sequences
-tools.test.ui math.geometry.rect accessors ;
+tools.test.ui math.geometry.rect accessors ui.gadgets.buttons
+ui.gadgets.packs ;
 IN: ui.gadgets.scrollers.tests
 
 [ ] [
@@ -74,7 +75,7 @@ dup layout
         "g2" get scroll>gadget
         "s" get layout
         "s" get scroller-value
-    ] map [ { 3 0 } = ] all?
+    ] map [ { 2 0 } = ] all?
 ] unit-test
 
 [ ] [ "Hi" <label> dup "l" set <scroller> "s" set ] unit-test
@@ -86,4 +87,22 @@ dup layout
 [ t ] [ "s" get @right grid-child slider? ] unit-test
 [ f ] [ "s" get @right grid-child find-scroller* ] unit-test
 
+[ ] [
+    "Click Me" [ [ scroll>gadget ] [ unparent ] bi ] <bevel-button>
+    [ <pile> swap add-gadget <scroller> ] keep
+    dup quot>> call
+    layout
+] unit-test
+
+[ t ] [
+    <gadget> { 200 200 } >>dim
+    [ [ scroll>gadget ] [ unparent ] bi ] <bevel-button>
+    dup
+    <pile> swap add-gadget <scroller> { 100 100 } >>dim dup layout
+    swap dup quot>> call
+    dup layout
+    model>> dependencies>> [ range-max value>> ] map
+    viewport-gap 2 v*n =
+] unit-test
+
 \ <scroller> must-infer

basis/ui/gadgets/scrollers/scrollers.factor

@@ -3,9 +3,8 @@
 USING: accessors arrays ui.gadgets ui.gadgets.viewports
 ui.gadgets.frames ui.gadgets.grids ui.gadgets.theme
 ui.gadgets.sliders ui.gestures kernel math namespaces sequences
-models models.range models.compose
+models models.range models.compose combinators math.vectors
-combinators math.vectors classes.tuple math.geometry.rect
+classes.tuple math.geometry.rect combinators.short-circuit ;
-combinators.short-circuit ;
 IN: ui.gadgets.scrollers
 
 TUPLE: scroller < frame viewport x y follows ;
@@ -22,9 +21,10 @@ TUPLE: scroller < frame viewport x y follows ;
 : scroll-down-line ( scroller -- ) y>> 1 swap slide-by-line ;
 
 : do-mouse-scroll ( scroller -- )
-    scroll-direction get-global first2
+    scroll-direction get-global
-    pick y>> slide-by-line
+    [ first swap x>> slide-by-line ]
-    swap x>> slide-by-line ;
+    [ second swap y>> slide-by-line ]
+    2bi ;
 
 scroller H{
     { T{ mouse-scroll } [ do-mouse-scroll ] }
@@ -49,8 +49,8 @@ scroller H{
 
 : scroll ( value scroller -- )
     [
-        dup viewport>> rect-dim { 0 0 }
+        viewport>> [ rect-dim { 0 0 } ] [ viewport-dim ] bi
-        rot viewport>> viewport-dim 4array flip
+        4array flip
     ] keep
     2dup control-value = [ 2drop ] [ set-control-value ] if ;
 
@@ -58,15 +58,14 @@ scroller H{
     [ [ loc>> ] [ dim>> ] bi ] dip vmin <rect> ;
 
 : (scroll>rect) ( rect scroller -- )
-    [
+    [ [ loc>> { 1 1 } v- ] [ dim>> { 1 1 } v+ ] bi <rect> ] dip
-        scroller-value vneg offset-rect
+    {
-        viewport-gap offset-rect
+        [ scroller-value vneg offset-rect viewport-gap offset-rect ]
-    ] keep
+        [ viewport>> dim>> rect-min ]
-    [ viewport>> dim>> rect-min ] keep
+        [ viewport>> 2rect-extent [ v- { 0 0 } vmin ] [ v- { 0 0 } vmax ] 2bi* v+ ]
-    [
+        [ scroller-value v+ ]
-        viewport>> 2rect-extent
+        [ scroll ]
-        [ v- { 1 1 } v- { 0 0 } vmin ] [ v- { 0 0 } vmax ] 2bi* v+
+    } cleave ;
-    ] keep dup scroller-value rot v+ swap scroll ;
 
 : relative-scroll-rect ( rect gadget scroller -- newrect )
     viewport>> gadget-child relative-loc offset-rect ;
@@ -81,14 +80,17 @@ scroller H{
         [ relative-scroll-rect ] keep
         swap >>follows
         relayout
-    ] [
+    ] [ 3drop ] if ;
-        3drop
+
-    ] if ;
+: (update-scroller) ( scroller -- )
+    [ scroller-value ] keep scroll ;
 
 : (scroll>gadget) ( gadget scroller -- )
-    >r { 0 0 } over pref-dim <rect> swap r>
+    2dup swap child? [
+        [ [ pref-dim { 0 0 } swap <rect> ] keep ] dip
         [ relative-scroll-rect ] keep
-    (scroll>rect) ;
+        (scroll>rect)
+    ] [ f >>follows (update-scroller) drop ] if ;
 
 : scroll>gadget ( gadget -- )
     dup find-scroller* dup [
@@ -99,7 +101,7 @@ scroller H{
     ] if ;
 
 : (scroll>bottom) ( scroller -- )
-    dup viewport>> viewport-dim { 0 1 } v* swap scroll ;
+    [ viewport>> viewport-dim { 0 1 } v* ] keep scroll ;
 
 : scroll>bottom ( gadget -- )
     find-scroller [ t >>follows relayout-1 ] when* ;
@@ -115,24 +117,26 @@ M: gadget update-scroller swap (scroll>gadget) ;
 
 M: rect update-scroller swap (scroll>rect) ;
 
-M: f update-scroller drop dup scroller-value swap scroll ;
+M: f update-scroller drop (update-scroller) ;
 
 M: scroller layout*
-    dup call-next-method
+    [ call-next-method ] [
         dup follows>>
-    2dup update-scroller
+        [ update-scroller ] [ >>follows drop ] 2bi
-    >>follows drop ;
+    ] bi ; 
 
 M: scroller focusable-child*
     viewport>> ;
 
 M: scroller model-changed
-    nip f >>follows drop ;
+    f >>follows 2drop ;
 
-TUPLE: limited-scroller < scroller fixed-dim ;
+TUPLE: limited-scroller < scroller
+{ min-dim initial: { 0 0 } }
+{ max-dim initial: { 1/0. 1/0. } } ;
 
-: <limited-scroller> ( gadget dim -- scroller )
+: <limited-scroller> ( gadget -- scroller )
-    >r limited-scroller new-scroller r> >>fixed-dim ;
+    limited-scroller new-scroller ;
 
 M: limited-scroller pref-dim*
-    fixed-dim>> ;
+    [ call-next-method ] [ min-dim>> vmax ] [ max-dim>> vmin ] tri ;

basis/ui/gadgets/slots/slots.factor

@@ -71,7 +71,7 @@ M: value-ref finish-editing
 : <slot-editor> ( ref -- gadget )
     { 0 1 } slot-editor new-track
         swap >>ref
-        dup <toolbar> f track-add
+        add-toolbar
         <source-editor> >>text
         dup text>> <scroller> 1 track-add
         dup revert ;

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

@@ -14,3 +14,10 @@ IN: ui.gadgets.tracks.tests
         <gadget> { 100 100 } >>dim 1 track-add
     pref-dim
 ] unit-test
+
+[ { 10 10 } ] [
+    { 0 1 } <track>
+        <gadget> { 10 10 } >>dim 1 track-add
+        <gadget> { 10 10 } >>dim 0 track-add
+    pref-dim
+] unit-test

basis/ui/gadgets/tracks/tracks.factor

@@ -1,8 +1,8 @@
 ! Copyright (C) 2006, 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: accessors io kernel math namespaces
+USING: accessors io kernel namespaces fry
-       sequences words math.vectors ui.gadgets ui.gadgets.packs
+math math.vectors math.geometry.rect math.order
-       math.geometry.rect fry ;
+sequences words ui.gadgets ui.gadgets.packs ;
 
 IN: ui.gadgets.tracks
 
@@ -35,13 +35,17 @@ TUPLE: track < pack sizes ;
 
 M: track layout* ( track -- ) dup track-layout pack-layout ;
 
-: track-pref-dims-1 ( track -- dim ) children>> pref-dims max-dim ;
+: track-pref-dims-1 ( track -- dim )
+    children>> pref-dims max-dim ;
 
 : track-pref-dims-2 ( track -- dim )
+    [
         [ children>> pref-dims ] [ normalized-sizes ] bi
-    [ [ v/n ] when* ] 2map
+        [ dup { 0 f } memq? [ drop ] [ v/n ] if ] 2map
-    max-dim
+        max-dim [ >fixnum ] map
-    [ >fixnum ] map ;
+    ]
+    [ [ gap>> ] [ children>> length 1 [-] ] bi v*n ] bi
+    v+ ;
 
 M: track pref-dim* ( gadget -- dim )
     [ track-pref-dims-1 ]

basis/ui/gadgets/viewports/viewports.factor

@@ -21,9 +21,11 @@ TUPLE: viewport < gadget ;
         swap add-gadget ;
 
 M: viewport layout*
-    dup rect-dim viewport-gap 2 v*n v-
+    [
-    over gadget-child pref-dim vmax
+        [ rect-dim viewport-gap 2 v*n v- ]
-    swap gadget-child (>>dim) ;
+        [ gadget-child pref-dim ]
+        bi vmax
+    ] [ gadget-child ] bi (>>dim) ;
 
 M: viewport focusable-child*
     gadget-child ;

basis/ui/gadgets/worlds/worlds.factor

@@ -30,7 +30,7 @@ ERROR: no-world-found ;
 
 : (request-focus) ( child world ? -- )
     pick parent>> pick eq? [
-        >r >r dup parent>> dup r> r>
+        [ dup parent>> dup ] 2dip
         [ (request-focus) ] keep
     ] unless focus-child ;
 
@@ -80,7 +80,7 @@ SYMBOL: ui-error-hook
 : ui-error ( error -- )
     ui-error-hook get [ call ] [ print-error ] if* ;
 
-[ rethrow ] ui-error-hook set-global
+ui-error-hook global [ [ rethrow ] or ] change-at
 
 : draw-world ( world -- )
     dup draw-world? [

basis/ui/tools/browser/browser.factor

@@ -4,17 +4,17 @@ USING: debugger ui.tools.workspace help help.topics kernel
 models models.history ui.commands ui.gadgets ui.gadgets.panes
 ui.gadgets.scrollers ui.gadgets.tracks ui.gestures
 ui.gadgets.buttons compiler.units assocs words vocabs
-accessors ;
+accessors fry combinators.short-circuit ;
 IN: ui.tools.browser
 
 TUPLE: browser-gadget < track pane history ;
 
 : show-help ( link help -- )
-    dup history>> add-history
+    history>> dup add-history
-    >r >link r> history>> set-model ;
+    [ >link ] dip set-model ;
 
 : <help-pane> ( browser-gadget -- gadget )
-    history>> [ [ help ] curry try ] <pane-control> ;
+    history>> [ '[ _ print-topic ] try ] <pane-control> ;
 
 : init-history ( browser-gadget -- )
     "handbook" >link <history> >>history drop ;
@@ -22,7 +22,7 @@ TUPLE: browser-gadget < track pane history ;
 : <browser-gadget> ( -- gadget )
     { 0 1 } browser-gadget new-track
         dup init-history
-        dup <toolbar> f track-add
+        add-toolbar
         dup <help-pane> >>pane
         dup pane>> <scroller> 1 track-add ;
 
@@ -38,10 +38,11 @@ M: browser-gadget ungraft*
     [ call-next-method ] [ remove-definition-observer ] bi ;
 
 : showing-definition? ( defspec assoc -- ? )
-    [ key? ] 2keep
+    {
-    [ >r dup word-link? [ name>> ] when r> key? ] 2keep
+        [ key? ]
-    >r dup vocab-link? [ vocab ] when r> key?
+        [ [ dup word-link? [ name>> ] when ] dip key? ]
-    or or ;
+        [ [ dup vocab-link? [ vocab ] when ] dip key? ]
+    } 2|| ;
 
 M: browser-gadget definitions-changed ( assoc browser -- )
     history>>

basis/ui/tools/debugger/debugger.factor

@@ -25,7 +25,7 @@ TUPLE: debugger < track restarts ;
 
 : <debugger> ( error restarts restart-hook -- gadget )
     { 0 1 } debugger new-track
-        dup <toolbar> f track-add
+        add-toolbar
         -rot <restart-list> >>restarts
         dup restarts>> rot <debugger-display> <scroller> 1 track-add ;
 
@@ -35,7 +35,15 @@ M: debugger focusable-child* restarts>> ;
     #! No restarts for the debugger window
     f [ drop ] <debugger> "Error" open-window ;
 
-[ debugger-window ] ui-error-hook set-global
+GENERIC: error-in-debugger? ( error -- ? )
+
+M: world-error error-in-debugger? world>> gadget-child debugger? ;
+
+M: object error-in-debugger? drop f ;
+
+[
+    dup error-in-debugger? [ rethrow ] [ debugger-window ] if 
+] ui-error-hook set-global
 
 M: world-error error.
     "An error occurred while drawing the world " write

basis/ui/tools/deploy/deploy.factor

@@ -96,9 +96,12 @@ TUPLE: deploy-gadget < pack vocab settings ;
 : com-close ( gadget -- )
     close-window ;
 
+deploy-gadget "misc" "Miscellaneous commands" {
+    { T{ key-down f f "ESC" } com-close }
+} define-command-map
+
 deploy-gadget "toolbar" f {
-    { f com-close }
+    { T{ key-down f f "F1" } com-help }
-    { f com-help }
     { f com-revert }
     { f com-save }
     { T{ key-down f f "RET" } com-deploy }

basis/ui/tools/inspector/inspector.factor

@@ -17,7 +17,7 @@ TUPLE: inspector-gadget < track object pane ;
 
 : <inspector-gadget> ( -- gadget )
     { 0 1 } inspector-gadget new-track
-        dup <toolbar> f track-add
+        add-toolbar
         <pane> >>pane
         dup pane>> <scroller> 1 track-add ;
 

basis/ui/tools/interactor/interactor.factor

@@ -178,10 +178,6 @@ M: interactor stream-read-quot
         ]
     } cond ;
 
-M: interactor pref-dim*
-    [ line-height 4 * 0 swap 2array ] [ call-next-method ] bi
-    vmax ;
-
 interactor "interactor" f {
     { T{ key-down f f "RET" } evaluate-input }
     { T{ key-down f { C+ } "k" } clear-input }

basis/ui/tools/listener/listener.factor

@@ -1,20 +1,21 @@
 ! Copyright (C) 2005, 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: inspector ui.tools.interactor ui.tools.inspector
+USING: inspector help help.markup io io.styles
-ui.tools.workspace help.markup io io.styles
+kernel models namespaces parser quotations sequences  vocabs words
-kernel models namespaces parser quotations sequences ui.commands
+prettyprint listener debugger threads boxes concurrency.flags
+math arrays generic accessors combinators assocs fry ui.commands
 ui.gadgets ui.gadgets.editors ui.gadgets.labelled
 ui.gadgets.panes ui.gadgets.buttons ui.gadgets.scrollers
-ui.gadgets.tracks ui.gestures ui.operations vocabs words
+ui.gadgets.tracks ui.gadgets.borders ui.gestures ui.operations
-prettyprint listener debugger threads boxes concurrency.flags
+ui.tools.browser ui.tools.interactor ui.tools.inspector
-math arrays generic accessors combinators assocs ;
+ui.tools.workspace ;
 IN: ui.tools.listener
 
-TUPLE: listener-gadget < track input output stack ;
+TUPLE: listener-gadget < track input output ;
 
 : listener-output, ( listener -- listener )
-    <scrolling-pane> >>output
+    <scrolling-pane>
-    dup output>> <scroller> "Output" <labelled-gadget> 1 track-add ;
+    [ >>output ] [ <scroller> 1 track-add ] bi ;
 
 : listener-streams ( listener -- input output )
     [ input>> ] [ output>> <pane-stream> ] bi ;
@@ -23,15 +24,13 @@ TUPLE: listener-gadget < track input output stack ;
     output>> <pane-stream> <interactor> ;
 
 : listener-input, ( listener -- listener )
-    dup <listener-input> >>input
+    dup <listener-input>
-    dup input>>
+    [ >>input ] [ 1 <border> { 1 1 } >>fill f track-add ] bi ;
-        { 0 100 } <limited-scroller>
-        "Input" <labelled-gadget>
-    f track-add ;
 
 : welcome. ( -- )
     "If this is your first time with Factor, please read the " print
-    "handbook" ($link) "." print nl ;
+    "handbook" ($link) ". To see a list of keyboard shortcuts," print
+    "press F1." print nl ;
 
 M: listener-gadget focusable-child*
     input>> ;
@@ -58,7 +57,7 @@ M: listener-gadget tool-scroller
 
 : call-listener ( quot -- )
     [ workspace-busy? not ] get-workspace* listener>>
-    [ dup wait-for-listener (call-listener) ] 2curry
+    '[ _ _ dup wait-for-listener (call-listener) ]
     "Listener call" spawn drop ;
 
 M: listener-command invoke-command ( target command -- )
@@ -74,7 +73,7 @@ M: listener-operation invoke-command ( target command -- )
 
 : listener-run-files ( seq -- )
     [
-        [ [ run-file ] each ] curry call-listener
+        '[ _ [ run-file ] each ] call-listener
     ] unless-empty ;
 
 : com-end ( listener -- )
@@ -120,20 +119,8 @@ M: engine-word word-completion-string
     [ select-all ]
     2bi ;
 
-TUPLE: stack-display < track ;
+: ui-help-hook ( topic -- )
-
+    browser-gadget call-tool ;
-: <stack-display> ( workspace -- gadget )
-    listener>>
-    { 0 1 } stack-display new-track
-    over <toolbar> f track-add
-    swap stack>> [ [ stack. ] curry try ] t "Data stack" <labelled-pane>
-    1 track-add ;
-
-M: stack-display tool-scroller
-    find-workspace listener>> tool-scroller ;
-
-: ui-listener-hook ( listener -- )
-    >r datastack r> stack>> set-model ;
 
 : ui-error-hook ( error listener -- )
     find-workspace debugger-popup ;
@@ -144,17 +131,20 @@ M: stack-display tool-scroller
 
 : listener-thread ( listener -- )
     dup listener-streams [
-        [ [ ui-listener-hook ] curry listener-hook set ]
+        [ ui-help-hook ] help-hook set
-        [ [ ui-error-hook ] curry error-hook set ]
+        [ '[ _ ui-error-hook ] error-hook set ]
-        [ [ ui-inspector-hook ] curry inspector-hook set ] tri
+        [ '[ _ ui-inspector-hook ] inspector-hook set ] bi
         welcome.
         listener
     ] with-streams* ;
 
 : start-listener-thread ( listener -- )
-    [
+    '[
-        [ input>> register-self ] [ listener-thread ] bi
+        _
-    ] curry "Listener" spawn drop ;
+        [ input>> register-self ]
+        [ listener-thread ]
+        bi
+    ] "Listener" spawn drop ;
 
 : restart-listener ( listener -- )
     #! Returns when listener is ready to receive input.
@@ -166,12 +156,9 @@ M: stack-display tool-scroller
         [ wait-for-listener ]
     } cleave ;
 
-: init-listener ( listener -- )
-    f <model> >>stack drop ;
-
 : <listener-gadget> ( -- gadget )
     { 0 1 } listener-gadget new-track
-        dup init-listener
+        add-toolbar
         listener-output,
         listener-input, ;
 
@@ -179,12 +166,21 @@ M: stack-display tool-scroller
 
 \ listener-help H{ { +nullary+ t } } define-command
 
+: com-auto-use ( -- )
+    auto-use? [ not ] change ;
+
+\ com-auto-use H{ { +nullary+ t } { +listener+ t } } define-command
+
+listener-gadget "misc" "Miscellaneous commands" {
+    { T{ key-down f f "F1" } listener-help }
+} define-command-map
+
 listener-gadget "toolbar" f {
     { f restart-listener }
+    { T{ key-down f { A+ } "a" } com-auto-use }
     { T{ key-down f { A+ } "c" } clear-output }
     { T{ key-down f { A+ } "C" } clear-stack }
     { T{ key-down f { C+ } "d" } com-end }
-    { T{ key-down f f "F1" } listener-help }
 } define-command-map
 
 M: listener-gadget handle-gesture ( gesture gadget -- ? )

basis/ui/tools/profiler/profiler.factor

@@ -9,7 +9,7 @@ TUPLE: profiler-gadget < track pane ;
 
 : <profiler-gadget> ( -- gadget )
     { 0 1 } profiler-gadget new-track
-        dup <toolbar> f track-add
+        add-toolbar
         <pane> >>pane
         dup pane>> <scroller> 1 track-add ;
 

basis/ui/tools/search/search.factor

@@ -1,14 +1,14 @@
 ! Copyright (C) 2006, 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: accessors assocs ui.tools.interactor ui.tools.listener
+USING: accessors assocs help help.topics io.files io.styles
-ui.tools.workspace help help.topics io.files io.styles kernel
+kernel models models.delay models.filter namespaces prettyprint
-models models.delay models.filter namespaces prettyprint
 quotations sequences sorting source-files definitions strings
-tools.completion tools.crossref classes.tuple ui.commands
+tools.completion tools.crossref classes.tuple vocabs words
-ui.gadgets ui.gadgets.editors ui.gadgets.lists
+vocabs.loader tools.vocabs unicode.case calendar locals
-ui.gadgets.scrollers ui.gadgets.tracks ui.gestures ui.operations
+ui.tools.interactor ui.tools.listener ui.tools.workspace
-vocabs words vocabs.loader tools.vocabs unicode.case calendar ui
+ui.commands ui.gadgets ui.gadgets.editors ui.gadgets.lists
-;
+ui.gadgets.scrollers ui.gadgets.tracks ui.gadgets.borders
+ui.gestures ui.operations ui ;
 IN: ui.tools.search
 
 TUPLE: live-search < track field list ;
@@ -23,7 +23,7 @@ TUPLE: live-search < track field list ;
 M: live-search handle-gesture ( gesture live-search -- ? )
     tuck search-gesture dup [
         over find-workspace hide-popup
-        >r search-value r> invoke-command f
+        [ search-value ] dip invoke-command f
     ] [
         2drop t
     ] if ;
@@ -47,26 +47,28 @@ search-field H{
     { T{ key-down f f "RET" } [ find-search-list invoke-value-action ] }
 } set-gestures
 
-: <search-model> ( live-search producer -- live-search filter )
+: <search-model> ( live-search producer -- filter )
-    >r dup field>> model>>                   ! live-search model :: producer
+    [
+        field>> model>>
         ui-running? [ 1/5 seconds <delay> ] when
-    [ "\n" join ] r> append <filter> ;
+    ] dip [ "\n" join ] prepend <filter> ;
 
-: <search-list> ( live-search seq limited? presenter -- live-search list )
+: init-search-model ( live-search seq limited? -- live-search )
-    >r
+    [ 2drop ]
-    [ limited-completions ] [ completions ] ? curry
+    [ [ limited-completions ] [ completions ] ? curry <search-model> ] 3bi
-    <search-model>
+    >>model ; inline
-    >r [ find-workspace hide-popup ] r> r>
-    swap <list> ;
 
-: <live-search> ( string seq limited? presenter -- gadget )
+: <search-list> ( presenter live-search -- list )
+    [ [ find-workspace hide-popup ] ] [ ] [ model>> ] tri* <list> ;
+
+:: <live-search> ( string seq limited? presenter -- gadget )
     { 0 1 } live-search new-track
         <search-field> >>field
-        dup field>> f track-add
+        seq limited? init-search-model
-        -roll <search-list> >>list
+        presenter over <search-list> >>list
+        dup field>> 1 <border> { 1 1 } >>fill f track-add
         dup list>> <scroller> 1 track-add
-    swap                         
+        string over field>> set-editor-string
-        over field>> set-editor-string
         dup field>> end-of-document ;
 
 M: live-search focusable-child* field>> ;
@@ -80,26 +82,27 @@ M: live-search pref-dim* drop { 400 200 } ;
     [ dup synopsis >lower ] { } map>assoc sort-values ;
 
 : <definition-search> ( string words limited? -- gadget )
-    >r definition-candidates r> [ synopsis ] <live-search> ;
+    [ definition-candidates ] dip [ synopsis ] <live-search> ;
 
 : word-candidates ( words -- candidates )
     [ dup name>> >lower ] { } map>assoc ;
 
 : <word-search> ( string words limited? -- gadget )
-    >r word-candidates r> [ synopsis ] <live-search> ;
+    [ word-candidates ] dip [ synopsis ] <live-search> ;
 
 : com-words ( workspace -- )
     dup current-word all-words t <word-search>
     "Word search" show-titled-popup ;
 
 : show-vocab-words ( workspace vocab -- )
-    "" over words natural-sort f <word-search>
+    [ "" swap words natural-sort f <word-search> ]
-    "Words in " rot vocab-name append show-titled-popup ;
+    [ "Words in " swap vocab-name append ]
+    bi show-titled-popup ;
 
 : show-word-usage ( workspace word -- )
-    "" over smart-usage f <definition-search>
+    [ "" swap smart-usage f <definition-search> ]
-    "Words and methods using " rot name>> append
+    [ "Words and methods using " swap name>> append ]
-    show-titled-popup ;
+    bi show-titled-popup ;
 
 : help-candidates ( seq -- candidates )
     [ dup >link swap article-title >lower ] { } map>assoc
@@ -127,8 +130,9 @@ M: live-search pref-dim* drop { 400 200 } ;
     "Source file search" show-titled-popup ;
 
 : show-vocab-files ( workspace vocab -- )
-    "" over vocab-files <source-file-search>
+    [ "" swap vocab-files <source-file-search> ]
-    "Source files in " rot vocab-name append show-titled-popup ;
+    [ "Source files in " swap vocab-name append ]
+    bi show-titled-popup ;
 
 : vocab-candidates ( -- candidates )
     all-vocabs-seq [ dup vocab-name >lower ] { } map>assoc ;

basis/ui/tools/tools-docs.factor

@@ -32,7 +32,7 @@ ARTICLE: "ui-listener" "UI listener"
 { $heading "Editing commands" }
 "The text editing commands are standard; see " { $link "gadgets-editors" } "."
 { $heading "Implementation" }
-"Listeners are instances of " { $link listener-gadget } ". The listener consists of an output area (instance of " { $link pane } "), and an input area (instance of " { $link interactor } "), and a stack display kept up to date using a " { $link listener-hook } "." ;
+"Listeners are instances of " { $link listener-gadget } ". The listener consists of an output area (instance of " { $link pane } ") and an input area (instance of " { $link interactor } ")." ;
 
 ARTICLE: "ui-inspector" "UI inspector"
 "The graphical inspector builds on the terminal inspector (see " { $link "inspector" } ") and provides in-place editing of slot values."

basis/ui/tools/tools.factor

@@ -19,8 +19,7 @@ IN: ui.tools
     <toggle-buttons> ;
 
 : <workspace-book> ( workspace -- gadget )
-    dup
+        <gadget>
-        <stack-display>
         <browser-gadget>
         <inspector-gadget>
         <profiler-gadget>
@@ -34,14 +33,14 @@ IN: ui.tools
         dup <workspace-book> >>book
 
         dup <workspace-tabs> f track-add
-        dup book>> 1/5 track-add
+        dup book>> 0 track-add
-        dup listener>> 4/5 track-add
+        dup listener>> 1 track-add
-        dup <toolbar> f track-add ;
+        add-toolbar ;
 
 : resize-workspace ( workspace -- )
-    dup sizes>> over control-value zero? [
+    dup sizes>> over control-value 0 = [
-        1/5 over set-second
+        0 over set-second
-        4/5 swap set-third
+        1 swap set-third
     ] [
         2/3 over set-second
         1/3 swap set-third
@@ -55,13 +54,15 @@ M: workspace model-changed
 
 [ workspace-window ] ui-hook set-global
 
-: com-listener ( workspace -- ) stack-display select-tool ;
+: select-tool ( workspace n -- ) swap book>> model>> set-model ;
 
-: com-browser ( workspace -- ) browser-gadget select-tool ;
+: com-listener ( workspace -- ) 0 select-tool ;
 
-: com-inspector ( workspace -- ) inspector-gadget select-tool ;
+: com-browser ( workspace -- ) 1 select-tool ;
 
-: com-profiler ( workspace -- ) profiler-gadget select-tool ;
+: com-inspector ( workspace -- ) 2 select-tool ;
+
+: com-profiler ( workspace -- ) 3 select-tool ;
 
 workspace "tool-switching" f {
     { T{ key-down f { A+ } "1" } com-listener }

basis/ui/tools/traceback/traceback.factor

@@ -36,14 +36,17 @@ M: traceback-gadget pref-dim* drop { 550 600 } ;
 
     dup model>> <callstack-display> 2/3 track-add
 
-    dup <toolbar> f track-add ;
+    add-toolbar ;
 
 : <namestack-display> ( model -- gadget )
     [ [ name>> namestack. ] when* ]
     <pane-control> ;
 
 : <variables-gadget> ( model -- gadget )
-    <namestack-display> { 400 400 } <limited-scroller> ;
+    <namestack-display>
+    <limited-scroller>
+        { 400 400 } >>min-dim
+        { 400 400 } >>max-dim ;
 
 : variables ( traceback -- )
     model>> <variables-gadget>

basis/ui/tools/walker/walker.factor

@@ -62,7 +62,7 @@ M: walker-gadget focusable-child*
         swap >>status
         dup continuation>> <traceback-gadget> >>traceback
 
-        dup <toolbar>                     f track-add
+        add-toolbar
         dup status>> self <thread-status> f track-add
         dup traceback>> 1 track-add ;
     

basis/ui/tools/workspace/workspace.factor

@@ -1,12 +1,12 @@
-! Copyright (C) 2006, 2007 Slava Pestov.
+! Copyright (C) 2006, 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: classes continuations help help.topics kernel models
-       sequences ui ui.backend ui.tools.debugger ui.gadgets
+sequences assocs arrays namespaces accessors math.vectors ui
-       ui.gadgets.books ui.gadgets.buttons ui.gadgets.labelled
+ui.backend ui.tools.debugger ui.gadgets ui.gadgets.books
-       ui.gadgets.panes ui.gadgets.scrollers ui.gadgets.tracks
+ui.gadgets.buttons ui.gadgets.labelled ui.gadgets.panes
-       ui.gadgets.worlds ui.gadgets.presentations ui.gadgets.status-bar
+ui.gadgets.scrollers ui.gadgets.tracks ui.gadgets.worlds
-       ui.commands ui.gestures assocs arrays namespaces accessors ;
+ui.gadgets.presentations ui.gadgets.status-bar ui.commands
-
+ui.gestures ;
 IN: ui.tools.workspace
 
 TUPLE: workspace < track book listener popup ;
@@ -32,8 +32,6 @@ M: gadget tool-scroller drop f ;
     [ find-tool swap ] keep book>> model>>
     set-model ;
 
-: select-tool ( workspace class -- ) swap show-tool drop ;
-
 : get-workspace* ( quot -- workspace )
     [ >r dup workspace? r> [ drop f ] if ] curry find-window
     [ dup raise-window gadget-child ]
@@ -47,12 +45,15 @@ M: gadget tool-scroller drop f ;
 : get-tool ( class -- gadget )
     get-workspace find-tool nip ;
 
+: <help-pane> ( topic -- pane )
+    <pane> [ [ help ] with-pane ] keep ;
+
 : help-window ( topic -- )
     [
-        <pane> [ [ help ] with-pane ] keep
+        <help-pane> <limited-scroller>
-        { 550 700 } <limited-scroller>
+            { 550 700 } >>max-dim
-    ] keep
+    ] [ article-title ] bi
-    article-title open-window ;
+    open-window ;
 
 : hide-popup ( workspace -- )
     dup popup>> track-remove
@@ -78,7 +79,7 @@ SYMBOL: workspace-dim
 
 { 600 700 } workspace-dim set-global
 
-M: workspace pref-dim* drop workspace-dim get ;
+M: workspace pref-dim* call-next-method workspace-dim get vmax ;
 
 M: workspace focusable-child*
     dup popup>> [ ] [ listener>> ] ?if ;

basis/ui/ui.factor

@@ -129,8 +129,8 @@ SYMBOL: ui-hook
 
 : notify ( gadget -- )
     dup graft-state>>
-    dup first { f f } { t t } ?
+    [ first { f f } { t t } ? >>graft-state ] keep
-    pick (>>graft-state) {
+    {
         { { f t } [ dup activate-control graft* ] }
         { { t f } [ dup deactivate-control ungraft* ] }
     } case ;

basis/ui/x11/x11.factor

@@ -185,7 +185,7 @@ M: world client-event
 
 M: x11-ui-backend do-events
     wait-event dup XAnyEvent-window window dup
-    [ [ 2dup handle-event ] assert-depth ] when 2drop ;
+    [ [ [ 2dup handle-event ] ui-try ] assert-depth ] when 2drop ;
 
 : x-clipboard@ ( gadget clipboard -- prop win )
     atom>> swap

basis/values/values-docs.factor

@@ -2,7 +2,7 @@ USING: help.markup help.syntax ;
 IN: values
 
 ARTICLE: "values" "Global values"
-"Usually, dynamically scoped variables are sufficient for holding data which is not literal. But occasionally, for global information that's calculated just once, it's useful to use the word mechanism instead, and set the word to the appropriate value just once. Values abstract over this concept. To create a new word as a value, use the following syntax:"
+"Usually, dynamically scoped variables are sufficient for holding data which is not literal. But occasionally, for global information that's calculated just once, it's useful to use the word mechanism instead, and set the word to the appropriate value just once. The " { $vocab-link "values" } " vocabulary implements " { $emphasis "values" } ", which abstract over this concept. To create a new word as a value, use the following syntax:"
 { $subsection POSTPONE: VALUE: }
 "To get the value, just call the word. The following words manipulate values:"
 { $subsection get-value }
@@ -10,6 +10,8 @@ ARTICLE: "values" "Global values"
 { $subsection POSTPONE: to: }
 { $subsection change-value } ;
 
+ABOUT: "values"
+
 HELP: VALUE:
 { $syntax "VALUE: word" }
 { $values { "word" "a word to be created" } }

core/math/math-docs.factor

@@ -348,6 +348,7 @@ ARTICLE: "bitwise-arithmetic" "Bitwise arithmetic"
 { $subsection 2/ }
 { $subsection 2^ }
 { $subsection bit? }
+"The " { $vocab-link "math.bitwise" } " vocabulary implements additional bitwise integer operations."
 { $see-also "conditionals" } ;
 
 ARTICLE: "arithmetic" "Arithmetic"

core/parser/parser-docs.factor

@@ -42,12 +42,14 @@ $nl
 "The " { $vocab-link "qualified" } " vocabulary contains some tools for helping with shadowing." ;
 
 ARTICLE: "vocabulary-search-errors"  "Word lookup errors"
-"If the parser cannot not find a word in the current vocabulary search path, it attempts to look for the word in all loaded vocabularies. Then, one of three things happen:"
+"If the parser cannot not find a word in the current vocabulary search path, it attempts to look for the word in all loaded vocabularies."
-{ $list
+$nl
-    { "If there are no words having this name at all, an error is thrown and parsing stops." }
+"If " { $link auto-use? } " mode is off, a restartable error is thrown with a restart for each vocabulary in question, together with a restart which defers the word in the current vocabulary, as if " { $link POSTPONE: DEFER: } " was used."
-    { "If there are vocabularies which contain words with this name, a restartable error is thrown, with a restart for each vocabulary in question. The restarts add the vocabulary to the search path and continue parsing." }
+$nl
-}
+"If " { $link auto-use? } " mode is on and only one vocabulary has a word with this name, the vocabulary is added to the search path and parsing continues."
-"When writing a new vocabulary, one approach is to ignore " { $link POSTPONE: USING: } " declarations altogether, then to load the vocabulary and observe any parser notes and restarts and use this information to write the correct " { $link POSTPONE: USING: } " declaration." ;
+$nl
+"If any restarts were invoked, or if " { $link auto-use? } " is on, the parser will print the correct " { $link POSTPONE: USING: } " after parsing completes. This form can be copy and pasted back into the source file."
+{ $subsection auto-use? } ;
 
 ARTICLE: "vocabulary-search" "Vocabulary search path"
 "When the parser reads a token, it attempts to look up a word named by that token. The lookup is performed by searching each vocabulary in the search path, in order."
@@ -353,3 +355,7 @@ HELP: staging-violation
 { $description "Throws a " { $link staging-violation } " error." }
 { $error-description "Thrown by the parser if a parsing word is used in the same compilation unit as where it was defined; see " { $link "compilation-units" } "." }
 { $notes "One possible workaround is to use the " { $link POSTPONE: << } " word to execute code at parse time. However, executing words defined in the same source file at parse time is still prohibited." } ;
+
+HELP: auto-use?
+{ $var-description "If set to a true value, the behavior of the parser when encountering an unknown word name is changed. If only one loaded vocabulary has a word with this name, instead of throwing an error, the parser adds the vocabulary to the search path and prints a parse note. Off by default." }
+{ $notes "This feature is intended to help during development. To generate a " { $link POSTPONE: USING: } " form automatically, enable " { $link auto-use? } ", load the source file, and copy and paste the " { $link POSTPONE: USING: } " form printed by the parser back into the file, then disable " { $link auto-use? } ". See " { $link "vocabulary-search-errors" } "." } ;

core/parser/parser-tests.factor

@@ -428,7 +428,7 @@ must-fail-with
     "USE: this-better-not-exist" eval
 ] must-fail
 
-[ ": foo ;" eval ] [ error>> no-current-vocab? ] must-fail-with
+[ ": foo ;" eval ] [ error>> error>> no-current-vocab? ] must-fail-with
 
 [ 92 ] [ "CHAR: \\" eval ] unit-test
 [ 92 ] [ "CHAR: \\\\" eval ] unit-test
@@ -483,7 +483,7 @@ must-fail-with
 
 [ t ] [ "staging-problem-test-2" "parser.tests" lookup >boolean ] unit-test
 
-[ "DEFER: blah" eval ] [ error>> no-current-vocab? ] must-fail-with
+[ "DEFER: blah" eval ] [ error>> error>> no-current-vocab? ] must-fail-with
 
 [
     "IN: parser.tests : blah ; parsing FORGET: blah" eval
@@ -496,3 +496,5 @@ DEFER: blah
 
 [ "IN: parser.tests USE: kernel TUPLE: blah < tuple ; : blah ; TUPLE: blah < tuple ; : blah ;" eval ]
 [ error>> error>> def>> \ blah eq? ] must-fail-with
+
+[ ] [ f lexer set f file set "Hello world" note. ] unit-test

core/parser/parser.factor

@@ -25,7 +25,7 @@ t parser-notes set-global
 : note. ( str -- )
     parser-notes? [
         file get [ path>> write ":" write ] when* 
-        lexer get line>> number>string write ": " write
+        lexer get [ line>> number>string write ": " write ] when*
         "Note: " write dup print
     ] when drop ;
 
@@ -82,17 +82,20 @@ ERROR: no-word-error name ;
 
 SYMBOL: amended-use?
 
-SYMBOL: do-what-i-mean?
+SYMBOL: auto-use?
 
 : no-word-restarted ( restart-value -- word )
-    dup word?
+    dup word? [
-    [ amended-use? on dup vocabulary>> (use+) ]
+        amended-use? on
-    [ create-in ]
+        dup vocabulary>>
-    if ;
+        [ (use+) ] [
+            "Added ``" swap "'' vocabulary to search path" 3append note.
+        ] bi
+    ] [ create-in ] if ;
 
 : no-word ( name -- newword )
     dup words-named [ forward-reference? not ] filter
-    dup length 1 = do-what-i-mean? get and
+    dup length 1 = auto-use? get and
     [ nip first no-word-restarted ]
     [ <no-word-error> throw-restarts no-word-restarted ]
     if ;

unmaintained/io/load.factor

@@ -1,24 +0,0 @@
-USING: kernel ;
-
-REQUIRES: libs/calendar libs/shuffle ;
-
-PROVIDE: libs/io
-{ +files+ {
-    "io.factor"
-    "mmap.factor"
-    "shell.factor"
-    { "os-unix.factor" [ unix? ] }
-    { "os-unix-shell.factor" [ unix? ] }
-    { "mmap-os-unix.factor" [ unix? ] }
-
-    { "os-winnt.factor" [ winnt? ] }
-    { "os-winnt-shell.factor" [ winnt? ] }
-    { "mmap-os-winnt.factor" [ winnt? ] }
-
-    { "os-wince.factor" [ wince? ] }
-} }
-{ +tests+ {
-    "test/io.factor"
-    "test/mmap.factor"
-} } ;
-

unmaintained/io/os-unix-shell.factor

@@ -1,46 +0,0 @@
-USING: arrays kernel libs-io sequences prettyprint unix-internals
-calendar namespaces math ;
-USE: io
-IN: shell
-
-TUPLE: unix-shell ;
-
-T{ unix-shell } \ shell set-global
-
-TUPLE: file name mode nlink uid gid size mtime symbol ;
-
-M: unix-shell directory* ( path -- seq )
-    dup (directory) [ tuck >r "/" r> 3append stat* 2array ] map-with ;
-
-M: unix-shell make-file ( path -- file )
-    first2
-    [ stat-mode ] keep
-    [ stat-nlink ] keep
-    [ stat-uid ] keep
-    [ stat-gid ] keep
-    [ stat-size ] keep
-    [ stat-mtime timespec>timestamp >local-time ] keep
-    stat-mode mode>symbol <file> ;
-
-M: unix-shell file. ( file -- )
-    [ [ file-mode >oct write ] keep ] with-cell
-    [ bl ] with-cell
-    [ [ file-nlink unparse write ] keep ] with-cell
-    [ bl ] with-cell
-    [ [ file-uid unparse write ] keep ] with-cell
-    [ bl ] with-cell
-    [ [ file-gid unparse write ] keep ] with-cell
-    [ bl ] with-cell
-    [ [ file-size unparse write ] keep ] with-cell
-    [ bl ] with-cell
-    [ [ file-mtime file-time-string write ] keep ] with-cell
-    [ bl ] with-cell
-    [ file-name write ] with-cell ;
-
-USE: unix-internals
-M: unix-shell touch-file ( path -- )
-    dup open-append dup -1 = [
-        drop now dup set-file-times
-    ] [
-        nip [ now dup set-file-times* ] keep close
-    ] if ;

unmaintained/io/os-unix.factor

@@ -1,24 +0,0 @@
-! Copyright (C) 2007 Doug Coleman.
-! See http://factorcode.org/license.txt for BSD license.
-USING: alien arrays calendar errors io io-internals kernel
-math nonblocking-io sequences unix-internals unix-io ;
-IN: libs-io
-
-: O_APPEND  HEX: 100 ; inline
-: O_EXCL    HEX: 800 ; inline
-: SEEK_SET 0 ; inline
-: SEEK_CUR 1 ; inline
-: SEEK_END 2 ; inline
-: EEXIST 17 ; inline
-
-: mode>symbol ( mode -- ch )
-    S_IFMT bitand
-    {
-        { [ dup S_IFDIR = ] [ drop "/" ] }
-        { [ dup S_IFIFO = ] [ drop "|" ] }
-        { [ dup S_IXUSR = ] [ drop "*" ] }
-        { [ dup S_IFLNK = ] [ drop "@" ] }
-        { [ dup S_IFWHT = ] [ drop "%" ] }
-        { [ dup S_IFSOCK = ] [ drop "=" ] }
-        { [ t ] [ drop "" ] }
-    } cond ;

unmaintained/io/os-winnt-shell.factor

@@ -1,55 +0,0 @@
-USING: alien calendar io io-internals kernel libs-io math
-namespaces prettyprint sequences windows-api ;
-IN: shell
-
-TUPLE: winnt-shell ;
-
-T{ winnt-shell } \ shell set-global
-
-TUPLE: file name size mtime attributes ;
-
-: ((directory*)) ( handle -- )
-    "WIN32_FIND_DATA" <c-object> [ FindNextFile ] 2keep
-    rot zero? [ 2drop ] [ , ((directory*)) ] if ;
-
-: (directory*) ( path -- )
-    "WIN32_FIND_DATA" <c-object> [
-        FindFirstFile dup INVALID_HANDLE_VALUE = [
-            win32-error
-        ] when
-    ] keep ,
-    [ ((directory*)) ] keep FindClose win32-error=0/f ;
-
-: append-star ( path -- path )
-    dup peek CHAR: \\ = "*" "\\*" ? append ;
-
-M: winnt-shell directory* ( path -- seq )
-    normalize-pathname append-star [ (directory*) ] { } make ;
-
-: WIN32_FIND_DATA>file-size ( WIN32_FILE_ATTRIBUTE_DATA -- n )
-    [ WIN32_FIND_DATA-nFileSizeLow ] keep
-    WIN32_FIND_DATA-nFileSizeHigh 32 shift + ; 
-
-M: winnt-shell make-file ( WIN32_FIND_DATA -- file )
-    [ WIN32_FIND_DATA-cFileName alien>u16-string ] keep
-    [ WIN32_FIND_DATA>file-size ] keep
-    [
-        WIN32_FIND_DATA-ftCreationTime
-        FILETIME>timestamp >local-time
-    ] keep
-    WIN32_FIND_DATA-dwFileAttributes <file> ;
-
-M: winnt-shell file. ( file -- )
-    [ [ file-attributes >oct write ] keep ] with-cell
-    [ bl ] with-cell
-    [ [ file-size unparse write ] keep ] with-cell
-    [ bl ] with-cell
-    [ [ file-mtime file-time-string write ] keep ] with-cell
-    [ bl ] with-cell
-    [ file-name write ] with-cell ;
-
-M: winnt-shell touch-file ( path -- )
-    #! Set the file write time to 'now'
-    normalize-pathname
-    dup maybe-create-file [ drop ] [ now set-file-write-time ] if ;
-

unmaintained/io/os-winnt.factor

@@ -1,96 +0,0 @@
-USING: alien calendar errors generic io io-internals kernel
-math namespaces nonblocking-io parser quotations sequences
-shuffle windows-api words ;
-IN: libs-io
-
-: stat* ( path -- WIN32_FIND_DATA )
-    "WIN32_FIND_DATA" <c-object>
-    [
-        FindFirstFile
-        [ INVALID_HANDLE_VALUE = [ win32-error ] when ] keep
-        FindClose win32-error=0/f
-    ] keep ;
-
-: set-file-time ( path timestamp/f timestamp/f timestamp/f -- )
-    #! timestamp order: creation access write
-    >r >r >r open-existing dup r> r> r>
-    [ timestamp>FILETIME ] 3 napply
-    SetFileTime win32-error=0/f
-    close-handle ;
-
-: set-file-times ( path timestamp/f timestamp/f -- )
-    f -rot set-file-time ;
-
-: set-file-create-time ( path timestamp -- )
-    f f set-file-time ;
-
-: set-file-access-time ( path timestamp -- )
-    >r f r> f set-file-time ;
-
-: set-file-write-time ( path timestamp -- )
-    >r f f r> set-file-time ;
-
-: maybe-make-filetime ( ? -- FILETIME/f )
-    [ "FILETIME" <c-object> ] [ f ] if ;
-
-: file-time ( path ? ? ? -- FILETIME/f FILETIME/f FILETIME/f )
-    >r >r >r open-existing dup r> r> r>
-    [ maybe-make-filetime ] 3 napply
-    [ GetFileTime win32-error=0/f close-handle ] 3keep ;
-
-: file-times ( path -- FILETIME FILETIME FILETIME )
-    t t t file-time [ FILETIME>timestamp ] 3 napply ;
-
-: file-create-time ( path -- FILETIME )
-    t f f file-time 2drop FILETIME>timestamp ;
-
-: file-access-time ( path -- FILETIME )
-    f t f file-time drop nip FILETIME>timestamp ;
-
-: file-write-time ( path -- FILETIME )
-    f f t file-time 2nip FILETIME>timestamp ;
-
-: attrib ( path -- n )
-    [ stat* WIN32_FIND_DATA-dwFileAttributes ] catch
-    [ drop 0 ] when ;
-
-: (read-only?) ( mode -- ? )
-    FILE_ATTRIBUTE_READONLY bit-set? ;
-
-: read-only? ( path -- ? )
-    attrib (read-only?) ;
-
-: (hidden?) ( mode -- ? )
-    FILE_ATTRIBUTE_HIDDEN bit-set? ;
-
-: hidden? ( path -- ? )
-    attrib (hidden?) ;
-
-: (system?) ( mode -- ? )
-    FILE_ATTRIBUTE_SYSTEM bit-set? ;
-
-: system? ( path -- ? )
-    attrib (system?) ;
-
-: (directory?) ( mode -- ? )
-    FILE_ATTRIBUTE_DIRECTORY bit-set? ;
-
-: directory? ( path -- ? )
-    attrib (directory?) ;
-
-: (archive?) ( mode -- ? )
-    FILE_ATTRIBUTE_ARCHIVE bit-set? ;
-    
-: archive? ( path -- ? )
-    attrib (archive?) ;
-
-! FILE_ATTRIBUTE_DEVICE
-! FILE_ATTRIBUTE_NORMAL
-! FILE_ATTRIBUTE_TEMPORARY
-! FILE_ATTRIBUTE_SPARSE_FILE
-! FILE_ATTRIBUTE_REPARSE_POINT
-! FILE_ATTRIBUTE_COMPRESSED
-! FILE_ATTRIBUTE_OFFLINE
-! FILE_ATTRIBUTE_NOT_CONTENT_INDEXED
-! FILE_ATTRIBUTE_ENCRYPTED
-

unmaintained/io/shell.factor

@@ -1,40 +0,0 @@
-USING: calendar io io-internals kernel math namespaces
-nonblocking-io prettyprint quotations sequences ;
-IN: shell
-
-SYMBOL: shell
-HOOK: directory* shell ( path -- seq )
-HOOK: make-file shell ( bytes -- file )
-HOOK: file. shell ( file -- )
-HOOK: touch-file shell ( path -- )
-
-: (ls) ( path -- )
-    >r H{ } r> directory*
-    [
-        [ [ make-file file. ] with-row ] each
-    ] curry tabular-output ;
-
-: ls ( -- )
-    cwd (ls) ;
-
-: pwd ( -- )
-    cwd pprint nl ;
-
-: (slurp) ( quot -- )
-    >r default-buffer-size read r> over [
-        dup slip (slurp)
-    ] [
-        2drop
-    ] if ;
-
-: slurp ( stream quot -- )
-    [ (slurp) ] curry with-stream ;
-
-: cat ( path -- )
-     <file-reader> stdio get
-     duplex-stream-out <duplex-stream>
-     [ write ] slurp ;
-
-: copy-file ( path path -- )
-    >r <file-reader> r>
-    <file-writer> <duplex-stream> [ write ] slurp ;

unmaintained/io/test/io.factor

@@ -1,42 +0,0 @@
-USING: calendar errors io kernel libs-io math namespaces sequences
-shell test ;
-IN: temporary
-
-SYMBOL: file "file-appender-test.txt" \ file set
-[ \ file get delete-file ] catch drop
-[ f ] [ \ file get exists? ] unit-test
-\ file get <file-appender> [ "asdf" write ] with-stream
-[ t ] [ \ file get exists? ] unit-test
-[ 4 ] [ \ file get file-length ] unit-test
-\ file get <file-appender> [ "jkl;" write ] with-stream
-[ t ] [ \ file get exists? ] unit-test
-[ 8 ] [ \ file get file-length ] unit-test
-[ "asdfjkl;" ] [ \ file get <file-reader> contents ] unit-test
-\ file get delete-file
-[ f ] [ \ file get exists? ] unit-test
-
-SYMBOL: directory "test-directory" \ directory set
-\ directory get create-directory
-[ t ] [ \ directory get directory? ] unit-test
-\ directory get delete-directory
-[ f ] [ \ directory get directory? ] unit-test
-
-SYMBOL: time "time-test.txt" \ time set
-[ \ time get delete-file ] catch drop
-\ time get touch-file
-[ 0 ] [ \ time get file-length ] unit-test
-[ t ] [ \ time get exists? ] unit-test
-\ time get 0 unix-time>timestamp dup set-file-times
-[ t ] [ \ time get file-write-time 0 unix-time>timestamp = ] unit-test
-[ t ] [ \ time get file-access-time 0 unix-time>timestamp = ] unit-test
-\ time get touch-file
-[ t ] [ now \ time get file-write-time timestamp- 10 < ] unit-test
-\ time get delete-file
-
-SYMBOL: longname "" 255 CHAR: a pad-left \ longname set
-\ longname get touch-file
-[ t ] [ \ longname get exists? ] unit-test
-[ 0 ] [ \ longname get file-length ] unit-test
-\ longname get delete-file
-[ f ] [ \ longname get exists? ] unit-test
-

unmaintained/io/test/mmap.factor

@@ -1,21 +0,0 @@
-USING: alien errors io kernel libs-io mmap namespaces test ;
-
-IN: temporary
-SYMBOL: mmap "mmap-test.txt" \ mmap set
-
-[ \ mmap get delete-file ] catch drop
-\ mmap get [
-    "Four" write
-] with-file-writer
-
-\ mmap get [
-    >r CHAR: R r> mmap-address 3 set-alien-unsigned-1
-] with-mmap
-
-\ mmap get [
-    mmap-address 3 alien-unsigned-1 CHAR: R = [
-        "mmap test failed" throw
-    ] unless
-] with-mmap
-
-[ \ mmap get delete-file ] catch drop

vm/math.c

@@ -33,18 +33,18 @@ void primitive_float_to_fixnum(void)
 
 #define POP_FIXNUMS(x,y) \
 	F_FIXNUM y = untag_fixnum_fast(dpop()); \
-	F_FIXNUM x = untag_fixnum_fast(dpop());
+	F_FIXNUM x = untag_fixnum_fast(dpeek());
 
 void primitive_fixnum_add(void)
 {
 	POP_FIXNUMS(x,y)
-	box_signed_cell(x + y);
+	drepl(allot_integer(x + y));
 }
 
 void primitive_fixnum_subtract(void)
 {
 	POP_FIXNUMS(x,y)
-	box_signed_cell(x - y);
+	drepl(allot_integer(x - y));
 }
 
 /* Multiply two integers, and trap overflow.
@@ -54,20 +54,20 @@ void primitive_fixnum_multiply(void)
 	POP_FIXNUMS(x,y)
 
 	if(x == 0 || y == 0)
-		dpush(tag_fixnum(0));
+		drepl(tag_fixnum(0));
 	else
 	{
 		F_FIXNUM prod = x * y;
 		/* if this is not equal, we have overflow */
 		if(prod / x == y)
-			box_signed_cell(prod);
+			drepl(allot_integer(prod));
 		else
 		{
 			F_ARRAY *bx = fixnum_to_bignum(x);
 			REGISTER_BIGNUM(bx);
 			F_ARRAY *by = fixnum_to_bignum(y);
 			UNREGISTER_BIGNUM(bx);
-			dpush(tag_bignum(bignum_multiply(bx,by)));
+			drepl(tag_bignum(bignum_multiply(bx,by)));
 		}
 	}
 }
@@ -75,14 +75,27 @@ void primitive_fixnum_multiply(void)
 void primitive_fixnum_divint(void)
 {
 	POP_FIXNUMS(x,y)
-	box_signed_cell(x / y);
+	F_FIXNUM result = x / y;
+	if(result == -FIXNUM_MIN)
+		drepl(allot_integer(-FIXNUM_MIN));
+	else
+		drepl(tag_fixnum(result));
 }
 
 void primitive_fixnum_divmod(void)
 {
-	POP_FIXNUMS(x,y)
+	F_FIXNUM y = get(ds);
-	box_signed_cell(x / y);
+	F_FIXNUM x = get(ds - CELLS);
-	dpush(tag_fixnum(x % y));
+	if(y == -1 && x == tag_fixnum(FIXNUM_MIN))
+	{
+		put(ds - CELLS,allot_integer(-FIXNUM_MIN));
+		put(ds,tag_fixnum(0));
+	}
+	else
+	{
+		put(ds - CELLS,tag_fixnum(x / y));
+		put(ds,x % y);
+	}
 }
 
 /*
@@ -96,15 +109,15 @@ void primitive_fixnum_shift(void)
 
 	if(x == 0 || y == 0)
 	{
-		dpush(tag_fixnum(x));
+		drepl(tag_fixnum(x));
 		return;
 	}
 	else if(y < 0)
 	{
 		if(y <= -WORD_SIZE)
-			dpush(x < 0 ? tag_fixnum(-1) : tag_fixnum(0));
+			drepl(x < 0 ? tag_fixnum(-1) : tag_fixnum(0));
 		else
-			dpush(tag_fixnum(x >> -y));
+			drepl(tag_fixnum(x >> -y));
 		return;
 	}
 	else if(y < WORD_SIZE - TAG_BITS)
@@ -112,12 +125,12 @@ void primitive_fixnum_shift(void)
 		F_FIXNUM mask = -((F_FIXNUM)1 << (WORD_SIZE - 1 - TAG_BITS - y));
 		if((x > 0 && (x & mask) == 0) || (x & mask) == mask)
 		{
-			dpush(tag_fixnum(x << y));
+			drepl(tag_fixnum(x << y));
 			return;
 		}
 	}
 
-	dpush(tag_bignum(bignum_arithmetic_shift(
+	drepl(tag_bignum(bignum_arithmetic_shift(
 		fixnum_to_bignum(x),y)));
 }