Factor out some compiler error code into source-files.errors

basis/debugger/debugger.factor

@@ -9,7 +9,8 @@ combinators generic.math classes.builtin classes compiler.units
 generic.standard vocabs init kernel.private io.encodings
 accessors math.order destructors source-files parser
 classes.tuple.parser effects.parser lexer compiler.errors
-generic.parser strings.parser vocabs.loader vocabs.parser see ;
+generic.parser strings.parser vocabs.loader vocabs.parser see
+source-files.errors ;
 IN: debugger
 
 GENERIC: error. ( error -- )
@@ -268,11 +269,6 @@ M: duplicate-slot-names summary
 M: invalid-slot-name summary
     drop "Invalid slot name" ;
 
-: file. ( file -- ) path>> <pathname> . ;
-
-M: source-file-error error.
-    [ file>> file. ] [ error>> error. ] bi ;
-
 M: source-file-error summary
     error>> summary ;
 
@@ -309,12 +305,13 @@ M: lexer-error compute-restarts
 M: lexer-error error-help
     error>> error-help ;
 
-M: compiler-error compiler-error. ( error -- )
+M: source-file-error error.
     [
         [
             [
-                [ line#>> # ": " % ]
+                [ file>> [ % ": " % ] when* ]
-                [ word>> synopsis % ] bi
+                [ line#>> [ # ": " % ] when* ]
+                [ summary % ] tri
             ] "" make
         ] [
             [
@@ -324,7 +321,7 @@ M: compiler-error compiler-error. ( error -- )
         ] bi format nl
     ] [ error>> error. ] bi ;
 
-M: compiler-error error. compiler-error. ;
+M: compiler-error summary word>> synopsis ;
 
 M: bad-effect summary
     drop "Bad stack effect declaration" ;

basis/tools/errors/authors.txt

@@ -0,0 +1 @@
+Slava Pestov

basis/tools/errors/errors.factor

@@ -0,0 +1,25 @@
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: assocs compiler.errors debugger io kernel sequences
+source-files.errors ;
+IN: tools.errors
+
+#! Tools for source-files.errors. Used by tools.tests and others
+#! for error reporting
+
+: errors. ( errors -- )
+    group-by-source-file sort-errors
+    [
+        [ nl "==== " write print nl ]
+        [ [ nl ] [ error. ] interleave ]
+        bi*
+    ] assoc-each ;
+
+: compiler-errors. ( type -- )
+    errors-of-type errors. ;
+
+: :errors ( -- ) +error+ compiler-errors. ;
+
+: :warnings ( -- ) +warning+ compiler-errors. ;
+
+: :linkage ( -- ) +linkage+ compiler-errors. ;

core/compiler/errors/errors.factor

@@ -1,15 +1,13 @@
 ! Copyright (C) 2007, 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: kernel namespaces make assocs io sequences
-sorting continuations math math.order math.parser accessors
+continuations math math.parser accessors definitions
-definitions ;
+source-files.errors ;
 IN: compiler.errors
 
-SYMBOL: +error+
+SYMBOLS: +error+ +warning+ +linkage+ ;
-SYMBOL: +warning+
-SYMBOL: +linkage+
 
-TUPLE: compiler-error error word file line# ;
+TUPLE: compiler-error < source-file-error word ;
 
 GENERIC: compiler-error-type ( error -- ? )
 
@@ -17,8 +15,6 @@ M: object compiler-error-type drop +error+ ;
 
 M: compiler-error compiler-error-type error>> compiler-error-type ;
 
-GENERIC: compiler-error. ( error -- )
-
 SYMBOL: compiler-errors
 
 compiler-errors [ H{ } clone ] initialize
@@ -30,20 +26,6 @@ SYMBOL: with-compiler-errors?
     swap [ [ nip compiler-error-type ] dip eq? ] curry
     assoc-filter ;
 
-: sort-compile-errors ( assoc -- alist )
-    [ [ [ line#>> ] compare ] sort ] { } assoc-map-as sort-keys ;
-
-: group-by-source-file ( errors -- assoc )
-    H{ } clone [ [ push-at ] curry [ nip dup file>> ] prepose assoc-each ] keep ;
-
-: compiler-errors. ( type -- )
-    errors-of-type group-by-source-file sort-compile-errors
-    [
-        [ nl "==== " write print nl ]
-        [ [ nl ] [ compiler-error. ] interleave ]
-        bi*
-    ] assoc-each ;
-
 : (compiler-report) ( what type word -- )
     over errors-of-type assoc-empty? [ 3drop ] [
         [
@@ -62,14 +44,12 @@ SYMBOL: with-compiler-errors?
     "semantic warnings" +warning+ "warnings" (compiler-report)
     "linkage errors" +linkage+ "linkage" (compiler-report) ;
 
-: :errors ( -- ) +error+ compiler-errors. ;
-
-: :warnings ( -- ) +warning+ compiler-errors. ;
-
-: :linkage ( -- ) +linkage+ compiler-errors. ;
-
 : <compiler-error> ( error word -- compiler-error )
-    dup where [ first2 ] [ "<unknown file>" 0 ] if* \ compiler-error boa ;
+    \ compiler-error new
+        swap
+        [ >>word ]
+        [ where [ first2 ] [ "<unknown file>" 0 ] if* [ >>file ] [ >>line# ] bi* ] bi
+        swap >>error ;
 
 : compiler-error ( error word -- )
     compiler-errors get-global pick

core/parser/parser-tests.factor

@@ -3,7 +3,7 @@ io.streams.string namespaces classes effects source-files assocs
 sequences strings io.files io.pathnames definitions
 continuations sorting classes.tuple compiler.units debugger
 vocabs vocabs.loader accessors eval combinators lexer
-vocabs.parser words.symbol multiline ;
+vocabs.parser words.symbol multiline source-files.errors ;
 IN: parser.tests
 
 \ run-file must-infer

core/parser/parser.factor

@@ -190,6 +190,7 @@ SYMBOL: interactive-vocabs
     "tools.annotations"
     "tools.crossref"
     "tools.disassembler"
+    "tools.errors"
     "tools.memory"
     "tools.profiler"
     "tools.test"

core/source-files/errors/authors.txt

@@ -0,0 +1 @@
+Slava Pestov

core/source-files/errors/errors.factor

@@ -0,0 +1,12 @@
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors assocs kernel math.order sorting ;
+IN: source-files.errors
+
+TUPLE: source-file-error error file line# ;
+
+: sort-errors ( assoc -- alist )
+    [ [ [ line#>> ] compare ] sort ] { } assoc-map-as sort-keys ;
+
+: group-by-source-file ( errors -- assoc )
+    H{ } clone [ [ push-at ] curry [ nip dup file>> ] prepose assoc-each ] keep ;

core/source-files/source-files.factor

@@ -4,7 +4,7 @@ USING: arrays definitions generic assocs kernel math namespaces
 sequences strings vectors words quotations io io.files
 io.pathnames combinators sorting splitting math.parser effects
 continuations checksums checksums.crc32 vocabs hashtables graphs
-compiler.units io.encodings.utf8 accessors ;
+compiler.units io.encodings.utf8 accessors source-files.errors ;
 IN: source-files
 
 SYMBOL: source-files
@@ -77,21 +77,20 @@ M: pathname forget*
 
 SYMBOL: file
 
-TUPLE: source-file-error error file ;
+: wrap-source-file-error ( error -- * )
-
+    file get rollback-source-file
-: <source-file-error> ( msg -- error )
     \ source-file-error new
-        file get >>file
+        f >>line#
-        swap >>error ;
+        file get path>> >>file
+        swap >>error rethrow  ;
 
 : with-source-file ( name quot -- )
     #! Should be called from inside with-compilation-unit.
     [
-        swap source-file
-        dup file set
-        definitions>> old-definitions set
         [
-            file get rollback-source-file
+            source-file
-            <source-file-error> rethrow
+            [ file set ]
-        ] recover
+            [ definitions>> old-definitions set ] bi
+        ] dip
+        [ wrap-source-file-error ] recover
     ] with-scope ; inline