Major UI improvements, fix problem with deferred words

library/bootstrap/boot-stage1.factor

@@ -109,6 +109,7 @@ vectors words ;
 
         "/library/tools/memory.factor"
         "/library/tools/listener.factor"
+        "/library/tools/inspector.factor"
         "/library/tools/walker.factor"
 
         "/library/tools/annotations.factor"
@@ -182,6 +183,7 @@ vectors words ;
         "/library/ui/gestures.factor"
         "/library/ui/borders.factor"
         "/library/ui/buttons.factor"
+        "/library/ui/tiles.factor"
         "/library/ui/line-editor.factor"
         "/library/ui/sliders.factor"
         "/library/ui/viewports.factor"
@@ -191,13 +193,14 @@ vectors words ;
         "/library/ui/incremental.factor"
         "/library/ui/paragraphs.factor"
         "/library/ui/panes.factor"
+        "/library/ui/tabs.factor"
         "/library/ui/outliner.factor"
         "/library/ui/environment.factor"
         "/library/ui/presentations.factor"
         "/library/ui/listener.factor"
-        "/library/ui/inspector.factor"
         "/library/ui/browser.factor"
         "/library/ui/apropos.factor"
+        "/library/ui/help.factor"
         "/library/ui/launchpad.factor"
 
         "/library/continuations.facts"

library/cocoa/menu-bar.factor

@@ -113,7 +113,7 @@ DEFER: described-menu
         { {
             "File"
             { "New Listener" listener-window "n" }
-            { "New Browser" [ f browser-window ] "b" }
+            { "New Browser" browser-window "b" }
             { }
             { "Run..." menu-run-file "o" }
             { }

library/test/collections/sequences.factor

@@ -212,3 +212,9 @@ unit-test
 [ 10 "hi" "bye" copy-into ] unit-test-fails
 
 [ { 1 2 3 5 6 } ] [ 3 { 1 2 3 4 5 6 } remove-index ] unit-test
+
+[ V{ 1 2 3 } ]
+[ 3 V{ 1 2 } clone [ push-new ] keep ] unit-test
+
+[ V{ 1 2 3 } ]
+[ 3 V{ 1 3 2 } clone [ push-new ] keep ] unit-test

library/test/words.factor

@@ -1,5 +1,5 @@
 IN: temporary
-USING: arrays generic hashtables kernel math namespaces
+USING: arrays errors generic hashtables kernel math namespaces
 sequences test words ;
 
 [ 4 ] [
@@ -99,6 +99,9 @@ GENERIC: freakish
 M: array freakish ;
 [ t ] [ \ bar \ freakish usage member? ] unit-test
 
+DEFER: x
+[ t ] [ [ x ] catch third \ x eq? ] unit-test
+
 ! This has to be the last test in the file.
 : test-last ( -- ) ;
 

library/tools/debugger.factor

@@ -1,9 +1,9 @@
 ! Copyright (C) 2004, 2006 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-IN: errors
 USING: arrays generic hashtables inspector io kernel
 kernel-internals math namespaces parser prettyprint sequences
-sequences-internals strings vectors words ;
+sequences-internals strings styles vectors words ;
+IN: errors
 
 SYMBOL: error
 SYMBOL: error-continuation
@@ -128,32 +128,51 @@ M: object error. ( error -- ) . ;
 
 : :res ( n -- ) restarts get nth first3 continue-with ;
 
+: (debug-help) ( string quot -- )
+    <input> simple-object terpri ;
+
+: restart. ( restart n -- )
+    [ [ # " :res  " % first % ] "" make ] keep
+    [ :res ] curry (debug-help) ;
+
 : restarts. ( -- )
     restarts get dup empty? [
         drop
     ] [
+        terpri
         "The following restarts are available:" print
-        dup length [
+        terpri
-            number>string write " :res  " write first print
+        dup length [ restart. ] 2each
-        ] 2each
     ] if ;
 
+DEFER: :error
+DEFER: :cc
+
 : debug-help ( -- )
-    restarts.
+    terpri
-    ":s :r :c show stacks at time of error" print
+    "Debugger commands:" print
+    terpri
+    ":s  data stack at exception time" [ :s ] (debug-help)
+    ":r  retain stack at exception time" [ :r ] (debug-help)
+    ":c  call stack at exception time" [ :c ] (debug-help)
+    ":error starts the inspector with the error" [ :error ] (debug-help)
+    ":cc starts the inspector with the error continuation" [ :cc ] (debug-help)
     ":get ( var -- value ) accesses variables at time of error" print
-    ":error starts the inspector with the error" print
-    ":cc starts the inspector with the error continuation" print
     flush ;
 
 : flush-error-handler ( -- )
     [ "Error in default error handler!" print ] when ;
 
 : print-error ( error -- )
-    "An unhandled error was caught:" print terpri
+    [
-    [ dup error. ] catch nip flush-error-handler ;
+        dup error.
+        restarts.
+        debug-help
+    ] [
+        "Error in print-error!" print
+    ] recover drop ;
 
-: try ( quot -- ) [ print-error terpri debug-help ] recover ;
+: try ( quot -- ) [ print-error ] recover ;
 
 : save-error ( error continuation -- )
     error-continuation set-global

library/tools/describe.factor

@@ -2,7 +2,8 @@
 ! See http://factorcode.org/license.txt for BSD license.
 IN: inspector
 USING: arrays generic hashtables help io kernel kernel-internals
-math namespaces prettyprint sequences strings vectors words ;
+math namespaces prettyprint sequences strings styles vectors
+words ;
 
 GENERIC: summary ( object -- string )
 
@@ -61,6 +62,9 @@ M: word summary ( word -- )
         drop "a uniquely generated symbol"
     ] if ;
 
+M: input summary ( input -- )
+    "Input: " swap input-string unparse-short append ;
+
 : format-column ( list ? -- list )
     >r [ unparse-short ] map r> [
         [ 0 [ length max ] reduce ] keep

library/tools/inspector.factor

@@ -23,7 +23,9 @@ SYMBOL: inspector-stack
     sheet sheet-numbers sheet. ;
 
 : inspector-help ( -- )
+    terpri
     "Object inspector." print
+    terpri
     "inspecting ( -- obj ) push current object" print
     "go ( n -- ) inspect nth slot" print
     "up -- return to previous object" print

library/tools/listener.factor

@@ -9,10 +9,8 @@ SYMBOL: quit-flag
 
 SYMBOL: listener-hook
 SYMBOL: datastack-hook
-SYMBOL: error-hook
 
 "  " listener-prompt set-global
-[ drop terpri debug-help ] error-hook set-global
 
 : bye ( -- ) quit-flag on ;
 
@@ -32,16 +30,10 @@ SYMBOL: error-hook
         f depth (read-multiline) >r >quotation r> in get
     ] with-parser in set ;
 
-: listen-try
-    [
-        print-error error-continuation get error-hook get call
-    ] recover ;
-
 : listen ( -- )
     listener-hook get call
     listener-prompt get write flush
-    [ read-multiline [ call ] [ bye ] if ]
+    [ read-multiline [ call ] [ bye ] if ] try ;
-    listen-try ;
 
 : (listener) ( -- )
     quit-flag get [ quit-flag off ] [ listen (listener) ] if ;

library/ui/borders.factor

@@ -12,7 +12,7 @@ C: border ( child gap -- border )
     [ add-gadget ] keep ;
 
 : <default-border> ( child -- border )
-    5 <border> ;
+    3 <border> ;
 
 : layout-border-loc ( border -- )
     dup border-size swap gadget-child set-rect-loc ;

library/ui/browser.factor

@@ -1,9 +1,9 @@
 ! Copyright (C) 2006 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 IN: gadgets-browser
-USING: gadgets gadgets-buttons gadgets-inspector gadgets-labels
+USING: gadgets gadgets-buttons gadgets-labels gadgets-layouts
-gadgets-layouts gadgets-panes gadgets-presentations
+gadgets-panes gadgets-presentations gadgets-scrolling
-gadgets-scrolling gadgets-theme gadgets-tracks generic
+gadgets-tabs gadgets-tiles gadgets-theme gadgets-tracks generic
 hashtables help inspector kernel math prettyprint sequences
 words ;
 
@@ -36,41 +36,32 @@ TUPLE: browser vocabs vocab-track word-track ;
 
 : find-browser [ browser? ] find-parent ;
 
-TUPLE: tile ;
-
-: find-tile [ tile? ] find-parent ;
-
 : close-tile ( tile -- )
     dup gadget-parent [
         browser-track-showing hash>alist rassoc
     ] keep hide-asset ;
 
-: <close-button> ( -- gadget )
+: <browser-tile> ( gadget title -- gadget )
-    { 0.0 0.0 0.0 1.0 } close-box <polygon-gadget>
+    [ close-tile ] <tile> ;
-    [ find-tile close-tile ] <bevel-button> ;
-
-: <closable-title> ( title -- gadget )
-    {
-        { [ <label> ] f @center }
-        { [ <close-button> ] f @right }
-    } make-frame ;
-
-: <title> ( title closable? -- gadget )
-    [ <closable-title> ] [ <label> ] if dup title-theme ;
-
-C: tile ( gadget title closable? -- gadget )
-    {
-        { [ <title> ] f @top }
-        { [ ] f @center }
-    } make-frame* ;
 
 : showing-word? ( word browser -- ? )
     browser-word-track showing-asset? ;
 
 DEFER: show-vocab
 
+: <word-pages> ( word -- tabs )
+    {
+        { "Definition" [ see ] }
+        { "Documentation" [ word-help (help) ] }
+        { "Calls in" [ usage. ] }
+        { "Calls out" [ uses. ] }
+        { "Links in" [ links-in. ] }
+        { "Links out" [ links-out. ] }
+        { "Properties" [ word-props describe ] }
+    } <pages> ;
+
 : <word-view> ( word -- gadget )
-    [ f <inspector> ] keep word-name t <tile> ;
+    [ <word-pages> ] keep word-name <browser-tile> ;
 
 : show-word ( word browser -- )
     over word-vocabulary over show-vocab
@@ -91,7 +82,7 @@ DEFER: show-vocab
     [
         words natural-sort
         [ <word-button> ] map make-pile <scroller>
-    ] keep t <tile> ;
+    ] keep <browser-tile> ;
 
 : showing-vocab? ( vocab browser -- ? )
     browser-vocab-track showing-asset? ;
@@ -137,15 +128,19 @@ DEFER: show-vocab
     [ <word-view> ] [ 2drop ] <browser-track> ;
 
 C: browser ( -- browser )
-    <y-track> over set-delegate
+    {
-    <vocabs> over add-vocabs
+        { [ <vocabs> ] set-browser-vocabs 1/4 }
-    <vocab-track> over add-vocab-track
+        { [ <vocab-track> ] set-browser-vocab-track 1/4 }
-    <word-track> over add-word-track
+        { [ <word-track> ] set-browser-word-track 1/2 }
-    { 1/4 1/4 1/2 } over set-track-sizes ;
+    } { 1 0 0 } make-track* ;
 
-: browser-window ( word -- )
+: browser-window ( -- )
-    <browser> [ "Browser" open-window ] keep
+    <browser> "Browser" open-window ;
-    over [ show-word ] [ 2drop ] if ;
+
+: browser-tool
+    [ browser? ]
+    [ <browser> ]
+    [ show-word ] ;
 
 M: word show-object ( word button -- )
-    find-browser [ show-word ] [ browser-window ] if* ;
+    browser-tool call-tool ;

library/ui/environment.factor

@@ -37,3 +37,16 @@ hashtables kernel math namespaces queues sequences threads ;
 
 : open-window ( gadget title -- )
     >r <status-bar> <world> dup prefer r> open-window* ;
+
+: (open-tool) ( arg cons setter -- )
+    >r call tuck r> call "Tool" open-window ; inline
+
+: open-tool ( arg pred cons setter -- )
+    rot drop (open-tool) ;
+
+: call-tool ( arg gadget pred cons setter -- )
+    >r >r find-parent dup [
+        r> drop r> call
+    ] [
+        drop r> r> (open-tool)
+    ] if ;

library/ui/frames.factor

@@ -89,7 +89,7 @@ M: frame layout* ( frame -- dim )
     frame get 2dup r> dup [ execute ] [ 3drop ] if
     r> execute frame-add ;
 
-: build-frame ( gadget specs -- )
+: build-frame ( frame specs -- )
     #! Specs is an array of triples { quot setter loc }.
     #! The setter has stack effect ( new gadget -- ),
     #! the loc is @center, @top, etc.

library/ui/help.factor

@@ -0,0 +1,45 @@
+! Copyright (C) 2006 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+IN: gadgets-help
+USING: gadgets gadgets-panes gadgets-presentations
+gadgets-scrolling gadgets-tabs gadgets-tiles gadgets-tracks help
+io kernel sequences ;
+
+TUPLE: help-gadget history tabs ;
+
+TUPLE: history pane seq ;
+
+C: history ( -- gadget )
+    V{ } clone over set-history-seq
+    <pane> dup pick set-history-pane
+    <scroller> "History" f <tile> over set-gadget-delegate ;
+
+: update-history ( history -- )
+    dup history-seq swap history-pane [
+        <reversed> [
+            [ article-title ] keep simple-object terpri
+        ] each
+    ] with-pane ;
+
+: add-history ( link history -- )
+    [ history-seq push-new ] keep update-history ;
+
+C: help-gadget ( -- gadget )
+    {
+        { [ <history> ] set-help-gadget-history 1/4 }
+        { [ <tabs> ] set-help-gadget-tabs 3/4 }
+    } { 1 0 0 } make-track* ;
+
+: show-help ( link help -- )
+    2dup help-gadget-history add-history {
+        { "Article" [ help ] }
+        { "Links in" [ links-in. ] }
+        { "Links out" [ links-out. ] }
+    } swap help-gadget-tabs set-pages ;
+
+: help-tool
+    [ help-gadget? ]
+    [ <help-gadget> ]
+    [ show-help ] ;
+
+M: link show-object ( link button -- ) help-tool call-tool ;

library/ui/inspector.factor

@@ -1,106 +0,0 @@
-! Copyright (C) 2006 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: arrays gadgets gadgets-buttons gadgets-labels
-gadgets-layouts gadgets-panes gadgets-presentations
-gadgets-scrolling gadgets-theme generic hashtables help
-inspector kernel math namespaces prettyprint sequences words ;
-IN: gadgets-inspector
-
-SYMBOL: components
-
-H{ } clone components set-global
-
-: get-components ( class -- assoc )
-    components get-global hash [
-        { { "Slots" [ describe ] } }
-    ] unless* ;
-
-{
-    { "Definition" [ see ] }
-    { "Documentation" [ word-help (help) ] }
-    { "Calls in" [ usage. ] }
-    { "Calls out" [ uses. ] }
-    { "Links in" [ links-in. ] }
-    { "Links out" [ links-out. ] }
-    { "Properties" [ word-props describe ] }
-} \ word components get-global set-hash
-
-{
-    { "Article" [ help ] }
-    { "Links in" [ links-in. ] }
-    { "Links out" [ links-out. ] }
-} \ link components get-global set-hash
-
-{
-    { "Call stack" [ continuation-call callstack. ] }
-    { "Data stack" [ continuation-data stack. ] }
-    { "Retain stack" [ continuation-retain stack. ] }
-    { "Name stack" [ continuation-name stack. ] }
-    { "Catch stack" [ continuation-catch stack. ] }
-} \ continuation components get-global set-hash
-
-TUPLE: book page pages ;
-
-: show-page ( key book -- )
-    dup book-page unparent
-    [ book-pages assoc ] keep
-    [ set-book-page ] 2keep
-    add-gadget ;
-
-C: book ( pages -- book )
-    dup delegate>gadget
-    [ set-book-pages ] 2keep
-    [ >r first first r> show-page ] keep ;
-
-M: book pref-dim* ( book -- dim ) book-page pref-dim ;
-
-M: book layout* ( book -- )
-    dup rect-dim swap book-page set-gadget-dim ;
-
-: component-pages ( obj -- assoc )
-    dup class get-components
-    [ first2 swapd make-pane <scroller> 2array ] map-with ;
-
-: <tab> ( name book -- button )
-    dupd [ show-page drop ] curry curry
-    >r <label> r> <bevel-button> ;
-
-: tabs ( assoc book gadget -- )
-    >r swap [ first swap <tab> ] map-with r> add-gadgets ;
-
-TUPLE: inspector object history tabs ;
-
-: save-current ( inspector -- )
-    dup inspector-object swap inspector-history push ;
-
-: (inspect) ( obj inspector -- )
-    [ set-inspector-object ] 2keep
-    dup inspector-tabs clear-gadget
-    >r component-pages dup <book> r>
-    [ @center frame-add ] 2keep inspector-tabs tabs ;
-
-: inspect ( obj inspector -- ) dup save-current (inspect) ;
-
-: find-inspector [ inspector? ] find-parent ;
-
-: go-back ( inspector -- )
-    dup inspector-history dup empty?
-    [ 2drop ] [ pop swap inspect ] if ;
-
-: <back-button> ( -- gadget )
-    "<" <label> [ find-inspector go-back ] <bevel-button> ;
-
-C: inspector ( obj history? -- inspector )
-    V{ } clone over set-inspector-history
-    dup delegate>frame [
-        swap [ <back-button> , ] when
-        <shelf> dup pick set-inspector-tabs ,
-    ] { } make make-shelf dup highlight-theme
-    over @top frame-add
-    [ (inspect) ] keep ;
-
-: inspector-window ( obj -- )
-    t <inspector> "Inspector" open-window ;
-
-M: object show-object ( object button -- )
-    find-inspector [ inspect ] [ inspector-window ] if* ;

library/ui/launchpad.factor

@@ -1,8 +1,9 @@
 IN: gadgets-launchpad
 USING: gadgets gadgets-apropos gadgets-borders gadgets-browser
-gadgets-buttons gadgets-inspector gadgets-labels gadgets-layouts
+gadgets-buttons gadgets-labels gadgets-layouts gadgets-listener
-gadgets-listener gadgets-panes gadgets-scrolling gadgets-theme
+gadgets-panes gadgets-presentations gadgets-scrolling
-help inspector io kernel memory namespaces sequences ; 
+gadgets-theme help inspector io kernel memory namespaces
+sequences ; 
 
 : <launchpad> ( menu -- )
     [ first2 >r <label> [ drop ] r> append <bevel-button> ] map
@@ -13,7 +14,7 @@ help inspector io kernel memory namespaces sequences ;
     >r make-pane <scroller> r> open-window ;
 
 : handbook-window ( -- )
-    T{ link f "handbook" } inspector-window ;
+    T{ link f "handbook" } f show-object ;
 
 : memory-window ( -- )
     [ heap-stats. terpri room. ] "Memory" pane-window ;
@@ -25,7 +26,7 @@ help inspector io kernel memory namespaces sequences ;
     <apropos-gadget> "Apropos" open-window ;
 
 : globals-window ( -- )
-    global inspector-window ;
+    global f show-object ;
 
 : default-launchpad
     {

library/ui/listener.factor

@@ -3,9 +3,9 @@
 IN: gadgets-listener
 USING: arrays gadgets gadgets-editors gadgets-labels
 gadgets-layouts gadgets-panes gadgets-presentations
-gadgets-scrolling gadgets-theme generic hashtables io jedit
+gadgets-scrolling gadgets-theme generic hashtables inspector io
-kernel listener math namespaces parser prettyprint sequences
+jedit kernel listener math namespaces parser prettyprint
-styles threads words ;
+sequences styles threads words ;
 
 TUPLE: listener-gadget scroller stack ;
 
@@ -35,15 +35,9 @@ TUPLE: listener-gadget scroller stack ;
     ] keep
     listener-gadget-pane word-completion ;
 
-: ui-error-hook ( error -- )
-    terpri H{ { font-style bold } } [
-        "Debug this error" swap simple-object terpri
-    ] with-style ;
-
 : listener-thread ( listener -- )
     dup listener-gadget-pane [
         [ ui-listener-hook ] curry listener-hook set
-        [ ui-error-hook ] error-hook set
         print-banner listener
     ] with-stream* ;
 
@@ -66,20 +60,20 @@ M: listener-gadget focusable-child* ( listener -- gadget )
 : listener-window ( -- )
     <listener-gadget> "Listener" open-window ;
 
-: listener-window* ( quot/string -- )
+: call-listener ( quot/string listener -- )
-    <listener-gadget> [
+    listener-gadget-pane over quotation?
-        listener-gadget-pane over quotation?
+    [ pane-call ] [ replace-input ] if ;
-        [ pane-call ] [ replace-input ] if
+
-    ] keep "Listener" open-window ;
+: listener-tool
+    [ listener-gadget? ]
+    [ <listener-gadget> ]
+    [ call-listener ] ;
 
 : listener-run-files ( seq -- )
-    [ [ run-file ] each ] curry listener-window* ;
+    [ [ run-file ] each ] curry listener-tool open-tool ;
-
-: find-listener [ listener-gadget? ] find-parent ;
 
 M: input show-object ( input button -- )
-    >r input-string r> find-listener [
+    >r input-string r> listener-tool call-tool ;
-        listener-gadget-pane replace-input
+
-    ] [
+M: object show-object ( object button -- )
-        listener-window*
+    >r [ inspect ] curry r> listener-tool call-tool ;
-    ] if* ;

library/ui/panes.factor

@@ -38,7 +38,7 @@ continuation scrolls? ;
 SYMBOL: structured-input
 
 : pane-call ( quot pane -- )
-    dup [ "Command: " write over . ] with-stream*
+    dup [ "Command: " write over short. ] with-stream*
     >r structured-input set-global
     "\"structured-input\" \"gadgets-panes\" lookup get-global call"
     r> pane-eval ;

library/ui/tabs.factor

@@ -0,0 +1,48 @@
+! Copyright (C) 2006 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+IN: gadgets-tabs
+USING: arrays gadgets gadgets-buttons gadgets-labels
+gadgets-layouts gadgets-panes gadgets-scrolling gadgets-theme
+kernel sequences ;
+
+TUPLE: book page pages ;
+
+: show-page ( n book -- )
+    dup book-page unparent
+    [ book-pages nth ] keep
+    [ set-book-page ] 2keep
+    add-gadget ;
+
+C: book ( pages -- book )
+    dup delegate>gadget
+    [ set-book-pages ] keep
+    0 over show-page ;
+
+M: book pref-dim* ( book -- dim ) book-page pref-dim ;
+
+M: book layout* ( book -- )
+    dup rect-dim swap book-page set-gadget-dim ;
+
+: <tab> ( name n book -- button )
+    [ show-page drop ] curry curry
+    >r <label> r> <bevel-button> ;
+
+: make-tabs ( book names -- gadget )
+    dup length [ pick <tab> ] 2map make-shelf
+    dup highlight-theme nip ;
+
+TUPLE: tabs buttons book ;
+
+C: tabs dup delegate>frame ;
+
+: set-tabs ( names pages tabs -- )
+    {
+        { [ <book> tuck ] set-tabs-book @center }
+        { [ make-tabs ] set-tabs-buttons @top }
+    } build-frame ;
+
+: set-pages ( obj assoc tabs -- )
+    >r flip first2 swapd [ make-pane <scroller> ] map-with
+    r> set-tabs ;
+
+: <pages> ( obj assoc -- tabs ) <tabs> [ set-pages ] keep ;

library/ui/tiles.factor

@@ -0,0 +1,28 @@
+! Copyright (C) 2006 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+IN: gadgets-tiles
+USING: gadgets gadgets-buttons gadgets-labels gadgets-layouts
+gadgets-theme kernel sequences ;
+
+TUPLE: tile ;
+
+: find-tile [ tile? ] find-parent ;
+
+: <close-button> ( quot -- gadget | quot: tile -- )
+    { 0.0 0.0 0.0 1.0 } close-box <polygon-gadget>
+    [ find-tile ] rot append <bevel-button> ;
+
+: <closable-title> ( title quot -- gadget )
+    {
+        { [ <close-button> ] f @right }
+        { [ <label> ] f @center }
+    } make-frame ;
+
+: <title> ( title quot -- gadget | quot: tile -- )
+    [ <closable-title> ] [ <label> ] if* dup title-theme ;
+
+C: tile ( gadget title quot -- gadget )
+    {
+        { [ <title> ] f @top }
+        { [ ] f @center }
+    } make-frame* ;

library/ui/tracks.factor

@@ -1,8 +1,8 @@
 ! Copyright (C) 2006 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 IN: gadgets-tracks
-USING: gadgets gadgets-layouts gadgets-theme io kernel math
+USING: gadgets gadgets-layouts gadgets-theme generic io kernel
-namespaces sequences ;
+math namespaces sequences words ;
 
 TUPLE: divider ;
 
@@ -111,3 +111,24 @@ C: divider ( -- divider )
 
 : track-remove ( gadget track -- )
     [ gadget-children index ] keep track-remove@ ;
+
+: track-add-spec ( { quot setter loc } -- )
+    first2
+    >r call track get 2dup track-add
+    r> dup [ execute ] [ 3drop ] if ;
+
+: build-track ( track specs -- )
+    #! Specs is an array of triples { quot setter loc }.
+    #! The setter has stack effect ( new gadget -- ),
+    #! the loc is a ratio from 0 to 1.
+    [
+        swap track set
+        [ [ track-add-spec ] each ] keep
+        [ third ] map track get set-track-sizes
+    ] with-scope ;
+
+: make-track ( specs orientation -- gadget )
+    <track> [ swap build-track ] keep ;
+
+: make-track* ( gadget specs orientation -- gadget )
+    <track> pick [ set-delegate build-track ] keep ;

native/run.c

@@ -102,7 +102,7 @@ void run_callback(CELL quot)
 /* XT of deferred words */
 void undefined(F_WORD* word)
 {
-	general_error(ERROR_UNDEFINED_WORD,tag_object(word),F,true);
+	general_error(ERROR_UNDEFINED_WORD,tag_word(word),F,true);
 }
 
 /* XT of compound definitions */