fix bootstrap failure

CHANGES.html

@@ -26,6 +26,7 @@
 <li>Faster <code>map</code>, <code>2each</code> and <code>2map</code>.</li>
 <li>Arrays are now better supported and should be used instead of vectors where resizing is not desired.</li>
 <li>Some new sequence words that do not bounds check: <code>nth-unsafe</code> and <code>set-nth-unsafe</code>. These should only be used in special circumstances, such as inner loops (<code>each</code>, <code>map</code> and so on use them).</li>
+<li>New <code>replace-slice ( new from to seq -- seq )</code> word replaces a slice of a sequence with another sequence.</li>
 <li>Hashtables did not obey the rule that equal objects must have equal hashcodes, so using hashtables as hashtable keys did not work.</li>
 </li>
 

TODO.FACTOR.txt

@@ -2,7 +2,6 @@
 - compile interruption checks
 - check that set-datastack and set-callstack compile correctly in the
   face of optimization
-- slice: if sequence or seq start is changed, abstraction violation
 - code walker & exceptions
 - floating point intrinsics
 - load all sources in stage1
@@ -25,9 +24,13 @@
 - get outliner working with lots of lines of output
 - listener continuations
 - test copy-into of a sequence into itself
+- vertical alignment of arrows -vs- outliner gadget
+- slice: if sequence or seq start is changed, abstraction violation
+- find* should test for index below 0
 
 + ui:
 
+- multi-part gradients
 - tabular output
 - completion
 - debugger should use outlining
@@ -50,6 +53,7 @@
 
 + misc
 
+- signal handler should not lose stack pointers
 - sigsegv handling on OS X:
 
   http://developer.apple.com/technotes/tn2004/tn2123.html#SECLIMITATIONS

library/bootstrap/boot-stage1.factor

@@ -14,7 +14,6 @@ sequences io vectors words ;
     [
         [ hashtable? ] instances
         [ dup hash-size 1 max swap set-bucket-count ] each
-
         boot
     ] %
 

library/collections/growable.factor

@@ -34,12 +34,11 @@ TUPLE: bounds-error index seq ;
 
 : bounds-error <bounds-error> throw ;
 
-: growable-check ( n seq -- fx seq )
-    over 0 < [ 2dup bounds-error ] when ; inline
+: growable-check ( n seq -- n seq )
+    over 0 < [ bounds-error ] when ; inline
 
-: bounds-check ( n seq -- fx seq )
-    growable-check 2dup length >= [ 2dup bounds-error ] when ;
-    inline
+: bounds-check ( n seq -- n seq )
+    2dup bounds-check? [ bounds-error ] unless ; inline
 
 : grow-length ( len seq -- )
     growable-check 2dup capacity > [ 2dup expand ] when set-fill ;

library/collections/sequence-combinators.factor

@@ -83,16 +83,17 @@ M: object map ( seq quot -- seq )
     [ 2dup min-length [ (2map) ] collect ] keep like
     >r 3drop r> ; inline
 
+: if-bounds ( i seq quot -- )
+    >r pick pick bounds-check? r> [ 3drop -1 f ] if ; inline
+
 : find* ( i seq quot -- i elt )
-    pick pick length >= [
-        3drop -1 f
-    ] [
+    [
         3dup >r >r >r >r nth-unsafe r> call [
             r> dup r> nth-unsafe r> drop
         ] [
             r> 1+ r> r> find*
         ] if
-    ] if ; inline
+    ] if-bounds ; inline
 
 : find-with* ( obj i seq quot -- i elt | quot: elt -- ? )
     -rot [ with rot ] find* 2swap 2drop ; inline
@@ -100,6 +101,21 @@ M: object map ( seq quot -- seq )
 M: object find ( seq quot -- i elt )
     0 -rot find* ;
 
+: find-last* ( i seq quot -- i elt )
+    [
+        3dup >r >r >r >r nth-unsafe r> call [
+            r> dup r> nth-unsafe r> drop
+        ] [
+            r> 1- r> r> find-last*
+        ] if
+    ] if-bounds ; inline
+
+: find-last-with* ( obj i seq quot -- i elt | quot: elt -- ? )
+    -rot [ with rot ] find-last* 2swap 2drop ; inline
+
+: find-last ( seq quot -- i elt )
+    >r [ length 1- ] keep r> find-last* ; inline
+
 : contains? ( seq quot -- ? )
     find drop -1 > ; inline
 

library/collections/sequences.factor

@@ -46,6 +46,9 @@ GENERIC: resize ( n seq -- seq )
 : first3 ( { x y z } -- x y z )
     dup first over second rot third ; inline
 
+: bounds-check? ( n seq -- ? )
+    over 0 >= [ length < ] [ 2drop f ] if ;
+
 IN: sequences-internals
 
 ! Unsafe sequence protocol for inner loops

library/collections/slicing.factor

@@ -44,6 +44,12 @@ M: object tail ( index seq -- seq ) [ tail-slice ] keep like ;
 : ?tail ( seq end -- seq ? )
     2dup tail? [ length swap head* t ] [ drop f ] if ; flushable
 
+: replace-slice ( new from to seq -- seq )
+    #! Replace the range between 'from' and 'to' in 'seq' with
+    #! 'new'. The new sequence has the same type as 'seq'.
+    tuck >r >r head-slice r> r> tail-slice swapd append3 ;
+    flushable
+
 : (group) ( n seq -- )
     2dup length >= [
         dup like , drop
@@ -90,6 +96,8 @@ M: object tail ( index seq -- seq ) [ tail-slice ] keep like ;
 
 : split ( seq subseq -- seq ) [ (split) ] [ ] make ; flushable
 
-: (cut) ( n seq -- ) [ head ] 2keep tail-slice ; flushable
+: (cut) ( n seq -- before after )
+    [ head ] 2keep tail-slice ; flushable
 
-: cut ( n seq -- ) [ (cut) ] keep like ; flushable
+: cut ( n seq -- before after )
+    [ (cut) ] keep like ; flushable

library/compiler/intrinsics.factor

@@ -126,8 +126,7 @@ namespaces sequences words ;
     { fixnum-bitor  %fixnum-bitor  }
     { fixnum-bitxor %fixnum-bitxor }
 } [
-    first2 [ literalize , \ binary-op , ] [ ] make
-    "intrinsic" set-word-prop
+    first2 [ binary-op ] curry "intrinsic" set-word-prop
 ] each
 
 : binary-jump-reg ( node label op -- )
@@ -146,8 +145,7 @@ namespaces sequences words ;
     { fixnum>  %jump-fixnum>  }
     { eq?      %jump-eq?      }
 } [
-    first2 [ literalize , \ binary-jump , ] [ ] make
-    "if-intrinsic" set-word-prop
+    first2 [ binary-jump ] curry "if-intrinsic" set-word-prop
 ] each
 
 \ fixnum/i [

library/help/tutorial.factor

@@ -23,13 +23,10 @@ M: string tutorial-line
     }@ cond ;
 
 : example-theme
-    dup button-theme
-    "Monospaced" font set-paint-prop ;
+    dup solid-interior "Monospaced" font set-paint-prop ;
 
 M: general-list tutorial-line
-    car
-    <label> [ label-text pane get pane-input set-editor-text ]
-    <roll-button> dup example-theme ;
+    car <input-button> dup example-theme ;
 
 : <page> ( list -- gadget )
     [ tutorial-line ] map

library/math/math.factor

@@ -42,7 +42,7 @@ GENERIC: ceiling  ( n -- n ) foldable
 : between? ( x min max -- ? )
     #! Push if min <= x <= max. Handles case where min > max
     #! by swapping them.
-    2dup > [ swap ] when  >r dupd max r> min = ; foldable
+    pick rot >= [ <= ] [ 2drop f ] if ; inline
 
 : sq dup * ; inline
 

library/test/collections/sequences.factor

@@ -168,3 +168,9 @@ unit-test
 [ 5 ] [ 1 >bignum { 1 5 7 } nth-unsafe ] unit-test
 [ 5 ] [ 1 >bignum @{ 1 5 7 }@ nth-unsafe ] unit-test
 [ 5 ] [ 1 >bignum "\u0001\u0005\u0007" nth-unsafe ] unit-test
+
+[ "before&after" ] [ "&" 6 11 "before and after" replace-slice ] unit-test
+
+[ 3 "a" ] [ { "a" "b" "c" "a" "d" } [ "a" = ] find-last ] unit-test
+
+[ -1 f ] [ -1 { 1 2 3 } [ 1 = ] find* ] unit-test

library/test/gadgets/line-editor.factor

@@ -3,64 +3,56 @@ USING: kernel line-editor namespaces sequences strings test ;
 
 <line-editor> "editor" set
 
+[ 14 ] [ 4 5 5 10 (point-update) ] unit-test
+
+[ 10 ] [ 4 15 15 10 (point-update) ] unit-test
+
+[ 6 ] [ 0 5 9 10 (point-update) ] unit-test
+
+[ 5 ] [ 0 5 13 10 (point-update) ] unit-test
+
+[ 10 ] [ 0 18 23 10 (point-update) ] unit-test
+
+[ 0 ] [ 0 0 10 10 (point-update) ] unit-test
+
 [ "Hello world" ] [
     "Hello world" 0 "editor" get [ line-insert ] bind
     "editor" get [ line-text get ] bind
 ] unit-test
 
 [ t ] [
-    "editor" get [ caret get ] bind
+    "editor" get [ caret-pos ] bind
     "Hello world" length =
 ] unit-test
 
 [ "Hello, crazy world" ] [
-    "editor" get [ 0 caret set ] bind
+    "editor" get [ 0 set-caret-pos ] bind
     ", crazy" 5 "editor" get [ line-insert ] bind
     "editor" get [ line-text get ] bind
 ] unit-test
 
-[ 0 ] [ "editor" get [ caret get ] bind ] unit-test
+[ 0 ] [ "editor" get [ caret-pos ] bind ] unit-test
 
 [ "Hello, crazy world" ] [
-    "editor" get [ 5 caret set "Hello world" line-text set ] bind
+    "editor" get [ 5 set-caret-pos "Hello world" line-text set ] bind
     ", crazy" 5 "editor" get [ line-insert ] bind
     "editor" get [ line-text get ] bind
 ] unit-test
 
 [ "Hello, crazy" ] [
-    "editor" get [ caret get line-text get head ] bind
-] unit-test
-
-[ 0 ]
-[
-    [
-        0 caret set
-        3 2 caret-remove
-        caret get
-    ] with-scope
-] unit-test
-
-[ 3 ]
-[
-    [
-        4 caret set
-        3 6 caret-remove
-        caret get
-    ] with-scope
-] unit-test
-
-[ 5 ]
-[
-    [
-        8 caret set
-        3 3 caret-remove
-        caret get
-    ] with-scope
+    "editor" get [ caret-pos line-text get head ] bind
 ] unit-test
 
 [ "Hellorld" ]
 [
-    "editor" get [ 0 caret set "Hello world" line-text set ] bind
-    4 3 "editor" get [ line-remove ] bind
+    "editor" get [ 0 set-caret-pos "Hello world" line-text set ] bind
+    4 7 "editor" get [ line-remove ] bind
     "editor" get [ line-text get ] bind
 ] unit-test
+
+[ 0 "" ]
+[
+    "editor" get [ "hello world" set-line-text ] bind
+    "editor" get [ 0 line-length line-remove ] bind
+    "editor" get [ caret-pos line-text get ] bind
+] unit-test

library/tools/debugger.factor

@@ -71,7 +71,9 @@ M: kernel-error error. ( error -- )
 M: no-method error. ( error -- )
     "No suitable method." print
     "Generic word: " write dup no-method-generic .
-    "Object: " write no-method-object short. ;
+    "Methods: " write dup no-method-generic order .
+    "Object: " write dup no-method-object short.
+    "Object class: " write no-method-object class short. ;
 
 M: no-math-method error. ( error -- )
     "No suitable arithmetic method." print

library/tools/memory.factor

@@ -51,10 +51,10 @@ sequences strings unparser vectors words ;
     [ begin-scan [ (each-object) ] keep ]
     [ end-scan ] cleanup drop ; inline
 
-: instances ( quot -- list )
+: instances ( quot -- seq )
     #! Return a list of all object that return true when the
     #! quotation is applied to them.
-    [ [ [ swap call ] 2keep rot ?, ] each-object drop ] [ ] make ;
+    [ [ [ swap call ] 2keep rot ?, ] each-object drop ] { } make ;
     inline
 
 G: each-slot ( obj quot -- )

library/ui/editors.factor

@@ -62,7 +62,7 @@ TUPLE: editor line caret ;
 : set-caret-x ( x editor -- )
     #! Move the caret to a clicked location.
     dup [
-        gadget-font line-text get x>offset caret set
+        gadget-font line-text get x>offset set-caret-pos
     ] with-editor ;
 
 : click-editor ( editor -- )
@@ -73,13 +73,19 @@ TUPLE: editor line caret ;
         [[ [ gain-focus ] [ focus-editor ] ]]
         [[ [ lose-focus ] [ unfocus-editor ] ]]
         [[ [ button-down 1 ] [ click-editor ] ]]
-        [[ [ "BACKSPACE" ] [ [ delete-prev ] with-editor ] ]]
-        [[ [ "DELETE" ] [ [ delete-next ] with-editor ] ]]
-        [[ [ "LEFT" ] [ [ left ] with-editor ] ]]
-        [[ [ "RIGHT" ] [ [ right ] with-editor ] ]]
+        [[ [ "BACKSPACE" ] [ [ << char-elt >> delete-prev-elt ] with-editor ] ]]
+        [[ [ "DELETE" ] [ [ << char-elt >> delete-next-elt ] with-editor ] ]]
+        [[ [ "CTRL" "BACKSPACE" ] [ [ << word-elt >> delete-prev-elt ] with-editor ] ]]
+        [[ [ "CTRL" "DELETE" ] [ [ << word-elt >> delete-next-elt ] with-editor ] ]]
+        [[ [ "ALT" "BACKSPACE" ] [ [ << document-elt >> delete-prev-elt ] with-editor ] ]]
+        [[ [ "ALT" "DELETE" ] [ [ << document-elt >> delete-next-elt ] with-editor ] ]]
+        [[ [ "LEFT" ] [ [ << char-elt >> prev-elt ] with-editor ] ]]
+        [[ [ "RIGHT" ] [ [ << char-elt >> next-elt ] with-editor ] ]]
+        [[ [ "CTRL" "LEFT" ] [ [ << word-elt >> prev-elt ] with-editor ] ]]
+        [[ [ "CTRL" "RIGHT" ] [ [ << word-elt >> next-elt ] with-editor ] ]]
+        [[ [ "HOME" ] [ [ << document-elt >> prev-elt ] with-editor ] ]]
+        [[ [ "END" ] [ [ << document-elt >> next-elt ] with-editor ] ]]
         [[ [ "CTRL" "k" ] [ [ line-clear ] with-editor ] ]]
-        [[ [ "HOME" ] [ [ home ] with-editor ] ]]
-        [[ [ "END" ] [ [ end ] with-editor ] ]]
     ] swap add-actions ;
 
 C: editor ( text -- )
@@ -94,7 +100,7 @@ C: editor ( text -- )
     head >r gadget-font r> size-string drop ;
 
 : caret-loc ( editor -- x y )
-    dup editor-line [ caret get line-text get ] bind offset>x
+    dup editor-line [ caret-pos line-text get ] bind offset>x
     0 0 3array ;
 
 : caret-dim ( editor -- w h )

library/ui/line-editor.factor

@@ -3,13 +3,12 @@
 IN: line-editor
 USING: kernel math namespaces sequences strings vectors ;
 
-SYMBOL: line-text
-SYMBOL: caret
-
-! History stuff
 SYMBOL: history
 SYMBOL: history-index
 
+SYMBOL: line-text
+SYMBOL: caret
+
 : history-length ( -- n )
     #! Call this in the line editor scope.
     history get length ;
@@ -19,23 +18,109 @@ SYMBOL: history-index
     #! resets the history index.
     history-length history-index set ;
 
-: commit-history ( -- )
-    #! Call this in the line editor scope. Adds the currently
-    #! entered text to the history.
-    line-text get dup empty? [
-        drop
+! A point is a mutable object holding an index in the line
+! editor. Changing text in the points registered with the
+! line editor will move the point if it is after the changed
+! text.
+TUPLE: point index ;
+
+: (point-update) ( len from to index -- index )
+    pick over > [
+        >r 3drop r>
     ] [
-        history get push reset-history
+        3dup -rot between? [ 2drop ] [ >r - + r> ] if +
     ] if ;
 
+: point-update ( len from to point -- )
+    #! Call this in the line editor scope.
+    [ point-index (point-update) ] keep set-point-index ;
+
+: line-replace ( str from to -- )
+    #! Call this in the line editor scope.
+    reset-history
+    pick length pick pick caret get point-update
+    line-text [ replace-slice ] change ;
+
+: line-remove ( from to -- )
+    #! Call this in the line editor scope.
+    "" -rot line-replace ;
+
+: line-length line-text get length ;
+
 : set-line-text ( text -- )
     #! Call this in the line editor scope.
-    dup line-text set length caret set ;
+    0 line-length line-replace ;
+
+: line-clear ( -- )
+    #! Call this in the line editor scope.
+    "" set-line-text ;
+
+! An element is a unit of text; character, word, etc.
+GENERIC: next-elt* ( i str element -- i )
+GENERIC: prev-elt* ( i str element -- i )
+
+TUPLE: char-elt ;
+
+M: char-elt next-elt* 2drop 1+ ;
+M: char-elt prev-elt* 2drop 1- ;
+
+TUPLE: word-elt ;
+
+M: word-elt next-elt* ( i str element -- i )
+    drop dup length >r [ blank? ] find* drop dup -1 =
+    [ drop r> ] [ r> drop 1+ ] if ;
+
+M: word-elt prev-elt* ( i str element -- i )
+    drop >r 1- r> [ blank? ] find-last* drop 1+ ;
+
+TUPLE: document-elt ;
+
+M: document-elt next-elt* rot 2drop length ;
+M: document-elt prev-elt* 3drop 0 ;
+
+: caret-pos caret get point-index ;
+
+: set-caret-pos caret get set-point-index ;
+
+: next-elt@ ( element -- from to )
+    >r caret-pos dup line-text get r> next-elt* line-length min ;
+
+: next-elt ( element -- )
+    next-elt@ set-caret-pos drop ;
+
+: prev-elt@ ( element -- from to )
+    >r caret-pos dup line-text get r> prev-elt* 0 max swap ;
+
+: prev-elt ( element -- )
+    prev-elt@ drop set-caret-pos ;
+
+: delete-next-elt ( element -- )
+    next-elt@ line-remove ;
+
+: delete-prev-elt ( element -- )
+    prev-elt@ line-remove ;
+
+: insert-char ( ch -- )
+    #! Call this in the line editor scope.
+    ch>string caret-pos dup line-replace ;
+
+: commit-history ( -- )
+    #! Call this in the line editor scope. Adds the currently
+    #! entered text to the history.
+    line-text get dup empty?
+    [ drop ] [ history get push reset-history ] if ;
+
+: <line-editor> ( -- editor )
+    [
+        "" line-text set
+        0 <point> caret set
+        { } clone history set
+        0 history-index set
+    ] make-hash ;
 
 : goto-history ( n -- )
     #! Call this in the line editor scope.
-    dup history-index set
-    history get nth set-line-text ;
+    dup history get nth set-line-text history-index set ;
 
 : history-prev ( -- )
     #! Call this in the line editor scope.
@@ -43,89 +128,10 @@ SYMBOL: history-index
         drop
     ] [
         dup history-length = [ commit-history ] when
-        1 - goto-history
+        1- goto-history
     ] if ;
 
 : history-next ( -- )
     #! Call this in the line editor scope.
-    history-index get dup 1+ history-length >= [
-        drop
-    ] [
-        1+ goto-history
-    ] if ;
-
-: line-clear ( -- )
-    #! Call this in the line editor scope.
-    0 caret set
-    "" line-text set ;
-
-: <line-editor> ( -- editor )
-    [
-        line-clear
-        { } clone history set
-        0 history-index set
-    ] make-hash ;
-
-: caret-insert ( str offset -- )
-    #! Call this in the line editor scope.
-    caret get <= [
-        length caret [ + ] change
-    ] [
-        drop
-    ] if ;
-
-: line-insert ( str offset -- )
-    #! Call this in the line editor scope.
-    reset-history
-    2dup caret-insert
-    line-text get [ head ] 2keep tail
-    swapd append3 line-text set ;
-
-: insert-char ( ch -- )
-    #! Call this in the line editor scope.
-    ch>string caret get line-insert ;
-
-: caret-remove ( offset length -- )
-    #! Call this in the line editor scope.
-    2dup + caret get <= [
-        nip caret [ swap - ] change
-    ] [
-        caret get pick pick dupd + between? [
-            drop caret set
-        ] [
-            2drop
-        ] if
-    ] if ;
-
-: line-remove ( offset length -- )
-    #! Call this in the line editor scope.
-    reset-history
-    2dup caret-remove
-    dupd + line-text get tail
-    >r line-text get head r> append
-    line-text set ;
-
-: delete-prev ( -- )
-    #! Call this in the line editor scope.
-    caret get dup 0 = [ drop ] [ 1- 1 line-remove ] if ;
-
-: delete-next ( -- )
-    #! Call this in the line editor scope.
-    caret get dup line-text get length =
-    [ drop ] [ 1 line-remove ] if ;
-
-: left ( -- )
-    #! Call this in the line editor scope.
-    caret [ 1- 0 max ] change ;
-
-: right ( -- )
-    #! Call this in the line editor scope.
-    caret [ 1+ line-text get length min ] change ;
-
-: home ( -- )
-    #! Call this in the line editor scope.
-    0 caret set ;
-
-: end ( -- )
-    #! Call this in the line editor scope.
-    line-text get length caret set ;
+    history-index get dup 1+ history-length >=
+    [ drop ] [ 1+ goto-history ] if ;

library/ui/menus.factor

@@ -19,15 +19,17 @@ namespaces sequences ;
     #! Adjust loc to fit inside max.
     swap |v-| vmin ;
 
-: menu-loc ( menu -- loc )
-    hand rect-loc swap rect-dim world get rect-dim fit-bounds ;
+: menu-loc ( menu loc -- loc )
+    swap rect-dim world get rect-dim fit-bounds ;
 
-: show-menu ( menu -- )
-    dup show-glass
-    dup menu-loc swap set-rect-loc
+: show-menu ( menu loc -- )
+    >r dup dup show-glass r>
+    menu-loc swap set-rect-loc
     world get world-glass dup menu-actions
     hand set-hand-clicked ;
 
+: show-hand-menu ( menu -- ) hand rect-loc show-menu ;
+
 : menu-items ( assoc -- pile )
     #! Given an association list mapping labels to quotations.
     #! Prepend a call to hide-menu to each quotation.
@@ -39,7 +41,7 @@ namespaces sequences ;
     menu-items line-border dup menu-theme ;
 
 : <menu-button> ( gadget quot -- button )
-    [ show-menu ] append <roll-button>
+    [ show-hand-menu ] append <roll-button>
     dup [ button-clicked ] [ button-down 1 ] set-action
     dup [ button-update ] [ button-up 1 ] set-action ;
 

library/ui/panes.factor

@@ -2,6 +2,8 @@
 ! See http://factor.sf.net/license.txt for BSD license.
 IN: gadgets-presentations
 DEFER: <presentation>
+DEFER: <input-button>
+DEFER: gadget.
 
 IN: gadgets-panes
 USING: arrays gadgets gadgets-editors gadgets-labels
@@ -52,9 +54,13 @@ SYMBOL: structured-input
     #! Add current line to the history, and clear the editor.
     [ commit-history line-text get line-clear ] with-editor ;
 
+: replace-input ( string pane -- )
+    pane-input set-editor-text ;
+
 : print-input ( string pane -- )
-    [ [[ font-style bold ]] ] swap
-    [ stream-format ] keep stream-terpri ;
+    [
+        <input-button> dup bold font-style set-paint-prop gadget.
+    ] with-stream* ;
 
 : pane-return ( pane -- )
     dup pane-input dup [

library/ui/presentations.factor

@@ -4,7 +4,7 @@ IN: gadgets-presentations
 USING: arrays compiler gadgets gadgets-buttons gadgets-labels
 gadgets-menus gadgets-outliner gadgets-panes generic hashtables
 inference inspector io jedit kernel lists memory namespaces
-parser prettyprint sequences styles words ;
+parser prettyprint sequences strings styles words ;
 
 SYMBOL: commands
 
@@ -27,6 +27,10 @@ SYMBOL: commands
 : <command-button> ( gadget object -- button )
     [ nip command-menu ] curry <menu-button> ;
 
+: <input-button> ( string -- button )
+    dup <label> swap [ nip pane get replace-input ] curry
+    <roll-button> ;
+
 : init-commands ( gadget -- gadget )
     dup presented paint-prop [ <command-button> ] when* ;
 

library/ui/sliders.factor

@@ -27,7 +27,7 @@ TUPLE: slider vector elevator thumb value max page ;
 : screen>slider slider-scale / ;
 
 : fix-slider-value ( n slider -- n )
-    dup slider-max swap slider-page - min 0 max ;
+    dup slider-max swap slider-page - min 0 max >fixnum ;
 
 : fix-slider ( slider -- )
     #! Call after changing slots, to relayout and do invariants:

library/ui/ui.factor

@@ -10,11 +10,8 @@ sdl sequences shells styles threads words ;
     global [
         <world> world set
         @{ 800 600 0 }@ world get set-gadget-dim
-        
-        world get dup world-theme
-
+        world get world-theme
         <gadget> dup solid-interior add-layer
-
         listener-application
     ] bind ;
 

library/ui/world.factor

@@ -33,8 +33,7 @@ C: world ( -- world )
     [ pop-invalid [ layout ] each layout-world ] when ;
 
 : hide-glass ( -- )
-    world get world-glass unparent f
-    world get set-world-glass ;
+    f world get dup world-glass unparent set-world-glass ;
 
 : show-glass ( gadget -- )
     hide-glass