Merge branch 'master' of git://factorcode.org/git/factor
commit
ab3107d690
|
@ -15,5 +15,3 @@ tools.test threads concurrency.count-downs ;
|
||||||
[ resume ] curry instant later drop
|
[ resume ] curry instant later drop
|
||||||
] "test" suspend drop
|
] "test" suspend drop
|
||||||
] unit-test
|
] unit-test
|
||||||
|
|
||||||
\ alarm-thread-loop must-infer
|
|
||||||
|
|
|
@ -2,8 +2,6 @@ IN: alien.c-types.tests
|
||||||
USING: alien alien.syntax alien.c-types kernel tools.test
|
USING: alien alien.syntax alien.c-types kernel tools.test
|
||||||
sequences system libc alien.strings io.encodings.utf8 ;
|
sequences system libc alien.strings io.encodings.utf8 ;
|
||||||
|
|
||||||
\ expand-constants must-infer
|
|
||||||
|
|
||||||
CONSTANT: xyz 123
|
CONSTANT: xyz 123
|
||||||
|
|
||||||
[ { "blah" 123 } ] [ { "blah" xyz } expand-constants ] unit-test
|
[ { "blah" 123 } ] [ { "blah" xyz } expand-constants ] unit-test
|
||||||
|
|
|
@ -25,6 +25,3 @@ IN: base64.tests
|
||||||
|
|
||||||
[ { 33 52 17 40 12 51 33 43 18 33 23 } base64> ]
|
[ { 33 52 17 40 12 51 33 43 18 33 23 } base64> ]
|
||||||
[ malformed-base64? ] must-fail-with
|
[ malformed-base64? ] must-fail-with
|
||||||
|
|
||||||
\ >base64 must-infer
|
|
||||||
\ base64> must-infer
|
|
||||||
|
|
|
@ -1,8 +1,6 @@
|
||||||
IN: binary-search.tests
|
IN: binary-search.tests
|
||||||
USING: binary-search math.order vectors kernel tools.test ;
|
USING: binary-search math.order vectors kernel tools.test ;
|
||||||
|
|
||||||
\ sorted-member? must-infer
|
|
||||||
|
|
||||||
[ f ] [ 3 { } [ <=> ] with search drop ] unit-test
|
[ f ] [ 3 { } [ <=> ] with search drop ] unit-test
|
||||||
[ 0 ] [ 3 { 3 } [ <=> ] with search drop ] unit-test
|
[ 0 ] [ 3 { 3 } [ <=> ] with search drop ] unit-test
|
||||||
[ 1 ] [ 2 { 1 2 3 } [ <=> ] with search drop ] unit-test
|
[ 1 ] [ 2 { 1 2 3 } [ <=> ] with search drop ] unit-test
|
||||||
|
|
|
@ -108,7 +108,7 @@ nl
|
||||||
|
|
||||||
"." write flush
|
"." write flush
|
||||||
|
|
||||||
{ (compile) } compile-unoptimized
|
{ compile-word } compile-unoptimized
|
||||||
|
|
||||||
"." write flush
|
"." write flush
|
||||||
|
|
||||||
|
|
|
@ -2,9 +2,6 @@ IN: bootstrap.image.tests
|
||||||
USING: bootstrap.image bootstrap.image.private tools.test
|
USING: bootstrap.image bootstrap.image.private tools.test
|
||||||
kernel math ;
|
kernel math ;
|
||||||
|
|
||||||
\ ' must-infer
|
|
||||||
\ write-image must-infer
|
|
||||||
|
|
||||||
[ f ] [ { 1 2 3 } [ 1 2 3 ] eql? ] unit-test
|
[ f ] [ { 1 2 3 } [ 1 2 3 ] eql? ] unit-test
|
||||||
|
|
||||||
[ t ] [ [ 1 2 3 ] [ 1 2 3 ] eql? ] unit-test
|
[ t ] [ [ 1 2 3 ] [ 1 2 3 ] eql? ] unit-test
|
||||||
|
|
|
@ -16,13 +16,6 @@ SYMBOL: bootstrap-time
|
||||||
vm file-name os windows? [ "." split1-last drop ] when
|
vm file-name os windows? [ "." split1-last drop ] when
|
||||||
".image" append resource-path ;
|
".image" append resource-path ;
|
||||||
|
|
||||||
: do-crossref ( -- )
|
|
||||||
"Cross-referencing..." print flush
|
|
||||||
H{ } clone crossref set-global
|
|
||||||
xref-words
|
|
||||||
xref-generics
|
|
||||||
xref-sources ;
|
|
||||||
|
|
||||||
: load-components ( -- )
|
: load-components ( -- )
|
||||||
"include" "exclude"
|
"include" "exclude"
|
||||||
[ get-global " " split harvest ] bi@
|
[ get-global " " split harvest ] bi@
|
||||||
|
@ -68,8 +61,6 @@ SYMBOL: bootstrap-time
|
||||||
|
|
||||||
(command-line) parse-command-line
|
(command-line) parse-command-line
|
||||||
|
|
||||||
do-crossref
|
|
||||||
|
|
||||||
! Set dll paths
|
! Set dll paths
|
||||||
os wince? [ "windows.ce" require ] when
|
os wince? [ "windows.ce" require ] when
|
||||||
os winnt? [ "windows.nt" require ] when
|
os winnt? [ "windows.nt" require ] when
|
||||||
|
@ -78,6 +69,8 @@ SYMBOL: bootstrap-time
|
||||||
"stage2: deployment mode" print
|
"stage2: deployment mode" print
|
||||||
] [
|
] [
|
||||||
"listener" require
|
"listener" require
|
||||||
|
"debugger" require
|
||||||
|
"tools.errors" require
|
||||||
"none" require
|
"none" require
|
||||||
] if
|
] if
|
||||||
|
|
||||||
|
|
|
@ -2,10 +2,6 @@ USING: arrays calendar kernel math sequences tools.test
|
||||||
continuations system math.order threads ;
|
continuations system math.order threads ;
|
||||||
IN: calendar.tests
|
IN: calendar.tests
|
||||||
|
|
||||||
\ time+ must-infer
|
|
||||||
\ time* must-infer
|
|
||||||
\ time- must-infer
|
|
||||||
|
|
||||||
[ f ] [ 2004 12 32 0 0 0 instant <timestamp> valid-timestamp? ] unit-test
|
[ f ] [ 2004 12 32 0 0 0 instant <timestamp> valid-timestamp? ] unit-test
|
||||||
[ f ] [ 2004 2 30 0 0 0 instant <timestamp> valid-timestamp? ] unit-test
|
[ f ] [ 2004 2 30 0 0 0 instant <timestamp> valid-timestamp? ] unit-test
|
||||||
[ f ] [ 2003 2 29 0 0 0 instant <timestamp> valid-timestamp? ] unit-test
|
[ f ] [ 2003 2 29 0 0 0 instant <timestamp> valid-timestamp? ] unit-test
|
||||||
|
|
|
@ -10,6 +10,6 @@ IN: calendar.format.macros
|
||||||
: compiled-test-1 ( -- n )
|
: compiled-test-1 ( -- n )
|
||||||
{ [ 1 throw ] [ 2 ] } attempt-all-quots ;
|
{ [ 1 throw ] [ 2 ] } attempt-all-quots ;
|
||||||
|
|
||||||
\ compiled-test-1 must-infer
|
\ compiled-test-1 def>> must-infer
|
||||||
|
|
||||||
[ 2 ] [ compiled-test-1 ] unit-test
|
[ 2 ] [ compiled-test-1 ] unit-test
|
||||||
|
|
|
@ -42,7 +42,7 @@ IN: combinators.smart.tests
|
||||||
: nested-smart-combo-test ( -- array )
|
: nested-smart-combo-test ( -- array )
|
||||||
[ [ 1 2 ] output>array [ 3 4 ] output>array ] output>array ;
|
[ [ 1 2 ] output>array [ 3 4 ] output>array ] output>array ;
|
||||||
|
|
||||||
\ nested-smart-combo-test must-infer
|
\ nested-smart-combo-test def>> must-infer
|
||||||
|
|
||||||
[ { { 1 2 } { 3 4 } } ] [ nested-smart-combo-test ] unit-test
|
[ { { 1 2 } { 3 4 } } ] [ nested-smart-combo-test ] unit-test
|
||||||
|
|
||||||
|
|
|
@ -5,8 +5,6 @@ math.private compiler.tree.builder compiler.tree.optimizer
|
||||||
compiler.cfg.builder compiler.cfg.debugger arrays locals byte-arrays
|
compiler.cfg.builder compiler.cfg.debugger arrays locals byte-arrays
|
||||||
kernel.private math ;
|
kernel.private math ;
|
||||||
|
|
||||||
\ build-cfg must-infer
|
|
||||||
|
|
||||||
! Just ensure that various CFGs build correctly.
|
! Just ensure that various CFGs build correctly.
|
||||||
: unit-test-cfg ( quot -- ) '[ _ test-cfg drop ] [ ] swap unit-test ;
|
: unit-test-cfg ( quot -- ) '[ _ test-cfg drop ] [ ] swap unit-test ;
|
||||||
|
|
||||||
|
|
|
@ -16,7 +16,7 @@ M: callable test-cfg
|
||||||
build-tree optimize-tree gensym build-cfg ;
|
build-tree optimize-tree gensym build-cfg ;
|
||||||
|
|
||||||
M: word test-cfg
|
M: word test-cfg
|
||||||
[ build-tree-from-word optimize-tree ] keep build-cfg ;
|
[ build-tree optimize-tree ] keep build-cfg ;
|
||||||
|
|
||||||
SYMBOL: allocate-registers?
|
SYMBOL: allocate-registers?
|
||||||
|
|
||||||
|
|
|
@ -1,4 +1,4 @@
|
||||||
USING: compiler.cfg.linear-scan.assignment tools.test ;
|
USING: compiler.cfg.linear-scan.assignment tools.test ;
|
||||||
IN: compiler.cfg.linear-scan.assignment.tests
|
IN: compiler.cfg.linear-scan.assignment.tests
|
||||||
|
|
||||||
\ assign-registers must-infer
|
|
||||||
|
|
|
@ -1,4 +1,4 @@
|
||||||
IN: compiler.cfg.linearization.tests
|
IN: compiler.cfg.linearization.tests
|
||||||
USING: compiler.cfg.linearization tools.test ;
|
USING: compiler.cfg.linearization tools.test ;
|
||||||
|
|
||||||
\ build-mr must-infer
|
|
||||||
|
|
|
@ -27,12 +27,12 @@ $nl
|
||||||
{ $subsection compile-queue }
|
{ $subsection compile-queue }
|
||||||
"Once compiled, a word is added to the assoc stored in the " { $link compiled } " variable. When compilation is complete, this assoc is passed to " { $link modify-code-heap } "."
|
"Once compiled, a word is added to the assoc stored in the " { $link compiled } " variable. When compilation is complete, this assoc is passed to " { $link modify-code-heap } "."
|
||||||
$nl
|
$nl
|
||||||
"The " { $link (compile) } " word performs the actual task of compiling an individual word. The process proceeds as follows:"
|
"The " { $link compile-word } " word performs the actual task of compiling an individual word. The process proceeds as follows:"
|
||||||
{ $list
|
{ $list
|
||||||
{ "The " { $link frontend } " word calls " { $link build-tree-from-word } ". If this fails, the error is passed to " { $link fail } ". The logic for ignoring compile warnings generated for inline words and macros is located here. If the error is not ignorable, it is added to the global " { $link compiler-errors } " assoc (see " { $link "compiler-errors" } ")." }
|
{ "The " { $link frontend } " word calls " { $link build-tree } ". If this fails, the error is passed to " { $link deoptimize } ". The logic for ignoring compile warnings generated for inline words and macros is located here. If the error is not ignorable, it is added to the global " { $link compiler-errors } " assoc (see " { $link "compiler-errors" } ")." }
|
||||||
{ "If the word contains a breakpoint, compilation ends here. Otherwise, all remaining steps execute until machine code is generated. Any further errors thrown by the compiler are not reported as compile errors, but instead are ordinary exceptions. This is because they indicate bugs in the compiler, not errors in user code." }
|
{ "If the word contains a breakpoint, compilation ends here. Otherwise, all remaining steps execute until machine code is generated. Any further errors thrown by the compiler are not reported as compile errors, but instead are ordinary exceptions. This is because they indicate bugs in the compiler, not errors in user code." }
|
||||||
{ "The " { $link frontend } " word then calls " { $link optimize-tree } ". This produces the final optimized tree IR, and this stage of the compiler is complete." }
|
{ "The " { $link frontend } " word then calls " { $link optimize-tree } ". This produces the final optimized tree IR, and this stage of the compiler is complete." }
|
||||||
{ "The " { $link backend } " word calls " { $link build-cfg } " followed by " { $link optimize-cfg } " and a few other stages. Finally, it calls " { $link save-asm } ", and adds any uncompiled words called by this word to the compilation queue with " { $link maybe-compile } "." }
|
{ "The " { $link backend } " word calls " { $link build-cfg } " followed by " { $link optimize-cfg } " and a few other stages. Finally, it calls " { $link save-asm } ", and adds any uncompiled words called by this word to the compilation queue with " { $link compile-dependency } "." }
|
||||||
}
|
}
|
||||||
"If compilation fails, the word is stored in the " { $link compiled } " assoc with a value of " { $link f } ". This causes the VM to compile the word with the non-optimizing compiler."
|
"If compilation fails, the word is stored in the " { $link compiled } " assoc with a value of " { $link f } ". This causes the VM to compile the word with the non-optimizing compiler."
|
||||||
$nl
|
$nl
|
||||||
|
@ -60,7 +60,7 @@ HELP: decompile
|
||||||
{ $values { "word" word } }
|
{ $values { "word" word } }
|
||||||
{ $description "Removes a word's optimized definition. The word will be compiled with the non-optimizing compiler until recompiled with the optimizing compiler again." } ;
|
{ $description "Removes a word's optimized definition. The word will be compiled with the non-optimizing compiler until recompiled with the optimizing compiler again." } ;
|
||||||
|
|
||||||
HELP: (compile)
|
HELP: compile-word
|
||||||
{ $values { "word" word } }
|
{ $values { "word" word } }
|
||||||
{ $description "Compile a single word." }
|
{ $description "Compile a single word." }
|
||||||
{ $notes "This is an internal word, and user code should call " { $link compile } " instead." } ;
|
{ $notes "This is an internal word, and user code should call " { $link compile } " instead." } ;
|
||||||
|
|
|
@ -15,6 +15,7 @@ SYMBOL: compile-queue
|
||||||
SYMBOL: compiled
|
SYMBOL: compiled
|
||||||
|
|
||||||
: queue-compile? ( word -- ? )
|
: queue-compile? ( word -- ? )
|
||||||
|
#! Don't attempt to compile certain words.
|
||||||
{
|
{
|
||||||
[ "forgotten" word-prop ]
|
[ "forgotten" word-prop ]
|
||||||
[ compiled get key? ]
|
[ compiled get key? ]
|
||||||
|
@ -25,26 +26,14 @@ SYMBOL: compiled
|
||||||
: queue-compile ( word -- )
|
: queue-compile ( word -- )
|
||||||
dup queue-compile? [ compile-queue get push-front ] [ drop ] if ;
|
dup queue-compile? [ compile-queue get push-front ] [ drop ] if ;
|
||||||
|
|
||||||
: maybe-compile ( word -- )
|
: recompile-callers? ( word -- ? )
|
||||||
dup optimized>> [ drop ] [ queue-compile ] if ;
|
changed-effects get key? ;
|
||||||
|
|
||||||
SYMBOLS: +optimized+ +unoptimized+ ;
|
: recompile-callers ( words -- )
|
||||||
|
#! If a word's stack effect changed, recompile all words that
|
||||||
: ripple-up ( words -- )
|
#! have compiled calls to it.
|
||||||
dup "compiled-status" word-prop +unoptimized+ eq?
|
dup recompile-callers?
|
||||||
[ usage [ word? ] filter ] [ compiled-usage keys ] if
|
[ compiled-usage keys [ queue-compile ] each ] [ drop ] if ;
|
||||||
[ queue-compile ] each ;
|
|
||||||
|
|
||||||
: ripple-up? ( status word -- ? )
|
|
||||||
[
|
|
||||||
[ nip changed-effects get key? ]
|
|
||||||
[ "compiled-status" word-prop eq? not ] 2bi or
|
|
||||||
] keep "compiled-status" word-prop and ;
|
|
||||||
|
|
||||||
: save-compiled-status ( word status -- )
|
|
||||||
[ over ripple-up? [ ripple-up ] [ drop ] if ]
|
|
||||||
[ "compiled-status" set-word-prop ]
|
|
||||||
2bi ;
|
|
||||||
|
|
||||||
: start ( word -- )
|
: start ( word -- )
|
||||||
"trace-compilation" get [ dup name>> print flush ] when
|
"trace-compilation" get [ dup name>> print flush ] when
|
||||||
|
@ -53,39 +42,72 @@ SYMBOLS: +optimized+ +unoptimized+ ;
|
||||||
f swap compiler-error ;
|
f swap compiler-error ;
|
||||||
|
|
||||||
: ignore-error? ( word error -- ? )
|
: ignore-error? ( word error -- ? )
|
||||||
|
#! Ignore warnings on inline combinators, macros, and special
|
||||||
|
#! words such as 'call'.
|
||||||
[
|
[
|
||||||
{
|
{
|
||||||
[ inline? ]
|
|
||||||
[ macro? ]
|
[ macro? ]
|
||||||
[ "transform-quot" word-prop ]
|
[ inline? ]
|
||||||
[ "no-compile" word-prop ]
|
|
||||||
[ "special" word-prop ]
|
[ "special" word-prop ]
|
||||||
|
[ "no-compile" word-prop ]
|
||||||
} 1||
|
} 1||
|
||||||
] [ error-type +compiler-warning+ eq? ] bi* and ;
|
] [ error-type +compiler-warning+ eq? ] bi* and ;
|
||||||
|
|
||||||
: (fail) ( word -- * )
|
: finish ( word -- )
|
||||||
|
#! Recompile callers if the word's stack effect changed, then
|
||||||
|
#! save the word's dependencies so that if they change, the
|
||||||
|
#! word can get recompiled too.
|
||||||
|
[ recompile-callers ]
|
||||||
[ compiled-unxref ]
|
[ compiled-unxref ]
|
||||||
[ f swap compiled get set-at ]
|
[
|
||||||
[ +unoptimized+ save-compiled-status ]
|
dup crossref? [
|
||||||
tri
|
dependencies get
|
||||||
return ;
|
generic-dependencies get
|
||||||
|
compiled-xref
|
||||||
|
] [ drop ] if
|
||||||
|
] tri ;
|
||||||
|
|
||||||
: fail ( word error -- * )
|
: deoptimize-with ( word def -- * )
|
||||||
[ 2dup ignore-error? [ drop f ] when swap compiler-error ] [ drop (fail) ] 2bi ;
|
#! If the word failed to infer, compile it with the
|
||||||
|
#! non-optimizing compiler.
|
||||||
|
swap [ finish ] [ compiled get set-at ] bi return ;
|
||||||
|
|
||||||
|
: not-compiled-def ( word error -- def )
|
||||||
|
'[ _ _ not-compiled ] [ ] like ;
|
||||||
|
|
||||||
|
: deoptimize ( word error -- * )
|
||||||
|
#! If the error is ignorable, compile the word with the
|
||||||
|
#! non-optimizing compiler, using its definition. Otherwise,
|
||||||
|
#! if the compiler error is not ignorable, use a dummy
|
||||||
|
#! definition from 'not-compiled-def' which throws an error.
|
||||||
|
2dup ignore-error?
|
||||||
|
[ drop f over def>> ]
|
||||||
|
[ 2dup not-compiled-def ] if
|
||||||
|
[ swap compiler-error ] [ deoptimize-with ] bi-curry* bi ;
|
||||||
|
|
||||||
: frontend ( word -- nodes )
|
: frontend ( word -- nodes )
|
||||||
dup contains-breakpoints? [ (fail) ] [
|
#! If the word contains breakpoints, don't optimize it, since
|
||||||
[ build-tree-from-word ] [ fail ] recover optimize-tree
|
#! the walker does not support this.
|
||||||
|
dup contains-breakpoints? [ dup def>> deoptimize-with ] [
|
||||||
|
[ build-tree ] [ deoptimize ] recover optimize-tree
|
||||||
] if ;
|
] if ;
|
||||||
|
|
||||||
|
: compile-dependency ( word -- )
|
||||||
|
#! If a word calls an unoptimized word, try to compile the callee.
|
||||||
|
dup optimized>> [ drop ] [ queue-compile ] if ;
|
||||||
|
|
||||||
! Only switch this off for debugging.
|
! Only switch this off for debugging.
|
||||||
SYMBOL: compile-dependencies?
|
SYMBOL: compile-dependencies?
|
||||||
|
|
||||||
t compile-dependencies? set-global
|
t compile-dependencies? set-global
|
||||||
|
|
||||||
|
: compile-dependencies ( asm -- )
|
||||||
|
compile-dependencies? get
|
||||||
|
[ calls>> [ compile-dependency ] each ] [ drop ] if ;
|
||||||
|
|
||||||
: save-asm ( asm -- )
|
: save-asm ( asm -- )
|
||||||
[ [ code>> ] [ label>> ] bi compiled get set-at ]
|
[ [ code>> ] [ label>> ] bi compiled get set-at ]
|
||||||
[ compile-dependencies? get [ calls>> [ maybe-compile ] each ] [ drop ] if ]
|
[ compile-dependencies ]
|
||||||
bi ;
|
bi ;
|
||||||
|
|
||||||
: backend ( nodes word -- )
|
: backend ( nodes word -- )
|
||||||
|
@ -99,19 +121,9 @@ t compile-dependencies? set-global
|
||||||
save-asm
|
save-asm
|
||||||
] each ;
|
] each ;
|
||||||
|
|
||||||
: finish ( word -- )
|
: compile-word ( word -- )
|
||||||
[ +optimized+ save-compiled-status ]
|
#! We return early if the word has breakpoints or if it
|
||||||
[ compiled-unxref ]
|
#! failed to infer.
|
||||||
[
|
|
||||||
dup crossref?
|
|
||||||
[
|
|
||||||
dependencies get
|
|
||||||
generic-dependencies get
|
|
||||||
compiled-xref
|
|
||||||
] [ drop ] if
|
|
||||||
] tri ;
|
|
||||||
|
|
||||||
: (compile) ( word -- )
|
|
||||||
'[
|
'[
|
||||||
_ {
|
_ {
|
||||||
[ start ]
|
[ start ]
|
||||||
|
@ -122,10 +134,10 @@ t compile-dependencies? set-global
|
||||||
] with-return ;
|
] with-return ;
|
||||||
|
|
||||||
: compile-loop ( deque -- )
|
: compile-loop ( deque -- )
|
||||||
[ (compile) yield-hook get call( -- ) ] slurp-deque ;
|
[ compile-word yield-hook get call( -- ) ] slurp-deque ;
|
||||||
|
|
||||||
: decompile ( word -- )
|
: decompile ( word -- )
|
||||||
f 2array 1array modify-code-heap ;
|
dup def>> 2array 1array modify-code-heap ;
|
||||||
|
|
||||||
: compile-call ( quot -- )
|
: compile-call ( quot -- )
|
||||||
[ dup infer define-temp ] with-compilation-unit execute ;
|
[ dup infer define-temp ] with-compilation-unit execute ;
|
||||||
|
@ -150,4 +162,4 @@ M: optimizing-compiler recompile ( words -- alist )
|
||||||
f compiler-impl set-global ;
|
f compiler-impl set-global ;
|
||||||
|
|
||||||
: recompile-all ( -- )
|
: recompile-all ( -- )
|
||||||
forget-errors all-words compile ;
|
all-words compile ;
|
||||||
|
|
|
@ -52,3 +52,5 @@ T{ error-type
|
||||||
: compiler-error ( error word -- )
|
: compiler-error ( error word -- )
|
||||||
compiler-errors get-global pick
|
compiler-errors get-global pick
|
||||||
[ [ [ <compiler-error> ] keep ] dip set-at ] [ delete-at drop ] if ;
|
[ [ [ <compiler-error> ] keep ] dip set-at ] [ delete-at drop ] if ;
|
||||||
|
|
||||||
|
ERROR: not-compiled word error ;
|
|
@ -1,5 +0,0 @@
|
||||||
IN: compiler.tests
|
|
||||||
USING: words kernel stack-checker alien.strings tools.test
|
|
||||||
compiler.units ;
|
|
||||||
|
|
||||||
[ ] [ [ \ if redefined ] with-compilation-unit [ string>alien ] infer. ] unit-test
|
|
|
@ -261,7 +261,7 @@ USE: binary-search.private
|
||||||
: lift-loop-tail-test-2 ( -- a b c )
|
: lift-loop-tail-test-2 ( -- a b c )
|
||||||
10 [ ] lift-loop-tail-test-1 1 2 3 ;
|
10 [ ] lift-loop-tail-test-1 1 2 3 ;
|
||||||
|
|
||||||
\ lift-loop-tail-test-2 must-infer
|
\ lift-loop-tail-test-2 def>> must-infer
|
||||||
|
|
||||||
[ 1 2 3 ] [ lift-loop-tail-test-2 ] unit-test
|
[ 1 2 3 ] [ lift-loop-tail-test-2 ] unit-test
|
||||||
|
|
||||||
|
@ -302,8 +302,8 @@ HINTS: recursive-inline-hang-3 array ;
|
||||||
|
|
||||||
: member-test ( obj -- ? ) { + - * / /i } member? ;
|
: member-test ( obj -- ? ) { + - * / /i } member? ;
|
||||||
|
|
||||||
\ member-test must-infer
|
\ member-test def>> must-infer
|
||||||
[ ] [ \ member-test build-tree-from-word optimize-tree drop ] unit-test
|
[ ] [ \ member-test build-tree optimize-tree drop ] unit-test
|
||||||
[ t ] [ \ + member-test ] unit-test
|
[ t ] [ \ + member-test ] unit-test
|
||||||
[ f ] [ \ append member-test ] unit-test
|
[ f ] [ \ append member-test ] unit-test
|
||||||
|
|
||||||
|
@ -325,7 +325,7 @@ PREDICATE: list < improper-list
|
||||||
dup "a" get { array-capacity } declare >=
|
dup "a" get { array-capacity } declare >=
|
||||||
[ dup "b" get { array-capacity } declare >= [ 3 ] [ 4 ] if ] [ 5 ] if ;
|
[ dup "b" get { array-capacity } declare >= [ 3 ] [ 4 ] if ] [ 5 ] if ;
|
||||||
|
|
||||||
\ interval-inference-bug must-infer
|
[ t ] [ \ interval-inference-bug optimized>> ] unit-test
|
||||||
|
|
||||||
[ ] [ 1 "a" set 2 "b" set ] unit-test
|
[ ] [ 1 "a" set 2 "b" set ] unit-test
|
||||||
[ 2 3 ] [ 2 interval-inference-bug ] unit-test
|
[ 2 3 ] [ 2 interval-inference-bug ] unit-test
|
||||||
|
|
|
@ -0,0 +1,107 @@
|
||||||
|
IN: compiler.tests.redefine0
|
||||||
|
USING: tools.test eval compiler compiler.errors compiler.units definitions kernel math
|
||||||
|
namespaces macros assocs ;
|
||||||
|
|
||||||
|
! Test ripple-up behavior
|
||||||
|
: test-1 ( -- a ) 3 ;
|
||||||
|
: test-2 ( -- ) test-1 ;
|
||||||
|
|
||||||
|
[ test-2 ] [ not-compiled? ] must-fail-with
|
||||||
|
|
||||||
|
[ ] [ "IN: compiler.tests.redefine0 : test-1 ( -- ) ;" eval( -- ) ] unit-test
|
||||||
|
|
||||||
|
{ 0 0 } [ test-1 ] must-infer-as
|
||||||
|
|
||||||
|
[ ] [ test-2 ] unit-test
|
||||||
|
|
||||||
|
[ ] [
|
||||||
|
[
|
||||||
|
\ test-1 forget
|
||||||
|
\ test-2 forget
|
||||||
|
] with-compilation-unit
|
||||||
|
] unit-test
|
||||||
|
|
||||||
|
: test-3 ( a -- ) drop ;
|
||||||
|
: test-4 ( -- ) [ 1 2 3 ] test-3 ;
|
||||||
|
|
||||||
|
[ ] [ test-4 ] unit-test
|
||||||
|
|
||||||
|
[ ] [ "IN: compiler.tests.redefine0 USE: kernel : test-3 ( a -- ) call ; inline" eval( -- ) ] unit-test
|
||||||
|
|
||||||
|
[ test-4 ] [ not-compiled? ] must-fail-with
|
||||||
|
|
||||||
|
[ ] [
|
||||||
|
[
|
||||||
|
\ test-3 forget
|
||||||
|
\ test-4 forget
|
||||||
|
] with-compilation-unit
|
||||||
|
] unit-test
|
||||||
|
|
||||||
|
: test-5 ( a -- quot ) ;
|
||||||
|
: test-6 ( a -- b ) test-5 ;
|
||||||
|
|
||||||
|
[ 31337 ] [ 31337 test-6 ] unit-test
|
||||||
|
|
||||||
|
[ ] [ "IN: compiler.tests.redefine0 USING: macros kernel ; MACRO: test-5 ( a -- quot ) drop [ ] ;" eval( -- ) ] unit-test
|
||||||
|
|
||||||
|
[ 31337 test-6 ] [ not-compiled? ] must-fail-with
|
||||||
|
|
||||||
|
[ ] [
|
||||||
|
[
|
||||||
|
\ test-5 forget
|
||||||
|
\ test-6 forget
|
||||||
|
] with-compilation-unit
|
||||||
|
] unit-test
|
||||||
|
|
||||||
|
GENERIC: test-7 ( a -- b )
|
||||||
|
|
||||||
|
M: integer test-7 + ;
|
||||||
|
|
||||||
|
: test-8 ( a -- b ) 255 bitand test-7 ;
|
||||||
|
|
||||||
|
[ 1 test-7 ] [ not-compiled? ] must-fail-with
|
||||||
|
[ 1 test-8 ] [ not-compiled? ] must-fail-with
|
||||||
|
|
||||||
|
[ ] [ "IN: compiler.tests.redefine0 USING: macros math kernel ; GENERIC: test-7 ( x y -- z ) : test-8 ( a b -- c ) 255 bitand test-7 ;" eval( -- ) ] unit-test
|
||||||
|
|
||||||
|
[ 4 ] [ 1 3 test-7 ] unit-test
|
||||||
|
[ 4 ] [ 1 259 test-8 ] unit-test
|
||||||
|
|
||||||
|
[ ] [
|
||||||
|
[
|
||||||
|
\ test-7 forget
|
||||||
|
\ test-8 forget
|
||||||
|
] with-compilation-unit
|
||||||
|
] unit-test
|
||||||
|
|
||||||
|
! Indirect dependency on an unoptimized word
|
||||||
|
: test-9 ( -- ) ;
|
||||||
|
<< SYMBOL: quot
|
||||||
|
[ test-9 ] quot set-global >>
|
||||||
|
MACRO: test-10 ( -- quot ) quot get ;
|
||||||
|
: test-11 ( -- ) test-10 ;
|
||||||
|
|
||||||
|
[ ] [ test-11 ] unit-test
|
||||||
|
|
||||||
|
[ ] [ "IN: compiler.tests.redefine0 : test-9 ( -- ) 1 ;" eval( -- ) ] unit-test
|
||||||
|
|
||||||
|
! test-11 should get recompiled now
|
||||||
|
|
||||||
|
[ test-11 ] [ not-compiled? ] must-fail-with
|
||||||
|
|
||||||
|
[ ] [ "IN: compiler.tests.redefine0 : test-9 ( -- a ) 1 ;" eval( -- ) ] unit-test
|
||||||
|
|
||||||
|
[ ] [ "IN: compiler.tests.redefine0 : test-9 ( -- ) ;" eval( -- ) ] unit-test
|
||||||
|
|
||||||
|
[ ] [ test-11 ] unit-test
|
||||||
|
|
||||||
|
quot global delete-at
|
||||||
|
|
||||||
|
[ ] [
|
||||||
|
[
|
||||||
|
\ test-9 forget
|
||||||
|
\ test-10 forget
|
||||||
|
\ test-11 forget
|
||||||
|
\ quot forget
|
||||||
|
] with-compilation-unit
|
||||||
|
] unit-test
|
|
@ -36,41 +36,3 @@ M: integer method-redefine-generic-2 3 + ;
|
||||||
fixnum string [ \ method-redefine-generic-2 method forget ] bi@
|
fixnum string [ \ method-redefine-generic-2 method forget ] bi@
|
||||||
] with-compilation-unit
|
] with-compilation-unit
|
||||||
] unit-test
|
] unit-test
|
||||||
|
|
||||||
! Test ripple-up behavior
|
|
||||||
: hey ( -- ) ;
|
|
||||||
: there ( -- ) hey ;
|
|
||||||
|
|
||||||
[ t ] [ \ hey optimized>> ] unit-test
|
|
||||||
[ t ] [ \ there optimized>> ] unit-test
|
|
||||||
[ ] [ "IN: compiler.tests : hey ( -- ) 3 ;" eval( -- ) ] unit-test
|
|
||||||
[ f ] [ \ hey optimized>> ] unit-test
|
|
||||||
[ f ] [ \ there optimized>> ] unit-test
|
|
||||||
[ ] [ "IN: compiler.tests : hey ( -- ) ;" eval( -- ) ] unit-test
|
|
||||||
[ t ] [ \ there optimized>> ] unit-test
|
|
||||||
|
|
||||||
: good ( -- ) ;
|
|
||||||
: bad ( -- ) good ;
|
|
||||||
: ugly ( -- ) bad ;
|
|
||||||
|
|
||||||
[ t ] [ \ good optimized>> ] unit-test
|
|
||||||
[ t ] [ \ bad optimized>> ] unit-test
|
|
||||||
[ t ] [ \ ugly optimized>> ] unit-test
|
|
||||||
|
|
||||||
[ f ] [ \ good compiled-usage assoc-empty? ] unit-test
|
|
||||||
|
|
||||||
[ ] [ "IN: compiler.tests : good ( -- ) 3 ;" eval( -- ) ] unit-test
|
|
||||||
|
|
||||||
[ f ] [ \ good optimized>> ] unit-test
|
|
||||||
[ f ] [ \ bad optimized>> ] unit-test
|
|
||||||
[ f ] [ \ ugly optimized>> ] unit-test
|
|
||||||
|
|
||||||
[ t ] [ \ good compiled-usage assoc-empty? ] unit-test
|
|
||||||
|
|
||||||
[ ] [ "IN: compiler.tests : good ( -- ) ;" eval( -- ) ] unit-test
|
|
||||||
|
|
||||||
[ t ] [ \ good optimized>> ] unit-test
|
|
||||||
[ t ] [ \ bad optimized>> ] unit-test
|
|
||||||
[ t ] [ \ ugly optimized>> ] unit-test
|
|
||||||
|
|
||||||
[ f ] [ \ good compiled-usage assoc-empty? ] unit-test
|
|
||||||
|
|
|
@ -7,4 +7,5 @@ quotations stack-checker ;
|
||||||
[ ] [ "IN: compiler.tests.redefine16 GENERIC# blah 2 ( foo bar baz -- )" eval( -- ) ] unit-test
|
[ ] [ "IN: compiler.tests.redefine16 GENERIC# blah 2 ( foo bar baz -- )" eval( -- ) ] unit-test
|
||||||
[ ] [ "IN: compiler.tests.redefine16 USING: strings math arrays prettyprint ; M: string blah 1 + 3array . ;" eval( -- ) ] unit-test
|
[ ] [ "IN: compiler.tests.redefine16 USING: strings math arrays prettyprint ; M: string blah 1 + 3array . ;" eval( -- ) ] unit-test
|
||||||
[ ] [ "IN: compiler.tests.redefine16 GENERIC# blah 2 ( foo bar baz -- x )" eval( -- ) ] unit-test
|
[ ] [ "IN: compiler.tests.redefine16 GENERIC# blah 2 ( foo bar baz -- x )" eval( -- ) ] unit-test
|
||||||
[ "blah" "compiler.tests.redefine16" lookup 1quotation infer ] must-fail
|
|
||||||
|
[ ] [ [ "blah" "compiler.tests.redefine16" lookup forget ] with-compilation-unit ] unit-test
|
||||||
|
|
|
@ -3,8 +3,6 @@ sequences.private math.private math combinators strings alien
|
||||||
arrays memory vocabs parser eval ;
|
arrays memory vocabs parser eval ;
|
||||||
IN: compiler.tests
|
IN: compiler.tests
|
||||||
|
|
||||||
\ (compile) must-infer
|
|
||||||
|
|
||||||
! Test empty word
|
! Test empty word
|
||||||
[ ] [ [ ] compile-call ] unit-test
|
[ ] [ [ ] compile-call ] unit-test
|
||||||
|
|
||||||
|
|
|
@ -3,12 +3,11 @@ compiler.tree stack-checker.errors ;
|
||||||
IN: compiler.tree.builder
|
IN: compiler.tree.builder
|
||||||
|
|
||||||
HELP: build-tree
|
HELP: build-tree
|
||||||
{ $values { "quot" quotation } { "nodes" "a sequence of nodes" } }
|
{ $values { "quot/word" { $or quotation word } } { "nodes" "a sequence of nodes" } }
|
||||||
{ $description "Attempts to construct tree SSA IR from a quotation." }
|
{ $description "Attempts to construct tree SSA IR from a quotation." }
|
||||||
{ $notes "This is the first stage of the compiler." }
|
{ $notes "This is the first stage of the compiler." }
|
||||||
{ $errors "Throws an " { $link inference-error } " if stack effect inference fails." } ;
|
{ $errors "Throws an " { $link inference-error } " if stack effect inference fails." } ;
|
||||||
|
|
||||||
HELP: build-tree-with
|
HELP: build-sub-tree
|
||||||
{ $values { "in-stack" "a sequence of values" } { "quot" quotation } { "nodes" "a sequence of nodes" } { "out-stack" "a sequence of values" } }
|
{ $values { "#call" #call } { "quot/word" { $or quotation word } } { "nodes" { $maybe "a sequence of nodes" } } }
|
||||||
{ $description "Attempts to construct tree SSA IR from a quotation, starting with an initial data stack of values, and outputting stack resulting at the end." }
|
{ $description "Attempts to construct tree SSA IR from a quotation, starting with an initial data stack of values from the call site. Outputs " { $link f } " if stack effect inference fails." } ;
|
||||||
{ $errors "Throws an " { $link inference-error } " if stack effect inference fails." } ;
|
|
||||||
|
|
|
@ -1,11 +1,27 @@
|
||||||
IN: compiler.tree.builder.tests
|
IN: compiler.tree.builder.tests
|
||||||
USING: compiler.tree.builder tools.test sequences kernel
|
USING: compiler.tree.builder tools.test sequences kernel
|
||||||
compiler.tree ;
|
compiler.tree stack-checker stack-checker.errors ;
|
||||||
|
|
||||||
\ build-tree must-infer
|
|
||||||
\ build-tree-with must-infer
|
|
||||||
\ build-tree-from-word must-infer
|
|
||||||
|
|
||||||
: inline-recursive ( -- ) inline-recursive ; inline recursive
|
: inline-recursive ( -- ) inline-recursive ; inline recursive
|
||||||
|
|
||||||
[ t ] [ \ inline-recursive build-tree-from-word [ #recursive? ] any? ] unit-test
|
[ t ] [ \ inline-recursive build-tree [ #recursive? ] any? ] unit-test
|
||||||
|
|
||||||
|
: bad-recursion-1 ( a -- b )
|
||||||
|
dup [ drop bad-recursion-1 5 ] [ ] if ;
|
||||||
|
|
||||||
|
[ \ bad-recursion-1 build-tree ] [ inference-error? ] must-fail-with
|
||||||
|
|
||||||
|
FORGET: bad-recursion-1
|
||||||
|
|
||||||
|
: bad-recursion-2 ( obj -- obj )
|
||||||
|
dup [ dup first swap second bad-recursion-2 ] [ ] if ;
|
||||||
|
|
||||||
|
[ \ bad-recursion-2 build-tree ] [ inference-error? ] must-fail-with
|
||||||
|
|
||||||
|
FORGET: bad-recursion-2
|
||||||
|
|
||||||
|
: bad-bin ( a b -- ) 5 [ 5 bad-bin bad-bin 5 ] [ 2drop ] if ;
|
||||||
|
|
||||||
|
[ \ bad-bin build-tree ] [ inference-error? ] must-fail-with
|
||||||
|
|
||||||
|
FORGET: bad-bin
|
||||||
|
|
|
@ -1,7 +1,8 @@
|
||||||
! Copyright (C) 2008 Slava Pestov.
|
! Copyright (C) 2008, 2009 Slava Pestov.
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
USING: fry accessors quotations kernel sequences namespaces
|
USING: fry locals accessors quotations kernel sequences namespaces
|
||||||
assocs words arrays vectors hints combinators compiler.tree
|
assocs words arrays vectors hints combinators continuations
|
||||||
|
effects compiler.tree
|
||||||
stack-checker
|
stack-checker
|
||||||
stack-checker.state
|
stack-checker.state
|
||||||
stack-checker.errors
|
stack-checker.errors
|
||||||
|
@ -10,54 +11,60 @@ stack-checker.backend
|
||||||
stack-checker.recursive-state ;
|
stack-checker.recursive-state ;
|
||||||
IN: compiler.tree.builder
|
IN: compiler.tree.builder
|
||||||
|
|
||||||
: with-tree-builder ( quot -- nodes )
|
<PRIVATE
|
||||||
'[ V{ } clone stack-visitor set @ ]
|
|
||||||
with-infer nip ; inline
|
|
||||||
|
|
||||||
: build-tree ( quot -- nodes )
|
GENERIC: (build-tree) ( quot -- )
|
||||||
#! Not safe to call from inference transforms.
|
|
||||||
[ f initial-recursive-state infer-quot ] with-tree-builder ;
|
|
||||||
|
|
||||||
: build-tree-with ( in-stack quot -- nodes out-stack )
|
M: callable (build-tree) f initial-recursive-state infer-quot ;
|
||||||
#! Not safe to call from inference transforms.
|
|
||||||
[
|
|
||||||
[ >vector \ meta-d set ]
|
|
||||||
[ f initial-recursive-state infer-quot ] bi*
|
|
||||||
] with-tree-builder
|
|
||||||
unclip-last in-d>> ;
|
|
||||||
|
|
||||||
: build-sub-tree ( #call quot -- nodes )
|
|
||||||
[ [ out-d>> ] [ in-d>> ] bi ] dip build-tree-with
|
|
||||||
over ends-with-terminate?
|
|
||||||
[ drop swap [ f swap #push ] map append ]
|
|
||||||
[ rot #copy suffix ]
|
|
||||||
if ;
|
|
||||||
|
|
||||||
: (build-tree-from-word) ( word -- )
|
|
||||||
dup initial-recursive-state recursive-state set
|
|
||||||
dup [ "inline" word-prop ] [ "recursive" word-prop ] bi and
|
|
||||||
[ 1quotation ] [ specialized-def ] if
|
|
||||||
infer-quot-here ;
|
|
||||||
|
|
||||||
: check-cannot-infer ( word -- )
|
|
||||||
dup "cannot-infer" word-prop [ cannot-infer-effect ] [ drop ] if ;
|
|
||||||
|
|
||||||
TUPLE: do-not-compile word ;
|
|
||||||
|
|
||||||
: check-no-compile ( word -- )
|
: check-no-compile ( word -- )
|
||||||
dup "no-compile" word-prop [ do-not-compile inference-warning ] [ drop ] if ;
|
dup "no-compile" word-prop [ do-not-compile ] [ drop ] if ;
|
||||||
|
|
||||||
: build-tree-from-word ( word -- nodes )
|
: check-effect ( word effect -- )
|
||||||
[
|
swap required-stack-effect 2dup effect<=
|
||||||
[
|
[ 2drop ] [ effect-error ] if ;
|
||||||
|
|
||||||
|
: inline-recursive? ( word -- ? )
|
||||||
|
[ "inline" word-prop ] [ "recursive" word-prop ] bi and ;
|
||||||
|
|
||||||
|
: word-body ( word -- quot )
|
||||||
|
dup inline-recursive? [ 1quotation ] [ specialized-def ] if ;
|
||||||
|
|
||||||
|
M: word (build-tree)
|
||||||
{
|
{
|
||||||
[ check-cannot-infer ]
|
[ initial-recursive-state recursive-state set ]
|
||||||
[ check-no-compile ]
|
[ check-no-compile ]
|
||||||
[ (build-tree-from-word) ]
|
[ word-body infer-quot-here ]
|
||||||
[ finish-word ]
|
[ current-effect check-effect ]
|
||||||
} cleave
|
} cleave ;
|
||||||
] maybe-cannot-infer
|
|
||||||
] with-tree-builder ;
|
: build-tree-with ( in-stack word/quot -- nodes )
|
||||||
|
[
|
||||||
|
V{ } clone stack-visitor set
|
||||||
|
[ [ >vector \ meta-d set ] [ length d-in set ] bi ]
|
||||||
|
[ (build-tree) ]
|
||||||
|
bi*
|
||||||
|
] with-infer nip ;
|
||||||
|
|
||||||
|
PRIVATE>
|
||||||
|
|
||||||
|
: build-tree ( word/quot -- nodes )
|
||||||
|
[ f ] dip build-tree-with ;
|
||||||
|
|
||||||
|
:: build-sub-tree ( #call word/quot -- nodes/f )
|
||||||
|
#! We don't want methods on mixins to have a declaration for that mixin.
|
||||||
|
#! This slows down compiler.tree.propagation.inlining since then every
|
||||||
|
#! inlined usage of a method has an inline-dependency on the mixin, and
|
||||||
|
#! not the more specific type at the call site.
|
||||||
|
specialize-method? off
|
||||||
|
[
|
||||||
|
#call in-d>> word/quot build-tree-with unclip-last in-d>> :> in-d
|
||||||
|
{
|
||||||
|
{ [ dup not ] [ ] }
|
||||||
|
{ [ dup ends-with-terminate? ] [ #call out-d>> [ f swap #push ] map append ] }
|
||||||
|
[ in-d #call out-d>> #copy suffix ]
|
||||||
|
} cond
|
||||||
|
] [ dup inference-error? [ drop f ] [ rethrow ] if ] recover ;
|
||||||
|
|
||||||
: contains-breakpoints? ( word -- ? )
|
: contains-breakpoints? ( word -- ? )
|
||||||
def>> [ word? ] filter [ "break?" word-prop ] any? ;
|
def>> [ word? ] filter [ "break?" word-prop ] any? ;
|
||||||
|
|
|
@ -1,4 +1,4 @@
|
||||||
IN: compiler.tree.checker.tests
|
IN: compiler.tree.checker.tests
|
||||||
USING: compiler.tree.checker tools.test ;
|
USING: compiler.tree.checker tools.test ;
|
||||||
|
|
||||||
\ check-nodes must-infer
|
|
||||||
|
|
|
@ -144,13 +144,15 @@ M: #terminate check-stack-flow*
|
||||||
|
|
||||||
SYMBOL: branch-out
|
SYMBOL: branch-out
|
||||||
|
|
||||||
: check-branch ( nodes -- stack )
|
: check-branch ( nodes -- datastack )
|
||||||
[
|
[
|
||||||
datastack [ clone ] change
|
datastack [ clone ] change
|
||||||
V{ } clone retainstack set
|
retainstack [ clone ] change
|
||||||
(check-stack-flow)
|
retainstack get clone [ (check-stack-flow) ] dip
|
||||||
terminated? get [ assert-retainstack-empty ] unless
|
terminated? get [ drop f ] [
|
||||||
terminated? get f datastack get ?
|
retainstack get assert=
|
||||||
|
datastack get
|
||||||
|
] if
|
||||||
] with-scope ;
|
] with-scope ;
|
||||||
|
|
||||||
M: #branch check-stack-flow*
|
M: #branch check-stack-flow*
|
||||||
|
|
|
@ -9,8 +9,6 @@ accessors combinators io prettyprint words sequences.deep
|
||||||
sequences.private arrays classes kernel.private ;
|
sequences.private arrays classes kernel.private ;
|
||||||
IN: compiler.tree.dead-code.tests
|
IN: compiler.tree.dead-code.tests
|
||||||
|
|
||||||
\ remove-dead-code must-infer
|
|
||||||
|
|
||||||
: count-live-values ( quot -- n )
|
: count-live-values ( quot -- n )
|
||||||
build-tree
|
build-tree
|
||||||
analyze-recursive
|
analyze-recursive
|
||||||
|
|
|
@ -1,8 +1,5 @@
|
||||||
IN: compiler.tree.debugger.tests
|
IN: compiler.tree.debugger.tests
|
||||||
USING: compiler.tree.debugger tools.test sorting sequences io math.order ;
|
USING: compiler.tree.debugger tools.test sorting sequences io math.order ;
|
||||||
|
|
||||||
\ optimized. must-infer
|
|
||||||
\ optimizer-report. must-infer
|
|
||||||
|
|
||||||
[ [ <=> ] sort ] optimized.
|
[ [ <=> ] sort ] optimized.
|
||||||
[ <reversed> [ print ] each ] optimizer-report.
|
[ <reversed> [ print ] each ] optimizer-report.
|
|
@ -142,8 +142,7 @@ SYMBOL: node-count
|
||||||
|
|
||||||
: make-report ( word/quot -- assoc )
|
: make-report ( word/quot -- assoc )
|
||||||
[
|
[
|
||||||
dup word? [ build-tree-from-word ] [ build-tree ] if
|
build-tree optimize-tree
|
||||||
optimize-tree
|
|
||||||
|
|
||||||
H{ } clone words-called set
|
H{ } clone words-called set
|
||||||
H{ } clone generics-called set
|
H{ } clone generics-called set
|
||||||
|
|
|
@ -7,8 +7,6 @@ compiler.tree.def-use arrays kernel.private sorting math.order
|
||||||
binary-search compiler.tree.checker ;
|
binary-search compiler.tree.checker ;
|
||||||
IN: compiler.tree.def-use.tests
|
IN: compiler.tree.def-use.tests
|
||||||
|
|
||||||
\ compute-def-use must-infer
|
|
||||||
|
|
||||||
[ t ] [
|
[ t ] [
|
||||||
[ 1 2 3 ] build-tree compute-def-use drop
|
[ 1 2 3 ] build-tree compute-def-use drop
|
||||||
def-use get {
|
def-use get {
|
||||||
|
|
|
@ -11,8 +11,6 @@ compiler.tree.propagation.info stack-checker.errors
|
||||||
compiler.tree.checker
|
compiler.tree.checker
|
||||||
kernel.private ;
|
kernel.private ;
|
||||||
|
|
||||||
\ escape-analysis must-infer
|
|
||||||
|
|
||||||
GENERIC: count-unboxed-allocations* ( m node -- n )
|
GENERIC: count-unboxed-allocations* ( m node -- n )
|
||||||
|
|
||||||
: (count-unboxed-allocations) ( m node -- n )
|
: (count-unboxed-allocations) ( m node -- n )
|
||||||
|
|
|
@ -6,9 +6,6 @@ compiler.tree.normalization.renaming
|
||||||
compiler.tree compiler.tree.checker
|
compiler.tree compiler.tree.checker
|
||||||
sequences accessors tools.test kernel math ;
|
sequences accessors tools.test kernel math ;
|
||||||
|
|
||||||
\ count-introductions must-infer
|
|
||||||
\ normalize must-infer
|
|
||||||
|
|
||||||
[ 3 ] [ [ 3drop 1 2 3 ] build-tree count-introductions ] unit-test
|
[ 3 ] [ [ 3drop 1 2 3 ] build-tree count-introductions ] unit-test
|
||||||
|
|
||||||
[ 4 ] [ [ 3drop 1 2 3 3drop drop ] build-tree count-introductions ] unit-test
|
[ 4 ] [ [ 3drop 1 2 3 3drop drop ] build-tree count-introductions ] unit-test
|
||||||
|
|
|
@ -1,4 +1,4 @@
|
||||||
USING: compiler.tree.optimizer tools.test ;
|
USING: compiler.tree.optimizer tools.test ;
|
||||||
IN: compiler.tree.optimizer.tests
|
IN: compiler.tree.optimizer.tests
|
||||||
|
|
||||||
\ optimize-tree must-infer
|
|
||||||
|
|
|
@ -4,6 +4,7 @@ USING: accessors kernel arrays sequences math math.order
|
||||||
math.partial-dispatch generic generic.standard generic.math
|
math.partial-dispatch generic generic.standard generic.math
|
||||||
classes.algebra classes.union sets quotations assocs combinators
|
classes.algebra classes.union sets quotations assocs combinators
|
||||||
words namespaces continuations classes fry combinators.smart hints
|
words namespaces continuations classes fry combinators.smart hints
|
||||||
|
locals
|
||||||
compiler.tree
|
compiler.tree
|
||||||
compiler.tree.builder
|
compiler.tree.builder
|
||||||
compiler.tree.recursive
|
compiler.tree.recursive
|
||||||
|
@ -27,24 +28,34 @@ SYMBOL: node-count
|
||||||
SYMBOL: inlining-count
|
SYMBOL: inlining-count
|
||||||
|
|
||||||
! Splicing nodes
|
! Splicing nodes
|
||||||
GENERIC: splicing-nodes ( #call word/quot/f -- nodes )
|
: splicing-call ( #call word -- nodes )
|
||||||
|
|
||||||
M: word splicing-nodes
|
|
||||||
[ [ in-d>> ] [ out-d>> ] bi ] dip #call 1array ;
|
[ [ in-d>> ] [ out-d>> ] bi ] dip #call 1array ;
|
||||||
|
|
||||||
M: callable splicing-nodes
|
: splicing-body ( #call quot/word -- nodes/f )
|
||||||
build-sub-tree analyze-recursive normalize ;
|
build-sub-tree dup [ analyze-recursive normalize ] when ;
|
||||||
|
|
||||||
! Dispatch elimination
|
! Dispatch elimination
|
||||||
|
: undo-inlining ( #call -- ? )
|
||||||
|
f >>method f >>body f >>class drop f ;
|
||||||
|
|
||||||
|
: propagate-body ( #call -- ? )
|
||||||
|
body>> (propagate) t ;
|
||||||
|
|
||||||
|
GENERIC: splicing-nodes ( #call word/quot -- nodes/f )
|
||||||
|
|
||||||
|
M: word splicing-nodes splicing-call ;
|
||||||
|
|
||||||
|
M: callable splicing-nodes splicing-body ;
|
||||||
|
|
||||||
: eliminate-dispatch ( #call class/f word/quot/f -- ? )
|
: eliminate-dispatch ( #call class/f word/quot/f -- ? )
|
||||||
dup [
|
dup [
|
||||||
[ >>class ] dip
|
[ >>class ] dip
|
||||||
over method>> over = [ drop ] [
|
over method>> over = [ drop propagate-body ] [
|
||||||
2dup splicing-nodes
|
2dup splicing-nodes dup [
|
||||||
[ >>method ] [ >>body ] bi*
|
[ >>method ] [ >>body ] bi* propagate-body
|
||||||
|
] [ 2drop undo-inlining ] if
|
||||||
] if
|
] if
|
||||||
body>> (propagate) t
|
] [ 2drop undo-inlining ] if ;
|
||||||
] [ 2drop f >>method f >>body f >>class drop f ] if ;
|
|
||||||
|
|
||||||
: inlining-standard-method ( #call word -- class/f method/f )
|
: inlining-standard-method ( #call word -- class/f method/f )
|
||||||
dup "methods" word-prop assoc-empty? [ 2drop f f ] [
|
dup "methods" word-prop assoc-empty? [ 2drop f f ] [
|
||||||
|
@ -159,19 +170,17 @@ SYMBOL: history
|
||||||
[ history [ swap suffix ] change ]
|
[ history [ swap suffix ] change ]
|
||||||
bi ;
|
bi ;
|
||||||
|
|
||||||
: inline-word-def ( #call word quot -- ? )
|
:: inline-word ( #call word -- ? )
|
||||||
over history get memq? [ 3drop f ] [
|
word history get memq? [ f ] [
|
||||||
|
#call word splicing-body [
|
||||||
[
|
[
|
||||||
[ remember-inlining ] dip
|
word remember-inlining
|
||||||
[ drop ] [ splicing-nodes ] 2bi
|
[ ] [ count-nodes ] [ (propagate) ] tri
|
||||||
[ >>body drop ] [ count-nodes ] [ (propagate) ] tri
|
] with-scope
|
||||||
] with-scope node-count +@
|
[ #call (>>body) ] [ node-count +@ ] bi* t
|
||||||
t
|
] [ f ] if*
|
||||||
] if ;
|
] if ;
|
||||||
|
|
||||||
: inline-word ( #call word -- ? )
|
|
||||||
dup specialized-def inline-word-def ;
|
|
||||||
|
|
||||||
: inline-method-body ( #call word -- ? )
|
: inline-method-body ( #call word -- ? )
|
||||||
2dup should-inline? [ inline-word ] [ 2drop f ] if ;
|
2dup should-inline? [ inline-word ] [ 2drop f ] if ;
|
||||||
|
|
||||||
|
@ -191,10 +200,6 @@ SYMBOL: history
|
||||||
call( #call -- word/quot/f )
|
call( #call -- word/quot/f )
|
||||||
object swap eliminate-dispatch ;
|
object swap eliminate-dispatch ;
|
||||||
|
|
||||||
: inline-instance-check ( #call word -- ? )
|
|
||||||
over in-d>> second value-info literal>> dup class?
|
|
||||||
[ "predicate" word-prop '[ drop @ ] inline-word-def ] [ 3drop f ] if ;
|
|
||||||
|
|
||||||
: (do-inlining) ( #call word -- ? )
|
: (do-inlining) ( #call word -- ? )
|
||||||
#! If the generic was defined in an outer compilation unit,
|
#! If the generic was defined in an outer compilation unit,
|
||||||
#! then it doesn't have a definition yet; the definition
|
#! then it doesn't have a definition yet; the definition
|
||||||
|
@ -206,7 +211,6 @@ SYMBOL: history
|
||||||
#! discouraged, but it should still work.)
|
#! discouraged, but it should still work.)
|
||||||
{
|
{
|
||||||
{ [ dup never-inline-word? ] [ 2drop f ] }
|
{ [ dup never-inline-word? ] [ 2drop f ] }
|
||||||
{ [ dup \ instance? eq? ] [ inline-instance-check ] }
|
|
||||||
{ [ dup always-inline-word? ] [ inline-word ] }
|
{ [ dup always-inline-word? ] [ inline-word ] }
|
||||||
{ [ dup standard-generic? ] [ inline-standard-method ] }
|
{ [ dup standard-generic? ] [ inline-standard-method ] }
|
||||||
{ [ dup math-generic? ] [ inline-math-method ] }
|
{ [ dup math-generic? ] [ inline-math-method ] }
|
||||||
|
|
|
@ -341,6 +341,11 @@ generic-comparison-ops [
|
||||||
] [ 2drop object-info ] if
|
] [ 2drop object-info ] if
|
||||||
] "outputs" set-word-prop
|
] "outputs" set-word-prop
|
||||||
|
|
||||||
|
\ instance? [
|
||||||
|
in-d>> second value-info literal>> dup class?
|
||||||
|
[ "predicate" word-prop '[ drop @ ] ] [ drop f ] if
|
||||||
|
] "custom-inlining" set-word-prop
|
||||||
|
|
||||||
\ equal? [
|
\ equal? [
|
||||||
! If first input has a known type and second input is an
|
! If first input has a known type and second input is an
|
||||||
! object, we convert this to [ swap equal? ].
|
! object, we convert this to [ swap equal? ].
|
||||||
|
|
|
@ -12,8 +12,6 @@ specialized-arrays.double system sorting math.libm
|
||||||
math.intervals ;
|
math.intervals ;
|
||||||
IN: compiler.tree.propagation.tests
|
IN: compiler.tree.propagation.tests
|
||||||
|
|
||||||
\ propagate must-infer
|
|
||||||
|
|
||||||
[ V{ } ] [ [ ] final-classes ] unit-test
|
[ V{ } ] [ [ ] final-classes ] unit-test
|
||||||
|
|
||||||
[ V{ fixnum } ] [ [ 1 ] final-classes ] unit-test
|
[ V{ fixnum } ] [ [ 1 ] final-classes ] unit-test
|
||||||
|
|
|
@ -10,8 +10,6 @@ compiler.tree.combinators ;
|
||||||
[ { f t t t } ] [ t { f f t t } (tail-calls) ] unit-test
|
[ { f t t t } ] [ t { f f t t } (tail-calls) ] unit-test
|
||||||
[ { f f f t } ] [ t { f f t f } (tail-calls) ] unit-test
|
[ { f f f t } ] [ t { f f t f } (tail-calls) ] unit-test
|
||||||
|
|
||||||
\ analyze-recursive must-infer
|
|
||||||
|
|
||||||
: label-is-loop? ( nodes word -- ? )
|
: label-is-loop? ( nodes word -- ? )
|
||||||
[
|
[
|
||||||
{
|
{
|
||||||
|
@ -21,8 +19,6 @@ compiler.tree.combinators ;
|
||||||
} 2&&
|
} 2&&
|
||||||
] curry contains-node? ;
|
] curry contains-node? ;
|
||||||
|
|
||||||
\ label-is-loop? must-infer
|
|
||||||
|
|
||||||
: label-is-not-loop? ( nodes word -- ? )
|
: label-is-not-loop? ( nodes word -- ? )
|
||||||
[
|
[
|
||||||
{
|
{
|
||||||
|
@ -32,8 +28,6 @@ compiler.tree.combinators ;
|
||||||
} 2&&
|
} 2&&
|
||||||
] curry contains-node? ;
|
] curry contains-node? ;
|
||||||
|
|
||||||
\ label-is-not-loop? must-infer
|
|
||||||
|
|
||||||
: loop-test-1 ( a -- )
|
: loop-test-1 ( a -- )
|
||||||
dup [ 1+ loop-test-1 ] [ drop ] if ; inline recursive
|
dup [ 1+ loop-test-1 ] [ drop ] if ; inline recursive
|
||||||
|
|
||||||
|
|
|
@ -8,8 +8,6 @@ compiler.tree.def-use kernel accessors sequences math
|
||||||
math.private sorting math.order binary-search sequences.private
|
math.private sorting math.order binary-search sequences.private
|
||||||
slots.private ;
|
slots.private ;
|
||||||
|
|
||||||
\ unbox-tuples must-infer
|
|
||||||
|
|
||||||
: test-unboxing ( quot -- )
|
: test-unboxing ( quot -- )
|
||||||
build-tree
|
build-tree
|
||||||
analyze-recursive
|
analyze-recursive
|
||||||
|
|
|
@ -2,8 +2,6 @@ IN: db.pools.tests
|
||||||
USING: db.pools tools.test continuations io.files io.files.temp
|
USING: db.pools tools.test continuations io.files io.files.temp
|
||||||
io.directories namespaces accessors kernel math destructors ;
|
io.directories namespaces accessors kernel math destructors ;
|
||||||
|
|
||||||
\ <db-pool> must-infer
|
|
||||||
|
|
||||||
{ 1 0 } [ [ ] with-db-pool ] must-infer-as
|
{ 1 0 } [ [ ] with-db-pool ] must-infer-as
|
||||||
|
|
||||||
{ 1 0 } [ [ ] with-pooled-db ] must-infer-as
|
{ 1 0 } [ [ ] with-pooled-db ] must-infer-as
|
||||||
|
|
|
@ -592,17 +592,6 @@ string-encoding-test "STRING_ENCODING_TEST" {
|
||||||
[ test-string-encoding ] test-sqlite
|
[ test-string-encoding ] test-sqlite
|
||||||
[ test-string-encoding ] test-postgresql
|
[ test-string-encoding ] test-postgresql
|
||||||
|
|
||||||
! Don't comment these out. These words must infer
|
|
||||||
\ bind-tuple must-infer
|
|
||||||
\ insert-tuple must-infer
|
|
||||||
\ update-tuple must-infer
|
|
||||||
\ delete-tuples must-infer
|
|
||||||
\ select-tuple must-infer
|
|
||||||
\ define-persistent must-infer
|
|
||||||
\ ensure-table must-infer
|
|
||||||
\ create-table must-infer
|
|
||||||
\ drop-table must-infer
|
|
||||||
|
|
||||||
: test-queries ( -- )
|
: test-queries ( -- )
|
||||||
[ ] [ exam ensure-table ] unit-test
|
[ ] [ exam ensure-table ] unit-test
|
||||||
[ ] [ 1000 [ random-exam insert-tuple ] times ] unit-test
|
[ ] [ 1000 [ random-exam insert-tuple ] times ] unit-test
|
||||||
|
|
|
@ -126,14 +126,14 @@ HOOK: signal-error. os ( obj -- )
|
||||||
: primitive-error. ( error -- )
|
: primitive-error. ( error -- )
|
||||||
"Unimplemented primitive" print drop ;
|
"Unimplemented primitive" print drop ;
|
||||||
|
|
||||||
PREDICATE: kernel-error < array
|
PREDICATE: vm-error < array
|
||||||
{
|
{
|
||||||
{ [ dup empty? ] [ drop f ] }
|
{ [ dup empty? ] [ drop f ] }
|
||||||
{ [ dup first "kernel-error" = not ] [ drop f ] }
|
{ [ dup first "kernel-error" = not ] [ drop f ] }
|
||||||
[ second 0 15 between? ]
|
[ second 0 15 between? ]
|
||||||
} cond ;
|
} cond ;
|
||||||
|
|
||||||
: kernel-errors ( error -- n errors )
|
: vm-errors ( error -- n errors )
|
||||||
second {
|
second {
|
||||||
{ 0 [ expired-error. ] }
|
{ 0 [ expired-error. ] }
|
||||||
{ 1 [ io-error. ] }
|
{ 1 [ io-error. ] }
|
||||||
|
@ -153,9 +153,11 @@ PREDICATE: kernel-error < array
|
||||||
{ 15 [ memory-error. ] }
|
{ 15 [ memory-error. ] }
|
||||||
} ; inline
|
} ; inline
|
||||||
|
|
||||||
M: kernel-error error. dup kernel-errors case ;
|
M: vm-error summary drop "VM error" ;
|
||||||
|
|
||||||
M: kernel-error error-help kernel-errors at first ;
|
M: vm-error error. dup vm-errors case ;
|
||||||
|
|
||||||
|
M: vm-error error-help vm-errors at first ;
|
||||||
|
|
||||||
M: no-method summary
|
M: no-method summary
|
||||||
drop "No suitable method" ;
|
drop "No suitable method" ;
|
||||||
|
|
|
@ -1 +1 @@
|
||||||
Doug Coleman
|
Slava Pestov
|
||||||
|
|
|
@ -0,0 +1 @@
|
||||||
|
unportable
|
|
@ -43,8 +43,6 @@ WHERE
|
||||||
|
|
||||||
>>
|
>>
|
||||||
|
|
||||||
\ sqsq must-infer
|
|
||||||
|
|
||||||
[ 16 ] [ 2 sqsq ] unit-test
|
[ 16 ] [ 2 sqsq ] unit-test
|
||||||
|
|
||||||
<<
|
<<
|
||||||
|
|
|
@ -1,6 +1,3 @@
|
||||||
USING: furnace.auth tools.test ;
|
USING: furnace.auth tools.test ;
|
||||||
IN: furnace.auth.tests
|
IN: furnace.auth.tests
|
||||||
|
|
||||||
\ logged-in-username must-infer
|
|
||||||
\ <protected> must-infer
|
|
||||||
\ new-realm must-infer
|
|
||||||
|
|
|
@ -1,4 +1,4 @@
|
||||||
IN: furnace.auth.features.edit-profile.tests
|
IN: furnace.auth.features.edit-profile.tests
|
||||||
USING: tools.test furnace.auth.features.edit-profile ;
|
USING: tools.test furnace.auth.features.edit-profile ;
|
||||||
|
|
||||||
\ allow-edit-profile must-infer
|
|
||||||
|
|
|
@ -1,4 +1,4 @@
|
||||||
IN: furnace.auth.features.recover-password
|
IN: furnace.auth.features.recover-password
|
||||||
USING: tools.test furnace.auth.features.recover-password ;
|
USING: tools.test furnace.auth.features.recover-password ;
|
||||||
|
|
||||||
\ allow-password-recovery must-infer
|
|
||||||
|
|
|
@ -1,4 +1,4 @@
|
||||||
IN: furnace.auth.features.registration.tests
|
IN: furnace.auth.features.registration.tests
|
||||||
USING: tools.test furnace.auth.features.registration ;
|
USING: tools.test furnace.auth.features.registration ;
|
||||||
|
|
||||||
\ allow-registration must-infer
|
|
||||||
|
|
|
@ -1,4 +1,4 @@
|
||||||
IN: furnace.auth.login.tests
|
IN: furnace.auth.login.tests
|
||||||
USING: tools.test furnace.auth.login ;
|
USING: tools.test furnace.auth.login ;
|
||||||
|
|
||||||
\ <login-realm> must-infer
|
|
||||||
|
|
|
@ -1,4 +1,4 @@
|
||||||
IN: furnace.db.tests
|
IN: furnace.db.tests
|
||||||
USING: tools.test furnace.db ;
|
USING: tools.test furnace.db ;
|
||||||
|
|
||||||
\ <db-persistence> must-infer
|
|
||||||
|
|
|
@ -17,8 +17,3 @@ HELP: xref-article
|
||||||
{ $values { "topic" "an article name or a word" } }
|
{ $values { "topic" "an article name or a word" } }
|
||||||
{ $description "Sets the " { $link article-parent } " of each child of this article." }
|
{ $description "Sets the " { $link article-parent } " of each child of this article." }
|
||||||
$low-level-note ;
|
$low-level-note ;
|
||||||
|
|
||||||
HELP: unxref-article
|
|
||||||
{ $values { "topic" "an article name or a word" } }
|
|
||||||
{ $description "Clears the " { $link article-parent } " of each child of this article." }
|
|
||||||
$low-level-note ;
|
|
||||||
|
|
|
@ -1,4 +1,4 @@
|
||||||
! Copyright (C) 2005, 2008 Slava Pestov.
|
! Copyright (C) 2005, 2009 Slava Pestov.
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
USING: arrays definitions generic assocs math fry
|
USING: arrays definitions generic assocs math fry
|
||||||
io kernel namespaces prettyprint prettyprint.sections
|
io kernel namespaces prettyprint prettyprint.sections
|
||||||
|
@ -12,9 +12,6 @@ IN: help.crossref
|
||||||
: article-children ( topic -- seq )
|
: article-children ( topic -- seq )
|
||||||
{ $subsection } article-links ;
|
{ $subsection } article-links ;
|
||||||
|
|
||||||
M: link uses
|
|
||||||
{ $subsection $link $see-also } article-links ;
|
|
||||||
|
|
||||||
: help-path ( topic -- seq )
|
: help-path ( topic -- seq )
|
||||||
[ article-parent ] follow rest ;
|
[ article-parent ] follow rest ;
|
||||||
|
|
||||||
|
@ -22,10 +19,7 @@ M: link uses
|
||||||
article-children [ set-article-parent ] with each ;
|
article-children [ set-article-parent ] with each ;
|
||||||
|
|
||||||
: xref-article ( topic -- )
|
: xref-article ( topic -- )
|
||||||
dup >link xref dup set-article-parents ;
|
dup set-article-parents ;
|
||||||
|
|
||||||
: unxref-article ( topic -- )
|
|
||||||
>link unxref ;
|
|
||||||
|
|
||||||
: prev/next ( obj seq n -- obj' )
|
: prev/next ( obj seq n -- obj' )
|
||||||
[ [ index dup ] keep ] dip swap
|
[ [ index dup ] keep ] dip swap
|
||||||
|
|
|
@ -156,10 +156,7 @@ help-hook [ [ print-topic ] ] initialize
|
||||||
error get (:help) ;
|
error get (:help) ;
|
||||||
|
|
||||||
: remove-article ( name -- )
|
: remove-article ( name -- )
|
||||||
dup articles get key? [
|
articles get delete-at ;
|
||||||
dup unxref-article
|
|
||||||
dup articles get delete-at
|
|
||||||
] when drop ;
|
|
||||||
|
|
||||||
: add-article ( article name -- )
|
: add-article ( article name -- )
|
||||||
[ remove-article ] keep
|
[ remove-article ] keep
|
||||||
|
@ -167,7 +164,6 @@ help-hook [ [ print-topic ] ] initialize
|
||||||
xref-article ;
|
xref-article ;
|
||||||
|
|
||||||
: remove-word-help ( word -- )
|
: remove-word-help ( word -- )
|
||||||
dup word-help [ dup unxref-article ] when
|
|
||||||
f "help" set-word-prop ;
|
f "help" set-word-prop ;
|
||||||
|
|
||||||
: set-word-help ( content word -- )
|
: set-word-help ( content word -- )
|
||||||
|
|
|
@ -26,5 +26,3 @@ TUPLE: blahblah quux ;
|
||||||
[ "a string, a fixnum, or an integer" ]
|
[ "a string, a fixnum, or an integer" ]
|
||||||
[ [ { $or string fixnum integer } print-element ] with-string-writer ] unit-test
|
[ [ { $or string fixnum integer } print-element ] with-string-writer ] unit-test
|
||||||
|
|
||||||
\ print-element must-infer
|
|
||||||
\ print-topic must-infer
|
|
|
@ -138,7 +138,7 @@ ALIAS: $slot $snippet
|
||||||
|
|
||||||
! Images
|
! Images
|
||||||
: $image ( element -- )
|
: $image ( element -- )
|
||||||
[ [ "" ] dip first image associate format ] ($span) ;
|
[ first write-image ] ($span) ;
|
||||||
|
|
||||||
: <$image> ( path -- element )
|
: <$image> ( path -- element )
|
||||||
1array \ $image prefix ;
|
1array \ $image prefix ;
|
||||||
|
@ -251,7 +251,7 @@ M: word ($instance)
|
||||||
dup name>> a/an write bl ($link) ;
|
dup name>> a/an write bl ($link) ;
|
||||||
|
|
||||||
M: string ($instance)
|
M: string ($instance)
|
||||||
dup a/an write bl $snippet ;
|
write ;
|
||||||
|
|
||||||
M: f ($instance)
|
M: f ($instance)
|
||||||
drop { f } $link ;
|
drop { f } $link ;
|
||||||
|
|
|
@ -3,11 +3,6 @@ help.markup help.syntax kernel sequences tools.test words parser
|
||||||
namespaces assocs source-files eval ;
|
namespaces assocs source-files eval ;
|
||||||
IN: help.topics.tests
|
IN: help.topics.tests
|
||||||
|
|
||||||
\ article-name must-infer
|
|
||||||
\ article-title must-infer
|
|
||||||
\ article-content must-infer
|
|
||||||
\ article-parent must-infer
|
|
||||||
|
|
||||||
! Test help cross-referencing
|
! Test help cross-referencing
|
||||||
|
|
||||||
[ ] [ "Test B" { "Hello world." } <article> { "test" "b" } add-article ] unit-test
|
[ ] [ "Test B" { "Hello world." } <article> { "test" "b" } add-article ] unit-test
|
||||||
|
|
|
@ -2,9 +2,9 @@
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
USING: parser words definitions kernel sequences assocs arrays
|
USING: parser words definitions kernel sequences assocs arrays
|
||||||
kernel.private fry combinators accessors vectors strings sbufs
|
kernel.private fry combinators accessors vectors strings sbufs
|
||||||
byte-arrays byte-vectors io.binary io.streams.string splitting
|
byte-arrays byte-vectors io.binary io.streams.string splitting math
|
||||||
math math.parser generic generic.standard generic.standard.engines classes
|
math.parser generic generic.standard generic.standard.engines classes
|
||||||
hashtables ;
|
hashtables namespaces ;
|
||||||
IN: hints
|
IN: hints
|
||||||
|
|
||||||
GENERIC: specializer-predicate ( spec -- quot )
|
GENERIC: specializer-predicate ( spec -- quot )
|
||||||
|
@ -37,13 +37,18 @@ M: object specializer-declaration class ;
|
||||||
: specialize-quot ( quot specializer -- quot' )
|
: specialize-quot ( quot specializer -- quot' )
|
||||||
specializer-cases alist>quot ;
|
specializer-cases alist>quot ;
|
||||||
|
|
||||||
: method-declaration ( method -- quot )
|
! compiler.tree.propagation.inlining sets this to f
|
||||||
[ "method-generic" word-prop dispatch# object <array> ]
|
SYMBOL: specialize-method?
|
||||||
[ "method-class" word-prop ]
|
|
||||||
bi prefix ;
|
t specialize-method? set-global
|
||||||
|
|
||||||
: specialize-method ( quot method -- quot' )
|
: specialize-method ( quot method -- quot' )
|
||||||
[ method-declaration '[ _ declare ] prepend ]
|
[
|
||||||
|
specialize-method? get [
|
||||||
|
[ "method-class" word-prop ] [ "method-generic" word-prop ] bi
|
||||||
|
method-declaration prepend
|
||||||
|
] [ drop ] if
|
||||||
|
]
|
||||||
[ "method-generic" word-prop "specializer" word-prop ] bi
|
[ "method-generic" word-prop "specializer" word-prop ] bi
|
||||||
[ specialize-quot ] when* ;
|
[ specialize-quot ] when* ;
|
||||||
|
|
||||||
|
@ -65,7 +70,7 @@ M: object specializer-declaration class ;
|
||||||
|
|
||||||
SYNTAX: HINTS:
|
SYNTAX: HINTS:
|
||||||
scan-object
|
scan-object
|
||||||
[ redefined ]
|
[ changed-definition ]
|
||||||
[ parse-definition "specializer" set-word-prop ] bi ;
|
[ parse-definition "specializer" set-word-prop ] bi ;
|
||||||
|
|
||||||
! Default specializers
|
! Default specializers
|
||||||
|
|
|
@ -4,8 +4,6 @@ io.streams.null accessors inspector html.streams
|
||||||
html.components html.forms namespaces
|
html.components html.forms namespaces
|
||||||
xml.writer ;
|
xml.writer ;
|
||||||
|
|
||||||
\ render must-infer
|
|
||||||
|
|
||||||
[ ] [ begin-form ] unit-test
|
[ ] [ begin-form ] unit-test
|
||||||
|
|
||||||
[ ] [ 3 "hi" set-value ] unit-test
|
[ ] [ 3 "hi" set-value ] unit-test
|
||||||
|
|
|
@ -1,8 +1,6 @@
|
||||||
USING: http.client http.client.private http tools.test
|
USING: http.client http.client.private http tools.test
|
||||||
namespaces urls ;
|
namespaces urls ;
|
||||||
|
|
||||||
\ download must-infer
|
|
||||||
|
|
||||||
[ "localhost" f ] [ "localhost" parse-host ] unit-test
|
[ "localhost" f ] [ "localhost" parse-host ] unit-test
|
||||||
[ "localhost" 8888 ] [ "localhost:8888" parse-host ] unit-test
|
[ "localhost" 8888 ] [ "localhost:8888" parse-host ] unit-test
|
||||||
|
|
||||||
|
|
|
@ -3,8 +3,6 @@ tools.test kernel namespaces accessors io http math sequences
|
||||||
assocs arrays classes words urls ;
|
assocs arrays classes words urls ;
|
||||||
IN: http.server.dispatchers.tests
|
IN: http.server.dispatchers.tests
|
||||||
|
|
||||||
\ find-responder must-infer
|
|
||||||
|
|
||||||
TUPLE: mock-responder path ;
|
TUPLE: mock-responder path ;
|
||||||
|
|
||||||
C: <mock-responder> mock-responder
|
C: <mock-responder> mock-responder
|
||||||
|
|
|
@ -2,8 +2,6 @@ IN: http.server.redirection.tests
|
||||||
USING: http http.server.redirection urls accessors
|
USING: http http.server.redirection urls accessors
|
||||||
namespaces tools.test present kernel ;
|
namespaces tools.test present kernel ;
|
||||||
|
|
||||||
\ relative-to-request must-infer
|
|
||||||
|
|
||||||
[
|
[
|
||||||
<request>
|
<request>
|
||||||
<url>
|
<url>
|
||||||
|
|
|
@ -4,8 +4,6 @@ IN: http.server.tests
|
||||||
|
|
||||||
[ t ] [ [ \ + first ] [ <500> ] recover response? ] unit-test
|
[ t ] [ [ \ + first ] [ <500> ] recover response? ] unit-test
|
||||||
|
|
||||||
\ make-http-error must-infer
|
|
||||||
|
|
||||||
[ "text/plain; charset=UTF-8" ] [
|
[ "text/plain; charset=UTF-8" ] [
|
||||||
<response>
|
<response>
|
||||||
"text/plain" >>content-type
|
"text/plain" >>content-type
|
||||||
|
|
|
@ -3,9 +3,6 @@ io.directories kernel io.pathnames accessors tools.test
|
||||||
sequences io.files.temp ;
|
sequences io.files.temp ;
|
||||||
IN: io.files.info.tests
|
IN: io.files.info.tests
|
||||||
|
|
||||||
\ file-info must-infer
|
|
||||||
\ link-info must-infer
|
|
||||||
|
|
||||||
[ t ] [
|
[ t ] [
|
||||||
temp-directory [ "hi41" "test41" utf8 set-file-contents ] with-directory
|
temp-directory [ "hi41" "test41" utf8 set-file-contents ] with-directory
|
||||||
temp-directory "test41" append-path utf8 file-contents "hi41" =
|
temp-directory "test41" append-path utf8 file-contents "hi41" =
|
||||||
|
|
|
@ -1,6 +1,3 @@
|
||||||
IN: io.launcher.tests
|
IN: io.launcher.tests
|
||||||
USING: tools.test io.launcher ;
|
USING: tools.test io.launcher ;
|
||||||
|
|
||||||
\ <process-stream> must-infer
|
|
||||||
\ <process-reader> must-infer
|
|
||||||
\ <process-writer> must-infer
|
|
||||||
|
|
|
@ -4,8 +4,6 @@ concurrency.mailboxes tools.test destructors io.files.info
|
||||||
io.pathnames io.files.temp io.directories.hierarchy ;
|
io.pathnames io.files.temp io.directories.hierarchy ;
|
||||||
IN: io.monitors.recursive.tests
|
IN: io.monitors.recursive.tests
|
||||||
|
|
||||||
\ pump-thread must-infer
|
|
||||||
|
|
||||||
SINGLETON: mock-io-backend
|
SINGLETON: mock-io-backend
|
||||||
|
|
||||||
TUPLE: counter i ;
|
TUPLE: counter i ;
|
||||||
|
|
|
@ -1,4 +1,4 @@
|
||||||
IN: io.monitors.windows.nt.tests
|
IN: io.monitors.windows.nt.tests
|
||||||
USING: io.monitors.windows.nt tools.test ;
|
USING: io.monitors.windows.nt tools.test ;
|
||||||
|
|
||||||
\ fill-queue-thread must-infer
|
|
||||||
|
|
|
@ -5,7 +5,6 @@ io.backend.unix classes words destructors threads tools.test
|
||||||
concurrency.promises byte-arrays locals calendar io.timeouts
|
concurrency.promises byte-arrays locals calendar io.timeouts
|
||||||
io.sockets.secure.unix.debug ;
|
io.sockets.secure.unix.debug ;
|
||||||
|
|
||||||
\ <secure-config> must-infer
|
|
||||||
{ 1 0 } [ [ ] with-secure-context ] must-infer-as
|
{ 1 0 } [ [ ] with-secure-context ] must-infer-as
|
||||||
|
|
||||||
[ ] [ <promise> "port" set ] unit-test
|
[ ] [ <promise> "port" set ] unit-test
|
||||||
|
|
|
@ -1,8 +1,2 @@
|
||||||
IN: io.styles.tests
|
IN: io.styles.tests
|
||||||
USING: io.styles tools.test ;
|
USING: io.styles tools.test ;
|
||||||
|
|
||||||
\ stream-format must-infer
|
|
||||||
\ stream-write-table must-infer
|
|
||||||
\ make-span-stream must-infer
|
|
||||||
\ make-block-stream must-infer
|
|
||||||
\ make-cell-stream must-infer
|
|
|
@ -156,3 +156,5 @@ M: input summary
|
||||||
] "" make ;
|
] "" make ;
|
||||||
|
|
||||||
: write-object ( str obj -- ) presented associate format ;
|
: write-object ( str obj -- ) presented associate format ;
|
||||||
|
|
||||||
|
: write-image ( image -- ) [ "" ] dip image associate format ;
|
||||||
|
|
|
@ -2,10 +2,6 @@
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
USING: tools.test lcs ;
|
USING: tools.test lcs ;
|
||||||
|
|
||||||
\ lcs must-infer
|
|
||||||
\ diff must-infer
|
|
||||||
\ levenshtein must-infer
|
|
||||||
|
|
||||||
[ 3 ] [ "sitting" "kitten" levenshtein ] unit-test
|
[ 3 ] [ "sitting" "kitten" levenshtein ] unit-test
|
||||||
[ 3 ] [ "kitten" "sitting" levenshtein ] unit-test
|
[ 3 ] [ "kitten" "sitting" levenshtein ] unit-test
|
||||||
[ 1 ] [ "freshpak" "freshpack" levenshtein ] unit-test
|
[ 1 ] [ "freshpak" "freshpack" levenshtein ] unit-test
|
||||||
|
|
|
@ -1,14 +1,14 @@
|
||||||
IN: locals.backend.tests
|
IN: locals.backend.tests
|
||||||
USING: tools.test locals.backend kernel arrays ;
|
USING: tools.test locals.backend kernel arrays accessors ;
|
||||||
|
|
||||||
: get-local-test-1 ( -- x ) 3 1 load-locals 0 get-local 1 drop-locals ;
|
: get-local-test-1 ( -- x ) 3 1 load-locals 0 get-local 1 drop-locals ;
|
||||||
|
|
||||||
\ get-local-test-1 must-infer
|
\ get-local-test-1 def>> must-infer
|
||||||
|
|
||||||
[ 3 ] [ get-local-test-1 ] unit-test
|
[ 3 ] [ get-local-test-1 ] unit-test
|
||||||
|
|
||||||
: get-local-test-2 ( -- x ) 3 4 2 load-locals -1 get-local 2 drop-locals ;
|
: get-local-test-2 ( -- x ) 3 4 2 load-locals -1 get-local 2 drop-locals ;
|
||||||
|
|
||||||
\ get-local-test-2 must-infer
|
\ get-local-test-2 def>> must-infer
|
||||||
|
|
||||||
[ 3 ] [ get-local-test-2 ] unit-test
|
[ 3 ] [ get-local-test-2 ] unit-test
|
||||||
|
|
|
@ -43,8 +43,8 @@ IN: locals.tests
|
||||||
|
|
||||||
[ { 1 2 } ] [ 2 let-test-4 ] unit-test
|
[ { 1 2 } ] [ 2 let-test-4 ] unit-test
|
||||||
|
|
||||||
:: let-test-5 ( a -- b )
|
:: let-test-5 ( a b -- b )
|
||||||
a [let | a [ ] b [ ] | a b 2array ] ;
|
a b [let | a [ ] b [ ] | a b 2array ] ;
|
||||||
|
|
||||||
[ { 2 1 } ] [ 1 2 let-test-5 ] unit-test
|
[ { 2 1 } ] [ 1 2 let-test-5 ] unit-test
|
||||||
|
|
||||||
|
@ -129,7 +129,8 @@ write-test-2 "q" set
|
||||||
SYMBOL: a
|
SYMBOL: a
|
||||||
|
|
||||||
:: use-test ( a b c -- a b c )
|
:: use-test ( a b c -- a b c )
|
||||||
USE: kernel ;
|
USE: kernel
|
||||||
|
a b c ;
|
||||||
|
|
||||||
[ t ] [ a symbol? ] unit-test
|
[ t ] [ a symbol? ] unit-test
|
||||||
|
|
||||||
|
@ -171,9 +172,9 @@ M:: string lambda-generic ( a b -- c ) a b lambda-generic-2 ;
|
||||||
|
|
||||||
[ ] [ \ lambda-generic see ] unit-test
|
[ ] [ \ lambda-generic see ] unit-test
|
||||||
|
|
||||||
:: unparse-test-1 ( a -- ) [let | a! [ ] | ] ;
|
:: unparse-test-1 ( a -- ) [let | a! [ 3 ] | ] ;
|
||||||
|
|
||||||
[ "[let | a! [ ] | ]" ] [
|
[ "[let | a! [ 3 ] | ]" ] [
|
||||||
\ unparse-test-1 "lambda" word-prop body>> first unparse
|
\ unparse-test-1 "lambda" word-prop body>> first unparse
|
||||||
] unit-test
|
] unit-test
|
||||||
|
|
||||||
|
@ -286,7 +287,7 @@ M:: sequence method-with-locals ( a -- y ) a reverse ;
|
||||||
{ [ a b > ] [ 5 ] }
|
{ [ a b > ] [ 5 ] }
|
||||||
} cond ;
|
} cond ;
|
||||||
|
|
||||||
\ cond-test must-infer
|
\ cond-test def>> must-infer
|
||||||
|
|
||||||
[ 3 ] [ 1 2 cond-test ] unit-test
|
[ 3 ] [ 1 2 cond-test ] unit-test
|
||||||
[ 4 ] [ 2 2 cond-test ] unit-test
|
[ 4 ] [ 2 2 cond-test ] unit-test
|
||||||
|
@ -295,7 +296,7 @@ M:: sequence method-with-locals ( a -- y ) a reverse ;
|
||||||
:: 0&&-test ( a -- ? )
|
:: 0&&-test ( a -- ? )
|
||||||
{ [ a integer? ] [ a even? ] [ a 10 > ] } 0&& ;
|
{ [ a integer? ] [ a even? ] [ a 10 > ] } 0&& ;
|
||||||
|
|
||||||
\ 0&&-test must-infer
|
\ 0&&-test def>> must-infer
|
||||||
|
|
||||||
[ f ] [ 1.5 0&&-test ] unit-test
|
[ f ] [ 1.5 0&&-test ] unit-test
|
||||||
[ f ] [ 3 0&&-test ] unit-test
|
[ f ] [ 3 0&&-test ] unit-test
|
||||||
|
@ -305,7 +306,7 @@ M:: sequence method-with-locals ( a -- y ) a reverse ;
|
||||||
:: &&-test ( a -- ? )
|
:: &&-test ( a -- ? )
|
||||||
{ [ a integer? ] [ a even? ] [ a 10 > ] } && ;
|
{ [ a integer? ] [ a even? ] [ a 10 > ] } && ;
|
||||||
|
|
||||||
\ &&-test must-infer
|
\ &&-test def>> must-infer
|
||||||
|
|
||||||
[ f ] [ 1.5 &&-test ] unit-test
|
[ f ] [ 1.5 &&-test ] unit-test
|
||||||
[ f ] [ 3 &&-test ] unit-test
|
[ f ] [ 3 &&-test ] unit-test
|
||||||
|
@ -321,7 +322,7 @@ M:: sequence method-with-locals ( a -- y ) a reverse ;
|
||||||
]
|
]
|
||||||
] ;
|
] ;
|
||||||
|
|
||||||
\ let-and-cond-test-1 must-infer
|
\ let-and-cond-test-1 def>> must-infer
|
||||||
|
|
||||||
[ 20 ] [ let-and-cond-test-1 ] unit-test
|
[ 20 ] [ let-and-cond-test-1 ] unit-test
|
||||||
|
|
||||||
|
@ -332,7 +333,7 @@ M:: sequence method-with-locals ( a -- y ) a reverse ;
|
||||||
]
|
]
|
||||||
] ;
|
] ;
|
||||||
|
|
||||||
\ let-and-cond-test-2 must-infer
|
\ let-and-cond-test-2 def>> must-infer
|
||||||
|
|
||||||
[ { 10 20 } ] [ let-and-cond-test-2 ] unit-test
|
[ { 10 20 } ] [ let-and-cond-test-2 ] unit-test
|
||||||
|
|
||||||
|
@ -388,7 +389,7 @@ ERROR: punned-class x ;
|
||||||
{ 5 [ a a ^ ] }
|
{ 5 [ a a ^ ] }
|
||||||
} case ;
|
} case ;
|
||||||
|
|
||||||
\ big-case-test must-infer
|
\ big-case-test def>> must-infer
|
||||||
|
|
||||||
[ 9 ] [ 3 big-case-test ] unit-test
|
[ 9 ] [ 3 big-case-test ] unit-test
|
||||||
|
|
||||||
|
@ -400,7 +401,7 @@ ERROR: punned-class x ;
|
||||||
[| x | x 12 + { "howdy" } nth ]
|
[| x | x 12 + { "howdy" } nth ]
|
||||||
} case ;
|
} case ;
|
||||||
|
|
||||||
\ littledan-case-problem-1 must-infer
|
\ littledan-case-problem-1 def>> must-infer
|
||||||
|
|
||||||
[ "howdy" ] [ -12 \ littledan-case-problem-1 def>> call ] unit-test
|
[ "howdy" ] [ -12 \ littledan-case-problem-1 def>> call ] unit-test
|
||||||
[ "howdy" ] [ -12 littledan-case-problem-1 ] unit-test
|
[ "howdy" ] [ -12 littledan-case-problem-1 ] unit-test
|
||||||
|
@ -412,7 +413,7 @@ ERROR: punned-class x ;
|
||||||
[| x | x a - { "howdy" } nth ]
|
[| x | x a - { "howdy" } nth ]
|
||||||
} case ;
|
} case ;
|
||||||
|
|
||||||
\ littledan-case-problem-2 must-infer
|
\ littledan-case-problem-2 def>> must-infer
|
||||||
|
|
||||||
[ "howdy" ] [ -12 \ littledan-case-problem-2 def>> call ] unit-test
|
[ "howdy" ] [ -12 \ littledan-case-problem-2 def>> call ] unit-test
|
||||||
[ "howdy" ] [ -12 littledan-case-problem-2 ] unit-test
|
[ "howdy" ] [ -12 littledan-case-problem-2 ] unit-test
|
||||||
|
@ -424,7 +425,7 @@ ERROR: punned-class x ;
|
||||||
[| x | x a - { "howdy" } nth ]
|
[| x | x a - { "howdy" } nth ]
|
||||||
} cond ;
|
} cond ;
|
||||||
|
|
||||||
\ littledan-cond-problem-1 must-infer
|
\ littledan-cond-problem-1 def>> must-infer
|
||||||
|
|
||||||
[ f ] [ -12 \ littledan-cond-problem-1 def>> call ] unit-test
|
[ f ] [ -12 \ littledan-cond-problem-1 def>> call ] unit-test
|
||||||
[ 4 ] [ 12 \ littledan-cond-problem-1 def>> call ] unit-test
|
[ 4 ] [ 12 \ littledan-cond-problem-1 def>> call ] unit-test
|
||||||
|
@ -448,12 +449,12 @@ ERROR: punned-class x ;
|
||||||
: littledan-case-problem-4 ( a -- b )
|
: littledan-case-problem-4 ( a -- b )
|
||||||
[ 1 + ] littledan-case-problem-3 ;
|
[ 1 + ] littledan-case-problem-3 ;
|
||||||
|
|
||||||
\ littledan-case-problem-4 must-infer
|
\ littledan-case-problem-4 def>> must-infer
|
||||||
*/
|
*/
|
||||||
|
|
||||||
GENERIC: lambda-method-forget-test ( a -- b )
|
GENERIC: lambda-method-forget-test ( a -- b )
|
||||||
|
|
||||||
M:: integer lambda-method-forget-test ( a -- b ) ;
|
M:: integer lambda-method-forget-test ( a -- b ) a ;
|
||||||
|
|
||||||
[ ] [ [ M\ integer lambda-method-forget-test forget ] with-compilation-unit ] unit-test
|
[ ] [ [ M\ integer lambda-method-forget-test forget ] with-compilation-unit ] unit-test
|
||||||
|
|
||||||
|
@ -467,7 +468,7 @@ M:: integer lambda-method-forget-test ( a -- b ) ;
|
||||||
:: (funny-macro-test) ( obj quot -- ? ) obj { quot } 1&& ; inline
|
:: (funny-macro-test) ( obj quot -- ? ) obj { quot } 1&& ; inline
|
||||||
: funny-macro-test ( n -- ? ) [ odd? ] (funny-macro-test) ;
|
: funny-macro-test ( n -- ? ) [ odd? ] (funny-macro-test) ;
|
||||||
|
|
||||||
\ funny-macro-test must-infer
|
\ funny-macro-test def>> must-infer
|
||||||
|
|
||||||
[ t ] [ 3 funny-macro-test ] unit-test
|
[ t ] [ 3 funny-macro-test ] unit-test
|
||||||
[ f ] [ 2 funny-macro-test ] unit-test
|
[ f ] [ 2 funny-macro-test ] unit-test
|
||||||
|
@ -483,11 +484,11 @@ M:: integer lambda-method-forget-test ( a -- b ) ;
|
||||||
|
|
||||||
:: FAILdog-1 ( -- b ) { [| c | c ] } ;
|
:: FAILdog-1 ( -- b ) { [| c | c ] } ;
|
||||||
|
|
||||||
\ FAILdog-1 must-infer
|
\ FAILdog-1 def>> must-infer
|
||||||
|
|
||||||
:: FAILdog-2 ( a -- b ) a { [| c | c ] } cond ;
|
:: FAILdog-2 ( a -- b ) a { [| c | c ] } cond ;
|
||||||
|
|
||||||
\ FAILdog-2 must-infer
|
\ FAILdog-2 def>> must-infer
|
||||||
|
|
||||||
[ 3 ] [ 3 [| a | \ a ] call ] unit-test
|
[ 3 ] [ 3 [| a | \ a ] call ] unit-test
|
||||||
|
|
||||||
|
@ -518,7 +519,7 @@ M:: integer lambda-method-forget-test ( a -- b ) ;
|
||||||
{ [ is-integer? ] [ is-even? ] [ >10? ] } &&
|
{ [ is-integer? ] [ is-even? ] [ >10? ] } &&
|
||||||
] ;
|
] ;
|
||||||
|
|
||||||
\ wlet-&&-test must-infer
|
\ wlet-&&-test def>> must-infer
|
||||||
[ f ] [ 1.5 wlet-&&-test ] unit-test
|
[ f ] [ 1.5 wlet-&&-test ] unit-test
|
||||||
[ f ] [ 3 wlet-&&-test ] unit-test
|
[ f ] [ 3 wlet-&&-test ] unit-test
|
||||||
[ f ] [ 8 wlet-&&-test ] unit-test
|
[ f ] [ 8 wlet-&&-test ] unit-test
|
||||||
|
@ -527,13 +528,13 @@ M:: integer lambda-method-forget-test ( a -- b ) ;
|
||||||
: fry-locals-test-1 ( -- n )
|
: fry-locals-test-1 ( -- n )
|
||||||
[let | | 6 '[ [let | A [ 4 ] | A _ + ] ] call ] ;
|
[let | | 6 '[ [let | A [ 4 ] | A _ + ] ] call ] ;
|
||||||
|
|
||||||
\ fry-locals-test-1 must-infer
|
\ fry-locals-test-1 def>> must-infer
|
||||||
[ 10 ] [ fry-locals-test-1 ] unit-test
|
[ 10 ] [ fry-locals-test-1 ] unit-test
|
||||||
|
|
||||||
:: fry-locals-test-2 ( -- n )
|
:: fry-locals-test-2 ( -- n )
|
||||||
[let | | 6 '[ [let | A [ 4 ] | A _ + ] ] call ] ;
|
[let | | 6 '[ [let | A [ 4 ] | A _ + ] ] call ] ;
|
||||||
|
|
||||||
\ fry-locals-test-2 must-infer
|
\ fry-locals-test-2 def>> must-infer
|
||||||
[ 10 ] [ fry-locals-test-2 ] unit-test
|
[ 10 ] [ fry-locals-test-2 ] unit-test
|
||||||
|
|
||||||
[ 1 ] [ 3 4 [| | '[ [ _ swap - ] call ] call ] call ] unit-test
|
[ 1 ] [ 3 4 [| | '[ [ _ swap - ] call ] call ] call ] unit-test
|
||||||
|
|
|
@ -12,10 +12,11 @@ IN: macros
|
||||||
PRIVATE>
|
PRIVATE>
|
||||||
|
|
||||||
: define-macro ( word definition effect -- )
|
: define-macro ( word definition effect -- )
|
||||||
real-macro-effect
|
real-macro-effect {
|
||||||
[ [ memoize-quot [ call ] append ] keep define-declared ]
|
[ [ memoize-quot [ call ] append ] keep define-declared ]
|
||||||
[ drop "macro" set-word-prop ]
|
[ drop "macro" set-word-prop ]
|
||||||
3bi ;
|
[ 2drop changed-effect ]
|
||||||
|
} 3cleave ;
|
||||||
|
|
||||||
SYNTAX: MACRO: (:) define-macro ;
|
SYNTAX: MACRO: (:) define-macro ;
|
||||||
|
|
||||||
|
|
|
@ -26,7 +26,7 @@ CONSTANT: b 2
|
||||||
|
|
||||||
[ 3 ] [ foo ] unit-test
|
[ 3 ] [ foo ] unit-test
|
||||||
[ 3 ] [ { a b } flags ] unit-test
|
[ 3 ] [ { a b } flags ] unit-test
|
||||||
\ foo must-infer
|
\ foo def>> must-infer
|
||||||
|
|
||||||
[ 1 ] [ { 1 } flags ] unit-test
|
[ 1 ] [ { 1 } flags ] unit-test
|
||||||
|
|
||||||
|
|
|
@ -31,6 +31,3 @@ T{ model-tester f f } "tester" set
|
||||||
"tester" get
|
"tester" get
|
||||||
"model-c" get value>>
|
"model-c" get value>>
|
||||||
] unit-test
|
] unit-test
|
||||||
|
|
||||||
\ model-changed must-infer
|
|
||||||
\ set-model must-infer
|
|
||||||
|
|
|
@ -5,8 +5,6 @@ USING: kernel tools.test strings namespaces make arrays sequences
|
||||||
peg peg.private peg.parsers accessors words math accessors ;
|
peg peg.private peg.parsers accessors words math accessors ;
|
||||||
IN: peg.tests
|
IN: peg.tests
|
||||||
|
|
||||||
\ parse must-infer
|
|
||||||
|
|
||||||
[ ] [ reset-pegs ] unit-test
|
[ ] [ reset-pegs ] unit-test
|
||||||
|
|
||||||
[
|
[
|
||||||
|
|
|
@ -17,5 +17,3 @@ IN: peg.search.tests
|
||||||
"abc 123 def 456" 'integer' [ 2 * number>string ] action replace
|
"abc 123 def 456" 'integer' [ 2 * number>string ] action replace
|
||||||
] unit-test
|
] unit-test
|
||||||
|
|
||||||
\ search must-infer
|
|
||||||
\ replace must-infer
|
|
||||||
|
|
|
@ -3,10 +3,6 @@ USING: accessors tools.test persistent.vectors
|
||||||
persistent.sequences sequences kernel arrays random namespaces
|
persistent.sequences sequences kernel arrays random namespaces
|
||||||
vectors math math.order ;
|
vectors math math.order ;
|
||||||
|
|
||||||
\ new-nth must-infer
|
|
||||||
\ ppush must-infer
|
|
||||||
\ ppop must-infer
|
|
||||||
|
|
||||||
[ 0 ] [ PV{ } length ] unit-test
|
[ 0 ] [ PV{ } length ] unit-test
|
||||||
|
|
||||||
[ 1 ] [ 3 PV{ } ppush length ] unit-test
|
[ 1 ] [ 3 PV{ } ppush length ] unit-test
|
||||||
|
|
|
@ -86,7 +86,6 @@ unit-test
|
||||||
drop ;
|
drop ;
|
||||||
|
|
||||||
[ "drop ;" ] [
|
[ "drop ;" ] [
|
||||||
\ blah f "inferred-effect" set-word-prop
|
|
||||||
[ \ blah see ] with-string-writer "\n" ?tail drop 6 tail*
|
[ \ blah see ] with-string-writer "\n" ?tail drop 6 tail*
|
||||||
] unit-test
|
] unit-test
|
||||||
|
|
||||||
|
|
|
@ -4,10 +4,6 @@ USING: regexp tools.test kernel sequences regexp.parser regexp.private
|
||||||
eval strings multiline accessors ;
|
eval strings multiline accessors ;
|
||||||
IN: regexp-tests
|
IN: regexp-tests
|
||||||
|
|
||||||
\ <regexp> must-infer
|
|
||||||
\ compile-regexp must-infer
|
|
||||||
\ matches? must-infer
|
|
||||||
|
|
||||||
[ f ] [ "b" "a*" <regexp> matches? ] unit-test
|
[ f ] [ "b" "a*" <regexp> matches? ] unit-test
|
||||||
[ t ] [ "" "a*" <regexp> matches? ] unit-test
|
[ t ] [ "" "a*" <regexp> matches? ] unit-test
|
||||||
[ t ] [ "a" "a*" <regexp> matches? ] unit-test
|
[ t ] [ "a" "a*" <regexp> matches? ] unit-test
|
||||||
|
|
|
@ -4,8 +4,6 @@ namespaces logging accessors assocs sorting smtp.private
|
||||||
concurrency.promises system ;
|
concurrency.promises system ;
|
||||||
IN: smtp.tests
|
IN: smtp.tests
|
||||||
|
|
||||||
\ send-email must-infer
|
|
||||||
|
|
||||||
{ 0 0 } [ [ ] with-smtp-connection ] must-infer-as
|
{ 0 0 } [ [ ] with-smtp-connection ] must-infer-as
|
||||||
|
|
||||||
[ "hello\nworld" validate-address ] must-fail
|
[ "hello\nworld" validate-address ] must-fail
|
||||||
|
|
|
@ -1,10 +1,10 @@
|
||||||
! Copyright (C) 2004, 2008 Slava Pestov.
|
! Copyright (C) 2004, 2009 Slava Pestov.
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
USING: fry arrays generic io io.streams.string kernel math
|
USING: fry arrays generic io io.streams.string kernel math
|
||||||
namespaces parser sequences strings vectors words quotations
|
namespaces parser sequences strings vectors words quotations
|
||||||
effects classes continuations assocs combinators
|
effects classes continuations assocs combinators
|
||||||
compiler.errors accessors math.order definitions sets
|
compiler.errors accessors math.order definitions sets
|
||||||
generic.standard.engines.tuple hints stack-checker.state
|
generic.standard.engines.tuple hints macros stack-checker.state
|
||||||
stack-checker.visitor stack-checker.errors stack-checker.values
|
stack-checker.visitor stack-checker.errors stack-checker.values
|
||||||
stack-checker.recursive-state ;
|
stack-checker.recursive-state ;
|
||||||
IN: stack-checker.backend
|
IN: stack-checker.backend
|
||||||
|
@ -84,11 +84,8 @@ M: object apply-object push-literal ;
|
||||||
meta-r empty? [ too-many->r ] unless ;
|
meta-r empty? [ too-many->r ] unless ;
|
||||||
|
|
||||||
: infer-quot-here ( quot -- )
|
: infer-quot-here ( quot -- )
|
||||||
meta-r [
|
|
||||||
V{ } clone \ meta-r set
|
|
||||||
[ apply-object terminated? get not ] all?
|
[ apply-object terminated? get not ] all?
|
||||||
[ commit-literals check->r ] [ literals get delete-all ] if
|
[ commit-literals ] [ literals get delete-all ] if ;
|
||||||
] dip \ meta-r set ;
|
|
||||||
|
|
||||||
: infer-quot ( quot rstate -- )
|
: infer-quot ( quot rstate -- )
|
||||||
recursive-state get [
|
recursive-state get [
|
||||||
|
@ -116,13 +113,14 @@ M: object apply-object push-literal ;
|
||||||
] if ;
|
] if ;
|
||||||
|
|
||||||
: infer->r ( n -- )
|
: infer->r ( n -- )
|
||||||
consume-d dup copy-values [ nip output-r ] [ #>r, ] 2bi ;
|
terminated? get [ drop ] [
|
||||||
|
consume-d dup copy-values [ nip output-r ] [ #>r, ] 2bi
|
||||||
|
] if ;
|
||||||
|
|
||||||
: infer-r> ( n -- )
|
: infer-r> ( n -- )
|
||||||
consume-r dup copy-values [ nip output-d ] [ #r>, ] 2bi ;
|
terminated? get [ drop ] [
|
||||||
|
consume-r dup copy-values [ nip output-d ] [ #r>, ] 2bi
|
||||||
: undo-infer ( -- )
|
] if ;
|
||||||
recorded get [ f "inferred-effect" set-word-prop ] each ;
|
|
||||||
|
|
||||||
: (consume/produce) ( effect -- inputs outputs )
|
: (consume/produce) ( effect -- inputs outputs )
|
||||||
[ in>> length consume-d ] [ out>> length produce-d ] bi ;
|
[ in>> length consume-d ] [ out>> length produce-d ] bi ;
|
||||||
|
@ -132,59 +130,25 @@ M: object apply-object push-literal ;
|
||||||
[ terminated?>> [ terminate ] when ]
|
[ terminated?>> [ terminate ] when ]
|
||||||
bi ; inline
|
bi ; inline
|
||||||
|
|
||||||
: infer-word-def ( word -- )
|
|
||||||
[ specialized-def ] [ add-recursive-state ] bi infer-quot ;
|
|
||||||
|
|
||||||
: end-infer ( -- )
|
: end-infer ( -- )
|
||||||
|
terminated? get [ check->r ] unless
|
||||||
meta-d clone #return, ;
|
meta-d clone #return, ;
|
||||||
|
|
||||||
: required-stack-effect ( word -- effect )
|
: required-stack-effect ( word -- effect )
|
||||||
dup stack-effect [ ] [ missing-effect ] ?if ;
|
dup stack-effect [ ] [ missing-effect ] ?if ;
|
||||||
|
|
||||||
: check-effect ( word effect -- )
|
|
||||||
over required-stack-effect 2dup effect<=
|
|
||||||
[ 3drop ] [ effect-error ] if ;
|
|
||||||
|
|
||||||
: finish-word ( word -- )
|
|
||||||
[ current-effect check-effect ]
|
|
||||||
[ recorded get push ]
|
|
||||||
[ t "inferred-effect" set-word-prop ]
|
|
||||||
tri ;
|
|
||||||
|
|
||||||
: cannot-infer-effect ( word -- * )
|
|
||||||
"cannot-infer" word-prop rethrow ;
|
|
||||||
|
|
||||||
: maybe-cannot-infer ( word quot -- )
|
|
||||||
[ [ "cannot-infer" set-word-prop ] keep rethrow ] recover ; inline
|
|
||||||
|
|
||||||
: infer-word ( word -- effect )
|
|
||||||
[
|
|
||||||
[
|
|
||||||
init-inference
|
|
||||||
init-known-values
|
|
||||||
stack-visitor off
|
|
||||||
dependencies off
|
|
||||||
generic-dependencies off
|
|
||||||
[ infer-word-def end-infer ]
|
|
||||||
[ finish-word ]
|
|
||||||
[ stack-effect ]
|
|
||||||
tri
|
|
||||||
] with-scope
|
|
||||||
] maybe-cannot-infer ;
|
|
||||||
|
|
||||||
: apply-word/effect ( word effect -- )
|
: apply-word/effect ( word effect -- )
|
||||||
swap '[ _ #call, ] consume/produce ;
|
swap '[ _ #call, ] consume/produce ;
|
||||||
|
|
||||||
: call-recursive-word ( word -- )
|
: infer-word ( word -- )
|
||||||
dup required-stack-effect apply-word/effect ;
|
{
|
||||||
|
{ [ dup macro? ] [ do-not-compile ] }
|
||||||
: cached-infer ( word -- )
|
{ [ dup "no-compile" word-prop ] [ do-not-compile ] }
|
||||||
dup stack-effect apply-word/effect ;
|
[ dup required-stack-effect apply-word/effect ]
|
||||||
|
} cond ;
|
||||||
|
|
||||||
: with-infer ( quot -- effect visitor )
|
: with-infer ( quot -- effect visitor )
|
||||||
[
|
[
|
||||||
[
|
|
||||||
V{ } clone recorded set
|
|
||||||
init-inference
|
init-inference
|
||||||
init-known-values
|
init-known-values
|
||||||
stack-visitor off
|
stack-visitor off
|
||||||
|
@ -192,5 +156,4 @@ M: object apply-object push-literal ;
|
||||||
end-infer
|
end-infer
|
||||||
current-effect
|
current-effect
|
||||||
stack-visitor get
|
stack-visitor get
|
||||||
] [ ] [ undo-infer ] cleanup
|
|
||||||
] with-scope ; inline
|
] with-scope ; inline
|
||||||
|
|
|
@ -2,7 +2,7 @@
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
USING: accessors combinators combinators.private effects fry
|
USING: accessors combinators combinators.private effects fry
|
||||||
kernel kernel.private make sequences continuations quotations
|
kernel kernel.private make sequences continuations quotations
|
||||||
stack-checker stack-checker.transforms ;
|
stack-checker stack-checker.transforms words ;
|
||||||
IN: stack-checker.call-effect
|
IN: stack-checker.call-effect
|
||||||
|
|
||||||
! call( and execute( have complex expansions.
|
! call( and execute( have complex expansions.
|
||||||
|
@ -54,6 +54,8 @@ M: quotation cached-effect
|
||||||
|
|
||||||
\ call-effect-slow [ call-effect-slow>quot ] 1 define-transform
|
\ call-effect-slow [ call-effect-slow>quot ] 1 define-transform
|
||||||
|
|
||||||
|
\ call-effect-slow t "no-compile" set-word-prop
|
||||||
|
|
||||||
: call-effect-fast ( quot effect inline-cache -- )
|
: call-effect-fast ( quot effect inline-cache -- )
|
||||||
2over call-effect-unsafe?
|
2over call-effect-unsafe?
|
||||||
[ [ nip (>>value) ] [ drop call-effect-unsafe ] 3bi ]
|
[ [ nip (>>value) ] [ drop call-effect-unsafe ] 3bi ]
|
||||||
|
@ -71,6 +73,8 @@ M: quotation cached-effect
|
||||||
]
|
]
|
||||||
] 0 define-transform
|
] 0 define-transform
|
||||||
|
|
||||||
|
\ call-effect t "no-compile" set-word-prop
|
||||||
|
|
||||||
: execute-effect-slow ( word effect -- )
|
: execute-effect-slow ( word effect -- )
|
||||||
[ '[ _ execute ] ] dip call-effect-slow ; inline
|
[ '[ _ execute ] ] dip call-effect-slow ; inline
|
||||||
|
|
||||||
|
@ -93,3 +97,5 @@ M: quotation cached-effect
|
||||||
inline-cache new '[ _ _ execute-effect-ic ] ;
|
inline-cache new '[ _ _ execute-effect-ic ] ;
|
||||||
|
|
||||||
\ execute-effect [ execute-effect>quot ] 1 define-transform
|
\ execute-effect [ execute-effect>quot ] 1 define-transform
|
||||||
|
|
||||||
|
\ execute-effect t "no-compile" set-word-prop
|
|
@ -24,6 +24,10 @@ M: inference-error error-type type>> ;
|
||||||
: inference-warning ( ... class -- * )
|
: inference-warning ( ... class -- * )
|
||||||
+compiler-warning+ (inference-error) ; inline
|
+compiler-warning+ (inference-error) ; inline
|
||||||
|
|
||||||
|
TUPLE: do-not-compile word ;
|
||||||
|
|
||||||
|
: do-not-compile ( word -- * ) \ do-not-compile inference-warning ;
|
||||||
|
|
||||||
TUPLE: literal-expected what ;
|
TUPLE: literal-expected what ;
|
||||||
|
|
||||||
: literal-expected ( what -- * ) \ literal-expected inference-warning ;
|
: literal-expected ( what -- * ) \ literal-expected inference-warning ;
|
||||||
|
@ -48,9 +52,9 @@ TUPLE: missing-effect word ;
|
||||||
: missing-effect ( word -- * )
|
: missing-effect ( word -- * )
|
||||||
pretty-word \ missing-effect inference-error ;
|
pretty-word \ missing-effect inference-error ;
|
||||||
|
|
||||||
TUPLE: effect-error word inferred declared ;
|
TUPLE: effect-error inferred declared ;
|
||||||
|
|
||||||
: effect-error ( word inferred declared -- * )
|
: effect-error ( inferred declared -- * )
|
||||||
\ effect-error inference-error ;
|
\ effect-error inference-error ;
|
||||||
|
|
||||||
TUPLE: recursive-quotation-error quot ;
|
TUPLE: recursive-quotation-error quot ;
|
||||||
|
|
|
@ -40,10 +40,7 @@ M: missing-effect summary
|
||||||
] "" make ;
|
] "" make ;
|
||||||
|
|
||||||
M: effect-error summary
|
M: effect-error summary
|
||||||
[
|
drop "Stack effect declaration is wrong" ;
|
||||||
"Stack effect declaration of the word " %
|
|
||||||
word>> name>> % " is wrong" %
|
|
||||||
] "" make ;
|
|
||||||
|
|
||||||
M: recursive-quotation-error error.
|
M: recursive-quotation-error error.
|
||||||
"The quotation " write
|
"The quotation " write
|
||||||
|
|
|
@ -216,10 +216,25 @@ M: object infer-call*
|
||||||
dispatch <tuple-boa> exit load-local load-locals get-local
|
dispatch <tuple-boa> exit load-local load-locals get-local
|
||||||
drop-locals do-primitive alien-invoke alien-indirect
|
drop-locals do-primitive alien-invoke alien-indirect
|
||||||
alien-callback
|
alien-callback
|
||||||
} [ t "special" set-word-prop ] each
|
} [
|
||||||
|
[ t "special" set-word-prop ]
|
||||||
|
[ t "no-compile" set-word-prop ] bi
|
||||||
|
] each
|
||||||
|
|
||||||
|
! Exceptions to the above
|
||||||
|
\ curry f "no-compile" set-word-prop
|
||||||
|
\ compose f "no-compile" set-word-prop
|
||||||
|
|
||||||
|
! More words not to compile
|
||||||
|
\ call t "no-compile" set-word-prop
|
||||||
|
\ call subwords [ t "no-compile" set-word-prop ] each
|
||||||
|
|
||||||
|
\ execute t "no-compile" set-word-prop
|
||||||
|
\ execute subwords [ t "no-compile" set-word-prop ] each
|
||||||
|
|
||||||
|
\ effective-method t "no-compile" set-word-prop
|
||||||
|
\ effective-method subwords [ t "no-compile" set-word-prop ] each
|
||||||
|
|
||||||
M\ quotation call t "no-compile" set-word-prop
|
|
||||||
M\ word execute t "no-compile" set-word-prop
|
|
||||||
\ clear t "no-compile" set-word-prop
|
\ clear t "no-compile" set-word-prop
|
||||||
|
|
||||||
: non-inline-word ( word -- )
|
: non-inline-word ( word -- )
|
||||||
|
@ -230,14 +245,11 @@ M\ word execute t "no-compile" set-word-prop
|
||||||
{ [ dup "primitive" word-prop ] [ infer-primitive ] }
|
{ [ dup "primitive" word-prop ] [ infer-primitive ] }
|
||||||
{ [ dup "transform-quot" word-prop ] [ apply-transform ] }
|
{ [ dup "transform-quot" word-prop ] [ apply-transform ] }
|
||||||
{ [ dup "macro" word-prop ] [ apply-macro ] }
|
{ [ dup "macro" word-prop ] [ apply-macro ] }
|
||||||
{ [ dup "cannot-infer" word-prop ] [ cannot-infer-effect ] }
|
|
||||||
{ [ dup "inferred-effect" word-prop ] [ cached-infer ] }
|
|
||||||
{ [ dup local? ] [ infer-local-reader ] }
|
{ [ dup local? ] [ infer-local-reader ] }
|
||||||
{ [ dup local-reader? ] [ infer-local-reader ] }
|
{ [ dup local-reader? ] [ infer-local-reader ] }
|
||||||
{ [ dup local-writer? ] [ infer-local-writer ] }
|
{ [ dup local-writer? ] [ infer-local-writer ] }
|
||||||
{ [ dup local-word? ] [ infer-local-word ] }
|
{ [ dup local-word? ] [ infer-local-word ] }
|
||||||
{ [ dup recursive-word? ] [ call-recursive-word ] }
|
[ infer-word ]
|
||||||
[ dup infer-word apply-word/effect ]
|
|
||||||
} cond ;
|
} cond ;
|
||||||
|
|
||||||
: define-primitive ( word inputs outputs -- )
|
: define-primitive ( word inputs outputs -- )
|
||||||
|
|
|
@ -1,39 +1,26 @@
|
||||||
! Copyright (C) 2008 Slava Pestov.
|
! Copyright (C) 2008, 2009 Slava Pestov.
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
USING: accessors arrays sequences kernel sequences assocs
|
USING: accessors arrays sequences kernel sequences assocs
|
||||||
namespaces stack-checker.recursive-state.tree ;
|
namespaces stack-checker.recursive-state.tree ;
|
||||||
IN: stack-checker.recursive-state
|
IN: stack-checker.recursive-state
|
||||||
|
|
||||||
TUPLE: recursive-state word words quotations inline-words ;
|
TUPLE: recursive-state word quotations inline-words ;
|
||||||
|
|
||||||
: prepare-recursive-state ( word rstate -- rstate )
|
: initial-recursive-state ( word -- state )
|
||||||
|
recursive-state new
|
||||||
swap >>word
|
swap >>word
|
||||||
f >>quotations
|
f >>quotations
|
||||||
f >>inline-words ; inline
|
f >>inline-words ; inline
|
||||||
|
|
||||||
: initial-recursive-state ( word -- state )
|
|
||||||
recursive-state new
|
|
||||||
f >>words
|
|
||||||
prepare-recursive-state ; inline
|
|
||||||
|
|
||||||
f initial-recursive-state recursive-state set-global
|
f initial-recursive-state recursive-state set-global
|
||||||
|
|
||||||
: add-recursive-state ( word -- rstate )
|
: add-local-quotation ( rstate quot -- rstate )
|
||||||
recursive-state get clone
|
|
||||||
[ word>> dup ] keep [ store ] change-words
|
|
||||||
prepare-recursive-state ;
|
|
||||||
|
|
||||||
: add-local-quotation ( recursive-state quot -- rstate )
|
|
||||||
swap clone [ dupd store ] change-quotations ;
|
swap clone [ dupd store ] change-quotations ;
|
||||||
|
|
||||||
: add-inline-word ( word label -- rstate )
|
: add-inline-word ( word label -- rstate )
|
||||||
swap recursive-state get clone
|
swap recursive-state get clone
|
||||||
[ store ] change-inline-words ;
|
[ store ] change-inline-words ;
|
||||||
|
|
||||||
: recursive-word? ( word -- ? )
|
|
||||||
recursive-state get 2dup word>> eq?
|
|
||||||
[ 2drop t ] [ words>> lookup ] if ;
|
|
||||||
|
|
||||||
: inline-recursive-label ( word -- label/f )
|
: inline-recursive-label ( word -- label/f )
|
||||||
recursive-state get inline-words>> lookup ;
|
recursive-state get inline-words>> lookup ;
|
||||||
|
|
||||||
|
|
|
@ -109,7 +109,6 @@ HELP: inference-error
|
||||||
"The " { $snippet "error" } " slot contains one of several possible " { $link "inference-errors" } "."
|
"The " { $snippet "error" } " slot contains one of several possible " { $link "inference-errors" } "."
|
||||||
} ;
|
} ;
|
||||||
|
|
||||||
|
|
||||||
HELP: infer
|
HELP: infer
|
||||||
{ $values { "quot" "a quotation" } { "effect" "an instance of " { $link effect } } }
|
{ $values { "quot" "a quotation" } { "effect" "an instance of " { $link effect } } }
|
||||||
{ $description "Attempts to infer the quotation's stack effect. For interactive testing, the " { $link infer. } " word should be called instead since it presents the output in a nicely formatted manner." }
|
{ $description "Attempts to infer the quotation's stack effect. For interactive testing, the " { $link infer. } " word should be called instead since it presents the output in a nicely formatted manner." }
|
||||||
|
@ -121,11 +120,3 @@ HELP: infer.
|
||||||
{ $errors "Throws an " { $link inference-error } " if stack effect inference fails." } ;
|
{ $errors "Throws an " { $link inference-error } " if stack effect inference fails." } ;
|
||||||
|
|
||||||
{ infer infer. } related-words
|
{ infer infer. } related-words
|
||||||
|
|
||||||
HELP: forget-errors
|
|
||||||
{ $description "Removes markers indicating which words do not have stack effects."
|
|
||||||
$nl
|
|
||||||
"The stack effect inference code remembers which words failed to infer as an optimization, so that it does not try to infer the stack effect of words which do not have one over and over again." }
|
|
||||||
{ $notes "Usually this word does not need to be called directly; if a word failed to compile because of a stack effect error, fixing the word definition clears the flag automatically. However, if words failed to compile due to external factors which were subsequently rectified, such as an unavailable C library or a missing or broken compiler transform, this flag can be cleared for all words:"
|
|
||||||
{ $code "forget-errors" }
|
|
||||||
"Subsequent invocations of the compiler will consider all words for compilation." } ;
|
|
||||||
|
|
|
@ -10,7 +10,7 @@ sequences.private destructors combinators eval locals.backend
|
||||||
system compiler.units ;
|
system compiler.units ;
|
||||||
IN: stack-checker.tests
|
IN: stack-checker.tests
|
||||||
|
|
||||||
\ infer. must-infer
|
[ 1234 infer ] must-fail
|
||||||
|
|
||||||
{ 0 2 } [ 2 "Hello" ] must-infer-as
|
{ 0 2 } [ 2 "Hello" ] must-infer-as
|
||||||
{ 1 2 } [ dup ] must-infer-as
|
{ 1 2 } [ dup ] must-infer-as
|
||||||
|
@ -65,11 +65,6 @@ IN: stack-checker.tests
|
||||||
|
|
||||||
{ 1 1 } [ simple-recursion-2 ] must-infer-as
|
{ 1 1 } [ simple-recursion-2 ] must-infer-as
|
||||||
|
|
||||||
: bad-recursion-2 ( obj -- obj )
|
|
||||||
dup [ dup first swap second bad-recursion-2 ] [ ] if ;
|
|
||||||
|
|
||||||
[ [ bad-recursion-2 ] infer ] must-fail
|
|
||||||
|
|
||||||
: funny-recursion ( obj -- obj )
|
: funny-recursion ( obj -- obj )
|
||||||
dup [ funny-recursion 1 ] [ 2 ] if drop ;
|
dup [ funny-recursion 1 ] [ 2 ] if drop ;
|
||||||
|
|
||||||
|
@ -196,94 +191,11 @@ DEFER: blah4
|
||||||
over string? [ 2array throw ] unless
|
over string? [ 2array throw ] unless
|
||||||
] must-infer-as
|
] must-infer-as
|
||||||
|
|
||||||
! Regression
|
|
||||||
|
|
||||||
! This order of branches works
|
|
||||||
DEFER: do-crap
|
|
||||||
: more-crap ( obj -- ) dup [ drop ] [ dup do-crap call ] if ;
|
|
||||||
: do-crap ( obj -- ) dup [ more-crap ] [ do-crap ] if ;
|
|
||||||
[ [ do-crap ] infer ] must-fail
|
|
||||||
|
|
||||||
! This one does not
|
|
||||||
DEFER: do-crap*
|
|
||||||
: more-crap* ( obj -- ) dup [ drop ] [ dup do-crap* call ] if ;
|
|
||||||
: do-crap* ( obj -- ) dup [ do-crap* ] [ more-crap* ] if ;
|
|
||||||
[ [ do-crap* ] infer ] must-fail
|
|
||||||
|
|
||||||
! Regression
|
! Regression
|
||||||
: too-deep ( a b -- c )
|
: too-deep ( a b -- c )
|
||||||
dup [ drop ] [ 2dup too-deep too-deep * ] if ; inline recursive
|
dup [ drop ] [ 2dup too-deep too-deep * ] if ; inline recursive
|
||||||
{ 2 1 } [ too-deep ] must-infer-as
|
{ 2 1 } [ too-deep ] must-infer-as
|
||||||
|
|
||||||
! Error reporting is wrong
|
|
||||||
MATH: xyz ( a b -- c )
|
|
||||||
M: fixnum xyz 2array ;
|
|
||||||
M: float xyz
|
|
||||||
[ 3 ] bi@ swapd [ 2array swap ] dip 2array swap ;
|
|
||||||
|
|
||||||
[ [ xyz ] infer ] [ inference-error? ] must-fail-with
|
|
||||||
|
|
||||||
! Doug Coleman discovered this one while working on the
|
|
||||||
! calendar library
|
|
||||||
DEFER: A
|
|
||||||
DEFER: B
|
|
||||||
DEFER: C
|
|
||||||
|
|
||||||
: A ( a -- )
|
|
||||||
dup {
|
|
||||||
[ drop ]
|
|
||||||
[ A ]
|
|
||||||
[ \ A no-method ]
|
|
||||||
[ dup C A ]
|
|
||||||
} dispatch ;
|
|
||||||
|
|
||||||
: B ( b -- )
|
|
||||||
dup {
|
|
||||||
[ C ]
|
|
||||||
[ B ]
|
|
||||||
[ \ B no-method ]
|
|
||||||
[ dup B B ]
|
|
||||||
} dispatch ;
|
|
||||||
|
|
||||||
: C ( c -- )
|
|
||||||
dup {
|
|
||||||
[ A ]
|
|
||||||
[ C ]
|
|
||||||
[ \ C no-method ]
|
|
||||||
[ dup B C ]
|
|
||||||
} dispatch ;
|
|
||||||
|
|
||||||
{ 1 0 } [ A ] must-infer-as
|
|
||||||
{ 1 0 } [ B ] must-infer-as
|
|
||||||
{ 1 0 } [ C ] must-infer-as
|
|
||||||
|
|
||||||
! I found this bug by thinking hard about the previous one
|
|
||||||
DEFER: Y
|
|
||||||
: X ( a b -- c d ) dup [ swap Y ] [ ] if ;
|
|
||||||
: Y ( a b -- c d ) X ;
|
|
||||||
|
|
||||||
{ 2 2 } [ X ] must-infer-as
|
|
||||||
{ 2 2 } [ Y ] must-infer-as
|
|
||||||
|
|
||||||
! This one comes from UI code
|
|
||||||
DEFER: #1
|
|
||||||
: #2 ( a b: ( -- ) -- ) dup [ call ] [ 2drop ] if ; inline
|
|
||||||
: #3 ( a -- ) [ #1 ] #2 ;
|
|
||||||
: #4 ( a -- ) dup [ drop ] [ dup #4 dup #3 call ] if ;
|
|
||||||
: #1 ( a -- ) dup [ dup #4 dup #3 ] [ ] if drop ;
|
|
||||||
|
|
||||||
[ \ #4 def>> infer ] must-fail
|
|
||||||
[ [ #1 ] infer ] must-fail
|
|
||||||
|
|
||||||
! Similar
|
|
||||||
DEFER: bar
|
|
||||||
: foo ( a b -- c d ) dup [ 2drop f f bar ] [ ] if ;
|
|
||||||
: bar ( a b -- ) [ 2 2 + ] t foo drop call drop ;
|
|
||||||
|
|
||||||
[ [ foo ] infer ] must-fail
|
|
||||||
|
|
||||||
[ 1234 infer ] must-fail
|
|
||||||
|
|
||||||
! This used to hang
|
! This used to hang
|
||||||
[ [ [ dup call ] dup call ] infer ]
|
[ [ [ dup call ] dup call ] infer ]
|
||||||
[ inference-error? ] must-fail-with
|
[ inference-error? ] must-fail-with
|
||||||
|
@ -311,16 +223,6 @@ DEFER: bar
|
||||||
[ [ [ [ drop 3 ] swap call ] dup call ] infer ]
|
[ [ [ [ drop 3 ] swap call ] dup call ] infer ]
|
||||||
[ inference-error? ] must-fail-with
|
[ inference-error? ] must-fail-with
|
||||||
|
|
||||||
! This form should not have a stack effect
|
|
||||||
|
|
||||||
: bad-recursion-1 ( a -- b )
|
|
||||||
dup [ drop bad-recursion-1 5 ] [ ] if ;
|
|
||||||
|
|
||||||
[ [ bad-recursion-1 ] infer ] must-fail
|
|
||||||
|
|
||||||
: bad-bin ( a b -- ) 5 [ 5 bad-bin bad-bin 5 ] [ 2drop ] if ;
|
|
||||||
[ [ bad-bin ] infer ] must-fail
|
|
||||||
|
|
||||||
[ [ 1 drop-locals ] infer ] [ inference-error? ] must-fail-with
|
[ [ 1 drop-locals ] infer ] [ inference-error? ] must-fail-with
|
||||||
|
|
||||||
! Regression
|
! Regression
|
||||||
|
@ -333,114 +235,14 @@ DEFER: bar
|
||||||
|
|
||||||
[ [ 3 [ ] curry 1 2 [ ] 2curry if ] infer ] must-fail
|
[ [ 3 [ ] curry 1 2 [ ] 2curry if ] infer ] must-fail
|
||||||
|
|
||||||
! Test number protocol
|
|
||||||
\ bitor must-infer
|
|
||||||
\ bitand must-infer
|
|
||||||
\ bitxor must-infer
|
|
||||||
\ mod must-infer
|
|
||||||
\ /i must-infer
|
|
||||||
\ /f must-infer
|
|
||||||
\ /mod must-infer
|
|
||||||
\ + must-infer
|
|
||||||
\ - must-infer
|
|
||||||
\ * must-infer
|
|
||||||
\ / must-infer
|
|
||||||
\ < must-infer
|
|
||||||
\ <= must-infer
|
|
||||||
\ > must-infer
|
|
||||||
\ >= must-infer
|
|
||||||
\ number= must-infer
|
|
||||||
|
|
||||||
! Test object protocol
|
|
||||||
\ = must-infer
|
|
||||||
\ clone must-infer
|
|
||||||
\ hashcode* must-infer
|
|
||||||
|
|
||||||
! Test sequence protocol
|
|
||||||
\ length must-infer
|
|
||||||
\ nth must-infer
|
|
||||||
\ set-length must-infer
|
|
||||||
\ set-nth must-infer
|
|
||||||
\ new must-infer
|
|
||||||
\ new-resizable must-infer
|
|
||||||
\ like must-infer
|
|
||||||
\ lengthen must-infer
|
|
||||||
|
|
||||||
! Test assoc protocol
|
|
||||||
\ at* must-infer
|
|
||||||
\ set-at must-infer
|
|
||||||
\ new-assoc must-infer
|
|
||||||
\ delete-at must-infer
|
|
||||||
\ clear-assoc must-infer
|
|
||||||
\ assoc-size must-infer
|
|
||||||
\ assoc-like must-infer
|
|
||||||
\ assoc-clone-like must-infer
|
|
||||||
\ >alist must-infer
|
|
||||||
{ 1 3 } [ [ 2drop f ] assoc-find ] must-infer-as
|
{ 1 3 } [ [ 2drop f ] assoc-find ] must-infer-as
|
||||||
|
|
||||||
! Test some random library words
|
|
||||||
\ 1quotation must-infer
|
|
||||||
\ string>number must-infer
|
|
||||||
\ get must-infer
|
|
||||||
|
|
||||||
\ push must-infer
|
|
||||||
\ append must-infer
|
|
||||||
\ peek must-infer
|
|
||||||
|
|
||||||
\ reverse must-infer
|
|
||||||
\ member? must-infer
|
|
||||||
\ remove must-infer
|
|
||||||
\ natural-sort must-infer
|
|
||||||
|
|
||||||
\ forget must-infer
|
|
||||||
\ define-class must-infer
|
|
||||||
\ define-tuple-class must-infer
|
|
||||||
\ define-union-class must-infer
|
|
||||||
\ define-predicate-class must-infer
|
|
||||||
\ instance? must-infer
|
|
||||||
\ next-method-quot must-infer
|
|
||||||
|
|
||||||
! Test words with continuations
|
! Test words with continuations
|
||||||
{ 0 0 } [ [ drop ] callcc0 ] must-infer-as
|
{ 0 0 } [ [ drop ] callcc0 ] must-infer-as
|
||||||
{ 0 1 } [ [ 4 swap continue-with ] callcc1 ] must-infer-as
|
{ 0 1 } [ [ 4 swap continue-with ] callcc1 ] must-infer-as
|
||||||
{ 2 1 } [ [ + ] [ ] [ ] cleanup ] must-infer-as
|
{ 2 1 } [ [ + ] [ ] [ ] cleanup ] must-infer-as
|
||||||
{ 2 1 } [ [ + ] [ 3drop 0 ] recover ] must-infer-as
|
{ 2 1 } [ [ + ] [ 3drop 0 ] recover ] must-infer-as
|
||||||
|
|
||||||
\ dispose must-infer
|
|
||||||
|
|
||||||
! Test stream protocol
|
|
||||||
\ set-timeout must-infer
|
|
||||||
\ stream-read must-infer
|
|
||||||
\ stream-read1 must-infer
|
|
||||||
\ stream-readln must-infer
|
|
||||||
\ stream-read-until must-infer
|
|
||||||
\ stream-write must-infer
|
|
||||||
\ stream-write1 must-infer
|
|
||||||
\ stream-nl must-infer
|
|
||||||
\ stream-flush must-infer
|
|
||||||
|
|
||||||
! Test stream utilities
|
|
||||||
\ lines must-infer
|
|
||||||
\ contents must-infer
|
|
||||||
|
|
||||||
! Test prettyprinting
|
|
||||||
\ . must-infer
|
|
||||||
\ short. must-infer
|
|
||||||
\ unparse must-infer
|
|
||||||
|
|
||||||
\ describe must-infer
|
|
||||||
\ error. must-infer
|
|
||||||
|
|
||||||
! Test odds and ends
|
|
||||||
\ io-thread must-infer
|
|
||||||
|
|
||||||
! Incorrect stack declarations on inline recursive words should
|
|
||||||
! be caught
|
|
||||||
: fooxxx ( a b -- c ) over [ foo ] when ; inline
|
|
||||||
: barxxx ( a b -- c ) fooxxx ;
|
|
||||||
|
|
||||||
[ [ barxxx ] infer ] must-fail
|
|
||||||
|
|
||||||
! A typo
|
! A typo
|
||||||
{ 1 0 } [ { [ ] } dispatch ] must-infer-as
|
{ 1 0 } [ { [ ] } dispatch ] must-infer-as
|
||||||
|
|
||||||
|
@ -463,7 +265,6 @@ DEFER: deferred-word
|
||||||
|
|
||||||
{ 1 1 } [ [ deferred-word ] [ 3 ] if ] must-infer-as
|
{ 1 1 } [ [ deferred-word ] [ 3 ] if ] must-infer-as
|
||||||
|
|
||||||
|
|
||||||
DEFER: an-inline-word
|
DEFER: an-inline-word
|
||||||
|
|
||||||
: normal-word-3 ( -- )
|
: normal-word-3 ( -- )
|
||||||
|
@ -498,14 +299,12 @@ ERROR: custom-error ;
|
||||||
[ custom-error inference-error ] infer
|
[ custom-error inference-error ] infer
|
||||||
] unit-test
|
] unit-test
|
||||||
|
|
||||||
[ T{ effect f 1 2 t } ] [
|
[ T{ effect f 1 1 t } ] [
|
||||||
[ dup [ 3 throw ] dip ] infer
|
[ dup [ 3 throw ] dip ] infer
|
||||||
] unit-test
|
] unit-test
|
||||||
|
|
||||||
! Regression
|
! Regression
|
||||||
: missing->r-check ( a -- ) 1 load-locals ;
|
[ [ 1 load-locals ] infer ] must-fail
|
||||||
|
|
||||||
[ [ missing->r-check ] infer ] must-fail
|
|
||||||
|
|
||||||
! Corner case
|
! Corner case
|
||||||
[ [ [ f dup ] [ dup ] produce ] infer ] must-fail
|
[ [ [ f dup ] [ dup ] produce ] infer ] must-fail
|
||||||
|
@ -513,35 +312,12 @@ ERROR: custom-error ;
|
||||||
[ [ [ f dup ] [ ] while ] infer ] must-fail
|
[ [ [ f dup ] [ ] while ] infer ] must-fail
|
||||||
|
|
||||||
: erg's-inference-bug ( -- ) f dup [ erg's-inference-bug ] when ; inline recursive
|
: erg's-inference-bug ( -- ) f dup [ erg's-inference-bug ] when ; inline recursive
|
||||||
|
|
||||||
[ [ erg's-inference-bug ] infer ] must-fail
|
[ [ erg's-inference-bug ] infer ] must-fail
|
||||||
|
FORGET: erg's-inference-bug
|
||||||
: inference-invalidation-a ( -- ) ;
|
|
||||||
: inference-invalidation-b ( quot -- ) [ inference-invalidation-a ] dip call ; inline
|
|
||||||
: inference-invalidation-c ( a b -- c ) [ + ] inference-invalidation-b ; inline
|
|
||||||
|
|
||||||
[ 7 ] [ 4 3 inference-invalidation-c ] unit-test
|
|
||||||
|
|
||||||
{ 2 1 } [ [ + ] inference-invalidation-b ] must-infer-as
|
|
||||||
|
|
||||||
[ ] [ "IN: stack-checker.tests : inference-invalidation-a ( -- a b ) 1 2 ;" eval( -- ) ] unit-test
|
|
||||||
|
|
||||||
[ 3 ] [ inference-invalidation-c ] unit-test
|
|
||||||
|
|
||||||
{ 0 1 } [ inference-invalidation-c ] must-infer-as
|
|
||||||
|
|
||||||
GENERIC: inference-invalidation-d ( obj -- )
|
|
||||||
|
|
||||||
M: object inference-invalidation-d inference-invalidation-c 2drop ;
|
|
||||||
|
|
||||||
\ inference-invalidation-d must-infer
|
|
||||||
|
|
||||||
[ ] [ "IN: stack-checker.tests : inference-invalidation-a ( -- ) ;" eval( -- ) ] unit-test
|
|
||||||
|
|
||||||
[ [ inference-invalidation-d ] infer ] must-fail
|
|
||||||
|
|
||||||
: bad-recursion-3 ( -- ) dup [ [ bad-recursion-3 ] dip ] when ; inline recursive
|
: bad-recursion-3 ( -- ) dup [ [ bad-recursion-3 ] dip ] when ; inline recursive
|
||||||
[ [ bad-recursion-3 ] infer ] must-fail
|
[ [ bad-recursion-3 ] infer ] must-fail
|
||||||
|
FORGET: bad-recursion-3
|
||||||
|
|
||||||
: bad-recursion-4 ( -- ) 4 [ dup call roll ] times ; inline recursive
|
: bad-recursion-4 ( -- ) 4 [ dup call roll ] times ; inline recursive
|
||||||
[ [ [ ] [ 1 2 3 ] over dup bad-recursion-4 ] infer ] must-fail
|
[ [ [ ] [ 1 2 3 ] over dup bad-recursion-4 ] infer ] must-fail
|
||||||
|
@ -562,6 +338,8 @@ M: object inference-invalidation-d inference-invalidation-c 2drop ;
|
||||||
|
|
||||||
[ [ unbalanced-retain-usage ] infer ] [ inference-error? ] must-fail-with
|
[ [ unbalanced-retain-usage ] infer ] [ inference-error? ] must-fail-with
|
||||||
|
|
||||||
|
FORGET: unbalanced-retain-usage
|
||||||
|
|
||||||
DEFER: eee'
|
DEFER: eee'
|
||||||
: ddd' ( ? -- ) [ f eee' ] when ; inline recursive
|
: ddd' ( ? -- ) [ f eee' ] when ; inline recursive
|
||||||
: eee' ( ? -- ) [ swap [ ] ] dip ddd' call ; inline recursive
|
: eee' ( ? -- ) [ swap [ ] ] dip ddd' call ; inline recursive
|
||||||
|
@ -588,3 +366,7 @@ DEFER: eee'
|
||||||
[ forget-test ] must-infer
|
[ forget-test ] must-infer
|
||||||
[ ] [ [ \ forget-test forget ] with-compilation-unit ] unit-test
|
[ ] [ [ \ forget-test forget ] with-compilation-unit ] unit-test
|
||||||
[ forget-test ] must-infer
|
[ forget-test ] must-infer
|
||||||
|
|
||||||
|
[ [ cond ] infer ] must-fail
|
||||||
|
[ [ bi ] infer ] must-fail
|
||||||
|
[ at ] must-infer
|
|
@ -16,17 +16,4 @@ M: callable infer ( quot -- effect )
|
||||||
#! Safe to call from inference transforms.
|
#! Safe to call from inference transforms.
|
||||||
infer effect>string print ;
|
infer effect>string print ;
|
||||||
|
|
||||||
: forget-errors ( -- )
|
|
||||||
all-words [
|
|
||||||
dup subwords [ f "cannot-infer" set-word-prop ] each
|
|
||||||
f "cannot-infer" set-word-prop
|
|
||||||
] each ;
|
|
||||||
|
|
||||||
: forget-effects ( -- )
|
|
||||||
forget-errors
|
|
||||||
all-words [
|
|
||||||
dup subwords [ f "inferred-effect" set-word-prop ] each
|
|
||||||
f "inferred-effect" set-word-prop
|
|
||||||
] each ;
|
|
||||||
|
|
||||||
"stack-checker.call-effect" require
|
"stack-checker.call-effect" require
|
|
@ -42,6 +42,7 @@ SYMBOL: literals
|
||||||
: init-inference ( -- )
|
: init-inference ( -- )
|
||||||
terminated? off
|
terminated? off
|
||||||
V{ } clone \ meta-d set
|
V{ } clone \ meta-d set
|
||||||
|
V{ } clone \ meta-r set
|
||||||
V{ } clone literals set
|
V{ } clone literals set
|
||||||
0 d-in set ;
|
0 d-in set ;
|
||||||
|
|
||||||
|
@ -64,6 +65,3 @@ SYMBOL: generic-dependencies
|
||||||
: depends-on-generic ( generic class -- )
|
: depends-on-generic ( generic class -- )
|
||||||
generic-dependencies get dup
|
generic-dependencies get dup
|
||||||
[ swap '[ _ ?class-or ] change-at ] [ 3drop ] if ;
|
[ swap '[ _ ?class-or ] change-at ] [ 3drop ] if ;
|
||||||
|
|
||||||
! Words we've inferred the stack effect of, for rollback
|
|
||||||
SYMBOL: recorded
|
|
||||||
|
|
|
@ -3,9 +3,14 @@ USING: sequences stack-checker.transforms tools.test math kernel
|
||||||
quotations stack-checker stack-checker.errors accessors combinators words arrays
|
quotations stack-checker stack-checker.errors accessors combinators words arrays
|
||||||
classes classes.tuple ;
|
classes classes.tuple ;
|
||||||
|
|
||||||
|
: compose-n ( quot n -- ) "OOPS" throw ;
|
||||||
|
|
||||||
|
<<
|
||||||
: compose-n-quot ( word n -- quot' ) <repetition> >quotation ;
|
: compose-n-quot ( word n -- quot' ) <repetition> >quotation ;
|
||||||
: compose-n ( quot n -- ) compose-n-quot call ;
|
|
||||||
\ compose-n [ compose-n-quot ] 2 define-transform
|
\ compose-n [ compose-n-quot ] 2 define-transform
|
||||||
|
\ compose-n t "no-compile" set-word-prop
|
||||||
|
>>
|
||||||
|
|
||||||
: compose-n-test ( a b c -- x ) 2 \ + compose-n ;
|
: compose-n-test ( a b c -- x ) 2 \ + compose-n ;
|
||||||
|
|
||||||
[ 6 ] [ 1 2 3 compose-n-test ] unit-test
|
[ 6 ] [ 1 2 3 compose-n-test ] unit-test
|
||||||
|
|
|
@ -10,13 +10,6 @@ stack-checker.state stack-checker.visitor stack-checker.errors
|
||||||
stack-checker.values stack-checker.recursive-state ;
|
stack-checker.values stack-checker.recursive-state ;
|
||||||
IN: stack-checker.transforms
|
IN: stack-checker.transforms
|
||||||
|
|
||||||
: give-up-transform ( word -- )
|
|
||||||
{
|
|
||||||
{ [ dup "inferred-effect" word-prop ] [ cached-infer ] }
|
|
||||||
{ [ dup recursive-word? ] [ call-recursive-word ] }
|
|
||||||
[ dup infer-word apply-word/effect ]
|
|
||||||
} cond ;
|
|
||||||
|
|
||||||
: call-transformer ( word stack quot -- newquot )
|
: call-transformer ( word stack quot -- newquot )
|
||||||
'[ _ _ with-datastack [ length 1 assert= ] [ first ] bi nip ]
|
'[ _ _ with-datastack [ length 1 assert= ] [ first ] bi nip ]
|
||||||
[ transform-expansion-error ]
|
[ transform-expansion-error ]
|
||||||
|
@ -29,7 +22,7 @@ IN: stack-checker.transforms
|
||||||
word inlined-dependency depends-on
|
word inlined-dependency depends-on
|
||||||
values [ length meta-d shorten-by ] [ #drop, ] bi
|
values [ length meta-d shorten-by ] [ #drop, ] bi
|
||||||
rstate infer-quot
|
rstate infer-quot
|
||||||
] [ word give-up-transform ] if* ;
|
] [ word infer-word ] if* ;
|
||||||
|
|
||||||
: literals? ( values -- ? ) [ literal-value? ] all? ;
|
: literals? ( values -- ? ) [ literal-value? ] all? ;
|
||||||
|
|
||||||
|
@ -41,7 +34,7 @@ IN: stack-checker.transforms
|
||||||
[ first literal recursion>> ] tri
|
[ first literal recursion>> ] tri
|
||||||
] if
|
] if
|
||||||
((apply-transform))
|
((apply-transform))
|
||||||
] [ 2drop give-up-transform ] if ;
|
] [ 2drop infer-word ] if ;
|
||||||
|
|
||||||
: apply-transform ( word -- )
|
: apply-transform ( word -- )
|
||||||
[ ] [ "transform-quot" word-prop ] [ "transform-n" word-prop ] tri
|
[ ] [ "transform-quot" word-prop ] [ "transform-n" word-prop ] tri
|
||||||
|
@ -59,6 +52,8 @@ IN: stack-checker.transforms
|
||||||
! Combinators
|
! Combinators
|
||||||
\ cond [ cond>quot ] 1 define-transform
|
\ cond [ cond>quot ] 1 define-transform
|
||||||
|
|
||||||
|
\ cond t "no-compile" set-word-prop
|
||||||
|
|
||||||
\ case [
|
\ case [
|
||||||
[
|
[
|
||||||
[ no-case ]
|
[ no-case ]
|
||||||
|
@ -71,14 +66,24 @@ IN: stack-checker.transforms
|
||||||
] if-empty
|
] if-empty
|
||||||
] 1 define-transform
|
] 1 define-transform
|
||||||
|
|
||||||
|
\ case t "no-compile" set-word-prop
|
||||||
|
|
||||||
\ cleave [ cleave>quot ] 1 define-transform
|
\ cleave [ cleave>quot ] 1 define-transform
|
||||||
|
|
||||||
|
\ cleave t "no-compile" set-word-prop
|
||||||
|
|
||||||
\ 2cleave [ 2cleave>quot ] 1 define-transform
|
\ 2cleave [ 2cleave>quot ] 1 define-transform
|
||||||
|
|
||||||
|
\ 2cleave t "no-compile" set-word-prop
|
||||||
|
|
||||||
\ 3cleave [ 3cleave>quot ] 1 define-transform
|
\ 3cleave [ 3cleave>quot ] 1 define-transform
|
||||||
|
|
||||||
|
\ 3cleave t "no-compile" set-word-prop
|
||||||
|
|
||||||
\ spread [ spread>quot ] 1 define-transform
|
\ spread [ spread>quot ] 1 define-transform
|
||||||
|
|
||||||
|
\ spread t "no-compile" set-word-prop
|
||||||
|
|
||||||
\ (call-next-method) [
|
\ (call-next-method) [
|
||||||
[
|
[
|
||||||
[ "method-class" word-prop ]
|
[ "method-class" word-prop ]
|
||||||
|
@ -90,6 +95,8 @@ IN: stack-checker.transforms
|
||||||
] bi
|
] bi
|
||||||
] 1 define-transform
|
] 1 define-transform
|
||||||
|
|
||||||
|
\ (call-next-method) t "no-compile" set-word-prop
|
||||||
|
|
||||||
! Constructors
|
! Constructors
|
||||||
\ boa [
|
\ boa [
|
||||||
dup tuple-class? [
|
dup tuple-class? [
|
||||||
|
@ -100,6 +107,9 @@ IN: stack-checker.transforms
|
||||||
] [ drop f ] if
|
] [ drop f ] if
|
||||||
] 1 define-transform
|
] 1 define-transform
|
||||||
|
|
||||||
|
\ boa t "no-compile" set-word-prop
|
||||||
|
M\ tuple-class boa t "no-compile" set-word-prop
|
||||||
|
|
||||||
\ new [
|
\ new [
|
||||||
dup tuple-class? [
|
dup tuple-class? [
|
||||||
dup inlined-dependency depends-on
|
dup inlined-dependency depends-on
|
||||||
|
|
|
@ -2,9 +2,6 @@ USING: syndication io kernel io.files tools.test io.encodings.binary
|
||||||
calendar urls xml.writer ;
|
calendar urls xml.writer ;
|
||||||
IN: syndication.tests
|
IN: syndication.tests
|
||||||
|
|
||||||
\ download-feed must-infer
|
|
||||||
\ feed>xml must-infer
|
|
||||||
|
|
||||||
: load-news-file ( filename -- feed )
|
: load-news-file ( filename -- feed )
|
||||||
#! Load an news syndication file and process it, returning
|
#! Load an news syndication file and process it, returning
|
||||||
#! it as an feed tuple.
|
#! it as an feed tuple.
|
||||||
|
|
|
@ -4,7 +4,7 @@ USING: threads kernel namespaces continuations combinators
|
||||||
sequences math namespaces.private continuations.private
|
sequences math namespaces.private continuations.private
|
||||||
concurrency.messaging quotations kernel.private words
|
concurrency.messaging quotations kernel.private words
|
||||||
sequences.private assocs models models.arrow arrays accessors
|
sequences.private assocs models models.arrow arrays accessors
|
||||||
generic generic.standard definitions make sbufs ;
|
generic generic.standard definitions make sbufs tools.crossref ;
|
||||||
IN: tools.continuations
|
IN: tools.continuations
|
||||||
|
|
||||||
<PRIVATE
|
<PRIVATE
|
||||||
|
|
|
@ -1,15 +1,57 @@
|
||||||
USING: help.markup help.syntax words definitions prettyprint ;
|
USING: help.markup help.syntax words definitions prettyprint
|
||||||
|
tools.crossref.private math quotations assocs ;
|
||||||
IN: tools.crossref
|
IN: tools.crossref
|
||||||
|
|
||||||
ARTICLE: "tools.crossref" "Cross-referencing tools"
|
ARTICLE: "tools.crossref" "Definition cross referencing"
|
||||||
|
"Definitions can answer a sequence of definitions they directly depend on:"
|
||||||
|
{ $subsection uses }
|
||||||
|
"An inverted index of the above:"
|
||||||
|
{ $subsection get-crossref }
|
||||||
|
"Words to access it:"
|
||||||
|
{ $subsection usage }
|
||||||
|
{ $subsection smart-usage }
|
||||||
|
"Tools for interactive use:"
|
||||||
{ $subsection usage. }
|
{ $subsection usage. }
|
||||||
|
{ $subsection vocab-uses. }
|
||||||
|
{ $subsection vocab-usage. }
|
||||||
{ $see-also "definitions" "words" "see" } ;
|
{ $see-also "definitions" "words" "see" } ;
|
||||||
|
|
||||||
ABOUT: "tools.crossref"
|
ABOUT: "tools.crossref"
|
||||||
|
|
||||||
|
HELP: uses
|
||||||
|
{ $values { "defspec" "a definition specifier" } { "seq" "a sequence of definition specifiers" } }
|
||||||
|
{ $description "Outputs a sequence of definitions directory called by the given definition." }
|
||||||
|
{ $notes "The sequence might include the definition itself, if it is a recursive word." }
|
||||||
|
{ $examples
|
||||||
|
"We can ask the " { $link sq } " word to produce a list of words it calls:"
|
||||||
|
{ $unchecked-example "\ sq uses ." "{ dup * }" }
|
||||||
|
} ;
|
||||||
|
|
||||||
|
HELP: crossref
|
||||||
|
{ $var-description "A graph whose vertices are definition specifiers and edges are usages. See " { $link "graphs" } ". This variable is reset to " { $link f } " every time a definition is added or removed. Call " { $link get-crossref } " to lazily construct the graph instead of using this variable directly." } ;
|
||||||
|
|
||||||
|
HELP: get-crossref
|
||||||
|
{ $values { "crossref" assoc } }
|
||||||
|
{ $description "Outputs the cross-referencing index, mapping definitions to usages, building it first if necessary." }
|
||||||
|
{ $notes "This word is used to implement " { $link usage } " and " { $link usage. } "." } ;
|
||||||
|
|
||||||
|
HELP: crossref-def
|
||||||
|
{ $values { "defspec" "a definition specifier" } }
|
||||||
|
{ $description "Adds a vertex representing this definition, along with edges representing dependencies to the " { $link crossref } " graph." }
|
||||||
|
$low-level-note ;
|
||||||
|
|
||||||
|
HELP: usage
|
||||||
|
{ $values { "defspec" "a definition specifier" } { "seq" "a sequence of definition specifiers" } }
|
||||||
|
{ $description "Outputs a sequence of definitions that directly call the given definition." }
|
||||||
|
{ $notes "The sequence might include the definition itself, if it is a recursive word." } ;
|
||||||
|
|
||||||
HELP: usage.
|
HELP: usage.
|
||||||
{ $values { "word" "a word" } }
|
{ $values { "word" "a word" } }
|
||||||
{ $description "Prints an list of all callers of a word. This may include the word itself, if it is recursive." }
|
{ $description "Prints an list of all callers of a word. This may include the word itself, if it is recursive." }
|
||||||
{ $examples { $code "\\ reverse usage." } } ;
|
{ $examples { $code "\\ reverse usage." } } ;
|
||||||
|
|
||||||
|
HELP: quot-uses
|
||||||
|
{ $values { "quot" quotation } { "assoc" "an assoc with words as keys" } }
|
||||||
|
{ $description "Outputs a set of words referenced by the quotation and any quotations it contains." } ;
|
||||||
|
|
||||||
{ usage usage. } related-words
|
{ usage usage. } related-words
|
||||||
|
|
|
@ -11,3 +11,40 @@ M: integer foo + ;
|
||||||
|
|
||||||
[ t ] [ integer \ foo method \ + usage member? ] unit-test
|
[ t ] [ integer \ foo method \ + usage member? ] unit-test
|
||||||
[ t ] [ \ foo usage [ pathname? ] any? ] unit-test
|
[ t ] [ \ foo usage [ pathname? ] any? ] unit-test
|
||||||
|
|
||||||
|
! Issues with forget
|
||||||
|
GENERIC: generic-forget-test-1 ( a b -- c )
|
||||||
|
|
||||||
|
M: integer generic-forget-test-1 / ;
|
||||||
|
|
||||||
|
[ t ] [
|
||||||
|
\ / usage [ word? ] filter
|
||||||
|
[ name>> "integer=>generic-forget-test-1" = ] any?
|
||||||
|
] unit-test
|
||||||
|
|
||||||
|
[ ] [
|
||||||
|
[ \ generic-forget-test-1 forget ] with-compilation-unit
|
||||||
|
] unit-test
|
||||||
|
|
||||||
|
[ f ] [
|
||||||
|
\ / usage [ word? ] filter
|
||||||
|
[ name>> "integer=>generic-forget-test-1" = ] any?
|
||||||
|
] unit-test
|
||||||
|
|
||||||
|
GENERIC: generic-forget-test-2 ( a b -- c )
|
||||||
|
|
||||||
|
M: sequence generic-forget-test-2 = ;
|
||||||
|
|
||||||
|
[ t ] [
|
||||||
|
\ = usage [ word? ] filter
|
||||||
|
[ name>> "sequence=>generic-forget-test-2" = ] any?
|
||||||
|
] unit-test
|
||||||
|
|
||||||
|
[ ] [
|
||||||
|
[ M\ sequence generic-forget-test-2 forget ] with-compilation-unit
|
||||||
|
] unit-test
|
||||||
|
|
||||||
|
[ f ] [
|
||||||
|
\ = usage [ word? ] filter
|
||||||
|
[ name>> "sequence=>generic-forget-test-2" = ] any?
|
||||||
|
] unit-test
|
|
@ -1,9 +1,84 @@
|
||||||
! Copyright (C) 2005, 2009 Slava Pestov.
|
! Copyright (C) 2005, 2009 Slava Pestov.
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
USING: assocs definitions io io.styles kernel prettyprint
|
USING: words assocs definitions io io.pathnames io.styles kernel
|
||||||
sorting see ;
|
prettyprint sorting see sets sequences arrays hashtables help.crossref
|
||||||
|
help.topics help.markup quotations accessors source-files namespaces
|
||||||
|
graphs vocabs generic generic.standard.engines.tuple threads
|
||||||
|
compiler.units init ;
|
||||||
IN: tools.crossref
|
IN: tools.crossref
|
||||||
|
|
||||||
|
SYMBOL: crossref
|
||||||
|
|
||||||
|
GENERIC: uses ( defspec -- seq )
|
||||||
|
|
||||||
|
<PRIVATE
|
||||||
|
|
||||||
|
GENERIC# quot-uses 1 ( obj assoc -- )
|
||||||
|
|
||||||
|
M: object quot-uses 2drop ;
|
||||||
|
|
||||||
|
M: word quot-uses over crossref? [ conjoin ] [ 2drop ] if ;
|
||||||
|
|
||||||
|
: seq-uses ( seq assoc -- ) [ quot-uses ] curry each ;
|
||||||
|
|
||||||
|
M: array quot-uses seq-uses ;
|
||||||
|
|
||||||
|
M: hashtable quot-uses [ >alist ] dip seq-uses ;
|
||||||
|
|
||||||
|
M: callable quot-uses seq-uses ;
|
||||||
|
|
||||||
|
M: wrapper quot-uses [ wrapped>> ] dip quot-uses ;
|
||||||
|
|
||||||
|
M: callable uses ( quot -- assoc )
|
||||||
|
H{ } clone [ quot-uses ] keep keys ;
|
||||||
|
|
||||||
|
M: word uses def>> uses ;
|
||||||
|
|
||||||
|
M: link uses { $subsection $link $see-also } article-links ;
|
||||||
|
|
||||||
|
M: pathname uses string>> source-file top-level-form>> uses ;
|
||||||
|
|
||||||
|
GENERIC: crossref-def ( defspec -- )
|
||||||
|
|
||||||
|
M: object crossref-def
|
||||||
|
dup uses crossref get add-vertex ;
|
||||||
|
|
||||||
|
M: word crossref-def
|
||||||
|
[ call-next-method ] [ subwords [ crossref-def ] each ] bi ;
|
||||||
|
|
||||||
|
: build-crossref ( -- crossref )
|
||||||
|
"Computing usage index... " write flush yield
|
||||||
|
H{ } clone crossref [
|
||||||
|
all-words
|
||||||
|
source-files get keys [ <pathname> ] map
|
||||||
|
[ [ crossref-def ] each ] bi@
|
||||||
|
crossref get
|
||||||
|
] with-variable
|
||||||
|
"done" print flush ;
|
||||||
|
|
||||||
|
: get-crossref ( -- crossref )
|
||||||
|
crossref global [ drop build-crossref ] cache ;
|
||||||
|
|
||||||
|
GENERIC: irrelevant? ( defspec -- ? )
|
||||||
|
|
||||||
|
M: object irrelevant? drop f ;
|
||||||
|
|
||||||
|
M: default-method irrelevant? drop t ;
|
||||||
|
|
||||||
|
M: engine-word irrelevant? drop t ;
|
||||||
|
|
||||||
|
PRIVATE>
|
||||||
|
|
||||||
|
: usage ( defspec -- seq ) get-crossref at keys ;
|
||||||
|
|
||||||
|
GENERIC: smart-usage ( defspec -- seq )
|
||||||
|
|
||||||
|
M: object smart-usage usage [ irrelevant? not ] filter ;
|
||||||
|
|
||||||
|
M: method-body smart-usage "method-generic" word-prop smart-usage ;
|
||||||
|
|
||||||
|
M: f smart-usage drop \ f smart-usage ;
|
||||||
|
|
||||||
: synopsis-alist ( definitions -- alist )
|
: synopsis-alist ( definitions -- alist )
|
||||||
[ [ synopsis ] keep ] { } map>assoc ;
|
[ [ synopsis ] keep ] { } map>assoc ;
|
||||||
|
|
||||||
|
@ -15,3 +90,34 @@ IN: tools.crossref
|
||||||
|
|
||||||
: usage. ( word -- )
|
: usage. ( word -- )
|
||||||
smart-usage sorted-definitions. ;
|
smart-usage sorted-definitions. ;
|
||||||
|
|
||||||
|
: vocab-xref ( vocab quot -- vocabs )
|
||||||
|
[ [ vocab-name ] [ words [ generic? not ] filter ] bi ] dip map
|
||||||
|
[
|
||||||
|
[ [ word? ] [ generic? not ] bi and ] filter [
|
||||||
|
dup method-body?
|
||||||
|
[ "method-generic" word-prop ] when
|
||||||
|
vocabulary>>
|
||||||
|
] map
|
||||||
|
] gather natural-sort remove sift ; inline
|
||||||
|
|
||||||
|
: vocabs. ( seq -- )
|
||||||
|
[ dup >vocab-link write-object nl ] each ;
|
||||||
|
|
||||||
|
: vocab-uses ( vocab -- vocabs ) [ uses ] vocab-xref ;
|
||||||
|
|
||||||
|
: vocab-uses. ( vocab -- ) vocab-uses vocabs. ;
|
||||||
|
|
||||||
|
: vocab-usage ( vocab -- vocabs ) [ usage ] vocab-xref ;
|
||||||
|
|
||||||
|
: vocab-usage. ( vocab -- ) vocab-usage vocabs. ;
|
||||||
|
|
||||||
|
<PRIVATE
|
||||||
|
|
||||||
|
SINGLETON: invalidate-crossref
|
||||||
|
|
||||||
|
M: invalidate-crossref definitions-changed 2drop crossref global delete-at ;
|
||||||
|
|
||||||
|
[ invalidate-crossref add-definition-observer ] "tools.crossref" add-init-hook
|
||||||
|
|
||||||
|
PRIVATE>
|
Some files were not shown because too many files have changed in this diff Show More
Loading…
Reference in New Issue