From b5eaee6081acedef4981c405b518f334f0d1eb89 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 29 Aug 2005 22:18:10 +0000 Subject: [PATCH] UI fixes --- library/compiler/compiler.factor | 6 ++-- library/compiler/intrinsics.factor | 6 ++-- library/tools/debugger.factor | 4 --- library/tools/gensym.factor | 17 +++++------ library/ui/panes.factor | 2 +- library/ui/scrolling.factor | 47 +++++++++++++----------------- library/ui/sliders.factor | 5 +++- 7 files changed, 39 insertions(+), 48 deletions(-) diff --git a/library/compiler/compiler.factor b/library/compiler/compiler.factor index c0e2640944..cc9b882818 100644 --- a/library/compiler/compiler.factor +++ b/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 ( -- ) diff --git a/library/compiler/intrinsics.factor b/library/compiler/intrinsics.factor index ffd6aa0bec..3dfe44a471 100644 --- a/library/compiler/intrinsics.factor +++ b/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 diff --git a/library/tools/debugger.factor b/library/tools/debugger.factor index 57a0bc547c..dc4552a6de 100644 --- a/library/tools/debugger.factor +++ b/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 diff --git a/library/tools/gensym.factor b/library/tools/gensym.factor index fb95bbe375..ce7cdb86f8 100644 --- a/library/tools/gensym.factor +++ b/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 ; + "G:" + global [ \ gensym dup inc get ] bind + number>string append f ; -global [ 0 gensym-count set ] bind +0 \ gensym global set-hash diff --git a/library/ui/panes.factor b/library/ui/panes.factor index 2cc4cd05a1..65a5098362 100644 --- a/library/ui/panes.factor +++ b/library/ui/panes.factor @@ -38,7 +38,7 @@ SYMBOL: structured-input [ 2 nesting-limit set 5 length-limit set - t newline + newline ] with-pprint ; : pane-call ( quot pane -- ) diff --git a/library/ui/scrolling.factor b/library/ui/scrolling.factor index 280a9971f4..40244d86df 100644 --- a/library/ui/scrolling.factor +++ b/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 ) 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* ; diff --git a/library/ui/sliders.factor b/library/ui/sliders.factor index 17fc281fb8..46903c8503 100644 --- a/library/ui/sliders.factor +++ b/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.