From be7dec33ae1c58aa6948180e453a1792539e7f95 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 29 Jun 2005 03:50:23 +0000 Subject: [PATCH] more UI cleanups, fix jedit-stream bug --- CHANGES.txt | 15 ++++++++++++--- library/alien/aliens.factor | 2 -- library/bootstrap/primitives.factor | 1 + library/test/gadgets.factor | 2 +- library/tools/jedit-wire.factor | 2 +- library/ui/borders.factor | 6 +++--- library/ui/editors.factor | 6 +++--- library/ui/fonts.factor | 2 +- library/ui/frames.factor | 6 +++--- library/ui/gadgets.factor | 8 ++++---- library/ui/labels.factor | 6 +++--- library/ui/layouts.factor | 2 -- library/ui/piles.factor | 25 ++++++++++++++++++------- library/ui/presentations.factor | 6 ++++-- library/ui/scrolling.factor | 8 +++++--- library/ui/shelves.factor | 8 ++++---- library/ui/splitters.factor | 8 ++++---- library/ui/stacks.factor | 2 +- native/alien.c | 10 ++++++++++ native/alien.h | 1 + native/primitives.c | 3 ++- 21 files changed, 81 insertions(+), 48 deletions(-) diff --git a/CHANGES.txt b/CHANGES.txt index 078f88555c..ad8f08c68d 100644 --- a/CHANGES.txt +++ b/CHANGES.txt @@ -1,9 +1,7 @@ Factor 0.76: ------------ -+ Framework - -- md5 hashing algorithm in contrib/crypto/ (Doug Coleman). ++ Core language - New words: @@ -11,6 +9,17 @@ Factor 0.76: unparser hex-string ( str -- str ) sequences fourth ( seq -- elt ) +- String input streams. + + with-string is now string-out ( quot -- string ) + + new string-in ( string quot -- ) word, calls quot with stdio bound to + a stream that reads from the given string. + ++ Framework + +- md5 hashing algorithm in contrib/crypto/ (Doug Coleman). + Factor 0.75: ------------ diff --git a/library/alien/aliens.factor b/library/alien/aliens.factor index c3e930c0ce..4684658d47 100644 --- a/library/alien/aliens.factor +++ b/library/alien/aliens.factor @@ -16,8 +16,6 @@ BUILTIN: displaced-alien 20 displaced-alien? ; #! C null value. 0 ; -: null? ( alien -- ? ) dup alien? [ alien-address 0 = ] when ; - M: alien hashcode ( obj -- n ) alien-address >fixnum ; diff --git a/library/bootstrap/primitives.factor b/library/bootstrap/primitives.factor index c2b3eb0f54..ba903cee10 100644 --- a/library/bootstrap/primitives.factor +++ b/library/bootstrap/primitives.factor @@ -207,6 +207,7 @@ vocabularies get [ [ "fwrite" "io-internals" [ [ string alien ] [ ] ] ] [ "fflush" "io-internals" [ [ alien ] [ ] ] ] [ "fclose" "io-internals" [ [ alien ] [ ] ] ] + [ "expired?" "alien" [ [ object ] [ boolean ] ] ] ] [ make-primitive ] each drop diff --git a/library/test/gadgets.factor b/library/test/gadgets.factor index 5cb9df1a13..8f0bf9f23c 100644 --- a/library/test/gadgets.factor +++ b/library/test/gadgets.factor @@ -70,7 +70,7 @@ USING: gadgets kernel lists math namespaces test sequences ; [ 300 620 ] [ - 0 10 0 "pile" set + 0 { 10 10 10 } 0 "pile" set 0 0 100 100 "pile" get add-gadget 0 0 200 200 "pile" get add-gadget 0 0 300 300 "pile" get add-gadget diff --git a/library/tools/jedit-wire.factor b/library/tools/jedit-wire.factor index bf35f2ffe9..1501f8aa46 100644 --- a/library/tools/jedit-wire.factor +++ b/library/tools/jedit-wire.factor @@ -39,7 +39,7 @@ prettyprint sequences io strings words ; ! remaining -- input : jedit-write-attr ( str style -- ) CHAR: w write - [ swap . . ] string-out + [ swap . "USE: styles" print . ] string-out dup write-len write ; TUPLE: jedit-stream ; diff --git a/library/ui/borders.factor b/library/ui/borders.factor index 56f27cd9a1..a7205167a5 100644 --- a/library/ui/borders.factor +++ b/library/ui/borders.factor @@ -2,7 +2,7 @@ ! See http://factor.sf.net/license.txt for BSD license. IN: gadgets USING: errors generic hashtables kernel lists math namespaces -sdl ; +sdl vectors ; ! A border lays out its children on top of each other, all with ! a 5-pixel padding. @@ -33,9 +33,9 @@ C: border ( child delegate size -- border ) [ shape-h rot - ] keep gadget-child resize-gadget ; -M: border pref-size ( border -- w h ) +M: border pref-dim ( border -- dim ) [ border-size 2 * ] keep - gadget-child pref-size >r over + r> rot + ; + gadget-child pref-size >r over + r> rot + 0 3vector ; M: border layout* ( border -- ) dup layout-border-x/y layout-border-w/h ; diff --git a/library/ui/editors.factor b/library/ui/editors.factor index a54d52d947..5c33d0da88 100644 --- a/library/ui/editors.factor +++ b/library/ui/editors.factor @@ -2,7 +2,7 @@ ! See http://factor.sf.net/license.txt for BSD license. IN: gadgets USING: generic kernel line-editor lists math namespaces sdl -sequences strings styles ; +sequences strings styles vectors ; ! An editor gadget wraps a line editor object and passes ! gestures to the line editor. @@ -88,8 +88,8 @@ M: editor user-input* ( ch editor -- ? ) [ [ insert-char ] with-editor ] keep scroll>bottom t ; -M: editor pref-size ( editor -- w h ) - dup editor-text label-size >r 1 + r> ; +M: editor pref-dim ( editor -- dim ) + dup editor-text label-size >r 1 + r> 0 3vector ; M: editor layout* ( editor -- ) dup editor-caret over caret-size rot resize-gadget diff --git a/library/ui/fonts.factor b/library/ui/fonts.factor index a446da6936..e00a683cff 100644 --- a/library/ui/fonts.factor +++ b/library/ui/fonts.factor @@ -35,7 +35,7 @@ global [ open-fonts nest drop ] bind : ttf-init ( -- ) TTF_Init - open-fonts [ [ cdr null? not ] hash-subset ] change ; + open-fonts [ [ cdr expired? not ] hash-subset ] change ; : gadget-font ( gadget -- font ) [ font paint-prop ] keep diff --git a/library/ui/frames.factor b/library/ui/frames.factor index e8e065ed2a..c298e0c2cf 100644 --- a/library/ui/frames.factor +++ b/library/ui/frames.factor @@ -2,7 +2,7 @@ ! See http://factor.sf.net/license.txt for BSD license. IN: gadgets USING: gadgets generic kernel lists math namespaces sdl -sequences words ; +sequences vectors words ; ! A frame arranges left/right/top/bottom gadgets around a ! center gadget, which gets any leftover space. @@ -43,7 +43,7 @@ C: frame ( -- frame ) : add-h pref-size nip height [ + ] change ; : add-w pref-size drop width [ + ] change ; -M: frame pref-size ( glue -- w h ) +M: frame pref-dim ( glue -- dim ) [ dup frame-major [ max-w ] each dup frame-minor [ max-h ] each @@ -51,7 +51,7 @@ M: frame pref-size ( glue -- w h ) dup frame-right add-w dup frame-top add-h frame-bottom add-h - ] with-pref-size ; + ] with-pref-size 0 3vector ; SYMBOL: frame-right-run SYMBOL: frame-bottom-run diff --git a/library/ui/gadgets.factor b/library/ui/gadgets.factor index 8610a394a9..342faf3241 100644 --- a/library/ui/gadgets.factor +++ b/library/ui/gadgets.factor @@ -73,15 +73,15 @@ C: gadget ( shape -- gadget ) : set-paint-prop ( gadget value key -- ) rot gadget-paint set-hash ; -GENERIC: pref-size ( gadget -- w h ) +GENERIC: pref-dim ( gadget -- dim ) -M: gadget pref-size shape-size ; +M: gadget pref-dim shape-dim ; -: pref-dim pref-size 0 3vector ; +: pref-size pref-dim 3unseq drop ; GENERIC: layout* ( gadget -- ) -: prefer ( gadget -- ) [ pref-size ] keep resize-gadget ; +: prefer ( gadget -- ) dup pref-dim swap set-gadget-dim ; M: gadget layout* #! Trivial layout gives each child its preferred size. diff --git a/library/ui/labels.factor b/library/ui/labels.factor index f7b7194259..72b8d9088e 100644 --- a/library/ui/labels.factor +++ b/library/ui/labels.factor @@ -2,7 +2,7 @@ ! See http://factor.sf.net/license.txt for BSD license. IN: gadgets USING: generic hashtables io kernel lists math namespaces sdl -sequences styles ; +sequences styles vectors ; ! A label gadget draws a string. TUPLE: label text ; @@ -13,8 +13,8 @@ C: label ( text -- label ) : label-size ( gadget text -- w h ) >r gadget-font r> size-string ; -M: label pref-size ( label -- w h ) - dup label-text label-size ; +M: label pref-dim ( label -- dim ) + dup label-text label-size 0 3vector ; M: label draw-shape ( label -- ) [ dup gadget-font swap label-text ] keep diff --git a/library/ui/layouts.factor b/library/ui/layouts.factor index 8ffbe1f877..34fcad834b 100644 --- a/library/ui/layouts.factor +++ b/library/ui/layouts.factor @@ -27,8 +27,6 @@ namespaces sdl sequences ; : with-layout ( quot -- ) [ 0 x set 0 y set call ] with-scope ; inline -: default-gap 3 ; - : packed-pref-dim ( children gap axis -- dim ) #! The preferred size of the gadget, if all children are #! packed in the direction of the given axis. diff --git a/library/ui/piles.factor b/library/ui/piles.factor index ac8c33d329..f23f9ac2ab 100644 --- a/library/ui/piles.factor +++ b/library/ui/piles.factor @@ -4,7 +4,20 @@ IN: gadgets USING: errors generic hashtables kernel lists math namespaces sdl sequences vectors ; -! A pile is a box that lays out its contents vertically. +! pile-align +! +! if the component is smaller than its allocated space, where to +! place the component inside the allocated space. +! +! pile-gap +! +! amount of space, in pixels, between components. +! +! pile-fill +! +! if the component is smaller than its allocated space, how much +! to scale the size, where a value of 0 represents no scaling, and +! a value of 1 represents resizing to fully fill allocated space. TUPLE: pile align gap fill ; C: pile ( align gap fill -- pile ) @@ -16,18 +29,16 @@ C: pile ( align gap fill -- pile ) [ set-pile-gap ] keep [ set-pile-align ] keep ; -: 1/2 default-gap 0 ; -: 0 0 1 ; +: 0 { 0 0 0 } 1 ; -M: pile pref-size ( pile -- w h ) - dup gadget-children swap pile-gap dup dup 3vector { 0 1 0 } - packed-pref-dim 3unseq drop ; +M: pile pref-dim ( pile -- dim ) + dup gadget-children swap pile-gap { 0 1 0 } packed-pref-dim ; : w- swap shape-w swap pref-size drop - ; : pile-x/y ( pile gadget offset -- ) rot pile-align * >fixnum y get rot move-gadget ; : pile-w/h ( pile gadget offset -- ) - rot dup pile-gap y [ + ] change + rot dup pile-gap first y [ + ] change pile-fill * >fixnum over pref-size dup y [ + ] change >r + r> rot resize-gadget ; : vertically ( pile gadget -- ) 2dup w- 3dup pile-x/y pile-w/h ; diff --git a/library/ui/presentations.factor b/library/ui/presentations.factor index ec260e5d6f..72ebe2c087 100644 --- a/library/ui/presentations.factor +++ b/library/ui/presentations.factor @@ -1,10 +1,12 @@ ! Copyright (C) 2005 Slava Pestov. ! See http://factor.sf.net/license.txt for BSD license. IN: gadgets -USING: hashtables io kernel lists namespaces prettyprint ; +USING: hashtables io kernel lists namespaces parser prettyprint +sequences ; : actions-menu ( -- ) - "actions" get show-menu ; + "actions" get [ uncons [ eval ] append cons ] map + show-menu ; : init-actions ( gadget -- ) [ "actions" get actions-menu ] button-gestures ; diff --git a/library/ui/scrolling.factor b/library/ui/scrolling.factor index 94ec70e87e..858dcea33e 100644 --- a/library/ui/scrolling.factor +++ b/library/ui/scrolling.factor @@ -34,7 +34,7 @@ C: viewport ( content -- viewport ) [ add-gadget ] keep { 0 0 0 } over set-viewport-origin ; -M: viewport pref-size gadget-child pref-size ; +M: viewport pref-dim gadget-child pref-dim ; M: viewport layout* ( viewport -- ) dup viewport-origin @@ -106,7 +106,7 @@ C: slider ( viewport vector -- slider ) : thumb-dim ( slider -- h ) [ shape-dim dup ] keep >thumb slider-dim vmax vmin ; -M: slider pref-size drop slider-dim 3unseq drop ; +M: slider pref-dim drop slider-dim ; M: slider layout* ( slider -- ) dup thumb-loc over slider-vector v* @@ -122,7 +122,9 @@ TUPLE: scroller viewport x y ; : add-y-slider 2dup set-scroller-y add-right ; -: viewport>bottom -1 swap scroll-viewport ; +: viewport>bottom ( -- viewport ) + dup viewport-dim vneg over viewport-origin + { 0 1 0 } set-axis swap scroll ; : (scroll>bottom) ( scroller -- ) dup scroller-viewport viewport>bottom diff --git a/library/ui/shelves.factor b/library/ui/shelves.factor index 157ad15bdd..0aaf0f9354 100644 --- a/library/ui/shelves.factor +++ b/library/ui/shelves.factor @@ -2,7 +2,7 @@ ! See http://factor.sf.net/license.txt for BSD license. IN: gadgets USING: errors generic hashtables kernel lists math namespaces -sdl sequences ; +sdl sequences vectors ; ! A shelf is a box that lays out its contents horizontally. TUPLE: shelf gap align fill ; @@ -16,10 +16,10 @@ C: shelf ( align gap fill -- shelf ) [ set-shelf-gap ] keep [ set-shelf-align ] keep ; -: 1/2 default-gap 0 ; +: 1/2 { 3 3 3 } 0 ; : 0 0 1 ; -M: shelf pref-size ( pile -- w h ) +M: shelf pref-dim ( pile -- dim ) [ dup shelf-gap swap gadget-children [ length 1 - 0 max * width set ] keep @@ -28,7 +28,7 @@ M: shelf pref-size ( pile -- w h ) height [ max ] change width [ + ] change ] each - ] with-pref-size ; + ] with-pref-size 0 3vector ; : h- swap shape-h swap pref-size nip - ; : shelf-x/y rot shelf-align * >fixnum >r x get r> rot move-gadget ; diff --git a/library/ui/splitters.factor b/library/ui/splitters.factor index d8e8bd84a6..3bfbe20e86 100644 --- a/library/ui/splitters.factor +++ b/library/ui/splitters.factor @@ -8,7 +8,7 @@ TUPLE: divider splitter ; : divider-size { 8 8 0 } ; -M: divider pref-size drop divider-size 3unseq drop ; +M: divider pref-dim drop divider-size ; TUPLE: splitter vector split ; @@ -43,9 +43,9 @@ C: splitter ( first second vector -- splitter ) : { 1 0 0 } ; -M: splitter pref-size - dup gadget-children swap splitter-vector { 0 0 0 } swap - packed-pref-dim 3unseq drop ; +M: splitter pref-dim + dup gadget-children swap splitter-vector + { 0 0 0 } swap packed-pref-dim ; : splitter-part ( splitter -- vec ) dup splitter-split swap shape-dim n*v divider-size 1/2 v*n v- ; diff --git a/library/ui/stacks.factor b/library/ui/stacks.factor index 08dbed1fd9..7133200ca2 100644 --- a/library/ui/stacks.factor +++ b/library/ui/stacks.factor @@ -13,7 +13,7 @@ C: stack ( list -- stack ) : max-dim ( shapelist -- dim ) { 0 0 0 } [ shape-dim vmax ] reduce ; -M: stack pref-size gadget-children max-dim 3unseq drop ; +M: stack pref-dim gadget-children max-dim ; M: stack layout* ( stack -- ) dup shape-dim swap gadget-children diff --git a/native/alien.c b/native/alien.c index edd0ca24f3..86fa3921b5 100644 --- a/native/alien.c +++ b/native/alien.c @@ -1,5 +1,15 @@ #include "factor.h" +void primitive_expired(void) +{ + CELL object = dpeek(); + + if(type_of(object) == ALIEN_TYPE) + drepl(tag_boolean(alien->expired)); + else + drepl(F); +} + INLINE void* alien_offset(CELL object) { ALIEN *alien; diff --git a/native/alien.h b/native/alien.h index c0ac4e6a25..4da239d77b 100644 --- a/native/alien.h +++ b/native/alien.h @@ -20,6 +20,7 @@ INLINE DISPLACED_ALIEN* untag_displaced_alien_fast(CELL tagged) return (DISPLACED_ALIEN*)UNTAG(tagged); } +void primitive_expired(void); void primitive_alien(void); void primitive_displaced_alien(void); void primitive_alien_address(void); diff --git a/native/primitives.c b/native/primitives.c index e99328a388..d4a1f5407e 100644 --- a/native/primitives.c +++ b/native/primitives.c @@ -172,7 +172,8 @@ void* primitives[] = { primitive_fgetc, primitive_fwrite, primitive_fflush, - primitive_fclose + primitive_fclose, + primitive_expired }; CELL primitive_to_xt(CELL primitive)