From 68b93121543089cd7d5f99f051f35c2fb72796da Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 26 Nov 2004 04:14:17 +0000 Subject: [PATCH] telnetd fix --- TODO.FACTOR.txt | 5 ---- factor/jedit/ListenerAttributeSet.java | 8 ++++--- library/bootstrap/init-stage2.factor | 4 ++-- library/bootstrap/init.factor | 1 - library/errors.factor | 13 ++++------ library/eval-catch.factor | 2 +- library/in-thread.factor | 2 +- library/syntax/prettyprint.factor | 12 +++++----- library/test/benchmark/ack.factor | 2 +- library/test/errors.factor | 11 +++++++-- library/test/threads.factor | 1 + library/tools/debugger.factor | 12 +++++++--- library/tools/inference.factor | 4 ++-- library/tools/interpreter.factor | 16 +++++++++---- library/tools/jedit-wire.factor | 4 +++- library/tools/listener.factor | 33 +++++++++++--------------- library/tools/telnetd.factor | 19 +++------------ 17 files changed, 72 insertions(+), 77 deletions(-) diff --git a/TODO.FACTOR.txt b/TODO.FACTOR.txt index 8191667d9a..6c3deaf680 100644 --- a/TODO.FACTOR.txt +++ b/TODO.FACTOR.txt @@ -4,7 +4,6 @@ - type inference - some way to step over a word in the stepper - step: print NEXT word to execute, not word that JUST executed -- step: start a nested listener + compiler/ffi: @@ -37,10 +36,8 @@ + kernel: -- dissolve library/platform/native/ - profiler is inaccurate: wrong word on cs - better i/o scheduler -- >lower, >upper for strings - don't rehash strings on every startup - remove sbufs - cat, reverse-cat primitives @@ -52,11 +49,9 @@ + misc: -- alist -vs- assoc terminology - jedit ==> jedit-word, jedit takes a file name - command line parsing cleanup - nicer way to combine two paths -- catchstack lists - OOP - ditch object paths - browser responder for word links in HTTPd; inspect responder for diff --git a/factor/jedit/ListenerAttributeSet.java b/factor/jedit/ListenerAttributeSet.java index e003b4ec7e..6c8f4f07b1 100644 --- a/factor/jedit/ListenerAttributeSet.java +++ b/factor/jedit/ListenerAttributeSet.java @@ -32,7 +32,7 @@ package factor.jedit; import console.*; import factor.Cons; import javax.swing.text.*; -import javax.swing.Action; +import javax.swing.*; import java.awt.Color; import org.gjt.sp.jedit.GUIUtilities; @@ -69,8 +69,10 @@ public class ListenerAttributeSet extends SimpleAttributeSet else if("actions".equals(key)) addAttribute(ConsolePane.Actions,createActionsMenu((Cons)value)); else if("icon".equals(key)) - addAttribute(StyleConstants.IconAttribute, - GUIUtilities.loadIcon((String)value)); + { + StyleConstants.setIcon(this,GUIUtilities.loadIcon( + "jeditresource:/Factor.jar!" + value)); + } } //}}} //{{{ toColor() method diff --git a/library/bootstrap/init-stage2.factor b/library/bootstrap/init-stage2.factor index 61bc481de6..986ceac01b 100644 --- a/library/bootstrap/init-stage2.factor +++ b/library/bootstrap/init-stage2.factor @@ -79,7 +79,8 @@ USE: unparser [ warm-boot - "interactive" get [ init-listener ] when + garbage-collection + "interactive" get [ print-banner listener ] when 0 exit* ] set-boot @@ -88,7 +89,6 @@ init-error-handler 0 [ drop succ ] each-word unparse write " words" print "Inferring stack effects..." print -[ 2 car ] [ ] catch 0 [ unit try-infer [ succ ] when ] each-word unparse write " words have a stack effect" print diff --git a/library/bootstrap/init.factor b/library/bootstrap/init.factor index 5bbd913350..a88b4a6f41 100644 --- a/library/bootstrap/init.factor +++ b/library/bootstrap/init.factor @@ -40,7 +40,6 @@ USE: vectors : boot ( -- ) #! Initialize an interpreter with the basic services. - init-errors init-namespaces init-threads init-stdio diff --git a/library/errors.factor b/library/errors.factor index 42fd177d0d..36ab85ba6e 100644 --- a/library/errors.factor +++ b/library/errors.factor @@ -38,16 +38,11 @@ USE: vectors ! This is a very lightweight exception handling system. -: catchstack* ( -- cs ) 6 getenv ; -: catchstack ( -- cs ) catchstack* vector-clone ; -: set-catchstack* ( cs -- ) 6 setenv ; -: set-catchstack ( cs -- ) vector-clone set-catchstack* ; +: catchstack ( -- cs ) 6 getenv ; +: set-catchstack ( cs -- ) 6 setenv ; -: init-errors ( -- ) - 64 set-catchstack* ; - -: >c ( catch -- ) catchstack* vector-push ; -: c> ( catch -- ) catchstack* vector-pop ; +: >c ( catch -- ) catchstack cons set-catchstack ; +: c> ( catch -- ) catchstack uncons set-catchstack ; : save-error ( error -- ) #! Save the stacks and parser state for post-mortem diff --git a/library/eval-catch.factor b/library/eval-catch.factor index 5d7ceeda6c..216f3bc802 100644 --- a/library/eval-catch.factor +++ b/library/eval-catch.factor @@ -32,7 +32,7 @@ USE: combinators USE: stdio : eval-catch ( str -- ) - [ eval ] print-error ; + [ eval ] [ [ default-error-handler drop ] when* ] catch ; : eval>string ( in -- out ) [ eval-catch ] with-string ; diff --git a/library/in-thread.factor b/library/in-thread.factor index 6c5cf8cf1c..71dfac12cc 100644 --- a/library/in-thread.factor +++ b/library/in-thread.factor @@ -43,7 +43,7 @@ USE: stack [ schedule-thread ! Clear stacks since we never go up from this point - { } set-catchstack + [ ] set-catchstack { } set-callstack print-error (yield) diff --git a/library/syntax/prettyprint.factor b/library/syntax/prettyprint.factor index 03fd40d2ef..a2bb55154a 100644 --- a/library/syntax/prettyprint.factor +++ b/library/syntax/prettyprint.factor @@ -116,10 +116,10 @@ DEFER: prettyprint* write-attr ; : prettyprint-[ ( indent -- indent ) - \ [ prettyprint-word \ ] prettyprint-word ; + prettyprint> \ ] prettyprint-word ; : prettyprint-list ( indent list -- indent ) #! Pretty-print a list, without [ and ]. @@ -156,10 +156,10 @@ DEFER: prettyprint* ] ifte ; : prettyprint-{{ ( indent -- indent ) - \ {{ prettyprint-word \ }} prettyprint-word ; + prettyprint> \ }} prettyprint-word ; : prettyprint-{{}} ( indent hashtable -- indent ) hash>alist dup length 0 = [ @@ -206,10 +206,10 @@ DEFER: prettyprint* #! Unparse each element on its own line. stack>list [ . ] each ; -: .n namestack [.] ; : .s datastack {.} ; : .r callstack {.} ; -: .c catchstack {.} ; +: .n namestack [.] ; +: .c catchstack [.] ; ! For integers only : .b >bin print ; diff --git a/library/test/benchmark/ack.factor b/library/test/benchmark/ack.factor index 59bd1eab4a..49fe4a9634 100644 --- a/library/test/benchmark/ack.factor +++ b/library/test/benchmark/ack.factor @@ -16,6 +16,6 @@ USE: test ] [ dupd pred ack >r pred r> ack ] ifte - ] ifte ; compiled + ] ifte ; [ 4093 ] [ 3 9 ack ] unit-test diff --git a/library/test/errors.factor b/library/test/errors.factor index 7c3a6904a5..0b16ffc7d4 100644 --- a/library/test/errors.factor +++ b/library/test/errors.factor @@ -5,6 +5,8 @@ USE: namespaces USE: stack USE: test USE: lists +USE: parser +USE: stdio [ f ] [ [ ] [ ] catch ] unit-test @@ -16,5 +18,10 @@ USE: lists "Hello" = ] unit-test -[ ] [ [ ] print-error ] unit-test -[ ] [ [ 2 car ] print-error ] unit-test +"!!! The following error is part of the test" print + +[ ] [ [ 6 [ 12 [ "2 car" ] ] ] default-error-handler ] unit-test + +"!!! The following error is part of the test" print + +[ [ "2 car" ] parse ] [ default-error-handler ] catch diff --git a/library/test/threads.factor b/library/test/threads.factor index 0a298d9bcb..d537bbcc97 100644 --- a/library/test/threads.factor +++ b/library/test/threads.factor @@ -15,3 +15,4 @@ USE: errors [ 2 ] [ yield "x" get ] unit-test [ ] [ [ flush ] in-thread flush ] unit-test [ ] [ [ "Errors, errors" throw ] in-thread ] unit-test +yield diff --git a/library/tools/debugger.factor b/library/tools/debugger.factor index 06ed1bf62f..54efff5857 100644 --- a/library/tools/debugger.factor +++ b/library/tools/debugger.factor @@ -147,12 +147,16 @@ USE: math : :s ( -- ) "error-datastack" get {.} ; : :r ( -- ) "error-callstack" get {.} ; : :n ( -- ) "error-namestack" get [.] ; -: :c ( -- ) "error-catchstack" get {.} ; +: :c ( -- ) "error-catchstack" get [.] ; : :get ( var -- value ) "error-namestack" get (get) ; +: flush-error-handler ( error -- ) + #! Last resort. + [ "Error in default error handler!" print drop ] when ; + : default-error-handler ( error -- ) - #! Print the error and return to the top level. + #! Print the error. [ in-parser? [ parse-dump ] [ standard-dump ] ifte @@ -160,7 +164,9 @@ USE: math "show stacks at time of error." print \ :get prettyprint-word " ( var -- value ) inspects the error namestack." print - ] when* ; + ] [ + flush-error-handler + ] catch ; : print-error ( quot -- ) #! Execute a quotation, and if it throws an error, print it diff --git a/library/tools/inference.factor b/library/tools/inference.factor index 01d1d69644..c9d29d7ec8 100644 --- a/library/tools/inference.factor +++ b/library/tools/inference.factor @@ -145,14 +145,14 @@ DEFER: (infer) : apply-compound ( word -- ) #! Infer a compound word's stack effect. - dup "inline" word-property [ + dup "inline-infer" word-property [ inline-compound ] [ [ infer-compound consume/produce ] [ [ - dup t "inline" set-word-property + dup t "inline-infer" set-word-property inline-compound ] when ] catch diff --git a/library/tools/interpreter.factor b/library/tools/interpreter.factor index 7f3566ad0b..d915463789 100644 --- a/library/tools/interpreter.factor +++ b/library/tools/interpreter.factor @@ -44,6 +44,7 @@ USE: stdio ! partial evaluation, also for trace and step. ! Meta-stacks +USE: listener SYMBOL: meta-r : push-r meta-r get vector-push ; : pop-r meta-r get vector-pop ; @@ -176,7 +177,7 @@ SYMBOL: meta-cf : &c #! Print stepper catch stack. - meta-c get {.} ; + meta-c get [.] ; : &get ( var -- value ) #! Print stepper variable value. @@ -197,10 +198,15 @@ SYMBOL: meta-cf " ( var -- value ) inspects the stepper namestack." print \ step prettyprint-word " -- single step" print \ (trace) prettyprint-word " -- trace until end" print - \ (run) prettyprint-word " -- run until end" print ; + \ (run) prettyprint-word " -- run until end" print + \ exit prettyprint-word " -- exit single-stepper" print ; : walk ( quot -- ) #! Single-step through execution of a quotation. - init-interpreter - meta-cf set - walk-banner ; + [ + "walk" listener-prompt set + init-interpreter + meta-cf set + walk-banner + listener + ] with-scope ; diff --git a/library/tools/jedit-wire.factor b/library/tools/jedit-wire.factor index 682791508e..69da9fedc1 100644 --- a/library/tools/jedit-wire.factor +++ b/library/tools/jedit-wire.factor @@ -46,6 +46,7 @@ USE: words ! ! jEdit sends a packet with code to eval, it receives the output ! captured with with-string. +USE: listener : write-packet ( string -- ) dup str-length write-big-endian-32 write flush ; @@ -102,7 +103,8 @@ USE: words : stream-server ( -- ) #! Execute this in the inferior Factor. - "stdio" get "stdio" set ; + "stdio" get "stdio" set + print-banner ; : jedit-lookup ( word vocabs -- ) #! A utility word called by the Factor plugin to get some diff --git a/library/tools/listener.factor b/library/tools/listener.factor index 483fda356a..3963827711 100644 --- a/library/tools/listener.factor +++ b/library/tools/listener.factor @@ -45,18 +45,13 @@ USE: vectors SYMBOL: cont-prompt SYMBOL: listener-prompt +SYMBOL: quit-flag global [ "..." cont-prompt set "ok" listener-prompt set ] bind -: print-banner ( -- ) - "Factor " write version print - "Copyright (C) 2003, 2004 Slava Pestov" print - "Copyright (C) 2004 Chris Double" print - "Type ``exit'' to exit, ``help'' for help." print ; - : prompt. ( text -- ) "prompt" style write-attr ! Print the space without a style, to workaround a bug in @@ -65,7 +60,8 @@ global [ " " write flush ; : exit ( -- ) - "quit-flag" on ; + #! Exit the current listener. + quit-flag on ; : (read-multiline) ( quot depth -- quot ? ) #! Flag indicates EOF. @@ -85,16 +81,14 @@ global [ #! EOF. f depth (read-multiline) >r reverse r> ; -: listener-step ( -- ) +: listen ( -- ) + #! Wait for user input, and execute. listener-prompt get prompt. [ read-multiline [ call ] [ exit ] ifte ] print-error ; -: listener-loop ( -- ) - "quit-flag" get [ - "quit-flag" off - ] [ - listener-step listener-loop - ] ifte ; +: listener ( -- ) + #! Run a listener loop that executes user input. + quit-flag get [ quit-flag off ] [ listen listener ] ifte ; : kb. 1024 /i unparse write " KB" write ; @@ -109,13 +103,14 @@ global [ "Data space: " write (room.) "Code space: " write (room.) ; -: init-listener ( -- ) - print-banner +: print-banner ( -- ) + "Factor " write version print + "Copyright (C) 2003, 2004 Slava Pestov" print + "Copyright (C) 2004 Chris Double" print + "Type ``exit'' to exit, ``help'' for help." print terpri room. - terpri - - listener-loop ; + terpri ; : help ( -- ) "SESSION:" print diff --git a/library/tools/telnetd.factor b/library/tools/telnetd.factor index a0c1603116..813961f628 100644 --- a/library/tools/telnetd.factor +++ b/library/tools/telnetd.factor @@ -42,29 +42,16 @@ USE: threads dup [ "client" set log-client - listener-loop + listener ] with-stream ; : telnet-connection ( socket -- ) [ telnet-client ] in-thread drop ; -: quit-flag ( -- ? ) - global [ "telnetd-quit-flag" get ] bind ; - -: clear-quit-flag ( -- ) - global [ f "telnetd-quit-flag" set ] bind ; - : telnetd-loop ( server -- server ) - quit-flag [ - dup >r accept telnet-connection r> - telnetd-loop - ] unless ; + [ [ accept telnet-connection ] keep ] forever ; : telnetd ( port -- ) [ - [ - telnetd-loop - ] [ - clear-quit-flag swap fclose rethrow - ] catch + [ telnetd-loop ] [ swap fclose rethrow ] catch ] with-logging ;