Merge branch 'master' into experimental

db4
Alex Chapman 2009-04-20 12:21:54 +10:00
commit dac233992a
329 changed files with 3306 additions and 2036 deletions

2
.gitignore vendored
View File

@ -25,3 +25,5 @@ build-support/wordsize
.#* .#*
*.swo *.swo
checksums.txt checksums.txt
*.so
a.out

View File

@ -58,3 +58,10 @@ $nl
"} cond >>" "} cond >>"
} }
"Note the parse time evaluation with " { $link POSTPONE: << } "." } ; "Note the parse time evaluation with " { $link POSTPONE: << } "." } ;
ARTICLE: "loading-libs" "Loading native libraries"
"Before calling a C library, you must associate its path name on disk with a logical name which Factor uses to identify the library:"
{ $subsection add-library }
"Once a library has been defined, you can try loading it to see if the path name is correct:"
{ $subsection load-library }
"If the compiler cannot load a library, or cannot resolve a symbol in a library, a linkage error is reported using the compiler error mechanism (see " { $link "compiler-errors" } "). Once you install the right library, reload the source file containing the " { $link add-library } " form to force the compiler to try loading the library again." ;

View File

@ -1,7 +1,7 @@
! Copyright (C) 2008 Slava Pestov. ! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: alien alien.c-types arrays assocs effects grouping kernel USING: alien alien.c-types arrays assocs effects grouping kernel
parser sequences splitting words fry locals ; parser sequences splitting words fry locals lexer namespaces ;
IN: alien.parser IN: alien.parser
: parse-arglist ( parameters return -- types effect ) : parse-arglist ( parameters return -- types effect )
@ -12,8 +12,15 @@ IN: alien.parser
: function-quot ( return library function types -- quot ) : function-quot ( return library function types -- quot )
'[ _ _ _ _ alien-invoke ] ; '[ _ _ _ _ alien-invoke ] ;
:: define-function ( return library function parameters -- ) :: make-function ( return library function parameters -- word quot effect )
function create-in dup reset-generic function create-in dup reset-generic
return library function return library function
parameters return parse-arglist [ function-quot ] dip parameters return parse-arglist [ function-quot ] dip ;
define-declared ;
: (FUNCTION:) ( -- word quot effect )
scan "c-library" get scan ";" parse-tokens
[ "()" subseq? not ] filter
make-function ;
: define-function ( return library function parameters -- )
make-function define-declared ;

View File

@ -16,9 +16,7 @@ SYNTAX: BAD-ALIEN <bad-alien> parsed ;
SYNTAX: LIBRARY: scan "c-library" set ; SYNTAX: LIBRARY: scan "c-library" set ;
SYNTAX: FUNCTION: SYNTAX: FUNCTION:
scan "c-library" get scan ";" parse-tokens (FUNCTION:) define-declared ;
[ "()" subseq? not ] filter
define-function ;
SYNTAX: TYPEDEF: SYNTAX: TYPEDEF:
scan scan typedef ; scan scan typedef ;

View File

@ -8,7 +8,7 @@ namespaces eval kernel vocabs.loader io ;
(command-line) parse-command-line (command-line) parse-command-line
load-vocab-roots load-vocab-roots
run-user-init run-user-init
"e" get [ eval ] when* "e" get [ eval( -- ) ] when*
ignore-cli-args? not script get and ignore-cli-args? not script get and
[ run-script ] [ "run" get run ] if* [ run-script ] [ "run" get run ] if*
output-stream get [ stream-flush ] when* output-stream get [ stream-flush ] when*

View File

@ -4,7 +4,7 @@ USING: accessors init namespaces words words.symbol io
kernel.private math memory continuations kernel io.files kernel.private math memory continuations kernel io.files
io.pathnames io.backend system parser vocabs sequences io.pathnames io.backend system parser vocabs sequences
vocabs.loader combinators splitting source-files strings vocabs.loader combinators splitting source-files strings
definitions assocs compiler.errors compiler.units math.parser definitions assocs compiler.units math.parser
generic sets command-line ; generic sets command-line ;
IN: bootstrap.stage2 IN: bootstrap.stage2
@ -81,14 +81,11 @@ SYMBOL: bootstrap-time
"none" require "none" require
] if ] if
[ load-components
load-components
millis over - core-bootstrap-time set-global millis over - core-bootstrap-time set-global
run-bootstrap-init run-bootstrap-init
] with-compiler-errors
:errors
f error set-global f error set-global
f error-continuation set-global f error-continuation set-global

View File

@ -6,6 +6,7 @@ IN: bootstrap.tools
"bootstrap.image" "bootstrap.image"
"tools.annotations" "tools.annotations"
"tools.crossref" "tools.crossref"
"tools.errors"
"tools.deploy" "tools.deploy"
"tools.disassembler" "tools.disassembler"
"tools.memory" "tools.memory"

View File

@ -5,6 +5,7 @@ kernel kernel.private layouts assocs words summary arrays
combinators classes.algebra alien alien.c-types alien.structs combinators classes.algebra alien alien.c-types alien.structs
alien.strings alien.arrays alien.complex sets libc alien.libraries alien.strings alien.arrays alien.complex sets libc alien.libraries
continuations.private fry cpu.architecture continuations.private fry cpu.architecture
source-files.errors
compiler.errors compiler.errors
compiler.alien compiler.alien
compiler.cfg compiler.cfg
@ -379,8 +380,7 @@ TUPLE: no-such-library name ;
M: no-such-library summary M: no-such-library summary
drop "Library not found" ; drop "Library not found" ;
M: no-such-library compiler-error-type M: no-such-library error-type drop +linkage-error+ ;
drop +linkage+ ;
: no-such-library ( name -- ) : no-such-library ( name -- )
\ no-such-library boa \ no-such-library boa
@ -391,8 +391,7 @@ TUPLE: no-such-symbol name ;
M: no-such-symbol summary M: no-such-symbol summary
drop "Symbol not found" ; drop "Symbol not found" ;
M: no-such-symbol compiler-error-type M: no-such-symbol error-type drop +linkage-error+ ;
drop +linkage+ ;
: no-such-symbol ( name -- ) : no-such-symbol ( name -- )
\ no-such-symbol boa \ no-such-symbol boa

View File

@ -1,5 +1,7 @@
USING: help.markup help.syntax words io parser USING: assocs compiler.cfg.builder compiler.cfg.optimizer
assocs words.private sequences compiler.units quotations ; compiler.errors compiler.tree.builder compiler.tree.optimizer
compiler.units help.markup help.syntax io parser quotations
sequences words words.private ;
IN: compiler IN: compiler
HELP: enable-compiler HELP: enable-compiler
@ -18,6 +20,24 @@ ARTICLE: "compiler-usage" "Calling the optimizing compiler"
{ $subsection compile-call } { $subsection compile-call }
"Higher-level words can be found in " { $link "compilation-units" } "." ; "Higher-level words can be found in " { $link "compilation-units" } "." ;
ARTICLE: "compiler-impl" "Compiler implementation"
"The " { $vocab-link "compiler" } "vocabulary, in addition to providing the user-visible words of the compiler, implements the main compilation loop."
$nl
"Words are added to the " { $link compile-queue } " variable as needed and compiled."
{ $subsection compile-queue }
"Once compiled, a word is added to the assoc stored in the " { $link compiled } " variable. When compilation is complete, this assoc is passed to " { $link modify-code-heap } "."
$nl
"The " { $link (compile) } " word performs the actual task of compiling an individual word. The process proceeds as follows:"
{ $list
{ "The " { $link frontend } " word calls " { $link build-tree-from-word } ". If this fails, the error is passed to " { $link fail } ". The logic for ignoring compile warnings generated for inline words and macros is located here. If the error is not ignorable, it is added to the global " { $link compiler-errors } " assoc (see " { $link "compiler-errors" } ")." }
{ "If the word contains a breakpoint, compilation ends here. Otherwise, all remaining steps execute until machine code is generated. Any further errors thrown by the compiler are not reported as compile errors, but instead are ordinary exceptions. This is because they indicate bugs in the compiler, not errors in user code." }
{ "The " { $link frontend } " word then calls " { $link optimize-tree } ". This produces the final optimized tree IR, and this stage of the compiler is complete." }
{ "The " { $link backend } " word calls " { $link build-cfg } " followed by " { $link optimize-cfg } " and a few other stages. Finally, it calls " { $link save-asm } ", and adds any uncompiled words called by this word to the compilation queue with " { $link maybe-compile } "." }
}
"If compilation fails, the word is stored in the " { $link compiled } " assoc with a value of " { $link f } ". This causes the VM to compile the word with the non-optimizing compiler."
$nl
"Calling " { $link modify-code-heap } " is handled not by the " { $vocab-link "compiler" } " vocabulary, but rather " { $vocab-link "compiler.units" } ". The optimizing compiler merely provides an implementation of the " { $link recompile } " generic word." ;
ARTICLE: "compiler" "Optimizing compiler" ARTICLE: "compiler" "Optimizing compiler"
"Factor includes two compilers which work behind the scenes. Words are always compiled, and the compilers do not have to be invoked explicitly. For the most part, compilation is fully transparent. However, there are a few things worth knowing about the compilation process." "Factor includes two compilers which work behind the scenes. Words are always compiled, and the compilers do not have to be invoked explicitly. For the most part, compilation is fully transparent. However, there are a few things worth knowing about the compilation process."
$nl $nl
@ -31,7 +51,8 @@ $nl
"The optimizing compiler also trades off compile time for performance of generated code, so loading certain vocabularies might take a while. Saving the image after loading vocabularies can save you a lot of time that you would spend waiting for the same code to load in every coding session; see " { $link "images" } " for information." "The optimizing compiler also trades off compile time for performance of generated code, so loading certain vocabularies might take a while. Saving the image after loading vocabularies can save you a lot of time that you would spend waiting for the same code to load in every coding session; see " { $link "images" } " for information."
{ $subsection "compiler-errors" } { $subsection "compiler-errors" }
{ $subsection "hints" } { $subsection "hints" }
{ $subsection "compiler-usage" } ; { $subsection "compiler-usage" }
{ $subsection "compiler-impl" } ;
ABOUT: "compiler" ABOUT: "compiler"

View File

@ -2,7 +2,7 @@
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: accessors kernel namespaces arrays sequences io words fry USING: accessors kernel namespaces arrays sequences io words fry
continuations vocabs assocs dlists definitions math graphs generic continuations vocabs assocs dlists definitions math graphs generic
combinators deques search-deques macros io stack-checker combinators deques search-deques macros io source-files.errors stack-checker
stack-checker.state stack-checker.inlining combinators.short-circuit stack-checker.state stack-checker.inlining combinators.short-circuit
compiler.errors compiler.units compiler.tree.builder compiler.errors compiler.units compiler.tree.builder
compiler.tree.optimizer compiler.cfg.builder compiler.cfg.optimizer compiler.tree.optimizer compiler.cfg.builder compiler.cfg.optimizer
@ -53,22 +53,30 @@ SYMBOLS: +optimized+ +unoptimized+ ;
f swap compiler-error ; f swap compiler-error ;
: ignore-error? ( word error -- ? ) : ignore-error? ( word error -- ? )
[ [ inline? ] [ macro? ] bi or ]
[ compiler-error-type +warning+ eq? ] bi* and ;
: fail ( word error -- * )
[ 2dup ignore-error? [ 2drop ] [ swap compiler-error ] if ]
[ [
drop {
[ compiled-unxref ] [ inline? ]
[ f swap compiled get set-at ] [ macro? ]
[ +unoptimized+ save-compiled-status ] [ "transform-quot" word-prop ]
tri [ "no-compile" word-prop ]
] 2bi [ "special" word-prop ]
} 1||
] [ error-type +compiler-warning+ eq? ] bi* and ;
: (fail) ( word -- * )
[ compiled-unxref ]
[ f swap compiled get set-at ]
[ +unoptimized+ save-compiled-status ]
tri
return ; return ;
: fail ( word error -- * )
[ 2dup ignore-error? [ drop f ] when swap compiler-error ] [ drop (fail) ] 2bi ;
: frontend ( word -- nodes ) : frontend ( word -- nodes )
[ build-tree-from-word ] [ fail ] recover optimize-tree ; dup contains-breakpoints? [ (fail) ] [
[ build-tree-from-word ] [ fail ] recover optimize-tree
] if ;
! Only switch this off for debugging. ! Only switch this off for debugging.
SYMBOL: compile-dependencies? SYMBOL: compile-dependencies?
@ -122,6 +130,8 @@ t compile-dependencies? set-global
: compile-call ( quot -- ) : compile-call ( quot -- )
[ dup infer define-temp ] with-compilation-unit execute ; [ dup infer define-temp ] with-compilation-unit execute ;
\ compile-call t "no-compile" set-word-prop
SINGLETON: optimizing-compiler SINGLETON: optimizing-compiler
M: optimizing-compiler recompile ( words -- alist ) M: optimizing-compiler recompile ( words -- alist )

View File

@ -0,0 +1,5 @@
IN: compiler.errors
USING: help.markup help.syntax vocabs.loader words io
quotations words.symbol ;
ABOUT: "compiler-errors"

View File

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

View File

@ -12,7 +12,7 @@ IN: compiler.tests
IN: compiler.tests.folding IN: compiler.tests.folding
GENERIC: foldable-generic ( a -- b ) foldable GENERIC: foldable-generic ( a -- b ) foldable
M: integer foldable-generic f <array> ; M: integer foldable-generic f <array> ;
"> eval "> eval( -- )
] unit-test ] unit-test
[ ] [ [ ] [
@ -20,7 +20,7 @@ IN: compiler.tests
USING: math arrays ; USING: math arrays ;
IN: compiler.tests.folding IN: compiler.tests.folding
: fold-test ( -- x ) 10 foldable-generic ; : fold-test ( -- x ) 10 foldable-generic ;
"> eval "> eval( -- )
] unit-test ] unit-test
[ t ] [ [ t ] [

View File

@ -11,7 +11,7 @@ M: integer method-redefine-generic-1 3 + ;
[ 6 ] [ method-redefine-test-1 ] unit-test [ 6 ] [ method-redefine-test-1 ] unit-test
[ ] [ "IN: compiler.tests USE: math M: fixnum method-redefine-generic-1 4 + ;" eval ] unit-test [ ] [ "IN: compiler.tests USE: math M: fixnum method-redefine-generic-1 4 + ;" eval( -- ) ] unit-test
[ 7 ] [ method-redefine-test-1 ] unit-test [ 7 ] [ method-redefine-test-1 ] unit-test
@ -27,7 +27,7 @@ M: integer method-redefine-generic-2 3 + ;
[ 6 ] [ method-redefine-test-2 ] unit-test [ 6 ] [ method-redefine-test-2 ] unit-test
[ ] [ "IN: compiler.tests USE: kernel USE: math M: fixnum method-redefine-generic-2 4 + ; USE: strings M: string method-redefine-generic-2 drop f ;" eval ] unit-test [ ] [ "IN: compiler.tests USE: kernel USE: math M: fixnum method-redefine-generic-2 4 + ; USE: strings M: string method-redefine-generic-2 drop f ;" eval( -- ) ] unit-test
[ 7 ] [ method-redefine-test-2 ] unit-test [ 7 ] [ method-redefine-test-2 ] unit-test
@ -43,10 +43,10 @@ M: integer method-redefine-generic-2 3 + ;
[ t ] [ \ hey optimized>> ] unit-test [ t ] [ \ hey optimized>> ] unit-test
[ t ] [ \ there optimized>> ] unit-test [ t ] [ \ there optimized>> ] unit-test
[ ] [ "IN: compiler.tests : hey ( -- ) 3 ;" eval ] unit-test [ ] [ "IN: compiler.tests : hey ( -- ) 3 ;" eval( -- ) ] unit-test
[ f ] [ \ hey optimized>> ] unit-test [ f ] [ \ hey optimized>> ] unit-test
[ f ] [ \ there optimized>> ] unit-test [ f ] [ \ there optimized>> ] unit-test
[ ] [ "IN: compiler.tests : hey ( -- ) ;" eval ] unit-test [ ] [ "IN: compiler.tests : hey ( -- ) ;" eval( -- ) ] unit-test
[ t ] [ \ there optimized>> ] unit-test [ t ] [ \ there optimized>> ] unit-test
: good ( -- ) ; : good ( -- ) ;
@ -59,7 +59,7 @@ M: integer method-redefine-generic-2 3 + ;
[ f ] [ \ good compiled-usage assoc-empty? ] unit-test [ f ] [ \ good compiled-usage assoc-empty? ] unit-test
[ ] [ "IN: compiler.tests : good ( -- ) 3 ;" eval ] unit-test [ ] [ "IN: compiler.tests : good ( -- ) 3 ;" eval( -- ) ] unit-test
[ f ] [ \ good optimized>> ] unit-test [ f ] [ \ good optimized>> ] unit-test
[ f ] [ \ bad optimized>> ] unit-test [ f ] [ \ bad optimized>> ] unit-test
@ -67,7 +67,7 @@ M: integer method-redefine-generic-2 3 + ;
[ t ] [ \ good compiled-usage assoc-empty? ] unit-test [ t ] [ \ good compiled-usage assoc-empty? ] unit-test
[ ] [ "IN: compiler.tests : good ( -- ) ;" eval ] unit-test [ ] [ "IN: compiler.tests : good ( -- ) ;" eval( -- ) ] unit-test
[ t ] [ \ good optimized>> ] unit-test [ t ] [ \ good optimized>> ] unit-test
[ t ] [ \ bad optimized>> ] unit-test [ t ] [ \ bad optimized>> ] unit-test

View File

@ -13,7 +13,7 @@ IN: compiler.tests
MIXIN: my-mixin MIXIN: my-mixin
INSTANCE: fixnum my-mixin INSTANCE: fixnum my-mixin
: my-inline ( a -- b ) dup my-mixin instance? [ 1 + ] when ; : my-inline ( a -- b ) dup my-mixin instance? [ 1 + ] when ;
"> eval "> eval( -- )
] unit-test ] unit-test
[ ] [ [ ] [
@ -21,7 +21,7 @@ IN: compiler.tests
USE: math USE: math
IN: compiler.tests.redefine10 IN: compiler.tests.redefine10
INSTANCE: float my-mixin INSTANCE: float my-mixin
"> eval "> eval( -- )
] unit-test ] unit-test
[ 2.0 ] [ [ 2.0 ] [

View File

@ -17,7 +17,7 @@ IN: compiler.tests
M: my-mixin my-generic drop 0 ; M: my-mixin my-generic drop 0 ;
M: object my-generic drop 1 ; M: object my-generic drop 1 ;
: my-inline ( -- b ) { } my-generic ; : my-inline ( -- b ) { } my-generic ;
"> eval "> eval( -- )
] unit-test ] unit-test
[ ] [ [ ] [

View File

@ -15,6 +15,6 @@ M: object g drop t ;
TUPLE: jeah ; TUPLE: jeah ;
[ ] [ "USE: kernel IN: compiler.tests.redefine12 M: jeah g drop f ;" eval ] unit-test [ ] [ "USE: kernel IN: compiler.tests.redefine12 M: jeah g drop f ;" eval( -- ) ] unit-test
[ f ] [ T{ jeah } h ] unit-test [ f ] [ T{ jeah } h ] unit-test

View File

@ -5,7 +5,7 @@ arrays words assocs eval words.symbol ;
DEFER: redefine2-test DEFER: redefine2-test
[ ] [ "USE: sequences USE: kernel IN: compiler.tests TUPLE: redefine2-test ; M: redefine2-test nth 2drop 3 ; INSTANCE: redefine2-test sequence" eval ] unit-test [ ] [ "USE: sequences USE: kernel IN: compiler.tests TUPLE: redefine2-test ; M: redefine2-test nth 2drop 3 ; INSTANCE: redefine2-test sequence" eval( -- ) ] unit-test
[ t ] [ \ redefine2-test symbol? ] unit-test [ t ] [ \ redefine2-test symbol? ] unit-test

View File

@ -18,7 +18,7 @@ M: empty-mixin sheeple drop "wake up" ;
[ t ] [ object \ sheeple method \ sheeple-test "compiled-uses" word-prop key? ] unit-test [ t ] [ object \ sheeple method \ sheeple-test "compiled-uses" word-prop key? ] unit-test
[ f ] [ empty-mixin \ sheeple method \ sheeple-test "compiled-uses" word-prop key? ] unit-test [ f ] [ empty-mixin \ sheeple method \ sheeple-test "compiled-uses" word-prop key? ] unit-test
[ ] [ "IN: compiler.tests USE: arrays INSTANCE: array empty-mixin" eval ] unit-test [ ] [ "IN: compiler.tests USE: arrays INSTANCE: array empty-mixin" eval( -- ) ] unit-test
[ "wake up" ] [ sheeple-test ] unit-test [ "wake up" ] [ sheeple-test ] unit-test
[ f ] [ object \ sheeple method \ sheeple-test "compiled-uses" word-prop key? ] unit-test [ f ] [ object \ sheeple method \ sheeple-test "compiled-uses" word-prop key? ] unit-test

View File

@ -7,6 +7,6 @@ USING: io.streams.string kernel tools.test eval ;
[ "" ] [ [ declaration-test ] with-string-writer ] unit-test [ "" ] [ [ declaration-test ] with-string-writer ] unit-test
[ ] [ "IN: compiler.tests USE: io : declaration-test-1 ( -- a ) \"X\" write f ;" eval ] unit-test [ ] [ "IN: compiler.tests USE: io : declaration-test-1 ( -- a ) \"X\" write f ;" eval( -- ) ] unit-test
[ "X" ] [ [ declaration-test ] with-string-writer ] unit-test [ "X" ] [ [ declaration-test ] with-string-writer ] unit-test

View File

@ -14,7 +14,7 @@ IN: compiler.tests
GENERIC: my-generic ( a -- b ) GENERIC: my-generic ( a -- b )
M: object my-generic [ <=> ] sort ; M: object my-generic [ <=> ] sort ;
: my-inline ( a -- b ) my-generic ; : my-inline ( a -- b ) my-generic ;
"> eval "> eval( -- )
] unit-test ] unit-test
[ ] [ [ ] [
@ -23,7 +23,7 @@ IN: compiler.tests
IN: compiler.tests.redefine5 IN: compiler.tests.redefine5
TUPLE: my-tuple ; TUPLE: my-tuple ;
M: my-tuple my-generic drop 0 ; M: my-tuple my-generic drop 0 ;
"> eval "> eval( -- )
] unit-test ] unit-test
[ 0 ] [ [ 0 ] [

View File

@ -14,7 +14,7 @@ IN: compiler.tests
MIXIN: my-mixin MIXIN: my-mixin
M: my-mixin my-generic drop 0 ; M: my-mixin my-generic drop 0 ;
: my-inline ( a -- b ) { my-mixin } declare my-generic ; : my-inline ( a -- b ) { my-mixin } declare my-generic ;
"> eval "> eval( -- )
] unit-test ] unit-test
[ ] [ [ ] [
@ -24,7 +24,7 @@ IN: compiler.tests
TUPLE: my-tuple ; TUPLE: my-tuple ;
M: my-tuple my-generic drop 1 ; M: my-tuple my-generic drop 1 ;
INSTANCE: my-tuple my-mixin INSTANCE: my-tuple my-mixin
"> eval "> eval( -- )
] unit-test ] unit-test
[ 1 ] [ [ 1 ] [

View File

@ -13,7 +13,7 @@ IN: compiler.tests
MIXIN: my-mixin MIXIN: my-mixin
INSTANCE: fixnum my-mixin INSTANCE: fixnum my-mixin
: my-inline ( a -- b ) dup my-mixin? [ 1 + ] when ; : my-inline ( a -- b ) dup my-mixin? [ 1 + ] when ;
"> eval "> eval( -- )
] unit-test ] unit-test
[ ] [ [ ] [
@ -21,7 +21,7 @@ IN: compiler.tests
USE: math USE: math
IN: compiler.tests.redefine7 IN: compiler.tests.redefine7
INSTANCE: float my-mixin INSTANCE: float my-mixin
"> eval "> eval( -- )
] unit-test ] unit-test
[ 2.0 ] [ [ 2.0 ] [

View File

@ -16,7 +16,7 @@ IN: compiler.tests
! We add the bogus quotation here to hinder inlining ! We add the bogus quotation here to hinder inlining
! since otherwise we cannot trigger this bug. ! since otherwise we cannot trigger this bug.
M: my-mixin my-generic 1 + [ [ <=> ] sort ] drop ; M: my-mixin my-generic 1 + [ [ <=> ] sort ] drop ;
"> eval "> eval( -- )
] unit-test ] unit-test
[ ] [ [ ] [
@ -24,7 +24,7 @@ IN: compiler.tests
USE: math USE: math
IN: compiler.tests.redefine8 IN: compiler.tests.redefine8
INSTANCE: float my-mixin INSTANCE: float my-mixin
"> eval "> eval( -- )
] unit-test ] unit-test
[ 2.0 ] [ [ 2.0 ] [

View File

@ -16,7 +16,7 @@ IN: compiler.tests
! We add the bogus quotation here to hinder inlining ! We add the bogus quotation here to hinder inlining
! since otherwise we cannot trigger this bug. ! since otherwise we cannot trigger this bug.
M: my-mixin my-generic 1 + [ [ <=> ] sort ] drop ; M: my-mixin my-generic 1 + [ [ <=> ] sort ] drop ;
"> eval "> eval( -- )
] unit-test ] unit-test
[ ] [ [ ] [
@ -25,7 +25,7 @@ IN: compiler.tests
IN: compiler.tests.redefine9 IN: compiler.tests.redefine9
TUPLE: my-tuple ; TUPLE: my-tuple ;
INSTANCE: my-tuple my-mixin INSTANCE: my-tuple my-mixin
"> eval "> eval( -- )
] unit-test ] unit-test
[ [

View File

@ -237,6 +237,6 @@ M: f single-combination-test-2 single-combination-test-4 ;
10 [ 10 [
[ "compiler.tests.foo" forget-vocab ] with-compilation-unit [ "compiler.tests.foo" forget-vocab ] with-compilation-unit
[ t ] [ [ t ] [
"USING: prettyprint words accessors ; IN: compiler.tests.foo : (recursive) ( -- ) (recursive) (recursive) ; inline recursive : recursive ( -- ) (recursive) ; \\ (recursive) optimized>>" eval "USING: prettyprint words accessors ; IN: compiler.tests.foo : (recursive) ( -- ) (recursive) (recursive) ; inline recursive : recursive ( -- ) (recursive) ; \\ (recursive) optimized>>" eval( -- obj )
] unit-test ] unit-test
] times ] times

View File

@ -42,8 +42,10 @@ IN: compiler.tree.builder
: check-cannot-infer ( word -- ) : check-cannot-infer ( word -- )
dup "cannot-infer" word-prop [ cannot-infer-effect ] [ drop ] if ; dup "cannot-infer" word-prop [ cannot-infer-effect ] [ drop ] if ;
TUPLE: do-not-compile word ;
: check-no-compile ( word -- ) : check-no-compile ( word -- )
dup "no-compile" word-prop [ cannot-infer-effect ] [ drop ] if ; dup "no-compile" word-prop [ do-not-compile inference-warning ] [ drop ] if ;
: build-tree-from-word ( word -- nodes ) : build-tree-from-word ( word -- nodes )
[ [
@ -56,3 +58,6 @@ IN: compiler.tree.builder
} cleave } cleave
] maybe-cannot-infer ] maybe-cannot-infer
] with-tree-builder ; ] with-tree-builder ;
: contains-breakpoints? ( word -- ? )
def>> [ word? ] filter [ "break?" word-prop ] any? ;

View File

@ -197,7 +197,7 @@ M: fixnum annotate-entry-test-1 drop ;
[ dup annotate-entry-test-1 1+ ] dip (annotate-entry-test-2) [ dup annotate-entry-test-1 1+ ] dip (annotate-entry-test-2)
] if ; inline recursive ] if ; inline recursive
: annotate-entry-test-2 ( from to -- ) 0 -rot (annotate-entry-test-2) ; inline : annotate-entry-test-2 ( from to -- obj ) 0 -rot (annotate-entry-test-2) ; inline
[ f ] [ [ f ] [
[ { bignum } declare annotate-entry-test-2 ] [ { bignum } declare annotate-entry-test-2 ]
@ -302,7 +302,7 @@ cell-bits 32 = [
] unit-test ] unit-test
[ t ] [ [ t ] [
[ 1000 [ 1+ ] map ] { 1+ fixnum+ } inlined? [ 1000 iota [ 1+ ] map ] { 1+ fixnum+ } inlined?
] unit-test ] unit-test
: rec ( a -- b ) : rec ( a -- b )

View File

@ -17,13 +17,13 @@ sequences accessors tools.test kernel math ;
[ 2 ] [ [ 3 [ drop ] [ 2drop 3 ] if ] build-tree count-introductions ] unit-test [ 2 ] [ [ 3 [ drop ] [ 2drop 3 ] if ] build-tree count-introductions ] unit-test
: foo ( -- ) swap ; inline recursive : foo ( quot: ( -- ) -- ) call ; inline recursive
: recursive-inputs ( nodes -- n ) : recursive-inputs ( nodes -- n )
[ #recursive? ] find nip child>> first in-d>> length ; [ #recursive? ] find nip child>> first in-d>> length ;
[ 0 2 ] [ [ 1 3 ] [
[ foo ] build-tree [ [ swap ] foo ] build-tree
[ recursive-inputs ] [ recursive-inputs ]
[ analyze-recursive normalize recursive-inputs ] bi [ analyze-recursive normalize recursive-inputs ] bi
] unit-test ] unit-test
@ -34,18 +34,18 @@ sequences accessors tools.test kernel math ;
[ ] [ [ [ 1 ] [ 2 ] if + * ] test-normalization ] unit-test [ ] [ [ [ 1 ] [ 2 ] if + * ] test-normalization ] unit-test
DEFER: bbb DEFER: bbb
: aaa ( x -- ) dup [ dup [ bbb ] dip aaa ] [ drop ] if ; inline recursive : aaa ( obj x -- obj ) dup [ dup [ bbb ] dip aaa ] [ drop ] if ; inline recursive
: bbb ( x -- ) [ drop 0 ] dip aaa ; inline recursive : bbb ( obj x -- obj ) [ drop 0 ] dip aaa ; inline recursive
[ ] [ [ bbb ] test-normalization ] unit-test [ ] [ [ bbb ] test-normalization ] unit-test
: ccc ( -- ) ccc drop 1 ; inline recursive : ccc ( obj -- 1 ) ccc drop 1 ; inline recursive
[ ] [ [ ccc ] test-normalization ] unit-test [ ] [ [ ccc ] test-normalization ] unit-test
DEFER: eee DEFER: eee
: ddd ( -- ) eee ; inline recursive : ddd ( a b -- a b ) eee ; inline recursive
: eee ( -- ) swap ddd ; inline recursive : eee ( a b -- a b ) swap ddd ; inline recursive
[ ] [ [ eee ] test-normalization ] unit-test [ ] [ [ eee ] test-normalization ] unit-test

View File

@ -148,7 +148,11 @@ DEFER: (flat-length)
] sum-outputs ; ] sum-outputs ;
: should-inline? ( #call word -- ? ) : should-inline? ( #call word -- ? )
dup "inline" word-prop [ 2drop t ] [ inlining-rank 5 >= ] if ; {
{ [ dup contains-breakpoints? ] [ 2drop f ] }
{ [ dup "inline" word-prop ] [ 2drop t ] }
[ inlining-rank 5 >= ]
} cond ;
SYMBOL: history SYMBOL: history

View File

@ -680,7 +680,7 @@ TUPLE: littledan-2 { from read-only } { to read-only } ;
: (littledan-3-test) ( x -- ) : (littledan-3-test) ( x -- )
length 1+ f <array> (littledan-3-test) ; inline recursive length 1+ f <array> (littledan-3-test) ; inline recursive
: littledan-3-test ( x -- ) : littledan-3-test ( -- )
0 f <array> (littledan-3-test) ; inline 0 f <array> (littledan-3-test) ; inline
[ ] [ [ littledan-3-test ] final-classes drop ] unit-test [ ] [ [ littledan-3-test ] final-classes drop ] unit-test

View File

@ -57,7 +57,7 @@ compiler.tree.combinators ;
\ (each-integer) label-is-loop? \ (each-integer) label-is-loop?
] unit-test ] unit-test
: loop-test-2 ( a -- ) : loop-test-2 ( a b -- a' )
dup [ 1+ loop-test-2 1- ] [ drop ] if ; inline recursive dup [ 1+ loop-test-2 1- ] [ drop ] if ; inline recursive
[ t ] [ [ t ] [

View File

@ -3,7 +3,7 @@ USING: sequences tools.test concurrency.exchangers
concurrency.count-downs concurrency.promises locals kernel concurrency.count-downs concurrency.promises locals kernel
threads ; threads ;
:: exchanger-test ( -- ) :: exchanger-test ( -- string )
[let | [let |
ex [ <exchanger> ] ex [ <exchanger> ]
c [ 2 <count-down> ] c [ 2 <count-down> ]

View File

@ -11,7 +11,7 @@ kernel threads locals accessors calendar ;
[ f ] [ flag-test-1 ] unit-test [ f ] [ flag-test-1 ] unit-test
:: flag-test-2 ( -- ) :: flag-test-2 ( -- ? )
[let | f [ <flag> ] | [let | f [ <flag> ] |
[ 1 seconds sleep f raise-flag ] "Flag test" spawn drop [ 1 seconds sleep f raise-flag ] "Flag test" spawn drop
f lower-flag f lower-flag

View File

@ -7,6 +7,10 @@ IN: concurrency.promises
HELP: promise HELP: promise
{ $class-description "The class of write-once promises." } ; { $class-description "The class of write-once promises." } ;
HELP: <promise>
{ $values { "promise" promise } }
{ $description "Creates a new promise which may be fulfilled by calling " { $link fulfill } "." } ;
HELP: promise-fulfilled? HELP: promise-fulfilled?
{ $values { "promise" promise } { "?" "a boolean" } } { $values { "promise" promise } { "?" "a boolean" } }
{ $description "Tests if " { $link fulfill } " has previously been called on the promise, in which case " { $link ?promise } " will return immediately without blocking." } ; { $description "Tests if " { $link fulfill } " has previously been called on the promise, in which case " { $link ?promise } " will return immediately without blocking." } ;

View File

@ -310,7 +310,7 @@ CONSTANT: rs-reg 30
4 ds-reg 0 LWZ 4 ds-reg 0 LWZ
5 ds-reg -4 LWZU 5 ds-reg -4 LWZU
5 0 4 CMP 5 0 4 CMP
2 swap execute ! magic number 2 swap execute( offset -- ) ! magic number
\ f tag-number 3 LI \ f tag-number 3 LI
3 ds-reg 0 STW ; 3 ds-reg 0 STW ;
@ -341,7 +341,7 @@ CONSTANT: rs-reg 30
: jit-math ( insn -- ) : jit-math ( insn -- )
3 ds-reg 0 LWZ 3 ds-reg 0 LWZ
4 ds-reg -4 LWZU 4 ds-reg -4 LWZU
[ 5 3 4 ] dip execute [ 5 3 4 ] dip execute( dst src1 src2 -- )
5 ds-reg 0 STW ; 5 ds-reg 0 STW ;
[ \ ADD jit-math ] f f f \ fixnum+fast define-sub-primitive [ \ ADD jit-math ] f f f \ fixnum+fast define-sub-primitive

View File

@ -334,7 +334,7 @@ big-endian off
! compare with second value ! compare with second value
ds-reg [] temp0 CMP ds-reg [] temp0 CMP
! move t if true ! move t if true
[ temp1 temp3 ] dip execute [ temp1 temp3 ] dip execute( dst src -- )
! store ! store
ds-reg [] temp1 MOV ; ds-reg [] temp1 MOV ;
@ -355,7 +355,7 @@ big-endian off
! pop stack ! pop stack
ds-reg bootstrap-cell SUB ds-reg bootstrap-cell SUB
! compute result ! compute result
[ ds-reg [] temp0 ] dip execute ; [ ds-reg [] temp0 ] dip execute( dst src -- ) ;
[ \ ADD jit-math ] f f f \ fixnum+fast define-sub-primitive [ \ ADD jit-math ] f f f \ fixnum+fast define-sub-primitive

View File

@ -8,8 +8,9 @@ classes.mixin classes.tuple continuations continuations.private
combinators generic.math classes.builtin classes compiler.units combinators generic.math classes.builtin classes compiler.units
generic.standard vocabs init kernel.private io.encodings generic.standard vocabs init kernel.private io.encodings
accessors math.order destructors source-files parser accessors math.order destructors source-files parser
classes.tuple.parser effects.parser lexer compiler.errors classes.tuple.parser effects.parser lexer
generic.parser strings.parser vocabs.loader vocabs.parser ; generic.parser strings.parser vocabs.loader vocabs.parser see
source-files.errors ;
IN: debugger IN: debugger
GENERIC: error. ( error -- ) GENERIC: error. ( error -- )
@ -213,14 +214,13 @@ M: condition error-help error>> error-help ;
M: assert summary drop "Assertion failed" ; M: assert summary drop "Assertion failed" ;
M: assert error. M: assert-sequence summary drop "Assertion failed" ;
"Assertion failed" print
M: assert-sequence error.
standard-table-style [ standard-table-style [
15 length-limit set [ "=== Expected:" print expected>> stack. ]
5 line-limit set [ "=== Got:" print got>> stack. ] bi
[ expect>> [ [ "Expect:" write ] with-cell pprint-cell ] with-row ] ] tabular-output ;
[ got>> [ [ "Got:" write ] with-cell pprint-cell ] with-row ] bi
] tabular-output nl ;
M: immutable summary drop "Sequence is immutable" ; M: immutable summary drop "Sequence is immutable" ;
@ -268,20 +268,6 @@ M: duplicate-slot-names summary
M: invalid-slot-name summary M: invalid-slot-name summary
drop "Invalid slot name" ; drop "Invalid slot name" ;
: file. ( file -- ) path>> <pathname> . ;
M: source-file-error error.
[ file>> file. ] [ error>> error. ] bi ;
M: source-file-error summary
error>> summary ;
M: source-file-error compute-restarts
error>> compute-restarts ;
M: source-file-error error-help
error>> error-help ;
M: not-in-a-method-error summary M: not-in-a-method-error summary
drop "call-next-method can only be called in a method definition" ; drop "call-next-method can only be called in a method definition" ;
@ -309,12 +295,6 @@ M: lexer-error compute-restarts
M: lexer-error error-help M: lexer-error error-help
error>> error-help ; error>> error-help ;
M: object compiler-error. ( error word -- )
nl
"While compiling " write pprint ": " print
nl
print-error ;
M: bad-effect summary M: bad-effect summary
drop "Bad stack effect declaration" ; drop "Bad stack effect declaration" ;

View File

@ -35,7 +35,7 @@ M: hello bing hello-test ;
[ 3 ] [ 1 0 <hello> 2 whoa ] unit-test [ 3 ] [ 1 0 <hello> 2 whoa ] unit-test
[ 3 ] [ 1 0 <hello> f <goodbye> 2 whoa ] unit-test [ 3 ] [ 1 0 <hello> f <goodbye> 2 whoa ] unit-test
[ ] [ 3 [ "USING: accessors delegate ; IN: delegate.tests CONSULT: baz goodbye these>> ;" eval ] times ] unit-test [ ] [ 3 [ "USING: accessors delegate ; IN: delegate.tests CONSULT: baz goodbye these>> ;" eval( -- ) ] times ] unit-test
[ H{ { goodbye T{ consultation f baz goodbye [ these>> ] } } } ] [ baz protocol-consult ] unit-test [ H{ { goodbye T{ consultation f baz goodbye [ these>> ] } } } ] [ baz protocol-consult ] unit-test
[ H{ } ] [ bee protocol-consult ] unit-test [ H{ } ] [ bee protocol-consult ] unit-test
@ -63,22 +63,22 @@ CONSULT: beta hey value>> 1- ;
[ 0 ] [ 1 <hey> three ] unit-test [ 0 ] [ 1 <hey> three ] unit-test
[ { hey } ] [ alpha protocol-users ] unit-test [ { hey } ] [ alpha protocol-users ] unit-test
[ { hey } ] [ beta protocol-users ] unit-test [ { hey } ] [ beta protocol-users ] unit-test
[ ] [ "USE: delegate IN: delegate.tests PROTOCOL: alpha one ;" eval ] unit-test [ ] [ "USE: delegate IN: delegate.tests PROTOCOL: alpha one ;" eval( -- ) ] unit-test
[ f ] [ hey \ two method ] unit-test [ f ] [ hey \ two method ] unit-test
[ f ] [ hey \ four method ] unit-test [ f ] [ hey \ four method ] unit-test
[ ] [ "USE: delegate IN: delegate.tests PROTOCOL: beta two three four ;" eval ] unit-test [ ] [ "USE: delegate IN: delegate.tests PROTOCOL: beta two three four ;" eval( -- ) ] unit-test
[ { hey } ] [ alpha protocol-users ] unit-test [ { hey } ] [ alpha protocol-users ] unit-test
[ { hey } ] [ beta protocol-users ] unit-test [ { hey } ] [ beta protocol-users ] unit-test
[ 2 ] [ 1 <hey> one ] unit-test [ 2 ] [ 1 <hey> one ] unit-test
[ 0 ] [ 1 <hey> two ] unit-test [ 0 ] [ 1 <hey> two ] unit-test
[ 0 ] [ 1 <hey> three ] unit-test [ 0 ] [ 1 <hey> three ] unit-test
[ 0 ] [ 1 <hey> four ] unit-test [ 0 ] [ 1 <hey> four ] unit-test
[ ] [ "USING: math accessors delegate ; IN: delegate.tests CONSULT: beta hey value>> 2 - ;" eval ] unit-test [ ] [ "USING: math accessors delegate ; IN: delegate.tests CONSULT: beta hey value>> 2 - ;" eval( -- ) ] unit-test
[ 2 ] [ 1 <hey> one ] unit-test [ 2 ] [ 1 <hey> one ] unit-test
[ -1 ] [ 1 <hey> two ] unit-test [ -1 ] [ 1 <hey> two ] unit-test
[ -1 ] [ 1 <hey> three ] unit-test [ -1 ] [ 1 <hey> three ] unit-test
[ -1 ] [ 1 <hey> four ] unit-test [ -1 ] [ 1 <hey> four ] unit-test
[ ] [ "IN: delegate.tests FORGET: alpha" eval ] unit-test [ ] [ "IN: delegate.tests FORGET: alpha" eval( -- ) ] unit-test
[ f ] [ hey \ one method ] unit-test [ f ] [ hey \ one method ] unit-test
TUPLE: slot-protocol-test-1 a b ; TUPLE: slot-protocol-test-1 a b ;

View File

@ -1,4 +1,5 @@
USING: help.markup help.syntax parser source-files vocabs.loader ; USING: help.markup help.syntax parser source-files
source-files.errors vocabs.loader ;
IN: editors IN: editors
ARTICLE: "editor" "Editor integration" ARTICLE: "editor" "Editor integration"
@ -13,6 +14,9 @@ ARTICLE: "editor" "Editor integration"
ABOUT: "editor" ABOUT: "editor"
HELP: edit-hook
{ $var-description "A quotation with stack effect " { $snippet "( file line -- )" } ". If not set, the " { $link edit } " word throws a condition with restarts for loading one of the sub-vocabularies of the " { $vocab-link "editors" } " vocabulary." } ;
HELP: edit HELP: edit
{ $values { "defspec" "a definition specifier" } } { $values { "defspec" "a definition specifier" } }
{ $description "Opens the source file containing the definition using the current " { $link edit-hook } ". See " { $link "editor" } "." } { $description "Opens the source file containing the definition using the current " { $link edit-hook } ". See " { $link "editor" } "." }

View File

@ -1,8 +1,8 @@
! Copyright (C) 2005, 2009 Slava Pestov. ! Copyright (C) 2005, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: parser lexer kernel namespaces sequences definitions USING: parser lexer kernel namespaces sequences definitions io.files
io.files io.backend io.pathnames io summary continuations io.backend io.pathnames io summary continuations tools.crossref
tools.crossref tools.vocabs prettyprint source-files assocs tools.vocabs prettyprint source-files source-files.errors assocs
vocabs vocabs.loader splitting accessors debugger prettyprint vocabs vocabs.loader splitting accessors debugger prettyprint
help.topics ; help.topics ;
IN: editors IN: editors
@ -57,7 +57,7 @@ M: lexer-error error-line
[ error>> error-line ] [ line>> ] bi or ; [ error>> error-line ] [ line>> ] bi or ;
M: source-file-error error-file M: source-file-error error-file
[ error>> error-file ] [ file>> path>> ] bi or ; [ error>> error-file ] [ file>> ] bi or ;
M: source-file-error error-line M: source-file-error error-line
error>> error-line ; error>> error-line ;
@ -81,6 +81,9 @@ M: object error-line
: :edit ( -- ) : :edit ( -- )
error get (:edit) ; error get (:edit) ;
: edit-error ( error -- )
[ file>> ] [ line#>> ] bi 2dup and [ edit-location ] [ 2drop ] if ;
: edit-each ( seq -- ) : edit-each ( seq -- )
[ [
[ "Editing " write . ] [ "Editing " write . ]

View File

@ -0,0 +1 @@
Doug Coleman

View File

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

View File

@ -0,0 +1 @@
gedit integration

View File

@ -0,0 +1 @@
unportable

View File

@ -1,18 +1,23 @@
IN: eval IN: eval
USING: help.markup help.syntax strings io ; USING: help.markup help.syntax strings io effects ;
HELP: eval HELP: eval
{ $values { "str" string } } { $values { "str" string } { "effect" effect } }
{ $description "Parses Factor source code from a string, and calls the resulting quotation." } { $description "Parses Factor source code from a string, and calls the resulting quotation, which must have the given stack effect." }
{ $errors "Throws an error if the input is malformed, or if the evaluation itself throws an error." } ;
HELP: eval(
{ $syntax "eval( inputs -- outputs )" }
{ $description "Parses Factor source code from the string at the top of the stack, and calls the resulting quotation, which must have the given stack effect." }
{ $errors "Throws an error if the input is malformed, or if the evaluation itself throws an error." } ; { $errors "Throws an error if the input is malformed, or if the evaluation itself throws an error." } ;
HELP: eval>string HELP: eval>string
{ $values { "str" string } { "output" string } } { $values { "str" string } { "output" string } }
{ $description "Evaluates the Factor code in " { $snippet "str" } " with " { $link output-stream } " rebound to a string output stream, then outputs the resulting string." } ; { $description "Evaluates the Factor code in " { $snippet "str" } " with " { $link output-stream } " rebound to a string output stream, then outputs the resulting string. The code in the string must not take or leave any values on the stack." } ;
ARTICLE: "eval" "Evaluating strings at runtime" ARTICLE: "eval" "Evaluating strings at runtime"
"The " { $vocab-link "eval" } " vocabulary implements support for evaluating strings at runtime." "The " { $vocab-link "eval" } " vocabulary implements support for evaluating strings at runtime."
{ $subsection eval } { $subsection POSTPONE: eval( }
{ $subsection eval>string } ; { $subsection eval>string } ;
ABOUT: "eval" ABOUT: "eval"

View File

@ -1,4 +1,6 @@
IN: eval.tests IN: eval.tests
USING: eval tools.test ; USING: eval tools.test ;
[ 4 ] [ "USE: math 2 2 +" eval( -- result ) ] unit-test
[ "USE: math 2 2 +" eval( -- ) ] must-fail
[ "4\n" ] [ "USING: math prettyprint ; 2 2 + ." eval>string ] unit-test [ "4\n" ] [ "USING: math prettyprint ; 2 2 + ." eval>string ] unit-test

View File

@ -1,23 +1,25 @@
! Copyright (C) 2008, 2009 Slava Pestov. ! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: splitting parser compiler.units kernel namespaces USING: splitting parser compiler.units kernel namespaces
debugger io.streams.string fry ; debugger io.streams.string fry combinators effects.parser ;
IN: eval IN: eval
: parse-string ( str -- quot ) : parse-string ( str -- quot )
[ string-lines parse-lines ] with-compilation-unit ; [ string-lines parse-lines ] with-compilation-unit ;
: (eval) ( str -- ) : (eval) ( str effect -- )
parse-string call ; [ parse-string ] dip call-effect ; inline
: eval ( str -- ) : eval ( str effect -- )
[ (eval) ] with-file-vocabs ; [ (eval) ] with-file-vocabs ; inline
SYNTAX: eval( \ eval parse-call( ;
: (eval>string) ( str -- output ) : (eval>string) ( str -- output )
[ [
"quiet" on "quiet" on
parser-notes off parser-notes off
'[ _ (eval) ] try '[ _ (( -- )) (eval) ] try
] with-string-writer ; ] with-string-writer ;
: eval>string ( str -- output ) : eval>string ( str -- output )

View File

@ -56,7 +56,7 @@ sequences eval accessors ;
3 '[ [ [ _ 1array ] call 1array ] call 1array ] call 3 '[ [ [ _ 1array ] call 1array ] call 1array ] call
] unit-test ] unit-test
[ "USING: fry locals.backend ; f '[ load-local _ ]" eval ] [ "USING: fry locals.backend ; f '[ load-local _ ]" eval( -- quot ) ]
[ error>> >r/r>-in-fry-error? ] must-fail-with [ error>> >r/r>-in-fry-error? ] must-fail-with
[ { { "a" 1 } { "b" 2 } { "c" 3 } { "d" 4 } } ] [ [ { { "a" 1 } { "b" 2 } { "c" 3 } { "d" 4 } } ] [

View File

@ -22,7 +22,7 @@ M: foo call-responder*
"x" [ 1+ ] schange "x" [ 1+ ] schange
"x" sget number>string "text/html" <content> ; "x" sget number>string "text/html" <content> ;
: url-responder-mock-test ( -- ) : url-responder-mock-test ( -- string )
[ [
<request> <request>
"GET" >>method "GET" >>method
@ -34,7 +34,7 @@ M: foo call-responder*
[ write-response-body drop ] with-string-writer [ write-response-body drop ] with-string-writer
] with-destructors ; ] with-destructors ;
: sessions-mock-test ( -- ) : sessions-mock-test ( -- string )
[ [
<request> <request>
"GET" >>method "GET" >>method

View File

@ -272,8 +272,8 @@ HELP: nweave
HELP: n*quot HELP: n*quot
{ $values { $values
{ "n" integer } { "seq" sequence } { "n" integer } { "quot" quotation }
{ "seq'" sequence } { "quot'" quotation }
} }
{ $examples { $examples
{ $example "USING: generalizations prettyprint math ;" { $example "USING: generalizations prettyprint math ;"

View File

@ -7,7 +7,7 @@ IN: generalizations
<< <<
: n*quot ( n seq -- seq' ) <repetition> concat >quotation ; : n*quot ( n quot -- quot' ) <repetition> concat >quotation ;
: repeat ( n obj quot -- ) swapd times ; inline : repeat ( n obj quot -- ) swapd times ; inline

View File

@ -4,11 +4,11 @@ IN: hash2.tests
[ t ] [ 1 2 { 1 2 } 2= ] unit-test [ t ] [ 1 2 { 1 2 } 2= ] unit-test
[ f ] [ 1 3 { 1 2 } 2= ] unit-test [ f ] [ 1 3 { 1 2 } 2= ] unit-test
: sample-hash ( -- ) : sample-hash ( -- hash )
5 <hash2> 5 <hash2>
dup 2 3 "foo" roll set-hash2 [ [ 2 3 "foo" ] dip set-hash2 ] keep
dup 4 2 "bar" roll set-hash2 [ [ 4 2 "bar" ] dip set-hash2 ] keep
dup 4 7 "other" roll set-hash2 ; [ [ 4 7 "other" ] dip set-hash2 ] keep ;
[ "foo" ] [ 2 3 sample-hash hash2 ] unit-test [ "foo" ] [ 2 3 sample-hash hash2 ] unit-test
[ "bar" ] [ 4 2 sample-hash hash2 ] unit-test [ "bar" ] [ 4 2 sample-hash hash2 ] unit-test

View File

@ -1,4 +1,6 @@
USING: kernel sequences arrays math vectors ; ! Copyright (C) 2007 Daniel Ehrenberg
! See http://factorcode.org/license.txt for BSD license.
USING: kernel sequences arrays math vectors locals ;
IN: hash2 IN: hash2
! Little ad-hoc datastructure used to map two numbers ! Little ad-hoc datastructure used to map two numbers
@ -22,8 +24,8 @@ IN: hash2
: assoc2 ( a b alist -- value ) : assoc2 ( a b alist -- value )
(assoc2) dup [ third ] when ; inline (assoc2) dup [ third ] when ; inline
: set-assoc2 ( value a b alist -- alist ) :: set-assoc2 ( value a b alist -- alist )
[ rot 3array ] dip ?push ; inline { a b value } alist ?push ; inline
: hash2@ ( a b hash2 -- a b bucket hash2 ) : hash2@ ( a b hash2 -- a b bucket hash2 )
[ 2dup hashcode2 ] dip [ length mod ] keep ; inline [ 2dup hashcode2 ] dip [ length mod ] keep ; inline
@ -31,8 +33,8 @@ IN: hash2
: hash2 ( a b hash2 -- value/f ) : hash2 ( a b hash2 -- value/f )
hash2@ nth dup [ assoc2 ] [ 3drop f ] if ; hash2@ nth dup [ assoc2 ] [ 3drop f ] if ;
: set-hash2 ( a b value hash2 -- ) :: set-hash2 ( a b value hash2 -- )
[ -rot ] dip hash2@ [ set-assoc2 ] change-nth ; value a b hash2 hash2@ [ set-assoc2 ] change-nth ;
: alist>hash2 ( alist size -- hash2 ) : alist>hash2 ( alist size -- hash2 )
<hash2> [ over [ first3 ] dip set-hash2 ] reduce ; inline <hash2> [ over [ first3 ] dip set-hash2 ] reduce ; inline

View File

@ -54,7 +54,7 @@ IN: heaps.tests
: sort-entries ( entries -- entries' ) : sort-entries ( entries -- entries' )
[ [ key>> ] compare ] sort ; [ [ key>> ] compare ] sort ;
: delete-test ( n -- ? ) : delete-test ( n -- obj1 obj2 )
[ [
random-alist random-alist
<min-heap> [ heap-push-all ] keep <min-heap> [ heap-push-all ] keep

View File

@ -74,7 +74,7 @@ $nl
"shuffle-words" "shuffle-words"
"words" "words"
"generic" "generic"
"tools" "handbook-tools-reference"
} ; } ;
ARTICLE: "cookbook-combinators" "Control flow cookbook" ARTICLE: "cookbook-combinators" "Control flow cookbook"

View File

@ -4,7 +4,7 @@ definitions assocs sequences kernel namespaces parser arrays
io.streams.string continuations debugger compiler.units eval ; io.streams.string continuations debugger compiler.units eval ;
[ ] [ [ ] [
"IN: help.crossref.tests USING: help.syntax help.markup ; : foo ( -- ) ; HELP: foo \"foo is great\" ; ARTICLE: \"foo\" \"Foo\" { $subsection foo } ;" eval "IN: help.crossref.tests USING: help.syntax help.markup ; : foo ( -- ) ; HELP: foo \"foo is great\" ; ARTICLE: \"foo\" \"Foo\" { $subsection foo } ;" eval( -- )
] unit-test ] unit-test
[ $subsection ] [ [ $subsection ] [
@ -23,7 +23,7 @@ io.streams.string continuations debugger compiler.units eval ;
] unit-test ] unit-test
[ ] [ [ ] [
"IN: help.crossref.tests USING: help.syntax help.markup ; : bar ( -- ) ; HELP: bar \"bar is great\" ; ARTICLE: \"bar\" \"Bar\" { $subsection bar } ;" eval "IN: help.crossref.tests USING: help.syntax help.markup ; : bar ( -- ) ; HELP: bar \"bar is great\" ; ARTICLE: \"bar\" \"Bar\" { $subsection bar } ;" eval( -- )
] unit-test ] unit-test
[ ] [ [ ] [

View File

@ -32,7 +32,7 @@ IN: help.definitions.tests
"hello" "help.definitions.tests" lookup "help" word-prop "hello" "help.definitions.tests" lookup "help" word-prop
] unit-test ] unit-test
[ ] [ "IN: help.definitions.tests USING: help.syntax ; : xxx ( -- ) ; HELP: xxx ;" eval ] unit-test [ ] [ "IN: help.definitions.tests USING: help.syntax ; : xxx ( -- ) ; HELP: xxx ;" eval( -- ) ] unit-test
[ ] [ "xxx" "help.definitions.tests" lookup print-topic ] unit-test [ ] [ "xxx" "help.definitions.tests" lookup print-topic ] unit-test

View File

@ -5,7 +5,7 @@ math system strings sbufs vectors byte-arrays quotations
io.streams.byte-array classes.builtin parser lexer io.streams.byte-array classes.builtin parser lexer
classes.predicate classes.union classes.intersection classes.predicate classes.union classes.intersection
classes.singleton classes.tuple help.vocabs math.parser classes.singleton classes.tuple help.vocabs math.parser
accessors definitions ; accessors definitions sets ;
IN: help.handbook IN: help.handbook
ARTICLE: "conventions" "Conventions" ARTICLE: "conventions" "Conventions"
@ -13,13 +13,13 @@ ARTICLE: "conventions" "Conventions"
{ $heading "Documentation conventions" } { $heading "Documentation conventions" }
"Factor documentation consists of two distinct bodies of text. There is a hierarchy of articles, much like this one, and there is word documentation. Help articles reference word documentation, and vice versa, but not every documented word is referenced from some help article." "Factor documentation consists of two distinct bodies of text. There is a hierarchy of articles, much like this one, and there is word documentation. Help articles reference word documentation, and vice versa, but not every documented word is referenced from some help article."
$nl $nl
"Every article has links to parent articles at the top. These can be persued if the article is too specific." "Every article has links to parent articles at the top. Explore these if the article you are reading is too specific."
$nl $nl
"Some generic words have " { $strong "Description" } " headings, and others have " { $strong "Contract" } " headings. A distinction is made between words which are not intended to be extended with user-defined methods, and those that are." "Some generic words have " { $strong "Description" } " headings, and others have " { $strong "Contract" } " headings. A distinction is made between words which are not intended to be extended with user-defined methods, and those that are."
{ $heading "Vocabulary naming conventions" } { $heading "Vocabulary naming conventions" }
"A vocabulary name ending in " { $snippet ".private" } " contains words which are either implementation detail, unsafe, or both. For example, the " { $snippet "sequence.private" } " vocabulary contains words which access sequence elements without bounds checking (" { $link "sequences-unsafe" } ")." "A vocabulary name ending in " { $snippet ".private" } " contains words which are either implementation detail, unsafe, or both. For example, the " { $snippet "sequence.private" } " vocabulary contains words which access sequence elements without bounds checking (" { $link "sequences-unsafe" } ")."
$nl $nl
"You should should avoid using internal words from the Factor library unless absolutely necessary. Similarly, your own code can place words in internal vocabularies if you do not want other people to use them unless they have a good reason." "You should avoid using internal words from the Factor library unless absolutely necessary. Similarly, your own code can place words in internal vocabularies if you do not want other people to use them unless they have a good reason."
{ $heading "Word naming conventions" } { $heading "Word naming conventions" }
"These conventions are not hard and fast, but are usually a good first step in understanding a word's behavior:" "These conventions are not hard and fast, but are usually a good first step in understanding a word's behavior:"
{ $table { $table
@ -197,29 +197,6 @@ ARTICLE: "io" "Input and output"
{ $subsection "io.ports" } { $subsection "io.ports" }
{ $see-also "destructors" } ; { $see-also "destructors" } ;
ARTICLE: "tools" "Developer tools"
{ $subsection "tools.vocabs" }
"Exploratory tools:"
{ $subsection "see" }
{ $subsection "editor" }
{ $subsection "listener" }
{ $subsection "tools.crossref" }
{ $subsection "inspector" }
{ $subsection "tools.completion" }
{ $subsection "summary" }
"Debugging tools:"
{ $subsection "tools.annotations" }
{ $subsection "tools.test" }
{ $subsection "tools.threads" }
"Performance tools:"
{ $subsection "tools.memory" }
{ $subsection "profiling" }
{ $subsection "timing" }
{ $subsection "tools.disassembler" }
"Deployment tools:"
{ $subsection "tools.deploy" }
{ $see-also "ui-tools" } ;
ARTICLE: "article-index" "Article index" ARTICLE: "article-index" "Article index"
{ $index [ articles get keys ] } ; { $index [ articles get keys ] } ;
@ -248,59 +225,79 @@ ARTICLE: "class-index" "Class index"
USING: help.cookbook help.tutorial ; USING: help.cookbook help.tutorial ;
ARTICLE: "handbook-language-reference" "Language reference" ARTICLE: "handbook-language-reference" "The language"
"Fundamentals:" { $heading "Fundamentals" }
{ $subsection "conventions" } { $subsection "conventions" }
{ $subsection "syntax" } { $subsection "syntax" }
{ $subsection "effects" } { $subsection "effects" }
"Data types:" { $subsection "evaluator" }
{ $heading "Data types" }
{ $subsection "booleans" } { $subsection "booleans" }
{ $subsection "numbers" } { $subsection "numbers" }
{ $subsection "collections" } { $subsection "collections" }
"Evaluation semantics:" { $heading "Evaluation" }
{ $subsection "evaluator" }
{ $subsection "words" } { $subsection "words" }
{ $subsection "shuffle-words" } { $subsection "shuffle-words" }
{ $subsection "combinators" } { $subsection "combinators" }
{ $subsection "errors" } { $subsection "errors" }
{ $subsection "continuations" } { $subsection "continuations" }
"Named values:" { $heading "Named values" }
{ $subsection "locals" } { $subsection "locals" }
{ $subsection "namespaces" } { $subsection "namespaces" }
{ $subsection "namespaces-global" } { $subsection "namespaces-global" }
{ $subsection "values" } { $subsection "values" }
"Abstractions:" { $heading "Abstractions" }
{ $subsection "objects" } { $subsection "objects" }
{ $subsection "destructors" } { $subsection "destructors" }
{ $subsection "macros" } { $subsection "macros" }
{ $subsection "fry" } { $subsection "fry" }
"Program organization:" { $heading "Program organization" }
{ $subsection "vocabs.loader" } { $subsection "vocabs.loader" }
"Vocabularies tagged " { $link T{ vocab-tag { name "extensions" } } } " implement various additional language abstractions." ; "Vocabularies tagged " { $link T{ vocab-tag { name "extensions" } } } " implement various additional language abstractions." ;
ARTICLE: "handbook-environment-reference" "Environment reference" ARTICLE: "handbook-system-reference" "The implementation"
"Parse time and compile time:" { $heading "Parse time and compile time" }
{ $subsection "parser" } { $subsection "parser" }
{ $subsection "definitions" } { $subsection "definitions" }
{ $subsection "vocabularies" } { $subsection "vocabularies" }
{ $subsection "source-files" } { $subsection "source-files" }
{ $subsection "compiler" } { $subsection "compiler" }
"Tools:" { $heading "Virtual machine" }
{ $subsection "prettyprint" }
{ $subsection "tools" }
{ $subsection "help" }
{ $subsection "inference" }
{ $subsection "images" } { $subsection "images" }
"VM:"
{ $subsection "cli" } { $subsection "cli" }
{ $subsection "rc-files" } { $subsection "rc-files" }
{ $subsection "init" } { $subsection "init" }
{ $subsection "system" } { $subsection "system" }
{ $subsection "layouts" } ; { $subsection "layouts" } ;
ARTICLE: "handbook-library-reference" "Library reference" ARTICLE: "handbook-tools-reference" "Developer tools"
"This index only includes articles from loaded vocabularies. To explore more vocabularies, see " { $link "vocab-index" } "." "The below tools are text-based. " { $link "ui-tools" } " are documented separately."
{ $index [ "handbook" orphan-articles remove ] } ; { $heading "Workflow" }
{ $subsection "listener" }
{ $subsection "editor" }
{ $subsection "tools.vocabs" }
{ $subsection "tools.test" }
{ $subsection "help" }
{ $heading "Debugging" }
{ $subsection "prettyprint" }
{ $subsection "inspector" }
{ $subsection "tools.annotations" }
{ $subsection "inference" }
{ $heading "Browsing" }
{ $subsection "see" }
{ $subsection "tools.crossref" }
{ $heading "Performance" }
{ $subsection "timing" }
{ $subsection "profiling" }
{ $subsection "tools.memory" }
{ $subsection "tools.threads" }
{ $subsection "tools.disassembler" }
{ $heading "Deployment" }
{ $subsection "tools.deploy" } ;
ARTICLE: "handbook-library-reference" "Libraries"
"This index lists articles from loaded vocabularies which are not subsections of any other article. To explore more vocabularies, see " { $link "vocab-index" } "."
{ $index [ orphan-articles { "help.home" "handbook" } diff ] } ;
ARTICLE: "handbook" "Factor handbook" ARTICLE: "handbook" "Factor handbook"
"Learn the language:" "Learn the language:"
@ -308,11 +305,11 @@ ARTICLE: "handbook" "Factor handbook"
{ $subsection "first-program" } { $subsection "first-program" }
"Reference material:" "Reference material:"
{ $subsection "handbook-language-reference" } { $subsection "handbook-language-reference" }
{ $subsection "handbook-environment-reference" }
{ $subsection "io" } { $subsection "io" }
{ $subsection "ui" } { $subsection "ui" }
{ $subsection "handbook-system-reference" }
{ $subsection "handbook-tools-reference" }
{ $subsection "ui-tools" } { $subsection "ui-tools" }
{ $subsection "unicode" }
{ $subsection "alien" } { $subsection "alien" }
{ $subsection "handbook-library-reference" } { $subsection "handbook-library-reference" }
"Explore loaded libraries:" "Explore loaded libraries:"

View File

@ -8,6 +8,7 @@ ARTICLE: "help.home" "Factor documentation"
{ $link "handbook" } { $link "handbook" }
{ $link "vocab-index" } { $link "vocab-index" }
{ $link "ui-tools" } { $link "ui-tools" }
{ $link "ui-listener" }
} }
{ $heading "Recently visited" } { $heading "Recently visited" }
{ $table { $table

View File

@ -0,0 +1 @@
Slava Pestov

View File

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

View File

@ -14,6 +14,10 @@ $nl
"To run help lint, use one of the following two words:" "To run help lint, use one of the following two words:"
{ $subsection help-lint } { $subsection help-lint }
{ $subsection help-lint-all } { $subsection help-lint-all }
"Once a help lint run completes, failures can be listed:"
{ $subsection :lint-failures }
"Help lint failures are also shown in the " { $link "ui.tools.error-list" } "."
$nl
"Help lint performs the following checks:" "Help lint performs the following checks:"
{ $list { $list
"ensures examples run and produce stated output" "ensures examples run and produce stated output"

View File

@ -1,161 +1,53 @@
! Copyright (C) 2006, 2009 Slava Pestov. ! Copyright (C) 2006, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: fry accessors sequences parser kernel help help.markup USING: assocs continuations fry help help.lint.checks
help.topics words strings classes tools.vocabs namespaces make help.topics io kernel namespaces parser sequences
io io.streams.string prettyprint definitions arrays vectors source-files.errors tools.vocabs vocabs words classes
combinators combinators.short-circuit splitting debugger locals tools.errors ;
hashtables sorting effects vocabs vocabs.loader assocs editors FROM: help.lint.checks => all-vocabs ;
continuations classes.predicate macros math sets eval
vocabs.parser words.symbol values grouping unicode.categories
sequences.deep ;
IN: help.lint IN: help.lint
SYMBOL: vocabs-quot SYMBOL: lint-failures
: check-example ( element -- ) lint-failures [ H{ } clone ] initialize
'[
_ rest [
but-last "\n" join
[ (eval>string) ] call( code -- output )
"\n" ?tail drop
] keep
peek assert=
] vocabs-quot get call( quot -- ) ;
: check-examples ( element -- ) TUPLE: help-lint-error < source-file-error ;
\ $example swap elements [ check-example ] each ;
: extract-values ( element -- seq ) SYMBOL: +help-lint-failure+
\ $values swap elements dup empty? [
first rest [ first ] map prune natural-sort
] unless ;
: effect-values ( word -- seq ) T{ error-type
stack-effect { type +help-lint-failure+ }
[ in>> ] [ out>> ] bi append { word ":lint-failures" }
[ dup pair? [ first ] when effect>string ] map { plural "help lint failures" }
prune natural-sort ; { icon "vocab:ui/tools/error-list/icons/help-lint-error.tiff" }
{ quot [ lint-failures get values ] }
{ forget-quot [ lint-failures get delete-at ] }
} define-error-type
: contains-funky-elements? ( element -- ? ) M: help-lint-error error-type drop +help-lint-failure+ ;
{
$shuffle
$values-x/y
$predicate
$class-description
$error-description
} swap '[ _ elements empty? not ] any? ;
: don't-check-word? ( word -- ? ) <PRIVATE
{
[ macro? ]
[ symbol? ]
[ value-word? ]
[ parsing-word? ]
[ "declared-effect" word-prop not ]
} 1|| ;
: check-values ( word element -- ) : <help-lint-error> ( error topic -- help-lint-error )
{ \ help-lint-error <definition-error> ;
[
[ don't-check-word? ]
[ contains-funky-elements? ]
bi* or
] [
[ effect-values ]
[ extract-values ]
bi* sequence=
]
} 2|| [ "$values don't match stack effect" throw ] unless ;
: check-nulls ( element -- ) PRIVATE>
\ $values swap elements
null swap deep-member?
[ "$values should not contain null" throw ] when ;
: check-see-also ( element -- ) : help-lint-error ( error topic -- )
\ $see-also swap elements [ lint-failures get pick
rest dup prune [ length ] bi@ assert= [ [ [ <help-lint-error> ] keep ] dip set-at ] [ delete-at drop ] if
] each ; notify-error-observers ;
: vocab-exists? ( name -- ? ) <PRIVATE
[ vocab ] [ "all-vocabs" get member? ] bi or ;
: check-modules ( element -- ) :: check-something ( topic quot -- )
\ $vocab-link swap elements [ [ quot call( -- ) f ] [ ] recover
second topic help-lint-error ; inline
vocab-exists? [ "$vocab-link to non-existent vocabulary" throw ] unless
] each ;
: check-rendering ( element -- )
[ print-content ] with-string-writer drop ;
: check-strings ( str -- )
[
"\n\t" intersects?
[ "Paragraph text should not contain \\n or \\t" throw ] when
] [
" " swap subseq?
[ "Paragraph text should not contain double spaces" throw ] when
] bi ;
: check-whitespace ( str1 str2 -- )
[ " " tail? ] [ " " head? ] bi* or
[ "Missing whitespace between strings" throw ] unless ;
: check-bogus-nl ( element -- )
{ { $nl } { { $nl } } } [ head? ] with any?
[ "Simple element should not begin with a paragraph break" throw ] when ;
: check-elements ( element -- )
{
[ check-bogus-nl ]
[ [ string? ] filter [ check-strings ] each ]
[ [ simple-element? ] filter [ check-elements ] each ]
[ 2 <clumps> [ [ string? ] all? ] filter [ first2 check-whitespace ] each ]
} cleave ;
: check-descriptions ( element -- )
{ $description $class-description $var-description }
swap '[
_ elements [
rest { { } { "" } } member?
[ "Empty description" throw ] when
] each
] each ;
: check-markup ( element -- )
{
[ check-elements ]
[ check-rendering ]
[ check-examples ]
[ check-modules ]
[ check-descriptions ]
} cleave ;
: check-class-description ( word element -- )
[ class? not ]
[ { $class-description } swap elements empty? not ] bi* and
[ "A word that is not a class has a $class-description" throw ] when ;
: all-word-help ( words -- seq )
[ word-help ] filter ;
TUPLE: help-error error topic ;
C: <help-error> help-error
M: help-error error.
[ "In " write topic>> pprint nl ]
[ error>> error. ]
bi ;
: check-something ( obj quot -- )
flush '[ _ call( -- ) ] swap '[ _ <help-error> , ] recover ; inline
: check-word ( word -- ) : check-word ( word -- )
[ with-file-vocabs ] vocabs-quot set [ with-file-vocabs ] vocabs-quot set
dup word-help [ dup word-help [
dup '[ [ >link ] keep '[
_ dup word-help _ dup word-help
[ check-values ] [ check-values ]
[ check-class-description ] [ check-class-description ]
@ -165,69 +57,38 @@ M: help-error error.
: check-words ( words -- ) [ check-word ] each ; : check-words ( words -- ) [ check-word ] each ;
: check-article-title ( article -- )
article-title first LETTER?
[ "Article title must begin with a capital letter" throw ] unless ;
: check-article ( article -- ) : check-article ( article -- )
[ with-interactive-vocabs ] vocabs-quot set [ with-interactive-vocabs ] vocabs-quot set
dup '[ >link dup '[
_ _
[ check-article-title ] [ check-article-title ]
[ article-content check-markup ] bi [ article-content check-markup ] bi
] check-something ; ] check-something ;
: files>vocabs ( -- assoc )
vocabs
[ [ [ vocab-docs-path ] keep ] H{ } map>assoc ]
[ [ [ vocab-source-path ] keep ] H{ } map>assoc ]
bi assoc-union ;
: group-articles ( -- assoc )
articles get keys
files>vocabs
H{ } clone [
'[
dup >link where dup
[ first _ at _ push-at ] [ 2drop ] if
] each
] keep ;
: check-about ( vocab -- ) : check-about ( vocab -- )
dup '[ _ vocab-help [ article drop ] when* ] check-something ; dup '[ _ vocab-help [ article drop ] when* ] check-something ;
: check-vocab ( vocab -- seq ) : check-vocab ( vocab -- )
"Checking " write dup write "..." print "Checking " write dup write "..." print
[ [ vocab check-about ]
[ check-about ] [ words [ check-word ] each ]
[ words [ check-word ] each ] [ vocab-articles get at [ check-article ] each ]
[ "vocab-articles" get at [ check-article ] each ] tri ;
tri
] { } make ;
: run-help-lint ( prefix -- alist ) PRIVATE>
: help-lint ( prefix -- )
[ [
all-vocabs-seq [ vocab-name ] map "all-vocabs" set all-vocabs-seq [ vocab-name ] map all-vocabs set
group-articles "vocab-articles" set group-articles vocab-articles set
child-vocabs child-vocabs
[ dup check-vocab ] { } map>assoc [ check-vocab ] each
[ nip empty? not ] assoc-filter
] with-scope ; ] with-scope ;
: typos. ( assoc -- )
[
"==== ALL CHECKS PASSED" print
] [
[
swap vocab-heading.
[ print-error nl ] each
] assoc-each
] if-empty ;
: help-lint ( prefix -- ) run-help-lint typos. ;
: help-lint-all ( -- ) "" help-lint ; : help-lint-all ( -- ) "" help-lint ;
: :lint-failures ( -- ) lint-failures get errors. ;
: unlinked-words ( words -- seq ) : unlinked-words ( words -- seq )
all-word-help [ article-parent not ] filter ; all-word-help [ article-parent not ] filter ;
@ -235,6 +96,6 @@ M: help-error error.
all-words all-words
[ word-help not ] filter [ word-help not ] filter
[ article-parent ] filter [ article-parent ] filter
[ "predicating" word-prop not ] filter ; [ predicate? not ] filter ;
MAIN: help-lint MAIN: help-lint

View File

@ -4,12 +4,12 @@ IN: help.syntax.tests
[ [
[ "foobar" ] [ [ "foobar" ] [
"IN: help.syntax.tests USE: help.syntax ABOUT: \"foobar\"" eval "IN: help.syntax.tests USE: help.syntax ABOUT: \"foobar\"" eval( -- )
"help.syntax.tests" vocab vocab-help "help.syntax.tests" vocab vocab-help
] unit-test ] unit-test
[ { "foobar" } ] [ [ { "foobar" } ] [
"IN: help.syntax.tests USE: help.syntax ABOUT: { \"foobar\" }" eval "IN: help.syntax.tests USE: help.syntax ABOUT: { \"foobar\" }" eval( -- )
"help.syntax.tests" vocab vocab-help "help.syntax.tests" vocab vocab-help
] unit-test ] unit-test

View File

@ -29,7 +29,7 @@ SYMBOL: foo
} "\n" join } "\n" join
[ [
"testfile" source-file file set "testfile" source-file file set
eval eval( -- )
] with-scope ] with-scope
] unit-test ] unit-test

View File

@ -76,9 +76,11 @@ $nl
{ $code "." } { $code "." }
"What we just did is called " { $emphasis "interactive testing" } ". A more advanced technique which comes into play with larger programs is " { $link "tools.test" } "." "What we just did is called " { $emphasis "interactive testing" } ". A more advanced technique which comes into play with larger programs is " { $link "tools.test" } "."
$nl $nl
"Open the file named " { $snippet "palindrome-tests.factor" } "; it is located in the same directory as " { $snippet "palindrome.factor" } ", and it was created by the scaffold tool." "Create a test harness file using the scaffold tool:"
{ $code "\"palindrome\" scaffold-tests" }
"Now, open the file named " { $snippet "palindrome-tests.factor" } "; it is located in the same directory as " { $snippet "palindrome.factor" } ", and it was created by the scaffold tool."
$nl $nl
"We will add some unit tests, which are similar to the interactive tests we did above. Unit tests are defined with the " { $link unit-test } " word, which takes a sequence of expected outputs, and a piece of code. It runs the code, and asserts that it outputs the expected values." "We will add some unit tests, which are similar to the interactive tests we did above. Unit tests are defined with the " { $link POSTPONE: unit-test } " word, which takes a sequence of expected outputs, and a piece of code. It runs the code, and asserts that it outputs the expected values."
$nl $nl
"Add the following three lines to " { $snippet "palindrome-tests.factor" } ":" "Add the following three lines to " { $snippet "palindrome-tests.factor" } ":"
{ $code { $code

View File

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

View File

@ -1,6 +1,6 @@
! Copyright (C) 2009 Daniel Ehrenberg, Slava Pestov ! Copyright (C) 2009 Daniel Ehrenberg, Slava Pestov
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: io kernel ; USING: io kernel sequences ;
IN: io.crlf IN: io.crlf
: crlf ( -- ) : crlf ( -- )
@ -8,4 +8,4 @@ IN: io.crlf
: read-crlf ( -- seq ) : read-crlf ( -- seq )
"\r" read-until "\r" read-until
[ CHAR: \r assert= read1 CHAR: \n assert= ] when* ; [ CHAR: \r assert= read1 CHAR: \n assert= ] [ f like ] if* ;

View File

@ -140,7 +140,46 @@ HELP: <process-stream>
{ "desc" "a launch descriptor" } { "desc" "a launch descriptor" }
{ "encoding" "an encoding descriptor" } { "encoding" "an encoding descriptor" }
{ "stream" "a bidirectional stream" } } { "stream" "a bidirectional stream" } }
{ $description "Launches a process and redirects its input and output via a pair of pipes which may be read and written as a stream of the given encoding." } ; { $description "Launches a process and redirects its input and output via a pair of pipes which may be read and written as a stream with the given encoding." } ;
HELP: <process-reader>
{ $values
{ "desc" "a launch descriptor" }
{ "encoding" "an encoding descriptor" }
{ "stream" "an input stream" } }
{ $description "Launches a process and redirects its output via a pipe which may be read as a stream with the given encoding." } ;
HELP: <process-writer>
{ $values
{ "desc" "a launch descriptor" }
{ "encoding" "an encoding descriptor" }
{ "stream" "an output stream" }
}
{ $description "Launches a process and redirects its input via a pipe which may be written to as a stream with the given encoding." } ;
HELP: with-process-stream
{ $values
{ "desc" "a launch descriptor" }
{ "encoding" "an encoding descriptor" }
{ "quot" quotation }
}
{ $description "Launches a process and redirects its input and output via a pair of pipes. The quotation is called with " { $link input-stream } " and " { $link output-stream } " rebound to these pipes." } ;
HELP: with-process-reader
{ $values
{ "desc" "a launch descriptor" }
{ "encoding" "an encoding descriptor" }
{ "quot" quotation }
}
{ $description "Launches a process and redirects its output via a pipe. The quotation is called with " { $link input-stream } " and " { $link output-stream } " rebound to this pipe." } ;
HELP: with-process-writer
{ $values
{ "desc" "a launch descriptor" }
{ "encoding" "an encoding descriptor" }
{ "quot" quotation }
}
{ $description "Launches a process and redirects its input via a pipe. The quotation is called with " { $link input-stream } " and " { $link output-stream } " rebound to this pipe." } ;
HELP: wait-for-process HELP: wait-for-process
{ $values { "process" process } { "status" object } } { $values { "process" process } { "status" object } }
@ -175,7 +214,11 @@ ARTICLE: "io.launcher.launch" "Launching processes"
"Redirecting standard input and output to a pipe:" "Redirecting standard input and output to a pipe:"
{ $subsection <process-reader> } { $subsection <process-reader> }
{ $subsection <process-writer> } { $subsection <process-writer> }
{ $subsection <process-stream> } ; { $subsection <process-stream> }
"Combinators built on top of the above:"
{ $subsection with-process-reader }
{ $subsection with-process-writer }
{ $subsection with-process-stream } ;
ARTICLE: "io.launcher.examples" "Launcher examples" ARTICLE: "io.launcher.examples" "Launcher examples"
"Starting a command and waiting for it to finish:" "Starting a command and waiting for it to finish:"

View File

@ -10,13 +10,13 @@ USING: io.launcher.unix.parser tools.test ;
[ V{ "abc" "def" } ] [ "abc def" tokenize-command ] unit-test [ V{ "abc" "def" } ] [ "abc def" tokenize-command ] unit-test
[ V{ "abc def" } ] [ "abc\\ def" tokenize-command ] unit-test [ V{ "abc def" } ] [ "abc\\ def" tokenize-command ] unit-test
[ V{ "abc\\" "def" } ] [ "abc\\\\ def" tokenize-command ] unit-test [ V{ "abc\\" "def" } ] [ "abc\\\\ def" tokenize-command ] unit-test
[ V{ "abc\\ def" } ] [ "'abc\\\\ def'" tokenize-command ] unit-test [ V{ "abc\\ def" } ] [ "\"abc\\\\ def\"" tokenize-command ] unit-test
[ V{ "abc\\ def" } ] [ " 'abc\\\\ def'" tokenize-command ] unit-test [ V{ "abc\\ def" } ] [ " \"abc\\\\ def\"" tokenize-command ] unit-test
[ V{ "abc\\ def" "hey" } ] [ "'abc\\\\ def' hey" tokenize-command ] unit-test [ V{ "abc\\ def" "hey" } ] [ "\"abc\\\\ def\" hey" tokenize-command ] unit-test
[ V{ "abc def" "hey" } ] [ "'abc def' \"hey\"" tokenize-command ] unit-test [ V{ "abc def" "hey" } ] [ "\"abc def\" \"hey\"" tokenize-command ] unit-test
[ "'abc def' \"hey" tokenize-command ] must-fail [ "\"abc def\" \"hey" tokenize-command ] must-fail
[ "'abc def" tokenize-command ] must-fail [ "\"abc def" tokenize-command ] must-fail
[ V{ "abc def" "h\"ey" } ] [ "'abc def' \"h\\\"ey\" " tokenize-command ] unit-test [ V{ "abc def" "h\"ey" } ] [ "\"abc def\" \"h\\\"ey\" " tokenize-command ] unit-test
[ [
V{ V{

View File

@ -1,33 +1,17 @@
! Copyright (C) 2008 Slava Pestov ! Copyright (C) 2008 Slava Pestov
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: peg peg.parsers kernel sequences strings words ; USING: peg peg.ebnf arrays sequences strings kernel ;
IN: io.launcher.unix.parser IN: io.launcher.unix.parser
! Our command line parser. Supported syntax: ! Our command line parser. Supported syntax:
! foo bar baz -- simple tokens ! foo bar baz -- simple tokens
! foo\ bar -- escaping the space ! foo\ bar -- escaping the space
! 'foo bar' -- quotation
! "foo bar" -- quotation ! "foo bar" -- quotation
: 'escaped-char' ( -- parser ) EBNF: tokenize-command
"\\" token any-char 2seq [ second ] action ; space = " "
escaped-char = "\" .:ch => [[ ch ]]
: 'quoted-char' ( delimiter -- parser' ) quoted = '"' (escaped-char | [^"])*:a '"' => [[ a ]]
'escaped-char' unquoted = (escaped-char | [^ "])+
swap [ member? not ] curry satisfy argument = (quoted | unquoted) => [[ >string ]]
2choice ; inline command = space* (argument:a space* => [[ a ]])+:c !(.) => [[ c ]]
;EBNF
: 'quoted' ( delimiter -- parser )
dup 'quoted-char' repeat0 swap dup surrounded-by ;
: 'unquoted' ( -- parser ) " '\"" 'quoted-char' repeat1 ;
: 'argument' ( -- parser )
"\"" 'quoted'
"'" 'quoted'
'unquoted' 3choice
[ >string ] action ;
PEG: tokenize-command ( command -- ast/f )
'argument' " " token repeat1 list-of
" " token repeat0 tuck pack
just ;

View File

@ -98,7 +98,7 @@ IN: io.launcher.windows.nt.tests
<process> <process>
console-vm "-script" "env.factor" 3array >>command console-vm "-script" "env.factor" 3array >>command
ascii <process-reader> contents ascii <process-reader> contents
] with-directory eval ] with-directory eval( -- alist )
os-envs = os-envs =
] unit-test ] unit-test
@ -110,7 +110,7 @@ IN: io.launcher.windows.nt.tests
+replace-environment+ >>environment-mode +replace-environment+ >>environment-mode
os-envs >>environment os-envs >>environment
ascii <process-reader> contents ascii <process-reader> contents
] with-directory eval ] with-directory eval( -- alist )
os-envs = os-envs =
] unit-test ] unit-test
@ -121,7 +121,7 @@ IN: io.launcher.windows.nt.tests
console-vm "-script" "env.factor" 3array >>command console-vm "-script" "env.factor" 3array >>command
{ { "A" "B" } } >>environment { { "A" "B" } } >>environment
ascii <process-reader> contents ascii <process-reader> contents
] with-directory eval ] with-directory eval( -- alist )
"A" swap at "A" swap at
] unit-test ] unit-test
@ -133,7 +133,7 @@ IN: io.launcher.windows.nt.tests
{ { "USERPROFILE" "XXX" } } >>environment { { "USERPROFILE" "XXX" } } >>environment
+prepend-environment+ >>environment-mode +prepend-environment+ >>environment-mode
ascii <process-reader> contents ascii <process-reader> contents
] with-directory eval ] with-directory eval( -- alist )
"USERPROFILE" swap at "XXX" = "USERPROFILE" swap at "XXX" =
] unit-test ] unit-test

View File

@ -192,7 +192,7 @@ M: object (client) ( remote -- client-in client-out local )
] with-destructors ; ] with-destructors ;
: <client> ( remote encoding -- stream local ) : <client> ( remote encoding -- stream local )
[ (client) -rot ] dip <encoder-duplex> swap ; [ (client) ] dip swap [ <encoder-duplex> ] dip ;
SYMBOL: local-address SYMBOL: local-address

View File

@ -274,7 +274,7 @@ HELP: <input>
{ $description "Creates a new " { $link input } "." } ; { $description "Creates a new " { $link input } "." } ;
HELP: standard-table-style HELP: standard-table-style
{ $values { "style" hashtable } } { $values { "value" hashtable } }
{ $description "Outputs a table style where cells are separated by 5-pixel gaps and framed by a light gray border. This style can be passed to " { $link tabular-output } "." } ; { $description "Outputs a table style where cells are separated by 5-pixel gaps and framed by a light gray border. This style can be passed to " { $link tabular-output } "." } ;
ARTICLE: "io.streams.plain" "Plain writer streams" ARTICLE: "io.streams.plain" "Plain writer streams"

View File

@ -135,11 +135,11 @@ SYMBOL: wrap-margin
SYMBOL: table-gap SYMBOL: table-gap
SYMBOL: table-border SYMBOL: table-border
: standard-table-style ( -- style ) CONSTANT: standard-table-style
H{ H{
{ table-gap { 5 5 } } { table-gap { 5 5 } }
{ table-border T{ rgba f 0.8 0.8 0.8 1.0 } } { table-border T{ rgba f 0.8 0.8 0.8 1.0 } }
} ; }
! Input history ! Input history
TUPLE: input string ; TUPLE: input string ;

View File

@ -1,4 +1,4 @@
USING: help.markup help.syntax kernel io system prettyprint ; USING: help.markup help.syntax kernel io system prettyprint continuations ;
IN: listener IN: listener
ARTICLE: "listener-watch" "Watching variables in the listener" ARTICLE: "listener-watch" "Watching variables in the listener"
@ -41,32 +41,18 @@ $nl
{ $example "{ 1 2 3 } [\n .\n] each" "1\n2\n3" } { $example "{ 1 2 3 } [\n .\n] each" "1\n2\n3" }
"The listener knows when to expect more input by looking at the height of the stack. Parsing words such as " { $link POSTPONE: { } " leave elements on the parser stack, and corresponding words such as " { $link POSTPONE: } } " pop them." "The listener knows when to expect more input by looking at the height of the stack. Parsing words such as " { $link POSTPONE: { } " leave elements on the parser stack, and corresponding words such as " { $link POSTPONE: } } " pop them."
{ $subsection "listener-watch" } { $subsection "listener-watch" }
"You can start a nested listener or exit a listener using the following words:" "To start a nested listener:"
{ $subsection listener } { $subsection listener }
{ $subsection bye } "To exit the listener, invoke the " { $link return } " word."
"Finally, the multi-line expression reading word can be used independently of the rest of the listener:" $nl
"Multi-line quotations can be read independently of the rest of the listener:"
{ $subsection read-quot } ; { $subsection read-quot } ;
ABOUT: "listener" ABOUT: "listener"
<PRIVATE
HELP: quit-flag
{ $var-description "Variable set to true by " { $link bye } " word; it forces the next iteration of the " { $link listener } " loop to end." } ;
PRIVATE>
HELP: read-quot HELP: read-quot
{ $values { "quot/f" "a parsed quotation, or " { $link f } " indicating end of file" } } { $values { "quot/f" "a parsed quotation, or " { $link f } " indicating end of file" } }
{ $description "Reads a Factor expression which possibly spans more than one line from " { $link input-stream } ". Additional lines of input are read while the parser stack height is greater than one. Since structural parsing words push partial quotations on the stack, this will keep on reading input until all delimited parsing words are terminated." } ; { $description "Reads a Factor expression which possibly spans more than one line from " { $link input-stream } ". Additional lines of input are read while the parser stack height is greater than one. Since structural parsing words push partial quotations on the stack, this will keep on reading input until all delimited parsing words are terminated." } ;
HELP: listen
{ $description "Prompts for an expression on " { $link input-stream } " and evaluates it. On end of file, " { $link quit-flag } " is set to terminate the listener loop." }
{ $errors "If the expression input by the user throws an error, the error is printed to " { $link output-stream } " and the word returns normally." } ;
HELP: listener HELP: listener
{ $description "Prompts for expressions on " { $link input-stream } " and evaluates them until end of file is reached." } ; { $description "Prompts for expressions on " { $link input-stream } " and evaluates them until end of file is reached." } ;
HELP: bye
{ $description "Exits the current listener." }
{ $notes "This word is for interactive use only. To exit the Factor runtime, use " { $link exit } "." } ;

View File

@ -25,7 +25,7 @@ SYNTAX: hello "Hi" print ;
"\\ + 1 2 3 4" parse-interactive "\\ + 1 2 3 4" parse-interactive
"cont" get continue-with "cont" get continue-with
] ignore-errors ] ignore-errors
"USE: debugger :1" eval "USE: debugger :1" eval( -- quot )
] callcc1 ] callcc1
] unit-test ] unit-test
] with-file-vocabs ] with-file-vocabs
@ -50,7 +50,7 @@ SYNTAX: hello "Hi" print ;
[ [
[ ] [ [ ] [
"IN: listener.tests : hello ( -- )\n\"world\" ;" parse-interactive "IN: listener.tests : hello ( -- string )\n\"world\" ;" parse-interactive
drop drop
] unit-test ] unit-test
] with-file-vocabs ] with-file-vocabs

View File

@ -4,7 +4,7 @@ USING: arrays hashtables io kernel math math.parser memory
namespaces parser lexer sequences strings io.styles namespaces parser lexer sequences strings io.styles
vectors words generic system combinators continuations debugger vectors words generic system combinators continuations debugger
definitions compiler.units accessors colors prettyprint fry definitions compiler.units accessors colors prettyprint fry
sets vocabs.parser ; sets vocabs.parser source-files.errors locals ;
IN: listener IN: listener
GENERIC: stream-read-quot ( stream -- quot/f ) GENERIC: stream-read-quot ( stream -- quot/f )
@ -32,17 +32,9 @@ M: object stream-read-quot
: read-quot ( -- quot/f ) input-stream get stream-read-quot ; : read-quot ( -- quot/f ) input-stream get stream-read-quot ;
<PRIVATE
SYMBOL: quit-flag
PRIVATE>
: bye ( -- ) quit-flag on ;
SYMBOL: visible-vars SYMBOL: visible-vars
: show-var ( var -- ) visible-vars [ swap suffix ] change ; : show-var ( var -- ) visible-vars [ swap suffix ] change ;
: show-vars ( seq -- ) visible-vars [ swap union ] change ; : show-vars ( seq -- ) visible-vars [ swap union ] change ;
@ -68,6 +60,8 @@ SYMBOL: max-stack-items
10 max-stack-items set-global 10 max-stack-items set-global
SYMBOL: error-summary-hook
<PRIVATE <PRIVATE
: title. ( string -- ) : title. ( string -- )
@ -96,26 +90,44 @@ SYMBOL: max-stack-items
] dip ] dip
] when stack. ; ] when stack. ;
: stacks. ( -- ) : datastack. ( datastack -- )
display-stacks? get [ display-stacks? get [
datastack [ nl "--- Data stack:" title. trimmed-stack. ] unless-empty [ nl "--- Data stack:" title. trimmed-stack. ] unless-empty
] when ; ] [ drop ] if ;
: prompt. ( -- ) : prompt. ( -- )
"( " in get auto-use? get [ " - auto" append ] when " )" 3append in get auto-use? get [ " - auto" append ] when "( " " )" surround
H{ { background T{ rgba f 1 0.7 0.7 1 } } } format bl flush ; H{ { background T{ rgba f 1 0.7 0.7 1 } } } format bl flush ;
: listen ( -- ) [ error-summary ] error-summary-hook set-global
visible-vars. stacks. prompt.
[ read-quot [ [ call-error-hook ] recover ] [ bye ] if* ]
[ dup lexer-error? [ call-error-hook ] [ rethrow ] if ] recover ;
: until-quit ( -- ) : call-error-summary-hook ( -- )
quit-flag get [ quit-flag off ] [ listen until-quit ] if ; error-summary-hook get call( -- ) ;
:: (listener) ( datastack -- )
call-error-summary-hook
visible-vars.
datastack datastack.
prompt.
[
read-quot [
'[ datastack _ with-datastack ]
[ call-error-hook datastack ]
recover
] [ return ] if*
] [
dup lexer-error?
[ call-error-hook datastack ]
[ rethrow ]
if
] recover
(listener) ;
PRIVATE> PRIVATE>
: listener ( -- ) : listener ( -- )
[ until-quit ] with-interactive-vocabs ; [ [ { } (listener) ] with-interactive-vocabs ] with-return ;
MAIN: listener MAIN: listener

View File

@ -106,7 +106,8 @@ PRIVATE>
: deep-sequence>cons ( sequence -- cons ) : deep-sequence>cons ( sequence -- cons )
[ <reversed> ] keep nil [ <reversed> ] keep nil
[ tuck same? [ deep-sequence>cons ] when swons ] with reduce ; [ [ nip ] [ same? ] 2bi [ deep-sequence>cons ] when swons ]
with reduce ;
<PRIVATE <PRIVATE
:: (lmap>vector) ( acc list quot: ( elt -- elt' ) -- acc ) :: (lmap>vector) ( acc list quot: ( elt -- elt' ) -- acc )

View File

@ -261,7 +261,7 @@ M:: fixnum next-method-test ( a -- b ) a call-next-method 1 + ;
CONSTANT: new-definition "USING: math ;\nIN: locals.tests\n: a-word-with-locals ( -- x ) 2 3 + ;\n" CONSTANT: new-definition "USING: math ;\nIN: locals.tests\n: a-word-with-locals ( -- x ) 2 3 + ;\n"
[ ] [ new-definition eval ] unit-test [ ] [ new-definition eval( -- ) ] unit-test
[ t ] [ [ t ] [
[ \ a-word-with-locals see ] with-string-writer [ \ a-word-with-locals see ] with-string-writer
@ -461,7 +461,7 @@ M:: integer lambda-method-forget-test ( a -- b ) ;
[ [
"USING: locals fry math ; 1 '[ [let | A [ 10 ] | A _ + ] ]" "USING: locals fry math ; 1 '[ [let | A [ 10 ] | A _ + ] ]"
eval call eval( -- ) call
] [ error>> >r/r>-in-fry-error? ] must-fail-with ] [ error>> >r/r>-in-fry-error? ] must-fail-with
:: (funny-macro-test) ( obj quot -- ? ) obj { quot } 1&& ; inline :: (funny-macro-test) ( obj quot -- ? ) obj { quot } 1&& ; inline
@ -473,10 +473,10 @@ M:: integer lambda-method-forget-test ( a -- b ) ;
[ f ] [ 2 funny-macro-test ] unit-test [ f ] [ 2 funny-macro-test ] unit-test
! Some odd parser corner cases ! Some odd parser corner cases
[ "USE: locals [let" eval ] [ error>> unexpected-eof? ] must-fail-with [ "USE: locals [let" eval( -- ) ] [ error>> unexpected-eof? ] must-fail-with
[ "USE: locals [let |" eval ] [ error>> unexpected-eof? ] must-fail-with [ "USE: locals [let |" eval( -- ) ] [ error>> unexpected-eof? ] must-fail-with
[ "USE: locals [let | a" eval ] [ error>> unexpected-eof? ] must-fail-with [ "USE: locals [let | a" eval( -- ) ] [ error>> unexpected-eof? ] must-fail-with
[ "USE: locals [|" eval ] [ error>> unexpected-eof? ] must-fail-with [ "USE: locals [|" eval( -- ) ] [ error>> unexpected-eof? ] must-fail-with
[ 25 ] [ 5 [| a | { [ a sq ] } cond ] call ] unit-test [ 25 ] [ 5 [| a | { [ a sq ] } cond ] call ] unit-test
[ 25 ] [ 5 [| | { [| a | a sq ] } ] call first call ] unit-test [ 25 ] [ 5 [| | { [| a | a sq ] } ] call first call ] unit-test
@ -491,19 +491,19 @@ M:: integer lambda-method-forget-test ( a -- b ) ;
[ 3 ] [ 3 [| a | \ a ] call ] unit-test [ 3 ] [ 3 [| a | \ a ] call ] unit-test
[ "USE: locals [| | { [let | a [ 0 ] | a ] } ]" eval ] must-fail [ "USE: locals [| | { [let | a [ 0 ] | a ] } ]" eval( -- ) ] must-fail
[ "USE: locals [| | { [wlet | a [ 0 ] | a ] } ]" eval ] must-fail [ "USE: locals [| | { [wlet | a [ 0 ] | a ] } ]" eval( -- ) ] must-fail
[ "USE: locals [| | { [let* | a [ 0 ] | a ] } ]" eval ] must-fail [ "USE: locals [| | { [let* | a [ 0 ] | a ] } ]" eval( -- ) ] must-fail
[ "USE: locals [| | [let | a! [ 0 ] | { a! } ] ]" eval ] must-fail [ "USE: locals [| | [let | a! [ 0 ] | { a! } ] ]" eval( -- ) ] must-fail
[ "USE: locals [| | [wlet | a [ 0 ] | { a } ] ]" eval ] must-fail [ "USE: locals [| | [wlet | a [ 0 ] | { a } ] ]" eval( -- ) ] must-fail
[ "USE: locals [| | { :> a } ]" eval ] must-fail [ "USE: locals [| | { :> a } ]" eval( -- ) ] must-fail
[ "USE: locals 3 :> a" eval ] must-fail [ "USE: locals 3 :> a" eval( -- ) ] must-fail
[ 3 ] [ 3 [| | :> a a ] call ] unit-test [ 3 ] [ 3 [| | :> a a ] call ] unit-test

View File

@ -13,11 +13,11 @@ unit-test
[ t ] [ \ see-test macro? ] unit-test [ t ] [ \ see-test macro? ] unit-test
[ t ] [ [ t ] [
"USING: math ;\nIN: macros.tests\n: see-test ( a b -- c ) - ;\n" dup eval "USING: math ;\nIN: macros.tests\n: see-test ( a b -- c ) - ;\n" dup eval( -- )
[ \ see-test see ] with-string-writer = [ \ see-test see ] with-string-writer =
] unit-test ] unit-test
[ f ] [ \ see-test macro? ] unit-test [ f ] [ \ see-test macro? ] unit-test
[ ] [ "USING: macros stack-checker kernel ; IN: hanging-macro MACRO: c ( quot -- ) infer drop [ ] ; : a ( -- ) [ a ] c ;" eval ] unit-test [ ] [ "USING: macros stack-checker kernel ; IN: hanging-macro MACRO: c ( quot -- ) infer drop [ ] ; : a ( -- ) [ a ] c ;" eval( -- ) ] unit-test

View File

@ -62,8 +62,7 @@ MACRO: match-cond ( assoc -- )
} cond ; } cond ;
: match-replace ( object pattern1 pattern2 -- result ) : match-replace ( object pattern1 pattern2 -- result )
-rot [ match [ "Pattern does not match" throw ] unless* ] dip swap
match [ "Pattern does not match" throw ] unless*
[ replace-patterns ] bind ; [ replace-patterns ] bind ;
: ?1-tail ( seq -- tail/f ) : ?1-tail ( seq -- tail/f )

View File

@ -255,11 +255,11 @@ IN: math.intervals.tests
0 pick interval-contains? over first \ recip eq? and [ 0 pick interval-contains? over first \ recip eq? and [
2drop t 2drop t
] [ ] [
[ [ random-element ] dip first execute ] 2keep [ [ random-element ] dip first execute( a -- b ) ] 2keep
second execute interval-contains? second execute( a -- b ) interval-contains?
] if ; ] if ;
[ t ] [ 80000 [ drop unary-test ] all? ] unit-test [ t ] [ 80000 iota [ drop unary-test ] all? ] unit-test
: random-binary-op ( -- pair ) : random-binary-op ( -- pair )
{ {
@ -286,11 +286,11 @@ IN: math.intervals.tests
0 pick interval-contains? over first { / /i mod rem } member? and [ 0 pick interval-contains? over first { / /i mod rem } member? and [
3drop t 3drop t
] [ ] [
[ [ [ random-element ] bi@ ] dip first execute ] 3keep [ [ [ random-element ] bi@ ] dip first execute( a b -- c ) ] 3keep
second execute interval-contains? second execute( a b -- c ) interval-contains?
] if ; ] if ;
[ t ] [ 80000 [ drop binary-test ] all? ] unit-test [ t ] [ 80000 iota [ drop binary-test ] all? ] unit-test
: random-comparison ( -- pair ) : random-comparison ( -- pair )
{ {
@ -305,7 +305,7 @@ IN: math.intervals.tests
[ [ [ random-element ] bi@ ] dip first execute ] 3keep [ [ [ random-element ] bi@ ] dip first execute ] 3keep
second execute dup incomparable eq? [ 2drop t ] [ = ] if ; second execute dup incomparable eq? [ 2drop t ] [ = ] if ;
[ t ] [ 40000 [ drop comparison-test ] all? ] unit-test [ t ] [ 40000 iota [ drop comparison-test ] all? ] unit-test
[ t ] [ -10 10 [a,b] 0 100 [a,b] assume> 0 10 (a,b] = ] unit-test [ t ] [ -10 10 [a,b] 0 100 [a,b] assume> 0 10 (a,b] = ] unit-test
@ -322,7 +322,7 @@ IN: math.intervals.tests
[ t ] [ -10 10 [a,b] interval-abs 0 10 [a,b] = ] unit-test [ t ] [ -10 10 [a,b] interval-abs 0 10 [a,b] = ] unit-test
! Test that commutative interval ops really are ! Test that commutative interval ops really are
: random-interval-or-empty ( -- ) : random-interval-or-empty ( -- obj )
10 random 0 = [ empty-interval ] [ random-interval ] if ; 10 random 0 = [ empty-interval ] [ random-interval ] if ;
: random-commutative-op ( -- op ) : random-commutative-op ( -- op )
@ -333,7 +333,7 @@ IN: math.intervals.tests
} random ; } random ;
[ t ] [ [ t ] [
80000 [ 80000 iota [
drop drop
random-interval-or-empty random-interval-or-empty random-interval-or-empty random-interval-or-empty
random-commutative-op random-commutative-op

View File

@ -9,7 +9,7 @@ MEMO: fib ( m -- n )
[ 89 ] [ 10 fib ] unit-test [ 89 ] [ 10 fib ] unit-test
[ "USING: kernel math memoize generalizations ; IN: memoize.tests MEMO: x ( a b c d e -- f g h i j ) [ 1+ ] 4 ndip ;" eval ] must-fail [ "USING: kernel math memoize generalizations ; IN: memoize.tests MEMO: x ( a b c d e -- f g h i j ) [ 1+ ] 4 ndip ;" eval( -- ) ] must-fail
MEMO: see-test ( a -- b ) reverse ; MEMO: see-test ( a -- b ) reverse ;
@ -17,7 +17,7 @@ MEMO: see-test ( a -- b ) reverse ;
[ [ \ see-test see ] with-string-writer ] [ [ \ see-test see ] with-string-writer ]
unit-test unit-test
[ ] [ "IN: memoize.tests : fib ( -- ) ;" eval ] unit-test [ ] [ "IN: memoize.tests : fib ( -- ) ;" eval( -- ) ] unit-test
[ "IN: memoize.tests\n: fib ( -- ) ;\n" ] [ [ \ fib see ] with-string-writer ] unit-test [ "IN: memoize.tests\n: fib ( -- ) ;\n" ] [ [ \ fib see ] with-string-writer ] unit-test

View File

@ -61,3 +61,5 @@ M: memoized reset-word
: invalidate-memoized ( inputs... word -- ) : invalidate-memoized ( inputs... word -- )
[ stack-effect in>> packer call ] [ "memoize" word-prop delete-at ] bi ; [ stack-effect in>> packer call ] [ "memoize" word-prop delete-at ] bi ;
\ invalidate-memoized t "no-compile" set-word-prop

View File

@ -137,9 +137,6 @@ ERROR: no-content-disposition multipart ;
[ no-content-disposition ] [ no-content-disposition ]
} case ; } case ;
: assert-sequence= ( a b -- )
2dup sequence= [ 2drop ] [ assert ] if ;
: read-assert-sequence= ( sequence -- ) : read-assert-sequence= ( sequence -- )
[ length read ] keep assert-sequence= ; [ length read ] keep assert-sequence= ;

View File

@ -56,6 +56,6 @@ TUPLE: color
! Test reshaping with a mirror ! Test reshaping with a mirror
1 2 3 color boa <mirror> "mirror" set 1 2 3 color boa <mirror> "mirror" set
[ ] [ "IN: mirrors.tests USE: math TUPLE: color { green integer } { red integer } { blue integer } ;" eval ] unit-test [ ] [ "IN: mirrors.tests USE: math TUPLE: color { green integer } { red integer } { blue integer } ;" eval( -- ) ] unit-test
[ 1 ] [ "red" "mirror" get at ] unit-test [ 1 ] [ "red" "mirror" get at ] unit-test

View File

@ -0,0 +1 @@
Slava Pestov

View File

@ -7,15 +7,15 @@ HELP: <smart-arrow>
{ $examples { $examples
"A model which adds the values of two existing models:" "A model which adds the values of two existing models:"
{ $example { $example
"USING: models models.arrows.smart accessors math prettyprint ;" "USING: models models.arrow.smart accessors kernel math prettyprint ;"
"1 <model> 2 <model> [ + ] <smart-arrow>" "1 <model> 2 <model> [ + ] <smart-arrow>"
"[ activate-model ] [ value>> ] bi ." "[ activate-model ] [ value>> ] bi ."
"3" "3"
} }
} ; } ;
ARTICLE: "models.arrows.smart" "Smart arrow models" ARTICLE: "models.arrow.smart" "Smart arrow models"
"The " { $vocab-link "models.arrows.smart" } " vocabulary generalizes arrows to arbitrary input arity. They're called “smart” because they resemble " { $link "combinators.smart" } "." "The " { $vocab-link "models.arrow.smart" } " vocabulary generalizes arrows to arbitrary input arity. They're called “smart” because they resemble " { $link "combinators.smart" } "."
{ $subsection <smart-arrow> } ; { $subsection <smart-arrow> } ;
ABOUT: "models.arrows.smart" ABOUT: "models.arrow.smart"

Some files were not shown because too many files have changed in this diff Show More