Clean up class definition recording

core/bootstrap/image/image.factor

@@ -351,12 +351,18 @@ M: curry '
 : emit-words ( -- )
     all-words [ emit-word ] each ;
 
+: fix-source-files
+    [
+        clone dup source-file-definitions H{ } clone 2array
+        over set-source-file-definitions
+    ] assoc-map ;
+
 : emit-global ( -- )
     [
         {
             dictionary source-files
             typemap builtins class<map update-map
-        } [ dup get swap bootstrap-word set ] each
+        } [ dup get swap [ source-files eq? [ fix-source-files ] when ] keep bootstrap-word set ] each
     ] H{ } make-assoc
     bootstrap-global set
     bootstrap-global emit-userenv ;
@@ -444,7 +450,6 @@ PRIVATE>
 
 : make-image ( arch -- )
     [
-        [ drop ] recompile-hook set
         prepare-image
         begin-image
         "resource:/core/bootstrap/stage1.factor" run-file

core/bootstrap/primitives.factor

@@ -19,7 +19,11 @@ crossref off
 "syntax" vocab vocab-words bootstrap-syntax set
 
 "resource:core/bootstrap/syntax.factor" parse-file
+
 H{ } clone dictionary set
+H{ } clone changed-words set
+[ drop ] recompile-hook set
+
 call
 
 ! Create some empty vocabs where the below primitives and

core/cpu/x86/assembler/assembler.factor

@@ -1,6 +1,6 @@
 ! Copyright (C) 2005, 2007 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: arrays generator generator.fixup io.binary kernel
+USING: arrays generator.fixup io.binary kernel
 combinators kernel.private math namespaces parser sequences
 words system ;
 IN: cpu.x86.assembler

core/definitions/definitions-docs.factor

@@ -88,12 +88,7 @@ HELP: redefine-error
 { $description "Throws a " { $link redefine-error } "." }
 { $error-description "Indicates that a single source file contains two definitions for the same artifact, one of which shadows the other. This is an error since it indicates a likely mistake, such as two words accidentally named the same by the developer; the error is restartable." } ;
 
-HELP: redefinition?
+HELP: remember-definition
-{ $values { "definition" "a definition specifier" } { "?" "a boolean" } }
-{ $description "Tests if this definition is already present in the current source file." }
-$parsing-note ;
-
-HELP: (save-location)
 { $values { "definition" "a definition specifier" } { "loc" "a " { $snippet "{ path line# }" } " pair" } }
 { $description "Saves the location of a definition and associates this definition with the current source file."
 $nl

core/definitions/definitions.factor

@@ -54,26 +54,37 @@ TUPLE: redefine-error def ;
     \ redefine-error construct-boa
     { { "Continue" t } } throw-restarts drop ;
 
-: redefinition? ( definition -- ? )
+: add-once ( key assoc -- )
-    new-definitions get key? ;
+    2dup key? [ drop redefine-error ] when dupd set-at ;
 
-: (save-location) ( definition loc -- )
+: (remember-definition) ( definition loc assoc -- )
-    over redefinition? [ over redefine-error ] when
+    >r over set-where r> add-once ;
-    over set-where
+
-    dup new-definitions get set-at ;
+: remember-definition ( definition loc -- )
+    new-definitions get first (remember-definition) ;
+
+: remember-class ( class loc -- )
+    new-definitions get second (remember-definition) ;
 
 TUPLE: forward-error word ;
 
 : forward-error ( word -- )
     \ forward-error construct-boa throw ;
 
+: forward-reference? ( word -- ? )
+    dup old-definitions get assoc-stack
+    [ new-definitions get assoc-stack not ]
+    [ drop f ] if ;
+
 SYMBOL: recompile-hook
 
+: <definitions> ( -- pair ) { H{ } H{ } } [ clone ] map ;
+
 : with-compilation-unit ( quot -- new-defs )
     [
         H{ } clone changed-words set
-        H{ } clone new-definitions set
+        <definitions> new-definitions set
-        old-definitions off
+        <definitions> old-definitions set
         call
         changed-words get keys recompile-hook get call
     ] with-scope ; inline

core/parser/parser-docs.factor

@@ -229,7 +229,7 @@ HELP: <lexer>
 
 HELP: location
 { $values { "loc" "a " { $snippet "{ path line# }" } " pair" } }
-{ $description "Outputs the current parser location. This value can be passed to " { $link set-where } " or " { $link (save-location) } "." } ;
+{ $description "Outputs the current parser location. This value can be passed to " { $link set-where } " or " { $link remember-definition } "." } ;
 
 HELP: save-location
 { $values { "definition" "a definition specifier" } }

core/parser/parser-tests.factor

@@ -141,7 +141,7 @@ IN: temporary
         "IN: temporary : smudge-me ;" <string-reader> "foo"
         parse-stream drop
 
-        "foo" source-file source-file-definitions assoc-size
+        "foo" source-file source-file-definitions first assoc-size
     ] unit-test
 
     [ t ] [ "smudge-me" "temporary" lookup >boolean ] unit-test
@@ -158,21 +158,21 @@ IN: temporary
         "IN: temporary USING: math strings ; GENERIC: smudge-me M: integer smudge-me ; M: string smudge-me ;" <string-reader> "foo"
         parse-stream drop
 
-        "foo" source-file source-file-definitions assoc-size
+        "foo" source-file source-file-definitions first assoc-size
     ] unit-test
 
     [ 1 ] [
         "IN: temporary USING: arrays ; M: array smudge-me ;" <string-reader> "bar"
         parse-stream drop
 
-        "bar" source-file source-file-definitions assoc-size
+        "bar" source-file source-file-definitions first assoc-size
     ] unit-test
 
     [ 2 ] [
         "IN: temporary USING: math strings ; GENERIC: smudge-me M: integer smudge-me ;" <string-reader> "foo"
         parse-stream drop
 
-        "foo" source-file source-file-definitions assoc-size
+        "foo" source-file source-file-definitions first assoc-size
     ] unit-test
     
     [ t ] [
@@ -217,7 +217,7 @@ IN: temporary
 
     [ t ] [
         [
-            "IN: temporary : x ; : y 3 throw ; parsing y"
+            "IN: temporary : x ; : y 3 throw ; this is an error"
             <string-reader> "a" parse-stream
         ] catch parse-error?
     ] unit-test
@@ -376,9 +376,9 @@ IN: temporary
     : ~c ;
     : ~d ;
 
-    H{ { ~a ~a } { ~c ~c } { ~d ~d } } old-definitions set
+    { H{ { ~a ~a } { ~c ~c } { ~d ~d } } H{ } } old-definitions set
     
-    H{ { ~d ~d } } new-definitions set
+    { H{ { ~d ~d } } H{ } } new-definitions set
     
     [ V{ ~b } { ~a } { ~a ~c } ] [
         smudged-usage

core/parser/parser.factor

@@ -20,7 +20,10 @@ TUPLE: lexer text line column ;
     [ >r source-file-path r> 2array ] [ 2drop f ] if ;
 
 : save-location ( definition -- )
-    location (save-location) ;
+    location remember-definition ;
+
+: save-class-location ( class -- )
+    location remember-class ;
 
 SYMBOL: parser-notes
 
@@ -217,7 +220,7 @@ PREDICATE: unexpected unexpected-eof
 
 : CREATE-CLASS ( -- word )
     scan in get create
-    dup <class-definition> save-location
+    dup save-class-location
     dup predicate-word save-location ;
 
 : word-restarts ( possibilities -- restarts )
@@ -235,14 +238,6 @@ M: no-word summary
     swap words-named word-restarts throw-restarts
     dup word-vocabulary (use+) ;
 
-: forward-reference? ( word -- ? )
-    {
-        { [ dup old-definitions get key? over <class-definition> old-definitions get key? or not ] [ f ] }
-        { [ dup new-definitions get key? ] [ f ] }
-        { [ dup <class-definition> new-definitions get key? ] [ f ] }
-        { [ t ] [ t ] }
-    } cond nip ;
-
 : check-forward ( str word -- word )
     dup forward-reference? [
         drop
@@ -270,7 +265,8 @@ M: staging-violation summary
     "A parsing word cannot be used in the same file it is defined in." ;
 
 : execute-parsing ( word -- )
-    dup new-definitions get key? [ staging-violation ] when
+    dup
+    new-definitions get first key? [ staging-violation ] when
     execute ;
 
 : parse-step ( accum end -- accum ? )
@@ -380,9 +376,10 @@ SYMBOL: bootstrap-syntax
         file get source-file-path =
     ] assoc-subset ;
 
+: removed-definitions ( -- definitions ) new-definitions get old-definitions get [ first2 union ] 2apply diff ;
+
 : smudged-usage ( -- usages referenced removed )
-    new-definitions get old-definitions get diff filter-moved
+    removed-definitions filter-moved keys [
-    keys [
         outside-usages
         [ empty? swap pathname? or not ] assoc-subset
         dup values concat prune swap keys

core/source-files/source-files-docs.factor

@@ -37,7 +37,7 @@ HELP: source-file
         { { $link source-file-modified } " - the result of " { $link file-modified } " at the time the source file was most recently loaded." }
         { { $link source-file-checksum } " - the CRC32 checksum of the source file's contents at the time it was most recently loaded." }
         { { $link source-file-uses } " - an assoc whose keys are words referenced from this source file's top level form." }
-        { { $link source-file-definitions } " - an assoc whose keys are definitions defined in this source file." }
+        { { $link source-file-definitions } " - a pair of assocs, containing definitions and classes defined in this source file, respectively" }
     }
 } ;
 

core/source-files/source-files.factor

@@ -58,7 +58,9 @@ uses definitions ;
     new-definitions get swap set-source-file-definitions ;
 
 : <source-file> ( path -- source-file )
-    { set-source-file-path } \ source-file construct ;
+    <definitions>
+    { set-source-file-path set-source-file-definitions }
+    \ source-file construct ;
 
 : source-file ( path -- source-file )
     source-files get [ <source-file> ] cache ;
@@ -74,13 +76,13 @@ M: pathname where pathname-string 1 2array ;
 : forget-source ( path -- )
     dup source-file
     dup unxref-source
-    source-file-definitions keys forget-all
+    source-file-definitions [ keys forget-all ] each
     source-files get delete-at ;
 
 M: pathname forget pathname-string forget-source ;
 
 : rollback-source-file ( source-file -- )
-    dup source-file-definitions new-definitions get union
+    dup source-file-definitions new-definitions get [ union ] 2map
     swap set-source-file-definitions ;
 
 SYMBOL: file

core/syntax/syntax.factor

@@ -95,7 +95,7 @@ IN: bootstrap.syntax
 
     "DEFER:" [
         scan in get create
-        dup old-definitions get delete-at
+        dup old-definitions get first delete-at
         set-word
     ] define-syntax
 
@@ -128,7 +128,7 @@ IN: bootstrap.syntax
         location >r
         scan-word bootstrap-word scan-word
         [ parse-definition <method> -rot define-method ] 2keep
-        2array r> (save-location)
+        2array r> remember-definition
     ] define-syntax
 
     "UNION:" [

extra/help/definitions/definitions-tests.factor

@@ -12,7 +12,7 @@ IN: temporary
         "IN: temporary USING: help.syntax ; : hello ; HELP: hello \"test\" ; ARTICLE: \"hello\" \"world\" ; ARTICLE: \"hello2\" \"world\" ;" <string-reader> "foo"
         parse-stream drop
 
-        "foo" source-file source-file-definitions assoc-size
+        "foo" source-file source-file-definitions first assoc-size
     ] unit-test
 
     [ t ] [ "hello" articles get key? ] unit-test
@@ -25,7 +25,7 @@ IN: temporary
         "IN: temporary USING: help.syntax ; : hello ; ARTICLE: \"hello\" \"world\" ;" <string-reader> "foo"
         parse-stream drop
 
-        "foo" source-file source-file-definitions assoc-size
+        "foo" source-file source-file-definitions first assoc-size
     ] unit-test
 
     [ t ] [ "hello" articles get key? ] unit-test

extra/help/syntax/syntax.factor

@@ -13,7 +13,7 @@ IN: help.syntax
 : ARTICLE:
     location >r
     \ ; parse-until >array [ first2 ] keep 2 tail <article>
-    over add-article >link r> (save-location) ; parsing
+    over add-article >link r> remember-definition ; parsing
 
 : ABOUT:
     scan-word dup parsing? [