New implementation of compiler error reporting

core/bootstrap/stage2.factor

@@ -4,7 +4,7 @@ USING: init command-line namespaces words debugger io
 kernel.private math memory continuations kernel io.files
 io.backend system parser vocabs sequences prettyprint
 vocabs.loader combinators splitting source-files strings
-definitions assocs ;
+definitions assocs compiler.errors ;
 IN: bootstrap.stage2
 
 ! Wrap everything in a catch which starts a listener so
@@ -37,21 +37,25 @@ IN: bootstrap.stage2
         "none" require
     ] if
 
-    "exclude" "include"
-    [ get-global " " split [ empty? not ] subset ] 2apply
-    seq-diff
-    [ "bootstrap." swap append require ] each
+    [
+        "exclude" "include"
+        [ get-global " " split [ empty? not ] subset ] 2apply
+        seq-diff
+        [ "bootstrap." swap append require ] each
 
-    init-io
-    init-stdio
+        init-io
+        init-stdio
 
-    run-bootstrap-init
+        run-bootstrap-init
+
+        "Compiling remaining words..." print
+
+        all-words [ compiled? not ] subset recompile-hook get call
+    ] with-compiler-errors
 
     f error set-global
     f error-continuation set-global
 
-    all-words [ compiled? not ] subset recompile-hook get call
-
     "deploy-vocab" get [
         "tools.deploy.shaker" run
     ] [

core/compiler/compiler.factor

@@ -3,7 +3,7 @@
 USING: kernel namespaces arrays sequences io inference.backend
 generator debugger math.parser prettyprint words words.private
 continuations vocabs assocs alien.compiler dlists optimizer
-definitions ;
+definitions math compiler.errors ;
 IN: compiler
 
 SYMBOL: compiler-hook
@@ -33,7 +33,7 @@ SYMBOL: compiler-hook
         dup word-dataflow optimize >r over dup r> generate
     ] [
         dup inference-error? [ rethrow ] unless
-        print-error f over compiled get set-at f
+        over compiler-error f over compiled get set-at f
     ] recover
     2drop ;
 !    2dup ripple-up save-effect ;
@@ -63,7 +63,7 @@ SYMBOL: compiler-hook
     ] with-variable execute ;
 
 : recompile-all ( -- )
-    all-words recompile ;
+    [ all-words recompile ] with-compiler-errors ;
 
 : decompile ( word -- )
     f 2array 1array modify-code-heap ;

core/compiler/errors/errors.factor

@@ -0,0 +1,56 @@
+! Copyright (C) 2007 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel namespaces assocs prettyprint io sequences
+sorting continuations debugger math ;
+IN: compiler.errors
+
+SYMBOL: compiler-errors
+
+SYMBOL: with-compiler-errors?
+
+: compiler-error ( error word -- )
+    with-compiler-errors? get [
+        compiler-errors get set-at
+    ] [ 2drop ] if ;
+
+: compiler-error. ( error word -- )
+    nl
+    "While compiling " write pprint ": " print
+    nl
+    print-error ;
+
+: compiler-errors. ( assoc -- )
+    >alist sort-keys [ swap compiler-error. ] assoc-each ;
+
+GENERIC: compiler-warning? ( error -- ? )
+
+: (:errors) ( -- assoc )
+    compiler-errors get-global
+    [ nip compiler-warning? not ] assoc-subset ;
+
+: :errors (:errors) compiler-errors. ;
+
+: (:warnings) ( -- seq )
+    compiler-errors get-global
+    [ nip compiler-warning? ] assoc-subset ;
+
+: :warnings (:warnings) compiler-errors. ;
+
+: (compiler-report) ( what assoc -- )
+    length dup zero? [ 2drop ] [
+        ":" write over write " - print " write pprint
+        " compiler " write write "." print
+    ] if ;
+
+: compiler-report ( -- )
+    "errors" (:errors) (compiler-report)
+    "warnings" (:warnings) (compiler-report) ;
+
+: with-compiler-errors ( quot -- )
+    with-compiler-errors? get "quiet" get or [ call ] [
+        [
+            with-compiler-errors? on
+            V{ } clone compiler-errors set-global
+            [ compiler-report ] [ ] cleanup
+        ] with-scope
+    ] if ; inline

core/continuations/continuations-tests.factor

@@ -71,3 +71,38 @@ IN: temporary
 [ t ] [ \ bar word-def "c" get innermost-frame-quot = ] unit-test
 
 [ 1 ] [ "c" get innermost-frame-scan ] unit-test
+
+SYMBOL: always-counter
+SYMBOL: error-counter
+
+[
+    0 always-counter set
+    0 error-counter set
+
+    [ ] [ always-counter inc ] [ error-counter inc ] cleanup
+
+    [ 1 ] [ always-counter get ] unit-test
+    [ 0 ] [ error-counter get ] unit-test
+
+    [ "a" ] [
+        [
+            [ "a" throw ]
+            [ always-counter inc ]
+            [ error-counter inc ] cleanup
+        ] catch
+    ] unit-test
+
+    [ 2 ] [ always-counter get ] unit-test
+    [ 1 ] [ error-counter get ] unit-test
+
+    [ "a" ] [
+        [
+            [ ]
+            [ always-counter inc "a" throw ]
+            [ error-counter inc ] cleanup
+        ] catch
+    ] unit-test
+
+    [ 3 ] [ always-counter get ] unit-test
+    [ 2 ] [ error-counter get ] unit-test
+] with-scope

core/inference/backend/backend.factor

@@ -4,7 +4,7 @@ IN: inference.backend
 USING: inference.dataflow arrays generic io io.streams.string
 kernel math namespaces parser prettyprint sequences
 strings vectors words quotations effects classes continuations
-debugger assocs combinators ;
+debugger assocs combinators compiler.errors ;
 
 : recursive-label ( word -- label/f )
     recursive-state get at ;
@@ -22,6 +22,9 @@ debugger assocs combinators ;
 
 TUPLE: inference-error rstate major? ;
 
+M: inference-error compiler-warning?
+    inference-error-major? not ;
+
 : (inference-error) ( ... class important? -- * )
     >r construct-boa r>
     recursive-state get {

core/parser/parser.factor

@@ -5,7 +5,7 @@ namespaces prettyprint sequences strings vectors words
 quotations inspector io.styles io combinators sorting
 splitting math.parser effects continuations debugger 
 io.files io.streams.string io.streams.lines vocabs
-source-files classes hashtables ;
+source-files classes hashtables compiler.errors ;
 IN: parser
 
 TUPLE: lexer text line column ;
@@ -354,7 +354,7 @@ SYMBOL: bootstrap-syntax
             "arrays"
             "assocs"
             "combinators"
-            "compiler"
+            "compiler.errors"
             "continuations"
             "debugger"
             "definitions"
@@ -455,9 +455,11 @@ SYMBOL: bootstrap-syntax
 
 : parse-file ( file -- quot )
     [
-        [ parsing-file ] keep
-        [ ?resource-path <file-reader> ] keep
-        parse-stream
+        [
+            [ parsing-file ] keep
+            [ ?resource-path <file-reader> ] keep
+            parse-stream
+        ] with-compiler-errors
     ] [
         over parse-file-restarts rethrow-restarts
         drop parse-file

core/vocabs/loader/loader.factor

@@ -3,7 +3,8 @@
 USING: namespaces splitting sequences io.files kernel assocs
 words vocabs definitions parser continuations inspector debugger
 io io.styles io.streams.lines hashtables sorting prettyprint
-source-files arrays combinators strings system math.parser ;
+source-files arrays combinators strings system math.parser
+compiler.errors ;
 IN: vocabs.loader
 
 SYMBOL: vocab-roots
@@ -108,7 +109,8 @@ SYMBOL: load-help?
         drop no-vocab
     ] if ;
 
-: require ( vocab -- ) load-vocab drop ;
+: require ( vocab -- )
+    load-vocab drop ;
 
 : run ( vocab -- )
     dup load-vocab vocab-main [
@@ -150,11 +152,14 @@ SYMBOL: load-help?
     dup update-roots
     dup modified-sources swap modified-docs ;
 
+: require-each ( seq -- )
+    [ [ require ] each ] with-compiler-errors ;
+
 : do-refresh ( modified-sources modified-docs -- )
     2dup
     [ f swap set-vocab-docs-loaded? ] each
     [ f swap set-vocab-source-loaded? ] each
-    append prune [ require ] each ;
+    append prune require-each ;
 
 : refresh ( prefix -- ) to-refresh do-refresh ;
 
@@ -172,7 +177,7 @@ M: string (load-vocab)
 M: vocab-link (load-vocab)
     vocab-name (load-vocab) ;
 
-[ dup vocab [ ] [ ] ?if (load-vocab) ]
+[ [ dup vocab [ ] [ ] ?if (load-vocab) ] with-compiler-errors ]
 load-vocab-hook set-global
 
 : vocab-where ( vocab -- loc )

extra/tools/annotations/annotations.factor

@@ -6,7 +6,7 @@ IN: tools.annotations
 
 <PRIVATE
 
-: check-compound ( word -- word )
+: check-compound ( word -- )
     compound? [
         "Annotations can only be used with compound words" throw
     ] unless ;

extra/tools/browser/browser.factor

@@ -117,7 +117,7 @@ M: vocab-link summary vocab-summary ;
 : load-everything ( -- )
     all-vocabs-seq
     [ vocab-name dangerous? not ] subset
-    [ require ] each ;
+    require-each ;
 
 : unrooted-child-vocabs ( prefix -- seq )
     dup empty? [ CHAR: . add ] unless
@@ -137,7 +137,7 @@ M: vocab-link summary vocab-summary ;
 
 : load-children ( prefix -- )
     all-child-vocabs values concat
-    [ require ] each ;
+    require-each ;
 
 : vocab-status-string ( vocab -- string )
     {