diff --git a/basis/compiler/compiler.factor b/basis/compiler/compiler.factor index e3c2ed4697..a772855ab6 100755 --- a/basis/compiler/compiler.factor +++ b/basis/compiler/compiler.factor @@ -63,17 +63,23 @@ M: method-body no-compile? "method-generic" word-prop no-compile? ; M: predicate-engine-word no-compile? "owner-generic" word-prop no-compile? ; M: word no-compile? - { - [ macro? ] - [ inline? ] - [ "special" word-prop ] - [ "no-compile" word-prop ] - } 1|| ; + { [ macro? ] [ "special" word-prop ] [ "no-compile" word-prop ] } 1|| ; + +GENERIC: combinator? ( word -- ? ) + +M: method-body combinator? "method-generic" word-prop combinator? ; + +M: predicate-engine-word combinator? "owner-generic" word-prop combinator? ; + +M: word combinator? inline? ; : ignore-error? ( word error -- ? ) #! Ignore some errors on inline combinators, macros, and special #! words such as 'call'. - [ no-compile? ] [ { [ do-not-compile? ] [ literal-expected? ] } 1|| ] bi* and ; + { + [ drop no-compile? ] + [ [ combinator? ] [ unknown-macro-input? ] bi* and ] + } 2|| ; : finish ( word -- ) #! Recompile callers if the word's stack effect changed, then diff --git a/basis/compiler/tree/builder/builder.factor b/basis/compiler/tree/builder/builder.factor index e4523deb9f..8eb66fde1f 100644 --- a/basis/compiler/tree/builder/builder.factor +++ b/basis/compiler/tree/builder/builder.factor @@ -39,7 +39,7 @@ M: word (build-tree) [ recursive-state set V{ } clone stack-visitor set - [ [ >vector \ meta-d set ] [ length d-in set ] bi ] + [ [ >vector \ meta-d set ] [ length input-count set ] bi ] [ (build-tree) ] bi* ] with-infer nip ; diff --git a/basis/debugger/debugger.factor b/basis/debugger/debugger.factor index f1e23b18f5..72dea5aeac 100644 --- a/basis/debugger/debugger.factor +++ b/basis/debugger/debugger.factor @@ -26,6 +26,9 @@ M: object error. short. ; M: string error. print ; +: traceback-link. ( continuation -- ) + "[" write [ "Traceback" ] dip write-object "]" print ; + : :s ( -- ) error-continuation get data>> stack. ; diff --git a/basis/stack-checker/backend/backend-tests.factor b/basis/stack-checker/backend/backend-tests.factor index 48cd10a7ee..b58998cb49 100644 --- a/basis/stack-checker/backend/backend-tests.factor +++ b/basis/stack-checker/backend/backend-tests.factor @@ -1,17 +1,21 @@ USING: stack-checker.backend tools.test kernel namespaces -stack-checker.state sequences ; +stack-checker.state stack-checker.values sequences assocs ; IN: stack-checker.backend.tests [ ] [ V{ } clone \ meta-d set V{ } clone \ meta-r set V{ } clone \ literals set - 0 d-in set + H{ } clone known-values set + 0 input-count set ] unit-test [ 0 ] [ 0 ensure-d length ] unit-test [ 2 ] [ 2 ensure-d length ] unit-test + +[ t ] [ meta-d [ known-values get at input-parameter? ] all? ] unit-test + [ 2 ] [ meta-d length ] unit-test [ 3 ] [ 3 ensure-d length ] unit-test diff --git a/basis/stack-checker/backend/backend.factor b/basis/stack-checker/backend/backend.factor index 2d4c1e9c61..b2a99f0731 100755 --- a/basis/stack-checker/backend/backend.factor +++ b/basis/stack-checker/backend/backend.factor @@ -10,10 +10,14 @@ IN: stack-checker.backend : push-d ( obj -- ) meta-d push ; +: introduce-values ( values -- ) + [ [ [ input-parameter ] dip set-known ] each ] + [ length input-count +@ ] + [ #introduce, ] + tri ; + : pop-d ( -- obj ) - meta-d [ - dup 1array #introduce, d-in inc - ] [ pop ] if-empty ; + meta-d [ dup 1array introduce-values ] [ pop ] if-empty ; : peek-d ( -- obj ) pop-d dup push-d ; @@ -24,7 +28,7 @@ IN: stack-checker.backend meta-d 2dup length > [ 2dup [ nip >array ] [ length - make-values ] [ nip delete-all ] 2tri - [ length d-in +@ ] [ #introduce, ] [ meta-d push-all ] tri + [ introduce-values ] [ meta-d push-all ] bi meta-d push-all ] when swap tail* ; diff --git a/basis/stack-checker/branches/branches.factor b/basis/stack-checker/branches/branches.factor index 8b0665aa49..99e5a70409 100755 --- a/basis/stack-checker/branches/branches.factor +++ b/basis/stack-checker/branches/branches.factor @@ -11,7 +11,7 @@ IN: stack-checker.branches SYMBOLS: +bottom+ +top+ ; -: unify-inputs ( max-d-in d-in meta-d -- new-meta-d ) +: unify-inputs ( max-input-count input-count meta-d -- new-meta-d ) ! Introduced values can be anything, and don't unify with ! literals. dup [ [ - +top+ ] dip append ] [ 3drop f ] if ; @@ -24,7 +24,7 @@ SYMBOLS: +bottom+ +top+ ; '[ _ +bottom+ pad-head ] map ] unless ; -: phi-inputs ( max-d-in pairs -- newseq ) +: phi-inputs ( max-input-count pairs -- newseq ) dup empty? [ nip ] [ swap '[ [ _ ] dip first2 unify-inputs ] map pad-with-bottom @@ -61,9 +61,9 @@ SYMBOL: quotations branch-variable ; : datastack-phi ( seq -- phi-in phi-out ) - [ d-in branch-variable ] [ \ meta-d active-variable ] bi + [ input-count branch-variable ] [ \ meta-d active-variable ] bi unify-branches - [ d-in set ] [ ] [ dup >vector \ meta-d set ] tri* ; + [ input-count set ] [ ] [ dup >vector \ meta-d set ] tri* ; : terminated-phi ( seq -- terminated ) terminated? branch-variable ; @@ -80,7 +80,7 @@ SYMBOL: quotations : copy-inference ( -- ) \ meta-d [ clone ] change literals [ clone ] change - d-in [ ] change ; + input-count [ ] change ; GENERIC: infer-branch ( literal -- namespace ) diff --git a/basis/stack-checker/state/state-tests.factor b/basis/stack-checker/dependencies/dependencies-tests.factor similarity index 92% rename from basis/stack-checker/state/state-tests.factor rename to basis/stack-checker/dependencies/dependencies-tests.factor index 4ecb39e592..9bcec64033 100644 --- a/basis/stack-checker/state/state-tests.factor +++ b/basis/stack-checker/dependencies/dependencies-tests.factor @@ -1,5 +1,5 @@ -IN: stack-checker.state.tests -USING: tools.test stack-checker.state words kernel namespaces +IN: stack-checker.dependencies.tests +USING: tools.test stack-checker.dependencies words kernel namespaces definitions ; : computing-dependencies ( quot -- dependencies ) @@ -35,4 +35,3 @@ SYMBOL: b [ inlined-dependency ] [ called-dependency inlined-dependency strongest-dependency ] unit-test [ flushed-dependency ] [ called-dependency flushed-dependency strongest-dependency ] unit-test [ called-dependency ] [ called-dependency f strongest-dependency ] unit-test - diff --git a/basis/stack-checker/errors/errors-docs.factor b/basis/stack-checker/errors/errors-docs.factor index 5da5197700..4b432e733f 100755 --- a/basis/stack-checker/errors/errors-docs.factor +++ b/basis/stack-checker/errors/errors-docs.factor @@ -12,10 +12,10 @@ HELP: do-not-compile } } ; -HELP: literal-expected -{ $error-description "Thrown when inference encounters a combinator or macro being applied to a value which is not known to be a literal, or constructed in a manner which can be analyzed statically. Such code needs changes before it can compile and run. See " { $link "inference-combinators" } " and " { $link "inference-escape" } " for details." } +HELP: unknown-macro-input +{ $error-description "Thrown when inference encounters a combinator or macro being applied to an input parameter of a non-" { $link POSTPONE: inline } " word. The word needs to be declared " { $link POSTPONE: inline } " before its callers can compile and run. See " { $link "inference-combinators" } " and " { $link "inference-escape" } " for details." } { $examples - "In this example, the words being defined cannot be called, because they fail to compile with a " { $link literal-expected } " error:" + "In this example, the words being defined cannot be called, because they fail to compile with a " { $link unknown-macro-input } " error:" { $code ": bad-example ( quot -- )" " [ call ] [ call ] bi ;" @@ -41,6 +41,27 @@ HELP: literal-expected } } ; +HELP: bad-macro-input +{ $error-description "Thrown when inference encounters a combinator or macro being applied to a value which is not known at compile time. Such code needs changes before it can compile and run. See " { $link "inference-combinators" } " and " { $link "inference-escape" } " for details." } +{ $examples + "In this example, the words being defined cannot be called, because they fail to compile with a " { $link bad-macro-input } " error:" + { $code + ": bad-example ( quot -- )" + " [ . ] append call ; inline" + "" + ": usage ( -- )" + " 2 2 [ + ] bad-example ;" + } + "One fix is to use " { $link compose } " instead of " { $link append } ":" + { $code + ": good-example ( quot -- )" + " [ . ] compose call ; inline" + "" + ": usage ( -- )" + " 2 2 [ + ] good-example ;" + } +} ; + HELP: unbalanced-branches-error { $values { "in" "a sequence of integers" } { "out" "a sequence of integers" } } { $description "Throws an " { $link unbalanced-branches-error } "." } @@ -121,7 +142,8 @@ ARTICLE: "inference-errors" "Stack checker errors" "Errors thrown when insufficient information is available to calculate the stack effect of a call to a combinator or macro (see " { $link "inference-combinators" } "):" { $subsections do-not-compile - literal-expected + unknown-macro-input + bad-macro-input } "Error thrown when a word's stack effect declaration does not match the composition of the stack effects of its factors:" { $subsections effect-error } diff --git a/basis/stack-checker/errors/errors.factor b/basis/stack-checker/errors/errors.factor index b1071df708..d476de84c5 100644 --- a/basis/stack-checker/errors/errors.factor +++ b/basis/stack-checker/errors/errors.factor @@ -1,13 +1,14 @@ ! Copyright (C) 2006, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: kernel stack-checker.values ; IN: stack-checker.errors TUPLE: inference-error ; ERROR: do-not-compile < inference-error word ; -ERROR: literal-expected < inference-error what ; +ERROR: bad-macro-input < inference-error macro ; + +ERROR: unknown-macro-input < inference-error macro ; ERROR: unbalanced-branches-error < inference-error branches quots ; @@ -31,8 +32,6 @@ ERROR: inconsistent-recursive-call-error < inference-error word ; ERROR: unknown-primitive-error < inference-error ; -ERROR: transform-expansion-error < inference-error word error ; +ERROR: transform-expansion-error < inference-error error continuation word ; -ERROR: bad-declaration-error < inference-error declaration ; - -M: object (literal) "literal value" literal-expected ; \ No newline at end of file +ERROR: bad-declaration-error < inference-error declaration ; \ 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 5be5722c23..eef35b61cd 100644 --- a/basis/stack-checker/errors/prettyprint/prettyprint.factor +++ b/basis/stack-checker/errors/prettyprint/prettyprint.factor @@ -4,10 +4,11 @@ USING: accessors kernel prettyprint io debugger sequences assocs stack-checker.errors summary effects ; IN: stack-checker.errors.prettyprint -M: literal-expected summary - what>> "Got a computed value where a " " was expected" surround ; +M: unknown-macro-input summary + macro>> name>> "Cannot apply “" "” to an input parameter of a non-inline word" surround ; -M: literal-expected error. summary print ; +M: bad-macro-input summary + macro>> name>> "Cannot apply “" "” to a run-time computed value" surround ; M: unbalanced-branches-error summary drop "Unbalanced branches" ; @@ -56,7 +57,10 @@ M: transform-expansion-error summary word>> name>> "Macro expansion of " " threw an error" surround ; M: transform-expansion-error error. - [ summary print ] [ error>> error. ] bi ; + [ summary print ] + [ nl "The error was:" print error>> error. nl ] + [ continuation>> traceback-link. ] + tri ; M: do-not-compile summary word>> name>> "Cannot compile call to " prepend ; \ No newline at end of file diff --git a/basis/stack-checker/inlining/inlining.factor b/basis/stack-checker/inlining/inlining.factor index d94868688c..2a2f86df3d 100644 --- a/basis/stack-checker/inlining/inlining.factor +++ b/basis/stack-checker/inlining/inlining.factor @@ -82,7 +82,7 @@ SYMBOL: enter-out bi ; : recursive-word-inputs ( label -- n ) - entry-stack-height d-in get + ; + entry-stack-height input-count get + ; : (inline-recursive-word) ( word -- label in out visitor terminated? ) dup prepare-stack diff --git a/basis/stack-checker/known-words/known-words.factor b/basis/stack-checker/known-words/known-words.factor index 9095eaca8a..1a9eb4afa4 100644 --- a/basis/stack-checker/known-words/known-words.factor +++ b/basis/stack-checker/known-words/known-words.factor @@ -98,8 +98,8 @@ M: composed infer-call* 1 infer->r infer-call terminated? get [ 1 infer-r> infer-call ] unless ; -M: object infer-call* - "literal quotation" literal-expected ; +M: input-parameter infer-call* \ call unknown-macro-input ; +M: object infer-call* \ call bad-macro-input ; : infer-ndip ( word n -- ) [ literals get ] 2dip @@ -231,7 +231,7 @@ M: bad-executable summary \ alien-callback [ infer-alien-callback ] "special" set-word-prop : infer-special ( word -- ) - "special" word-prop call( -- ) ; + [ current-word set ] [ "special" word-prop call( -- ) ] bi ; : infer-local-reader ( word -- ) (( -- value )) apply-word/effect ; diff --git a/basis/stack-checker/stack-checker-docs.factor b/basis/stack-checker/stack-checker-docs.factor index c806f98e2e..9ade6f2537 100644 --- a/basis/stack-checker/stack-checker-docs.factor +++ b/basis/stack-checker/stack-checker-docs.factor @@ -26,7 +26,7 @@ ARTICLE: "inference-combinators" "Combinator stack effects" { "The combinator must be called with a quotation that is either literal or built from literal quotations, " { $link curry } ", and " { $link compose } ". (Note that quotations that use " { $vocab-link "fry" } " or " { $vocab-link "locals" } " use " { $link curry } " and " { $link compose } " from the perspective of the stack checker.)" } { "If the word is declared " { $link POSTPONE: inline } ", the combinator may additionally be called on one of the word's input parameters or with quotations built from the word's input parameters, literal quotations, " { $link curry } ", and " { $link compose } ". When inline, a word is itself considered to be a combinator, and its callers must in turn satisfy these conditions." } } -"If neither condition holds, the stack checker throws a " { $link literal-expected } " error. To make the code compile, a runtime checking combinator such as " { $link POSTPONE: call( } " must be used instead. See " { $link "inference-escape" } " for details. An inline combinator can be called with an unknown quotation by " { $link curry } "ing the quotation onto a literal quotation that uses " { $link POSTPONE: call( } "." +"If neither condition holds, the stack checker throws a " { $link unknown-macro-input } " or " { $link bad-macro-input } " error. To make the code compile, a runtime checking combinator such as " { $link POSTPONE: call( } " must be used instead. See " { $link "inference-escape" } " for details. An inline combinator can be called with an unknown quotation by " { $link curry } "ing the quotation onto a literal quotation that uses " { $link POSTPONE: call( } "." { $heading "Examples" } { $subheading "Calling a combinator" } "The following usage of " { $link map } " passes the stack checker, because the quotation is the result of " { $link curry } ":" @@ -51,7 +51,7 @@ ARTICLE: "inference-combinators" "Combinator stack effects" "However this fails to pass the stack checker since there is no guarantee the quotation has the right stack effect for " { $link map } ". It can be wrapped in a new quotation with a declaration:" { $code ": perform ( values action -- results )" " quot>> [ call( value -- result ) ] curry map ;" } { $heading "Explanation" } -"This restriction exists because without further information, one cannot say what the stack effect of " { $link call } " is; it depends on the given quotation. If the stack checker encounters a " { $link call } " without further information, a " { $link literal-expected } " error is raised." +"This restriction exists because without further information, one cannot say what the stack effect of " { $link call } " is; it depends on the given quotation. If the stack checker encounters a " { $link call } " without further information, a " { $link unknown-macro-input } " or " { $link bad-macro-input } " error is raised." $nl "On the other hand, the stack effect of applying " { $link call } " to a literal quotation or a " { $link curry } " of a literal quotation is easy to compute; it behaves as if the quotation was substituted at that point." { $heading "Limitations" } diff --git a/basis/stack-checker/stack-checker-tests.factor b/basis/stack-checker/stack-checker-tests.factor index 274566c868..7ee7b8e0dd 100644 --- a/basis/stack-checker/stack-checker-tests.factor +++ b/basis/stack-checker/stack-checker-tests.factor @@ -16,14 +16,18 @@ IN: stack-checker.tests { 1 2 } [ dup ] must-infer-as { 1 2 } [ [ dup ] call ] must-infer-as -[ [ call ] infer ] must-fail +[ [ call ] infer ] [ T{ unknown-macro-input f call } = ] must-fail-with +[ [ curry call ] infer ] [ T{ unknown-macro-input f call } = ] must-fail-with +[ [ { } >quotation call ] infer ] [ T{ bad-macro-input f call } = ] must-fail-with +[ [ append curry call ] infer ] [ T{ bad-macro-input f call } = ] must-fail-with { 2 4 } [ 2dup ] must-infer-as { 1 0 } [ [ ] [ ] if ] must-infer-as -[ [ if ] infer ] must-fail -[ [ [ ] if ] infer ] must-fail -[ [ [ 2 ] [ ] if ] infer ] must-fail +[ [ if ] infer ] [ T{ unknown-macro-input f if } = ] must-fail-with +[ [ { } >quotation { } >quotation if ] infer ] [ T{ bad-macro-input f if } = ] must-fail-with +[ [ [ ] if ] infer ] [ T{ unknown-macro-input f if } = ] must-fail-with +[ [ [ 2 ] [ ] if ] infer ] [ unbalanced-branches-error? ] must-fail-with { 4 3 } [ [ rot ] [ -rot ] if ] must-infer-as { 4 3 } [ @@ -46,7 +50,7 @@ IN: stack-checker.tests [ [ [ [ 2 2 fixnum+ ] ] [ [ 2 2 fixnum* ] ] if call ] infer -] must-fail +] [ T{ bad-macro-input f call } = ] must-fail-with ! Test inference of termination of control flow : termination-test-1 ( -- * ) "foo" throw ; @@ -198,42 +202,42 @@ DEFER: blah4 ! This used to hang [ [ [ dup call ] dup call ] infer ] -[ inference-error? ] must-fail-with +[ recursive-quotation-error? ] must-fail-with : m ( q -- ) dup call ; inline -[ [ [ m ] m ] infer ] [ inference-error? ] must-fail-with +[ [ [ m ] m ] infer ] [ recursive-quotation-error? ] must-fail-with : m' ( quot -- ) dup curry call ; inline -[ [ [ m' ] m' ] infer ] [ inference-error? ] must-fail-with +[ [ [ m' ] m' ] infer ] [ recursive-quotation-error? ] must-fail-with : m'' ( -- q ) [ dup curry ] ; inline : m''' ( -- ) m'' call call ; inline -[ [ [ m''' ] m''' ] infer ] [ inference-error? ] must-fail-with +[ [ [ m''' ] m''' ] infer ] [ recursive-quotation-error? ] must-fail-with -: m-if ( a b c -- ) t over if ; inline +: m-if ( a b c -- ) t over when ; inline -[ [ [ m-if ] m-if ] infer ] [ inference-error? ] must-fail-with +[ [ [ m-if ] m-if ] infer ] [ recursive-quotation-error? ] must-fail-with ! This doesn't hang but it's also an example of the ! undedicable case [ [ [ [ drop 3 ] swap call ] dup call ] infer ] -[ inference-error? ] must-fail-with +[ recursive-quotation-error? ] must-fail-with -[ [ 1 drop-locals ] infer ] [ inference-error? ] must-fail-with +[ [ 1 drop-locals ] infer ] [ too-many-r>? ] must-fail-with ! Regression -[ [ cleave ] infer ] [ inference-error? ] must-fail-with +[ [ cleave ] infer ] [ T{ unknown-macro-input f cleave } = ] must-fail-with ! Test some curry stuff { 1 1 } [ 3 [ ] curry 4 [ ] curry if ] must-infer-as { 2 1 } [ [ ] curry 4 [ ] curry if ] must-infer-as -[ [ 3 [ ] curry 1 2 [ ] 2curry if ] infer ] must-fail +[ [ 3 [ ] curry 1 2 [ ] 2curry if ] infer ] [ unbalanced-branches-error? ] must-fail-with { 1 3 } [ [ 2drop f ] assoc-find ] must-infer-as @@ -304,7 +308,7 @@ ERROR: custom-error ; ] unit-test ! Regression -[ [ 1 load-locals ] infer ] must-fail +[ [ 1 load-locals ] infer ] [ too-many->r? ] must-fail-with ! Corner case [ [ [ f dup ] [ dup ] produce ] infer ] must-fail @@ -329,6 +333,8 @@ FORGET: bad-recursion-3 dup bad-recursion-6 call ; inline recursive [ [ [ drop f ] bad-recursion-6 ] infer ] must-fail +[ ] [ [ \ bad-recursion-6 forget ] with-compilation-unit ] unit-test + { 3 0 } [ [ 2drop "A" throw ] [ ] if 2drop ] must-infer-as { 2 0 } [ drop f f [ 2drop "A" throw ] [ ] if 2drop ] must-infer-as @@ -346,6 +352,9 @@ DEFER: eee' [ [ eee' ] infer ] [ inference-error? ] must-fail-with +[ ] [ [ \ ddd' forget ] with-compilation-unit ] unit-test +[ ] [ [ \ eee' forget ] with-compilation-unit ] unit-test + : bogus-error ( x -- ) dup "A" throw [ bogus-error ] [ drop ] if ; inline recursive @@ -367,9 +376,9 @@ DEFER: eee' [ ] [ [ \ forget-test forget ] with-compilation-unit ] unit-test [ forget-test ] must-infer -[ [ cond ] infer ] must-fail -[ [ bi ] infer ] must-fail -[ at ] must-infer +[ [ cond ] infer ] [ T{ unknown-macro-input f cond } = ] must-fail-with +[ [ bi ] infer ] [ T{ unknown-macro-input f call } = ] must-fail-with +[ [ each ] infer ] [ T{ unknown-macro-input f call } = ] must-fail-with [ [ [ "OOPS" throw ] dip ] [ drop ] if ] must-infer @@ -380,5 +389,5 @@ DEFER: eee' { 3 1 } [ call( a b -- c ) ] must-infer-as { 3 1 } [ execute( a b -- c ) ] must-infer-as -[ [ call-effect ] infer ] must-fail -[ [ execute-effect ] infer ] must-fail +[ [ call-effect ] infer ] [ T{ unknown-macro-input f call-effect } = ] must-fail-with +[ [ execute-effect ] infer ] [ T{ unknown-macro-input f execute-effect } = ] must-fail-with diff --git a/basis/stack-checker/state/state.factor b/basis/stack-checker/state/state.factor index c0d3d05409..1c527abfe4 100644 --- a/basis/stack-checker/state/state.factor +++ b/basis/stack-checker/state/state.factor @@ -2,14 +2,15 @@ ! See http://factorcode.org/license.txt for BSD license. USING: assocs arrays namespaces sequences kernel definitions math effects accessors words fry classes.algebra -compiler.units stack-checker.values stack-checker.visitor ; +compiler.units stack-checker.values stack-checker.visitor +stack-checker.errors ; IN: stack-checker.state ! Did the current control-flow path throw an error? SYMBOL: terminated? ! Number of inputs current word expects from the stack -SYMBOL: d-in +SYMBOL: input-count DEFER: commit-literals @@ -34,13 +35,13 @@ SYMBOL: literals [ [ (push-literal) ] each ] [ delete-all ] bi ] unless-empty ; -: current-stack-height ( -- n ) meta-d length d-in get - ; +: current-stack-height ( -- n ) meta-d length input-count get - ; : current-effect ( -- effect ) - d-in get meta-d length terminated? get effect boa ; + input-count get meta-d length terminated? get effect boa ; : init-inference ( -- ) terminated? off V{ } clone \ meta-d set V{ } clone literals set - 0 d-in set ; + 0 input-count set ; diff --git a/basis/stack-checker/transforms/transforms-tests.factor b/basis/stack-checker/transforms/transforms-tests.factor index 843083bd52..bbe3cb2ed9 100644 --- a/basis/stack-checker/transforms/transforms-tests.factor +++ b/basis/stack-checker/transforms/transforms-tests.factor @@ -1,15 +1,9 @@ IN: stack-checker.transforms.tests USING: sequences stack-checker.transforms tools.test math kernel -quotations stack-checker stack-checker.errors accessors combinators words arrays -classes classes.tuple ; +quotations stack-checker stack-checker.errors accessors +combinators words arrays classes classes.tuple macros ; -: compose-n ( quot n -- ) "OOPS" throw ; - -<< -: compose-n-quot ( n word -- quot' ) >quotation ; -\ compose-n [ compose-n-quot ] 2 define-transform -\ compose-n t "no-compile" set-word-prop ->> +MACRO: compose-n ( n word -- quot' ) >quotation ; : compose-n-test ( a b c -- x ) 2 \ + compose-n ; @@ -64,14 +58,16 @@ DEFER: smart-combo ( quot -- ) [ [ [ "a" "b" ] very-smart-combo "c" ] very-smart-combo ] must-infer ! Caveat found by Doug -DEFER: curry-folding-test ( quot -- ) - -\ curry-folding-test [ length \ drop >quotation ] 1 define-transform +MACRO: curry-folding-test ( quot -- ) + length \ drop >quotation ; { 3 0 } [ [ 1 2 3 ] curry-folding-test ] must-infer-as { 3 0 } [ 1 [ 2 3 ] curry curry-folding-test ] must-infer-as { 3 0 } [ [ 1 2 ] 3 [ ] curry compose curry-folding-test ] must-infer-as +[ [ curry curry-folding-test ] infer ] +[ T{ unknown-macro-input f curry-folding-test } = ] must-fail-with + : member?-test ( a -- ? ) { 1 2 3 10 7 58 } member? ; [ f ] [ 1.0 member?-test ] unit-test @@ -82,4 +78,8 @@ DEFER: curry-folding-test ( quot -- ) \ bad-macro [ "OOPS" throw ] 0 define-transform -[ [ bad-macro ] infer ] [ inference-error? ] must-fail-with \ No newline at end of file +[ [ bad-macro ] infer ] [ f >>continuation T{ transform-expansion-error f "OOPS" f bad-macro } = ] must-fail-with + +MACRO: two-params ( a b -- c ) + 1quotation ; + +[ [ 3 two-params ] infer ] [ T{ unknown-macro-input f two-params } = ] 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 53f8b77ad8..3fdf29b85e 100755 --- a/basis/stack-checker/transforms/transforms.factor +++ b/basis/stack-checker/transforms/transforms.factor @@ -11,37 +11,45 @@ stack-checker.values stack-checker.recursive-state stack-checker.dependencies ; IN: stack-checker.transforms -: call-transformer ( word stack quot -- newquot ) - '[ _ _ with-datastack [ length 1 assert= ] [ first ] bi nip ] - [ transform-expansion-error ] +: call-transformer ( stack quot -- newquot ) + '[ _ _ with-datastack [ length 1 assert= ] [ first ] bi ] + [ error-continuation get current-word get transform-expansion-error ] recover ; -:: ((apply-transform)) ( word quot values stack rstate -- ) - rstate recursive-state - [ word stack quot call-transformer ] with-variable - [ - values [ length meta-d shorten-by ] [ #drop, ] bi - rstate infer-quot - ] [ word infer-word ] if* ; +:: ((apply-transform)) ( quot values stack rstate -- ) + rstate recursive-state [ stack quot call-transformer ] with-variable + values [ length meta-d shorten-by ] [ #drop, ] bi + rstate infer-quot ; -: literals? ( values -- ? ) [ literal-value? ] all? ; +: literal-values? ( values -- ? ) [ literal-value? ] all? ; -: (apply-transform) ( word quot n -- ) - ensure-d dup literals? [ - dup empty? [ dup recursive-state get ] [ - [ ] - [ [ literal value>> ] map ] - [ first literal recursion>> ] tri - ] if - ((apply-transform)) - ] [ 2drop infer-word ] if ; +: input-values? ( values -- ? ) + [ { [ literal-value? ] [ input-value? ] } 1|| ] all? ; + +: (apply-transform) ( quot n -- ) + ensure-d { + { [ dup literal-values? ] [ + dup empty? [ dup recursive-state get ] [ + [ ] + [ [ literal value>> ] map ] + [ first literal recursion>> ] tri + ] if + ((apply-transform)) + ] } + { [ dup input-values? ] [ drop current-word get unknown-macro-input ] } + [ drop current-word get bad-macro-input ] + } cond ; : apply-transform ( word -- ) - [ ] [ "transform-quot" word-prop ] [ "transform-n" word-prop ] tri + [ current-word set ] + [ "transform-quot" word-prop ] + [ "transform-n" word-prop ] tri (apply-transform) ; : apply-macro ( word -- ) - [ ] [ "macro" word-prop ] [ "declared-effect" word-prop in>> length ] tri + [ current-word set ] + [ "macro" word-prop ] + [ "declared-effect" word-prop in>> length ] tri (apply-transform) ; : define-transform ( word quot n -- ) diff --git a/basis/stack-checker/values/values.factor b/basis/stack-checker/values/values.factor index 19db441381..97545a872f 100644 --- a/basis/stack-checker/values/values.factor +++ b/basis/stack-checker/values/values.factor @@ -1,7 +1,7 @@ -! Copyright (C) 2008 Slava Pestov. +! Copyright (C) 2008, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: accessors namespaces kernel assocs sequences -stack-checker.recursive-state ; +stack-checker.recursive-state stack-checker.errors ; IN: stack-checker.values ! Values @@ -28,22 +28,26 @@ SYMBOL: known-values GENERIC: (literal-value?) ( value -- ? ) -M: object (literal-value?) drop f ; +: literal-value? ( value -- ? ) known (literal-value?) ; -GENERIC: (literal) ( value -- literal ) +GENERIC: (input-value?) ( value -- ? ) + +: input-value? ( value -- ? ) known (input-value?) ; + +GENERIC: (literal) ( known -- literal ) ! Literal value TUPLE: literal < identity-tuple value recursion hashcode ; : literal ( value -- literal ) known (literal) ; -: literal-value? ( value -- ? ) known (literal-value?) ; - M: literal hashcode* nip hashcode>> ; : ( obj -- value ) recursive-state get over hashcode \ literal boa ; +M: literal (input-value?) drop f ; + M: literal (literal-value?) drop t ; M: literal (literal) ; @@ -61,7 +65,10 @@ C: curried : >curried< ( curried -- obj quot ) [ obj>> ] [ quot>> ] bi ; inline +M: curried (input-value?) >curried< [ input-value? ] either? ; + M: curried (literal-value?) >curried< [ literal-value? ] both? ; + M: curried (literal) >curried< [ curry ] curried/composed-literal ; ! Result of compose @@ -72,5 +79,27 @@ C: composed : >composed< ( composed -- quot1 quot2 ) [ quot1>> ] [ quot2>> ] bi ; inline +M: composed (input-value?) + [ quot1>> input-value? ] [ quot2>> input-value? ] bi or ; + M: composed (literal-value?) >composed< [ literal-value? ] both? ; -M: composed (literal) >composed< [ compose ] curried/composed-literal ; \ No newline at end of file + +M: composed (literal) >composed< [ compose ] curried/composed-literal ; + +! Input parameters +SINGLETON: input-parameter + +SYMBOL: current-word + +M: input-parameter (input-value?) drop t ; + +M: input-parameter (literal-value?) drop f ; + +M: input-parameter (literal) current-word get unknown-macro-input ; + +! Computed values +M: f (input-value?) drop f ; + +M: f (literal-value?) drop f ; + +M: f (literal) current-word get bad-macro-input ; \ No newline at end of file diff --git a/basis/tools/test/test.factor b/basis/tools/test/test.factor index 009789a739..559b1357c8 100644 --- a/basis/tools/test/test.factor +++ b/basis/tools/test/test.factor @@ -121,9 +121,6 @@ SYNTAX: TEST: vocab-tests [ run-test-file ] each ] [ drop ] if ; -: traceback-button. ( failure -- ) - "[" write [ "Traceback" ] dip continuation>> write-object "]" print ; - PRIVATE> TEST: unit-test @@ -137,7 +134,7 @@ M: test-failure error. ( error -- ) [ error-location print nl ] [ asset>> [ experiment. nl ] when* ] [ error>> error. ] - [ traceback-button. ] + [ continuation>> traceback-link. ] } cleave ; : :test-failures ( -- ) test-failures get errors. ;