diff --git a/TODO.FACTOR.txt b/TODO.FACTOR.txt index 63140a0205..7622398781 100644 --- a/TODO.FACTOR.txt +++ b/TODO.FACTOR.txt @@ -1,6 +1,11 @@ - add a socket timeout -- fix error postoning -- not all errors thrown by i/o code are - postponed +- compiling when* +- 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: diff --git a/contrib/dejong.factor b/contrib/dejong.factor index abe827d4af..5a262a2166 100644 --- a/contrib/dejong.factor +++ b/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: ! diff --git a/contrib/irc.factor b/contrib/irc.factor index e680f196f6..4f695c7fb5 100644 --- a/contrib/irc.factor +++ b/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 "stdio" set ] dip - call + >r "stdio" get swap "stdio" set r> call ] with-scope ; : irc-action-quot ( action -- quot ) diff --git a/contrib/mandel.factor b/contrib/mandel.factor index f35ec5fa2c..b22be2340c 100644 --- a/contrib/mandel.factor +++ b/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 diff --git a/library/init.factor b/library/init.factor index b461109ae6..e3759028de 100644 --- a/library/init.factor +++ b/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 ; diff --git a/library/jedit/console.factor b/library/jedit/console.factor index 870b0560f4..1ccb73bd7c 100644 --- a/library/jedit/console.factor +++ b/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 "stdio" set - init-interpreter + init-listener ] with-scope ; diff --git a/library/platform/jvm/boot-mini.factor b/library/platform/jvm/boot-mini.factor index b55d59e1b8..67f0a61b8d 100644 --- a/library/platform/jvm/boot-mini.factor +++ b/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/inspector.factor" run-resource ! inspector -"/library/inspect-vocabularies.factor" run-resource ! inspector +"/library/tools/listener.factor" run-resource ! listener +"/library/tools/inspector.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 diff --git a/library/platform/jvm/boot-sumo.factor b/library/platform/jvm/boot-sumo.factor index 69a74923b2..95f0dbbe56 100644 --- a/library/platform/jvm/boot-sumo.factor +++ b/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/inspector.factor" run-resource ! inspector -"/library/inspect-vocabularies.factor" run-resource ! inspector +"/library/tools/listener.factor" run-resource ! listener +"/library/tools/inspector.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/inferior.factor" run-resource ! inferior +"/library/tools/telnetd.factor" run-resource ! telnetd +"/library/tools/inferior.factor" run-resource ! inferior !!! Java -> native VM image cross-compiler. -"/library/image.factor" run-resource ! cross-compiler -"/library/cross-compiler.factor" run-resource ! cross-compiler +"/library/tools/image.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 diff --git a/library/platform/jvm/init.factor b/library/platform/jvm/init.factor index dccd0699e9..4bf3fb8d9b 100644 --- a/library/platform/jvm/init.factor +++ b/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 ; diff --git a/library/platform/native/boot-stage2.factor b/library/platform/native/boot-stage2.factor index aa73c4ca94..3a68c326ae 100644 --- a/library/platform/native/boot-stage2.factor +++ b/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/inspector.factor" - "/library/inspect-vocabularies.factor" + "/library/tools/listener.factor" + "/library/tools/inspector.factor" + "/library/tools/word-tools.factor" "/library/test/test.factor" "/library/ansi.factor" - "/library/telnetd.factor" - "/library/inferior.factor" + "/library/tools/telnetd.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/cross-compiler.factor" + "/library/tools/image.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 -DEFER: init-interpreter +IN: listener +DEFER: init-listener [ warm-boot - "interactive" get [ init-interpreter ] when + "interactive" get [ init-listener ] when 0 exit* ] set-boot diff --git a/library/platform/native/gensym.factor b/library/platform/native/gensym.factor new file mode 100644 index 0000000000..514bb2eff7 --- /dev/null +++ b/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 diff --git a/library/test/assoc.factor b/library/test/assoc.factor deleted file mode 100644 index 03ca9848ed..0000000000 --- a/library/test/assoc.factor +++ /dev/null @@ -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 diff --git a/library/test/inference.factor b/library/test/inference.factor new file mode 100644 index 0000000000..bed403414e --- /dev/null +++ b/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 diff --git a/library/test/interpreter.factor b/library/test/listener.factor similarity index 92% rename from library/test/interpreter.factor rename to library/test/listener.factor index 7594e2f2cd..c9f52b9e51 100644 --- a/library/test/interpreter.factor +++ b/library/test/listener.factor @@ -1,5 +1,5 @@ IN: scratchpad -USE: interpreter +USE: listener USE: namespaces USE: stdio USE: test diff --git a/library/test/test.factor b/library/test/test.factor index 652ad5736e..f34b1094c0 100644 --- a/library/test/test.factor +++ b/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" = [ [ diff --git a/library/test/vectors.factor b/library/test/vectors.factor index cd81ae9a7e..44cf2a02b8 100644 --- a/library/test/vectors.factor +++ b/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 diff --git a/library/cross-compiler.factor b/library/tools/cross-compiler.factor similarity index 100% rename from library/cross-compiler.factor rename to library/tools/cross-compiler.factor diff --git a/library/debugger.factor b/library/tools/debugger.factor similarity index 100% rename from library/debugger.factor rename to library/tools/debugger.factor diff --git a/library/image.factor b/library/tools/image.factor similarity index 100% rename from library/image.factor rename to library/tools/image.factor diff --git a/library/tools/inference.factor b/library/tools/inference.factor new file mode 100644 index 0000000000..d8c2a03ec3 --- /dev/null +++ b/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 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 diff --git a/library/inferior.factor b/library/tools/inferior.factor similarity index 99% rename from library/inferior.factor rename to library/tools/inferior.factor index b2d5dd9577..b95c5e12d7 100644 --- a/library/inferior.factor +++ b/library/tools/inferior.factor @@ -28,7 +28,7 @@ IN: inferior USE: combinators USE: errors -USE: interpreter +USE: listener USE: kernel USE: lists USE: logic diff --git a/library/inspector.factor b/library/tools/inspector.factor similarity index 100% rename from library/inspector.factor rename to library/tools/inspector.factor diff --git a/library/tools/interpreter.factor b/library/tools/interpreter.factor new file mode 100644 index 0000000000..8823fe2069 --- /dev/null +++ b/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 meta-r set + 10 meta-d set + 10 meta-n set + 10 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 ; diff --git a/library/interpreter.factor b/library/tools/listener.factor similarity index 88% rename from library/interpreter.factor rename to library/tools/listener.factor index f86e39bc5f..51dacad74b 100644 --- a/library/interpreter.factor +++ b/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 ; diff --git a/library/telnetd.factor b/library/tools/telnetd.factor similarity index 98% rename from library/telnetd.factor rename to library/tools/telnetd.factor index 38256c946f..147706018f 100644 --- a/library/telnetd.factor +++ b/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 -- ) diff --git a/library/inspect-vocabularies.factor b/library/tools/word-tools.factor similarity index 100% rename from library/inspect-vocabularies.factor rename to library/tools/word-tools.factor diff --git a/library/vector-combinators.factor b/library/vector-combinators.factor index 8b13a1d05a..6f6e6ef90f 100644 --- a/library/vector-combinators.factor +++ b/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 ; diff --git a/library/vectors.factor b/library/vectors.factor index 516ba187b1..076e0b7f63 100644 --- a/library/vectors.factor +++ b/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 ; diff --git a/library/vocabularies.factor b/library/vocabularies.factor index 6c4cb0e141..f04957e790 100644 --- a/library/vocabularies.factor +++ b/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" diff --git a/native/socket.c b/native/socket.c index 061f9a9ecf..5076dadfda 100644 --- a/native/socket.c +++ b/native/socket.c @@ -115,8 +115,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));