Merge branch 'master' of git://factorcode.org/git/factor

db4
John Benediktsson 2009-04-22 03:37:18 -07:00
commit ab3107d690
180 changed files with 815 additions and 1344 deletions

View File

@ -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

View File

@ -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

View File

@ -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

View File

@ -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

View File

@ -108,7 +108,7 @@ nl
"." write flush "." write flush
{ (compile) } compile-unoptimized { compile-word } compile-unoptimized
"." write flush "." write flush

View File

@ -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

View File

@ -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

View File

@ -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

View File

@ -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

View File

@ -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

View File

@ -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 ;

View File

@ -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?

View File

@ -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

View File

@ -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

View File

@ -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." } ;

View File

@ -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 ;

View File

@ -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 ;

View File

@ -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

View File

@ -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

View File

@ -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

View File

@ -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

View File

@ -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

View File

@ -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

View File

@ -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." } ;

View File

@ -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

View File

@ -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? ;

View File

@ -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

View File

@ -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*

View File

@ -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

View File

@ -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.

View File

@ -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

View File

@ -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 {

View File

@ -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 )

View File

@ -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

View File

@ -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

View File

@ -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 ] }

View File

@ -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? ].

View File

@ -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

View File

@ -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

View File

@ -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

View File

@ -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

View File

@ -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

View File

@ -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" ;

View File

@ -1 +1 @@
Doug Coleman Slava Pestov

View File

@ -0,0 +1 @@
unportable

View File

@ -43,8 +43,6 @@ WHERE
>> >>
\ sqsq must-infer
[ 16 ] [ 2 sqsq ] unit-test [ 16 ] [ 2 sqsq ] unit-test
<< <<

View File

@ -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

View File

@ -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

View File

@ -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

View File

@ -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

View File

@ -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

View File

@ -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

View File

@ -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 ;

View File

@ -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

View File

@ -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 -- )

View File

@ -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

View File

@ -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 ;

View File

@ -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

View File

@ -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

View File

@ -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

View File

@ -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

View File

@ -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

View File

@ -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>

View File

@ -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

View File

@ -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" =

View File

@ -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

View File

@ -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 ;

View File

@ -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

View File

@ -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

View File

@ -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

View File

@ -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 ;

View File

@ -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

View File

@ -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

View File

@ -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

View File

@ -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 ;

View File

@ -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

View File

@ -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

View File

@ -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
[ [

View File

@ -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

View File

@ -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

View File

@ -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

View File

@ -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

View File

@ -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

View File

@ -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

View File

@ -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

View File

@ -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 ;

View File

@ -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

View File

@ -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 -- )

View File

@ -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 ;

View File

@ -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." } ;

View File

@ -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

View File

@ -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

View File

@ -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

View File

@ -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

View File

@ -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

View File

@ -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.

View File

@ -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

View File

@ -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

View File

@ -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

View File

@ -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