more UI cleanups, fix jedit-stream bug

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:
 ------------
 

library/alien/aliens.factor

@@ -16,8 +16,6 @@ BUILTIN: displaced-alien 20 displaced-alien? ;
     #! C null value.
     0 <alien> ;
 
-: null? ( alien -- ? ) dup alien? [ alien-address 0 = ] when ;
-
 M: alien hashcode ( obj -- n )
     alien-address >fixnum ;
 

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

library/test/gadgets.factor

@@ -70,7 +70,7 @@ USING: gadgets kernel lists math namespaces test sequences ;
 [
     300 620
 ] [
-    0 10 0 <pile> "pile" set
+    0 { 10 10 10 } 0 <pile> "pile" set
     0 0 100 100 <rectangle> <gadget> "pile" get add-gadget
     0 0 200 200 <rectangle> <gadget> "pile" get add-gadget
     0 0 300 300 <rectangle> <gadget> "pile" get add-gadget

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 ;

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 ;

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

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

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

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.

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

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.

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 ;
 
-: <default-pile> 1/2 default-gap 0 <pile> ;
-: <line-pile> 0 0 1 <pile> ;
+: <line-pile> 0 { 0 0 0 } 1 <pile> ;
 
-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 ;

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 <menu> show-menu ;
+    "actions" get [ uncons [ eval ] append cons ] map
+    <menu> show-menu ;
 
 : init-actions ( gadget -- )
     [ "actions" get actions-menu ] button-gestures ;

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

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 ;
 
-: <default-shelf> 1/2 default-gap 0 <shelf> ;
+: <default-shelf> 1/2 { 3 3 3 } 0 <shelf> ;
 : <line-shelf> 0 0 1 <shelf> ;
 
-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 ;

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 )
 
 : <y-splitter> { 1 0 0 } <splitter> ;
 
-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- ;

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

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;

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);

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)