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
checksums.txt
*.so
a.out

View File

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

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.
USING: alien alien.c-types arrays assocs effects grouping kernel
parser sequences splitting words fry locals ;
parser sequences splitting words fry locals lexer namespaces ;
IN: alien.parser
: parse-arglist ( parameters return -- types effect )
@ -12,8 +12,15 @@ IN: alien.parser
: function-quot ( return library function types -- quot )
'[ _ _ _ _ alien-invoke ] ;
:: define-function ( return library function parameters -- )
:: make-function ( return library function parameters -- word quot effect )
function create-in dup reset-generic
return library function
parameters return parse-arglist [ function-quot ] dip
define-declared ;
parameters return parse-arglist [ function-quot ] dip ;
: (FUNCTION:) ( -- word quot effect )
scan "c-library" get scan ";" parse-tokens
[ "()" subseq? not ] filter
make-function ;
: define-function ( return library function parameters -- )
make-function define-declared ;

View File

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

View File

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

View File

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

View File

@ -6,6 +6,7 @@ IN: bootstrap.tools
"bootstrap.image"
"tools.annotations"
"tools.crossref"
"tools.errors"
"tools.deploy"
"tools.disassembler"
"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
alien.strings alien.arrays alien.complex sets libc alien.libraries
continuations.private fry cpu.architecture
source-files.errors
compiler.errors
compiler.alien
compiler.cfg
@ -379,8 +380,7 @@ TUPLE: no-such-library name ;
M: no-such-library summary
drop "Library not found" ;
M: no-such-library compiler-error-type
drop +linkage+ ;
M: no-such-library error-type drop +linkage-error+ ;
: no-such-library ( name -- )
\ no-such-library boa
@ -391,8 +391,7 @@ TUPLE: no-such-symbol name ;
M: no-such-symbol summary
drop "Symbol not found" ;
M: no-such-symbol compiler-error-type
drop +linkage+ ;
M: no-such-symbol error-type drop +linkage-error+ ;
: no-such-symbol ( name -- )
\ no-such-symbol boa

View File

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

View File

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

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

View File

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

View File

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

View File

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

View File

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

View File

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

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
[ f ] [ empty-mixin \ sheeple method \ sheeple-test "compiled-uses" word-prop key? ] unit-test
[ ] [ "IN: compiler.tests USE: arrays INSTANCE: array empty-mixin" eval ] unit-test
[ ] [ "IN: compiler.tests USE: arrays INSTANCE: array empty-mixin" eval( -- ) ] unit-test
[ "wake up" ] [ sheeple-test ] unit-test
[ f ] [ object \ sheeple method \ sheeple-test "compiled-uses" word-prop key? ] unit-test

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

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
ARTICLE: "editor" "Editor integration"
@ -13,6 +14,9 @@ ARTICLE: "editor" "Editor integration"
ABOUT: "editor"
HELP: edit-hook
{ $var-description "A quotation with stack effect " { $snippet "( file line -- )" } ". If not set, the " { $link edit } " word throws a condition with restarts for loading one of the sub-vocabularies of the " { $vocab-link "editors" } " vocabulary." } ;
HELP: edit
{ $values { "defspec" "a definition specifier" } }
{ $description "Opens the source file containing the definition using the current " { $link edit-hook } ". See " { $link "editor" } "." }

View File

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

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

View File

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

View File

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

View File

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

View File

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

View File

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

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
@ -94,4 +94,4 @@ MACRO: nweave ( n -- )
: nappend-as ( n exemplar -- seq )
[ narray concat ] dip like ; inline
: nappend ( n -- seq ) narray concat ; inline
: nappend ( n -- seq ) narray concat ; inline

View File

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

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
! Little ad-hoc datastructure used to map two numbers
@ -22,8 +24,8 @@ IN: hash2
: assoc2 ( a b alist -- value )
(assoc2) dup [ third ] when ; inline
: set-assoc2 ( value a b alist -- alist )
[ rot 3array ] dip ?push ; inline
:: set-assoc2 ( value a b alist -- alist )
{ a b value } alist ?push ; inline
: hash2@ ( a b hash2 -- a b bucket hash2 )
[ 2dup hashcode2 ] dip [ length mod ] keep ; inline
@ -31,8 +33,8 @@ IN: hash2
: hash2 ( a b hash2 -- value/f )
hash2@ nth dup [ assoc2 ] [ 3drop f ] if ;
: set-hash2 ( a b value hash2 -- )
[ -rot ] dip hash2@ [ set-assoc2 ] change-nth ;
:: set-hash2 ( a b value hash2 -- )
value a b hash2 hash2@ [ set-assoc2 ] change-nth ;
: alist>hash2 ( alist size -- hash2 )
<hash2> [ over [ first3 ] dip set-hash2 ] reduce ; inline

View File

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

View File

@ -74,7 +74,7 @@ $nl
"shuffle-words"
"words"
"generic"
"tools"
"handbook-tools-reference"
} ;
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 ;
[ ] [
"IN: help.crossref.tests USING: help.syntax help.markup ; : foo ( -- ) ; HELP: foo \"foo is great\" ; ARTICLE: \"foo\" \"Foo\" { $subsection foo } ;" eval
"IN: help.crossref.tests USING: help.syntax help.markup ; : foo ( -- ) ; HELP: foo \"foo is great\" ; ARTICLE: \"foo\" \"Foo\" { $subsection foo } ;" eval( -- )
] unit-test
[ $subsection ] [
@ -23,7 +23,7 @@ io.streams.string continuations debugger compiler.units eval ;
] unit-test
[ ] [
"IN: help.crossref.tests USING: help.syntax help.markup ; : bar ( -- ) ; HELP: bar \"bar is great\" ; ARTICLE: \"bar\" \"Bar\" { $subsection bar } ;" eval
"IN: help.crossref.tests USING: help.syntax help.markup ; : bar ( -- ) ; HELP: bar \"bar is great\" ; ARTICLE: \"bar\" \"Bar\" { $subsection bar } ;" eval( -- )
] unit-test
[ ] [

View File

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

View File

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

View File

@ -8,6 +8,7 @@ ARTICLE: "help.home" "Factor documentation"
{ $link "handbook" }
{ $link "vocab-index" }
{ $link "ui-tools" }
{ $link "ui-listener" }
}
{ $heading "Recently visited" }
{ $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:"
{ $subsection help-lint }
{ $subsection help-lint-all }
"Once a help lint run completes, failures can be listed:"
{ $subsection :lint-failures }
"Help lint failures are also shown in the " { $link "ui.tools.error-list" } "."
$nl
"Help lint performs the following checks:"
{ $list
"ensures examples run and produce stated output"

View File

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

View File

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

View File

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

View File

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

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
! See http://factorcode.org/license.txt for BSD license.
USING: io kernel ;
USING: io kernel sequences ;
IN: io.crlf
: crlf ( -- )
@ -8,4 +8,4 @@ IN: io.crlf
: read-crlf ( -- seq )
"\r" read-until
[ CHAR: \r assert= read1 CHAR: \n assert= ] when* ;
[ CHAR: \r assert= read1 CHAR: \n assert= ] [ f like ] if* ;

View File

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

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" "hey" } ] [ "'abc\\\\ def' hey" tokenize-command ] unit-test
[ V{ "abc def" "hey" } ] [ "'abc def' \"hey\"" tokenize-command ] unit-test
[ "'abc def' \"hey" tokenize-command ] must-fail
[ "'abc def" tokenize-command ] must-fail
[ V{ "abc def" "h\"ey" } ] [ "'abc def' \"h\\\"ey\" " tokenize-command ] unit-test
[ V{ "abc\\ def" } ] [ "\"abc\\\\ def\"" tokenize-command ] unit-test
[ V{ "abc\\ def" } ] [ " \"abc\\\\ def\"" tokenize-command ] unit-test
[ V{ "abc\\ def" "hey" } ] [ "\"abc\\\\ def\" hey" tokenize-command ] unit-test
[ V{ "abc def" "hey" } ] [ "\"abc def\" \"hey\"" tokenize-command ] unit-test
[ "\"abc def\" \"hey" tokenize-command ] must-fail
[ "\"abc def" tokenize-command ] must-fail
[ V{ "abc def" "h\"ey" } ] [ "\"abc def\" \"h\\\"ey\" " tokenize-command ] unit-test
[
V{

View File

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

View File

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

View File

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

View File

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

View File

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

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

View File

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

View File

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

View File

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

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"
[ ] [ new-definition eval ] unit-test
[ ] [ new-definition eval( -- ) ] unit-test
[ t ] [
[ \ a-word-with-locals see ] with-string-writer
@ -461,7 +461,7 @@ M:: integer lambda-method-forget-test ( a -- b ) ;
[
"USING: locals fry math ; 1 '[ [let | A [ 10 ] | A _ + ] ]"
eval call
eval( -- ) call
] [ error>> >r/r>-in-fry-error? ] must-fail-with
:: (funny-macro-test) ( obj quot -- ? ) obj { quot } 1&& ; inline
@ -473,10 +473,10 @@ M:: integer lambda-method-forget-test ( a -- b ) ;
[ f ] [ 2 funny-macro-test ] unit-test
! Some odd parser corner cases
[ "USE: locals [let" eval ] [ error>> unexpected-eof? ] must-fail-with
[ "USE: locals [let |" eval ] [ error>> unexpected-eof? ] must-fail-with
[ "USE: locals [let | a" eval ] [ error>> unexpected-eof? ] must-fail-with
[ "USE: locals [|" eval ] [ error>> unexpected-eof? ] must-fail-with
[ "USE: locals [let" eval( -- ) ] [ error>> unexpected-eof? ] must-fail-with
[ "USE: locals [let |" eval( -- ) ] [ error>> unexpected-eof? ] must-fail-with
[ "USE: locals [let | a" eval( -- ) ] [ error>> unexpected-eof? ] must-fail-with
[ "USE: locals [|" eval( -- ) ] [ error>> unexpected-eof? ] must-fail-with
[ 25 ] [ 5 [| a | { [ a sq ] } cond ] call ] unit-test
[ 25 ] [ 5 [| | { [| a | a sq ] } ] call first call ] unit-test
@ -491,19 +491,19 @@ M:: integer lambda-method-forget-test ( a -- b ) ;
[ 3 ] [ 3 [| a | \ a ] call ] unit-test
[ "USE: locals [| | { [let | a [ 0 ] | a ] } ]" eval ] must-fail
[ "USE: locals [| | { [let | a [ 0 ] | a ] } ]" eval( -- ) ] must-fail
[ "USE: locals [| | { [wlet | a [ 0 ] | a ] } ]" eval ] must-fail
[ "USE: locals [| | { [wlet | a [ 0 ] | a ] } ]" eval( -- ) ] must-fail
[ "USE: locals [| | { [let* | a [ 0 ] | a ] } ]" eval ] must-fail
[ "USE: locals [| | { [let* | a [ 0 ] | a ] } ]" eval( -- ) ] must-fail
[ "USE: locals [| | [let | a! [ 0 ] | { a! } ] ]" eval ] must-fail
[ "USE: locals [| | [let | a! [ 0 ] | { a! } ] ]" eval( -- ) ] must-fail
[ "USE: locals [| | [wlet | a [ 0 ] | { a } ] ]" eval ] must-fail
[ "USE: locals [| | [wlet | a [ 0 ] | { a } ] ]" eval( -- ) ] must-fail
[ "USE: locals [| | { :> a } ]" eval ] must-fail
[ "USE: locals [| | { :> a } ]" eval( -- ) ] must-fail
[ "USE: locals 3 :> a" eval ] must-fail
[ "USE: locals 3 :> a" eval( -- ) ] must-fail
[ 3 ] [ 3 [| | :> a a ] call ] unit-test
@ -584,4 +584,4 @@ M: integer ed's-bug neg ;
:: ed's-test-case ( a -- b )
{ [ a ed's-bug ] } && ;
[ t ] [ \ ed's-test-case optimized>> ] unit-test
[ t ] [ \ ed's-test-case optimized>> ] unit-test

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

@ -0,0 +1 @@
Slava Pestov

View File

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

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