Merge branch 'master' into experimental
commit
dac233992a
|
@ -25,3 +25,5 @@ build-support/wordsize
|
|||
.#*
|
||||
*.swo
|
||||
checksums.txt
|
||||
*.so
|
||||
a.out
|
||||
|
|
|
@ -58,3 +58,10 @@ $nl
|
|||
"} cond >>"
|
||||
}
|
||||
"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.
|
||||
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
|
||||
|
||||
: parse-arglist ( parameters return -- types effect )
|
||||
|
@ -12,8 +12,15 @@ IN: alien.parser
|
|||
: function-quot ( return library function types -- quot )
|
||||
'[ _ _ _ _ alien-invoke ] ;
|
||||
|
||||
:: define-function ( return library function parameters -- )
|
||||
:: make-function ( return library function parameters -- word quot effect )
|
||||
function create-in dup reset-generic
|
||||
return library function
|
||||
parameters return parse-arglist [ function-quot ] dip
|
||||
define-declared ;
|
||||
parameters return parse-arglist [ function-quot ] dip ;
|
||||
|
||||
: (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: FUNCTION:
|
||||
scan "c-library" get scan ";" parse-tokens
|
||||
[ "()" subseq? not ] filter
|
||||
define-function ;
|
||||
(FUNCTION:) define-declared ;
|
||||
|
||||
SYNTAX: TYPEDEF:
|
||||
scan scan typedef ;
|
||||
|
|
|
@ -8,7 +8,7 @@ namespaces eval kernel vocabs.loader io ;
|
|||
(command-line) parse-command-line
|
||||
load-vocab-roots
|
||||
run-user-init
|
||||
"e" get [ eval ] when*
|
||||
"e" get [ eval( -- ) ] when*
|
||||
ignore-cli-args? not script get and
|
||||
[ run-script ] [ "run" get run ] if*
|
||||
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
|
||||
io.pathnames io.backend system parser vocabs sequences
|
||||
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 ;
|
||||
IN: bootstrap.stage2
|
||||
|
||||
|
@ -81,14 +81,11 @@ SYMBOL: bootstrap-time
|
|||
"none" require
|
||||
] if
|
||||
|
||||
[
|
||||
load-components
|
||||
load-components
|
||||
|
||||
millis over - core-bootstrap-time set-global
|
||||
millis over - core-bootstrap-time set-global
|
||||
|
||||
run-bootstrap-init
|
||||
] with-compiler-errors
|
||||
:errors
|
||||
run-bootstrap-init
|
||||
|
||||
f error set-global
|
||||
f error-continuation set-global
|
||||
|
|
|
@ -6,6 +6,7 @@ IN: bootstrap.tools
|
|||
"bootstrap.image"
|
||||
"tools.annotations"
|
||||
"tools.crossref"
|
||||
"tools.errors"
|
||||
"tools.deploy"
|
||||
"tools.disassembler"
|
||||
"tools.memory"
|
||||
|
|
|
@ -5,6 +5,7 @@ kernel kernel.private layouts assocs words summary arrays
|
|||
combinators classes.algebra alien alien.c-types alien.structs
|
||||
alien.strings alien.arrays alien.complex sets libc alien.libraries
|
||||
continuations.private fry cpu.architecture
|
||||
source-files.errors
|
||||
compiler.errors
|
||||
compiler.alien
|
||||
compiler.cfg
|
||||
|
@ -379,8 +380,7 @@ TUPLE: no-such-library name ;
|
|||
M: no-such-library summary
|
||||
drop "Library not found" ;
|
||||
|
||||
M: no-such-library compiler-error-type
|
||||
drop +linkage+ ;
|
||||
M: no-such-library error-type drop +linkage-error+ ;
|
||||
|
||||
: no-such-library ( name -- )
|
||||
\ no-such-library boa
|
||||
|
@ -391,8 +391,7 @@ TUPLE: no-such-symbol name ;
|
|||
M: no-such-symbol summary
|
||||
drop "Symbol not found" ;
|
||||
|
||||
M: no-such-symbol compiler-error-type
|
||||
drop +linkage+ ;
|
||||
M: no-such-symbol error-type drop +linkage-error+ ;
|
||||
|
||||
: no-such-symbol ( name -- )
|
||||
\ no-such-symbol boa
|
||||
|
|
|
@ -1,5 +1,7 @@
|
|||
USING: help.markup help.syntax words io parser
|
||||
assocs words.private sequences compiler.units quotations ;
|
||||
USING: assocs compiler.cfg.builder compiler.cfg.optimizer
|
||||
compiler.errors compiler.tree.builder compiler.tree.optimizer
|
||||
compiler.units help.markup help.syntax io parser quotations
|
||||
sequences words words.private ;
|
||||
IN: compiler
|
||||
|
||||
HELP: enable-compiler
|
||||
|
@ -18,6 +20,24 @@ ARTICLE: "compiler-usage" "Calling the optimizing compiler"
|
|||
{ $subsection compile-call }
|
||||
"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"
|
||||
"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
|
||||
|
@ -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."
|
||||
{ $subsection "compiler-errors" }
|
||||
{ $subsection "hints" }
|
||||
{ $subsection "compiler-usage" } ;
|
||||
{ $subsection "compiler-usage" }
|
||||
{ $subsection "compiler-impl" } ;
|
||||
|
||||
ABOUT: "compiler"
|
||||
|
||||
|
|
|
@ -2,7 +2,7 @@
|
|||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors kernel namespaces arrays sequences io words fry
|
||||
continuations vocabs assocs dlists definitions math graphs generic
|
||||
combinators deques search-deques macros io stack-checker
|
||||
combinators deques search-deques macros io source-files.errors stack-checker
|
||||
stack-checker.state stack-checker.inlining combinators.short-circuit
|
||||
compiler.errors compiler.units compiler.tree.builder
|
||||
compiler.tree.optimizer compiler.cfg.builder compiler.cfg.optimizer
|
||||
|
@ -53,22 +53,30 @@ SYMBOLS: +optimized+ +unoptimized+ ;
|
|||
f swap compiler-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 ]
|
||||
[ f swap compiled get set-at ]
|
||||
[ +unoptimized+ save-compiled-status ]
|
||||
tri
|
||||
] 2bi
|
||||
{
|
||||
[ inline? ]
|
||||
[ macro? ]
|
||||
[ "transform-quot" word-prop ]
|
||||
[ "no-compile" word-prop ]
|
||||
[ "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 ;
|
||||
|
||||
: fail ( word error -- * )
|
||||
[ 2dup ignore-error? [ drop f ] when swap compiler-error ] [ drop (fail) ] 2bi ;
|
||||
|
||||
: 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.
|
||||
SYMBOL: compile-dependencies?
|
||||
|
@ -122,6 +130,8 @@ t compile-dependencies? set-global
|
|||
: compile-call ( quot -- )
|
||||
[ dup infer define-temp ] with-compilation-unit execute ;
|
||||
|
||||
\ compile-call t "no-compile" set-word-prop
|
||||
|
||||
SINGLETON: optimizing-compiler
|
||||
|
||||
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
|
||||
GENERIC: foldable-generic ( a -- b ) foldable
|
||||
M: integer foldable-generic f <array> ;
|
||||
"> eval
|
||||
"> eval( -- )
|
||||
] unit-test
|
||||
|
||||
[ ] [
|
||||
|
@ -20,7 +20,7 @@ IN: compiler.tests
|
|||
USING: math arrays ;
|
||||
IN: compiler.tests.folding
|
||||
: fold-test ( -- x ) 10 foldable-generic ;
|
||||
"> eval
|
||||
"> eval( -- )
|
||||
] unit-test
|
||||
|
||||
[ t ] [
|
||||
|
|
|
@ -11,7 +11,7 @@ M: integer method-redefine-generic-1 3 + ;
|
|||
|
||||
[ 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
|
||||
|
||||
|
@ -27,7 +27,7 @@ M: integer method-redefine-generic-2 3 + ;
|
|||
|
||||
[ 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
|
||||
|
||||
|
@ -43,10 +43,10 @@ M: integer method-redefine-generic-2 3 + ;
|
|||
|
||||
[ t ] [ \ hey 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 ] [ \ there optimized>> ] unit-test
|
||||
[ ] [ "IN: compiler.tests : hey ( -- ) ;" eval ] unit-test
|
||||
[ ] [ "IN: compiler.tests : hey ( -- ) ;" eval( -- ) ] unit-test
|
||||
[ t ] [ \ there optimized>> ] unit-test
|
||||
|
||||
: good ( -- ) ;
|
||||
|
@ -59,7 +59,7 @@ M: integer method-redefine-generic-2 3 + ;
|
|||
|
||||
[ 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 ] [ \ bad optimized>> ] unit-test
|
||||
|
@ -67,7 +67,7 @@ M: integer method-redefine-generic-2 3 + ;
|
|||
|
||||
[ 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 ] [ \ bad optimized>> ] unit-test
|
||||
|
|
|
@ -13,7 +13,7 @@ IN: compiler.tests
|
|||
MIXIN: my-mixin
|
||||
INSTANCE: fixnum my-mixin
|
||||
: my-inline ( a -- b ) dup my-mixin instance? [ 1 + ] when ;
|
||||
"> eval
|
||||
"> eval( -- )
|
||||
] unit-test
|
||||
|
||||
[ ] [
|
||||
|
@ -21,7 +21,7 @@ IN: compiler.tests
|
|||
USE: math
|
||||
IN: compiler.tests.redefine10
|
||||
INSTANCE: float my-mixin
|
||||
"> eval
|
||||
"> eval( -- )
|
||||
] unit-test
|
||||
|
||||
[ 2.0 ] [
|
||||
|
|
|
@ -17,7 +17,7 @@ IN: compiler.tests
|
|||
M: my-mixin my-generic drop 0 ;
|
||||
M: object my-generic drop 1 ;
|
||||
: my-inline ( -- b ) { } my-generic ;
|
||||
"> eval
|
||||
"> eval( -- )
|
||||
] unit-test
|
||||
|
||||
[ ] [
|
||||
|
|
|
@ -15,6 +15,6 @@ M: object g drop t ;
|
|||
|
||||
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
|
||||
|
|
|
@ -5,7 +5,7 @@ arrays words assocs eval words.symbol ;
|
|||
|
||||
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
|
||||
|
||||
|
|
|
@ -18,7 +18,7 @@ M: empty-mixin sheeple drop "wake up" ;
|
|||
[ 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
|
||||
|
||||
[ ] [ "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
|
||||
[ 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
|
||||
|
||||
[ ] [ "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
|
||||
|
|
|
@ -14,7 +14,7 @@ IN: compiler.tests
|
|||
GENERIC: my-generic ( a -- b )
|
||||
M: object my-generic [ <=> ] sort ;
|
||||
: my-inline ( a -- b ) my-generic ;
|
||||
"> eval
|
||||
"> eval( -- )
|
||||
] unit-test
|
||||
|
||||
[ ] [
|
||||
|
@ -23,7 +23,7 @@ IN: compiler.tests
|
|||
IN: compiler.tests.redefine5
|
||||
TUPLE: my-tuple ;
|
||||
M: my-tuple my-generic drop 0 ;
|
||||
"> eval
|
||||
"> eval( -- )
|
||||
] unit-test
|
||||
|
||||
[ 0 ] [
|
||||
|
|
|
@ -14,7 +14,7 @@ IN: compiler.tests
|
|||
MIXIN: my-mixin
|
||||
M: my-mixin my-generic drop 0 ;
|
||||
: my-inline ( a -- b ) { my-mixin } declare my-generic ;
|
||||
"> eval
|
||||
"> eval( -- )
|
||||
] unit-test
|
||||
|
||||
[ ] [
|
||||
|
@ -24,7 +24,7 @@ IN: compiler.tests
|
|||
TUPLE: my-tuple ;
|
||||
M: my-tuple my-generic drop 1 ;
|
||||
INSTANCE: my-tuple my-mixin
|
||||
"> eval
|
||||
"> eval( -- )
|
||||
] unit-test
|
||||
|
||||
[ 1 ] [
|
||||
|
|
|
@ -13,7 +13,7 @@ IN: compiler.tests
|
|||
MIXIN: my-mixin
|
||||
INSTANCE: fixnum my-mixin
|
||||
: my-inline ( a -- b ) dup my-mixin? [ 1 + ] when ;
|
||||
"> eval
|
||||
"> eval( -- )
|
||||
] unit-test
|
||||
|
||||
[ ] [
|
||||
|
@ -21,7 +21,7 @@ IN: compiler.tests
|
|||
USE: math
|
||||
IN: compiler.tests.redefine7
|
||||
INSTANCE: float my-mixin
|
||||
"> eval
|
||||
"> eval( -- )
|
||||
] unit-test
|
||||
|
||||
[ 2.0 ] [
|
||||
|
|
|
@ -16,7 +16,7 @@ IN: compiler.tests
|
|||
! We add the bogus quotation here to hinder inlining
|
||||
! since otherwise we cannot trigger this bug.
|
||||
M: my-mixin my-generic 1 + [ [ <=> ] sort ] drop ;
|
||||
"> eval
|
||||
"> eval( -- )
|
||||
] unit-test
|
||||
|
||||
[ ] [
|
||||
|
@ -24,7 +24,7 @@ IN: compiler.tests
|
|||
USE: math
|
||||
IN: compiler.tests.redefine8
|
||||
INSTANCE: float my-mixin
|
||||
"> eval
|
||||
"> eval( -- )
|
||||
] unit-test
|
||||
|
||||
[ 2.0 ] [
|
||||
|
|
|
@ -16,7 +16,7 @@ IN: compiler.tests
|
|||
! We add the bogus quotation here to hinder inlining
|
||||
! since otherwise we cannot trigger this bug.
|
||||
M: my-mixin my-generic 1 + [ [ <=> ] sort ] drop ;
|
||||
"> eval
|
||||
"> eval( -- )
|
||||
] unit-test
|
||||
|
||||
[ ] [
|
||||
|
@ -25,7 +25,7 @@ IN: compiler.tests
|
|||
IN: compiler.tests.redefine9
|
||||
TUPLE: my-tuple ;
|
||||
INSTANCE: my-tuple my-mixin
|
||||
"> eval
|
||||
"> eval( -- )
|
||||
] unit-test
|
||||
|
||||
[
|
||||
|
|
|
@ -237,6 +237,6 @@ M: f single-combination-test-2 single-combination-test-4 ;
|
|||
10 [
|
||||
[ "compiler.tests.foo" forget-vocab ] with-compilation-unit
|
||||
[ 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
|
||||
] times
|
||||
|
|
|
@ -42,8 +42,10 @@ IN: compiler.tree.builder
|
|||
: check-cannot-infer ( word -- )
|
||||
dup "cannot-infer" word-prop [ cannot-infer-effect ] [ drop ] if ;
|
||||
|
||||
TUPLE: do-not-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 )
|
||||
[
|
||||
|
@ -56,3 +58,6 @@ IN: compiler.tree.builder
|
|||
} cleave
|
||||
] maybe-cannot-infer
|
||||
] 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)
|
||||
] 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 ] [
|
||||
[ { bignum } declare annotate-entry-test-2 ]
|
||||
|
@ -302,7 +302,7 @@ cell-bits 32 = [
|
|||
] unit-test
|
||||
|
||||
[ t ] [
|
||||
[ 1000 [ 1+ ] map ] { 1+ fixnum+ } inlined?
|
||||
[ 1000 iota [ 1+ ] map ] { 1+ fixnum+ } inlined?
|
||||
] unit-test
|
||||
|
||||
: rec ( a -- b )
|
||||
|
@ -519,4 +519,4 @@ cell-bits 32 = [
|
|||
[ t ] [
|
||||
[ { integer integer } declare + drop ]
|
||||
{ + +-integer-integer } inlined?
|
||||
] unit-test
|
||||
] unit-test
|
||||
|
|
|
@ -17,13 +17,13 @@ sequences accessors tools.test kernel math ;
|
|||
|
||||
[ 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? ] find nip child>> first in-d>> length ;
|
||||
|
||||
[ 0 2 ] [
|
||||
[ foo ] build-tree
|
||||
[ 1 3 ] [
|
||||
[ [ swap ] foo ] build-tree
|
||||
[ recursive-inputs ]
|
||||
[ analyze-recursive normalize recursive-inputs ] bi
|
||||
] unit-test
|
||||
|
@ -34,18 +34,18 @@ sequences accessors tools.test kernel math ;
|
|||
[ ] [ [ [ 1 ] [ 2 ] if + * ] test-normalization ] unit-test
|
||||
|
||||
DEFER: bbb
|
||||
: aaa ( x -- ) dup [ dup [ bbb ] dip aaa ] [ drop ] if ; inline recursive
|
||||
: bbb ( x -- ) [ drop 0 ] dip aaa ; inline recursive
|
||||
: aaa ( obj x -- obj ) dup [ dup [ bbb ] dip aaa ] [ drop ] if ; inline recursive
|
||||
: bbb ( obj x -- obj ) [ drop 0 ] dip aaa ; inline recursive
|
||||
|
||||
[ ] [ [ bbb ] test-normalization ] unit-test
|
||||
|
||||
: ccc ( -- ) ccc drop 1 ; inline recursive
|
||||
: ccc ( obj -- 1 ) ccc drop 1 ; inline recursive
|
||||
|
||||
[ ] [ [ ccc ] test-normalization ] unit-test
|
||||
|
||||
DEFER: eee
|
||||
: ddd ( -- ) eee ; inline recursive
|
||||
: eee ( -- ) swap ddd ; inline recursive
|
||||
: ddd ( a b -- a b ) eee ; inline recursive
|
||||
: eee ( a b -- a b ) swap ddd ; inline recursive
|
||||
|
||||
[ ] [ [ eee ] test-normalization ] unit-test
|
||||
|
||||
|
|
|
@ -148,7 +148,11 @@ DEFER: (flat-length)
|
|||
] sum-outputs ;
|
||||
|
||||
: 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
|
||||
|
||||
|
|
|
@ -680,11 +680,11 @@ TUPLE: littledan-2 { from read-only } { to read-only } ;
|
|||
: (littledan-3-test) ( x -- )
|
||||
length 1+ f <array> (littledan-3-test) ; inline recursive
|
||||
|
||||
: littledan-3-test ( x -- )
|
||||
: littledan-3-test ( -- )
|
||||
0 f <array> (littledan-3-test) ; inline
|
||||
|
||||
[ ] [ [ littledan-3-test ] final-classes drop ] unit-test
|
||||
|
||||
[ V{ 0 } ] [ [ { } length ] final-literals ] unit-test
|
||||
|
||||
[ V{ 1 } ] [ [ { } length 1+ f <array> length ] final-literals ] unit-test
|
||||
[ V{ 1 } ] [ [ { } length 1+ f <array> length ] final-literals ] unit-test
|
||||
|
|
|
@ -57,7 +57,7 @@ compiler.tree.combinators ;
|
|||
\ (each-integer) label-is-loop?
|
||||
] unit-test
|
||||
|
||||
: loop-test-2 ( a -- )
|
||||
: loop-test-2 ( a b -- a' )
|
||||
dup [ 1+ loop-test-2 1- ] [ drop ] if ; inline recursive
|
||||
|
||||
[ t ] [
|
||||
|
|
|
@ -3,7 +3,7 @@ USING: sequences tools.test concurrency.exchangers
|
|||
concurrency.count-downs concurrency.promises locals kernel
|
||||
threads ;
|
||||
|
||||
:: exchanger-test ( -- )
|
||||
:: exchanger-test ( -- string )
|
||||
[let |
|
||||
ex [ <exchanger> ]
|
||||
c [ 2 <count-down> ]
|
||||
|
|
|
@ -11,7 +11,7 @@ kernel threads locals accessors calendar ;
|
|||
|
||||
[ f ] [ flag-test-1 ] unit-test
|
||||
|
||||
:: flag-test-2 ( -- )
|
||||
:: flag-test-2 ( -- ? )
|
||||
[let | f [ <flag> ] |
|
||||
[ 1 seconds sleep f raise-flag ] "Flag test" spawn drop
|
||||
f lower-flag
|
||||
|
|
|
@ -7,6 +7,10 @@ IN: concurrency.promises
|
|||
HELP: promise
|
||||
{ $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?
|
||||
{ $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." } ;
|
||||
|
|
|
@ -310,7 +310,7 @@ CONSTANT: rs-reg 30
|
|||
4 ds-reg 0 LWZ
|
||||
5 ds-reg -4 LWZU
|
||||
5 0 4 CMP
|
||||
2 swap execute ! magic number
|
||||
2 swap execute( offset -- ) ! magic number
|
||||
\ f tag-number 3 LI
|
||||
3 ds-reg 0 STW ;
|
||||
|
||||
|
@ -341,7 +341,7 @@ CONSTANT: rs-reg 30
|
|||
: jit-math ( insn -- )
|
||||
3 ds-reg 0 LWZ
|
||||
4 ds-reg -4 LWZU
|
||||
[ 5 3 4 ] dip execute
|
||||
[ 5 3 4 ] dip execute( dst src1 src2 -- )
|
||||
5 ds-reg 0 STW ;
|
||||
|
||||
[ \ ADD jit-math ] f f f \ fixnum+fast define-sub-primitive
|
||||
|
|
|
@ -334,7 +334,7 @@ big-endian off
|
|||
! compare with second value
|
||||
ds-reg [] temp0 CMP
|
||||
! move t if true
|
||||
[ temp1 temp3 ] dip execute
|
||||
[ temp1 temp3 ] dip execute( dst src -- )
|
||||
! store
|
||||
ds-reg [] temp1 MOV ;
|
||||
|
||||
|
@ -355,7 +355,7 @@ big-endian off
|
|||
! pop stack
|
||||
ds-reg bootstrap-cell SUB
|
||||
! 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
|
||||
|
||||
|
|
|
@ -8,8 +8,9 @@ classes.mixin classes.tuple continuations continuations.private
|
|||
combinators generic.math classes.builtin classes compiler.units
|
||||
generic.standard vocabs init kernel.private io.encodings
|
||||
accessors math.order destructors source-files parser
|
||||
classes.tuple.parser effects.parser lexer compiler.errors
|
||||
generic.parser strings.parser vocabs.loader vocabs.parser ;
|
||||
classes.tuple.parser effects.parser lexer
|
||||
generic.parser strings.parser vocabs.loader vocabs.parser see
|
||||
source-files.errors ;
|
||||
IN: debugger
|
||||
|
||||
GENERIC: error. ( error -- )
|
||||
|
@ -213,14 +214,13 @@ M: condition error-help error>> error-help ;
|
|||
|
||||
M: assert summary drop "Assertion failed" ;
|
||||
|
||||
M: assert error.
|
||||
"Assertion failed" print
|
||||
M: assert-sequence summary drop "Assertion failed" ;
|
||||
|
||||
M: assert-sequence error.
|
||||
standard-table-style [
|
||||
15 length-limit set
|
||||
5 line-limit set
|
||||
[ expect>> [ [ "Expect:" write ] with-cell pprint-cell ] with-row ]
|
||||
[ got>> [ [ "Got:" write ] with-cell pprint-cell ] with-row ] bi
|
||||
] tabular-output nl ;
|
||||
[ "=== Expected:" print expected>> stack. ]
|
||||
[ "=== Got:" print got>> stack. ] bi
|
||||
] tabular-output ;
|
||||
|
||||
M: immutable summary drop "Sequence is immutable" ;
|
||||
|
||||
|
@ -268,20 +268,6 @@ M: duplicate-slot-names summary
|
|||
M: invalid-slot-name summary
|
||||
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
|
||||
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
|
||||
error>> error-help ;
|
||||
|
||||
M: object compiler-error. ( error word -- )
|
||||
nl
|
||||
"While compiling " write pprint ": " print
|
||||
nl
|
||||
print-error ;
|
||||
|
||||
M: bad-effect summary
|
||||
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> 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{ } ] [ bee protocol-consult ] unit-test
|
||||
|
||||
|
@ -63,22 +63,22 @@ CONSULT: beta hey value>> 1- ;
|
|||
[ 0 ] [ 1 <hey> three ] unit-test
|
||||
[ { hey } ] [ alpha 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 \ 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 } ] [ beta protocol-users ] unit-test
|
||||
[ 2 ] [ 1 <hey> one ] unit-test
|
||||
[ 0 ] [ 1 <hey> two ] unit-test
|
||||
[ 0 ] [ 1 <hey> three ] 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
|
||||
[ -1 ] [ 1 <hey> two ] unit-test
|
||||
[ -1 ] [ 1 <hey> three ] 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
|
||||
|
||||
TUPLE: slot-protocol-test-1 a b ;
|
||||
|
@ -196,4 +196,4 @@ DEFER: seq-delegate
|
|||
seq-delegate
|
||||
sequence-protocol \ protocol-consult word-prop
|
||||
key?
|
||||
] unit-test
|
||||
] unit-test
|
||||
|
|
|
@ -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
|
||||
|
||||
ARTICLE: "editor" "Editor integration"
|
||||
|
@ -13,6 +14,9 @@ ARTICLE: "editor" "Editor integration"
|
|||
|
||||
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
|
||||
{ $values { "defspec" "a definition specifier" } }
|
||||
{ $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.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: parser lexer kernel namespaces sequences definitions
|
||||
io.files io.backend io.pathnames io summary continuations
|
||||
tools.crossref tools.vocabs prettyprint source-files assocs
|
||||
USING: parser lexer kernel namespaces sequences definitions io.files
|
||||
io.backend io.pathnames io summary continuations tools.crossref
|
||||
tools.vocabs prettyprint source-files source-files.errors assocs
|
||||
vocabs vocabs.loader splitting accessors debugger prettyprint
|
||||
help.topics ;
|
||||
IN: editors
|
||||
|
@ -57,7 +57,7 @@ M: lexer-error error-line
|
|||
[ error>> error-line ] [ line>> ] bi or ;
|
||||
|
||||
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
|
||||
error>> error-line ;
|
||||
|
@ -81,6 +81,9 @@ M: object error-line
|
|||
: :edit ( -- )
|
||||
error get (:edit) ;
|
||||
|
||||
: edit-error ( error -- )
|
||||
[ file>> ] [ line#>> ] bi 2dup and [ edit-location ] [ 2drop ] if ;
|
||||
|
||||
: edit-each ( seq -- )
|
||||
[
|
||||
[ "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
|
||||
USING: help.markup help.syntax strings io ;
|
||||
USING: help.markup help.syntax strings io effects ;
|
||||
|
||||
HELP: eval
|
||||
{ $values { "str" string } }
|
||||
{ $description "Parses Factor source code from a string, and calls the resulting quotation." }
|
||||
{ $values { "str" string } { "effect" effect } }
|
||||
{ $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." } ;
|
||||
|
||||
HELP: eval>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"
|
||||
"The " { $vocab-link "eval" } " vocabulary implements support for evaluating strings at runtime."
|
||||
{ $subsection eval }
|
||||
{ $subsection POSTPONE: eval( }
|
||||
{ $subsection eval>string } ;
|
||||
|
||||
ABOUT: "eval"
|
||||
|
|
|
@ -1,4 +1,6 @@
|
|||
IN: eval.tests
|
||||
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
|
||||
|
|
|
@ -1,23 +1,25 @@
|
|||
! Copyright (C) 2008, 2009 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: splitting parser compiler.units kernel namespaces
|
||||
debugger io.streams.string fry ;
|
||||
debugger io.streams.string fry combinators effects.parser ;
|
||||
IN: eval
|
||||
|
||||
: parse-string ( str -- quot )
|
||||
[ string-lines parse-lines ] with-compilation-unit ;
|
||||
|
||||
: (eval) ( str -- )
|
||||
parse-string call ;
|
||||
: (eval) ( str effect -- )
|
||||
[ parse-string ] dip call-effect ; inline
|
||||
|
||||
: eval ( str -- )
|
||||
[ (eval) ] with-file-vocabs ;
|
||||
: eval ( str effect -- )
|
||||
[ (eval) ] with-file-vocabs ; inline
|
||||
|
||||
SYNTAX: eval( \ eval parse-call( ;
|
||||
|
||||
: (eval>string) ( str -- output )
|
||||
[
|
||||
"quiet" on
|
||||
parser-notes off
|
||||
'[ _ (eval) ] try
|
||||
'[ _ (( -- )) (eval) ] try
|
||||
] with-string-writer ;
|
||||
|
||||
: eval>string ( str -- output )
|
||||
|
|
|
@ -56,7 +56,7 @@ sequences eval accessors ;
|
|||
3 '[ [ [ _ 1array ] call 1array ] call 1array ] call
|
||||
] 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
|
||||
|
||||
[ { { "a" 1 } { "b" 2 } { "c" 3 } { "d" 4 } } ] [
|
||||
|
|
|
@ -22,7 +22,7 @@ M: foo call-responder*
|
|||
"x" [ 1+ ] schange
|
||||
"x" sget number>string "text/html" <content> ;
|
||||
|
||||
: url-responder-mock-test ( -- )
|
||||
: url-responder-mock-test ( -- string )
|
||||
[
|
||||
<request>
|
||||
"GET" >>method
|
||||
|
@ -34,7 +34,7 @@ M: foo call-responder*
|
|||
[ write-response-body drop ] with-string-writer
|
||||
] with-destructors ;
|
||||
|
||||
: sessions-mock-test ( -- )
|
||||
: sessions-mock-test ( -- string )
|
||||
[
|
||||
<request>
|
||||
"GET" >>method
|
||||
|
|
|
@ -272,8 +272,8 @@ HELP: nweave
|
|||
|
||||
HELP: n*quot
|
||||
{ $values
|
||||
{ "n" integer } { "seq" sequence }
|
||||
{ "seq'" sequence }
|
||||
{ "n" integer } { "quot" quotation }
|
||||
{ "quot'" quotation }
|
||||
}
|
||||
{ $examples
|
||||
{ $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
|
||||
|
||||
|
@ -94,4 +94,4 @@ MACRO: nweave ( n -- )
|
|||
: nappend-as ( n exemplar -- seq )
|
||||
[ narray concat ] dip like ; inline
|
||||
|
||||
: nappend ( n -- seq ) narray concat ; inline
|
||||
: nappend ( n -- seq ) narray concat ; inline
|
||||
|
|
|
@ -4,11 +4,11 @@ IN: hash2.tests
|
|||
[ t ] [ 1 2 { 1 2 } 2= ] unit-test
|
||||
[ f ] [ 1 3 { 1 2 } 2= ] unit-test
|
||||
|
||||
: sample-hash ( -- )
|
||||
: sample-hash ( -- hash )
|
||||
5 <hash2>
|
||||
dup 2 3 "foo" roll set-hash2
|
||||
dup 4 2 "bar" roll set-hash2
|
||||
dup 4 7 "other" roll set-hash2 ;
|
||||
[ [ 2 3 "foo" ] dip set-hash2 ] keep
|
||||
[ [ 4 2 "bar" ] dip set-hash2 ] keep
|
||||
[ [ 4 7 "other" ] dip set-hash2 ] keep ;
|
||||
|
||||
[ "foo" ] [ 2 3 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
|
||||
|
||||
! Little ad-hoc datastructure used to map two numbers
|
||||
|
@ -22,8 +24,8 @@ IN: hash2
|
|||
: assoc2 ( a b alist -- value )
|
||||
(assoc2) dup [ third ] when ; inline
|
||||
|
||||
: set-assoc2 ( value a b alist -- alist )
|
||||
[ rot 3array ] dip ?push ; inline
|
||||
:: set-assoc2 ( value a b alist -- alist )
|
||||
{ a b value } alist ?push ; inline
|
||||
|
||||
: hash2@ ( a b hash2 -- a b bucket hash2 )
|
||||
[ 2dup hashcode2 ] dip [ length mod ] keep ; inline
|
||||
|
@ -31,8 +33,8 @@ IN: hash2
|
|||
: hash2 ( a b hash2 -- value/f )
|
||||
hash2@ nth dup [ assoc2 ] [ 3drop f ] if ;
|
||||
|
||||
: set-hash2 ( a b value hash2 -- )
|
||||
[ -rot ] dip hash2@ [ set-assoc2 ] change-nth ;
|
||||
:: set-hash2 ( a b value hash2 -- )
|
||||
value a b hash2 hash2@ [ set-assoc2 ] change-nth ;
|
||||
|
||||
: alist>hash2 ( alist size -- hash2 )
|
||||
<hash2> [ over [ first3 ] dip set-hash2 ] reduce ; inline
|
||||
|
|
|
@ -54,7 +54,7 @@ IN: heaps.tests
|
|||
: sort-entries ( entries -- entries' )
|
||||
[ [ key>> ] compare ] sort ;
|
||||
|
||||
: delete-test ( n -- ? )
|
||||
: delete-test ( n -- obj1 obj2 )
|
||||
[
|
||||
random-alist
|
||||
<min-heap> [ heap-push-all ] keep
|
||||
|
|
|
@ -74,7 +74,7 @@ $nl
|
|||
"shuffle-words"
|
||||
"words"
|
||||
"generic"
|
||||
"tools"
|
||||
"handbook-tools-reference"
|
||||
} ;
|
||||
|
||||
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 ;
|
||||
|
||||
[ ] [
|
||||
"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
|
||||
|
||||
[ $subsection ] [
|
||||
|
@ -23,7 +23,7 @@ io.streams.string continuations debugger compiler.units eval ;
|
|||
] 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
|
||||
|
||||
[ ] [
|
||||
|
|
|
@ -32,7 +32,7 @@ IN: help.definitions.tests
|
|||
"hello" "help.definitions.tests" lookup "help" word-prop
|
||||
] 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
|
||||
|
||||
|
|
|
@ -5,7 +5,7 @@ math system strings sbufs vectors byte-arrays quotations
|
|||
io.streams.byte-array classes.builtin parser lexer
|
||||
classes.predicate classes.union classes.intersection
|
||||
classes.singleton classes.tuple help.vocabs math.parser
|
||||
accessors definitions ;
|
||||
accessors definitions sets ;
|
||||
IN: help.handbook
|
||||
|
||||
ARTICLE: "conventions" "Conventions"
|
||||
|
@ -13,13 +13,13 @@ ARTICLE: "conventions" "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."
|
||||
$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
|
||||
"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" }
|
||||
"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
|
||||
"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" }
|
||||
"These conventions are not hard and fast, but are usually a good first step in understanding a word's behavior:"
|
||||
{ $table
|
||||
|
@ -197,29 +197,6 @@ ARTICLE: "io" "Input and output"
|
|||
{ $subsection "io.ports" }
|
||||
{ $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"
|
||||
{ $index [ articles get keys ] } ;
|
||||
|
||||
|
@ -248,59 +225,79 @@ ARTICLE: "class-index" "Class index"
|
|||
|
||||
USING: help.cookbook help.tutorial ;
|
||||
|
||||
ARTICLE: "handbook-language-reference" "Language reference"
|
||||
"Fundamentals:"
|
||||
ARTICLE: "handbook-language-reference" "The language"
|
||||
{ $heading "Fundamentals" }
|
||||
{ $subsection "conventions" }
|
||||
{ $subsection "syntax" }
|
||||
{ $subsection "effects" }
|
||||
"Data types:"
|
||||
{ $subsection "evaluator" }
|
||||
{ $heading "Data types" }
|
||||
{ $subsection "booleans" }
|
||||
{ $subsection "numbers" }
|
||||
{ $subsection "collections" }
|
||||
"Evaluation semantics:"
|
||||
{ $subsection "evaluator" }
|
||||
{ $heading "Evaluation" }
|
||||
{ $subsection "words" }
|
||||
{ $subsection "shuffle-words" }
|
||||
{ $subsection "combinators" }
|
||||
{ $subsection "errors" }
|
||||
{ $subsection "continuations" }
|
||||
"Named values:"
|
||||
{ $heading "Named values" }
|
||||
{ $subsection "locals" }
|
||||
{ $subsection "namespaces" }
|
||||
{ $subsection "namespaces-global" }
|
||||
{ $subsection "values" }
|
||||
"Abstractions:"
|
||||
{ $heading "Abstractions" }
|
||||
{ $subsection "objects" }
|
||||
{ $subsection "destructors" }
|
||||
{ $subsection "macros" }
|
||||
{ $subsection "fry" }
|
||||
"Program organization:"
|
||||
{ $heading "Program organization" }
|
||||
{ $subsection "vocabs.loader" }
|
||||
"Vocabularies tagged " { $link T{ vocab-tag { name "extensions" } } } " implement various additional language abstractions." ;
|
||||
|
||||
ARTICLE: "handbook-environment-reference" "Environment reference"
|
||||
"Parse time and compile time:"
|
||||
ARTICLE: "handbook-system-reference" "The implementation"
|
||||
{ $heading "Parse time and compile time" }
|
||||
{ $subsection "parser" }
|
||||
{ $subsection "definitions" }
|
||||
{ $subsection "vocabularies" }
|
||||
{ $subsection "source-files" }
|
||||
{ $subsection "compiler" }
|
||||
"Tools:"
|
||||
{ $subsection "prettyprint" }
|
||||
{ $subsection "tools" }
|
||||
{ $subsection "help" }
|
||||
{ $subsection "inference" }
|
||||
{ $heading "Virtual machine" }
|
||||
{ $subsection "images" }
|
||||
"VM:"
|
||||
{ $subsection "cli" }
|
||||
{ $subsection "rc-files" }
|
||||
{ $subsection "init" }
|
||||
{ $subsection "system" }
|
||||
{ $subsection "layouts" } ;
|
||||
|
||||
ARTICLE: "handbook-library-reference" "Library reference"
|
||||
"This index only includes articles from loaded vocabularies. To explore more vocabularies, see " { $link "vocab-index" } "."
|
||||
{ $index [ "handbook" orphan-articles remove ] } ;
|
||||
ARTICLE: "handbook-tools-reference" "Developer tools"
|
||||
"The below tools are text-based. " { $link "ui-tools" } " are documented separately."
|
||||
{ $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"
|
||||
"Learn the language:"
|
||||
|
@ -308,11 +305,11 @@ ARTICLE: "handbook" "Factor handbook"
|
|||
{ $subsection "first-program" }
|
||||
"Reference material:"
|
||||
{ $subsection "handbook-language-reference" }
|
||||
{ $subsection "handbook-environment-reference" }
|
||||
{ $subsection "io" }
|
||||
{ $subsection "ui" }
|
||||
{ $subsection "handbook-system-reference" }
|
||||
{ $subsection "handbook-tools-reference" }
|
||||
{ $subsection "ui-tools" }
|
||||
{ $subsection "unicode" }
|
||||
{ $subsection "alien" }
|
||||
{ $subsection "handbook-library-reference" }
|
||||
"Explore loaded libraries:"
|
||||
|
|
|
@ -8,6 +8,7 @@ ARTICLE: "help.home" "Factor documentation"
|
|||
{ $link "handbook" }
|
||||
{ $link "vocab-index" }
|
||||
{ $link "ui-tools" }
|
||||
{ $link "ui-listener" }
|
||||
}
|
||||
{ $heading "Recently visited" }
|
||||
{ $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:"
|
||||
{ $subsection help-lint }
|
||||
{ $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:"
|
||||
{ $list
|
||||
"ensures examples run and produce stated output"
|
||||
|
|
|
@ -1,161 +1,53 @@
|
|||
! Copyright (C) 2006, 2009 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: fry accessors sequences parser kernel help help.markup
|
||||
help.topics words strings classes tools.vocabs namespaces make
|
||||
io io.streams.string prettyprint definitions arrays vectors
|
||||
combinators combinators.short-circuit splitting debugger
|
||||
hashtables sorting effects vocabs vocabs.loader assocs editors
|
||||
continuations classes.predicate macros math sets eval
|
||||
vocabs.parser words.symbol values grouping unicode.categories
|
||||
sequences.deep ;
|
||||
USING: assocs continuations fry help help.lint.checks
|
||||
help.topics io kernel namespaces parser sequences
|
||||
source-files.errors tools.vocabs vocabs words classes
|
||||
locals tools.errors ;
|
||||
FROM: help.lint.checks => all-vocabs ;
|
||||
IN: help.lint
|
||||
|
||||
SYMBOL: vocabs-quot
|
||||
SYMBOL: lint-failures
|
||||
|
||||
: check-example ( element -- )
|
||||
'[
|
||||
_ rest [
|
||||
but-last "\n" join
|
||||
[ (eval>string) ] call( code -- output )
|
||||
"\n" ?tail drop
|
||||
] keep
|
||||
peek assert=
|
||||
] vocabs-quot get call( quot -- ) ;
|
||||
lint-failures [ H{ } clone ] initialize
|
||||
|
||||
: check-examples ( element -- )
|
||||
\ $example swap elements [ check-example ] each ;
|
||||
TUPLE: help-lint-error < source-file-error ;
|
||||
|
||||
: extract-values ( element -- seq )
|
||||
\ $values swap elements dup empty? [
|
||||
first rest [ first ] map prune natural-sort
|
||||
] unless ;
|
||||
SYMBOL: +help-lint-failure+
|
||||
|
||||
: effect-values ( word -- seq )
|
||||
stack-effect
|
||||
[ in>> ] [ out>> ] bi append
|
||||
[ dup pair? [ first ] when effect>string ] map
|
||||
prune natural-sort ;
|
||||
T{ error-type
|
||||
{ type +help-lint-failure+ }
|
||||
{ word ":lint-failures" }
|
||||
{ plural "help lint failures" }
|
||||
{ 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 -- ? )
|
||||
{
|
||||
$shuffle
|
||||
$values-x/y
|
||||
$predicate
|
||||
$class-description
|
||||
$error-description
|
||||
} swap '[ _ elements empty? not ] any? ;
|
||||
M: help-lint-error error-type drop +help-lint-failure+ ;
|
||||
|
||||
: don't-check-word? ( word -- ? )
|
||||
{
|
||||
[ macro? ]
|
||||
[ symbol? ]
|
||||
[ value-word? ]
|
||||
[ parsing-word? ]
|
||||
[ "declared-effect" word-prop not ]
|
||||
} 1|| ;
|
||||
<PRIVATE
|
||||
|
||||
: 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" throw ] unless ;
|
||||
: <help-lint-error> ( error topic -- help-lint-error )
|
||||
\ help-lint-error <definition-error> ;
|
||||
|
||||
: check-nulls ( element -- )
|
||||
\ $values swap elements
|
||||
null swap deep-member?
|
||||
[ "$values should not contain null" throw ] when ;
|
||||
PRIVATE>
|
||||
|
||||
: check-see-also ( element -- )
|
||||
\ $see-also swap elements [
|
||||
rest dup prune [ length ] bi@ assert=
|
||||
] each ;
|
||||
: help-lint-error ( error topic -- )
|
||||
lint-failures get pick
|
||||
[ [ [ <help-lint-error> ] keep ] dip set-at ] [ delete-at drop ] if
|
||||
notify-error-observers ;
|
||||
|
||||
: vocab-exists? ( name -- ? )
|
||||
[ vocab ] [ "all-vocabs" get member? ] bi or ;
|
||||
<PRIVATE
|
||||
|
||||
: check-modules ( element -- )
|
||||
\ $vocab-link swap elements [
|
||||
second
|
||||
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-something ( topic quot -- )
|
||||
[ quot call( -- ) f ] [ ] recover
|
||||
topic help-lint-error ; inline
|
||||
|
||||
: check-word ( word -- )
|
||||
[ with-file-vocabs ] vocabs-quot set
|
||||
dup word-help [
|
||||
dup '[
|
||||
[ >link ] keep '[
|
||||
_ dup word-help
|
||||
[ check-values ]
|
||||
[ check-class-description ]
|
||||
|
@ -165,69 +57,38 @@ M: help-error error.
|
|||
|
||||
: 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 -- )
|
||||
[ with-interactive-vocabs ] vocabs-quot set
|
||||
dup '[
|
||||
>link dup '[
|
||||
_
|
||||
[ check-article-title ]
|
||||
[ article-content check-markup ] bi
|
||||
] 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 -- )
|
||||
dup '[ _ vocab-help [ article drop ] when* ] check-something ;
|
||||
|
||||
: check-vocab ( vocab -- seq )
|
||||
: check-vocab ( vocab -- )
|
||||
"Checking " write dup write "..." print
|
||||
[
|
||||
[ check-about ]
|
||||
[ words [ check-word ] each ]
|
||||
[ "vocab-articles" get at [ check-article ] each ]
|
||||
tri
|
||||
] { } make ;
|
||||
[ vocab check-about ]
|
||||
[ words [ check-word ] each ]
|
||||
[ vocab-articles get at [ check-article ] each ]
|
||||
tri ;
|
||||
|
||||
: run-help-lint ( prefix -- alist )
|
||||
PRIVATE>
|
||||
|
||||
: help-lint ( prefix -- )
|
||||
[
|
||||
all-vocabs-seq [ vocab-name ] map "all-vocabs" set
|
||||
group-articles "vocab-articles" set
|
||||
all-vocabs-seq [ vocab-name ] map all-vocabs set
|
||||
group-articles vocab-articles set
|
||||
child-vocabs
|
||||
[ dup check-vocab ] { } map>assoc
|
||||
[ nip empty? not ] assoc-filter
|
||||
[ check-vocab ] each
|
||||
] 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 ;
|
||||
|
||||
: :lint-failures ( -- ) lint-failures get errors. ;
|
||||
|
||||
: unlinked-words ( words -- seq )
|
||||
all-word-help [ article-parent not ] filter ;
|
||||
|
||||
|
@ -235,6 +96,6 @@ M: help-error error.
|
|||
all-words
|
||||
[ word-help not ] filter
|
||||
[ article-parent ] filter
|
||||
[ "predicating" word-prop not ] filter ;
|
||||
[ predicate? not ] filter ;
|
||||
|
||||
MAIN: help-lint
|
||||
|
|
|
@ -4,12 +4,12 @@ IN: help.syntax.tests
|
|||
|
||||
[
|
||||
[ "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
|
||||
] unit-test
|
||||
|
||||
[ { "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
|
||||
] unit-test
|
||||
|
||||
|
|
|
@ -29,7 +29,7 @@ SYMBOL: foo
|
|||
} "\n" join
|
||||
[
|
||||
"testfile" source-file file set
|
||||
eval
|
||||
eval( -- )
|
||||
] with-scope
|
||||
] unit-test
|
||||
|
||||
|
|
|
@ -76,9 +76,11 @@ $nl
|
|||
{ $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" } "."
|
||||
$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
|
||||
"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
|
||||
"Add the following three lines to " { $snippet "palindrome-tests.factor" } ":"
|
||||
{ $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
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: io kernel ;
|
||||
USING: io kernel sequences ;
|
||||
IN: io.crlf
|
||||
|
||||
: crlf ( -- )
|
||||
|
@ -8,4 +8,4 @@ IN: io.crlf
|
|||
|
||||
: read-crlf ( -- seq )
|
||||
"\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" }
|
||||
{ "encoding" "an encoding descriptor" }
|
||||
{ "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
|
||||
{ $values { "process" process } { "status" object } }
|
||||
|
@ -175,7 +214,11 @@ ARTICLE: "io.launcher.launch" "Launching processes"
|
|||
"Redirecting standard input and output to a pipe:"
|
||||
{ $subsection <process-reader> }
|
||||
{ $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"
|
||||
"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" "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" tokenize-command ] must-fail
|
||||
[ V{ "abc def" "h\"ey" } ] [ "'abc def' \"h\\\"ey\" " 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
|
||||
[ "\"abc def\" \"hey" tokenize-command ] must-fail
|
||||
[ "\"abc def" tokenize-command ] must-fail
|
||||
[ V{ "abc def" "h\"ey" } ] [ "\"abc def\" \"h\\\"ey\" " tokenize-command ] unit-test
|
||||
|
||||
[
|
||||
V{
|
||||
|
|
|
@ -1,33 +1,17 @@
|
|||
! Copyright (C) 2008 Slava Pestov
|
||||
! 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
|
||||
|
||||
! Our command line parser. Supported syntax:
|
||||
! foo bar baz -- simple tokens
|
||||
! foo\ bar -- escaping the space
|
||||
! 'foo bar' -- quotation
|
||||
! "foo bar" -- quotation
|
||||
: 'escaped-char' ( -- parser )
|
||||
"\\" token any-char 2seq [ second ] action ;
|
||||
|
||||
: 'quoted-char' ( delimiter -- parser' )
|
||||
'escaped-char'
|
||||
swap [ member? not ] curry satisfy
|
||||
2choice ; inline
|
||||
|
||||
: '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 ;
|
||||
EBNF: tokenize-command
|
||||
space = " "
|
||||
escaped-char = "\" .:ch => [[ ch ]]
|
||||
quoted = '"' (escaped-char | [^"])*:a '"' => [[ a ]]
|
||||
unquoted = (escaped-char | [^ "])+
|
||||
argument = (quoted | unquoted) => [[ >string ]]
|
||||
command = space* (argument:a space* => [[ a ]])+:c !(.) => [[ c ]]
|
||||
;EBNF
|
||||
|
|
|
@ -98,7 +98,7 @@ IN: io.launcher.windows.nt.tests
|
|||
<process>
|
||||
console-vm "-script" "env.factor" 3array >>command
|
||||
ascii <process-reader> contents
|
||||
] with-directory eval
|
||||
] with-directory eval( -- alist )
|
||||
|
||||
os-envs =
|
||||
] unit-test
|
||||
|
@ -110,7 +110,7 @@ IN: io.launcher.windows.nt.tests
|
|||
+replace-environment+ >>environment-mode
|
||||
os-envs >>environment
|
||||
ascii <process-reader> contents
|
||||
] with-directory eval
|
||||
] with-directory eval( -- alist )
|
||||
|
||||
os-envs =
|
||||
] unit-test
|
||||
|
@ -121,7 +121,7 @@ IN: io.launcher.windows.nt.tests
|
|||
console-vm "-script" "env.factor" 3array >>command
|
||||
{ { "A" "B" } } >>environment
|
||||
ascii <process-reader> contents
|
||||
] with-directory eval
|
||||
] with-directory eval( -- alist )
|
||||
|
||||
"A" swap at
|
||||
] unit-test
|
||||
|
@ -133,7 +133,7 @@ IN: io.launcher.windows.nt.tests
|
|||
{ { "USERPROFILE" "XXX" } } >>environment
|
||||
+prepend-environment+ >>environment-mode
|
||||
ascii <process-reader> contents
|
||||
] with-directory eval
|
||||
] with-directory eval( -- alist )
|
||||
|
||||
"USERPROFILE" swap at "XXX" =
|
||||
] unit-test
|
||||
|
|
|
@ -192,7 +192,7 @@ M: object (client) ( remote -- client-in client-out local )
|
|||
] with-destructors ;
|
||||
|
||||
: <client> ( remote encoding -- stream local )
|
||||
[ (client) -rot ] dip <encoder-duplex> swap ;
|
||||
[ (client) ] dip swap [ <encoder-duplex> ] dip ;
|
||||
|
||||
SYMBOL: local-address
|
||||
|
||||
|
|
|
@ -274,7 +274,7 @@ HELP: <input>
|
|||
{ $description "Creates a new " { $link input } "." } ;
|
||||
|
||||
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 } "." } ;
|
||||
|
||||
ARTICLE: "io.streams.plain" "Plain writer streams"
|
||||
|
|
|
@ -135,11 +135,11 @@ SYMBOL: wrap-margin
|
|||
SYMBOL: table-gap
|
||||
SYMBOL: table-border
|
||||
|
||||
: standard-table-style ( -- style )
|
||||
CONSTANT: standard-table-style
|
||||
H{
|
||||
{ table-gap { 5 5 } }
|
||||
{ table-border T{ rgba f 0.8 0.8 0.8 1.0 } }
|
||||
} ;
|
||||
}
|
||||
|
||||
! Input history
|
||||
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
|
||||
|
||||
ARTICLE: "listener-watch" "Watching variables in the listener"
|
||||
|
@ -41,32 +41,18 @@ $nl
|
|||
{ $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."
|
||||
{ $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 bye }
|
||||
"Finally, the multi-line expression reading word can be used independently of the rest of the listener:"
|
||||
"To exit the listener, invoke the " { $link return } " word."
|
||||
$nl
|
||||
"Multi-line quotations can be read independently of the rest of the listener:"
|
||||
{ $subsection read-quot } ;
|
||||
|
||||
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
|
||||
{ $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." } ;
|
||||
|
||||
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
|
||||
{ $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
|
||||
"cont" get continue-with
|
||||
] ignore-errors
|
||||
"USE: debugger :1" eval
|
||||
"USE: debugger :1" eval( -- quot )
|
||||
] callcc1
|
||||
] unit-test
|
||||
] 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
|
||||
] unit-test
|
||||
] with-file-vocabs
|
||||
|
|
|
@ -4,7 +4,7 @@ USING: arrays hashtables io kernel math math.parser memory
|
|||
namespaces parser lexer sequences strings io.styles
|
||||
vectors words generic system combinators continuations debugger
|
||||
definitions compiler.units accessors colors prettyprint fry
|
||||
sets vocabs.parser ;
|
||||
sets vocabs.parser source-files.errors locals ;
|
||||
IN: listener
|
||||
|
||||
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 ;
|
||||
|
||||
<PRIVATE
|
||||
|
||||
SYMBOL: quit-flag
|
||||
|
||||
PRIVATE>
|
||||
|
||||
: bye ( -- ) quit-flag on ;
|
||||
|
||||
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 ;
|
||||
|
||||
|
@ -68,6 +60,8 @@ SYMBOL: max-stack-items
|
|||
|
||||
10 max-stack-items set-global
|
||||
|
||||
SYMBOL: error-summary-hook
|
||||
|
||||
<PRIVATE
|
||||
|
||||
: title. ( string -- )
|
||||
|
@ -96,26 +90,44 @@ SYMBOL: max-stack-items
|
|||
] dip
|
||||
] when stack. ;
|
||||
|
||||
: stacks. ( -- )
|
||||
: datastack. ( datastack -- )
|
||||
display-stacks? get [
|
||||
datastack [ nl "--- Data stack:" title. trimmed-stack. ] unless-empty
|
||||
] when ;
|
||||
[ nl "--- Data stack:" title. trimmed-stack. ] unless-empty
|
||||
] [ drop ] if ;
|
||||
|
||||
: 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 ;
|
||||
|
||||
: listen ( -- )
|
||||
visible-vars. stacks. prompt.
|
||||
[ read-quot [ [ call-error-hook ] recover ] [ bye ] if* ]
|
||||
[ dup lexer-error? [ call-error-hook ] [ rethrow ] if ] recover ;
|
||||
[ error-summary ] error-summary-hook set-global
|
||||
|
||||
: until-quit ( -- )
|
||||
quit-flag get [ quit-flag off ] [ listen until-quit ] if ;
|
||||
: call-error-summary-hook ( -- )
|
||||
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>
|
||||
|
||||
: listener ( -- )
|
||||
[ until-quit ] with-interactive-vocabs ;
|
||||
[ [ { } (listener) ] with-interactive-vocabs ] with-return ;
|
||||
|
||||
MAIN: listener
|
||||
|
|
|
@ -106,7 +106,8 @@ PRIVATE>
|
|||
|
||||
: deep-sequence>cons ( sequence -- cons )
|
||||
[ <reversed> ] keep nil
|
||||
[ tuck same? [ deep-sequence>cons ] when swons ] with reduce ;
|
||||
[ [ nip ] [ same? ] 2bi [ deep-sequence>cons ] when swons ]
|
||||
with reduce ;
|
||||
|
||||
<PRIVATE
|
||||
:: (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"
|
||||
|
||||
[ ] [ new-definition eval ] unit-test
|
||||
[ ] [ new-definition eval( -- ) ] unit-test
|
||||
|
||||
[ t ] [
|
||||
[ \ 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 _ + ] ]"
|
||||
eval call
|
||||
eval( -- ) call
|
||||
] [ error>> >r/r>-in-fry-error? ] must-fail-with
|
||||
|
||||
:: (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
|
||||
|
||||
! 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 | a" eval ] [ error>> unexpected-eof? ] must-fail-with
|
||||
[ "USE: locals [|" 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 [|" eval( -- ) ] [ error>> unexpected-eof? ] must-fail-with
|
||||
|
||||
[ 25 ] [ 5 [| a | { [ a sq ] } cond ] 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
|
||||
|
||||
[ "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
|
||||
|
||||
|
@ -584,4 +584,4 @@ M: integer ed's-bug neg ;
|
|||
:: ed's-test-case ( a -- b )
|
||||
{ [ a ed's-bug ] } && ;
|
||||
|
||||
[ t ] [ \ ed's-test-case optimized>> ] unit-test
|
||||
[ t ] [ \ ed's-test-case optimized>> ] unit-test
|
||||
|
|
|
@ -13,11 +13,11 @@ unit-test
|
|||
[ t ] [ \ see-test macro? ] unit-test
|
||||
|
||||
[ 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 =
|
||||
] 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 ;
|
||||
|
||||
: match-replace ( object pattern1 pattern2 -- result )
|
||||
-rot
|
||||
match [ "Pattern does not match" throw ] unless*
|
||||
[ match [ "Pattern does not match" throw ] unless* ] dip swap
|
||||
[ replace-patterns ] bind ;
|
||||
|
||||
: ?1-tail ( seq -- tail/f )
|
||||
|
|
|
@ -255,11 +255,11 @@ IN: math.intervals.tests
|
|||
0 pick interval-contains? over first \ recip eq? and [
|
||||
2drop t
|
||||
] [
|
||||
[ [ random-element ] dip first execute ] 2keep
|
||||
second execute interval-contains?
|
||||
[ [ random-element ] dip first execute( a -- b ) ] 2keep
|
||||
second execute( a -- b ) interval-contains?
|
||||
] if ;
|
||||
|
||||
[ t ] [ 80000 [ drop unary-test ] all? ] unit-test
|
||||
[ t ] [ 80000 iota [ drop unary-test ] all? ] unit-test
|
||||
|
||||
: random-binary-op ( -- pair )
|
||||
{
|
||||
|
@ -286,11 +286,11 @@ IN: math.intervals.tests
|
|||
0 pick interval-contains? over first { / /i mod rem } member? and [
|
||||
3drop t
|
||||
] [
|
||||
[ [ [ random-element ] bi@ ] dip first execute ] 3keep
|
||||
second execute interval-contains?
|
||||
[ [ [ random-element ] bi@ ] dip first execute( a b -- c ) ] 3keep
|
||||
second execute( a b -- c ) interval-contains?
|
||||
] if ;
|
||||
|
||||
[ t ] [ 80000 [ drop binary-test ] all? ] unit-test
|
||||
[ t ] [ 80000 iota [ drop binary-test ] all? ] unit-test
|
||||
|
||||
: random-comparison ( -- pair )
|
||||
{
|
||||
|
@ -305,7 +305,7 @@ IN: math.intervals.tests
|
|||
[ [ [ random-element ] bi@ ] dip first execute ] 3keep
|
||||
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
|
||||
|
||||
|
@ -322,7 +322,7 @@ IN: math.intervals.tests
|
|||
[ t ] [ -10 10 [a,b] interval-abs 0 10 [a,b] = ] unit-test
|
||||
|
||||
! Test that commutative interval ops really are
|
||||
: random-interval-or-empty ( -- )
|
||||
: random-interval-or-empty ( -- obj )
|
||||
10 random 0 = [ empty-interval ] [ random-interval ] if ;
|
||||
|
||||
: random-commutative-op ( -- op )
|
||||
|
@ -333,7 +333,7 @@ IN: math.intervals.tests
|
|||
} random ;
|
||||
|
||||
[ t ] [
|
||||
80000 [
|
||||
80000 iota [
|
||||
drop
|
||||
random-interval-or-empty random-interval-or-empty
|
||||
random-commutative-op
|
||||
|
|
|
@ -9,7 +9,7 @@ MEMO: fib ( m -- n )
|
|||
|
||||
[ 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 ;
|
||||
|
||||
|
@ -17,7 +17,7 @@ MEMO: see-test ( a -- b ) reverse ;
|
|||
[ [ \ see-test see ] with-string-writer ]
|
||||
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
|
||||
|
||||
|
|
|
@ -61,3 +61,5 @@ M: memoized reset-word
|
|||
|
||||
: invalidate-memoized ( inputs... word -- )
|
||||
[ 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 ]
|
||||
} case ;
|
||||
|
||||
: assert-sequence= ( a b -- )
|
||||
2dup sequence= [ 2drop ] [ assert ] if ;
|
||||
|
||||
: read-assert-sequence= ( sequence -- )
|
||||
[ length read ] keep assert-sequence= ;
|
||||
|
||||
|
|
|
@ -56,6 +56,6 @@ TUPLE: color
|
|||
! Test reshaping with a mirror
|
||||
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
|
||||
|
|
|
@ -0,0 +1 @@
|
|||
Slava Pestov
|
|
@ -7,15 +7,15 @@ HELP: <smart-arrow>
|
|||
{ $examples
|
||||
"A model which adds the values of two existing models:"
|
||||
{ $example
|
||||
"USING: models models.arrows.smart accessors math prettyprint ;"
|
||||
"USING: models models.arrow.smart accessors kernel math prettyprint ;"
|
||||
"1 <model> 2 <model> [ + ] <smart-arrow>"
|
||||
"[ activate-model ] [ value>> ] bi ."
|
||||
"3"
|
||||
}
|
||||
} ;
|
||||
|
||||
ARTICLE: "models.arrows.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" } "."
|
||||
ARTICLE: "models.arrow.smart" "Smart arrow models"
|
||||
"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> } ;
|
||||
|
||||
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