some UI tweaking

library/continuations.factor

@@ -3,8 +3,8 @@
 IN: errors
 USING: kernel-internals ;
 
-: catchstack ( -- cs ) 6 getenv ;
+: catchstack ( -- cs ) 6 getenv ; inline
-: set-catchstack ( cs -- ) 6 setenv ;
+: set-catchstack ( cs -- ) 6 setenv ; inline
 
 IN: kernel
 USING: namespaces sequences ;
@@ -19,10 +19,16 @@ TUPLE: continuation data c call name catch ;
 : set-c-stack ( c-stack -- )
     [ "not supported" throw ] when ;
 
+: interpret ( quot -- )
+    #! Call the quotation in the interpreter. When compiled,
+    #! the quotation is ignored.
+    call ;
+
 : continuation ( -- interp )
     #! The continuation is reified from after the *caller* of
-    #! this word returns.
+    #! this word returns. It must be declared inline for this
-    datastack c-stack callstack dup pop* dup pop*
+    #! invariant to be preserved in compiled code too.
+    datastack c-stack callstack [ dup pop* dup pop* ] interpret
     namestack catchstack <continuation> ; inline
 
 : >continuation< ( continuation -- data c call name catch )
@@ -33,9 +39,11 @@ TUPLE: continuation data c call name catch ;
     continuation-catch ; inline
 
 : ifcc ( terminator balance -- | quot: continuation -- )
+    #! Note that the branch at the end must not be optimized out
+    #! by the compiler.
     [
         continuation
-        dup continuation-data f over push f swap push t
+        dup continuation-data f over push f swap push dup
     ] call 2swap if ; inline
 
 : callcc0 ( quot -- | quot: continuation -- )

library/sdl/sdl-utils.factor

@@ -1,7 +1,7 @@
 ! Copyright (C) 2004, 2005 Slava Pestov.
 ! See http://factor.sf.net/license.txt for BSD license.
 IN: sdl
-USING: kernel lists math namespaces sequences ;
+USING: errors kernel lists math namespaces sequences ;
 
 SYMBOL: surface
 SYMBOL: width
@@ -12,9 +12,12 @@ SYMBOL: bpp
     >r 3dup bpp set height set width set r>
     SDL_SetVideoMode surface set ;
 
+: sdl-error ( 0/-1 -- )
+    0 = [ SDL_GetError throw ] unless ;
+
 : with-screen ( width height bpp flags quot -- )
     #! Set up SDL graphics and call the quotation.
-    SDL_INIT_EVERYTHING SDL_Init drop
+    SDL_INIT_EVERYTHING SDL_Init sdl-error
     1 SDL_EnableUNICODE drop
     SDL_DEFAULT_REPEAT_DELAY SDL_DEFAULT_REPEAT_INTERVAL
     SDL_EnableKeyRepeat drop

library/test/benchmark/hashtables.factor

@@ -1,14 +1,15 @@
 USING: compiler hashtables kernel math namespaces sequences test ;
 
 : store-hash ( hashtable n -- )
-    [ >float dup pick set-hash ] each drop ;
+    [ dup pick set-hash ] each drop ;
 
 : lookup-hash ( hashtable n -- )
-    [ >float over hash drop ] each drop ;
+    [ over hash drop ] each drop ;
 
 : hashtable-benchmark ( -- )
     100 [
-        80000 1000 <hashtable> swap 2dup store-hash lookup-hash
+        drop
-    ] times ; compiled
+        80000 100000 <hashtable> swap 2dup store-hash lookup-hash
+    ] each ; compiled
 
 [ ] [ hashtable-benchmark ] unit-test

library/test/benchmark/image.factor

@@ -2,7 +2,7 @@ IN: temporary
 USING: generic image kernel math namespaces parser test ;
 
 [
-    "/library/bootstrap/boot-stage1.factor" run-resource
+    "/library/bootstrap/boot-stage1.factor" run-resource drop
 ] with-image drop
 
 [ fixnum ] [ 4 class ] unit-test

library/test/test.factor

@@ -111,10 +111,8 @@ SYMBOL: failures
     {
         "io/buffer" "compiler/optimizer"
         "compiler/simple"
-        "compiler/stack" "compiler/if"
+        "compiler/stack" "compiler/ifte"
         "compiler/generic" "compiler/bail-out"
         "compiler/linearizer" "compiler/intrinsics"
         "compiler/identities"
     } run-tests ;
-
-: all-tests tests compiler-tests benchmarks ;

library/tools/interpreter.factor

@@ -54,10 +54,10 @@ SYMBOL: meta-executing
 
 : host-word ( word -- )
     [
-        \ call push-r  continuation [
+        \ call push-r
-            continuation over continuation-data push continue
+        [ continuation swap continue-with ] cons cons push-r
-        ] cons cons push-r  meta-interp continue
+        meta-interp continue
-    ] call  set-meta-interp  pop-d 2drop ;
+    ] callcc1 set-meta-interp pop-d 2drop ;
 
 : meta-call ( quot -- )
     #! Note we do tail call optimization here.

library/tools/walker.factor

@@ -36,23 +36,17 @@ sequences io strings vectors words ;
     #! Step into current word.
     next do report ;
 
-: continue
+: end-walk
     #! Continue executing the single-stepped continuation in the
     #! primary interpreter.
-    meta-d get set-datastack
+    \ call push-r meta-cf get push-r meta-interp continue ;
-    meta-c get set-catchstack
-    meta-cf get
-    meta-r get
-    meta-n get set-namestack
-    set-callstack call ;
 
 : walk-banner ( -- )
     "&s &r show stepper stacks" print
     "&get ( var -- value ) get stepper variable value" print
     "step -- single step over" print
     "into -- single step into" print
-    "continue -- continue execution" print
+    "bye -- continue execution" print
-    "bye -- exit single-stepper" print
     report ;
 
 : walk-listener walk-banner "walk " listener-prompt set listener ;
@@ -71,4 +65,5 @@ sequences io strings vectors words ;
     callstack namestack [
         init-walk
         walk-listener
+        end-walk
     ] with-scope ;

library/ui/fonts.factor

@@ -35,7 +35,7 @@ SYMBOL: open-fonts
 global [ open-fonts nest drop ] bind
 
 : ttf-init ( -- )
-    TTF_Init -1 = [ SDL_GetError throw ] when
+    TTF_Init sdl-error
     global [
         open-fonts [ [ cdr expired? not ] hash-subset ] change
     ] bind ;

library/ui/gadgets.factor

@@ -74,3 +74,8 @@ M: gadget children-on ( rect/point gadget -- list )
             [ nip pick-up ] [ rot 2drop ] if
         ] with-scope
     ] [ 2drop f ] if ;
+
+! Mind-map/outliner node protocol
+GENERIC: node-gadget ( node -- gadget )
+GENERIC: node-left ( node -- seq )
+GENERIC: node-right ( node -- seq )

library/ui/listener.factor

@@ -30,14 +30,11 @@ C: display ( -- display )
     <pile> 2dup swap set-display-pane
     <scroller> over add-center ;
 
-: make-presentations ( seq -- seq )
-    [ [ unparse-short <label> ] keep <object-button> ] map ;
-
 : present-stack ( seq title display -- )
     [ display-title set-label-text ] keep
     [
         display-pane dup clear-gadget
-        >r reverse-slice make-presentations r> add-gadgets
+        >r reverse-slice [ <object-button> ] map r> add-gadgets
     ] keep relayout ;
 
 : ui-listener-hook ( -- )

library/ui/load.factor

@@ -24,6 +24,7 @@ USING: kernel parser sequences io ;
     "/library/ui/panes.factor"
     "/library/ui/presentations.factor"
     "/library/ui/books.factor"
+    "/library/ui/outliner.factor"
     "/library/ui/mindmap.factor"
     "/library/ui/listener.factor"
     "/library/ui/ui.factor"

library/ui/menus.factor

@@ -39,3 +39,9 @@ gadgets-labels generic kernel lists math namespaces sequences ;
 : <menu> ( assoc -- gadget )
     #! Given an association list mapping labels to quotations.
     menu-items line-border dup menu-theme ;
+
+: <menu-button> ( gadget quot -- button )
+    [ show-menu ] append <roll-button>
+    dup [ button-clicked ] [ button-down 1 ] set-action
+    dup [ button-update ] [ button-up 1 ] set-action ;
+

library/ui/mindmap.factor

@@ -1,20 +1,18 @@
 ! Copyright (C) 2005 Slava Pestov.
 ! See http://factor.sf.net/license.txt for BSD license.
 IN: gadgets-mindmap
-USING: gadgets gadgets-buttons gadgets-labels gadgets-layouts
+USING: arrays gadgets gadgets-buttons gadgets-labels
-generic kernel math sequences styles ;
+gadgets-layouts generic kernel math sequences styles ;
 
 ! Mind-map tree-view gadget, like http://freemind.sf.net.
 
-! Mind-map node protocol
-GENERIC: node-gadget ( node -- gadget )
-GENERIC: node-left ( node -- seq )
-GENERIC: node-right ( node -- seq )
-
 TUPLE: mindmap left node gadget right expanded? left? right? ;
 
+DEFER: <expand-button>
+
 : add-mindmap-node ( mindmap -- )
-    dup mindmap-node node-gadget swap
+    dup mindmap-node node-gadget <expand-button> 2array
+    <shelf> [ add-gadgets ] keep swap
     2dup add-gadget set-mindmap-gadget ;
 
 : collapse-mindmap ( mindmap -- )
@@ -67,7 +65,7 @@ TUPLE: mindmap left node gadget right expanded? left? right? ;
     dup add-mindmap-node
     expand-right ;
 
-: toggle-expanded ( mindmap -- )
+: toggle-mindmap ( mindmap -- )
     dup mindmap-expanded?
     [ collapse-mindmap ] [ expand-mindmap ] if ;
 
@@ -100,4 +98,4 @@ M: mindmap draw-gadget* ( mindmap -- )
 : find-mindmap [ mindmap? ] find-parent ;
 
 : <expand-button> ( label -- gadget )
-    <label> [ find-mindmap toggle-expanded ] <roll-button> ;
+    "+" <label> [ find-mindmap toggle-mindmap ] <roll-button> ;

library/ui/presentations.factor

@@ -26,16 +26,17 @@ SYMBOL: commands
 : command-menu ( presented -- menu )
     dup applicable
     [ [ third command-quot ] keep second swons ] map-with
-    <menu> show-menu ;
+    <menu> ;
 
-: <object-button> ( gadget object -- button )
+: <command-button> ( gadget object -- button )
     [ \ drop , literalize , \ command-menu , ] [ ] make
-    <roll-button>
+    <menu-button> ;
-    dup [ button-clicked ] [ button-down 1 ] set-action
+
-    dup [ button-update ] [ button-up 1 ] set-action ;
+: <object-button> ( object -- button )
+    [ unparse-short <label> ] keep <command-button> ;
 
 : init-commands ( gadget -- gadget )
-    dup presented paint-prop [ <object-button> ] when* ;
+    dup presented paint-prop [ <command-button> ] when* ;
 
 : <styled-label> ( style text -- label )
     <label> swap dup [ alist>hash ] when over set-gadget-paint ;

native/unix/ffi.c

@@ -2,6 +2,11 @@
 
 static void *null_dll;
 
+void ffi_test(void *font, char *text, int fg)
+{
+	fprintf(stderr,"%d %d %d",font,text,fg);
+}
+
 void init_ffi(void)
 {
 	null_dll = dlopen(NULL,RTLD_LAZY);