adding trace, step, stack inference to cvs, rearranging some stuff

TODO.FACTOR.txt

@@ -1,6 +1,11 @@
 - add a socket timeout
-- fix error postoning -- not all errors thrown by i/o code are
+- compiling when*
-  postponed
+- compiling unless*
+- getenv/setenv: if literal arg, compile as a load/store
+- inline words
+- alist -vs- assoc terminology
+- compiler: drop literal peephole optimization
+- [ 2 2 . ] run fails
 
 + compiler/ffi:
 
@@ -10,11 +15,6 @@
 - struct membres that are not *
 - float types
 - compile word twice; no more 'cannot compile' error!
-- compiler: drop literal peephole optimization
-- compiling when*
-- compiling unless*
-- getenv/setenv: if literal arg, compile as a load/store
-- inline words
 - perhaps /i should work with all numbers
 
 + docs:
@@ -61,7 +61,6 @@
 - 'cascading' styles
 - command line parsing cleanup
 - nicer way to combine two paths
-- alist -vs- assoc terminology
 
 + httpd:
 

contrib/dejong.factor

@@ -1,7 +1,7 @@
 ! DeJong attractor renderer.
 ! To run this code, start your interpreter like so:
 !
-! ./f -library:sdl=libSDL.so -library:sdl-gfx=libSDL_gfx.so
+! ./f -libraries:sdl=libSDL.so -libraries:sdl-gfx=libSDL_gfx.so
 !
 ! Then, enter this at the interpreter prompt:
 !

contrib/irc.factor

@@ -26,11 +26,10 @@
 ! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
 
 IN: irc
-USE: arithmetic
 USE: combinators
 USE: errors
 USE: inspector
-USE: interpreter
+USE: listener
 USE: kernel
 USE: lists
 USE: logic
@@ -65,7 +64,7 @@ USE: unparser
     "ACTION " write write " :" write print ;
 
 : keep-datastack ( quot -- )
-    datastack [ call ] dip set-datastack drop ;
+    datastack slip set-datastack drop ;
 
 : irc-stream-write ( string -- )
     dup "buf" get sbuf-append
@@ -96,8 +95,7 @@ USE: unparser
 
 : with-irc-stream ( recepient quot -- )
     [
-        [ "stdio" get swap <irc-stream> "stdio" set ] dip
+        >r "stdio" get swap <irc-stream> "stdio" set r> call
-        call
     ] with-scope ;
 
 : irc-action-quot ( action -- quot )

contrib/mandel.factor

@@ -84,10 +84,10 @@ SYMBOL: center
     ] with-pixels ;
 
 : mandel ( -- )
-    640 480 32 SDL_HWSURFACE SDL_FULLSCREEN bitor SDL_SetVideoMode drop
+    640 480 32 SDL_HWSURFACE SDL_SetVideoMode drop
 
     [
-        3 zoom-fact set
+        0.8 zoom-fact set
         -0.65 center set
         100 nb-iter set
         [ render ] time

library/init.factor

@@ -31,7 +31,7 @@ USE: compiler
 USE: continuations
 USE: errors
 USE: files
-USE: interpreter
+USE: listener
 USE: kernel
 USE: lists
 USE: namespaces
@@ -97,9 +97,3 @@ USE: words
 : parse-command-line ( args -- )
     #! Parse command line arguments.
     parse-switches run-files ;
-
-: init-interpreter ( -- )
-    print-banner
-    room.
-
-    interpreter-loop ;

library/jedit/console.factor

@@ -29,7 +29,7 @@ IN: console
 USE: combinators
 USE: continuations
 USE: init
-USE: interpreter
+USE: listener
 USE: kernel
 USE: lists
 USE: namespaces
@@ -152,5 +152,5 @@ USE: unparser
     [
         dup "console" set
         <console-stream> "stdio" set
-        init-interpreter
+        init-listener
     ] with-scope ;

library/platform/jvm/boot-mini.factor

@@ -72,7 +72,7 @@ USE: parser
 "/library/extend-stream.factor"             run-resource ! streams
 "/library/platform/jvm/unparser.factor"     run-resource ! unparser
 "/library/platform/jvm/parser.factor"       run-resource ! parser
-"/library/styles.factor"                    run-resource ! styles
+"/library/presentation.factor"              run-resource ! presentation
 
 !!! Math library.
 "/library/platform/jvm/real-math.factor" run-resource ! real-math
@@ -85,12 +85,12 @@ USE: parser
 "/library/vocabulary-style.factor"         run-resource ! style
 "/library/prettyprint.factor"              run-resource ! prettyprint
 "/library/platform/jvm/prettyprint.factor" run-resource ! prettyprint
-"/library/interpreter.factor"              run-resource ! interpreter
+"/library/tools/listener.factor"           run-resource ! listener
-"/library/inspector.factor"                run-resource ! inspector
+"/library/tools/inspector.factor"          run-resource ! inspector
-"/library/inspect-vocabularies.factor"     run-resource ! inspector
+"/library/tools/word-tools.factor"         run-resource ! inspector
 "/library/platform/jvm/compiler.factor"    run-resource ! compiler
 "/library/platform/jvm/debugger.factor"    run-resource ! debugger
-"/library/debugger.factor"                 run-resource ! debugger
+"/library/tools/debugger.factor"           run-resource ! debugger
 
 !!! Final initialization...
 "/library/init.factor"                     run-resource ! init

library/platform/jvm/boot-sumo.factor

@@ -91,37 +91,23 @@ USE: parser
 "/library/prettyprint.factor"              run-resource ! prettyprint
 "/library/files.factor"                    run-resource ! files
 "/library/platform/jvm/prettyprint.factor" run-resource ! prettyprint
-"/library/interpreter.factor"              run-resource ! interpreter
+"/library/tools/listener.factor"           run-resource ! listener
-"/library/inspector.factor"                run-resource ! inspector
+"/library/tools/inspector.factor"          run-resource ! inspector
-"/library/inspect-vocabularies.factor"     run-resource ! inspector
+"/library/tools/word-tools.factor"         run-resource ! inspector
 "/library/platform/jvm/compiler.factor"    run-resource ! compiler
 "/library/platform/jvm/debugger.factor"    run-resource ! debugger
-"/library/debugger.factor"                 run-resource ! debugger
+"/library/tools/debugger.factor"           run-resource ! debugger
 "/library/test/test.factor"                run-resource ! test
 "/library/platform/jvm/test.factor"        run-resource ! test
 "/library/ansi.factor"                     run-resource ! ansi
-"/library/telnetd.factor"                  run-resource ! telnetd
+"/library/tools/telnetd.factor"            run-resource ! telnetd
-"/library/inferior.factor"                 run-resource ! inferior
+"/library/tools/inferior.factor"           run-resource ! inferior
 
 !!! Java -> native VM image cross-compiler.
-"/library/image.factor"                       run-resource ! cross-compiler
+"/library/tools/image.factor"                 run-resource ! cross-compiler
-"/library/cross-compiler.factor"              run-resource ! cross-compiler
+"/library/tools/cross-compiler.factor"        run-resource ! cross-compiler
 "/library/platform/jvm/cross-compiler.factor" run-resource ! cross-compiler
 
-!!! HTTPD.
-"/library/httpd/url-encoding.factor"       run-resource ! url-encoding
-"/library/httpd/html-tags.factor"          run-resource ! html
-"/library/httpd/html.factor"               run-resource ! html
-"/library/httpd/http-common.factor"        run-resource ! httpd
-"/library/httpd/responder.factor"          run-resource ! httpd-responder
-"/library/httpd/httpd.factor"              run-resource ! httpd
-"/library/httpd/inspect-responder.factor"  run-resource ! inspect-responder
-"/library/httpd/file-responder.factor"     run-resource ! file-responder
-"/library/httpd/quit-responder.factor"     run-resource ! quit-responder
-"/library/httpd/resource-responder.factor" run-resource ! resource-responder
-"/library/httpd/test-responder.factor"     run-resource ! test-responder
-"/library/httpd/default-responders.factor" run-resource ! default-responders
-
 !!! Final initialization...
 "/library/init.factor"              run-resource ! init
 "/library/platform/jvm/init.factor" run-resource ! init

library/platform/jvm/init.factor

@@ -31,7 +31,7 @@ USE: compiler
 USE: continuations
 USE: kernel
 USE: lists
-USE: interpreter
+USE: listener
 USE: namespaces
 USE: parser
 USE: stack
@@ -78,4 +78,4 @@ USE: words
 
     t "startup-done" set
     
-    "interactive" get [ init-interpreter 1 exit* ] when ;
+    "interactive" get [ init-listener 1 exit* ] when ;

library/platform/native/boot-stage2.factor

@@ -84,7 +84,7 @@ USE: stdio
     "/library/vocabulary-style.factor"
     "/library/prettyprint.factor"
     "/library/platform/native/debugger.factor"
-    "/library/debugger.factor"
+    "/library/tools/debugger.factor"
     "/library/platform/native/init.factor"
 
     "/library/math/constants.factor"
@@ -103,18 +103,21 @@ USE: stdio
     "/library/platform/native/prettyprint.factor"
     "/library/platform/native/files.factor"
     "/library/files.factor"
-    "/library/interpreter.factor"
+    "/library/tools/listener.factor"
-    "/library/inspector.factor"
+    "/library/tools/inspector.factor"
-    "/library/inspect-vocabularies.factor"
+    "/library/tools/word-tools.factor"
     "/library/test/test.factor"
     "/library/ansi.factor"
-    "/library/telnetd.factor"
+    "/library/tools/telnetd.factor"
-    "/library/inferior.factor"
+    "/library/tools/inferior.factor"
     "/library/platform/native/profiler.factor"
     "/library/platform/native/heap-stats.factor"
+    "/library/platform/native/gensym.factor"
+    "/library/tools/interpreter.factor"
+    "/library/tools/inference.factor"
 
-    "/library/image.factor"
+    "/library/tools/image.factor"
-    "/library/cross-compiler.factor"
+    "/library/tools/cross-compiler.factor"
     "/library/platform/native/cross-compiler.factor"
 
     "/library/httpd/url-encoding.factor"
@@ -179,12 +182,12 @@ IN: compiler
 DEFER: compilable-words
 DEFER: compilable-word-list
 
-IN: init
+IN: listener
-DEFER: init-interpreter
+DEFER: init-listener
 
 [
     warm-boot
-    "interactive" get [ init-interpreter ] when
+    "interactive" get [ init-listener ] when
     0 exit*
 ] set-boot
 

library/platform/native/gensym.factor

@@ -0,0 +1,47 @@
+! :folding=indent:collapseFolds=1:
+
+! $Id$
+!
+! Copyright (C) 2004 Slava Pestov.
+! 
+! Redistribution and use in source and binary forms, with or without
+! modification, are permitted provided that the following conditions are met:
+! 
+! 1. Redistributions of source code must retain the above copyright notice,
+!    this list of conditions and the following disclaimer.
+! 
+! 2. Redistributions in binary form must reproduce the above copyright notice,
+!    this list of conditions and the following disclaimer in the documentation
+!    and/or other materials provided with the distribution.
+! 
+! THIS SOFTWARE IS PROVIDED ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES,
+! INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND
+! FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
+! DEVELOPERS AND CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+! SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
+! PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS;
+! OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
+! WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
+! OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF
+! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+
+IN: words
+USE: math
+USE: namespaces
+USE: stack
+USE: strings
+USE: unparser
+
+SYMBOL: gensym-count
+
+: (gensym) ( -- name )
+    "G:" global [
+        gensym-count get succ dup gensym-count set
+    ] bind unparse cat2 ;
+
+: gensym ( -- word )
+    #! Return a word that is distinct from every other word, and
+    #! is not contained in any vocabulary.
+    (gensym) f (create) ;
+
+global [ 0 gensym-count set ] bind

library/test/assoc.factor

@@ -1,39 +0,0 @@
-IN: scratchpad
-USE: arithmetic
-USE: combinators
-USE: compiler
-USE: hashtables
-USE: kernel
-USE: lists
-USE: logic
-USE: namespaces
-USE: stack
-USE: stdio
-USE: strings
-USE: test
-
-"Checking association lists" print
-
-[
-    [ "monkey" | 1       ]
-    [ "banana" | 2       ]
-    [ "Java"   | 3       ]
-    [ t        | "true"  ]
-    [ f        | "false" ]
-    [ [ 1 2 ]  | [ 2 1 ] ]
-] "assoc" set
-
-[ [ 1 1 0 0 ] ] [ [ assoc? ] ] [ balance>list ] test-word
-[ t ] [ "assoc" get ] [ assoc? ] test-word
-[ f ] [ [ 1 2 3 | 4 ] ] [ assoc? ] test-word
-
-[ [ 2 1 0 0 ] ] [ [ assoc ] ] [ balance>list ] test-word
-[ f           ] [ "monkey" f      ] [ assoc             ] test-word
-[ f           ] [ "donkey" "assoc" get ] [ assoc             ] test-word
-[ 1           ] [ "monkey" "assoc" get ] [ assoc             ] test-word
-[ "false"     ] [ f        "assoc" get ] [ assoc             ] test-word
-[ [ 2 1 ]     ] [ [ 1 2 ]  "assoc" get ] [ assoc             ] test-word
-
-"is great" "Java" "assoc" get set-assoc "assoc" set
-
-[ "is great" ] [ "Java" "assoc" get ] [ assoc ] test-word

library/test/inference.factor

@@ -0,0 +1,35 @@
+IN: scratchpad
+USE: test
+USE: inference
+USE: stack
+USE: combinators
+USE: vectors
+
+[ 6 ] [ 6 gensym-vector vector-length ] unit-test
+
+[ [ 0 | 2 ] ] [ [ 2 "Hello" ] infer ] unit-test
+[ [ 1 | 2 ] ] [ [ dup ] infer ] unit-test
+
+[ [ 1 | 2 ] ] [ [ [ dup ] call ] infer ] unit-test
+[ [ call ] infer ] unit-test-fails
+
+[ [ 2 | 4 ] ] [ [ 2dup ] infer ] unit-test
+[ [ 2 | 0 ] ] [ [ set-vector-length ] infer ] unit-test
+[ [ 1 | 0 ] ] [ [ vector-clear ] infer ] unit-test
+[ [ 2 | 0 ] ] [ [ vector-push ] infer ] unit-test
+
+[ [ 1 | 0 ] ] [ [ [ ] [ ] ifte ] infer ] unit-test
+[ [ ifte ] infer ] unit-test-fails
+[ [ [ ] ifte ] infer ] unit-test-fails
+[ [ [ 2 ] [ ] ifte ] infer ] unit-test-fails
+[ [ 4 | 3 ] ] [ [ [ rot ] [ -rot ] ifte ] infer ] unit-test
+
+[ [ 4 | 3 ] ] [
+    [
+        [
+            [ swap 3 ] [ nip 5 5 ] ifte
+        ] [
+            -rot
+        ] ifte
+    ] infer
+] unit-test

library/test/listener.factor

@@ -1,5 +1,5 @@
 IN: scratchpad
-USE: interpreter
+USE: listener
 USE: namespaces
 USE: stdio
 USE: test

library/test/test.factor

@@ -85,8 +85,8 @@ USE: unparser
         "image"
         "init"
         "inspector"
-        "interpreter"
         "io/io"
+        "listener"
         "vectors"
         "words"
         "unparser"
@@ -114,6 +114,8 @@ USE: unparser
         "sbuf" test
         "threads" test
         "parsing-word" test
+        "inference" test
+        "interpreter" test
 
         cpu "x86" = [
             [

library/test/vectors.factor

@@ -32,3 +32,6 @@ USE: vectors
 [ t ] [ { 1 2 3 } hashcode { 1 2 3 } hashcode = ] unit-test
 [ t ] [ { 1 { 2 } 3 } hashcode { 1 { 2 } 3 } hashcode = ] unit-test
 [ t ] [ { } hashcode { } hashcode = ] unit-test
+
+[ { 1 2 3 4 5 6 } ]
+[ { 1 2 3 } vector-clone dup { 4 5 6 } vector-append ] unit-test

library/tools/inference.factor

@@ -0,0 +1,178 @@
+! :folding=indent:collapseFolds=1:
+
+! $Id$
+!
+! Copyright (C) 2004 Slava Pestov.
+! 
+! Redistribution and use in source and binary forms, with or without
+! modification, are permitted provided that the following conditions are met:
+! 
+! 1. Redistributions of source code must retain the above copyright notice,
+!    this list of conditions and the following disclaimer.
+! 
+! 2. Redistributions in binary form must reproduce the above copyright notice,
+!    this list of conditions and the following disclaimer in the documentation
+!    and/or other materials provided with the distribution.
+! 
+! THIS SOFTWARE IS PROVIDED ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES,
+! INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND
+! FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
+! DEVELOPERS AND CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+! SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
+! PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS;
+! OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
+! WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
+! OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF
+! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+
+IN: inference
+USE: combinators
+USE: errors
+USE: interpreter
+USE: kernel
+USE: lists
+USE: math
+USE: namespaces
+USE: stack
+USE: strings
+USE: vectors
+USE: words
+
+! Word properties that affect inference:
+! - infer-effect -- must be set. controls number of inputs
+! expected, and number of outputs produced.
+! - meta-infer -- evaluate word in meta-interpreter if set.
+! - infer - quotation with custom inference behavior; ifte uses
+! this. Word is passed on the stack.
+
+SYMBOL: d-in
+SYMBOL: r-in
+
+: gensym-vector ( n --  vector )
+    dup <vector> swap [ gensym over vector-push ] times ;
+
+: inputs ( count stack -- stack )
+    #! Add this many inputs to the given stack.
+    >r dup d-in +@ gensym-vector dup r> vector-append ;
+
+: ensure ( count stack -- stack )
+    #! Ensure stack has this many elements.
+    2dup vector-length > [
+        [ vector-length - ] keep inputs
+    ] [
+        nip
+    ] ifte ;
+
+: ensure-d ( count -- )
+    #! Ensure count of unknown results are on the stack.
+    meta-d get ensure meta-d set ;
+
+: consume-d ( count -- )
+    #! Remove count of elements.
+    [ pop-d drop ] times ;
+
+: produce-d ( count -- )
+    #! Push count of unknown results.
+    [ gensym push-d ] times ;
+
+: standard-effect ( word [ in | out ] -- )
+    over "meta-infer" word-property [
+        drop host-word
+    ] [
+        unswons consume-d produce-d drop
+    ] ifte ;
+
+: apply-effect ( word [ in | out ] -- )
+    #! Helper word for apply-word.
+    dup car ensure-d
+    over "infer" word-property dup [
+        nip nip call
+    ] [
+        drop standard-effect
+    ] ifte ;
+
+: no-effect ( word -- )
+    "Unknown stack effect: " swap word-name cat2 throw ;
+
+DEFER: (infer)
+
+: apply-word ( word -- )
+    #! Apply the word's stack effect to the inferencer's state.
+    dup "infer-effect" word-property dup [
+        apply-effect
+    ] [
+        drop dup compound? [
+            word-parameter (infer)
+        ] [
+            drop no-effect
+        ] ifte
+    ] ifte ;
+
+: init-inference ( -- )
+    init-interpreter
+    0 d-in set
+    0 r-in set ;
+
+: effect ( -- [ in | out ] )
+    #! After inference is finished, collect information.
+    d-in get meta-d get vector-length cons ;
+
+: (infer) ( quot -- )
+    [ dup word? [ apply-word ] [ push-d ] ifte ] each ;
+
+: infer ( quot -- [ in | out ] )
+    #! Stack effect of a quotation.
+    [ init-inference (infer)  effect ] with-scope ;
+
+: infer-branch ( quot -- in-d datastack )
+    [
+        copy-interpreter (infer)
+        d-in get  meta-d get
+    ] with-scope ;
+
+: unify ( in stack in stack -- )
+    swapd 2dup vector-length= [
+        drop meta-d set
+        2dup = [
+            drop d-in set
+        ] [
+            "Unbalanced ifte inputs" throw
+        ] ifte
+    ] [
+        "Unbalanced ifte outputs" throw
+    ] ifte ;
+
+: infer-ifte ( -- )
+    pop-d pop-d pop-d  drop ( condition )
+    >r infer-branch r> infer-branch unify ;
+
+\ call [ pop-d (infer) ] "infer" set-word-property
+\ call [ 1 | 0 ] "infer-effect" set-word-property
+
+\ ifte [ 3 | 0 ] "infer-effect" set-word-property
+\ ifte [ infer-ifte ] "infer" set-word-property
+
+\ >r [ pop-d push-r ] "infer" set-word-property
+\ >r [ 1 | 0 ] "infer-effect" set-word-property
+\ r> [ pop-r push-d ] "infer" set-word-property
+\ r> [ 0 | 1 ] "infer-effect" set-word-property
+
+\ drop  t "meta-infer" set-word-property
+\ drop [ 1 | 0 ] "infer-effect" set-word-property
+\ nip t "meta-infer" set-word-property
+\ nip [ 2 | 1 ] "infer-effect" set-word-property
+\ dup  t "meta-infer" set-word-property
+\ dup [ 1 | 2 ] "infer-effect" set-word-property
+\ over t "meta-infer" set-word-property
+\ over [ 2 | 3 ] "infer-effect" set-word-property
+\ pick t "meta-infer" set-word-property
+\ pick [ 3 | 4 ] "infer-effect" set-word-property
+\ swap t "meta-infer" set-word-property
+\ swap [ 2 | 2 ] "infer-effect" set-word-property
+\ rot t "meta-infer" set-word-property
+\ rot [ 3 | 3 ] "infer-effect" set-word-property
+
+\ vector-nth [ 2 | 1 ] "infer-effect" set-word-property
+\ set-vector-nth [ 3 | 0 ] "infer-effect" set-word-property
+\ vector-length [ 1 | 1 ] "infer-effect" set-word-property
+\ set-vector-length [ 2 | 0 ] "infer-effect" set-word-property

library/tools/inferior.factor

@@ -28,7 +28,7 @@
 IN: inferior
 USE: combinators
 USE: errors
-USE: interpreter
+USE: listener
 USE: kernel
 USE: lists
 USE: logic

library/tools/interpreter.factor

@@ -0,0 +1,201 @@
+! :folding=indent:collapseFolds=1:
+
+! $Id$
+!
+! Copyright (C) 2004 Slava Pestov.
+! 
+! Redistribution and use in source and binary forms, with or without
+! modification, are permitted provided that the following conditions are met:
+! 
+! 1. Redistributions of source code must retain the above copyright notice,
+!    this list of conditions and the following disclaimer.
+! 
+! 2. Redistributions in binary form must reproduce the above copyright notice,
+!    this list of conditions and the following disclaimer in the documentation
+!    and/or other materials provided with the distribution.
+! 
+! THIS SOFTWARE IS PROVIDED ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES,
+! INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND
+! FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
+! DEVELOPERS AND CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+! SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
+! PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS;
+! OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
+! WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
+! OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF
+! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+
+IN: interpreter
+USE: vectors
+USE: namespaces
+USE: logic
+USE: kernel
+USE: combinators
+USE: lists
+USE: words
+USE: stack
+USE: errors
+USE: continuations
+USE: strings
+USE: prettyprint
+USE: stdio
+
+! A Factor interpreter written in Factor. Used by compiler for
+! partial evaluation, also for trace and step.
+
+! Meta-stacks
+SYMBOL: meta-r
+: push-r meta-r get vector-push ;
+: pop-r meta-r get vector-pop ;
+SYMBOL: meta-d
+: push-d meta-d get vector-push ;
+: pop-d meta-d get vector-pop ;
+SYMBOL: meta-n
+SYMBOL: meta-c
+
+! Call frame
+SYMBOL: meta-cf
+
+: init-interpreter ( -- )
+    10 <vector> meta-r set
+    10 <vector> meta-d set
+    10 <vector> meta-n set
+    10 <vector> meta-c set
+    f meta-cf set ;
+
+: copy-interpreter ( -- )
+    #! Copy interpreter state from containing namespaces.
+    meta-r get vector-clone meta-r set
+    meta-d get vector-clone meta-d set
+    meta-n get vector-clone meta-n set
+    meta-c get vector-clone meta-c set ;
+
+: done-cf? ( -- ? )
+    meta-cf get not ;
+
+: done? ( -- ? )
+    done-cf? meta-r get vector-empty? and ;
+
+! Callframe.
+: up ( -- )
+    pop-r meta-cf set ;
+
+: next ( -- obj )
+    meta-cf get [ meta-cf uncons@ ] [ up next ] ifte ;
+
+: host-word ( word -- )
+    #! Swap in the meta-interpreter's stacks, execute the word,
+    #! swap in the old stacks. This is so messy.
+    push-d datastack push-d
+    meta-d get set-datastack
+    >r execute datastack r> tuck vector-push
+    set-datastack meta-d set ;
+
+: meta-call ( quot -- )
+    #! Note we do tail call optimization here.
+    meta-cf get [ push-r ] when* meta-cf set ;
+
+: meta-word ( word -- )
+    dup "meta-word" word-property dup [
+        nip call
+    ] [
+        drop dup compound? [
+            word-parameter meta-call
+        ] [
+            host-word
+        ] ifte
+    ] ifte ;
+
+: do ( obj -- )
+    dup word? [ meta-word ] [ push-d ] ifte ;
+
+: (interpret) ( quot -- )
+    #! The quotation is called with each word as its executed.
+    done? [ drop ] [ [ next swap call ] keep (interpret) ] ifte ;
+
+: interpret ( quot quot -- )
+    #! The first quotation is meta-interpreted, with each word
+    #! passed to the second quotation. Pollutes current
+    #! namespace.
+    init-interpreter swap meta-cf set (interpret) ;
+
+: (run) ( -- )
+    [ do ] (interpret) ;
+
+: run ( quot -- )
+    [ do ] interpret ;
+
+: set-meta-word ( word quot -- )
+    "meta-word" set-word-property ;
+
+\ datastack [ meta-d get vector-clone push-d ] set-meta-word
+\ set-datastack [ pop-d vector-clone meta-d set ] set-meta-word
+\ >r   [ pop-d push-r ] set-meta-word
+\ r>   [ pop-r push-d ] set-meta-word
+\ callstack [ meta-r get vector-clone push-d ] set-meta-word
+\ set-callstack [ pop-d vector-clone meta-r set ] set-meta-word
+\ namestack* [ meta-n get push-d ] set-meta-word
+\ set-namestack* [ pop-d meta-n set ] set-meta-word
+\ catchstack* [ meta-c get push-d ] set-meta-word
+\ set-catchstack* [ pop-d meta-c set ] set-meta-word
+\ call [ pop-d meta-call ] set-meta-word
+\ execute [ pop-d meta-word ] set-meta-word
+\ ifte [ pop-d pop-d pop-d [ nip ] [ drop ] ifte meta-call ] set-meta-word
+
+! Some useful tools
+
+: report ( obj -- )
+    meta-r get vector-length " " fill write . flush ;
+
+: (trace) ( -- )
+    [ dup report do ] (interpret) ;
+
+: trace ( quot -- )
+    #! Trace execution of a quotation by printing each word as
+    #! its executed, and each literal as its pushed. Each line
+    #! is indented by the call stack height.
+    [
+        init-interpreter
+        meta-cf set
+        (trace)
+        meta-d get set-datastack
+    ] with-scope ;
+
+: walk-banner ( -- )
+    "The following words control the single-stepper:" print
+    "&s      -- print stepper data stack" print
+    "&r      -- print stepper call stack" print
+    "&n      -- print stepper name stack" print
+    "&c      -- print stepper catch stack" print
+    "step    -- single step" print
+    "(trace) -- trace until end" print
+    "(run)   -- run until end" print ;
+
+: walk ( quot -- )
+    #! Single-step through execution of a quotation.
+    init-interpreter
+    meta-cf set
+    walk-banner ;
+
+: &s
+    #! Print stepper data stack.
+    meta-d get {.} ;
+
+: &r
+    #! Print stepper call stack.
+    meta-r get {.} meta-cf get . ;
+
+: &n
+    #! Print stepper name stack.
+    meta-n get {.} ;
+
+: &c
+    #! Print stepper catch stack.
+    meta-c get {.} ;
+
+: not-done ( quot -- )
+    done? [ "Stepper is done." print drop ] [ call ] ifte ;
+
+: step
+    #! Step into current word.
+    [ next dup report do ] not-done ;

library/tools/listener.factor

@@ -25,7 +25,7 @@
 ! OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF
 ! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
 
-IN: interpreter
+IN: listener
 USE: combinators
 USE: continuations
 USE: errors
@@ -63,14 +63,14 @@ USE: vectors
 : eval-catch ( str -- )
     [ eval ] [ [ default-error-handler drop ] when* ] catch ;
 
-: interpret ( -- )
+: listener-step ( -- )
     print-prompt read [ eval-catch ] [ exit ] ifte* ;
 
-: interpreter-loop ( -- )
+: listener-loop ( -- )
     "quit-flag" get [
         "quit-flag" off
     ] [
-        interpret interpreter-loop
+        listener-step listener-loop
     ] ifte ;
 
 : room. ( -- )
@@ -78,12 +78,19 @@ USE: vectors
     1024 /i unparse write " KB total, " write
     1024 /i unparse write " KB free" print ;
 
+: init-listener ( -- )
+    print-banner
+    room.
+
+    listener-loop ;
+
 : help ( -- )
     "SESSION:" print
     native? [
         "\"foo.image\" save-image   -- save heap to a file" print
     ] when
     "room.                    -- show memory usage" print
+    "heap-stats.              -- memory allocation breakdown" print
     "garbage-collection       -- force a GC" print
     "exit                     -- exit interpreter" print
     terpri
@@ -103,5 +110,10 @@ USE: vectors
     "\"foo\" get .              -- print a variable value." print
     ".                        -- print top of stack." print
     terpri
+    "PROFILER:                [ ... ] call-profile" print
+    "                         [ ... ] allot-profile" print
+    "TRACE:                   [ ... ] trace" print
+    "SINGLE STEP:             [ ... ] step" print
+    terpri
     "HTTP SERVER:             USE: httpd 8888 httpd" print
     "TELNET SERVER:           USE: telnetd 9999 telnetd" print ;

library/tools/telnetd.factor

@@ -28,7 +28,7 @@
 IN: telnetd
 USE: combinators
 USE: errors
-USE: interpreter
+USE: listener
 USE: kernel
 USE: logging
 USE: logic
@@ -42,7 +42,7 @@ USE: threads
     dup [
         "client" set
         log-client
-        interpreter-loop
+        listener-loop
     ] with-stream ;
 
 : telnet-connection ( socket -- )

library/vector-combinators.factor

@@ -53,3 +53,7 @@ USE: stack
 
 : vector-all? ( vector pred -- ? )
     vector-map vector-and ;
+
+: vector-append ( v1 v2 -- )
+    #! Destructively append v2 to v1.
+    [ over vector-push ] vector-each drop ;

library/vectors.factor

@@ -40,7 +40,7 @@ USE: stack
 : vector-empty? ( obj -- ? )
     vector-length 0 = ;
 
-: vector-clear ( vector -- list )
+: vector-clear ( vector -- )
     #! Clears a vector.
     0 swap set-vector-length ;
 

library/vocabularies.factor

@@ -64,10 +64,11 @@ USE: strings
         "files"
         "hashtables"
         "inferior"
-        "inspector"
         "interpreter"
+        "inspector"
         "jedit"
         "kernel"
+        "listener"
         "lists"
         "logic"
         "math"
@@ -75,6 +76,7 @@ USE: strings
         "parser"
         "prettyprint"
         "processes"
+        "profiler"
         "stack"
         "streams"
         "stdio"

native/socket.c

@@ -116,8 +116,6 @@ CELL accept_connection(PORT* p)
 	struct sockaddr_in clientname;
 	size_t size = sizeof(clientname);
 
-	/* int oobinline = 1; */
-
 	int new = accept(p->fd,(struct sockaddr *)&clientname,&size);
 	if(new < 0)
 	{
@@ -127,9 +125,6 @@ CELL accept_connection(PORT* p)
 			io_error(__FUNCTION__);
 	}
 
-	/* if(setsockopt(new,SOL_SOCKET,SO_OOBINLINE,&oobinline,sizeof(int)) < 0)
-		io_error(__FUNCTION__); */
-
 	p->client_host = tag_object(from_c_string(inet_ntoa(
 		clientname.sin_addr)));
 	p->client_port = tag_fixnum(ntohs(clientname.sin_port));