! 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 ;
: 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 ( -- )
>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
: 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
! 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
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 ;
+
+: find-scroller [ scroller? ] find-parent ;
-: fix-scroll ( origin viewport -- origin )
- dup rect-dim swap viewport-dim v- vmax { 0 0 0 } vmin ;
+: 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 ;
[ [ 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-sliders ( scroller -- )
- dup
- dup scroller-x update-slider
- dup scroller-y update-slider ;
+: update-slider ( scroller value slider -- )
+ >r >r scroller-viewport dup rect-dim swap viewport-dim
+ r> r> set-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 ;
: 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 ;
: 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.
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* ;