telnetd fix

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

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

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
 

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

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

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 ;

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)

library/syntax/prettyprint.factor

@@ -116,10 +116,10 @@ DEFER: prettyprint*
     write-attr ;
 
 : prettyprint-[ ( indent -- indent )
-        \ [ prettyprint-word <prettyprint ;
+    \ [ prettyprint-word <prettyprint ;
 
 : prettyprint-] ( indent -- indent )
-        prettyprint> \ ] 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 ;
+    \ {{ prettyprint-word <prettyprint ;
 
 : prettyprint-}} ( indent -- indent )
-        prettyprint> \ }} 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 ;

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

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

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

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

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

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 ;

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 <jedit-stream> "stdio" set ;
+    "stdio" get <jedit-stream> "stdio" set
+    print-banner ;
 
 : jedit-lookup ( word vocabs -- )
     #! A utility word called by the Factor plugin to get some

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

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 -- )
     [
-        <server> [
-            telnetd-loop
-        ] [
-            clear-quit-flag swap fclose rethrow
-        ] catch
+        <server> [ telnetd-loop ] [ swap fclose rethrow ] catch
     ] with-logging ;