diff --git a/basis/bootstrap/stage2.factor b/basis/bootstrap/stage2.factor index 12741f2170..fd21c9646c 100644 --- a/basis/bootstrap/stage2.factor +++ b/basis/bootstrap/stage2.factor @@ -88,7 +88,6 @@ SYMBOL: bootstrap-time run-bootstrap-init ] with-compiler-errors - :errors f error set-global f error-continuation set-global diff --git a/basis/bootstrap/tools/tools.factor b/basis/bootstrap/tools/tools.factor index b0afe4a1d9..cb0792ee1e 100644 --- a/basis/bootstrap/tools/tools.factor +++ b/basis/bootstrap/tools/tools.factor @@ -6,6 +6,7 @@ IN: bootstrap.tools "bootstrap.image" "tools.annotations" "tools.crossref" + "tools.errors" "tools.deploy" "tools.disassembler" "tools.memory" diff --git a/basis/compiler/codegen/codegen.factor b/basis/compiler/codegen/codegen.factor index 65e70bd042..cf1d81fbc2 100755 --- a/basis/compiler/codegen/codegen.factor +++ b/basis/compiler/codegen/codegen.factor @@ -5,6 +5,7 @@ kernel kernel.private layouts assocs words summary arrays combinators classes.algebra alien alien.c-types alien.structs alien.strings alien.arrays alien.complex sets libc alien.libraries continuations.private fry cpu.architecture +source-files.errors compiler.errors compiler.alien compiler.cfg @@ -379,8 +380,7 @@ TUPLE: no-such-library name ; M: no-such-library summary drop "Library not found" ; -M: no-such-library compiler-error-type - drop +linkage+ ; +M: no-such-library source-file-error-type drop +linkage-error+ ; : no-such-library ( name -- ) \ no-such-library boa @@ -391,8 +391,7 @@ TUPLE: no-such-symbol name ; M: no-such-symbol summary drop "Symbol not found" ; -M: no-such-symbol compiler-error-type - drop +linkage+ ; +M: no-such-symbol source-file-error-type drop +linkage-error+ ; : no-such-symbol ( name -- ) \ no-such-symbol boa diff --git a/basis/compiler/compiler.factor b/basis/compiler/compiler.factor index 04c1a9c55f..2492b6cc23 100644 --- a/basis/compiler/compiler.factor +++ b/basis/compiler/compiler.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: accessors kernel namespaces arrays sequences io words fry continuations vocabs assocs dlists definitions math graphs generic -combinators deques search-deques macros io stack-checker +combinators deques search-deques macros io source-files.errors stack-checker stack-checker.state stack-checker.inlining combinators.short-circuit compiler.errors compiler.units compiler.tree.builder compiler.tree.optimizer compiler.cfg.builder compiler.cfg.optimizer @@ -54,7 +54,7 @@ SYMBOLS: +optimized+ +unoptimized+ ; : ignore-error? ( word error -- ? ) [ [ inline? ] [ macro? ] bi or ] - [ compiler-error-type +warning+ eq? ] bi* and ; + [ source-file-error-type +compiler-warning+ eq? ] bi* and ; : fail ( word error -- * ) [ 2dup ignore-error? [ 2drop ] [ swap compiler-error ] if ] diff --git a/basis/compiler/tree/builder/builder.factor b/basis/compiler/tree/builder/builder.factor index 4cb7650b1d..dc87d596aa 100644 --- a/basis/compiler/tree/builder/builder.factor +++ b/basis/compiler/tree/builder/builder.factor @@ -42,8 +42,10 @@ IN: compiler.tree.builder : check-cannot-infer ( word -- ) dup "cannot-infer" word-prop [ cannot-infer-effect ] [ drop ] if ; +TUPLE: do-not-compile word ; + : check-no-compile ( word -- ) - dup "no-compile" word-prop [ cannot-infer-effect ] [ drop ] if ; + dup "no-compile" word-prop [ do-not-compile inference-warning ] [ drop ] if ; : build-tree-from-word ( word -- nodes ) [ diff --git a/basis/debugger/debugger.factor b/basis/debugger/debugger.factor index efd35ab280..c088b86c31 100644 --- a/basis/debugger/debugger.factor +++ b/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 ; +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>> . ; - -M: source-file-error error. - [ file>> file. ] [ error>> error. ] bi ; - M: source-file-error summary error>> summary ; @@ -309,11 +305,23 @@ M: lexer-error compute-restarts M: lexer-error error-help error>> error-help ; -M: object compiler-error. ( error word -- ) - nl - "While compiling " write pprint ": " print - nl - print-error ; +M: source-file-error error. + [ + [ + [ + [ file>> [ % ": " % ] when* ] + [ line#>> [ # ": " % ] when* ] + [ summary % ] tri + ] "" make + ] [ + [ + presented set + bold font-style set + ] H{ } make-assoc + ] bi format nl + ] [ error>> error. ] bi ; + +M: compiler-error summary asset>> summary ; M: bad-effect summary drop "Bad stack effect declaration" ; diff --git a/basis/editors/editors-docs.factor b/basis/editors/editors-docs.factor index e3961aef80..646582beb0 100644 --- a/basis/editors/editors-docs.factor +++ b/basis/editors/editors-docs.factor @@ -1,4 +1,5 @@ -USING: help.markup help.syntax parser source-files vocabs.loader ; +USING: help.markup help.syntax parser source-files +source-files.errors vocabs.loader ; IN: editors ARTICLE: "editor" "Editor integration" diff --git a/basis/editors/editors.factor b/basis/editors/editors.factor index 0003b508fb..b494b52c68 100644 --- a/basis/editors/editors.factor +++ b/basis/editors/editors.factor @@ -1,8 +1,8 @@ ! Copyright (C) 2005, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: parser lexer kernel namespaces sequences definitions -io.files io.backend io.pathnames io summary continuations -tools.crossref tools.vocabs prettyprint source-files assocs +USING: parser lexer kernel namespaces sequences definitions io.files +io.backend io.pathnames io summary continuations tools.crossref +tools.vocabs prettyprint source-files source-files.errors assocs vocabs vocabs.loader splitting accessors debugger prettyprint help.topics ; IN: editors @@ -81,6 +81,9 @@ M: object error-line : :edit ( -- ) error get (:edit) ; +: edit-error ( error -- ) + [ file>> ] [ line#>> ] bi edit-location ; + : edit-each ( seq -- ) [ [ "Editing " write . ] diff --git a/basis/mime/multipart/multipart.factor b/basis/mime/multipart/multipart.factor index 0edfb05a30..0cf7556bcd 100755 --- a/basis/mime/multipart/multipart.factor +++ b/basis/mime/multipart/multipart.factor @@ -137,9 +137,6 @@ ERROR: no-content-disposition multipart ; [ no-content-disposition ] } case ; -: assert-sequence= ( a b -- ) - 2dup sequence= [ 2drop ] [ assert ] if ; - : read-assert-sequence= ( sequence -- ) [ length read ] keep assert-sequence= ; diff --git a/basis/models/arrow/smart/authors.txt b/basis/models/arrow/smart/authors.txt new file mode 100644 index 0000000000..d4f5d6b3ae --- /dev/null +++ b/basis/models/arrow/smart/authors.txt @@ -0,0 +1 @@ +Slava Pestov \ No newline at end of file diff --git a/basis/models/arrow/smart/smart-tests.factor b/basis/models/arrow/smart/smart-tests.factor new file mode 100644 index 0000000000..3e8375e512 --- /dev/null +++ b/basis/models/arrow/smart/smart-tests.factor @@ -0,0 +1,4 @@ +IN: models.arrows.smart.tests +USING: models.arrow.smart tools.test accessors models math kernel ; + +[ 7 ] [ 3 4 [ + ] [ activate-model ] [ value>> ] bi ] unit-test \ No newline at end of file diff --git a/basis/models/arrow/smart/smart.factor b/basis/models/arrow/smart/smart.factor new file mode 100644 index 0000000000..257a2bb1ea --- /dev/null +++ b/basis/models/arrow/smart/smart.factor @@ -0,0 +1,9 @@ +! Copyright (C) 2009 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: models.arrow models.product stack-checker accessors fry +generalizations macros kernel ; +IN: models.arrow.smart + +MACRO: ( quot -- quot' ) + [ infer in>> dup ] keep + '[ _ narray [ _ firstn @ ] ] ; \ No newline at end of file diff --git a/basis/models/search/search.factor b/basis/models/search/search.factor index 4bf74b3b92..5ecb0fa34a 100644 --- a/basis/models/search/search.factor +++ b/basis/models/search/search.factor @@ -1,12 +1,10 @@ ! Copyright (C) 2008, 2009 Slava Pestov ! See http://factorcode.org/license.txt for BSD license. -USING: arrays fry kernel models.product models.arrow -sequences unicode.case ; +USING: fry kernel models.arrow.smart sequences unicode.case ; IN: models.search : ( values search quot -- model ) - [ 2array ] dip - '[ first2 _ curry filter ] ; + '[ _ curry filter ] ; inline : ( values search quot -- model ) - '[ swap @ [ >case-fold ] bi@ subseq? ] ; + '[ swap @ [ >case-fold ] bi@ subseq? ] ; inline diff --git a/basis/models/sort/sort.factor b/basis/models/sort/sort.factor index 23c150796f..efd2e4927b 100644 --- a/basis/models/sort/sort.factor +++ b/basis/models/sort/sort.factor @@ -1,8 +1,7 @@ -! Copyright (C) 2008 Slava Pestov +! Copyright (C) 2009 Slava Pestov ! See http://factorcode.org/license.txt for BSD license. -USING: arrays fry kernel models.product models.arrow -sequences sorting ; +USING: sorting models.arrow.smart fry ; IN: models.sort : ( values sort -- model ) - 2array [ first2 sort ] ; \ No newline at end of file + [ '[ _ call( obj1 obj2 -- <=> ) ] sort ] ; inline \ No newline at end of file diff --git a/basis/stack-checker/errors/errors.factor b/basis/stack-checker/errors/errors.factor index 07c26ad100..799e3f73e3 100644 --- a/basis/stack-checker/errors/errors.factor +++ b/basis/stack-checker/errors/errors.factor @@ -2,7 +2,8 @@ ! See http://factorcode.org/license.txt for BSD license. USING: kernel generic sequences io words arrays summary effects continuations assocs accessors namespaces compiler.errors -stack-checker.values stack-checker.recursive-state ; +stack-checker.values stack-checker.recursive-state +source-files.errors compiler.errors ; IN: stack-checker.errors : pretty-word ( word -- word' ) @@ -10,7 +11,7 @@ IN: stack-checker.errors TUPLE: inference-error error type word ; -M: inference-error compiler-error-type type>> ; +M: inference-error source-file-error-type type>> ; : (inference-error) ( ... class type -- * ) [ boa ] dip @@ -18,10 +19,10 @@ M: inference-error compiler-error-type type>> ; \ inference-error boa rethrow ; inline : inference-error ( ... class -- * ) - +error+ (inference-error) ; inline + +compiler-error+ (inference-error) ; inline : inference-warning ( ... class -- * ) - +warning+ (inference-error) ; inline + +compiler-warning+ (inference-error) ; inline TUPLE: literal-expected what ; @@ -81,3 +82,8 @@ TUPLE: unknown-primitive-error ; : unknown-primitive-error ( -- * ) \ unknown-primitive-error inference-warning ; + +TUPLE: transform-expansion-error word error ; + +: transform-expansion-error ( word error -- * ) + \ transform-expansion-error inference-error ; \ No newline at end of file diff --git a/basis/stack-checker/errors/prettyprint/prettyprint.factor b/basis/stack-checker/errors/prettyprint/prettyprint.factor index 9dc82339b5..d6cee8e08f 100644 --- a/basis/stack-checker/errors/prettyprint/prettyprint.factor +++ b/basis/stack-checker/errors/prettyprint/prettyprint.factor @@ -1,19 +1,26 @@ -! Copyright (C) 2008 Slava Pestov. +! Copyright (C) 2008, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: accessors kernel prettyprint io debugger -sequences assocs stack-checker.errors summary effects ; +sequences assocs stack-checker.errors summary effects make ; IN: stack-checker.errors.prettyprint +M: inference-error summary error>> summary ; + M: inference-error error-help error>> error-help ; M: inference-error error. [ word>> [ "In word: " write . ] when* ] [ error>> error. ] bi ; -M: literal-expected error. - "Got a computed value where a " write what>> write " was expected" print ; +M: literal-expected summary + [ "Got a computed value where a " % what>> % " was expected" % ] "" make ; + +M: literal-expected error. summary print ; + +M: unbalanced-branches-error summary + drop "Unbalanced branches" ; M: unbalanced-branches-error error. - "Unbalanced branches:" print + dup summary print [ quots>> ] [ branches>> [ length ] { } assoc>map ] bi zip [ [ first pprint-short bl ] [ second effect>string print ] bi ] each ; @@ -25,16 +32,18 @@ M: too-many-r> summary drop "Quotation pops retain stack elements which it did not push" ; -M: missing-effect error. - "The word " write - word>> pprint - " must declare a stack effect" print ; +M: missing-effect summary + [ + "The word " % + word>> name>> % + " must declare a stack effect" % + ] "" make ; -M: effect-error error. - "Stack effects of the word " write - [ word>> pprint " do not match." print ] - [ "Inferred: " write inferred>> . ] - [ "Declared: " write declared>> . ] tri ; +M: effect-error summary + [ + "Stack effect declaration of the word " % + word>> name>> % " is wrong" % + ] "" make ; M: recursive-quotation-error error. "The quotation " write @@ -42,26 +51,40 @@ M: recursive-quotation-error error. " calls itself." print "Stack effect inference is undecidable when quotation-level recursion is permitted." print ; -M: undeclared-recursion-error error. - "The inline recursive word " write - word>> pprint - " must be declared recursive" print ; - -M: diverging-recursion-error error. - "The recursive word " write - word>> pprint - " digs arbitrarily deep into the stack" print ; - -M: unbalanced-recursion-error error. - "The recursive word " write - word>> pprint - " leaves with the stack having the wrong height" print ; - -M: inconsistent-recursive-call-error error. - "The recursive word " write - word>> pprint - " calls itself with a different set of quotation parameters than were input" print ; - -M: unknown-primitive-error error. +M: undeclared-recursion-error summary drop - "Cannot determine stack effect statically" print ; + "Inline recursive words must be declared recursive" ; + +M: diverging-recursion-error summary + [ + "The recursive word " % + word>> name>> % + " digs arbitrarily deep into the stack" % + ] "" make ; + +M: unbalanced-recursion-error summary + [ + "The recursive word " % + word>> name>> % + " leaves with the stack having the wrong height" % + ] "" make ; + +M: inconsistent-recursive-call-error summary + [ + "The recursive word " % + word>> name>> % + " calls itself with a different set of quotation parameters than were input" % + ] "" make ; + +M: unknown-primitive-error summary + drop + "Cannot determine stack effect statically" ; + +M: transform-expansion-error summary + drop + "Compiler transform threw an error" ; + +M: transform-expansion-error error. + [ summary print ] + [ "Word: " write word>> . nl ] + [ error>> error. ] tri ; \ No newline at end of file diff --git a/basis/stack-checker/transforms/transforms-tests.factor b/basis/stack-checker/transforms/transforms-tests.factor index 0aa3876907..abb1f2abdb 100644 --- a/basis/stack-checker/transforms/transforms-tests.factor +++ b/basis/stack-checker/transforms/transforms-tests.factor @@ -1,6 +1,6 @@ IN: stack-checker.transforms.tests USING: sequences stack-checker.transforms tools.test math kernel -quotations stack-checker accessors combinators words arrays +quotations stack-checker stack-checker.errors accessors combinators words arrays classes classes.tuple ; : compose-n-quot ( word n -- quot' ) >quotation ; @@ -70,4 +70,11 @@ DEFER: curry-folding-test ( quot -- ) : member?-test ( a -- ? ) { 1 2 3 10 7 58 } member? ; [ f ] [ 1.0 member?-test ] unit-test -[ t ] [ \ member?-test def>> first [ member?-test ] all? ] unit-test \ No newline at end of file +[ t ] [ \ member?-test def>> first [ member?-test ] all? ] unit-test + +! Macro expansion should throw its own type of error +: bad-macro ( -- ) ; + +\ bad-macro [ "OOPS" throw ] 0 define-transform + +[ [ bad-macro ] infer ] [ inference-error? ] must-fail-with \ No newline at end of file diff --git a/basis/stack-checker/transforms/transforms.factor b/basis/stack-checker/transforms/transforms.factor index c2b348f5f1..541d74bdeb 100755 --- a/basis/stack-checker/transforms/transforms.factor +++ b/basis/stack-checker/transforms/transforms.factor @@ -17,9 +17,14 @@ IN: stack-checker.transforms [ dup infer-word apply-word/effect ] } cond ; +: call-transformer ( word stack quot -- newquot ) + '[ _ _ with-datastack [ length 1 assert= ] [ first ] bi nip ] + [ transform-expansion-error ] + recover ; + :: ((apply-transform)) ( word quot values stack rstate -- ) rstate recursive-state - [ stack quot with-datastack first ] with-variable + [ word stack quot call-transformer ] with-variable [ word inlined-dependency depends-on values [ length meta-d shorten-by ] [ #drop, ] bi diff --git a/basis/tools/errors/authors.txt b/basis/tools/errors/authors.txt new file mode 100644 index 0000000000..d4f5d6b3ae --- /dev/null +++ b/basis/tools/errors/authors.txt @@ -0,0 +1 @@ +Slava Pestov \ No newline at end of file diff --git a/basis/tools/errors/errors-docs.factor b/basis/tools/errors/errors-docs.factor new file mode 100644 index 0000000000..b66b557a81 --- /dev/null +++ b/basis/tools/errors/errors-docs.factor @@ -0,0 +1,40 @@ +IN: tools.errors +USING: compiler.errors tools.errors help.markup help.syntax vocabs.loader +words quotations io ; + +ARTICLE: "compiler-errors" "Compiler warnings and errors" +"After loading a vocabulary, you might see messages like:" +{ $code + ":errors - print 2 compiler errors." + ":warnings - print 50 compiler warnings." +} +"These warnings arise from the compiler's stack effect checker. Warnings are non-fatal conditions -- not all code has a static stack effect, so you try to minimize warnings but understand that in many cases they cannot be eliminated. Errors indicate programming mistakes, such as erroneous stack effect declarations." +$nl +"The precise warning and error conditions are documented in " { $link "inference-errors" } "." +$nl +"Words to view warnings and errors:" +{ $subsection :errors } +{ $subsection :warnings } +{ $subsection :linkage } +"Words such as " { $link require } " use a combinator which counts errors and prints a report at the end:" +{ $subsection with-compiler-errors } ; + +HELP: compiler-error +{ $values { "error" "an error" } { "word" word } } +{ $description "If inside a " { $link with-compiler-errors } ", saves the error for future persual via " { $link :errors } ", " { $link :warnings } " and " { $link :linkage } ". If not inside a " { $link with-compiler-errors } ", ignores the error." } ; + +HELP: with-compiler-errors +{ $values { "quot" quotation } } +{ $description "Calls the quotation and collects any compiler warnings and errors. Compiler warnings and errors are summarized at the end and can be viewed with " { $link :errors } ", " { $link :warnings } ", and " { $link :linkage } "." } +{ $notes "Nested calls to " { $link with-compiler-errors } " are ignored, and only the outermost call collects warnings and errors." } ; + +HELP: :errors +{ $description "Prints all serious compiler errors from the most recent compile to " { $link output-stream } "." } ; + +HELP: :warnings +{ $description "Prints all ignorable compiler warnings from the most recent compile to " { $link output-stream } "." } ; + +HELP: :linkage +{ $description "Prints all C library interface linkage errors from the most recent compile to " { $link output-stream } "." } ; + +{ :errors :warnings } related-words diff --git a/basis/tools/errors/errors.factor b/basis/tools/errors/errors.factor new file mode 100644 index 0000000000..4b717a8bdd --- /dev/null +++ b/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 values errors. ; + +: :errors ( -- ) +compiler-error+ compiler-errors. ; + +: :warnings ( -- ) +compiler-warning+ compiler-errors. ; + +: :linkage ( -- ) +linkage-error+ compiler-errors. ; diff --git a/basis/tools/profiler/profiler.factor b/basis/tools/profiler/profiler.factor index 864a637096..f4488136b2 100644 --- a/basis/tools/profiler/profiler.factor +++ b/basis/tools/profiler/profiler.factor @@ -7,7 +7,7 @@ continuations generic compiler.units sets classes fry ; IN: tools.profiler : profile ( quot -- ) - [ t profiling call ] [ f profiling ] [ ] cleanup ; + [ t profiling call ] [ f profiling ] [ ] cleanup ; inline : filter-counts ( alist -- alist' ) [ second 0 > ] filter ; diff --git a/basis/tools/test/test-docs.factor b/basis/tools/test/test-docs.factor index 3cabff457f..06a54f0868 100644 --- a/basis/tools/test/test-docs.factor +++ b/basis/tools/test/test-docs.factor @@ -3,33 +3,23 @@ IN: tools.test ARTICLE: "tools.test.write" "Writing unit tests" "Assert that a quotation outputs a specific set of values:" -{ $subsection unit-test } +{ $subsection POSTPONE: unit-test } "Assert that a quotation throws an error:" -{ $subsection must-fail } -{ $subsection must-fail-with } +{ $subsection POSTPONE: must-fail } +{ $subsection POSTPONE: must-fail-with } "Assert that a quotation or word has a specific static stack effect (see " { $link "inference" } "):" -{ $subsection must-infer } -{ $subsection must-infer-as } ; +{ $subsection POSTPONE: must-infer } +{ $subsection POSTPONE: must-infer-as } ; ARTICLE: "tools.test.run" "Running unit tests" "The following words run test harness files; any test failures are collected and printed at the end:" { $subsection test } -{ $subsection test-all } ; - -ARTICLE: "tools.test.failure" "Handling test failures" -"Most of the time the words documented in " { $link "tools.test.run" } " are used because they print all test failures in human-readable form. Some tools inspect the test failures and takes some kind of action instead, for example, " { $vocab-link "mason" } "." -$nl -"The following words output an association list mapping vocabulary names to sequences of failures; a failure is an array having the shape " { $snippet "{ error test continuation }" } ", and the elements are as follows:" -{ $list - { { $snippet "error" } " - the error thrown by the unit test" } - { { $snippet "test" } " - a pair " { $snippet "{ output input }" } " containing expected output and a unit test quotation which didn't produce this output" } - { { $snippet "continuation" } " - the traceback at the point of the error" } -} -"The following words run test harness files and output failures:" -{ $subsection run-tests } -{ $subsection run-all-tests } +{ $subsection test-all } "The following word prints failures:" -{ $subsection test-failures. } ; +{ $subsection :failures } +"Unit test failurs are instances of a class, and are stored in a global variable:" +{ $subsection test-failure } +{ $subsection test-failures } ; ARTICLE: "tools.test" "Unit testing" "A unit test is a piece of code which starts with known input values, then compares the output of a word with an expected output, where the expected output is defined by the word's contract." @@ -45,8 +35,7 @@ $nl $nl "If the test harness needs to define words, they should be placed in a vocabulary named " { $snippet { $emphasis "vocab" } ".tests" } " where " { $emphasis "vocab" } " is the vocab being tested." { $subsection "tools.test.write" } -{ $subsection "tools.test.run" } -{ $subsection "tools.test.failure" } ; +{ $subsection "tools.test.run" } ; ABOUT: "tools.test" @@ -78,17 +67,8 @@ HELP: test { $values { "prefix" "a vocabulary name" } } { $description "Runs unit tests for the vocabulary named " { $snippet "prefix" } " and all of its child vocabularies." } ; -HELP: run-tests -{ $values { "prefix" "a vocabulary name" } { "failures" "an association list of unit test failures" } } -{ $description "Runs unit tests for the vocabulary named " { $snippet "prefix" } " and all of its child vocabularies. Outputs unit test failures as documented in " { $link "tools.test.failure" } "." } ; - HELP: test-all { $description "Runs unit tests for all loaded vocabularies." } ; -HELP: run-all-tests -{ $values { "failures" "an association list of unit test failures" } } -{ $description "Runs unit tests for all loaded vocabularies and outputs unit test failures as documented in " { $link "tools.test.failure" } "." } ; - -HELP: test-failures. -{ $values { "assoc" "an association list of unit test failures" } } -{ $description "Prints unit test failures output by " { $link run-tests } " or " { $link run-all-tests } " to " { $link output-stream } "." } ; +HELP: :failures +{ $description "Prints all pending unit test failures." } ; diff --git a/basis/tools/test/test.factor b/basis/tools/test/test.factor index c6dea08d18..8c308e6406 100644 --- a/basis/tools/test/test.factor +++ b/basis/tools/test/test.factor @@ -1,95 +1,138 @@ -! Copyright (C) 2003, 2008 Slava Pestov. +! Copyright (C) 2003, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors namespaces arrays prettyprint sequences kernel -vectors quotations words parser assocs combinators continuations -debugger io io.styles io.files vocabs vocabs.loader source-files -compiler.units summary stack-checker effects tools.vocabs fry ; +USING: accessors arrays assocs combinators compiler.units +continuations debugger effects fry generalizations io io.files +io.styles kernel lexer locals macros math.parser namespaces +parser prettyprint quotations sequences source-files splitting +stack-checker summary unicode.case vectors vocabs vocabs.loader words +tools.vocabs tools.errors source-files.errors io.streams.string make +compiler.errors ; IN: tools.test -SYMBOL: failures +TUPLE: test-failure < source-file-error continuation ; -: ( error what -- triple ) - error-continuation get 3array ; +SYMBOL: +test-failure+ -: failure ( error what -- ) +M: test-failure source-file-error-type drop +test-failure+ ; + +SYMBOL: test-failures +test-failures [ V{ } clone ] initialize + + ( error experiment file line# -- triple ) + test-failure new + swap >>line# + swap >>file + swap >>asset + swap >>error + error-continuation get >>continuation ; + +: failure ( error experiment file line# -- ) "--> test failed!" print - failures get push ; + test-failures get push ; -SYMBOL: this-test +SYMBOL: file -: (unit-test) ( what quot -- ) - swap dup . flush this-test set - failures get [ - [ this-test get failure ] recover - ] [ - call - ] if ; inline +: file-failure ( error -- ) + f file get f failure ; -: unit-test ( output input -- ) - [ 2array ] 2keep '[ - _ { } _ with-datastack swap >array assert= - ] (unit-test) ; +:: (unit-test) ( output input -- error ? ) + [ { } input with-datastack output assert-sequence= f f ] [ t ] recover ; inline : short-effect ( effect -- pair ) [ in>> length ] [ out>> length ] bi 2array ; -: must-infer-as ( effect quot -- ) - [ 1quotation ] dip '[ _ infer short-effect ] unit-test ; +:: (must-infer-as) ( effect quot -- error ? ) + [ quot infer short-effect effect assert= f f ] [ t ] recover ; inline -: must-infer ( word/quot -- ) - dup word? [ 1quotation ] when - '[ _ infer drop ] [ ] swap unit-test ; +:: (must-infer) ( word/quot -- error ? ) + word/quot dup word? [ '[ _ execute ] ] when :> quot + [ quot infer drop f f ] [ t ] recover ; inline -: must-fail-with ( quot pred -- ) - [ '[ @ f ] ] dip '[ _ _ recover ] [ t ] swap unit-test ; +TUPLE: did-not-fail ; +CONSTANT: did-not-fail T{ did-not-fail } -: must-fail ( quot -- ) - [ drop t ] must-fail-with ; +M: did-not-fail summary drop "Did not fail" ; -: (run-test) ( vocab -- ) +:: (must-fail-with) ( quot pred -- error ? ) + [ quot call did-not-fail t ] + [ dup pred call [ drop f f ] [ t ] if ] recover ; inline + +:: (must-fail) ( quot -- error ? ) + [ quot call did-not-fail t ] [ drop f f ] recover ; inline + +: experiment-title ( word -- string ) + "(" ?head drop ")" ?tail drop { { CHAR: - CHAR: \s } } substitute >title ; + +MACRO: ( word -- ) + [ stack-effect in>> length dup ] + [ name>> experiment-title ] bi + '[ _ ndup _ narray _ prefix ] ; + +: experiment. ( seq -- ) + [ first write ": " write ] [ rest . ] bi ; + +:: experiment ( word: ( -- error ? ) line# -- ) + word :> e + e experiment. + word execute [ + file get [ + e file get line# failure + ] [ rethrow ] if + ] [ drop ] if ; inline + +: parse-test ( accum word -- accum ) + literalize parsed + lexer get line>> parsed + \ experiment parsed ; inline + +<< + +SYNTAX: TEST: + scan + [ create-in ] + [ "(" ")" surround search '[ _ parse-test ] ] bi + define-syntax ; + +>> + +: run-test-file ( path -- ) + dup file [ + test-failures get [ file>> file get = not ] filter-here + '[ _ run-file ] [ file-failure ] recover + ] with-variable ; + +: run-vocab-tests ( vocab -- ) dup vocab source-loaded?>> [ - vocab-tests [ run-file ] each + vocab-tests [ run-test-file ] each ] [ drop ] if ; -: run-test ( vocab -- failures ) - V{ } clone [ - failures [ - [ (run-test) ] [ swap failure ] recover - ] with-variable - ] keep ; +: traceback-button. ( failure -- ) + "[" write [ "Traceback" ] dip continuation>> write-object "]" print ; -: failure. ( triple -- ) - dup second . - dup first print-error - "Traceback" swap third write-object ; +PRIVATE> -: test-failures. ( assoc -- ) - [ - nl - [ - "==== ALL TESTS PASSED" print - ] [ - "==== FAILING TESTS:" print - [ - swap vocab-heading. - [ failure. nl ] each - ] assoc-each - ] if-empty - ] [ - "==== NOTHING TO TEST" print - ] if* ; +TEST: unit-test +TEST: must-infer-as +TEST: must-infer +TEST: must-fail-with +TEST: must-fail -: run-tests ( prefix -- failures ) - child-vocabs [ f ] [ - [ dup run-test ] { } map>assoc - [ second empty? not ] filter - ] if-empty ; +M: test-failure summary + asset>> [ [ experiment. ] with-string-writer ] [ "Top-level form" ] if* ; + +M: test-failure error. ( error -- ) + [ call-next-method ] + [ traceback-button. ] + bi ; + +: :failures ( -- ) test-failures get errors. ; : test ( prefix -- ) - run-tests test-failures. ; + [ child-vocabs [ run-vocab-tests ] each ] with-compiler-errors + test-failures get [ + ":failures - show " write length pprint " failing tests." print + ] unless-empty ; -: run-all-tests ( -- failures ) - "" run-tests ; - -: test-all ( -- ) - run-all-tests test-failures. ; +: test-all ( -- ) "" test ; diff --git a/basis/ui/baseline-alignment/baseline-alignment.factor b/basis/ui/baseline-alignment/baseline-alignment.factor index e02c6188f5..1cdaf760dc 100644 --- a/basis/ui/baseline-alignment/baseline-alignment.factor +++ b/basis/ui/baseline-alignment/baseline-alignment.factor @@ -24,35 +24,47 @@ TUPLE: gadget-metrics height ascent descent cap-height ; [ dup [ 2dup - ] [ f ] if ] dip gadget-metrics boa ; inline +: ?supremum ( seq -- n/f ) + sift [ f ] [ supremum ] if-empty ; + : max-ascent ( seq -- n ) - 0 [ ascent>> [ max ] when* ] reduce ; inline + [ ascent>> ] map ?supremum ; : max-cap-height ( seq -- n ) - 0 [ cap-height>> [ max ] when* ] reduce ; inline + [ cap-height>> ] map ?supremum ; : max-descent ( seq -- n ) - 0 [ descent>> [ max ] when* ] reduce ; inline + [ descent>> ] map ?supremum ; : max-text-height ( seq -- y ) - 0 [ [ height>> ] [ ascent>> ] bi [ max ] [ drop ] if ] reduce ; + [ ascent>> ] filter [ height>> ] map ?supremum ; : max-graphics-height ( seq -- y ) - 0 [ [ height>> ] [ ascent>> ] bi [ drop ] [ max ] if ] reduce ; - -: (align-baselines) ( y max leading -- y' ) [ swap - ] dip + ; + [ ascent>> not ] filter [ height>> ] map ?supremum 0 or ; :: combine-metrics ( graphics-height ascent descent cap-height -- ascent' descent' ) - cap-height 2 / :> mid-line - graphics-height 2 / - [ ascent mid-line - max mid-line + >integer ] - [ descent mid-line + max mid-line - >integer ] bi ; + ascent [ + cap-height 2 / :> mid-line + graphics-height 2 / + [ ascent mid-line - max mid-line + >integer ] + [ descent mid-line + max mid-line - >integer ] bi + ] [ f f ] if ; + +: (measure-metrics) ( children sizes -- graphics-height ascent descent cap-height ) + [ ] 2map + { + [ max-graphics-height ] + [ max-ascent ] + [ max-descent ] + [ max-cap-height ] + } cleave ; PRIVATE> :: align-baselines ( gadgets -- ys ) gadgets [ dup pref-dim ] map - dup max-ascent :> max-ascent - dup max-cap-height :> max-cap-height + dup max-ascent 0 or :> max-ascent + dup max-cap-height 0 or :> max-cap-height dup max-graphics-height :> max-graphics-height max-cap-height max-graphics-height + 2 /i :> critical-line @@ -61,20 +73,12 @@ PRIVATE> [ dup ascent>> - [ ascent>> max-ascent text-leading ] - [ height>> max-graphics-height graphics-leading ] if - (align-baselines) + [ ascent>> max-ascent swap - text-leading ] + [ height>> max-graphics-height swap - 2/ graphics-leading ] if + ] map ; : measure-metrics ( children sizes -- ascent descent ) - [ ] 2map - { - [ max-graphics-height ] - [ max-ascent ] - [ max-descent ] - [ max-cap-height ] - } cleave - combine-metrics ; + (measure-metrics) combine-metrics ; : measure-height ( children sizes -- height ) - measure-metrics + ; \ No newline at end of file + (measure-metrics) dup [ combine-metrics + ] [ 3drop ] if ; \ No newline at end of file diff --git a/basis/ui/gadgets/icons/icons.factor b/basis/ui/gadgets/icons/icons.factor index ddadb6b99e..123f7a540d 100644 --- a/basis/ui/gadgets/icons/icons.factor +++ b/basis/ui/gadgets/icons/icons.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: kernel accessors ui.images ui.pens -ui.pens.image ui.gadgets ; +ui.pens.image ui.gadgets ui.gadgets.labels ; IN: ui.gadgets.icons TUPLE: icon < gadget ; @@ -9,4 +9,6 @@ TUPLE: icon < gadget ; : ( image-name -- icon ) icon new swap t >>fill? >>interior ; -M: icon pref-dim* dup interior>> pen-pref-dim ; \ No newline at end of file +M: icon pref-dim* dup interior>> pen-pref-dim ; + +M: image-name >label ; \ No newline at end of file diff --git a/basis/ui/gadgets/packs/packs-tests.factor b/basis/ui/gadgets/packs/packs-tests.factor index cae7d12dc3..153579643d 100644 --- a/basis/ui/gadgets/packs/packs-tests.factor +++ b/basis/ui/gadgets/packs/packs-tests.factor @@ -90,4 +90,43 @@ IN: ui.gadgets.packs.tests [ ] [ "g" get prefer ] unit-test -[ ] [ "g" get layout ] unit-test \ No newline at end of file +[ ] [ "g" get layout ] unit-test + +! Baseline alignment without any text gadgets should behave like align=1/2 + +baseline+ >>align + { 30 30 } >>dim add-gadget + { 30 20 } >>dim add-gadget +"g" set + +[ { 60 30 } ] [ "g" get pref-dim ] unit-test + +[ ] [ "g" get prefer ] unit-test + +[ ] [ "g" get layout ] unit-test + +[ V{ { 0 0 } { 30 5 } } ] +[ "g" get children>> [ loc>> ] map ] unit-test + + +baseline+ >>align + { 30 30 } >>dim add-gadget +10 10 { 10 10 } add-gadget +"g" set + +[ ] [ "g" get prefer ] unit-test + +[ ] [ "g" get layout ] unit-test + +[ V{ { 0 0 } { 30 10 } } ] +[ "g" get children>> [ loc>> ] map ] unit-test + + +baseline+ >>align + { 30 30 } >>dim add-gadget add-gadget +10 10 { 10 10 } add-gadget +"g" set + +[ ] [ "g" get prefer ] unit-test + +[ ] [ "g" get layout ] unit-test + +[ V{ { 0 0 } { 30 10 } } ] +[ "g" get children>> [ loc>> ] map ] unit-test \ No newline at end of file diff --git a/basis/ui/gadgets/packs/packs.factor b/basis/ui/gadgets/packs/packs.factor index 95f04dfe4d..f47b374aeb 100644 --- a/basis/ui/gadgets/packs/packs.factor +++ b/basis/ui/gadgets/packs/packs.factor @@ -1,8 +1,8 @@ ! Copyright (C) 2005, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: sequences ui.gadgets ui.baseline-alignment kernel math -math.functions math.vectors math.order math.rectangles namespaces -accessors fry combinators arrays ; +USING: sequences ui.gadgets ui.baseline-alignment +ui.baseline-alignment.private kernel math math.functions math.vectors +math.order math.rectangles namespaces accessors fry combinators arrays ; IN: ui.gadgets.packs TUPLE: pack < gadget @@ -84,8 +84,7 @@ M: pack pref-dim* children>> dup pref-dims measure-metrics drop ; : pack-cap-height ( pack -- n ) - children>> [ cap-height ] map sift - [ f ] [ supremum ] if-empty ; + children>> [ cap-height ] map ?supremum ; PRIVATE> diff --git a/basis/ui/gadgets/panes/panes-tests.factor b/basis/ui/gadgets/panes/panes-tests.factor index 0529437a76..01abe8b3d9 100644 --- a/basis/ui/gadgets/panes/panes-tests.factor +++ b/basis/ui/gadgets/panes/panes-tests.factor @@ -2,7 +2,7 @@ USING: alien ui.gadgets.panes ui.gadgets namespaces kernel sequences io io.styles io.streams.string tools.test prettyprint definitions help help.syntax help.markup help.stylesheet splitting ui.gadgets.debug models math summary -inspector accessors help.topics see ; +inspector accessors help.topics see fry ; IN: ui.gadgets.panes.tests : #children ( -- n ) "pane" get children>> length ; @@ -18,8 +18,9 @@ IN: ui.gadgets.panes.tests [ t ] [ #children "num-children" get = ] unit-test : test-gadget-text ( quot -- ? ) - dup make-pane gadget-text dup print "======" print - swap with-string-writer dup print = ; + '[ _ call( -- ) ] + [ make-pane gadget-text dup print "======" print ] + [ with-string-writer dup print ] bi = ; [ t ] [ [ "hello" write ] test-gadget-text ] unit-test [ t ] [ [ "hello" pprint ] test-gadget-text ] unit-test diff --git a/basis/ui/gadgets/search-tables/search-tables.factor b/basis/ui/gadgets/search-tables/search-tables.factor index 17570a8714..fc564b6ffe 100644 --- a/basis/ui/gadgets/search-tables/search-tables.factor +++ b/basis/ui/gadgets/search-tables/search-tables.factor @@ -74,7 +74,7 @@ CONSULT: table-protocol search-table table>> ; dup field>> { 2 2 } f track-add values search 500 milliseconds quot renderer f >>takes-focus? >>table - dup table>> 1 track-add ; + dup table>> 1 track-add ; inline M: search-table model-changed nip field>> clear-search-field ; diff --git a/basis/ui/gadgets/tables/tables.factor b/basis/ui/gadgets/tables/tables.factor index 77249149ae..3fe2156df0 100644 --- a/basis/ui/gadgets/tables/tables.factor +++ b/basis/ui/gadgets/tables/tables.factor @@ -59,14 +59,19 @@ focused? ; GENERIC: cell-width ( font cell -- x ) GENERIC: cell-height ( font cell -- y ) +GENERIC: cell-padding ( cell -- y ) GENERIC: draw-cell ( font cell -- ) M: string cell-width text-width ; M: string cell-height text-height ceiling ; +M: string cell-padding drop 0 ; M: string draw-cell draw-text ; +CONSTANT: image-padding 2 + M: image-name cell-width nip image-dim first ; M: image-name cell-height nip image-dim second ; +M: image-name cell-padding drop image-padding ; M: image-name draw-cell nip draw-image ; : table-rows ( table -- rows ) @@ -87,7 +92,7 @@ CONSTANT: column-title-background COLOR: light-gray if ; : row-column-widths ( table row -- widths ) - [ font>> ] dip [ cell-width ] with map ; + [ font>> ] dip [ [ cell-width ] [ cell-padding ] bi + ] with map ; : compute-total-width ( gap widths -- total ) swap [ column-offsets drop ] keep - ; @@ -162,9 +167,10 @@ M: table layout* '[ [ 0 2array ] [ _ 2array ] bi gl-line ] each ] bi ; -: column-loc ( font column width align -- loc ) - [ [ cell-width ] dip swap - ] dip - * >integer 0 2array ; +:: column-loc ( font column width align -- loc ) + font column cell-width width swap - align * column cell-padding 2 / 1 align - * + + font column cell-height \ line-height get swap - 2 / + [ >integer ] bi@ 2array ; : translate-column ( width gap -- ) + 0 2array gl-translate ; @@ -203,18 +209,21 @@ M: table draw-line ( row index table -- ) M: table draw-gadget* dup control-value empty? [ drop ] [ - { - [ draw-selected-row ] - [ draw-lines ] - [ draw-column-lines ] - [ draw-focused-row ] - [ draw-moused-row ] - } cleave + dup line-height \ line-height [ + { + [ draw-selected-row ] + [ draw-lines ] + [ draw-column-lines ] + [ draw-focused-row ] + [ draw-moused-row ] + } cleave + ] with-variable ] if ; M: table line-height ( table -- y ) [ font>> ] [ renderer>> prototype-row ] bi - [ cell-height ] with [ max ] map-reduce ; + [ [ cell-height ] [ cell-padding ] bi + ] with + [ max ] map-reduce ; M: table pref-dim* [ compute-column-widths drop ] keep @@ -379,14 +388,16 @@ TUPLE: column-headers < gadget table ; column-title-background >>interior ; : draw-column-titles ( table -- ) - { - [ renderer>> column-titles ] - [ column-widths>> ] - [ table-column-alignment ] - [ font>> column-title-font ] - [ gap>> ] - } cleave - draw-columns ; + dup font>> font-metrics height>> \ line-height [ + { + [ renderer>> column-titles ] + [ column-widths>> ] + [ table-column-alignment ] + [ font>> column-title-font ] + [ gap>> ] + } cleave + draw-columns + ] with-variable ; M: column-headers draw-gadget* table>> draw-column-titles ; diff --git a/basis/ui/tools/browser/browser.factor b/basis/ui/tools/browser/browser.factor index 0c6e1fe05a..a493d5d7d2 100644 --- a/basis/ui/tools/browser/browser.factor +++ b/basis/ui/tools/browser/browser.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2006, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: debugger help help.topics help.crossref help.home kernel models +USING: debugger classes help help.topics help.crossref help.home kernel models compiler.units assocs words vocabs accessors fry arrays combinators.short-circuit namespaces sequences models help.apropos combinators ui ui.commands ui.gadgets ui.gadgets.panes @@ -91,6 +91,10 @@ M: browser-gadget focusable-child* search-field>> ; : browser-window ( -- ) "help.home" (browser-window) ; +: error-help-window ( error -- ) + [ error-help ] + [ dup tuple? [ class ] [ drop "errors" ] if ] bi or (browser-window) ; + \ browser-window H{ { +nullary+ t } } define-command : com-browse ( link -- ) diff --git a/basis/ui/tools/browser/popups/popups.factor b/basis/ui/tools/browser/popups/popups.factor index 05d7779305..91ac96e0f9 100644 --- a/basis/ui/tools/browser/popups/popups.factor +++ b/basis/ui/tools/browser/popups/popups.factor @@ -46,7 +46,7 @@ SLOT: model : show-links-popup ( browser-gadget quot title -- ) [ dup model>> ] 2dip - [ hand-loc get { 0 0 } show-glass ] [ request-focus ] bi ; + [ hand-loc get { 0 0 } show-glass ] [ request-focus ] bi ; inline : com-show-outgoing-links ( browser-gadget -- ) [ uses ] "Outgoing links" show-links-popup ; diff --git a/basis/ui/tools/debugger/debugger.factor b/basis/ui/tools/debugger/debugger.factor index c3ead4e3f5..42666ab064 100644 --- a/basis/ui/tools/debugger/debugger.factor +++ b/basis/ui/tools/debugger/debugger.factor @@ -8,7 +8,7 @@ ui.gadgets.buttons ui.gadgets.labels ui.gadgets.panes ui.gadgets.presentations ui.gadgets.viewports ui.gadgets.tables ui.gadgets.tracks ui.gadgets.scrollers ui.gadgets.panes ui.gadgets.borders ui.gadgets.status-bar ui.tools.traceback -ui.tools.inspector ; +ui.tools.inspector ui.tools.browser ; IN: ui.tools.debugger TUPLE: debugger < track error restarts restart-hook restart-list continuation ; @@ -86,9 +86,7 @@ debugger "gestures" f { : com-traceback ( debugger -- ) continuation>> traceback-window ; -: com-help ( debugger -- ) error>> (:help) ; - -\ com-help H{ { +listener+ t } } define-command +: com-help ( debugger -- ) error>> error-help-window ; : com-edit ( debugger -- ) error>> (:edit) ; diff --git a/basis/ui/tools/error-list/authors.txt b/basis/ui/tools/error-list/authors.txt new file mode 100644 index 0000000000..d4f5d6b3ae --- /dev/null +++ b/basis/ui/tools/error-list/authors.txt @@ -0,0 +1 @@ +Slava Pestov \ No newline at end of file diff --git a/basis/ui/tools/error-list/error-list-docs.factor b/basis/ui/tools/error-list/error-list-docs.factor new file mode 100644 index 0000000000..21e9a71db5 --- /dev/null +++ b/basis/ui/tools/error-list/error-list-docs.factor @@ -0,0 +1,20 @@ +IN: ui.tools.error-list +USING: help.markup help.syntax ; + +ARTICLE: "ui.tools.error-list" "UI error list tool" +"The error list tool displays messages generated by tools which process source files and definitions." +$nl +"The different types of messages displayed:" +{ $table + { "Icon" "Message type" "Reference" } + { { $image "vocab:ui/tools/error-list/icons/note.tiff" } "Parser note" { $link "parser" } } + { { $image "vocab:ui/tools/error-list/icons/syntax-error.tiff" } "Syntax error" { $link "syntax" } } + { { $image "vocab:ui/tools/error-list/icons/compiler-warning.tiff" } "Compiler warning" { $link "compiler-errors" } } + { { $image "vocab:ui/tools/error-list/icons/compiler-error.tiff" } "Compiler error" { $link "compiler-errors" } } + { { $image "vocab:ui/tools/error-list/icons/unit-test-error.tiff" } "Unit test failure" { $link "tools.test" } } + { { $image "vocab:ui/tools/error-list/icons/help-lint-error.tiff" } "Help lint failure" { $link "help.lint" } } + { { $image "vocab:ui/tools/error-list/icons/linkage-error.tiff" } "Linkage error" { $link "compiler-errors" } } +} +"The " { $vocab-link "source-files.errors" } " vocabulary contains backend code used by this tool." ; + +ABOUT: "ui.tools.error-list" diff --git a/basis/ui/tools/error-list/error-list.factor b/basis/ui/tools/error-list/error-list.factor new file mode 100644 index 0000000000..73b1d7991a --- /dev/null +++ b/basis/ui/tools/error-list/error-list.factor @@ -0,0 +1,210 @@ +! Copyright (C) 2009 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors arrays sequences sorting assocs colors.constants fry +combinators combinators.smart combinators.short-circuit editors memoize +compiler.errors compiler.units fonts kernel io.pathnames prettyprint +tools.test stack-checker.errors source-files.errors math.parser +math.order models models.arrow models.arrow.smart models.search +models.mapping debugger namespaces summary locals ui ui.commands +ui.gadgets ui.gadgets.panes ui.gadgets.tables ui.gadgets.labeled +ui.gadgets.tracks ui.gestures ui.operations ui.tools.browser +ui.tools.common ui.gadgets.scrollers ui.tools.inspector +ui.gadgets.status-bar ui.operations ui.gadgets.buttons +ui.gadgets.borders ui.gadgets.packs ui.gadgets.labels +ui.baseline-alignment ui.images ; +IN: ui.tools.error-list + +CONSTANT: error-types + { + +compiler-warning+ + +compiler-error+ + +test-failure+ + +linkage-error+ + } + +MEMO: error-list-icon ( object -- object ) + "vocab:ui/tools/error-list/icons/" ".tiff" surround ; + +: error-icon ( type -- icon ) + { + { +compiler-error+ [ "compiler-error" ] } + { +compiler-warning+ [ "compiler-warning" ] } + { +linkage-error+ [ "linkage-error" ] } + { +test-failure+ [ "unit-test-error" ] } + } case error-list-icon ; + +: ( alist -- gadget ) + [ { 15 0 } >>gap ] dip + [ swap add-gadget ] assoc-each ; + +: ( -- model gadget ) + #! Linkage errors are not shown by default. + error-types [ dup +linkage-error+ eq? not ] { } map>assoc + [ [ [ error-icon ] dip ] assoc-map ] + [ ] bi ; + +TUPLE: error-list-gadget < tool +visible-errors source-file error +error-toggle source-file-table error-table error-display ; + +SINGLETON: source-file-renderer + +: source-file-icon ( -- image-name ) + "source-file" error-list-icon ; + +M: source-file-renderer row-columns + drop first2 + [ [ source-file-icon ] [ ] [ length number>string ] tri* ] output>array ; + +M: source-file-renderer prototype-row + drop source-file-icon "" "" 3array ; + +M: source-file-renderer row-value + drop dup [ first ] when ; + +M: source-file-renderer column-titles + drop { "" "File" "Errors" } ; + +M: source-file-renderer column-alignment drop { 0 0 1 } ; + +M: source-file-renderer filled-column drop 1 ; + +: ( model -- model' ) + [ group-by-source-file >alist sort-keys ] ; + +:: ( error-list -- table ) + error-list model>> + source-file-renderer +
+ [ invoke-primary-operation ] >>action + COLOR: dark-gray >>column-line-color + 6 >>gap + 30 >>min-rows + 30 >>max-rows + 60 >>min-cols + 60 >>max-cols + t >>selection-required? + error-list source-file>> >>selected-value ; + +SINGLETON: error-renderer + +M: error-renderer row-columns + drop [ + { + [ source-file-error-type error-icon ] + [ line#>> number>string ] + [ asset>> unparse-short ] + [ error>> summary ] + } cleave + ] output>array ; + +M: error-renderer prototype-row + drop [ +compiler-error+ error-icon "" "" "" ] output>array ; + +M: error-renderer row-value + drop ; + +M: error-renderer column-titles + drop { "" "Line" "Asset" "Error" } ; + +M: error-renderer column-alignment drop { 0 1 0 0 } ; + +: sort-errors ( seq -- seq' ) + [ [ [ file>> ] [ line#>> ] bi 2array ] compare ] sort ; + +: ( error-list -- model ) + [ model>> ] [ source-file>> ] bi + [ [ file>> ] [ string>> ] bi* = ] + [ sort-errors ] ; + +:: ( error-list -- table ) + error-list + error-renderer +
+ [ invoke-primary-operation ] >>action + COLOR: dark-gray >>column-line-color + 6 >>gap + 30 >>min-rows + 30 >>max-rows + 60 >>min-cols + 60 >>max-cols + t >>selection-required? + error-list error>> >>selected-value ; + +TUPLE: error-display < track ; + +: ( error-list -- gadget ) + vertical error-display new-track + add-toolbar + swap error>> >>model + dup model>> [ print-error ] 1 track-add ; + +: com-inspect ( error-display -- ) + model>> value>> inspector ; + +: com-help ( error-display -- ) + model>> value>> error>> error-help-window ; + +: com-edit ( error-display -- ) + model>> value>> edit-error ; + +error-display "toolbar" f { + { f com-inspect } + { f com-help } + { f com-edit } +} define-command-map + +: ( error-list -- toolbar ) + [ ] [ error-toggle>> "Show errors:" label-on-left add-gadget ] bi ; + +: ( visible-errors model -- model' ) + [ swap '[ source-file-error-type _ at ] filter ] ; + +:: ( model -- gadget ) + vertical error-list-gadget new-track + [ >>error-toggle ] [ >>visible-errors ] bi* + dup visible-errors>> model >>model + f >>source-file + f >>error + dup >>source-file-table + dup >>error-table + dup >>error-display + :> error-list + error-list vertical + { 5 5 } >>gap + error-list f track-add + error-list source-file-table>> "Source files" 1/4 track-add + error-list error-table>> "Errors" 1/2 track-add + error-list error-display>> "Details" 1/4 track-add + { 5 5 } 1 track-add ; + +M: error-list-gadget focusable-child* + source-file-table>> ; + +: error-list-help ( -- ) "ui.tools.error-list" com-browse ; + +\ error-list-help H{ { +nullary+ t } } define-command + +error-list-gadget "toolbar" f { + { T{ key-down f f "F1" } error-list-help } +} define-command-map + +SYMBOL: compiler-error-model + +compiler-error-model [ f ] initialize + +SINGLETON: updater + +M: updater definitions-changed + 2drop + compiler-errors get-global values + test-failures get-global append + compiler-error-model get-global + set-model ; + +updater remove-definition-observer +updater add-definition-observer + +: error-list-window ( -- ) + compiler-error-model get-global + "Compiler errors" open-status-window ; \ No newline at end of file diff --git a/basis/ui/tools/error-list/icons/compiler-error.tiff b/basis/ui/tools/error-list/icons/compiler-error.tiff new file mode 100644 index 0000000000..7a53d578fa Binary files /dev/null and b/basis/ui/tools/error-list/icons/compiler-error.tiff differ diff --git a/basis/ui/tools/error-list/icons/compiler-warning.tiff b/basis/ui/tools/error-list/icons/compiler-warning.tiff new file mode 100644 index 0000000000..405cfd4761 Binary files /dev/null and b/basis/ui/tools/error-list/icons/compiler-warning.tiff differ diff --git a/basis/ui/tools/error-list/icons/help-lint-error.tiff b/basis/ui/tools/error-list/icons/help-lint-error.tiff new file mode 100644 index 0000000000..464728a70c Binary files /dev/null and b/basis/ui/tools/error-list/icons/help-lint-error.tiff differ diff --git a/basis/ui/tools/error-list/icons/linkage-error.tiff b/basis/ui/tools/error-list/icons/linkage-error.tiff new file mode 100644 index 0000000000..78644fd819 Binary files /dev/null and b/basis/ui/tools/error-list/icons/linkage-error.tiff differ diff --git a/basis/ui/tools/error-list/icons/note.tiff b/basis/ui/tools/error-list/icons/note.tiff new file mode 100644 index 0000000000..834dea6b82 Binary files /dev/null and b/basis/ui/tools/error-list/icons/note.tiff differ diff --git a/basis/ui/tools/error-list/icons/source-file.tiff b/basis/ui/tools/error-list/icons/source-file.tiff new file mode 100644 index 0000000000..5fb3375520 Binary files /dev/null and b/basis/ui/tools/error-list/icons/source-file.tiff differ diff --git a/basis/ui/tools/error-list/icons/syntax-error.tiff b/basis/ui/tools/error-list/icons/syntax-error.tiff new file mode 100644 index 0000000000..5446c80e15 Binary files /dev/null and b/basis/ui/tools/error-list/icons/syntax-error.tiff differ diff --git a/basis/ui/tools/error-list/icons/unit-test-error.tiff b/basis/ui/tools/error-list/icons/unit-test-error.tiff new file mode 100644 index 0000000000..b6ea439f5a Binary files /dev/null and b/basis/ui/tools/error-list/icons/unit-test-error.tiff differ diff --git a/basis/ui/tools/operations/operations.factor b/basis/ui/tools/operations/operations.factor index c6371ac8aa..5da6402c8e 100644 --- a/basis/ui/tools/operations/operations.factor +++ b/basis/ui/tools/operations/operations.factor @@ -5,7 +5,7 @@ stack-checker summary io.pathnames io.styles kernel namespaces parser prettyprint quotations tools.crossref tools.annotations editors tools.profiler tools.test tools.time tools.walker vocabs vocabs.loader words sequences tools.vocabs classes -compiler.units accessors vocabs.parser macros.expander ui +compiler.errors compiler.units accessors vocabs.parser macros.expander ui ui.tools.browser ui.tools.listener ui.tools.listener.completion ui.tools.profiler ui.tools.inspector ui.tools.traceback ui.commands ui.gadgets.editors ui.gestures ui.operations @@ -86,6 +86,21 @@ IN: ui.tools.operations { +listener+ t } } define-operation +! Compiler errors +[ compiler-error? ] \ edit-error H{ + { +primary+ t } + { +secondary+ t } + { +listener+ t } +} define-operation + +: com-reload ( error -- ) + file>> run-file ; + +[ compiler-error? ] \ com-reload H{ + { +listener+ t } +} define-operation + +! Definitions : com-forget ( defspec -- ) [ forget ] with-compilation-unit ; @@ -173,4 +188,4 @@ interactor "These commands operate on the entire contents of the input area." [ ] [ quot-action ] -define-operation-map +define-operation-map \ No newline at end of file diff --git a/basis/ui/tools/profiler/profiler-tests.factor b/basis/ui/tools/profiler/profiler-tests.factor new file mode 100644 index 0000000000..86bebddbc9 --- /dev/null +++ b/basis/ui/tools/profiler/profiler-tests.factor @@ -0,0 +1,3 @@ +USING: ui.tools.profiler tools.test ; + +\ profiler-window must-infer diff --git a/basis/ui/tools/profiler/profiler.factor b/basis/ui/tools/profiler/profiler.factor index 1c2318a35e..5fef64ea88 100644 --- a/basis/ui/tools/profiler/profiler.factor +++ b/basis/ui/tools/profiler/profiler.factor @@ -11,6 +11,7 @@ ui.gadgets.tabbed ui.gadgets.status-bar ui.gadgets.borders ui.tools.browser ui.tools.common ui.baseline-alignment ui.operations ui.images ; FROM: models.arrow => ; +FROM: models.arrow.smart => ; FROM: models.product => ; IN: ui.tools.profiler @@ -112,8 +113,8 @@ M: method-renderer column-titles drop { "" "Method" "Count" } ; : ( profiler -- model ) [ [ method-counters ] dip - [ generic>> ] [ class>> ] bi 3array - [ first3 '[ _ _ method-matches? ] filter ] + [ generic>> ] [ class>> ] bi + [ '[ _ _ method-matches? ] filter ] ] keep ; : sort-by-name ( obj1 obj2 -- <=> ) @@ -208,6 +209,6 @@ profiler-gadget "toolbar" f { : profiler-window ( -- ) "Profiling results" open-status-window ; -: com-profile ( quot -- ) profile profiler-window ; +: com-profile ( quot -- ) profile profiler-window ; inline MAIN: profiler-window diff --git a/basis/ui/tools/tools-docs.factor b/basis/ui/tools/tools-docs.factor index 52cd77d726..92aa1be947 100644 --- a/basis/ui/tools/tools-docs.factor +++ b/basis/ui/tools/tools-docs.factor @@ -66,6 +66,7 @@ $nl { $subsection "ui-listener" } { $subsection "ui-browser" } { $subsection "ui-inspector" } +{ $subsection "ui.tools.error-list" } { $subsection "ui.tools.profiler" } { $subsection "ui-walker" } { $subsection "ui.tools.deploy" } diff --git a/basis/ui/tools/tools.factor b/basis/ui/tools/tools.factor index 203953db1a..cd4216b7a1 100644 --- a/basis/ui/tools/tools.factor +++ b/basis/ui/tools/tools.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2006, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: memory system kernel tools.vocabs ui.tools.operations -ui.tools.listener ui.tools.browser ui.tools.common +ui.tools.listener ui.tools.browser ui.tools.common ui.tools.error-list ui.tools.walker ui.commands ui.gestures ui ui.private ; IN: ui.tools diff --git a/core/compiler/errors/errors-docs.factor b/core/compiler/errors/errors-docs.factor index 8368afeb19..987db582b4 100644 --- a/core/compiler/errors/errors-docs.factor +++ b/core/compiler/errors/errors-docs.factor @@ -2,51 +2,7 @@ IN: compiler.errors USING: help.markup help.syntax vocabs.loader words io quotations words.symbol ; -ARTICLE: "compiler-errors" "Compiler warnings and errors" -"After loading a vocabulary, you might see messages like:" -{ $code - ":errors - print 2 compiler errors." - ":warnings - print 50 compiler warnings." -} -"These warnings arise from the compiler's stack effect checker. Warnings are non-fatal conditions -- not all code has a static stack effect, so you try to minimize warnings but understand that in many cases they cannot be eliminated. Errors indicate programming mistakes, such as erroneous stack effect declarations." -$nl -"The precise warning and error conditions are documented in " { $link "inference-errors" } "." -$nl -"Words to view warnings and errors:" -{ $subsection :errors } -{ $subsection :warnings } -{ $subsection :linkage } -"Words such as " { $link require } " use a combinator which counts errors and prints a report at the end:" -{ $subsection with-compiler-errors } ; - HELP: compiler-errors { $var-description "Global variable holding an assoc mapping words to compiler errors. This variable is set by " { $link with-compiler-errors } "." } ; ABOUT: "compiler-errors" - -HELP: compiler-error -{ $values { "error" "an error" } { "word" word } } -{ $description "If inside a " { $link with-compiler-errors } ", saves the error for future persual via " { $link :errors } ", " { $link :warnings } " and " { $link :linkage } ". If not inside a " { $link with-compiler-errors } ", ignores the error." } ; - -HELP: compiler-error. -{ $values { "error" "an error" } { "word" word } } -{ $description "Prints a compiler error to " { $link output-stream } "." } ; - -HELP: compiler-errors. -{ $values { "type" symbol } } -{ $description "Prints compiler errors to " { $link output-stream } ". The type parameter is one of " { $link +error+ } ", " { $link +warning+ } ", or " { $link +linkage+ } "." } ; -HELP: :errors -{ $description "Prints all serious compiler errors from the most recent compile to " { $link output-stream } "." } ; - -HELP: :warnings -{ $description "Prints all ignorable compiler warnings from the most recent compile to " { $link output-stream } "." } ; - -HELP: :linkage -{ $description "Prints all C library interface linkage errors from the most recent compile to " { $link output-stream } "." } ; - -{ :errors :warnings } related-words - -HELP: with-compiler-errors -{ $values { "quot" quotation } } -{ $description "Calls the quotation and collects any compiler warnings and errors. Compiler warnings and errors are summarized at the end and can be viewed with " { $link :errors } ", " { $link :warnings } ", and " { $link :linkage } "." } -{ $notes "Nested calls to " { $link with-compiler-errors } " are ignored, and only the outermost call collects warnings and errors." } ; diff --git a/core/compiler/errors/errors.factor b/core/compiler/errors/errors.factor index 1ea497c3fc..1f02aaf341 100644 --- a/core/compiler/errors/errors.factor +++ b/core/compiler/errors/errors.factor @@ -1,32 +1,27 @@ -! Copyright (C) 2007, 2008 Slava Pestov. +! 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.parser ; +continuations math math.parser accessors definitions +source-files.errors ; IN: compiler.errors -SYMBOL: +error+ -SYMBOL: +warning+ -SYMBOL: +linkage+ +SYMBOLS: +compiler-error+ +compiler-warning+ +linkage-error+ ; -GENERIC: compiler-error-type ( error -- ? ) +TUPLE: compiler-error < source-file-error ; -M: object compiler-error-type drop +error+ ; - -GENERIC# compiler-error. 1 ( error word -- ) +M: compiler-error source-file-error-type error>> source-file-error-type ; SYMBOL: compiler-errors +compiler-errors [ H{ } clone ] initialize + SYMBOL: with-compiler-errors? : errors-of-type ( type -- assoc ) compiler-errors get-global - swap [ [ nip compiler-error-type ] dip eq? ] curry + swap [ [ nip source-file-error-type ] dip eq? ] curry assoc-filter ; -: compiler-errors. ( type -- ) - errors-of-type >alist sort-keys - [ swap compiler-error. ] assoc-each ; - : (compiler-report) ( what type word -- ) over errors-of-type assoc-empty? [ 3drop ] [ [ @@ -41,27 +36,25 @@ SYMBOL: with-compiler-errors? ] if ; : compiler-report ( -- ) - "semantic errors" +error+ "errors" (compiler-report) - "semantic warnings" +warning+ "warnings" (compiler-report) - "linkage errors" +linkage+ "linkage" (compiler-report) ; + "compiler errors" +compiler-error+ "errors" (compiler-report) + "compiler warnings" +compiler-warning+ "warnings" (compiler-report) + "linkage errors" +linkage-error+ "linkage" (compiler-report) ; -: :errors ( -- ) +error+ compiler-errors. ; - -: :warnings ( -- ) +warning+ compiler-errors. ; - -: :linkage ( -- ) +linkage+ compiler-errors. ; +: ( error word -- compiler-error ) + \ compiler-error new + swap + [ >>asset ] + [ where [ first2 ] [ "" 0 ] if* [ >>file ] [ >>line# ] bi* ] bi + swap >>error ; : compiler-error ( error word -- ) - with-compiler-errors? get [ - compiler-errors get pick - [ set-at ] [ delete-at drop ] if - ] [ 2drop ] if ; + compiler-errors get-global pick + [ [ [ ] keep ] dip set-at ] [ delete-at drop ] if ; : with-compiler-errors ( quot -- ) with-compiler-errors? get "quiet" get or [ call ] [ [ with-compiler-errors? on - V{ } clone compiler-errors set-global [ compiler-report ] [ ] cleanup ] with-scope ] if ; inline diff --git a/core/compiler/units/units-tests.factor b/core/compiler/units/units-tests.factor index d84b377f36..6545a45604 100644 --- a/core/compiler/units/units-tests.factor +++ b/core/compiler/units/units-tests.factor @@ -1,6 +1,6 @@ -IN: compiler.units.tests USING: definitions compiler.units tools.test arrays sequences words kernel accessors namespaces fry ; +IN: compiler.units.tests [ [ [ ] define-temp ] with-compilation-unit ] must-infer [ [ [ ] define-temp ] with-nested-compilation-unit ] must-infer @@ -30,4 +30,19 @@ accessors namespaces fry ; "a" get [ "B" ] define ] with-compilation-unit "b" get execute -] unit-test \ No newline at end of file +] unit-test + +! Notify observers even if compilation unit did nothing +SINGLETON: observer + +observer add-definition-observer + +SYMBOL: counter + +0 counter set-global + +M: observer definitions-changed 2drop global [ counter inc ] bind ; + +[ ] with-compilation-unit + +[ 1 ] [ counter get-global ] unit-test \ No newline at end of file diff --git a/core/compiler/units/units.factor b/core/compiler/units/units.factor index afa05f9442..e8b5b4647d 100644 --- a/core/compiler/units/units.factor +++ b/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 compiler.errors ; IN: compiler.units SYMBOL: old-definitions @@ -41,7 +41,7 @@ SYMBOL: compiler-impl HOOK: recompile compiler-impl ( words -- alist ) ! Non-optimizing compiler -M: f recompile [ f ] { } map>assoc ; +M: f recompile [ [ f swap compiler-error ] each ] [ [ f ] { } map>assoc ] bi ; ! Trivial compiler. We don't want to touch the code heap ! during stage1 bootstrap, it would just waste time. diff --git a/core/parser/parser-tests.factor b/core/parser/parser-tests.factor index 3ba414fe6b..9e1fcb95bd 100644 --- a/core/parser/parser-tests.factor +++ b/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 diff --git a/core/parser/parser.factor b/core/parser/parser.factor index 6d613a8b24..04fa7fa03f 100644 --- a/core/parser/parser.factor +++ b/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" diff --git a/core/sequences/sequences.factor b/core/sequences/sequences.factor index 564309a6fb..b614c15150 100755 --- a/core/sequences/sequences.factor +++ b/core/sequences/sequences.factor @@ -568,6 +568,9 @@ M: sequence <=> 2dup [ length ] bi@ = [ mismatch not ] [ 2drop f ] if ; inline +: assert-sequence= ( a b -- ) + 2dup sequence= [ 2drop ] [ assert ] if ; + : sequence-hashcode-step ( oldhash newpart -- newhash ) >fixnum swap [ [ -2 fixnum-shift-fast ] [ 5 fixnum-shift-fast ] bi diff --git a/core/source-files/errors/authors.txt b/core/source-files/errors/authors.txt new file mode 100644 index 0000000000..d4f5d6b3ae --- /dev/null +++ b/core/source-files/errors/authors.txt @@ -0,0 +1 @@ +Slava Pestov \ No newline at end of file diff --git a/core/source-files/errors/errors.factor b/core/source-files/errors/errors.factor new file mode 100644 index 0000000000..7f19d04f84 --- /dev/null +++ b/core/source-files/errors/errors.factor @@ -0,0 +1,14 @@ +! Copyright (C) 2009 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors assocs kernel math.order sorting sequences ; +IN: source-files.errors + +TUPLE: source-file-error error asset file line# ; + +: sort-errors ( errors -- alerrors'ist ) + [ [ [ line#>> ] compare ] sort ] { } assoc-map-as sort-keys ; + +: group-by-source-file ( errors -- assoc ) + H{ } clone [ [ push-at ] curry [ dup file>> ] prepose each ] keep ; + +GENERIC: source-file-error-type ( error -- type ) diff --git a/core/source-files/source-files.factor b/core/source-files/source-files.factor index c8441ba3b0..8edd62260a 100644 --- a/core/source-files/source-files.factor +++ b/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 ; - -: ( msg -- error ) +: wrap-source-file-error ( error -- * ) + file get rollback-source-file \ source-file-error new - file get >>file - swap >>error ; + f >>line# + 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 - rethrow - ] recover + source-file + [ file set ] + [ definitions>> old-definitions set ] bi + ] dip + [ wrap-source-file-error ] recover ] with-scope ; inline