adding trace, step, stack inference to cvs, rearranging some stuff
Slava Pestov
parent
bd7fc60d8e
commit
d347d20dbc
|
|
@ -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:
|
||||
|
||||
|
|
|
|||
|
|
@ -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:
|
||||
!
|
||||
|
|
|
|||
|
|
@ -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
|
||||
call
|
||||
>r "stdio" get swap <irc-stream> "stdio" set r> call
|
||||
] with-scope ;
|
||||
|
||||
: irc-action-quot ( action -- quot )
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
@ -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
|
||||
|
|
@ -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
|
||||
|
|
@ -1,5 +1,5 @@
|
|||
IN: scratchpad
|
||||
USE: interpreter
|
||||
USE: listener
|
||||
USE: namespaces
|
||||
USE: stdio
|
||||
USE: test
|
||||
|
|
@ -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" = [
|
||||
[
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
@ -28,7 +28,7 @@
|
|||
IN: inferior
|
||||
USE: combinators
|
||||
USE: errors
|
||||
USE: interpreter
|
||||
USE: listener
|
||||
USE: kernel
|
||||
USE: lists
|
||||
USE: logic
|
||||
|
|
@ -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 ;
|
||||
|
|
@ -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 ;
|
||||
|
|
@ -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 -- )
|
||||
|
|
@ -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 ;
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
||||
|
|
|
|||
|
|
@ -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"
|
||||
|
|
|
|||
|
|
@ -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));
|
||||
|
|
|
|||
Loading…
Reference in New Issue