better error reporting

diff --git a/TODO.FACTOR.txt b/TODO.FACTOR.txt
index d944b115807800628dd98541bbfb2fc464e9b00e..ea52a4df89916982de05ef67a357b0580bb445b6 100644 (file)
--- a/TODO.FACTOR.txt
+++ b/TODO.FACTOR.txt
@@ -9,7 +9,6 @@
 \r
 - type inference\r
 - handle odd base cases, with code after ifte\r
-- handle recursion with when, when* etc\r
 \r
 + compiler:\r
 \r

diff --git a/library/bootstrap/init-stage2.factor b/library/bootstrap/init-stage2.factor
index 5d550746d10a9e6589235c9ba935040f88037ba6..3bb64a86e623ceb0a1a2d58cd03831e21ee2466d 100644 (file)
--- a/library/bootstrap/init-stage2.factor
+++ b/library/bootstrap/init-stage2.factor
@@ -118,8 +118,10 @@ os "win32" = "compile" get and [
 "Compiling system..." print
 "compile" get [ compile-all ] when
 
+terpri
 "Unless you're working on the compiler, ignore the errors above." print
 "Not every word compiles, by design." print
+terpri
 
 0 [ compiled? [ succ ] when ] each-word
 unparse write " words compiled" print

diff --git a/library/compiler/compiler.factor b/library/compiler/compiler.factor
index 9f604999c58926c9474763c92248c1f911d72836..1f0bb60ee4934f4c0168a44e73a989b93b45b299 100644 (file)
--- a/library/compiler/compiler.factor
+++ b/library/compiler/compiler.factor
@@ -86,7 +86,7 @@ M: compound (compile) ( word -- )
 : cannot-compile ( word error -- )
     "verbose-compile" get [
         "Cannot compile " write swap .
-        default-error-handler
+        print-error
     ] [
         2drop
     ] ifte ;

diff --git a/library/eval-catch.factor b/library/eval-catch.factor
index b77c72a1a60d52a4629850efef9d3c2fb828dda1..6e40f2d90d3ed9351e92f43ba55f21fe7284146f 100644 (file)
--- a/library/eval-catch.factor
+++ b/library/eval-catch.factor
@@ -31,7 +31,7 @@ USE: errors
 USE: stdio
 
 : eval-catch ( str -- )
-    [ eval ] [ [ default-error-handler drop ] when* ] catch ;
+    [ eval ] [ [ print-error debug-help drop ] when* ] catch ;
 
 : eval>string ( in -- out )
     [ eval-catch ] with-string ;

diff --git a/library/httpd/httpd.factor b/library/httpd/httpd.factor
index db94bacccca990a224cefbfc3fc1dcf2c0ca6496..b0822ac90d47bf3e17f76670271ba53fc24c513d 100644 (file)
--- a/library/httpd/httpd.factor
+++ b/library/httpd/httpd.factor
@@ -86,7 +86,7 @@ USE: url-encoding
             stdio get "client" set log-client
             read [ parse-request ] when*
         ] with-stream
-    ] print-error ;
+    ] try ;
 
 : httpd-connection ( socket -- )
     "http-server" get accept [ httpd-client ] in-thread drop ;

diff --git a/library/in-thread.factor b/library/in-thread.factor
index cfda3f0b64a7b75fb5ca988a47ac5c72c0c3ad56..37ff962057eaa1d536d58423b885c7fd7348ec56 100644 (file)
--- a/library/in-thread.factor
+++ b/library/in-thread.factor
@@ -42,6 +42,6 @@ USE: lists
         ! Clear stacks since we never go up from this point
         [ ] set-catchstack
         { } set-callstack
-        print-error
+        try
         (yield)
     ] callcc0 drop ;

diff --git a/library/inference/branches.factor b/library/inference/branches.factor
index b4025926a38969be5b441f4bbb614138cbc33d2b..51ad120578de2cf170630aa991e99b7ebb7754c4 100644 (file)
--- a/library/inference/branches.factor
+++ b/library/inference/branches.factor
@@ -87,9 +87,11 @@ USE: prettyprint
     unify-lengths unify-stacks ;
 
 : check-lengths ( list -- )
-    [ vector-length ] map all=? [
-        "Unbalanced return stack effect" throw
-    ] unless ;
+    dup [ vector-length ] map all=? [
+        drop
+    ] [
+        "Unbalanced return stack effect:" <multi-error> throw
+    ] ifte ;
 
 : unify-callstacks ( list -- datastack )
     [ [ meta-r get ] bind ] map

diff --git a/library/io/stdio.factor b/library/io/stdio.factor
index 6654ae77eedd14da7f96828f671196ec3051978f..04b0457829adb1b8f6a68abd1cc640fee48a4aaf 100644 (file)
--- a/library/io/stdio.factor
+++ b/library/io/stdio.factor
@@ -71,5 +71,12 @@ M: stdio-stream fclose ( -- )
 C: stdio-stream ( delegate -- stream )
     [ delegate set ] extend ;
 
+: with-prefix ( prefix quot -- )
+    #! Each line of output from the given quotation is prefixed
+    #! with a string.
+    swap stdio get <prefix-stream> [
+        stdio set call
+    ] with-scope ; inline
+
 ! Set this to a quotation in init code, depending on OS.
 SYMBOL: smart-term-hook

diff --git a/library/io/stream.factor b/library/io/stream.factor
index 6e89459f19041a94b72fc690771b0ba43e34f6c1..e6172a2cd56d9af7930e26c0d881a023f28a3929 100644 (file)
--- a/library/io/stream.factor
+++ b/library/io/stream.factor
@@ -31,6 +31,7 @@ USE: kernel
 USE: namespaces
 USE: strings
 USE: generic
+USE: lists
 
 GENERIC: fflush      ( stream -- )
 GENERIC: fauto-flush ( stream -- )
@@ -71,3 +72,24 @@ M: string-output-stream fauto-flush ( stream -- )
 C: string-output-stream ( size -- stream )
     #! Creates a new stream for writing to a string buffer.
     [ <sbuf> "buf" set ] extend ;
+
+! Prefix stream prefixes each line with a given string.
+TRAITS: prefix-stream
+SYMBOL: prefix
+SYMBOL: last-newline
+
+M: prefix-stream fwrite-attr ( string style stream -- )
+    [
+        last-newline get [
+            prefix get delegate get fwrite last-newline off
+        ] when
+
+        dupd delegate get fwrite-attr
+
+        "\n" str-tail? [
+            last-newline on
+        ] when
+    ] bind ;
+
+C: prefix-stream ( prefix stream -- stream )
+    [ last-newline on delegate set prefix set ] extend ;

diff --git a/library/syntax/prettyprint.factor b/library/syntax/prettyprint.factor
index 68148e6cb71ee051e7e569f51aec76ade844270e..a6f15114ac01fca2e84589a6afb98f6b467f1c3e 100644 (file)
--- a/library/syntax/prettyprint.factor
+++ b/library/syntax/prettyprint.factor
@@ -53,12 +53,12 @@ M: object prettyprint* ( indent obj -- indent )
     #! Avoid infinite loops -- maximum indent, 10 levels.
     "prettyprint-limit" get [ 40 ] unless* ;
 
-: prettyprint-indent ( indent -- )
+: indent ( indent -- )
     #! Print the given number of spaces.
     " " fill write ;
 
 : prettyprint-newline ( indent -- )
-    "\n" write prettyprint-indent ;
+    "\n" write indent ;
 
 : prettyprint-space ( -- )
     " " write ;

diff --git a/library/test/errors.factor b/library/test/errors.factor
index db0be3163413e4e5aea1b460db0f8068a85feb12..2188a34c7d946bda36dcf92eb7cce0c8e8af3aea 100644 (file)
--- a/library/test/errors.factor
+++ b/library/test/errors.factor
@@ -19,11 +19,11 @@ USE: stdio
 
 "!!! The following error is part of the test" print
 
-[ ] [ [ 6 [ 12 [ "2 car" ] ] ] default-error-handler ] unit-test
+[ ] [ [ 6 [ 12 [ "2 car" ] ] ] print-error ] unit-test
 
 "!!! The following error is part of the test" print
 
-[ [ "2 car" ] parse ] [ default-error-handler ] catch
+[ [ "2 car" ] parse ] [ print-error ] catch
 
 [ [ "\"\" { } vector-nth" ] parse ] [ type-check-error ] catch
 

diff --git a/library/tools/debugger.factor b/library/tools/debugger.factor
index c7678d6f27c4272dbe55e02bd132a24f162e2699..e4d90dfe8a9636e076a00abccf3076733006ca07 100644 (file)
--- a/library/tools/debugger.factor
+++ b/library/tools/debugger.factor
@@ -105,8 +105,13 @@ USE: generic
 : port-closed-error ( obj -- )
     "Port closed: " write . ;
 
-: kernel-error. ( obj n -- str )
-    {
+GENERIC: error. ( error -- )
+
+PREDICATE: cons kernel-error ( obj -- ? )
+    uncons cons? swap fixnum? and ;
+
+M: kernel-error error. ( error -- )
+    uncons car swap {
         expired-error
         io-task-twice-error
         no-io-tasks-error
@@ -124,33 +129,49 @@ USE: generic
         port-closed-error
     } vector-nth execute ;
 
-: kernel-error? ( obj -- ? )
-    dup cons? [ uncons cons? swap fixnum? and ] [ drop f ] ifte ;
+M: string error. ( error -- )
+    print ;
 
-: error. ( error -- str )
-    dup kernel-error? [
-        uncons car swap kernel-error.
-    ] [
-        dup string? [ print ] [ . ] ifte
-    ] ifte ;
+TRAITS: chained-error
+SYMBOL: original-error
+
+C: chained-error ( original chain -- )
+    [ chained-error set original-error set ] extend ;
 
-: standard-dump ( error -- )
-    "ERROR: " write error. ;
+M: chained-error error. ( error -- )
+    [
+        chained-error get error.
+        " " [ original-error get error. ] with-prefix
+    ] bind ;
+
+TRAITS: multi-error
+
+C: multi-error ( list message -- )
+    [ original-error set multi-error set ] extend ;
 
-: parse-dump ( error -- )
+M: multi-error error. ( error -- )
     [
+        original-error get error.
+        " " [ multi-error get [ . ] each ] with-prefix
+    ] bind ;
+
+M: object error. ( error -- )
+    . ;
+
+: in-parser? ( -- ? )
+    "error-line" get "error-col" get and ;
+
+: parse-dump ( -- )
+    [
+        "Parsing " ,
         "error-file" get [ "<interactive>" ] unless* , ":" ,
-        "error-line-number" get [ 1 ] unless* unparse , ": " ,
-    ] make-string write
-    error.
+        "error-line-number" get [ 1 ] unless* unparse ,
+    ] make-string print
     
     "error-line" get print
     
     [ "error-col" get " " fill , "^" , ] make-string print ;
 
-: in-parser? ( -- ? )
-    "error-line" get "error-col" get and ;
-
 : :s ( -- ) "error-datastack"  get {.} ;
 : :r ( -- ) "error-callstack"  get {.} ;
 : :n ( -- ) "error-namestack"  get [.] ;
@@ -158,31 +179,34 @@ USE: generic
 
 : :get ( var -- value ) "error-namestack" get (get) ;
 
+: debug-help ( -- )
+    [ :s :r :n :c ] [ prettyprint-1 " " write ] each
+    "show stacks at time of error." print
+    \ :get prettyprint-1
+    " ( var -- value ) inspects the error namestack." print ;
+
 : flush-error-handler ( error -- )
     #! Last resort.
     [ "Error in default error handler!" print drop ] when ;
 
-: default-error-handler ( error -- )
+: print-error ( error -- )
     #! Print the error.
     [
-        in-parser? [ parse-dump ] [ standard-dump ] ifte
-
-        [ :s :r :n :c ] [ prettyprint-1 " " write ] each
-        "show stacks at time of error." print
-        \ :get prettyprint-1
-        " ( var -- value ) inspects the error namestack." print
+        "! " [
+            in-parser? [ parse-dump ] when error.
+        ] with-prefix
     ] [
         flush-error-handler
     ] catch ;
 
-: print-error ( quot -- )
+: try ( quot -- )
     #! Execute a quotation, and if it throws an error, print it
     #! and return to the caller.
-    [ [ default-error-handler ] when* ] catch ;
+    [ [ print-error debug-help ] when* ] catch ;
 
 : init-error-handler ( -- )
     [ 1 exit* ] >c ( last resort )
-    [ default-error-handler 1 exit* ] >c
+    [ print-error 1 exit* ] >c
     [ dup save-error rethrow ] 5 setenv ( kernel calls on error ) ;
 
 ! So that stage 2 boot gives a useful error message if something

diff --git a/library/tools/listener.factor b/library/tools/listener.factor
index 022f5c5e05c23e00ba3d589a794d172a383583f7..9b7684d6980cbfd40e32da8e3d94f4c8a8f39c4c 100644 (file)
--- a/library/tools/listener.factor
+++ b/library/tools/listener.factor
@@ -80,7 +80,7 @@ global [
 : listen ( -- )
     #! Wait for user input, and execute.
     listener-prompt get prompt.
-    [ read-multiline [ call ] [ exit ] ifte ] print-error ;
+    [ read-multiline [ call ] [ exit ] ifte ] try ;
 
 : listener ( -- )
     #! Run a listener loop that executes user input.