From 27656fe0e3ae8b80bc10fd6591b99de7548b87e8 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 20 Feb 2008 23:13:22 -0600 Subject: [PATCH] Fix channels for recent changes --- extra/channels/channels.factor | 14 +- extra/tools/interpreter/debug/debug.factor | 31 --- .../tools/interpreter/interpreter-docs.factor | 54 ------ .../interpreter/interpreter-tests.factor | 113 ----------- .../tools/{interpreter => walker}/authors.txt | 0 .../{interpreter => walker}/debug/authors.txt | 0 extra/tools/walker/debug/debug.factor | 19 ++ extra/tools/walker/interpreter-docs.factor | 1 + .../tools/{interpreter => walker}/summary.txt | 0 extra/tools/walker/walker-tests.factor | 106 ++++++++++ .../walker.factor} | 181 +++++++++--------- 11 files changed, 227 insertions(+), 292 deletions(-) delete mode 100644 extra/tools/interpreter/debug/debug.factor delete mode 100644 extra/tools/interpreter/interpreter-docs.factor delete mode 100755 extra/tools/interpreter/interpreter-tests.factor rename extra/tools/{interpreter => walker}/authors.txt (100%) rename extra/tools/{interpreter => walker}/debug/authors.txt (100%) create mode 100755 extra/tools/walker/debug/debug.factor create mode 100755 extra/tools/walker/interpreter-docs.factor rename extra/tools/{interpreter => walker}/summary.txt (100%) create mode 100755 extra/tools/walker/walker-tests.factor rename extra/tools/{interpreter/interpreter.factor => walker/walker.factor} (54%) diff --git a/extra/channels/channels.factor b/extra/channels/channels.factor index 01f810b8e3..8fe36ab454 100755 --- a/extra/channels/channels.factor +++ b/extra/channels/channels.factor @@ -2,7 +2,8 @@ ! See http://factorcode.org/license.txt for BSD license. ! ! Channels - based on ideas from newsqueak -USING: kernel sequences sequences.lib threads continuations random math ; +USING: kernel sequences sequences.lib threads continuations +random math ; IN: channels TUPLE: channel receivers senders ; @@ -16,7 +17,8 @@ GENERIC: from ( channel -- value ) @@ -36,5 +38,5 @@ M: channel to ( value channel -- ) M: channel from ( channel -- value ) [ notify channel-senders - dup empty? [ stop ] [ (from) ] if - ] curry callcc1 ; + dup empty? [ drop ] [ (from) ] if + ] curry "channel receive" suspend ; diff --git a/extra/tools/interpreter/debug/debug.factor b/extra/tools/interpreter/debug/debug.factor deleted file mode 100644 index 438734773f..0000000000 --- a/extra/tools/interpreter/debug/debug.factor +++ /dev/null @@ -1,31 +0,0 @@ -! Copyright (C) 2004, 2007 Slava Pestov. -! See http://factorcode.org/license.txt for BSD license. -USING: tools.interpreter kernel arrays continuations threads -sequences namespaces ; -IN: tools.interpreter.debug - -: run-interpreter ( interpreter -- ) - dup interpreter-continuation [ - dup step-into run-interpreter - ] [ - drop - ] if ; - -: quot>cont ( quot -- cont ) - [ - swap [ - continue-with - ] curry callcc0 call stop - ] curry callcc1 ; - -: init-interpreter ( quot interpreter -- ) - >r - [ datastack "datastack" set ] compose quot>cont - f swap 2array - r> restore ; - -: test-interpreter ( quot -- ) - - [ init-interpreter ] keep - run-interpreter - "datastack" get ; diff --git a/extra/tools/interpreter/interpreter-docs.factor b/extra/tools/interpreter/interpreter-docs.factor deleted file mode 100644 index cb4b207fd9..0000000000 --- a/extra/tools/interpreter/interpreter-docs.factor +++ /dev/null @@ -1,54 +0,0 @@ -USING: help.markup help.syntax kernel generic -math hashtables quotations classes continuations ; -IN: tools.interpreter - -ARTICLE: "meta-interpreter" "Meta-circular interpreter" -"The meta-circular interpreter is used to implement the walker tool in the UI. If you are simply interested in single stepping through a piece of code, use the " { $link "ui-walker" } "." -$nl -"On the other hand, if you want to implement a similar tool yourself, then you can use the words described in this section." -$nl -"Meta-circular interpreter words are found in the " { $vocab-link "tools.interpreter" } " vocabulary." -$nl -"Breakpoints can be inserted in user code:" -{ $subsection break } -"Breakpoints invoke a hook:" -{ $subsection break-hook } -"Single stepping with the meta-circular interpreter:" -{ $subsection step } -{ $subsection step-into } -{ $subsection step-out } -{ $subsection step-all } ; - -ABOUT: "meta-interpreter" - -HELP: interpreter -{ $class-description "An interpreter instance." } ; - -HELP: step -{ $values { "interpreter" interpreter } } -{ $description "Evaluates the object in the single stepper using Factor evaluation semantics:" - { $list - { "If the object is a " { $link wrapper } ", then the wrapped object is pushed on the single stepper's data stack" } - { "If the object is a word, then the word is executed in the single stepper's continuation atomically" } - { "Otherwise, the object is pushed on the single stepper's data stack" } - } -} ; - -HELP: step-into -{ $values { "interpreter" interpreter } } -{ $description "Evaluates the object in the single stepper using Factor evaluation semantics:" - { $list - { "If the object is a " { $link wrapper } ", then the wrapped object is pushed on the single stepper's data stack" } - { "If the object is a compound word, then the single stepper enters the word definition" } - { "If the object is a primitive word or a word with special single stepper behavior, it is executed in the single stepper's continuation atomically" } - { "Otherwise, the object is pushed on the single stepper's data stack" } - } -} ; - -HELP: step-out -{ $values { "interpreter" interpreter } } -{ $description "Evaluates the remainder of the current quotation in the single stepper." } ; - -HELP: step-all -{ $values { "interpreter" interpreter } } -{ $description "Executes the remainder of the single stepper's continuation. This effectively ends single stepping unless the continuation invokes " { $link break } " at a later point in time." } ; diff --git a/extra/tools/interpreter/interpreter-tests.factor b/extra/tools/interpreter/interpreter-tests.factor deleted file mode 100755 index 644f83c2ca..0000000000 --- a/extra/tools/interpreter/interpreter-tests.factor +++ /dev/null @@ -1,113 +0,0 @@ -USING: tools.interpreter io io.streams.string kernel math -math.private namespaces prettyprint sequences tools.test -continuations math.parser threads arrays -tools.interpreter.private tools.interpreter.debug ; -IN: temporary - -[ "Ooops" throw ] break-hook set - -[ { } ] [ - [ ] test-interpreter -] unit-test - -[ { 1 } ] [ - [ 1 ] test-interpreter -] unit-test - -[ { 1 2 3 } ] [ - [ 1 2 3 ] test-interpreter -] unit-test - -[ { "Yo" 2 } ] [ - [ 2 >r "Yo" r> ] test-interpreter -] unit-test - -[ { 2 } ] [ - [ t [ 2 ] [ "hi" ] if ] test-interpreter -] unit-test - -[ { "hi" } ] [ - [ f [ 2 ] [ "hi" ] if ] test-interpreter -] unit-test - -[ { 4 } ] [ - [ 2 2 fixnum+ ] test-interpreter -] unit-test - -: foo 2 2 fixnum+ ; - -[ { 8 } ] [ - [ foo 4 fixnum+ ] test-interpreter -] unit-test - -[ { C{ 1 1.5 } { } C{ 1 1.5 } { } } ] [ - [ C{ 1 1.5 } { } 2dup ] test-interpreter -] unit-test - -[ { t } ] [ - [ 5 5 number= ] test-interpreter -] unit-test - -[ { f } ] [ - [ 5 6 number= ] test-interpreter -] unit-test - -[ { f } ] [ - [ "XYZ" "XYZ" mismatch ] test-interpreter -] unit-test - -[ { t } ] [ - [ "XYZ" "XYZ" sequence= ] test-interpreter -] unit-test - -[ { t } ] [ - [ "XYZ" "XYZ" = ] test-interpreter -] unit-test - -[ { f } ] [ - [ "XYZ" "XuZ" = ] test-interpreter -] unit-test - -[ { 4 } ] [ - [ 2 2 + ] test-interpreter -] unit-test - -[ { } 2 ] [ - 2 "x" set [ [ 3 "x" set ] with-scope ] test-interpreter "x" get -] unit-test - -[ { 3 } ] [ - [ 3 "x" set "x" get ] test-interpreter -] unit-test - -[ { "hi\n" } ] [ - [ [ "hi" print ] with-string-writer ] test-interpreter -] unit-test - -[ { "4\n" } ] [ - [ [ 2 2 + number>string print ] with-string-writer ] test-interpreter -] unit-test - -[ { 1 2 3 } ] [ - [ { 1 2 3 } set-datastack ] test-interpreter -] unit-test - -[ { 6 } ] -[ [ 3 [ nip continue ] callcc0 2 * ] test-interpreter ] unit-test - -[ { 6 } ] -[ [ [ 3 swap continue-with ] callcc1 2 * ] test-interpreter ] unit-test - -[ { } ] -[ [ [ ] [ ] recover ] test-interpreter ] unit-test - -[ { 6 } ] -[ [ [ 3 throw ] [ 2 * ] recover ] test-interpreter ] unit-test - -[ { "{ 1 2 3 }\n" } ] [ - [ [ { 1 2 3 } . ] with-string-writer ] test-interpreter -] unit-test - -[ { } ] [ - [ "a" "b" set "c" "d" set [ ] test-interpreter ] with-scope -] unit-test diff --git a/extra/tools/interpreter/authors.txt b/extra/tools/walker/authors.txt similarity index 100% rename from extra/tools/interpreter/authors.txt rename to extra/tools/walker/authors.txt diff --git a/extra/tools/interpreter/debug/authors.txt b/extra/tools/walker/debug/authors.txt similarity index 100% rename from extra/tools/interpreter/debug/authors.txt rename to extra/tools/walker/debug/authors.txt diff --git a/extra/tools/walker/debug/debug.factor b/extra/tools/walker/debug/debug.factor new file mode 100755 index 0000000000..e1482be796 --- /dev/null +++ b/extra/tools/walker/debug/debug.factor @@ -0,0 +1,19 @@ +! Copyright (C) 2004, 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: concurrency.promises models tools.walker kernel +sequences concurrency.messaging locals ; +IN: tools.walker.debug + +:: test-walker | quot | + [let | p [ ] + s [ f ] + c [ f ] | + [ s c start-walker-thread p fulfill break ] + quot compose + + step-into-all + p ?promise + send-synchronous drop + + c model-value continuation-data + ] ; diff --git a/extra/tools/walker/interpreter-docs.factor b/extra/tools/walker/interpreter-docs.factor new file mode 100755 index 0000000000..8b13789179 --- /dev/null +++ b/extra/tools/walker/interpreter-docs.factor @@ -0,0 +1 @@ + diff --git a/extra/tools/interpreter/summary.txt b/extra/tools/walker/summary.txt similarity index 100% rename from extra/tools/interpreter/summary.txt rename to extra/tools/walker/summary.txt diff --git a/extra/tools/walker/walker-tests.factor b/extra/tools/walker/walker-tests.factor new file mode 100755 index 0000000000..6081ef1a65 --- /dev/null +++ b/extra/tools/walker/walker-tests.factor @@ -0,0 +1,106 @@ +USING: tools.walker io io.streams.string kernel math +math.private namespaces prettyprint sequences tools.test +continuations math.parser threads arrays tools.walker.debug ; +IN: temporary + +[ { } ] [ + [ ] test-walker +] unit-test + +[ { 1 } ] [ + [ 1 ] test-walker +] unit-test + +[ { 1 2 3 } ] [ + [ 1 2 3 ] test-walker +] unit-test + +[ { "Yo" 2 } ] [ + [ 2 >r "Yo" r> ] test-walker +] unit-test + +[ { 2 } ] [ + [ t [ 2 ] [ "hi" ] if ] test-walker +] unit-test + +[ { "hi" } ] [ + [ f [ 2 ] [ "hi" ] if ] test-walker +] unit-test + +[ { 4 } ] [ + [ 2 2 fixnum+ ] test-walker +] unit-test + +: foo 2 2 fixnum+ ; + +[ { 8 } ] [ + [ foo 4 fixnum+ ] test-walker +] unit-test + +[ { C{ 1 1.5 } { } C{ 1 1.5 } { } } ] [ + [ C{ 1 1.5 } { } 2dup ] test-walker +] unit-test + +[ { t } ] [ + [ 5 5 number= ] test-walker +] unit-test + +[ { f } ] [ + [ 5 6 number= ] test-walker +] unit-test + +[ { f } ] [ + [ "XYZ" "XYZ" mismatch ] test-walker +] unit-test + +[ { t } ] [ + [ "XYZ" "XYZ" sequence= ] test-walker +] unit-test + +[ { t } ] [ + [ "XYZ" "XYZ" = ] test-walker +] unit-test + +[ { f } ] [ + [ "XYZ" "XuZ" = ] test-walker +] unit-test + +[ { 4 } ] [ + [ 2 2 + ] test-walker +] unit-test + +[ { 3 } ] [ + [ [ 3 "x" set "x" get ] with-scope ] test-walker +] unit-test + +[ { "hi\n" } ] [ + [ [ "hi" print ] with-string-writer ] test-walker +] unit-test + +[ { "4\n" } ] [ + [ [ 2 2 + number>string print ] with-string-writer ] test-walker +] unit-test + +[ { 1 2 3 } ] [ + [ { 1 2 3 } set-datastack ] test-walker +] unit-test + +[ { 6 } ] +[ [ 3 [ nip continue ] callcc0 2 * ] test-walker ] unit-test + +[ { 6 } ] +[ [ [ 3 swap continue-with ] callcc1 2 * ] test-walker ] unit-test + +[ { } ] +[ [ [ ] [ ] recover ] test-walker ] unit-test + +[ { 6 } ] +[ [ [ 3 throw ] [ 2 * ] recover ] test-walker ] unit-test + +[ { "{ 1 2 3 }\n" } ] [ + [ [ { 1 2 3 } . ] with-string-writer ] test-walker +] unit-test + +[ { } ] [ + [ "a" "b" set "c" "d" set [ ] test-walker ] with-scope +] unit-test diff --git a/extra/tools/interpreter/interpreter.factor b/extra/tools/walker/walker.factor similarity index 54% rename from extra/tools/interpreter/interpreter.factor rename to extra/tools/walker/walker.factor index ed640918cb..70f4a845ba 100755 --- a/extra/tools/interpreter/interpreter.factor +++ b/extra/tools/walker/walker.factor @@ -1,54 +1,54 @@ -: walk ( quot -- ) \ break add* call ; +! Copyright (C) 2004, 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: threads kernel namespaces continuations combinators +sequences math namespaces.private continuations.private +concurrency.messaging quotations kernel.private words +sequences.private assocs models ; +IN: tools.walker SYMBOL: walker-hook ! Thread local -SYMBOL: interpreter-thread +SYMBOL: walker-thread -: get-interpreter-thread ( -- thread ) - interpreter-thread tget dup [ - walker-hook get - [ "No walker hook" throw ] or - interpreter-thread +: get-walker-thread ( -- thread ) + walker-thread tget [ + walker-hook get [ "No walker hook" throw ] or call + walker-thread tget ] unless* ; : break ( -- ) callstack [ - over set-continuation-callstack + over set-continuation-call - interpreter-thread send-synchronous { + get-walker-thread send-synchronous { { [ dup continuation? ] [ (continue) ] } { [ dup quotation? ] [ call ] } { [ dup not ] [ "Single stepping abandoned" throw ] } } cond ] curry callcc0 ; -SYMBOL: +suspended+ -SYMBOL: +running+ -SYMBOL: +stopped+ - -! Messages sent to interpreter thread -SYMBOL: status +: walk ( quot -- ) \ break add* call ; +! Messages sent to walker thread SYMBOL: step SYMBOL: step-out SYMBOL: step-into SYMBOL: step-all +SYMBOL: step-into-all SYMBOL: step-back SYMBOL: detach SYMBOL: abandon SYMBOL: call-in -SYMBOL: get-thread -SYMBOL: get-continuation - -n ndrop >c c> continue continue-with - (continue-with) stop yield suspend sleep (spawn) + stop yield suspend sleep (spawn) suspend } [ dup [ execute break ] curry @@ -126,102 +126,107 @@ M: word (step-into) (step-into-execute) ; swap cut [ swap % unclip literalize , \ (step-into) , % ] [ ] make - ] (step) ; + ] change-frame ; -: status-change ( symbol -- ) - +running+ interpreter-status tget set-model ; +: status ( -- symbol ) + walker-status tget model-value ; + +: set-status ( symbol -- ) + walker-status tget set-model ; : detach-msg ( -- f ) - +detached+ status-change - f interpreter-stepping? tset - f interpreter-running? tset - f ; + +stopped+ set-status ; -: continuation-msg ( -- continuation ) - interpreter-thread tget thread-continuation box-value ; +: keep-running ( continuation -- continuation ) + +running+ set-status + dup continuation? [ dup walker-history tget push ] when ; -: keep-running f interpreter-stepping? tset ; +: walker-stopped ( -- ) + +stopped+ set-status + [ + { + { detach [ detach-msg ] } + [ drop f ] + } case + ] handle-synchronous + walker-stopped ; -: save-continuation ( continuation -- ) - dup interpreter-continuation tget set-model - interpreter-history tget push ; - -: handle-command ( continuation -- continuation' ) - t interpreter-stepping? tset - [ interpreter-stepping? tget ] [ +: step-into-all-loop ( -- ) + +running+ set-status + [ status +stopped+ eq? not ] [ [ { - ! These are sent by the walker tool. We reply and - ! keep cycling. - { status [ +suspended+ ] } { detach [ detach-msg ] } - { get-thread [ interpreter-thread tget ] } - { get-continuation [ dup ] } + { step [ f ] } + { step-out [ f ] } + { step-into [ f ] } + { step-all [ f ] } + { step-into-all [ f ] } + { step-back [ f ] } + { f [ walker-stopped ] } + [ step-into-msg ] + } case + ] handle-synchronous + ] [ ] while ; + +: walker-suspended ( continuation -- continuation' ) + +suspended+ set-status + [ status +suspended+ eq? ] [ + [ + { + ! These are sent by the walker tool. We reply + ! and keep cycling. + { detach [ detach-msg ] } ! These change the state of the thread being ! interpreted, so we modify the continuation and ! output f. - { step [ (step) keep-running ] } - { step-out [ (step-out) keep-running ] } - { step-into [ (step-into) keep-running ] } + { step [ step-msg keep-running ] } + { step-out [ step-out-msg keep-running ] } + { step-into [ step-into-msg keep-running ] } { step-all [ keep-running ] } + { step-into-all [ step-into-all-loop ] } { abandon [ drop f keep-running ] } ! Pass quotation to debugged thread { call-in [ nip keep-running ] } ! Pass previous continuation to debugged thread - { step-back [ drop interpreter-history tget pop f ] } + { step-back [ drop walker-history tget pop f ] } } case ] handle-synchronous - ] [ ] while - dup continuation? [ dup save-continuation ] when ; + ] [ ] while ; -: interpreter-stopped ( -- ) - [ - { - { detach [ detach-msg ] } - { status [ +stopped+ ] } - { get-thread [ interpreter-thread tget ] } - { get-continuation [ f ] } - [ drop f ] - } case - ] handle-synchronous - interpreter-stopped ; - -: interpreter-loop ( -- ) - [ interpreter-running? tget ] [ +: walker-loop ( -- ) + +running+ set-status + [ status +stopped+ eq? not ] [ [ - status-change { { detach [ detach-msg ] } - { get-thread [ interpreter-thread tget ] } - { get-continuation [ f ] } ! ignore these commands while the thread is ! running { step [ f ] } { step-out [ f ] } { step-into [ f ] } { step-all [ f ] } + { step-into-all [ step-into-all-loop ] } { step-back [ f ] } - ! thread has exited so we exit the monitor too - { f [ interpreter-stopped ] } + { f [ walker-stopped f ] } ! thread hit a breakpoint and sent us the - ! continuation, so we modify it and send it back. - [ handle-command ] + ! continuation, so we modify it and send it + ! back. + [ walker-suspended ] } case ] handle-synchronous - ] [ ] while; + ] [ ] while ; -PRIVATE> +: associate-thread ( walker -- ) + dup walker-thread tset + [ f swap send ] curry self set-thread-exit-handler ; -: start-interpreter-thread ( thread -- thread' ) +: start-walker-thread ( status continuation -- thread' ) [ - [ - interpreter-thread tset - t interpreter-running tset - f interpreter-stepping tset - f interpreter-continuation tset - V{ } clone interpreter-history tset - interpreter-loop - ] curry - ] keep - "Interpreter for " over thread-name append spawn - dup rot set-thread-; + walker-continuation tset + walker-status tset + V{ } clone walker-history tset + walker-loop + ] 2curry + "Walker on " self thread-name append spawn + [ associate-thread ] keep ;