Unit test fixes

core/bootstrap/image/image.factor

@@ -351,18 +351,12 @@ 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 [ source-files eq? [ fix-source-files ] when ] keep bootstrap-word set ] each
+        } [ dup get swap bootstrap-word set ] each
     ] H{ } make-assoc
     bootstrap-global set
     bootstrap-global emit-userenv ;

core/compiler/compiler-docs.factor

@@ -77,15 +77,6 @@ HELP: compile-failed
 { $values { "word" word } { "error" "an error" } }
 { $description "Called when the optimizing compiler fails to compile a word. The word is removed from the set of words pending compilation, and it's un-optimized compiled definition will be used. The error is reported by calling " { $link compile-error } "." } ;
 
-HELP: forget-errors
-{ $values { "seq" "a sequence of words" } }
-{ $description "If any of the words in the sequence previously failed to compile, removes the marker indicating such."
-$nl
-"The compiler remembers which words failed to compile as an optimization, so that it does not try to infer the stack effect of words which do not have one over and over again." }
-{ $notes "Usually this word does not need to be called directly; if a word failed to compile because of a stack effect error, fixing the word definition clears the flag automatically. However, if words failed to compile due to external factors which were subsequently rectified, such as an unavailable C library or a missing or broken compiler transform, this flag can be cleared for all words:"
-{ $code "all-words forget-errors" }
-"Subsequent invocations of the compiler will consider all words for compilation." } ;
-
 HELP: compile-batch
 { $values { "seq" "a sequence of words" } }
 { $description "Compiles a batch of words. Any compile errors are summarized at the end and can be viewed with " { $link :warnings } " and " { $link :errors } "." } ;

core/compiler/compiler.factor

@@ -1,8 +1,9 @@
 ! Copyright (C) 2004, 2007 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: kernel namespaces arrays sequences io inference.backend
-generator debugger math.parser prettyprint words continuations
-vocabs assocs alien.compiler dlists optimizer definitions ;
+generator debugger math.parser prettyprint words words.private
+continuations vocabs assocs alien.compiler dlists optimizer
+definitions ;
 IN: compiler
 
 SYMBOL: compiler-hook
@@ -45,14 +46,14 @@ SYMBOL: compiler-hook
         H{ } clone compiled-xts set
         [ queue-compile ] each
         compile-queue get [ (compile) ] dlist-slurp
-        compiled-xts get finish-compilation-unit
+        compiled-xts get >alist modify-code-heap
     ] with-scope ; inline
 
 : compile-quot ( quot -- word )
-    [ gensym dup rot define-compound ] with-compilation-unit ;
+    [ define-temp ] with-compilation-unit ;
 
 : compile-call ( quot -- )
     compile-quot execute ;
 
 : compile-all ( -- )
-    all-words compile-batch ;
+    all-words compile ;

core/compiler/test/alien.factor

@@ -99,12 +99,6 @@ unit-test
     "int" { "int" "int" "int" "int" } "stdcall" alien-indirect
     data-gc ;
 
-! This is a hack -- words are compiled before top-level forms
-! run.
-
-DEFER: >> delimiter
-: << \ >> parse-until >quotation call ; parsing
-
 << "f-stdcall" f "stdcall" add-library >>
 
 [ f ] [ "f-stdcall" load-library ] unit-test

core/definitions/definitions-tests.factor

@@ -7,9 +7,11 @@ M: combination-1 perform-combination 2drop { } [ ] each [ ] ;
 
 SYMBOL: generic-1
 
-generic-1 T{ combination-1 } define-generic
+[
+    generic-1 T{ combination-1 } define-generic
 
-[ ] <method> object \ generic-1 define-method
+    [ ] <method> object \ generic-1 define-method
+] with-compilation-unit
 
 [ ] [
     [

core/definitions/definitions.factor

@@ -85,6 +85,6 @@ SYMBOL: recompile-hook
         H{ } clone changed-words set
         <definitions> new-definitions set
         <definitions> old-definitions set
-        call
-        changed-words get keys recompile-hook get call
+        [ changed-words get keys recompile-hook get call ] [ ]
+        cleanup
     ] with-scope ; inline

core/generator/generator.factor

@@ -22,7 +22,6 @@ SYMBOL: compiled-xts
 : compiling? ( word -- ? )
     {
         { [ dup compiled-xts get key? ] [ drop t ] }
-        { [ dup word-changed? ] [ drop f ] }
         { [ t ] [ compiled? ] }
     } cond ;
 

core/generic/generic-tests.factor

@@ -184,7 +184,11 @@ M: debug-combination perform-combination
 
 SYMBOL: redefinition-test-generic
 
-redefinition-test-generic T{ debug-combination } define-generic
+[
+    redefinition-test-generic
+    T{ debug-combination }
+    define-generic
+] with-compilation-unit
 
 TUPLE: redefinition-test-tuple ;
 

core/inference/inference-docs.factor

@@ -139,3 +139,11 @@ HELP: dataflow-with
 { $values { "quot" "a quotation" } { "stack" "a vector" } { "dataflow" "a dataflow node" } }
 { $description "Attempts to construct a dataflow graph showing stack flow in the quotation, starting with an initial data stack of values." }
 { $errors "Throws an " { $link inference-error } " if stack effect inference fails." } ;
+
+HELP: forget-errors
+{ $description "Removes markers indicating which words do not have stack effects."
+$nl
+"The stack effect inference code remembers which words failed to infer as an optimization, so that it does not try to infer the stack effect of words which do not have one over and over again." }
+{ $notes "Usually this word does not need to be called directly; if a word failed to compile because of a stack effect error, fixing the word definition clears the flag automatically. However, if words failed to compile due to external factors which were subsequently rectified, such as an unavailable C library or a missing or broken compiler transform, this flag can be cleared for all words:"
+{ $code "forget-errors" }
+"Subsequent invocations of the compiler will consider all words for compilation." } ;

core/inference/inference.factor

@@ -3,7 +3,8 @@
 IN: inference
 USING: inference.backend inference.dataflow
 inference.known-words inference.transforms inference.errors
-sequences prettyprint io effects kernel namespaces quotations ;
+sequences prettyprint io effects kernel namespaces quotations
+words vocabs ;
 
 GENERIC: infer ( quot -- effect )
 
@@ -26,5 +27,5 @@ M: callable dataflow-with
         f infer-quot
     ] with-infer nip ;
 
-: forget-errors ( seq -- )
-    [ f "no-effect" set-word-prop ] each ;
+: forget-errors ( -- )
+    all-words [ f "no-effect" set-word-prop ] each ;

core/listener/listener-tests.factor

@@ -1,11 +1,14 @@
-USING: io io.streams.string listener tools.test parser
-math namespaces continuations vocabs ;
+USING: io io.streams.string io.streams.duplex listener
+tools.test parser math namespaces continuations vocabs kernel ;
 IN: temporary
 
 : hello "Hi" print ; parsing
 
+: parse-interactive ( string -- quot )
+    <string-reader> stream-read-quot ;
+
 [ [ ] ] [
-    "USE: temporary hello" <string-reader> parse-interactive
+    "USE: temporary hello" parse-interactive
 ] unit-test
 
 [
@@ -17,11 +20,10 @@ IN: temporary
         [
             "cont" set
             [
-                "\\ + 1 2 3 4" 
-                <string-reader>
-                parse-interactive "cont" get continue-with
+                "\\ + 1 2 3 4" parse-interactive
+                "cont" get continue-with
             ] catch
-            ":1" eval
+            "USE: debugger :1" eval
         ] callcc1
     ] unit-test
 ] with-scope
@@ -31,10 +33,14 @@ IN: temporary
 ] unit-test
 
 [
-    "USE: vocabs.loader.test.c" <string-reader>
-    parse-interactive
+    "USE: vocabs.loader.test.c" parse-interactive
 ] unit-test-fails
 
 [ ] [
     "vocabs.loader.test.c" forget-vocab
 ] unit-test
+
+[ ] [
+    "IN: temporary : hello\n\"world\" ;" parse-interactive
+    drop
+] unit-test

core/listener/listener.factor

@@ -15,7 +15,9 @@ SYMBOL: listener-hook
 GENERIC: stream-read-quot ( stream -- quot/f )
 
 : read-quot-step ( lines -- quot/f )
-    [ parse-lines ] catch {
+    [
+        [ parse-lines in get ] with-compilation-unit in set
+    ] catch {
         { [ dup delegate unexpected-eof? ] [ 2drop f ] }
         { [ dup not ] [ drop ] }
         { [ t ] [ rethrow ] }
@@ -36,10 +38,7 @@ M: line-reader stream-read-quot
 M: duplex-stream stream-read-quot
     duplex-stream-in stream-read-quot ;
 
-: read-quot ( -- quot )
-    [
-        stdio get stream-read-quot in get
-    ] with-compilation-unit in set ;
+: read-quot ( -- quot ) stdio get stream-read-quot ;
 
 : bye ( -- ) quit-flag on ;
 

core/parser/parser-tests.factor

@@ -385,3 +385,11 @@ IN: temporary
         natural-sort
     ] unit-test
 ] with-scope
+
+[ ] [
+    "IN: temporary USE: kernel PREDICATE: object foo ( x -- y ) ;" eval
+] unit-test
+
+[ t ] [
+    "foo?" "temporary" lookup word eq?
+] unit-test

core/parser/parser.factor

@@ -221,7 +221,7 @@ PREDICATE: unexpected unexpected-eof
 : CREATE-CLASS ( -- word )
     scan in get create
     dup save-class-location
-    dup predicate-word save-location ;
+    dup predicate-word dup set-word save-location ;
 
 : word-restarts ( possibilities -- restarts )
     natural-sort [

core/prettyprint/prettyprint-tests.factor

@@ -113,10 +113,10 @@ unit-test
         use [ clone ] change
 
         [
-             parse-lines drop
-             [
-                 "USE: temporary \\ " swap " see" 3append eval
-             ] string-out "\n" split 1 head*
+            [ parse-fresh drop ] with-compilation-unit
+            [
+                "temporary" lookup see
+            ] string-out "\n" split 1 head*
         ] keep =
     ] with-scope ;
 

core/source-files/source-files.factor

@@ -73,15 +73,15 @@ uses definitions ;
 
 M: pathname where pathname-string 1 2array ;
 
-: forget-source ( path -- )
-    [
-        dup source-file
-        dup unxref-source
-        source-file-definitions [ keys forget-all ] each
-        source-files get delete-at
-    ] with-compilation-unit ;
+M: pathname forget
+    pathname-string
+    dup source-file
+    dup unxref-source
+    source-file-definitions [ keys forget-all ] each
+    source-files get delete-at ;
 
-M: pathname forget pathname-string forget-source ;
+: forget-source ( path -- )
+    [ <pathname> forget ] with-compilation-unit ;
 
 : rollback-source-file ( source-file -- )
     dup source-file-definitions new-definitions get [ union ] 2map

core/tuples/tuples-tests.factor

@@ -45,7 +45,7 @@ C: <point> point
 100 200 <point> "p" set
 
 ! Use eval to sequence parsing explicitly
-"IN: temporary TUPLE: point x y z ; do-parse-hook" eval
+"IN: temporary TUPLE: point x y z ;" eval
 
 [ 100 ] [ "p" get point-x ] unit-test
 [ 200 ] [ "p" get point-y ] unit-test
@@ -53,7 +53,7 @@ C: <point> point
 
 300 "p" get "set-point-z" "temporary" lookup execute
 
-"IN: temporary TUPLE: point z y ; do-parse-hook" eval
+"IN: temporary TUPLE: point z y ;" eval
 
 [ "p" get point-x ] unit-test-fails
 [ 200 ] [ "p" get point-y ] unit-test
@@ -216,46 +216,37 @@ SYMBOL: not-a-tuple-class
 [ not-a-tuple-class construct-boa ] unit-test-fails
 [ not-a-tuple-class construct-empty ] unit-test-fails
 
-! Reshaping bug. It's only an issue when optimizer compiler is
-! enabled.
-parse-hook get [
-    TUPLE: erg's-reshape-problem a b c ;
+TUPLE: erg's-reshape-problem a b c ;
 
-    C: <erg's-reshape-problem> erg's-reshape-problem
+C: <erg's-reshape-problem> erg's-reshape-problem
 
-    [ ] [
-        "IN: temporary TUPLE: erg's-reshape-problem a b c d ;" eval
-    ] unit-test
+[ ] [
+    ! <erg's-reshape-problem> hasn't been recompiled yet, so
+    ! we just created a tuple using an obsolete layout
+    "IN: temporary USE: namespaces TUPLE: erg's-reshape-problem a b c d ; 1 2 3 <erg's-reshape-problem> \"a\" set" eval
+] unit-test
 
+[ 1 2 ] [
+    ! that's ok, but... this shouldn't fail:
+    "IN: temporary TUPLE: erg's-reshape-problem a b d c ;" eval
 
-    [ 1 2 ] [
-        ! <erg's-reshape-problem> hasn't been recompiled yet, so
-        ! we just created a tuple using an obsolete layout
-        1 2 3 <erg's-reshape-problem>
-
-        ! that's ok, but... this shouldn't fail:
-        "IN: temporary TUPLE: erg's-reshape-problem a b d c ;" eval
-
-        { erg's-reshape-problem-a erg's-reshape-problem-b }
-        get-slots
-    ] unit-test
-] when
+    "a" get
+    { erg's-reshape-problem-a erg's-reshape-problem-b }
+    get-slots
+] unit-test
 
 ! We want to make sure constructors are recompiled when
 ! tuples are reshaped
 : cons-test-1 \ erg's-reshape-problem construct-empty ;
 : cons-test-2 \ erg's-reshape-problem construct-boa ;
 : cons-test-3
-    { erg's-reshape-problem-a }
+    { set-erg's-reshape-problem-a }
     \ erg's-reshape-problem construct ;
 
 "IN: temporary TUPLE: erg's-reshape-problem a b c d e f ;" eval
 
-[ t ] [
-    {
-        <erg's-reshape-problem>
-        cons-test-1
-        cons-test-2
-        cons-test-3
-    } [ changed-words get key? ] all?
-] unit-test
+[ ] [ 1 2 3 4 5 6 cons-test-2 "a" set ] unit-test
+
+[ t ] [ cons-test-1 array-capacity "a" get array-capacity = ] unit-test
+
+[ t ] [ 1 cons-test-3 array-capacity "a" get array-capacity = ] unit-test

core/vocabs/loader/loader-tests.factor

@@ -63,7 +63,7 @@ IN: temporary
         "resource:core/vocabs/loader/test/a/a.factor"
         source-file source-file-definitions dup USE: prettyprint .
         "v-l-t-a-hello" "vocabs.loader.test.a" lookup dup .
-        swap key?
+        swap first key?
     ] unit-test
 ] times
 
@@ -93,7 +93,9 @@ IN: temporary
 [ 1 ] [ "count-me" get-global ] unit-test
 
 [ ] [
-    "bob" "vocabs.loader.test.b" create [ ] define-compound
+    [
+        "bob" "vocabs.loader.test.b" create [ ] define-compound
+    ] with-compilation-unit
 ] unit-test
 
 [ ] [ "vocabs.loader.test.b" refresh ] unit-test

core/vocabs/loader/test/a/a.factor

@@ -1,9 +1,7 @@
 USING: namespaces parser ;
 IN: vocabs.loader.test.a
 
-: COUNT-ME global [ "count-me" inc ] bind ; parsing
-
-COUNT-ME
+<< global [ "count-me" inc ] bind >>
 
 : v-l-t-a-hello 4 ;
 

core/vocabs/loader/test/b/b.factor

@@ -1,7 +1,6 @@
 USING: namespaces ;
 IN: vocabs.loader.test.b
 
-: COUNT-ME global [ "count-me" inc ] bind ; parsing
-COUNT-ME
+<< global [ "count-me" inc ] bind >>
 
 : fred bob ;

core/vocabs/vocabs.factor

@@ -75,12 +75,6 @@ SYMBOL: load-vocab-hook
     [ vocab-words at ] curry* map
     [ ] subset ;
 
-: forget-vocab ( vocab -- )
-    [
-        dup vocab-words values forget-all
-        vocab-name dictionary get delete-at
-    ] with-compilation-unit ;
-
 : child-vocab? ( prefix name -- ? )
     2dup = pick empty? or
     [ 2drop t ] [ swap CHAR: . add head? ] if ;
@@ -98,4 +92,9 @@ M: vocab-link vocab-name vocab-link-name ;
 
 UNION: vocab-spec vocab vocab-link ;
 
-M: vocab-spec forget vocab-name forget-vocab ;
+M: vocab-spec forget
+    dup vocab-words values forget-all
+    vocab-name dictionary get delete-at ;
+
+: forget-vocab ( vocab -- )
+    [ f >vocab-link forget ] with-compilation-unit ;

core/words/words-docs.factor

@@ -337,6 +337,15 @@ HELP: define-declared
 { $description "Defines a compound word and declares its stack effect." }
 { $side-effects "word" } ;
 
+HELP: define-temp
+{ $values { "quot" quotation } { "word" word } }
+{ $description "Creates an uninterned word that will call " { $snippet "quot" } " when executed." }
+{ $notes
+    "The following phrases are equivalent:"
+    { $code "[ 2 2 + . ] call" }
+    { $code "[ 2 2 + . ] define-temp execute" }
+} ;
+
 HELP: quot-uses
 { $values { "quot" quotation } { "assoc" "an assoc with words as keys" } }
 { $description "Outputs a set of words referenced by the quotation and any quotations it contains." } ;

core/words/words-tests.factor

@@ -4,8 +4,10 @@ vocabs continuations ;
 IN: temporary
 
 [ 4 ] [
-    "poo" "scratchpad" create [ 2 2 + ] define-compound
-    "poo" "scratchpad" lookup execute
+    [
+        "poo" "temporary" create [ 2 2 + ] define-compound
+    ] with-compilation-unit
+    "poo" "temporary" lookup execute
 ] unit-test
 
 [ t ] [ t vocabs [ words [ word? and ] each ] each ] unit-test
@@ -88,14 +90,23 @@ FORGET: another-forgotten
 FORGET: foe
 
 ! xref should not retain references to gensyms
-gensym [ * ] define-compound
+[ ] [
+    [ gensym [ * ] define-compound ] with-compilation-unit
+] unit-test
 
 [ t ] [
     \ * usage [ word? ] subset [ interned? not ] subset empty?
 ] unit-test
 
 DEFER: calls-a-gensym
-\ calls-a-gensym gensym dup "x" set 1quotation define-compound
+[ ] [
+    [
+        \ calls-a-gensym
+        gensym dup "x" set 1quotation
+        define-compound
+    ] with-compilation-unit
+] unit-test
+
 [ f ] [ "x" get crossref get at ] unit-test
 
 ! more xref buggery
@@ -130,10 +141,18 @@ DEFER: x
 SYMBOL: quot-uses-a
 SYMBOL: quot-uses-b
 
-quot-uses-a [ 2 3 + ] define-compound
+[ ] [
+    [
+        quot-uses-a [ 2 3 + ] define-compound
+    ] with-compilation-unit
+] unit-test
 
 [ { + } ] [ \ quot-uses-a uses ] unit-test
 
-quot-uses-b 2 [ 3 + ] curry define-compound
+[ ] [
+    [
+        quot-uses-b 2 [ 3 + ] curry define-compound
+    ] with-compilation-unit
+] unit-test
 
 [ { + } ] [ \ quot-uses-b uses ] unit-test

core/words/words.factor

@@ -102,7 +102,8 @@ PRIVATE>
 : intern-symbol ( word -- )
     dup undefined? [ define-symbol ] [ drop ] if ;
 
-: define-compound ( word def -- ) [ ] like define ;
+: define-compound ( word def -- )
+    [ ] like define ;
 
 : define-declared ( word def effect -- )
     pick swap "declared-effect" set-word-prop
@@ -135,6 +136,9 @@ PRIVATE>
 : gensym ( -- word )
     "G:" \ gensym counter number>string append f <word> ;
 
+: define-temp ( quot -- word )
+    gensym dup rot define-compound ;
+
 : reveal ( word -- )
     dup word-name over word-vocabulary vocab-words set-at ;
 

extra/cocoa/subclassing/subclassing.factor

@@ -83,7 +83,7 @@ IN: cocoa.subclassing
 : prepare-method ( ret types quot -- type imp )
     >r [ encode-types ] 2keep r> [
         "cdecl" swap 4array % \ alien-callback ,
-    ] [ ] make compile-quot ;
+    ] [ ] make define-temp ;
 
 : prepare-methods ( methods -- methods )
     [ first4 prepare-method 3array ] map ;