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

Merge branch 'master' into irc

db4
Bruno Deferrari 2009-04-26 20:04:32 -03:00
parent 17cbf3dded 06012cf291
commit 3c845d6ba8
697 changed files with 7543 additions and 4342 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
.gitignore vendored
View File

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

7
Makefile
View File

@ -7,7 +7,6 @@ CONSOLE_EXECUTABLE = factor-console
TEST_LIBRARY = factor-ffi-test
VERSION = 0.92
IMAGE = factor.image
BUNDLE = Factor.app
LIBPATH = -L/usr/X11R6/lib
CFLAGS = -Wall
@ -151,17 +150,17 @@ macosx.app: factor
@executable_path/../Frameworks/libfactor.dylib \
Factor.app/Contents/MacOS/factor
factor: $(DLL_OBJS) $(EXE_OBJS)
$(EXECUTABLE): $(DLL_OBJS) $(EXE_OBJS)
$(LINKER) $(ENGINE) $(DLL_OBJS)
$(CC) $(LIBS) $(LIBPATH) -L. $(LINK_WITH_ENGINE) \
$(CFLAGS) -o $@$(EXE_SUFFIX)$(EXE_EXTENSION) $(EXE_OBJS)
factor-console: $(DLL_OBJS) $(EXE_OBJS)
$(CONSOLE_EXECUTABLE): $(DLL_OBJS) $(EXE_OBJS)
$(LINKER) $(ENGINE) $(DLL_OBJS)
$(CC) $(LIBS) $(LIBPATH) -L. $(LINK_WITH_ENGINE) \
$(CFLAGS) $(CFLAGS_CONSOLE) -o factor$(EXE_SUFFIX)$(CONSOLE_EXTENSION) $(EXE_OBJS)
factor-ffi-test: vm/ffi_test.o
$(TEST_LIBRARY): vm/ffi_test.o
$(CC) $(LIBPATH) $(CFLAGS) $(FFI_TEST_CFLAGS) $(SHARED_FLAG) -o libfactor-ffi-test$(SHARED_DLL_EXTENSION) $(TEST_OBJS)
clean:

4
README.txt
View File

@ -59,10 +59,10 @@ On Unix, Factor can either run a graphical user interface using X11, or
a terminal listener.
For X11 support, you need recent development libraries for libc,
Pango, X11, OpenGL and GLUT. On a Debian-derived Linux distribution
Pango, X11, and OpenGL. On a Debian-derived Linux distribution
(like Ubuntu), you can use the following line to grab everything:
sudo apt-get install libc6-dev libpango-1.0-dev libx11-dev glutg3-dev
sudo apt-get install libc6-dev libpango-1.0-dev libx11-dev
If your DISPLAY environment variable is set, the UI will start
automatically:

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

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

2
basis/alien/c-types/c-types-tests.factor
View File

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

7
basis/alien/libraries/libraries-docs.factor
View File

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

17
basis/alien/parser/parser.factor
View File

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

4
basis/alien/syntax/syntax.factor
View File

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

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

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

2
basis/binary-search/binary-search-tests.factor
View File

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

2
basis/bootstrap/compiler/compiler.factor
View File

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

2
basis/bootstrap/finish-bootstrap.factor
View File

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

3
basis/bootstrap/image/image-tests.factor
View File

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

24
basis/bootstrap/stage2.factor
View File

@ -4,7 +4,7 @@ USING: accessors init namespaces words words.symbol io
kernel.private math memory continuations kernel io.files
io.pathnames io.backend system parser vocabs sequences
vocabs.loader combinators splitting source-files strings
definitions assocs compiler.errors compiler.units math.parser
definitions assocs compiler.units math.parser
generic sets command-line ;
IN: bootstrap.stage2
@ -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,18 +68,19 @@ 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
[
load-components
load-components
millis over - core-bootstrap-time set-global
millis over - core-bootstrap-time set-global
run-bootstrap-init
] with-compiler-errors
:errors
run-bootstrap-init
f error set-global
f error-continuation set-global

1
basis/bootstrap/tools/tools.factor
View File

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

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

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

64
basis/calendar/calendar.factor
View File

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

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

@ -1,4 +1,4 @@
USING: tools.test kernel ;
USING: tools.test kernel accessors ;
IN: calendar.format.macros
[ 2 ] [ { [ 2 ] } attempt-all-quots ] unit-test
@ -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

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

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

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

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

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

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

2
basis/compiler/cfg/builder/builder-tests.factor
View File

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

2
basis/compiler/cfg/debugger/debugger.factor
View File

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

2
basis/compiler/cfg/linear-scan/assignment/assignment-tests.factor
View File

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

2
basis/compiler/cfg/linearization/linearization-tests.factor
View File

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

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

@ -5,6 +5,7 @@ kernel kernel.private layouts assocs words summary arrays
combinators classes.algebra alien alien.c-types alien.structs
alien.strings alien.arrays alien.complex sets libc alien.libraries
continuations.private fry cpu.architecture
source-files.errors
compiler.errors
compiler.alien
compiler.cfg
@ -374,47 +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 compiler-error-type
drop +linkage+ ;
: 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 compiler-error-type
drop +linkage+ ;
: 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>>

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

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

145
basis/compiler/compiler.factor
View File

@ -2,19 +2,20 @@
! See http://factorcode.org/license.txt for BSD license.
USING: accessors kernel namespaces arrays sequences io words fry
continuations vocabs assocs dlists definitions math graphs generic
combinators deques search-deques macros io 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,59 +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 -- ? )
[ [ inline? ] [ macro? ] bi or ]
[ compiler-error-type +warning+ eq? ] bi* and ;
: fail ( word error -- * )
[ 2dup ignore-error? [ 2drop ] [ swap compiler-error ] if ]
#! Ignore some errors on inline combinators, macros, and special
#! words such as 'call'.
[
{
[ macro? ]
[ inline? ]
[ "special" word-prop ]
[ "no-compile" word-prop ]
} 1||
] [
{
[ do-not-compile? ]
[ literal-expected? ]
} 1||
] bi* and ;
: 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 ]
[
dup crossref? [
dependencies get
generic-dependencies get
compiled-xref
] [ drop ] if
] tri ;
: 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
[ compiled-unxref ]
[ f swap compiled get set-at ]
[ +unoptimized+ save-compiled-status ]
tri
] 2bi
return ;
[ 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 )
[ 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 -- )
@ -91,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 ]
@ -114,14 +145,16 @@ 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 ;
\ compile-call t "no-compile" set-word-prop
SINGLETON: optimizing-compiler
M: optimizing-compiler recompile ( words -- alist )
@ -140,4 +173,4 @@ M: optimizing-compiler recompile ( words -- alist )
f compiler-impl set-global ;
: recompile-all ( -- )
forget-errors all-words compile ;
all-words compile ;

0
core/compiler/errors/authors.txt → basis/compiler/errors/authors.txt
View File

5
basis/compiler/errors/errors-docs.factor Normal file
View File

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

72
basis/compiler/errors/errors.factor Normal file
View File

@ -0,0 +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 fry
summary ;
IN: compiler.errors
SYMBOL: +compiler-error+
SYMBOL: compiler-errors
compiler-errors [ H{ } clone ] initialize
TUPLE: compiler-error < source-file-error ;
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-errors get 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-errors get values ] }
{ forget-quot [ linkage-errors get delete-at ] }
{ fatal? f }
} define-error-type
TUPLE: no-such-library name ;
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 ;

0
core/compiler/errors/summary.txt → basis/compiler/errors/summary.txt
View File

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

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

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

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

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

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

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

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

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

@ -1,6 +1,6 @@
USING: eval tools.test compiler.units vocabs multiline words
kernel classes.mixin arrays ;
IN: compiler.tests
IN: compiler.tests.folding
! Calls to generic words were not folded away.
@ -12,7 +12,7 @@ IN: compiler.tests
IN: compiler.tests.folding
GENERIC: foldable-generic ( a -- b ) foldable
M: integer foldable-generic f <array> ;
"> eval
"> eval( -- )
] unit-test
[ ] [
@ -20,7 +20,7 @@ IN: compiler.tests
USING: math arrays ;
IN: compiler.tests.folding
: fold-test ( -- x ) 10 foldable-generic ;
"> eval
"> eval( -- )
] unit-test
[ t ] [

5
basis/compiler/tests/insane.factor
View File

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

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

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

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

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

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

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

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

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

107
basis/compiler/tests/redefine0.factor Normal file
View File

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

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

@ -1,7 +1,7 @@
USING: accessors compiler compiler.units tools.test math parser
kernel sequences sequences.private classes.mixin generic
definitions arrays words assocs eval strings ;
IN: compiler.tests
IN: compiler.tests.redefine1
GENERIC: method-redefine-generic-1 ( a -- b )
@ -11,7 +11,7 @@ M: integer method-redefine-generic-1 3 + ;
[ 6 ] [ method-redefine-test-1 ] unit-test
[ ] [ "IN: compiler.tests USE: math M: fixnum method-redefine-generic-1 4 + ;" eval ] unit-test
[ ] [ "IN: compiler.tests.redefine1 USE: math M: fixnum method-redefine-generic-1 4 + ;" eval( -- ) ] unit-test
[ 7 ] [ method-redefine-test-1 ] unit-test
@ -27,7 +27,7 @@ M: integer method-redefine-generic-2 3 + ;
[ 6 ] [ method-redefine-test-2 ] unit-test
[ ] [ "IN: compiler.tests USE: kernel USE: math M: fixnum method-redefine-generic-2 4 + ; USE: strings M: string method-redefine-generic-2 drop f ;" eval ] unit-test
[ ] [ "IN: compiler.tests.redefine1 USE: kernel USE: math M: fixnum method-redefine-generic-2 4 + ; USE: strings M: string method-redefine-generic-2 drop f ;" eval( -- ) ] unit-test
[ 7 ] [ method-redefine-test-2 ] unit-test
@ -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

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

@ -1,6 +1,6 @@
USING: eval tools.test compiler.units vocabs multiline words
kernel ;
IN: compiler.tests
IN: compiler.tests.redefine10
! Mixin redefinition did not recompile all necessary words.
@ -13,7 +13,7 @@ IN: compiler.tests
MIXIN: my-mixin
INSTANCE: fixnum my-mixin
: my-inline ( a -- b ) dup my-mixin instance? [ 1 + ] when ;
"> eval
"> eval( -- )
] unit-test
[ ] [
@ -21,7 +21,7 @@ IN: compiler.tests
USE: math
IN: compiler.tests.redefine10
INSTANCE: float my-mixin
"> eval
"> eval( -- )
] unit-test
[ 2.0 ] [

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

@ -1,6 +1,6 @@
USING: eval tools.test compiler.units vocabs multiline words
kernel classes.mixin arrays ;
IN: compiler.tests
IN: compiler.tests.redefine11
! Mixin redefinition did not recompile all necessary words.
@ -17,7 +17,7 @@ IN: compiler.tests
M: my-mixin my-generic drop 0 ;
M: object my-generic drop 1 ;
: my-inline ( -- b ) { } my-generic ;
"> eval
"> eval( -- )
] unit-test
[ ] [

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

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

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

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

11
basis/compiler/tests/redefine16.factor Normal file
View File

@ -0,0 +1,11 @@
IN: compiler.tests.redefine16
USING: eval tools.test definitions words compiler.units
quotations stack-checker ;
[ ] [ [ "blah" "compiler.tests.redefine16" lookup forget ] with-compilation-unit ] unit-test
[ ] [ "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 forget ] with-compilation-unit ] unit-test

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

@ -1,11 +1,11 @@
IN: compiler.tests
IN: compiler.tests.redefine2
USING: compiler compiler.units tools.test math parser kernel
sequences sequences.private classes.mixin generic definitions
arrays words assocs eval words.symbol ;
DEFER: redefine2-test
[ ] [ "USE: sequences USE: kernel IN: compiler.tests TUPLE: redefine2-test ; M: redefine2-test nth 2drop 3 ; INSTANCE: redefine2-test sequence" eval ] unit-test
[ ] [ "USE: sequences USE: kernel IN: compiler.tests.redefine2 TUPLE: redefine2-test ; M: redefine2-test nth 2drop 3 ; INSTANCE: redefine2-test sequence" eval( -- ) ] unit-test
[ t ] [ \ redefine2-test symbol? ] unit-test

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

@ -1,4 +1,4 @@
IN: compiler.tests
IN: compiler.tests.redefine3
USING: accessors compiler compiler.units tools.test math parser
kernel sequences sequences.private classes.mixin generic
definitions arrays words assocs eval ;
@ -18,7 +18,7 @@ M: empty-mixin sheeple drop "wake up" ;
[ t ] [ object \ sheeple method \ sheeple-test "compiled-uses" word-prop key? ] unit-test
[ f ] [ empty-mixin \ sheeple method \ sheeple-test "compiled-uses" word-prop key? ] unit-test
[ ] [ "IN: compiler.tests USE: arrays INSTANCE: array empty-mixin" eval ] unit-test
[ ] [ "IN: compiler.tests.redefine3 USE: arrays INSTANCE: array empty-mixin" eval( -- ) ] unit-test
[ "wake up" ] [ sheeple-test ] unit-test
[ f ] [ object \ sheeple method \ sheeple-test "compiled-uses" word-prop key? ] unit-test

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

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

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

@ -1,6 +1,6 @@
USING: eval tools.test compiler.units vocabs multiline words
kernel ;
IN: compiler.tests
IN: compiler.tests.redefine5
! Regression: if dispatch was eliminated but method was not inlined,
! compiled usage information was not recorded.
@ -14,7 +14,7 @@ IN: compiler.tests
GENERIC: my-generic ( a -- b )
M: object my-generic [ <=> ] sort ;
: my-inline ( a -- b ) my-generic ;
"> eval
"> eval( -- )
] unit-test
[ ] [
@ -23,7 +23,7 @@ IN: compiler.tests
IN: compiler.tests.redefine5
TUPLE: my-tuple ;
M: my-tuple my-generic drop 0 ;
"> eval
"> eval( -- )
] unit-test
[ 0 ] [

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

@ -1,6 +1,6 @@
USING: eval tools.test compiler.units vocabs multiline words
kernel ;
IN: compiler.tests
IN: compiler.tests.redefine6
! Mixin redefinition did not recompile all necessary words.
@ -14,7 +14,7 @@ IN: compiler.tests
MIXIN: my-mixin
M: my-mixin my-generic drop 0 ;
: my-inline ( a -- b ) { my-mixin } declare my-generic ;
"> eval
"> eval( -- )
] unit-test
[ ] [
@ -24,7 +24,7 @@ IN: compiler.tests
TUPLE: my-tuple ;
M: my-tuple my-generic drop 1 ;
INSTANCE: my-tuple my-mixin
"> eval
"> eval( -- )
] unit-test
[ 1 ] [

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

@ -1,6 +1,6 @@
USING: eval tools.test compiler.units vocabs multiline words
kernel ;
IN: compiler.tests
IN: compiler.tests.redefine7
! Mixin redefinition did not recompile all necessary words.
@ -13,7 +13,7 @@ IN: compiler.tests
MIXIN: my-mixin
INSTANCE: fixnum my-mixin
: my-inline ( a -- b ) dup my-mixin? [ 1 + ] when ;
"> eval
"> eval( -- )
] unit-test
[ ] [
@ -21,7 +21,7 @@ IN: compiler.tests
USE: math
IN: compiler.tests.redefine7
INSTANCE: float my-mixin
"> eval
"> eval( -- )
] unit-test
[ 2.0 ] [

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

@ -1,6 +1,6 @@
USING: eval tools.test compiler.units vocabs multiline words
kernel ;
IN: compiler.tests
IN: compiler.tests.redefine8
! Mixin redefinition did not recompile all necessary words.
@ -16,7 +16,7 @@ IN: compiler.tests
! We add the bogus quotation here to hinder inlining
! since otherwise we cannot trigger this bug.
M: my-mixin my-generic 1 + [ [ <=> ] sort ] drop ;
"> eval
"> eval( -- )
] unit-test
[ ] [
@ -24,7 +24,7 @@ IN: compiler.tests
USE: math
IN: compiler.tests.redefine8
INSTANCE: float my-mixin
"> eval
"> eval( -- )
] unit-test
[ 2.0 ] [

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

@ -1,6 +1,6 @@
USING: eval tools.test compiler.units vocabs multiline words
kernel generic.math ;
IN: compiler.tests
IN: compiler.tests.redefine9
! Mixin redefinition did not recompile all necessary words.
@ -16,7 +16,7 @@ IN: compiler.tests
! We add the bogus quotation here to hinder inlining
! since otherwise we cannot trigger this bug.
M: my-mixin my-generic 1 + [ [ <=> ] sort ] drop ;
"> eval
"> eval( -- )
] unit-test
[ ] [
@ -25,7 +25,7 @@ IN: compiler.tests
IN: compiler.tests.redefine9
TUPLE: my-tuple ;
INSTANCE: my-tuple my-mixin
"> eval
"> eval( -- )
] unit-test
[

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

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

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

@ -1,9 +1,7 @@
USING: compiler compiler.units tools.test kernel kernel.private
sequences.private math.private math combinators strings alien
arrays memory vocabs parser eval ;
IN: compiler.tests
\ (compile) must-infer
IN: compiler.tests.simple
! Test empty word
[ ] [ [ ] compile-call ] unit-test
@ -237,6 +235,6 @@ M: f single-combination-test-2 single-combination-test-4 ;
10 [
[ "compiler.tests.foo" forget-vocab ] with-compilation-unit
[ t ] [
"USING: prettyprint words accessors ; IN: compiler.tests.foo : (recursive) ( -- ) (recursive) (recursive) ; inline recursive : recursive ( -- ) (recursive) ; \\ (recursive) optimized>>" eval
"USING: prettyprint words accessors ; IN: compiler.tests.foo : (recursive) ( -- ) (recursive) (recursive) ; inline recursive : recursive ( -- ) (recursive) ; \\ (recursive) optimized>>" eval( -- obj )
] unit-test
] times

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

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

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

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

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

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

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

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

28
basis/compiler/tree/builder/builder-tests.factor
View File

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

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

@ -1,7 +1,8 @@
! Copyright (C) 2008 Slava Pestov.
! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: fry accessors quotations kernel sequences namespaces
assocs words arrays vectors hints combinators compiler.tree
USING: fry locals accessors quotations kernel sequences namespaces
assocs words arrays vectors hints combinators continuations
effects compiler.tree
stack-checker
stack-checker.state
stack-checker.errors
@ -10,49 +11,58 @@ 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 ;
M: callable (build-tree) infer-quot-here ;
: check-no-compile ( word -- )
dup "no-compile" word-prop [ cannot-infer-effect ] [ 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 )
[
[
{
[ check-cannot-infer ]
[ check-no-compile ]
[ (build-tree-from-word) ]
[ finish-word ]
} cleave
] maybe-cannot-infer
] with-tree-builder ;
<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.
specialize-method? off
[
#call in-d>> word/quot build-tree-with unclip-last in-d>> :> in-d
{
{ [ dup not ] [ ] }
{ [ dup ends-with-terminate? ] [ #call out-d>> [ f swap #push ] map append ] }
[ in-d #call out-d>> #copy suffix ]
} cond
] [ dup inference-error? [ drop f ] [ rethrow ] if ] recover ;
: contains-breakpoints? ( word -- ? )
def>> [ word? ] filter [ "break?" word-prop ] any? ;

2
basis/compiler/tree/checker/checker-tests.factor
View File

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

6
basis/compiler/tree/cleanup/cleanup-tests.factor
View File

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

2
basis/compiler/tree/dead-code/dead-code-tests.factor
View File

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

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

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

3
basis/compiler/tree/debugger/debugger.factor
View File

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

2
basis/compiler/tree/def-use/def-use-tests.factor
View File

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

2
basis/compiler/tree/escape-analysis/escape-analysis-tests.factor
View File

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

19
basis/compiler/tree/normalization/normalization-tests.factor
View File

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

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

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

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

@ -18,6 +18,12 @@ IN: compiler.tree.optimizer
SYMBOL: check-optimizer?
: ?check ( nodes -- nodes' )
check-optimizer? get [
compute-def-use
dup check-nodes
] when ;
: optimize-tree ( nodes -- nodes' )
analyze-recursive
normalize
@ -30,10 +36,7 @@ SYMBOL: check-optimizer?
apply-identities
compute-def-use
remove-dead-code
check-optimizer? get [
compute-def-use
dup check-nodes
] when
?check
compute-def-use
optimize-modular-arithmetic
finalize ;

78
basis/compiler/tree/propagation/inlining/inlining.factor
View File

@ -3,7 +3,8 @@
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
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 ] [
@ -136,19 +147,21 @@ DEFER: (flat-length)
[
[ classes-known? 2 0 ? ]
[
{
[ body-length-bias ]
[ "default" word-prop -4 0 ? ]
[ "specializer" word-prop 1 0 ? ]
[ method-body? 1 0 ? ]
} cleave
[ body-length-bias ]
[ "specializer" word-prop 1 0 ? ]
[ method-body? 1 0 ? ]
tri
node-count-bias
loop-nesting get 0 or 2 *
] bi*
] sum-outputs ;
: should-inline? ( #call word -- ? )
dup "inline" word-prop [ 2drop t ] [ inlining-rank 5 >= ] if ;
{
{ [ dup contains-breakpoints? ] [ 2drop f ] }
{ [ dup "inline" word-prop ] [ 2drop t ] }
[ inlining-rank 5 >= ]
} cond ;
SYMBOL: history
@ -157,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 ;
@ -177,7 +188,9 @@ SYMBOL: history
{ curry compose } memq? ;
: never-inline-word? ( word -- ? )
[ deferred? ] [ { call execute } memq? ] bi or ;
[ deferred? ]
[ "default" word-prop ]
[ { call execute } memq? ] tri or or ;
: custom-inlining? ( word -- ? )
"custom-inlining" word-prop ;
@ -187,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
@ -202,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 ] }

5
basis/compiler/tree/propagation/known-words/known-words.factor
View File

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

6
basis/compiler/tree/propagation/propagation-tests.factor
View File

@ -12,8 +12,6 @@ specialized-arrays.double system sorting math.libm
math.intervals ;
IN: compiler.tree.propagation.tests
\ propagate must-infer
[ V{ } ] [ [ ] final-classes ] unit-test
[ V{ fixnum } ] [ [ 1 ] final-classes ] unit-test
@ -680,11 +678,11 @@ TUPLE: littledan-2 { from read-only } { to read-only } ;
: (littledan-3-test) ( x -- )
length 1+ f <array> (littledan-3-test) ; inline recursive
: littledan-3-test ( x -- )
: littledan-3-test ( -- )
0 f <array> (littledan-3-test) ; inline
[ ] [ [ littledan-3-test ] final-classes drop ] unit-test
[ V{ 0 } ] [ [ { } length ] final-literals ] unit-test
[ V{ 1 } ] [ [ { } length 1+ f <array> length ] final-literals ] unit-test
[ V{ 1 } ] [ [ { } length 1+ f <array> length ] final-literals ] unit-test

8
basis/compiler/tree/recursive/recursive-tests.factor
View File

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

2
basis/compiler/tree/tuple-unboxing/tuple-unboxing-tests.factor
View File

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

2
basis/concurrency/exchangers/exchangers-tests.factor
View File

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

2
basis/concurrency/flags/flags-tests.factor
View File

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

4
basis/concurrency/promises/promises-docs.factor
View File

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

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

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

4
basis/cpu/ppc/bootstrap.factor
View File

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

4
basis/cpu/x86/bootstrap.factor
View File

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

2
basis/db/pools/pools-tests.factor
View File

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

12
basis/db/tester/tester.factor
View File

@ -3,7 +3,7 @@
USING: concurrency.combinators db.pools db.sqlite db.tuples
db.types kernel math random threads tools.test db sequences
io prettyprint db.postgresql db.sqlite accessors io.files.temp
namespaces fry system ;
namespaces fry system math.parser ;
IN: db.tester
: postgresql-test-db ( -- postgresql-db )
@ -56,6 +56,10 @@ test-2 "TEST2" {
{ "z" "Z" { VARCHAR 256 } +not-null+ }
} define-persistent
: test-1-tuple ( -- tuple )
f 100 random 100 random 100 random [ number>string ] tri@
test-1 boa ;
: db-tester ( test-db -- )
[
[
@ -67,8 +71,7 @@ test-2 "TEST2" {
drop
10 [
dup [
f 100 random 100 random 100 random test-1 boa
insert-tuple yield
test-1-tuple insert-tuple yield
] with-db
] times
] with parallel-each
@ -84,8 +87,7 @@ test-2 "TEST2" {
<db-pool> [
10 [
10 [
f 100 random 100 random 100 random test-1 boa
insert-tuple yield
test-1-tuple insert-tuple yield
] times
] parallel-each
] with-pooled-db

11
basis/db/tuples/tuples-tests.factor
View File

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

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

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

58
basis/debugger/debugger.factor
View File

@ -8,8 +8,9 @@ classes.mixin classes.tuple continuations continuations.private
combinators generic.math classes.builtin classes compiler.units
generic.standard vocabs init kernel.private io.encodings
accessors math.order destructors source-files parser
classes.tuple.parser effects.parser lexer compiler.errors
generic.parser strings.parser vocabs.loader vocabs.parser ;
classes.tuple.parser effects.parser lexer
generic.parser strings.parser vocabs.loader vocabs.parser see
source-files.errors ;
IN: debugger
GENERIC: error. ( error -- )
@ -87,8 +88,7 @@ M: string error. print ;
: divide-by-zero-error. ( obj -- )
"Division by zero" print drop ;
: signal-error. ( obj -- )
"Operating system signal " write third . ;
HOOK: signal-error. os ( obj -- )
: array-size-error. ( obj -- )
"Invalid array size: " write dup third .
@ -126,14 +126,14 @@ M: string error. print ;
: 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" ;
@ -213,14 +215,13 @@ M: condition error-help error>> error-help ;
M: assert summary drop "Assertion failed" ;
M: assert error.
"Assertion failed" print
M: assert-sequence summary drop "Assertion failed" ;
M: assert-sequence error.
standard-table-style [
15 length-limit set
5 line-limit set
[ expect>> [ [ "Expect:" write ] with-cell pprint-cell ] with-row ]
[ got>> [ [ "Got:" write ] with-cell pprint-cell ] with-row ] bi
] tabular-output nl ;
[ "=== Expected:" print expected>> stack. ]
[ "=== Got:" print got>> stack. ] bi
] tabular-output ;
M: immutable summary drop "Sequence is immutable" ;
@ -268,20 +269,6 @@ M: duplicate-slot-names summary
M: invalid-slot-name summary
drop "Invalid slot name" ;
: file. ( file -- ) path>> <pathname> . ;
M: source-file-error error.
[ file>> file. ] [ error>> error. ] bi ;
M: source-file-error summary
error>> summary ;
M: source-file-error compute-restarts
error>> compute-restarts ;
M: source-file-error error-help
error>> error-help ;
M: not-in-a-method-error summary
drop "call-next-method can only be called in a method definition" ;
@ -309,12 +296,6 @@ M: lexer-error compute-restarts
M: lexer-error error-help
error>> error-help ;
M: object compiler-error. ( error word -- )
nl
"While compiling " write pprint ": " print
nl
print-error ;
M: bad-effect summary
drop "Bad stack effect declaration" ;
@ -326,4 +307,9 @@ M: check-mixin-class summary drop "Not a mixin class" ;
M: not-found-in-roots summary drop "Cannot resolve vocab: path" ;
M: wrong-values summary drop "Quotation called with wrong stack effect" ;
M: wrong-values summary drop "Quotation called with wrong stack effect" ;
{
{ [ os windows? ] [ "debugger.windows" require ] }
{ [ os unix? ] [ "debugger.unix" require ] }
} cond

1
basis/debugger/unix/authors.txt Normal file
View File

@ -0,0 +1 @@
Slava Pestov

23
basis/debugger/unix/unix.factor Normal file
View File

@ -0,0 +1,23 @@
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: debugger io kernel math prettyprint sequences system ;
IN: debugger.unix
CONSTANT: signal-names
{
"SIGHUP" "SIGINT" "SIGQUIT" "SIGILL" "SIGTRAP" "SIGABRT"
"SIGEMT" "SIGFPE" "SIGKILL" "SIGBUS" "SIGSEGV" "SIGSYS"
"SIGPIPE" "SIGALRM" "SIGTERM" "SIGURG" "SIGSTOP" "SIGTSIP"
"SIGCONT" "SIGCHLD" "SIGTTIN" "SIGTTOU" "SIGIO" "SIGXCPU"
"SIGXFSZ" "SIGVTALRM" "SIGPROF" "SIGWINCH" "SIGINFO"
"SIGUSR1" "SIGUSR2"
}
: signal-name ( n -- str/f ) 1- signal-names ?nth ;
: signal-name. ( n -- )
signal-name [ " (" ")" surround write ] when* ;
M: unix signal-error. ( obj -- )
"Unix signal #" write
third [ pprint ] [ signal-name. ] bi nl ;

1
basis/debugger/windows/authors.txt Normal file
View File

@ -0,0 +1 @@
Slava Pestov

6
basis/debugger/windows/windows.factor Normal file
View File

@ -0,0 +1,6 @@
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: debugger io prettyprint sequences system ;
IN: debugger.windows
M: windows signal-error. "Windows exception #" write third .h ;

12
basis/delegate/delegate-tests.factor
View File

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

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

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

11
basis/editors/editors.factor
View File

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

1
basis/editors/emacs/authors.txt
View File

@ -1 +1,2 @@
Eduardo Cavazos
Doug Coleman

19
basis/editors/emacs/emacs-docs.factor
View File

@ -2,10 +2,23 @@ USING: help help.syntax help.markup ;
IN: editors.emacs
ARTICLE: "editors.emacs" "Integration with Emacs"
"Put this in your " { $snippet ".emacs" } " file:"
"Full Emacs integration with Factor requires the use of two executable files -- " { $snippet "emacs" } " and " { $snippet "emacsclient" } ", which act as a client/server pair. To start the server, run the " { $snippet "emacs" } " binary and run " { $snippet "M-x server-start" } " or start " { $snippet "emacs" } " with the following line in your " { $snippet ".emacs" } " file:"
{ $code "(server-start)" }
"On Windows, if you install Emacs to " { $snippet "Program Files" } " or " { $snippet "Program Files(x86)" } ", Factor will automatically detect the path to " { $snippet "emacsclient.exe" } ". On Unix systems, make sure that " { $snippet "emacsclient" } " is in your path. To set the path manually, use the following snippet:"
{ $code "USE: edtiors.emacs"
"\"/my/crazy/bin/emacsclient\" emacsclient-path set-global"
}
"If you would like a new window to open when you ask Factor to edit an object, put this in your " { $snippet ".emacs" } " file:"
{ $code "(setq server-window 'switch-to-buffer-other-frame)" }
{ $see-also "editor" } ;
ABOUT: "editors.emacs"
"To quickly scaffold a " { $snippet ".emacs" } " file, run the following code:"
{ $code "USE: tools.scaffold"
"scaffold-emacs"
}
{ $see-also "editor" }
;
ABOUT: "editors.emacs"

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