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

db4
Aaron Schaefer 2009-04-27 22:53:20 -04:00
commit b1454784e4
340 changed files with 2630 additions and 2247 deletions

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:

View File

@ -15,5 +15,3 @@ tools.test threads concurrency.count-downs ;
[ resume ] curry instant later drop
] "test" suspend drop
] unit-test
\ alarm-thread-loop must-infer

View File

@ -2,8 +2,6 @@ IN: alien.c-types.tests
USING: alien alien.syntax alien.c-types kernel tools.test
sequences system libc alien.strings io.encodings.utf8 ;
\ expand-constants must-infer
CONSTANT: xyz 123
[ { "blah" 123 } ] [ { "blah" xyz } expand-constants ] unit-test

View File

@ -25,6 +25,3 @@ IN: base64.tests
[ { 33 52 17 40 12 51 33 43 18 33 23 } base64> ]
[ malformed-base64? ] must-fail-with
\ >base64 must-infer
\ base64> must-infer

View File

@ -1,8 +1,6 @@
IN: binary-search.tests
USING: binary-search math.order vectors kernel tools.test ;
\ sorted-member? must-infer
[ f ] [ 3 { } [ <=> ] with search drop ] unit-test
[ 0 ] [ 3 { 3 } [ <=> ] with search drop ] unit-test
[ 1 ] [ 2 { 1 2 3 } [ <=> ] with search drop ] unit-test

View File

@ -108,7 +108,7 @@ nl
"." write flush
{ (compile) } compile-unoptimized
{ compile-word } compile-unoptimized
"." write flush

View File

@ -2,9 +2,6 @@ IN: bootstrap.image.tests
USING: bootstrap.image bootstrap.image.private tools.test
kernel math ;
\ ' must-infer
\ write-image must-infer
[ f ] [ { 1 2 3 } [ 1 2 3 ] eql? ] unit-test
[ t ] [ [ 1 2 3 ] [ 1 2 3 ] eql? ] unit-test

View File

@ -16,13 +16,6 @@ SYMBOL: bootstrap-time
vm file-name os windows? [ "." split1-last drop ] when
".image" append resource-path ;
: do-crossref ( -- )
"Cross-referencing..." print flush
H{ } clone crossref set-global
xref-words
xref-generics
xref-sources ;
: load-components ( -- )
"include" "exclude"
[ get-global " " split harvest ] bi@
@ -68,8 +61,6 @@ SYMBOL: bootstrap-time
(command-line) parse-command-line
do-crossref
! Set dll paths
os wince? [ "windows.ce" require ] when
os winnt? [ "windows.nt" require ] when
@ -77,6 +68,10 @@ SYMBOL: bootstrap-time
"staging" get "deploy-vocab" get or [
"stage2: deployment mode" print
] [
"debugger" require
"alien.prettyprint" require
"inspector" require
"tools.errors" require
"listener" require
"none" require
] if

View File

@ -1,11 +1,7 @@
USING: arrays calendar kernel math sequences tools.test
continuations system math.order threads ;
continuations system math.order threads accessors ;
IN: calendar.tests
\ time+ must-infer
\ time* must-infer
\ time- must-infer
[ f ] [ 2004 12 32 0 0 0 instant <timestamp> valid-timestamp? ] unit-test
[ f ] [ 2004 2 30 0 0 0 instant <timestamp> valid-timestamp? ] unit-test
[ f ] [ 2003 2 29 0 0 0 instant <timestamp> valid-timestamp? ] unit-test
@ -167,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

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 ;

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
@ -10,6 +10,6 @@ IN: calendar.format.macros
: compiled-test-1 ( -- n )
{ [ 1 throw ] [ 2 ] } attempt-all-quots ;
\ compiled-test-1 must-infer
\ compiled-test-1 def>> must-infer
[ 2 ] [ compiled-test-1 ] unit-test

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

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"

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 )
@ -42,7 +42,7 @@ IN: combinators.smart.tests
: nested-smart-combo-test ( -- array )
[ [ 1 2 ] output>array [ 3 4 ] output>array ] output>array ;
\ nested-smart-combo-test must-infer
\ nested-smart-combo-test def>> must-infer
[ { { 1 2 } { 3 4 } } ] [ nested-smart-combo-test ] unit-test

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 ;

View File

@ -5,8 +5,6 @@ math.private compiler.tree.builder compiler.tree.optimizer
compiler.cfg.builder compiler.cfg.debugger arrays locals byte-arrays
kernel.private math ;
\ build-cfg must-infer
! Just ensure that various CFGs build correctly.
: unit-test-cfg ( quot -- ) '[ _ test-cfg drop ] [ ] swap unit-test ;

View File

@ -16,7 +16,7 @@ M: callable test-cfg
build-tree optimize-tree gensym build-cfg ;
M: word test-cfg
[ build-tree-from-word optimize-tree ] keep build-cfg ;
[ build-tree optimize-tree ] keep build-cfg ;
SYMBOL: allocate-registers?

View File

@ -1,4 +1,4 @@
USING: compiler.cfg.linear-scan.assignment tools.test ;
IN: compiler.cfg.linear-scan.assignment.tests
\ assign-registers must-infer

View File

@ -1,4 +1,4 @@
IN: compiler.cfg.linearization.tests
USING: compiler.cfg.linearization tools.test ;
\ build-mr must-infer

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

View File

@ -27,12 +27,12 @@ $nl
{ $subsection compile-queue }
"Once compiled, a word is added to the assoc stored in the " { $link compiled } " variable. When compilation is complete, this assoc is passed to " { $link modify-code-heap } "."
$nl
"The " { $link (compile) } " word performs the actual task of compiling an individual word. The process proceeds as follows:"
"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-from-word } ". If this fails, the error is passed to " { $link fail } ". The logic for ignoring compile warnings generated for inline words and macros is located here. If the error is not ignorable, it is added to the global " { $link compiler-errors } " assoc (see " { $link "compiler-errors" } ")." }
{ "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 maybe-compile } "." }
{ "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 } "." }
}
"If compilation fails, the word is stored in the " { $link compiled } " assoc with a value of " { $link f } ". This causes the VM to compile the word with the non-optimizing compiler."
$nl
@ -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" }
@ -60,7 +60,7 @@ HELP: decompile
{ $values { "word" word } }
{ $description "Removes a word's optimized definition. The word will be compiled with the non-optimizing compiler until recompiled with the optimizing compiler again." } ;
HELP: (compile)
HELP: compile-word
{ $values { "word" word } }
{ $description "Compile a single word." }
{ $notes "This is an internal word, and user code should call " { $link compile } " instead." } ;

View File

@ -2,19 +2,20 @@
! 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
SYMBOL: compiled
: queue-compile? ( word -- ? )
#! Don't attempt to compile certain words.
{
[ "forgotten" word-prop ]
[ compiled get key? ]
@ -25,67 +26,99 @@ SYMBOL: compiled
: queue-compile ( word -- )
dup queue-compile? [ compile-queue get push-front ] [ drop ] if ;
: maybe-compile ( word -- )
dup optimized>> [ drop ] [ queue-compile ] if ;
: recompile-callers? ( word -- ? )
changed-effects get key? ;
SYMBOLS: +optimized+ +unoptimized+ ;
: ripple-up ( words -- )
dup "compiled-status" word-prop +unoptimized+ eq?
[ usage [ word? ] filter ] [ compiled-usage keys ] if
[ queue-compile ] each ;
: ripple-up? ( status word -- ? )
[
[ nip changed-effects get key? ]
[ "compiled-status" word-prop eq? not ] 2bi or
] keep "compiled-status" word-prop and ;
: save-compiled-status ( word status -- )
[ over ripple-up? [ ripple-up ] [ drop ] if ]
[ "compiled-status" set-word-prop ]
2bi ;
: recompile-callers ( words -- )
#! If a word's stack effect changed, recompile all words that
#! have compiled calls to it.
dup recompile-callers?
[ compiled-usage keys [ queue-compile ] each ] [ drop ] if ;
: start ( word -- )
"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 some errors on inline combinators, macros, and special
#! words such as 'call'.
[
{
[ inline? ]
[ macro? ]
[ "transform-quot" word-prop ]
[ "no-compile" word-prop ]
[ inline? ]
[ "special" word-prop ]
[ "no-compile" word-prop ]
} 1||
] [ error-type +compiler-warning+ eq? ] bi* and ;
] [
{
[ do-not-compile? ]
[ literal-expected? ]
} 1||
] bi* and ;
: (fail) ( word -- * )
: finish ( word -- )
#! Recompile callers if the word's stack effect changed, then
#! save the word's dependencies so that if they change, the
#! word can get recompiled too.
[ recompile-callers ]
[ compiled-unxref ]
[ f swap compiled get set-at ]
[ +unoptimized+ save-compiled-status ]
tri
return ;
[
dup crossref? [
dependencies get
generic-dependencies get
compiled-xref
] [ drop ] if
] tri ;
: fail ( word error -- * )
[ 2dup ignore-error? [ drop f ] when swap compiler-error ] [ drop (fail) ] 2bi ;
: deoptimize-with ( word def -- * )
#! If the word failed to infer, compile it with the
#! non-optimizing compiler.
swap [ finish ] [ compiled get set-at ] bi return ;
: not-compiled-def ( word error -- def )
'[ _ _ not-compiled ] [ ] like ;
: deoptimize ( word error -- * )
#! If the error is ignorable, compile the word with the
#! 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
[ 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 )
dup contains-breakpoints? [ (fail) ] [
[ build-tree-from-word ] [ fail ] recover optimize-tree
#! If the word contains breakpoints, don't optimize it, since
#! the walker does not support this.
dup contains-breakpoints? [ dup def>> deoptimize-with ] [
[ build-tree ] [ deoptimize ] recover optimize-tree
] if ;
: compile-dependency ( word -- )
#! If a word calls an unoptimized word, try to compile the callee.
dup optimized>> [ drop ] [ queue-compile ] if ;
! Only switch this off for debugging.
SYMBOL: compile-dependencies?
t compile-dependencies? set-global
: compile-dependencies ( asm -- )
compile-dependencies? get
[ calls>> [ compile-dependency ] each ] [ drop ] if ;
: save-asm ( asm -- )
[ [ code>> ] [ label>> ] bi compiled get set-at ]
[ compile-dependencies? get [ calls>> [ maybe-compile ] each ] [ drop ] if ]
[ compile-dependencies ]
bi ;
: backend ( nodes word -- )
@ -99,19 +132,9 @@ t compile-dependencies? set-global
save-asm
] each ;
: finish ( word -- )
[ +optimized+ save-compiled-status ]
[ compiled-unxref ]
[
dup crossref?
[
dependencies get
generic-dependencies get
compiled-xref
] [ drop ] if
] tri ;
: (compile) ( word -- )
: compile-word ( word -- )
#! We return early if the word has breakpoints or if it
#! failed to infer.
'[
_ {
[ start ]
@ -122,10 +145,10 @@ t compile-dependencies? set-global
] with-return ;
: compile-loop ( deque -- )
[ (compile) yield-hook get call( -- ) ] slurp-deque ;
[ compile-word yield-hook get call( -- ) ] slurp-deque ;
: decompile ( word -- )
f 2array 1array modify-code-heap ;
dup def>> 2array 1array modify-code-heap ;
: compile-call ( quot -- )
[ dup infer define-temp ] with-compilation-unit execute ;
@ -150,4 +173,4 @@ M: optimizing-compiler recompile ( words -- alist )
f compiler-impl set-global ;
: recompile-all ( -- )
forget-errors all-words compile ;
all-words compile ;

View File

@ -1,54 +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 ;

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 )

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

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

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 ;

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.

View File

@ -1,5 +0,0 @@
IN: compiler.tests
USING: words kernel stack-checker alien.strings tools.test
compiler.units ;
[ ] [ [ \ if redefined ] with-compilation-unit [ string>alien ] infer. ] unit-test

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

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 ;
@ -261,7 +261,7 @@ USE: binary-search.private
: lift-loop-tail-test-2 ( -- a b c )
10 [ ] lift-loop-tail-test-1 1 2 3 ;
\ lift-loop-tail-test-2 must-infer
\ lift-loop-tail-test-2 def>> must-infer
[ 1 2 3 ] [ lift-loop-tail-test-2 ] unit-test
@ -302,8 +302,8 @@ HINTS: recursive-inline-hang-3 array ;
: member-test ( obj -- ? ) { + - * / /i } member? ;
\ member-test must-infer
[ ] [ \ member-test build-tree-from-word optimize-tree drop ] unit-test
\ member-test def>> must-infer
[ ] [ \ member-test build-tree optimize-tree drop ] unit-test
[ t ] [ \ + member-test ] unit-test
[ f ] [ \ append member-test ] unit-test
@ -325,7 +325,7 @@ PREDICATE: list < improper-list
dup "a" get { array-capacity } declare >=
[ dup "b" get { array-capacity } declare >= [ 3 ] [ 4 ] if ] [ 5 ] if ;
\ interval-inference-bug must-infer
[ t ] [ \ interval-inference-bug optimized>> ] unit-test
[ ] [ 1 "a" set 2 "b" set ] unit-test
[ 2 3 ] [ 2 interval-inference-bug ] unit-test

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

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 ;

View File

@ -0,0 +1,107 @@
IN: compiler.tests.redefine0
USING: tools.test eval compiler compiler.errors compiler.units definitions kernel math
namespaces macros assocs ;
! Test ripple-up behavior
: test-1 ( -- a ) 3 ;
: test-2 ( -- ) test-1 ;
[ test-2 ] [ not-compiled? ] must-fail-with
[ ] [ "IN: compiler.tests.redefine0 : test-1 ( -- ) ;" eval( -- ) ] unit-test
{ 0 0 } [ test-1 ] must-infer-as
[ ] [ test-2 ] unit-test
[ ] [
[
\ test-1 forget
\ test-2 forget
] with-compilation-unit
] unit-test
: test-3 ( a -- ) drop ;
: test-4 ( -- ) [ 1 2 3 ] test-3 ;
[ ] [ test-4 ] unit-test
[ ] [ "IN: compiler.tests.redefine0 USE: kernel : test-3 ( a -- ) call ; inline" eval( -- ) ] unit-test
[ test-4 ] [ not-compiled? ] must-fail-with
[ ] [
[
\ test-3 forget
\ test-4 forget
] with-compilation-unit
] unit-test
: test-5 ( a -- quot ) ;
: test-6 ( a -- b ) test-5 ;
[ 31337 ] [ 31337 test-6 ] unit-test
[ ] [ "IN: compiler.tests.redefine0 USING: macros kernel ; MACRO: test-5 ( a -- quot ) drop [ ] ;" eval( -- ) ] unit-test
[ 31337 test-6 ] [ not-compiled? ] must-fail-with
[ ] [
[
\ test-5 forget
\ test-6 forget
] with-compilation-unit
] unit-test
GENERIC: test-7 ( a -- b )
M: integer test-7 + ;
: test-8 ( a -- b ) 255 bitand test-7 ;
[ 1 test-7 ] [ not-compiled? ] must-fail-with
[ 1 test-8 ] [ not-compiled? ] must-fail-with
[ ] [ "IN: compiler.tests.redefine0 USING: macros math kernel ; GENERIC: test-7 ( x y -- z ) : test-8 ( a b -- c ) 255 bitand test-7 ;" eval( -- ) ] unit-test
[ 4 ] [ 1 3 test-7 ] unit-test
[ 4 ] [ 1 259 test-8 ] unit-test
[ ] [
[
\ test-7 forget
\ test-8 forget
] with-compilation-unit
] unit-test
! Indirect dependency on an unoptimized word
: test-9 ( -- ) ;
<< SYMBOL: quot
[ test-9 ] quot set-global >>
MACRO: test-10 ( -- quot ) quot get ;
: test-11 ( -- ) test-10 ;
[ ] [ test-11 ] unit-test
[ ] [ "IN: compiler.tests.redefine0 : test-9 ( -- ) 1 ;" eval( -- ) ] unit-test
! test-11 should get recompiled now
[ test-11 ] [ not-compiled? ] must-fail-with
[ ] [ "IN: compiler.tests.redefine0 : test-9 ( -- a ) 1 ;" eval( -- ) ] unit-test
[ ] [ "IN: compiler.tests.redefine0 : test-9 ( -- ) ;" eval( -- ) ] unit-test
[ ] [ test-11 ] unit-test
quot global delete-at
[ ] [
[
\ test-9 forget
\ test-10 forget
\ test-11 forget
\ quot forget
] with-compilation-unit
] unit-test

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
@ -36,41 +36,3 @@ M: integer method-redefine-generic-2 3 + ;
fixnum string [ \ method-redefine-generic-2 method forget ] bi@
] with-compilation-unit
] unit-test
! Test ripple-up behavior
: hey ( -- ) ;
: there ( -- ) hey ;
[ t ] [ \ hey optimized>> ] unit-test
[ t ] [ \ there optimized>> ] unit-test
[ ] [ "IN: compiler.tests : hey ( -- ) 3 ;" eval( -- ) ] unit-test
[ f ] [ \ hey optimized>> ] unit-test
[ f ] [ \ there optimized>> ] unit-test
[ ] [ "IN: compiler.tests : hey ( -- ) ;" eval( -- ) ] unit-test
[ t ] [ \ there optimized>> ] unit-test
: good ( -- ) ;
: bad ( -- ) good ;
: ugly ( -- ) bad ;
[ t ] [ \ good optimized>> ] unit-test
[ t ] [ \ bad optimized>> ] unit-test
[ t ] [ \ ugly optimized>> ] unit-test
[ f ] [ \ good compiled-usage assoc-empty? ] unit-test
[ ] [ "IN: compiler.tests : good ( -- ) 3 ;" eval( -- ) ] unit-test
[ f ] [ \ good optimized>> ] unit-test
[ f ] [ \ bad optimized>> ] unit-test
[ f ] [ \ ugly optimized>> ] unit-test
[ t ] [ \ good compiled-usage assoc-empty? ] unit-test
[ ] [ "IN: compiler.tests : good ( -- ) ;" eval( -- ) ] unit-test
[ t ] [ \ good optimized>> ] unit-test
[ t ] [ \ bad optimized>> ] unit-test
[ t ] [ \ ugly optimized>> ] unit-test
[ f ] [ \ good compiled-usage assoc-empty? ] unit-test

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.

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.

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

View File

@ -7,4 +7,5 @@ quotations stack-checker ;
[ ] [ "IN: compiler.tests.redefine16 GENERIC# blah 2 ( foo bar baz -- )" eval( -- ) ] unit-test
[ ] [ "IN: compiler.tests.redefine16 USING: strings math arrays prettyprint ; M: string blah 1 + 3array . ;" eval( -- ) ] unit-test
[ ] [ "IN: compiler.tests.redefine16 GENERIC# blah 2 ( foo bar baz -- x )" eval( -- ) ] unit-test
[ "blah" "compiler.tests.redefine16" lookup 1quotation infer ] must-fail
[ ] [ [ "blah" "compiler.tests.redefine16" lookup forget ] with-compilation-unit ] unit-test

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

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

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

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.

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.

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.

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.

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.

View File

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

View File

@ -1,9 +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
\ (compile) must-infer
IN: compiler.tests.simple
! Test empty word
[ ] [ [ ] compile-call ] unit-test

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 )
{

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 ;

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 ;

View File

@ -3,12 +3,11 @@ compiler.tree stack-checker.errors ;
IN: compiler.tree.builder
HELP: build-tree
{ $values { "quot" quotation } { "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-tree-with
{ $values { "in-stack" "a sequence of values" } { "quot" quotation } { "nodes" "a sequence of nodes" } { "out-stack" "a sequence of values" } }
{ $description "Attempts to construct tree SSA IR from a quotation, starting with an initial data stack of values, and outputting stack resulting at the end." }
{ $errors "Throws an " { $link inference-error } " if stack effect inference fails." } ;
HELP: build-sub-tree
{ $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." } ;

View File

@ -1,11 +1,27 @@
IN: compiler.tree.builder.tests
USING: compiler.tree.builder tools.test sequences kernel
compiler.tree ;
\ build-tree must-infer
\ build-tree-with must-infer
\ build-tree-from-word must-infer
compiler.tree stack-checker stack-checker.errors ;
: inline-recursive ( -- ) inline-recursive ; inline recursive
[ t ] [ \ inline-recursive build-tree-from-word [ #recursive? ] any? ] unit-test
[ t ] [ \ inline-recursive build-tree [ #recursive? ] any? ] unit-test
: bad-recursion-1 ( a -- b )
dup [ drop bad-recursion-1 5 ] [ ] if ;
[ \ bad-recursion-1 build-tree ] [ inference-error? ] must-fail-with
FORGET: bad-recursion-1
: bad-recursion-2 ( obj -- obj )
dup [ dup first swap second bad-recursion-2 ] [ ] if ;
[ \ bad-recursion-2 build-tree ] [ inference-error? ] must-fail-with
FORGET: bad-recursion-2
: bad-bin ( a b -- ) 5 [ 5 bad-bin bad-bin 5 ] [ 2drop ] if ;
[ \ bad-bin build-tree ] [ inference-error? ] must-fail-with
FORGET: bad-bin

View File

@ -1,7 +1,8 @@
! Copyright (C) 2008 Slava Pestov.
! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: fry accessors quotations kernel sequences namespaces
assocs words arrays vectors hints combinators compiler.tree
USING: fry locals accessors quotations kernel sequences namespaces
assocs words arrays vectors hints combinators continuations
effects compiler.tree
stack-checker
stack-checker.state
stack-checker.errors
@ -10,54 +11,59 @@ stack-checker.backend
stack-checker.recursive-state ;
IN: compiler.tree.builder
: with-tree-builder ( quot -- nodes )
'[ V{ } clone stack-visitor set @ ]
with-infer nip ; inline
<PRIVATE
: build-tree ( quot -- nodes )
#! Not safe to call from inference transforms.
[ f initial-recursive-state infer-quot ] with-tree-builder ;
GENERIC: (build-tree) ( quot -- )
: build-tree-with ( in-stack quot -- nodes out-stack )
#! Not safe to call from inference transforms.
[
[ >vector \ meta-d set ]
[ f initial-recursive-state infer-quot ] bi*
] with-tree-builder
unclip-last in-d>> ;
: build-sub-tree ( #call quot -- nodes )
[ [ out-d>> ] [ in-d>> ] bi ] dip build-tree-with
over ends-with-terminate?
[ drop swap [ f swap #push ] map append ]
[ rot #copy suffix ]
if ;
: (build-tree-from-word) ( word -- )
dup initial-recursive-state recursive-state set
dup [ "inline" word-prop ] [ "recursive" word-prop ] bi and
[ 1quotation ] [ specialized-def ] if
infer-quot-here ;
: check-cannot-infer ( word -- )
dup "cannot-infer" word-prop [ cannot-infer-effect ] [ drop ] if ;
TUPLE: do-not-compile word ;
M: callable (build-tree) infer-quot-here ;
: check-no-compile ( word -- )
dup "no-compile" word-prop [ do-not-compile inference-warning ] [ drop ] if ;
dup "no-compile" word-prop [ do-not-compile ] [ drop ] if ;
: build-tree-from-word ( word -- nodes )
: check-effect ( word effect -- )
swap required-stack-effect 2dup effect<=
[ 2drop ] [ effect-error ] if ;
: inline-recursive? ( word -- ? )
[ "inline" word-prop ] [ "recursive" word-prop ] bi and ;
: word-body ( word -- quot )
dup inline-recursive? [ 1quotation ] [ specialized-def ] if ;
M: word (build-tree)
[ 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) ]
bi*
] with-infer nip ;
PRIVATE>
: build-tree ( word/quot -- nodes )
[ f ] dip build-tree-with ;
:: build-sub-tree ( #call word/quot -- nodes/f )
#! We don't want methods on mixins to have a declaration for that mixin.
#! 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.
f specialize-method? [
[
#call in-d>> word/quot build-tree-with unclip-last in-d>> :> in-d
{
[ check-cannot-infer ]
[ check-no-compile ]
[ (build-tree-from-word) ]
[ finish-word ]
} cleave
] maybe-cannot-infer
] with-tree-builder ;
{ [ 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? ;

View File

@ -1,4 +1,4 @@
IN: compiler.tree.checker.tests
USING: compiler.tree.checker tools.test ;
\ check-nodes must-infer

View File

@ -9,8 +9,6 @@ accessors combinators io prettyprint words sequences.deep
sequences.private arrays classes kernel.private ;
IN: compiler.tree.dead-code.tests
\ remove-dead-code must-infer
: count-live-values ( quot -- n )
build-tree
analyze-recursive

View File

@ -1,8 +1,5 @@
IN: compiler.tree.debugger.tests
USING: compiler.tree.debugger tools.test sorting sequences io math.order ;
\ optimized. must-infer
\ optimizer-report. must-infer
[ [ <=> ] sort ] optimized.
[ <reversed> [ print ] each ] optimizer-report.

View File

@ -142,8 +142,7 @@ SYMBOL: node-count
: make-report ( word/quot -- assoc )
[
dup word? [ build-tree-from-word ] [ build-tree ] if
optimize-tree
build-tree optimize-tree
H{ } clone words-called set
H{ } clone generics-called set

View File

@ -7,8 +7,6 @@ compiler.tree.def-use arrays kernel.private sorting math.order
binary-search compiler.tree.checker ;
IN: compiler.tree.def-use.tests
\ compute-def-use must-infer
[ t ] [
[ 1 2 3 ] build-tree compute-def-use drop
def-use get {

View File

@ -11,8 +11,6 @@ compiler.tree.propagation.info stack-checker.errors
compiler.tree.checker
kernel.private ;
\ escape-analysis must-infer
GENERIC: count-unboxed-allocations* ( m node -- n )
: (count-unboxed-allocations) ( m node -- n )

View File

@ -6,9 +6,6 @@ compiler.tree.normalization.renaming
compiler.tree compiler.tree.checker
sequences accessors tools.test kernel math ;
\ count-introductions must-infer
\ normalize must-infer
[ 3 ] [ [ 3drop 1 2 3 ] build-tree count-introductions ] unit-test
[ 4 ] [ [ 3drop 1 2 3 3drop drop ] build-tree count-introductions ] unit-test

View File

@ -1,4 +1,4 @@
USING: compiler.tree.optimizer tools.test ;
IN: compiler.tree.optimizer.tests
\ optimize-tree must-infer

View File

@ -4,6 +4,7 @@ USING: accessors kernel arrays sequences math math.order
math.partial-dispatch generic generic.standard generic.math
classes.algebra classes.union sets quotations assocs combinators
words namespaces continuations classes fry combinators.smart hints
locals
compiler.tree
compiler.tree.builder
compiler.tree.recursive
@ -27,24 +28,34 @@ SYMBOL: node-count
SYMBOL: inlining-count
! Splicing nodes
GENERIC: splicing-nodes ( #call word/quot/f -- nodes )
M: word splicing-nodes
: splicing-call ( #call word -- nodes )
[ [ in-d>> ] [ out-d>> ] bi ] dip #call 1array ;
M: callable splicing-nodes
build-sub-tree analyze-recursive normalize ;
: splicing-body ( #call quot/word -- nodes/f )
build-sub-tree dup [ analyze-recursive normalize ] when ;
! Dispatch elimination
: undo-inlining ( #call -- ? )
f >>method f >>body f >>class drop f ;
: propagate-body ( #call -- ? )
body>> (propagate) t ;
GENERIC: splicing-nodes ( #call word/quot -- nodes/f )
M: word splicing-nodes splicing-call ;
M: callable splicing-nodes splicing-body ;
: eliminate-dispatch ( #call class/f word/quot/f -- ? )
dup [
[ >>class ] dip
over method>> over = [ drop ] [
2dup splicing-nodes
[ >>method ] [ >>body ] bi*
over method>> over = [ drop propagate-body ] [
2dup splicing-nodes dup [
[ >>method ] [ >>body ] bi* propagate-body
] [ 2drop undo-inlining ] if
] if
body>> (propagate) t
] [ 2drop f >>method f >>body f >>class drop f ] if ;
] [ 2drop undo-inlining ] if ;
: inlining-standard-method ( #call word -- class/f method/f )
dup "methods" word-prop assoc-empty? [ 2drop f f ] [
@ -159,19 +170,17 @@ SYMBOL: history
[ history [ swap suffix ] change ]
bi ;
: inline-word-def ( #call word quot -- ? )
over history get memq? [ 3drop f ] [
[
[ remember-inlining ] dip
[ drop ] [ splicing-nodes ] 2bi
[ >>body drop ] [ count-nodes ] [ (propagate) ] tri
] with-scope node-count +@
t
:: inline-word ( #call word -- ? )
word history get memq? [ f ] [
#call word splicing-body [
[
word remember-inlining
[ ] [ count-nodes ] [ (propagate) ] tri
] with-scope
[ #call (>>body) ] [ node-count +@ ] bi* t
] [ f ] if*
] if ;
: inline-word ( #call word -- ? )
dup def>> inline-word-def ;
: inline-method-body ( #call word -- ? )
2dup should-inline? [ inline-word ] [ 2drop f ] if ;
@ -191,10 +200,6 @@ SYMBOL: history
call( #call -- word/quot/f )
object swap eliminate-dispatch ;
: inline-instance-check ( #call word -- ? )
over in-d>> second value-info literal>> dup class?
[ "predicate" word-prop '[ drop @ ] inline-word-def ] [ 3drop f ] if ;
: (do-inlining) ( #call word -- ? )
#! If the generic was defined in an outer compilation unit,
#! then it doesn't have a definition yet; the definition
@ -206,7 +211,6 @@ SYMBOL: history
#! discouraged, but it should still work.)
{
{ [ dup never-inline-word? ] [ 2drop f ] }
{ [ dup \ instance? eq? ] [ inline-instance-check ] }
{ [ dup always-inline-word? ] [ inline-word ] }
{ [ dup standard-generic? ] [ inline-standard-method ] }
{ [ dup math-generic? ] [ inline-math-method ] }

View File

@ -341,6 +341,11 @@ generic-comparison-ops [
] [ 2drop object-info ] if
] "outputs" set-word-prop
\ instance? [
in-d>> second value-info literal>> dup class?
[ "predicate" word-prop '[ drop @ ] ] [ drop f ] if
] "custom-inlining" set-word-prop
\ equal? [
! If first input has a known type and second input is an
! object, we convert this to [ swap equal? ].

View File

@ -12,8 +12,6 @@ specialized-arrays.double system sorting math.libm
math.intervals ;
IN: compiler.tree.propagation.tests
\ propagate must-infer
[ V{ } ] [ [ ] final-classes ] unit-test
[ V{ fixnum } ] [ [ 1 ] final-classes ] unit-test

View File

@ -10,8 +10,6 @@ compiler.tree.combinators ;
[ { f t t t } ] [ t { f f t t } (tail-calls) ] unit-test
[ { f f f t } ] [ t { f f t f } (tail-calls) ] unit-test
\ analyze-recursive must-infer
: label-is-loop? ( nodes word -- ? )
[
{
@ -21,8 +19,6 @@ compiler.tree.combinators ;
} 2&&
] curry contains-node? ;
\ label-is-loop? must-infer
: label-is-not-loop? ( nodes word -- ? )
[
{
@ -32,8 +28,6 @@ compiler.tree.combinators ;
} 2&&
] curry contains-node? ;
\ label-is-not-loop? must-infer
: loop-test-1 ( a -- )
dup [ 1+ loop-test-1 ] [ drop ] if ; inline recursive

View File

@ -8,8 +8,6 @@ compiler.tree.def-use kernel accessors sequences math
math.private sorting math.order binary-search sequences.private
slots.private ;
\ unbox-tuples must-infer
: test-unboxing ( quot -- )
build-tree
analyze-recursive

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

View File

@ -2,8 +2,6 @@ IN: db.pools.tests
USING: db.pools tools.test continuations io.files io.files.temp
io.directories namespaces accessors kernel math destructors ;
\ <db-pool> must-infer
{ 1 0 } [ [ ] with-db-pool ] must-infer-as
{ 1 0 } [ [ ] with-pooled-db ] must-infer-as

View File

@ -592,17 +592,6 @@ string-encoding-test "STRING_ENCODING_TEST" {
[ test-string-encoding ] test-sqlite
[ test-string-encoding ] test-postgresql
! Don't comment these out. These words must infer
\ bind-tuple must-infer
\ insert-tuple must-infer
\ update-tuple must-infer
\ delete-tuples must-infer
\ select-tuple must-infer
\ define-persistent must-infer
\ ensure-table must-infer
\ create-table must-infer
\ drop-table must-infer
: test-queries ( -- )
[ ] [ exam ensure-table ] unit-test
[ ] [ 1000 [ random-exam insert-tuple ] times ] unit-test

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

View File

@ -126,14 +126,14 @@ HOOK: signal-error. os ( obj -- )
: primitive-error. ( error -- )
"Unimplemented primitive" print drop ;
PREDICATE: kernel-error < array
PREDICATE: vm-error < array
{
{ [ dup empty? ] [ drop f ] }
{ [ dup first "kernel-error" = not ] [ drop f ] }
[ second 0 15 between? ]
} cond ;
: kernel-errors ( error -- n errors )
: vm-errors ( error -- n errors )
second {
{ 0 [ expired-error. ] }
{ 1 [ io-error. ] }
@ -153,9 +153,11 @@ PREDICATE: kernel-error < array
{ 15 [ memory-error. ] }
} ; inline
M: kernel-error error. dup kernel-errors case ;
M: vm-error summary drop "VM error" ;
M: kernel-error error-help kernel-errors at first ;
M: vm-error error. dup vm-errors case ;
M: vm-error error-help vm-errors at first ;
M: no-method summary
drop "No suitable method" ;

View File

@ -1 +1 @@
Doug Coleman
Slava Pestov

View File

@ -0,0 +1 @@
unportable

View File

@ -43,8 +43,6 @@ WHERE
>>
\ sqsq must-infer
[ 16 ] [ 2 sqsq ] unit-test
<<
@ -65,6 +63,24 @@ WHERE
[ 4 ] [ 1 3 blah ] unit-test
<<
FUNCTOR: symbol-test ( W -- )
W DEFINES ${W}
WHERE
SYMBOL: W
;FUNCTOR
"blorgh" symbol-test
>>
[ blorgh ] [ blorgh ] unit-test
GENERIC: some-generic ( a -- b )
! Does replacing an ordinary word with a functor-generated one work?
@ -74,6 +90,7 @@ GENERIC: some-generic ( a -- b )
TUPLE: some-tuple ;
: some-word ( -- ) ;
M: some-tuple some-generic ;
SYMBOL: some-symbol
"> <string-reader> "functors-test" parse-stream
] unit-test
@ -84,6 +101,7 @@ GENERIC: some-generic ( a -- b )
"some-tuple" "functors.tests" lookup
"some-generic" "functors.tests" lookup method >boolean
] unit-test ;
[ t ] [ "some-symbol" "functors.tests" lookup >boolean ] unit-test
test-redefinition
@ -92,12 +110,14 @@ FUNCTOR: redefine-test ( W -- )
W-word DEFINES ${W}-word
W-tuple DEFINES-CLASS ${W}-tuple
W-generic IS ${W}-generic
W-symbol DEFINES ${W}-symbol
WHERE
TUPLE: W-tuple ;
: W-word ( -- ) ;
M: W-tuple W-generic ;
SYMBOL: W-symbol
;FUNCTOR
@ -107,4 +127,5 @@ M: W-tuple W-generic ;
"> <string-reader> "functors-test" parse-stream
] unit-test
test-redefinition
test-redefinition

View File

@ -5,7 +5,7 @@ words interpolate namespaces sequences io.streams.string fry
classes.mixin effects lexer parser classes.tuple.parser
effects.parser locals.types locals.parser generic.parser
locals.rewrite.closures vocabs.parser classes.parser
arrays accessors ;
arrays accessors words.symbol ;
IN: functors
! This is a hack
@ -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 ;
@ -80,6 +90,10 @@ SYNTAX: `:
parse-declared*
\ define-declared* parsed ;
SYNTAX: `SYMBOL:
scan-param parsed
\ define-symbol parsed ;
SYNTAX: `SYNTAX:
scan-param parsed
parse-definition*
@ -92,6 +106,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 ;
@ -116,7 +132,9 @@ DEFER: ;FUNCTOR delimiter
{ ":" POSTPONE: `: }
{ "INSTANCE:" POSTPONE: `INSTANCE: }
{ "SYNTAX:" POSTPONE: `SYNTAX: }
{ "SYMBOL:" POSTPONE: `SYMBOL: }
{ "inline" POSTPONE: `inline }
{ "call-next-method" POSTPONE: `call-next-method }
} ;
: push-functor-words ( -- )

View File

@ -1,6 +1,3 @@
USING: furnace.auth tools.test ;
IN: furnace.auth.tests
\ logged-in-username must-infer
\ <protected> must-infer
\ new-realm must-infer

View File

@ -1,4 +1,4 @@
IN: furnace.auth.features.edit-profile.tests
USING: tools.test furnace.auth.features.edit-profile ;
\ allow-edit-profile must-infer

View File

@ -1,4 +1,4 @@
IN: furnace.auth.features.recover-password
USING: tools.test furnace.auth.features.recover-password ;
\ allow-password-recovery must-infer

View File

@ -1,4 +1,4 @@
IN: furnace.auth.features.registration.tests
USING: tools.test furnace.auth.features.registration ;
\ allow-registration must-infer

View File

@ -1,4 +1,4 @@
IN: furnace.auth.login.tests
USING: tools.test furnace.auth.login ;
\ <login-realm> must-infer

View File

@ -1,4 +1,4 @@
IN: furnace.db.tests
USING: tools.test furnace.db ;
\ <db-persistence> must-infer

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

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" }

View File

@ -17,8 +17,3 @@ HELP: xref-article
{ $values { "topic" "an article name or a word" } }
{ $description "Sets the " { $link article-parent } " of each child of this article." }
$low-level-note ;
HELP: unxref-article
{ $values { "topic" "an article name or a word" } }
{ $description "Clears the " { $link article-parent } " of each child of this article." }
$low-level-note ;

View File

@ -1,4 +1,4 @@
! Copyright (C) 2005, 2008 Slava Pestov.
! Copyright (C) 2005, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays definitions generic assocs math fry
io kernel namespaces prettyprint prettyprint.sections
@ -12,9 +12,6 @@ IN: help.crossref
: article-children ( topic -- seq )
{ $subsection } article-links ;
M: link uses
{ $subsection $link $see-also } article-links ;
: help-path ( topic -- seq )
[ article-parent ] follow rest ;
@ -22,10 +19,7 @@ M: link uses
article-children [ set-article-parent ] with each ;
: xref-article ( topic -- )
dup >link xref dup set-article-parents ;
: unxref-article ( topic -- )
>link unxref ;
dup set-article-parents ;
: prev/next ( obj seq n -- obj' )
[ [ index dup ] keep ] dip swap

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" }

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 ;
@ -156,10 +156,7 @@ help-hook [ [ print-topic ] ] initialize
error get (:help) ;
: remove-article ( name -- )
dup articles get key? [
dup unxref-article
dup articles get delete-at
] when drop ;
articles get delete-at ;
: add-article ( article name -- )
[ remove-article ] keep
@ -167,7 +164,6 @@ help-hook [ [ print-topic ] ] initialize
xref-article ;
: remove-word-help ( word -- )
dup word-help [ dup unxref-article ] when
f "help" set-word-prop ;
: set-word-help ( content word -- )

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
@ -26,5 +26,3 @@ TUPLE: blahblah quux ;
[ "a string, a fixnum, or an integer" ]
[ [ { $or string fixnum integer } print-element ] with-string-writer ] unit-test
\ print-element must-infer
\ print-topic must-infer

View File

@ -138,7 +138,7 @@ ALIAS: $slot $snippet
! Images
: $image ( element -- )
[ [ "" ] dip first image associate format ] ($span) ;
[ first write-image ] ($span) ;
: <$image> ( path -- element )
1array \ $image prefix ;
@ -251,7 +251,7 @@ M: word ($instance)
dup name>> a/an write bl ($link) ;
M: string ($instance)
dup a/an write bl $snippet ;
write ;
M: f ($instance)
drop { f } $link ;

View File

@ -3,11 +3,6 @@ help.markup help.syntax kernel sequences tools.test words parser
namespaces assocs source-files eval ;
IN: help.topics.tests
\ article-name must-infer
\ article-title must-infer
\ article-content must-infer
\ article-parent must-infer
! Test help cross-referencing
[ ] [ "Test B" { "Hello world." } <article> { "test" "b" } add-article ] unit-test

View File

@ -2,9 +2,9 @@
! See http://factorcode.org/license.txt for BSD license.
USING: parser words definitions kernel sequences assocs arrays
kernel.private fry combinators accessors vectors strings sbufs
byte-arrays byte-vectors io.binary io.streams.string splitting
math math.parser generic generic.standard generic.standard.engines classes
hashtables ;
byte-arrays byte-vectors io.binary io.streams.string splitting math
math.parser generic generic.standard generic.standard.engines classes
hashtables namespaces ;
IN: hints
GENERIC: specializer-predicate ( spec -- quot )
@ -37,13 +37,18 @@ M: object specializer-declaration class ;
: specialize-quot ( quot specializer -- quot' )
specializer-cases alist>quot ;
: method-declaration ( method -- quot )
[ "method-generic" word-prop dispatch# object <array> ]
[ "method-class" word-prop ]
bi prefix ;
! compiler.tree.propagation.inlining sets this to f
SYMBOL: specialize-method?
t specialize-method? set-global
: specialize-method ( quot method -- quot' )
[ method-declaration '[ _ declare ] prepend ]
[
specialize-method? get [
[ "method-class" word-prop ] [ "method-generic" word-prop ] bi
method-declaration prepend
] [ drop ] if
]
[ "method-generic" word-prop "specializer" word-prop ] bi
[ specialize-quot ] when* ;
@ -65,7 +70,7 @@ M: object specializer-declaration class ;
SYNTAX: HINTS:
scan-object
[ redefined ]
[ changed-definition ]
[ parse-definition "specializer" set-word-prop ] bi ;
! Default specializers

View File

@ -4,8 +4,6 @@ io.streams.null accessors inspector html.streams
html.components html.forms namespaces
xml.writer ;
\ render must-infer
[ ] [ begin-form ] unit-test
[ ] [ 3 "hi" set-value ] unit-test

View File

@ -1,8 +1,6 @@
USING: http.client http.client.private http tools.test
namespaces urls ;
\ download must-infer
[ "localhost" f ] [ "localhost" parse-host ] unit-test
[ "localhost" 8888 ] [ "localhost:8888" parse-host ] unit-test

View File

@ -3,8 +3,6 @@ tools.test kernel namespaces accessors io http math sequences
assocs arrays classes words urls ;
IN: http.server.dispatchers.tests
\ find-responder must-infer
TUPLE: mock-responder path ;
C: <mock-responder> mock-responder

View File

@ -2,8 +2,6 @@ IN: http.server.redirection.tests
USING: http http.server.redirection urls accessors
namespaces tools.test present kernel ;
\ relative-to-request must-infer
[
<request>
<url>

View File

@ -4,8 +4,6 @@ IN: http.server.tests
[ t ] [ [ \ + first ] [ <500> ] recover response? ] unit-test
\ make-http-error must-infer
[ "text/plain; charset=UTF-8" ] [
<response>
"text/plain" >>content-type

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

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 ;

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