diff --git a/library/tools/describe.factor b/library/tools/describe.factor index 1637c9e2fe..cbb30df204 100644 --- a/library/tools/describe.factor +++ b/library/tools/describe.factor @@ -76,7 +76,7 @@ DEFER: describe : describe ( object -- ) dup summary print sheet sheet. ; -: stack. ( seq -- seq ) >array describe ; +: stack. ( seq -- seq ) >array sheet sheet. ; : .s datastack stack. ; : .r retainstack stack. ; diff --git a/library/tools/interpreter.factor b/library/tools/interpreter.factor index c179b80c80..fac7c20f52 100644 --- a/library/tools/interpreter.factor +++ b/library/tools/interpreter.factor @@ -29,6 +29,9 @@ SYMBOL: callframe SYMBOL: callframe-scan SYMBOL: callframe-end +: meta-callframe ( -- seq ) + { callframe callframe-scan callframe-end } [ get ] map ; + ! Callframe. : up ( -- ) pop-c callframe-end set diff --git a/library/tools/walker.factor b/library/tools/walker.factor index e04af60b55..9f862b090d 100644 --- a/library/tools/walker.factor +++ b/library/tools/walker.factor @@ -9,10 +9,7 @@ vectors words ; : &r ( -- ) meta-r get stack. ; -: meta-c* - [ - meta-c get % { callframe callframe-scan callframe-end } [ get , ] each - ] { } make ; +: meta-c* ( -- seq ) meta-c get meta-callframe append ; : &c ( -- ) meta-c* callstack. ; @@ -42,5 +39,5 @@ vectors words ; : walk ( quot -- ) continuation [ set-meta-interp pop-d drop (meta-call) - set-walk-hooks walk-banner listener end-walk + set-walk-hooks walk-banner (listener) end-walk ] with-scope ; diff --git a/library/ui/tools/listener.factor b/library/ui/tools/listener.factor index c9c96508c9..492eca4419 100644 --- a/library/ui/tools/listener.factor +++ b/library/ui/tools/listener.factor @@ -3,52 +3,40 @@ IN: gadgets-listener USING: arrays gadgets gadgets-editors gadgets-frames gadgets-labels gadgets-panes gadgets-presentations -gadgets-scrolling gadgets-theme generic hashtables inspector io -jedit kernel listener math models namespaces parser prettyprint -sequences styles threads words ; +gadgets-scrolling gadgets-theme gadgets-tiles gadgets-tracks +generic hashtables inspector io jedit kernel listener math +models namespaces parser prettyprint sequences shells styles +threads words ; TUPLE: listener-gadget pane stack ; -: usable-words ( -- words ) - use get hash-concat hash-values ; - -: word-completion ( pane -- ) - usable-words swap pane-input set-possibilities ; - -: show-stack ( seq pack -- ) - dup clear-gadget [ - dup empty? [ - "Empty stack" write drop - ] [ - "Stack top: " write - [ [ unparse-short ] keep write-object bl ] each bl - ] if - ] with-stream* ; - : ui-listener-hook ( listener -- ) - [ - >r datastack-hook get call r> - listener-gadget-stack show-stack - ] keep - listener-gadget-pane word-completion ; + >r datastack-hook get call r> + listener-gadget-stack set-model ; : listener-thread ( listener -- ) dup listener-gadget-pane [ - [ ui-listener-hook ] curry listener-hook set - print-banner listener + [ ui-listener-hook ] curry listener-hook set tty ] with-stream* ; -: ( -- gadget ) dup highlight-theme ; - : start-listener ( listener -- ) [ >r clear r> init-namespaces listener-thread ] in-thread drop ; +: ( model quot title -- gadget ) + >r r> f ; + +: ( model title -- gadget ) + [ stack. ] swap ; + +: ( -- gadget ) + gadget get listener-gadget-stack "Stack" ; + C: listener-gadget ( -- gadget ) - { - { [ ] set-listener-gadget-stack f @top } - { [ ] set-listener-gadget-pane [ ] @center } - } make-frame* dup start-listener ; + f over set-listener-gadget-stack { + { [ ] set-listener-gadget-pane [ ] 5/6 } + { [ ] f f 1/6 } + } { 0 1 } make-track* dup start-listener ; M: listener-gadget pref-dim* delegate pref-dim* { 600 600 } vmax ; diff --git a/library/ui/tools/walker.factor b/library/ui/tools/walker.factor new file mode 100644 index 0000000000..ac566d462b --- /dev/null +++ b/library/ui/tools/walker.factor @@ -0,0 +1,106 @@ +! Copyright (C) 2006 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +IN: gadgets-walker +USING: gadgets gadgets-buttons gadgets-frames gadgets-listener +gadgets-panes gadgets-scrolling gadgets-tiles gadgets-tracks +generic inspector interpreter io kernel listener math models +namespaces sequences shells threads ; + +TUPLE: stack-track ; + +C: stack-track ( cs rs ds -- gadget ) + { + { [ "Data stack" ] f f 1/3 } + { [ "Retain stack" ] f f 1/3 } + { [ [ callstack. ] "Call stack" ] f f 1/3 } + } { 1 0 } make-track* ; + +TUPLE: walker-track pane ; + +: ( quot -- gadget ) + [ [ first2 callframe. ] when* ] + "Current quotation" ; + +C: walker-track ( cs rs ds quot -- gadget ) + { + { [ ] f f 1/6 } + { [ ] f f 1/6 } + { [ ] set-walker-track-pane [ ] 2/3 } + } { 0 1 } make-track* ; + +TUPLE: walker-gadget track ds rs cs quot ; + +: find-walker-gadget [ walker-gadget? ] find-parent ; + +: walker-gadget-pane walker-gadget-track walker-track-pane ; + +: walker-command ( button word -- ) + unit swap find-walker-gadget walker-gadget-pane pane-call ; + +: step ( -- ) next do-1 ; + +: into ( -- ) next do ; + +: end ( -- ) save-callframe meta-interp continue ; + +: ( -- gadget ) + { + { "Step over" step } + { "Step into" into } + { "Continue" end } + } [ + [ + first2 [ walker-command ] curry , + ] each + ] make-toolbar ; + +: init-walker-models ( walker -- ) + f over set-walker-gadget-ds + f over set-walker-gadget-rs + f over set-walker-gadget-cs + f swap set-walker-gadget-quot ; + +: walker-models ( -- cs rs ds quot ) + gadget get walker-gadget-cs + gadget get walker-gadget-rs + gadget get walker-gadget-ds + gadget get walker-gadget-quot ; + +: walker-listener-hook ( walker -- ) + meta-d get over walker-gadget-ds set-model + meta-r get over walker-gadget-rs set-model + meta-c get over walker-gadget-cs set-model + meta-callframe swap walker-gadget-quot set-model ; + +C: walker-gadget ( -- gadget ) + dup init-walker-models { + { [ ] f f @top } + { [ walker-models ] set-walker-gadget-track f @center } + } make-frame* ; + +M: walker-gadget gadget-title + drop "Single stepper" ; + +M: walker-gadget pref-dim* + delegate pref-dim* { 600 600 } vmax ; + +M: walker-gadget focusable-child* ( listener -- gadget ) + walker-gadget-pane ; + +: walker ( quot continuation -- ) + "walk " listener-prompt set + set-meta-interp pop-d drop (meta-call) + clear (listener) end ; + +: walker-thread ( quot continuation walker -- ) + dup walker-gadget-pane [ + [ walker-listener-hook ] curry listener-hook set + walker + ] with-pane ; + +: start-walker ( quot continuation walker -- ) + [ init-namespaces walker-thread ] in-thread 3drop ; + +: walk ( quot -- ) + continuation dup open-window + start-walker ;