Merge branch 'master' into experimental
commit
dac233992a
|
@ -25,3 +25,5 @@ build-support/wordsize
|
||||||
.#*
|
.#*
|
||||||
*.swo
|
*.swo
|
||||||
checksums.txt
|
checksums.txt
|
||||||
|
*.so
|
||||||
|
a.out
|
||||||
|
|
|
@ -58,3 +58,10 @@ $nl
|
||||||
"} cond >>"
|
"} cond >>"
|
||||||
}
|
}
|
||||||
"Note the parse time evaluation with " { $link POSTPONE: << } "." } ;
|
"Note the parse time evaluation with " { $link POSTPONE: << } "." } ;
|
||||||
|
|
||||||
|
ARTICLE: "loading-libs" "Loading native libraries"
|
||||||
|
"Before calling a C library, you must associate its path name on disk with a logical name which Factor uses to identify the library:"
|
||||||
|
{ $subsection add-library }
|
||||||
|
"Once a library has been defined, you can try loading it to see if the path name is correct:"
|
||||||
|
{ $subsection load-library }
|
||||||
|
"If the compiler cannot load a library, or cannot resolve a symbol in a library, a linkage error is reported using the compiler error mechanism (see " { $link "compiler-errors" } "). Once you install the right library, reload the source file containing the " { $link add-library } " form to force the compiler to try loading the library again." ;
|
||||||
|
|
|
@ -1,7 +1,7 @@
|
||||||
! Copyright (C) 2008 Slava Pestov.
|
! Copyright (C) 2008, 2009 Slava Pestov.
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
USING: alien alien.c-types arrays assocs effects grouping kernel
|
USING: alien alien.c-types arrays assocs effects grouping kernel
|
||||||
parser sequences splitting words fry locals ;
|
parser sequences splitting words fry locals lexer namespaces ;
|
||||||
IN: alien.parser
|
IN: alien.parser
|
||||||
|
|
||||||
: parse-arglist ( parameters return -- types effect )
|
: parse-arglist ( parameters return -- types effect )
|
||||||
|
@ -12,8 +12,15 @@ IN: alien.parser
|
||||||
: function-quot ( return library function types -- quot )
|
: function-quot ( return library function types -- quot )
|
||||||
'[ _ _ _ _ alien-invoke ] ;
|
'[ _ _ _ _ alien-invoke ] ;
|
||||||
|
|
||||||
:: define-function ( return library function parameters -- )
|
:: make-function ( return library function parameters -- word quot effect )
|
||||||
function create-in dup reset-generic
|
function create-in dup reset-generic
|
||||||
return library function
|
return library function
|
||||||
parameters return parse-arglist [ function-quot ] dip
|
parameters return parse-arglist [ function-quot ] dip ;
|
||||||
define-declared ;
|
|
||||||
|
: (FUNCTION:) ( -- word quot effect )
|
||||||
|
scan "c-library" get scan ";" parse-tokens
|
||||||
|
[ "()" subseq? not ] filter
|
||||||
|
make-function ;
|
||||||
|
|
||||||
|
: define-function ( return library function parameters -- )
|
||||||
|
make-function define-declared ;
|
||||||
|
|
|
@ -16,9 +16,7 @@ SYNTAX: BAD-ALIEN <bad-alien> parsed ;
|
||||||
SYNTAX: LIBRARY: scan "c-library" set ;
|
SYNTAX: LIBRARY: scan "c-library" set ;
|
||||||
|
|
||||||
SYNTAX: FUNCTION:
|
SYNTAX: FUNCTION:
|
||||||
scan "c-library" get scan ";" parse-tokens
|
(FUNCTION:) define-declared ;
|
||||||
[ "()" subseq? not ] filter
|
|
||||||
define-function ;
|
|
||||||
|
|
||||||
SYNTAX: TYPEDEF:
|
SYNTAX: TYPEDEF:
|
||||||
scan scan typedef ;
|
scan scan typedef ;
|
||||||
|
|
|
@ -8,7 +8,7 @@ namespaces eval kernel vocabs.loader io ;
|
||||||
(command-line) parse-command-line
|
(command-line) parse-command-line
|
||||||
load-vocab-roots
|
load-vocab-roots
|
||||||
run-user-init
|
run-user-init
|
||||||
"e" get [ eval ] when*
|
"e" get [ eval( -- ) ] when*
|
||||||
ignore-cli-args? not script get and
|
ignore-cli-args? not script get and
|
||||||
[ run-script ] [ "run" get run ] if*
|
[ run-script ] [ "run" get run ] if*
|
||||||
output-stream get [ stream-flush ] when*
|
output-stream get [ stream-flush ] when*
|
||||||
|
|
|
@ -4,7 +4,7 @@ USING: accessors init namespaces words words.symbol io
|
||||||
kernel.private math memory continuations kernel io.files
|
kernel.private math memory continuations kernel io.files
|
||||||
io.pathnames io.backend system parser vocabs sequences
|
io.pathnames io.backend system parser vocabs sequences
|
||||||
vocabs.loader combinators splitting source-files strings
|
vocabs.loader combinators splitting source-files strings
|
||||||
definitions assocs compiler.errors compiler.units math.parser
|
definitions assocs compiler.units math.parser
|
||||||
generic sets command-line ;
|
generic sets command-line ;
|
||||||
IN: bootstrap.stage2
|
IN: bootstrap.stage2
|
||||||
|
|
||||||
|
@ -81,14 +81,11 @@ SYMBOL: bootstrap-time
|
||||||
"none" require
|
"none" require
|
||||||
] if
|
] if
|
||||||
|
|
||||||
[
|
load-components
|
||||||
load-components
|
|
||||||
|
|
||||||
millis over - core-bootstrap-time set-global
|
millis over - core-bootstrap-time set-global
|
||||||
|
|
||||||
run-bootstrap-init
|
run-bootstrap-init
|
||||||
] with-compiler-errors
|
|
||||||
:errors
|
|
||||||
|
|
||||||
f error set-global
|
f error set-global
|
||||||
f error-continuation set-global
|
f error-continuation set-global
|
||||||
|
|
|
@ -6,6 +6,7 @@ IN: bootstrap.tools
|
||||||
"bootstrap.image"
|
"bootstrap.image"
|
||||||
"tools.annotations"
|
"tools.annotations"
|
||||||
"tools.crossref"
|
"tools.crossref"
|
||||||
|
"tools.errors"
|
||||||
"tools.deploy"
|
"tools.deploy"
|
||||||
"tools.disassembler"
|
"tools.disassembler"
|
||||||
"tools.memory"
|
"tools.memory"
|
||||||
|
|
|
@ -5,6 +5,7 @@ kernel kernel.private layouts assocs words summary arrays
|
||||||
combinators classes.algebra alien alien.c-types alien.structs
|
combinators classes.algebra alien alien.c-types alien.structs
|
||||||
alien.strings alien.arrays alien.complex sets libc alien.libraries
|
alien.strings alien.arrays alien.complex sets libc alien.libraries
|
||||||
continuations.private fry cpu.architecture
|
continuations.private fry cpu.architecture
|
||||||
|
source-files.errors
|
||||||
compiler.errors
|
compiler.errors
|
||||||
compiler.alien
|
compiler.alien
|
||||||
compiler.cfg
|
compiler.cfg
|
||||||
|
@ -379,8 +380,7 @@ TUPLE: no-such-library name ;
|
||||||
M: no-such-library summary
|
M: no-such-library summary
|
||||||
drop "Library not found" ;
|
drop "Library not found" ;
|
||||||
|
|
||||||
M: no-such-library compiler-error-type
|
M: no-such-library error-type drop +linkage-error+ ;
|
||||||
drop +linkage+ ;
|
|
||||||
|
|
||||||
: no-such-library ( name -- )
|
: no-such-library ( name -- )
|
||||||
\ no-such-library boa
|
\ no-such-library boa
|
||||||
|
@ -391,8 +391,7 @@ TUPLE: no-such-symbol name ;
|
||||||
M: no-such-symbol summary
|
M: no-such-symbol summary
|
||||||
drop "Symbol not found" ;
|
drop "Symbol not found" ;
|
||||||
|
|
||||||
M: no-such-symbol compiler-error-type
|
M: no-such-symbol error-type drop +linkage-error+ ;
|
||||||
drop +linkage+ ;
|
|
||||||
|
|
||||||
: no-such-symbol ( name -- )
|
: no-such-symbol ( name -- )
|
||||||
\ no-such-symbol boa
|
\ no-such-symbol boa
|
||||||
|
|
|
@ -1,5 +1,7 @@
|
||||||
USING: help.markup help.syntax words io parser
|
USING: assocs compiler.cfg.builder compiler.cfg.optimizer
|
||||||
assocs words.private sequences compiler.units quotations ;
|
compiler.errors compiler.tree.builder compiler.tree.optimizer
|
||||||
|
compiler.units help.markup help.syntax io parser quotations
|
||||||
|
sequences words words.private ;
|
||||||
IN: compiler
|
IN: compiler
|
||||||
|
|
||||||
HELP: enable-compiler
|
HELP: enable-compiler
|
||||||
|
@ -18,6 +20,24 @@ ARTICLE: "compiler-usage" "Calling the optimizing compiler"
|
||||||
{ $subsection compile-call }
|
{ $subsection compile-call }
|
||||||
"Higher-level words can be found in " { $link "compilation-units" } "." ;
|
"Higher-level words can be found in " { $link "compilation-units" } "." ;
|
||||||
|
|
||||||
|
ARTICLE: "compiler-impl" "Compiler implementation"
|
||||||
|
"The " { $vocab-link "compiler" } "vocabulary, in addition to providing the user-visible words of the compiler, implements the main compilation loop."
|
||||||
|
$nl
|
||||||
|
"Words are added to the " { $link compile-queue } " variable as needed and compiled."
|
||||||
|
{ $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:"
|
||||||
|
{ $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" } ")." }
|
||||||
|
{ "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 } "." }
|
||||||
|
}
|
||||||
|
"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
|
||||||
|
"Calling " { $link modify-code-heap } " is handled not by the " { $vocab-link "compiler" } " vocabulary, but rather " { $vocab-link "compiler.units" } ". The optimizing compiler merely provides an implementation of the " { $link recompile } " generic word." ;
|
||||||
|
|
||||||
ARTICLE: "compiler" "Optimizing compiler"
|
ARTICLE: "compiler" "Optimizing compiler"
|
||||||
"Factor includes two compilers which work behind the scenes. Words are always compiled, and the compilers do not have to be invoked explicitly. For the most part, compilation is fully transparent. However, there are a few things worth knowing about the compilation process."
|
"Factor includes two compilers which work behind the scenes. Words are always compiled, and the compilers do not have to be invoked explicitly. For the most part, compilation is fully transparent. However, there are a few things worth knowing about the compilation process."
|
||||||
$nl
|
$nl
|
||||||
|
@ -31,7 +51,8 @@ $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."
|
"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."
|
||||||
{ $subsection "compiler-errors" }
|
{ $subsection "compiler-errors" }
|
||||||
{ $subsection "hints" }
|
{ $subsection "hints" }
|
||||||
{ $subsection "compiler-usage" } ;
|
{ $subsection "compiler-usage" }
|
||||||
|
{ $subsection "compiler-impl" } ;
|
||||||
|
|
||||||
ABOUT: "compiler"
|
ABOUT: "compiler"
|
||||||
|
|
||||||
|
|
|
@ -2,7 +2,7 @@
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
USING: accessors kernel namespaces arrays sequences io words fry
|
USING: accessors kernel namespaces arrays sequences io words fry
|
||||||
continuations vocabs assocs dlists definitions math graphs generic
|
continuations vocabs assocs dlists definitions math graphs generic
|
||||||
combinators deques search-deques macros io stack-checker
|
combinators deques search-deques macros io source-files.errors stack-checker
|
||||||
stack-checker.state stack-checker.inlining combinators.short-circuit
|
stack-checker.state stack-checker.inlining combinators.short-circuit
|
||||||
compiler.errors compiler.units compiler.tree.builder
|
compiler.errors compiler.units compiler.tree.builder
|
||||||
compiler.tree.optimizer compiler.cfg.builder compiler.cfg.optimizer
|
compiler.tree.optimizer compiler.cfg.builder compiler.cfg.optimizer
|
||||||
|
@ -53,22 +53,30 @@ SYMBOLS: +optimized+ +unoptimized+ ;
|
||||||
f swap compiler-error ;
|
f swap compiler-error ;
|
||||||
|
|
||||||
: ignore-error? ( word error -- ? )
|
: ignore-error? ( word error -- ? )
|
||||||
[ [ inline? ] [ macro? ] bi or ]
|
|
||||||
[ compiler-error-type +warning+ eq? ] bi* and ;
|
|
||||||
|
|
||||||
: fail ( word error -- * )
|
|
||||||
[ 2dup ignore-error? [ 2drop ] [ swap compiler-error ] if ]
|
|
||||||
[
|
[
|
||||||
drop
|
{
|
||||||
[ compiled-unxref ]
|
[ inline? ]
|
||||||
[ f swap compiled get set-at ]
|
[ macro? ]
|
||||||
[ +unoptimized+ save-compiled-status ]
|
[ "transform-quot" word-prop ]
|
||||||
tri
|
[ "no-compile" word-prop ]
|
||||||
] 2bi
|
[ "special" word-prop ]
|
||||||
|
} 1||
|
||||||
|
] [ error-type +compiler-warning+ eq? ] bi* and ;
|
||||||
|
|
||||||
|
: (fail) ( word -- * )
|
||||||
|
[ compiled-unxref ]
|
||||||
|
[ f swap compiled get set-at ]
|
||||||
|
[ +unoptimized+ save-compiled-status ]
|
||||||
|
tri
|
||||||
return ;
|
return ;
|
||||||
|
|
||||||
|
: fail ( word error -- * )
|
||||||
|
[ 2dup ignore-error? [ drop f ] when swap compiler-error ] [ drop (fail) ] 2bi ;
|
||||||
|
|
||||||
: frontend ( word -- nodes )
|
: frontend ( word -- nodes )
|
||||||
[ build-tree-from-word ] [ fail ] recover optimize-tree ;
|
dup contains-breakpoints? [ (fail) ] [
|
||||||
|
[ build-tree-from-word ] [ fail ] recover optimize-tree
|
||||||
|
] if ;
|
||||||
|
|
||||||
! Only switch this off for debugging.
|
! Only switch this off for debugging.
|
||||||
SYMBOL: compile-dependencies?
|
SYMBOL: compile-dependencies?
|
||||||
|
@ -122,6 +130,8 @@ t compile-dependencies? set-global
|
||||||
: compile-call ( quot -- )
|
: compile-call ( quot -- )
|
||||||
[ dup infer define-temp ] with-compilation-unit execute ;
|
[ dup infer define-temp ] with-compilation-unit execute ;
|
||||||
|
|
||||||
|
\ compile-call t "no-compile" set-word-prop
|
||||||
|
|
||||||
SINGLETON: optimizing-compiler
|
SINGLETON: optimizing-compiler
|
||||||
|
|
||||||
M: optimizing-compiler recompile ( words -- alist )
|
M: optimizing-compiler recompile ( words -- alist )
|
||||||
|
|
|
@ -0,0 +1,5 @@
|
||||||
|
IN: compiler.errors
|
||||||
|
USING: help.markup help.syntax vocabs.loader words io
|
||||||
|
quotations words.symbol ;
|
||||||
|
|
||||||
|
ABOUT: "compiler-errors"
|
|
@ -0,0 +1,54 @@
|
||||||
|
! Copyright (C) 2007, 2009 Slava Pestov.
|
||||||
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
|
USING: accessors source-files.errors kernel namespaces assocs ;
|
||||||
|
IN: compiler.errors
|
||||||
|
|
||||||
|
TUPLE: compiler-error < source-file-error ;
|
||||||
|
|
||||||
|
M: compiler-error error-type error>> error-type ;
|
||||||
|
|
||||||
|
SYMBOL: compiler-errors
|
||||||
|
|
||||||
|
compiler-errors [ H{ } clone ] initialize
|
||||||
|
|
||||||
|
SYMBOLS: +compiler-error+ +compiler-warning+ +linkage-error+ ;
|
||||||
|
|
||||||
|
: errors-of-type ( type -- assoc )
|
||||||
|
compiler-errors get-global
|
||||||
|
swap [ [ nip error-type ] dip eq? ] curry
|
||||||
|
assoc-filter ;
|
||||||
|
|
||||||
|
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 ] }
|
||||||
|
{ 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
|
||||||
|
|
||||||
|
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 ] }
|
||||||
|
{ fatal? f }
|
||||||
|
} define-error-type
|
||||||
|
|
||||||
|
: <compiler-error> ( error word -- compiler-error )
|
||||||
|
\ compiler-error <definition-error> ;
|
||||||
|
|
||||||
|
: compiler-error ( error word -- )
|
||||||
|
compiler-errors get-global pick
|
||||||
|
[ [ [ <compiler-error> ] keep ] dip set-at ] [ delete-at drop ] if ;
|
|
@ -12,7 +12,7 @@ IN: compiler.tests
|
||||||
IN: compiler.tests.folding
|
IN: compiler.tests.folding
|
||||||
GENERIC: foldable-generic ( a -- b ) foldable
|
GENERIC: foldable-generic ( a -- b ) foldable
|
||||||
M: integer foldable-generic f <array> ;
|
M: integer foldable-generic f <array> ;
|
||||||
"> eval
|
"> eval( -- )
|
||||||
] unit-test
|
] unit-test
|
||||||
|
|
||||||
[ ] [
|
[ ] [
|
||||||
|
@ -20,7 +20,7 @@ IN: compiler.tests
|
||||||
USING: math arrays ;
|
USING: math arrays ;
|
||||||
IN: compiler.tests.folding
|
IN: compiler.tests.folding
|
||||||
: fold-test ( -- x ) 10 foldable-generic ;
|
: fold-test ( -- x ) 10 foldable-generic ;
|
||||||
"> eval
|
"> eval( -- )
|
||||||
] unit-test
|
] unit-test
|
||||||
|
|
||||||
[ t ] [
|
[ t ] [
|
||||||
|
|
|
@ -11,7 +11,7 @@ M: integer method-redefine-generic-1 3 + ;
|
||||||
|
|
||||||
[ 6 ] [ method-redefine-test-1 ] unit-test
|
[ 6 ] [ method-redefine-test-1 ] unit-test
|
||||||
|
|
||||||
[ ] [ "IN: compiler.tests USE: math M: fixnum method-redefine-generic-1 4 + ;" eval ] unit-test
|
[ ] [ "IN: compiler.tests USE: math M: fixnum method-redefine-generic-1 4 + ;" eval( -- ) ] unit-test
|
||||||
|
|
||||||
[ 7 ] [ method-redefine-test-1 ] unit-test
|
[ 7 ] [ method-redefine-test-1 ] unit-test
|
||||||
|
|
||||||
|
@ -27,7 +27,7 @@ M: integer method-redefine-generic-2 3 + ;
|
||||||
|
|
||||||
[ 6 ] [ method-redefine-test-2 ] unit-test
|
[ 6 ] [ method-redefine-test-2 ] unit-test
|
||||||
|
|
||||||
[ ] [ "IN: compiler.tests USE: kernel USE: math M: fixnum method-redefine-generic-2 4 + ; USE: strings M: string method-redefine-generic-2 drop f ;" eval ] unit-test
|
[ ] [ "IN: compiler.tests USE: kernel USE: math M: fixnum method-redefine-generic-2 4 + ; USE: strings M: string method-redefine-generic-2 drop f ;" eval( -- ) ] unit-test
|
||||||
|
|
||||||
[ 7 ] [ method-redefine-test-2 ] unit-test
|
[ 7 ] [ method-redefine-test-2 ] unit-test
|
||||||
|
|
||||||
|
@ -43,10 +43,10 @@ M: integer method-redefine-generic-2 3 + ;
|
||||||
|
|
||||||
[ t ] [ \ hey optimized>> ] unit-test
|
[ t ] [ \ hey optimized>> ] unit-test
|
||||||
[ t ] [ \ there optimized>> ] unit-test
|
[ t ] [ \ there optimized>> ] unit-test
|
||||||
[ ] [ "IN: compiler.tests : hey ( -- ) 3 ;" eval ] unit-test
|
[ ] [ "IN: compiler.tests : hey ( -- ) 3 ;" eval( -- ) ] unit-test
|
||||||
[ f ] [ \ hey optimized>> ] unit-test
|
[ f ] [ \ hey optimized>> ] unit-test
|
||||||
[ f ] [ \ there optimized>> ] unit-test
|
[ f ] [ \ there optimized>> ] unit-test
|
||||||
[ ] [ "IN: compiler.tests : hey ( -- ) ;" eval ] unit-test
|
[ ] [ "IN: compiler.tests : hey ( -- ) ;" eval( -- ) ] unit-test
|
||||||
[ t ] [ \ there optimized>> ] unit-test
|
[ t ] [ \ there optimized>> ] unit-test
|
||||||
|
|
||||||
: good ( -- ) ;
|
: good ( -- ) ;
|
||||||
|
@ -59,7 +59,7 @@ M: integer method-redefine-generic-2 3 + ;
|
||||||
|
|
||||||
[ f ] [ \ good compiled-usage assoc-empty? ] unit-test
|
[ f ] [ \ good compiled-usage assoc-empty? ] unit-test
|
||||||
|
|
||||||
[ ] [ "IN: compiler.tests : good ( -- ) 3 ;" eval ] unit-test
|
[ ] [ "IN: compiler.tests : good ( -- ) 3 ;" eval( -- ) ] unit-test
|
||||||
|
|
||||||
[ f ] [ \ good optimized>> ] unit-test
|
[ f ] [ \ good optimized>> ] unit-test
|
||||||
[ f ] [ \ bad optimized>> ] unit-test
|
[ f ] [ \ bad optimized>> ] unit-test
|
||||||
|
@ -67,7 +67,7 @@ M: integer method-redefine-generic-2 3 + ;
|
||||||
|
|
||||||
[ t ] [ \ good compiled-usage assoc-empty? ] unit-test
|
[ t ] [ \ good compiled-usage assoc-empty? ] unit-test
|
||||||
|
|
||||||
[ ] [ "IN: compiler.tests : good ( -- ) ;" eval ] unit-test
|
[ ] [ "IN: compiler.tests : good ( -- ) ;" eval( -- ) ] unit-test
|
||||||
|
|
||||||
[ t ] [ \ good optimized>> ] unit-test
|
[ t ] [ \ good optimized>> ] unit-test
|
||||||
[ t ] [ \ bad optimized>> ] unit-test
|
[ t ] [ \ bad optimized>> ] unit-test
|
||||||
|
|
|
@ -13,7 +13,7 @@ IN: compiler.tests
|
||||||
MIXIN: my-mixin
|
MIXIN: my-mixin
|
||||||
INSTANCE: fixnum my-mixin
|
INSTANCE: fixnum my-mixin
|
||||||
: my-inline ( a -- b ) dup my-mixin instance? [ 1 + ] when ;
|
: my-inline ( a -- b ) dup my-mixin instance? [ 1 + ] when ;
|
||||||
"> eval
|
"> eval( -- )
|
||||||
] unit-test
|
] unit-test
|
||||||
|
|
||||||
[ ] [
|
[ ] [
|
||||||
|
@ -21,7 +21,7 @@ IN: compiler.tests
|
||||||
USE: math
|
USE: math
|
||||||
IN: compiler.tests.redefine10
|
IN: compiler.tests.redefine10
|
||||||
INSTANCE: float my-mixin
|
INSTANCE: float my-mixin
|
||||||
"> eval
|
"> eval( -- )
|
||||||
] unit-test
|
] unit-test
|
||||||
|
|
||||||
[ 2.0 ] [
|
[ 2.0 ] [
|
||||||
|
|
|
@ -17,7 +17,7 @@ IN: compiler.tests
|
||||||
M: my-mixin my-generic drop 0 ;
|
M: my-mixin my-generic drop 0 ;
|
||||||
M: object my-generic drop 1 ;
|
M: object my-generic drop 1 ;
|
||||||
: my-inline ( -- b ) { } my-generic ;
|
: my-inline ( -- b ) { } my-generic ;
|
||||||
"> eval
|
"> eval( -- )
|
||||||
] unit-test
|
] unit-test
|
||||||
|
|
||||||
[ ] [
|
[ ] [
|
||||||
|
|
|
@ -15,6 +15,6 @@ M: object g drop t ;
|
||||||
|
|
||||||
TUPLE: jeah ;
|
TUPLE: jeah ;
|
||||||
|
|
||||||
[ ] [ "USE: kernel IN: compiler.tests.redefine12 M: jeah g drop f ;" eval ] unit-test
|
[ ] [ "USE: kernel IN: compiler.tests.redefine12 M: jeah g drop f ;" eval( -- ) ] unit-test
|
||||||
|
|
||||||
[ f ] [ T{ jeah } h ] unit-test
|
[ f ] [ T{ jeah } h ] unit-test
|
||||||
|
|
|
@ -5,7 +5,7 @@ arrays words assocs eval words.symbol ;
|
||||||
|
|
||||||
DEFER: redefine2-test
|
DEFER: redefine2-test
|
||||||
|
|
||||||
[ ] [ "USE: sequences USE: kernel IN: compiler.tests TUPLE: redefine2-test ; M: redefine2-test nth 2drop 3 ; INSTANCE: redefine2-test sequence" eval ] unit-test
|
[ ] [ "USE: sequences USE: kernel IN: compiler.tests TUPLE: redefine2-test ; M: redefine2-test nth 2drop 3 ; INSTANCE: redefine2-test sequence" eval( -- ) ] unit-test
|
||||||
|
|
||||||
[ t ] [ \ redefine2-test symbol? ] unit-test
|
[ t ] [ \ redefine2-test symbol? ] unit-test
|
||||||
|
|
||||||
|
|
|
@ -18,7 +18,7 @@ M: empty-mixin sheeple drop "wake up" ;
|
||||||
[ t ] [ object \ sheeple method \ sheeple-test "compiled-uses" word-prop key? ] unit-test
|
[ t ] [ object \ sheeple method \ sheeple-test "compiled-uses" word-prop key? ] unit-test
|
||||||
[ f ] [ empty-mixin \ sheeple method \ sheeple-test "compiled-uses" word-prop key? ] unit-test
|
[ f ] [ empty-mixin \ sheeple method \ sheeple-test "compiled-uses" word-prop key? ] unit-test
|
||||||
|
|
||||||
[ ] [ "IN: compiler.tests USE: arrays INSTANCE: array empty-mixin" eval ] unit-test
|
[ ] [ "IN: compiler.tests USE: arrays INSTANCE: array empty-mixin" eval( -- ) ] unit-test
|
||||||
|
|
||||||
[ "wake up" ] [ sheeple-test ] unit-test
|
[ "wake up" ] [ sheeple-test ] unit-test
|
||||||
[ f ] [ object \ sheeple method \ sheeple-test "compiled-uses" word-prop key? ] unit-test
|
[ f ] [ object \ sheeple method \ sheeple-test "compiled-uses" word-prop key? ] unit-test
|
||||||
|
|
|
@ -7,6 +7,6 @@ USING: io.streams.string kernel tools.test eval ;
|
||||||
|
|
||||||
[ "" ] [ [ declaration-test ] with-string-writer ] unit-test
|
[ "" ] [ [ declaration-test ] with-string-writer ] unit-test
|
||||||
|
|
||||||
[ ] [ "IN: compiler.tests USE: io : declaration-test-1 ( -- a ) \"X\" write f ;" eval ] unit-test
|
[ ] [ "IN: compiler.tests USE: io : declaration-test-1 ( -- a ) \"X\" write f ;" eval( -- ) ] unit-test
|
||||||
|
|
||||||
[ "X" ] [ [ declaration-test ] with-string-writer ] unit-test
|
[ "X" ] [ [ declaration-test ] with-string-writer ] unit-test
|
||||||
|
|
|
@ -14,7 +14,7 @@ IN: compiler.tests
|
||||||
GENERIC: my-generic ( a -- b )
|
GENERIC: my-generic ( a -- b )
|
||||||
M: object my-generic [ <=> ] sort ;
|
M: object my-generic [ <=> ] sort ;
|
||||||
: my-inline ( a -- b ) my-generic ;
|
: my-inline ( a -- b ) my-generic ;
|
||||||
"> eval
|
"> eval( -- )
|
||||||
] unit-test
|
] unit-test
|
||||||
|
|
||||||
[ ] [
|
[ ] [
|
||||||
|
@ -23,7 +23,7 @@ IN: compiler.tests
|
||||||
IN: compiler.tests.redefine5
|
IN: compiler.tests.redefine5
|
||||||
TUPLE: my-tuple ;
|
TUPLE: my-tuple ;
|
||||||
M: my-tuple my-generic drop 0 ;
|
M: my-tuple my-generic drop 0 ;
|
||||||
"> eval
|
"> eval( -- )
|
||||||
] unit-test
|
] unit-test
|
||||||
|
|
||||||
[ 0 ] [
|
[ 0 ] [
|
||||||
|
|
|
@ -14,7 +14,7 @@ IN: compiler.tests
|
||||||
MIXIN: my-mixin
|
MIXIN: my-mixin
|
||||||
M: my-mixin my-generic drop 0 ;
|
M: my-mixin my-generic drop 0 ;
|
||||||
: my-inline ( a -- b ) { my-mixin } declare my-generic ;
|
: my-inline ( a -- b ) { my-mixin } declare my-generic ;
|
||||||
"> eval
|
"> eval( -- )
|
||||||
] unit-test
|
] unit-test
|
||||||
|
|
||||||
[ ] [
|
[ ] [
|
||||||
|
@ -24,7 +24,7 @@ IN: compiler.tests
|
||||||
TUPLE: my-tuple ;
|
TUPLE: my-tuple ;
|
||||||
M: my-tuple my-generic drop 1 ;
|
M: my-tuple my-generic drop 1 ;
|
||||||
INSTANCE: my-tuple my-mixin
|
INSTANCE: my-tuple my-mixin
|
||||||
"> eval
|
"> eval( -- )
|
||||||
] unit-test
|
] unit-test
|
||||||
|
|
||||||
[ 1 ] [
|
[ 1 ] [
|
||||||
|
|
|
@ -13,7 +13,7 @@ IN: compiler.tests
|
||||||
MIXIN: my-mixin
|
MIXIN: my-mixin
|
||||||
INSTANCE: fixnum my-mixin
|
INSTANCE: fixnum my-mixin
|
||||||
: my-inline ( a -- b ) dup my-mixin? [ 1 + ] when ;
|
: my-inline ( a -- b ) dup my-mixin? [ 1 + ] when ;
|
||||||
"> eval
|
"> eval( -- )
|
||||||
] unit-test
|
] unit-test
|
||||||
|
|
||||||
[ ] [
|
[ ] [
|
||||||
|
@ -21,7 +21,7 @@ IN: compiler.tests
|
||||||
USE: math
|
USE: math
|
||||||
IN: compiler.tests.redefine7
|
IN: compiler.tests.redefine7
|
||||||
INSTANCE: float my-mixin
|
INSTANCE: float my-mixin
|
||||||
"> eval
|
"> eval( -- )
|
||||||
] unit-test
|
] unit-test
|
||||||
|
|
||||||
[ 2.0 ] [
|
[ 2.0 ] [
|
||||||
|
|
|
@ -16,7 +16,7 @@ IN: compiler.tests
|
||||||
! We add the bogus quotation here to hinder inlining
|
! We add the bogus quotation here to hinder inlining
|
||||||
! since otherwise we cannot trigger this bug.
|
! since otherwise we cannot trigger this bug.
|
||||||
M: my-mixin my-generic 1 + [ [ <=> ] sort ] drop ;
|
M: my-mixin my-generic 1 + [ [ <=> ] sort ] drop ;
|
||||||
"> eval
|
"> eval( -- )
|
||||||
] unit-test
|
] unit-test
|
||||||
|
|
||||||
[ ] [
|
[ ] [
|
||||||
|
@ -24,7 +24,7 @@ IN: compiler.tests
|
||||||
USE: math
|
USE: math
|
||||||
IN: compiler.tests.redefine8
|
IN: compiler.tests.redefine8
|
||||||
INSTANCE: float my-mixin
|
INSTANCE: float my-mixin
|
||||||
"> eval
|
"> eval( -- )
|
||||||
] unit-test
|
] unit-test
|
||||||
|
|
||||||
[ 2.0 ] [
|
[ 2.0 ] [
|
||||||
|
|
|
@ -16,7 +16,7 @@ IN: compiler.tests
|
||||||
! We add the bogus quotation here to hinder inlining
|
! We add the bogus quotation here to hinder inlining
|
||||||
! since otherwise we cannot trigger this bug.
|
! since otherwise we cannot trigger this bug.
|
||||||
M: my-mixin my-generic 1 + [ [ <=> ] sort ] drop ;
|
M: my-mixin my-generic 1 + [ [ <=> ] sort ] drop ;
|
||||||
"> eval
|
"> eval( -- )
|
||||||
] unit-test
|
] unit-test
|
||||||
|
|
||||||
[ ] [
|
[ ] [
|
||||||
|
@ -25,7 +25,7 @@ IN: compiler.tests
|
||||||
IN: compiler.tests.redefine9
|
IN: compiler.tests.redefine9
|
||||||
TUPLE: my-tuple ;
|
TUPLE: my-tuple ;
|
||||||
INSTANCE: my-tuple my-mixin
|
INSTANCE: my-tuple my-mixin
|
||||||
"> eval
|
"> eval( -- )
|
||||||
] unit-test
|
] unit-test
|
||||||
|
|
||||||
[
|
[
|
||||||
|
|
|
@ -237,6 +237,6 @@ M: f single-combination-test-2 single-combination-test-4 ;
|
||||||
10 [
|
10 [
|
||||||
[ "compiler.tests.foo" forget-vocab ] with-compilation-unit
|
[ "compiler.tests.foo" forget-vocab ] with-compilation-unit
|
||||||
[ t ] [
|
[ t ] [
|
||||||
"USING: prettyprint words accessors ; IN: compiler.tests.foo : (recursive) ( -- ) (recursive) (recursive) ; inline recursive : recursive ( -- ) (recursive) ; \\ (recursive) optimized>>" eval
|
"USING: prettyprint words accessors ; IN: compiler.tests.foo : (recursive) ( -- ) (recursive) (recursive) ; inline recursive : recursive ( -- ) (recursive) ; \\ (recursive) optimized>>" eval( -- obj )
|
||||||
] unit-test
|
] unit-test
|
||||||
] times
|
] times
|
||||||
|
|
|
@ -42,8 +42,10 @@ IN: compiler.tree.builder
|
||||||
: check-cannot-infer ( word -- )
|
: check-cannot-infer ( word -- )
|
||||||
dup "cannot-infer" word-prop [ cannot-infer-effect ] [ drop ] if ;
|
dup "cannot-infer" word-prop [ cannot-infer-effect ] [ drop ] if ;
|
||||||
|
|
||||||
|
TUPLE: do-not-compile word ;
|
||||||
|
|
||||||
: check-no-compile ( word -- )
|
: check-no-compile ( word -- )
|
||||||
dup "no-compile" word-prop [ cannot-infer-effect ] [ drop ] if ;
|
dup "no-compile" word-prop [ do-not-compile inference-warning ] [ drop ] if ;
|
||||||
|
|
||||||
: build-tree-from-word ( word -- nodes )
|
: build-tree-from-word ( word -- nodes )
|
||||||
[
|
[
|
||||||
|
@ -56,3 +58,6 @@ IN: compiler.tree.builder
|
||||||
} cleave
|
} cleave
|
||||||
] maybe-cannot-infer
|
] maybe-cannot-infer
|
||||||
] with-tree-builder ;
|
] with-tree-builder ;
|
||||||
|
|
||||||
|
: contains-breakpoints? ( word -- ? )
|
||||||
|
def>> [ word? ] filter [ "break?" word-prop ] any? ;
|
||||||
|
|
|
@ -197,7 +197,7 @@ M: fixnum annotate-entry-test-1 drop ;
|
||||||
[ dup annotate-entry-test-1 1+ ] dip (annotate-entry-test-2)
|
[ dup annotate-entry-test-1 1+ ] dip (annotate-entry-test-2)
|
||||||
] if ; inline recursive
|
] if ; inline recursive
|
||||||
|
|
||||||
: annotate-entry-test-2 ( from to -- ) 0 -rot (annotate-entry-test-2) ; inline
|
: annotate-entry-test-2 ( from to -- obj ) 0 -rot (annotate-entry-test-2) ; inline
|
||||||
|
|
||||||
[ f ] [
|
[ f ] [
|
||||||
[ { bignum } declare annotate-entry-test-2 ]
|
[ { bignum } declare annotate-entry-test-2 ]
|
||||||
|
@ -302,7 +302,7 @@ cell-bits 32 = [
|
||||||
] unit-test
|
] unit-test
|
||||||
|
|
||||||
[ t ] [
|
[ t ] [
|
||||||
[ 1000 [ 1+ ] map ] { 1+ fixnum+ } inlined?
|
[ 1000 iota [ 1+ ] map ] { 1+ fixnum+ } inlined?
|
||||||
] unit-test
|
] unit-test
|
||||||
|
|
||||||
: rec ( a -- b )
|
: rec ( a -- b )
|
||||||
|
|
|
@ -17,13 +17,13 @@ sequences accessors tools.test kernel math ;
|
||||||
|
|
||||||
[ 2 ] [ [ 3 [ drop ] [ 2drop 3 ] if ] build-tree count-introductions ] unit-test
|
[ 2 ] [ [ 3 [ drop ] [ 2drop 3 ] if ] build-tree count-introductions ] unit-test
|
||||||
|
|
||||||
: foo ( -- ) swap ; inline recursive
|
: foo ( quot: ( -- ) -- ) call ; inline recursive
|
||||||
|
|
||||||
: recursive-inputs ( nodes -- n )
|
: recursive-inputs ( nodes -- n )
|
||||||
[ #recursive? ] find nip child>> first in-d>> length ;
|
[ #recursive? ] find nip child>> first in-d>> length ;
|
||||||
|
|
||||||
[ 0 2 ] [
|
[ 1 3 ] [
|
||||||
[ foo ] build-tree
|
[ [ swap ] foo ] build-tree
|
||||||
[ recursive-inputs ]
|
[ recursive-inputs ]
|
||||||
[ analyze-recursive normalize recursive-inputs ] bi
|
[ analyze-recursive normalize recursive-inputs ] bi
|
||||||
] unit-test
|
] unit-test
|
||||||
|
@ -34,18 +34,18 @@ sequences accessors tools.test kernel math ;
|
||||||
[ ] [ [ [ 1 ] [ 2 ] if + * ] test-normalization ] unit-test
|
[ ] [ [ [ 1 ] [ 2 ] if + * ] test-normalization ] unit-test
|
||||||
|
|
||||||
DEFER: bbb
|
DEFER: bbb
|
||||||
: aaa ( x -- ) dup [ dup [ bbb ] dip aaa ] [ drop ] if ; inline recursive
|
: aaa ( obj x -- obj ) dup [ dup [ bbb ] dip aaa ] [ drop ] if ; inline recursive
|
||||||
: bbb ( x -- ) [ drop 0 ] dip aaa ; inline recursive
|
: bbb ( obj x -- obj ) [ drop 0 ] dip aaa ; inline recursive
|
||||||
|
|
||||||
[ ] [ [ bbb ] test-normalization ] unit-test
|
[ ] [ [ bbb ] test-normalization ] unit-test
|
||||||
|
|
||||||
: ccc ( -- ) ccc drop 1 ; inline recursive
|
: ccc ( obj -- 1 ) ccc drop 1 ; inline recursive
|
||||||
|
|
||||||
[ ] [ [ ccc ] test-normalization ] unit-test
|
[ ] [ [ ccc ] test-normalization ] unit-test
|
||||||
|
|
||||||
DEFER: eee
|
DEFER: eee
|
||||||
: ddd ( -- ) eee ; inline recursive
|
: ddd ( a b -- a b ) eee ; inline recursive
|
||||||
: eee ( -- ) swap ddd ; inline recursive
|
: eee ( a b -- a b ) swap ddd ; inline recursive
|
||||||
|
|
||||||
[ ] [ [ eee ] test-normalization ] unit-test
|
[ ] [ [ eee ] test-normalization ] unit-test
|
||||||
|
|
||||||
|
|
|
@ -148,7 +148,11 @@ DEFER: (flat-length)
|
||||||
] sum-outputs ;
|
] sum-outputs ;
|
||||||
|
|
||||||
: should-inline? ( #call word -- ? )
|
: should-inline? ( #call word -- ? )
|
||||||
dup "inline" word-prop [ 2drop t ] [ inlining-rank 5 >= ] if ;
|
{
|
||||||
|
{ [ dup contains-breakpoints? ] [ 2drop f ] }
|
||||||
|
{ [ dup "inline" word-prop ] [ 2drop t ] }
|
||||||
|
[ inlining-rank 5 >= ]
|
||||||
|
} cond ;
|
||||||
|
|
||||||
SYMBOL: history
|
SYMBOL: history
|
||||||
|
|
||||||
|
|
|
@ -680,7 +680,7 @@ TUPLE: littledan-2 { from read-only } { to read-only } ;
|
||||||
: (littledan-3-test) ( x -- )
|
: (littledan-3-test) ( x -- )
|
||||||
length 1+ f <array> (littledan-3-test) ; inline recursive
|
length 1+ f <array> (littledan-3-test) ; inline recursive
|
||||||
|
|
||||||
: littledan-3-test ( x -- )
|
: littledan-3-test ( -- )
|
||||||
0 f <array> (littledan-3-test) ; inline
|
0 f <array> (littledan-3-test) ; inline
|
||||||
|
|
||||||
[ ] [ [ littledan-3-test ] final-classes drop ] unit-test
|
[ ] [ [ littledan-3-test ] final-classes drop ] unit-test
|
||||||
|
|
|
@ -57,7 +57,7 @@ compiler.tree.combinators ;
|
||||||
\ (each-integer) label-is-loop?
|
\ (each-integer) label-is-loop?
|
||||||
] unit-test
|
] unit-test
|
||||||
|
|
||||||
: loop-test-2 ( a -- )
|
: loop-test-2 ( a b -- a' )
|
||||||
dup [ 1+ loop-test-2 1- ] [ drop ] if ; inline recursive
|
dup [ 1+ loop-test-2 1- ] [ drop ] if ; inline recursive
|
||||||
|
|
||||||
[ t ] [
|
[ t ] [
|
||||||
|
|
|
@ -3,7 +3,7 @@ USING: sequences tools.test concurrency.exchangers
|
||||||
concurrency.count-downs concurrency.promises locals kernel
|
concurrency.count-downs concurrency.promises locals kernel
|
||||||
threads ;
|
threads ;
|
||||||
|
|
||||||
:: exchanger-test ( -- )
|
:: exchanger-test ( -- string )
|
||||||
[let |
|
[let |
|
||||||
ex [ <exchanger> ]
|
ex [ <exchanger> ]
|
||||||
c [ 2 <count-down> ]
|
c [ 2 <count-down> ]
|
||||||
|
|
|
@ -11,7 +11,7 @@ kernel threads locals accessors calendar ;
|
||||||
|
|
||||||
[ f ] [ flag-test-1 ] unit-test
|
[ f ] [ flag-test-1 ] unit-test
|
||||||
|
|
||||||
:: flag-test-2 ( -- )
|
:: flag-test-2 ( -- ? )
|
||||||
[let | f [ <flag> ] |
|
[let | f [ <flag> ] |
|
||||||
[ 1 seconds sleep f raise-flag ] "Flag test" spawn drop
|
[ 1 seconds sleep f raise-flag ] "Flag test" spawn drop
|
||||||
f lower-flag
|
f lower-flag
|
||||||
|
|
|
@ -7,6 +7,10 @@ IN: concurrency.promises
|
||||||
HELP: promise
|
HELP: promise
|
||||||
{ $class-description "The class of write-once promises." } ;
|
{ $class-description "The class of write-once promises." } ;
|
||||||
|
|
||||||
|
HELP: <promise>
|
||||||
|
{ $values { "promise" promise } }
|
||||||
|
{ $description "Creates a new promise which may be fulfilled by calling " { $link fulfill } "." } ;
|
||||||
|
|
||||||
HELP: promise-fulfilled?
|
HELP: promise-fulfilled?
|
||||||
{ $values { "promise" promise } { "?" "a boolean" } }
|
{ $values { "promise" promise } { "?" "a boolean" } }
|
||||||
{ $description "Tests if " { $link fulfill } " has previously been called on the promise, in which case " { $link ?promise } " will return immediately without blocking." } ;
|
{ $description "Tests if " { $link fulfill } " has previously been called on the promise, in which case " { $link ?promise } " will return immediately without blocking." } ;
|
||||||
|
|
|
@ -310,7 +310,7 @@ CONSTANT: rs-reg 30
|
||||||
4 ds-reg 0 LWZ
|
4 ds-reg 0 LWZ
|
||||||
5 ds-reg -4 LWZU
|
5 ds-reg -4 LWZU
|
||||||
5 0 4 CMP
|
5 0 4 CMP
|
||||||
2 swap execute ! magic number
|
2 swap execute( offset -- ) ! magic number
|
||||||
\ f tag-number 3 LI
|
\ f tag-number 3 LI
|
||||||
3 ds-reg 0 STW ;
|
3 ds-reg 0 STW ;
|
||||||
|
|
||||||
|
@ -341,7 +341,7 @@ CONSTANT: rs-reg 30
|
||||||
: jit-math ( insn -- )
|
: jit-math ( insn -- )
|
||||||
3 ds-reg 0 LWZ
|
3 ds-reg 0 LWZ
|
||||||
4 ds-reg -4 LWZU
|
4 ds-reg -4 LWZU
|
||||||
[ 5 3 4 ] dip execute
|
[ 5 3 4 ] dip execute( dst src1 src2 -- )
|
||||||
5 ds-reg 0 STW ;
|
5 ds-reg 0 STW ;
|
||||||
|
|
||||||
[ \ ADD jit-math ] f f f \ fixnum+fast define-sub-primitive
|
[ \ ADD jit-math ] f f f \ fixnum+fast define-sub-primitive
|
||||||
|
|
|
@ -334,7 +334,7 @@ big-endian off
|
||||||
! compare with second value
|
! compare with second value
|
||||||
ds-reg [] temp0 CMP
|
ds-reg [] temp0 CMP
|
||||||
! move t if true
|
! move t if true
|
||||||
[ temp1 temp3 ] dip execute
|
[ temp1 temp3 ] dip execute( dst src -- )
|
||||||
! store
|
! store
|
||||||
ds-reg [] temp1 MOV ;
|
ds-reg [] temp1 MOV ;
|
||||||
|
|
||||||
|
@ -355,7 +355,7 @@ big-endian off
|
||||||
! pop stack
|
! pop stack
|
||||||
ds-reg bootstrap-cell SUB
|
ds-reg bootstrap-cell SUB
|
||||||
! compute result
|
! compute result
|
||||||
[ ds-reg [] temp0 ] dip execute ;
|
[ ds-reg [] temp0 ] dip execute( dst src -- ) ;
|
||||||
|
|
||||||
[ \ ADD jit-math ] f f f \ fixnum+fast define-sub-primitive
|
[ \ ADD jit-math ] f f f \ fixnum+fast define-sub-primitive
|
||||||
|
|
||||||
|
|
|
@ -8,8 +8,9 @@ classes.mixin classes.tuple continuations continuations.private
|
||||||
combinators generic.math classes.builtin classes compiler.units
|
combinators generic.math classes.builtin classes compiler.units
|
||||||
generic.standard vocabs init kernel.private io.encodings
|
generic.standard vocabs init kernel.private io.encodings
|
||||||
accessors math.order destructors source-files parser
|
accessors math.order destructors source-files parser
|
||||||
classes.tuple.parser effects.parser lexer compiler.errors
|
classes.tuple.parser effects.parser lexer
|
||||||
generic.parser strings.parser vocabs.loader vocabs.parser ;
|
generic.parser strings.parser vocabs.loader vocabs.parser see
|
||||||
|
source-files.errors ;
|
||||||
IN: debugger
|
IN: debugger
|
||||||
|
|
||||||
GENERIC: error. ( error -- )
|
GENERIC: error. ( error -- )
|
||||||
|
@ -213,14 +214,13 @@ M: condition error-help error>> error-help ;
|
||||||
|
|
||||||
M: assert summary drop "Assertion failed" ;
|
M: assert summary drop "Assertion failed" ;
|
||||||
|
|
||||||
M: assert error.
|
M: assert-sequence summary drop "Assertion failed" ;
|
||||||
"Assertion failed" print
|
|
||||||
|
M: assert-sequence error.
|
||||||
standard-table-style [
|
standard-table-style [
|
||||||
15 length-limit set
|
[ "=== Expected:" print expected>> stack. ]
|
||||||
5 line-limit set
|
[ "=== Got:" print got>> stack. ] bi
|
||||||
[ expect>> [ [ "Expect:" write ] with-cell pprint-cell ] with-row ]
|
] tabular-output ;
|
||||||
[ got>> [ [ "Got:" write ] with-cell pprint-cell ] with-row ] bi
|
|
||||||
] tabular-output nl ;
|
|
||||||
|
|
||||||
M: immutable summary drop "Sequence is immutable" ;
|
M: immutable summary drop "Sequence is immutable" ;
|
||||||
|
|
||||||
|
@ -268,20 +268,6 @@ M: duplicate-slot-names summary
|
||||||
M: invalid-slot-name summary
|
M: invalid-slot-name summary
|
||||||
drop "Invalid slot name" ;
|
drop "Invalid slot name" ;
|
||||||
|
|
||||||
: file. ( file -- ) path>> <pathname> . ;
|
|
||||||
|
|
||||||
M: source-file-error error.
|
|
||||||
[ file>> file. ] [ error>> error. ] bi ;
|
|
||||||
|
|
||||||
M: source-file-error summary
|
|
||||||
error>> summary ;
|
|
||||||
|
|
||||||
M: source-file-error compute-restarts
|
|
||||||
error>> compute-restarts ;
|
|
||||||
|
|
||||||
M: source-file-error error-help
|
|
||||||
error>> error-help ;
|
|
||||||
|
|
||||||
M: not-in-a-method-error summary
|
M: not-in-a-method-error summary
|
||||||
drop "call-next-method can only be called in a method definition" ;
|
drop "call-next-method can only be called in a method definition" ;
|
||||||
|
|
||||||
|
@ -309,12 +295,6 @@ M: lexer-error compute-restarts
|
||||||
M: lexer-error error-help
|
M: lexer-error error-help
|
||||||
error>> error-help ;
|
error>> error-help ;
|
||||||
|
|
||||||
M: object compiler-error. ( error word -- )
|
|
||||||
nl
|
|
||||||
"While compiling " write pprint ": " print
|
|
||||||
nl
|
|
||||||
print-error ;
|
|
||||||
|
|
||||||
M: bad-effect summary
|
M: bad-effect summary
|
||||||
drop "Bad stack effect declaration" ;
|
drop "Bad stack effect declaration" ;
|
||||||
|
|
||||||
|
|
|
@ -35,7 +35,7 @@ M: hello bing hello-test ;
|
||||||
[ 3 ] [ 1 0 <hello> 2 whoa ] unit-test
|
[ 3 ] [ 1 0 <hello> 2 whoa ] unit-test
|
||||||
[ 3 ] [ 1 0 <hello> f <goodbye> 2 whoa ] unit-test
|
[ 3 ] [ 1 0 <hello> f <goodbye> 2 whoa ] unit-test
|
||||||
|
|
||||||
[ ] [ 3 [ "USING: accessors delegate ; IN: delegate.tests CONSULT: baz goodbye these>> ;" eval ] times ] unit-test
|
[ ] [ 3 [ "USING: accessors delegate ; IN: delegate.tests CONSULT: baz goodbye these>> ;" eval( -- ) ] times ] unit-test
|
||||||
[ H{ { goodbye T{ consultation f baz goodbye [ these>> ] } } } ] [ baz protocol-consult ] unit-test
|
[ H{ { goodbye T{ consultation f baz goodbye [ these>> ] } } } ] [ baz protocol-consult ] unit-test
|
||||||
[ H{ } ] [ bee protocol-consult ] unit-test
|
[ H{ } ] [ bee protocol-consult ] unit-test
|
||||||
|
|
||||||
|
@ -63,22 +63,22 @@ CONSULT: beta hey value>> 1- ;
|
||||||
[ 0 ] [ 1 <hey> three ] unit-test
|
[ 0 ] [ 1 <hey> three ] unit-test
|
||||||
[ { hey } ] [ alpha protocol-users ] unit-test
|
[ { hey } ] [ alpha protocol-users ] unit-test
|
||||||
[ { hey } ] [ beta protocol-users ] unit-test
|
[ { hey } ] [ beta protocol-users ] unit-test
|
||||||
[ ] [ "USE: delegate IN: delegate.tests PROTOCOL: alpha one ;" eval ] unit-test
|
[ ] [ "USE: delegate IN: delegate.tests PROTOCOL: alpha one ;" eval( -- ) ] unit-test
|
||||||
[ f ] [ hey \ two method ] unit-test
|
[ f ] [ hey \ two method ] unit-test
|
||||||
[ f ] [ hey \ four method ] unit-test
|
[ f ] [ hey \ four method ] unit-test
|
||||||
[ ] [ "USE: delegate IN: delegate.tests PROTOCOL: beta two three four ;" eval ] unit-test
|
[ ] [ "USE: delegate IN: delegate.tests PROTOCOL: beta two three four ;" eval( -- ) ] unit-test
|
||||||
[ { hey } ] [ alpha protocol-users ] unit-test
|
[ { hey } ] [ alpha protocol-users ] unit-test
|
||||||
[ { hey } ] [ beta protocol-users ] unit-test
|
[ { hey } ] [ beta protocol-users ] unit-test
|
||||||
[ 2 ] [ 1 <hey> one ] unit-test
|
[ 2 ] [ 1 <hey> one ] unit-test
|
||||||
[ 0 ] [ 1 <hey> two ] unit-test
|
[ 0 ] [ 1 <hey> two ] unit-test
|
||||||
[ 0 ] [ 1 <hey> three ] unit-test
|
[ 0 ] [ 1 <hey> three ] unit-test
|
||||||
[ 0 ] [ 1 <hey> four ] unit-test
|
[ 0 ] [ 1 <hey> four ] unit-test
|
||||||
[ ] [ "USING: math accessors delegate ; IN: delegate.tests CONSULT: beta hey value>> 2 - ;" eval ] unit-test
|
[ ] [ "USING: math accessors delegate ; IN: delegate.tests CONSULT: beta hey value>> 2 - ;" eval( -- ) ] unit-test
|
||||||
[ 2 ] [ 1 <hey> one ] unit-test
|
[ 2 ] [ 1 <hey> one ] unit-test
|
||||||
[ -1 ] [ 1 <hey> two ] unit-test
|
[ -1 ] [ 1 <hey> two ] unit-test
|
||||||
[ -1 ] [ 1 <hey> three ] unit-test
|
[ -1 ] [ 1 <hey> three ] unit-test
|
||||||
[ -1 ] [ 1 <hey> four ] unit-test
|
[ -1 ] [ 1 <hey> four ] unit-test
|
||||||
[ ] [ "IN: delegate.tests FORGET: alpha" eval ] unit-test
|
[ ] [ "IN: delegate.tests FORGET: alpha" eval( -- ) ] unit-test
|
||||||
[ f ] [ hey \ one method ] unit-test
|
[ f ] [ hey \ one method ] unit-test
|
||||||
|
|
||||||
TUPLE: slot-protocol-test-1 a b ;
|
TUPLE: slot-protocol-test-1 a b ;
|
||||||
|
|
|
@ -1,4 +1,5 @@
|
||||||
USING: help.markup help.syntax parser source-files vocabs.loader ;
|
USING: help.markup help.syntax parser source-files
|
||||||
|
source-files.errors vocabs.loader ;
|
||||||
IN: editors
|
IN: editors
|
||||||
|
|
||||||
ARTICLE: "editor" "Editor integration"
|
ARTICLE: "editor" "Editor integration"
|
||||||
|
@ -13,6 +14,9 @@ ARTICLE: "editor" "Editor integration"
|
||||||
|
|
||||||
ABOUT: "editor"
|
ABOUT: "editor"
|
||||||
|
|
||||||
|
HELP: edit-hook
|
||||||
|
{ $var-description "A quotation with stack effect " { $snippet "( file line -- )" } ". If not set, the " { $link edit } " word throws a condition with restarts for loading one of the sub-vocabularies of the " { $vocab-link "editors" } " vocabulary." } ;
|
||||||
|
|
||||||
HELP: edit
|
HELP: edit
|
||||||
{ $values { "defspec" "a definition specifier" } }
|
{ $values { "defspec" "a definition specifier" } }
|
||||||
{ $description "Opens the source file containing the definition using the current " { $link edit-hook } ". See " { $link "editor" } "." }
|
{ $description "Opens the source file containing the definition using the current " { $link edit-hook } ". See " { $link "editor" } "." }
|
||||||
|
|
|
@ -1,8 +1,8 @@
|
||||||
! Copyright (C) 2005, 2009 Slava Pestov.
|
! Copyright (C) 2005, 2009 Slava Pestov.
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
USING: parser lexer kernel namespaces sequences definitions
|
USING: parser lexer kernel namespaces sequences definitions io.files
|
||||||
io.files io.backend io.pathnames io summary continuations
|
io.backend io.pathnames io summary continuations tools.crossref
|
||||||
tools.crossref tools.vocabs prettyprint source-files assocs
|
tools.vocabs prettyprint source-files source-files.errors assocs
|
||||||
vocabs vocabs.loader splitting accessors debugger prettyprint
|
vocabs vocabs.loader splitting accessors debugger prettyprint
|
||||||
help.topics ;
|
help.topics ;
|
||||||
IN: editors
|
IN: editors
|
||||||
|
@ -57,7 +57,7 @@ M: lexer-error error-line
|
||||||
[ error>> error-line ] [ line>> ] bi or ;
|
[ error>> error-line ] [ line>> ] bi or ;
|
||||||
|
|
||||||
M: source-file-error error-file
|
M: source-file-error error-file
|
||||||
[ error>> error-file ] [ file>> path>> ] bi or ;
|
[ error>> error-file ] [ file>> ] bi or ;
|
||||||
|
|
||||||
M: source-file-error error-line
|
M: source-file-error error-line
|
||||||
error>> error-line ;
|
error>> error-line ;
|
||||||
|
@ -81,6 +81,9 @@ M: object error-line
|
||||||
: :edit ( -- )
|
: :edit ( -- )
|
||||||
error get (:edit) ;
|
error get (:edit) ;
|
||||||
|
|
||||||
|
: edit-error ( error -- )
|
||||||
|
[ file>> ] [ line#>> ] bi 2dup and [ edit-location ] [ 2drop ] if ;
|
||||||
|
|
||||||
: edit-each ( seq -- )
|
: edit-each ( seq -- )
|
||||||
[
|
[
|
||||||
[ "Editing " write . ]
|
[ "Editing " write . ]
|
||||||
|
|
|
@ -0,0 +1 @@
|
||||||
|
Doug Coleman
|
|
@ -0,0 +1,17 @@
|
||||||
|
! Copyright (C) 2008 Doug Coleman.
|
||||||
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
|
USING: editors io.launcher kernel make math.parser namespaces
|
||||||
|
sequences ;
|
||||||
|
IN: editors.gedit
|
||||||
|
|
||||||
|
: gedit-path ( -- path )
|
||||||
|
\ gedit-path get-global [
|
||||||
|
"gedit"
|
||||||
|
] unless* ;
|
||||||
|
|
||||||
|
: gedit ( file line -- )
|
||||||
|
[
|
||||||
|
gedit-path , number>string "+" prepend , ,
|
||||||
|
] { } make run-detached drop ;
|
||||||
|
|
||||||
|
[ gedit ] edit-hook set-global
|
|
@ -0,0 +1 @@
|
||||||
|
gedit integration
|
|
@ -0,0 +1 @@
|
||||||
|
unportable
|
|
@ -1,18 +1,23 @@
|
||||||
IN: eval
|
IN: eval
|
||||||
USING: help.markup help.syntax strings io ;
|
USING: help.markup help.syntax strings io effects ;
|
||||||
|
|
||||||
HELP: eval
|
HELP: eval
|
||||||
{ $values { "str" string } }
|
{ $values { "str" string } { "effect" effect } }
|
||||||
{ $description "Parses Factor source code from a string, and calls the resulting quotation." }
|
{ $description "Parses Factor source code from a string, and calls the resulting quotation, which must have the given stack effect." }
|
||||||
|
{ $errors "Throws an error if the input is malformed, or if the evaluation itself throws an error." } ;
|
||||||
|
|
||||||
|
HELP: eval(
|
||||||
|
{ $syntax "eval( inputs -- outputs )" }
|
||||||
|
{ $description "Parses Factor source code from the string at the top of the stack, and calls the resulting quotation, which must have the given stack effect." }
|
||||||
{ $errors "Throws an error if the input is malformed, or if the evaluation itself throws an error." } ;
|
{ $errors "Throws an error if the input is malformed, or if the evaluation itself throws an error." } ;
|
||||||
|
|
||||||
HELP: eval>string
|
HELP: eval>string
|
||||||
{ $values { "str" string } { "output" string } }
|
{ $values { "str" string } { "output" string } }
|
||||||
{ $description "Evaluates the Factor code in " { $snippet "str" } " with " { $link output-stream } " rebound to a string output stream, then outputs the resulting string." } ;
|
{ $description "Evaluates the Factor code in " { $snippet "str" } " with " { $link output-stream } " rebound to a string output stream, then outputs the resulting string. The code in the string must not take or leave any values on the stack." } ;
|
||||||
|
|
||||||
ARTICLE: "eval" "Evaluating strings at runtime"
|
ARTICLE: "eval" "Evaluating strings at runtime"
|
||||||
"The " { $vocab-link "eval" } " vocabulary implements support for evaluating strings at runtime."
|
"The " { $vocab-link "eval" } " vocabulary implements support for evaluating strings at runtime."
|
||||||
{ $subsection eval }
|
{ $subsection POSTPONE: eval( }
|
||||||
{ $subsection eval>string } ;
|
{ $subsection eval>string } ;
|
||||||
|
|
||||||
ABOUT: "eval"
|
ABOUT: "eval"
|
||||||
|
|
|
@ -1,4 +1,6 @@
|
||||||
IN: eval.tests
|
IN: eval.tests
|
||||||
USING: eval tools.test ;
|
USING: eval tools.test ;
|
||||||
|
|
||||||
|
[ 4 ] [ "USE: math 2 2 +" eval( -- result ) ] unit-test
|
||||||
|
[ "USE: math 2 2 +" eval( -- ) ] must-fail
|
||||||
[ "4\n" ] [ "USING: math prettyprint ; 2 2 + ." eval>string ] unit-test
|
[ "4\n" ] [ "USING: math prettyprint ; 2 2 + ." eval>string ] unit-test
|
||||||
|
|
|
@ -1,23 +1,25 @@
|
||||||
! Copyright (C) 2008, 2009 Slava Pestov.
|
! Copyright (C) 2008, 2009 Slava Pestov.
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
USING: splitting parser compiler.units kernel namespaces
|
USING: splitting parser compiler.units kernel namespaces
|
||||||
debugger io.streams.string fry ;
|
debugger io.streams.string fry combinators effects.parser ;
|
||||||
IN: eval
|
IN: eval
|
||||||
|
|
||||||
: parse-string ( str -- quot )
|
: parse-string ( str -- quot )
|
||||||
[ string-lines parse-lines ] with-compilation-unit ;
|
[ string-lines parse-lines ] with-compilation-unit ;
|
||||||
|
|
||||||
: (eval) ( str -- )
|
: (eval) ( str effect -- )
|
||||||
parse-string call ;
|
[ parse-string ] dip call-effect ; inline
|
||||||
|
|
||||||
: eval ( str -- )
|
: eval ( str effect -- )
|
||||||
[ (eval) ] with-file-vocabs ;
|
[ (eval) ] with-file-vocabs ; inline
|
||||||
|
|
||||||
|
SYNTAX: eval( \ eval parse-call( ;
|
||||||
|
|
||||||
: (eval>string) ( str -- output )
|
: (eval>string) ( str -- output )
|
||||||
[
|
[
|
||||||
"quiet" on
|
"quiet" on
|
||||||
parser-notes off
|
parser-notes off
|
||||||
'[ _ (eval) ] try
|
'[ _ (( -- )) (eval) ] try
|
||||||
] with-string-writer ;
|
] with-string-writer ;
|
||||||
|
|
||||||
: eval>string ( str -- output )
|
: eval>string ( str -- output )
|
||||||
|
|
|
@ -56,7 +56,7 @@ sequences eval accessors ;
|
||||||
3 '[ [ [ _ 1array ] call 1array ] call 1array ] call
|
3 '[ [ [ _ 1array ] call 1array ] call 1array ] call
|
||||||
] unit-test
|
] unit-test
|
||||||
|
|
||||||
[ "USING: fry locals.backend ; f '[ load-local _ ]" eval ]
|
[ "USING: fry locals.backend ; f '[ load-local _ ]" eval( -- quot ) ]
|
||||||
[ error>> >r/r>-in-fry-error? ] must-fail-with
|
[ error>> >r/r>-in-fry-error? ] must-fail-with
|
||||||
|
|
||||||
[ { { "a" 1 } { "b" 2 } { "c" 3 } { "d" 4 } } ] [
|
[ { { "a" 1 } { "b" 2 } { "c" 3 } { "d" 4 } } ] [
|
||||||
|
|
|
@ -22,7 +22,7 @@ M: foo call-responder*
|
||||||
"x" [ 1+ ] schange
|
"x" [ 1+ ] schange
|
||||||
"x" sget number>string "text/html" <content> ;
|
"x" sget number>string "text/html" <content> ;
|
||||||
|
|
||||||
: url-responder-mock-test ( -- )
|
: url-responder-mock-test ( -- string )
|
||||||
[
|
[
|
||||||
<request>
|
<request>
|
||||||
"GET" >>method
|
"GET" >>method
|
||||||
|
@ -34,7 +34,7 @@ M: foo call-responder*
|
||||||
[ write-response-body drop ] with-string-writer
|
[ write-response-body drop ] with-string-writer
|
||||||
] with-destructors ;
|
] with-destructors ;
|
||||||
|
|
||||||
: sessions-mock-test ( -- )
|
: sessions-mock-test ( -- string )
|
||||||
[
|
[
|
||||||
<request>
|
<request>
|
||||||
"GET" >>method
|
"GET" >>method
|
||||||
|
|
|
@ -272,8 +272,8 @@ HELP: nweave
|
||||||
|
|
||||||
HELP: n*quot
|
HELP: n*quot
|
||||||
{ $values
|
{ $values
|
||||||
{ "n" integer } { "seq" sequence }
|
{ "n" integer } { "quot" quotation }
|
||||||
{ "seq'" sequence }
|
{ "quot'" quotation }
|
||||||
}
|
}
|
||||||
{ $examples
|
{ $examples
|
||||||
{ $example "USING: generalizations prettyprint math ;"
|
{ $example "USING: generalizations prettyprint math ;"
|
||||||
|
|
|
@ -7,7 +7,7 @@ IN: generalizations
|
||||||
|
|
||||||
<<
|
<<
|
||||||
|
|
||||||
: n*quot ( n seq -- seq' ) <repetition> concat >quotation ;
|
: n*quot ( n quot -- quot' ) <repetition> concat >quotation ;
|
||||||
|
|
||||||
: repeat ( n obj quot -- ) swapd times ; inline
|
: repeat ( n obj quot -- ) swapd times ; inline
|
||||||
|
|
||||||
|
|
|
@ -4,11 +4,11 @@ IN: hash2.tests
|
||||||
[ t ] [ 1 2 { 1 2 } 2= ] unit-test
|
[ t ] [ 1 2 { 1 2 } 2= ] unit-test
|
||||||
[ f ] [ 1 3 { 1 2 } 2= ] unit-test
|
[ f ] [ 1 3 { 1 2 } 2= ] unit-test
|
||||||
|
|
||||||
: sample-hash ( -- )
|
: sample-hash ( -- hash )
|
||||||
5 <hash2>
|
5 <hash2>
|
||||||
dup 2 3 "foo" roll set-hash2
|
[ [ 2 3 "foo" ] dip set-hash2 ] keep
|
||||||
dup 4 2 "bar" roll set-hash2
|
[ [ 4 2 "bar" ] dip set-hash2 ] keep
|
||||||
dup 4 7 "other" roll set-hash2 ;
|
[ [ 4 7 "other" ] dip set-hash2 ] keep ;
|
||||||
|
|
||||||
[ "foo" ] [ 2 3 sample-hash hash2 ] unit-test
|
[ "foo" ] [ 2 3 sample-hash hash2 ] unit-test
|
||||||
[ "bar" ] [ 4 2 sample-hash hash2 ] unit-test
|
[ "bar" ] [ 4 2 sample-hash hash2 ] unit-test
|
||||||
|
|
|
@ -1,4 +1,6 @@
|
||||||
USING: kernel sequences arrays math vectors ;
|
! Copyright (C) 2007 Daniel Ehrenberg
|
||||||
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
|
USING: kernel sequences arrays math vectors locals ;
|
||||||
IN: hash2
|
IN: hash2
|
||||||
|
|
||||||
! Little ad-hoc datastructure used to map two numbers
|
! Little ad-hoc datastructure used to map two numbers
|
||||||
|
@ -22,8 +24,8 @@ IN: hash2
|
||||||
: assoc2 ( a b alist -- value )
|
: assoc2 ( a b alist -- value )
|
||||||
(assoc2) dup [ third ] when ; inline
|
(assoc2) dup [ third ] when ; inline
|
||||||
|
|
||||||
: set-assoc2 ( value a b alist -- alist )
|
:: set-assoc2 ( value a b alist -- alist )
|
||||||
[ rot 3array ] dip ?push ; inline
|
{ a b value } alist ?push ; inline
|
||||||
|
|
||||||
: hash2@ ( a b hash2 -- a b bucket hash2 )
|
: hash2@ ( a b hash2 -- a b bucket hash2 )
|
||||||
[ 2dup hashcode2 ] dip [ length mod ] keep ; inline
|
[ 2dup hashcode2 ] dip [ length mod ] keep ; inline
|
||||||
|
@ -31,8 +33,8 @@ IN: hash2
|
||||||
: hash2 ( a b hash2 -- value/f )
|
: hash2 ( a b hash2 -- value/f )
|
||||||
hash2@ nth dup [ assoc2 ] [ 3drop f ] if ;
|
hash2@ nth dup [ assoc2 ] [ 3drop f ] if ;
|
||||||
|
|
||||||
: set-hash2 ( a b value hash2 -- )
|
:: set-hash2 ( a b value hash2 -- )
|
||||||
[ -rot ] dip hash2@ [ set-assoc2 ] change-nth ;
|
value a b hash2 hash2@ [ set-assoc2 ] change-nth ;
|
||||||
|
|
||||||
: alist>hash2 ( alist size -- hash2 )
|
: alist>hash2 ( alist size -- hash2 )
|
||||||
<hash2> [ over [ first3 ] dip set-hash2 ] reduce ; inline
|
<hash2> [ over [ first3 ] dip set-hash2 ] reduce ; inline
|
||||||
|
|
|
@ -54,7 +54,7 @@ IN: heaps.tests
|
||||||
: sort-entries ( entries -- entries' )
|
: sort-entries ( entries -- entries' )
|
||||||
[ [ key>> ] compare ] sort ;
|
[ [ key>> ] compare ] sort ;
|
||||||
|
|
||||||
: delete-test ( n -- ? )
|
: delete-test ( n -- obj1 obj2 )
|
||||||
[
|
[
|
||||||
random-alist
|
random-alist
|
||||||
<min-heap> [ heap-push-all ] keep
|
<min-heap> [ heap-push-all ] keep
|
||||||
|
|
|
@ -74,7 +74,7 @@ $nl
|
||||||
"shuffle-words"
|
"shuffle-words"
|
||||||
"words"
|
"words"
|
||||||
"generic"
|
"generic"
|
||||||
"tools"
|
"handbook-tools-reference"
|
||||||
} ;
|
} ;
|
||||||
|
|
||||||
ARTICLE: "cookbook-combinators" "Control flow cookbook"
|
ARTICLE: "cookbook-combinators" "Control flow cookbook"
|
||||||
|
|
|
@ -4,7 +4,7 @@ definitions assocs sequences kernel namespaces parser arrays
|
||||||
io.streams.string continuations debugger compiler.units eval ;
|
io.streams.string continuations debugger compiler.units eval ;
|
||||||
|
|
||||||
[ ] [
|
[ ] [
|
||||||
"IN: help.crossref.tests USING: help.syntax help.markup ; : foo ( -- ) ; HELP: foo \"foo is great\" ; ARTICLE: \"foo\" \"Foo\" { $subsection foo } ;" eval
|
"IN: help.crossref.tests USING: help.syntax help.markup ; : foo ( -- ) ; HELP: foo \"foo is great\" ; ARTICLE: \"foo\" \"Foo\" { $subsection foo } ;" eval( -- )
|
||||||
] unit-test
|
] unit-test
|
||||||
|
|
||||||
[ $subsection ] [
|
[ $subsection ] [
|
||||||
|
@ -23,7 +23,7 @@ io.streams.string continuations debugger compiler.units eval ;
|
||||||
] unit-test
|
] unit-test
|
||||||
|
|
||||||
[ ] [
|
[ ] [
|
||||||
"IN: help.crossref.tests USING: help.syntax help.markup ; : bar ( -- ) ; HELP: bar \"bar is great\" ; ARTICLE: \"bar\" \"Bar\" { $subsection bar } ;" eval
|
"IN: help.crossref.tests USING: help.syntax help.markup ; : bar ( -- ) ; HELP: bar \"bar is great\" ; ARTICLE: \"bar\" \"Bar\" { $subsection bar } ;" eval( -- )
|
||||||
] unit-test
|
] unit-test
|
||||||
|
|
||||||
[ ] [
|
[ ] [
|
||||||
|
|
|
@ -32,7 +32,7 @@ IN: help.definitions.tests
|
||||||
"hello" "help.definitions.tests" lookup "help" word-prop
|
"hello" "help.definitions.tests" lookup "help" word-prop
|
||||||
] unit-test
|
] unit-test
|
||||||
|
|
||||||
[ ] [ "IN: help.definitions.tests USING: help.syntax ; : xxx ( -- ) ; HELP: xxx ;" eval ] unit-test
|
[ ] [ "IN: help.definitions.tests USING: help.syntax ; : xxx ( -- ) ; HELP: xxx ;" eval( -- ) ] unit-test
|
||||||
|
|
||||||
[ ] [ "xxx" "help.definitions.tests" lookup print-topic ] unit-test
|
[ ] [ "xxx" "help.definitions.tests" lookup print-topic ] unit-test
|
||||||
|
|
||||||
|
|
|
@ -5,7 +5,7 @@ math system strings sbufs vectors byte-arrays quotations
|
||||||
io.streams.byte-array classes.builtin parser lexer
|
io.streams.byte-array classes.builtin parser lexer
|
||||||
classes.predicate classes.union classes.intersection
|
classes.predicate classes.union classes.intersection
|
||||||
classes.singleton classes.tuple help.vocabs math.parser
|
classes.singleton classes.tuple help.vocabs math.parser
|
||||||
accessors definitions ;
|
accessors definitions sets ;
|
||||||
IN: help.handbook
|
IN: help.handbook
|
||||||
|
|
||||||
ARTICLE: "conventions" "Conventions"
|
ARTICLE: "conventions" "Conventions"
|
||||||
|
@ -13,13 +13,13 @@ ARTICLE: "conventions" "Conventions"
|
||||||
{ $heading "Documentation conventions" }
|
{ $heading "Documentation conventions" }
|
||||||
"Factor documentation consists of two distinct bodies of text. There is a hierarchy of articles, much like this one, and there is word documentation. Help articles reference word documentation, and vice versa, but not every documented word is referenced from some help article."
|
"Factor documentation consists of two distinct bodies of text. There is a hierarchy of articles, much like this one, and there is word documentation. Help articles reference word documentation, and vice versa, but not every documented word is referenced from some help article."
|
||||||
$nl
|
$nl
|
||||||
"Every article has links to parent articles at the top. These can be persued if the article is too specific."
|
"Every article has links to parent articles at the top. Explore these if the article you are reading is too specific."
|
||||||
$nl
|
$nl
|
||||||
"Some generic words have " { $strong "Description" } " headings, and others have " { $strong "Contract" } " headings. A distinction is made between words which are not intended to be extended with user-defined methods, and those that are."
|
"Some generic words have " { $strong "Description" } " headings, and others have " { $strong "Contract" } " headings. A distinction is made between words which are not intended to be extended with user-defined methods, and those that are."
|
||||||
{ $heading "Vocabulary naming conventions" }
|
{ $heading "Vocabulary naming conventions" }
|
||||||
"A vocabulary name ending in " { $snippet ".private" } " contains words which are either implementation detail, unsafe, or both. For example, the " { $snippet "sequence.private" } " vocabulary contains words which access sequence elements without bounds checking (" { $link "sequences-unsafe" } ")."
|
"A vocabulary name ending in " { $snippet ".private" } " contains words which are either implementation detail, unsafe, or both. For example, the " { $snippet "sequence.private" } " vocabulary contains words which access sequence elements without bounds checking (" { $link "sequences-unsafe" } ")."
|
||||||
$nl
|
$nl
|
||||||
"You should should avoid using internal words from the Factor library unless absolutely necessary. Similarly, your own code can place words in internal vocabularies if you do not want other people to use them unless they have a good reason."
|
"You should avoid using internal words from the Factor library unless absolutely necessary. Similarly, your own code can place words in internal vocabularies if you do not want other people to use them unless they have a good reason."
|
||||||
{ $heading "Word naming conventions" }
|
{ $heading "Word naming conventions" }
|
||||||
"These conventions are not hard and fast, but are usually a good first step in understanding a word's behavior:"
|
"These conventions are not hard and fast, but are usually a good first step in understanding a word's behavior:"
|
||||||
{ $table
|
{ $table
|
||||||
|
@ -197,29 +197,6 @@ ARTICLE: "io" "Input and output"
|
||||||
{ $subsection "io.ports" }
|
{ $subsection "io.ports" }
|
||||||
{ $see-also "destructors" } ;
|
{ $see-also "destructors" } ;
|
||||||
|
|
||||||
ARTICLE: "tools" "Developer tools"
|
|
||||||
{ $subsection "tools.vocabs" }
|
|
||||||
"Exploratory tools:"
|
|
||||||
{ $subsection "see" }
|
|
||||||
{ $subsection "editor" }
|
|
||||||
{ $subsection "listener" }
|
|
||||||
{ $subsection "tools.crossref" }
|
|
||||||
{ $subsection "inspector" }
|
|
||||||
{ $subsection "tools.completion" }
|
|
||||||
{ $subsection "summary" }
|
|
||||||
"Debugging tools:"
|
|
||||||
{ $subsection "tools.annotations" }
|
|
||||||
{ $subsection "tools.test" }
|
|
||||||
{ $subsection "tools.threads" }
|
|
||||||
"Performance tools:"
|
|
||||||
{ $subsection "tools.memory" }
|
|
||||||
{ $subsection "profiling" }
|
|
||||||
{ $subsection "timing" }
|
|
||||||
{ $subsection "tools.disassembler" }
|
|
||||||
"Deployment tools:"
|
|
||||||
{ $subsection "tools.deploy" }
|
|
||||||
{ $see-also "ui-tools" } ;
|
|
||||||
|
|
||||||
ARTICLE: "article-index" "Article index"
|
ARTICLE: "article-index" "Article index"
|
||||||
{ $index [ articles get keys ] } ;
|
{ $index [ articles get keys ] } ;
|
||||||
|
|
||||||
|
@ -248,59 +225,79 @@ ARTICLE: "class-index" "Class index"
|
||||||
|
|
||||||
USING: help.cookbook help.tutorial ;
|
USING: help.cookbook help.tutorial ;
|
||||||
|
|
||||||
ARTICLE: "handbook-language-reference" "Language reference"
|
ARTICLE: "handbook-language-reference" "The language"
|
||||||
"Fundamentals:"
|
{ $heading "Fundamentals" }
|
||||||
{ $subsection "conventions" }
|
{ $subsection "conventions" }
|
||||||
{ $subsection "syntax" }
|
{ $subsection "syntax" }
|
||||||
{ $subsection "effects" }
|
{ $subsection "effects" }
|
||||||
"Data types:"
|
{ $subsection "evaluator" }
|
||||||
|
{ $heading "Data types" }
|
||||||
{ $subsection "booleans" }
|
{ $subsection "booleans" }
|
||||||
{ $subsection "numbers" }
|
{ $subsection "numbers" }
|
||||||
{ $subsection "collections" }
|
{ $subsection "collections" }
|
||||||
"Evaluation semantics:"
|
{ $heading "Evaluation" }
|
||||||
{ $subsection "evaluator" }
|
|
||||||
{ $subsection "words" }
|
{ $subsection "words" }
|
||||||
{ $subsection "shuffle-words" }
|
{ $subsection "shuffle-words" }
|
||||||
{ $subsection "combinators" }
|
{ $subsection "combinators" }
|
||||||
{ $subsection "errors" }
|
{ $subsection "errors" }
|
||||||
{ $subsection "continuations" }
|
{ $subsection "continuations" }
|
||||||
"Named values:"
|
{ $heading "Named values" }
|
||||||
{ $subsection "locals" }
|
{ $subsection "locals" }
|
||||||
{ $subsection "namespaces" }
|
{ $subsection "namespaces" }
|
||||||
{ $subsection "namespaces-global" }
|
{ $subsection "namespaces-global" }
|
||||||
{ $subsection "values" }
|
{ $subsection "values" }
|
||||||
"Abstractions:"
|
{ $heading "Abstractions" }
|
||||||
{ $subsection "objects" }
|
{ $subsection "objects" }
|
||||||
{ $subsection "destructors" }
|
{ $subsection "destructors" }
|
||||||
{ $subsection "macros" }
|
{ $subsection "macros" }
|
||||||
{ $subsection "fry" }
|
{ $subsection "fry" }
|
||||||
"Program organization:"
|
{ $heading "Program organization" }
|
||||||
{ $subsection "vocabs.loader" }
|
{ $subsection "vocabs.loader" }
|
||||||
"Vocabularies tagged " { $link T{ vocab-tag { name "extensions" } } } " implement various additional language abstractions." ;
|
"Vocabularies tagged " { $link T{ vocab-tag { name "extensions" } } } " implement various additional language abstractions." ;
|
||||||
|
|
||||||
ARTICLE: "handbook-environment-reference" "Environment reference"
|
ARTICLE: "handbook-system-reference" "The implementation"
|
||||||
"Parse time and compile time:"
|
{ $heading "Parse time and compile time" }
|
||||||
{ $subsection "parser" }
|
{ $subsection "parser" }
|
||||||
{ $subsection "definitions" }
|
{ $subsection "definitions" }
|
||||||
{ $subsection "vocabularies" }
|
{ $subsection "vocabularies" }
|
||||||
{ $subsection "source-files" }
|
{ $subsection "source-files" }
|
||||||
{ $subsection "compiler" }
|
{ $subsection "compiler" }
|
||||||
"Tools:"
|
{ $heading "Virtual machine" }
|
||||||
{ $subsection "prettyprint" }
|
|
||||||
{ $subsection "tools" }
|
|
||||||
{ $subsection "help" }
|
|
||||||
{ $subsection "inference" }
|
|
||||||
{ $subsection "images" }
|
{ $subsection "images" }
|
||||||
"VM:"
|
|
||||||
{ $subsection "cli" }
|
{ $subsection "cli" }
|
||||||
{ $subsection "rc-files" }
|
{ $subsection "rc-files" }
|
||||||
{ $subsection "init" }
|
{ $subsection "init" }
|
||||||
{ $subsection "system" }
|
{ $subsection "system" }
|
||||||
{ $subsection "layouts" } ;
|
{ $subsection "layouts" } ;
|
||||||
|
|
||||||
ARTICLE: "handbook-library-reference" "Library reference"
|
ARTICLE: "handbook-tools-reference" "Developer tools"
|
||||||
"This index only includes articles from loaded vocabularies. To explore more vocabularies, see " { $link "vocab-index" } "."
|
"The below tools are text-based. " { $link "ui-tools" } " are documented separately."
|
||||||
{ $index [ "handbook" orphan-articles remove ] } ;
|
{ $heading "Workflow" }
|
||||||
|
{ $subsection "listener" }
|
||||||
|
{ $subsection "editor" }
|
||||||
|
{ $subsection "tools.vocabs" }
|
||||||
|
{ $subsection "tools.test" }
|
||||||
|
{ $subsection "help" }
|
||||||
|
{ $heading "Debugging" }
|
||||||
|
{ $subsection "prettyprint" }
|
||||||
|
{ $subsection "inspector" }
|
||||||
|
{ $subsection "tools.annotations" }
|
||||||
|
{ $subsection "inference" }
|
||||||
|
{ $heading "Browsing" }
|
||||||
|
{ $subsection "see" }
|
||||||
|
{ $subsection "tools.crossref" }
|
||||||
|
{ $heading "Performance" }
|
||||||
|
{ $subsection "timing" }
|
||||||
|
{ $subsection "profiling" }
|
||||||
|
{ $subsection "tools.memory" }
|
||||||
|
{ $subsection "tools.threads" }
|
||||||
|
{ $subsection "tools.disassembler" }
|
||||||
|
{ $heading "Deployment" }
|
||||||
|
{ $subsection "tools.deploy" } ;
|
||||||
|
|
||||||
|
ARTICLE: "handbook-library-reference" "Libraries"
|
||||||
|
"This index lists articles from loaded vocabularies which are not subsections of any other article. To explore more vocabularies, see " { $link "vocab-index" } "."
|
||||||
|
{ $index [ orphan-articles { "help.home" "handbook" } diff ] } ;
|
||||||
|
|
||||||
ARTICLE: "handbook" "Factor handbook"
|
ARTICLE: "handbook" "Factor handbook"
|
||||||
"Learn the language:"
|
"Learn the language:"
|
||||||
|
@ -308,11 +305,11 @@ ARTICLE: "handbook" "Factor handbook"
|
||||||
{ $subsection "first-program" }
|
{ $subsection "first-program" }
|
||||||
"Reference material:"
|
"Reference material:"
|
||||||
{ $subsection "handbook-language-reference" }
|
{ $subsection "handbook-language-reference" }
|
||||||
{ $subsection "handbook-environment-reference" }
|
|
||||||
{ $subsection "io" }
|
{ $subsection "io" }
|
||||||
{ $subsection "ui" }
|
{ $subsection "ui" }
|
||||||
|
{ $subsection "handbook-system-reference" }
|
||||||
|
{ $subsection "handbook-tools-reference" }
|
||||||
{ $subsection "ui-tools" }
|
{ $subsection "ui-tools" }
|
||||||
{ $subsection "unicode" }
|
|
||||||
{ $subsection "alien" }
|
{ $subsection "alien" }
|
||||||
{ $subsection "handbook-library-reference" }
|
{ $subsection "handbook-library-reference" }
|
||||||
"Explore loaded libraries:"
|
"Explore loaded libraries:"
|
||||||
|
|
|
@ -8,6 +8,7 @@ ARTICLE: "help.home" "Factor documentation"
|
||||||
{ $link "handbook" }
|
{ $link "handbook" }
|
||||||
{ $link "vocab-index" }
|
{ $link "vocab-index" }
|
||||||
{ $link "ui-tools" }
|
{ $link "ui-tools" }
|
||||||
|
{ $link "ui-listener" }
|
||||||
}
|
}
|
||||||
{ $heading "Recently visited" }
|
{ $heading "Recently visited" }
|
||||||
{ $table
|
{ $table
|
||||||
|
|
|
@ -0,0 +1 @@
|
||||||
|
Slava Pestov
|
|
@ -0,0 +1,176 @@
|
||||||
|
! Copyright (C) 2009 Slava Pestov.
|
||||||
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
|
USING: accessors arrays assocs classes combinators
|
||||||
|
combinators.short-circuit definitions effects eval fry grouping
|
||||||
|
help help.markup help.topics io.streams.string kernel macros
|
||||||
|
namespaces sequences sequences.deep sets sorting splitting
|
||||||
|
strings unicode.categories values vocabs vocabs.loader words
|
||||||
|
words.symbol summary debugger io ;
|
||||||
|
IN: help.lint.checks
|
||||||
|
|
||||||
|
ERROR: simple-lint-error message ;
|
||||||
|
|
||||||
|
M: simple-lint-error summary message>> ;
|
||||||
|
|
||||||
|
M: simple-lint-error error. summary print ;
|
||||||
|
|
||||||
|
SYMBOL: vocabs-quot
|
||||||
|
SYMBOL: all-vocabs
|
||||||
|
SYMBOL: vocab-articles
|
||||||
|
|
||||||
|
: check-example ( element -- )
|
||||||
|
'[
|
||||||
|
_ rest [
|
||||||
|
but-last "\n" join
|
||||||
|
[ (eval>string) ] call( code -- output )
|
||||||
|
"\n" ?tail drop
|
||||||
|
] keep
|
||||||
|
peek assert=
|
||||||
|
] vocabs-quot get call( quot -- ) ;
|
||||||
|
|
||||||
|
: check-examples ( element -- )
|
||||||
|
\ $example swap elements [ check-example ] each ;
|
||||||
|
|
||||||
|
: extract-values ( element -- seq )
|
||||||
|
\ $values swap elements dup empty? [
|
||||||
|
first rest [ first ] map prune natural-sort
|
||||||
|
] unless ;
|
||||||
|
|
||||||
|
: effect-values ( word -- seq )
|
||||||
|
stack-effect
|
||||||
|
[ in>> ] [ out>> ] bi append
|
||||||
|
[ dup pair? [ first ] when effect>string ] map
|
||||||
|
prune natural-sort ;
|
||||||
|
|
||||||
|
: contains-funky-elements? ( element -- ? )
|
||||||
|
{
|
||||||
|
$shuffle
|
||||||
|
$values-x/y
|
||||||
|
$predicate
|
||||||
|
$class-description
|
||||||
|
$error-description
|
||||||
|
} swap '[ _ elements empty? not ] any? ;
|
||||||
|
|
||||||
|
: don't-check-word? ( word -- ? )
|
||||||
|
{
|
||||||
|
[ macro? ]
|
||||||
|
[ symbol? ]
|
||||||
|
[ value-word? ]
|
||||||
|
[ parsing-word? ]
|
||||||
|
[ "declared-effect" word-prop not ]
|
||||||
|
} 1|| ;
|
||||||
|
|
||||||
|
: check-values ( word element -- )
|
||||||
|
{
|
||||||
|
[
|
||||||
|
[ don't-check-word? ]
|
||||||
|
[ contains-funky-elements? ]
|
||||||
|
bi* or
|
||||||
|
] [
|
||||||
|
[ effect-values ]
|
||||||
|
[ extract-values ]
|
||||||
|
bi* sequence=
|
||||||
|
]
|
||||||
|
} 2|| [ "$values don't match stack effect" simple-lint-error ] unless ;
|
||||||
|
|
||||||
|
: check-nulls ( element -- )
|
||||||
|
\ $values swap elements
|
||||||
|
null swap deep-member?
|
||||||
|
[ "$values should not contain null" simple-lint-error ] when ;
|
||||||
|
|
||||||
|
: check-see-also ( element -- )
|
||||||
|
\ $see-also swap elements [
|
||||||
|
rest dup prune [ length ] bi@ assert=
|
||||||
|
] each ;
|
||||||
|
|
||||||
|
: vocab-exists? ( name -- ? )
|
||||||
|
[ vocab ] [ all-vocabs get member? ] bi or ;
|
||||||
|
|
||||||
|
: check-modules ( element -- )
|
||||||
|
\ $vocab-link swap elements [
|
||||||
|
second
|
||||||
|
vocab-exists? [
|
||||||
|
"$vocab-link to non-existent vocabulary"
|
||||||
|
simple-lint-error
|
||||||
|
] unless
|
||||||
|
] each ;
|
||||||
|
|
||||||
|
: check-rendering ( element -- )
|
||||||
|
[ print-content ] with-string-writer drop ;
|
||||||
|
|
||||||
|
: check-strings ( str -- )
|
||||||
|
[
|
||||||
|
"\n\t" intersects? [
|
||||||
|
"Paragraph text should not contain \\n or \\t"
|
||||||
|
simple-lint-error
|
||||||
|
] when
|
||||||
|
] [
|
||||||
|
" " swap subseq? [
|
||||||
|
"Paragraph text should not contain double spaces"
|
||||||
|
simple-lint-error
|
||||||
|
] when
|
||||||
|
] bi ;
|
||||||
|
|
||||||
|
: check-whitespace ( str1 str2 -- )
|
||||||
|
[ " " tail? ] [ " " head? ] bi* or
|
||||||
|
[ "Missing whitespace between strings" simple-lint-error ] unless ;
|
||||||
|
|
||||||
|
: check-bogus-nl ( element -- )
|
||||||
|
{ { $nl } { { $nl } } } [ head? ] with any? [
|
||||||
|
"Simple element should not begin with a paragraph break"
|
||||||
|
simple-lint-error
|
||||||
|
] when ;
|
||||||
|
|
||||||
|
: check-class-description ( word element -- )
|
||||||
|
[ class? not ]
|
||||||
|
[ { $class-description } swap elements empty? not ] bi* and
|
||||||
|
[ "A word that is not a class has a $class-description" simple-lint-error ] when ;
|
||||||
|
|
||||||
|
: check-article-title ( article -- )
|
||||||
|
article-title first LETTER?
|
||||||
|
[ "Article title must begin with a capital letter" simple-lint-error ] unless ;
|
||||||
|
|
||||||
|
: check-elements ( element -- )
|
||||||
|
{
|
||||||
|
[ check-bogus-nl ]
|
||||||
|
[ [ string? ] filter [ check-strings ] each ]
|
||||||
|
[ [ simple-element? ] filter [ check-elements ] each ]
|
||||||
|
[ 2 <clumps> [ [ string? ] all? ] filter [ first2 check-whitespace ] each ]
|
||||||
|
} cleave ;
|
||||||
|
|
||||||
|
: check-descriptions ( element -- )
|
||||||
|
{ $description $class-description $var-description }
|
||||||
|
swap '[
|
||||||
|
_ elements [
|
||||||
|
rest { { } { "" } } member?
|
||||||
|
[ "Empty description" throw ] when
|
||||||
|
] each
|
||||||
|
] each ;
|
||||||
|
|
||||||
|
: check-markup ( element -- )
|
||||||
|
{
|
||||||
|
[ check-elements ]
|
||||||
|
[ check-rendering ]
|
||||||
|
[ check-examples ]
|
||||||
|
[ check-modules ]
|
||||||
|
[ check-descriptions ]
|
||||||
|
} cleave ;
|
||||||
|
|
||||||
|
: files>vocabs ( -- assoc )
|
||||||
|
vocabs
|
||||||
|
[ [ [ vocab-docs-path ] keep ] H{ } map>assoc ]
|
||||||
|
[ [ [ vocab-source-path ] keep ] H{ } map>assoc ]
|
||||||
|
bi assoc-union ;
|
||||||
|
|
||||||
|
: group-articles ( -- assoc )
|
||||||
|
articles get keys
|
||||||
|
files>vocabs
|
||||||
|
H{ } clone [
|
||||||
|
'[
|
||||||
|
dup >link where dup
|
||||||
|
[ first _ at _ push-at ] [ 2drop ] if
|
||||||
|
] each
|
||||||
|
] keep ;
|
||||||
|
|
||||||
|
: all-word-help ( words -- seq )
|
||||||
|
[ word-help ] filter ;
|
|
@ -14,6 +14,10 @@ $nl
|
||||||
"To run help lint, use one of the following two words:"
|
"To run help lint, use one of the following two words:"
|
||||||
{ $subsection help-lint }
|
{ $subsection help-lint }
|
||||||
{ $subsection help-lint-all }
|
{ $subsection help-lint-all }
|
||||||
|
"Once a help lint run completes, failures can be listed:"
|
||||||
|
{ $subsection :lint-failures }
|
||||||
|
"Help lint failures are also shown in the " { $link "ui.tools.error-list" } "."
|
||||||
|
$nl
|
||||||
"Help lint performs the following checks:"
|
"Help lint performs the following checks:"
|
||||||
{ $list
|
{ $list
|
||||||
"ensures examples run and produce stated output"
|
"ensures examples run and produce stated output"
|
||||||
|
|
|
@ -1,161 +1,53 @@
|
||||||
! Copyright (C) 2006, 2009 Slava Pestov.
|
! Copyright (C) 2006, 2009 Slava Pestov.
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
USING: fry accessors sequences parser kernel help help.markup
|
USING: assocs continuations fry help help.lint.checks
|
||||||
help.topics words strings classes tools.vocabs namespaces make
|
help.topics io kernel namespaces parser sequences
|
||||||
io io.streams.string prettyprint definitions arrays vectors
|
source-files.errors tools.vocabs vocabs words classes
|
||||||
combinators combinators.short-circuit splitting debugger
|
locals tools.errors ;
|
||||||
hashtables sorting effects vocabs vocabs.loader assocs editors
|
FROM: help.lint.checks => all-vocabs ;
|
||||||
continuations classes.predicate macros math sets eval
|
|
||||||
vocabs.parser words.symbol values grouping unicode.categories
|
|
||||||
sequences.deep ;
|
|
||||||
IN: help.lint
|
IN: help.lint
|
||||||
|
|
||||||
SYMBOL: vocabs-quot
|
SYMBOL: lint-failures
|
||||||
|
|
||||||
: check-example ( element -- )
|
lint-failures [ H{ } clone ] initialize
|
||||||
'[
|
|
||||||
_ rest [
|
|
||||||
but-last "\n" join
|
|
||||||
[ (eval>string) ] call( code -- output )
|
|
||||||
"\n" ?tail drop
|
|
||||||
] keep
|
|
||||||
peek assert=
|
|
||||||
] vocabs-quot get call( quot -- ) ;
|
|
||||||
|
|
||||||
: check-examples ( element -- )
|
TUPLE: help-lint-error < source-file-error ;
|
||||||
\ $example swap elements [ check-example ] each ;
|
|
||||||
|
|
||||||
: extract-values ( element -- seq )
|
SYMBOL: +help-lint-failure+
|
||||||
\ $values swap elements dup empty? [
|
|
||||||
first rest [ first ] map prune natural-sort
|
|
||||||
] unless ;
|
|
||||||
|
|
||||||
: effect-values ( word -- seq )
|
T{ error-type
|
||||||
stack-effect
|
{ type +help-lint-failure+ }
|
||||||
[ in>> ] [ out>> ] bi append
|
{ word ":lint-failures" }
|
||||||
[ dup pair? [ first ] when effect>string ] map
|
{ plural "help lint failures" }
|
||||||
prune natural-sort ;
|
{ icon "vocab:ui/tools/error-list/icons/help-lint-error.tiff" }
|
||||||
|
{ quot [ lint-failures get values ] }
|
||||||
|
{ forget-quot [ lint-failures get delete-at ] }
|
||||||
|
} define-error-type
|
||||||
|
|
||||||
: contains-funky-elements? ( element -- ? )
|
M: help-lint-error error-type drop +help-lint-failure+ ;
|
||||||
{
|
|
||||||
$shuffle
|
|
||||||
$values-x/y
|
|
||||||
$predicate
|
|
||||||
$class-description
|
|
||||||
$error-description
|
|
||||||
} swap '[ _ elements empty? not ] any? ;
|
|
||||||
|
|
||||||
: don't-check-word? ( word -- ? )
|
<PRIVATE
|
||||||
{
|
|
||||||
[ macro? ]
|
|
||||||
[ symbol? ]
|
|
||||||
[ value-word? ]
|
|
||||||
[ parsing-word? ]
|
|
||||||
[ "declared-effect" word-prop not ]
|
|
||||||
} 1|| ;
|
|
||||||
|
|
||||||
: check-values ( word element -- )
|
: <help-lint-error> ( error topic -- help-lint-error )
|
||||||
{
|
\ help-lint-error <definition-error> ;
|
||||||
[
|
|
||||||
[ don't-check-word? ]
|
|
||||||
[ contains-funky-elements? ]
|
|
||||||
bi* or
|
|
||||||
] [
|
|
||||||
[ effect-values ]
|
|
||||||
[ extract-values ]
|
|
||||||
bi* sequence=
|
|
||||||
]
|
|
||||||
} 2|| [ "$values don't match stack effect" throw ] unless ;
|
|
||||||
|
|
||||||
: check-nulls ( element -- )
|
PRIVATE>
|
||||||
\ $values swap elements
|
|
||||||
null swap deep-member?
|
|
||||||
[ "$values should not contain null" throw ] when ;
|
|
||||||
|
|
||||||
: check-see-also ( element -- )
|
: help-lint-error ( error topic -- )
|
||||||
\ $see-also swap elements [
|
lint-failures get pick
|
||||||
rest dup prune [ length ] bi@ assert=
|
[ [ [ <help-lint-error> ] keep ] dip set-at ] [ delete-at drop ] if
|
||||||
] each ;
|
notify-error-observers ;
|
||||||
|
|
||||||
: vocab-exists? ( name -- ? )
|
<PRIVATE
|
||||||
[ vocab ] [ "all-vocabs" get member? ] bi or ;
|
|
||||||
|
|
||||||
: check-modules ( element -- )
|
:: check-something ( topic quot -- )
|
||||||
\ $vocab-link swap elements [
|
[ quot call( -- ) f ] [ ] recover
|
||||||
second
|
topic help-lint-error ; inline
|
||||||
vocab-exists? [ "$vocab-link to non-existent vocabulary" throw ] unless
|
|
||||||
] each ;
|
|
||||||
|
|
||||||
: check-rendering ( element -- )
|
|
||||||
[ print-content ] with-string-writer drop ;
|
|
||||||
|
|
||||||
: check-strings ( str -- )
|
|
||||||
[
|
|
||||||
"\n\t" intersects?
|
|
||||||
[ "Paragraph text should not contain \\n or \\t" throw ] when
|
|
||||||
] [
|
|
||||||
" " swap subseq?
|
|
||||||
[ "Paragraph text should not contain double spaces" throw ] when
|
|
||||||
] bi ;
|
|
||||||
|
|
||||||
: check-whitespace ( str1 str2 -- )
|
|
||||||
[ " " tail? ] [ " " head? ] bi* or
|
|
||||||
[ "Missing whitespace between strings" throw ] unless ;
|
|
||||||
|
|
||||||
: check-bogus-nl ( element -- )
|
|
||||||
{ { $nl } { { $nl } } } [ head? ] with any?
|
|
||||||
[ "Simple element should not begin with a paragraph break" throw ] when ;
|
|
||||||
|
|
||||||
: check-elements ( element -- )
|
|
||||||
{
|
|
||||||
[ check-bogus-nl ]
|
|
||||||
[ [ string? ] filter [ check-strings ] each ]
|
|
||||||
[ [ simple-element? ] filter [ check-elements ] each ]
|
|
||||||
[ 2 <clumps> [ [ string? ] all? ] filter [ first2 check-whitespace ] each ]
|
|
||||||
} cleave ;
|
|
||||||
|
|
||||||
: check-descriptions ( element -- )
|
|
||||||
{ $description $class-description $var-description }
|
|
||||||
swap '[
|
|
||||||
_ elements [
|
|
||||||
rest { { } { "" } } member?
|
|
||||||
[ "Empty description" throw ] when
|
|
||||||
] each
|
|
||||||
] each ;
|
|
||||||
|
|
||||||
: check-markup ( element -- )
|
|
||||||
{
|
|
||||||
[ check-elements ]
|
|
||||||
[ check-rendering ]
|
|
||||||
[ check-examples ]
|
|
||||||
[ check-modules ]
|
|
||||||
[ check-descriptions ]
|
|
||||||
} cleave ;
|
|
||||||
|
|
||||||
: check-class-description ( word element -- )
|
|
||||||
[ class? not ]
|
|
||||||
[ { $class-description } swap elements empty? not ] bi* and
|
|
||||||
[ "A word that is not a class has a $class-description" throw ] when ;
|
|
||||||
|
|
||||||
: all-word-help ( words -- seq )
|
|
||||||
[ word-help ] filter ;
|
|
||||||
|
|
||||||
TUPLE: help-error error topic ;
|
|
||||||
|
|
||||||
C: <help-error> help-error
|
|
||||||
|
|
||||||
M: help-error error.
|
|
||||||
[ "In " write topic>> pprint nl ]
|
|
||||||
[ error>> error. ]
|
|
||||||
bi ;
|
|
||||||
|
|
||||||
: check-something ( obj quot -- )
|
|
||||||
flush '[ _ call( -- ) ] swap '[ _ <help-error> , ] recover ; inline
|
|
||||||
|
|
||||||
: check-word ( word -- )
|
: check-word ( word -- )
|
||||||
[ with-file-vocabs ] vocabs-quot set
|
[ with-file-vocabs ] vocabs-quot set
|
||||||
dup word-help [
|
dup word-help [
|
||||||
dup '[
|
[ >link ] keep '[
|
||||||
_ dup word-help
|
_ dup word-help
|
||||||
[ check-values ]
|
[ check-values ]
|
||||||
[ check-class-description ]
|
[ check-class-description ]
|
||||||
|
@ -165,69 +57,38 @@ M: help-error error.
|
||||||
|
|
||||||
: check-words ( words -- ) [ check-word ] each ;
|
: check-words ( words -- ) [ check-word ] each ;
|
||||||
|
|
||||||
: check-article-title ( article -- )
|
|
||||||
article-title first LETTER?
|
|
||||||
[ "Article title must begin with a capital letter" throw ] unless ;
|
|
||||||
|
|
||||||
: check-article ( article -- )
|
: check-article ( article -- )
|
||||||
[ with-interactive-vocabs ] vocabs-quot set
|
[ with-interactive-vocabs ] vocabs-quot set
|
||||||
dup '[
|
>link dup '[
|
||||||
_
|
_
|
||||||
[ check-article-title ]
|
[ check-article-title ]
|
||||||
[ article-content check-markup ] bi
|
[ article-content check-markup ] bi
|
||||||
] check-something ;
|
] check-something ;
|
||||||
|
|
||||||
: files>vocabs ( -- assoc )
|
|
||||||
vocabs
|
|
||||||
[ [ [ vocab-docs-path ] keep ] H{ } map>assoc ]
|
|
||||||
[ [ [ vocab-source-path ] keep ] H{ } map>assoc ]
|
|
||||||
bi assoc-union ;
|
|
||||||
|
|
||||||
: group-articles ( -- assoc )
|
|
||||||
articles get keys
|
|
||||||
files>vocabs
|
|
||||||
H{ } clone [
|
|
||||||
'[
|
|
||||||
dup >link where dup
|
|
||||||
[ first _ at _ push-at ] [ 2drop ] if
|
|
||||||
] each
|
|
||||||
] keep ;
|
|
||||||
|
|
||||||
: check-about ( vocab -- )
|
: check-about ( vocab -- )
|
||||||
dup '[ _ vocab-help [ article drop ] when* ] check-something ;
|
dup '[ _ vocab-help [ article drop ] when* ] check-something ;
|
||||||
|
|
||||||
: check-vocab ( vocab -- seq )
|
: check-vocab ( vocab -- )
|
||||||
"Checking " write dup write "..." print
|
"Checking " write dup write "..." print
|
||||||
[
|
[ vocab check-about ]
|
||||||
[ check-about ]
|
[ words [ check-word ] each ]
|
||||||
[ words [ check-word ] each ]
|
[ vocab-articles get at [ check-article ] each ]
|
||||||
[ "vocab-articles" get at [ check-article ] each ]
|
tri ;
|
||||||
tri
|
|
||||||
] { } make ;
|
|
||||||
|
|
||||||
: run-help-lint ( prefix -- alist )
|
PRIVATE>
|
||||||
|
|
||||||
|
: help-lint ( prefix -- )
|
||||||
[
|
[
|
||||||
all-vocabs-seq [ vocab-name ] map "all-vocabs" set
|
all-vocabs-seq [ vocab-name ] map all-vocabs set
|
||||||
group-articles "vocab-articles" set
|
group-articles vocab-articles set
|
||||||
child-vocabs
|
child-vocabs
|
||||||
[ dup check-vocab ] { } map>assoc
|
[ check-vocab ] each
|
||||||
[ nip empty? not ] assoc-filter
|
|
||||||
] with-scope ;
|
] with-scope ;
|
||||||
|
|
||||||
: typos. ( assoc -- )
|
|
||||||
[
|
|
||||||
"==== ALL CHECKS PASSED" print
|
|
||||||
] [
|
|
||||||
[
|
|
||||||
swap vocab-heading.
|
|
||||||
[ print-error nl ] each
|
|
||||||
] assoc-each
|
|
||||||
] if-empty ;
|
|
||||||
|
|
||||||
: help-lint ( prefix -- ) run-help-lint typos. ;
|
|
||||||
|
|
||||||
: help-lint-all ( -- ) "" help-lint ;
|
: help-lint-all ( -- ) "" help-lint ;
|
||||||
|
|
||||||
|
: :lint-failures ( -- ) lint-failures get errors. ;
|
||||||
|
|
||||||
: unlinked-words ( words -- seq )
|
: unlinked-words ( words -- seq )
|
||||||
all-word-help [ article-parent not ] filter ;
|
all-word-help [ article-parent not ] filter ;
|
||||||
|
|
||||||
|
@ -235,6 +96,6 @@ M: help-error error.
|
||||||
all-words
|
all-words
|
||||||
[ word-help not ] filter
|
[ word-help not ] filter
|
||||||
[ article-parent ] filter
|
[ article-parent ] filter
|
||||||
[ "predicating" word-prop not ] filter ;
|
[ predicate? not ] filter ;
|
||||||
|
|
||||||
MAIN: help-lint
|
MAIN: help-lint
|
||||||
|
|
|
@ -4,12 +4,12 @@ IN: help.syntax.tests
|
||||||
|
|
||||||
[
|
[
|
||||||
[ "foobar" ] [
|
[ "foobar" ] [
|
||||||
"IN: help.syntax.tests USE: help.syntax ABOUT: \"foobar\"" eval
|
"IN: help.syntax.tests USE: help.syntax ABOUT: \"foobar\"" eval( -- )
|
||||||
"help.syntax.tests" vocab vocab-help
|
"help.syntax.tests" vocab vocab-help
|
||||||
] unit-test
|
] unit-test
|
||||||
|
|
||||||
[ { "foobar" } ] [
|
[ { "foobar" } ] [
|
||||||
"IN: help.syntax.tests USE: help.syntax ABOUT: { \"foobar\" }" eval
|
"IN: help.syntax.tests USE: help.syntax ABOUT: { \"foobar\" }" eval( -- )
|
||||||
"help.syntax.tests" vocab vocab-help
|
"help.syntax.tests" vocab vocab-help
|
||||||
] unit-test
|
] unit-test
|
||||||
|
|
||||||
|
|
|
@ -29,7 +29,7 @@ SYMBOL: foo
|
||||||
} "\n" join
|
} "\n" join
|
||||||
[
|
[
|
||||||
"testfile" source-file file set
|
"testfile" source-file file set
|
||||||
eval
|
eval( -- )
|
||||||
] with-scope
|
] with-scope
|
||||||
] unit-test
|
] unit-test
|
||||||
|
|
||||||
|
|
|
@ -76,9 +76,11 @@ $nl
|
||||||
{ $code "." }
|
{ $code "." }
|
||||||
"What we just did is called " { $emphasis "interactive testing" } ". A more advanced technique which comes into play with larger programs is " { $link "tools.test" } "."
|
"What we just did is called " { $emphasis "interactive testing" } ". A more advanced technique which comes into play with larger programs is " { $link "tools.test" } "."
|
||||||
$nl
|
$nl
|
||||||
"Open the file named " { $snippet "palindrome-tests.factor" } "; it is located in the same directory as " { $snippet "palindrome.factor" } ", and it was created by the scaffold tool."
|
"Create a test harness file using the scaffold tool:"
|
||||||
|
{ $code "\"palindrome\" scaffold-tests" }
|
||||||
|
"Now, open the file named " { $snippet "palindrome-tests.factor" } "; it is located in the same directory as " { $snippet "palindrome.factor" } ", and it was created by the scaffold tool."
|
||||||
$nl
|
$nl
|
||||||
"We will add some unit tests, which are similar to the interactive tests we did above. Unit tests are defined with the " { $link unit-test } " word, which takes a sequence of expected outputs, and a piece of code. It runs the code, and asserts that it outputs the expected values."
|
"We will add some unit tests, which are similar to the interactive tests we did above. Unit tests are defined with the " { $link POSTPONE: unit-test } " word, which takes a sequence of expected outputs, and a piece of code. It runs the code, and asserts that it outputs the expected values."
|
||||||
$nl
|
$nl
|
||||||
"Add the following three lines to " { $snippet "palindrome-tests.factor" } ":"
|
"Add the following three lines to " { $snippet "palindrome-tests.factor" } ":"
|
||||||
{ $code
|
{ $code
|
||||||
|
|
|
@ -0,0 +1,8 @@
|
||||||
|
IN: io.crlf.tests
|
||||||
|
USING: io.crlf tools.test io.streams.string io ;
|
||||||
|
|
||||||
|
[ "Hello, world." ] [ "Hello, world." [ read-crlf ] with-string-reader ] unit-test
|
||||||
|
[ "Hello, world." ] [ "Hello, world.\r\n" [ read-crlf ] with-string-reader ] unit-test
|
||||||
|
[ "Hello, world.\r" [ read-crlf ] with-string-reader ] must-fail
|
||||||
|
[ f ] [ "" [ read-crlf ] with-string-reader ] unit-test
|
||||||
|
[ "" ] [ "\r\n" [ read-crlf ] with-string-reader ] unit-test
|
|
@ -1,6 +1,6 @@
|
||||||
! Copyright (C) 2009 Daniel Ehrenberg, Slava Pestov
|
! Copyright (C) 2009 Daniel Ehrenberg, Slava Pestov
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
USING: io kernel ;
|
USING: io kernel sequences ;
|
||||||
IN: io.crlf
|
IN: io.crlf
|
||||||
|
|
||||||
: crlf ( -- )
|
: crlf ( -- )
|
||||||
|
@ -8,4 +8,4 @@ IN: io.crlf
|
||||||
|
|
||||||
: read-crlf ( -- seq )
|
: read-crlf ( -- seq )
|
||||||
"\r" read-until
|
"\r" read-until
|
||||||
[ CHAR: \r assert= read1 CHAR: \n assert= ] when* ;
|
[ CHAR: \r assert= read1 CHAR: \n assert= ] [ f like ] if* ;
|
||||||
|
|
|
@ -140,7 +140,46 @@ HELP: <process-stream>
|
||||||
{ "desc" "a launch descriptor" }
|
{ "desc" "a launch descriptor" }
|
||||||
{ "encoding" "an encoding descriptor" }
|
{ "encoding" "an encoding descriptor" }
|
||||||
{ "stream" "a bidirectional stream" } }
|
{ "stream" "a bidirectional stream" } }
|
||||||
{ $description "Launches a process and redirects its input and output via a pair of pipes which may be read and written as a stream of the given encoding." } ;
|
{ $description "Launches a process and redirects its input and output via a pair of pipes which may be read and written as a stream with the given encoding." } ;
|
||||||
|
|
||||||
|
HELP: <process-reader>
|
||||||
|
{ $values
|
||||||
|
{ "desc" "a launch descriptor" }
|
||||||
|
{ "encoding" "an encoding descriptor" }
|
||||||
|
{ "stream" "an input stream" } }
|
||||||
|
{ $description "Launches a process and redirects its output via a pipe which may be read as a stream with the given encoding." } ;
|
||||||
|
|
||||||
|
HELP: <process-writer>
|
||||||
|
{ $values
|
||||||
|
{ "desc" "a launch descriptor" }
|
||||||
|
{ "encoding" "an encoding descriptor" }
|
||||||
|
{ "stream" "an output stream" }
|
||||||
|
}
|
||||||
|
{ $description "Launches a process and redirects its input via a pipe which may be written to as a stream with the given encoding." } ;
|
||||||
|
|
||||||
|
HELP: with-process-stream
|
||||||
|
{ $values
|
||||||
|
{ "desc" "a launch descriptor" }
|
||||||
|
{ "encoding" "an encoding descriptor" }
|
||||||
|
{ "quot" quotation }
|
||||||
|
}
|
||||||
|
{ $description "Launches a process and redirects its input and output via a pair of pipes. The quotation is called with " { $link input-stream } " and " { $link output-stream } " rebound to these pipes." } ;
|
||||||
|
|
||||||
|
HELP: with-process-reader
|
||||||
|
{ $values
|
||||||
|
{ "desc" "a launch descriptor" }
|
||||||
|
{ "encoding" "an encoding descriptor" }
|
||||||
|
{ "quot" quotation }
|
||||||
|
}
|
||||||
|
{ $description "Launches a process and redirects its output via a pipe. The quotation is called with " { $link input-stream } " and " { $link output-stream } " rebound to this pipe." } ;
|
||||||
|
|
||||||
|
HELP: with-process-writer
|
||||||
|
{ $values
|
||||||
|
{ "desc" "a launch descriptor" }
|
||||||
|
{ "encoding" "an encoding descriptor" }
|
||||||
|
{ "quot" quotation }
|
||||||
|
}
|
||||||
|
{ $description "Launches a process and redirects its input via a pipe. The quotation is called with " { $link input-stream } " and " { $link output-stream } " rebound to this pipe." } ;
|
||||||
|
|
||||||
HELP: wait-for-process
|
HELP: wait-for-process
|
||||||
{ $values { "process" process } { "status" object } }
|
{ $values { "process" process } { "status" object } }
|
||||||
|
@ -175,7 +214,11 @@ ARTICLE: "io.launcher.launch" "Launching processes"
|
||||||
"Redirecting standard input and output to a pipe:"
|
"Redirecting standard input and output to a pipe:"
|
||||||
{ $subsection <process-reader> }
|
{ $subsection <process-reader> }
|
||||||
{ $subsection <process-writer> }
|
{ $subsection <process-writer> }
|
||||||
{ $subsection <process-stream> } ;
|
{ $subsection <process-stream> }
|
||||||
|
"Combinators built on top of the above:"
|
||||||
|
{ $subsection with-process-reader }
|
||||||
|
{ $subsection with-process-writer }
|
||||||
|
{ $subsection with-process-stream } ;
|
||||||
|
|
||||||
ARTICLE: "io.launcher.examples" "Launcher examples"
|
ARTICLE: "io.launcher.examples" "Launcher examples"
|
||||||
"Starting a command and waiting for it to finish:"
|
"Starting a command and waiting for it to finish:"
|
||||||
|
|
|
@ -10,13 +10,13 @@ USING: io.launcher.unix.parser tools.test ;
|
||||||
[ V{ "abc" "def" } ] [ "abc def" tokenize-command ] unit-test
|
[ V{ "abc" "def" } ] [ "abc def" tokenize-command ] unit-test
|
||||||
[ V{ "abc def" } ] [ "abc\\ def" tokenize-command ] unit-test
|
[ V{ "abc def" } ] [ "abc\\ def" tokenize-command ] unit-test
|
||||||
[ V{ "abc\\" "def" } ] [ "abc\\\\ def" tokenize-command ] unit-test
|
[ V{ "abc\\" "def" } ] [ "abc\\\\ def" tokenize-command ] unit-test
|
||||||
[ V{ "abc\\ def" } ] [ "'abc\\\\ def'" tokenize-command ] unit-test
|
[ V{ "abc\\ def" } ] [ "\"abc\\\\ def\"" tokenize-command ] unit-test
|
||||||
[ V{ "abc\\ def" } ] [ " 'abc\\\\ def'" tokenize-command ] unit-test
|
[ V{ "abc\\ def" } ] [ " \"abc\\\\ def\"" tokenize-command ] unit-test
|
||||||
[ V{ "abc\\ def" "hey" } ] [ "'abc\\\\ def' hey" tokenize-command ] unit-test
|
[ V{ "abc\\ def" "hey" } ] [ "\"abc\\\\ def\" hey" tokenize-command ] unit-test
|
||||||
[ V{ "abc def" "hey" } ] [ "'abc def' \"hey\"" tokenize-command ] unit-test
|
[ V{ "abc def" "hey" } ] [ "\"abc def\" \"hey\"" tokenize-command ] unit-test
|
||||||
[ "'abc def' \"hey" tokenize-command ] must-fail
|
[ "\"abc def\" \"hey" tokenize-command ] must-fail
|
||||||
[ "'abc def" tokenize-command ] must-fail
|
[ "\"abc def" tokenize-command ] must-fail
|
||||||
[ V{ "abc def" "h\"ey" } ] [ "'abc def' \"h\\\"ey\" " tokenize-command ] unit-test
|
[ V{ "abc def" "h\"ey" } ] [ "\"abc def\" \"h\\\"ey\" " tokenize-command ] unit-test
|
||||||
|
|
||||||
[
|
[
|
||||||
V{
|
V{
|
||||||
|
|
|
@ -1,33 +1,17 @@
|
||||||
! Copyright (C) 2008 Slava Pestov
|
! Copyright (C) 2008 Slava Pestov
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
USING: peg peg.parsers kernel sequences strings words ;
|
USING: peg peg.ebnf arrays sequences strings kernel ;
|
||||||
IN: io.launcher.unix.parser
|
IN: io.launcher.unix.parser
|
||||||
|
|
||||||
! Our command line parser. Supported syntax:
|
! Our command line parser. Supported syntax:
|
||||||
! foo bar baz -- simple tokens
|
! foo bar baz -- simple tokens
|
||||||
! foo\ bar -- escaping the space
|
! foo\ bar -- escaping the space
|
||||||
! 'foo bar' -- quotation
|
|
||||||
! "foo bar" -- quotation
|
! "foo bar" -- quotation
|
||||||
: 'escaped-char' ( -- parser )
|
EBNF: tokenize-command
|
||||||
"\\" token any-char 2seq [ second ] action ;
|
space = " "
|
||||||
|
escaped-char = "\" .:ch => [[ ch ]]
|
||||||
: 'quoted-char' ( delimiter -- parser' )
|
quoted = '"' (escaped-char | [^"])*:a '"' => [[ a ]]
|
||||||
'escaped-char'
|
unquoted = (escaped-char | [^ "])+
|
||||||
swap [ member? not ] curry satisfy
|
argument = (quoted | unquoted) => [[ >string ]]
|
||||||
2choice ; inline
|
command = space* (argument:a space* => [[ a ]])+:c !(.) => [[ c ]]
|
||||||
|
;EBNF
|
||||||
: 'quoted' ( delimiter -- parser )
|
|
||||||
dup 'quoted-char' repeat0 swap dup surrounded-by ;
|
|
||||||
|
|
||||||
: 'unquoted' ( -- parser ) " '\"" 'quoted-char' repeat1 ;
|
|
||||||
|
|
||||||
: 'argument' ( -- parser )
|
|
||||||
"\"" 'quoted'
|
|
||||||
"'" 'quoted'
|
|
||||||
'unquoted' 3choice
|
|
||||||
[ >string ] action ;
|
|
||||||
|
|
||||||
PEG: tokenize-command ( command -- ast/f )
|
|
||||||
'argument' " " token repeat1 list-of
|
|
||||||
" " token repeat0 tuck pack
|
|
||||||
just ;
|
|
||||||
|
|
|
@ -98,7 +98,7 @@ IN: io.launcher.windows.nt.tests
|
||||||
<process>
|
<process>
|
||||||
console-vm "-script" "env.factor" 3array >>command
|
console-vm "-script" "env.factor" 3array >>command
|
||||||
ascii <process-reader> contents
|
ascii <process-reader> contents
|
||||||
] with-directory eval
|
] with-directory eval( -- alist )
|
||||||
|
|
||||||
os-envs =
|
os-envs =
|
||||||
] unit-test
|
] unit-test
|
||||||
|
@ -110,7 +110,7 @@ IN: io.launcher.windows.nt.tests
|
||||||
+replace-environment+ >>environment-mode
|
+replace-environment+ >>environment-mode
|
||||||
os-envs >>environment
|
os-envs >>environment
|
||||||
ascii <process-reader> contents
|
ascii <process-reader> contents
|
||||||
] with-directory eval
|
] with-directory eval( -- alist )
|
||||||
|
|
||||||
os-envs =
|
os-envs =
|
||||||
] unit-test
|
] unit-test
|
||||||
|
@ -121,7 +121,7 @@ IN: io.launcher.windows.nt.tests
|
||||||
console-vm "-script" "env.factor" 3array >>command
|
console-vm "-script" "env.factor" 3array >>command
|
||||||
{ { "A" "B" } } >>environment
|
{ { "A" "B" } } >>environment
|
||||||
ascii <process-reader> contents
|
ascii <process-reader> contents
|
||||||
] with-directory eval
|
] with-directory eval( -- alist )
|
||||||
|
|
||||||
"A" swap at
|
"A" swap at
|
||||||
] unit-test
|
] unit-test
|
||||||
|
@ -133,7 +133,7 @@ IN: io.launcher.windows.nt.tests
|
||||||
{ { "USERPROFILE" "XXX" } } >>environment
|
{ { "USERPROFILE" "XXX" } } >>environment
|
||||||
+prepend-environment+ >>environment-mode
|
+prepend-environment+ >>environment-mode
|
||||||
ascii <process-reader> contents
|
ascii <process-reader> contents
|
||||||
] with-directory eval
|
] with-directory eval( -- alist )
|
||||||
|
|
||||||
"USERPROFILE" swap at "XXX" =
|
"USERPROFILE" swap at "XXX" =
|
||||||
] unit-test
|
] unit-test
|
||||||
|
|
|
@ -192,7 +192,7 @@ M: object (client) ( remote -- client-in client-out local )
|
||||||
] with-destructors ;
|
] with-destructors ;
|
||||||
|
|
||||||
: <client> ( remote encoding -- stream local )
|
: <client> ( remote encoding -- stream local )
|
||||||
[ (client) -rot ] dip <encoder-duplex> swap ;
|
[ (client) ] dip swap [ <encoder-duplex> ] dip ;
|
||||||
|
|
||||||
SYMBOL: local-address
|
SYMBOL: local-address
|
||||||
|
|
||||||
|
|
|
@ -274,7 +274,7 @@ HELP: <input>
|
||||||
{ $description "Creates a new " { $link input } "." } ;
|
{ $description "Creates a new " { $link input } "." } ;
|
||||||
|
|
||||||
HELP: standard-table-style
|
HELP: standard-table-style
|
||||||
{ $values { "style" hashtable } }
|
{ $values { "value" hashtable } }
|
||||||
{ $description "Outputs a table style where cells are separated by 5-pixel gaps and framed by a light gray border. This style can be passed to " { $link tabular-output } "." } ;
|
{ $description "Outputs a table style where cells are separated by 5-pixel gaps and framed by a light gray border. This style can be passed to " { $link tabular-output } "." } ;
|
||||||
|
|
||||||
ARTICLE: "io.streams.plain" "Plain writer streams"
|
ARTICLE: "io.streams.plain" "Plain writer streams"
|
||||||
|
|
|
@ -135,11 +135,11 @@ SYMBOL: wrap-margin
|
||||||
SYMBOL: table-gap
|
SYMBOL: table-gap
|
||||||
SYMBOL: table-border
|
SYMBOL: table-border
|
||||||
|
|
||||||
: standard-table-style ( -- style )
|
CONSTANT: standard-table-style
|
||||||
H{
|
H{
|
||||||
{ table-gap { 5 5 } }
|
{ table-gap { 5 5 } }
|
||||||
{ table-border T{ rgba f 0.8 0.8 0.8 1.0 } }
|
{ table-border T{ rgba f 0.8 0.8 0.8 1.0 } }
|
||||||
} ;
|
}
|
||||||
|
|
||||||
! Input history
|
! Input history
|
||||||
TUPLE: input string ;
|
TUPLE: input string ;
|
||||||
|
|
|
@ -1,4 +1,4 @@
|
||||||
USING: help.markup help.syntax kernel io system prettyprint ;
|
USING: help.markup help.syntax kernel io system prettyprint continuations ;
|
||||||
IN: listener
|
IN: listener
|
||||||
|
|
||||||
ARTICLE: "listener-watch" "Watching variables in the listener"
|
ARTICLE: "listener-watch" "Watching variables in the listener"
|
||||||
|
@ -41,32 +41,18 @@ $nl
|
||||||
{ $example "{ 1 2 3 } [\n .\n] each" "1\n2\n3" }
|
{ $example "{ 1 2 3 } [\n .\n] each" "1\n2\n3" }
|
||||||
"The listener knows when to expect more input by looking at the height of the stack. Parsing words such as " { $link POSTPONE: { } " leave elements on the parser stack, and corresponding words such as " { $link POSTPONE: } } " pop them."
|
"The listener knows when to expect more input by looking at the height of the stack. Parsing words such as " { $link POSTPONE: { } " leave elements on the parser stack, and corresponding words such as " { $link POSTPONE: } } " pop them."
|
||||||
{ $subsection "listener-watch" }
|
{ $subsection "listener-watch" }
|
||||||
"You can start a nested listener or exit a listener using the following words:"
|
"To start a nested listener:"
|
||||||
{ $subsection listener }
|
{ $subsection listener }
|
||||||
{ $subsection bye }
|
"To exit the listener, invoke the " { $link return } " word."
|
||||||
"Finally, the multi-line expression reading word can be used independently of the rest of the listener:"
|
$nl
|
||||||
|
"Multi-line quotations can be read independently of the rest of the listener:"
|
||||||
{ $subsection read-quot } ;
|
{ $subsection read-quot } ;
|
||||||
|
|
||||||
ABOUT: "listener"
|
ABOUT: "listener"
|
||||||
|
|
||||||
<PRIVATE
|
|
||||||
|
|
||||||
HELP: quit-flag
|
|
||||||
{ $var-description "Variable set to true by " { $link bye } " word; it forces the next iteration of the " { $link listener } " loop to end." } ;
|
|
||||||
|
|
||||||
PRIVATE>
|
|
||||||
|
|
||||||
HELP: read-quot
|
HELP: read-quot
|
||||||
{ $values { "quot/f" "a parsed quotation, or " { $link f } " indicating end of file" } }
|
{ $values { "quot/f" "a parsed quotation, or " { $link f } " indicating end of file" } }
|
||||||
{ $description "Reads a Factor expression which possibly spans more than one line from " { $link input-stream } ". Additional lines of input are read while the parser stack height is greater than one. Since structural parsing words push partial quotations on the stack, this will keep on reading input until all delimited parsing words are terminated." } ;
|
{ $description "Reads a Factor expression which possibly spans more than one line from " { $link input-stream } ". Additional lines of input are read while the parser stack height is greater than one. Since structural parsing words push partial quotations on the stack, this will keep on reading input until all delimited parsing words are terminated." } ;
|
||||||
|
|
||||||
HELP: listen
|
|
||||||
{ $description "Prompts for an expression on " { $link input-stream } " and evaluates it. On end of file, " { $link quit-flag } " is set to terminate the listener loop." }
|
|
||||||
{ $errors "If the expression input by the user throws an error, the error is printed to " { $link output-stream } " and the word returns normally." } ;
|
|
||||||
|
|
||||||
HELP: listener
|
HELP: listener
|
||||||
{ $description "Prompts for expressions on " { $link input-stream } " and evaluates them until end of file is reached." } ;
|
{ $description "Prompts for expressions on " { $link input-stream } " and evaluates them until end of file is reached." } ;
|
||||||
|
|
||||||
HELP: bye
|
|
||||||
{ $description "Exits the current listener." }
|
|
||||||
{ $notes "This word is for interactive use only. To exit the Factor runtime, use " { $link exit } "." } ;
|
|
||||||
|
|
|
@ -25,7 +25,7 @@ SYNTAX: hello "Hi" print ;
|
||||||
"\\ + 1 2 3 4" parse-interactive
|
"\\ + 1 2 3 4" parse-interactive
|
||||||
"cont" get continue-with
|
"cont" get continue-with
|
||||||
] ignore-errors
|
] ignore-errors
|
||||||
"USE: debugger :1" eval
|
"USE: debugger :1" eval( -- quot )
|
||||||
] callcc1
|
] callcc1
|
||||||
] unit-test
|
] unit-test
|
||||||
] with-file-vocabs
|
] with-file-vocabs
|
||||||
|
@ -50,7 +50,7 @@ SYNTAX: hello "Hi" print ;
|
||||||
|
|
||||||
[
|
[
|
||||||
[ ] [
|
[ ] [
|
||||||
"IN: listener.tests : hello ( -- )\n\"world\" ;" parse-interactive
|
"IN: listener.tests : hello ( -- string )\n\"world\" ;" parse-interactive
|
||||||
drop
|
drop
|
||||||
] unit-test
|
] unit-test
|
||||||
] with-file-vocabs
|
] with-file-vocabs
|
||||||
|
|
|
@ -4,7 +4,7 @@ USING: arrays hashtables io kernel math math.parser memory
|
||||||
namespaces parser lexer sequences strings io.styles
|
namespaces parser lexer sequences strings io.styles
|
||||||
vectors words generic system combinators continuations debugger
|
vectors words generic system combinators continuations debugger
|
||||||
definitions compiler.units accessors colors prettyprint fry
|
definitions compiler.units accessors colors prettyprint fry
|
||||||
sets vocabs.parser ;
|
sets vocabs.parser source-files.errors locals ;
|
||||||
IN: listener
|
IN: listener
|
||||||
|
|
||||||
GENERIC: stream-read-quot ( stream -- quot/f )
|
GENERIC: stream-read-quot ( stream -- quot/f )
|
||||||
|
@ -32,17 +32,9 @@ M: object stream-read-quot
|
||||||
|
|
||||||
: read-quot ( -- quot/f ) input-stream get stream-read-quot ;
|
: read-quot ( -- quot/f ) input-stream get stream-read-quot ;
|
||||||
|
|
||||||
<PRIVATE
|
|
||||||
|
|
||||||
SYMBOL: quit-flag
|
|
||||||
|
|
||||||
PRIVATE>
|
|
||||||
|
|
||||||
: bye ( -- ) quit-flag on ;
|
|
||||||
|
|
||||||
SYMBOL: visible-vars
|
SYMBOL: visible-vars
|
||||||
|
|
||||||
: show-var ( var -- ) visible-vars [ swap suffix ] change ;
|
: show-var ( var -- ) visible-vars [ swap suffix ] change ;
|
||||||
|
|
||||||
: show-vars ( seq -- ) visible-vars [ swap union ] change ;
|
: show-vars ( seq -- ) visible-vars [ swap union ] change ;
|
||||||
|
|
||||||
|
@ -68,6 +60,8 @@ SYMBOL: max-stack-items
|
||||||
|
|
||||||
10 max-stack-items set-global
|
10 max-stack-items set-global
|
||||||
|
|
||||||
|
SYMBOL: error-summary-hook
|
||||||
|
|
||||||
<PRIVATE
|
<PRIVATE
|
||||||
|
|
||||||
: title. ( string -- )
|
: title. ( string -- )
|
||||||
|
@ -96,26 +90,44 @@ SYMBOL: max-stack-items
|
||||||
] dip
|
] dip
|
||||||
] when stack. ;
|
] when stack. ;
|
||||||
|
|
||||||
: stacks. ( -- )
|
: datastack. ( datastack -- )
|
||||||
display-stacks? get [
|
display-stacks? get [
|
||||||
datastack [ nl "--- Data stack:" title. trimmed-stack. ] unless-empty
|
[ nl "--- Data stack:" title. trimmed-stack. ] unless-empty
|
||||||
] when ;
|
] [ drop ] if ;
|
||||||
|
|
||||||
: prompt. ( -- )
|
: prompt. ( -- )
|
||||||
"( " in get auto-use? get [ " - auto" append ] when " )" 3append
|
in get auto-use? get [ " - auto" append ] when "( " " )" surround
|
||||||
H{ { background T{ rgba f 1 0.7 0.7 1 } } } format bl flush ;
|
H{ { background T{ rgba f 1 0.7 0.7 1 } } } format bl flush ;
|
||||||
|
|
||||||
: listen ( -- )
|
[ error-summary ] error-summary-hook set-global
|
||||||
visible-vars. stacks. prompt.
|
|
||||||
[ read-quot [ [ call-error-hook ] recover ] [ bye ] if* ]
|
|
||||||
[ dup lexer-error? [ call-error-hook ] [ rethrow ] if ] recover ;
|
|
||||||
|
|
||||||
: until-quit ( -- )
|
: call-error-summary-hook ( -- )
|
||||||
quit-flag get [ quit-flag off ] [ listen until-quit ] if ;
|
error-summary-hook get call( -- ) ;
|
||||||
|
|
||||||
|
:: (listener) ( datastack -- )
|
||||||
|
call-error-summary-hook
|
||||||
|
visible-vars.
|
||||||
|
datastack datastack.
|
||||||
|
prompt.
|
||||||
|
|
||||||
|
[
|
||||||
|
read-quot [
|
||||||
|
'[ datastack _ with-datastack ]
|
||||||
|
[ call-error-hook datastack ]
|
||||||
|
recover
|
||||||
|
] [ return ] if*
|
||||||
|
] [
|
||||||
|
dup lexer-error?
|
||||||
|
[ call-error-hook datastack ]
|
||||||
|
[ rethrow ]
|
||||||
|
if
|
||||||
|
] recover
|
||||||
|
|
||||||
|
(listener) ;
|
||||||
|
|
||||||
PRIVATE>
|
PRIVATE>
|
||||||
|
|
||||||
: listener ( -- )
|
: listener ( -- )
|
||||||
[ until-quit ] with-interactive-vocabs ;
|
[ [ { } (listener) ] with-interactive-vocabs ] with-return ;
|
||||||
|
|
||||||
MAIN: listener
|
MAIN: listener
|
||||||
|
|
|
@ -106,7 +106,8 @@ PRIVATE>
|
||||||
|
|
||||||
: deep-sequence>cons ( sequence -- cons )
|
: deep-sequence>cons ( sequence -- cons )
|
||||||
[ <reversed> ] keep nil
|
[ <reversed> ] keep nil
|
||||||
[ tuck same? [ deep-sequence>cons ] when swons ] with reduce ;
|
[ [ nip ] [ same? ] 2bi [ deep-sequence>cons ] when swons ]
|
||||||
|
with reduce ;
|
||||||
|
|
||||||
<PRIVATE
|
<PRIVATE
|
||||||
:: (lmap>vector) ( acc list quot: ( elt -- elt' ) -- acc )
|
:: (lmap>vector) ( acc list quot: ( elt -- elt' ) -- acc )
|
||||||
|
|
|
@ -261,7 +261,7 @@ M:: fixnum next-method-test ( a -- b ) a call-next-method 1 + ;
|
||||||
|
|
||||||
CONSTANT: new-definition "USING: math ;\nIN: locals.tests\n: a-word-with-locals ( -- x ) 2 3 + ;\n"
|
CONSTANT: new-definition "USING: math ;\nIN: locals.tests\n: a-word-with-locals ( -- x ) 2 3 + ;\n"
|
||||||
|
|
||||||
[ ] [ new-definition eval ] unit-test
|
[ ] [ new-definition eval( -- ) ] unit-test
|
||||||
|
|
||||||
[ t ] [
|
[ t ] [
|
||||||
[ \ a-word-with-locals see ] with-string-writer
|
[ \ a-word-with-locals see ] with-string-writer
|
||||||
|
@ -461,7 +461,7 @@ M:: integer lambda-method-forget-test ( a -- b ) ;
|
||||||
|
|
||||||
[
|
[
|
||||||
"USING: locals fry math ; 1 '[ [let | A [ 10 ] | A _ + ] ]"
|
"USING: locals fry math ; 1 '[ [let | A [ 10 ] | A _ + ] ]"
|
||||||
eval call
|
eval( -- ) call
|
||||||
] [ error>> >r/r>-in-fry-error? ] must-fail-with
|
] [ error>> >r/r>-in-fry-error? ] must-fail-with
|
||||||
|
|
||||||
:: (funny-macro-test) ( obj quot -- ? ) obj { quot } 1&& ; inline
|
:: (funny-macro-test) ( obj quot -- ? ) obj { quot } 1&& ; inline
|
||||||
|
@ -473,10 +473,10 @@ M:: integer lambda-method-forget-test ( a -- b ) ;
|
||||||
[ f ] [ 2 funny-macro-test ] unit-test
|
[ f ] [ 2 funny-macro-test ] unit-test
|
||||||
|
|
||||||
! Some odd parser corner cases
|
! Some odd parser corner cases
|
||||||
[ "USE: locals [let" eval ] [ error>> unexpected-eof? ] must-fail-with
|
[ "USE: locals [let" eval( -- ) ] [ error>> unexpected-eof? ] must-fail-with
|
||||||
[ "USE: locals [let |" eval ] [ error>> unexpected-eof? ] must-fail-with
|
[ "USE: locals [let |" eval( -- ) ] [ error>> unexpected-eof? ] must-fail-with
|
||||||
[ "USE: locals [let | a" eval ] [ error>> unexpected-eof? ] must-fail-with
|
[ "USE: locals [let | a" eval( -- ) ] [ error>> unexpected-eof? ] must-fail-with
|
||||||
[ "USE: locals [|" eval ] [ error>> unexpected-eof? ] must-fail-with
|
[ "USE: locals [|" eval( -- ) ] [ error>> unexpected-eof? ] must-fail-with
|
||||||
|
|
||||||
[ 25 ] [ 5 [| a | { [ a sq ] } cond ] call ] unit-test
|
[ 25 ] [ 5 [| a | { [ a sq ] } cond ] call ] unit-test
|
||||||
[ 25 ] [ 5 [| | { [| a | a sq ] } ] call first call ] unit-test
|
[ 25 ] [ 5 [| | { [| a | a sq ] } ] call first call ] unit-test
|
||||||
|
@ -491,19 +491,19 @@ M:: integer lambda-method-forget-test ( a -- b ) ;
|
||||||
|
|
||||||
[ 3 ] [ 3 [| a | \ a ] call ] unit-test
|
[ 3 ] [ 3 [| a | \ a ] call ] unit-test
|
||||||
|
|
||||||
[ "USE: locals [| | { [let | a [ 0 ] | a ] } ]" eval ] must-fail
|
[ "USE: locals [| | { [let | a [ 0 ] | a ] } ]" eval( -- ) ] must-fail
|
||||||
|
|
||||||
[ "USE: locals [| | { [wlet | a [ 0 ] | a ] } ]" eval ] must-fail
|
[ "USE: locals [| | { [wlet | a [ 0 ] | a ] } ]" eval( -- ) ] must-fail
|
||||||
|
|
||||||
[ "USE: locals [| | { [let* | a [ 0 ] | a ] } ]" eval ] must-fail
|
[ "USE: locals [| | { [let* | a [ 0 ] | a ] } ]" eval( -- ) ] must-fail
|
||||||
|
|
||||||
[ "USE: locals [| | [let | a! [ 0 ] | { a! } ] ]" eval ] must-fail
|
[ "USE: locals [| | [let | a! [ 0 ] | { a! } ] ]" eval( -- ) ] must-fail
|
||||||
|
|
||||||
[ "USE: locals [| | [wlet | a [ 0 ] | { a } ] ]" eval ] must-fail
|
[ "USE: locals [| | [wlet | a [ 0 ] | { a } ] ]" eval( -- ) ] must-fail
|
||||||
|
|
||||||
[ "USE: locals [| | { :> a } ]" eval ] must-fail
|
[ "USE: locals [| | { :> a } ]" eval( -- ) ] must-fail
|
||||||
|
|
||||||
[ "USE: locals 3 :> a" eval ] must-fail
|
[ "USE: locals 3 :> a" eval( -- ) ] must-fail
|
||||||
|
|
||||||
[ 3 ] [ 3 [| | :> a a ] call ] unit-test
|
[ 3 ] [ 3 [| | :> a a ] call ] unit-test
|
||||||
|
|
||||||
|
|
|
@ -13,11 +13,11 @@ unit-test
|
||||||
[ t ] [ \ see-test macro? ] unit-test
|
[ t ] [ \ see-test macro? ] unit-test
|
||||||
|
|
||||||
[ t ] [
|
[ t ] [
|
||||||
"USING: math ;\nIN: macros.tests\n: see-test ( a b -- c ) - ;\n" dup eval
|
"USING: math ;\nIN: macros.tests\n: see-test ( a b -- c ) - ;\n" dup eval( -- )
|
||||||
[ \ see-test see ] with-string-writer =
|
[ \ see-test see ] with-string-writer =
|
||||||
] unit-test
|
] unit-test
|
||||||
|
|
||||||
[ f ] [ \ see-test macro? ] unit-test
|
[ f ] [ \ see-test macro? ] unit-test
|
||||||
|
|
||||||
[ ] [ "USING: macros stack-checker kernel ; IN: hanging-macro MACRO: c ( quot -- ) infer drop [ ] ; : a ( -- ) [ a ] c ;" eval ] unit-test
|
[ ] [ "USING: macros stack-checker kernel ; IN: hanging-macro MACRO: c ( quot -- ) infer drop [ ] ; : a ( -- ) [ a ] c ;" eval( -- ) ] unit-test
|
||||||
|
|
||||||
|
|
|
@ -62,8 +62,7 @@ MACRO: match-cond ( assoc -- )
|
||||||
} cond ;
|
} cond ;
|
||||||
|
|
||||||
: match-replace ( object pattern1 pattern2 -- result )
|
: match-replace ( object pattern1 pattern2 -- result )
|
||||||
-rot
|
[ match [ "Pattern does not match" throw ] unless* ] dip swap
|
||||||
match [ "Pattern does not match" throw ] unless*
|
|
||||||
[ replace-patterns ] bind ;
|
[ replace-patterns ] bind ;
|
||||||
|
|
||||||
: ?1-tail ( seq -- tail/f )
|
: ?1-tail ( seq -- tail/f )
|
||||||
|
|
|
@ -255,11 +255,11 @@ IN: math.intervals.tests
|
||||||
0 pick interval-contains? over first \ recip eq? and [
|
0 pick interval-contains? over first \ recip eq? and [
|
||||||
2drop t
|
2drop t
|
||||||
] [
|
] [
|
||||||
[ [ random-element ] dip first execute ] 2keep
|
[ [ random-element ] dip first execute( a -- b ) ] 2keep
|
||||||
second execute interval-contains?
|
second execute( a -- b ) interval-contains?
|
||||||
] if ;
|
] if ;
|
||||||
|
|
||||||
[ t ] [ 80000 [ drop unary-test ] all? ] unit-test
|
[ t ] [ 80000 iota [ drop unary-test ] all? ] unit-test
|
||||||
|
|
||||||
: random-binary-op ( -- pair )
|
: random-binary-op ( -- pair )
|
||||||
{
|
{
|
||||||
|
@ -286,11 +286,11 @@ IN: math.intervals.tests
|
||||||
0 pick interval-contains? over first { / /i mod rem } member? and [
|
0 pick interval-contains? over first { / /i mod rem } member? and [
|
||||||
3drop t
|
3drop t
|
||||||
] [
|
] [
|
||||||
[ [ [ random-element ] bi@ ] dip first execute ] 3keep
|
[ [ [ random-element ] bi@ ] dip first execute( a b -- c ) ] 3keep
|
||||||
second execute interval-contains?
|
second execute( a b -- c ) interval-contains?
|
||||||
] if ;
|
] if ;
|
||||||
|
|
||||||
[ t ] [ 80000 [ drop binary-test ] all? ] unit-test
|
[ t ] [ 80000 iota [ drop binary-test ] all? ] unit-test
|
||||||
|
|
||||||
: random-comparison ( -- pair )
|
: random-comparison ( -- pair )
|
||||||
{
|
{
|
||||||
|
@ -305,7 +305,7 @@ IN: math.intervals.tests
|
||||||
[ [ [ random-element ] bi@ ] dip first execute ] 3keep
|
[ [ [ random-element ] bi@ ] dip first execute ] 3keep
|
||||||
second execute dup incomparable eq? [ 2drop t ] [ = ] if ;
|
second execute dup incomparable eq? [ 2drop t ] [ = ] if ;
|
||||||
|
|
||||||
[ t ] [ 40000 [ drop comparison-test ] all? ] unit-test
|
[ t ] [ 40000 iota [ drop comparison-test ] all? ] unit-test
|
||||||
|
|
||||||
[ t ] [ -10 10 [a,b] 0 100 [a,b] assume> 0 10 (a,b] = ] unit-test
|
[ t ] [ -10 10 [a,b] 0 100 [a,b] assume> 0 10 (a,b] = ] unit-test
|
||||||
|
|
||||||
|
@ -322,7 +322,7 @@ IN: math.intervals.tests
|
||||||
[ t ] [ -10 10 [a,b] interval-abs 0 10 [a,b] = ] unit-test
|
[ t ] [ -10 10 [a,b] interval-abs 0 10 [a,b] = ] unit-test
|
||||||
|
|
||||||
! Test that commutative interval ops really are
|
! Test that commutative interval ops really are
|
||||||
: random-interval-or-empty ( -- )
|
: random-interval-or-empty ( -- obj )
|
||||||
10 random 0 = [ empty-interval ] [ random-interval ] if ;
|
10 random 0 = [ empty-interval ] [ random-interval ] if ;
|
||||||
|
|
||||||
: random-commutative-op ( -- op )
|
: random-commutative-op ( -- op )
|
||||||
|
@ -333,7 +333,7 @@ IN: math.intervals.tests
|
||||||
} random ;
|
} random ;
|
||||||
|
|
||||||
[ t ] [
|
[ t ] [
|
||||||
80000 [
|
80000 iota [
|
||||||
drop
|
drop
|
||||||
random-interval-or-empty random-interval-or-empty
|
random-interval-or-empty random-interval-or-empty
|
||||||
random-commutative-op
|
random-commutative-op
|
||||||
|
|
|
@ -9,7 +9,7 @@ MEMO: fib ( m -- n )
|
||||||
|
|
||||||
[ 89 ] [ 10 fib ] unit-test
|
[ 89 ] [ 10 fib ] unit-test
|
||||||
|
|
||||||
[ "USING: kernel math memoize generalizations ; IN: memoize.tests MEMO: x ( a b c d e -- f g h i j ) [ 1+ ] 4 ndip ;" eval ] must-fail
|
[ "USING: kernel math memoize generalizations ; IN: memoize.tests MEMO: x ( a b c d e -- f g h i j ) [ 1+ ] 4 ndip ;" eval( -- ) ] must-fail
|
||||||
|
|
||||||
MEMO: see-test ( a -- b ) reverse ;
|
MEMO: see-test ( a -- b ) reverse ;
|
||||||
|
|
||||||
|
@ -17,7 +17,7 @@ MEMO: see-test ( a -- b ) reverse ;
|
||||||
[ [ \ see-test see ] with-string-writer ]
|
[ [ \ see-test see ] with-string-writer ]
|
||||||
unit-test
|
unit-test
|
||||||
|
|
||||||
[ ] [ "IN: memoize.tests : fib ( -- ) ;" eval ] unit-test
|
[ ] [ "IN: memoize.tests : fib ( -- ) ;" eval( -- ) ] unit-test
|
||||||
|
|
||||||
[ "IN: memoize.tests\n: fib ( -- ) ;\n" ] [ [ \ fib see ] with-string-writer ] unit-test
|
[ "IN: memoize.tests\n: fib ( -- ) ;\n" ] [ [ \ fib see ] with-string-writer ] unit-test
|
||||||
|
|
||||||
|
|
|
@ -61,3 +61,5 @@ M: memoized reset-word
|
||||||
|
|
||||||
: invalidate-memoized ( inputs... word -- )
|
: invalidate-memoized ( inputs... word -- )
|
||||||
[ stack-effect in>> packer call ] [ "memoize" word-prop delete-at ] bi ;
|
[ stack-effect in>> packer call ] [ "memoize" word-prop delete-at ] bi ;
|
||||||
|
|
||||||
|
\ invalidate-memoized t "no-compile" set-word-prop
|
|
@ -137,9 +137,6 @@ ERROR: no-content-disposition multipart ;
|
||||||
[ no-content-disposition ]
|
[ no-content-disposition ]
|
||||||
} case ;
|
} case ;
|
||||||
|
|
||||||
: assert-sequence= ( a b -- )
|
|
||||||
2dup sequence= [ 2drop ] [ assert ] if ;
|
|
||||||
|
|
||||||
: read-assert-sequence= ( sequence -- )
|
: read-assert-sequence= ( sequence -- )
|
||||||
[ length read ] keep assert-sequence= ;
|
[ length read ] keep assert-sequence= ;
|
||||||
|
|
||||||
|
|
|
@ -56,6 +56,6 @@ TUPLE: color
|
||||||
! Test reshaping with a mirror
|
! Test reshaping with a mirror
|
||||||
1 2 3 color boa <mirror> "mirror" set
|
1 2 3 color boa <mirror> "mirror" set
|
||||||
|
|
||||||
[ ] [ "IN: mirrors.tests USE: math TUPLE: color { green integer } { red integer } { blue integer } ;" eval ] unit-test
|
[ ] [ "IN: mirrors.tests USE: math TUPLE: color { green integer } { red integer } { blue integer } ;" eval( -- ) ] unit-test
|
||||||
|
|
||||||
[ 1 ] [ "red" "mirror" get at ] unit-test
|
[ 1 ] [ "red" "mirror" get at ] unit-test
|
||||||
|
|
|
@ -0,0 +1 @@
|
||||||
|
Slava Pestov
|
|
@ -7,15 +7,15 @@ HELP: <smart-arrow>
|
||||||
{ $examples
|
{ $examples
|
||||||
"A model which adds the values of two existing models:"
|
"A model which adds the values of two existing models:"
|
||||||
{ $example
|
{ $example
|
||||||
"USING: models models.arrows.smart accessors math prettyprint ;"
|
"USING: models models.arrow.smart accessors kernel math prettyprint ;"
|
||||||
"1 <model> 2 <model> [ + ] <smart-arrow>"
|
"1 <model> 2 <model> [ + ] <smart-arrow>"
|
||||||
"[ activate-model ] [ value>> ] bi ."
|
"[ activate-model ] [ value>> ] bi ."
|
||||||
"3"
|
"3"
|
||||||
}
|
}
|
||||||
} ;
|
} ;
|
||||||
|
|
||||||
ARTICLE: "models.arrows.smart" "Smart arrow models"
|
ARTICLE: "models.arrow.smart" "Smart arrow models"
|
||||||
"The " { $vocab-link "models.arrows.smart" } " vocabulary generalizes arrows to arbitrary input arity. They're called “smart” because they resemble " { $link "combinators.smart" } "."
|
"The " { $vocab-link "models.arrow.smart" } " vocabulary generalizes arrows to arbitrary input arity. They're called “smart” because they resemble " { $link "combinators.smart" } "."
|
||||||
{ $subsection <smart-arrow> } ;
|
{ $subsection <smart-arrow> } ;
|
||||||
|
|
||||||
ABOUT: "models.arrows.smart"
|
ABOUT: "models.arrow.smart"
|
Some files were not shown because too many files have changed in this diff Show More
Loading…
Reference in New Issue