UI fixes

library/compiler/compiler.factor

@@ -1,7 +1,7 @@
 ! Copyright (C) 2004, 2005 Slava Pestov.
 IN: compiler
-USING: compiler-backend compiler-frontend errors inference
-io kernel lists math namespaces prettyprint words ;
+USING: compiler-backend compiler-frontend errors inference io
+kernel lists math namespaces prettyprint sequences words ;
 
 : supported-cpu? ( -- ? )
     cpu "unknown" = not ;
@@ -25,7 +25,7 @@ M: compound (compile) ( word -- )
 : precompile ( word -- )
     #! Print linear IR of word.
     [
-        word-def dataflow optimize linearize simplify sequence.
+        word-def dataflow optimize linearize simplify [ . ] each
     ] with-scope ;
 
 : compile-postponed ( -- )

library/compiler/intrinsics.factor

@@ -155,8 +155,8 @@ sequences vectors words ;
     >r load-inputs 2unseq swap dup r> execute ,
     0 0 %replace-d , ; inline
 
-: literal-fixnum? ( value -- ? )
-    dup literal? [ literal-value fixnum? ] [ drop f ] ifte ;
+: literal-immediate? ( value -- ? )
+    dup literal? [ literal-value immediate? ] [ drop f ] ifte ;
 
 : binary-op-imm ( imm op -- )
     1 %dec-d , in-1
@@ -166,7 +166,7 @@ sequences vectors words ;
 : binary-op ( node op -- )
     #! out is a vreg where the vop stores the result.
     fixnum-imm? [
-        >r dup node-peek dup literal-fixnum? [
+        >r dup node-peek dup literal-immediate? [
             literal-value r> binary-op-imm drop
         ] [
             drop r> binary-op-reg

library/tools/debugger.factor

@@ -137,7 +137,3 @@ M: object error. ( error -- ) . ;
         save-error rethrow
     ] 5 setenv
     kernel-error 12 setenv ;
-
-! So that stage 2 boot gives a useful error message if something
-! fails after this file is loaded.
-init-error-handler

library/tools/gensym.factor

@@ -1,17 +1,14 @@
 ! Copyright (C) 2004, 2005 Slava Pestov.
 ! See http://factor.sf.net/license.txt for BSD license.
-IN: words USING: kernel math namespaces parser sequences strings ;
-
-SYMBOL: gensym-count
-
-: (gensym) ( -- name )
-    "G:" global [
-        gensym-count [ 1 + dup ] change
-    ] bind number>string append ;
+IN: words
+USING: hashtables kernel math namespaces parser sequences
+strings ;
 
 : gensym ( -- word )
     #! Return a word that is distinct from every other word, and
     #! is not contained in any vocabulary.
-    (gensym) f <word> ;
+    "G:"
+    global [ \ gensym dup inc get ] bind
+    number>string append f <word> ;
 
-global [ 0 gensym-count set ] bind
+0 \ gensym global set-hash

library/ui/panes.factor

@@ -38,7 +38,7 @@ SYMBOL: structured-input
     [
         2 nesting-limit set
         5 length-limit set
-        <block pprint-elements block> t newline
+        <block pprint-elements block> newline
     ] with-pprint ;
 
 : pane-call ( quot pane -- )

library/ui/scrolling.factor

@@ -5,26 +5,29 @@ USING: generic kernel lists math matrices namespaces sequences
 threads vectors styles ;
 
 ! A viewport can be scrolled.
-TUPLE: viewport origin ;
+TUPLE: viewport ;
 
 ! A scroller combines a viewport with two x and y sliders.
 TUPLE: scroller viewport x y bottom? ;
 
-: viewport-dim gadget-child pref-dim ;
+: scroller-origin ( scroller -- { x y 0 } )
+    dup scroller-x slider-value
+    swap scroller-y slider-value
+    0 3vector ;
 
-: fix-scroll ( origin viewport -- origin )
-    dup rect-dim swap viewport-dim v- vmax { 0 0 0 } vmin ;
+: find-scroller [ scroller? ] find-parent ;
+
+: viewport-dim gadget-child pref-dim ;
 
 C: viewport ( content -- viewport )
     <gadget> over set-delegate
     t over set-gadget-root?
-    [ add-gadget ] keep
-    { 0 0 0 } over set-viewport-origin ;
+    [ add-gadget ] keep ;
 
 M: viewport pref-dim gadget-child pref-dim ;
 
 M: viewport layout* ( viewport -- )
-    dup viewport-origin over fix-scroll
+    dup find-scroller scroller-origin vneg
     swap gadget-child dup prefer
     set-rect-loc ;
 
@@ -38,23 +41,14 @@ M: viewport focusable-child* ( viewport -- gadget )
     [ [ slider-vector v. ] keep set-slider-page ] keep
     fix-slider ;
 
-: update-slider ( scroller slider -- )
-    >r dup rect-dim
-    over viewport-dim
-    rot scroller-viewport viewport-origin vneg
-    r> set-slider ;
+: update-slider ( scroller value slider -- )
+    >r >r scroller-viewport dup rect-dim swap viewport-dim
+    r> r> set-slider ;
 
-: update-sliders ( scroller -- )
-    dup
-    dup scroller-x update-slider
-    dup scroller-y update-slider ;
-
-: scroll ( origin scroller -- )
-    [
-        scroller-viewport [ fix-scroll ] keep
-        [ set-viewport-origin ] keep
-        relayout
-    ] keep update-sliders ;
+: scroll ( scroller value -- )
+    2dup
+    over scroller-x update-slider
+    over scroller-y update-slider ;
 
 : add-viewport 2dup set-scroller-viewport add-center ;
 
@@ -63,7 +57,7 @@ M: viewport focusable-child* ( viewport -- gadget )
 : add-y-slider 2dup set-scroller-y add-right ;
 
 : scroll>bottom ( gadget -- )
-    [ scroller? ] find-parent
+    find-scroller
     [ t over set-scroller-bottom? relayout ] when* ;
 
 : scroll-up-line scroller-y -1 swap slide-by-line ;
@@ -72,7 +66,8 @@ M: viewport focusable-child* ( viewport -- gadget )
 
 : scroller-actions ( scroller -- )
     dup [ scroll-up-line ] [ button-down 4 ] set-action
-    [ scroll-down-line ] [ button-down 5 ] set-action ;
+    dup [ scroll-down-line ] [ button-down 5 ] set-action
+    [ scroller-viewport relayout ] [ slider-changed ] set-action ;
 
 C: scroller ( gadget -- scroller )
     #! Wrap a scrolling pane around the gadget.
@@ -88,5 +83,5 @@ M: scroller focusable-child* ( scroller -- viewport )
 M: scroller layout* ( scroller -- )
     dup scroller-bottom? [
         f over set-scroller-bottom?
-        dup scroller-viewport viewport-dim vneg over scroll
+        dup dup scroller-viewport viewport-dim scroll
     ] when delegate layout* ;

library/ui/sliders.factor

@@ -38,8 +38,11 @@ TUPLE: slider vector elevator thumb value max page ;
     dup slider-max over slider-page max over set-slider-max
     dup slider-value over fix-slider-value swap set-slider-value ;
 
+SYMBOL: slider-changed
+
 : set-slider-value* ( value slider -- )
-    [ set-slider-value ] keep fix-slider ;
+    [ set-slider-value ] keep [ fix-slider ] keep
+    [ slider-changed ] swap handle-gesture drop ;
 
 : elevator-drag ( elevator -- )
     dup drag-loc >r find-slider r> over slider-vector v.