steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

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

db4
John Benediktsson 2009-04-22 03:37:18 -07:00
parent d8a384ec60 caf6f280ea
commit ab3107d690
180 changed files with 815 additions and 1344 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
basis/alarms/alarms-tests.factor
View File

@ -15,5 +15,3 @@ tools.test threads concurrency.count-downs ;
[ resume ] curry instant later drop
] "test" suspend drop
] unit-test
\ alarm-thread-loop must-infer

2
basis/alien/c-types/c-types-tests.factor
View File

@ -2,8 +2,6 @@ IN: alien.c-types.tests
USING: alien alien.syntax alien.c-types kernel tools.test
sequences system libc alien.strings io.encodings.utf8 ;
\ expand-constants must-infer
CONSTANT: xyz 123
[ { "blah" 123 } ] [ { "blah" xyz } expand-constants ] unit-test

3
basis/base64/base64-tests.factor
View File

@ -25,6 +25,3 @@ IN: base64.tests
[ { 33 52 17 40 12 51 33 43 18 33 23 } base64> ]
[ malformed-base64? ] must-fail-with
\ >base64 must-infer
\ base64> must-infer

2
basis/binary-search/binary-search-tests.factor
View File

@ -1,8 +1,6 @@
IN: binary-search.tests
USING: binary-search math.order vectors kernel tools.test ;
\ sorted-member? must-infer
[ f ] [ 3 { } [ <=> ] with search drop ] unit-test
[ 0 ] [ 3 { 3 } [ <=> ] with search drop ] unit-test
[ 1 ] [ 2 { 1 2 3 } [ <=> ] with search drop ] unit-test

2
basis/bootstrap/compiler/compiler.factor
View File

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

3
basis/bootstrap/image/image-tests.factor
View File

@ -2,9 +2,6 @@ IN: bootstrap.image.tests
USING: bootstrap.image bootstrap.image.private tools.test
kernel math ;
\ ' must-infer
\ write-image must-infer
[ f ] [ { 1 2 3 } [ 1 2 3 ] eql? ] unit-test
[ t ] [ [ 1 2 3 ] [ 1 2 3 ] eql? ] unit-test

11
basis/bootstrap/stage2.factor
View File

@ -16,13 +16,6 @@ SYMBOL: bootstrap-time
vm file-name os windows? [ "." split1-last drop ] when
".image" append resource-path ;
: do-crossref ( -- )
"Cross-referencing..." print flush
H{ } clone crossref set-global
xref-words
xref-generics
xref-sources ;
: load-components ( -- )
"include" "exclude"
[ get-global " " split harvest ] bi@
@ -68,8 +61,6 @@ SYMBOL: bootstrap-time
(command-line) parse-command-line
do-crossref
! Set dll paths
os wince? [ "windows.ce" require ] when
os winnt? [ "windows.nt" require ] when
@ -78,6 +69,8 @@ SYMBOL: bootstrap-time
"stage2: deployment mode" print
] [
"listener" require
"debugger" require
"tools.errors" require
"none" require
] if

4
basis/calendar/calendar-tests.factor
View File

@ -2,10 +2,6 @@ USING: arrays calendar kernel math sequences tools.test
continuations system math.order threads ;
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 2 30 0 0 0 instant <timestamp> valid-timestamp? ] unit-test
[ f ] [ 2003 2 29 0 0 0 instant <timestamp> valid-timestamp? ] unit-test

2
basis/calendar/format/macros/macros-tests.factor
View File

@ -10,6 +10,6 @@ IN: calendar.format.macros
: compiled-test-1 ( -- n )
{ [ 1 throw ] [ 2 ] } attempt-all-quots ;
\ compiled-test-1 must-infer
\ compiled-test-1 def>> must-infer
[ 2 ] [ compiled-test-1 ] unit-test

2
basis/combinators/smart/smart-tests.factor
View File

@ -42,7 +42,7 @@ IN: combinators.smart.tests
: nested-smart-combo-test ( -- 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

2
basis/compiler/cfg/builder/builder-tests.factor
View File

@ -5,8 +5,6 @@ math.private compiler.tree.builder compiler.tree.optimizer
compiler.cfg.builder compiler.cfg.debugger arrays locals byte-arrays
kernel.private math ;
\ build-cfg must-infer
! Just ensure that various CFGs build correctly.
: unit-test-cfg ( quot -- ) '[ _ test-cfg drop ] [ ] swap unit-test ;

2
basis/compiler/cfg/debugger/debugger.factor
View File

@ -16,7 +16,7 @@ M: callable test-cfg
build-tree optimize-tree gensym build-cfg ;
M: word test-cfg
[ build-tree-from-word optimize-tree ] keep build-cfg ;
[ build-tree optimize-tree ] keep build-cfg ;
SYMBOL: allocate-registers?

2
basis/compiler/cfg/linear-scan/assignment/assignment-tests.factor
View File

@ -1,4 +1,4 @@
USING: compiler.cfg.linear-scan.assignment tools.test ;
IN: compiler.cfg.linear-scan.assignment.tests
\ assign-registers must-infer

2
basis/compiler/cfg/linearization/linearization-tests.factor
View File

@ -1,4 +1,4 @@
IN: compiler.cfg.linearization.tests
USING: compiler.cfg.linearization tools.test ;
\ build-mr must-infer

8
basis/compiler/compiler-docs.factor
View File

@ -27,12 +27,12 @@ $nl
{ $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 } "."
$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
{ "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." }
{ "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."
$nl
@ -60,7 +60,7 @@ HELP: decompile
{ $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." } ;
HELP: (compile)
HELP: compile-word
{ $values { "word" word } }
{ $description "Compile a single word." }
{ $notes "This is an internal word, and user code should call " { $link compile } " instead." } ;

108
basis/compiler/compiler.factor
View File

@ -15,6 +15,7 @@ SYMBOL: compile-queue
SYMBOL: compiled
: queue-compile? ( word -- ? )
#! Don't attempt to compile certain words.
{
[ "forgotten" word-prop ]
[ compiled get key? ]
@ -25,26 +26,14 @@ SYMBOL: compiled
: queue-compile ( word -- )
dup queue-compile? [ compile-queue get push-front ] [ drop ] if ;
: maybe-compile ( word -- )
dup optimized>> [ drop ] [ queue-compile ] if ;
: recompile-callers? ( word -- ? )
changed-effects get key? ;
SYMBOLS: +optimized+ +unoptimized+ ;
: ripple-up ( words -- )
dup "compiled-status" word-prop +unoptimized+ eq?
[ usage [ word? ] filter ] [ compiled-usage keys ] 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 ;
: recompile-callers ( words -- )
#! If a word's stack effect changed, recompile all words that
#! have compiled calls to it.
dup recompile-callers?
[ compiled-usage keys [ queue-compile ] each ] [ drop ] if ;
: start ( word -- )
"trace-compilation" get [ dup name>> print flush ] when
@ -53,39 +42,72 @@ SYMBOLS: +optimized+ +unoptimized+ ;
f swap compiler-error ;
: ignore-error? ( word error -- ? )
#! Ignore warnings on inline combinators, macros, and special
#! words such as 'call'.
[
{
[ inline? ]
[ macro? ]
[ "transform-quot" word-prop ]
[ "no-compile" word-prop ]
[ inline? ]
[ "special" word-prop ]
[ "no-compile" word-prop ]
} 1||
] [ 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 ]
[ f swap compiled get set-at ]
[ +unoptimized+ save-compiled-status ]
tri
return ;
[
dup crossref? [
dependencies get
generic-dependencies get
compiled-xref
] [ drop ] if
] tri ;
: fail ( word error -- * )
[ 2dup ignore-error? [ drop f ] when swap compiler-error ] [ drop (fail) ] 2bi ;
: deoptimize-with ( word def -- * )
#! 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 )
dup contains-breakpoints? [ (fail) ] [
[ build-tree-from-word ] [ fail ] recover optimize-tree
#! If the word contains breakpoints, don't optimize it, since
#! the walker does not support this.
dup contains-breakpoints? [ dup def>> deoptimize-with ] [
[ build-tree ] [ deoptimize ] recover optimize-tree
] 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.
SYMBOL: compile-dependencies?
t compile-dependencies? set-global
: compile-dependencies ( asm -- )
compile-dependencies? get
[ calls>> [ compile-dependency ] each ] [ drop ] if ;
: save-asm ( asm -- )
[ [ code>> ] [ label>> ] bi compiled get set-at ]
[ compile-dependencies? get [ calls>> [ maybe-compile ] each ] [ drop ] if ]
[ compile-dependencies ]
bi ;
: backend ( nodes word -- )
@ -99,19 +121,9 @@ t compile-dependencies? set-global
save-asm
] each ;
: finish ( word -- )
[ +optimized+ save-compiled-status ]
[ compiled-unxref ]
[
dup crossref?
[
dependencies get
generic-dependencies get
compiled-xref
] [ drop ] if
] tri ;
: (compile) ( word -- )
: compile-word ( word -- )
#! We return early if the word has breakpoints or if it
#! failed to infer.
'[
_ {
[ start ]
@ -122,10 +134,10 @@ t compile-dependencies? set-global
] with-return ;
: compile-loop ( deque -- )
[ (compile) yield-hook get call( -- ) ] slurp-deque ;
[ compile-word yield-hook get call( -- ) ] slurp-deque ;
: decompile ( word -- )
f 2array 1array modify-code-heap ;
dup def>> 2array 1array modify-code-heap ;
: compile-call ( quot -- )
[ dup infer define-temp ] with-compilation-unit execute ;
@ -150,4 +162,4 @@ M: optimizing-compiler recompile ( words -- alist )
f compiler-impl set-global ;
: recompile-all ( -- )
forget-errors all-words compile ;
all-words compile ;

2
basis/compiler/errors/errors.factor
View File

@ -52,3 +52,5 @@ T{ error-type
: compiler-error ( error word -- )
compiler-errors get-global pick
[ [ [ <compiler-error> ] keep ] dip set-at ] [ delete-at drop ] if ;
ERROR: not-compiled word error ;

5
basis/compiler/tests/insane.factor
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

8
basis/compiler/tests/optimizer.factor
View File

@ -261,7 +261,7 @@ USE: binary-search.private
: lift-loop-tail-test-2 ( -- a b c )
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
@ -302,8 +302,8 @@ HINTS: recursive-inline-hang-3 array ;
: member-test ( obj -- ? ) { + - * / /i } member? ;
\ member-test must-infer
[ ] [ \ member-test build-tree-from-word optimize-tree drop ] unit-test
\ member-test def>> must-infer
[ ] [ \ member-test build-tree optimize-tree drop ] unit-test
[ t ] [ \ + 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 "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
[ 2 3 ] [ 2 interval-inference-bug ] unit-test

107
basis/compiler/tests/redefine0.factor Normal file
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

38
basis/compiler/tests/redefine1.factor
View File

@ -36,41 +36,3 @@ M: integer method-redefine-generic-2 3 + ;
fixnum string [ \ method-redefine-generic-2 method forget ] bi@
] with-compilation-unit
] 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

3
basis/compiler/tests/redefine16.factor
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 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
[ "blah" "compiler.tests.redefine16" lookup 1quotation infer ] must-fail
[ ] [ [ "blah" "compiler.tests.redefine16" lookup forget ] with-compilation-unit ] unit-test

2
basis/compiler/tests/simple.factor
View File

@ -3,8 +3,6 @@ sequences.private math.private math combinators strings alien
arrays memory vocabs parser eval ;
IN: compiler.tests
\ (compile) must-infer
! Test empty word
[ ] [ [ ] compile-call ] unit-test

9
basis/compiler/tree/builder/builder-docs.factor
View File

@ -3,12 +3,11 @@ compiler.tree stack-checker.errors ;
IN: compiler.tree.builder
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." }
{ $notes "This is the first stage of the compiler." }
{ $errors "Throws an " { $link inference-error } " if stack effect inference fails." } ;
HELP: build-tree-with
{ $values { "in-stack" "a sequence of values" } { "quot" quotation } { "nodes" "a sequence of nodes" } { "out-stack" "a sequence of values" } }
{ $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." }
{ $errors "Throws an " { $link inference-error } " if stack effect inference fails." } ;
HELP: build-sub-tree
{ $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 from the call site. Outputs " { $link f } " if stack effect inference fails." } ;

28
basis/compiler/tree/builder/builder-tests.factor
View File

@ -1,11 +1,27 @@
IN: compiler.tree.builder.tests
USING: compiler.tree.builder tools.test sequences kernel
compiler.tree ;
\ build-tree must-infer
\ build-tree-with must-infer
\ build-tree-from-word must-infer
compiler.tree stack-checker stack-checker.errors ;
: 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

95
basis/compiler/tree/builder/builder.factor
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.
USING: fry accessors quotations kernel sequences namespaces
assocs words arrays vectors hints combinators compiler.tree
USING: fry locals accessors quotations kernel sequences namespaces
assocs words arrays vectors hints combinators continuations
effects compiler.tree
stack-checker
stack-checker.state
stack-checker.errors
@ -10,54 +11,60 @@ stack-checker.backend
stack-checker.recursive-state ;
IN: compiler.tree.builder
: with-tree-builder ( quot -- nodes )
'[ V{ } clone stack-visitor set @ ]
with-infer nip ; inline
<PRIVATE
: build-tree ( quot -- nodes )
#! Not safe to call from inference transforms.
[ f initial-recursive-state infer-quot ] with-tree-builder ;
GENERIC: (build-tree) ( quot -- )
: build-tree-with ( in-stack quot -- nodes out-stack )
#! 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 ;
M: callable (build-tree) f initial-recursive-state infer-quot ;
: 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 ]
[ (build-tree-from-word) ]
[ finish-word ]
} cleave
] maybe-cannot-infer
] with-tree-builder ;
[ word-body infer-quot-here ]
[ current-effect check-effect ]
} cleave ;
: 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 -- ? )
def>> [ word? ] filter [ "break?" word-prop ] any? ;

2
basis/compiler/tree/checker/checker-tests.factor
View File

@ -1,4 +1,4 @@
IN: compiler.tree.checker.tests
USING: compiler.tree.checker tools.test ;
\ check-nodes must-infer

12
basis/compiler/tree/checker/checker.factor
View File

@ -144,13 +144,15 @@ M: #terminate check-stack-flow*
SYMBOL: branch-out
: check-branch ( nodes -- stack )
: check-branch ( nodes -- datastack )
[
datastack [ clone ] change
V{ } clone retainstack set
(check-stack-flow)
terminated? get [ assert-retainstack-empty ] unless
terminated? get f datastack get ?
retainstack [ clone ] change
retainstack get clone [ (check-stack-flow) ] dip
terminated? get [ drop f ] [
retainstack get assert=
datastack get
] if
] with-scope ;
M: #branch check-stack-flow*

2
basis/compiler/tree/dead-code/dead-code-tests.factor
View File

@ -9,8 +9,6 @@ accessors combinators io prettyprint words sequences.deep
sequences.private arrays classes kernel.private ;
IN: compiler.tree.dead-code.tests
\ remove-dead-code must-infer
: count-live-values ( quot -- n )
build-tree
analyze-recursive

3
basis/compiler/tree/debugger/debugger-tests.factor
View File

@ -1,8 +1,5 @@
IN: compiler.tree.debugger.tests
USING: compiler.tree.debugger tools.test sorting sequences io math.order ;
\ optimized. must-infer
\ optimizer-report. must-infer
[ [ <=> ] sort ] optimized.
[ <reversed> [ print ] each ] optimizer-report.

3
basis/compiler/tree/debugger/debugger.factor
View File

@ -142,8 +142,7 @@ SYMBOL: node-count
: make-report ( word/quot -- assoc )
[
dup word? [ build-tree-from-word ] [ build-tree ] if
optimize-tree
build-tree optimize-tree
H{ } clone words-called set
H{ } clone generics-called set

2
basis/compiler/tree/def-use/def-use-tests.factor
View File

@ -7,8 +7,6 @@ compiler.tree.def-use arrays kernel.private sorting math.order
binary-search compiler.tree.checker ;
IN: compiler.tree.def-use.tests
\ compute-def-use must-infer
[ t ] [
[ 1 2 3 ] build-tree compute-def-use drop
def-use get {

2
basis/compiler/tree/escape-analysis/escape-analysis-tests.factor
View File

@ -11,8 +11,6 @@ compiler.tree.propagation.info stack-checker.errors
compiler.tree.checker
kernel.private ;
\ escape-analysis must-infer
GENERIC: count-unboxed-allocations* ( m node -- n )
: (count-unboxed-allocations) ( m node -- n )

3
basis/compiler/tree/normalization/normalization-tests.factor
View File

@ -6,9 +6,6 @@ compiler.tree.normalization.renaming
compiler.tree compiler.tree.checker
sequences accessors tools.test kernel math ;
\ count-introductions must-infer
\ normalize must-infer
[ 3 ] [ [ 3drop 1 2 3 ] build-tree count-introductions ] unit-test
[ 4 ] [ [ 3drop 1 2 3 3drop drop ] build-tree count-introductions ] unit-test

2
basis/compiler/tree/optimizer/optimizer-tests.factor
View File

@ -1,4 +1,4 @@
USING: compiler.tree.optimizer tools.test ;
IN: compiler.tree.optimizer.tests
\ optimize-tree must-infer

54
basis/compiler/tree/propagation/inlining/inlining.factor
View File

@ -4,6 +4,7 @@ USING: accessors kernel arrays sequences math math.order
math.partial-dispatch generic generic.standard generic.math
classes.algebra classes.union sets quotations assocs combinators
words namespaces continuations classes fry combinators.smart hints
locals
compiler.tree
compiler.tree.builder
compiler.tree.recursive
@ -27,24 +28,34 @@ SYMBOL: node-count
SYMBOL: inlining-count
! Splicing nodes
GENERIC: splicing-nodes ( #call word/quot/f -- nodes )
M: word splicing-nodes
: splicing-call ( #call word -- nodes )
[ [ in-d>> ] [ out-d>> ] bi ] dip #call 1array ;
M: callable splicing-nodes
build-sub-tree analyze-recursive normalize ;
: splicing-body ( #call quot/word -- nodes/f )
build-sub-tree dup [ analyze-recursive normalize ] when ;
! 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 -- ? )
dup [
[ >>class ] dip
over method>> over = [ drop ] [
2dup splicing-nodes
[ >>method ] [ >>body ] bi*
over method>> over = [ drop propagate-body ] [
2dup splicing-nodes dup [
[ >>method ] [ >>body ] bi* propagate-body
] [ 2drop undo-inlining ] if
] if
body>> (propagate) t
] [ 2drop f >>method f >>body f >>class drop f ] if ;
] [ 2drop undo-inlining ] if ;
: inlining-standard-method ( #call word -- class/f method/f )
dup "methods" word-prop assoc-empty? [ 2drop f f ] [
@ -159,19 +170,17 @@ SYMBOL: history
[ history [ swap suffix ] change ]
bi ;
: inline-word-def ( #call word quot -- ? )
over history get memq? [ 3drop f ] [
:: inline-word ( #call word -- ? )
word history get memq? [ f ] [
#call word splicing-body [
[
[ remember-inlining ] dip
[ drop ] [ splicing-nodes ] 2bi
[ >>body drop ] [ count-nodes ] [ (propagate) ] tri
] with-scope node-count +@
t
word remember-inlining
[ ] [ count-nodes ] [ (propagate) ] tri
] with-scope
[ #call (>>body) ] [ node-count +@ ] bi* t
] [ f ] if*
] if ;
: inline-word ( #call word -- ? )
dup specialized-def inline-word-def ;
: inline-method-body ( #call word -- ? )
2dup should-inline? [ inline-word ] [ 2drop f ] if ;
@ -191,10 +200,6 @@ SYMBOL: history
call( #call -- word/quot/f )
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 -- ? )
#! If the generic was defined in an outer compilation unit,
#! then it doesn't have a definition yet; the definition
@ -206,7 +211,6 @@ SYMBOL: history
#! discouraged, but it should still work.)
{
{ [ dup never-inline-word? ] [ 2drop f ] }
{ [ dup \ instance? eq? ] [ inline-instance-check ] }
{ [ dup always-inline-word? ] [ inline-word ] }
{ [ dup standard-generic? ] [ inline-standard-method ] }
{ [ dup math-generic? ] [ inline-math-method ] }

5
basis/compiler/tree/propagation/known-words/known-words.factor
View File

@ -341,6 +341,11 @@ generic-comparison-ops [
] [ 2drop object-info ] if
] "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? [
! If first input has a known type and second input is an
! object, we convert this to [ swap equal? ].

2
basis/compiler/tree/propagation/propagation-tests.factor
View File

@ -12,8 +12,6 @@ specialized-arrays.double system sorting math.libm
math.intervals ;
IN: compiler.tree.propagation.tests
\ propagate must-infer
[ V{ } ] [ [ ] final-classes ] unit-test
[ V{ fixnum } ] [ [ 1 ] final-classes ] unit-test

6
basis/compiler/tree/recursive/recursive-tests.factor
View File

@ -10,8 +10,6 @@ compiler.tree.combinators ;
[ { 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
\ analyze-recursive must-infer
: label-is-loop? ( nodes word -- ? )
[
{
@ -21,8 +19,6 @@ compiler.tree.combinators ;
} 2&&
] curry contains-node? ;
\ label-is-loop? must-infer
: label-is-not-loop? ( nodes word -- ? )
[
{
@ -32,8 +28,6 @@ compiler.tree.combinators ;
} 2&&
] curry contains-node? ;
\ label-is-not-loop? must-infer
: loop-test-1 ( a -- )
dup [ 1+ loop-test-1 ] [ drop ] if ; inline recursive

2
basis/compiler/tree/tuple-unboxing/tuple-unboxing-tests.factor
View File

@ -8,8 +8,6 @@ compiler.tree.def-use kernel accessors sequences math
math.private sorting math.order binary-search sequences.private
slots.private ;
\ unbox-tuples must-infer
: test-unboxing ( quot -- )
build-tree
analyze-recursive

2
basis/db/pools/pools-tests.factor
View File

@ -2,8 +2,6 @@ IN: db.pools.tests
USING: db.pools tools.test continuations io.files io.files.temp
io.directories namespaces accessors kernel math destructors ;
\ <db-pool> must-infer
{ 1 0 } [ [ ] with-db-pool ] must-infer-as
{ 1 0 } [ [ ] with-pooled-db ] must-infer-as

11
basis/db/tuples/tuples-tests.factor
View File

@ -592,17 +592,6 @@ string-encoding-test "STRING_ENCODING_TEST" {
[ test-string-encoding ] test-sqlite
[ 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 ( -- )
[ ] [ exam ensure-table ] unit-test
[ ] [ 1000 [ random-exam insert-tuple ] times ] unit-test

10
basis/debugger/debugger.factor
View File

@ -126,14 +126,14 @@ HOOK: signal-error. os ( obj -- )
: primitive-error. ( error -- )
"Unimplemented primitive" print drop ;
PREDICATE: kernel-error < array
PREDICATE: vm-error < array
{
{ [ dup empty? ] [ drop f ] }
{ [ dup first "kernel-error" = not ] [ drop f ] }
[ second 0 15 between? ]
} cond ;
: kernel-errors ( error -- n errors )
: vm-errors ( error -- n errors )
second {
{ 0 [ expired-error. ] }
{ 1 [ io-error. ] }
@ -153,9 +153,11 @@ PREDICATE: kernel-error < array
{ 15 [ memory-error. ] }
} ; 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
drop "No suitable method" ;

2
basis/editors/emacs/windows/authors.txt
View File

@ -1 +1 @@
Doug Coleman
Slava Pestov

1
basis/editors/emacs/windows/tags.txt Normal file
View File

@ -0,0 +1 @@
unportable

2
basis/functors/functors-tests.factor
View File

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

3
basis/furnace/auth/auth-tests.factor
View File

@ -1,6 +1,3 @@
USING: furnace.auth tools.test ;
IN: furnace.auth.tests
\ logged-in-username must-infer
\ <protected> must-infer
\ new-realm must-infer

2
basis/furnace/auth/features/edit-profile/edit-profile-tests.factor
View File

@ -1,4 +1,4 @@
IN: furnace.auth.features.edit-profile.tests
USING: tools.test furnace.auth.features.edit-profile ;
\ allow-edit-profile must-infer

2
basis/furnace/auth/features/recover-password/recover-password-tests.factor
View File

@ -1,4 +1,4 @@
IN: furnace.auth.features.recover-password
USING: tools.test furnace.auth.features.recover-password ;
\ allow-password-recovery must-infer

2
basis/furnace/auth/features/registration/registration-tests.factor
View File

@ -1,4 +1,4 @@
IN: furnace.auth.features.registration.tests
USING: tools.test furnace.auth.features.registration ;
\ allow-registration must-infer

2
basis/furnace/auth/login/login-tests.factor
View File

@ -1,4 +1,4 @@
IN: furnace.auth.login.tests
USING: tools.test furnace.auth.login ;
\ <login-realm> must-infer

2
basis/furnace/db/db-tests.factor
View File

@ -1,4 +1,4 @@
IN: furnace.db.tests
USING: tools.test furnace.db ;
\ <db-persistence> must-infer

5
basis/help/crossref/crossref-docs.factor
View File

@ -17,8 +17,3 @@ HELP: xref-article
{ $values { "topic" "an article name or a word" } }
{ $description "Sets the " { $link article-parent } " of each child of this article." }
$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 ;

10
basis/help/crossref/crossref.factor
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.
USING: arrays definitions generic assocs math fry
io kernel namespaces prettyprint prettyprint.sections
@ -12,9 +12,6 @@ IN: help.crossref
: article-children ( topic -- seq )
{ $subsection } article-links ;
M: link uses
{ $subsection $link $see-also } article-links ;
: help-path ( topic -- seq )
[ article-parent ] follow rest ;
@ -22,10 +19,7 @@ M: link uses
article-children [ set-article-parent ] with each ;
: xref-article ( topic -- )
dup >link xref dup set-article-parents ;
: unxref-article ( topic -- )
>link unxref ;
dup set-article-parents ;
: prev/next ( obj seq n -- obj' )
[ [ index dup ] keep ] dip swap

6
basis/help/help.factor
View File

@ -156,10 +156,7 @@ help-hook [ [ print-topic ] ] initialize
error get (:help) ;
: remove-article ( name -- )
dup articles get key? [
dup unxref-article
dup articles get delete-at
] when drop ;
articles get delete-at ;
: add-article ( article name -- )
[ remove-article ] keep
@ -167,7 +164,6 @@ help-hook [ [ print-topic ] ] initialize
xref-article ;
: remove-word-help ( word -- )
dup word-help [ dup unxref-article ] when
f "help" set-word-prop ;
: set-word-help ( content word -- )

2
basis/help/markup/markup-tests.factor
View File

@ -26,5 +26,3 @@ TUPLE: blahblah quux ;
[ "a string, a fixnum, or an integer" ]
[ [ { $or string fixnum integer } print-element ] with-string-writer ] unit-test
\ print-element must-infer
\ print-topic must-infer

4
basis/help/markup/markup.factor
View File

@ -138,7 +138,7 @@ ALIAS: $slot $snippet
! Images
: $image ( element -- )
[ [ "" ] dip first image associate format ] ($span) ;
[ first write-image ] ($span) ;
: <$image> ( path -- element )
1array \ $image prefix ;
@ -251,7 +251,7 @@ M: word ($instance)
dup name>> a/an write bl ($link) ;
M: string ($instance)
dup a/an write bl $snippet ;
write ;
M: f ($instance)
drop { f } $link ;

5
basis/help/topics/topics-tests.factor
View File

@ -3,11 +3,6 @@ help.markup help.syntax kernel sequences tools.test words parser
namespaces assocs source-files eval ;
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 B" { "Hello world." } <article> { "test" "b" } add-article ] unit-test

23
basis/hints/hints.factor
View File

@ -2,9 +2,9 @@
! See http://factorcode.org/license.txt for BSD license.
USING: parser words definitions kernel sequences assocs arrays
kernel.private fry combinators accessors vectors strings sbufs
byte-arrays byte-vectors io.binary io.streams.string splitting
math math.parser generic generic.standard generic.standard.engines classes
hashtables ;
byte-arrays byte-vectors io.binary io.streams.string splitting math
math.parser generic generic.standard generic.standard.engines classes
hashtables namespaces ;
IN: hints
GENERIC: specializer-predicate ( spec -- quot )
@ -37,13 +37,18 @@ M: object specializer-declaration class ;
: specialize-quot ( quot specializer -- quot' )
specializer-cases alist>quot ;
: method-declaration ( method -- quot )
[ "method-generic" word-prop dispatch# object <array> ]
[ "method-class" word-prop ]
bi prefix ;
! compiler.tree.propagation.inlining sets this to f
SYMBOL: specialize-method?
t specialize-method? set-global
: 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
[ specialize-quot ] when* ;
@ -65,7 +70,7 @@ M: object specializer-declaration class ;
SYNTAX: HINTS:
scan-object
[ redefined ]
[ changed-definition ]
[ parse-definition "specializer" set-word-prop ] bi ;
! Default specializers

2
basis/html/components/components-tests.factor
View File

@ -4,8 +4,6 @@ io.streams.null accessors inspector html.streams
html.components html.forms namespaces
xml.writer ;
\ render must-infer
[ ] [ begin-form ] unit-test
[ ] [ 3 "hi" set-value ] unit-test

2
basis/http/client/client-tests.factor
View File

@ -1,8 +1,6 @@
USING: http.client http.client.private http tools.test
namespaces urls ;
\ download must-infer
[ "localhost" f ] [ "localhost" parse-host ] unit-test
[ "localhost" 8888 ] [ "localhost:8888" parse-host ] unit-test

2
basis/http/server/dispatchers/dispatchers-tests.factor
View File

@ -3,8 +3,6 @@ tools.test kernel namespaces accessors io http math sequences
assocs arrays classes words urls ;
IN: http.server.dispatchers.tests
\ find-responder must-infer
TUPLE: mock-responder path ;
C: <mock-responder> mock-responder

2
basis/http/server/redirection/redirection-tests.factor
View File

@ -2,8 +2,6 @@ IN: http.server.redirection.tests
USING: http http.server.redirection urls accessors
namespaces tools.test present kernel ;
\ relative-to-request must-infer
[
<request>
<url>

2
basis/http/server/server-tests.factor
View File

@ -4,8 +4,6 @@ IN: http.server.tests
[ t ] [ [ \ + first ] [ <500> ] recover response? ] unit-test
\ make-http-error must-infer
[ "text/plain; charset=UTF-8" ] [
<response>
"text/plain" >>content-type

3
basis/io/files/info/info-tests.factor
View File

@ -3,9 +3,6 @@ io.directories kernel io.pathnames accessors tools.test
sequences io.files.temp ;
IN: io.files.info.tests
\ file-info must-infer
\ link-info must-infer
[ t ] [
temp-directory [ "hi41" "test41" utf8 set-file-contents ] with-directory
temp-directory "test41" append-path utf8 file-contents "hi41" =

3
basis/io/launcher/launcher-tests.factor
View File

@ -1,6 +1,3 @@
IN: io.launcher.tests
USING: tools.test io.launcher ;
\ <process-stream> must-infer
\ <process-reader> must-infer
\ <process-writer> must-infer

2
basis/io/monitors/recursive/recursive-tests.factor
View File

@ -4,8 +4,6 @@ concurrency.mailboxes tools.test destructors io.files.info
io.pathnames io.files.temp io.directories.hierarchy ;
IN: io.monitors.recursive.tests
\ pump-thread must-infer
SINGLETON: mock-io-backend
TUPLE: counter i ;

2
basis/io/monitors/windows/nt/nt-tests.factor
View File

@ -1,4 +1,4 @@
IN: io.monitors.windows.nt.tests
USING: io.monitors.windows.nt tools.test ;
\ fill-queue-thread must-infer

1
basis/io/sockets/secure/unix/unix-tests.factor
View File

@ -5,7 +5,6 @@ io.backend.unix classes words destructors threads tools.test
concurrency.promises byte-arrays locals calendar io.timeouts
io.sockets.secure.unix.debug ;
\ <secure-config> must-infer
{ 1 0 } [ [ ] with-secure-context ] must-infer-as
[ ] [ <promise> "port" set ] unit-test

6
basis/io/styles/styles-tests.factor
View File

@ -1,8 +1,2 @@
IN: io.styles.tests
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

2
basis/io/styles/styles.factor
View File

@ -156,3 +156,5 @@ M: input summary
] "" make ;
: write-object ( str obj -- ) presented associate format ;
: write-image ( image -- ) [ "" ] dip image associate format ;

4
basis/lcs/lcs-tests.factor
View File

@ -2,10 +2,6 @@
! See http://factorcode.org/license.txt for BSD license.
USING: tools.test lcs ;
\ lcs must-infer
\ diff must-infer
\ levenshtein must-infer
[ 3 ] [ "sitting" "kitten" levenshtein ] unit-test
[ 3 ] [ "kitten" "sitting" levenshtein ] unit-test
[ 1 ] [ "freshpak" "freshpack" levenshtein ] unit-test

6
basis/locals/backend/backend-tests.factor
View File

@ -1,14 +1,14 @@
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 must-infer
\ get-local-test-1 def>> must-infer
[ 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 must-infer
\ get-local-test-2 def>> must-infer
[ 3 ] [ get-local-test-2 ] unit-test

45
basis/locals/locals-tests.factor
View File

@ -43,8 +43,8 @@ IN: locals.tests
[ { 1 2 } ] [ 2 let-test-4 ] unit-test
:: let-test-5 ( a -- b )
a [let | a [ ] b [ ] | a b 2array ] ;
:: let-test-5 ( a b -- b )
a b [let | a [ ] b [ ] | a b 2array ] ;
[ { 2 1 } ] [ 1 2 let-test-5 ] unit-test
@ -129,7 +129,8 @@ write-test-2 "q" set
SYMBOL: a
:: use-test ( a b c -- a b c )
USE: kernel ;
USE: kernel
a b c ;
[ 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
:: 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
] unit-test
@ -286,7 +287,7 @@ M:: sequence method-with-locals ( a -- y ) a reverse ;
{ [ a b > ] [ 5 ] }
} cond ;
\ cond-test must-infer
\ cond-test def>> must-infer
[ 3 ] [ 1 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 -- ? )
{ [ a integer? ] [ a even? ] [ a 10 > ] } 0&& ;
\ 0&&-test must-infer
\ 0&&-test def>> must-infer
[ f ] [ 1.5 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 -- ? )
{ [ a integer? ] [ a even? ] [ a 10 > ] } && ;
\ &&-test must-infer
\ &&-test def>> must-infer
[ f ] [ 1.5 &&-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
@ -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
@ -388,7 +389,7 @@ ERROR: punned-class x ;
{ 5 [ a a ^ ] }
} case ;
\ big-case-test must-infer
\ big-case-test def>> must-infer
[ 9 ] [ 3 big-case-test ] unit-test
@ -400,7 +401,7 @@ ERROR: punned-class x ;
[| x | x 12 + { "howdy" } nth ]
} 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 ] unit-test
@ -412,7 +413,7 @@ ERROR: punned-class x ;
[| x | x a - { "howdy" } nth ]
} 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 ] unit-test
@ -424,7 +425,7 @@ ERROR: punned-class x ;
[| x | x a - { "howdy" } nth ]
} cond ;
\ littledan-cond-problem-1 must-infer
\ littledan-cond-problem-1 def>> must-infer
[ f ] [ -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 )
[ 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 )
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
@ -467,7 +468,7 @@ M:: integer lambda-method-forget-test ( a -- b ) ;
:: (funny-macro-test) ( obj quot -- ? ) obj { quot } 1&& ; inline
: 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
[ 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 must-infer
\ FAILdog-1 def>> must-infer
:: FAILdog-2 ( a -- b ) a { [| c | c ] } cond ;
\ FAILdog-2 must-infer
\ FAILdog-2 def>> must-infer
[ 3 ] [ 3 [| a | \ a ] call ] unit-test
@ -518,7 +519,7 @@ M:: integer lambda-method-forget-test ( a -- b ) ;
{ [ is-integer? ] [ is-even? ] [ >10? ] } &&
] ;
\ wlet-&&-test must-infer
\ wlet-&&-test def>> must-infer
[ f ] [ 1.5 wlet-&&-test ] unit-test
[ f ] [ 3 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 )
[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
:: fry-locals-test-2 ( -- n )
[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
[ 1 ] [ 3 4 [| | '[ [ _ swap - ] call ] call ] call ] unit-test

5
basis/macros/macros.factor
View File

@ -12,10 +12,11 @@ IN: macros
PRIVATE>
: define-macro ( word definition effect -- )
real-macro-effect
real-macro-effect {
[ [ memoize-quot [ call ] append ] keep define-declared ]
[ drop "macro" set-word-prop ]
3bi ;
[ 2drop changed-effect ]
} 3cleave ;
SYNTAX: MACRO: (:) define-macro ;

2
basis/math/bitwise/bitwise-tests.factor
View File

@ -26,7 +26,7 @@ CONSTANT: b 2
[ 3 ] [ foo ] unit-test
[ 3 ] [ { a b } flags ] unit-test
\ foo must-infer
\ foo def>> must-infer
[ 1 ] [ { 1 } flags ] unit-test

3
basis/models/models-tests.factor
View File

@ -31,6 +31,3 @@ T{ model-tester f f } "tester" set
"tester" get
"model-c" get value>>
] unit-test
\ model-changed must-infer
\ set-model must-infer

2
basis/peg/peg-tests.factor
View File

@ -5,8 +5,6 @@ USING: kernel tools.test strings namespaces make arrays sequences
peg peg.private peg.parsers accessors words math accessors ;
IN: peg.tests
\ parse must-infer
[ ] [ reset-pegs ] unit-test
[

2
basis/peg/search/search-tests.factor
View File

@ -17,5 +17,3 @@ IN: peg.search.tests
"abc 123 def 456" 'integer' [ 2 * number>string ] action replace
] unit-test
\ search must-infer
\ replace must-infer

4
basis/persistent/vectors/vectors-tests.factor
View File

@ -3,10 +3,6 @@ USING: accessors tools.test persistent.vectors
persistent.sequences sequences kernel arrays random namespaces
vectors math math.order ;
\ new-nth must-infer
\ ppush must-infer
\ ppop must-infer
[ 0 ] [ PV{ } length ] unit-test
[ 1 ] [ 3 PV{ } ppush length ] unit-test

1
basis/prettyprint/prettyprint-tests.factor
View File

@ -86,7 +86,6 @@ unit-test
drop ;
[ "drop ;" ] [
\ blah f "inferred-effect" set-word-prop
[ \ blah see ] with-string-writer "\n" ?tail drop 6 tail*
] unit-test

4
basis/regexp/regexp-tests.factor
View File

@ -4,10 +4,6 @@ USING: regexp tools.test kernel sequences regexp.parser regexp.private
eval strings multiline accessors ;
IN: regexp-tests
\ <regexp> must-infer
\ compile-regexp must-infer
\ matches? must-infer
[ f ] [ "b" "a*" <regexp> matches? ] unit-test
[ t ] [ "" "a*" <regexp> matches? ] unit-test
[ t ] [ "a" "a*" <regexp> matches? ] unit-test

2
basis/smtp/smtp-tests.factor
View File

@ -4,8 +4,6 @@ namespaces logging accessors assocs sorting smtp.private
concurrency.promises system ;
IN: smtp.tests
\ send-email must-infer
{ 0 0 } [ [ ] with-smtp-connection ] must-infer-as
[ "hello\nworld" validate-address ] must-fail

69
basis/stack-checker/backend/backend.factor
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.
USING: fry arrays generic io io.streams.string kernel math
namespaces parser sequences strings vectors words quotations
effects classes continuations assocs combinators
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.recursive-state ;
IN: stack-checker.backend
@ -84,11 +84,8 @@ M: object apply-object push-literal ;
meta-r empty? [ too-many->r ] unless ;
: infer-quot-here ( quot -- )
meta-r [
V{ } clone \ meta-r set
[ apply-object terminated? get not ] all?
[ commit-literals check->r ] [ literals get delete-all ] if
] dip \ meta-r set ;
[ commit-literals ] [ literals get delete-all ] if ;
: infer-quot ( quot rstate -- )
recursive-state get [
@ -116,13 +113,14 @@ M: object apply-object push-literal ;
] if ;
: 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 -- )
consume-r dup copy-values [ nip output-d ] [ #r>, ] 2bi ;
: undo-infer ( -- )
recorded get [ f "inferred-effect" set-word-prop ] each ;
terminated? get [ drop ] [
consume-r dup copy-values [ nip output-d ] [ #r>, ] 2bi
] if ;
: (consume/produce) ( effect -- inputs outputs )
[ in>> length consume-d ] [ out>> length produce-d ] bi ;
@ -132,59 +130,25 @@ M: object apply-object push-literal ;
[ terminated?>> [ terminate ] when ]
bi ; inline
: infer-word-def ( word -- )
[ specialized-def ] [ add-recursive-state ] bi infer-quot ;
: end-infer ( -- )
terminated? get [ check->r ] unless
meta-d clone #return, ;
: required-stack-effect ( word -- effect )
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 -- )
swap '[ _ #call, ] consume/produce ;
: call-recursive-word ( word -- )
dup required-stack-effect apply-word/effect ;
: cached-infer ( word -- )
dup stack-effect apply-word/effect ;
: infer-word ( word -- )
{
{ [ dup macro? ] [ do-not-compile ] }
{ [ dup "no-compile" word-prop ] [ do-not-compile ] }
[ dup required-stack-effect apply-word/effect ]
} cond ;
: with-infer ( quot -- effect visitor )
[
[
V{ } clone recorded set
init-inference
init-known-values
stack-visitor off
@ -192,5 +156,4 @@ M: object apply-object push-literal ;
end-infer
current-effect
stack-visitor get
] [ ] [ undo-infer ] cleanup
] with-scope ; inline

8
basis/stack-checker/call-effect/call-effect.factor
View File

@ -2,7 +2,7 @@
! See http://factorcode.org/license.txt for BSD license.
USING: accessors combinators combinators.private effects fry
kernel kernel.private make sequences continuations quotations
stack-checker stack-checker.transforms ;
stack-checker stack-checker.transforms words ;
IN: stack-checker.call-effect
! 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 t "no-compile" set-word-prop
: call-effect-fast ( quot effect inline-cache -- )
2over call-effect-unsafe?
[ [ nip (>>value) ] [ drop call-effect-unsafe ] 3bi ]
@ -71,6 +73,8 @@ M: quotation cached-effect
]
] 0 define-transform
\ call-effect t "no-compile" set-word-prop
: execute-effect-slow ( word effect -- )
[ '[ _ execute ] ] dip call-effect-slow ; inline
@ -93,3 +97,5 @@ M: quotation cached-effect
inline-cache new '[ _ _ execute-effect-ic ] ;
\ execute-effect [ execute-effect>quot ] 1 define-transform
\ execute-effect t "no-compile" set-word-prop

8
basis/stack-checker/errors/errors.factor
View File

@ -24,6 +24,10 @@ M: inference-error error-type type>> ;
: inference-warning ( ... class -- * )
+compiler-warning+ (inference-error) ; inline
TUPLE: do-not-compile word ;
: do-not-compile ( word -- * ) \ do-not-compile inference-warning ;
TUPLE: literal-expected what ;
: literal-expected ( what -- * ) \ literal-expected inference-warning ;
@ -48,9 +52,9 @@ TUPLE: missing-effect word ;
: missing-effect ( word -- * )
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 ;
TUPLE: recursive-quotation-error quot ;

5
basis/stack-checker/errors/prettyprint/prettyprint.factor
View File

@ -40,10 +40,7 @@ M: missing-effect summary
] "" make ;
M: effect-error summary
[
"Stack effect declaration of the word " %
word>> name>> % " is wrong" %
] "" make ;
drop "Stack effect declaration is wrong" ;
M: recursive-quotation-error error.
"The quotation " write

26
basis/stack-checker/known-words/known-words.factor
View File

@ -216,10 +216,25 @@ M: object infer-call*
dispatch <tuple-boa> exit load-local load-locals get-local
drop-locals do-primitive alien-invoke alien-indirect
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
: non-inline-word ( word -- )
@ -230,14 +245,11 @@ M\ word execute t "no-compile" set-word-prop
{ [ dup "primitive" word-prop ] [ infer-primitive ] }
{ [ dup "transform-quot" word-prop ] [ apply-transform ] }
{ [ 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-reader? ] [ infer-local-reader ] }
{ [ dup local-writer? ] [ infer-local-writer ] }
{ [ dup local-word? ] [ infer-local-word ] }
{ [ dup recursive-word? ] [ call-recursive-word ] }
[ dup infer-word apply-word/effect ]
[ infer-word ]
} cond ;
: define-primitive ( word inputs outputs -- )

23
basis/stack-checker/recursive-state/recursive-state.factor
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.
USING: accessors arrays sequences kernel sequences assocs
namespaces stack-checker.recursive-state.tree ;
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
f >>quotations
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
: add-recursive-state ( word -- rstate )
recursive-state get clone
[ word>> dup ] keep [ store ] change-words
prepare-recursive-state ;
: add-local-quotation ( recursive-state quot -- rstate )
: add-local-quotation ( rstate quot -- rstate )
swap clone [ dupd store ] change-quotations ;
: add-inline-word ( word label -- rstate )
swap recursive-state get clone
[ store ] change-inline-words ;
: recursive-word? ( word -- ? )
recursive-state get 2dup word>> eq?
[ 2drop t ] [ words>> lookup ] if ;
: inline-recursive-label ( word -- label/f )
recursive-state get inline-words>> lookup ;

9
basis/stack-checker/stack-checker-docs.factor
View File

@ -109,7 +109,6 @@ HELP: inference-error
"The " { $snippet "error" } " slot contains one of several possible " { $link "inference-errors" } "."
} ;
HELP: infer
{ $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." }
@ -121,11 +120,3 @@ HELP: infer.
{ $errors "Throws an " { $link inference-error } " if stack effect inference fails." } ;
{ 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." } ;

240
basis/stack-checker/stack-checker-tests.factor
View File

@ -10,7 +10,7 @@ sequences.private destructors combinators eval locals.backend
system compiler.units ;
IN: stack-checker.tests
\ infer. must-infer
[ 1234 infer ] must-fail
{ 0 2 } [ 2 "Hello" ] 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
: bad-recursion-2 ( obj -- obj )
dup [ dup first swap second bad-recursion-2 ] [ ] if ;
[ [ bad-recursion-2 ] infer ] must-fail
: funny-recursion ( obj -- obj )
dup [ funny-recursion 1 ] [ 2 ] if drop ;
@ -196,94 +191,11 @@ DEFER: blah4
over string? [ 2array throw ] unless
] 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
: too-deep ( a b -- c )
dup [ drop ] [ 2dup too-deep too-deep * ] if ; inline recursive
{ 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
[ [ [ dup call ] dup call ] infer ]
[ inference-error? ] must-fail-with
@ -311,16 +223,6 @@ DEFER: bar
[ [ [ [ drop 3 ] swap call ] dup call ] infer ]
[ 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
! Regression
@ -333,114 +235,14 @@ DEFER: bar
[ [ 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
! 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
{ 0 0 } [ [ drop ] callcc0 ] must-infer-as
{ 0 1 } [ [ 4 swap continue-with ] callcc1 ] must-infer-as
{ 2 1 } [ [ + ] [ ] [ ] cleanup ] 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
{ 1 0 } [ { [ ] } dispatch ] must-infer-as
@ -463,7 +265,6 @@ DEFER: deferred-word
{ 1 1 } [ [ deferred-word ] [ 3 ] if ] must-infer-as
DEFER: an-inline-word
: normal-word-3 ( -- )
@ -498,14 +299,12 @@ ERROR: custom-error ;
[ custom-error inference-error ] infer
] unit-test
[ T{ effect f 1 2 t } ] [
[ T{ effect f 1 1 t } ] [
[ dup [ 3 throw ] dip ] infer
] unit-test
! Regression
: missing->r-check ( a -- ) 1 load-locals ;
[ [ missing->r-check ] infer ] must-fail
[ [ 1 load-locals ] infer ] must-fail
! Corner case
[ [ [ f dup ] [ dup ] produce ] infer ] must-fail
@ -513,35 +312,12 @@ ERROR: custom-error ;
[ [ [ f dup ] [ ] while ] infer ] must-fail
: erg's-inference-bug ( -- ) f dup [ erg's-inference-bug ] when ; inline recursive
[ [ erg's-inference-bug ] infer ] must-fail
: 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
FORGET: erg's-inference-bug
: bad-recursion-3 ( -- ) dup [ [ bad-recursion-3 ] dip ] when ; inline recursive
[ [ bad-recursion-3 ] infer ] must-fail
FORGET: bad-recursion-3
: bad-recursion-4 ( -- ) 4 [ dup call roll ] times ; inline recursive
[ [ [ ] [ 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
FORGET: unbalanced-retain-usage
DEFER: eee'
: ddd' ( ? -- ) [ f eee' ] when ; inline recursive
: eee' ( ? -- ) [ swap [ ] ] dip ddd' call ; inline recursive
@ -588,3 +366,7 @@ DEFER: eee'
[ forget-test ] must-infer
[ ] [ [ \ forget-test forget ] with-compilation-unit ] unit-test
[ forget-test ] must-infer
[ [ cond ] infer ] must-fail
[ [ bi ] infer ] must-fail
[ at ] must-infer

13
basis/stack-checker/stack-checker.factor
View File

@ -16,17 +16,4 @@ M: callable infer ( quot -- effect )
#! Safe to call from inference transforms.
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

4
basis/stack-checker/state/state.factor
View File

@ -42,6 +42,7 @@ SYMBOL: literals
: init-inference ( -- )
terminated? off
V{ } clone \ meta-d set
V{ } clone \ meta-r set
V{ } clone literals set
0 d-in set ;
@ -64,6 +65,3 @@ SYMBOL: generic-dependencies
: depends-on-generic ( generic class -- )
generic-dependencies get dup
[ swap '[ _ ?class-or ] change-at ] [ 3drop ] if ;
! Words we've inferred the stack effect of, for rollback
SYMBOL: recorded

7
basis/stack-checker/transforms/transforms-tests.factor
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
classes classes.tuple ;
: compose-n ( quot n -- ) "OOPS" throw ;
<<
: 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 t "no-compile" set-word-prop
>>
: compose-n-test ( a b c -- x ) 2 \ + compose-n ;
[ 6 ] [ 1 2 3 compose-n-test ] unit-test

28
basis/stack-checker/transforms/transforms.factor
View File

@ -10,13 +10,6 @@ stack-checker.state stack-checker.visitor stack-checker.errors
stack-checker.values stack-checker.recursive-state ;
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 )
'[ _ _ with-datastack [ length 1 assert= ] [ first ] bi nip ]
[ transform-expansion-error ]
@ -29,7 +22,7 @@ IN: stack-checker.transforms
word inlined-dependency depends-on
values [ length meta-d shorten-by ] [ #drop, ] bi
rstate infer-quot
] [ word give-up-transform ] if* ;
] [ word infer-word ] if* ;
: literals? ( values -- ? ) [ literal-value? ] all? ;
@ -41,7 +34,7 @@ IN: stack-checker.transforms
[ first literal recursion>> ] tri
] if
((apply-transform))
] [ 2drop give-up-transform ] if ;
] [ 2drop infer-word ] if ;
: apply-transform ( word -- )
[ ] [ "transform-quot" word-prop ] [ "transform-n" word-prop ] tri
@ -59,6 +52,8 @@ IN: stack-checker.transforms
! Combinators
\ cond [ cond>quot ] 1 define-transform
\ cond t "no-compile" set-word-prop
\ case [
[
[ no-case ]
@ -71,14 +66,24 @@ IN: stack-checker.transforms
] if-empty
] 1 define-transform
\ case t "no-compile" set-word-prop
\ cleave [ cleave>quot ] 1 define-transform
\ cleave t "no-compile" set-word-prop
\ 2cleave [ 2cleave>quot ] 1 define-transform
\ 2cleave t "no-compile" set-word-prop
\ 3cleave [ 3cleave>quot ] 1 define-transform
\ 3cleave t "no-compile" set-word-prop
\ spread [ spread>quot ] 1 define-transform
\ spread t "no-compile" set-word-prop
\ (call-next-method) [
[
[ "method-class" word-prop ]
@ -90,6 +95,8 @@ IN: stack-checker.transforms
] bi
] 1 define-transform
\ (call-next-method) t "no-compile" set-word-prop
! Constructors
\ boa [
dup tuple-class? [
@ -100,6 +107,9 @@ IN: stack-checker.transforms
] [ drop f ] if
] 1 define-transform
\ boa t "no-compile" set-word-prop
M\ tuple-class boa t "no-compile" set-word-prop
\ new [
dup tuple-class? [
dup inlined-dependency depends-on

3
basis/syndication/syndication-tests.factor
View File

@ -2,9 +2,6 @@ USING: syndication io kernel io.files tools.test io.encodings.binary
calendar urls xml.writer ;
IN: syndication.tests
\ download-feed must-infer
\ feed>xml must-infer
: load-news-file ( filename -- feed )
#! Load an news syndication file and process it, returning
#! it as an feed tuple.

2
basis/tools/continuations/continuations.factor
View File

@ -4,7 +4,7 @@ USING: threads kernel namespaces continuations combinators
sequences math namespaces.private continuations.private
concurrency.messaging quotations kernel.private words
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
<PRIVATE

46
basis/tools/crossref/crossref-docs.factor
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
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 vocab-uses. }
{ $subsection vocab-usage. }
{ $see-also "definitions" "words" "see" } ;
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.
{ $values { "word" "a word" } }
{ $description "Prints an list of all callers of a word. This may include the word itself, if it is recursive." }
{ $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

37
basis/tools/crossref/crossref-tests.factor
View File

@ -11,3 +11,40 @@ M: integer foo + ;
[ t ] [ integer \ foo method \ + usage member? ] 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

110
basis/tools/crossref/crossref.factor
View File

@ -1,9 +1,84 @@
! Copyright (C) 2005, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: assocs definitions io io.styles kernel prettyprint
sorting see ;
USING: words assocs definitions io io.pathnames io.styles kernel
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
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 ] keep ] { } map>assoc ;
@ -15,3 +90,34 @@ IN: tools.crossref
: usage. ( word -- )
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