diff --git a/README.txt b/README.txt index c5d53de842..c0d56dfa09 100755 --- a/README.txt +++ b/README.txt @@ -59,10 +59,10 @@ On Unix, Factor can either run a graphical user interface using X11, or a terminal listener. For X11 support, you need recent development libraries for libc, -Pango, X11, OpenGL and GLUT. On a Debian-derived Linux distribution +Pango, X11, and OpenGL. On a Debian-derived Linux distribution (like Ubuntu), you can use the following line to grab everything: - sudo apt-get install libc6-dev libpango-1.0-dev libx11-dev glutg3-dev + sudo apt-get install libc6-dev libpango-1.0-dev libx11-dev If your DISPLAY environment variable is set, the UI will start automatically: diff --git a/basis/alarms/alarms-tests.factor b/basis/alarms/alarms-tests.factor index d1161e4cee..7c64680a83 100644 --- a/basis/alarms/alarms-tests.factor +++ b/basis/alarms/alarms-tests.factor @@ -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 diff --git a/basis/alien/c-types/c-types-tests.factor b/basis/alien/c-types/c-types-tests.factor index 988dc180e0..ea9e881fd4 100644 --- a/basis/alien/c-types/c-types-tests.factor +++ b/basis/alien/c-types/c-types-tests.factor @@ -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 diff --git a/basis/base64/base64-tests.factor b/basis/base64/base64-tests.factor index 572d8a5227..9094286575 100644 --- a/basis/base64/base64-tests.factor +++ b/basis/base64/base64-tests.factor @@ -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 diff --git a/basis/binary-search/binary-search-tests.factor b/basis/binary-search/binary-search-tests.factor index 77b1c16505..63d2697418 100644 --- a/basis/binary-search/binary-search-tests.factor +++ b/basis/binary-search/binary-search-tests.factor @@ -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 diff --git a/basis/bootstrap/compiler/compiler.factor b/basis/bootstrap/compiler/compiler.factor index 617073bbc4..89a0ed86fe 100644 --- a/basis/bootstrap/compiler/compiler.factor +++ b/basis/bootstrap/compiler/compiler.factor @@ -108,7 +108,7 @@ nl "." write flush -{ (compile) } compile-unoptimized +{ compile-word } compile-unoptimized "." write flush diff --git a/basis/bootstrap/image/image-tests.factor b/basis/bootstrap/image/image-tests.factor index c432a47ea4..e7070d3cf2 100644 --- a/basis/bootstrap/image/image-tests.factor +++ b/basis/bootstrap/image/image-tests.factor @@ -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 diff --git a/basis/bootstrap/stage2.factor b/basis/bootstrap/stage2.factor index d6c1876d6a..cc853e4842 100644 --- a/basis/bootstrap/stage2.factor +++ b/basis/bootstrap/stage2.factor @@ -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 @@ -77,6 +68,10 @@ SYMBOL: bootstrap-time "staging" get "deploy-vocab" get or [ "stage2: deployment mode" print ] [ + "debugger" require + "alien.prettyprint" require + "inspector" require + "tools.errors" require "listener" require "none" require ] if diff --git a/basis/calendar/calendar-tests.factor b/basis/calendar/calendar-tests.factor index b6d8e74072..256b4e1b42 100644 --- a/basis/calendar/calendar-tests.factor +++ b/basis/calendar/calendar-tests.factor @@ -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 valid-timestamp? ] unit-test [ f ] [ 2004 2 30 0 0 0 instant valid-timestamp? ] unit-test [ f ] [ 2003 2 29 0 0 0 instant valid-timestamp? ] unit-test diff --git a/basis/calendar/format/macros/macros-tests.factor b/basis/calendar/format/macros/macros-tests.factor index 544332770f..4ba2872b43 100644 --- a/basis/calendar/format/macros/macros-tests.factor +++ b/basis/calendar/format/macros/macros-tests.factor @@ -1,4 +1,4 @@ -USING: tools.test kernel ; +USING: tools.test kernel accessors ; IN: calendar.format.macros [ 2 ] [ { [ 2 ] } attempt-all-quots ] unit-test @@ -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 diff --git a/basis/combinators/smart/smart-docs.factor b/basis/combinators/smart/smart-docs.factor index 679b587759..d8ee89ef2d 100644 --- a/basis/combinators/smart/smart-docs.factor +++ b/basis/combinators/smart/smart-docs.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2009 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. USING: help.markup help.syntax kernel quotations math sequences -multiline ; +multiline stack-checker ; IN: combinators.smart HELP: inputarray [ 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 diff --git a/basis/compiler/cfg/builder/builder-tests.factor b/basis/compiler/cfg/builder/builder-tests.factor index 0b303a8a43..58eae8181b 100644 --- a/basis/compiler/cfg/builder/builder-tests.factor +++ b/basis/compiler/cfg/builder/builder-tests.factor @@ -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 ; diff --git a/basis/compiler/cfg/debugger/debugger.factor b/basis/compiler/cfg/debugger/debugger.factor index 6d0a8f8c8e..6b0aba6813 100644 --- a/basis/compiler/cfg/debugger/debugger.factor +++ b/basis/compiler/cfg/debugger/debugger.factor @@ -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? diff --git a/basis/compiler/cfg/linear-scan/assignment/assignment-tests.factor b/basis/compiler/cfg/linear-scan/assignment/assignment-tests.factor index 9efc23651b..13c1783711 100644 --- a/basis/compiler/cfg/linear-scan/assignment/assignment-tests.factor +++ b/basis/compiler/cfg/linear-scan/assignment/assignment-tests.factor @@ -1,4 +1,4 @@ USING: compiler.cfg.linear-scan.assignment tools.test ; IN: compiler.cfg.linear-scan.assignment.tests -\ assign-registers must-infer + diff --git a/basis/compiler/cfg/linearization/linearization-tests.factor b/basis/compiler/cfg/linearization/linearization-tests.factor index 5e866d15db..fe8b4fd0c0 100644 --- a/basis/compiler/cfg/linearization/linearization-tests.factor +++ b/basis/compiler/cfg/linearization/linearization-tests.factor @@ -1,4 +1,4 @@ IN: compiler.cfg.linearization.tests USING: compiler.cfg.linearization tools.test ; -\ build-mr must-infer + diff --git a/basis/compiler/codegen/codegen.factor b/basis/compiler/codegen/codegen.factor index a220de476a..2a0456e3b7 100755 --- a/basis/compiler/codegen/codegen.factor +++ b/basis/compiler/codegen/codegen.factor @@ -375,45 +375,21 @@ M: long-long-type flatten-value-type ( type -- types ) : box-return* ( node -- ) return>> [ ] [ box-return ] if-void ; -TUPLE: no-such-library name ; - -M: no-such-library summary - drop "Library not found" ; - -M: no-such-library error-type drop +linkage-error+ ; - -: no-such-library ( name -- ) - \ no-such-library boa - compiling-word get compiler-error ; - -TUPLE: no-such-symbol name ; - -M: no-such-symbol summary - drop "Symbol not found" ; - -M: no-such-symbol error-type drop +linkage-error+ ; - -: no-such-symbol ( name -- ) - \ no-such-symbol boa - compiling-word get compiler-error ; - : check-dlsym ( symbols dll -- ) dup dll-valid? [ dupd '[ _ dlsym ] any? - [ drop ] [ no-such-symbol ] if + [ drop ] [ compiling-word get no-such-symbol ] if ] [ - dll-path no-such-library drop + dll-path compiling-word get no-such-library drop ] if ; -: stdcall-mangle ( symbol node -- symbol ) - "@" - swap parameters>> parameter-sizes drop - number>string 3append ; +: stdcall-mangle ( symbol params -- symbol ) + parameters>> parameter-sizes drop number>string "@" glue ; : alien-invoke-dlsym ( params -- symbols dll ) - dup function>> dup pick stdcall-mangle 2array - swap library>> library dup [ dll>> ] when - 2dup check-dlsym ; + [ [ function>> dup ] keep stdcall-mangle 2array ] + [ library>> library dup [ dll>> ] when ] + bi 2dup check-dlsym ; M: ##alien-invoke generate-insn params>> diff --git a/basis/compiler/compiler-docs.factor b/basis/compiler/compiler-docs.factor index f92f0015d3..b96d5e573a 100644 --- a/basis/compiler/compiler-docs.factor +++ b/basis/compiler/compiler-docs.factor @@ -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 certain compile errors 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 @@ -46,9 +46,9 @@ $nl { "The " { $emphasis "non-optimizing quotation compiler" } " compiles quotations to naive machine code very quickly. The non-optimizing quotation compiler is part of the VM." } { "The " { $emphasis "optimizing word compiler" } " compiles whole words at a time while performing extensive data and control flow analysis. This provides greater performance for generated code, but incurs a much longer compile time. The optimizing compiler is written in Factor." } } -"The optimizing compiler only compiles words which have a static stack effect. This means that methods defined on fundamental generic words such as " { $link nth } " should have a static stack effect. See " { $link "inference" } " and " { $link "cookbook-pitfalls" } "." -$nl "The optimizing compiler also trades off compile time for performance of generated code, so loading certain vocabularies might take a while. Saving the image after loading vocabularies can save you a lot of time that you would spend waiting for the same code to load in every coding session; see " { $link "images" } " for information." +$nl +"Most code you write will run with the optimizing compiler. Sometimes, the non-optimizing compiler is used, for example for listener interactions, or for running the quotation passed to " { $link POSTPONE: call( } "." { $subsection "compiler-errors" } { $subsection "hints" } { $subsection "compiler-usage" } @@ -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." } ; diff --git a/basis/compiler/compiler.factor b/basis/compiler/compiler.factor index e5d88af14a..ee91d04b3d 100644 --- a/basis/compiler/compiler.factor +++ b/basis/compiler/compiler.factor @@ -2,19 +2,20 @@ ! See http://factorcode.org/license.txt for BSD license. USING: accessors kernel namespaces arrays sequences io words fry continuations vocabs assocs dlists definitions math graphs generic -combinators deques search-deques macros io source-files.errors stack-checker -stack-checker.state stack-checker.inlining combinators.short-circuit -compiler.errors compiler.units compiler.tree.builder -compiler.tree.optimizer compiler.cfg.builder compiler.cfg.optimizer -compiler.cfg.linearization compiler.cfg.two-operand -compiler.cfg.linear-scan compiler.cfg.stack-frame compiler.codegen -compiler.utilities ; +combinators deques search-deques macros io source-files.errors +stack-checker stack-checker.state stack-checker.inlining +stack-checker.errors combinators.short-circuit compiler.errors +compiler.units compiler.tree.builder compiler.tree.optimizer +compiler.cfg.builder compiler.cfg.optimizer compiler.cfg.linearization +compiler.cfg.two-operand compiler.cfg.linear-scan +compiler.cfg.stack-frame compiler.codegen compiler.utilities ; IN: compiler SYMBOL: compile-queue SYMBOL: compiled : queue-compile? ( word -- ? ) + #! Don't attempt to compile certain words. { [ "forgotten" word-prop ] [ compiled get key? ] @@ -25,67 +26,99 @@ 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 H{ } clone dependencies set H{ } clone generic-dependencies set - f swap compiler-error ; + clear-compiler-error ; : ignore-error? ( word error -- ? ) + #! Ignore some errors 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 ; + ] [ + { + [ do-not-compile? ] + [ literal-expected? ] + } 1|| + ] 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 + [ dup def>> deoptimize-with ] + [ clear-compiler-error ] + bi + ] [ + [ swap compiler-error ] + [ [ drop ] [ not-compiled-def ] 2bi deoptimize-with ] + 2bi + ] if ; : 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 +132,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 +145,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 +173,4 @@ M: optimizing-compiler recompile ( words -- alist ) f compiler-impl set-global ; : recompile-all ( -- ) - forget-errors all-words compile ; + all-words compile ; diff --git a/basis/compiler/errors/errors.factor b/basis/compiler/errors/errors.factor index 22ae8d97ff..3881439fc0 100644 --- a/basis/compiler/errors/errors.factor +++ b/basis/compiler/errors/errors.factor @@ -1,54 +1,72 @@ ! Copyright (C) 2007, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors source-files.errors kernel namespaces assocs ; +USING: accessors source-files.errors kernel namespaces assocs fry +summary ; IN: compiler.errors -TUPLE: compiler-error < source-file-error ; - -M: compiler-error error-type error>> error-type ; - +SYMBOL: +compiler-error+ SYMBOL: compiler-errors compiler-errors [ H{ } clone ] initialize -SYMBOLS: +compiler-error+ +compiler-warning+ +linkage-error+ ; +TUPLE: compiler-error < source-file-error ; -: errors-of-type ( type -- assoc ) - compiler-errors get-global - swap [ [ nip error-type ] dip eq? ] curry - assoc-filter ; +M: compiler-error error-type drop +compiler-error+ ; + +SYMBOL: +linkage-error+ +SYMBOL: linkage-errors + +linkage-errors [ H{ } clone ] initialize + +TUPLE: linkage-error < source-file-error ; + +M: linkage-error error-type drop +linkage-error+ ; + +: clear-compiler-error ( word -- ) + compiler-errors linkage-errors + [ get-global delete-at ] bi-curry@ bi ; + +: compiler-error ( error -- ) + dup asset>> compiler-errors get-global set-at ; T{ error-type { type +compiler-error+ } { word ":errors" } { plural "compiler errors" } { icon "vocab:ui/tools/error-list/icons/compiler-error.tiff" } - { quot [ +compiler-error+ errors-of-type values ] } + { quot [ compiler-errors get values ] } { forget-quot [ compiler-errors get delete-at ] } } define-error-type -T{ error-type - { type +compiler-warning+ } - { word ":warnings" } - { plural "compiler warnings" } - { icon "vocab:ui/tools/error-list/icons/compiler-warning.tiff" } - { quot [ +compiler-warning+ errors-of-type values ] } - { forget-quot [ compiler-errors get delete-at ] } -} define-error-type +: ( error word -- compiler-error ) + \ compiler-error ; + +: ( error word -- linkage-error ) + \ linkage-error ; + +: linkage-error ( error word class -- ) + '[ _ boa ] dip dup asset>> linkage-errors get set-at ; inline T{ error-type { type +linkage-error+ } { word ":linkage" } { plural "linkage errors" } { icon "vocab:ui/tools/error-list/icons/linkage-error.tiff" } - { quot [ +linkage-error+ errors-of-type values ] } - { forget-quot [ compiler-errors get delete-at ] } + { quot [ linkage-errors get values ] } + { forget-quot [ linkage-errors get delete-at ] } { fatal? f } } define-error-type -: ( error word -- compiler-error ) - \ compiler-error ; +TUPLE: no-such-library name ; -: compiler-error ( error word -- ) - compiler-errors get-global pick - [ [ [ ] keep ] dip set-at ] [ delete-at drop ] if ; +M: no-such-library summary drop "Library not found" ; + +: no-such-library ( name word -- ) \ no-such-library linkage-error ; + +TUPLE: no-such-symbol name ; + +M: no-such-symbol summary drop "Symbol not found" ; + +: no-such-symbol ( name word -- ) \ no-such-symbol linkage-error ; + +ERROR: not-compiled word error ; \ No newline at end of file diff --git a/basis/compiler/tests/insane.factor b/basis/compiler/tests/insane.factor deleted file mode 100644 index aa79067252..0000000000 --- a/basis/compiler/tests/insane.factor +++ /dev/null @@ -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 diff --git a/basis/compiler/tests/optimizer.factor b/basis/compiler/tests/optimizer.factor index 3aed47ae7e..99bdb18812 100644 --- a/basis/compiler/tests/optimizer.factor +++ b/basis/compiler/tests/optimizer.factor @@ -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 diff --git a/basis/compiler/tests/redefine0.factor b/basis/compiler/tests/redefine0.factor new file mode 100644 index 0000000000..87b63aa029 --- /dev/null +++ b/basis/compiler/tests/redefine0.factor @@ -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 \ No newline at end of file diff --git a/basis/compiler/tests/redefine1.factor b/basis/compiler/tests/redefine1.factor index 8145ad628b..a28b183fb6 100644 --- a/basis/compiler/tests/redefine1.factor +++ b/basis/compiler/tests/redefine1.factor @@ -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 diff --git a/basis/compiler/tests/redefine16.factor b/basis/compiler/tests/redefine16.factor index e0bb1773c9..3bef30f9f1 100644 --- a/basis/compiler/tests/redefine16.factor +++ b/basis/compiler/tests/redefine16.factor @@ -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 diff --git a/basis/compiler/tests/simple.factor b/basis/compiler/tests/simple.factor index 769182a8b1..11b27979d5 100644 --- a/basis/compiler/tests/simple.factor +++ b/basis/compiler/tests/simple.factor @@ -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 diff --git a/basis/compiler/tree/builder/builder-docs.factor b/basis/compiler/tree/builder/builder-docs.factor index 8cf3796f0a..b7ee51834b 100644 --- a/basis/compiler/tree/builder/builder-docs.factor +++ b/basis/compiler/tree/builder/builder-docs.factor @@ -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 { "word/quot" { $or word quotation } } { "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 } { "word/quot" { $or word quotation } } { "nodes/f" { $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." } ; diff --git a/basis/compiler/tree/builder/builder-tests.factor b/basis/compiler/tree/builder/builder-tests.factor index 4982a3986c..f3a2b99db6 100755 --- a/basis/compiler/tree/builder/builder-tests.factor +++ b/basis/compiler/tree/builder/builder-tests.factor @@ -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 diff --git a/basis/compiler/tree/builder/builder.factor b/basis/compiler/tree/builder/builder.factor index fe9c2a26a4..7f760650e7 100644 --- a/basis/compiler/tree/builder/builder.factor +++ b/basis/compiler/tree/builder/builder.factor @@ -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,58 @@ 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 +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) infer-quot-here ; : 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-no-compile ] + [ word-body infer-quot-here ] + [ current-effect check-effect ] tri ; + +: build-tree-with ( in-stack word/quot -- nodes ) [ - [ - { - [ check-cannot-infer ] - [ check-no-compile ] - [ (build-tree-from-word) ] - [ finish-word ] - } cleave - ] maybe-cannot-infer - ] with-tree-builder ; + recursive-state set + 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? ; diff --git a/basis/compiler/tree/checker/checker-tests.factor b/basis/compiler/tree/checker/checker-tests.factor index 5a8706b900..d9591e7be2 100644 --- a/basis/compiler/tree/checker/checker-tests.factor +++ b/basis/compiler/tree/checker/checker-tests.factor @@ -1,4 +1,4 @@ IN: compiler.tree.checker.tests USING: compiler.tree.checker tools.test ; -\ check-nodes must-infer + diff --git a/basis/compiler/tree/dead-code/dead-code-tests.factor b/basis/compiler/tree/dead-code/dead-code-tests.factor index 7c28866e94..ed4df91eec 100644 --- a/basis/compiler/tree/dead-code/dead-code-tests.factor +++ b/basis/compiler/tree/dead-code/dead-code-tests.factor @@ -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 diff --git a/basis/compiler/tree/debugger/debugger-tests.factor b/basis/compiler/tree/debugger/debugger-tests.factor index 9b4a6da12a..9bacd51be1 100644 --- a/basis/compiler/tree/debugger/debugger-tests.factor +++ b/basis/compiler/tree/debugger/debugger-tests.factor @@ -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. [ [ print ] each ] optimizer-report. \ No newline at end of file diff --git a/basis/compiler/tree/debugger/debugger.factor b/basis/compiler/tree/debugger/debugger.factor index 8e102e0ea3..b1dc04082e 100644 --- a/basis/compiler/tree/debugger/debugger.factor +++ b/basis/compiler/tree/debugger/debugger.factor @@ -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 diff --git a/basis/compiler/tree/def-use/def-use-tests.factor b/basis/compiler/tree/def-use/def-use-tests.factor index d970e04afd..227a1f1dd7 100644 --- a/basis/compiler/tree/def-use/def-use-tests.factor +++ b/basis/compiler/tree/def-use/def-use-tests.factor @@ -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 { diff --git a/basis/compiler/tree/escape-analysis/escape-analysis-tests.factor b/basis/compiler/tree/escape-analysis/escape-analysis-tests.factor index 9a226b954f..bcb8b2f80a 100644 --- a/basis/compiler/tree/escape-analysis/escape-analysis-tests.factor +++ b/basis/compiler/tree/escape-analysis/escape-analysis-tests.factor @@ -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 ) diff --git a/basis/compiler/tree/normalization/normalization-tests.factor b/basis/compiler/tree/normalization/normalization-tests.factor index 680ae0b170..3b4574effe 100644 --- a/basis/compiler/tree/normalization/normalization-tests.factor +++ b/basis/compiler/tree/normalization/normalization-tests.factor @@ -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 diff --git a/basis/compiler/tree/optimizer/optimizer-tests.factor b/basis/compiler/tree/optimizer/optimizer-tests.factor index 1075e441e7..5d05947b8a 100644 --- a/basis/compiler/tree/optimizer/optimizer-tests.factor +++ b/basis/compiler/tree/optimizer/optimizer-tests.factor @@ -1,4 +1,4 @@ USING: compiler.tree.optimizer tools.test ; IN: compiler.tree.optimizer.tests -\ optimize-tree must-infer + diff --git a/basis/compiler/tree/optimizer/optimizer.factor b/basis/compiler/tree/optimizer/optimizer.factor index daa8f072ca..fe3c7acb92 100644 --- a/basis/compiler/tree/optimizer/optimizer.factor +++ b/basis/compiler/tree/optimizer/optimizer.factor @@ -29,7 +29,6 @@ SYMBOL: check-optimizer? normalize propagate cleanup - ?check dup run-escape-analysis? [ escape-analysis unbox-tuples diff --git a/basis/compiler/tree/propagation/inlining/inlining.factor b/basis/compiler/tree/propagation/inlining/inlining.factor index 7ae44a5293..aa66b2f6d7 100755 --- a/basis/compiler/tree/propagation/inlining/inlining.factor +++ b/basis/compiler/tree/propagation/inlining/inlining.factor @@ -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 ] [ - [ - [ remember-inlining ] dip - [ drop ] [ splicing-nodes ] 2bi - [ >>body drop ] [ count-nodes ] [ (propagate) ] tri - ] with-scope node-count +@ - t +:: inline-word ( #call word -- ? ) + word history get memq? [ f ] [ + #call word splicing-body [ + [ + 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 ] } diff --git a/basis/compiler/tree/propagation/known-words/known-words.factor b/basis/compiler/tree/propagation/known-words/known-words.factor index 1b5d383353..b91a1157f7 100644 --- a/basis/compiler/tree/propagation/known-words/known-words.factor +++ b/basis/compiler/tree/propagation/known-words/known-words.factor @@ -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? ]. diff --git a/basis/compiler/tree/propagation/propagation-tests.factor b/basis/compiler/tree/propagation/propagation-tests.factor index 5b9b49811f..f6308ac40a 100644 --- a/basis/compiler/tree/propagation/propagation-tests.factor +++ b/basis/compiler/tree/propagation/propagation-tests.factor @@ -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 diff --git a/basis/compiler/tree/recursive/recursive-tests.factor b/basis/compiler/tree/recursive/recursive-tests.factor index 971675d367..80edae076f 100644 --- a/basis/compiler/tree/recursive/recursive-tests.factor +++ b/basis/compiler/tree/recursive/recursive-tests.factor @@ -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 diff --git a/basis/compiler/tree/tuple-unboxing/tuple-unboxing-tests.factor b/basis/compiler/tree/tuple-unboxing/tuple-unboxing-tests.factor index 81ba01f1e2..8654a6f983 100644 --- a/basis/compiler/tree/tuple-unboxing/tuple-unboxing-tests.factor +++ b/basis/compiler/tree/tuple-unboxing/tuple-unboxing-tests.factor @@ -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 diff --git a/basis/cpu/ppc/assembler/assembler-tests.factor b/basis/cpu/ppc/assembler/assembler-tests.factor index f35a5cfca8..09db4cb050 100644 --- a/basis/cpu/ppc/assembler/assembler-tests.factor +++ b/basis/cpu/ppc/assembler/assembler-tests.factor @@ -114,5 +114,3 @@ make vocabs sequences ; { HEX: fc411800 } [ 1 2 3 FCMPU ] test-assembler { HEX: fc411840 } [ 1 2 3 FCMPO ] test-assembler { HEX: 3c601234 HEX: 60635678 } [ HEX: 12345678 3 LOAD ] test-assembler - -"cpu.ppc.assembler" words [ must-infer ] each diff --git a/basis/db/pools/pools-tests.factor b/basis/db/pools/pools-tests.factor index 7ff2a33d92..334ff9e11a 100644 --- a/basis/db/pools/pools-tests.factor +++ b/basis/db/pools/pools-tests.factor @@ -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 ; -\ must-infer - { 1 0 } [ [ ] with-db-pool ] must-infer-as { 1 0 } [ [ ] with-pooled-db ] must-infer-as diff --git a/basis/db/tester/tester.factor b/basis/db/tester/tester.factor index fcc5abf1cf..56bac7efcd 100644 --- a/basis/db/tester/tester.factor +++ b/basis/db/tester/tester.factor @@ -3,7 +3,7 @@ USING: concurrency.combinators db.pools db.sqlite db.tuples db.types kernel math random threads tools.test db sequences io prettyprint db.postgresql db.sqlite accessors io.files.temp -namespaces fry system ; +namespaces fry system math.parser ; IN: db.tester : postgresql-test-db ( -- postgresql-db ) @@ -56,6 +56,10 @@ test-2 "TEST2" { { "z" "Z" { VARCHAR 256 } +not-null+ } } define-persistent +: test-1-tuple ( -- tuple ) + f 100 random 100 random 100 random [ number>string ] tri@ + test-1 boa ; + : db-tester ( test-db -- ) [ [ @@ -67,8 +71,7 @@ test-2 "TEST2" { drop 10 [ dup [ - f 100 random 100 random 100 random test-1 boa - insert-tuple yield + test-1-tuple insert-tuple yield ] with-db ] times ] with parallel-each @@ -84,8 +87,7 @@ test-2 "TEST2" { [ 10 [ 10 [ - f 100 random 100 random 100 random test-1 boa - insert-tuple yield + test-1-tuple insert-tuple yield ] times ] parallel-each ] with-pooled-db diff --git a/basis/db/tuples/tuples-tests.factor b/basis/db/tuples/tuples-tests.factor index 375ee509bb..afdee3e89f 100644 --- a/basis/db/tuples/tuples-tests.factor +++ b/basis/db/tuples/tuples-tests.factor @@ -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 diff --git a/basis/debugger/debugger-tests.factor b/basis/debugger/debugger-tests.factor index afa4aa1c28..08f84d9335 100644 --- a/basis/debugger/debugger-tests.factor +++ b/basis/debugger/debugger-tests.factor @@ -2,3 +2,6 @@ IN: debugger.tests USING: debugger kernel continuations tools.test ; [ ] [ [ drop ] [ error. ] recover ] unit-test + +[ f ] [ { } vm-error? ] unit-test +[ f ] [ { "A" "B" } vm-error? ] unit-test \ No newline at end of file diff --git a/basis/debugger/debugger.factor b/basis/debugger/debugger.factor index 9abd5a9033..d8ebd5bbf9 100644 --- a/basis/debugger/debugger.factor +++ b/basis/debugger/debugger.factor @@ -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" ; diff --git a/basis/editors/emacs/authors.txt b/basis/editors/emacs/authors.txt index 6cfd5da273..07c1c4a765 100644 --- a/basis/editors/emacs/authors.txt +++ b/basis/editors/emacs/authors.txt @@ -1 +1,2 @@ Eduardo Cavazos +Doug Coleman diff --git a/basis/editors/emacs/emacs-docs.factor b/basis/editors/emacs/emacs-docs.factor index f55068e143..adf6d8a7b7 100644 --- a/basis/editors/emacs/emacs-docs.factor +++ b/basis/editors/emacs/emacs-docs.factor @@ -2,10 +2,23 @@ USING: help help.syntax help.markup ; IN: editors.emacs ARTICLE: "editors.emacs" "Integration with Emacs" -"Put this in your " { $snippet ".emacs" } " file:" +"Full Emacs integration with Factor requires the use of two executable files -- " { $snippet "emacs" } " and " { $snippet "emacsclient" } ", which act as a client/server pair. To start the server, run the " { $snippet "emacs" } " binary and run " { $snippet "M-x server-start" } " or start " { $snippet "emacs" } " with the following line in your " { $snippet ".emacs" } " file:" { $code "(server-start)" } +"On Windows, if you install Emacs to " { $snippet "Program Files" } " or " { $snippet "Program Files(x86)" } ", Factor will automatically detect the path to " { $snippet "emacsclient.exe" } ". On Unix systems, make sure that " { $snippet "emacsclient" } " is in your path. To set the path manually, use the following snippet:" +{ $code "USE: edtiors.emacs" + "\"/my/crazy/bin/emacsclient\" emacsclient-path set-global" +} + "If you would like a new window to open when you ask Factor to edit an object, put this in your " { $snippet ".emacs" } " file:" { $code "(setq server-window 'switch-to-buffer-other-frame)" } -{ $see-also "editor" } ; -ABOUT: "editors.emacs" \ No newline at end of file +"To quickly scaffold a " { $snippet ".emacs" } " file, run the following code:" +{ $code "USE: tools.scaffold" + "scaffold-emacs" +} + +{ $see-also "editor" } + +; + +ABOUT: "editors.emacs" diff --git a/basis/editors/emacs/emacs.factor b/basis/editors/emacs/emacs.factor index 366bc53104..31fcaf114e 100644 --- a/basis/editors/emacs/emacs.factor +++ b/basis/editors/emacs/emacs.factor @@ -11,7 +11,10 @@ M: object default-emacsclient ( -- path ) "emacsclient" ; : emacsclient ( file line -- ) [ - { [ emacsclient-path get ] [ default-emacsclient ] } 0|| , + { + [ emacsclient-path get-global ] + [ default-emacsclient dup emacsclient-path set-global ] + } 0|| , "--no-wait" , number>string "+" prepend , , diff --git a/basis/editors/emacs/windows/authors.txt b/basis/editors/emacs/windows/authors.txt index 7c1b2f2279..1901f27a24 100755 --- a/basis/editors/emacs/windows/authors.txt +++ b/basis/editors/emacs/windows/authors.txt @@ -1 +1 @@ -Doug Coleman +Slava Pestov diff --git a/basis/editors/emacs/windows/tags.txt b/basis/editors/emacs/windows/tags.txt new file mode 100644 index 0000000000..6bf68304bb --- /dev/null +++ b/basis/editors/emacs/windows/tags.txt @@ -0,0 +1 @@ +unportable diff --git a/basis/functors/functors-tests.factor b/basis/functors/functors-tests.factor index b4417532b4..37ec1d3e15 100644 --- a/basis/functors/functors-tests.factor +++ b/basis/functors/functors-tests.factor @@ -43,8 +43,6 @@ WHERE >> -\ sqsq must-infer - [ 16 ] [ 2 sqsq ] unit-test << diff --git a/basis/furnace/auth/auth-tests.factor b/basis/furnace/auth/auth-tests.factor index 220a8cd04c..54c32e7b4a 100644 --- a/basis/furnace/auth/auth-tests.factor +++ b/basis/furnace/auth/auth-tests.factor @@ -1,6 +1,3 @@ USING: furnace.auth tools.test ; IN: furnace.auth.tests -\ logged-in-username must-infer -\ must-infer -\ new-realm must-infer diff --git a/basis/furnace/auth/features/edit-profile/edit-profile-tests.factor b/basis/furnace/auth/features/edit-profile/edit-profile-tests.factor index d0fdf22c27..996047e83d 100644 --- a/basis/furnace/auth/features/edit-profile/edit-profile-tests.factor +++ b/basis/furnace/auth/features/edit-profile/edit-profile-tests.factor @@ -1,4 +1,4 @@ IN: furnace.auth.features.edit-profile.tests USING: tools.test furnace.auth.features.edit-profile ; -\ allow-edit-profile must-infer + diff --git a/basis/furnace/auth/features/recover-password/recover-password-tests.factor b/basis/furnace/auth/features/recover-password/recover-password-tests.factor index b589c52624..313b8ef397 100644 --- a/basis/furnace/auth/features/recover-password/recover-password-tests.factor +++ b/basis/furnace/auth/features/recover-password/recover-password-tests.factor @@ -1,4 +1,4 @@ IN: furnace.auth.features.recover-password USING: tools.test furnace.auth.features.recover-password ; -\ allow-password-recovery must-infer + diff --git a/basis/furnace/auth/features/registration/registration-tests.factor b/basis/furnace/auth/features/registration/registration-tests.factor index e770f35586..42acda416c 100644 --- a/basis/furnace/auth/features/registration/registration-tests.factor +++ b/basis/furnace/auth/features/registration/registration-tests.factor @@ -1,4 +1,4 @@ IN: furnace.auth.features.registration.tests USING: tools.test furnace.auth.features.registration ; -\ allow-registration must-infer + diff --git a/basis/furnace/auth/login/login-tests.factor b/basis/furnace/auth/login/login-tests.factor index 64f7bd3b96..aabd0c5c30 100644 --- a/basis/furnace/auth/login/login-tests.factor +++ b/basis/furnace/auth/login/login-tests.factor @@ -1,4 +1,4 @@ IN: furnace.auth.login.tests USING: tools.test furnace.auth.login ; -\ must-infer + diff --git a/basis/furnace/db/db-tests.factor b/basis/furnace/db/db-tests.factor index 34357ae701..15698d8e9b 100644 --- a/basis/furnace/db/db-tests.factor +++ b/basis/furnace/db/db-tests.factor @@ -1,4 +1,4 @@ IN: furnace.db.tests USING: tools.test furnace.db ; -\ must-infer + diff --git a/basis/help/cookbook/cookbook.factor b/basis/help/cookbook/cookbook.factor index 9bb76f8d5a..59486a9c35 100644 --- a/basis/help/cookbook/cookbook.factor +++ b/basis/help/cookbook/cookbook.factor @@ -12,7 +12,7 @@ $nl $nl "Factor evaluates code left to right, and stores intermediate values on a " { $emphasis "stack" } ". If you think of the stack as a pile of papers, then " { $emphasis "pushing" } " a value on the stack corresponds to placing a piece of paper at the top of the pile, while " { $emphasis "popping" } " a value corresponds to removing the topmost piece." $nl -"All words except those which only push literals on the stack must have a " { $emphasis "stack effect declaration" } ", for example " { $snippet "( x y -- z )" } " denotes that a word takes two inputs, with " { $snippet "y" } " at the top of the stack, and returns one output. Stack effect declarations can be viewed by browsing source code, or using tools such as " { $link see } "; they are also checked by the compiler. See " { $link "effect-declaration" } "." +"All words have a " { $emphasis "stack effect declaration" } ", for example " { $snippet "( x y -- z )" } " denotes that a word takes two inputs, with " { $snippet "y" } " at the top of the stack, and returns one output. Stack effect declarations can be viewed by browsing source code, or using tools such as " { $link see } "; they are also checked by the compiler. See " { $link "effects" } "." $nl "Coming back to the example in the beginning of this article, the following series of steps occurs as the code is evaluated:" { $table @@ -56,18 +56,9 @@ $nl "5 0 - ! Computes 5-0" "5 0 swap - ! Computes 0-5" } -"Also, in the above example a stack effect declaration is written between " { $snippet "(" } " and " { $snippet ")" } " with a mnemonic description of what the word does to the stack. See " { $link "effect-declaration" } " for details." +"Also, in the above example a stack effect declaration is written between " { $snippet "(" } " and " { $snippet ")" } " with a mnemonic description of what the word does to the stack. See " { $link "effects" } " for details." { $curious - "This syntax will be familiar to anybody who has used Forth before. However the behavior is slightly different. In most Forth systems, the below code prints 2, because the definition of " { $snippet "b" } " still refers to the previous definition of " { $snippet "a" } ":" - { $code - ": a 1 ;" - ": b ( -- x ) a 1 + ;" - ": a 2 ;" - "b ." - } - "In Factor, this example will print 3 since word redefinition is explicitly supported." - $nl - "Indeed, redefining a word twice in the same source file is an error; this is almost always a mistake since there's no way to call the first definition. See " { $link "definition-checking" } "." + "This syntax will be familiar to anybody who has used Forth before. However, unlike Forth, some additional static checks are performed. See " { $link "definition-checking" } " and " { $link "inference" } "." } { $references { "A whole slew of shuffle words can be used to rearrange the stack. There are forms of word definition other than colon definition, words can be defined entirely at runtime, and word definitions can be " { $emphasis "annotated" } " with tracing calls and breakpoints without modifying the source code." } @@ -175,53 +166,11 @@ $nl "parser" } ; -ARTICLE: "cookbook-io" "Input and output cookbook" -"Ask the user for their age, and print it back:" -{ $code - "USING: io math.parser ;" - ": ask-age ( -- ) \"How old are you?\" print ;" - ": read-age ( -- n ) readln string>number ;" - ": print-age ( n -- )" - " \"You are \" write" - " number>string write" - " \" years old.\" print ;" - ": example ( -- ) ask-age read-age print-age ;" - "example" -} -"Print the lines of a file in sorted order:" -{ $code - "USING: io io.encodings.utf8 io.files sequences sorting ;" - "\"lines.txt\" utf8 file-lines natural-sort [ print ] each" -} -"Read 1024 bytes from a file:" -{ $code - "USING: io io.encodings.binary io.files ;" - "\"data.bin\" binary [ 1024 read ] with-file-reader" -} -"Convert a file of 4-byte cells from little to big endian or vice versa, by directly mapping it into memory and operating on it with sequence words:" -{ $code - "USING: accessors grouping io.files io.mmap.char kernel sequences ;" - "\"mydata.dat\" [" - " 4 [ reverse-here ] change-each" - "] with-mapped-char-file" -} -"Send some bytes to a remote host:" -{ $code - "USING: io io.encodings.ascii io.sockets strings ;" - "\"myhost\" 1033 ascii" - "[ B{ 12 17 102 } write ] with-client" -} -{ $references - { } - "number-strings" - "io" -} ; - ARTICLE: "cookbook-application" "Application cookbook" "Vocabularies can define a main entry point:" { $code "IN: game-of-life" "..." -": play-life ... ;" +": play-life ( -- ) ... ;" "" "MAIN: play-life" } @@ -318,7 +267,6 @@ $nl { "Use " { $link "cleave-combinators" } " and " { $link "spread-combinators" } " instead of " { $link "shuffle-words" } " to give your code more structure." } { "Not everything has to go on the stack. The " { $vocab-link "namespaces" } " vocabulary provides dynamically-scoped variables, and the " { $vocab-link "locals" } " vocabulary provides lexically-scoped variables. Learn both and use them where they make sense, but keep in mind that overuse of variables makes code harder to factor." } "Every time you define a word which simply manipulates sequences, hashtables or objects in an abstract way which is not related to your program domain, check the library to see if you can reuse an existing definition." - { "Learn to use the " { $link "inference" } " tool." } { "Write unit tests. Factor provides good support for unit testing; see " { $link "tools.test" } ". Once your program has a good test suite you can refactor with confidence and catch regressions early." } "Don't write Factor as if it were C. Imperative programming and indexed loops are almost always not the most idiomatic solution." { "Use sequences, assocs and objects to group related data. Object allocation is very cheap. Don't be afraid to create tuples, pairs and triples. Don't be afraid of operations which allocate new objects either, such as " { $link append } "." } @@ -332,6 +280,7 @@ $nl "Factor tries to implement as much of itself as possible, because this improves simplicity and performance. One consequence is that Factor exposes its internals for extension and study. You even have the option of using low-level features not usually found in high-level languages, such manual memory management, pointer arithmetic, and inline assembly code." $nl "Unsafe features are tucked away so that you will not invoke them by accident, or have to use them to solve conventional programming problems. However when the need arises, unsafe features are invaluable, for example you might have to do some pointer arithmetic when interfacing directly with C libraries." ; + ARTICLE: "cookbook-pitfalls" "Pitfalls to avoid" "Factor is a very clean and consistent language. However, it has some limitations and leaky abstractions you should keep in mind, as well as behaviors which differ from other languages you may be used to." { $list @@ -341,13 +290,6 @@ ARTICLE: "cookbook-pitfalls" "Pitfalls to avoid" { "If a literal object appears in a word definition, the object itself is pushed on the stack when the word executes, not a copy. If you intend to mutate this object, you must " { $link clone } " it first. See " { $link "syntax-literals" } "." } { "For a discussion of potential issues surrounding the " { $link f } " object, see " { $link "booleans" } "." } { "Factor's object system is quite flexible. Careless usage of union, mixin and predicate classes can lead to similar problems to those caused by “multiple inheritance” in other languages. In particular, it is possible to have two classes such that they have a non-empty intersection and yet neither is a subclass of the other. If a generic word defines methods on two such classes, various disambiguation rules are applied to ensure method dispatch remains deterministic, however they may not be what you expect. See " { $link "method-order" } " for details." } - { "Performance-sensitive code should have a static stack effect so that it can be compiled by the optimizing word compiler, which generates more efficient code than the non-optimizing quotation compiler. See " { $link "inference" } " and " { $link "compiler" } "." - $nl - "This means that methods defined on performance sensitive, frequently-called core generic words such as " { $link nth } " should have static stack effects which are consistent with each other, since a generic word will only have a static stack effect if all methods do." - $nl - "Unit tests for the " { $vocab-link "stack-checker" } " vocabulary can be used to ensure that any methods your vocabulary defines on core generic words have static stack effects:" - { $code "\"stack-checker\" test" } - "In general, you should strive to write code with inferable stack effects, even for sections of a program which are not performance sensitive; the " { $link infer. } " tool together with the optimizing compiler's error reporting can catch many bugs ahead of time." } { "Be careful when calling words which access variables from a " { $link make-assoc } " which constructs an assoc with arbitrary keys, since those keys might shadow variables." } { "If " { $link run-file } " throws a stack depth assertion, it means that the top-level form in the file left behind values on the stack. The stack depth is compared before and after loading a source file, since this type of situation is almost always an error. If you have a legitimate need to load a source file which returns data in some manner, define a word in the source file which produces this data on the stack and call the word after loading the file." } } ; @@ -372,7 +314,6 @@ ARTICLE: "cookbook" "Factor cookbook" { $subsection "cookbook-combinators" } { $subsection "cookbook-variables" } { $subsection "cookbook-vocabs" } -{ $subsection "cookbook-io" } { $subsection "cookbook-application" } { $subsection "cookbook-scripts" } { $subsection "cookbook-philosophy" } diff --git a/basis/help/crossref/crossref-docs.factor b/basis/help/crossref/crossref-docs.factor index ae227fde89..7f243ec764 100644 --- a/basis/help/crossref/crossref-docs.factor +++ b/basis/help/crossref/crossref-docs.factor @@ -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 ; diff --git a/basis/help/crossref/crossref.factor b/basis/help/crossref/crossref.factor index b791a4b124..46f9561605 100644 --- a/basis/help/crossref/crossref.factor +++ b/basis/help/crossref/crossref.factor @@ -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 diff --git a/basis/help/handbook/handbook.factor b/basis/help/handbook/handbook.factor index a97a46badc..262c46bbc3 100644 --- a/basis/help/handbook/handbook.factor +++ b/basis/help/handbook/handbook.factor @@ -39,7 +39,7 @@ $nl { { $snippet "$" { $emphasis "foo" } } { "help markup" } { $links $heading $emphasis } } } { $heading "Stack effect conventions" } -"Stack effect conventions are documented in " { $link "effect-declaration" } "." +"Stack effect conventions are documented in " { $link "effects" } "." { $heading "Glossary of terms" } "Common terminology and abbreviations used throughout Factor and its documentation:" { $table @@ -229,9 +229,11 @@ ARTICLE: "handbook-language-reference" "The language" { $heading "Fundamentals" } { $subsection "conventions" } { $subsection "syntax" } -{ $subsection "effects" } +{ $heading "The stack" } { $subsection "evaluator" } -{ $heading "Data types" } +{ $subsection "effects" } +{ $subsection "inference" } +{ $heading "Basic data types" } { $subsection "booleans" } { $subsection "numbers" } { $subsection "collections" } @@ -239,16 +241,18 @@ ARTICLE: "handbook-language-reference" "The language" { $subsection "words" } { $subsection "shuffle-words" } { $subsection "combinators" } -{ $subsection "errors" } -{ $subsection "continuations" } +{ $subsection "threads" } { $heading "Named values" } { $subsection "locals" } { $subsection "namespaces" } { $subsection "namespaces-global" } { $subsection "values" } { $heading "Abstractions" } +{ $subsection "errors" } { $subsection "objects" } { $subsection "destructors" } +{ $subsection "continuations" } +{ $subsection "memoize" } { $subsection "parsing-words" } { $subsection "macros" } { $subsection "fry" } @@ -263,6 +267,7 @@ ARTICLE: "handbook-system-reference" "The implementation" { $subsection "vocabularies" } { $subsection "source-files" } { $subsection "compiler" } +{ $subsection "tools.errors" } { $heading "Virtual machine" } { $subsection "images" } { $subsection "cli" } @@ -283,7 +288,7 @@ ARTICLE: "handbook-tools-reference" "Developer tools" { $subsection "prettyprint" } { $subsection "inspector" } { $subsection "tools.annotations" } -{ $subsection "inference" } +{ $subsection "tools.inference" } { $heading "Browsing" } { $subsection "see" } { $subsection "tools.crossref" } diff --git a/basis/help/help.factor b/basis/help/help.factor index d20e06b6c6..956bc220e1 100644 --- a/basis/help/help.factor +++ b/basis/help/help.factor @@ -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 -- ) diff --git a/basis/help/markup/markup-tests.factor b/basis/help/markup/markup-tests.factor index 9b928f3691..93bed37a55 100644 --- a/basis/help/markup/markup-tests.factor +++ b/basis/help/markup/markup-tests.factor @@ -5,7 +5,7 @@ IN: help.markup.tests TUPLE: blahblah quux ; -[ "an int" ] [ [ { "int" } $instance ] with-string-writer ] unit-test +[ "int" ] [ [ { "int" } $instance ] with-string-writer ] unit-test [ ] [ \ quux>> print-topic ] unit-test [ ] [ \ >>quux print-topic ] unit-test @@ -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 \ No newline at end of file diff --git a/basis/help/markup/markup.factor b/basis/help/markup/markup.factor index 8b5edf38c1..04b6d90883 100644 --- a/basis/help/markup/markup.factor +++ b/basis/help/markup/markup.factor @@ -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 ; diff --git a/basis/help/topics/topics-tests.factor b/basis/help/topics/topics-tests.factor index ac9223b5d2..cafeb009a4 100644 --- a/basis/help/topics/topics-tests.factor +++ b/basis/help/topics/topics-tests.factor @@ -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." }
{ "test" "b" } add-article ] unit-test diff --git a/basis/hints/hints.factor b/basis/hints/hints.factor index d44bf92bf4..d445bf72ad 100644 --- a/basis/hints/hints.factor +++ b/basis/hints/hints.factor @@ -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 ] - [ "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 diff --git a/basis/html/components/components-tests.factor b/basis/html/components/components-tests.factor index 72ceea20a0..da2e5b5991 100644 --- a/basis/html/components/components-tests.factor +++ b/basis/html/components/components-tests.factor @@ -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 diff --git a/basis/http/client/client-tests.factor b/basis/http/client/client-tests.factor index 4dcc6b8813..4f786cb22c 100644 --- a/basis/http/client/client-tests.factor +++ b/basis/http/client/client-tests.factor @@ -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 diff --git a/basis/http/server/dispatchers/dispatchers-tests.factor b/basis/http/server/dispatchers/dispatchers-tests.factor index 2c8db27259..08974aca3b 100644 --- a/basis/http/server/dispatchers/dispatchers-tests.factor +++ b/basis/http/server/dispatchers/dispatchers-tests.factor @@ -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 diff --git a/basis/http/server/redirection/redirection-tests.factor b/basis/http/server/redirection/redirection-tests.factor index 14855ca875..72ff111db9 100644 --- a/basis/http/server/redirection/redirection-tests.factor +++ b/basis/http/server/redirection/redirection-tests.factor @@ -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 - [ diff --git a/basis/http/server/server-tests.factor b/basis/http/server/server-tests.factor index 171973fcd8..3dc97098a4 100644 --- a/basis/http/server/server-tests.factor +++ b/basis/http/server/server-tests.factor @@ -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" ] [ "text/plain" >>content-type diff --git a/basis/inverse/inverse-tests.factor b/basis/inverse/inverse-tests.factor index 9d81992eae..75e1198658 100644 --- a/basis/inverse/inverse-tests.factor +++ b/basis/inverse/inverse-tests.factor @@ -83,3 +83,9 @@ C: nil [ [ sqrt ] ] [ [ sq ] [undo] ] unit-test [ [ not ] ] [ [ not ] [undo] ] unit-test [ { 3 2 1 } ] [ { 1 2 3 } [ reverse ] undo ] unit-test + +TUPLE: funny-tuple ; +: ( -- funny-tuple ) \ funny-tuple boa ; +: funny-tuple ( -- ) "OOPS" throw ; + +[ ] [ [ ] [undo] drop ] unit-test \ No newline at end of file diff --git a/basis/inverse/inverse.factor b/basis/inverse/inverse.factor index 3a86703caf..a988063293 100755 --- a/basis/inverse/inverse.factor +++ b/basis/inverse/inverse.factor @@ -74,7 +74,9 @@ UNION: explicit-inverse normal-inverse math-inverse pop-inverse ; : fold-word ( stack word -- stack ) 2dup enough? - [ 1quotation with-datastack ] [ [ % ] [ , ] bi* { } ] if ; + [ 1quotation with-datastack ] + [ [ [ literalize , ] each ] [ , ] bi* { } ] + if ; : fold ( quot -- folded-quot ) [ { } [ fold-word ] reduce % ] [ ] make ; @@ -217,9 +219,7 @@ DEFER: _ "predicate" word-prop [ dupd call assure ] curry ; : slot-readers ( class -- quot ) - all-slots - [ name>> reader-word 1quotation [ keep ] curry ] map concat - [ ] like [ drop ] compose ; + all-slots [ name>> reader-word 1quotation ] map [ cleave ] curry ; : ?wrapped ( object -- wrapped ) dup wrapper? [ wrapped>> ] when ; diff --git a/basis/io/encodings/8-bit/8-bit-tests.factor b/basis/io/encodings/8-bit/8-bit-tests.factor index 8b18e2a9af..55b9c44934 100644 --- a/basis/io/encodings/8-bit/8-bit-tests.factor +++ b/basis/io/encodings/8-bit/8-bit-tests.factor @@ -4,11 +4,11 @@ IN: io.encodings.8-bit.tests [ B{ CHAR: f CHAR: o CHAR: o } ] [ "foo" latin1 encode ] unit-test [ { 256 } >string latin1 encode ] must-fail -[ B{ 255 } ] [ { 255 } latin1 encode ] unit-test +[ B{ 255 } ] [ { 255 } >string latin1 encode ] unit-test [ "bar" ] [ "bar" latin1 decode ] unit-test -[ { CHAR: b 233 CHAR: r } ] [ { CHAR: b 233 CHAR: r } latin1 decode >array ] unit-test -[ { HEX: fffd HEX: 20AC } ] [ { HEX: 81 HEX: 80 } windows-1252 decode >array ] unit-test +[ { CHAR: b 233 CHAR: r } ] [ B{ CHAR: b 233 CHAR: r } latin1 decode >array ] unit-test +[ { HEX: fffd HEX: 20AC } ] [ B{ HEX: 81 HEX: 80 } windows-1252 decode >array ] unit-test [ t ] [ \ latin1 8-bit-encoding? ] unit-test [ "bar" ] [ "bar" \ latin1 decode ] unit-test diff --git a/basis/io/encodings/ascii/ascii-tests.factor b/basis/io/encodings/ascii/ascii-tests.factor index 4f6d28835a..fcd549d31f 100644 --- a/basis/io/encodings/ascii/ascii-tests.factor +++ b/basis/io/encodings/ascii/ascii-tests.factor @@ -3,7 +3,7 @@ IN: io.encodings.ascii.tests [ B{ CHAR: f CHAR: o CHAR: o } ] [ "foo" ascii encode ] unit-test [ { 128 } >string ascii encode ] must-fail -[ B{ 127 } ] [ { 127 } ascii encode ] unit-test +[ B{ 127 } ] [ { 127 } >string ascii encode ] unit-test [ "bar" ] [ "bar" ascii decode ] unit-test -[ { CHAR: b HEX: fffd CHAR: r } ] [ { CHAR: b 233 CHAR: r } ascii decode >array ] unit-test +[ { CHAR: b HEX: fffd CHAR: r } ] [ B{ CHAR: b 233 CHAR: r } ascii decode >array ] unit-test diff --git a/basis/io/encodings/gb18030/gb18030-tests.factor b/basis/io/encodings/gb18030/gb18030-tests.factor index 20ea522a4d..da44d1cf9a 100644 --- a/basis/io/encodings/gb18030/gb18030-tests.factor +++ b/basis/io/encodings/gb18030/gb18030-tests.factor @@ -6,7 +6,7 @@ IN: io.encodings.gb18030.tests [ "hello" ] [ "hello" gb18030 encode >string ] unit-test [ "hello" ] [ "hello" gb18030 decode ] unit-test [ B{ HEX: A1 HEX: A4 HEX: 81 HEX: 30 HEX: 86 HEX: 30 } ] -[ B{ HEX: B7 HEX: B8 } gb18030 encode ] unit-test +[ B{ HEX: B7 HEX: B8 } >string gb18030 encode ] unit-test [ { HEX: B7 HEX: B8 } ] [ B{ HEX: A1 HEX: A4 HEX: 81 HEX: 30 HEX: 86 HEX: 30 } gb18030 decode >array ] unit-test [ { HEX: B7 CHAR: replacement-character } ] @@ -18,9 +18,9 @@ IN: io.encodings.gb18030.tests [ { HEX: B7 } ] [ B{ HEX: A1 HEX: A4 } gb18030 decode >array ] unit-test [ { CHAR: replacement-character } ] -[ B{ HEX: A1 } gb18030 decode >array ] unit-test +[ B{ HEX: A1 } >string gb18030 decode >array ] unit-test [ { HEX: 44D7 HEX: 464B } ] [ B{ HEX: 82 HEX: 33 HEX: A3 HEX: 39 HEX: 82 HEX: 33 HEX: C9 HEX: 31 } gb18030 decode >array ] unit-test [ { HEX: 82 HEX: 33 HEX: A3 HEX: 39 HEX: 82 HEX: 33 HEX: C9 HEX: 31 } ] -[ { HEX: 44D7 HEX: 464B } gb18030 encode >array ] unit-test +[ { HEX: 44D7 HEX: 464B } >string gb18030 encode >array ] unit-test diff --git a/basis/io/encodings/utf16/utf16-tests.factor b/basis/io/encodings/utf16/utf16-tests.factor index 230612cc77..e16c1f822e 100644 --- a/basis/io/encodings/utf16/utf16-tests.factor +++ b/basis/io/encodings/utf16/utf16-tests.factor @@ -1,25 +1,25 @@ ! Copyright (C) 2008 Daniel Ehrenberg. ! See http://factorcode.org/license.txt for BSD license. USING: kernel tools.test io.encodings.utf16 arrays sbufs -io.streams.byte-array sequences io.encodings io +io.streams.byte-array sequences io.encodings io strings io.encodings.string alien.c-types alien.strings accessors classes ; IN: io.encodings.utf16.tests -[ { CHAR: x } ] [ { 0 CHAR: x } utf16be decode >array ] unit-test -[ { HEX: 1D11E } ] [ { HEX: D8 HEX: 34 HEX: DD HEX: 1E } utf16be decode >array ] unit-test -[ { CHAR: replacement-character } ] [ { BIN: 11011111 CHAR: q } utf16be decode >array ] unit-test -[ { CHAR: replacement-character } ] [ { BIN: 11011011 CHAR: x BIN: 11011011 CHAR: x } utf16be decode >array ] unit-test +[ { CHAR: x } ] [ B{ 0 CHAR: x } utf16be decode >array ] unit-test +[ { HEX: 1D11E } ] [ B{ HEX: D8 HEX: 34 HEX: DD HEX: 1E } utf16be decode >array ] unit-test +[ { CHAR: replacement-character } ] [ B{ BIN: 11011111 CHAR: q } utf16be decode >array ] unit-test +[ { CHAR: replacement-character } ] [ B{ BIN: 11011011 CHAR: x BIN: 11011011 CHAR: x } utf16be decode >array ] unit-test -[ { 0 120 216 52 221 30 } ] [ { CHAR: x HEX: 1d11e } utf16be encode >array ] unit-test +[ { 0 120 216 52 221 30 } ] [ { CHAR: x HEX: 1d11e } >string utf16be encode >array ] unit-test -[ { CHAR: x } ] [ { CHAR: x 0 } utf16le decode >array ] unit-test -[ { 119070 } ] [ { HEX: 34 HEX: D8 HEX: 1E HEX: DD } utf16le decode >array ] unit-test -[ { CHAR: replacement-character } ] [ { 0 BIN: 11011111 } utf16le decode >array ] unit-test -[ { CHAR: replacement-character } ] [ { 0 BIN: 11011011 0 0 } utf16le decode >array ] unit-test +[ { CHAR: x } ] [ B{ CHAR: x 0 } utf16le decode >array ] unit-test +[ { 119070 } ] [ B{ HEX: 34 HEX: D8 HEX: 1E HEX: DD } >string utf16le decode >array ] unit-test +[ { CHAR: replacement-character } ] [ { 0 BIN: 11011111 } >string utf16le decode >array ] unit-test +[ { CHAR: replacement-character } ] [ { 0 BIN: 11011011 0 0 } >string utf16le decode >array ] unit-test -[ { 120 0 52 216 30 221 } ] [ { CHAR: x HEX: 1d11e } utf16le encode >array ] unit-test +[ { 120 0 52 216 30 221 } ] [ { CHAR: x HEX: 1d11e } >string utf16le encode >array ] unit-test -[ { CHAR: x } ] [ { HEX: ff HEX: fe CHAR: x 0 } utf16 decode >array ] unit-test -[ { CHAR: x } ] [ { HEX: fe HEX: ff 0 CHAR: x } utf16 decode >array ] unit-test +[ { CHAR: x } ] [ B{ HEX: ff HEX: fe CHAR: x 0 } utf16 decode >array ] unit-test +[ { CHAR: x } ] [ B{ HEX: fe HEX: ff 0 CHAR: x } utf16 decode >array ] unit-test -[ { HEX: ff HEX: fe 120 0 52 216 30 221 } ] [ { CHAR: x HEX: 1d11e } utf16 encode >array ] unit-test +[ { HEX: ff HEX: fe 120 0 52 216 30 221 } ] [ { CHAR: x HEX: 1d11e } >string utf16 encode >array ] unit-test diff --git a/basis/io/encodings/utf32/utf32-tests.factor b/basis/io/encodings/utf32/utf32-tests.factor index be1111e242..2a80e47c7b 100644 --- a/basis/io/encodings/utf32/utf32-tests.factor +++ b/basis/io/encodings/utf32/utf32-tests.factor @@ -1,30 +1,30 @@ ! Copyright (C) 2009 Daniel Ehrenberg. ! See http://factorcode.org/license.txt for BSD license. USING: kernel tools.test io.encodings.utf32 arrays sbufs -io.streams.byte-array sequences io.encodings io +io.streams.byte-array sequences io.encodings io strings io.encodings.string alien.c-types alien.strings accessors classes ; IN: io.encodings.utf32.tests -[ { CHAR: x } ] [ { 0 0 0 CHAR: x } utf32be decode >array ] unit-test -[ { HEX: 1D11E } ] [ { 0 1 HEX: D1 HEX: 1E } utf32be decode >array ] unit-test -[ { CHAR: replacement-character } ] [ { 0 1 HEX: D1 } utf32be decode >array ] unit-test -[ { CHAR: replacement-character } ] [ { 0 1 } utf32be decode >array ] unit-test -[ { CHAR: replacement-character } ] [ { 0 } utf32be decode >array ] unit-test +[ { CHAR: x } ] [ B{ 0 0 0 CHAR: x } utf32be decode >array ] unit-test +[ { HEX: 1D11E } ] [ B{ 0 1 HEX: D1 HEX: 1E } utf32be decode >array ] unit-test +[ { CHAR: replacement-character } ] [ B{ 0 1 HEX: D1 } utf32be decode >array ] unit-test +[ { CHAR: replacement-character } ] [ B{ 0 1 } utf32be decode >array ] unit-test +[ { CHAR: replacement-character } ] [ B{ 0 } utf32be decode >array ] unit-test [ { } ] [ { } utf32be decode >array ] unit-test -[ { 0 0 0 CHAR: x 0 1 HEX: D1 HEX: 1E } ] [ { CHAR: x HEX: 1d11e } utf32be encode >array ] unit-test +[ { 0 0 0 CHAR: x 0 1 HEX: D1 HEX: 1E } ] [ { CHAR: x HEX: 1d11e } >string utf32be encode >array ] unit-test -[ { CHAR: x } ] [ { CHAR: x 0 0 0 } utf32le decode >array ] unit-test -[ { HEX: 1d11e } ] [ { HEX: 1e HEX: d1 1 0 } utf32le decode >array ] unit-test -[ { CHAR: replacement-character } ] [ { HEX: 1e HEX: d1 1 } utf32le decode >array ] unit-test -[ { CHAR: replacement-character } ] [ { HEX: 1e HEX: d1 } utf32le decode >array ] unit-test -[ { CHAR: replacement-character } ] [ { HEX: 1e } utf32le decode >array ] unit-test +[ { CHAR: x } ] [ B{ CHAR: x 0 0 0 } utf32le decode >array ] unit-test +[ { HEX: 1d11e } ] [ B{ HEX: 1e HEX: d1 1 0 } utf32le decode >array ] unit-test +[ { CHAR: replacement-character } ] [ B{ HEX: 1e HEX: d1 1 } utf32le decode >array ] unit-test +[ { CHAR: replacement-character } ] [ B{ HEX: 1e HEX: d1 } utf32le decode >array ] unit-test +[ { CHAR: replacement-character } ] [ B{ HEX: 1e } utf32le decode >array ] unit-test [ { } ] [ { } utf32le decode >array ] unit-test -[ { 120 0 0 0 HEX: 1e HEX: d1 1 0 } ] [ { CHAR: x HEX: 1d11e } utf32le encode >array ] unit-test +[ { 120 0 0 0 HEX: 1e HEX: d1 1 0 } ] [ { CHAR: x HEX: 1d11e } >string utf32le encode >array ] unit-test -[ { CHAR: x } ] [ { HEX: ff HEX: fe 0 0 CHAR: x 0 0 0 } utf32 decode >array ] unit-test -[ { CHAR: x } ] [ { 0 0 HEX: fe HEX: ff 0 0 0 CHAR: x } utf32 decode >array ] unit-test +[ { CHAR: x } ] [ B{ HEX: ff HEX: fe 0 0 CHAR: x 0 0 0 } utf32 decode >array ] unit-test +[ { CHAR: x } ] [ B{ 0 0 HEX: fe HEX: ff 0 0 0 CHAR: x } utf32 decode >array ] unit-test -[ { HEX: ff HEX: fe 0 0 120 0 0 0 HEX: 1e HEX: d1 1 0 } ] [ { CHAR: x HEX: 1d11e } utf32 encode >array ] unit-test +[ { HEX: ff HEX: fe 0 0 120 0 0 0 HEX: 1e HEX: d1 1 0 } ] [ { CHAR: x HEX: 1d11e } >string utf32 encode >array ] unit-test diff --git a/basis/io/files/info/info-tests.factor b/basis/io/files/info/info-tests.factor index b94bc0635c..7b19f56b10 100644 --- a/basis/io/files/info/info-tests.factor +++ b/basis/io/files/info/info-tests.factor @@ -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" = diff --git a/basis/io/files/windows/nt/nt.factor b/basis/io/files/windows/nt/nt.factor index 9e449982fb..afc81c784c 100755 --- a/basis/io/files/windows/nt/nt.factor +++ b/basis/io/files/windows/nt/nt.factor @@ -4,7 +4,7 @@ io.backend.windows io.files.windows io.encodings.utf16n windows windows.kernel32 kernel libc math threads system environment alien.c-types alien.arrays alien.strings sequences combinators combinators.short-circuit ascii splitting alien strings assocs -namespaces make accessors tr windows.time ; +namespaces make accessors tr windows.time windows.shell32 ; IN: io.files.windows.nt M: winnt cwd @@ -58,4 +58,9 @@ M: winnt open-append [ dup windows-file-size ] [ drop 0 ] recover [ (open-append) ] dip >>ptr ; -M: winnt home "USERPROFILE" os-env ; +M: winnt home + { + [ "HOMEDRIVE" os-env "HOMEPATH" os-env append-path ] + [ "USERPROFILE" os-env ] + [ my-documents ] + } 0|| ; diff --git a/basis/io/launcher/launcher-tests.factor b/basis/io/launcher/launcher-tests.factor index 003f382020..da7284dbe5 100644 --- a/basis/io/launcher/launcher-tests.factor +++ b/basis/io/launcher/launcher-tests.factor @@ -1,6 +1,3 @@ IN: io.launcher.tests USING: tools.test io.launcher ; -\ must-infer -\ must-infer -\ must-infer diff --git a/basis/io/mmap/mmap-docs.factor b/basis/io/mmap/mmap-docs.factor index 5ef3400a6d..f0adb47321 100644 --- a/basis/io/mmap/mmap-docs.factor +++ b/basis/io/mmap/mmap-docs.factor @@ -54,11 +54,20 @@ ARTICLE: "io.mmap.arrays" "Memory-mapped arrays" ARTICLE: "io.mmap.low-level" "Reading and writing mapped files directly" "Data can be read and written from the " { $link mapped-file } " by applying low-level alien words to the " { $slot "address" } " slot. See " { $link "reading-writing-memory" } "." ; +ARTICLE: "io.mmap.examples" "Memory-mapped file example" +"Convert a file of 4-byte cells from little to big endian or vice versa, by directly mapping it into memory and operating on it with sequence words:" +{ $code + "USING: accessors grouping io.files io.mmap.char kernel sequences ;" + "\"mydata.dat\" [" + " 4 [ reverse-here ] change-each" + "] with-mapped-char-file" +} ; + ARTICLE: "io.mmap" "Memory-mapped files" "The " { $vocab-link "io.mmap" } " vocabulary implements support for memory-mapped files." { $subsection } "Memory-mapped files are disposable and can be closed with " { $link dispose } " or " { $link with-disposal } "." -$nl +{ $subsection "io.mmap.examples" } "A utility combinator which wraps the above:" { $subsection with-mapped-file } "Instances of " { $link mapped-file } " don't support any interesting operations in themselves. There are two facilities for accessing their contents:" diff --git a/basis/io/monitors/recursive/recursive-tests.factor b/basis/io/monitors/recursive/recursive-tests.factor index ace93ace44..db8e02ae73 100644 --- a/basis/io/monitors/recursive/recursive-tests.factor +++ b/basis/io/monitors/recursive/recursive-tests.factor @@ -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 ; diff --git a/basis/io/monitors/windows/nt/nt-tests.factor b/basis/io/monitors/windows/nt/nt-tests.factor index 79cd7e9e9f..a7ee649400 100644 --- a/basis/io/monitors/windows/nt/nt-tests.factor +++ b/basis/io/monitors/windows/nt/nt-tests.factor @@ -1,4 +1,4 @@ IN: io.monitors.windows.nt.tests USING: io.monitors.windows.nt tools.test ; -\ fill-queue-thread must-infer + diff --git a/basis/io/sockets/secure/unix/unix-tests.factor b/basis/io/sockets/secure/unix/unix-tests.factor index a3bfacc8a8..7c4dcc17d1 100644 --- a/basis/io/sockets/secure/unix/unix-tests.factor +++ b/basis/io/sockets/secure/unix/unix-tests.factor @@ -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 ; -\ must-infer { 1 0 } [ [ ] with-secure-context ] must-infer-as [ ] [ "port" set ] unit-test diff --git a/basis/io/sockets/sockets-docs.factor b/basis/io/sockets/sockets-docs.factor index a66ed1d0c0..970aa34ea6 100644 --- a/basis/io/sockets/sockets-docs.factor +++ b/basis/io/sockets/sockets-docs.factor @@ -56,12 +56,23 @@ $nl } "The " { $link inet } " address specifier is not supported by the " { $link send } " word because a single host name can resolve to any number of IPv4 or IPv6 addresses, therefore there is no way to know which address should be used. Applications should call " { $link resolve-host } " then use some kind of strategy to pick the correct address (for example, by sending a packet to each one and waiting for a response, or always assuming IPv4)." ; +ARTICLE: "network-examples" "Networking examples" +"Send some bytes to a remote host:" +{ $code + "USING: io io.encodings.ascii io.sockets strings ;" + "\"myhost\" 1033 ascii" + "[ B{ 12 17 102 } write ] with-client" +} +"Look up the IP addresses associated with a host name:" +{ $code "USING: io.sockets ;" "\"www.apple.com\" 80 resolve-host ." } ; + ARTICLE: "network-streams" "Networking" "Factor supports connection-oriented and packet-oriented communication over a variety of protocols:" { $list "TCP/IP and UDP/IP, over IPv4 and IPv6" "Unix domain sockets (Unix only)" } +{ $subsection "network-examples" } { $subsection "network-addressing" } { $subsection "network-connection" } { $subsection "network-packet" } diff --git a/basis/io/streams/byte-array/byte-array-tests.factor b/basis/io/streams/byte-array/byte-array-tests.factor index 44290bfb47..3cf52c6a78 100644 --- a/basis/io/streams/byte-array/byte-array-tests.factor +++ b/basis/io/streams/byte-array/byte-array-tests.factor @@ -1,11 +1,11 @@ USING: tools.test io.streams.byte-array io.encodings.binary io.encodings.utf8 io kernel arrays strings namespaces ; -[ B{ 1 2 3 } ] [ binary [ { 1 2 3 } write ] with-byte-writer ] unit-test +[ B{ 1 2 3 } ] [ binary [ B{ 1 2 3 } write ] with-byte-writer ] unit-test [ B{ 1 2 3 } ] [ { 1 2 3 } binary [ 3 read ] with-byte-reader ] unit-test [ B{ BIN: 11110101 BIN: 10111111 BIN: 10000000 BIN: 10111111 BIN: 11101111 BIN: 10000000 BIN: 10111111 BIN: 11011111 BIN: 10000000 CHAR: x } ] -[ { BIN: 101111111000000111111 BIN: 1111000000111111 BIN: 11111000000 CHAR: x } utf8 [ write ] with-byte-writer ] unit-test +[ { BIN: 101111111000000111111 BIN: 1111000000111111 BIN: 11111000000 CHAR: x } >string utf8 [ write ] with-byte-writer ] unit-test [ { BIN: 101111111000000111111 } t ] [ { BIN: 11110101 BIN: 10111111 BIN: 10000000 BIN: 10111111 } utf8 contents dup >array swap string? ] unit-test [ B{ 121 120 } 0 ] [ diff --git a/basis/io/streams/string/string.factor b/basis/io/streams/string/string.factor index a0087a70ee..85cb3022f5 100644 --- a/basis/io/streams/string/string.factor +++ b/basis/io/streams/string/string.factor @@ -33,5 +33,6 @@ M: sbuf stream-element-type drop +character+ ; 512 ; : with-string-writer ( quot -- str ) - swap [ output-stream get ] compose with-output-stream* - >string ; inline \ No newline at end of file + [ + swap with-output-stream* + ] keep >string ; inline \ No newline at end of file diff --git a/basis/io/styles/styles-tests.factor b/basis/io/styles/styles-tests.factor index 86c3681c2a..0259e4ab0b 100644 --- a/basis/io/styles/styles-tests.factor +++ b/basis/io/styles/styles-tests.factor @@ -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 \ No newline at end of file diff --git a/basis/io/styles/styles.factor b/basis/io/styles/styles.factor index 66b5f0458f..c3bf5d2f28 100644 --- a/basis/io/styles/styles.factor +++ b/basis/io/styles/styles.factor @@ -156,3 +156,5 @@ M: input summary ] "" make ; : write-object ( str obj -- ) presented associate format ; + +: write-image ( image -- ) [ "" ] dip image associate format ; diff --git a/basis/lcs/lcs-tests.factor b/basis/lcs/lcs-tests.factor index 7d9a9ffd27..3aa10a0687 100644 --- a/basis/lcs/lcs-tests.factor +++ b/basis/lcs/lcs-tests.factor @@ -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 diff --git a/basis/listener/listener.factor b/basis/listener/listener.factor index 4234a0023b..d96e0df6c1 100644 --- a/basis/listener/listener.factor +++ b/basis/listener/listener.factor @@ -60,7 +60,7 @@ SYMBOL: max-stack-items 10 max-stack-items set-global -SYMBOL: error-summary-hook +SYMBOL: error-summary? > 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 diff --git a/basis/locals/locals-tests.factor b/basis/locals/locals-tests.factor index d472a8b22b..68fa8dbda0 100644 --- a/basis/locals/locals-tests.factor +++ b/basis/locals/locals-tests.factor @@ -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 diff --git a/basis/macros/macros.factor b/basis/macros/macros.factor index a86b711340..0e5ef30f51 100644 --- a/basis/macros/macros.factor +++ b/basis/macros/macros.factor @@ -12,10 +12,11 @@ IN: macros PRIVATE> : define-macro ( word definition effect -- ) - real-macro-effect - [ [ memoize-quot [ call ] append ] keep define-declared ] - [ drop "macro" set-word-prop ] - 3bi ; + real-macro-effect { + [ [ memoize-quot [ call ] append ] keep define-declared ] + [ drop "macro" set-word-prop ] + [ 2drop changed-effect ] + } 3cleave ; SYNTAX: MACRO: (:) define-macro ; diff --git a/basis/math/bitwise/bitwise-tests.factor b/basis/math/bitwise/bitwise-tests.factor index 7698760f84..e10853af18 100644 --- a/basis/math/bitwise/bitwise-tests.factor +++ b/basis/math/bitwise/bitwise-tests.factor @@ -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 diff --git a/basis/math/intervals/intervals-tests.factor b/basis/math/intervals/intervals-tests.factor index 8b43456901..2b8b3dff24 100644 --- a/basis/math/intervals/intervals-tests.factor +++ b/basis/math/intervals/intervals-tests.factor @@ -302,8 +302,8 @@ IN: math.intervals.tests : comparison-test ( -- ? ) random-interval random-interval random-comparison - [ [ [ random-element ] bi@ ] dip first execute ] 3keep - second execute dup incomparable eq? [ 2drop t ] [ = ] if ; + [ [ [ random-element ] bi@ ] dip first execute( a b -- ? ) ] 3keep + second execute( a b -- ? ) dup incomparable eq? [ 2drop t ] [ = ] if ; [ t ] [ 40000 iota [ drop comparison-test ] all? ] unit-test diff --git a/basis/math/matrices/matrices.factor b/basis/math/matrices/matrices.factor index 7c687d753d..cfdbe17c06 100755 --- a/basis/math/matrices/matrices.factor +++ b/basis/math/matrices/matrices.factor @@ -1,6 +1,7 @@ ! Copyright (C) 2005, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: arrays kernel math math.order math.vectors sequences ; +USING: arrays kernel math math.order math.vectors +sequences sequences.private accessors columns ; IN: math.matrices ! Matrices diff --git a/basis/memoize/memoize-docs.factor b/basis/memoize/memoize-docs.factor index cfb5cffb37..a551272f43 100644 --- a/basis/memoize/memoize-docs.factor +++ b/basis/memoize/memoize-docs.factor @@ -3,6 +3,20 @@ USING: help.syntax help.markup words quotations effects ; IN: memoize +ARTICLE: "memoize" "Memoization" +"The " { $vocab-link "memoize" } " vocabulary implements a simple form of memoization, which is when a word caches results for every unique set of inputs that is supplied. Calling a memoized word with the same inputs more than once does not recalculate anything." +$nl +"Memoization is useful in situations where the set of possible inputs is small, but the results are expensive to compute and should be cached. Memoized words should not have any side effects." +$nl +"Defining a memoized word at parse time:" +{ $subsection POSTPONE: MEMO: } +"Defining a memoized word at run time:" +{ $subsection define-memoized } +"Clearing memoized results:" +{ $subsection reset-memoized } ; + +ABOUT: "memoize" + HELP: define-memoized { $values { "word" word } { "quot" quotation } { "effect" effect } } { $description "defines the given word at runtime as one which memoizes its output given a particular input" } diff --git a/basis/models/models-tests.factor b/basis/models/models-tests.factor index f875fa3140..7368a2aa54 100644 --- a/basis/models/models-tests.factor +++ b/basis/models/models-tests.factor @@ -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 diff --git a/basis/peg/ebnf/ebnf-tests.factor b/basis/peg/ebnf/ebnf-tests.factor index 58102cffc3..329156d733 100644 --- a/basis/peg/ebnf/ebnf-tests.factor +++ b/basis/peg/ebnf/ebnf-tests.factor @@ -300,8 +300,6 @@ main = Primary "x[i][j].y" primary ] unit-test -'ebnf' compile must-infer - { V{ V{ "a" "b" } "c" } } [ "abc" [EBNF a="a" "b" foo=(a "c") EBNF] ] unit-test diff --git a/basis/peg/peg-tests.factor b/basis/peg/peg-tests.factor index 7d5cb1e76a..683fa328d8 100644 --- a/basis/peg/peg-tests.factor +++ b/basis/peg/peg-tests.factor @@ -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 [ @@ -208,5 +206,3 @@ USE: compiler [ ] [ enable-compiler ] unit-test [ [ ] ] [ "" epsilon [ drop [ [ ] ] call ] action parse ] unit-test - -[ [ ] ] [ "" epsilon [ drop [ [ ] ] ] action [ call ] action parse ] unit-test \ No newline at end of file diff --git a/basis/peg/search/search-tests.factor b/basis/peg/search/search-tests.factor index 96d89d4611..b22a5ef0d0 100644 --- a/basis/peg/search/search-tests.factor +++ b/basis/peg/search/search-tests.factor @@ -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 diff --git a/basis/persistent/vectors/vectors-tests.factor b/basis/persistent/vectors/vectors-tests.factor index c232db8533..95fa70558d 100644 --- a/basis/persistent/vectors/vectors-tests.factor +++ b/basis/persistent/vectors/vectors-tests.factor @@ -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 diff --git a/basis/prettyprint/prettyprint-tests.factor b/basis/prettyprint/prettyprint-tests.factor index a660d4a311..25ee83985e 100644 --- a/basis/prettyprint/prettyprint-tests.factor +++ b/basis/prettyprint/prettyprint-tests.factor @@ -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 diff --git a/basis/regexp/parser/parser-tests.factor b/basis/regexp/parser/parser-tests.factor index 0e12014eef..5ea9753fba 100644 --- a/basis/regexp/parser/parser-tests.factor +++ b/basis/regexp/parser/parser-tests.factor @@ -4,7 +4,7 @@ IN: regexp.parser.tests : regexp-parses ( string -- ) [ [ ] ] dip '[ _ parse-regexp drop ] unit-test ; -: regexp-fails ( string -- regexp ) +: regexp-fails ( string -- ) '[ _ parse-regexp ] must-fail ; { diff --git a/basis/regexp/regexp-tests.factor b/basis/regexp/regexp-tests.factor index 0479b104cc..1f72fa04ba 100644 --- a/basis/regexp/regexp-tests.factor +++ b/basis/regexp/regexp-tests.factor @@ -4,10 +4,6 @@ USING: regexp tools.test kernel sequences regexp.parser regexp.private eval strings multiline accessors ; IN: regexp-tests -\ must-infer -\ compile-regexp must-infer -\ matches? must-infer - [ f ] [ "b" "a*" matches? ] unit-test [ t ] [ "" "a*" matches? ] unit-test [ t ] [ "a" "a*" matches? ] unit-test diff --git a/basis/smtp/smtp-tests.factor b/basis/smtp/smtp-tests.factor index df6510afbf..b8df0b7b5b 100644 --- a/basis/smtp/smtp-tests.factor +++ b/basis/smtp/smtp-tests.factor @@ -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 diff --git a/basis/smtp/smtp.factor b/basis/smtp/smtp.factor index bfba9ea28a..83457defa5 100644 --- a/basis/smtp/smtp.factor +++ b/basis/smtp/smtp.factor @@ -1,12 +1,12 @@ -! Copyright (C) 2007, 2008 Elie CHAFTARI, Dirk Vleugels, +! Copyright (C) 2007, 2009 Elie CHAFTARI, Dirk Vleugels, ! Slava Pestov, Doug Coleman, Daniel Ehrenberg. ! See http://factorcode.org/license.txt for BSD license. -USING: arrays namespaces make io io.encodings.string io.encodings.utf8 -io.encodings.iana io.timeouts io.sockets io.sockets.secure -io.encodings.ascii kernel logging sequences combinators splitting -assocs strings math.order math.parser random system calendar summary -calendar.format accessors sets hashtables base64 debugger classes -prettyprint io.crlf words ; +USING: arrays namespaces make io io.encodings io.encodings.string +io.encodings.utf8 io.encodings.iana io.encodings.binary +io.encodings.ascii io.timeouts io.sockets io.sockets.secure io.crlf +kernel logging sequences combinators splitting assocs strings +math.order math.parser random system calendar summary calendar.format +accessors sets hashtables base64 debugger classes prettyprint words ; IN: smtp SYMBOL: smtp-domain @@ -88,8 +88,9 @@ M: message-contains-dot summary ( obj -- string ) [ message-contains-dot ] when ; : send-body ( email -- ) - [ body>> ] [ encoding>> ] bi encode - >base64-lines write crlf + binary encode-output + [ body>> ] [ encoding>> ] bi encode >base64-lines write + ascii encode-output crlf "." command ; : quit ( -- ) diff --git a/basis/stack-checker/backend/backend.factor b/basis/stack-checker/backend/backend.factor index 9e867f4fbb..4fb5bab96f 100755 --- a/basis/stack-checker/backend/backend.factor +++ b/basis/stack-checker/backend/backend.factor @@ -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 @@ -121,19 +121,13 @@ M: object apply-object push-literal ; : infer-r> ( n -- ) consume-r dup copy-values [ nip output-d ] [ #r>, ] 2bi ; -: undo-infer ( -- ) - recorded get [ f "inferred-effect" set-word-prop ] each ; - -: (consume/produce) ( effect -- inputs outputs ) - [ in>> length consume-d ] [ out>> length produce-d ] bi ; - : consume/produce ( effect quot: ( inputs outputs -- ) -- ) - '[ (consume/produce) @ ] + '[ [ in>> length consume-d ] [ out>> length produce-d ] bi @ ] [ terminated?>> [ terminate ] when ] bi ; inline -: infer-word-def ( word -- ) - [ specialized-def ] [ add-recursive-state ] bi infer-quot ; +: apply-word/effect ( word effect -- ) + swap '[ _ #call, ] consume/produce ; : end-infer ( -- ) meta-d clone #return, ; @@ -141,56 +135,20 @@ M: object apply-object push-literal ; : 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 - call - end-infer - current-effect - stack-visitor get - ] [ ] [ undo-infer ] cleanup + init-inference + init-known-values + stack-visitor off + call + end-infer + current-effect + stack-visitor get ] with-scope ; inline diff --git a/basis/stack-checker/call-effect/call-effect.factor b/basis/stack-checker/call-effect/call-effect.factor index bd1f7c73c3..100088f174 100644 --- a/basis/stack-checker/call-effect/call-effect.factor +++ b/basis/stack-checker/call-effect/call-effect.factor @@ -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 \ No newline at end of file diff --git a/basis/stack-checker/errors/errors-docs.factor b/basis/stack-checker/errors/errors-docs.factor index 5b314a3154..7a87ab988d 100644 --- a/basis/stack-checker/errors/errors-docs.factor +++ b/basis/stack-checker/errors/errors-docs.factor @@ -3,10 +3,9 @@ sequences.private words ; IN: stack-checker.errors HELP: literal-expected -{ $error-description "Thrown when inference encounters a " { $link call } " or " { $link if } " being applied to a value which is not known to be a literal. Such a form can have an arbitrary stack effect, and does not compile." } -{ $notes "This error will be thrown when compiling any combinator, such as " { $link each } ". However, words calling combinators can compile if the combinator is declared " { $link POSTPONE: inline } " and the quotation being passed in is a literal." } +{ $error-description "Thrown when inference encounters a combinator or macro being applied to a value which is not known to be a literal, or constructed in a manner which can be analyzed statically. Such code needs changes before it can compile and run. See " { $link "inference-combinators" } " and " { $link "inference-escape" } " for details." } { $examples - "In this example, words calling " { $snippet "literal-expected-example" } " will compile, even if " { $snippet "literal-expected-example" } " does not compile itself:" + "In this example, words calling " { $snippet "literal-expected-example" } " will have a static stac keffect, even if " { $snippet "literal-expected-example" } " does not:" { $code ": literal-expected-example ( quot -- )" " [ call ] [ call ] bi ; inline" @@ -16,10 +15,8 @@ HELP: literal-expected HELP: unbalanced-branches-error { $values { "in" "a sequence of integers" } { "out" "a sequence of integers" } } { $description "Throws an " { $link unbalanced-branches-error } "." } -{ $error-description "Thrown when inference encounters an " { $link if } " or " { $link dispatch } " where the branches do not all exit with the same stack height." } -{ $notes "Conditionals with variable stack effects are considered to be bad style and should be avoided since they do not compile." -$nl -"If this error comes up when inferring the stack effect of a recursive word, check the word's stack effect declaration; it might be wrong." } +{ $error-description "Thrown when inference encounters an " { $link if } " or " { $link dispatch } " where the branches do not all exit with the same stack height. See " { $link "inference-branches" } " for details." } +{ $notes "If this error comes up when inferring the stack effect of a recursive word, check the word's stack effect declaration; it might be wrong." } { $examples { $code ": unbalanced-branches-example ( a b c -- )" @@ -86,25 +83,24 @@ HELP: inconsistent-recursive-call-error } } ; -ARTICLE: "inference-errors" "Inference warnings and errors" +ARTICLE: "inference-errors" "Stack checker errors" "These conditions are thrown by " { $link "inference" } ", as well as the " { $link "compiler" } "." $nl -"Main wrapper for all inference warnings and errors:" -{ $subsection inference-error } -"Inference warnings:" +"Error thrown when insufficient information is available to calculate the stack effect of a combinator call (see " { $link "inference-combinators" } "):" { $subsection literal-expected } -"Inference errors:" -{ $subsection recursive-quotation-error } -{ $subsection unbalanced-branches-error } +"Error thrown when a word's stack effect declaration does not match the composition of the stack effects of its factors:" { $subsection effect-error } -{ $subsection missing-effect } -"Inference errors for inline recursive words:" +"Error thrown when branches have incompatible stack effects (see " { $link "inference-branches" } "):" +{ $subsection unbalanced-branches-error } +"Inference errors for inline recursive words (see " { $link "inference-recursive-combinators" } "):" { $subsection undeclared-recursion-error } { $subsection diverging-recursion-error } { $subsection unbalanced-recursion-error } { $subsection inconsistent-recursive-call-error } -"Retain stack usage errors:" +"More obscure errors that are unlikely to arise in ordinary code:" +{ $subsection recursive-quotation-error } { $subsection too-many->r } -{ $subsection too-many-r> } ; +{ $subsection too-many-r> } +{ $subsection missing-effect } ; ABOUT: "inference-errors" diff --git a/basis/stack-checker/errors/errors.factor b/basis/stack-checker/errors/errors.factor index 156900f727..e036d4d81b 100644 --- a/basis/stack-checker/errors/errors.factor +++ b/basis/stack-checker/errors/errors.factor @@ -1,89 +1,36 @@ ! Copyright (C) 2006, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: kernel generic sequences io words arrays summary effects -continuations assocs accessors namespaces compiler.errors -stack-checker.values stack-checker.recursive-state -source-files.errors compiler.errors ; +USING: kernel stack-checker.values ; IN: stack-checker.errors -: pretty-word ( word -- word' ) - dup method-body? [ "method-generic" word-prop ] when ; +TUPLE: inference-error ; -TUPLE: inference-error error type word ; +ERROR: do-not-compile < inference-error word ; -M: inference-error error-type type>> ; +ERROR: literal-expected < inference-error what ; -: (inference-error) ( ... class type -- * ) - [ boa ] dip - recursive-state get word>> - \ inference-error boa rethrow ; inline +ERROR: unbalanced-branches-error < inference-error branches quots ; -: inference-error ( ... class -- * ) - +compiler-error+ (inference-error) ; inline +ERROR: too-many->r < inference-error ; -: inference-warning ( ... class -- * ) - +compiler-warning+ (inference-error) ; inline +ERROR: too-many-r> < inference-error ; -TUPLE: literal-expected what ; +ERROR: missing-effect < inference-error word ; -: literal-expected ( what -- * ) \ literal-expected inference-warning ; +ERROR: effect-error < inference-error inferred declared ; -M: object (literal) "literal value" literal-expected ; +ERROR: recursive-quotation-error < inference-error quot ; -TUPLE: unbalanced-branches-error branches quots ; +ERROR: undeclared-recursion-error < inference-error word ; -: unbalanced-branches-error ( branches quots -- * ) - \ unbalanced-branches-error inference-error ; +ERROR: diverging-recursion-error < inference-error word ; -TUPLE: too-many->r ; +ERROR: unbalanced-recursion-error < inference-error word height ; -: too-many->r ( -- * ) \ too-many->r inference-error ; +ERROR: inconsistent-recursive-call-error < inference-error word ; -TUPLE: too-many-r> ; +ERROR: unknown-primitive-error < inference-error ; -: too-many-r> ( -- * ) \ too-many-r> inference-error ; +ERROR: transform-expansion-error < inference-error word error ; -TUPLE: missing-effect word ; - -: missing-effect ( word -- * ) - pretty-word \ missing-effect inference-error ; - -TUPLE: effect-error word inferred declared ; - -: effect-error ( word inferred declared -- * ) - \ effect-error inference-error ; - -TUPLE: recursive-quotation-error quot ; - -: recursive-quotation-error ( word -- * ) - \ recursive-quotation-error inference-error ; - -TUPLE: undeclared-recursion-error word ; - -: undeclared-recursion-error ( word -- * ) - \ undeclared-recursion-error inference-error ; - -TUPLE: diverging-recursion-error word ; - -: diverging-recursion-error ( word -- * ) - \ diverging-recursion-error inference-error ; - -TUPLE: unbalanced-recursion-error word height ; - -: unbalanced-recursion-error ( word height -- * ) - \ unbalanced-recursion-error inference-error ; - -TUPLE: inconsistent-recursive-call-error word ; - -: inconsistent-recursive-call-error ( word -- * ) - \ inconsistent-recursive-call-error inference-error ; - -TUPLE: unknown-primitive-error ; - -: unknown-primitive-error ( -- * ) - \ unknown-primitive-error inference-warning ; - -TUPLE: transform-expansion-error word error ; - -: transform-expansion-error ( word error -- * ) - \ transform-expansion-error inference-error ; \ No newline at end of file +M: object (literal) "literal value" literal-expected ; \ No newline at end of file diff --git a/basis/stack-checker/errors/prettyprint/prettyprint.factor b/basis/stack-checker/errors/prettyprint/prettyprint.factor index d6cee8e08f..5be5722c23 100644 --- a/basis/stack-checker/errors/prettyprint/prettyprint.factor +++ b/basis/stack-checker/errors/prettyprint/prettyprint.factor @@ -1,18 +1,11 @@ ! Copyright (C) 2008, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: accessors kernel prettyprint io debugger -sequences assocs stack-checker.errors summary effects make ; +sequences assocs stack-checker.errors summary effects ; IN: stack-checker.errors.prettyprint -M: inference-error summary error>> summary ; - -M: inference-error error-help error>> error-help ; - -M: inference-error error. - [ word>> [ "In word: " write . ] when* ] [ error>> error. ] bi ; - M: literal-expected summary - [ "Got a computed value where a " % what>> % " was expected" % ] "" make ; + what>> "Got a computed value where a " " was expected" surround ; M: literal-expected error. summary print ; @@ -25,66 +18,45 @@ M: unbalanced-branches-error error. [ [ first pprint-short bl ] [ second effect>string print ] bi ] each ; M: too-many->r summary - drop - "Quotation pushes elements on retain stack without popping them" ; + drop "Quotation pushes elements on retain stack without popping them" ; M: too-many-r> summary - drop - "Quotation pops retain stack elements which it did not push" ; + drop "Quotation pops retain stack elements which it did not push" ; M: missing-effect summary - [ - "The word " % - word>> name>> % - " must declare a stack effect" % - ] "" make ; + drop "Missing stack effect declaration" ; 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 - quot>> pprint - " calls itself." print - "Stack effect inference is undecidable when quotation-level recursion is permitted." print ; +M: recursive-quotation-error summary + drop "Recursive quotation" ; M: undeclared-recursion-error summary - drop - "Inline recursive words must be declared recursive" ; + word>> name>> + "The inline recursive word " " must be declared recursive" surround ; M: diverging-recursion-error summary - [ - "The recursive word " % - word>> name>> % - " digs arbitrarily deep into the stack" % - ] "" make ; + word>> name>> + "The recursive word " " digs arbitrarily deep into the stack" surround ; M: unbalanced-recursion-error summary - [ - "The recursive word " % - word>> name>> % - " leaves with the stack having the wrong height" % - ] "" make ; + word>> name>> + "The recursive word " " leaves with the stack having the wrong height" surround ; M: inconsistent-recursive-call-error summary - [ - "The recursive word " % - word>> name>> % - " calls itself with a different set of quotation parameters than were input" % - ] "" make ; + word>> name>> + "The recursive word " + " calls itself with a different set of quotation parameters than were input" surround ; M: unknown-primitive-error summary - drop - "Cannot determine stack effect statically" ; + word>> name>> "The " " word cannot be called from optimized words" surround ; M: transform-expansion-error summary - drop - "Compiler transform threw an error" ; + word>> name>> "Macro expansion of " " threw an error" surround ; M: transform-expansion-error error. - [ summary print ] - [ "Word: " write word>> . nl ] - [ error>> error. ] tri ; \ No newline at end of file + [ summary print ] [ error>> error. ] bi ; + +M: do-not-compile summary + word>> name>> "Cannot compile call to " prepend ; \ No newline at end of file diff --git a/basis/stack-checker/known-words/known-words.factor b/basis/stack-checker/known-words/known-words.factor index abc1f68bb6..eade33e52b 100644 --- a/basis/stack-checker/known-words/known-words.factor +++ b/basis/stack-checker/known-words/known-words.factor @@ -216,10 +216,25 @@ M: object infer-call* dispatch 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 -- ) diff --git a/basis/stack-checker/recursive-state/recursive-state.factor b/basis/stack-checker/recursive-state/recursive-state.factor index 9abfb1fcd5..345e69e653 100644 --- a/basis/stack-checker/recursive-state/recursive-state.factor +++ b/basis/stack-checker/recursive-state/recursive-state.factor @@ -1,38 +1,19 @@ -! 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 ; +USING: accessors kernel namespaces stack-checker.recursive-state.tree ; IN: stack-checker.recursive-state -TUPLE: recursive-state word words quotations inline-words ; +TUPLE: recursive-state quotations inline-words ; -: prepare-recursive-state ( word rstate -- rstate ) - swap >>word - f >>quotations - f >>inline-words ; inline +: ( -- state ) recursive-state new ; inline -: initial-recursive-state ( word -- state ) - recursive-state new - f >>words - prepare-recursive-state ; inline + recursive-state set-global -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 ; + swap recursive-state get clone [ store ] change-inline-words ; : inline-recursive-label ( word -- label/f ) recursive-state get inline-words>> lookup ; diff --git a/basis/stack-checker/stack-checker-docs.factor b/basis/stack-checker/stack-checker-docs.factor index 28090918bb..243221ccf0 100644 --- a/basis/stack-checker/stack-checker-docs.factor +++ b/basis/stack-checker/stack-checker-docs.factor @@ -4,38 +4,54 @@ stack-checker.backend stack-checker.branches stack-checker.errors stack-checker.transforms -stack-checker.state ; +stack-checker.state +continuations ; IN: stack-checker ARTICLE: "inference-simple" "Straight-line stack effects" -"The simplest case to look at is that of a quotation which does not have any branches or recursion, and just pushes literals and calls words, each of which has a known stack effect." +"The simplest case is when a piece of code does not have any branches or recursion, and just pushes literals and calls words." $nl -"Stack effect inference works by stepping through the quotation, while maintaining a \"shadow stack\" which tracks stack height at the current position in the quotation. Initially, the shadow stack is empty. If a word is encountered which expects more values than there are on the shadow stack, a global counter is incremented. This counter keeps track of the number of inputs the quotation expects on the stack. When inference is done, this counter, together with the final height of the shadow stack, gives the inferred stack effect." -{ $subsection d-in } -{ $subsection meta-d } -"When a literal is encountered, it is simply pushed on the shadow stack. For example, the stack effect of the following quotation is inferred by pushing all three literals on the shadow stack, then taking the value of " { $link d-in } " and the length of " { $link meta-d } ":" +"Pushing a literal has stack effect " { $snippet "( -- object )" } ". The stack effect of a most words is always known statically from the declaration. Stack effects of " { $link POSTPONE: inline } " words and " { $link "macros" } ", may depend on literals pushed on the stack prior to the call, and this case is discussed in " { $link "inference-combinators" } "." +$nl +"The stack effect of each element in a code snippet is composed. The result is then the stack effect of the snippet." +$nl +"An example:" { $example "[ 1 2 3 ] infer." "( -- object object object )" } -"In the following example, the call to " { $link + } " expects two values on the shadow stack, but only one value is present, the literal which was pushed previously. This increments the " { $link d-in } " counter by one:" -{ $example "[ 2 + ] infer." "( object -- object )" } -"After the call to " { $link + } ", the shadow stack contains a \"computed value placeholder\", since the inferencer has no way to know what the resulting value actually is (in fact it is arbitrary)." ; +"Another example:" +{ $example "[ 2 + ] infer." "( object -- object )" } ; ARTICLE: "inference-combinators" "Combinator stack effects" -"Without further information, one cannot say what the stack effect of " { $link call } " is; it depends on the given quotation. If the inferencer encounters a " { $link call } " without further information, a " { $link literal-expected } " error is raised." -{ $example "[ dup call ] infer." "Got a computed value where a literal quotation was expected\n\nType :help for debugging help." } -"On the other hand, the stack effect of applying " { $link call } " to a literal quotation or a " { $link curry } " of a literal quotation is easy to compute; it behaves as if the quotation was substituted at that point:" -{ $example "[ [ 2 + ] call ] infer." "( object -- object )" } -"Consider a combinator such as " { $link keep } ". The combinator itself does not have a stack effect, because it applies " { $link call } " to a potentially arbitrary quotation. However, since the combinator is declared " { $link POSTPONE: inline } ", a given usage of it can have a stack effect:" -{ $example "[ [ 2 + ] keep ] infer." "( object -- object object )" } -"Another example is the " { $link compose } " combinator. Because it is decared " { $link POSTPONE: inline } ", we can infer the stack effect of applying " { $link call } " to the result of " { $link compose } ":" -{ $example "[ 2 [ + ] curry [ sq ] compose ] infer." "( -- object )" } -"Incidentally, this example demonstrates that the stack effect of nested currying and composition can also be inferred." +"If a word, call it " { $snippet "W" } ", calls a combinator, one of the following two conditions must hold:" +{ $list + { "The combinator may be called with a quotation that is either a literal, or built from literals, " { $link curry } " and " { $link compose } "." } + { "The combinator must be called on an input parameter, or be built from input parameters, literals, " { $link curry } " and " { $link compose } ", " { $strong "if" } " the word " { $snippet "W" } " must be declared " { $link POSTPONE: inline } ". Then " { $snippet "W" } " is itself considered to be a combinator, and its callers must satisfy one of these two conditions." } +} +"If neither condition holds, the stack checker throws a " { $link literal-expected } " error, and an escape hatch such as " { $link POSTPONE: call( } " must be used instead. See " { $link "inference-escape" } " for details. An inline combinator can be called with an unknown quotation by currying the quotation onto a literal quotation that uses " { $link POSTPONE: call( } "." +{ $heading "Examples" } +{ $subheading "Calling a combinator" } +"The following usage of " { $link map } " passes the stack checker, because the quotation is the result of " { $link curry } ":" +{ $example "[ [ + ] curry map ] infer." "( object object -- object )" } +{ $subheading "Defining an inline combinator" } +"The following word calls a quotation twice; the word is declared " { $link POSTPONE: inline } ", since it invokes " { $link call } " on the result of " { $link compose } " on an input parameter:" +{ $code ": twice ( value quot -- result ) dup compose call ; inline" } +"The following code now passes the stack checker; it would fail were " { $snippet "twice" } " not declared " { $link POSTPONE: inline } ":" +{ $unchecked-example "USE: math.functions" "[ [ sqrt ] twice ] infer." "( object -- object )" } +{ $subheading "Defining a combinator for unknown quotations" } +"In the next example, " { $link POSTPONE: call( } " must be used because the quotation the result of calling a runtime accessor, and the compiler cannot make any static assumptions about this quotation at all:" +{ $code + "TUPLE: action name quot ;" + ": perform ( value action -- result ) quot>> call( value -- result ) ;" +} +{ $subheading "Passing an unknown quotation to an inline combinator" } +"Suppose we want to write :" +{ $code ": perform ( values action -- results ) quot>> map ;" } +"However this fails to pass the stack checker since there is no guarantee the quotation has the right stack effect for " { $link map } ". It can be wrapped in a new quotation with a declaration:" +{ $code ": perform ( values action -- results )" " quot>> [ call( value -- result ) ] curry map ;" } +{ $heading "Explanation" } +"This restriction exists because without further information, one cannot say what the stack effect of " { $link call } " is; it depends on the given quotation. If the stack checker encounters a " { $link call } " without further information, a " { $link literal-expected } " error is raised." $nl -"A general rule of thumb is that any word which applies " { $link call } " or " { $link curry } " to one of its inputs must be declared " { $link POSTPONE: inline } "." -$nl -"Here is an example where the stack effect cannot be inferred:" -{ $code ": foo ( -- n quot ) 0 [ + ] ;" "[ foo reduce ] infer." } -"However if " { $snippet "foo" } " was declared " { $link POSTPONE: inline } ", everything would work, since the " { $link reduce } " combinator is also " { $link POSTPONE: inline } ", and the inferencer can see the literal quotation value at the point it is passed to " { $link call } ":" -{ $example ": foo ( -- n quot ) 0 [ + ] ; inline" "[ foo reduce ] infer." "( object -- object )" } +"On the other hand, the stack effect of applying " { $link call } " to a literal quotation or a " { $link curry } " of a literal quotation is easy to compute; it behaves as if the quotation was substituted at that point." +{ $heading "Limitations" } "Passing a literal quotation on the data stack through an inlined recursive combinator nullifies its literal status. For example, the following will not infer:" { $example "[ [ reverse ] swap [ reverse ] map swap call ] infer." "Got a computed value where a literal quotation was expected\n\nType :help for debugging help." @@ -46,30 +62,25 @@ $nl } ; ARTICLE: "inference-branches" "Branch stack effects" -"Conditionals such as " { $link if } " and combinators built on " { $link if } " present a problem, in that if the two branches leave the stack at a different height, it is not clear what the stack effect should be. In this case, inference throws a " { $link unbalanced-branches-error } "." +"Conditionals such as " { $link if } " and combinators built on top have the same restrictions as " { $link POSTPONE: inline } " combinators (see " { $link "inference-combinators" } ") with the additional requirement that all branches leave the stack at the same height. If this is not the case, the stack checker throws a " { $link unbalanced-branches-error } "." $nl "If all branches leave the stack at the same height, then the stack effect of the conditional is just the maximum of the stack effect of each branch. For example," { $example "[ [ + ] [ drop ] if ] infer." "( object object object -- object )" } "The call to " { $link if } " takes one value from the stack, a generalized boolean. The first branch " { $snippet "[ + ]" } " has stack effect " { $snippet "( x x -- x )" } " and the second has stack effect " { $snippet "( x -- )" } ". Since both branches decrease the height of the stack by one, we say that the stack effect of the two branches is " { $snippet "( x x -- x )" } ", and together with the boolean popped off the stack by " { $link if } ", this gives a total stack effect of " { $snippet "( x x x -- x )" } "." ; -ARTICLE: "inference-recursive" "Stack effects of recursive words" -"When a recursive call is encountered, the declared stack effect is substituted in. When inference is complete, the inferred stack effect is compared with the declared stack effect." +ARTICLE: "inference-recursive-combinators" "Recursive combinator stack effects" +"Most combinators do not call themselves recursively directly; instead, they are implemented in terms of existing combinators, for example " { $link while } ", " { $link map } ", and the " { $link "compositional-combinators" } ". In these cases, the rules outlined in " { $link "inference-combinators" } " apply." $nl -"Attempting to infer the stack effect of a recursive word which outputs a variable number of objects on the stack will fail. For example, the following will throw an " { $link unbalanced-branches-error } ":" -{ $code ": foo ( seq -- ) dup empty? [ drop ] [ dup pop foo ] if ;" "[ foo ] infer." } -"If you declare an incorrect stack effect, inference will fail also. Badly defined recursive words cannot confuse the inferencer." ; - -ARTICLE: "inference-recursive-combinators" "Recursive combinator inference" -"Most combinators are not explicitly recursive; instead, they are implemented in terms of existing combinators, for example " { $link while } ", " { $link map } ", and the " { $link "compositional-combinators" } "." -$nl -"Combinators which are recursive require additional care." -$nl -"If a recursive word takes quotation parameters from the stack and calls them, it must be declared " { $link POSTPONE: inline } " (as documented in " { $link "inference-combinators" } ") as well as " { $link POSTPONE: recursive } "." -$nl -"Furthermore, the input parameters which are quotations must be annotated in the stack effect. For example, the following will not infer:" +"Combinators which are recursive require additional care. In addition to being declared " { $link POSTPONE: inline } ", they must be declared " { $link POSTPONE: recursive } ". There are three restrictions that only apply to combinators with this declaration:" +{ $heading "Input quotation declaration" } +"Input parameters which are quotations must be annotated as much in the stack effect. For example, the following will not infer:" { $example ": bad ( quot -- ) [ call ] keep foo ; inline recursive" "[ [ ] bad ] infer." "Got a computed value where a literal quotation was expected\n\nType :help for debugging help." } "The following is correct:" { $example ": good ( quot: ( -- ) -- ) [ call ] keep good ; inline recursive" "[ [ ] good ] infer." "( -- )" } +"The effect of the nested quotation itself is only present for documentation purposes; the mere presence of a nested effect is sufficient to mark that value as a quotation parameter." +{ $heading "Data flow restrictions" } +"The stack checker does not trace data flow in two instances." +$nl "An inline recursive word cannot pass a quotation on the data stack through the recursive call. For example, the following will not infer:" { $example ": bad ( ? quot: ( ? -- ) -- ) 2dup [ not ] dip bad call ; inline recursive" "[ [ drop ] bad ] infer." "Got a computed value where a literal quotation was expected\n\nType :help for debugging help." } "However a small change can be made:" @@ -80,23 +91,47 @@ $nl "[ [ 5 ] t foo ] infer." } ; -ARTICLE: "inference" "Stack effect inference" -"The stack effect inference tool is used to check correctness of code before it is run. It is also used by the optimizing compiler to build the high-level SSA representation on which optimizations can be performed. Only words for which a stack effect can be inferred will compile with the optimizing compiler; all other words will be compiled with the non-optimizing compiler (see " { $link "compiler" } ")." -$nl -"The main entry point is a single word which takes a quotation and prints its stack effect and variable usage:" -{ $subsection infer. } -"Instead of printing the inferred information, it can be returned as objects on the stack:" +ARTICLE: "tools.inference" "Stack effect tools" +{ $link "inference" } " can be used interactively to print stack effects of quotations without running them. It can also be used from " { $link "combinators.smart" } "." { $subsection infer } -"Static stack effect inference can be combined with unit tests; see " { $link "tools.test.write" } "." +{ $subsection infer. } +"There are also some words for working with " { $link effect } " instances. Getting a word's declared stack effect:" +{ $subsection stack-effect } +"Converting a stack effect to a string form:" +{ $subsection effect>string } +"Comparing effects:" +{ $subsection effect-height } +{ $subsection effect<= } +"The class of stack effects:" +{ $subsection effect } +{ $subsection effect? } ; + +ARTICLE: "inference-escape" "Stack effect checking escape hatches" +"In a static checking regime, sometimes it is necessary to step outside the boundaries and run some code which cannot be statically checked; perhaps this code is constructed at run-time. There are two ways to get around the static stack checker." $nl -"The following articles describe the implementation of the stack effect inference algorithm:" +"If the stack effect of a word or quotation is known, but the word or quotation itself is not, " { $link POSTPONE: execute( } " or " { $link POSTPONE: call( } " can be used. See " { $link "call" } " for details." +$nl +"If the stack effect is not known, the code being called cannot manipulate the datastack directly. Instead, it must reflect the datastack into an array:" +{ $subsection with-datastack } +"The surrounding code has a static stack effect since " { $link with-datastack } " has one. However, the array passed in as input may be transformed arbitrarily by calling this combinator." ; + +ARTICLE: "inference" "Stack effect checking" +"The " { $link "compiler" } " checks the " { $link "effects" } " of words before they can be run. This ensures that words take exactly the number of inputs and outputs that the programmer declares in source." +$nl +"Words that do not pass the stack checker are rejected and cannot be run, and so essentially this defines a very simple and permissive type system that nevertheless catches some invalid programs and enables compiler optimizations." +$nl +"If a word's stack effect cannot be inferred, a compile error is reported. See " { $link "compiler-errors" } "." +$nl +"The following articles describe how different control structures are handled by the stack checker." { $subsection "inference-simple" } -{ $subsection "inference-recursive" } { $subsection "inference-combinators" } { $subsection "inference-recursive-combinators" } { $subsection "inference-branches" } +"Stack checking catches several classes of errors." { $subsection "inference-errors" } -{ $see-also "effects" } ; +"Sometimes code with a dynamic stack effect has to be run." +{ $subsection "inference-escape" } +{ $see-also "effects" "tools.inference" "tools.errors" } ; ABOUT: "inference" @@ -109,7 +144,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 +155,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." } ; diff --git a/basis/stack-checker/stack-checker-tests.factor b/basis/stack-checker/stack-checker-tests.factor index 6b9e9fd8b6..919cd098f6 100644 --- a/basis/stack-checker/stack-checker-tests.factor +++ b/basis/stack-checker/stack-checker-tests.factor @@ -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 ( -- ) @@ -503,9 +304,7 @@ ERROR: custom-error ; ] 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,9 @@ 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 + +[ [ [ "OOPS" throw ] dip ] [ drop ] if ] must-infer \ No newline at end of file diff --git a/basis/stack-checker/stack-checker.factor b/basis/stack-checker/stack-checker.factor index e18a6f0840..759988a61f 100644 --- a/basis/stack-checker/stack-checker.factor +++ b/basis/stack-checker/stack-checker.factor @@ -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 \ No newline at end of file diff --git a/basis/stack-checker/state/state.factor b/basis/stack-checker/state/state.factor index 6ae12dbd0c..a76d302a7e 100644 --- a/basis/stack-checker/state/state.factor +++ b/basis/stack-checker/state/state.factor @@ -64,6 +64,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 diff --git a/basis/stack-checker/transforms/transforms-tests.factor b/basis/stack-checker/transforms/transforms-tests.factor index abb1f2abdb..fe0fa08356 100644 --- a/basis/stack-checker/transforms/transforms-tests.factor +++ b/basis/stack-checker/transforms/transforms-tests.factor @@ -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' ) >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 diff --git a/basis/stack-checker/transforms/transforms.factor b/basis/stack-checker/transforms/transforms.factor index fd62c4998d..cd8a57bf2e 100755 --- a/basis/stack-checker/transforms/transforms.factor +++ b/basis/stack-checker/transforms/transforms.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2007, 2009 Slava Pestov, Daniel Ehrenberg. ! See http://factorcode.org/license.txt for BSD license. USING: fry accessors arrays kernel kernel.private combinators.private -words sequences generic math math.order namespaces make quotations +words sequences generic math math.order namespaces quotations assocs combinators combinators.short-circuit classes.tuple classes.tuple.private effects summary hashtables classes generic sets definitions generic.standard slots.private continuations locals @@ -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,14 +107,15 @@ 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 - [ - [ all-slots [ initial>> literalize , ] each ] - [ literalize , ] bi - \ boa , - ] [ ] make + [ all-slots [ initial>> literalize ] map ] + [ tuple-layout '[ _ ] ] + bi append ] [ drop f ] if ] 1 define-transform diff --git a/basis/syndication/syndication-tests.factor b/basis/syndication/syndication-tests.factor index 3ea037352c..b0bd5a2ff5 100644 --- a/basis/syndication/syndication-tests.factor +++ b/basis/syndication/syndication-tests.factor @@ -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. diff --git a/basis/threads/threads-docs.factor b/basis/threads/threads-docs.factor index a1d7e50594..dbdb69b3e9 100644 --- a/basis/threads/threads-docs.factor +++ b/basis/threads/threads-docs.factor @@ -48,7 +48,7 @@ ARTICLE: "thread-impl" "Thread implementation" { $subsection sleep-queue } ; ARTICLE: "threads" "Lightweight co-operative threads" -"Factor supports lightweight co-operative threads implemented on top of continuations. A thread will yield while waiting for input/output operations to complete, or when a yield has been explicitly requested." +"Factor supports lightweight co-operative threads implemented on top of " { $link "continuations" } ". A thread will yield while waiting for input/output operations to complete, or when a yield has been explicitly requested." $nl "Factor threads are very lightweight. Each thread can take as little as 900 bytes of memory. This library has been tested running hundreds of thousands of simple threads." $nl diff --git a/basis/tools/continuations/continuations.factor b/basis/tools/continuations/continuations.factor index 3e28c5925f..1ac4557ec4 100644 --- a/basis/tools/continuations/continuations.factor +++ b/basis/tools/continuations/continuations.factor @@ -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 > "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 \ No newline at end of file diff --git a/basis/tools/crossref/crossref.factor b/basis/tools/crossref/crossref.factor index 36ccaadc98..c5cd246f2e 100644 --- a/basis/tools/crossref/crossref.factor +++ b/basis/tools/crossref/crossref.factor @@ -1,9 +1,101 @@ ! 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 ) + +alist ] dip (seq-uses) + ] if ; + +M: array quot-uses seq-uses ; + +M: hashtable quot-uses assoc-uses ; + +M: callable quot-uses seq-uses ; + +M: wrapper quot-uses [ wrapped>> ] dip quot-uses ; + +M: callable uses ( quot -- assoc ) + V{ } clone visited [ + H{ } clone [ quot-uses ] keep keys + ] with-variable ; + +M: word uses def>> uses ; + +M: link uses { $subsection $link $see-also } article-links ; + +M: pathname uses string>> source-file top-level-form>> [ uses ] [ { } ] if* ; + +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 [ ] 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 +107,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. ; + + \ No newline at end of file diff --git a/basis/tools/deploy/shaker/shaker.factor b/basis/tools/deploy/shaker/shaker.factor index ba0daf6056..e23e1b092d 100755 --- a/basis/tools/deploy/shaker/shaker.factor +++ b/basis/tools/deploy/shaker/shaker.factor @@ -97,10 +97,8 @@ IN: tools.deploy.shaker { "alias" "boa-check" - "cannot-infer" "coercer" "combination" - "compiled-status" "compiled-generic-uses" "compiled-uses" "constraints" @@ -116,7 +114,6 @@ IN: tools.deploy.shaker "identities" "if-intrinsics" "infer" - "inferred-effect" "inline" "inlined-block" "input-classes" @@ -267,7 +264,6 @@ IN: tools.deploy.shaker compiler-impl compiler.errors:compiler-errors definition-observers - definitions:crossref interactive-vocabs layouts:num-tags layouts:num-types diff --git a/basis/tools/errors/errors-docs.factor b/basis/tools/errors/errors-docs.factor index 96b13b69b6..eb7b465d30 100644 --- a/basis/tools/errors/errors-docs.factor +++ b/basis/tools/errors/errors-docs.factor @@ -2,34 +2,33 @@ IN: tools.errors USING: help.markup help.syntax source-files.errors words io compiler.errors ; -ARTICLE: "compiler-errors" "Compiler warnings and errors" -"After loading a vocabulary, you might see messages like:" +ARTICLE: "compiler-errors" "Compiler errors" +"After loading a vocabulary, you might see a message like:" { $code ":errors - print 2 compiler errors" - ":warnings - print 50 compiler warnings" } -"These messages arise from the compiler's stack effect checker. Production code should not have any warnings and errors in it. Warning and error conditions are documented in " { $link "inference-errors" } "." +"This indicates that some words did not pass the stack checker. Stack checker error conditions are documented in " { $link "inference-errors" } ", and the stack checker itself in " { $link "inference" } "." $nl -"Words to view warnings and errors:" -{ $subsection :warnings } +"Words to view errors:" { $subsection :errors } { $subsection :linkage } -"Compiler warnings and errors are reported using the " { $link "tools.errors" } " mechanism and are shown in the " { $link "ui.tools.error-list" } "." ; +"Compiler errors are reported using the " { $link "tools.errors" } " mechanism, and as a result, they are also are shown in the " { $link "ui.tools.error-list" } "." ; HELP: compiler-error -{ $values { "error" "an error" } { "word" word } } -{ $description "Saves the error for future persual via " { $link :errors } ", " { $link :warnings } " and " { $link :linkage } "." } ; +{ $values { "error" compiler-error } { "word" word } } +{ $description "Saves the error for viewing with " { $link :errors } "." } ; + +HELP: linkage-error +{ $values { "error" linkage-error } { "word" word } } +{ $description "Saves the error for viewing with " { $link :linkage } "." } ; HELP: :errors -{ $description "Prints all serious compiler errors from the most recent compile to " { $link output-stream } "." } ; - -HELP: :warnings -{ $description "Prints all ignorable compiler warnings from the most recent compile to " { $link output-stream } "." } ; +{ $description "Prints all compiler errors." } ; HELP: :linkage -{ $description "Prints all C library interface linkage errors from the most recent compile to " { $link output-stream } "." } ; +{ $description "Prints all C library interface linkage errors." } ; -{ :errors :warnings :linkage } related-words +{ :errors :linkage } related-words HELP: errors. { $values { "errors" "a sequence of " { $link source-file-error } " instances" } } diff --git a/basis/tools/errors/errors-tests.factor b/basis/tools/errors/errors-tests.factor new file mode 100644 index 0000000000..a70aa32be8 --- /dev/null +++ b/basis/tools/errors/errors-tests.factor @@ -0,0 +1,20 @@ +USING: compiler.errors stack-checker.errors tools.test words ; +IN: tools.errors + +DEFER: blah + +[ ] [ + { + T{ compiler-error + { error + T{ inference-error + f + T{ do-not-compile f blah } + +compiler-error+ + blah + } + } + { asset blah } + } + } errors. +] unit-test \ No newline at end of file diff --git a/basis/tools/errors/errors.factor b/basis/tools/errors/errors.factor index 0a28bdec08..b53d4ef7a2 100644 --- a/basis/tools/errors/errors.factor +++ b/basis/tools/errors/errors.factor @@ -2,41 +2,44 @@ ! See http://factorcode.org/license.txt for BSD license. USING: assocs debugger io kernel sequences source-files.errors summary accessors continuations make math.parser io.styles namespaces -compiler.errors ; +compiler.errors prettyprint ; IN: tools.errors #! Tools for source-files.errors. Used by tools.tests and others #! for error reporting -M: source-file-error compute-restarts - error>> compute-restarts ; +M: source-file-error compute-restarts error>> compute-restarts ; -M: source-file-error error-help - error>> error-help ; +M: source-file-error error-help error>> error-help ; + +CONSTANT: +listener-input+ "" M: source-file-error summary [ - [ file>> [ % ": " % ] [ "" % ] if* ] + [ file>> [ % ": " % ] [ +listener-input+ % ] if* ] [ line#>> [ # ] when* ] bi - ] "" make - ; + ] "" make ; M: source-file-error error. - [ summary print nl ] [ error>> error. ] bi ; + [ summary print nl ] + [ asset>> [ "Asset: " write short. nl ] when* ] + [ error>> error. ] + tri ; : errors. ( errors -- ) group-by-source-file sort-errors [ - [ nl "==== " write print nl ] + [ nl "==== " write +listener-input+ or print nl ] [ [ nl ] [ error. ] interleave ] bi* ] assoc-each ; -: compiler-errors. ( type -- ) - errors-of-type values errors. ; +: :errors ( -- ) compiler-errors get values errors. ; -: :errors ( -- ) +compiler-error+ compiler-errors. ; +: :linkage ( -- ) linkage-errors get values errors. ; -: :warnings ( -- ) +compiler-warning+ compiler-errors. ; +M: not-compiled summary + word>> name>> "The word " " cannot be executed because it failed to compile" surround ; -: :linkage ( -- ) +linkage-error+ compiler-errors. ; \ No newline at end of file +M: not-compiled error. + [ summary print nl ] [ error>> error. ] bi ; \ No newline at end of file diff --git a/basis/tools/errors/model/authors.txt b/basis/tools/errors/model/authors.txt new file mode 100644 index 0000000000..d4f5d6b3ae --- /dev/null +++ b/basis/tools/errors/model/authors.txt @@ -0,0 +1 @@ +Slava Pestov \ No newline at end of file diff --git a/basis/tools/errors/model/model.factor b/basis/tools/errors/model/model.factor new file mode 100644 index 0000000000..c874363fe6 --- /dev/null +++ b/basis/tools/errors/model/model.factor @@ -0,0 +1,18 @@ +! Copyright (C) 2009 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: models source-files.errors namespaces models.delay init +kernel calendar ; +IN: tools.errors.model + +SYMBOLS: (error-list-model) error-list-model ; + +(error-list-model) [ f ] initialize + +error-list-model [ (error-list-model) get-global 100 milliseconds ] initialize + +SINGLETON: updater + +M: updater errors-changed drop f (error-list-model) get-global set-model ; + +[ updater add-error-observer ] "ui.tools.error-list" add-init-hook + diff --git a/basis/tools/memory/memory-tests.factor b/basis/tools/memory/memory-tests.factor index 60b54c2a0d..4b75cf0bfa 100644 --- a/basis/tools/memory/memory-tests.factor +++ b/basis/tools/memory/memory-tests.factor @@ -1,8 +1,5 @@ USING: tools.test tools.memory ; IN: tools.memory.tests -\ room. must-infer [ ] [ room. ] unit-test - -\ heap-stats. must-infer [ ] [ heap-stats. ] unit-test diff --git a/basis/tools/profiler/profiler-docs.factor b/basis/tools/profiler/profiler-docs.factor index a786cdfef1..efd2e164a3 100644 --- a/basis/tools/profiler/profiler-docs.factor +++ b/basis/tools/profiler/profiler-docs.factor @@ -1,5 +1,5 @@ -USING: tools.profiler.private tools.time help.markup help.syntax -quotations io strings words definitions ; +USING: tools.profiler.private tools.time tools.crossref +help.markup help.syntax quotations io strings words definitions ; IN: tools.profiler ARTICLE: "profiler-limitations" "Profiler limitations" @@ -23,7 +23,7 @@ $nl { $subsection vocabs-profile. } { $subsection method-profile. } { $subsection "profiler-limitations" } -{ $see-also "ui-profiler" } ; +{ $see-also "ui.tools.profiler" } ; ABOUT: "profiling" diff --git a/basis/tools/profiler/profiler-tests.factor b/basis/tools/profiler/profiler-tests.factor index 0bd3663729..d2e605ecdc 100644 --- a/basis/tools/profiler/profiler-tests.factor +++ b/basis/tools/profiler/profiler-tests.factor @@ -34,7 +34,7 @@ words ; [ 1 ] [ \ foobar counter>> ] unit-test -: fooblah ( -- ) { } [ ] like call ; +: fooblah ( -- ) { } [ ] like call( -- ) ; : foobaz ( -- ) fooblah fooblah ; diff --git a/basis/tools/profiler/profiler.factor b/basis/tools/profiler/profiler.factor index f4488136b2..219344db3b 100644 --- a/basis/tools/profiler/profiler.factor +++ b/basis/tools/profiler/profiler.factor @@ -3,7 +3,7 @@ USING: accessors words sequences math prettyprint kernel arrays io io.styles namespaces assocs kernel.private strings combinators sorting math.parser vocabs definitions tools.profiler.private -continuations generic compiler.units sets classes fry ; +tools.crossref continuations generic compiler.units sets classes fry ; IN: tools.profiler : profile ( quot -- ) diff --git a/basis/tools/test/test-docs.factor b/basis/tools/test/test-docs.factor index 9122edcb67..ac7b33d41e 100644 --- a/basis/tools/test/test-docs.factor +++ b/basis/tools/test/test-docs.factor @@ -58,8 +58,8 @@ HELP: must-fail-with { $notes "This word is used to test error handling code, ensuring that errors thrown by code contain the relevant debugging information." } ; HELP: must-infer -{ $values { "word/quot" "a quotation or a word" } } -{ $description "Ensures that the quotation or word has a static stack effect without running it." } +{ $values { "quot" quotation } } +{ $description "Ensures that the quotation has a static stack effect without running it." } { $notes "This word is used to test that code will compile with the optimizing compiler for optimum performance. See " { $link "compiler" } "." } ; HELP: must-infer-as diff --git a/basis/tools/test/test-tests.factor b/basis/tools/test/test-tests.factor index 03f7f006c9..c8ce3e01c7 100644 --- a/basis/tools/test/test-tests.factor +++ b/basis/tools/test/test-tests.factor @@ -1,8 +1,6 @@ IN: tools.test.tests USING: tools.test tools.test.private namespaces kernel sequences ; -\ test-all must-infer - : fake-unit-test ( quot -- ) [ "fake" file set diff --git a/basis/tools/test/test.factor b/basis/tools/test/test.factor index 1ff47e3d7f..c0c2f1892d 100644 --- a/basis/tools/test/test.factor +++ b/basis/tools/test/test.factor @@ -56,8 +56,7 @@ SYMBOL: file :: (must-infer-as) ( effect quot -- error ? ) [ quot infer short-effect effect assert= f f ] [ t ] recover ; -:: (must-infer) ( word/quot -- error ? ) - word/quot dup word? [ '[ _ execute ] ] when :> quot +:: (must-infer) ( quot -- error ? ) [ quot infer drop f f ] [ t ] recover ; TUPLE: did-not-fail ; diff --git a/basis/tools/vocabs/vocabs.factor b/basis/tools/vocabs/vocabs.factor index 66618ee23c..ba99a41eba 100644 --- a/basis/tools/vocabs/vocabs.factor +++ b/basis/tools/vocabs/vocabs.factor @@ -8,27 +8,6 @@ continuations compiler.errors init checksums checksums.crc32 sets accessors generic definitions words ; IN: tools.vocabs -: 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. ; - : vocab-tests-file ( vocab -- path ) dup "-tests.factor" vocab-dir+ vocab-append-path dup [ dup exists? [ drop f ] unless ] [ drop f ] if ; diff --git a/basis/ui/event-loop/event-loop-tests.factor b/basis/ui/event-loop/event-loop-tests.factor index ae1d7ec8bc..ac263cb79c 100644 --- a/basis/ui/event-loop/event-loop-tests.factor +++ b/basis/ui/event-loop/event-loop-tests.factor @@ -1,4 +1,2 @@ IN: ui.event-loop.tests USING: ui.event-loop tools.test ; - -\ event-loop must-infer diff --git a/basis/ui/gadgets/books/books-tests.factor b/basis/ui/gadgets/books/books-tests.factor index dab9ef5acf..3076ffc004 100644 --- a/basis/ui/gadgets/books/books-tests.factor +++ b/basis/ui/gadgets/books/books-tests.factor @@ -1,4 +1,2 @@ IN: ui.gadgets.books.tests USING: tools.test ui.gadgets.books ; - -\ must-infer diff --git a/basis/ui/gadgets/buttons/buttons-tests.factor b/basis/ui/gadgets/buttons/buttons-tests.factor index 0aa12f7279..f7c73b2438 100644 --- a/basis/ui/gadgets/buttons/buttons-tests.factor +++ b/basis/ui/gadgets/buttons/buttons-tests.factor @@ -28,10 +28,6 @@ T{ foo-gadget } "t" set } "religion" set ] unit-test -\ must-infer - -\ must-infer - [ 0 ] [ "religion" get gadget-child value>> ] unit-test diff --git a/basis/ui/gadgets/editors/editors-tests.factor b/basis/ui/gadgets/editors/editors-tests.factor index bd610ba53b..3ba32dc3c2 100644 --- a/basis/ui/gadgets/editors/editors-tests.factor +++ b/basis/ui/gadgets/editors/editors-tests.factor @@ -42,8 +42,6 @@ IN: ui.gadgets.editors.tests ] with-grafted-gadget ] unit-test -\ must-infer - "hello" "field" set "field" get [ diff --git a/basis/ui/gadgets/gadgets-tests.factor b/basis/ui/gadgets/gadgets-tests.factor index 03219c66fd..77860ba5b5 100644 --- a/basis/ui/gadgets/gadgets-tests.factor +++ b/basis/ui/gadgets/gadgets-tests.factor @@ -152,16 +152,3 @@ M: mock-gadget ungraft* { { f f } { f t } { t f } { t t } } [ notify-combo ] assoc-each ] with-string-writer print - -\ must-infer -\ unparent must-infer -\ add-gadget must-infer -\ add-gadgets must-infer -\ clear-gadget must-infer - -\ relayout must-infer -\ relayout-1 must-infer -\ pref-dim must-infer - -\ graft* must-infer -\ ungraft* must-infer \ No newline at end of file diff --git a/basis/ui/gadgets/scrollers/scrollers-tests.factor b/basis/ui/gadgets/scrollers/scrollers-tests.factor index 22df1f328b..4002c8b40e 100644 --- a/basis/ui/gadgets/scrollers/scrollers-tests.factor +++ b/basis/ui/gadgets/scrollers/scrollers-tests.factor @@ -104,5 +104,3 @@ dup layout model>> dependencies>> [ range-max value>> ] map { 0 0 } = ] unit-test - -\ must-infer diff --git a/basis/ui/gestures/gestures-tests.factor b/basis/ui/gestures/gestures-tests.factor index 402015ee7c..3bcea27819 100644 --- a/basis/ui/gestures/gestures-tests.factor +++ b/basis/ui/gestures/gestures-tests.factor @@ -1,5 +1,2 @@ IN: ui.gestures.tests USING: tools.test ui.gestures ; - -\ handle-gesture must-infer -\ send-queued-gesture must-infer \ No newline at end of file diff --git a/basis/ui/operations/operations-tests.factor b/basis/ui/operations/operations-tests.factor index 4612ea79b0..6e8339a539 100644 --- a/basis/ui/operations/operations-tests.factor +++ b/basis/ui/operations/operations-tests.factor @@ -26,5 +26,3 @@ io.streams.string math help help.markup accessors ; [ ] [ [ { $operations \ + } print-element ] with-string-writer drop ] unit-test - -\ object-operations must-infer \ No newline at end of file diff --git a/basis/ui/render/render-tests.factor b/basis/ui/render/render-tests.factor index 3410560ba9..3ae0082be1 100644 --- a/basis/ui/render/render-tests.factor +++ b/basis/ui/render/render-tests.factor @@ -1,4 +1,2 @@ IN: ui.render.tests USING: ui.render tools.test ; - -\ draw-gadget must-infer \ No newline at end of file diff --git a/basis/ui/tools/browser/browser-tests.factor b/basis/ui/tools/browser/browser-tests.factor index 3757f392c4..8027babc3f 100644 --- a/basis/ui/tools/browser/browser-tests.factor +++ b/basis/ui/tools/browser/browser-tests.factor @@ -1,5 +1,4 @@ IN: ui.tools.browser.tests USING: tools.test ui.gadgets.debug ui.tools.browser math ; -\ must-infer [ ] [ \ + [ ] with-grafted-gadget ] unit-test diff --git a/basis/ui/tools/browser/popups/popups.factor b/basis/ui/tools/browser/popups/popups.factor index 91ac96e0f9..2cd90ab335 100644 --- a/basis/ui/tools/browser/popups/popups.factor +++ b/basis/ui/tools/browser/popups/popups.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: accessors arrays assocs definitions fry help.topics kernel colors.constants math.rectangles models.arrow namespaces sequences -sorting definitions.icons ui.gadgets ui.gadgets.glass +sorting definitions.icons tools.crossref ui.gadgets ui.gadgets.glass ui.gadgets.labeled ui.gadgets.scrollers ui.gadgets.tables ui.gadgets.search-tables ui.gadgets.wrappers ui.gestures ui.operations ui.pens.solid ui.images ; diff --git a/basis/ui/tools/error-list/error-list-docs.factor b/basis/ui/tools/error-list/error-list-docs.factor index 10ca80d97d..5040a13be2 100644 --- a/basis/ui/tools/error-list/error-list-docs.factor +++ b/basis/ui/tools/error-list/error-list-docs.factor @@ -8,13 +8,12 @@ $nl { $heading "Message icons" } { $table { "Icon" "Message type" "Reference" } - { { $image "vocab:ui/tools/error-list/icons/note.tiff" } "Parser note" { $link "parser" } } - { { $image "vocab:ui/tools/error-list/icons/syntax-error.tiff" } "Syntax error" { $link "syntax" } } - { { $image "vocab:ui/tools/error-list/icons/compiler-warning.tiff" } "Compiler warning" { $link "compiler-errors" } } + ! { { $image "vocab:ui/tools/error-list/icons/note.tiff" } "Parser note" { $link "parser" } } + ! { { $image "vocab:ui/tools/error-list/icons/syntax-error.tiff" } "Syntax error" { $link "syntax" } } { { $image "vocab:ui/tools/error-list/icons/compiler-error.tiff" } "Compiler error" { $link "compiler-errors" } } + { { $image "vocab:ui/tools/error-list/icons/linkage-error.tiff" } "Linkage error" { $link "loading-libs" } } { { $image "vocab:ui/tools/error-list/icons/unit-test-error.tiff" } "Unit test failure" { $link "tools.test" } } { { $image "vocab:ui/tools/error-list/icons/help-lint-error.tiff" } "Help lint failure" { $link "help.lint" } } - { { $image "vocab:ui/tools/error-list/icons/linkage-error.tiff" } "Linkage error" { $link "loading-libs" } } } ; ABOUT: "ui.tools.error-list" diff --git a/basis/ui/tools/error-list/error-list.factor b/basis/ui/tools/error-list/error-list.factor index 6a63a70cf8..aa23a8ebe1 100644 --- a/basis/ui/tools/error-list/error-list.factor +++ b/basis/ui/tools/error-list/error-list.factor @@ -4,14 +4,14 @@ USING: accessors arrays sequences sorting assocs colors.constants fry combinators combinators.smart combinators.short-circuit editors make memoize compiler.units fonts kernel io.pathnames prettyprint source-files.errors math.parser init math.order models models.arrow -models.arrow.smart models.search models.mapping models.delay debugger namespaces -summary locals ui ui.commands ui.gadgets ui.gadgets.panes +models.arrow.smart models.search models.mapping debugger +namespaces summary locals ui ui.commands ui.gadgets ui.gadgets.panes ui.gadgets.tables ui.gadgets.labeled ui.gadgets.tracks ui.gestures ui.operations ui.tools.browser ui.tools.common ui.gadgets.scrollers ui.tools.inspector ui.gadgets.status-bar ui.operations ui.gadgets.buttons ui.gadgets.borders ui.gadgets.packs -ui.gadgets.labels ui.baseline-alignment ui.images -compiler.errors calendar ; +ui.gadgets.labels ui.baseline-alignment ui.images ui.tools.listener +compiler.errors tools.errors tools.errors.model ; IN: ui.tools.error-list CONSTANT: source-file-icon @@ -39,7 +39,7 @@ SINGLETON: source-file-renderer M: source-file-renderer row-columns drop first2 [ [ source-file-icon ] - [ "" or ] + [ +listener-input+ or ] [ length number>string ] tri* ] output>array ; @@ -97,7 +97,7 @@ M: error-renderer column-titles M: error-renderer column-alignment drop { 0 1 0 0 } ; : sort-errors ( seq -- seq' ) - [ [ [ asset>> unparse-short ] [ line#>> ] bi 2array ] keep ] { } map>assoc + [ [ [ line#>> ] [ asset>> unparse-short ] bi 2array ] keep ] { } map>assoc sort-keys values ; : file-matches? ( error pathname/f -- ? ) @@ -180,23 +180,9 @@ error-list-gadget "toolbar" f { { T{ key-down f f "F1" } error-list-help } } define-command-map -SYMBOL: error-list-model - -error-list-model [ f ] initialize - -SINGLETON: updater - -M: updater errors-changed - drop f error-list-model get-global set-model ; - -[ updater add-error-observer ] "ui.tools.error-list" add-init-hook - -: ( -- model ) - error-list-model get-global - 1/2 seconds [ drop all-errors ] ; - : error-list-window ( -- ) - "Errors" open-status-window ; + error-list-model get [ drop all-errors ] + "Errors" open-status-window ; : show-error-list ( -- ) [ error-list-gadget? ] find-window diff --git a/basis/ui/tools/error-list/icons/compiler-warning.tiff b/basis/ui/tools/error-list/icons/compiler-warning.tiff deleted file mode 100644 index 405cfd4761..0000000000 Binary files a/basis/ui/tools/error-list/icons/compiler-warning.tiff and /dev/null differ diff --git a/basis/ui/tools/inspector/inspector-tests.factor b/basis/ui/tools/inspector/inspector-tests.factor index 44e20fb0fd..2971b1e8cb 100644 --- a/basis/ui/tools/inspector/inspector-tests.factor +++ b/basis/ui/tools/inspector/inspector-tests.factor @@ -1,6 +1,4 @@ IN: ui.tools.inspector.tests USING: tools.test ui.tools.inspector math models ; -\ must-infer - [ ] [ \ + com-edit-slot ] unit-test \ No newline at end of file diff --git a/basis/ui/tools/listener/listener-tests.factor b/basis/ui/tools/listener/listener-tests.factor index 986e1270eb..45b94344a6 100644 --- a/basis/ui/tools/listener/listener-tests.factor +++ b/basis/ui/tools/listener/listener-tests.factor @@ -6,8 +6,6 @@ threads arrays generic threads accessors listener math calendar concurrency.promises io ui.tools.common ; IN: ui.tools.listener.tests -\ must-infer - [ [ ] [ >>output "interactor" set ] unit-test diff --git a/basis/ui/tools/listener/listener.factor b/basis/ui/tools/listener/listener.factor index 6484b8e1c4..eca16e7286 100644 --- a/basis/ui/tools/listener/listener.factor +++ b/basis/ui/tools/listener/listener.factor @@ -13,7 +13,7 @@ ui.gadgets.labeled ui.gadgets.panes ui.gadgets.scrollers ui.gadgets.status-bar ui.gadgets.tracks ui.gadgets.borders ui.gestures ui.operations ui.tools.browser ui.tools.common ui.tools.debugger ui.tools.listener.completion ui.tools.listener.popups -ui.tools.listener.history ui.tools.error-list ; +ui.tools.listener.history ui.images ui.tools.error-list tools.errors.model ; FROM: source-files.errors => all-errors ; IN: ui.tools.listener @@ -32,9 +32,10 @@ output history flag mailbox thread waiting token-model word-model popup ; : interactor-busy? ( interactor -- ? ) #! We're busy if there's no thread to resume. - [ waiting>> ] - [ thread>> dup [ thread-registered? ] when ] - bi and not ; + { + [ waiting>> ] + [ thread>> dup [ thread-registered? ] when ] + } 1&& not ; SLOT: vocabs @@ -171,7 +172,7 @@ M: interactor dispose drop ; over set-caret mark>caret ; -TUPLE: listener-gadget < tool input output scroller ; +TUPLE: listener-gadget < tool error-summary output scroller input ; { 600 700 } listener-gadget set-tool-dim @@ -181,17 +182,35 @@ TUPLE: listener-gadget < tool input output scroller ; : listener-streams ( listener -- input output ) [ input>> ] [ output>> ] bi ; -: init-listener ( listener -- listener ) +: init-input/output ( listener -- listener ) [ >>input ] [ pane new-pane t >>scrolls? >>output ] bi dup listener-streams >>output drop ; -: ( -- gadget ) +: error-summary. ( -- ) + error-counts keys [ + H{ { table-gap { 3 3 } } } [ + [ [ [ icon>> write-image ] with-cell ] each ] with-row + ] tabular-output + { "Press " { $command tool "common" show-error-list } " to view errors." } + print-element + ] unless-empty ; + +: ( -- gadget ) + error-list-model get [ drop error-summary. ] + COLOR: light-yellow >>interior ; + +: init-error-summary ( listener -- listener ) + >>error-summary + dup error-summary>> f track-add ; + +: ( -- listener ) vertical listener-gadget new-track add-toolbar - init-listener + init-input/output dup output>> >>scroller - dup scroller>> 1 track-add ; + dup scroller>> 1 track-add + init-error-summary ; M: listener-gadget focusable-child* input>> dup popup>> or ; @@ -357,18 +376,11 @@ interactor "completion" f { { T{ key-down f { C+ } "r" } history-completion-popup } } define-command-map -: ui-error-summary ( -- ) - error-counts keys [ - [ icon>> 1array \ $image prefix " " 2array ] { } map-as - { "Press " { $command tool "common" show-error-list } " to view errors." } - append print-element nl - ] unless-empty ; - : listener-thread ( listener -- ) dup listener-streams [ [ com-browse ] help-hook set '[ [ _ input>> ] 2dip debugger-popup ] error-hook set - [ ui-error-summary ] error-summary-hook set + error-summary? off tip-of-the-day. nl listener ] with-streams* ; diff --git a/basis/ui/tools/profiler/profiler-tests.factor b/basis/ui/tools/profiler/profiler-tests.factor index 86bebddbc9..c1c8fdbff9 100644 --- a/basis/ui/tools/profiler/profiler-tests.factor +++ b/basis/ui/tools/profiler/profiler-tests.factor @@ -1,3 +1,3 @@ USING: ui.tools.profiler tools.test ; -\ profiler-window must-infer + diff --git a/basis/ui/tools/walker/walker-tests.factor b/basis/ui/tools/walker/walker-tests.factor index fefb188239..fe0b57b980 100644 --- a/basis/ui/tools/walker/walker-tests.factor +++ b/basis/ui/tools/walker/walker-tests.factor @@ -1,4 +1,3 @@ USING: ui.tools.walker tools.test ; IN: ui.tools.walker.tests -\ must-infer diff --git a/basis/ui/ui-tests.factor b/basis/ui/ui-tests.factor index 4b4bf9d9ee..06de4eb9c2 100644 --- a/basis/ui/ui-tests.factor +++ b/basis/ui/ui-tests.factor @@ -1,5 +1,2 @@ IN: ui.tests USING: ui ui.private tools.test ; - -\ open-window must-infer -\ update-ui must-infer \ No newline at end of file diff --git a/basis/unicode/breaks/breaks-tests.factor b/basis/unicode/breaks/breaks-tests.factor index 3a26b01213..6d6d4233f5 100644 --- a/basis/unicode/breaks/breaks-tests.factor +++ b/basis/unicode/breaks/breaks-tests.factor @@ -32,7 +32,7 @@ IN: unicode.breaks.tests [ concat [ quot call [ "" like ] map ] curry ] bi unit-test ] each ; -: grapheme-test ( tests quot -- ) +: grapheme-test ( tests -- ) [ [ 1quotation ] [ concat [ >graphemes [ "" like ] map ] curry ] bi unit-test diff --git a/basis/unicode/case/case-tests.factor b/basis/unicode/case/case-tests.factor index a76f5e78c4..9344d1102e 100644 --- a/basis/unicode/case/case-tests.factor +++ b/basis/unicode/case/case-tests.factor @@ -4,10 +4,6 @@ USING: unicode.case tools.test namespaces strings unicode.normalize unicode.case.private ; IN: unicode.case.tests -\ >upper must-infer -\ >lower must-infer -\ >title must-infer - [ "Hello How Are You? I'm Good" ] [ "hEllo how ARE yOU? I'm good" >title ] unit-test [ "FUSS" ] [ "Fu\u0000DF" >upper ] unit-test [ "\u0003C3a\u0003C2 \u0003C3\u0003C2 \u0003C3a\u0003C2" ] [ "\u0003A3A\u0003A3 \u0003A3\u0003A3 \u0003A3A\u0003A3" >lower ] unit-test diff --git a/basis/unicode/collation/collation-tests.factor b/basis/unicode/collation/collation-tests.factor index f53a1382ae..fdeb721e65 100644 --- a/basis/unicode/collation/collation-tests.factor +++ b/basis/unicode/collation/collation-tests.factor @@ -11,9 +11,10 @@ IN: unicode.collation.tests : test-two ( str1 str2 -- ) [ +lt+ ] -rot [ string<=> ] 2curry unit-test ; -: test-equality ( str1 str2 -- ) +: test-equality ( str1 str2 -- ? ? ? ? ) { primary= secondary= tertiary= quaternary= } - [ execute ] with with each ; + [ execute( a b -- ? ) ] with with map + first4 ; [ f f f f ] [ "hello" "hi" test-equality ] unit-test [ t f f f ] [ "hello" "h\u0000e9llo" test-equality ] unit-test diff --git a/basis/unicode/normalize/normalize-tests.factor b/basis/unicode/normalize/normalize-tests.factor index f774016272..cea880c0b0 100644 --- a/basis/unicode/normalize/normalize-tests.factor +++ b/basis/unicode/normalize/normalize-tests.factor @@ -3,8 +3,6 @@ simple-flat-file io.encodings.utf8 io.files splitting math.parser locals math quotations assocs combinators unicode.normalize.private ; IN: unicode.normalize.tests -{ nfc nfkc nfd nfkd } [ must-infer ] each - [ "ab\u000323\u000302cd" ] [ "ab\u000302" "\u000323cd" string-append ] unit-test [ "ab\u00064b\u000347\u00034e\u00034d\u000346" ] [ "ab\u000346\u000347\u00064b\u00034e\u00034d" dup reorder ] unit-test diff --git a/basis/unix/groups/groups-tests.factor b/basis/unix/groups/groups-tests.factor index 2e989b32c0..eae2020077 100644 --- a/basis/unix/groups/groups-tests.factor +++ b/basis/unix/groups/groups-tests.factor @@ -5,8 +5,6 @@ IN: unix.groups.tests [ ] [ all-groups drop ] unit-test -\ all-groups must-infer - [ t ] [ real-group-name string? ] unit-test [ t ] [ effective-group-name string? ] unit-test diff --git a/basis/unix/users/users-tests.factor b/basis/unix/users/users-tests.factor index f2a4b7bc27..cf3747b346 100644 --- a/basis/unix/users/users-tests.factor +++ b/basis/unix/users/users-tests.factor @@ -3,11 +3,8 @@ USING: tools.test unix.users kernel strings math ; IN: unix.users.tests - [ ] [ all-users drop ] unit-test -\ all-users must-infer - [ t ] [ real-user-name string? ] unit-test [ t ] [ effective-user-name string? ] unit-test diff --git a/basis/windows/com/wrapper/wrapper.factor b/basis/windows/com/wrapper/wrapper.factor index a014a56ea0..e78c987cd4 100755 --- a/basis/windows/com/wrapper/wrapper.factor +++ b/basis/windows/com/wrapper/wrapper.factor @@ -132,7 +132,7 @@ unless [ [ 1 ] 2dip set-alien-unsigned-4 ] [ drop ] 2bi ; : (callbacks>vtbl) ( callbacks -- vtbl ) - [ execute ] void*-array{ } map-as malloc-byte-array ; + [ execute( -- callback ) ] void*-array{ } map-as malloc-byte-array ; : (callbacks>vtbls) ( callbacks -- vtbls ) [ (callbacks>vtbl) ] map ; diff --git a/basis/wrap/strings/strings-tests.factor b/basis/wrap/strings/strings-tests.factor index e66572dc1b..07f42caae3 100644 --- a/basis/wrap/strings/strings-tests.factor +++ b/basis/wrap/strings/strings-tests.factor @@ -38,6 +38,4 @@ word wrap."> [ "aaa bb\ncccc\nddddd" ] [ "aaa bb cccc ddddd" 6 wrap-string ] unit-test [ "aaa bb\nccccccc\nddddddd" ] [ "aaa bb ccccccc ddddddd" 6 wrap-string ] unit-test -\ wrap-string must-infer - [ "a b c d e f\ng h" ] [ "a b c d e f g h" 11 wrap-string ] unit-test diff --git a/basis/wrap/words/words-tests.factor b/basis/wrap/words/words-tests.factor index 7598b382ba..6df69a65d6 100644 --- a/basis/wrap/words/words-tests.factor +++ b/basis/wrap/words/words-tests.factor @@ -79,4 +79,3 @@ IN: wrap.words.tests } 35 35 wrap-words [ { } like ] map ] unit-test -\ wrap-words must-infer diff --git a/basis/x11/windows/windows.factor b/basis/x11/windows/windows.factor index 87a212bd8e..37da51e9b8 100644 --- a/basis/x11/windows/windows.factor +++ b/basis/x11/windows/windows.factor @@ -6,7 +6,7 @@ arrays fry ; IN: x11.windows : create-window-mask ( -- n ) - { CWColormap CWEventMask } flags ; + { CWBackPixel CWBorderPixel CWColormap CWEventMask } flags ; : create-colormap ( visinfo -- colormap ) [ dpy get root get ] dip XVisualInfo-visual AllocNone diff --git a/basis/xml/syntax/syntax-tests.factor b/basis/xml/syntax/syntax-tests.factor index 10ab961ec0..6fcaf780cc 100644 --- a/basis/xml/syntax/syntax-tests.factor +++ b/basis/xml/syntax/syntax-tests.factor @@ -33,8 +33,6 @@ TAG: neg calculate calc-arith ] unit-test -\ calc-arith must-infer - XML-NS: foo http://blah.com [ T{ name { main "bling" } { url "http://blah.com" } } ] [ "bling" foo ] unit-test @@ -90,7 +88,6 @@ XML-NS: foo http://blah.com [ "3" ] [ 3 [XML <-> XML] xml>string ] unit-test [ "" ] [ f [XML <-> XML] xml>string ] unit-test -\ XML] ] must-infer [ [XML <-> /> XML] ] must-infer diff --git a/basis/xml/tests/test.factor b/basis/xml/tests/test.factor index 1d07aa9406..74ba931c79 100644 --- a/basis/xml/tests/test.factor +++ b/basis/xml/tests/test.factor @@ -7,9 +7,7 @@ xml.traversal continuations assocs io.encodings.binary sequences.deep accessors io.streams.string ; ! This is insufficient -\ read-xml must-infer [ [ drop ] each-element ] must-infer -\ string>xml must-infer SYMBOL: xml-file [ ] [ diff --git a/basis/xml/writer/writer-tests.factor b/basis/xml/writer/writer-tests.factor index 2d31738c4c..ee09668a53 100644 --- a/basis/xml/writer/writer-tests.factor +++ b/basis/xml/writer/writer-tests.factor @@ -5,9 +5,6 @@ xml.writer.private io.streams.string xml.traversal sequences io.encodings.utf8 io.files accessors io.directories math math.parser ; IN: xml.writer.tests -\ write-xml must-infer -\ xml>string must-infer -\ pprint-xml must-infer ! Add a test for pprint-xml with sensitive-tags [ "foo" ] [ T{ name { main "foo" } } name>string ] unit-test diff --git a/basis/xmode/code2html/code2html-tests.factor b/basis/xmode/code2html/code2html-tests.factor index 8d5db4a6e9..d57b8ce28d 100644 --- a/basis/xmode/code2html/code2html-tests.factor +++ b/basis/xmode/code2html/code2html-tests.factor @@ -3,8 +3,6 @@ USING: xmode.code2html xmode.catalog tools.test multiline splitting memoize kernel io.streams.string xml.writer ; -\ htmlize-file must-infer - [ ] [ \ (load-mode) reset-memoized ] unit-test [ ] [ diff --git a/build-support/factor.sh b/build-support/factor.sh index 53aab9ad04..3ece72306a 100755 --- a/build-support/factor.sh +++ b/build-support/factor.sh @@ -22,6 +22,13 @@ test_program_installed() { return 1; } +exit_script() { + if [[ $FIND_MAKE_TARGET -eq true ]] ; then + echo $MAKE_TARGET; + fi + exit $1 +} + ensure_program_installed() { installed=0; for i in $* ; @@ -43,7 +50,7 @@ ensure_program_installed() { $ECHO -n "any of [ $* ]" fi $ECHO " and try again." - exit 1 + exit_script 1; fi } @@ -51,7 +58,7 @@ check_ret() { RET=$? if [[ $RET -ne 0 ]] ; then $ECHO $1 failed - exit 2 + exit_script 2 fi } @@ -62,7 +69,7 @@ check_gcc_version() { if [[ $GCC_VERSION == *3.3.* ]] ; then $ECHO "You have a known buggy version of gcc (3.3)" $ECHO "Install gcc 3.4 or higher and try again." - exit 3 + exit_script 3 elif [[ $GCC_VERSION == *4.3.* ]] ; then MAKE_OPTS="$MAKE_OPTS SITE_CFLAGS=-fno-forward-propagate" fi @@ -154,7 +161,7 @@ check_factor_exists() { if [[ -d "factor" ]] ; then $ECHO "A directory called 'factor' already exists." $ECHO "Rename or delete it and try again." - exit 4 + exit_script 4 fi } @@ -279,7 +286,7 @@ check_os_arch_word() { $ECHO "OS, ARCH, or WORD is empty. Please report this." echo $MAKE_TARGET - exit 5 + exit_script 5 fi } @@ -385,7 +392,7 @@ check_makefile_exists() { echo "You are likely in the wrong directory." echo "Run this script from your factor directory:" echo " ./build-support/factor.sh" - exit 6 + exit_script 6 fi } @@ -536,6 +543,6 @@ case "$1" in bootstrap) get_config_info; bootstrap ;; report) find_build_info ;; net-bootstrap) get_config_info; update_boot_images; bootstrap ;; - make-target) ECHO=false; find_build_info; echo $MAKE_TARGET ;; + make-target) FIND_MAKE_TARGET=true; ECHO=false; find_build_info; exit_script ;; *) usage ;; esac diff --git a/core/assocs/assocs-docs.factor b/core/assocs/assocs-docs.factor index 9576a41b7b..d4046a4dcf 100755 --- a/core/assocs/assocs-docs.factor +++ b/core/assocs/assocs-docs.factor @@ -361,8 +361,7 @@ HELP: inc-at HELP: >alist { $values { "assoc" assoc } { "newassoc" "an array of key/value pairs" } } -{ $contract "Converts an associative structure into an association list." } -{ $notes "The " { $link assoc } " mixin has a default implementation for this generic word which constructs the association list by iterating over the assoc with " { $link assoc-find } "." } ; +{ $contract "Converts an associative structure into an association list." } ; HELP: assoc-clone-like { $values diff --git a/core/bootstrap/primitives.factor b/core/bootstrap/primitives.factor index 4466bd9bfe..1258da8a4d 100644 --- a/core/bootstrap/primitives.factor +++ b/core/bootstrap/primitives.factor @@ -12,8 +12,6 @@ IN: bootstrap.primitives "Creating primitives and basic runtime structures..." print flush -crossref off - H{ } clone sub-primitives set "vocab:bootstrap/syntax.factor" parse-file diff --git a/core/checksums/checksums-tests.factor b/core/checksums/checksums-tests.factor index 1ec675b0cf..8ba09d8e91 100644 --- a/core/checksums/checksums-tests.factor +++ b/core/checksums/checksums-tests.factor @@ -1,7 +1,3 @@ IN: checksums.tests USING: checksums tools.test ; -\ checksum-bytes must-infer -\ checksum-stream must-infer -\ checksum-lines must-infer -\ checksum-file must-infer diff --git a/core/classes/algebra/algebra-tests.factor b/core/classes/algebra/algebra-tests.factor index a3610ff7c5..a6af5b8c29 100644 --- a/core/classes/algebra/algebra-tests.factor +++ b/core/classes/algebra/algebra-tests.factor @@ -7,12 +7,6 @@ random stack-checker effects kernel.private sbufs math.order classes.tuple accessors ; IN: classes.algebra.tests -\ class< must-infer -\ class-and must-infer -\ class-or must-infer -\ flatten-class must-infer -\ flatten-builtin-class must-infer - : class-and* ( cls1 cls2 cls3 -- ? ) [ class-and ] dip class= ; : class-or* ( cls1 cls2 cls3 -- ? ) [ class-or ] dip class= ; diff --git a/core/classes/classes-tests.factor b/core/classes/classes-tests.factor index 08746d1ba7..61d153f064 100644 --- a/core/classes/classes-tests.factor +++ b/core/classes/classes-tests.factor @@ -3,7 +3,7 @@ io.streams.string kernel math namespaces parser prettyprint sequences strings tools.test vectors words quotations classes classes.private classes.union classes.mixin classes.predicate classes.algebra vectors definitions source-files compiler.units -kernel.private sorting vocabs memory eval accessors ; +kernel.private sorting vocabs memory eval accessors sets ; IN: classes.tests [ t ] [ 3 object instance? ] unit-test @@ -22,10 +22,11 @@ M: method-forget-class method-forget-test ; [ ] [ [ \ method-forget-class forget ] with-compilation-unit ] unit-test [ t ] [ \ method-forget-test "methods" word-prop assoc-empty? ] unit-test -[ t ] [ +[ { } { } ] [ all-words [ class? ] filter implementors-map get keys - [ natural-sort ] bi@ = + [ natural-sort ] bi@ + [ diff ] [ swap diff ] 2bi ] unit-test ! Minor leak diff --git a/core/classes/classes.factor b/core/classes/classes.factor index ab8ba398cd..dfaec95f76 100644 --- a/core/classes/classes.factor +++ b/core/classes/classes.factor @@ -135,7 +135,7 @@ M: sequence implementors [ implementors ] gather ; [ dup class? [ drop ] [ [ implementors-map+ ] [ new-class ] bi ] if ] [ reset-class ] [ ?define-symbol ] - [ redefined ] + [ changed-definition ] [ ] } cleave ] dip [ assoc-union ] curry change-props diff --git a/core/classes/tuple/tuple-tests.factor b/core/classes/tuple/tuple-tests.factor index 68cdc20c53..c180807b0c 100644 --- a/core/classes/tuple/tuple-tests.factor +++ b/core/classes/tuple/tuple-tests.factor @@ -5,7 +5,7 @@ generic.standard effects classes.tuple classes.tuple.private arrays vectors strings compiler.units accessors classes.algebra calendar prettyprint io.streams.string splitting summary columns math.order classes.private slots slots.private eval see -words.symbol ; +words.symbol compiler.errors ; IN: classes.tuple.tests TUPLE: rect x y w h ; @@ -34,9 +34,7 @@ C: redefinition-test ! Make sure we handle changing shapes! TUPLE: point x y ; -C: point - -[ ] [ 100 200 "p" set ] unit-test +[ ] [ 100 200 point boa "p" set ] unit-test ! Use eval to sequence parsing explicitly [ ] [ "IN: classes.tuple.tests TUPLE: point x y z ;" eval( -- ) ] unit-test @@ -112,8 +110,6 @@ TUPLE: yo-momma ; [ ] [ \ yo-momma forget ] unit-test [ ] [ \ forget ] unit-test [ f ] [ \ yo-momma update-map get values memq? ] unit-test - - [ f ] [ \ yo-momma crossref get at ] unit-test ] with-compilation-unit TUPLE: loc-recording ; @@ -199,17 +195,6 @@ TUPLE: erg's-reshape-problem a b c d ; C: erg's-reshape-problem -! We want to make sure constructors are recompiled when -! tuples are reshaped -: cons-test-1 ( -- tuple ) \ erg's-reshape-problem new ; -: cons-test-2 ( a b c d -- tuple ) \ erg's-reshape-problem boa ; - -[ ] [ "IN: classes.tuple.tests TUPLE: erg's-reshape-problem a b c d e f ;" eval( -- ) ] unit-test - -[ ] [ 1 2 3 4 5 6 cons-test-2 "a" set ] unit-test - -[ t ] [ cons-test-1 tuple-size "a" get tuple-size = ] unit-test - ! Inheritance TUPLE: computer cpu ram ; C: computer @@ -287,7 +272,7 @@ test-server-slot-values ! Dynamically changing inheritance hierarchy TUPLE: electronic-device ; -[ ] [ "IN: classes.tuple.tests TUPLE: computer < electronic-device cpu ram ;" eval( -- ) ] unit-test +[ ] [ "IN: classes.tuple.tests TUPLE: computer < electronic-device cpu ram ; C: computer C: laptop C: server" eval( -- ) ] unit-test [ f ] [ electronic-device laptop class<= ] unit-test [ t ] [ server electronic-device class<= ] unit-test @@ -303,17 +288,17 @@ TUPLE: electronic-device ; [ f ] [ "server" get laptop? ] unit-test [ t ] [ "server" get server? ] unit-test -[ ] [ "IN: classes.tuple.tests TUPLE: computer cpu ram ;" eval( -- ) ] unit-test +[ ] [ "IN: classes.tuple.tests TUPLE: computer cpu ram ; C: computer C: laptop C: server" eval( -- ) ] unit-test [ f ] [ "laptop" get electronic-device? ] unit-test [ t ] [ "laptop" get computer? ] unit-test -[ ] [ "IN: classes.tuple.tests TUPLE: computer < electronic-device cpu ram disk ;" eval( -- ) ] unit-test +[ ] [ "IN: classes.tuple.tests TUPLE: computer < electronic-device cpu ram disk ; C: computer C: laptop C: server" eval( -- ) ] unit-test test-laptop-slot-values test-server-slot-values -[ ] [ "IN: classes.tuple.tests TUPLE: electronic-device voltage ;" eval( -- ) ] unit-test +[ ] [ "IN: classes.tuple.tests TUPLE: electronic-device voltage ; C: computer C: laptop C: server" eval( -- ) ] unit-test test-laptop-slot-values test-server-slot-values @@ -326,7 +311,7 @@ TUPLE: make-me-some-accessors voltage grounded? ; [ ] [ "laptop" get 220 >>voltage drop ] unit-test [ ] [ "server" get 110 >>voltage drop ] unit-test -[ ] [ "IN: classes.tuple.tests TUPLE: electronic-device voltage grounded? ;" eval( -- ) ] unit-test +[ ] [ "IN: classes.tuple.tests TUPLE: electronic-device voltage grounded? ; C: computer" eval( -- ) ] unit-test test-laptop-slot-values test-server-slot-values @@ -334,7 +319,7 @@ test-server-slot-values [ 220 ] [ "laptop" get voltage>> ] unit-test [ 110 ] [ "server" get voltage>> ] unit-test -[ ] [ "IN: classes.tuple.tests TUPLE: electronic-device grounded? voltage ;" eval( -- ) ] unit-test +[ ] [ "IN: classes.tuple.tests TUPLE: electronic-device grounded? voltage ; C: computer C: laptop C: server" eval( -- ) ] unit-test test-laptop-slot-values test-server-slot-values @@ -343,7 +328,7 @@ test-server-slot-values [ 110 ] [ "server" get voltage>> ] unit-test ! Reshaping superclass and subclass simultaneously -[ ] [ "IN: classes.tuple.tests TUPLE: electronic-device voltage ; TUPLE: computer < electronic-device cpu ram ;" eval( -- ) ] unit-test +[ ] [ "IN: classes.tuple.tests TUPLE: electronic-device voltage ; TUPLE: computer < electronic-device cpu ram ; C: computer C: laptop C: server" eval( -- ) ] unit-test test-laptop-slot-values test-server-slot-values @@ -354,9 +339,7 @@ test-server-slot-values ! Reshape crash TUPLE: test1 a ; TUPLE: test2 < test1 b ; -C: test2 - -"a" "b" "test" set +"a" "b" test2 boa "test" set : test-a/b ( -- ) [ "a" ] [ "test" get a>> ] unit-test @@ -412,15 +395,17 @@ TUPLE: constructor-update-1 xxx ; TUPLE: constructor-update-2 < constructor-update-1 yyy zzz ; -C: constructor-update-2 +: ( a b c -- tuple ) constructor-update-2 boa ; { 3 1 } [ ] must-infer-as [ ] [ "IN: classes.tuple.tests TUPLE: constructor-update-1 xxx ttt www ;" eval( -- ) ] unit-test -{ 5 1 } [ ] must-infer-as +{ 3 1 } [ ] must-infer-as -[ { 1 2 3 4 5 } ] [ 1 2 3 4 5 tuple-slots ] unit-test +[ 1 2 3 4 5 ] [ not-compiled? ] must-fail-with + +[ ] [ [ \ forget ] with-compilation-unit ] unit-test ! Redefinition problem TUPLE: redefinition-problem ; @@ -599,7 +584,7 @@ must-fail-with : foo ( a b -- c ) declared-types boa ; -\ foo must-infer +\ foo def>> must-infer [ T{ declared-types f 0 "hi" } ] [ 0.0 "hi" foo ] unit-test @@ -623,7 +608,7 @@ must-fail-with : blah ( -- vec ) vector new ; -\ blah must-infer +[ vector new ] must-infer [ V{ } ] [ blah ] unit-test diff --git a/core/classes/tuple/tuple.factor b/core/classes/tuple/tuple.factor index fb7a073205..fb1e613b3e 100755 --- a/core/classes/tuple/tuple.factor +++ b/core/classes/tuple/tuple.factor @@ -243,7 +243,7 @@ M: tuple-class update-class 2drop [ [ update-tuples-after ] - [ redefined ] + [ changed-definition ] bi ] each-subclass ] diff --git a/core/combinators/combinators-docs.factor b/core/combinators/combinators-docs.factor index dd55d5fabe..cbef25ac38 100644 --- a/core/combinators/combinators-docs.factor +++ b/core/combinators/combinators-docs.factor @@ -198,6 +198,8 @@ ARTICLE: "booleans" "Booleans" "In Factor, any object that is not " { $link f } " has a true value, and " { $link f } " has a false value. The " { $link t } " object is the canonical true value." { $subsection f } { $subsection t } +"A union class of the above:" +{ $subsection boolean } "There are some logical operations on booleans:" { $subsection >boolean } { $subsection not } @@ -269,28 +271,28 @@ ARTICLE: "combinators-quot" "Quotation construction utilities" { $subsection case>quot } { $subsection alist>quot } ; -ARTICLE: "call" "Fundamental combinators" -"The most basic combinators are those that take either a quotation or word, and invoke it immediately. There are two sets of combinators; they differe in whether or not the stack effect of the expected code is declared." -$nl -"The simplest combinators do not take an effect declaration:" -{ $subsection call } -{ $subsection execute } -"These combinators only get optimized by the compiler if the quotation or word parameter is a literal; otherwise a compiler warning will result. Definitions of combinators which require literal parameters must be followed by the " { $link POSTPONE: inline } " declaration. For example:" -{ $code - ": keep ( x quot -- x )" - " over [ call ] dip ; inline" -} -"See " { $link "declarations" } " and " { $link "compiler-errors" } " for details." -$nl -"The other set of combinators allow arbitrary quotations and words to be called from optimized code. This is done by specifying the stack effect of the quotation literally. It is checked at runtime that the stack effect is accurate." -{ $subsection call-effect } -{ $subsection execute-effect } -"A simple layer of syntax sugar is defined on top:" -{ $subsection POSTPONE: call( } -{ $subsection POSTPONE: execute( } +ARTICLE: "call-unsafe" "Unsafe combinators" "Unsafe calls declare an effect statically without any runtime checking:" { $subsection call-effect-unsafe } -{ $subsection execute-effect-unsafe } +{ $subsection execute-effect-unsafe } ; + +ARTICLE: "call" "Fundamental combinators" +"The most basic combinators are those that take either a quotation or word, and invoke it immediately." +$nl +"There are two sets of combinators; they differ in whether or not the stack effect of the expected code is declared." +$nl +"The simplest combinators do not take an effect declaration. The compiler checks the stack effect at compile time, rejecting the program if this cannot be done:" +{ $subsection call } +{ $subsection execute } +"The second set of combinators takes an effect declaration. The stack effect of the quotation or word is checked at runtime:" +{ $subsection POSTPONE: call( } +{ $subsection POSTPONE: execute( } +"The above are syntax sugar. The underlying words are a bit more verbose but allow non-constant effects to be passed in:" +{ $subsection call-effect } +{ $subsection execute-effect } +{ $subsection "call-unsafe" } +"The combinator variants that do not take an effect declaration can only be used if the compiler is able to infer the stack effect by other means. See " { $link "inference-combinators" } "." +{ $subsection "call-unsafe" } { $see-also "effects" "inference" } ; ARTICLE: "combinators" "Combinators" diff --git a/core/combinators/combinators-tests.factor b/core/combinators/combinators-tests.factor index a8049f709e..dd5fa06031 100644 --- a/core/combinators/combinators-tests.factor +++ b/core/combinators/combinators-tests.factor @@ -42,7 +42,7 @@ IN: combinators.tests { [ dup 2 mod 1 = ] [ drop "odd" ] } } cond ; -\ cond-test-1 must-infer +\ cond-test-1 def>> must-infer [ "even" ] [ 2 cond-test-1 ] unit-test [ "odd" ] [ 3 cond-test-1 ] unit-test @@ -54,7 +54,7 @@ IN: combinators.tests [ drop "something else" ] } cond ; -\ cond-test-2 must-infer +\ cond-test-2 def>> must-infer [ "true" ] [ t cond-test-2 ] unit-test [ "false" ] [ f cond-test-2 ] unit-test @@ -67,7 +67,7 @@ IN: combinators.tests { [ dup f = ] [ drop "false" ] } } cond ; -\ cond-test-3 must-infer +\ cond-test-3 def>> must-infer [ "something else" ] [ t cond-test-3 ] unit-test [ "something else" ] [ f cond-test-3 ] unit-test @@ -77,7 +77,7 @@ IN: combinators.tests { } cond ; -\ cond-test-4 must-infer +\ cond-test-4 def>> must-infer [ cond-test-4 ] [ class \ no-cond = ] must-fail-with @@ -168,7 +168,7 @@ IN: combinators.tests { 4 [ "four" ] } } case ; -\ case-test-1 must-infer +\ case-test-1 def>> must-infer [ "two" ] [ 2 case-test-1 ] unit-test @@ -186,7 +186,7 @@ IN: combinators.tests [ sq ] } case ; -\ case-test-2 must-infer +\ case-test-2 def>> must-infer [ 25 ] [ 5 case-test-2 ] unit-test @@ -204,7 +204,7 @@ IN: combinators.tests [ sq ] } case ; -\ case-test-3 must-infer +\ case-test-3 def>> must-infer [ "an array" ] [ { 1 2 3 } case-test-3 ] unit-test @@ -222,7 +222,7 @@ CONSTANT: case-const-2 2 [ drop "demasiado" ] } case ; -\ case-test-4 must-infer +\ case-test-4 def>> must-infer [ "uno" ] [ 1 case-test-4 ] unit-test [ "dos" ] [ 2 case-test-4 ] unit-test @@ -239,7 +239,7 @@ CONSTANT: case-const-2 2 [ drop "demasiado" print ] } case ; -\ case-test-5 must-infer +\ case-test-5 def>> must-infer [ ] [ 1 case-test-5 ] unit-test @@ -296,7 +296,7 @@ CONSTANT: case-const-2 2 { 3 [ "three" ] } } case ; -\ test-case-6 must-infer +\ test-case-6 def>> must-infer [ "three" ] [ 3 test-case-6 ] unit-test [ "do-not-call" ] [ \ do-not-call test-case-6 ] unit-test @@ -343,7 +343,7 @@ CONSTANT: case-const-2 2 { \ ] [ "KFC" ] } } case ; -\ test-case-7 must-infer +\ test-case-7 def>> must-infer [ "plus" ] [ \ + test-case-7 ] unit-test diff --git a/core/compiler/units/units-docs.factor b/core/compiler/units/units-docs.factor index bf3b4a7171..94a95ac9c3 100644 --- a/core/compiler/units/units-docs.factor +++ b/core/compiler/units/units-docs.factor @@ -60,8 +60,8 @@ HELP: modify-code-heap ( alist -- ) { $values { "alist" "an alist" } } { $description "Stores compiled code definitions in the code heap. The alist maps words to the following:" { $list - { { $link f } " - in this case, the word is compiled with the non-optimizing compiler part of the VM." } - { { $snippet "{ code labels rel words literals }" } " - in this case, a code heap block is allocated with the given data." } + { "a quotation - in this case, the quotation is compiled with the non-optimizing compiler and the word will call the quotation when executed." } + { { $snippet "{ code labels rel words literals }" } " - in this case, a code heap block is allocated with the given data and the word will call the code block when executed." } } } { $notes "This word is called at the end of " { $link with-compilation-unit } "." } ; diff --git a/core/compiler/units/units-tests.factor b/core/compiler/units/units-tests.factor index 03c68815cc..da2dce128f 100644 --- a/core/compiler/units/units-tests.factor +++ b/core/compiler/units/units-tests.factor @@ -1,4 +1,4 @@ -USING: definitions compiler.units tools.test arrays sequences words kernel +USING: compiler definitions compiler.units tools.test arrays sequences words kernel accessors namespaces fry eval ; IN: compiler.units.tests @@ -14,11 +14,13 @@ IN: compiler.units.tests ! Non-optimizing compiler bugs [ 1 1 ] [ - "A" "B" [ [ 1 ] dip ] >>def dup f 2array 1array modify-code-heap + "A" "B" [ [ [ 1 ] dip ] 2array 1array modify-code-heap ] keep 1 swap execute ] unit-test [ "A" "B" ] [ + disable-compiler + gensym "a" set gensym "b" set [ @@ -30,9 +32,11 @@ IN: compiler.units.tests "a" get [ "B" ] define ] with-compilation-unit "b" get execute + + enable-compiler ] unit-test -! Notify observers even if compilation unit did nothing +! Check that we notify observers SINGLETON: observer observer add-definition-observer @@ -43,7 +47,7 @@ SYMBOL: counter M: observer definitions-changed 2drop global [ counter inc ] bind ; -[ ] with-compilation-unit +[ gensym [ ] (( -- )) define-declared ] with-compilation-unit [ 1 ] [ counter get-global ] unit-test diff --git a/core/compiler/units/units.factor b/core/compiler/units/units.factor index a278bf0d5e..c84e8fa73e 100644 --- a/core/compiler/units/units.factor +++ b/core/compiler/units/units.factor @@ -41,7 +41,7 @@ SYMBOL: compiler-impl HOOK: recompile compiler-impl ( words -- alist ) ! Non-optimizing compiler -M: f recompile [ f ] { } map>assoc ; +M: f recompile [ dup def>> ] { } map>assoc ; ! Trivial compiler. We don't want to touch the code heap ! during stage1 bootstrap, it would just waste time. @@ -144,7 +144,7 @@ GENERIC: definitions-changed ( assoc obj -- ) update-tuples process-forgotten-definitions modify-code-heap - updated-definitions notify-definition-observers + updated-definitions dup assoc-empty? [ drop ] [ notify-definition-observers ] if notify-error-observers ; : with-nested-compilation-unit ( quot -- ) diff --git a/core/continuations/continuations-docs.factor b/core/continuations/continuations-docs.factor index 651169554e..2c91981f13 100644 --- a/core/continuations/continuations-docs.factor +++ b/core/continuations/continuations-docs.factor @@ -81,8 +81,6 @@ $nl { $subsection attempt-all } { $subsection retry } { $subsection with-return } -"Reflecting the datastack:" -{ $subsection with-datastack } "Continuations serve as the building block for a number of higher-level abstractions, such as " { $link "errors" } " and " { $link "threads" } "." { $subsection "continuations.private" } ; @@ -211,7 +209,7 @@ $low-level-note ; HELP: with-datastack { $values { "stack" sequence } { "quot" quotation } { "newstack" sequence } } -{ $description "Executes the quotation with the given data stack contents, and outputs the new data stack after the word returns. The input sequence is not modified. Does not affect the data stack in surrounding code, other than consuming the two inputs and pushing the output." } +{ $description "Executes the quotation with the given data stack contents, and outputs the new data stack after the word returns. The input sequence is not modified; a new sequence is produced. Does not affect the data stack in surrounding code, other than consuming the two inputs and pushing the output." } { $examples { $example "USING: continuations math prettyprint ;" "{ 3 7 } [ + ] with-datastack ." "{ 10 }" } } ; diff --git a/core/continuations/continuations-tests.factor b/core/continuations/continuations-tests.factor index 2111cce358..f4eeeefb77 100644 --- a/core/continuations/continuations-tests.factor +++ b/core/continuations/continuations-tests.factor @@ -50,21 +50,19 @@ IN: continuations.tests gc ] unit-test -[ f ] [ { } kernel-error? ] unit-test -[ f ] [ { "A" "B" } kernel-error? ] unit-test - ! ! See how well callstack overflow is handled ! [ clear drop ] must-fail ! ! : callstack-overflow callstack-overflow f ; ! [ callstack-overflow ] must-fail -: don't-compile-me ( n -- ) { } [ ] each ; - -: foo ( -- ) callstack "c" set 3 don't-compile-me ; +: don't-compile-me ( -- ) ; +: foo ( -- ) callstack "c" set don't-compile-me ; : bar ( -- a b ) 1 foo 2 ; -[ 1 3 2 ] [ bar ] unit-test +<< { don't-compile-me foo bar } [ t "no-compile" set-word-prop ] each >> + +[ 1 2 ] [ bar ] unit-test [ t ] [ \ bar def>> "c" get innermost-frame-quot = ] unit-test @@ -107,4 +105,4 @@ SYMBOL: error-counter [ { 4 } ] [ { 2 2 } [ + ] with-datastack ] unit-test -\ with-datastack must-infer +[ with-datastack ] must-infer diff --git a/core/definitions/definitions-docs.factor b/core/definitions/definitions-docs.factor index 9d49cf62c6..b1575cc1e4 100644 --- a/core/definitions/definitions-docs.factor +++ b/core/definitions/definitions-docs.factor @@ -10,21 +10,11 @@ $nl { $subsection set-where } "Definitions can be removed:" { $subsection forget } -"Definitions can answer a sequence of definitions they directly depend on:" -{ $subsection uses } "Definitions must implement a few operations used for printing them in source form:" { $subsection definer } { $subsection definition } { $see-also "see" } ; -ARTICLE: "definition-crossref" "Definition cross referencing" -"A common cross-referencing system is used to track definition usages:" -{ $subsection crossref } -{ $subsection xref } -{ $subsection unxref } -{ $subsection delete-xref } -{ $subsection usage } ; - ARTICLE: "definition-checking" "Definition sanity checking" "When a source file is reloaded, the parser compares the previous list of definitions with the current list; any definitions which are no longer present in the file are removed by a call to " { $link forget } ". A warning message is printed if any other definitions still depend on the removed definitions." $nl @@ -69,7 +59,6 @@ $nl } "For every source file loaded into the system, a list of definitions is maintained. Pathname objects implement the definition protocol, acting over the definitions their source files contain. See " { $link "source-files" } " for details." { $subsection "definition-protocol" } -{ $subsection "definition-crossref" } { $subsection "definition-checking" } { $subsection "compilation-units" } "A parsing word to remove definitions:" @@ -96,36 +85,3 @@ HELP: forget-all { $values { "definitions" "a sequence of definition specifiers" } } { $description "Forgets every definition in a sequence." } { $notes "This word must be called from inside " { $link with-compilation-unit } "." } ; - -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" } "." } ; - -HELP: xref -{ $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: unxref -{ $values { "defspec" "a definition specifier" } } -{ $description "Remove edges leaving the vertex which represents the definition from the " { $link crossref } " graph." } -{ $notes "This word is called before a word is redefined." } ; - -HELP: delete-xref -{ $values { "defspec" "a definition specifier" } } -{ $description "Remove the vertex which represents the definition from the " { $link crossref } " graph." } -{ $notes "This word is called before a word is forgotten." } -{ $see-also forget } ; diff --git a/core/definitions/definitions.factor b/core/definitions/definitions.factor index 7463a863e5..6f9fdaecf5 100644 --- a/core/definitions/definitions.factor +++ b/core/definitions/definitions.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2006, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: kernel sequences namespaces assocs graphs math math.order ; +USING: kernel sequences namespaces assocs math accessors ; IN: definitions MIXIN: definition @@ -19,9 +19,6 @@ SYMBOL: changed-definitions SYMBOL: changed-effects -: changed-effect ( word -- ) - dup changed-effects get set-in-unit ; - SYMBOL: changed-generics SYMBOL: outdated-generics @@ -44,6 +41,8 @@ GENERIC: forget* ( defspec -- ) M: f forget* drop ; +M: wrapper forget* wrapped>> forget* ; + SYMBOL: forgotten-definitions : forgotten-definition ( defspec -- ) @@ -56,29 +55,3 @@ SYMBOL: forgotten-definitions GENERIC: definer ( defspec -- start end ) GENERIC: definition ( defspec -- seq ) - -SYMBOL: crossref - -GENERIC: uses ( defspec -- seq ) - -M: object uses drop f ; - -: xref ( defspec -- ) dup uses crossref get add-vertex ; - -: usage ( defspec -- seq ) crossref get at keys ; - -GENERIC: irrelevant? ( defspec -- ? ) - -M: object irrelevant? drop f ; - -GENERIC: smart-usage ( defspec -- seq ) - -M: f smart-usage drop \ f smart-usage ; - -M: object smart-usage usage [ irrelevant? not ] filter ; - -: unxref ( defspec -- ) - dup uses crossref get remove-vertex ; - -: delete-xref ( defspec -- ) - dup unxref crossref get delete-at ; diff --git a/core/effects/effects-docs.factor b/core/effects/effects-docs.factor index 20709ca807..495aeb39c1 100644 --- a/core/effects/effects-docs.factor +++ b/core/effects/effects-docs.factor @@ -1,16 +1,20 @@ USING: help.markup help.syntax math strings words kernel combinators ; IN: effects -ARTICLE: "effect-declaration" "Stack effect declaration" -"Stack effects of words must be declared, with the exception of words which only push literals on the stack." -$nl -"A stack effect declaration is written in parentheses and lists word inputs and outputs, separated by " { $snippet "--" } ". Here is an example:" -{ $synopsis sq } +ARTICLE: "effects" "Stack effect declarations" +"Word definition words such as " { $link POSTPONE: : } " and " { $link POSTPONE: GENERIC: } " have a " { $emphasis "stack effect declaration" } " as part of their syntax. A stack effect declaration takes the following form:" +{ $code "( input1 input2 ... -- output1 ... )" } +"Stack elements in a stack effect are ordered so that the top of the stack is on the right side. Here is an example:" +{ $synopsis + } "Parameters which are quotations can be declared by suffixing the parameter name with " { $snippet ":" } " and then writing a nested stack effect declaration:" { $synopsis while } -"Stack effect declarations are read in using a parsing word:" -{ $subsection POSTPONE: ( } -"Stack elements in a stack effect are ordered so that the top of the stack is on the right side. Each value can be named by a data type or description. The following are some examples of value names:" +"Only the number of inputs and outputs carries semantic meaning." +$nl +"Nested quotation declaration only has semantic meaning for " { $link POSTPONE: inline } " " { $link POSTPONE: recursive } " words. See " { $link "inference-recursive-combinators" } "." +$nl +"In concatenative code, input and output names are for documentation purposes only and certain conventions have been established to make them more descriptive. For code written with " { $link "locals" } ", stack values are bound to local variables named by the stack effect's input parameters." +$nl +"Inputs and outputs are typically named after some pun on their data type, or a description of the value's purpose if the type is very general. The following are some examples of value names:" { $table { { { $snippet "?" } } "a boolean" } { { { $snippet "<=>" } } { "an ordering sepcifier; see " { $link "order-specifiers" } } } @@ -26,25 +30,7 @@ $nl { { $snippet "dim" } "a screen dimension specified as a two-element array holding width and height values" } { { $snippet "*" } "when this symbol appears by itself in the list of outputs, it means the word unconditionally throws an error" } } -"The stack effect inferencer verifies stack effect comments to ensure the correct number of inputs and outputs is listed. Value names are ignored; only their number matters. An error is thrown if a word's declared stack effect does not match its inferred stack effect. See " { $link "inference" } "." ; - -ARTICLE: "effects" "Stack effects" -"A " { $emphasis "stack effect declaration" } ", for example " { $snippet "( x y -- z )" } " denotes that an operation takes two inputs, with " { $snippet "y" } " at the top of the stack, and returns one output. Stack effects are first-class, and words for working with them are found in the " { $vocab-link "effects" } " vocabulary." -$nl -"Stack effects of words must be declared, and the " { $link "compiler" } " checks that these declarations are correct. Invalid declarations are reported as " { $link "compiler-errors" } ". The " { $link "inference" } " tool can be used to check stack effects interactively." -{ $subsection "effect-declaration" } -"There is a literal syntax for stack objects. It is most often used with " { $link define-declared } ", " { $link call-effect } " and " { $link execute-effect } "." -{ $subsection POSTPONE: (( } -"Getting a word's declared stack effect:" -{ $subsection stack-effect } -"Converting a stack effect to a string form:" -{ $subsection effect>string } -"Comparing effects:" -{ $subsection effect-height } -{ $subsection effect<= } -"The class of stack effects:" -{ $subsection effect } -{ $subsection effect? } ; +{ $see-also "inference" } ; ABOUT: "effects" diff --git a/core/generic/generic-docs.factor b/core/generic/generic-docs.factor index 7017ef8a08..e8b5e6d69c 100644 --- a/core/generic/generic-docs.factor +++ b/core/generic/generic-docs.factor @@ -95,7 +95,7 @@ $nl { $subsection POSTPONE: MATH: } "Method definition:" { $subsection POSTPONE: M: } -"Generic words must declare their stack effect in order to compile. See " { $link "effect-declaration" } "." +"Generic words must declare their stack effect in order to compile. See " { $link "effects" } "." { $subsection "method-order" } { $subsection "call-next-method" } { $subsection "method-combination" } diff --git a/core/generic/generic-tests.factor b/core/generic/generic-tests.factor index 37f5cf40ae..e7ae583aa6 100755 --- a/core/generic/generic-tests.factor +++ b/core/generic/generic-tests.factor @@ -133,69 +133,19 @@ M: f tag-and-f 4 ; [ 3.4 3 ] [ 3.4 tag-and-f ] unit-test ! Issues with forget -GENERIC: generic-forget-test-1 ( a b -- c ) +GENERIC: generic-forget-test ( a -- b ) -M: integer generic-forget-test-1 / ; +M: f generic-forget-test ; -[ 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 - -GENERIC: generic-forget-test-3 ( a -- b ) - -M: f generic-forget-test-3 ; - -[ ] [ \ f \ generic-forget-test-3 method "m" set ] unit-test +[ ] [ \ f \ generic-forget-test method "m" set ] unit-test [ ] [ [ "m" get forget ] with-compilation-unit ] unit-test -[ ] [ "IN: generic.tests M: f generic-forget-test-3 ;" eval( -- ) ] unit-test +[ ] [ "IN: generic.tests M: f generic-forget-test ;" eval( -- ) ] unit-test [ ] [ [ "m" get forget ] with-compilation-unit ] unit-test -[ f ] [ f generic-forget-test-3 ] unit-test - -: a-word ( -- ) ; - -GENERIC: a-generic ( a -- b ) - -M: integer a-generic a-word ; - -[ ] [ \ integer \ a-generic method "m" set ] unit-test - -[ t ] [ "m" get \ a-word usage memq? ] unit-test - -[ ] [ "IN: generic.tests : a-generic ( -- ) ;" eval( -- ) ] unit-test - -[ f ] [ "m" get \ a-word usage memq? ] unit-test +[ f ] [ f generic-forget-test ] unit-test ! erg's regression [ ] [ diff --git a/core/generic/generic.factor b/core/generic/generic.factor index 7fdb339069..965be91642 100644 --- a/core/generic/generic.factor +++ b/core/generic/generic.factor @@ -123,8 +123,6 @@ M: method-body crossref? PREDICATE: default-method < word "default" word-prop ; -M: default-method irrelevant? drop t ; - : ( generic combination -- method ) [ drop object bootstrap-word swap ] [ make-default-method ] 2bi [ define ] [ drop t "default" set-word-prop ] [ drop ] 2tri ; @@ -155,9 +153,6 @@ M: method-body forget* [ call-next-method ] bi ] if ; -M: method-body smart-usage - "method-generic" word-prop smart-usage ; - M: sequence update-methods ( class seq -- ) implementors [ [ changed-generic ] [ remake-generic drop ] 2bi @@ -192,6 +187,3 @@ M: generic forget* M: class forget-methods [ implementors ] [ [ swap method ] curry ] bi map forget-all ; - -: xref-generics ( -- ) - all-words [ subwords [ xref ] each ] each ; diff --git a/core/generic/standard/engines/tuple/tuple.factor b/core/generic/standard/engines/tuple/tuple.factor index 7e91adfaa1..a0711af095 100644 --- a/core/generic/standard/engines/tuple/tuple.factor +++ b/core/generic/standard/engines/tuple/tuple.factor @@ -86,8 +86,6 @@ M: engine-word where "tuple-dispatch-generic" word-prop where ; M: engine-word crossref? "forgotten" word-prop not ; -M: engine-word irrelevant? drop t ; - : remember-engine ( word -- ) generic get "engines" word-prop push ; diff --git a/core/generic/standard/standard-tests.factor b/core/generic/standard/standard-tests.factor index 420dd16991..58007f795f 100644 --- a/core/generic/standard/standard-tests.factor +++ b/core/generic/standard/standard-tests.factor @@ -280,27 +280,6 @@ M: growable call-next-hooker call-next-method "growable " prepend ; V{ } my-var [ call-next-hooker ] with-variable ] unit-test -! Cross-referencing with generic words -TUPLE: xref-tuple-1 ; -TUPLE: xref-tuple-2 < xref-tuple-1 ; - -: (xref-test) ( obj -- ) drop ; - -GENERIC: xref-test ( obj -- ) - -M: xref-tuple-1 xref-test (xref-test) ; -M: xref-tuple-2 xref-test (xref-test) ; - -[ t ] [ - \ xref-test - \ xref-tuple-1 \ xref-test method [ usage unique ] closure key? -] unit-test - -[ t ] [ - \ xref-test - \ xref-tuple-2 \ xref-test method [ usage unique ] closure key? -] unit-test - [ t ] [ { } \ nth effective-method nip \ sequence \ nth method eq? ] unit-test diff --git a/core/io/encodings/utf8/utf8-tests.factor b/core/io/encodings/utf8/utf8-tests.factor index 6cd3ee8033..088131acf9 100755 --- a/core/io/encodings/utf8/utf8-tests.factor +++ b/core/io/encodings/utf8/utf8-tests.factor @@ -6,7 +6,7 @@ IN: io.encodings.utf8.tests utf8 decode >array ; : encode-utf8-w/stream ( array -- newarray ) - utf8 encode >array ; + >string utf8 encode >array ; [ { CHAR: replacement-character } ] [ { BIN: 11110101 BIN: 10111111 BIN: 10000000 BIN: 11111111 } decode-utf8-w/stream ] unit-test diff --git a/core/io/files/files-docs.factor b/core/io/files/files-docs.factor index cf0aea787b..9989d889a8 100644 --- a/core/io/files/files-docs.factor +++ b/core/io/files/files-docs.factor @@ -2,7 +2,20 @@ USING: help.markup help.syntax io strings arrays io.backend io.files.private quotations sequences ; IN: io.files +ARTICLE: "io.files.examples" "Examples of reading and writing files" +"Sort the lines in a file and write them back to the same file:" +{ $code + "USING: io io.encodings.utf8 io.files sequences sorting ;" + "\"lines.txt\" utf8 [ file-lines natural-sort ] 2keep set-file-lines" +} +"Read 1024 bytes from a file:" +{ $code + "USING: io io.encodings.binary io.files ;" + "\"data.bin\" binary [ 1024 read ] with-file-reader" +} ; + ARTICLE: "io.files" "Reading and writing files" +{ $subsection "io.files.examples" } "File streams:" { $subsection } { $subsection } diff --git a/core/io/files/files-tests.factor b/core/io/files/files-tests.factor index a2d637dcb7..8f0fb9e97a 100644 --- a/core/io/files/files-tests.factor +++ b/core/io/files/files-tests.factor @@ -4,9 +4,6 @@ io.files io.files.private io.files.temp io.files.unique kernel make math sequences system threads tools.test generic.standard ; IN: io.files.tests -\ exists? must-infer -\ (exists?) must-infer - [ ] [ "append-test" temp-file dup exists? [ delete-file ] [ drop ] if ] unit-test [ ] [ "append-test" temp-file ascii dispose ] unit-test diff --git a/core/io/io-docs.factor b/core/io/io-docs.factor index ebc248bbbf..740152f294 100644 --- a/core/io/io-docs.factor +++ b/core/io/io-docs.factor @@ -355,9 +355,27 @@ $nl "Copying the contents of one stream to another:" { $subsection stream-copy } ; +ARTICLE: "stream-examples" "Stream example" +"Ask the user for their age, and print it back:" +{ $code + "USING: io math.parser ;" + "" + ": ask-age ( -- ) \"How old are you?\" print ;" + "" + ": read-age ( -- n ) readln string>number ;" + "" + ": print-age ( n -- )" + " \"You are \" write" + " number>string write" + " \" years old.\" print ;" + ": example ( -- ) ask-age read-age print-age ;" + "" + "example" +} ; + ARTICLE: "streams" "Streams" "Input and output centers on the concept of a " { $emphasis "stream" } ", which is a source or sink of " { $emphasis "elements" } "." -$nl +{ $subsection "stream-examples" } "A stream can either be passed around on the stack or bound to a dynamic variable and used as one of the two implicit " { $emphasis "default streams" } "." { $subsection "stream-protocol" } { $subsection "stdio" } diff --git a/core/kernel/kernel-docs.factor b/core/kernel/kernel-docs.factor index 36d04f1437..1d8c09a9b2 100644 --- a/core/kernel/kernel-docs.factor +++ b/core/kernel/kernel-docs.factor @@ -129,6 +129,9 @@ HELP: ? { $values { "?" "a generalized boolean" } { "true" object } { "false" object } { "true/false" "one two input objects" } } { $description "Chooses between two values depending on the boolean value of " { $snippet "cond" } "." } ; +HELP: boolean +{ $class-description "A union of the " { $link POSTPONE: t } " and " { $link POSTPONE: f } " classes." } ; + HELP: >boolean { $values { "obj" "a generalized boolean" } { "?" "a boolean" } } { $description "Convert a generalized boolean into a boolean. That is, " { $link f } " retains its value, whereas anything else becomes " { $link t } "." } ; @@ -182,12 +185,14 @@ HELP: either? HELP: call { $values { "callable" callable } } -{ $description "Calls a quotation." } +{ $description "Calls a quotation. Words which " { $link call } " an input parameter must be declared " { $link POSTPONE: inline } " so that a caller which passes in a literal quotation can have a static stack effect." } { $examples "The following two lines are equivalent:" { $code "2 [ 2 + 3 * ] call" "2 2 + 3 *" } } ; +{ call POSTPONE: call( } related-words + HELP: call-clear ( quot -- ) { $values { "quot" callable } } { $description "Calls a quotation with an empty call stack. If the quotation returns, Factor will exit.." } diff --git a/core/kernel/kernel-tests.factor b/core/kernel/kernel-tests.factor index 84a356805b..b58c744b05 100644 --- a/core/kernel/kernel-tests.factor +++ b/core/kernel/kernel-tests.factor @@ -1,7 +1,7 @@ USING: arrays byte-arrays kernel kernel.private math memory namespaces sequences tools.test math.private quotations continuations prettyprint io.streams.string debugger assocs -sequences.private accessors locals.backend grouping ; +sequences.private accessors locals.backend grouping words ; IN: kernel.tests [ 0 ] [ f size ] unit-test @@ -23,20 +23,25 @@ IN: kernel.tests : overflow-d ( -- ) 3 overflow-d ; -[ overflow-d ] [ { "kernel-error" 12 f f } = ] must-fail-with - -[ ] [ :c ] unit-test - : (overflow-d-alt) ( -- n ) 3 ; : overflow-d-alt ( -- ) (overflow-d-alt) overflow-d-alt ; +: overflow-r ( -- ) 3 load-local overflow-r ; + +<< +{ overflow-d (overflow-d-alt) overflow-d-alt overflow-r } +[ t "no-compile" set-word-prop ] each +>> + +[ overflow-d ] [ { "kernel-error" 12 f f } = ] must-fail-with + +[ ] [ :c ] unit-test + [ overflow-d-alt ] [ { "kernel-error" 12 f f } = ] must-fail-with [ ] [ [ :c ] with-string-writer drop ] unit-test -: overflow-r ( -- ) 3 load-local overflow-r ; - [ overflow-r ] [ { "kernel-error" 14 f f } = ] must-fail-with [ ] [ :c ] unit-test @@ -99,7 +104,9 @@ IN: kernel.tests [ ] [ :c ] unit-test ! Doesn't compile; important -: foo ( a -- b ) 5 + 0 [ ] each ; +: foo ( a -- b ) ; + +<< \ foo t "no-compile" set-word-prop >> [ drop foo ] must-fail [ ] [ :c ] unit-test @@ -109,13 +116,13 @@ IN: kernel.tests [ pick ] dip swap [ pick ] dip swap < [ [ 1+ ] 3dip (loop) ] [ 2drop 2drop ] if ; inline recursive -: loop ( obj obj -- ) +: loop ( obj -- ) H{ } values swap [ dup length swap ] dip 0 -roll (loop) ; [ loop ] must-fail ! Discovered on Windows -: total-failure-1 ( -- ) "" [ ] map unimplemented ; +: total-failure-1 ( -- a ) "" [ ] map unimplemented ; [ total-failure-1 ] must-fail diff --git a/core/kernel/kernel.factor b/core/kernel/kernel.factor index baccf56059..6245080225 100644 --- a/core/kernel/kernel.factor +++ b/core/kernel/kernel.factor @@ -176,12 +176,14 @@ PRIVATE> : tri-curry@ ( x y z q -- p' q' r' ) [curry] tri@ ; inline ! Booleans +UNION: boolean POSTPONE: t POSTPONE: f ; + +: >boolean ( obj -- ? ) [ t ] [ f ] if ; inline + : not ( obj -- ? ) [ f ] [ t ] if ; inline : and ( obj1 obj2 -- ? ) over ? ; inline -: >boolean ( obj -- ? ) [ t ] [ f ] if ; inline - : or ( obj1 obj2 -- ? ) dupd ? ; inline : xor ( obj1 obj2 -- ? ) [ f swap ? ] when* ; inline diff --git a/core/memory/memory-tests.factor b/core/memory/memory-tests.factor index 670c21d6ff..a6ecdc005e 100644 --- a/core/memory/memory-tests.factor +++ b/core/memory/memory-tests.factor @@ -3,6 +3,8 @@ sequences tools.test words namespaces layouts classes classes.builtin arrays quotations io.launcher system ; IN: memory.tests +[ ] [ { } { } become ] unit-test + ! LOL [ ] [ vm diff --git a/core/parser/parser-docs.factor b/core/parser/parser-docs.factor index ea82f7276f..98f41ae39a 100644 --- a/core/parser/parser-docs.factor +++ b/core/parser/parser-docs.factor @@ -110,7 +110,7 @@ HELP: save-location { $description "Saves the location of a definition and associates this definition with the current source file." } ; HELP: parser-notes -{ $var-description "A boolean controlling whether the parser will print various notes and warnings. Switched on by default. If a source file is being run for its effect on " { $link output-stream } ", this variable should be switched off, to prevent parser notes from polluting the output." } ; +{ $var-description "A boolean controlling whether the parser will print various notes. Switched on by default. If a source file is being run for its effect on " { $link output-stream } ", this variable should be switched off, to prevent parser notes from polluting the output." } ; HELP: parser-notes? { $values { "?" "a boolean" } } @@ -260,7 +260,7 @@ HELP: forget-smudged HELP: finish-parsing { $values { "lines" "the lines of text just parsed" } { "quot" "the quotation just parsed" } } -{ $description "Records information to the current " { $link file } " and prints warnings about any removed definitions which are still in use." } +{ $description "Records information to the current " { $link file } "." } { $notes "This is one of the factors of " { $link parse-stream } "." } ; HELP: parse-stream diff --git a/core/parser/parser-tests.factor b/core/parser/parser-tests.factor index 2add8663d8..e944ecc6f2 100644 --- a/core/parser/parser-tests.factor +++ b/core/parser/parser-tests.factor @@ -3,11 +3,10 @@ io.streams.string namespaces classes effects source-files assocs sequences strings io.files io.pathnames definitions continuations sorting classes.tuple compiler.units debugger vocabs vocabs.loader accessors eval combinators lexer -vocabs.parser words.symbol multiline source-files.errors ; +vocabs.parser words.symbol multiline source-files.errors +tools.crossref ; IN: parser.tests -\ run-file must-infer - [ [ 1 [ 2 [ 3 ] 4 ] 5 ] [ "1\n[\n2\n[\n3\n]\n4\n]\n5" eval( -- a b c ) ] diff --git a/core/parser/parser.factor b/core/parser/parser.factor index 9876818d26..7908f40cbe 100644 --- a/core/parser/parser.factor +++ b/core/parser/parser.factor @@ -264,7 +264,7 @@ print-use-hook [ [ ] ] initialize : finish-parsing ( lines quot -- ) file get - [ record-form ] + [ record-top-level-form ] [ record-definitions ] [ record-checksum ] tri ; diff --git a/core/source-files/source-files-docs.factor b/core/source-files/source-files-docs.factor index 2c9e2172cc..eb1284cd25 100644 --- a/core/source-files/source-files-docs.factor +++ b/core/source-files/source-files-docs.factor @@ -11,9 +11,7 @@ $nl { $subsection source-file } "Words intended for the parser:" { $subsection record-checksum } -{ $subsection record-form } -{ $subsection xref-source } -{ $subsection unxref-source } +{ $subsection record-definitions } "Removing a source file from the database:" { $subsection forget-source } "Updating the database:" @@ -42,25 +40,6 @@ HELP: record-checksum { $description "Records the CRC32 checksm of the source file's contents." } $low-level-note ; -HELP: xref-source -{ $values { "source-file" source-file } } -{ $description "Adds the source file to the " { $link crossref } " graph enabling words to find source files which reference them in their top level forms." } -$low-level-note ; - -HELP: unxref-source -{ $values { "source-file" source-file } } -{ $description "Removes the source file from the " { $link crossref } " graph." } -$low-level-note ; - -HELP: xref-sources -{ $description "Adds all loaded source files to the " { $link crossref } " graph. This is done during bootstrap." } -$low-level-note ; - -HELP: record-form -{ $values { "quot" quotation } { "source-file" source-file } } -{ $description "Records usage information for a source file's top level form." } -$low-level-note ; - HELP: reset-checksums { $description "Resets recorded modification times and CRC32 checksums for all loaded source files, creating a checkpoint for " { $link "tools.vocabs" } "." } ; diff --git a/core/source-files/source-files.factor b/core/source-files/source-files.factor index 6884a10d03..558018a147 100644 --- a/core/source-files/source-files.factor +++ b/core/source-files/source-files.factor @@ -1,4 +1,4 @@ -! Copyright (C) 2007, 2008 Slava Pestov. +! Copyright (C) 2007, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: arrays definitions generic assocs kernel math namespaces sequences strings vectors words quotations io io.files @@ -11,29 +11,16 @@ SYMBOL: source-files TUPLE: source-file path +top-level-form checksum -uses definitions ; +definitions ; + +: record-top-level-form ( quot file -- ) + (>>top-level-form) H{ } notify-definition-observers ; : record-checksum ( lines source-file -- ) [ crc32 checksum-lines ] dip (>>checksum) ; -: (xref-source) ( source-file -- pathname uses ) - [ path>> ] - [ uses>> [ crossref? ] filter ] bi ; - -: xref-source ( source-file -- ) - (xref-source) crossref get add-vertex ; - -: unxref-source ( source-file -- ) - (xref-source) crossref get remove-vertex ; - -: xref-sources ( -- ) - source-files get [ nip xref-source ] assoc-each ; - -: record-form ( quot source-file -- ) - [ quot-uses keys ] dip - [ unxref-source ] [ (>>uses) ] [ xref-source ] tri ; - : record-definitions ( file -- ) new-definitions get >>definitions drop ; @@ -58,13 +45,8 @@ ERROR: invalid-source-file-path path ; M: pathname where string>> 1 2array ; : forget-source ( path -- ) - [ - source-file - [ unxref-source ] - [ definitions>> [ keys forget-all ] each ] bi - ] - [ source-files get delete-at ] - bi ; + source-files get delete-at* + [ definitions>> [ keys forget-all ] each ] [ drop ] if ; M: pathname forget* string>> forget-source ; diff --git a/core/syntax/syntax-docs.factor b/core/syntax/syntax-docs.factor index 73335e09cf..7ab287fd20 100644 --- a/core/syntax/syntax-docs.factor +++ b/core/syntax/syntax-docs.factor @@ -1,7 +1,7 @@ USING: generic help.syntax help.markup kernel math parser words effects classes generic.standard classes.tuple generic.math generic.standard arrays io.pathnames vocabs.loader io sequences -assocs words.symbol words.alias words.constant ; +assocs words.symbol words.alias words.constant combinators ; IN: syntax ARTICLE: "parser-algorithm" "Parser algorithm" @@ -152,6 +152,11 @@ ARTICLE: "syntax-pathnames" "Pathname syntax" { $subsection POSTPONE: P" } "Pathnames are documented in " { $link "io.pathnames" } "." ; +ARTICLE: "syntax-effects" "Stack effect syntax" +"Note that this is " { $emphasis "not" } " syntax to declare stack effects of words. This pushes an " { $link effect } " instance on the stack for reflection, for use with words such as " { $link define-declared } ", " { $link call-effect } " and " { $link execute-effect } "." +{ $subsection POSTPONE: (( } +{ $see-also "effects" "inference" "tools.inference" } ; + ARTICLE: "syntax-literals" "Literals" "Many different types of objects can be constructed at parse time via literal syntax. Numbers are a special case since support for reading them is built-in to the parser. All other literals are constructed via parsing words." $nl @@ -168,7 +173,8 @@ $nl { $subsection "syntax-sbufs" } { $subsection "syntax-hashtables" } { $subsection "syntax-tuples" } -{ $subsection "syntax-pathnames" } ; +{ $subsection "syntax-pathnames" } +{ $subsection "syntax-effects" } ; ARTICLE: "syntax" "Syntax" "Factor has two main forms of syntax: " { $emphasis "definition" } " syntax and " { $emphasis "literal" } " syntax. Code is data, so the syntax for code is a special case of object literal syntax. This section documents literal syntax. Definition syntax is covered in " { $link "words" } ". Extending the parser is the main topic of " { $link "parser" } "." @@ -517,7 +523,7 @@ HELP: ( { $syntax "( inputs -- outputs )" } { $values { "inputs" "a list of tokens" } { "outputs" "a list of tokens" } } { $description "A stack effect declaration. This is treated as a comment unless it appears inside a word definition." } -{ $see-also "effect-declaration" } ; +{ $see-also "effects" } ; HELP: (( { $syntax "(( inputs -- outputs ))" } @@ -791,7 +797,14 @@ HELP: call-next-method HELP: call( { $syntax "call( stack -- effect )" } -{ $description "Calls the quotation on the top of the stack, asserting that it has the given stack effect. The quotation does not need to be known at compile time." } ; +{ $description "Calls the quotation on the top of the stack, asserting that it has the given stack effect. The quotation does not need to be known at compile time." } +{ $examples + { $code + "TUPLE: action name quot ;" + ": perform-action ( action -- )" + " [ name>> print ] [ quot>> call( -- ) ] bi ;" + } +} ; HELP: execute( { $syntax "execute( stack -- effect )" } diff --git a/core/words/words-docs.factor b/core/words/words-docs.factor index c20ee66de8..94609a06e5 100644 --- a/core/words/words-docs.factor +++ b/core/words/words-docs.factor @@ -21,8 +21,8 @@ $nl { $subsection gensym } { $subsection define-temp } ; -ARTICLE: "colon-definition" "Word definitions" -"Every word has an associated quotation definition that is called when the word is executed." +ARTICLE: "colon-definition" "Colon definitions" +"Every word has an associated quotation definition that is called when the word is executed. A " { $emphasis "colon definition" } " is a word where this quotation is supplied directly by the user. This is the simplest and most common type of word definition." $nl "Defining words at parse time:" { $subsection POSTPONE: : } @@ -31,7 +31,7 @@ $nl { $subsection define } { $subsection define-declared } { $subsection define-inline } -"Word definitions must declare their stack effect. See " { $link "effect-declaration" } "." +"Word definitions must declare their stack effect. See " { $link "effects" } "." $nl "All other types of word definitions, such as " { $link "words.symbol" } " and " { $link "generic" } ", are just special cases of the above." ; @@ -56,30 +56,16 @@ $nl ": foo undefined ;" } ; -ARTICLE: "declarations" "Declarations" -"Declarations are parsing words that set a word property in the most recently defined word. Declarations only affect definitions compiled with the optimizing compiler. They do not change evaluation semantics of a word, but instead declare that the word follows a certain contract, and thus may be compiled differently." +ARTICLE: "declarations" "Compiler declarations" +"Compiler declarations are parsing words that set a word property in the most recently defined word. They appear after the final " { $link POSTPONE: ; } " of a word definition:" +{ $code ": cubed ( x -- y ) dup dup * * ; foldable" } +"Compiler declarations assert that the word follows a certain contract, enabling certain optimizations that are not valid in general." { $subsection POSTPONE: inline } { $subsection POSTPONE: foldable } { $subsection POSTPONE: flushable } { $subsection POSTPONE: recursive } -{ $warning "If a generic word is declared " { $link POSTPONE: foldable } " or " { $link POSTPONE: flushable } ", all methods must satisfy the contract, otherwise unpredicable behavior will occur." } -"Stack effect declarations are documented in " { $link "effect-declaration" } "." ; - -ARTICLE: "word-definition" "Defining words" -"There are two approaches to creating word definitions:" -{ $list - "using parsing words at parse time," - "using defining words at run time." -} -"The latter is a more dynamic feature that can be used to implement code generation and such, and in fact parse time defining words are implemented in terms of run time defining words." -{ $subsection "colon-definition" } -{ $subsection "words.symbol" } -{ $subsection "words.alias" } -{ $subsection "words.constant" } -{ $subsection "primitives" } -{ $subsection "deferred" } -{ $subsection "declarations" } -"Words implement the definition protocol; see " { $link "definitions" } "." ; +"It is entirely up to the programmer to ensure that the word satisfies the contract of a declaration. Furthermore, if a generic word is declared " { $link POSTPONE: foldable } " or " { $link POSTPONE: flushable } ", all methods must satisfy the contract. Unspecified behavior may result if a word does not follow the contract of one of its declarations." +{ $see-also "effects" } ; ARTICLE: "word-props" "Word properties" "Each word has a hashtable of properties." @@ -100,14 +86,10 @@ $nl { { { $snippet "\"reading\"" } ", " { $snippet "\"writing\"" } } { "Set on slot accessor words - " { $link "slots" } } } - { { $snippet "\"declared-effect\"" } { $link "effect-declaration" } } + { { $snippet "\"declared-effect\"" } { $link "effects" } } { { { $snippet "\"help\"" } ", " { $snippet "\"help-loc\"" } ", " { $snippet "\"help-parent\"" } } { "Where word help is stored - " { $link "writing-help" } } } - { { $snippet "\"infer\"" } { $link "macros" } } - - { { { $snippet "\"inferred-effect\"" } } { $link "inference" } } - { { $snippet "\"specializer\"" } { $link "hints" } } { { $snippet "\"predicating\"" } " Set on class predicates, stores the corresponding class word" } @@ -138,9 +120,7 @@ $nl "An " { $emphasis "XT" } " (execution token) is the machine code address of a word:" { $subsection word-xt } ; -ARTICLE: "words" "Words" -"Words are the Factor equivalent of functions or procedures; a word is essentially a named quotation." -$nl +ARTICLE: "words.introspection" "Word introspection" "Word introspection facilities and implementation details are found in the " { $vocab-link "words" } " vocabulary." $nl "Word objects contain several slots:" @@ -153,22 +133,45 @@ $nl "Words are instances of a class." { $subsection word } { $subsection word? } +"Words implement the definition protocol; see " { $link "definitions" } "." { $subsection "interned-words" } { $subsection "uninterned-words" } -{ $subsection "word-definition" } { $subsection "word-props" } -{ $subsection "word.private" } +{ $subsection "word.private" } ; + +ARTICLE: "words" "Words" +"Words are the Factor equivalent of functions or procedures; a word is essentially a named quotation." +$nl +"There are two ways of creating word definitions:" +{ $list + "using parsing words at parse time," + "using defining words at run time." +} +"The latter is a more dynamic feature that can be used to implement code generation and such, and in fact parse time defining words are implemented in terms of run time defining words." +$nl +"Types of words:" +{ $subsection "colon-definition" } +{ $subsection "words.symbol" } +{ $subsection "words.alias" } +{ $subsection "words.constant" } +{ $subsection "primitives" } +"Advanced topics:" +{ $subsection "deferred" } +{ $subsection "declarations" } +{ $subsection "words.introspection" } { $see-also "vocabularies" "vocabs.loader" "definitions" "see" } ; ABOUT: "words" HELP: execute ( word -- ) { $values { "word" word } } -{ $description "Executes a word." } +{ $description "Executes a word. Words which " { $link execute } " an input parameter must be declared " { $link POSTPONE: inline } " so that a caller which passes in a literal word can have a static stack effect." } { $examples - { $example "USING: kernel io words ;" "IN: scratchpad" ": twice ( word -- ) dup execute execute ;\n: hello ( -- ) \"Hello\" print ;\n\\ hello twice" "Hello\nHello" } + { $example "USING: kernel io words ;" "IN: scratchpad" ": twice ( word -- ) dup execute execute ; inline\n: hello ( -- ) \"Hello\" print ;\n\\ hello twice" "Hello\nHello" } } ; +{ execute POSTPONE: execute( } related-words + HELP: deferred { $class-description "The class of deferred words created by " { $link POSTPONE: DEFER: } "." } ; @@ -294,10 +297,6 @@ HELP: define-temp "This word must be called from inside " { $link with-compilation-unit } "." } ; -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." } ; - HELP: delimiter? { $values { "obj" object } { "?" "a boolean" } } { $description "Tests if an object is a delimiter word declared by " { $link POSTPONE: delimiter } "." } diff --git a/core/words/words-tests.factor b/core/words/words-tests.factor index 3ba5e1f693..0ecf7b65f0 100755 --- a/core/words/words-tests.factor +++ b/core/words/words-tests.factor @@ -63,52 +63,6 @@ FORGET: forgotten FORGET: another-forgotten : another-forgotten ( -- ) ; -! I forgot remove-crossref calls! -: fee ( -- ) ; -: foe ( -- ) fee ; -: fie ( -- ) foe ; - -[ t ] [ \ fee usage [ word? ] filter empty? ] unit-test -[ t ] [ \ foe usage empty? ] unit-test -[ f ] [ \ foe crossref get key? ] unit-test - -FORGET: foe - -! xref should not retain references to gensyms -[ ] [ - [ gensym [ * ] define ] with-compilation-unit -] unit-test - -[ t ] [ - \ * usage [ word? ] filter [ crossref? ] all? -] unit-test - -DEFER: calls-a-gensym -[ ] [ - [ - \ calls-a-gensym - gensym dup "x" set 1quotation - (( x -- x )) define-declared - ] with-compilation-unit -] unit-test - -[ f ] [ "x" get crossref get at ] unit-test - -! more xref buggery -[ f ] [ - GENERIC: xyzzle ( x -- x ) - : a ( -- ) ; \ a - M: integer xyzzle a ; - FORGET: a - M: object xyzzle ; - crossref get at -] unit-test - -! regression -GENERIC: freakish ( x -- y ) -: bar ( x -- y ) freakish ; -M: array freakish ; -[ t ] [ \ bar \ freakish usage member? ] unit-test DEFER: x [ x ] [ undefined? ] must-fail-with @@ -122,26 +76,6 @@ DEFER: x [ ] [ "IN: words.tests : test-last ( -- ) ;" eval( -- ) ] unit-test [ "test-last" ] [ word name>> ] unit-test -! regression -SYMBOL: quot-uses-a -SYMBOL: quot-uses-b - -[ ] [ - [ - quot-uses-a [ 2 3 + ] define - ] with-compilation-unit -] unit-test - -[ { + } ] [ \ quot-uses-a uses ] unit-test - -[ ] [ - [ - quot-uses-b 2 [ 3 + ] curry define - ] with-compilation-unit -] unit-test - -[ { + } ] [ \ quot-uses-b uses ] unit-test - "undef-test" "words.tests" lookup [ [ forget ] with-compilation-unit ] when* @@ -191,8 +125,3 @@ SYMBOL: quot-uses-b keys [ "forgotten" word-prop ] any? ] filter ] unit-test - -[ { } ] [ - crossref get keys - [ word? ] filter [ "forgotten" word-prop ] filter -] unit-test diff --git a/core/words/words.factor b/core/words/words.factor index c388f093fd..eb0599db78 100755 --- a/core/words/words.factor +++ b/core/words/words.factor @@ -62,33 +62,7 @@ SYMBOL: bootstrapping? GENERIC: crossref? ( word -- ? ) M: word crossref? - dup "forgotten" word-prop [ - drop f - ] [ - vocabulary>> >boolean - ] if ; - -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) ; - -: quot-uses ( quot -- assoc ) - global [ H{ } clone [ (quot-uses) ] keep ] bind ; - -M: word uses ( word -- seq ) - def>> quot-uses keys ; + dup "forgotten" word-prop [ drop f ] [ vocabulary>> >boolean ] if ; SYMBOL: compiled-crossref @@ -131,52 +105,18 @@ GENERIC: subwords ( word -- seq ) M: word subwords drop f ; - - -: redefined ( word -- ) - [ H{ } clone visited [ (redefined) ] with-variable ] - [ changed-definition ] - bi ; - : define ( word def -- ) - [ ] like - over unxref - over redefined - >>def - dup crossref? [ dup xref ] when drop ; + over changed-definition [ ] like >>def drop ; + +: changed-effect ( word -- ) + [ dup changed-effects get set-in-unit ] + [ dup primitive? [ drop ] [ changed-definition ] if ] bi ; : set-stack-effect ( effect word -- ) 2dup "declared-effect" word-prop = [ 2drop ] [ - swap - [ drop changed-effect ] - [ "declared-effect" set-word-prop ] - [ drop dup primitive? [ drop ] [ redefined ] if ] + [ nip changed-effect ] + [ nip subwords [ changed-effect ] each ] + [ swap "declared-effect" set-word-prop ] 2tri ] if ; @@ -184,7 +124,11 @@ PRIVATE> [ nip swap set-stack-effect ] [ drop define ] 3bi ; : make-inline ( word -- ) - t "inline" set-word-prop ; + dup inline? [ drop ] [ + [ t "inline" set-word-prop ] + [ changed-effect ] + bi + ] if ; : make-recursive ( word -- ) t "recursive" set-word-prop ; @@ -254,10 +198,9 @@ M: word set-where swap "loc" set-word-prop ; M: word forget* dup "forgotten" word-prop [ drop ] [ - [ delete-xref ] [ [ name>> ] [ vocabulary>> vocab-words ] bi delete-at ] [ t "forgotten" set-word-prop ] - tri + bi ] if ; M: word hashcode* @@ -265,6 +208,4 @@ M: word hashcode* M: word literalize ; -: xref-words ( -- ) all-words [ xref ] each ; - INSTANCE: word definition \ No newline at end of file diff --git a/extra/annotations/annotations-docs.factor b/extra/annotations/annotations-docs.factor index 1bece9d4fb..8685d954e8 100644 --- a/extra/annotations/annotations-docs.factor +++ b/extra/annotations/annotations-docs.factor @@ -1,6 +1,6 @@ USING: accessors arrays combinators definitions generalizations help help.markup help.topics kernel sequences sorting vocabs -words combinators.smart ; +words combinators.smart tools.crossref ; IN: annotations > dn->ba ] - [ type>> type-table of uint16->ba ] - [ class>> class-table of uint16->ba ] + [ type>> type-table at uint16->ba ] + [ class>> class-table at uint16->ba ] } cleave ] output>array concat ; @@ -203,8 +203,8 @@ SYMBOLS: NO-ERROR FORMAT-ERROR SERVER-FAILURE NAME-ERROR NOT-IMPLEMENTED [ { [ name>> dn->ba ] - [ type>> type-table of uint16->ba ] - [ class>> class-table of uint16->ba ] + [ type>> type-table at uint16->ba ] + [ class>> class-table at uint16->ba ] [ ttl>> uint32->ba ] [ [ type>> ] [ rdata>> ] bi rdata->ba @@ -219,13 +219,13 @@ SYMBOLS: NO-ERROR FORMAT-ERROR SERVER-FAILURE NAME-ERROR NOT-IMPLEMENTED [ { [ qr>> 15 shift ] - [ opcode>> opcode-table of 11 shift ] + [ opcode>> opcode-table at 11 shift ] [ aa>> 10 shift ] [ tc>> 9 shift ] [ rd>> 8 shift ] [ ra>> 7 shift ] [ z>> 4 shift ] - [ rcode>> rcode-table of 0 shift ] + [ rcode>> rcode-table at 0 shift ] } cleave ] sum-outputs uint16->ba ; @@ -301,8 +301,8 @@ SYMBOLS: NO-ERROR FORMAT-ERROR SERVER-FAILURE NAME-ERROR NOT-IMPLEMENTED [ get-name ] [ skip-name - [ 0 + get-double type-table key-of ] - [ 2 + get-double class-table key-of ] + [ 0 + get-double type-table value-at ] + [ 2 + get-double class-table value-at ] 2bi ] 2bi query boa ; @@ -364,10 +364,10 @@ SYMBOLS: NO-ERROR FORMAT-ERROR SERVER-FAILURE NAME-ERROR NOT-IMPLEMENTED [ skip-name { - [ 0 + get-double type-table key-of ] - [ 2 + get-double class-table key-of ] + [ 0 + get-double type-table value-at ] + [ 2 + get-double class-table value-at ] [ 4 + get-quad ] - [ [ 10 + ] [ get-double type-table key-of ] 2bi get-rdata ] + [ [ 10 + ] [ get-double type-table value-at ] 2bi get-rdata ] } 2cleave ] @@ -393,13 +393,13 @@ SYMBOLS: NO-ERROR FORMAT-ERROR SERVER-FAILURE NAME-ERROR NOT-IMPLEMENTED get-double { [ 15 >> BIN: 1 bitand ] - [ 11 >> BIN: 111 bitand opcode-table key-of ] + [ 11 >> BIN: 111 bitand opcode-table value-at ] [ 10 >> BIN: 1 bitand ] [ 9 >> BIN: 1 bitand ] [ 8 >> BIN: 1 bitand ] [ 7 >> BIN: 1 bitand ] [ 4 >> BIN: 111 bitand ] - [ BIN: 1111 bitand rcode-table key-of ] + [ BIN: 1111 bitand rcode-table value-at ] } cleave ; @@ -484,7 +484,7 @@ SYMBOLS: NO-ERROR FORMAT-ERROR SERVER-FAILURE NAME-ERROR NOT-IMPLEMENTED ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -: message-query ( message -- query ) question-section>> 1st ; +: message-query ( message -- query ) question-section>> first ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! diff --git a/extra/dns/misc/misc.factor b/extra/dns/misc/misc.factor index 6e62513a80..af080f61eb 100644 --- a/extra/dns/misc/misc.factor +++ b/extra/dns/misc/misc.factor @@ -1,6 +1,6 @@ USING: kernel combinators sequences splitting math - io.files io.encodings.utf8 random newfx dns.util ; + io.files io.encodings.utf8 random dns.util ; IN: dns.misc @@ -9,8 +9,8 @@ IN: dns.misc : resolv-conf-servers ( -- seq ) "/etc/resolv.conf" utf8 file-lines [ " " split ] map - [ 1st "nameserver" = ] filter - [ 2nd ] map ; + [ first "nameserver" = ] filter + [ second ] map ; : resolv-conf-server ( -- ip ) resolv-conf-servers random ; diff --git a/extra/dns/server/server.factor b/extra/dns/server/server.factor index b14d765e8d..644533d3a2 100644 --- a/extra/dns/server/server.factor +++ b/extra/dns/server/server.factor @@ -2,7 +2,7 @@ USING: kernel combinators sequences sets math threads namespaces continuations debugger io io.sockets unicode.case accessors destructors combinators.short-circuit combinators.smart - newfx fry arrays + fry arrays dns dns.util dns.misc ; IN: dns.server @@ -64,7 +64,7 @@ SYMBOL: records-var [ rr->rdata-names ] map concat ; : extract-names ( message -- names ) - [ message-query name>> ] [ extract-rdata-names ] bi prefix-on ; + [ message-query name>> ] [ extract-rdata-names ] bi swap prefix ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! fill-authority @@ -99,7 +99,7 @@ DEFER: query->rrs : matching-cname? ( query -- rrs/f ) [ ] [ clone CNAME >>type matching-rrs ] bi ! query rrs [ empty? not ] - [ 1st swap clone over rdata>> >>name query->rrs prefix-on ] + [ first swap clone over rdata>> >>name query->rrs swap prefix ] [ 2drop f ] 1if ; diff --git a/extra/env/authors.txt b/extra/env/authors.txt new file mode 100644 index 0000000000..f13c9c1e77 --- /dev/null +++ b/extra/env/authors.txt @@ -0,0 +1 @@ +Joe Groff diff --git a/extra/env/env-docs.factor b/extra/env/env-docs.factor new file mode 100644 index 0000000000..918b30af4b --- /dev/null +++ b/extra/env/env-docs.factor @@ -0,0 +1,13 @@ +! (c)2009 Joe Groff, see bsd license +USING: help.markup help.syntax ; +IN: env + +HELP: env +{ $class-description "A singleton that implements the " { $link "assocs-protocol" } " over " { $link "environment" } "." } ; + +ARTICLE: "env" "Accessing the environment via the assoc protocol" +"The " { $vocab-link "env" } " vocabulary defines a " { $link env } " word which implements the " { $link "assocs-protocol" } " over " { $link "environment" } "." +{ $subsection env } +; + +ABOUT: "env" diff --git a/extra/env/env.factor b/extra/env/env.factor new file mode 100644 index 0000000000..f7f4c5d231 --- /dev/null +++ b/extra/env/env.factor @@ -0,0 +1,26 @@ +! (c)2009 Joe Groff, see bsd license +USING: assocs environment kernel sequences ; +IN: env + +SINGLETON: env + +INSTANCE: env assoc + +M: env at* + drop os-env dup >boolean ; + +M: env assoc-size + drop (os-envs) length ; + +M: env >alist + drop os-envs >alist ; + +M: env set-at + drop set-os-env ; + +M: env delete-at + drop unset-os-env ; + +M: env clear-assoc + drop os-envs keys [ unset-os-env ] each ; + diff --git a/extra/env/summary.txt b/extra/env/summary.txt new file mode 100644 index 0000000000..bd15472427 --- /dev/null +++ b/extra/env/summary.txt @@ -0,0 +1 @@ +Access environment variables via the assoc protocol diff --git a/extra/infix/parser/parser-tests.factor b/extra/infix/parser/parser-tests.factor index d6b5d0559c..fa598a4ac6 100644 --- a/extra/infix/parser/parser-tests.factor +++ b/extra/infix/parser/parser-tests.factor @@ -3,9 +3,6 @@ USING: infix.ast infix.parser infix.tokenizer tools.test ; IN: infix.parser.tests -\ parse-infix must-infer -\ build-infix-ast must-infer - [ T{ ast-number { value 1 } } ] [ "1" build-infix-ast ] unit-test [ T{ ast-negation f T{ ast-number { value 1 } } } ] [ "-1" build-infix-ast ] unit-test diff --git a/extra/infix/tokenizer/tokenizer-tests.factor b/extra/infix/tokenizer/tokenizer-tests.factor index f9c908414a..b068881b84 100644 --- a/extra/infix/tokenizer/tokenizer-tests.factor +++ b/extra/infix/tokenizer/tokenizer-tests.factor @@ -3,7 +3,6 @@ USING: infix.ast infix.tokenizer tools.test ; IN: infix.tokenizer.tests -\ tokenize-infix must-infer [ V{ T{ ast-number f 1 } } ] [ "1" tokenize-infix ] unit-test [ V{ T{ ast-number f 1.02 } CHAR: * T{ ast-number f 3 } } ] [ "1.02*3" tokenize-infix ] unit-test [ V{ T{ ast-number f 3 } CHAR: / CHAR: ( T{ ast-number f 3 } CHAR: + T{ ast-number f 4 } CHAR: ) } ] diff --git a/extra/irc/client/internals/internals-tests.factor b/extra/irc/client/internals/internals-tests.factor index d20ae50bcc..27b5648f97 100644 --- a/extra/irc/client/internals/internals-tests.factor +++ b/extra/irc/client/internals/internals-tests.factor @@ -41,7 +41,7 @@ M: mb-writer dispose drop ; : %pop-output-line ( -- string ) irc> stream>> out>> lines>> pop ; : read-matching-message ( chat quot: ( msg -- ? ) -- irc-message ) - [ in-messages>> 0.1 seconds ] dip mailbox-get-timeout? ; + [ in-messages>> 0.1 seconds ] dip mailbox-get-timeout? ; inline : spawning-irc ( quot: ( -- ) -- ) [ spawn-client ] dip [ (terminate-irc) ] compose with-irc ; inline diff --git a/extra/mason/cleanup/cleanup-tests.factor b/extra/mason/cleanup/cleanup-tests.factor index 9158536ffb..49a5153a8e 100644 --- a/extra/mason/cleanup/cleanup-tests.factor +++ b/extra/mason/cleanup/cleanup-tests.factor @@ -1,4 +1,2 @@ USING: tools.test mason.cleanup ; IN: mason.cleanup.tests - -\ cleanup must-infer diff --git a/extra/mason/release/upload/upload-tests.factor b/extra/mason/release/upload/upload-tests.factor index 73fc311399..09f1e13ae9 100644 --- a/extra/mason/release/upload/upload-tests.factor +++ b/extra/mason/release/upload/upload-tests.factor @@ -1,4 +1,3 @@ IN: mason.release.upload.tests USING: mason.release.upload tools.test ; -\ upload must-infer diff --git a/extra/mason/report/report.factor b/extra/mason/report/report.factor index eb00107d21..edc8416235 100644 --- a/extra/mason/report/report.factor +++ b/extra/mason/report/report.factor @@ -93,7 +93,7 @@ IN: mason.report load-everything-errors-file error-dump - "Compiler warnings and errors" + "Compiler errors" compiler-errors-file compiler-error-messages-file error-dump diff --git a/extra/mason/test/test.factor b/extra/mason/test/test.factor index 912fbaa17a..22b932ac5b 100644 --- a/extra/mason/test/test.factor +++ b/extra/mason/test/test.factor @@ -25,12 +25,6 @@ M: method-body word-vocabulary "method-generic" word-prop word-vocabulary ; [ file>> ] map prune natural-sort summary-file to-file errors details-file utf8 [ errors. ] with-file-writer ; -: do-compile-errors ( -- ) - compiler-errors get values - compiler-errors-file - compiler-error-messages-file - do-step ; - : do-tests ( -- ) test-all test-failures get test-all-vocabs-file @@ -50,6 +44,12 @@ M: method-body word-vocabulary "method-generic" word-prop word-vocabulary ; [ benchmark-error-messages-file utf8 [ benchmark-errors. ] with-file-writer ] bi ] bi* ; +: do-compile-errors ( -- ) + compiler-errors get values + compiler-errors-file + compiler-error-messages-file + do-step ; + : benchmark-ms ( quot -- ms ) benchmark 1000 /i ; inline @@ -66,11 +66,12 @@ M: method-body word-vocabulary "method-generic" word-prop word-vocabulary ; ".." [ bootstrap-time get boot-time-file to-file check-boot-image - [ do-load do-compile-errors ] benchmark-ms load-time-file to-file + [ do-load ] benchmark-ms load-time-file to-file [ generate-help ] benchmark-ms html-help-time-file to-file [ do-tests ] benchmark-ms test-time-file to-file [ do-help-lint ] benchmark-ms help-lint-time-file to-file [ do-benchmarks ] benchmark-ms benchmark-time-file to-file + do-compile-errors ] with-directory ; MAIN: do-all \ No newline at end of file diff --git a/extra/peg/javascript/javascript-tests.factor b/extra/peg/javascript/javascript-tests.factor index 0d6899714d..69223a418d 100644 --- a/extra/peg/javascript/javascript-tests.factor +++ b/extra/peg/javascript/javascript-tests.factor @@ -4,8 +4,6 @@ USING: kernel tools.test peg.javascript peg.javascript.ast accessors ; IN: peg.javascript.tests -\ parse-javascript must-infer - { T{ ast-begin f V{ T{ ast-number f 123 } } } } [ "123;" parse-javascript ] unit-test \ No newline at end of file diff --git a/extra/peg/javascript/parser/parser-tests.factor b/extra/peg/javascript/parser/parser-tests.factor index a2c50952be..a521202b1c 100644 --- a/extra/peg/javascript/parser/parser-tests.factor +++ b/extra/peg/javascript/parser/parser-tests.factor @@ -5,8 +5,6 @@ USING: kernel tools.test peg peg.javascript.ast peg.javascript.parser accessors multiline sequences math peg.ebnf ; IN: peg.javascript.parser.tests -\ javascript must-infer - { T{ ast-begin diff --git a/extra/peg/javascript/tokenizer/tokenizer-tests.factor b/extra/peg/javascript/tokenizer/tokenizer-tests.factor index f0080a31b2..0fbd55ccfd 100644 --- a/extra/peg/javascript/tokenizer/tokenizer-tests.factor +++ b/extra/peg/javascript/tokenizer/tokenizer-tests.factor @@ -4,8 +4,6 @@ USING: kernel tools.test peg peg.javascript.ast peg.javascript.tokenizer accessors ; IN: peg.javascript.tokenizer.tests -\ tokenize-javascript must-infer - { V{ T{ ast-number f 123 } diff --git a/extra/sandbox/authors.txt b/extra/sandbox/authors.txt new file mode 100644 index 0000000000..f97e1bfbf9 --- /dev/null +++ b/extra/sandbox/authors.txt @@ -0,0 +1 @@ +Maxim Savchenko diff --git a/extra/sandbox/sandbox-tests.factor b/extra/sandbox/sandbox-tests.factor new file mode 100644 index 0000000000..5d0496e77b --- /dev/null +++ b/extra/sandbox/sandbox-tests.factor @@ -0,0 +1,57 @@ +! Copyright (C) 2009 Maxim Savchenko +! See http://factorcode.org/license.txt for BSD license. + +USING: kernel accessors continuations lexer vocabs vocabs.parser + combinators.short-circuit sandbox tools.test ; + +IN: sandbox.tests + +<< "sandbox.syntax" load-vocab drop >> +USE: sandbox.syntax.private + +: run-script ( x lines -- y ) + H{ { "kernel" "kernel" } { "math" "math" } { "sequences" "sequences" } } + parse-sandbox call( x -- x! ) ; + +[ 120 ] +[ + 5 + { + "! Simple factorial example" + "APPLYING: kernel math sequences ;" + "1 swap [ 1+ * ] each" + } run-script +] unit-test + +[ + 5 + { + "! Jailbreak attempt with USE:" + "USE: io" + "\"Hello world!\" print" + } run-script +] +[ + { + [ lexer-error? ] + [ error>> condition? ] + [ error>> error>> no-word-error? ] + [ error>> error>> name>> "USE:" = ] + } 1&& +] must-fail-with + +[ + 5 + { + "! Jailbreak attempt with unauthorized APPLY:" + "APPLY: io" + "\"Hello world!\" print" + } run-script +] +[ + { + [ lexer-error? ] + [ error>> sandbox-error? ] + [ error>> vocab>> "io" = ] + } 1&& +] must-fail-with diff --git a/extra/sandbox/sandbox.factor b/extra/sandbox/sandbox.factor new file mode 100644 index 0000000000..097a7c8d8a --- /dev/null +++ b/extra/sandbox/sandbox.factor @@ -0,0 +1,23 @@ +! Copyright (C) 2009 Maxim Savchenko. +! See http://factorcode.org/license.txt for BSD license. + +USING: kernel sequences vectors assocs namespaces parser lexer vocabs + combinators.short-circuit vocabs.parser ; + +IN: sandbox + +SYMBOL: whitelist + +: with-sandbox-vocabs ( quot -- ) + "sandbox.syntax" load-vocab vocab-words 1vector + use [ auto-use? off call ] with-variable ; inline + +: parse-sandbox ( lines assoc -- quot ) + whitelist [ [ parse-lines ] with-sandbox-vocabs ] with-variable ; + +: reveal-in ( name -- ) + [ { [ search ] [ no-word ] } 1|| ] keep current-vocab vocab-words set-at ; + +SYNTAX: REVEAL: scan reveal-in ; + +SYNTAX: REVEALING: ";" parse-tokens [ reveal-in ] each ; diff --git a/extra/sandbox/summary.txt b/extra/sandbox/summary.txt new file mode 100644 index 0000000000..3ca1e25684 --- /dev/null +++ b/extra/sandbox/summary.txt @@ -0,0 +1 @@ +Basic sandboxing diff --git a/extra/sandbox/syntax/syntax.factor b/extra/sandbox/syntax/syntax.factor new file mode 100644 index 0000000000..2ff5f070c7 --- /dev/null +++ b/extra/sandbox/syntax/syntax.factor @@ -0,0 +1,26 @@ +! Copyright (C) 2009 Maxim Savchenko. +! See http://factorcode.org/license.txt for BSD license. + +USING: kernel sequences assocs namespaces lexer vocabs.parser sandbox ; +IN: sandbox.syntax + + + +SYNTAX: APPLY: scan sandbox-use+ ; + +SYNTAX: APPLYING: ";" parse-tokens [ sandbox-use+ ] each ; + +REVEALING: + ! #! + HEX: OCT: BIN: f t CHAR: " + [ { T{ + ] } ; + +REVEAL: ; diff --git a/extra/sequence-parser/sequence-parser-tests.factor b/extra/sequence-parser/sequence-parser-tests.factor index 3b2fcad5eb..da097f4c00 100644 --- a/extra/sequence-parser/sequence-parser-tests.factor +++ b/extra/sequence-parser/sequence-parser-tests.factor @@ -1,4 +1,5 @@ -USING: tools.test sequence-parser ascii kernel accessors ; +USING: tools.test sequence-parser unicode.categories kernel +accessors ; IN: sequence-parser.tests [ "hello" ] @@ -189,3 +190,15 @@ IN: sequence-parser.tests [ "123u" ] [ "123u" take-c-integer ] unit-test + +[ 36 ] +[ + " //jofiejoe\n //eoieow\n/*asdf*/\n " + skip-whitespace/comments n>> +] unit-test + +[ f ] +[ "\n" take-integer ] unit-test + +[ "\n" ] [ "\n" [ ] take-while ] unit-test +[ f ] [ "\n" [ not ] take-while ] unit-test diff --git a/extra/sequence-parser/sequence-parser.factor b/extra/sequence-parser/sequence-parser.factor index 4f57a7ccae..4cc10fd5fd 100644 --- a/extra/sequence-parser/sequence-parser.factor +++ b/extra/sequence-parser/sequence-parser.factor @@ -52,7 +52,7 @@ TUPLE: sequence-parser sequence n ; ] [ [ drop n>> ] [ skip-until ] - [ drop [ n>> ] [ sequence>> ] bi ] 2tri subseq + [ drop [ n>> ] [ sequence>> ] bi ] 2tri subseq f like ] if ; inline : take-while ( sequence-parser quot: ( obj -- ? ) -- sequence/f ) @@ -104,6 +104,45 @@ TUPLE: sequence-parser sequence n ; : skip-whitespace ( sequence-parser -- sequence-parser ) [ [ current blank? not ] take-until drop ] keep ; +: skip-whitespace-eol ( sequence-parser -- sequence-parser ) + [ [ current " \t\r" member? not ] take-until drop ] keep ; + +: take-c-comment ( sequence-parser -- seq/f ) + [ + dup "/*" take-sequence [ + "*/" take-until-sequence* + ] [ + drop f + ] if + ] with-sequence-parser ; + +: take-c++-comment ( sequence-parser -- seq/f ) + [ + dup "//" take-sequence [ + [ + [ + { [ current CHAR: \n = ] [ sequence-parse-end? ] } 1|| + ] take-until + ] [ + advance drop + ] bi + ] [ + drop f + ] if + ] with-sequence-parser ; + +: skip-whitespace/comments ( sequence-parser -- sequence-parser ) + skip-whitespace-eol + { + { [ dup take-c-comment ] [ skip-whitespace/comments ] } + { [ dup take-c++-comment ] [ skip-whitespace/comments ] } + [ ] + } cond ; + +: take-define-identifier ( sequence-parser -- string ) + skip-whitespace/comments + [ current { [ blank? ] [ CHAR: ( = ] } 1|| ] take-until ; + : take-rest-slice ( sequence-parser -- sequence/f ) [ sequence>> ] [ n>> ] bi 2dup [ length ] dip < [ 2drop f ] [ tail-slice ] if ; inline @@ -157,30 +196,6 @@ TUPLE: sequence-parser sequence n ; sequence-parser [ n + ] change-n drop ] if ; -: take-c-comment ( sequence-parser -- seq/f ) - [ - dup "/*" take-sequence [ - "*/" take-until-sequence* - ] [ - drop f - ] if - ] with-sequence-parser ; - -: take-c++-comment ( sequence-parser -- seq/f ) - [ - dup "//" take-sequence [ - [ - [ - { [ current CHAR: \n = ] [ sequence-parse-end? ] } 1|| - ] take-until - ] [ - advance drop - ] bi - ] [ - drop f - ] if - ] with-sequence-parser ; - : c-identifier-begin? ( ch -- ? ) CHAR: a CHAR: z [a,b] CHAR: A CHAR: Z [a,b] @@ -192,29 +207,30 @@ TUPLE: sequence-parser sequence n ; CHAR: 0 CHAR: 9 [a,b] { CHAR: _ } 4 nappend member? ; -: take-c-identifier ( state-parser -- string/f ) - [ - dup current c-identifier-begin? [ - [ current c-identifier-ch? ] take-while - ] [ - drop f - ] if - ] with-sequence-parser ; +: (take-c-identifier) ( sequence-parser -- string/f ) + dup current c-identifier-begin? [ + [ current c-identifier-ch? ] take-while + ] [ + drop f + ] if ; + +: take-c-identifier ( sequence-parser -- string/f ) + [ (take-c-identifier) ] with-sequence-parser ; << "length" [ length ] define-sorting >> : sort-tokens ( seq -- seq' ) { length>=< <=> } sort-by ; -: take-first-matching ( state-parser seq -- seq ) +: take-first-matching ( sequence-parser seq -- seq ) swap '[ _ [ swap take-sequence ] with-sequence-parser ] find nip ; -: take-longest ( state-parser seq -- seq ) +: take-longest ( sequence-parser seq -- seq ) sort-tokens take-first-matching ; -: take-c-integer ( state-parser -- string/f ) +: take-c-integer ( sequence-parser -- string/f ) [ dup take-integer [ swap @@ -225,5 +241,19 @@ TUPLE: sequence-parser sequence n ; ] if* ] with-sequence-parser ; +CONSTANT: c-punctuators + { + "[" "]" "(" ")" "{" "}" "." "->" + "++" "--" "&" "*" "+" "-" "~" "!" + "/" "%" "<<" ">>" "<" ">" "<=" ">=" "==" "!=" "^" "|" "&&" "||" + "?" ":" ";" "..." + "=" "*=" "/=" "%=" "+=" "-=" "<<=" ">>=" "&=" "^=" "|=" + "," "#" "##" + "<:" ":>" "<%" "%>" "%:" "%:%:" + } + +: take-c-punctuator ( sequence-parser -- string/f ) + c-punctuators take-longest ; + : write-full ( sequence-parser -- ) sequence>> write ; : write-rest ( sequence-parser -- ) take-rest write ; diff --git a/license.txt b/license.txt index 8f4f53585a..e9cd58a5e4 100644 --- a/license.txt +++ b/license.txt @@ -1,5 +1,3 @@ -Copyright (C) 2003, 2009 Slava Pestov and friends. - Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: diff --git a/extra/boolean-expr/authors.txt b/unmaintained/boolean-expr/authors.txt similarity index 100% rename from extra/boolean-expr/authors.txt rename to unmaintained/boolean-expr/authors.txt diff --git a/extra/boolean-expr/boolean-expr.factor b/unmaintained/boolean-expr/boolean-expr.factor similarity index 100% rename from extra/boolean-expr/boolean-expr.factor rename to unmaintained/boolean-expr/boolean-expr.factor diff --git a/extra/boolean-expr/summary.txt b/unmaintained/boolean-expr/summary.txt similarity index 100% rename from extra/boolean-expr/summary.txt rename to unmaintained/boolean-expr/summary.txt diff --git a/extra/boolean-expr/tags.txt b/unmaintained/boolean-expr/tags.txt similarity index 100% rename from extra/boolean-expr/tags.txt rename to unmaintained/boolean-expr/tags.txt diff --git a/extra/lint/authors.txt b/unmaintained/lint/authors.txt similarity index 100% rename from extra/lint/authors.txt rename to unmaintained/lint/authors.txt diff --git a/extra/lint/lint-tests.factor b/unmaintained/lint/lint-tests.factor similarity index 100% rename from extra/lint/lint-tests.factor rename to unmaintained/lint/lint-tests.factor diff --git a/extra/lint/lint.factor b/unmaintained/lint/lint.factor similarity index 100% rename from extra/lint/lint.factor rename to unmaintained/lint/lint.factor diff --git a/extra/lint/summary.txt b/unmaintained/lint/summary.txt similarity index 100% rename from extra/lint/summary.txt rename to unmaintained/lint/summary.txt diff --git a/extra/multi-methods/authors.txt b/unmaintained/multi-methods/authors.txt similarity index 100% rename from extra/multi-methods/authors.txt rename to unmaintained/multi-methods/authors.txt diff --git a/extra/multi-methods/multi-methods.factor b/unmaintained/multi-methods/multi-methods.factor similarity index 100% rename from extra/multi-methods/multi-methods.factor rename to unmaintained/multi-methods/multi-methods.factor diff --git a/extra/multi-methods/summary.txt b/unmaintained/multi-methods/summary.txt similarity index 100% rename from extra/multi-methods/summary.txt rename to unmaintained/multi-methods/summary.txt diff --git a/extra/multi-methods/tags.txt b/unmaintained/multi-methods/tags.txt similarity index 100% rename from extra/multi-methods/tags.txt rename to unmaintained/multi-methods/tags.txt diff --git a/extra/multi-methods/tests/canonicalize.factor b/unmaintained/multi-methods/tests/canonicalize.factor similarity index 100% rename from extra/multi-methods/tests/canonicalize.factor rename to unmaintained/multi-methods/tests/canonicalize.factor diff --git a/extra/multi-methods/tests/definitions.factor b/unmaintained/multi-methods/tests/definitions.factor similarity index 93% rename from extra/multi-methods/tests/definitions.factor rename to unmaintained/multi-methods/tests/definitions.factor index 240c9f86d7..aa66f41d8d 100644 --- a/extra/multi-methods/tests/definitions.factor +++ b/unmaintained/multi-methods/tests/definitions.factor @@ -2,9 +2,6 @@ IN: multi-methods.tests USING: multi-methods tools.test math sequences namespaces system kernel strings words compiler.units quotations ; -\ GENERIC: must-infer -\ create-method-in must-infer - DEFER: fake \ fake H{ } clone "multi-methods" set-word-prop diff --git a/extra/multi-methods/tests/legacy.factor b/unmaintained/multi-methods/tests/legacy.factor similarity index 100% rename from extra/multi-methods/tests/legacy.factor rename to unmaintained/multi-methods/tests/legacy.factor diff --git a/extra/multi-methods/tests/syntax.factor b/unmaintained/multi-methods/tests/syntax.factor similarity index 100% rename from extra/multi-methods/tests/syntax.factor rename to unmaintained/multi-methods/tests/syntax.factor diff --git a/extra/multi-methods/tests/topological-sort.factor b/unmaintained/multi-methods/tests/topological-sort.factor similarity index 100% rename from extra/multi-methods/tests/topological-sort.factor rename to unmaintained/multi-methods/tests/topological-sort.factor diff --git a/extra/newfx/newfx.factor b/unmaintained/newfx/newfx.factor similarity index 100% rename from extra/newfx/newfx.factor rename to unmaintained/newfx/newfx.factor diff --git a/extra/shell/parser/parser.factor b/unmaintained/shell/parser/parser.factor similarity index 100% rename from extra/shell/parser/parser.factor rename to unmaintained/shell/parser/parser.factor diff --git a/extra/shell/shell.factor b/unmaintained/shell/shell.factor similarity index 100% rename from extra/shell/shell.factor rename to unmaintained/shell/shell.factor diff --git a/vm/code_heap.c b/vm/code_heap.c index 65a28c6de3..1901c592e6 100755 --- a/vm/code_heap.c +++ b/vm/code_heap.c @@ -21,14 +21,16 @@ void set_word_code(F_WORD *word, F_CODE_BLOCK *compiled) word->optimizedp = T; } -/* Allocates memory */ -void default_word_code(F_WORD *word, bool relocate) +/* Compile a word definition with the non-optimizing compiler. Allocates memory */ +void jit_compile_word(F_WORD *word, CELL def, bool relocate) { + REGISTER_ROOT(def); REGISTER_UNTAGGED(word); - jit_compile(word->def,relocate); + jit_compile(def,relocate); UNREGISTER_UNTAGGED(word); + UNREGISTER_ROOT(def); - word->code = untag_quotation(word->def)->code; + word->code = untag_quotation(def)->code; word->optimizedp = F; } @@ -83,15 +85,15 @@ void primitive_modify_code_heap(void) CELL data = array_nth(pair,1); - if(data == F) + if(type_of(data) == QUOTATION_TYPE) { REGISTER_UNTAGGED(alist); REGISTER_UNTAGGED(word); - default_word_code(word,false); + jit_compile_word(word,data,false); UNREGISTER_UNTAGGED(word); UNREGISTER_UNTAGGED(alist); } - else + else if(type_of(data) == ARRAY_TYPE) { F_ARRAY *compiled_code = untag_array(data); @@ -115,6 +117,8 @@ void primitive_modify_code_heap(void) set_word_code(word,compiled); } + else + critical_error("Expected a quotation or an array",data); REGISTER_UNTAGGED(alist); update_word_xt(word); diff --git a/vm/code_heap.h b/vm/code_heap.h index 4f52819547..4c5aafcddd 100755 --- a/vm/code_heap.h +++ b/vm/code_heap.h @@ -5,7 +5,7 @@ void init_code_heap(CELL size); bool in_code_heap_p(CELL ptr); -void default_word_code(F_WORD *word, bool relocate); +void jit_compile_word(F_WORD *word, CELL def, bool relocate); void set_word_code(F_WORD *word, F_CODE_BLOCK *compiled); diff --git a/vm/data_gc.c b/vm/data_gc.c index 2252d07541..cc1df13d58 100755 --- a/vm/data_gc.c +++ b/vm/data_gc.c @@ -564,6 +564,8 @@ void primitive_clear_gc_stats(void) clear_gc_stats(); } +/* classes.tuple uses this to reshape tuples; tools.deploy.shaker uses this + to coalesce equal but distinct quotations and wrappers. */ void primitive_become(void) { F_ARRAY *new_objects = untag_array(dpop()); @@ -585,5 +587,9 @@ void primitive_become(void) gc(); + /* If a word's definition quotation was in old_objects and the + quotation in new_objects is not compiled, we might leak memory + by referencing the old quotation unless we recompile all + unoptimized words. */ compile_all_words(); } diff --git a/vm/quotations.c b/vm/quotations.c index e18e6b6098..d08fecdefb 100755 --- a/vm/quotations.c +++ b/vm/quotations.c @@ -533,7 +533,7 @@ void compile_all_words(void) F_WORD *word = untag_word(array_nth(untag_array(words),i)); REGISTER_UNTAGGED(word); if(word->optimizedp == F) - default_word_code(word,false); + jit_compile_word(word,word->def,false); UNREGISTER_UNTAGGED(word); update_word_xt(word); } diff --git a/vm/types.c b/vm/types.c index 119dc675bc..889de38016 100755 --- a/vm/types.c +++ b/vm/types.c @@ -54,7 +54,7 @@ F_WORD *allot_word(CELL vocab, CELL name) word->code = NULL; REGISTER_UNTAGGED(word); - default_word_code(word,true); + jit_compile_word(word,word->def,true); UNREGISTER_UNTAGGED(word); REGISTER_UNTAGGED(word);