Fix channels for recent changes

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 )
 <PRIVATE
 
 : wait ( channel -- )
-    [ channel-senders push stop ] curry callcc0 ;
+    [ channel-senders push ] curry
+    "channel send" suspend drop ;
 
 : (to) ( value receivers -- )
     delete-random resume-with yield ;
@@ -24,8 +26,8 @@ GENERIC: from ( channel -- value )
 : notify ( continuation channel -- channel )
     [ channel-receivers push ] keep ;
 
-: (from) ( senders -- * )
+: (from) ( senders -- )
-    delete-random continue ;
+    delete-random resume ;
 
 PRIVATE>
 
@@ -36,5 +38,5 @@ M: channel to ( value channel -- )
 M: channel from ( channel -- value )
     [
         notify channel-senders
-        dup empty? [ stop ] [ (from) ] if
+        dup empty? [ drop ] [ (from) ] if
-    ] curry callcc1 ;
+    ] curry "channel receive" suspend ;

extra/tools/interpreter/debug/debug.factor

@@ -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 -- )
-    <interpreter>
-    [ init-interpreter ] keep
-    run-interpreter
-    "datastack" get ;

extra/tools/interpreter/interpreter-docs.factor

@@ -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." } ;

extra/tools/interpreter/interpreter-tests.factor

@@ -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

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 [ <promise> ]
+           s [ f <model> ]
+           c [ f <model> ] |
+        [ s c start-walker-thread p fulfill break ]
+        quot compose
+
+        step-into-all
+        p ?promise
+        send-synchronous drop
+
+        c model-value continuation-data
+    ] ;

extra/tools/walker/interpreter-docs.factor

@@ -0,0 +1 @@
+

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

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 )
+: get-walker-thread ( -- thread )
-    interpreter-thread tget dup [
+    walker-thread tget [
-        walker-hook get
+        walker-hook get [ "No walker hook" throw ] or call
-        [ "No walker hook" throw ] or
+        walker-thread tget
-        interpreter-thread
     ] 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+
+: walk ( quot -- ) \ break add* call ;
-SYMBOL: +running+
-SYMBOL: +stopped+
-
-! Messages sent to interpreter thread
-SYMBOL: status
 
+! 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
-
-<PRIVATE
-
 ! Thread locals
-SYMBOL: interpreter-running?
+SYMBOL: walker-status
-SYMBOL: interpreter-stepping?
+SYMBOL: walker-continuation
-SYMBOL: interpreter-continuation
+SYMBOL: walker-history
-SYMBOL: interpreter-history
+
+SYMBOL: +running+
+SYMBOL: +suspended+
+SYMBOL: +stopped+
 
 : change-frame ( continuation quot -- continuation' )
     #! Applies quot to innermost call frame of the
@@ -112,7 +112,7 @@ M: word (step-into) (step-into-execute) ;
 {
     >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 -- )
+: status ( -- symbol )
-    +running+ interpreter-status tget set-model ;
+    walker-status tget model-value ;
+
+: set-status ( symbol -- )
+    walker-status tget set-model ;
 
 : detach-msg ( -- f )
-    +detached+ status-change
+    +stopped+ set-status ;
-    f interpreter-stepping? tset
-    f interpreter-running? tset
-    f ;
 
-: continuation-msg ( -- continuation )
+: keep-running ( continuation -- continuation )
-    interpreter-thread tget thread-continuation box-value ;
+    +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 -- )
+: step-into-all-loop ( -- )
-    dup interpreter-continuation tget set-model
+    +running+ set-status
-    interpreter-history tget push ;
+    [ status +stopped+ eq? not ] [
-
-: handle-command ( continuation -- continuation' )
-    t interpreter-stepping? tset
-    [ interpreter-stepping? tget ] [
         [
             {
-                ! These are sent by the walker tool. We reply and
-                ! keep cycling.
-                { status [ +suspended+ ] }
                 { detach [ detach-msg ] }
-                { get-thread [ interpreter-thread tget ] }
+                { step [ f ] }
-                { get-continuation [ dup ] }
+                { 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 [ step-msg keep-running ] }
-                { step-out [ (step-out) keep-running ] }
+                { step-out [ step-out-msg keep-running ] }
-                { step-into [ (step-into) 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
+    ] [ ] while ;
-    dup continuation? [ dup save-continuation ] when ;
 
-: interpreter-stopped ( -- )
+: walker-loop ( -- )
-    [
+    +running+ set-status
-        {
+    [ status +stopped+ eq? not ] [
-            { 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 ] [
         [
-            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 [ walker-stopped f ] }
-                { f [ interpreter-stopped ] }
                 ! thread hit a breakpoint and sent us the
-                ! continuation, so we modify it and send it back.
+                ! continuation, so we modify it and send it
-                [ handle-command ]
+                ! 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' )
     [
-        [
+        walker-continuation tset
-            interpreter-thread tset
+        walker-status tset
-            t interpreter-running tset
+        V{ } clone walker-history tset
-            f interpreter-stepping tset
+        walker-loop
-            f <model> interpreter-continuation tset
+    ] 2curry
-            V{ } clone interpreter-history tset
+    "Walker on " self thread-name append spawn
-            interpreter-loop
+    [ associate-thread ] keep ;
-        ] curry
-    ] keep
-    "Interpreter for " over thread-name append spawn
-    dup rot set-thread-;