From 6814e07f491dab7872c310cc7574e82ec1e832c7 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 24 Dec 2007 19:40:09 -0500 Subject: [PATCH] Unit test fixes --- core/bootstrap/image/image.factor | 8 +--- core/compiler/compiler-docs.factor | 9 ---- core/compiler/compiler.factor | 11 +++-- core/compiler/test/alien.factor | 6 --- core/definitions/definitions-tests.factor | 6 ++- core/definitions/definitions.factor | 4 +- core/generator/generator.factor | 1 - core/generic/generic-tests.factor | 6 ++- core/inference/inference-docs.factor | 8 ++++ core/inference/inference.factor | 7 +-- core/listener/listener-tests.factor | 24 ++++++---- core/listener/listener.factor | 9 ++-- core/parser/parser-tests.factor | 8 ++++ core/parser/parser.factor | 2 +- core/prettyprint/prettyprint-tests.factor | 8 ++-- core/source-files/source-files.factor | 16 +++---- core/tuples/tuples-tests.factor | 53 +++++++++------------- core/vocabs/loader/loader-tests.factor | 6 ++- core/vocabs/loader/test/a/a.factor | 4 +- core/vocabs/loader/test/b/b.factor | 3 +- core/vocabs/vocabs.factor | 13 +++--- core/words/words-docs.factor | 9 ++++ core/words/words-tests.factor | 31 ++++++++++--- core/words/words.factor | 6 ++- extra/cocoa/subclassing/subclassing.factor | 2 +- 25 files changed, 144 insertions(+), 116 deletions(-) mode change 100644 => 100755 core/inference/inference-docs.factor mode change 100644 => 100755 core/vocabs/loader/test/a/a.factor mode change 100644 => 100755 core/vocabs/loader/test/b/b.factor diff --git a/core/bootstrap/image/image.factor b/core/bootstrap/image/image.factor index a738c157c3..5e3ba5b85e 100755 --- a/core/bootstrap/image/image.factor +++ b/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 classalist 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 ; diff --git a/core/compiler/test/alien.factor b/core/compiler/test/alien.factor index 8358709590..e737a76e1e 100755 --- a/core/compiler/test/alien.factor +++ b/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 diff --git a/core/definitions/definitions-tests.factor b/core/definitions/definitions-tests.factor index f2a9d74aa5..4f79cd3f54 100755 --- a/core/definitions/definitions-tests.factor +++ b/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 -[ ] object \ generic-1 define-method + [ ] object \ generic-1 define-method +] with-compilation-unit [ ] [ [ diff --git a/core/definitions/definitions.factor b/core/definitions/definitions.factor index 104dd3c09e..ec21488efc 100755 --- a/core/definitions/definitions.factor +++ b/core/definitions/definitions.factor @@ -85,6 +85,6 @@ SYMBOL: recompile-hook H{ } clone changed-words set new-definitions set old-definitions set - call - changed-words get keys recompile-hook get call + [ changed-words get keys recompile-hook get call ] [ ] + cleanup ] with-scope ; inline diff --git a/core/generator/generator.factor b/core/generator/generator.factor index 0c63f74d64..048b853049 100755 --- a/core/generator/generator.factor +++ b/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 ; diff --git a/core/generic/generic-tests.factor b/core/generic/generic-tests.factor index 76b9934586..a66e24956e 100755 --- a/core/generic/generic-tests.factor +++ b/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 ; diff --git a/core/inference/inference-docs.factor b/core/inference/inference-docs.factor old mode 100644 new mode 100755 index b9ac8ce3a8..5a9c306abf --- a/core/inference/inference-docs.factor +++ b/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." } ; diff --git a/core/inference/inference.factor b/core/inference/inference.factor index f89bfa85df..9588976e50 100755 --- a/core/inference/inference.factor +++ b/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 ; diff --git a/core/listener/listener-tests.factor b/core/listener/listener-tests.factor index 06b634769e..2e5b6ccb1c 100755 --- a/core/listener/listener-tests.factor +++ b/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 ) + stream-read-quot ; + [ [ ] ] [ - "USE: temporary hello" parse-interactive + "USE: temporary hello" parse-interactive ] unit-test [ @@ -17,11 +20,10 @@ IN: temporary [ "cont" set [ - "\\ + 1 2 3 4" - - 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" - 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 diff --git a/core/listener/listener.factor b/core/listener/listener.factor index 709a03ee27..151b08151f 100755 --- a/core/listener/listener.factor +++ b/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 ; diff --git a/core/parser/parser-tests.factor b/core/parser/parser-tests.factor index 57ff831eca..f6d37af7b0 100755 --- a/core/parser/parser-tests.factor +++ b/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 diff --git a/core/parser/parser.factor b/core/parser/parser.factor index e954b55782..1d140ac3b6 100755 --- a/core/parser/parser.factor +++ b/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 [ diff --git a/core/prettyprint/prettyprint-tests.factor b/core/prettyprint/prettyprint-tests.factor index 7315b3f2e1..2d959528ed 100755 --- a/core/prettyprint/prettyprint-tests.factor +++ b/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 ; diff --git a/core/source-files/source-files.factor b/core/source-files/source-files.factor index 646322fc8f..d715fd0c95 100755 --- a/core/source-files/source-files.factor +++ b/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 -- ) + [ forget ] with-compilation-unit ; : rollback-source-file ( source-file -- ) dup source-file-definitions new-definitions get [ union ] 2map diff --git a/core/tuples/tuples-tests.factor b/core/tuples/tuples-tests.factor index e6630778e3..e21d21813a 100755 --- a/core/tuples/tuples-tests.factor +++ b/core/tuples/tuples-tests.factor @@ -45,7 +45,7 @@ C: point 100 200 "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 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 +C: erg's-reshape-problem - [ ] [ - "IN: temporary TUPLE: erg's-reshape-problem a b c d ;" eval - ] unit-test +[ ] [ + ! 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 \"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 ] [ - ! hasn't been recompiled yet, so - ! we just created a tuple using an obsolete layout - 1 2 3 - - ! 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 ] [ - { - - 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 diff --git a/core/vocabs/loader/loader-tests.factor b/core/vocabs/loader/loader-tests.factor index c78d3b378f..8a4d17c185 100755 --- a/core/vocabs/loader/loader-tests.factor +++ b/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 diff --git a/core/vocabs/loader/test/a/a.factor b/core/vocabs/loader/test/a/a.factor old mode 100644 new mode 100755 index d3f4dd9efd..03a2f8a091 --- a/core/vocabs/loader/test/a/a.factor +++ b/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 ; diff --git a/core/vocabs/loader/test/b/b.factor b/core/vocabs/loader/test/b/b.factor old mode 100644 new mode 100755 index 113f7af667..8bd75bfc84 --- a/core/vocabs/loader/test/b/b.factor +++ b/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 ; \ No newline at end of file diff --git a/core/vocabs/vocabs.factor b/core/vocabs/vocabs.factor index 864f1820ef..861a977891 100755 --- a/core/vocabs/vocabs.factor +++ b/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 ; diff --git a/core/words/words-docs.factor b/core/words/words-docs.factor index 520e7e00b4..14e3a48514 100755 --- a/core/words/words-docs.factor +++ b/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." } ; diff --git a/core/words/words-tests.factor b/core/words/words-tests.factor index 1a118fd705..82277be78c 100755 --- a/core/words/words-tests.factor +++ b/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 diff --git a/core/words/words.factor b/core/words/words.factor index 0491809cb6..28a89d467f 100755 --- a/core/words/words.factor +++ b/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 ; +: define-temp ( quot -- word ) + gensym dup rot define-compound ; + : reveal ( word -- ) dup word-name over word-vocabulary vocab-words set-at ; diff --git a/extra/cocoa/subclassing/subclassing.factor b/extra/cocoa/subclassing/subclassing.factor index 9cc8709e9d..d918bf29ca 100755 --- a/extra/cocoa/subclassing/subclassing.factor +++ b/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 ;