steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Merge branch 'master' of git://factorcode.org/git/factor

db4
John Benediktsson 2009-04-27 03:04:37 -07:00
parent ab3107d690 67fd98f42d
commit d804a0a683
205 changed files with 1942 additions and 1020 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

11
Makefile
View File

@ -7,7 +7,6 @@ CONSOLE_EXECUTABLE = factor-console
TEST_LIBRARY = factor-ffi-test
VERSION = 0.92
IMAGE = factor.image
BUNDLE = Factor.app
LIBPATH = -L/usr/X11R6/lib
CFLAGS = -Wall
@ -16,9 +15,11 @@ FFI_TEST_CFLAGS = -fPIC
ifdef DEBUG
CFLAGS += -g
else
CFLAGS += -O3 $(SITE_CFLAGS)
CFLAGS += -O3
endif
CFLAGS += $(SITE_CFLAGS)
ENGINE = $(DLL_PREFIX)factor$(DLL_SUFFIX)$(DLL_EXTENSION)
ifdef CONFIG
@ -151,17 +152,17 @@ macosx.app: factor
@executable_path/../Frameworks/libfactor.dylib \
Factor.app/Contents/MacOS/factor
factor: $(DLL_OBJS) $(EXE_OBJS)
$(EXECUTABLE): $(DLL_OBJS) $(EXE_OBJS)
$(LINKER) $(ENGINE) $(DLL_OBJS)
$(CC) $(LIBS) $(LIBPATH) -L. $(LINK_WITH_ENGINE) \
$(CFLAGS) -o $@$(EXE_SUFFIX)$(EXE_EXTENSION) $(EXE_OBJS)
factor-console: $(DLL_OBJS) $(EXE_OBJS)
$(CONSOLE_EXECUTABLE): $(DLL_OBJS) $(EXE_OBJS)
$(LINKER) $(ENGINE) $(DLL_OBJS)
$(CC) $(LIBS) $(LIBPATH) -L. $(LINK_WITH_ENGINE) \
$(CFLAGS) $(CFLAGS_CONSOLE) -o factor$(EXE_SUFFIX)$(CONSOLE_EXTENSION) $(EXE_OBJS)
factor-ffi-test: vm/ffi_test.o
$(TEST_LIBRARY): vm/ffi_test.o
$(CC) $(LIBPATH) $(CFLAGS) $(FFI_TEST_CFLAGS) $(SHARED_FLAG) -o libfactor-ffi-test$(SHARED_DLL_EXTENSION) $(TEST_OBJS)
clean:

4
basis/bootstrap/stage2.factor
View File

@ -68,9 +68,11 @@ SYMBOL: bootstrap-time
"staging" get "deploy-vocab" get or [
"stage2: deployment mode" print
] [
"listener" require
"debugger" require
"alien.prettyprint" require
"inspector" require
"tools.errors" require
"listener" require
"none" require
] if

9
basis/calendar/calendar-tests.factor
View File

@ -1,5 +1,5 @@
USING: arrays calendar kernel math sequences tools.test
continuations system math.order threads ;
continuations system math.order threads accessors ;
IN: calendar.tests
[ f ] [ 2004 12 32 0 0 0 instant <timestamp> valid-timestamp? ] unit-test
@ -163,3 +163,10 @@ IN: calendar.tests
[ t ] [ now 50 milliseconds sleep now before? ] unit-test
[ t ] [ now 50 milliseconds sleep now swap after? ] unit-test
[ t ] [ now 50 milliseconds sleep now 50 milliseconds sleep now swapd between? ] unit-test
[ 4 12 ] [ 2009 easter [ month>> ] [ day>> ] bi ] unit-test
[ 4 2 ] [ 1961 easter [ month>> ] [ day>> ] bi ] unit-test
[ f ] [ now dup midnight eq? ] unit-test
[ f ] [ now dup easter eq? ] unit-test
[ f ] [ now dup beginning-of-year eq? ] unit-test

64
basis/calendar/calendar.factor
View File

@ -1,8 +1,8 @@
! Copyright (C) 2007 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays classes.tuple combinators combinators.short-circuit
kernel locals math math.functions math.order namespaces sequences strings
summary system threads vocabs.loader ;
USING: accessors arrays classes.tuple combinators
combinators.short-circuit kernel locals math math.functions
math.order sequences summary system threads vocabs.loader ;
IN: calendar
HOOK: gmt-offset os ( -- hours minutes seconds )
@ -94,26 +94,50 @@ CONSTANT: day-abbreviations3
:: julian-day-number ( year month day -- n )
#! Returns a composite date number
#! Not valid before year -4800
[let* | a [ 14 month - 12 /i ]
y [ year 4800 + a - ]
m [ month 12 a * + 3 - ] |
day 153 m * 2 + 5 /i + 365 y * +
y 4 /i + y 100 /i - y 400 /i + 32045 -
] ;
14 month - 12 /i :> a
year 4800 + a - :> y
month 12 a * + 3 - :> m
day 153 m * 2 + 5 /i + 365 y * +
y 4 /i + y 100 /i - y 400 /i + 32045 - ;
:: julian-day-number>date ( n -- year month day )
#! Inverse of julian-day-number
[let* | a [ n 32044 + ]
b [ 4 a * 3 + 146097 /i ]
c [ a 146097 b * 4 /i - ]
d [ 4 c * 3 + 1461 /i ]
e [ c 1461 d * 4 /i - ]
m [ 5 e * 2 + 153 /i ] |
100 b * d + 4800 -
m 10 /i + m 3 +
12 m 10 /i * -
e 153 m * 2 + 5 /i - 1+
] ;
n 32044 + :> a
4 a * 3 + 146097 /i :> b
a 146097 b * 4 /i - :> c
4 c * 3 + 1461 /i :> d
c 1461 d * 4 /i - :> e
5 e * 2 + 153 /i :> m
100 b * d + 4800 -
m 10 /i + m 3 +
12 m 10 /i * -
e 153 m * 2 + 5 /i - 1+ ;
GENERIC: easter ( obj -- obj' )
:: easter-month-day ( year -- month day )
year 19 mod :> a
year 100 /mod :> c :> b
b 4 /mod :> e :> d
b 8 + 25 /i :> f
b f - 1 + 3 /i :> g
19 a * b + d - g - 15 + 30 mod :> h
c 4 /mod :> k :> i
32 2 e * + 2 i * + h - k - 7 mod :> l
a 11 h * + 22 l * + 451 /i :> m
h l + 7 m * - 114 + 31 /mod 1 + :> day :> month
month day ;
M: integer easter ( year -- timestamp )
dup easter-month-day <date> ;
M: timestamp easter ( timestamp -- timestamp )
clone
dup year>> easter-month-day
swapd >>day swap >>month ;
: >date< ( timestamp -- year month day )
[ year>> ] [ month>> ] [ day>> ] tri ;

2
basis/calendar/format/macros/macros-tests.factor
View File

@ -1,4 +1,4 @@
USING: tools.test kernel ;
USING: tools.test kernel accessors ;
IN: calendar.format.macros
[ 2 ] [ { [ 2 ] } attempt-all-quots ] unit-test

2
basis/checksums/md5/md5.factor
View File

@ -14,7 +14,7 @@ IN: checksums.md5
SYMBOLS: a b c d old-a old-b old-c old-d ;
: T ( N -- Y )
sin abs 4294967296 * >integer ; foldable
sin abs 32 2^ * >integer ; foldable
: initialize-md5 ( -- )
0 bytes-read set

7
basis/combinators/smart/smart-docs.factor
View File

@ -1,7 +1,7 @@
! Copyright (C) 2009 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: help.markup help.syntax kernel quotations math sequences
multiline ;
multiline stack-checker ;
IN: combinators.smart
HELP: input<sequence
@ -108,7 +108,7 @@ HELP: append-outputs-as
ARTICLE: "combinators.smart" "Smart combinators"
"The macros in the " { $vocab-link "combinators.smart" } " vocabulary look at the static stack effects of input quotations and generate code which produces or consumes the relevant number of stack values." $nl
"A " { $emphasis "smart combinator" } " is a macro which reflects on the stack effect of an input quotation. The " { $vocab-link "combinators.smart" } " vocabulary implements a few simple smart combinators which look at the static stack effects of input quotations and generate code which produces or consumes the relevant number of stack values." $nl
"Call a quotation and discard all output values:"
{ $subsection drop-outputs }
"Take all input values from a sequence:"
@ -122,6 +122,7 @@ ARTICLE: "combinators.smart" "Smart combinators"
{ $subsection sum-outputs }
"Concatenating output values:"
{ $subsection append-outputs }
{ $subsection append-outputs-as } ;
{ $subsection append-outputs-as }
"New smart combinators can be created by defining " { $link "macros" } " which call " { $link infer } "." ;
ABOUT: "combinators.smart"

2
basis/combinators/smart/smart-tests.factor
View File

@ -1,6 +1,6 @@
! Copyright (C) 2009 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: tools.test combinators.smart math kernel ;
USING: tools.test combinators.smart math kernel accessors ;
IN: combinators.smart.tests
: test-bi ( -- 9 11 )

4
basis/combinators/smart/smart.factor
View File

@ -18,6 +18,10 @@ MACRO: input<sequence ( quot -- newquot )
[ infer in>> ] keep
'[ _ firstn @ ] ;
MACRO: input<sequence-unsafe ( quot -- newquot )
[ infer in>> ] keep
'[ _ firstn-unsafe @ ] ;
MACRO: reduce-outputs ( quot operation -- newquot )
[ dup infer out>> 1 [-] ] dip n*quot compose ;

38
basis/compiler/codegen/codegen.factor
View File

@ -375,45 +375,21 @@ M: long-long-type flatten-value-type ( type -- types )
: box-return* ( node -- )
return>> [ ] [ box-return ] if-void ;
TUPLE: no-such-library name ;
M: no-such-library summary
drop "Library not found" ;
M: no-such-library error-type drop +linkage-error+ ;
: no-such-library ( name -- )
\ no-such-library boa
compiling-word get compiler-error ;
TUPLE: no-such-symbol name ;
M: no-such-symbol summary
drop "Symbol not found" ;
M: no-such-symbol error-type drop +linkage-error+ ;
: no-such-symbol ( name -- )
\ no-such-symbol boa
compiling-word get compiler-error ;
: check-dlsym ( symbols dll -- )
dup dll-valid? [
dupd '[ _ dlsym ] any?
[ drop ] [ no-such-symbol ] if
[ drop ] [ compiling-word get no-such-symbol ] if
] [
dll-path no-such-library drop
dll-path compiling-word get no-such-library drop
] if ;
: stdcall-mangle ( symbol node -- symbol )
"@"
swap parameters>> parameter-sizes drop
number>string 3append ;
: stdcall-mangle ( symbol params -- symbol )
parameters>> parameter-sizes drop number>string "@" glue ;
: alien-invoke-dlsym ( params -- symbols dll )
dup function>> dup pick stdcall-mangle 2array
swap library>> library dup [ dll>> ] when
2dup check-dlsym ;
[ [ function>> dup ] keep stdcall-mangle 2array ]
[ library>> library dup [ dll>> ] when ]
bi 2dup check-dlsym ;
M: ##alien-invoke generate-insn
params>>

6
basis/compiler/compiler-docs.factor
View File

@ -29,7 +29,7 @@ $nl
$nl
"The " { $link compile-word } " word performs the actual task of compiling an individual word. The process proceeds as follows:"
{ $list
{ "The " { $link frontend } " word calls " { $link build-tree } ". If this fails, the error is passed to " { $link deoptimize } ". The logic for ignoring compile warnings generated for inline words and macros is located here. If the error is not ignorable, it is added to the global " { $link compiler-errors } " assoc (see " { $link "compiler-errors" } ")." }
{ "The " { $link frontend } " word calls " { $link build-tree } ". If this fails, the error is passed to " { $link deoptimize } ". The logic for ignoring certain compile errors generated for inline words and macros is located here. If the error is not ignorable, it is added to the global " { $link compiler-errors } " assoc (see " { $link "compiler-errors" } ")." }
{ "If the word contains a breakpoint, compilation ends here. Otherwise, all remaining steps execute until machine code is generated. Any further errors thrown by the compiler are not reported as compile errors, but instead are ordinary exceptions. This is because they indicate bugs in the compiler, not errors in user code." }
{ "The " { $link frontend } " word then calls " { $link optimize-tree } ". This produces the final optimized tree IR, and this stage of the compiler is complete." }
{ "The " { $link backend } " word calls " { $link build-cfg } " followed by " { $link optimize-cfg } " and a few other stages. Finally, it calls " { $link save-asm } ", and adds any uncompiled words called by this word to the compilation queue with " { $link compile-dependency } "." }
@ -46,9 +46,9 @@ $nl
{ "The " { $emphasis "non-optimizing quotation compiler" } " compiles quotations to naive machine code very quickly. The non-optimizing quotation compiler is part of the VM." }
{ "The " { $emphasis "optimizing word compiler" } " compiles whole words at a time while performing extensive data and control flow analysis. This provides greater performance for generated code, but incurs a much longer compile time. The optimizing compiler is written in Factor." }
}
"The optimizing compiler only compiles words which have a static stack effect. This means that methods defined on fundamental generic words such as " { $link nth } " should have a static stack effect. See " { $link "inference" } " and " { $link "cookbook-pitfalls" } "."
$nl
"The optimizing compiler also trades off compile time for performance of generated code, so loading certain vocabularies might take a while. Saving the image after loading vocabularies can save you a lot of time that you would spend waiting for the same code to load in every coding session; see " { $link "images" } " for information."
$nl
"Most code you write will run with the optimizing compiler. Sometimes, the non-optimizing compiler is used, for example for listener interactions, or for running the quotation passed to " { $link POSTPONE: call( } "."
{ $subsection "compiler-errors" }
{ $subsection "hints" }
{ $subsection "compiler-usage" }

39
basis/compiler/compiler.factor
View File

@ -2,13 +2,13 @@
! See http://factorcode.org/license.txt for BSD license.
USING: accessors kernel namespaces arrays sequences io words fry
continuations vocabs assocs dlists definitions math graphs generic
combinators deques search-deques macros io source-files.errors stack-checker
stack-checker.state stack-checker.inlining combinators.short-circuit
compiler.errors compiler.units compiler.tree.builder
compiler.tree.optimizer compiler.cfg.builder compiler.cfg.optimizer
compiler.cfg.linearization compiler.cfg.two-operand
compiler.cfg.linear-scan compiler.cfg.stack-frame compiler.codegen
compiler.utilities ;
combinators deques search-deques macros io source-files.errors
stack-checker stack-checker.state stack-checker.inlining
stack-checker.errors combinators.short-circuit compiler.errors
compiler.units compiler.tree.builder compiler.tree.optimizer
compiler.cfg.builder compiler.cfg.optimizer compiler.cfg.linearization
compiler.cfg.two-operand compiler.cfg.linear-scan
compiler.cfg.stack-frame compiler.codegen compiler.utilities ;
IN: compiler
SYMBOL: compile-queue
@ -39,10 +39,10 @@ SYMBOL: compiled
"trace-compilation" get [ dup name>> print flush ] when
H{ } clone dependencies set
H{ } clone generic-dependencies set
f swap compiler-error ;
clear-compiler-error ;
: ignore-error? ( word error -- ? )
#! Ignore warnings on inline combinators, macros, and special
#! Ignore some errors on inline combinators, macros, and special
#! words such as 'call'.
[
{
@ -51,7 +51,12 @@ SYMBOL: compiled
[ "special" word-prop ]
[ "no-compile" word-prop ]
} 1||
] [ error-type +compiler-warning+ eq? ] bi* and ;
] [
{
[ do-not-compile? ]
[ literal-expected? ]
} 1||
] bi* and ;
: finish ( word -- )
#! Recompile callers if the word's stack effect changed, then
@ -80,10 +85,16 @@ SYMBOL: compiled
#! non-optimizing compiler, using its definition. Otherwise,
#! if the compiler error is not ignorable, use a dummy
#! definition from 'not-compiled-def' which throws an error.
2dup ignore-error?
[ drop f over def>> ]
[ 2dup not-compiled-def ] if
[ swap compiler-error ] [ deoptimize-with ] bi-curry* bi ;
2dup ignore-error? [
drop
[ dup def>> deoptimize-with ]
[ clear-compiler-error ]
bi
] [
[ swap <compiler-error> compiler-error ]
[ [ drop ] [ not-compiled-def ] 2bi deoptimize-with ]
2bi
] if ;
: frontend ( word -- nodes )
#! If the word contains breakpoints, don't optimize it, since

68
basis/compiler/errors/errors.factor
View File

@ -1,56 +1,72 @@
! Copyright (C) 2007, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors source-files.errors kernel namespaces assocs ;
USING: accessors source-files.errors kernel namespaces assocs fry
summary ;
IN: compiler.errors
TUPLE: compiler-error < source-file-error ;
M: compiler-error error-type error>> error-type ;
SYMBOL: +compiler-error+
SYMBOL: compiler-errors
compiler-errors [ H{ } clone ] initialize
SYMBOLS: +compiler-error+ +compiler-warning+ +linkage-error+ ;
TUPLE: compiler-error < source-file-error ;
: errors-of-type ( type -- assoc )
compiler-errors get-global
swap [ [ nip error-type ] dip eq? ] curry
assoc-filter ;
M: compiler-error error-type drop +compiler-error+ ;
SYMBOL: +linkage-error+
SYMBOL: linkage-errors
linkage-errors [ H{ } clone ] initialize
TUPLE: linkage-error < source-file-error ;
M: linkage-error error-type drop +linkage-error+ ;
: clear-compiler-error ( word -- )
compiler-errors linkage-errors
[ get-global delete-at ] bi-curry@ bi ;
: compiler-error ( error -- )
dup asset>> compiler-errors get-global set-at ;
T{ error-type
{ type +compiler-error+ }
{ word ":errors" }
{ plural "compiler errors" }
{ icon "vocab:ui/tools/error-list/icons/compiler-error.tiff" }
{ quot [ +compiler-error+ errors-of-type values ] }
{ quot [ compiler-errors get values ] }
{ forget-quot [ compiler-errors get delete-at ] }
} define-error-type
T{ error-type
{ type +compiler-warning+ }
{ word ":warnings" }
{ plural "compiler warnings" }
{ icon "vocab:ui/tools/error-list/icons/compiler-warning.tiff" }
{ quot [ +compiler-warning+ errors-of-type values ] }
{ forget-quot [ compiler-errors get delete-at ] }
} define-error-type
: <compiler-error> ( error word -- compiler-error )
\ compiler-error <definition-error> ;
: <linkage-error> ( error word -- linkage-error )
\ linkage-error <definition-error> ;
: linkage-error ( error word class -- )
'[ _ boa ] dip <linkage-error> dup asset>> linkage-errors get set-at ; inline
T{ error-type
{ type +linkage-error+ }
{ word ":linkage" }
{ plural "linkage errors" }
{ icon "vocab:ui/tools/error-list/icons/linkage-error.tiff" }
{ quot [ +linkage-error+ errors-of-type values ] }
{ forget-quot [ compiler-errors get delete-at ] }
{ quot [ linkage-errors get values ] }
{ forget-quot [ linkage-errors get delete-at ] }
{ fatal? f }
} define-error-type
: <compiler-error> ( error word -- compiler-error )
\ compiler-error <definition-error> ;
TUPLE: no-such-library name ;
: compiler-error ( error word -- )
compiler-errors get-global pick
[ [ [ <compiler-error> ] keep ] dip set-at ] [ delete-at drop ] if ;
M: no-such-library summary drop "Library not found" ;
: no-such-library ( name word -- ) \ no-such-library linkage-error ;
TUPLE: no-such-symbol name ;
M: no-such-symbol summary drop "Symbol not found" ;
: no-such-symbol ( name word -- ) \ no-such-symbol linkage-error ;
ERROR: not-compiled word error ;

2
basis/compiler/tests/alien.factor
View File

@ -5,7 +5,7 @@ continuations effects namespaces.private io io.streams.string
memory system threads tools.test math accessors combinators
specialized-arrays.float alien.libraries io.pathnames
io.backend ;
IN: compiler.tests
IN: compiler.tests.alien
<<
: libfactor-ffi-tests-path ( -- string )

4
basis/compiler/tests/codegen.factor
View File

@ -4,7 +4,7 @@ sequences sequences.private tools.test namespaces.private
slots.private sequences.private byte-arrays alien
alien.accessors layouts words definitions compiler.units io
combinators vectors grouping make ;
IN: compiler.tests
IN: compiler.tests.codegen
! Originally, this file did black box testing of templating
! optimization. We now have a different codegen, but the tests
@ -281,4 +281,4 @@ TUPLE: cucumber ;
M: cucumber equal? "The cucumber has no equal" throw ;
[ t ] [ [ cucumber ] compile-call cucumber eq? ] unit-test
[ t ] [ [ cucumber ] compile-call cucumber eq? ] unit-test

2
basis/compiler/tests/curry.factor
View File

@ -1,6 +1,6 @@
USING: tools.test quotations math kernel sequences
assocs namespaces make compiler.units compiler ;
IN: compiler.tests
IN: compiler.tests.curry
[ 3 ] [ 5 [ [ 2 - ] curry call ] compile-call ] unit-test
[ 3 ] [ [ 5 [ 2 - ] curry call ] compile-call ] unit-test

2
basis/compiler/tests/float.factor
View File

@ -1,4 +1,4 @@
IN: compiler.tests
IN: compiler.tests.float
USING: compiler.units compiler kernel kernel.private memory math
math.private tools.test math.floats.private ;

2
basis/compiler/tests/folding.factor
View File

@ -1,6 +1,6 @@
USING: eval tools.test compiler.units vocabs multiline words
kernel classes.mixin arrays ;
IN: compiler.tests
IN: compiler.tests.folding
! Calls to generic words were not folded away.

2
basis/compiler/tests/intrinsics.factor
View File

@ -6,7 +6,7 @@ sbufs strings.private slots.private alien math.order
alien.accessors alien.c-types alien.syntax alien.strings
namespaces libc sequences.private io.encodings.ascii
classes compiler ;
IN: compiler.tests
IN: compiler.tests.intrinsics
! Make sure that intrinsic ops compile to correct code.
[ ] [ 1 [ drop ] compile-call ] unit-test

2
basis/compiler/tests/optimizer.factor
View File

@ -5,7 +5,7 @@ quotations classes classes.algebra classes.tuple.private
continuations growable namespaces hints alien.accessors
compiler.tree.builder compiler.tree.optimizer sequences.deep
compiler ;
IN: optimizer.tests
IN: compiler.tests.optimizer
GENERIC: xyz ( obj -- obj )
M: array xyz xyz ;

4
basis/compiler/tests/peg-regression-2.factor
View File

@ -1,4 +1,4 @@
IN: compiler.tests
IN: compiler.tests.peg-regression-2
USING: peg.ebnf strings tools.test ;
GENERIC: <times> ( times -- term' )
@ -12,4 +12,4 @@ Regexp = Times:t => [[ t <times> ]]
;EBNF
[ "foo" ] [ "a" parse-regexp ] unit-test
[ "foo" ] [ "a" parse-regexp ] unit-test

2
basis/compiler/tests/peg-regression.factor
View File

@ -5,7 +5,7 @@
! end of a compilation unit.
USING: kernel accessors peg.ebnf ;
IN: compiler.tests
IN: compiler.tests.peg-regression
TUPLE: pipeline-expr background ;

2
basis/compiler/tests/redefine0.factor
View File

@ -104,4 +104,4 @@ quot global delete-at
\ test-11 forget
\ quot forget
] with-compilation-unit
] unit-test
] unit-test

6
basis/compiler/tests/redefine1.factor
View File

@ -1,7 +1,7 @@
USING: accessors compiler compiler.units tools.test math parser
kernel sequences sequences.private classes.mixin generic
definitions arrays words assocs eval strings ;
IN: compiler.tests
IN: compiler.tests.redefine1
GENERIC: method-redefine-generic-1 ( a -- b )
@ -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.redefine1 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.redefine1 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

2
basis/compiler/tests/redefine10.factor
View File

@ -1,6 +1,6 @@
USING: eval tools.test compiler.units vocabs multiline words
kernel ;
IN: compiler.tests
IN: compiler.tests.redefine10
! Mixin redefinition did not recompile all necessary words.

2
basis/compiler/tests/redefine11.factor
View File

@ -1,6 +1,6 @@
USING: eval tools.test compiler.units vocabs multiline words
kernel classes.mixin arrays ;
IN: compiler.tests
IN: compiler.tests.redefine11
! Mixin redefinition did not recompile all necessary words.

2
basis/compiler/tests/redefine15.factor
View File

@ -17,4 +17,4 @@ DEFER: word-1
[ \ word-3 [ [ 2 + ] bi@ ] (( a b -- c d )) define-declared ] with-compilation-unit
[ 2 3 ] [ 0 word-4 ] unit-test
[ 2 3 ] [ 0 word-4 ] unit-test

4
basis/compiler/tests/redefine2.factor
View File

@ -1,11 +1,11 @@
IN: compiler.tests
IN: compiler.tests.redefine2
USING: compiler compiler.units tools.test math parser kernel
sequences sequences.private classes.mixin generic definitions
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.redefine2 TUPLE: redefine2-test ; M: redefine2-test nth 2drop 3 ; INSTANCE: redefine2-test sequence" eval( -- ) ] unit-test
[ t ] [ \ redefine2-test symbol? ] unit-test

4
basis/compiler/tests/redefine3.factor
View File

@ -1,4 +1,4 @@
IN: compiler.tests
IN: compiler.tests.redefine3
USING: accessors compiler compiler.units tools.test math parser
kernel sequences sequences.private classes.mixin generic
definitions arrays words assocs eval ;
@ -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.redefine3 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

4
basis/compiler/tests/redefine4.factor
View File

@ -1,4 +1,4 @@
IN: compiler.tests
IN: compiler.tests.redefine4
USING: io.streams.string kernel tools.test eval ;
: declaration-test-1 ( -- a ) 3 ; flushable
@ -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.redefine4 USE: io : declaration-test-1 ( -- a ) \"X\" write f ;" eval( -- ) ] unit-test
[ "X" ] [ [ declaration-test ] with-string-writer ] unit-test

2
basis/compiler/tests/redefine5.factor
View File

@ -1,6 +1,6 @@
USING: eval tools.test compiler.units vocabs multiline words
kernel ;
IN: compiler.tests
IN: compiler.tests.redefine5
! Regression: if dispatch was eliminated but method was not inlined,
! compiled usage information was not recorded.

2
basis/compiler/tests/redefine6.factor
View File

@ -1,6 +1,6 @@
USING: eval tools.test compiler.units vocabs multiline words
kernel ;
IN: compiler.tests
IN: compiler.tests.redefine6
! Mixin redefinition did not recompile all necessary words.

2
basis/compiler/tests/redefine7.factor
View File

@ -1,6 +1,6 @@
USING: eval tools.test compiler.units vocabs multiline words
kernel ;
IN: compiler.tests
IN: compiler.tests.redefine7
! Mixin redefinition did not recompile all necessary words.

2
basis/compiler/tests/redefine8.factor
View File

@ -1,6 +1,6 @@
USING: eval tools.test compiler.units vocabs multiline words
kernel ;
IN: compiler.tests
IN: compiler.tests.redefine8
! Mixin redefinition did not recompile all necessary words.

2
basis/compiler/tests/redefine9.factor
View File

@ -1,6 +1,6 @@
USING: eval tools.test compiler.units vocabs multiline words
kernel generic.math ;
IN: compiler.tests
IN: compiler.tests.redefine9
! Mixin redefinition did not recompile all necessary words.

2
basis/compiler/tests/reload.factor
View File

@ -1,4 +1,4 @@
IN: compiler.tests
IN: compiler.tests.reload
USE: vocabs.loader
! "parser" reload

2
basis/compiler/tests/simple.factor
View File

@ -1,7 +1,7 @@
USING: compiler compiler.units tools.test kernel kernel.private
sequences.private math.private math combinators strings alien
arrays memory vocabs parser eval ;
IN: compiler.tests
IN: compiler.tests.simple
! Test empty word
[ ] [ [ ] compile-call ] unit-test

2
basis/compiler/tests/spilling.factor
View File

@ -1,6 +1,6 @@
USING: math.private kernel combinators accessors arrays
generalizations tools.test ;
IN: compiler.tests
IN: compiler.tests.spilling
: float-spill-bug ( a -- b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b )
{

2
basis/compiler/tests/stack-trace.factor
View File

@ -1,4 +1,4 @@
IN: compiler.tests
IN: compiler.tests.stack-trace
USING: compiler tools.test namespaces sequences
kernel.private kernel math continuations continuations.private
words splitting grouping sorting accessors ;

2
basis/compiler/tests/tuples.factor
View File

@ -1,4 +1,4 @@
IN: compiler.tests
IN: compiler.tests.tuples
USING: kernel tools.test compiler.units compiler ;
TUPLE: color red green blue ;

4
basis/compiler/tree/builder/builder-docs.factor
View File

@ -3,11 +3,11 @@ compiler.tree stack-checker.errors ;
IN: compiler.tree.builder
HELP: build-tree
{ $values { "quot/word" { $or quotation word } } { "nodes" "a sequence of nodes" } }
{ $values { "word/quot" { $or word quotation } } { "nodes" "a sequence of nodes" } }
{ $description "Attempts to construct tree SSA IR from a quotation." }
{ $notes "This is the first stage of the compiler." }
{ $errors "Throws an " { $link inference-error } " if stack effect inference fails." } ;
HELP: build-sub-tree
{ $values { "#call" #call } { "quot/word" { $or quotation word } } { "nodes" { $maybe "a sequence of nodes" } } }
{ $values { "#call" #call } { "word/quot" { $or word quotation } } { "nodes/f" { $maybe "a sequence of nodes" } } }
{ $description "Attempts to construct tree SSA IR from a quotation, starting with an initial data stack of values from the call site. Outputs " { $link f } " if stack effect inference fails." } ;

31
basis/compiler/tree/builder/builder.factor
View File

@ -15,7 +15,7 @@ IN: compiler.tree.builder
GENERIC: (build-tree) ( quot -- )
M: callable (build-tree) f initial-recursive-state infer-quot ;
M: callable (build-tree) infer-quot-here ;
: check-no-compile ( word -- )
dup "no-compile" word-prop [ do-not-compile ] [ drop ] if ;
@ -31,15 +31,13 @@ M: callable (build-tree) f initial-recursive-state infer-quot ;
dup inline-recursive? [ 1quotation ] [ specialized-def ] if ;
M: word (build-tree)
{
[ initial-recursive-state recursive-state set ]
[ check-no-compile ]
[ word-body infer-quot-here ]
[ current-effect check-effect ]
} cleave ;
[ check-no-compile ]
[ word-body infer-quot-here ]
[ current-effect check-effect ] tri ;
: build-tree-with ( in-stack word/quot -- nodes )
[
<recursive-state> recursive-state set
V{ } clone stack-visitor set
[ [ >vector \ meta-d set ] [ length d-in set ] bi ]
[ (build-tree) ]
@ -56,15 +54,16 @@ PRIVATE>
#! This slows down compiler.tree.propagation.inlining since then every
#! inlined usage of a method has an inline-dependency on the mixin, and
#! not the more specific type at the call site.
specialize-method? off
[
#call in-d>> word/quot build-tree-with unclip-last in-d>> :> in-d
{
{ [ dup not ] [ ] }
{ [ dup ends-with-terminate? ] [ #call out-d>> [ f swap #push ] map append ] }
[ in-d #call out-d>> #copy suffix ]
} cond
] [ dup inference-error? [ drop f ] [ rethrow ] if ] recover ;
f specialize-method? [
[
#call in-d>> word/quot build-tree-with unclip-last in-d>> :> in-d
{
{ [ dup not ] [ ] }
{ [ dup ends-with-terminate? ] [ #call out-d>> [ f swap #push ] map append ] }
[ in-d #call out-d>> #copy suffix ]
} cond
] [ dup inference-error? [ drop f ] [ rethrow ] if ] recover
] with-variable ;
: contains-breakpoints? ( word -- ? )
def>> [ word? ] filter [ "break?" word-prop ] any? ;

12
basis/compiler/tree/checker/checker.factor
View File

@ -144,15 +144,13 @@ M: #terminate check-stack-flow*
SYMBOL: branch-out
: check-branch ( nodes -- datastack )
: check-branch ( nodes -- stack )
[
datastack [ clone ] change
retainstack [ clone ] change
retainstack get clone [ (check-stack-flow) ] dip
terminated? get [ drop f ] [
retainstack get assert=
datastack get
] if
V{ } clone retainstack set
(check-stack-flow)
terminated? get [ assert-retainstack-empty ] unless
terminated? get f datastack get ?
] with-scope ;
M: #branch check-stack-flow*

1
basis/compiler/tree/optimizer/optimizer.factor
View File

@ -29,7 +29,6 @@ SYMBOL: check-optimizer?
normalize
propagate
cleanup
?check
dup run-escape-analysis? [
escape-analysis
unbox-tuples

2
basis/cpu/ppc/assembler/assembler-tests.factor
View File

@ -114,5 +114,3 @@ make vocabs sequences ;
{ HEX: fc411800 } [ 1 2 3 FCMPU ] test-assembler
{ HEX: fc411840 } [ 1 2 3 FCMPO ] test-assembler
{ HEX: 3c601234 HEX: 60635678 } [ HEX: 12345678 3 LOAD ] test-assembler
"cpu.ppc.assembler" words [ must-infer ] each

3
basis/debugger/debugger-tests.factor
View File

@ -2,3 +2,6 @@ IN: debugger.tests
USING: debugger kernel continuations tools.test ;
[ ] [ [ drop ] [ error. ] recover ] unit-test
[ f ] [ { } vm-error? ] unit-test
[ f ] [ { "A" "B" } vm-error? ] unit-test

27
basis/functors/functors.factor
View File

@ -18,6 +18,8 @@ IN: functors
: define-declared* ( word def effect -- ) pick set-word define-declared ;
TUPLE: fake-call-next-method ;
TUPLE: fake-quotation seq ;
GENERIC: >fake-quotations ( quot -- fake )
@ -29,17 +31,25 @@ M: array >fake-quotations [ >fake-quotations ] { } map-as ;
M: object >fake-quotations ;
GENERIC: fake-quotations> ( fake -- quot )
GENERIC: (fake-quotations>) ( fake -- )
M: fake-quotation fake-quotations>
seq>> [ fake-quotations> ] [ ] map-as ;
: fake-quotations> ( fake -- quot )
[ (fake-quotations>) ] [ ] make ;
M: array fake-quotations> [ fake-quotations> ] map ;
M: fake-quotation (fake-quotations>)
[ seq>> [ (fake-quotations>) ] each ] [ ] make , ;
M: object fake-quotations> ;
M: array (fake-quotations>)
[ [ (fake-quotations>) ] each ] { } make , ;
M: fake-call-next-method (fake-quotations>)
drop method-body get literalize , \ (call-next-method) , ;
M: object (fake-quotations>) , ;
: parse-definition* ( accum -- accum )
parse-definition >fake-quotations parsed \ fake-quotations> parsed ;
parse-definition >fake-quotations parsed
[ fake-quotations> first ] over push-all ;
: parse-declared* ( accum -- accum )
complete-effect
@ -64,7 +74,7 @@ SYNTAX: `TUPLE:
SYNTAX: `M:
scan-param parsed
scan-param parsed
\ create-method-in parsed
[ create-method-in dup method-body set ] over push-all
parse-definition*
\ define* parsed ;
@ -92,6 +102,8 @@ SYNTAX: `INSTANCE:
SYNTAX: `inline [ word make-inline ] over push-all ;
SYNTAX: `call-next-method T{ fake-call-next-method } parsed ;
: (INTERPOLATE) ( accum quot -- accum )
[ scan interpolate-locals ] dip
'[ _ with-string-writer @ ] parsed ;
@ -117,6 +129,7 @@ DEFER: ;FUNCTOR delimiter
{ "INSTANCE:" POSTPONE: `INSTANCE: }
{ "SYNTAX:" POSTPONE: `SYNTAX: }
{ "inline" POSTPONE: `inline }
{ "call-next-method" POSTPONE: `call-next-method }
} ;
: push-functor-words ( -- )

9
basis/generalizations/generalizations.factor
View File

@ -26,11 +26,14 @@ MACRO: narray ( n -- )
MACRO: nsum ( n -- )
1- [ + ] n*quot ;
MACRO: firstn-unsafe ( n -- )
[ '[ [ _ ] dip nth-unsafe ] ] map '[ _ cleave ] ;
MACRO: firstn ( n -- )
dup zero? [ drop [ drop ] ] [
[ [ '[ [ _ ] dip nth-unsafe ] ] map ]
[ 1- '[ [ _ ] dip bounds-check 2drop ] ]
bi prefix '[ _ cleave ]
[ 1- swap bounds-check 2drop ]
[ firstn-unsafe ]
bi-curry '[ _ _ bi ]
] if ;
MACRO: npick ( n -- )

69
basis/help/cookbook/cookbook.factor
View File

@ -12,7 +12,7 @@ $nl
$nl
"Factor evaluates code left to right, and stores intermediate values on a " { $emphasis "stack" } ". If you think of the stack as a pile of papers, then " { $emphasis "pushing" } " a value on the stack corresponds to placing a piece of paper at the top of the pile, while " { $emphasis "popping" } " a value corresponds to removing the topmost piece."
$nl
"All words except those which only push literals on the stack must have a " { $emphasis "stack effect declaration" } ", for example " { $snippet "( x y -- z )" } " denotes that a word takes two inputs, with " { $snippet "y" } " at the top of the stack, and returns one output. Stack effect declarations can be viewed by browsing source code, or using tools such as " { $link see } "; they are also checked by the compiler. See " { $link "effect-declaration" } "."
"All words have a " { $emphasis "stack effect declaration" } ", for example " { $snippet "( x y -- z )" } " denotes that a word takes two inputs, with " { $snippet "y" } " at the top of the stack, and returns one output. Stack effect declarations can be viewed by browsing source code, or using tools such as " { $link see } "; they are also checked by the compiler. See " { $link "effects" } "."
$nl
"Coming back to the example in the beginning of this article, the following series of steps occurs as the code is evaluated:"
{ $table
@ -56,18 +56,9 @@ $nl
"5 0 - ! Computes 5-0"
"5 0 swap - ! Computes 0-5"
}
"Also, in the above example a stack effect declaration is written between " { $snippet "(" } " and " { $snippet ")" } " with a mnemonic description of what the word does to the stack. See " { $link "effect-declaration" } " for details."
"Also, in the above example a stack effect declaration is written between " { $snippet "(" } " and " { $snippet ")" } " with a mnemonic description of what the word does to the stack. See " { $link "effects" } " for details."
{ $curious
"This syntax will be familiar to anybody who has used Forth before. However the behavior is slightly different. In most Forth systems, the below code prints 2, because the definition of " { $snippet "b" } " still refers to the previous definition of " { $snippet "a" } ":"
{ $code
": a 1 ;"
": b ( -- x ) a 1 + ;"
": a 2 ;"
"b ."
}
"In Factor, this example will print 3 since word redefinition is explicitly supported."
$nl
"Indeed, redefining a word twice in the same source file is an error; this is almost always a mistake since there's no way to call the first definition. See " { $link "definition-checking" } "."
"This syntax will be familiar to anybody who has used Forth before. However, unlike Forth, some additional static checks are performed. See " { $link "definition-checking" } " and " { $link "inference" } "."
}
{ $references
{ "A whole slew of shuffle words can be used to rearrange the stack. There are forms of word definition other than colon definition, words can be defined entirely at runtime, and word definitions can be " { $emphasis "annotated" } " with tracing calls and breakpoints without modifying the source code." }
@ -175,53 +166,11 @@ $nl
"parser"
} ;
ARTICLE: "cookbook-io" "Input and output cookbook"
"Ask the user for their age, and print it back:"
{ $code
"USING: io math.parser ;"
": ask-age ( -- ) \"How old are you?\" print ;"
": read-age ( -- n ) readln string>number ;"
": print-age ( n -- )"
" \"You are \" write"
" number>string write"
" \" years old.\" print ;"
": example ( -- ) ask-age read-age print-age ;"
"example"
}
"Print the lines of a file in sorted order:"
{ $code
"USING: io io.encodings.utf8 io.files sequences sorting ;"
"\"lines.txt\" utf8 file-lines natural-sort [ print ] each"
}
"Read 1024 bytes from a file:"
{ $code
"USING: io io.encodings.binary io.files ;"
"\"data.bin\" binary [ 1024 read ] with-file-reader"
}
"Convert a file of 4-byte cells from little to big endian or vice versa, by directly mapping it into memory and operating on it with sequence words:"
{ $code
"USING: accessors grouping io.files io.mmap.char kernel sequences ;"
"\"mydata.dat\" ["
" 4 <sliced-groups> [ reverse-here ] change-each"
"] with-mapped-char-file"
}
"Send some bytes to a remote host:"
{ $code
"USING: io io.encodings.ascii io.sockets strings ;"
"\"myhost\" 1033 <inet> ascii"
"[ B{ 12 17 102 } write ] with-client"
}
{ $references
{ }
"number-strings"
"io"
} ;
ARTICLE: "cookbook-application" "Application cookbook"
"Vocabularies can define a main entry point:"
{ $code "IN: game-of-life"
"..."
": play-life ... ;"
": play-life ( -- ) ... ;"
""
"MAIN: play-life"
}
@ -318,7 +267,6 @@ $nl
{ "Use " { $link "cleave-combinators" } " and " { $link "spread-combinators" } " instead of " { $link "shuffle-words" } " to give your code more structure." }
{ "Not everything has to go on the stack. The " { $vocab-link "namespaces" } " vocabulary provides dynamically-scoped variables, and the " { $vocab-link "locals" } " vocabulary provides lexically-scoped variables. Learn both and use them where they make sense, but keep in mind that overuse of variables makes code harder to factor." }
"Every time you define a word which simply manipulates sequences, hashtables or objects in an abstract way which is not related to your program domain, check the library to see if you can reuse an existing definition."
{ "Learn to use the " { $link "inference" } " tool." }
{ "Write unit tests. Factor provides good support for unit testing; see " { $link "tools.test" } ". Once your program has a good test suite you can refactor with confidence and catch regressions early." }
"Don't write Factor as if it were C. Imperative programming and indexed loops are almost always not the most idiomatic solution."
{ "Use sequences, assocs and objects to group related data. Object allocation is very cheap. Don't be afraid to create tuples, pairs and triples. Don't be afraid of operations which allocate new objects either, such as " { $link append } "." }
@ -332,6 +280,7 @@ $nl
"Factor tries to implement as much of itself as possible, because this improves simplicity and performance. One consequence is that Factor exposes its internals for extension and study. You even have the option of using low-level features not usually found in high-level languages, such manual memory management, pointer arithmetic, and inline assembly code."
$nl
"Unsafe features are tucked away so that you will not invoke them by accident, or have to use them to solve conventional programming problems. However when the need arises, unsafe features are invaluable, for example you might have to do some pointer arithmetic when interfacing directly with C libraries." ;
ARTICLE: "cookbook-pitfalls" "Pitfalls to avoid"
"Factor is a very clean and consistent language. However, it has some limitations and leaky abstractions you should keep in mind, as well as behaviors which differ from other languages you may be used to."
{ $list
@ -341,13 +290,6 @@ ARTICLE: "cookbook-pitfalls" "Pitfalls to avoid"
{ "If a literal object appears in a word definition, the object itself is pushed on the stack when the word executes, not a copy. If you intend to mutate this object, you must " { $link clone } " it first. See " { $link "syntax-literals" } "." }
{ "For a discussion of potential issues surrounding the " { $link f } " object, see " { $link "booleans" } "." }
{ "Factor's object system is quite flexible. Careless usage of union, mixin and predicate classes can lead to similar problems to those caused by “multiple inheritance” in other languages. In particular, it is possible to have two classes such that they have a non-empty intersection and yet neither is a subclass of the other. If a generic word defines methods on two such classes, various disambiguation rules are applied to ensure method dispatch remains deterministic, however they may not be what you expect. See " { $link "method-order" } " for details." }
{ "Performance-sensitive code should have a static stack effect so that it can be compiled by the optimizing word compiler, which generates more efficient code than the non-optimizing quotation compiler. See " { $link "inference" } " and " { $link "compiler" } "."
$nl
"This means that methods defined on performance sensitive, frequently-called core generic words such as " { $link nth } " should have static stack effects which are consistent with each other, since a generic word will only have a static stack effect if all methods do."
$nl
"Unit tests for the " { $vocab-link "stack-checker" } " vocabulary can be used to ensure that any methods your vocabulary defines on core generic words have static stack effects:"
{ $code "\"stack-checker\" test" }
"In general, you should strive to write code with inferable stack effects, even for sections of a program which are not performance sensitive; the " { $link infer. } " tool together with the optimizing compiler's error reporting can catch many bugs ahead of time." }
{ "Be careful when calling words which access variables from a " { $link make-assoc } " which constructs an assoc with arbitrary keys, since those keys might shadow variables." }
{ "If " { $link run-file } " throws a stack depth assertion, it means that the top-level form in the file left behind values on the stack. The stack depth is compared before and after loading a source file, since this type of situation is almost always an error. If you have a legitimate need to load a source file which returns data in some manner, define a word in the source file which produces this data on the stack and call the word after loading the file." }
} ;
@ -372,7 +314,6 @@ ARTICLE: "cookbook" "Factor cookbook"
{ $subsection "cookbook-combinators" }
{ $subsection "cookbook-variables" }
{ $subsection "cookbook-vocabs" }
{ $subsection "cookbook-io" }
{ $subsection "cookbook-application" }
{ $subsection "cookbook-scripts" }
{ $subsection "cookbook-philosophy" }

17
basis/help/handbook/handbook.factor
View File

@ -39,7 +39,7 @@ $nl
{ { $snippet "$" { $emphasis "foo" } } { "help markup" } { $links $heading $emphasis } }
}
{ $heading "Stack effect conventions" }
"Stack effect conventions are documented in " { $link "effect-declaration" } "."
"Stack effect conventions are documented in " { $link "effects" } "."
{ $heading "Glossary of terms" }
"Common terminology and abbreviations used throughout Factor and its documentation:"
{ $table
@ -229,9 +229,11 @@ ARTICLE: "handbook-language-reference" "The language"
{ $heading "Fundamentals" }
{ $subsection "conventions" }
{ $subsection "syntax" }
{ $subsection "effects" }
{ $heading "The stack" }
{ $subsection "evaluator" }
{ $heading "Data types" }
{ $subsection "effects" }
{ $subsection "inference" }
{ $heading "Basic data types" }
{ $subsection "booleans" }
{ $subsection "numbers" }
{ $subsection "collections" }
@ -239,16 +241,18 @@ ARTICLE: "handbook-language-reference" "The language"
{ $subsection "words" }
{ $subsection "shuffle-words" }
{ $subsection "combinators" }
{ $subsection "errors" }
{ $subsection "continuations" }
{ $subsection "threads" }
{ $heading "Named values" }
{ $subsection "locals" }
{ $subsection "namespaces" }
{ $subsection "namespaces-global" }
{ $subsection "values" }
{ $heading "Abstractions" }
{ $subsection "errors" }
{ $subsection "objects" }
{ $subsection "destructors" }
{ $subsection "continuations" }
{ $subsection "memoize" }
{ $subsection "parsing-words" }
{ $subsection "macros" }
{ $subsection "fry" }
@ -263,6 +267,7 @@ ARTICLE: "handbook-system-reference" "The implementation"
{ $subsection "vocabularies" }
{ $subsection "source-files" }
{ $subsection "compiler" }
{ $subsection "tools.errors" }
{ $heading "Virtual machine" }
{ $subsection "images" }
{ $subsection "cli" }
@ -283,7 +288,7 @@ ARTICLE: "handbook-tools-reference" "Developer tools"
{ $subsection "prettyprint" }
{ $subsection "inspector" }
{ $subsection "tools.annotations" }
{ $subsection "inference" }
{ $subsection "tools.inference" }
{ $heading "Browsing" }
{ $subsection "see" }
{ $subsection "tools.crossref" }

2
basis/help/help.factor
View File

@ -54,7 +54,7 @@ M: word article-title
dup [ parsing-word? ] [ symbol? ] bi or [
name>>
] [
[ name>> ]
[ unparse ]
[ stack-effect [ effect>string " " prepend ] [ "" ] if* ] bi
append
] if ;

2
basis/help/markup/markup-tests.factor
View File

@ -5,7 +5,7 @@ IN: help.markup.tests
TUPLE: blahblah quux ;
[ "an int" ] [ [ { "int" } $instance ] with-string-writer ] unit-test
[ "int" ] [ [ { "int" } $instance ] with-string-writer ] unit-test
[ ] [ \ quux>> print-topic ] unit-test
[ ] [ \ >>quux print-topic ] unit-test

6
basis/inverse/inverse-tests.factor
View File

@ -83,3 +83,9 @@ C: <nil> nil
[ [ sqrt ] ] [ [ sq ] [undo] ] unit-test
[ [ not ] ] [ [ not ] [undo] ] unit-test
[ { 3 2 1 } ] [ { 1 2 3 } [ reverse ] undo ] unit-test
TUPLE: funny-tuple ;
: <funny-tuple> ( -- funny-tuple ) \ funny-tuple boa ;
: funny-tuple ( -- ) "OOPS" throw ;
[ ] [ [ <funny-tuple> ] [undo] drop ] unit-test

10
basis/inverse/inverse.factor
View File

@ -12,7 +12,7 @@ IN: inverse
ERROR: fail ;
M: fail summary drop "Matching failed" ;
: assure ( ? -- ) [ fail ] unless ;
: assure ( ? -- ) [ fail ] unless ; inline
: =/fail ( obj1 obj2 -- ) = assure ;
@ -74,7 +74,9 @@ UNION: explicit-inverse normal-inverse math-inverse pop-inverse ;
: fold-word ( stack word -- stack )
2dup enough?
[ 1quotation with-datastack ] [ [ % ] [ , ] bi* { } ] if ;
[ 1quotation with-datastack ]
[ [ [ literalize , ] each ] [ , ] bi* { } ]
if ;
: fold ( quot -- folded-quot )
[ { } [ fold-word ] reduce % ] [ ] make ;
@ -217,9 +219,7 @@ DEFER: _
"predicate" word-prop [ dupd call assure ] curry ;
: slot-readers ( class -- quot )
all-slots
[ name>> reader-word 1quotation [ keep ] curry ] map concat
[ ] like [ drop ] compose ;
all-slots [ name>> reader-word 1quotation ] map [ cleave ] curry ;
: ?wrapped ( object -- wrapped )
dup wrapper? [ wrapped>> ] when ;

16
basis/io/directories/search/search-docs.factor
View File

@ -15,13 +15,20 @@ HELP: each-file
}
} ;
HELP: recursive-directory
HELP: recursive-directory-files
{ $values
{ "path" "a pathname string" } { "bfs?" "a boolean, breadth-first or depth-first" }
{ "paths" "a sequence of pathname strings" }
}
{ $description "Traverses a directory path recursively and returns a sequence of files in a breadth-first or depth-first manner." } ;
HELP: recursive-directory-entries
{ $values
{ "path" "a pathname string" } { "bfs?" "a boolean, breadth-first or depth-first" }
{ "directory-entries" "a sequence of directory-entries" }
}
{ $description "Traverses a directory path recursively and returns a sequence of directory-entries in a breadth-first or depth-first manner." } ;
HELP: find-file
{ $values
{ "path" "a pathname string" } { "bfs?" "a boolean, breadth-first or depth-first" } { "quot" quotation }
@ -41,11 +48,11 @@ HELP: find-all-files
{ "path" "a pathname string" } { "quot" quotation }
{ "paths/f" "a sequence of pathname strings or f" }
}
{ $description "Finds all files in the input directory matching the predicate quotation in a breadth-first or depth-first traversal." } ;
{ $description "Recursively finds all files in the input directory matching the predicate quotation." } ;
HELP: find-all-in-directories
{ $values
{ "directories" "a sequence of directory paths" } { "bfs?" "a boolean, breadth-first or depth-first" } { "quot" quotation }
{ "directories" "a sequence of directory paths" } { "quot" quotation }
{ "paths/f" "a sequence of pathname strings or f" }
}
{ $description "Finds all files in the input directories matching the predicate quotation in a breadth-first or depth-first traversal." } ;
@ -55,7 +62,8 @@ HELP: find-all-in-directories
ARTICLE: "io.directories.search" "Searching directories"
"The " { $vocab-link "io.directories.search" } " vocabulary contains words used for recursively iterating over a directory and for finding files in a directory tree." $nl
"Traversing directories:"
{ $subsection recursive-directory }
{ $subsection recursive-directory-files }
{ $subsection recursive-directory-entries }
{ $subsection each-file }
"Finding files:"
{ $subsection find-file }

23
basis/io/directories/search/search-tests.factor
View File

@ -1,12 +1,14 @@
USING: io.directories.search io.files io.files.unique
io.pathnames kernel namespaces sequences sorting tools.test ;
USING: combinators.smart io.directories
io.directories.hierarchy io.directories.search io.files
io.files.unique io.pathnames kernel namespaces sequences
sorting strings tools.test ;
IN: io.directories.search.tests
[ t ] [
[
10 [ "io.paths.test" "gogogo" make-unique-file ] replicate
current-temporary-directory get [ ] find-all-files
] with-unique-directory drop [ natural-sort ] bi@ =
] cleanup-unique-directory [ natural-sort ] bi@ =
] unit-test
[ f ] [
@ -18,3 +20,18 @@ IN: io.directories.search.tests
[ f ] [
{ } t [ "asdfasdfasdfasdfasdf" tail? ] find-in-directories
] unit-test
[ t ] [
[
current-temporary-directory get
"the-head" unique-file drop t
[ file-name "the-head" head? ] find-file string?
] cleanup-unique-directory
] unit-test
[ t ] [
[ unique-directory unique-directory ] output>array
[ [ "abcd" append-path touch-file ] each ]
[ [ file-name "abcd" = ] find-all-in-directories length 2 = ]
[ [ delete-tree ] each ] tri
] unit-test

120
basis/io/directories/search/search.factor
View File

@ -3,96 +3,106 @@
USING: accessors arrays continuations deques dlists fry
io.directories io.files io.files.info io.pathnames kernel
sequences system vocabs.loader locals math namespaces
sorting assocs ;
sorting assocs calendar threads io math.parser ;
IN: io.directories.search
: qualified-directory-entries ( path -- seq )
dup directory-entries
[ [ append-path ] change-name ] with map ;
: qualified-directory-files ( path -- seq )
dup directory-files [ append-path ] with map ;
: with-qualified-directory-files ( path quot -- )
'[ "" qualified-directory-files @ ] with-directory ; inline
: with-qualified-directory-entries ( path quot -- )
'[ "" qualified-directory-entries @ ] with-directory ; inline
<PRIVATE
TUPLE: directory-iterator path bfs queue ;
: qualified-directory ( path -- seq )
dup directory-files [ append-path ] with map ;
: push-directory ( path iter -- )
[ qualified-directory ] dip '[
: push-directory-entries ( path iter -- )
[ [ qualified-directory-entries ] [ 2drop f ] recover ] dip '[
_ [ queue>> ] [ bfs>> ] bi
[ push-front ] [ push-back ] if
] each ;
: <directory-iterator> ( path bfs? -- iterator )
<dlist> directory-iterator boa
dup path>> over push-directory ;
dup path>> over push-directory-entries ;
: next-file ( iter -- file/f )
: next-directory-entry ( iter -- directory-entry/f )
dup queue>> deque-empty? [ drop f ] [
dup queue>> pop-back dup link-info directory?
[ over push-directory next-file ] [ nip ] if
dup queue>> pop-back
dup directory?
[ name>> over push-directory-entries next-directory-entry ]
[ nip ] if
] if ;
:: iterate-directory ( iter quot: ( obj -- ? ) -- obj )
iter next-file [
quot call [ iter quot iterate-directory ] unless*
:: iterate-directory-entries ( iter quot: ( obj -- obj ) -- directory-entry/f )
iter next-directory-entry [
quot call
[ iter quot iterate-directory-entries ] unless*
] [
f
] if* ; inline recursive
: iterate-directory ( iter quot -- path/f )
[ name>> ] prepose iterate-directory-entries ; inline
: setup-traversal ( path bfs quot -- iterator quot' )
[ <directory-iterator> ] dip [ f ] compose ; inline
PRIVATE>
: each-file ( path bfs? quot: ( obj -- ) -- )
: each-file ( path bfs? quot -- )
setup-traversal iterate-directory drop ; inline
: each-directory-entry ( path bfs? quot -- )
setup-traversal iterate-directory-entries drop ; inline
: recursive-directory-files ( path bfs? -- paths )
[ ] accumulator [ each-file ] dip ; inline
: recursive-directory-entries ( path bfs? -- directory-entries )
[ ] accumulator [ each-directory-entry ] dip ; inline
: find-file ( path bfs? quot -- path/f )
[ <directory-iterator> ] dip
[ f ] compose iterate-directory drop ; inline
[ keep and ] curry iterate-directory ; inline
: recursive-directory ( path bfs? -- paths )
[ ] accumulator [ each-file ] dip ;
: find-all-files ( path quot -- paths/f )
[ f <directory-iterator> ] dip pusher
[ [ f ] compose iterate-directory drop ] dip ; inline
: find-file ( path bfs? quot: ( obj -- ? ) -- path/f )
'[
_ _ _ [ <directory-iterator> ] dip
[ keep and ] curry iterate-directory
] [ drop f ] recover ; inline
ERROR: file-not-found path bfs? quot ;
: find-all-files ( path quot: ( obj -- ? ) -- paths/f )
f swap
'[
_ _ _ [ <directory-iterator> ] dip
pusher [ [ f ] compose iterate-directory drop ] dip
] [ drop f ] recover ; inline
: find-file-throws ( path bfs? quot -- path )
3dup find-file dup [ 2nip nip ] [ drop file-not-found ] if ; inline
ERROR: file-not-found ;
: find-in-directories ( directories bfs? quot -- path'/f )
'[ _ [ _ _ find-file-throws ] attempt-all ]
[ drop f ] recover ; inline
: find-in-directories ( directories bfs? quot: ( obj -- ? ) -- path'/f )
'[
_ [ _ _ find-file [ file-not-found ] unless* ] attempt-all
] [
drop f
] recover ; inline
: find-all-in-directories ( directories quot -- paths/f )
'[ _ find-all-files ] map concat ; inline
: find-all-in-directories ( directories bfs? quot: ( obj -- ? ) -- paths/f )
'[ _ _ find-all-files ] map concat ; inline
: with-qualified-directory-files ( path quot -- )
'[
"" directory-files current-directory get
'[ _ prepend-path ] map @
] with-directory ; inline
: with-qualified-directory-entries ( path quot -- )
'[
"" directory-entries current-directory get
'[ [ _ prepend-path ] change-name ] map @
] with-directory ; inline
: link-size/0 ( path -- n )
[ link-info size-on-disk>> ] [ 2drop 0 ] recover ;
: directory-size ( path -- n )
0 swap t [ link-info size-on-disk>> + ] each-file ;
0 swap t [ link-size/0 + ] each-file ;
: path>usage ( directory-entry -- name size )
[ name>> dup ] [ directory? ] bi
[ directory-size ] [ link-size/0 ] if ;
: directory-usage ( path -- assoc )
[
[
[ name>> dup ] [ directory? ] bi [
directory-size
] [
link-info size-on-disk>>
] if
[ path>usage ] [ drop name>> 0 ] recover
] { } map>assoc
] with-qualified-directory-entries sort-values ;

12
basis/io/mmap/functor/functor.factor
View File

@ -9,13 +9,14 @@ SLOT: length
: mapped-file>direct ( mapped-file type -- alien length )
[ [ address>> ] [ length>> ] bi ] dip
heap-size [ 1- + ] keep /i ;
heap-size [ 1 - + ] keep /i ;
FUNCTOR: define-mapped-array ( T -- )
<mapped-A> DEFINES <mapped-${T}-array>
<A> IS <direct-${T}-array>
with-mapped-A-file DEFINES with-mapped-${T}-file
<mapped-A> DEFINES <mapped-${T}-array>
<A> IS <direct-${T}-array>
with-mapped-A-file DEFINES with-mapped-${T}-file
with-mapped-A-file-reader DEFINES with-mapped-${T}-file-reader
WHERE
@ -25,4 +26,7 @@ WHERE
: with-mapped-A-file ( path quot -- )
'[ <mapped-A> @ ] with-mapped-file ; inline
: with-mapped-A-file-reader ( path quot -- )
'[ <mapped-A> @ ] with-mapped-file-reader ; inline
;FUNCTOR

19
basis/io/mmap/mmap-docs.factor
View File

@ -18,7 +18,13 @@ HELP: <mapped-file>
HELP: with-mapped-file
{ $values { "path" "a pathname string" } { "quot" { $quotation "( mmap -- )" } } }
{ $contract "Opens a file and maps its contents into memory, passing the " { $link mapped-file } " instance to the quotation. The mapped file is disposed of when the quotation returns, or if an error is thrown." }
{ $contract "Opens a file for read/write access and maps its contents into memory, passing the " { $link mapped-file } " instance to the quotation. The mapped file is disposed of when the quotation returns, or if an error is thrown." }
{ $notes "This is a low-level word, because " { $link mapped-file } " objects simply expose their base address and length. Most applications should use " { $link "io.mmap.arrays" } " instead." }
{ $errors "Throws an error if a memory mapping could not be established." } ;
HELP: with-mapped-file-reader
{ $values { "path" "a pathname string" } { "quot" { $quotation "( mmap -- )" } } }
{ $contract "Opens a file for read-only access and maps its contents into memory, passing the " { $link mapped-file } " instance to the quotation. The mapped file is disposed of when the quotation returns, or if an error is thrown." }
{ $notes "This is a low-level word, because " { $link mapped-file } " objects simply expose their base address and length. Most applications should use " { $link "io.mmap.arrays" } " instead." }
{ $errors "Throws an error if a memory mapping could not be established." } ;
@ -54,11 +60,20 @@ ARTICLE: "io.mmap.arrays" "Memory-mapped arrays"
ARTICLE: "io.mmap.low-level" "Reading and writing mapped files directly"
"Data can be read and written from the " { $link mapped-file } " by applying low-level alien words to the " { $slot "address" } " slot. See " { $link "reading-writing-memory" } "." ;
ARTICLE: "io.mmap.examples" "Memory-mapped file example"
"Convert a file of 4-byte cells from little to big endian or vice versa, by directly mapping it into memory and operating on it with sequence words:"
{ $code
"USING: accessors grouping io.files io.mmap.char kernel sequences ;"
"\"mydata.dat\" ["
" 4 <sliced-groups> [ reverse-here ] change-each"
"] with-mapped-char-file"
} ;
ARTICLE: "io.mmap" "Memory-mapped files"
"The " { $vocab-link "io.mmap" } " vocabulary implements support for memory-mapped files."
{ $subsection <mapped-file> }
"Memory-mapped files are disposable and can be closed with " { $link dispose } " or " { $link with-disposal } "."
$nl
{ $subsection "io.mmap.examples" }
"A utility combinator which wraps the above:"
{ $subsection with-mapped-file }
"Instances of " { $link mapped-file } " don't support any interesting operations in themselves. There are two facilities for accessing their contents:"

1
basis/io/mmap/mmap-tests.factor
View File

@ -7,6 +7,7 @@ IN: io.mmap.tests
[ ] [ "12345" "mmap-test-file.txt" temp-file ascii set-file-contents ] unit-test
[ ] [ "mmap-test-file.txt" temp-file [ CHAR: 2 0 pick set-nth drop ] with-mapped-char-file ] unit-test
[ 5 ] [ "mmap-test-file.txt" temp-file [ length ] with-mapped-char-file ] unit-test
[ 5 ] [ "mmap-test-file.txt" temp-file [ length ] with-mapped-char-file-reader ] unit-test
[ "22345" ] [ "mmap-test-file.txt" temp-file ascii file-contents ] unit-test
[ "mmap-test-file.txt" temp-file delete-file ] ignore-errors

24
basis/io/mmap/mmap.factor
View File

@ -8,14 +8,27 @@ IN: io.mmap
TUPLE: mapped-file address handle length disposed ;
HOOK: (mapped-file) os ( path length -- address handle )
HOOK: (mapped-file-reader) os ( path length -- address handle )
HOOK: (mapped-file-r/w) os ( path length -- address handle )
ERROR: bad-mmap-size path size ;
: <mapped-file> ( path -- mmap )
<PRIVATE
: prepare-mapped-file ( path -- path' n )
[ normalize-path ] [ file-info size>> ] bi
dup 0 <= [ bad-mmap-size ] when
[ (mapped-file) ] keep
dup 0 <= [ bad-mmap-size ] when ;
PRIVATE>
: <mapped-file-reader> ( path -- mmap )
prepare-mapped-file
[ (mapped-file-reader) ] keep
f mapped-file boa ;
: <mapped-file> ( path -- mmap )
prepare-mapped-file
[ (mapped-file-r/w) ] keep
f mapped-file boa ;
HOOK: close-mapped-file io-backend ( mmap -- )
@ -25,6 +38,9 @@ M: mapped-file dispose* ( mmap -- ) close-mapped-file ;
: with-mapped-file ( path quot -- )
[ <mapped-file> ] dip with-disposal ; inline
: with-mapped-file-reader ( path quot -- )
[ <mapped-file-reader> ] dip with-disposal ; inline
{
{ [ os unix? ] [ "io.mmap.unix" require ] }
{ [ os winnt? ] [ "io.mmap.windows" require ] }

18
basis/io/mmap/unix/unix.factor
View File

@ -4,21 +4,23 @@ USING: alien io io.files kernel math math.bitwise system unix
io.backend.unix io.ports io.mmap destructors locals accessors ;
IN: io.mmap.unix
: open-r/w ( path -- fd ) O_RDWR file-mode open-file ;
:: mmap-open ( path length prot flags -- alien fd )
:: mmap-open ( path length prot flags open-mode -- alien fd )
[
f length prot flags
path open-r/w [ <fd> |dispose drop ] keep
path open-mode file-mode open-file [ <fd> |dispose drop ] keep
[ 0 mmap dup MAP_FAILED = [ (io-error) ] when ] keep
] with-destructors ;
M: unix (mapped-file)
M: unix (mapped-file-r/w)
{ PROT_READ PROT_WRITE } flags
{ MAP_FILE MAP_SHARED } flags
mmap-open ;
O_RDWR mmap-open ;
M: unix (mapped-file-reader)
{ PROT_READ } flags
{ MAP_FILE MAP_SHARED } flags
O_RDONLY mmap-open ;
M: unix close-mapped-file ( mmap -- )
[ [ address>> ] [ length>> ] bi munmap io-error ]
[ handle>> close-file ]
bi ;
[ handle>> close-file ] bi ;

11
basis/io/mmap/windows/windows.factor
View File

@ -28,7 +28,7 @@ M: win32-mapped-file dispose
C: <win32-mapped-file> win32-mapped-file
M: windows (mapped-file)
M: windows (mapped-file-r/w)
[
{ GENERIC_WRITE GENERIC_READ } flags
OPEN_ALWAYS
@ -37,6 +37,15 @@ M: windows (mapped-file)
-rot <win32-mapped-file>
] with-destructors ;
M: windows (mapped-file-reader)
[
GENERIC_READ
OPEN_ALWAYS
{ PAGE_READONLY SEC_COMMIT } flags
FILE_MAP_READ mmap-open
-rot <win32-mapped-file>
] with-destructors ;
M: windows close-mapped-file ( mapped-file -- )
[
[ handle>> &dispose drop ]

11
basis/io/sockets/sockets-docs.factor
View File

@ -56,12 +56,23 @@ $nl
}
"The " { $link inet } " address specifier is not supported by the " { $link send } " word because a single host name can resolve to any number of IPv4 or IPv6 addresses, therefore there is no way to know which address should be used. Applications should call " { $link resolve-host } " then use some kind of strategy to pick the correct address (for example, by sending a packet to each one and waiting for a response, or always assuming IPv4)." ;
ARTICLE: "network-examples" "Networking examples"
"Send some bytes to a remote host:"
{ $code
"USING: io io.encodings.ascii io.sockets strings ;"
"\"myhost\" 1033 <inet> ascii"
"[ B{ 12 17 102 } write ] with-client"
}
"Look up the IP addresses associated with a host name:"
{ $code "USING: io.sockets ;" "\"www.apple.com\" 80 <inet> resolve-host ." } ;
ARTICLE: "network-streams" "Networking"
"Factor supports connection-oriented and packet-oriented communication over a variety of protocols:"
{ $list
"TCP/IP and UDP/IP, over IPv4 and IPv6"
"Unix domain sockets (Unix only)"
}
{ $subsection "network-examples" }
{ $subsection "network-addressing" }
{ $subsection "network-connection" }
{ $subsection "network-packet" }

11
basis/listener/listener.factor
View File

@ -60,7 +60,9 @@ SYMBOL: max-stack-items
10 max-stack-items set-global
SYMBOL: error-summary-hook
SYMBOL: error-summary?
t error-summary? set-global
<PRIVATE
@ -99,13 +101,8 @@ SYMBOL: error-summary-hook
in get auto-use? get [ " - auto" append ] when "( " " )" surround
H{ { background T{ rgba f 1 0.7 0.7 1 } } } format bl flush ;
[ error-summary ] error-summary-hook set-global
: call-error-summary-hook ( -- )
error-summary-hook get call( -- ) ;
:: (listener) ( datastack -- )
call-error-summary-hook
error-summary? get [ error-summary ] when
visible-vars.
datastack datastack.
prompt.

2
basis/math/blas/config/config.factor
View File

@ -18,7 +18,7 @@ blas-fortran-abi [
{ [ os netbsd? cpu x86.64? and ] [ g95-abi ] }
{ [ os windows? cpu x86.64? and ] [ gfortran-abi ] }
{ [ os freebsd? ] [ gfortran-abi ] }
{ [ os linux? cpu x86.32? and ] [ gfortran-abi ] }
{ [ os linux? ] [ gfortran-abi ] }
[ f2c-abi ]
} cond
] initialize

4
basis/math/intervals/intervals-tests.factor
View File

@ -302,8 +302,8 @@ IN: math.intervals.tests
: comparison-test ( -- ? )
random-interval random-interval random-comparison
[ [ [ random-element ] bi@ ] dip first execute ] 3keep
second execute dup incomparable eq? [ 2drop t ] [ = ] if ;
[ [ [ random-element ] bi@ ] dip first execute( a b -- ? ) ] 3keep
second execute( a b -- ? ) dup incomparable eq? [ 2drop t ] [ = ] if ;
[ t ] [ 40000 iota [ drop comparison-test ] all? ] unit-test

3
basis/math/matrices/matrices.factor
View File

@ -1,6 +1,7 @@
! Copyright (C) 2005, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays kernel math math.order math.vectors sequences ;
USING: arrays kernel math math.order math.vectors
sequences sequences.private accessors columns ;
IN: math.matrices
! Matrices

14
basis/memoize/memoize-docs.factor
View File

@ -3,6 +3,20 @@
USING: help.syntax help.markup words quotations effects ;
IN: memoize
ARTICLE: "memoize" "Memoization"
"The " { $vocab-link "memoize" } " vocabulary implements a simple form of memoization, which is when a word caches results for every unique set of inputs that is supplied. Calling a memoized word with the same inputs more than once does not recalculate anything."
$nl
"Memoization is useful in situations where the set of possible inputs is small, but the results are expensive to compute and should be cached. Memoized words should not have any side effects."
$nl
"Defining a memoized word at parse time:"
{ $subsection POSTPONE: MEMO: }
"Defining a memoized word at run time:"
{ $subsection define-memoized }
"Clearing memoized results:"
{ $subsection reset-memoized } ;
ABOUT: "memoize"
HELP: define-memoized
{ $values { "word" word } { "quot" quotation } { "effect" effect } }
{ $description "defines the given word at runtime as one which memoizes its output given a particular input" }

2
basis/peg/ebnf/ebnf-tests.factor
View File

@ -300,8 +300,6 @@ main = Primary
"x[i][j].y" primary
] unit-test
'ebnf' compile must-infer
{ V{ V{ "a" "b" } "c" } } [
"abc" [EBNF a="a" "b" foo=(a "c") EBNF]
] unit-test

2
basis/peg/peg-tests.factor
View File

@ -206,5 +206,3 @@ USE: compiler
[ ] [ enable-compiler ] unit-test
[ [ ] ] [ "" epsilon [ drop [ [ ] ] call ] action parse ] unit-test
[ [ ] ] [ "" epsilon [ drop [ [ ] ] ] action [ call ] action parse ] unit-test

15
basis/prettyprint/backend/backend.factor
View File

@ -35,8 +35,8 @@ M: effect pprint* effect>string "(" ")" surround text ;
name>> "( no name )" or ;
: pprint-word ( word -- )
dup record-vocab
dup word-name* swap word-style styled-text ;
[ record-vocab ]
[ [ word-name* ] [ word-style ] bi styled-text ] bi ;
: pprint-prefix ( word quot -- )
<block swap pprint-word call block> ; inline
@ -48,11 +48,12 @@ M: word pprint*
[ pprint-word ] [ ?start-group ] [ ?end-group ] tri ;
M: method-body pprint*
<block
\ M\ pprint-word
[ "method-class" word-prop pprint-word ]
[ "method-generic" word-prop pprint-word ] bi
block> ;
[
[
[ "M\\ " % "method-class" word-prop word-name* % ]
[ " " % "method-generic" word-prop word-name* % ] bi
] "" make
] [ word-style ] bi styled-text ;
M: real pprint* number>string text ;

2
basis/regexp/parser/parser-tests.factor
View File

@ -4,7 +4,7 @@ IN: regexp.parser.tests
: regexp-parses ( string -- )
[ [ ] ] dip '[ _ parse-regexp drop ] unit-test ;
: regexp-fails ( string -- regexp )
: regexp-fails ( string -- )
'[ _ parse-regexp ] must-fail ;
{

27
basis/stack-checker/backend/backend.factor
View File

@ -84,8 +84,11 @@ M: object apply-object push-literal ;
meta-r empty? [ too-many->r ] unless ;
: infer-quot-here ( quot -- )
[ apply-object terminated? get not ] all?
[ commit-literals ] [ literals get delete-all ] if ;
meta-r [
V{ } clone \ meta-r set
[ apply-object terminated? get not ] all?
[ commit-literals check->r ] [ literals get delete-all ] if
] dip \ meta-r set ;
: infer-quot ( quot rstate -- )
recursive-state get [
@ -113,33 +116,25 @@ M: object apply-object push-literal ;
] if ;
: infer->r ( n -- )
terminated? get [ drop ] [
consume-d dup copy-values [ nip output-r ] [ #>r, ] 2bi
] if ;
consume-d dup copy-values [ nip output-r ] [ #>r, ] 2bi ;
: infer-r> ( n -- )
terminated? get [ drop ] [
consume-r dup copy-values [ nip output-d ] [ #r>, ] 2bi
] if ;
: (consume/produce) ( effect -- inputs outputs )
[ in>> length consume-d ] [ out>> length produce-d ] bi ;
consume-r dup copy-values [ nip output-d ] [ #r>, ] 2bi ;
: consume/produce ( effect quot: ( inputs outputs -- ) -- )
'[ (consume/produce) @ ]
'[ [ in>> length consume-d ] [ out>> length produce-d ] bi @ ]
[ terminated?>> [ terminate ] when ]
bi ; inline
: apply-word/effect ( word effect -- )
swap '[ _ #call, ] consume/produce ;
: end-infer ( -- )
terminated? get [ check->r ] unless
meta-d clone #return, ;
: required-stack-effect ( word -- effect )
dup stack-effect [ ] [ missing-effect ] ?if ;
: apply-word/effect ( word effect -- )
swap '[ _ #call, ] consume/produce ;
: infer-word ( word -- )
{
{ [ dup macro? ] [ do-not-compile ] }

32
basis/stack-checker/errors/errors-docs.factor
View File

@ -3,10 +3,9 @@ sequences.private words ;
IN: stack-checker.errors
HELP: literal-expected
{ $error-description "Thrown when inference encounters a " { $link call } " or " { $link if } " being applied to a value which is not known to be a literal. Such a form can have an arbitrary stack effect, and does not compile." }
{ $notes "This error will be thrown when compiling any combinator, such as " { $link each } ". However, words calling combinators can compile if the combinator is declared " { $link POSTPONE: inline } " and the quotation being passed in is a literal." }
{ $error-description "Thrown when inference encounters a combinator or macro being applied to a value which is not known to be a literal, or constructed in a manner which can be analyzed statically. Such code needs changes before it can compile and run. See " { $link "inference-combinators" } " and " { $link "inference-escape" } " for details." }
{ $examples
"In this example, words calling " { $snippet "literal-expected-example" } " will compile, even if " { $snippet "literal-expected-example" } " does not compile itself:"
"In this example, words calling " { $snippet "literal-expected-example" } " will have a static stac keffect, even if " { $snippet "literal-expected-example" } " does not:"
{ $code
": literal-expected-example ( quot -- )"
" [ call ] [ call ] bi ; inline"
@ -16,10 +15,8 @@ HELP: literal-expected
HELP: unbalanced-branches-error
{ $values { "in" "a sequence of integers" } { "out" "a sequence of integers" } }
{ $description "Throws an " { $link unbalanced-branches-error } "." }
{ $error-description "Thrown when inference encounters an " { $link if } " or " { $link dispatch } " where the branches do not all exit with the same stack height." }
{ $notes "Conditionals with variable stack effects are considered to be bad style and should be avoided since they do not compile."
$nl
"If this error comes up when inferring the stack effect of a recursive word, check the word's stack effect declaration; it might be wrong." }
{ $error-description "Thrown when inference encounters an " { $link if } " or " { $link dispatch } " where the branches do not all exit with the same stack height. See " { $link "inference-branches" } " for details." }
{ $notes "If this error comes up when inferring the stack effect of a recursive word, check the word's stack effect declaration; it might be wrong." }
{ $examples
{ $code
": unbalanced-branches-example ( a b c -- )"
@ -86,25 +83,24 @@ HELP: inconsistent-recursive-call-error
}
} ;
ARTICLE: "inference-errors" "Inference warnings and errors"
ARTICLE: "inference-errors" "Stack checker errors"
"These conditions are thrown by " { $link "inference" } ", as well as the " { $link "compiler" } "."
$nl
"Main wrapper for all inference warnings and errors:"
{ $subsection inference-error }
"Inference warnings:"
"Error thrown when insufficient information is available to calculate the stack effect of a combinator call (see " { $link "inference-combinators" } "):"
{ $subsection literal-expected }
"Inference errors:"
{ $subsection recursive-quotation-error }
{ $subsection unbalanced-branches-error }
"Error thrown when a word's stack effect declaration does not match the composition of the stack effects of its factors:"
{ $subsection effect-error }
{ $subsection missing-effect }
"Inference errors for inline recursive words:"
"Error thrown when branches have incompatible stack effects (see " { $link "inference-branches" } "):"
{ $subsection unbalanced-branches-error }
"Inference errors for inline recursive words (see " { $link "inference-recursive-combinators" } "):"
{ $subsection undeclared-recursion-error }
{ $subsection diverging-recursion-error }
{ $subsection unbalanced-recursion-error }
{ $subsection inconsistent-recursive-call-error }
"Retain stack usage errors:"
"More obscure errors that are unlikely to arise in ordinary code:"
{ $subsection recursive-quotation-error }
{ $subsection too-many->r }
{ $subsection too-many-r> } ;
{ $subsection too-many-r> }
{ $subsection missing-effect } ;
ABOUT: "inference-errors"

91
basis/stack-checker/errors/errors.factor
View File

@ -1,93 +1,36 @@
! Copyright (C) 2006, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel generic sequences io words arrays summary effects
continuations assocs accessors namespaces compiler.errors
stack-checker.values stack-checker.recursive-state
source-files.errors compiler.errors ;
USING: kernel stack-checker.values ;
IN: stack-checker.errors
: pretty-word ( word -- word' )
dup method-body? [ "method-generic" word-prop ] when ;
TUPLE: inference-error ;
TUPLE: inference-error error type word ;
ERROR: do-not-compile < inference-error word ;
M: inference-error error-type type>> ;
ERROR: literal-expected < inference-error what ;
: (inference-error) ( ... class type -- * )
[ boa ] dip
recursive-state get word>>
\ inference-error boa rethrow ; inline
ERROR: unbalanced-branches-error < inference-error branches quots ;
: inference-error ( ... class -- * )
+compiler-error+ (inference-error) ; inline
ERROR: too-many->r < inference-error ;
: inference-warning ( ... class -- * )
+compiler-warning+ (inference-error) ; inline
ERROR: too-many-r> < inference-error ;
TUPLE: do-not-compile word ;
ERROR: missing-effect < inference-error word ;
: do-not-compile ( word -- * ) \ do-not-compile inference-warning ;
ERROR: effect-error < inference-error inferred declared ;
TUPLE: literal-expected what ;
ERROR: recursive-quotation-error < inference-error quot ;
: literal-expected ( what -- * ) \ literal-expected inference-warning ;
ERROR: undeclared-recursion-error < inference-error word ;
M: object (literal) "literal value" literal-expected ;
ERROR: diverging-recursion-error < inference-error word ;
TUPLE: unbalanced-branches-error branches quots ;
ERROR: unbalanced-recursion-error < inference-error word height ;
: unbalanced-branches-error ( branches quots -- * )
\ unbalanced-branches-error inference-error ;
ERROR: inconsistent-recursive-call-error < inference-error word ;
TUPLE: too-many->r ;
ERROR: unknown-primitive-error < inference-error ;
: too-many->r ( -- * ) \ too-many->r inference-error ;
ERROR: transform-expansion-error < inference-error word error ;
TUPLE: too-many-r> ;
: too-many-r> ( -- * ) \ too-many-r> inference-error ;
TUPLE: missing-effect word ;
: missing-effect ( word -- * )
pretty-word \ missing-effect inference-error ;
TUPLE: effect-error inferred declared ;
: effect-error ( inferred declared -- * )
\ effect-error inference-error ;
TUPLE: recursive-quotation-error quot ;
: recursive-quotation-error ( word -- * )
\ recursive-quotation-error inference-error ;
TUPLE: undeclared-recursion-error word ;
: undeclared-recursion-error ( word -- * )
\ undeclared-recursion-error inference-error ;
TUPLE: diverging-recursion-error word ;
: diverging-recursion-error ( word -- * )
\ diverging-recursion-error inference-error ;
TUPLE: unbalanced-recursion-error word height ;
: unbalanced-recursion-error ( word height -- * )
\ unbalanced-recursion-error inference-error ;
TUPLE: inconsistent-recursive-call-error word ;
: inconsistent-recursive-call-error ( word -- * )
\ inconsistent-recursive-call-error inference-error ;
TUPLE: unknown-primitive-error ;
: unknown-primitive-error ( -- * )
\ unknown-primitive-error inference-warning ;
TUPLE: transform-expansion-error word error ;
: transform-expansion-error ( word error -- * )
\ transform-expansion-error inference-error ;
M: object (literal) "literal value" literal-expected ;

69
basis/stack-checker/errors/prettyprint/prettyprint.factor
View File

@ -1,18 +1,11 @@
! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors kernel prettyprint io debugger
sequences assocs stack-checker.errors summary effects make ;
sequences assocs stack-checker.errors summary effects ;
IN: stack-checker.errors.prettyprint
M: inference-error summary error>> summary ;
M: inference-error error-help error>> error-help ;
M: inference-error error.
[ word>> [ "In word: " write . ] when* ] [ error>> error. ] bi ;
M: literal-expected summary
[ "Got a computed value where a " % what>> % " was expected" % ] "" make ;
what>> "Got a computed value where a " " was expected" surround ;
M: literal-expected error. summary print ;
@ -25,63 +18,45 @@ M: unbalanced-branches-error error.
[ [ first pprint-short bl ] [ second effect>string print ] bi ] each ;
M: too-many->r summary
drop
"Quotation pushes elements on retain stack without popping them" ;
drop "Quotation pushes elements on retain stack without popping them" ;
M: too-many-r> summary
drop
"Quotation pops retain stack elements which it did not push" ;
drop "Quotation pops retain stack elements which it did not push" ;
M: missing-effect summary
[
"The word " %
word>> name>> %
" must declare a stack effect" %
] "" make ;
drop "Missing stack effect declaration" ;
M: effect-error summary
drop "Stack effect declaration is wrong" ;
M: recursive-quotation-error error.
"The quotation " write
quot>> pprint
" calls itself." print
"Stack effect inference is undecidable when quotation-level recursion is permitted." print ;
M: recursive-quotation-error summary
drop "Recursive quotation" ;
M: undeclared-recursion-error summary
drop
"Inline recursive words must be declared recursive" ;
word>> name>>
"The inline recursive word " " must be declared recursive" surround ;
M: diverging-recursion-error summary
[
"The recursive word " %
word>> name>> %
" digs arbitrarily deep into the stack" %
] "" make ;
word>> name>>
"The recursive word " " digs arbitrarily deep into the stack" surround ;
M: unbalanced-recursion-error summary
[
"The recursive word " %
word>> name>> %
" leaves with the stack having the wrong height" %
] "" make ;
word>> name>>
"The recursive word " " leaves with the stack having the wrong height" surround ;
M: inconsistent-recursive-call-error summary
[
"The recursive word " %
word>> name>> %
" calls itself with a different set of quotation parameters than were input" %
] "" make ;
word>> name>>
"The recursive word "
" calls itself with a different set of quotation parameters than were input" surround ;
M: unknown-primitive-error summary
drop
"Cannot determine stack effect statically" ;
word>> name>> "The " " word cannot be called from optimized words" surround ;
M: transform-expansion-error summary
drop
"Compiler transform threw an error" ;
word>> name>> "Macro expansion of " " threw an error" surround ;
M: transform-expansion-error error.
[ summary print ]
[ "Word: " write word>> . nl ]
[ error>> error. ] tri ;
[ summary print ] [ error>> error. ] bi ;
M: do-not-compile summary
word>> name>> "Cannot compile call to " prepend ;

16
basis/stack-checker/recursive-state/recursive-state.factor
View File

@ -1,25 +1,19 @@
! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays sequences kernel sequences assocs
namespaces stack-checker.recursive-state.tree ;
USING: accessors kernel namespaces stack-checker.recursive-state.tree ;
IN: stack-checker.recursive-state
TUPLE: recursive-state word quotations inline-words ;
TUPLE: recursive-state quotations inline-words ;
: initial-recursive-state ( word -- state )
recursive-state new
swap >>word
f >>quotations
f >>inline-words ; inline
: <recursive-state> ( -- state ) recursive-state new ; inline
f initial-recursive-state recursive-state set-global
<recursive-state> recursive-state set-global
: add-local-quotation ( rstate quot -- rstate )
swap clone [ dupd store ] change-quotations ;
: add-inline-word ( word label -- rstate )
swap recursive-state get clone
[ store ] change-inline-words ;
swap recursive-state get clone [ store ] change-inline-words ;
: inline-recursive-label ( word -- label/f )
recursive-state get inline-words>> lookup ;

133
basis/stack-checker/stack-checker-docs.factor
View File

@ -4,38 +4,54 @@ stack-checker.backend
stack-checker.branches
stack-checker.errors
stack-checker.transforms
stack-checker.state ;
stack-checker.state
continuations ;
IN: stack-checker
ARTICLE: "inference-simple" "Straight-line stack effects"
"The simplest case to look at is that of a quotation which does not have any branches or recursion, and just pushes literals and calls words, each of which has a known stack effect."
"The simplest case is when a piece of code does not have any branches or recursion, and just pushes literals and calls words."
$nl
"Stack effect inference works by stepping through the quotation, while maintaining a \"shadow stack\" which tracks stack height at the current position in the quotation. Initially, the shadow stack is empty. If a word is encountered which expects more values than there are on the shadow stack, a global counter is incremented. This counter keeps track of the number of inputs the quotation expects on the stack. When inference is done, this counter, together with the final height of the shadow stack, gives the inferred stack effect."
{ $subsection d-in }
{ $subsection meta-d }
"When a literal is encountered, it is simply pushed on the shadow stack. For example, the stack effect of the following quotation is inferred by pushing all three literals on the shadow stack, then taking the value of " { $link d-in } " and the length of " { $link meta-d } ":"
"Pushing a literal has stack effect " { $snippet "( -- object )" } ". The stack effect of a most words is always known statically from the declaration. Stack effects of " { $link POSTPONE: inline } " words and " { $link "macros" } ", may depend on literals pushed on the stack prior to the call, and this case is discussed in " { $link "inference-combinators" } "."
$nl
"The stack effect of each element in a code snippet is composed. The result is then the stack effect of the snippet."
$nl
"An example:"
{ $example "[ 1 2 3 ] infer." "( -- object object object )" }
"In the following example, the call to " { $link + } " expects two values on the shadow stack, but only one value is present, the literal which was pushed previously. This increments the " { $link d-in } " counter by one:"
{ $example "[ 2 + ] infer." "( object -- object )" }
"After the call to " { $link + } ", the shadow stack contains a \"computed value placeholder\", since the inferencer has no way to know what the resulting value actually is (in fact it is arbitrary)." ;
"Another example:"
{ $example "[ 2 + ] infer." "( object -- object )" } ;
ARTICLE: "inference-combinators" "Combinator stack effects"
"Without further information, one cannot say what the stack effect of " { $link call } " is; it depends on the given quotation. If the inferencer encounters a " { $link call } " without further information, a " { $link literal-expected } " error is raised."
{ $example "[ dup call ] infer." "Got a computed value where a literal quotation was expected\n\nType :help for debugging help." }
"On the other hand, the stack effect of applying " { $link call } " to a literal quotation or a " { $link curry } " of a literal quotation is easy to compute; it behaves as if the quotation was substituted at that point:"
{ $example "[ [ 2 + ] call ] infer." "( object -- object )" }
"Consider a combinator such as " { $link keep } ". The combinator itself does not have a stack effect, because it applies " { $link call } " to a potentially arbitrary quotation. However, since the combinator is declared " { $link POSTPONE: inline } ", a given usage of it can have a stack effect:"
{ $example "[ [ 2 + ] keep ] infer." "( object -- object object )" }
"Another example is the " { $link compose } " combinator. Because it is decared " { $link POSTPONE: inline } ", we can infer the stack effect of applying " { $link call } " to the result of " { $link compose } ":"
{ $example "[ 2 [ + ] curry [ sq ] compose ] infer." "( -- object )" }
"Incidentally, this example demonstrates that the stack effect of nested currying and composition can also be inferred."
"If a word, call it " { $snippet "W" } ", calls a combinator, one of the following two conditions must hold:"
{ $list
{ "The combinator may be called with a quotation that is either a literal, or built from literals, " { $link curry } " and " { $link compose } "." }
{ "The combinator must be called on an input parameter, or be built from input parameters, literals, " { $link curry } " and " { $link compose } ", " { $strong "if" } " the word " { $snippet "W" } " must be declared " { $link POSTPONE: inline } ". Then " { $snippet "W" } " is itself considered to be a combinator, and its callers must satisfy one of these two conditions." }
}
"If neither condition holds, the stack checker throws a " { $link literal-expected } " error, and an escape hatch such as " { $link POSTPONE: call( } " must be used instead. See " { $link "inference-escape" } " for details. An inline combinator can be called with an unknown quotation by currying the quotation onto a literal quotation that uses " { $link POSTPONE: call( } "."
{ $heading "Examples" }
{ $subheading "Calling a combinator" }
"The following usage of " { $link map } " passes the stack checker, because the quotation is the result of " { $link curry } ":"
{ $example "[ [ + ] curry map ] infer." "( object object -- object )" }
{ $subheading "Defining an inline combinator" }
"The following word calls a quotation twice; the word is declared " { $link POSTPONE: inline } ", since it invokes " { $link call } " on the result of " { $link compose } " on an input parameter:"
{ $code ": twice ( value quot -- result ) dup compose call ; inline" }
"The following code now passes the stack checker; it would fail were " { $snippet "twice" } " not declared " { $link POSTPONE: inline } ":"
{ $unchecked-example "USE: math.functions" "[ [ sqrt ] twice ] infer." "( object -- object )" }
{ $subheading "Defining a combinator for unknown quotations" }
"In the next example, " { $link POSTPONE: call( } " must be used because the quotation the result of calling a runtime accessor, and the compiler cannot make any static assumptions about this quotation at all:"
{ $code
"TUPLE: action name quot ;"
": perform ( value action -- result ) quot>> call( value -- result ) ;"
}
{ $subheading "Passing an unknown quotation to an inline combinator" }
"Suppose we want to write :"
{ $code ": perform ( values action -- results ) quot>> map ;" }
"However this fails to pass the stack checker since there is no guarantee the quotation has the right stack effect for " { $link map } ". It can be wrapped in a new quotation with a declaration:"
{ $code ": perform ( values action -- results )" " quot>> [ call( value -- result ) ] curry map ;" }
{ $heading "Explanation" }
"This restriction exists because without further information, one cannot say what the stack effect of " { $link call } " is; it depends on the given quotation. If the stack checker encounters a " { $link call } " without further information, a " { $link literal-expected } " error is raised."
$nl
"A general rule of thumb is that any word which applies " { $link call } " or " { $link curry } " to one of its inputs must be declared " { $link POSTPONE: inline } "."
$nl
"Here is an example where the stack effect cannot be inferred:"
{ $code ": foo ( -- n quot ) 0 [ + ] ;" "[ foo reduce ] infer." }
"However if " { $snippet "foo" } " was declared " { $link POSTPONE: inline } ", everything would work, since the " { $link reduce } " combinator is also " { $link POSTPONE: inline } ", and the inferencer can see the literal quotation value at the point it is passed to " { $link call } ":"
{ $example ": foo ( -- n quot ) 0 [ + ] ; inline" "[ foo reduce ] infer." "( object -- object )" }
"On the other hand, the stack effect of applying " { $link call } " to a literal quotation or a " { $link curry } " of a literal quotation is easy to compute; it behaves as if the quotation was substituted at that point."
{ $heading "Limitations" }
"Passing a literal quotation on the data stack through an inlined recursive combinator nullifies its literal status. For example, the following will not infer:"
{ $example
"[ [ reverse ] swap [ reverse ] map swap call ] infer." "Got a computed value where a literal quotation was expected\n\nType :help for debugging help."
@ -46,30 +62,25 @@ $nl
} ;
ARTICLE: "inference-branches" "Branch stack effects"
"Conditionals such as " { $link if } " and combinators built on " { $link if } " present a problem, in that if the two branches leave the stack at a different height, it is not clear what the stack effect should be. In this case, inference throws a " { $link unbalanced-branches-error } "."
"Conditionals such as " { $link if } " and combinators built on top have the same restrictions as " { $link POSTPONE: inline } " combinators (see " { $link "inference-combinators" } ") with the additional requirement that all branches leave the stack at the same height. If this is not the case, the stack checker throws a " { $link unbalanced-branches-error } "."
$nl
"If all branches leave the stack at the same height, then the stack effect of the conditional is just the maximum of the stack effect of each branch. For example,"
{ $example "[ [ + ] [ drop ] if ] infer." "( object object object -- object )" }
"The call to " { $link if } " takes one value from the stack, a generalized boolean. The first branch " { $snippet "[ + ]" } " has stack effect " { $snippet "( x x -- x )" } " and the second has stack effect " { $snippet "( x -- )" } ". Since both branches decrease the height of the stack by one, we say that the stack effect of the two branches is " { $snippet "( x x -- x )" } ", and together with the boolean popped off the stack by " { $link if } ", this gives a total stack effect of " { $snippet "( x x x -- x )" } "." ;
ARTICLE: "inference-recursive" "Stack effects of recursive words"
"When a recursive call is encountered, the declared stack effect is substituted in. When inference is complete, the inferred stack effect is compared with the declared stack effect."
ARTICLE: "inference-recursive-combinators" "Recursive combinator stack effects"
"Most combinators do not call themselves recursively directly; instead, they are implemented in terms of existing combinators, for example " { $link while } ", " { $link map } ", and the " { $link "compositional-combinators" } ". In these cases, the rules outlined in " { $link "inference-combinators" } " apply."
$nl
"Attempting to infer the stack effect of a recursive word which outputs a variable number of objects on the stack will fail. For example, the following will throw an " { $link unbalanced-branches-error } ":"
{ $code ": foo ( seq -- ) dup empty? [ drop ] [ dup pop foo ] if ;" "[ foo ] infer." }
"If you declare an incorrect stack effect, inference will fail also. Badly defined recursive words cannot confuse the inferencer." ;
ARTICLE: "inference-recursive-combinators" "Recursive combinator inference"
"Most combinators are not explicitly recursive; instead, they are implemented in terms of existing combinators, for example " { $link while } ", " { $link map } ", and the " { $link "compositional-combinators" } "."
$nl
"Combinators which are recursive require additional care."
$nl
"If a recursive word takes quotation parameters from the stack and calls them, it must be declared " { $link POSTPONE: inline } " (as documented in " { $link "inference-combinators" } ") as well as " { $link POSTPONE: recursive } "."
$nl
"Furthermore, the input parameters which are quotations must be annotated in the stack effect. For example, the following will not infer:"
"Combinators which are recursive require additional care. In addition to being declared " { $link POSTPONE: inline } ", they must be declared " { $link POSTPONE: recursive } ". There are three restrictions that only apply to combinators with this declaration:"
{ $heading "Input quotation declaration" }
"Input parameters which are quotations must be annotated as much in the stack effect. For example, the following will not infer:"
{ $example ": bad ( quot -- ) [ call ] keep foo ; inline recursive" "[ [ ] bad ] infer." "Got a computed value where a literal quotation was expected\n\nType :help for debugging help." }
"The following is correct:"
{ $example ": good ( quot: ( -- ) -- ) [ call ] keep good ; inline recursive" "[ [ ] good ] infer." "( -- )" }
"The effect of the nested quotation itself is only present for documentation purposes; the mere presence of a nested effect is sufficient to mark that value as a quotation parameter."
{ $heading "Data flow restrictions" }
"The stack checker does not trace data flow in two instances."
$nl
"An inline recursive word cannot pass a quotation on the data stack through the recursive call. For example, the following will not infer:"
{ $example ": bad ( ? quot: ( ? -- ) -- ) 2dup [ not ] dip bad call ; inline recursive" "[ [ drop ] bad ] infer." "Got a computed value where a literal quotation was expected\n\nType :help for debugging help." }
"However a small change can be made:"
@ -80,23 +91,47 @@ $nl
"[ [ 5 ] t foo ] infer."
} ;
ARTICLE: "inference" "Stack effect inference"
"The stack effect inference tool is used to check correctness of code before it is run. It is also used by the optimizing compiler to build the high-level SSA representation on which optimizations can be performed. Only words for which a stack effect can be inferred will compile with the optimizing compiler; all other words will be compiled with the non-optimizing compiler (see " { $link "compiler" } ")."
$nl
"The main entry point is a single word which takes a quotation and prints its stack effect and variable usage:"
{ $subsection infer. }
"Instead of printing the inferred information, it can be returned as objects on the stack:"
ARTICLE: "tools.inference" "Stack effect tools"
{ $link "inference" } " can be used interactively to print stack effects of quotations without running them. It can also be used from " { $link "combinators.smart" } "."
{ $subsection infer }
"Static stack effect inference can be combined with unit tests; see " { $link "tools.test.write" } "."
{ $subsection infer. }
"There are also some words for working with " { $link effect } " instances. Getting a word's declared stack effect:"
{ $subsection stack-effect }
"Converting a stack effect to a string form:"
{ $subsection effect>string }
"Comparing effects:"
{ $subsection effect-height }
{ $subsection effect<= }
"The class of stack effects:"
{ $subsection effect }
{ $subsection effect? } ;
ARTICLE: "inference-escape" "Stack effect checking escape hatches"
"In a static checking regime, sometimes it is necessary to step outside the boundaries and run some code which cannot be statically checked; perhaps this code is constructed at run-time. There are two ways to get around the static stack checker."
$nl
"The following articles describe the implementation of the stack effect inference algorithm:"
"If the stack effect of a word or quotation is known, but the word or quotation itself is not, " { $link POSTPONE: execute( } " or " { $link POSTPONE: call( } " can be used. See " { $link "call" } " for details."
$nl
"If the stack effect is not known, the code being called cannot manipulate the datastack directly. Instead, it must reflect the datastack into an array:"
{ $subsection with-datastack }
"The surrounding code has a static stack effect since " { $link with-datastack } " has one. However, the array passed in as input may be transformed arbitrarily by calling this combinator." ;
ARTICLE: "inference" "Stack effect checking"
"The " { $link "compiler" } " checks the " { $link "effects" } " of words before they can be run. This ensures that words take exactly the number of inputs and outputs that the programmer declares in source."
$nl
"Words that do not pass the stack checker are rejected and cannot be run, and so essentially this defines a very simple and permissive type system that nevertheless catches some invalid programs and enables compiler optimizations."
$nl
"If a word's stack effect cannot be inferred, a compile error is reported. See " { $link "compiler-errors" } "."
$nl
"The following articles describe how different control structures are handled by the stack checker."
{ $subsection "inference-simple" }
{ $subsection "inference-recursive" }
{ $subsection "inference-combinators" }
{ $subsection "inference-recursive-combinators" }
{ $subsection "inference-branches" }
"Stack checking catches several classes of errors."
{ $subsection "inference-errors" }
{ $see-also "effects" } ;
"Sometimes code with a dynamic stack effect has to be run."
{ $subsection "inference-escape" }
{ $see-also "effects" "tools.inference" "tools.errors" } ;
ABOUT: "inference"

6
basis/stack-checker/stack-checker-tests.factor
View File

@ -299,7 +299,7 @@ ERROR: custom-error ;
[ custom-error inference-error ] infer
] unit-test
[ T{ effect f 1 1 t } ] [
[ T{ effect f 1 2 t } ] [
[ dup [ 3 throw ] dip ] infer
] unit-test
@ -369,4 +369,6 @@ DEFER: eee'
[ [ cond ] infer ] must-fail
[ [ bi ] infer ] must-fail
[ at ] must-infer
[ at ] must-infer
[ [ [ "OOPS" throw ] dip ] [ drop ] if ] must-infer

1
basis/stack-checker/state/state.factor
View File

@ -42,7 +42,6 @@ SYMBOL: literals
: init-inference ( -- )
terminated? off
V{ } clone \ meta-d set
V{ } clone \ meta-r set
V{ } clone literals set
0 d-in set ;

10
basis/stack-checker/transforms/transforms.factor
View File

@ -1,7 +1,7 @@
! Copyright (C) 2007, 2009 Slava Pestov, Daniel Ehrenberg.
! See http://factorcode.org/license.txt for BSD license.
USING: fry accessors arrays kernel kernel.private combinators.private
words sequences generic math math.order namespaces make quotations
words sequences generic math math.order namespaces quotations
assocs combinators combinators.short-circuit classes.tuple
classes.tuple.private effects summary hashtables classes generic sets
definitions generic.standard slots.private continuations locals
@ -113,11 +113,9 @@ M\ tuple-class boa t "no-compile" set-word-prop
\ new [
dup tuple-class? [
dup inlined-dependency depends-on
[
[ all-slots [ initial>> literalize , ] each ]
[ literalize , ] bi
\ boa ,
] [ ] make
[ all-slots [ initial>> literalize ] map ]
[ tuple-layout '[ _ <tuple-boa> ] ]
bi append
] [ drop f ] if
] 1 define-transform

2
basis/threads/threads-docs.factor
View File

@ -48,7 +48,7 @@ ARTICLE: "thread-impl" "Thread implementation"
{ $subsection sleep-queue } ;
ARTICLE: "threads" "Lightweight co-operative threads"
"Factor supports lightweight co-operative threads implemented on top of continuations. A thread will yield while waiting for input/output operations to complete, or when a yield has been explicitly requested."
"Factor supports lightweight co-operative threads implemented on top of " { $link "continuations" } ". A thread will yield while waiting for input/output operations to complete, or when a yield has been explicitly requested."
$nl
"Factor threads are very lightweight. Each thread can take as little as 900 bytes of memory. This library has been tested running hundreds of thousands of simple threads."
$nl

4
basis/tools/crossref/crossref-docs.factor
View File

@ -1,5 +1,5 @@
USING: help.markup help.syntax words definitions prettyprint
tools.crossref.private math quotations assocs ;
tools.crossref.private math quotations assocs kernel ;
IN: tools.crossref
ARTICLE: "tools.crossref" "Definition cross referencing"
@ -51,7 +51,7 @@ HELP: usage.
{ $examples { $code "\\ reverse usage." } } ;
HELP: quot-uses
{ $values { "quot" quotation } { "assoc" "an assoc with words as keys" } }
{ $values { "obj" object } { "assoc" "an assoc with words as keys" } }
{ $description "Outputs a set of words referenced by the quotation and any quotations it contains." } ;
{ usage usage. } related-words

2
basis/tools/crossref/crossref-tests.factor
View File

@ -1,6 +1,6 @@
USING: math kernel sequences io.files io.pathnames
tools.crossref tools.test parser namespaces source-files generic
definitions ;
definitions words accessors compiler.units ;
IN: tools.crossref.tests
GENERIC: foo ( a b -- c )

25
basis/tools/crossref/crossref.factor
View File

@ -13,30 +13,47 @@ GENERIC: uses ( defspec -- seq )
<PRIVATE
SYMBOL: visited
GENERIC# quot-uses 1 ( obj assoc -- )
M: object quot-uses 2drop ;
M: word quot-uses over crossref? [ conjoin ] [ 2drop ] if ;
: seq-uses ( seq assoc -- ) [ quot-uses ] curry each ;
: (seq-uses) ( seq assoc -- )
[ quot-uses ] curry each ;
: seq-uses ( seq assoc -- )
over visited get memq? [ 2drop ] [
over visited get push
(seq-uses)
] if ;
: assoc-uses ( assoc' assoc -- )
over visited get memq? [ 2drop ] [
over visited get push
[ >alist ] dip (seq-uses)
] if ;
M: array quot-uses seq-uses ;
M: hashtable quot-uses [ >alist ] dip seq-uses ;
M: hashtable quot-uses assoc-uses ;
M: callable quot-uses seq-uses ;
M: wrapper quot-uses [ wrapped>> ] dip quot-uses ;
M: callable uses ( quot -- assoc )
H{ } clone [ quot-uses ] keep keys ;
V{ } clone visited [
H{ } clone [ quot-uses ] keep keys
] with-variable ;
M: word uses def>> uses ;
M: link uses { $subsection $link $see-also } article-links ;
M: pathname uses string>> source-file top-level-form>> uses ;
M: pathname uses string>> source-file top-level-form>> [ uses ] [ { } ] if* ;
GENERIC: crossref-def ( defspec -- )

31
basis/tools/errors/errors-docs.factor
View File

@ -1,35 +1,34 @@
IN: tools.errors
USING: help.markup help.syntax source-files.errors words io
compiler.errors ;
compiler.errors classes ;
ARTICLE: "compiler-errors" "Compiler warnings and errors"
"After loading a vocabulary, you might see messages like:"
ARTICLE: "compiler-errors" "Compiler errors"
"After loading a vocabulary, you might see a message like:"
{ $code
":errors - print 2 compiler errors"
":warnings - print 50 compiler warnings"
}
"These messages arise from the compiler's stack effect checker. Production code should not have any warnings and errors in it. Warning and error conditions are documented in " { $link "inference-errors" } "."
"This indicates that some words did not pass the stack checker. Stack checker error conditions are documented in " { $link "inference-errors" } ", and the stack checker itself in " { $link "inference" } "."
$nl
"Words to view warnings and errors:"
{ $subsection :warnings }
"Words to view errors:"
{ $subsection :errors }
{ $subsection :linkage }
"Compiler warnings and errors are reported using the " { $link "tools.errors" } " mechanism and are shown in the " { $link "ui.tools.error-list" } "." ;
"Compiler errors are reported using the " { $link "tools.errors" } " mechanism, and as a result, they are also are shown in the " { $link "ui.tools.error-list" } "." ;
HELP: compiler-error
{ $values { "error" "an error" } { "word" word } }
{ $description "Saves the error for future persual via " { $link :errors } ", " { $link :warnings } " and " { $link :linkage } "." } ;
{ $values { "error" compiler-error } }
{ $description "Saves the error for viewing with " { $link :errors } "." } ;
HELP: linkage-error
{ $values { "error" linkage-error } { "word" word } { "class" class } }
{ $description "Saves the error for viewing with " { $link :linkage } "." } ;
HELP: :errors
{ $description "Prints all serious compiler errors from the most recent compile to " { $link output-stream } "." } ;
HELP: :warnings
{ $description "Prints all ignorable compiler warnings from the most recent compile to " { $link output-stream } "." } ;
{ $description "Prints all compiler errors." } ;
HELP: :linkage
{ $description "Prints all C library interface linkage errors from the most recent compile to " { $link output-stream } "." } ;
{ $description "Prints all C library interface linkage errors." } ;
{ :errors :warnings :linkage } related-words
{ :errors :linkage } related-words
HELP: errors.
{ $values { "errors" "a sequence of " { $link source-file-error } " instances" } }

13
basis/tools/errors/errors-tests.factor Normal file
View File

@ -0,0 +1,13 @@
USING: compiler.errors stack-checker.errors tools.test words ;
IN: tools.errors
DEFER: blah
[ ] [
{
T{ compiler-error
{ error T{ do-not-compile f blah } }
{ asset blah }
}
} errors.
] unit-test

31
basis/tools/errors/errors.factor
View File

@ -2,44 +2,41 @@
! See http://factorcode.org/license.txt for BSD license.
USING: assocs debugger io kernel sequences source-files.errors
summary accessors continuations make math.parser io.styles namespaces
compiler.errors ;
compiler.errors prettyprint ;
IN: tools.errors
#! Tools for source-files.errors. Used by tools.tests and others
#! for error reporting
M: source-file-error compute-restarts
error>> compute-restarts ;
M: source-file-error compute-restarts error>> compute-restarts ;
M: source-file-error error-help
error>> error-help ;
M: source-file-error error-help error>> error-help ;
CONSTANT: +listener-input+ "<Listener input>"
M: source-file-error summary
[
[ file>> [ % ": " % ] [ "<Listener input>" % ] if* ]
[ file>> [ % ": " % ] [ +listener-input+ % ] if* ]
[ line#>> [ # ] when* ] bi
] "" make
;
] "" make ;
M: source-file-error error.
[ summary print nl ] [ error>> error. ] bi ;
[ summary print nl ]
[ asset>> [ "Asset: " write short. nl ] when* ]
[ error>> error. ]
tri ;
: errors. ( errors -- )
group-by-source-file sort-errors
[
[ nl "==== " write print nl ]
[ nl "==== " write +listener-input+ or print nl ]
[ [ nl ] [ error. ] interleave ]
bi*
] assoc-each ;
: compiler-errors. ( type -- )
errors-of-type values errors. ;
: :errors ( -- ) compiler-errors get values errors. ;
: :errors ( -- ) +compiler-error+ compiler-errors. ;
: :warnings ( -- ) +compiler-warning+ compiler-errors. ;
: :linkage ( -- ) +linkage-error+ compiler-errors. ;
: :linkage ( -- ) linkage-errors get values errors. ;
M: not-compiled summary
word>> name>> "The word " " cannot be executed because it failed to compile" surround ;

1
basis/tools/errors/model/authors.txt Normal file
View File

@ -0,0 +1 @@
Slava Pestov

18
basis/tools/errors/model/model.factor Normal file
View File

@ -0,0 +1,18 @@
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: models source-files.errors namespaces models.delay init
kernel calendar ;
IN: tools.errors.model
SYMBOLS: (error-list-model) error-list-model ;
(error-list-model) [ f <model> ] initialize
error-list-model [ (error-list-model) get-global 100 milliseconds <delay> ] initialize
SINGLETON: updater
M: updater errors-changed drop f (error-list-model) get-global set-model ;
[ updater add-error-observer ] "ui.tools.error-list" add-init-hook

2
basis/tools/profiler/profiler-tests.factor
View File

@ -34,7 +34,7 @@ words ;
[ 1 ] [ \ foobar counter>> ] unit-test
: fooblah ( -- ) { } [ ] like call ;
: fooblah ( -- ) { } [ ] like call( -- ) ;
: foobaz ( -- ) fooblah fooblah ;

3
basis/tools/time/time.factor
View File

@ -10,7 +10,7 @@ IN: tools.time
: time. ( data -- )
unclip
"==== RUNNING TIME" print nl 1000000 /f pprint " seconds" print nl
4 cut*
5 cut*
"==== GARBAGE COLLECTION" print nl
[
6 group
@ -32,6 +32,7 @@ IN: tools.time
"Total GC time (us):"
"Cards scanned:"
"Decks scanned:"
"Card scan time (us):"
"Code heap literal scans:"
} swap zip simple-table.
] bi* ;

2
basis/tuple-arrays/authors.txt
View File

@ -1 +1 @@
Daniel Ehrenberg
Slava Pestov

1
basis/tuple-arrays/summary.txt
View File

@ -1 +0,0 @@
Packed homogeneous tuple arrays

1
basis/tuple-arrays/tags.txt
View File

@ -1 +0,0 @@
collections

13
basis/tuple-arrays/tuple-arrays-docs.factor
View File

@ -1,13 +0,0 @@
USING: help.syntax help.markup splitting kernel sequences ;
IN: tuple-arrays
HELP: tuple-array
{ $description "The class of packed homogeneous tuple arrays. They are created with " { $link <tuple-array> } ". All elements are of the same tuple class. Mutations done to an element are not copied back to the packed array unless it is explicitly written back. To convert a sequence to a tuple array, use the word " { $link >tuple-array } "." } ;
HELP: <tuple-array>
{ $values { "class" "a tuple class" } { "length" "a non-negative integer" } { "tuple-array" tuple-array } }
{ $description "Creates an instance of the " { $link <tuple-array> } " class with the given length and containing the given tuple class." } ;
HELP: >tuple-array
{ $values { "seq" sequence } { "tuple-array" tuple-array } }
{ $description "Converts a sequence into a homogeneous unboxed tuple array of the type indicated by the first element." } ;

23
basis/tuple-arrays/tuple-arrays-tests.factor
View File

@ -5,17 +5,28 @@ IN: tuple-arrays.tests
SYMBOL: mat
TUPLE: foo bar ;
C: <foo> foo
[ 2 ] [ 2 foo <tuple-array> dup mat set length ] unit-test
TUPLE-ARRAY: foo
[ 2 ] [ 2 <foo-array> dup mat set length ] unit-test
[ T{ foo } ] [ mat get first ] unit-test
[ T{ foo f 2 } ] [ T{ foo f 2 } 0 mat get [ set-nth ] keep first ] unit-test
[ t ] [ { T{ foo f 1 } T{ foo f 2 } } >tuple-array dup mat set tuple-array? ] unit-test
[ t ] [ { T{ foo f 1 } T{ foo f 2 } } >foo-array dup mat set foo-array? ] unit-test
[ T{ foo f 3 } t ]
[ mat get [ bar>> 2 + <foo> ] map [ first ] keep tuple-array? ] unit-test
[ mat get [ bar>> 2 + <foo> ] map [ first ] keep foo-array? ] unit-test
[ 2 ] [ 2 foo <tuple-array> dup mat set length ] unit-test
[ 2 ] [ 2 <foo-array> dup mat set length ] unit-test
[ T{ foo } ] [ mat get first ] unit-test
[ T{ foo f 1 } ] [ T{ foo f 1 } 0 mat get [ set-nth ] keep first ] unit-test
TUPLE: baz { bing integer } bong ;
[ 0 ] [ 1 baz <tuple-array> first bing>> ] unit-test
[ f ] [ 1 baz <tuple-array> first bong>> ] unit-test
TUPLE-ARRAY: baz
[ 0 ] [ 1 <baz-array> first bing>> ] unit-test
[ f ] [ 1 <baz-array> first bong>> ] unit-test
TUPLE: broken x ;
: broken ( -- ) ;
TUPLE-ARRAY: broken
[ 100 ] [ 100 <broken-array> length ] unit-test

85
basis/tuple-arrays/tuple-arrays.factor
View File

@ -1,34 +1,73 @@
! Copyright (C) 2007 Daniel Ehrenberg.
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: splitting grouping classes.tuple classes math kernel
sequences arrays accessors ;
USING: accessors arrays combinators.smart fry functors kernel
kernel.private macros sequences combinators sequences.private
stack-checker parser math classes.tuple.private ;
FROM: inverse => undo ;
IN: tuple-arrays
TUPLE: tuple-array { seq read-only } { class read-only } ;
<PRIVATE
: <tuple-array> ( length class -- tuple-array )
[
new tuple>array 1 tail
[ <repetition> concat ] [ length ] bi <sliced-groups>
] [ ] bi tuple-array boa ;
MACRO: boa-unsafe ( class -- quot ) tuple-layout '[ _ <tuple-boa> ] ;
M: tuple-array nth
[ seq>> nth ] [ class>> ] bi prefix >tuple ;
MACRO: infer-in ( class -- quot ) infer in>> '[ _ ] ;
M: tuple-array set-nth ( elt n seq -- )
[ tuple>array 1 tail ] 2dip seq>> set-nth ;
: tuple-arity ( class -- quot ) '[ _ boa ] infer-in ; inline
M: tuple-array new-sequence
class>> <tuple-array> ;
: smart-tuple>array ( tuple class -- array )
'[ [ _ boa ] undo ] output>array ; inline
: >tuple-array ( seq -- tuple-array )
dup empty? [
0 over first class <tuple-array> clone-like
] unless ;
: tuple-prototype ( class -- array )
[ new ] [ smart-tuple>array ] bi ; inline
M: tuple-array like
drop dup tuple-array? [ >tuple-array ] unless ;
: tuple-slice ( n seq -- slice )
[ n>> [ * dup ] keep + ] [ seq>> ] bi { array } declare slice boa ; inline
M: tuple-array length seq>> length ;
: read-tuple ( slice class -- tuple )
'[ _ boa-unsafe ] input<sequence-unsafe ; inline
INSTANCE: tuple-array sequence
MACRO: write-tuple ( class -- quot )
[ '[ [ _ boa ] undo ] ]
[ tuple-arity <reversed> [ '[ [ _ ] dip set-nth-unsafe ] ] map '[ _ cleave ] ]
bi '[ _ dip @ ] ;
PRIVATE>
FUNCTOR: define-tuple-array ( CLASS -- )
CLASS IS ${CLASS}
CLASS-array DEFINES-CLASS ${CLASS}-array
CLASS-array? IS ${CLASS-array}?
<CLASS-array> DEFINES <${CLASS}-array>
>CLASS-array DEFINES >${CLASS}-array
WHERE
TUPLE: CLASS-array
{ seq array read-only }
{ n array-capacity read-only }
{ length array-capacity read-only } ;
: <CLASS-array> ( length -- tuple-array )
[ \ CLASS [ tuple-prototype <repetition> concat ] [ tuple-arity ] bi ] keep
\ CLASS-array boa ; inline
M: CLASS-array length length>> ;
M: CLASS-array nth-unsafe tuple-slice \ CLASS read-tuple ;
M: CLASS-array set-nth-unsafe tuple-slice \ CLASS write-tuple ;
M: CLASS-array new-sequence drop <CLASS-array> ;
: >CLASS-array ( seq -- tuple-array ) 0 <CLASS-array> clone-like ;
M: CLASS-array like drop dup CLASS-array? [ >CLASS-array ] unless ;
INSTANCE: CLASS-array sequence
;FUNCTOR
SYNTAX: TUPLE-ARRAY: scan-word define-tuple-array ;

35
basis/ui/gadgets/tables/tables-tests.factor
View File

@ -1,6 +1,6 @@
IN: ui.gadgets.tables.tests
USING: ui.gadgets.tables ui.gadgets.scrollers accessors
models namespaces tools.test kernel ;
USING: ui.gadgets.tables ui.gadgets.scrollers ui.gadgets.debug accessors
models namespaces tools.test kernel combinators ;
SINGLETON: test-renderer
@ -8,15 +8,40 @@ M: test-renderer row-columns drop ;
M: test-renderer column-titles drop { "First" "Last" } ;
[ ] [
: test-table ( -- table )
{
{ "Britney" "Spears" }
{ "Justin" "Timberlake" }
{ "Don" "Stewart" }
} <model> test-renderer <table>
"table" set
} <model> test-renderer <table> ;
[ ] [
test-table "table" set
] unit-test
[ ] [
"table" get <scroller> "scroller" set
] unit-test
[ { "Justin" "Timberlake" } { "Britney" "Spears" } ] [
test-table t >>selection-required? dup [
{
[ 1 select-row ]
[
model>> {
{ "Justin" "Timberlake" }
{ "Britney" "Spears" }
{ "Don" "Stewart" }
} swap set-model
]
[ selected-row drop ]
[
model>> {
{ "Britney" "Spears" }
{ "Don" "Stewart" }
} swap set-model
]
[ selected-row drop ]
} cleave
] with-grafted-gadget
] unit-test

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