diff --git a/library/continuations.factor b/library/continuations.factor index e3c43a1a05..e3a973721b 100644 --- a/library/continuations.factor +++ b/library/continuations.factor @@ -53,3 +53,10 @@ TUPLE: continuation data retain call name catch ; : continue-with ( obj continuation -- ) swap 9 setenv continue ; inline + +M: continuation clone + [ continuation-data clone ] keep + [ continuation-retain clone ] keep + [ continuation-call clone ] keep + [ continuation-name clone ] keep + continuation-catch clone ; diff --git a/library/tools/interpreter.factor b/library/tools/interpreter.factor index 25636d9ccb..1119f1c844 100644 --- a/library/tools/interpreter.factor +++ b/library/tools/interpreter.factor @@ -2,11 +2,10 @@ ! See http://factorcode.org/license.txt for BSD license. IN: interpreter USING: arrays errors generic io kernel kernel-internals math -namespaces prettyprint sequences strings threads vectors words ; +namespaces prettyprint sequences strings threads vectors words +hashtables ; -! A Factor interpreter written in Factor. It can transfer the -! continuation to and from the primary interpreter. Used by -! compiler for partial evaluation, also by the walker. +! Metacircular interpreter for single-stepping SYMBOL: meta-interp @@ -74,7 +73,7 @@ SYMBOL: callframe-end save-callframe (meta-call) ; : ( quot -- seq ) - 0 over length 3array ; + 0 over length 3array >vector ; : catch-harness ( continuation -- quot ) [ [ c> 2array ] % , \ continue-with , ] [ ] make ; @@ -138,17 +137,45 @@ M: object do do-1 ; \ if [ pop-d pop-d pop-d [ nip ] [ drop ] if meta-call ] "meta-word" set-word-prop \ dispatch [ pop-d pop-d swap nth meta-call ] "meta-word" set-word-prop -: step ( -- ) [ do-1 ] next ; +! Time travel +SYMBOL: meta-history -: step-in ( -- ) [ do ] next ; +: save-interp ( -- ) + meta-history get [ + [ + callframe [ ] change + callframe-scan [ ] change + callframe-end [ ] change + meta-interp [ clone ] change + ] make-hash swap push + ] when* ; + +: restore-interp ( ns -- ) + { callframe callframe-scan callframe-end } + [ dup pick hash swap set ] each + meta-interp swap hash clone meta-interp set ; + +: step ( -- ) save-interp [ do-1 ] next ; + +: step-in ( -- ) save-interp [ do ] next ; : step-out ( -- ) + save-interp callframe get callframe-scan get tail host-quot [ ] (meta-call) ; : step-all ( -- ) + save-interp save-callframe - meta-c [ V{ [ stop ] 0 1 } swap append ] change - meta-interp get schedule-thread yield - V{ } clone meta-c set + [ stop ] meta-c append + meta-interp get [ set-continuation-call ] keep + schedule-thread yield + meta-c delete-all [ ] (meta-call) ; + +: step-back ( -- ) + meta-history get dup empty? [ + drop + ] [ + pop restore-interp + ] if ; diff --git a/library/ui/text/interactor.factor b/library/ui/text/interactor.factor index ed54c0015d..d9fa83f957 100644 --- a/library/ui/text/interactor.factor +++ b/library/ui/text/interactor.factor @@ -62,7 +62,6 @@ SYMBOL: structured-input : interactor-history. ( interactor -- ) dup interactor-output [ - "History:" print interactor-history [ dup print-input ] each ] with-stream* ; @@ -79,8 +78,8 @@ SYMBOL: structured-input interactor H{ { T{ key-down f f "RETURN" } [ interactor-commit ] } + { T{ key-down f { A+ } "c" } [ dup [ interactor-output pane-clear ] curry swap interactor-call ] } { T{ key-down f { C+ } "h" } [ dup [ interactor-history. ] curry swap interactor-call ] } - { T{ key-down f { C+ } "b" } [ dup [ interactor-output pane-clear ] curry swap interactor-call ] } { T{ key-down f { C+ } "d" } [ f swap interactor-eval ] } { T{ key-down f { C+ } "i" } [ "infer ." quot-action ] } { T{ key-down f { C+ } "w" } [ "walk" quot-action ] } diff --git a/library/ui/tools/walker.factor b/library/ui/tools/walker.factor index 4bfbcbd47f..75e9a04fdb 100644 --- a/library/ui/tools/walker.factor +++ b/library/ui/tools/walker.factor @@ -46,23 +46,24 @@ TUPLE: walker-gadget track ds rs cs quot ns ; meta-c over walker-gadget-cs set-model meta-callframe swap walker-gadget-quot set-model ; -: with-walker ( walker quot -- ) - swap dup walker-gadget-ns +: with-walker ( gadget quot -- ) + swap find-walker-gadget + dup walker-gadget-ns [ slip update-stacks ] bind ; inline -: walker-command ( button word -- ) - >r find-walker-gadget r> unit with-walker ; +: walker-step [ step ] with-walker ; +: walker-step-in [ step-in ] with-walker ; +: walker-step-out [ step-out ] with-walker ; +: walker-step-all [ step-all ] with-walker ; +: walker-step-back [ step-back ] with-walker ; : ( -- gadget ) - { - { "Step" step } - { "Step in" step-in } - { "Step out" step-out } - { "Continue" step-all } - } [ - [ - first2 [ walker-command ] curry , - ] each + [ + "Step" [ walker-step ] , + "Step in" [ walker-step-in ] , + "Step out" [ walker-step-out ] , + "Continue" [ walker-step-all ] , + "Step back" [ walker-step-back ] , ] make-toolbar ; : init-walker-models ( walker -- ) @@ -98,6 +99,7 @@ M: walker-gadget focusable-child* : init-walker ( walker -- ) H{ } clone over set-walker-gadget-ns walker-continuation swap [ + V{ } clone meta-history set meta-interp set [ ] (meta-call) ] with-walker ; @@ -128,10 +130,11 @@ C: walker-gadget ( -- gadget ) dup walker-thread ; \ walker-gadget H{ - { T{ key-down f { C+ } "s" } [ \ step walker-command ] } - { T{ key-down f { C+ } "n" } [ \ step-in walker-command ] } - { T{ key-down f { C+ } "o" } [ \ step-out walker-command ] } - { T{ key-down f { C+ } "l" } [ \ step-all walker-command ] } + { T{ key-down f { C+ } "s" } [ walker-step ] } + { T{ key-down f { C+ } "n" } [ walker-step-in ] } + { T{ key-down f { C+ } "o" } [ walker-step-out ] } + { T{ key-down f { C+ } "r" } [ walker-step-all ] } + { T{ key-down f { C+ } "b" } [ walker-step-back ] } } set-gestures : walker-tool