Merge branch 'smarter_error_list' of git://factorcode.org/git/factor into smarter_error_list

basis/compiler/errors/errors.factor

@@ -25,6 +25,7 @@ T{ error-type
    { plural "compiler errors" }
    { icon "vocab:ui/tools/error-list/icons/compiler-error.tiff" }
    { quot [ +compiler-error+ errors-of-type values ] }
+   { forget-quot [ compiler-errors get delete-at ] }
 } define-error-type
 
 T{ error-type
@@ -33,6 +34,7 @@ T{ error-type
    { plural "compiler warnings" }
    { icon "vocab:ui/tools/error-list/icons/compiler-warning.tiff" }
    { quot [ +compiler-warning+ errors-of-type values ] }
+   { forget-quot [ compiler-errors get delete-at ] }
 } define-error-type
 
 T{ error-type
@@ -41,6 +43,7 @@ T{ error-type
    { plural "linkage errors" }
    { icon "vocab:ui/tools/error-list/icons/linkage-error.tiff" }
    { quot [ +linkage-error+ errors-of-type values ] }
+   { forget-quot [ compiler-errors get delete-at ] }
 } define-error-type
 
 : <compiler-error> ( error word -- compiler-error )
@@ -48,8 +51,7 @@ T{ error-type
 
 : compiler-error ( error word -- )
     compiler-errors get-global pick
-    [ [ [ <compiler-error> ] keep ] dip set-at ] [ delete-at drop ] if
-    notify-error-observers ;
+    [ [ [ <compiler-error> ] keep ] dip set-at ] [ delete-at drop ] if ;
 
 : compiler-errors. ( type -- )
     errors-of-type values errors. ;

basis/debugger/debugger.factor

@@ -268,15 +268,6 @@ M: duplicate-slot-names summary
 M: invalid-slot-name summary
     drop "Invalid slot name" ;
 
-M: source-file-error summary
-    error>> summary ;
-
-M: source-file-error compute-restarts
-    error>> compute-restarts ;
-
-M: source-file-error error-help
-    error>> error-help ;
-
 M: not-in-a-method-error summary
     drop "call-next-method can only be called in a method definition" ;
 
@@ -304,21 +295,6 @@ M: lexer-error compute-restarts
 M: lexer-error error-help
     error>> error-help ;
 
-M: source-file-error error.
-    [
-        [
-            [
-                [ file>> [ % ": " % ] when* ]
-                [ line#>> [ # ": " % ] when* ] bi
-            ] "" make
-        ] [
-            [
-                presented set
-                bold font-style set
-            ] H{ } make-assoc
-        ] bi format
-    ] [ error>> error. ] bi ;
-
 M: bad-effect summary
     drop "Bad stack effect declaration" ;
 

basis/help/lint/lint.factor

@@ -21,6 +21,7 @@ T{ error-type
    { plural "help lint failures" }
    { icon "vocab:ui/tools/error-list/icons/help-lint-error.tiff" }
    { quot [ lint-failures get values ] }
+   { forget-quot [ lint-failures get delete-at ] }
 } define-error-type
 
 M: help-lint-error error-type drop +help-lint-failure+ ;

basis/tools/errors/errors.factor

@@ -1,11 +1,36 @@
 ! Copyright (C) 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: assocs debugger io kernel sequences source-files.errors ;
+USING: assocs debugger io kernel sequences source-files.errors
+summary accessors continuations make math.parser io.styles namespaces ;
 IN: tools.errors
 
 #! Tools for source-files.errors. Used by tools.tests and others
 #! for error reporting
 
+M: source-file-error summary
+    error>> summary ;
+
+M: source-file-error compute-restarts
+    error>> compute-restarts ;
+
+M: source-file-error error-help
+    error>> error-help ;
+
+M: source-file-error error.
+    [
+        [
+            [
+                [ file>> [ % ": " % ] when* ]
+                [ line#>> [ # "\n" % ] when* ] bi
+            ] "" make
+        ] [
+            [
+                presented set
+                bold font-style set
+            ] H{ } make-assoc
+        ] bi format
+    ] [ error>> error. ] bi ;
+
 : errors. ( errors -- )
     group-by-source-file sort-errors
     [

core/compiler/units/units-tests.factor

@@ -1,5 +1,5 @@
 USING: definitions compiler.units tools.test arrays sequences words kernel
-accessors namespaces fry ;
+accessors namespaces fry eval ;
 IN: compiler.units.tests
 
 [ [ [ ] define-temp ] with-compilation-unit ] must-infer
@@ -46,3 +46,16 @@ M: observer definitions-changed 2drop global [ counter inc ] bind ;
 [ ] with-compilation-unit
 
 [ 1 ] [ counter get-global ] unit-test
+
+observer remove-definition-observer
+
+! Notify observers with nested compilation units
+observer add-definition-observer
+
+0 counter set-global
+
+DEFER: nesting-test
+
+[ ] [ "IN: compiler.units.tests << : nesting-test ( -- ) ; >>" eval ] unit-test
+
+observer remove-definition-observer

core/compiler/units/units.factor

@@ -3,7 +3,7 @@
 USING: accessors arrays kernel continuations assocs namespaces
 sequences words vocabs definitions hashtables init sets
 math math.order classes classes.algebra classes.tuple
-classes.tuple.private generic ;
+classes.tuple.private generic source-files.errors ;
 IN: compiler.units
 
 SYMBOL: old-definitions
@@ -132,17 +132,20 @@ GENERIC: definitions-changed ( assoc obj -- )
     changed-generics get compiled-generic-usages
     append assoc-combine keys ;
 
-: unxref-forgotten-definitions ( -- )
-    forgotten-definitions get
-    keys [ word? ] filter
-    [ delete-compiled-xref ] each ;
+: process-forgotten-definitions ( -- )
+    forgotten-definitions get keys
+    [ [ word? ] filter [ delete-compiled-xref ] each ]
+    [ [ delete-definition-errors ] each ]
+    bi ;
 
 : finish-compilation-unit ( -- )
     remake-generics
     to-recompile recompile
     update-tuples
-    unxref-forgotten-definitions
-    modify-code-heap ;
+    process-forgotten-definitions
+    modify-code-heap
+    updated-definitions notify-definition-observers
+    notify-error-observers ;
 
 : with-nested-compilation-unit ( quot -- )
     [
@@ -166,9 +169,5 @@ GENERIC: definitions-changed ( assoc obj -- )
         H{ } clone new-classes set
         <definitions> new-definitions set
         <definitions> old-definitions set
-        [
-            finish-compilation-unit
-            updated-definitions
-            notify-definition-observers
-        ] [ ] cleanup
+        [ finish-compilation-unit ] [ ] cleanup
     ] with-scope ; inline

core/source-files/errors/errors-tests.factor

@@ -0,0 +1,10 @@
+USING: assocs compiler.errors compiler.units definitions
+namespaces source-files.errors tools.test words ;
+IN: source-files.errors.tests
+
+DEFER: forget-test
+
+[ ] [ [ \ forget-test [ 1 ] (( -- )) define-declared ] with-compilation-unit ] unit-test
+[ t ] [ \ forget-test compiler-errors get key? ] unit-test
+[ ] [ [ \ forget-test forget ] with-compilation-unit ] unit-test
+[ f ] [ \ forget-test compiler-errors get key? ] unit-test

core/source-files/errors/errors.factor

@@ -12,7 +12,7 @@ TUPLE: source-file-error error asset file line# ;
 : group-by-source-file ( errors -- assoc )
     H{ } clone [ [ push-at ] curry [ dup file>> ] prepose each ] keep ;
 
-TUPLE: error-type type word plural icon quot ;
+TUPLE: error-type type word plural icon quot forget-quot ;
 
 GENERIC: error-type ( error -- type )
 
@@ -69,3 +69,9 @@ SYMBOL: error-observers
         bi-curry* bi and not
     ] 2curry filter-here
     notify-error-observers ;
+
+: delete-definition-errors ( definition -- )
+    error-types get [
+        second forget-quot>> dup
+        [ call( definition -- ) ] [ 2drop ] if
+    ] with each ;

core/source-files/source-files.factor

@@ -61,8 +61,7 @@ M: pathname where string>> 1 2array ;
     [
         source-file
         [ unxref-source ]
-        [ definitions>> [ keys forget-all ] each ]
-        bi
+        [ definitions>> [ keys forget-all ] each ] bi
     ]
     [ source-files get delete-at ]
     bi ;
@@ -82,7 +81,7 @@ SYMBOL: file
     \ source-file-error new
         f >>line#
         file get path>> >>file
-        swap >>error rethrow  ;
+        swap >>error rethrow ;
 
 : with-source-file ( name quot -- )
     #! Should be called from inside with-compilation-unit.

extra/images/viewer/viewer.factor

@@ -1,4 +1,4 @@
-! Copyright (C) 2007 Doug Coleman.
+! Copyright (C) 2007, 2009 Doug Coleman.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors images images.loader io.pathnames kernel namespaces
 opengl opengl.gl opengl.textures sequences strings ui ui.gadgets
@@ -27,11 +27,8 @@ M: image-gadget draw-gadget* ( gadget -- )
 
 GENERIC: image. ( object -- )
 
-: default-image. ( path -- )
-    <image-gadget> gadget. ;
+M: string image. ( image -- ) load-image image. ;
 
-M: string image. ( image -- ) load-image default-image. ;
+M: pathname image. ( image -- ) load-image image. ;
 
-M: pathname image. ( image -- ) load-image default-image. ;
-
-M: image image. ( image -- ) default-image. ;
+M: image image. ( image -- ) <image-gadget> gadget. ;