Merge branch 'master' of git://factorcode.org/git/factor
Aaron Schaefer
commit
b1454784e4
11
Makefile
11
Makefile
|
|
@ -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:
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -108,7 +108,7 @@ nl
|
|||
|
||||
"." write flush
|
||||
|
||||
{ (compile) } compile-unoptimized
|
||||
{ compile-word } compile-unoptimized
|
||||
|
||||
"." write flush
|
||||
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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"
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
||||
|
|
|
|||
|
|
@ -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?
|
||||
|
||||
|
|
|
|||
|
|
@ -1,4 +1,4 @@
|
|||
USING: compiler.cfg.linear-scan.assignment tools.test ;
|
||||
IN: compiler.cfg.linear-scan.assignment.tests
|
||||
|
||||
\ assign-registers must-infer
|
||||
|
||||
|
|
|
|||
|
|
@ -1,4 +1,4 @@
|
|||
IN: compiler.cfg.linearization.tests
|
||||
USING: compiler.cfg.linearization tools.test ;
|
||||
|
||||
\ build-mr must-infer
|
||||
|
||||
|
|
|
|||
|
|
@ -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>>
|
||||
|
|
|
|||
|
|
@ -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." } ;
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
|
@ -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,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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
||||
|
|
|
|||
|
|
@ -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.
|
||||
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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.
|
||||
|
||||
|
|
|
|||
|
|
@ -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.
|
||||
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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.
|
||||
|
|
|
|||
|
|
@ -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.
|
||||
|
||||
|
|
|
|||
|
|
@ -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.
|
||||
|
||||
|
|
|
|||
|
|
@ -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.
|
||||
|
||||
|
|
|
|||
|
|
@ -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.
|
||||
|
||||
|
|
|
|||
|
|
@ -1,4 +1,4 @@
|
|||
IN: compiler.tests
|
||||
IN: compiler.tests.reload
|
||||
USE: vocabs.loader
|
||||
|
||||
! "parser" reload
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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 )
|
||||
{
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
|
|
|||
|
|
@ -1,4 +1,4 @@
|
|||
IN: compiler.tests
|
||||
IN: compiler.tests.tuples
|
||||
USING: kernel tools.test compiler.units compiler ;
|
||||
|
||||
TUPLE: color red green blue ;
|
||||
|
|
|
|||
|
|
@ -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." } ;
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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? ;
|
||||
|
|
|
|||
|
|
@ -1,4 +1,4 @@
|
|||
IN: compiler.tree.checker.tests
|
||||
USING: compiler.tree.checker tools.test ;
|
||||
|
||||
\ check-nodes must-infer
|
||||
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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.
|
||||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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 {
|
||||
|
|
|
|||
|
|
@ -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 )
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -1,4 +1,4 @@
|
|||
USING: compiler.tree.optimizer tools.test ;
|
||||
IN: compiler.tree.optimizer.tests
|
||||
|
||||
\ optimize-tree must-infer
|
||||
|
||||
|
|
|
|||
|
|
@ -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 ] }
|
||||
|
|
|
|||
|
|
@ -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? ].
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
@ -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" ;
|
||||
|
|
|
|||
|
|
@ -1 +1 @@
|
|||
Doug Coleman
|
||||
Slava Pestov
|
||||
|
|
|
|||
|
|
@ -0,0 +1 @@
|
|||
unportable
|
||||
|
|
@ -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
|
||||
|
||||
|
|
|
|||
|
|
@ -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 ( -- )
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -1,4 +1,4 @@
|
|||
IN: furnace.auth.features.edit-profile.tests
|
||||
USING: tools.test furnace.auth.features.edit-profile ;
|
||||
|
||||
\ allow-edit-profile must-infer
|
||||
|
||||
|
|
|
|||
|
|
@ -1,4 +1,4 @@
|
|||
IN: furnace.auth.features.recover-password
|
||||
USING: tools.test furnace.auth.features.recover-password ;
|
||||
|
||||
\ allow-password-recovery must-infer
|
||||
|
||||
|
|
|
|||
|
|
@ -1,4 +1,4 @@
|
|||
IN: furnace.auth.features.registration.tests
|
||||
USING: tools.test furnace.auth.features.registration ;
|
||||
|
||||
\ allow-registration must-infer
|
||||
|
||||
|
|
|
|||
|
|
@ -1,4 +1,4 @@
|
|||
IN: furnace.auth.login.tests
|
||||
USING: tools.test furnace.auth.login ;
|
||||
|
||||
\ <login-realm> must-infer
|
||||
|
||||
|
|
|
|||
|
|
@ -1,4 +1,4 @@
|
|||
IN: furnace.db.tests
|
||||
USING: tools.test furnace.db ;
|
||||
|
||||
\ <db-persistence> must-infer
|
||||
|
||||
|
|
|
|||
|
|
@ -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 -- )
|
||||
|
|
|
|||
|
|
@ -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,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 ;
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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" }
|
||||
|
|
|
|||
|
|
@ -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 -- )
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
@ -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 ;
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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>
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
@ -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
Loading…
Reference in New Issue