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

Merge commit 'slava/master' into unicode 

Conflicts:

	core/parser/parser.factor
	core/source-files/source-files.factor
	extra/unicode/unicode-tests.factor
	extra/unicode/unicode.factor
db4
Daniel Ehrenberg 2008-01-09 17:30:59 -06:00
parent 98226eec9b 6df84617d6
commit 1dfabe3b34
414 changed files with 6364 additions and 5410 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
Makefile Normal file → Executable file
View File

@ -140,6 +140,7 @@ factor: $(DLL_OBJS) $(EXE_OBJS)
clean: clean:
rm -f vm/*.o rm -f vm/*.o
rm -f libfactor.a
vm/resources.o: vm/resources.o:
windres vm/factor.rs vm/resources.o windres vm/factor.rs vm/resources.o

13
core/alien/alien-docs.factor Normal file → Executable file
View File

@ -70,7 +70,18 @@ HELP: load-library
HELP: add-library HELP: add-library
{ $values { "name" "a string" } { "path" "a string" } { "abi" "one of " { $snippet "\"cdecl\"" } " or " { $snippet "\"stdcall\"" } } } { $values { "name" "a string" } { "path" "a string" } { "abi" "one of " { $snippet "\"cdecl\"" } " or " { $snippet "\"stdcall\"" } } }
{ $description "Defines a new logical library named " { $snippet "name" } " located in the file system at " { $snippet "path" } "and the specified ABI." } { $description "Defines a new logical library named " { $snippet "name" } " located in the file system at " { $snippet "path" } "and the specified ABI." }
{ $examples { $code "\"gif\" \"libgif.so\" \"cdecl\" add-library" } } ; { $notes "Because the entire source file is parsed before top-level forms are executed, " { $link add-library } " cannot be used in the same file as " { $link POSTPONE: FUNCTION: } " definitions from that library. The " { $link add-library } " call will happen too late, after compilation, and the alien calls will not work."
$nl
"Instead, " { $link add-library } " calls must either be placed in different source files from those that use that library, or alternatively, " { $link "syntax-immediate" } " can be used to load the library before compilation." }
{ $examples "Here is a typical usage of " { $link add-library } ":"
{ $code
"<< \"freetype\" {"
" { [ macosx? ] [ \"libfreetype.6.dylib\" \"cdecl\" add-library ] }"
" { [ windows? ] [ \"freetype6.dll\" \"cdecl\" add-library ] }"
" { [ t ] [ drop ] }"
"} cond >>"
}
"Note the parse time evaluation with " { $link POSTPONE: << } "." } ;
HELP: alien-invoke-error HELP: alien-invoke-error
{ $error-description "Thrown if the word calling " { $link alien-invoke } " was not compiled with the optimizing compiler. This may be a result of one of several failure conditions:" { $error-description "Thrown if the word calling " { $link alien-invoke } " was not compiled with the optimizing compiler. This may be a result of one of several failure conditions:"

25
core/alien/alien.factor Normal file → Executable file
View File

@ -1,16 +1,24 @@
! Copyright (C) 2004, 2007 Slava Pestov. ! Copyright (C) 2004, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
IN: alien
USING: assocs kernel math namespaces sequences system USING: assocs kernel math namespaces sequences system
byte-arrays bit-arrays float-arrays kernel.private tuples ; kernel.private tuples ;
IN: alien
! Some predicate classes used by the compiler for optimization ! Some predicate classes used by the compiler for optimization
! purposes ! purposes
PREDICATE: alien simple-alien PREDICATE: alien simple-alien
underlying-alien not ; underlying-alien not ;
UNION: simple-c-ptr ! These mixins are not intended to be extended by user code.
simple-alien byte-array bit-array float-array POSTPONE: f ; ! They are not unions, because if they were we'd have a circular
! dependency between alien and {byte,bit,float}-arrays.
MIXIN: simple-c-ptr
INSTANCE: simple-alien simple-c-ptr
INSTANCE: f simple-c-ptr
MIXIN: c-ptr
INSTANCE: alien c-ptr
INSTANCE: f c-ptr
DEFER: pinned-c-ptr? DEFER: pinned-c-ptr?
@ -20,9 +28,6 @@ PREDICATE: alien pinned-alien
UNION: pinned-c-ptr UNION: pinned-c-ptr
pinned-alien POSTPONE: f ; pinned-alien POSTPONE: f ;
UNION: c-ptr
alien bit-array byte-array float-array POSTPONE: f ;
M: f expired? drop t ; M: f expired? drop t ;
: <alien> ( address -- alien ) : <alien> ( address -- alien )
@ -47,9 +52,7 @@ M: alien equal?
SYMBOL: libraries SYMBOL: libraries
global [ libraries global [ H{ } assoc-like ] change-at
libraries [ H{ } assoc-like ] change
] bind
TUPLE: library path abi dll ; TUPLE: library path abi dll ;

4
core/alien/c-types/c-types.factor
View File

@ -194,7 +194,7 @@ M: long-long-type box-return ( type -- )
>r ">c-" swap "-array" 3append r> create ; >r ">c-" swap "-array" 3append r> create ;
: define-to-array ( type vocab -- ) : define-to-array ( type vocab -- )
[ to-array-word ] 2keep >c-array-quot define-compound ; [ to-array-word ] 2keep >c-array-quot define ;
: c-array>quot ( type vocab -- quot ) : c-array>quot ( type vocab -- quot )
[ [
@ -207,7 +207,7 @@ M: long-long-type box-return ( type -- )
>r "c-" swap "-array>" 3append r> create ; >r "c-" swap "-array>" 3append r> create ;
: define-from-array ( type vocab -- ) : define-from-array ( type vocab -- )
[ from-array-word ] 2keep c-array>quot define-compound ; [ from-array-word ] 2keep c-array>quot define ;
: <primitive-type> ( getter setter width boxer unboxer -- type ) : <primitive-type> ( getter setter width boxer unboxer -- type )
<c-type> <c-type>

3
core/alien/compiler/compiler.factor
View File

@ -2,7 +2,7 @@
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: arrays generator generator.registers generator.fixup USING: arrays generator generator.registers generator.fixup
hashtables kernel math namespaces sequences words hashtables kernel math namespaces sequences words
inference.backend inference.dataflow system inference.state inference.backend inference.dataflow system
math.parser classes alien.arrays alien.c-types alien.structs math.parser classes alien.arrays alien.c-types alien.structs
alien.syntax cpu.architecture alien inspector quotations assocs alien.syntax cpu.architecture alien inspector quotations assocs
kernel.private threads continuations.private libc combinators ; kernel.private threads continuations.private libc combinators ;
@ -387,7 +387,6 @@ TUPLE: callback-context ;
: generate-callback ( node -- ) : generate-callback ( node -- )
dup alien-callback-xt dup rot [ dup alien-callback-xt dup rot [
init-templates init-templates
generate-profiler-prologue
%save-word-xt %save-word-xt
%prologue-later %prologue-later
dup alien-stack-frame [ dup alien-stack-frame [

3
core/alien/syntax/syntax-docs.factor Normal file → Executable file
View File

@ -38,7 +38,6 @@ $nl
{ $unchecked-example { $unchecked-example
"LIBRARY: foo\nFUNCTION: void the_answer ( char* question, int value ) ;" "LIBRARY: foo\nFUNCTION: void the_answer ( char* question, int value ) ;"
"USE: compiler" "USE: compiler"
"\\ the_answer compile"
"\"the question\" 42 the_answer" "\"the question\" 42 the_answer"
"The answer to the question is 42." "The answer to the question is 42."
} } } }
@ -70,7 +69,7 @@ HELP: C-UNION:
HELP: C-ENUM: HELP: C-ENUM:
{ $syntax "C-ENUM: words... ;" } { $syntax "C-ENUM: words... ;" }
{ $values { "words" "a sequence of word names" } } { $values { "words" "a sequence of word names" } }
{ $description "Creates a sequence of compound definitions in the current vocabulary. Each word pushes an integer according to its index in the enumeration definition. The first word pushes 0." } { $description "Creates a sequence of word definitions in the current vocabulary. Each word pushes an integer according to its index in the enumeration definition. The first word pushes 0." }
{ $notes "This word emulates a C-style " { $snippet "enum" } " in Factor. While this feature can be used for any purpose, using integer constants is discouraged unless it is for interfacing with C libraries. Factor code should use symbolic constants instead." } { $notes "This word emulates a C-style " { $snippet "enum" } " in Factor. While this feature can be used for any purpose, using integer constants is discouraged unless it is for interfacing with C libraries. Factor code should use symbolic constants instead." }
{ $examples { $examples
"The following two lines are equivalent:" "The following two lines are equivalent:"

8
core/alien/syntax/syntax.factor
View File

@ -1,8 +1,8 @@
! Copyright (C) 2005, 2007 Slava Pestov, Alex Chapman. ! Copyright (C) 2005, 2007 Slava Pestov, Alex Chapman.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: arrays alien alien.c-types alien.structs kernel math USING: arrays alien alien.c-types alien.structs alien.arrays
namespaces parser sequences words quotations math.parser kernel math namespaces parser sequences words quotations
splitting effects prettyprint prettyprint.sections math.parser splitting effects prettyprint prettyprint.sections
prettyprint.backend assocs combinators ; prettyprint.backend assocs combinators ;
IN: alien.syntax IN: alien.syntax
@ -49,7 +49,7 @@ PRIVATE>
: C-ENUM: : C-ENUM:
";" parse-tokens ";" parse-tokens
dup length dup length
[ >r create-in r> 1quotation define-compound ] 2each ; [ >r create-in r> 1quotation define ] 2each ;
parsing parsing
M: alien pprint* M: alien pprint*

11
core/arrays/arrays-docs.factor Normal file → Executable file
View File

@ -1,6 +1,5 @@
USING: byte-arrays bit-arrays help.markup help.syntax USING: help.markup help.syntax
kernel kernel.private prettyprint strings sbufs vectors kernel kernel.private prettyprint sequences.private ;
quotations sequences.private ;
IN: arrays IN: arrays
ARTICLE: "arrays" "Arrays" ARTICLE: "arrays" "Arrays"
@ -34,16 +33,10 @@ HELP: <array> ( n elt -- array )
{ $values { "n" "a non-negative integer" } { "elt" "an initial element" } { "array" "a new array" } } { $values { "n" "a non-negative integer" } { "elt" "an initial element" } { "array" "a new array" } }
{ $description "Creates a new array with the given length and all elements initially set to " { $snippet "elt" } "." } ; { $description "Creates a new array with the given length and all elements initially set to " { $snippet "elt" } "." } ;
{ <array> <quotation> <string> <sbuf> <vector> <byte-array> <bit-array> }
related-words
HELP: >array HELP: >array
{ $values { "seq" "a sequence" } { "array" array } } { $values { "seq" "a sequence" } { "array" array } }
{ $description "Outputs a freshly-allocated array with the same elements as a given sequence." } ; { $description "Outputs a freshly-allocated array with the same elements as a given sequence." } ;
{ >array >quotation >string >sbuf >vector >byte-array >bit-array }
related-words
HELP: 1array HELP: 1array
{ $values { "x" object } { "array" array } } { $values { "x" object } { "array" array } }
{ $description "Create a new array with one element." } ; { $description "Create a new array with one element." } ;

2
core/assocs/assocs.factor
View File

@ -143,7 +143,7 @@ M: assoc >alist [ 2array ] { } assoc>map ;
swap [ = nip ] curry assoc-find 2drop ; swap [ = nip ] curry assoc-find 2drop ;
: search-alist ( key alist -- pair i ) : search-alist ( key alist -- pair i )
[ first = ] curry* find swap ; inline [ first = ] with find swap ; inline
M: sequence at* M: sequence at*
search-alist [ second t ] [ f ] if ; search-alist [ second t ] [ f ] if ;

6
core/bit-arrays/bit-arrays.factor Normal file → Executable file
View File

@ -1,4 +1,4 @@
! Copyright (C) 2007 Slava Pestov. ! Copyright (C) 2007, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: math alien kernel kernel.private sequences USING: math alien kernel kernel.private sequences
sequences.private ; sequences.private ;
@ -20,7 +20,7 @@ IN: bit-arrays
: (set-bits) ( bit-array n -- ) : (set-bits) ( bit-array n -- )
over length bits>cells -rot [ over length bits>cells -rot [
swap rot 4 * set-alien-unsigned-4 spin 4 * set-alien-unsigned-4
] 2curry each ; inline ] 2curry each ; inline
PRIVATE> PRIVATE>
@ -49,3 +49,5 @@ M: bit-array equal?
over bit-array? [ sequence= ] [ 2drop f ] if ; over bit-array? [ sequence= ] [ 2drop f ] if ;
INSTANCE: bit-array sequence INSTANCE: bit-array sequence
INSTANCE: bit-array simple-c-ptr
INSTANCE: bit-array c-ptr

64
core/bootstrap/compiler/compiler.factor
View File

@ -1,26 +1,30 @@
! Copyright (C) 2007, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: compiler cpu.architecture vocabs.loader system sequences USING: compiler cpu.architecture vocabs.loader system sequences
namespaces parser kernel kernel.private classes classes.private namespaces parser kernel kernel.private classes classes.private
arrays hashtables vectors tuples sbufs inference.dataflow arrays hashtables vectors tuples sbufs inference.dataflow
hashtables.private sequences.private math tuples.private hashtables.private sequences.private math tuples.private
growable namespaces.private alien.remote-control assocs words growable namespaces.private assocs words generator command-line
generator command-line vocabs io prettyprint libc ; vocabs io prettyprint libc compiler.units ;
IN: bootstrap.compiler
! Don't bring this in when deploying, since it will store a
! reference to 'eval' in a global variable
"deploy-vocab" get [
"alien.remote-control" require
] unless
"cpu." cpu append require "cpu." cpu append require
global [ { "compiler" } add-use ] bind nl
"Compiling some words to speed up bootstrap..." write
"-no-stack-traces" cli-args member? [ ! Compile a set of words ahead of the full compile.
f compiled-stack-traces? set-global ! This set of words was determined semi-empirically
0 set-profiler-prologues ! using the profiler. It improves bootstrap time
] when ! significantly, because frequenly called words
! which are also quick to compile are replaced by
! Compile a set of words ahead of our general ! compiled definitions as soon as possible.
! compile-all. This set of words was determined
! semi-empirically using the profiler. It improves
! bootstrap time significantly, because frequenly
! called words which are also quick to compile
! are replaced by compiled definitions as soon as
! possible.
{ {
roll -roll declare not roll -roll declare not
@ -38,14 +42,38 @@ global [ { "compiler" } add-use ] bind
find-pair-next namestack* find-pair-next namestack*
bitand bitor bitxor bitnot bitand bitor bitxor bitnot
} compile
"." write flush
{
+ 1+ 1- 2/ < <= > >= shift min + 1+ 1- 2/ < <= > >= shift min
} compile
new nth push pop peek hashcode* = get set "." write flush
{
new nth push pop peek
} compile
"." write flush
{
hashcode* = get set
} compile
"." write flush
{
. lines . lines
} compile
"." write flush
{
malloc free memcpy malloc free memcpy
} [ compile ] each } compile
[ recompile ] parse-hook set-global [ compiled-usages recompile ] recompile-hook set-global
" done" print flush

6
core/bootstrap/image/image-tests.factor Executable file
View File

@ -0,0 +1,6 @@
IN: temporary
USING: bootstrap.image bootstrap.image.private
tools.test.inference ;
\ ' must-infer
\ write-image must-infer

71
core/bootstrap/image/image.factor
View File

@ -1,4 +1,4 @@
! Copyright (C) 2004, 2007 Slava Pestov. ! Copyright (C) 2004, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: alien arrays bit-arrays byte-arrays generic assocs USING: alien arrays bit-arrays byte-arrays generic assocs
hashtables assocs hashtables.private io kernel kernel.private hashtables assocs hashtables.private io kernel kernel.private
@ -38,6 +38,9 @@ IN: bootstrap.image
: quot-array@ bootstrap-cell object tag-number - ; : quot-array@ bootstrap-cell object tag-number - ;
: quot-xt@ 3 bootstrap-cells object tag-number - ; : quot-xt@ 3 bootstrap-cells object tag-number - ;
: jit-define ( quot rc rt offset name -- )
>r >r >r >r { } make r> r> r> 4array r> set ;
! The image being constructed; a vector of word-size integers ! The image being constructed; a vector of word-size integers
SYMBOL: image SYMBOL: image
@ -58,42 +61,42 @@ SYMBOL: bootstrap-boot-quot
! JIT parameters ! JIT parameters
SYMBOL: jit-code-format SYMBOL: jit-code-format
SYMBOL: jit-setup
SYMBOL: jit-prolog SYMBOL: jit-prolog
SYMBOL: jit-word-primitive-jump SYMBOL: jit-primitive-word
SYMBOL: jit-word-primitive-call SYMBOL: jit-primitive
SYMBOL: jit-word-jump SYMBOL: jit-word-jump
SYMBOL: jit-word-call SYMBOL: jit-word-call
SYMBOL: jit-push-wrapper
SYMBOL: jit-push-literal SYMBOL: jit-push-literal
SYMBOL: jit-if-word SYMBOL: jit-if-word
SYMBOL: jit-if-jump SYMBOL: jit-if-jump
SYMBOL: jit-if-call
SYMBOL: jit-dispatch-word SYMBOL: jit-dispatch-word
SYMBOL: jit-dispatch SYMBOL: jit-dispatch
SYMBOL: jit-epilog SYMBOL: jit-epilog
SYMBOL: jit-return SYMBOL: jit-return
SYMBOL: jit-profiling
! Default definition for undefined words
SYMBOL: undefined-quot
: userenv-offset ( symbol -- n ) : userenv-offset ( symbol -- n )
{ {
{ bootstrap-boot-quot 20 } { bootstrap-boot-quot 20 }
{ bootstrap-global 21 } { bootstrap-global 21 }
{ jit-code-format 22 } { jit-code-format 22 }
{ jit-setup 23 } { jit-prolog 23 }
{ jit-prolog 24 } { jit-primitive-word 24 }
{ jit-word-primitive-jump 25 } { jit-primitive 25 }
{ jit-word-primitive-call 26 } { jit-word-jump 26 }
{ jit-word-jump 27 } { jit-word-call 27 }
{ jit-word-call 28 } { jit-push-literal 28 }
{ jit-push-wrapper 29 } { jit-if-word 29 }
{ jit-push-literal 30 } { jit-if-jump 30 }
{ jit-if-word 31 } { jit-dispatch-word 31 }
{ jit-if-jump 32 } { jit-dispatch 32 }
{ jit-if-call 33 } { jit-epilog 33 }
{ jit-dispatch-word 34 } { jit-return 34 }
{ jit-dispatch 35 } { jit-profiling 35 }
{ jit-epilog 36 } { undefined-quot 37 }
{ jit-return 37 }
} at header-size + ; } at header-size + ;
: emit ( cell -- ) image get push ; : emit ( cell -- ) image get push ;
@ -120,10 +123,10 @@ SYMBOL: jit-return
: align-here ( -- ) : align-here ( -- )
here 8 mod 4 = [ 0 emit ] when ; here 8 mod 4 = [ 0 emit ] when ;
: emit-fixnum ( n -- ) tag-bits get shift emit ; : emit-fixnum ( n -- ) tag-fixnum emit ;
: emit-object ( header tag quot -- addr ) : emit-object ( header tag quot -- addr )
swap here-as >r swap tag-header emit call align-here r> ; swap here-as >r swap tag-fixnum emit call align-here r> ;
inline inline
! Write an object to the image. ! Write an object to the image.
@ -173,7 +176,7 @@ M: fixnum '
#! When generating a 32-bit image on a 64-bit system, #! When generating a 32-bit image on a 64-bit system,
#! some fixnums should be bignums. #! some fixnums should be bignums.
dup most-negative-fixnum most-positive-fixnum between? dup most-negative-fixnum most-positive-fixnum between?
[ tag-bits get shift ] [ >bignum ' ] if ; [ tag-fixnum ] [ >bignum ' ] if ;
! Floats ! Floats
@ -213,6 +216,7 @@ M: f '
0 , ! count 0 , ! count
0 , ! xt 0 , ! xt
0 , ! code 0 , ! code
0 , ! profiling
] { } make ] { } make
\ word type-number object tag-number \ word type-number object tag-number
[ emit-seq ] emit-object [ emit-seq ] emit-object
@ -367,31 +371,30 @@ M: curry '
: emit-jit-data ( -- ) : emit-jit-data ( -- )
\ if jit-if-word set \ if jit-if-word set
\ dispatch jit-dispatch-word set \ dispatch jit-dispatch-word set
\ do-primitive jit-primitive-word set
[ undefined ] undefined-quot set
{ {
jit-code-format jit-code-format
jit-setup
jit-prolog jit-prolog
jit-word-primitive-jump jit-primitive-word
jit-word-primitive-call jit-primitive
jit-word-jump jit-word-jump
jit-word-call jit-word-call
jit-push-wrapper
jit-push-literal jit-push-literal
jit-if-word jit-if-word
jit-if-jump jit-if-jump
jit-if-call
jit-dispatch-word jit-dispatch-word
jit-dispatch jit-dispatch
jit-epilog jit-epilog
jit-return jit-return
jit-profiling
undefined-quot
} [ emit-userenv ] each ; } [ emit-userenv ] each ;
: fixup-header ( -- ) : fixup-header ( -- )
heap-size data-heap-size-offset fixup ; heap-size data-heap-size-offset fixup ;
: end-image ( -- ) : end-image ( -- )
"Building generic words..." print flush
all-words [ generic? ] subset [ make-generic ] each
"Serializing words..." print flush "Serializing words..." print flush
emit-words emit-words
"Serializing JIT data..." print flush "Serializing JIT data..." print flush
@ -444,7 +447,6 @@ PRIVATE>
: make-image ( arch -- ) : make-image ( arch -- )
[ [
parse-hook off
prepare-image prepare-image
begin-image begin-image
"resource:/core/bootstrap/stage1.factor" run-file "resource:/core/bootstrap/stage1.factor" run-file
@ -457,5 +459,8 @@ PRIVATE>
: make-images ( -- ) : make-images ( -- )
{ {
"x86.32" "x86.64" "linux-ppc" "macosx-ppc" "arm" "x86.32"
! "x86.64"
"linux-ppc" "macosx-ppc"
! "arm"
} [ make-image ] each ; } [ make-image ] each ;

429
core/bootstrap/primitives.factor Normal file → Executable file
View File

@ -1,26 +1,26 @@
! Copyright (C) 2004, 2007 Slava Pestov. ! Copyright (C) 2004, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
IN: bootstrap.primitives IN: bootstrap.primitives
USING: alien arrays byte-arrays generic hashtables USING: alien arrays byte-arrays generic hashtables
hashtables.private io kernel math namespaces parser sequences hashtables.private io kernel math namespaces parser sequences
strings vectors words quotations assocs layouts classes tuples strings vectors words quotations assocs layouts classes tuples
kernel.private vocabs vocabs.loader source-files definitions kernel.private vocabs vocabs.loader source-files definitions
slots classes.union words.private ; slots classes.union compiler.units ;
! Some very tricky code creating a bootstrap embryo in the
! host image.
"Creating primitives and basic runtime structures..." print flush "Creating primitives and basic runtime structures..." print flush
load-help? off load-help? off
crossref off crossref off
changed-words off
! Bring up a bare cross-compiling vocabulary. ! Bring up a bare cross-compiling vocabulary.
"syntax" vocab vocab-words bootstrap-syntax set "syntax" vocab vocab-words bootstrap-syntax set
"resource:core/bootstrap/syntax.factor" parse-file "resource:core/bootstrap/syntax.factor" parse-file
H{ } clone dictionary set H{ } clone dictionary set
H{ } clone changed-words set
[ drop ] recompile-hook set
call call
! Create some empty vocabs where the below primitives and ! Create some empty vocabs where the below primitives and
@ -31,6 +31,7 @@ call
"bit-arrays" "bit-arrays"
"byte-arrays" "byte-arrays"
"classes.private" "classes.private"
"compiler.units"
"continuations.private" "continuations.private"
"float-arrays" "float-arrays"
"generator" "generator"
@ -75,209 +76,7 @@ H{ } clone source-files set
H{ } clone class<map set H{ } clone class<map set
H{ } clone update-map set H{ } clone update-map set
: make-primitive ( word vocab n -- ) >r create r> define ; ! Builtin classes
{
{ "(execute)" "words.private" }
{ "(call)" "kernel.private" }
{ "uncurry" "kernel.private" }
{ "string>sbuf" "sbufs.private" }
{ "bignum>fixnum" "math.private" }
{ "float>fixnum" "math.private" }
{ "fixnum>bignum" "math.private" }
{ "float>bignum" "math.private" }
{ "fixnum>float" "math.private" }
{ "bignum>float" "math.private" }
{ "<ratio>" "math.private" }
{ "string>float" "math.private" }
{ "float>string" "math.private" }
{ "float>bits" "math" }
{ "double>bits" "math" }
{ "bits>float" "math" }
{ "bits>double" "math" }
{ "<complex>" "math.private" }
{ "fixnum+" "math.private" }
{ "fixnum+fast" "math.private" }
{ "fixnum-" "math.private" }
{ "fixnum-fast" "math.private" }
{ "fixnum*" "math.private" }
{ "fixnum*fast" "math.private" }
{ "fixnum/i" "math.private" }
{ "fixnum-mod" "math.private" }
{ "fixnum/mod" "math.private" }
{ "fixnum-bitand" "math.private" }
{ "fixnum-bitor" "math.private" }
{ "fixnum-bitxor" "math.private" }
{ "fixnum-bitnot" "math.private" }
{ "fixnum-shift" "math.private" }
{ "fixnum<" "math.private" }
{ "fixnum<=" "math.private" }
{ "fixnum>" "math.private" }
{ "fixnum>=" "math.private" }
{ "bignum=" "math.private" }
{ "bignum+" "math.private" }
{ "bignum-" "math.private" }
{ "bignum*" "math.private" }
{ "bignum/i" "math.private" }
{ "bignum-mod" "math.private" }
{ "bignum/mod" "math.private" }
{ "bignum-bitand" "math.private" }
{ "bignum-bitor" "math.private" }
{ "bignum-bitxor" "math.private" }
{ "bignum-bitnot" "math.private" }
{ "bignum-shift" "math.private" }
{ "bignum<" "math.private" }
{ "bignum<=" "math.private" }
{ "bignum>" "math.private" }
{ "bignum>=" "math.private" }
{ "bignum-bit?" "math.private" }
{ "bignum-log2" "math.private" }
{ "byte-array>bignum" "math" }
{ "float=" "math.private" }
{ "float+" "math.private" }
{ "float-" "math.private" }
{ "float*" "math.private" }
{ "float/f" "math.private" }
{ "float-mod" "math.private" }
{ "float<" "math.private" }
{ "float<=" "math.private" }
{ "float>" "math.private" }
{ "float>=" "math.private" }
{ "<word>" "words" }
{ "update-xt" "words" }
{ "word-xt" "words" }
{ "drop" "kernel" }
{ "2drop" "kernel" }
{ "3drop" "kernel" }
{ "dup" "kernel" }
{ "2dup" "kernel" }
{ "3dup" "kernel" }
{ "rot" "kernel" }
{ "-rot" "kernel" }
{ "dupd" "kernel" }
{ "swapd" "kernel" }
{ "nip" "kernel" }
{ "2nip" "kernel" }
{ "tuck" "kernel" }
{ "over" "kernel" }
{ "pick" "kernel" }
{ "swap" "kernel" }
{ ">r" "kernel" }
{ "r>" "kernel" }
{ "eq?" "kernel" }
{ "getenv" "kernel.private" }
{ "setenv" "kernel.private" }
{ "(stat)" "io.files.private" }
{ "(directory)" "io.files.private" }
{ "data-gc" "memory" }
{ "code-gc" "memory" }
{ "gc-time" "memory" }
{ "save-image" "memory" }
{ "save-image-and-exit" "memory" }
{ "datastack" "kernel" }
{ "retainstack" "kernel" }
{ "callstack" "kernel" }
{ "set-datastack" "kernel" }
{ "set-retainstack" "kernel" }
{ "set-callstack" "kernel" }
{ "exit" "system" }
{ "data-room" "memory" }
{ "code-room" "memory" }
{ "os-env" "system" }
{ "millis" "system" }
{ "type" "kernel.private" }
{ "tag" "kernel.private" }
{ "cwd" "io.files" }
{ "cd" "io.files" }
{ "add-compiled-block" "generator" }
{ "dlopen" "alien" }
{ "dlsym" "alien" }
{ "dlclose" "alien" }
{ "<byte-array>" "byte-arrays" }
{ "<bit-array>" "bit-arrays" }
{ "<displaced-alien>" "alien" }
{ "alien-signed-cell" "alien" }
{ "set-alien-signed-cell" "alien" }
{ "alien-unsigned-cell" "alien" }
{ "set-alien-unsigned-cell" "alien" }
{ "alien-signed-8" "alien" }
{ "set-alien-signed-8" "alien" }
{ "alien-unsigned-8" "alien" }
{ "set-alien-unsigned-8" "alien" }
{ "alien-signed-4" "alien" }
{ "set-alien-signed-4" "alien" }
{ "alien-unsigned-4" "alien" }
{ "set-alien-unsigned-4" "alien" }
{ "alien-signed-2" "alien" }
{ "set-alien-signed-2" "alien" }
{ "alien-unsigned-2" "alien" }
{ "set-alien-unsigned-2" "alien" }
{ "alien-signed-1" "alien" }
{ "set-alien-signed-1" "alien" }
{ "alien-unsigned-1" "alien" }
{ "set-alien-unsigned-1" "alien" }
{ "alien-float" "alien" }
{ "set-alien-float" "alien" }
{ "alien-double" "alien" }
{ "set-alien-double" "alien" }
{ "alien-cell" "alien" }
{ "set-alien-cell" "alien" }
{ "alien>char-string" "alien" }
{ "string>char-alien" "alien" }
{ "alien>u16-string" "alien" }
{ "string>u16-alien" "alien" }
{ "(throw)" "kernel.private" }
{ "string>memory" "alien" }
{ "memory>string" "alien" }
{ "alien-address" "alien" }
{ "slot" "slots.private" }
{ "set-slot" "slots.private" }
{ "char-slot" "strings.private" }
{ "set-char-slot" "strings.private" }
{ "resize-array" "arrays" }
{ "resize-string" "strings" }
{ "(hashtable)" "hashtables.private" }
{ "<array>" "arrays" }
{ "begin-scan" "memory" }
{ "next-object" "memory" }
{ "end-scan" "memory" }
{ "size" "memory" }
{ "die" "kernel" }
{ "finalize-compile" "generator" }
{ "fopen" "io.streams.c" }
{ "fgetc" "io.streams.c" }
{ "fread" "io.streams.c" }
{ "fwrite" "io.streams.c" }
{ "fflush" "io.streams.c" }
{ "fclose" "io.streams.c" }
{ "<wrapper>" "kernel" }
{ "(clone)" "kernel" }
{ "array>vector" "vectors.private" }
{ "<string>" "strings" }
{ "(>tuple)" "tuples.private" }
{ "array>quotation" "quotations.private" }
{ "quotation-xt" "quotations" }
{ "<tuple>" "tuples.private" }
{ "tuple>array" "tuples" }
{ "profiling" "tools.profiler.private" }
{ "become" "kernel.private" }
{ "(sleep)" "threads.private" }
{ "<float-array>" "float-arrays" }
{ "curry" "kernel" }
{ "<tuple-boa>" "tuples.private" }
{ "class-hash" "kernel.private" }
{ "callstack>array" "kernel" }
{ "innermost-frame-quot" "kernel.private" }
{ "innermost-frame-scan" "kernel.private" }
{ "set-innermost-frame-quot" "kernel.private" }
{ "call-clear" "kernel" }
{ "strip-compiled-quotations" "quotations" }
{ "(os-envs)" "system" }
}
dup length [ >r first2 r> make-primitive ] 2each
! Okay, now we have primitives fleshed out. Bring up the generic
! word system.
: builtin-predicate ( class predicate -- ) : builtin-predicate ( class predicate -- )
[ [
over "type" word-prop dup over "type" word-prop dup
@ -348,16 +147,16 @@ num-types get f <array> builtins set
{ {
{ {
{ "real" "math" } { "real" "math" }
"real" "real-part"
1 1
{ "real" "math" } { "real-part" "math" }
f f
} }
{ {
{ "real" "math" } { "real" "math" }
"imaginary" "imaginary-part"
2 2
{ "imaginary" "math" } { "imaginary-part" "math" }
f f
} }
} define-builtin } define-builtin
@ -513,7 +312,7 @@ define-builtin
{ "set-word-vocabulary" "words" } { "set-word-vocabulary" "words" }
} }
{ {
{ "object" "kernel" } { "quotation" "quotations" }
"def" "def"
4 4
{ "word-def" "words" } { "word-def" "words" }
@ -605,5 +404,205 @@ builtins get num-tags get tail f union-class define-class
"tombstone" "hashtables.private" lookup t "tombstone" "hashtables.private" lookup t
2array >tuple 1quotation define-inline 2array >tuple 1quotation define-inline
! Primitive words
: make-primitive ( word vocab n -- )
>r create dup reset-word r> [ do-primitive ] curry [ ] like define ;
{
{ "(execute)" "words.private" }
{ "(call)" "kernel.private" }
{ "uncurry" "kernel.private" }
{ "string>sbuf" "sbufs.private" }
{ "bignum>fixnum" "math.private" }
{ "float>fixnum" "math.private" }
{ "fixnum>bignum" "math.private" }
{ "float>bignum" "math.private" }
{ "fixnum>float" "math.private" }
{ "bignum>float" "math.private" }
{ "<ratio>" "math.private" }
{ "string>float" "math.private" }
{ "float>string" "math.private" }
{ "float>bits" "math" }
{ "double>bits" "math" }
{ "bits>float" "math" }
{ "bits>double" "math" }
{ "<complex>" "math.private" }
{ "fixnum+" "math.private" }
{ "fixnum+fast" "math.private" }
{ "fixnum-" "math.private" }
{ "fixnum-fast" "math.private" }
{ "fixnum*" "math.private" }
{ "fixnum*fast" "math.private" }
{ "fixnum/i" "math.private" }
{ "fixnum-mod" "math.private" }
{ "fixnum/mod" "math.private" }
{ "fixnum-bitand" "math.private" }
{ "fixnum-bitor" "math.private" }
{ "fixnum-bitxor" "math.private" }
{ "fixnum-bitnot" "math.private" }
{ "fixnum-shift" "math.private" }
{ "fixnum<" "math.private" }
{ "fixnum<=" "math.private" }
{ "fixnum>" "math.private" }
{ "fixnum>=" "math.private" }
{ "bignum=" "math.private" }
{ "bignum+" "math.private" }
{ "bignum-" "math.private" }
{ "bignum*" "math.private" }
{ "bignum/i" "math.private" }
{ "bignum-mod" "math.private" }
{ "bignum/mod" "math.private" }
{ "bignum-bitand" "math.private" }
{ "bignum-bitor" "math.private" }
{ "bignum-bitxor" "math.private" }
{ "bignum-bitnot" "math.private" }
{ "bignum-shift" "math.private" }
{ "bignum<" "math.private" }
{ "bignum<=" "math.private" }
{ "bignum>" "math.private" }
{ "bignum>=" "math.private" }
{ "bignum-bit?" "math.private" }
{ "bignum-log2" "math.private" }
{ "byte-array>bignum" "math" }
{ "float=" "math.private" }
{ "float+" "math.private" }
{ "float-" "math.private" }
{ "float*" "math.private" }
{ "float/f" "math.private" }
{ "float-mod" "math.private" }
{ "float<" "math.private" }
{ "float<=" "math.private" }
{ "float>" "math.private" }
{ "float>=" "math.private" }
{ "<word>" "words" }
{ "word-xt" "words" }
{ "drop" "kernel" }
{ "2drop" "kernel" }
{ "3drop" "kernel" }
{ "dup" "kernel" }
{ "2dup" "kernel" }
{ "3dup" "kernel" }
{ "rot" "kernel" }
{ "-rot" "kernel" }
{ "dupd" "kernel" }
{ "swapd" "kernel" }
{ "nip" "kernel" }
{ "2nip" "kernel" }
{ "tuck" "kernel" }
{ "over" "kernel" }
{ "pick" "kernel" }
{ "swap" "kernel" }
{ ">r" "kernel" }
{ "r>" "kernel" }
{ "eq?" "kernel" }
{ "getenv" "kernel.private" }
{ "setenv" "kernel.private" }
{ "(stat)" "io.files.private" }
{ "(directory)" "io.files.private" }
{ "data-gc" "memory" }
{ "code-gc" "memory" }
{ "gc-time" "memory" }
{ "save-image" "memory" }
{ "save-image-and-exit" "memory" }
{ "datastack" "kernel" }
{ "retainstack" "kernel" }
{ "callstack" "kernel" }
{ "set-datastack" "kernel" }
{ "set-retainstack" "kernel" }
{ "set-callstack" "kernel" }
{ "exit" "system" }
{ "data-room" "memory" }
{ "code-room" "memory" }
{ "os-env" "system" }
{ "millis" "system" }
{ "type" "kernel.private" }
{ "tag" "kernel.private" }
{ "cwd" "io.files" }
{ "cd" "io.files" }
{ "modify-code-heap" "compiler.units" }
{ "dlopen" "alien" }
{ "dlsym" "alien" }
{ "dlclose" "alien" }
{ "<byte-array>" "byte-arrays" }
{ "<bit-array>" "bit-arrays" }
{ "<displaced-alien>" "alien" }
{ "alien-signed-cell" "alien" }
{ "set-alien-signed-cell" "alien" }
{ "alien-unsigned-cell" "alien" }
{ "set-alien-unsigned-cell" "alien" }
{ "alien-signed-8" "alien" }
{ "set-alien-signed-8" "alien" }
{ "alien-unsigned-8" "alien" }
{ "set-alien-unsigned-8" "alien" }
{ "alien-signed-4" "alien" }
{ "set-alien-signed-4" "alien" }
{ "alien-unsigned-4" "alien" }
{ "set-alien-unsigned-4" "alien" }
{ "alien-signed-2" "alien" }
{ "set-alien-signed-2" "alien" }
{ "alien-unsigned-2" "alien" }
{ "set-alien-unsigned-2" "alien" }
{ "alien-signed-1" "alien" }
{ "set-alien-signed-1" "alien" }
{ "alien-unsigned-1" "alien" }
{ "set-alien-unsigned-1" "alien" }
{ "alien-float" "alien" }
{ "set-alien-float" "alien" }
{ "alien-double" "alien" }
{ "set-alien-double" "alien" }
{ "alien-cell" "alien" }
{ "set-alien-cell" "alien" }
{ "alien>char-string" "alien" }
{ "string>char-alien" "alien" }
{ "alien>u16-string" "alien" }
{ "string>u16-alien" "alien" }
{ "(throw)" "kernel.private" }
{ "string>memory" "alien" }
{ "memory>string" "alien" }
{ "alien-address" "alien" }
{ "slot" "slots.private" }
{ "set-slot" "slots.private" }
{ "char-slot" "strings.private" }
{ "set-char-slot" "strings.private" }
{ "resize-array" "arrays" }
{ "resize-string" "strings" }
{ "(hashtable)" "hashtables.private" }
{ "<array>" "arrays" }
{ "begin-scan" "memory" }
{ "next-object" "memory" }
{ "end-scan" "memory" }
{ "size" "memory" }
{ "die" "kernel" }
{ "fopen" "io.streams.c" }
{ "fgetc" "io.streams.c" }
{ "fread" "io.streams.c" }
{ "fwrite" "io.streams.c" }
{ "fflush" "io.streams.c" }
{ "fclose" "io.streams.c" }
{ "<wrapper>" "kernel" }
{ "(clone)" "kernel" }
{ "array>vector" "vectors.private" }
{ "<string>" "strings" }
{ "(>tuple)" "tuples.private" }
{ "array>quotation" "quotations.private" }
{ "quotation-xt" "quotations" }
{ "<tuple>" "tuples.private" }
{ "tuple>array" "tuples" }
{ "profiling" "tools.profiler.private" }
{ "become" "kernel.private" }
{ "(sleep)" "threads.private" }
{ "<float-array>" "float-arrays" }
{ "curry" "kernel" }
{ "<tuple-boa>" "tuples.private" }
{ "class-hash" "kernel.private" }
{ "callstack>array" "kernel" }
{ "innermost-frame-quot" "kernel.private" }
{ "innermost-frame-scan" "kernel.private" }
{ "set-innermost-frame-quot" "kernel.private" }
{ "call-clear" "kernel" }
{ "(os-envs)" "system" }
}
dup length [ >r first2 r> make-primitive ] 2each
! Bump build number ! Bump build number
"build" "kernel" create build 1+ 1quotation define-compound "build" "kernel" create build 1+ 1quotation define

11
core/bootstrap/stage1.factor
View File

@ -13,14 +13,15 @@ vocabs.loader system ;
"resource:core/bootstrap/primitives.factor" run-file "resource:core/bootstrap/primitives.factor" run-file
! Create a boot quotation ! Create a boot quotation for the target
[ [
! Rehash hashtables, since core/tools/image creates them [
! Rehash hashtables, since bootstrap.image creates them
! using the host image's hashing algorithms ! using the host image's hashing algorithms
[ hashtable? ] instances [ rehash ] each
[ [ hashtable? ] instances [ rehash ] each ] % boot
] %
\ boot ,
"math.integers" require "math.integers" require
"math.floats" require "math.floats" require

28
core/bootstrap/stage2.factor
View File

@ -4,7 +4,7 @@ USING: init command-line namespaces words debugger io
kernel.private math memory continuations kernel io.files kernel.private math memory continuations kernel io.files
io.backend system parser vocabs sequences prettyprint io.backend system parser vocabs sequences prettyprint
vocabs.loader combinators splitting source-files strings vocabs.loader combinators splitting source-files strings
definitions assocs ; definitions assocs compiler.errors compiler.units ;
IN: bootstrap.stage2 IN: bootstrap.stage2
! Wrap everything in a catch which starts a listener so ! Wrap everything in a catch which starts a listener so
@ -14,13 +14,11 @@ IN: bootstrap.stage2
vm file-name windows? [ >lower ".exe" ?tail drop ] when vm file-name windows? [ >lower ".exe" ?tail drop ] when
".image" append "output-image" set-global ".image" append "output-image" set-global
"math compiler tools help ui ui.tools io" "include" set-global "math tools help compiler ui ui.tools io" "include" set-global
"" "exclude" set-global "" "exclude" set-global
parse-command-line parse-command-line
all-words [ dup ] H{ } map>assoc changed-words set-global
"-no-crossref" cli-args member? [ "-no-crossref" cli-args member? [
"Cross-referencing..." print flush "Cross-referencing..." print flush
H{ } clone crossref set-global H{ } clone crossref set-global
@ -37,7 +35,6 @@ IN: bootstrap.stage2
] [ ] [
"listener" require "listener" require
"none" require "none" require
"listener" use+
] if ] if
[ [
@ -45,19 +42,14 @@ IN: bootstrap.stage2
[ get-global " " split [ empty? not ] subset ] 2apply [ get-global " " split [ empty? not ] subset ] 2apply
seq-diff seq-diff
[ "bootstrap." swap append require ] each [ "bootstrap." swap append require ] each
] no-parse-hook
init-io
init-stdio
changed-words get clear-assoc
"compile-errors" "generator" lookup [
f swap set-global
] when*
run-bootstrap-init run-bootstrap-init
"Compiling remaining words..." print flush
all-words [ compiled? not ] subset recompile-hook get call
] with-compiler-errors
f error set-global f error set-global
f error-continuation set-global f error-continuation set-global
@ -82,11 +74,11 @@ IN: bootstrap.stage2
[ ] count-words " words total" print [ ] count-words " words total" print
"Bootstrapping is complete." print "Bootstrapping is complete." print
"Now, you can run ./factor -i=" write "Now, you can run Factor:" print
"output-image" get print flush vm write " -i=" write "output-image" get print flush
"output-image" get resource-path save-image-and-exit "output-image" get resource-path save-image-and-exit
] if ] if
] [ ] [
error-hook get call "listener" vocab-main execute error. :c "listener" vocab-main execute
] recover ] recover

3
core/bootstrap/syntax.factor
View File

@ -45,7 +45,6 @@ f swap set-vocab-source-loaded?
"TUPLE:" "TUPLE:"
"T{" "T{"
"UNION:" "UNION:"
"USE-IF:"
"USE:" "USE:"
"USING:" "USING:"
"V{" "V{"
@ -63,6 +62,8 @@ f swap set-vocab-source-loaded?
"{" "{"
"}" "}"
"CS{" "CS{"
"<<"
">>"
} [ "syntax" create drop ] each } [ "syntax" create drop ] each
"t" "syntax" lookup define-symbol "t" "syntax" lookup define-symbol

3
core/byte-arrays/byte-arrays-docs.factor Normal file → Executable file
View File

@ -1,5 +1,4 @@
USING: arrays bit-arrays vectors strings sbufs USING: help.markup help.syntax ;
kernel help.markup help.syntax ;
IN: byte-arrays IN: byte-arrays
ARTICLE: "byte-arrays" "Byte arrays" ARTICLE: "byte-arrays" "Byte arrays"

8
core/byte-arrays/byte-arrays.factor Normal file → Executable file
View File

@ -1,8 +1,8 @@
! Copyright (C) 2007 Slava Pestov. ! Copyright (C) 2007, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: kernel kernel.private alien sequences sequences.private
math ;
IN: byte-arrays IN: byte-arrays
USING: kernel kernel.private alien sequences
sequences.private math ;
M: byte-array clone (clone) ; M: byte-array clone (clone) ;
M: byte-array length array-capacity ; M: byte-array length array-capacity ;
@ -16,3 +16,5 @@ M: byte-array equal?
over byte-array? [ sequence= ] [ 2drop f ] if ; over byte-array? [ sequence= ] [ 2drop f ] if ;
INSTANCE: byte-array sequence INSTANCE: byte-array sequence
INSTANCE: byte-array simple-c-ptr
INSTANCE: byte-array c-ptr

2
core/classes/classes-docs.factor Normal file → Executable file
View File

@ -122,7 +122,7 @@ HELP: predicate-word
HELP: define-predicate HELP: define-predicate
{ $values { "class" class } { "predicate" "a predicate word" } { "quot" "a quotation" } } { $values { "class" class } { "predicate" "a predicate word" } { "quot" "a quotation" } }
{ $description { $description
"Defines a predicate word. This is identical to a compound definition associating " { $snippet "quot" } " with " { $snippet "predicate" } " with the added perk that three word properties are set:" "Defines a predicate word. This is identical to a word definition associating " { $snippet "quot" } " with " { $snippet "predicate" } " with the added perk that three word properties are set:"
{ $list { $list
{ "the class word's " { $snippet "\"predicate\"" } " property is set to a quotation that calls the predicate" } { "the class word's " { $snippet "\"predicate\"" } " property is set to a quotation that calls the predicate" }
{ "the predicate word's " { $snippet "\"predicating\"" } " property is set to the class word" } { "the predicate word's " { $snippet "\"predicating\"" } " property is set to the class word" }

56
core/classes/classes-tests.factor Normal file → Executable file
View File

@ -2,7 +2,7 @@ USING: alien arrays definitions generic assocs hashtables io
kernel math namespaces parser prettyprint sequences strings kernel math namespaces parser prettyprint sequences strings
tools.test vectors words quotations classes io.streams.string tools.test vectors words quotations classes io.streams.string
classes.private classes.union classes.mixin classes.predicate classes.private classes.union classes.mixin classes.predicate
vectors ; vectors definitions source-files ;
IN: temporary IN: temporary
H{ } "s" set H{ } "s" set
@ -36,8 +36,8 @@ UNION: both first-one union-class ;
[ f ] [ \ integer \ null class< ] unit-test [ f ] [ \ integer \ null class< ] unit-test
[ t ] [ \ null \ object class< ] unit-test [ t ] [ \ null \ object class< ] unit-test
[ t ] [ \ generic \ compound class< ] unit-test [ t ] [ \ generic \ word class< ] unit-test
[ f ] [ \ compound \ generic class< ] unit-test [ f ] [ \ word \ generic class< ] unit-test
[ f ] [ \ reversed \ slice class< ] unit-test [ f ] [ \ reversed \ slice class< ] unit-test
[ f ] [ \ slice \ reversed class< ] unit-test [ f ] [ \ slice \ reversed class< ] unit-test
@ -62,7 +62,7 @@ UNION: bah fixnum alien ;
[ bah ] [ \ bah? "predicating" word-prop ] unit-test [ bah ] [ \ bah? "predicating" word-prop ] unit-test
! Test generic see and parsing ! Test generic see and parsing
[ "IN: temporary\nSYMBOL: bah\n\nUNION: bah fixnum alien ;\n" ] [ "USING: alien math ;\nIN: temporary\nUNION: bah fixnum alien ;\n" ]
[ [ \ bah see ] string-out ] unit-test [ [ \ bah see ] string-out ] unit-test
! Test redefinition of classes ! Test redefinition of classes
@ -78,9 +78,7 @@ M: union-1 generic-update-test drop "union-1" ;
[ union-1 ] [ fixnum float class-or ] unit-test [ union-1 ] [ fixnum float class-or ] unit-test
"IN: temporary UNION: union-1 rational array ;" eval "IN: temporary USE: math USE: arrays UNION: union-1 rational array ;" eval
do-parse-hook
[ t ] [ bignum union-1 class< ] unit-test [ t ] [ bignum union-1 class< ] unit-test
[ f ] [ union-1 number class< ] unit-test [ f ] [ union-1 number class< ] unit-test
@ -88,9 +86,7 @@ do-parse-hook
[ object ] [ fixnum float class-or ] unit-test [ object ] [ fixnum float class-or ] unit-test
"IN: temporary PREDICATE: integer union-1 even? ;" eval "IN: temporary USE: math PREDICATE: integer union-1 even? ;" eval
do-parse-hook
[ f ] [ union-1 union-class? ] unit-test [ f ] [ union-1 union-class? ] unit-test
[ t ] [ union-1 predicate-class? ] unit-test [ t ] [ union-1 predicate-class? ] unit-test
@ -130,14 +126,14 @@ INSTANCE: integer mx1
[ t ] [ mx1 integer class< ] unit-test [ t ] [ mx1 integer class< ] unit-test
[ t ] [ mx1 number class< ] unit-test [ t ] [ mx1 number class< ] unit-test
"INSTANCE: array mx1" eval "IN: temporary USE: arrays INSTANCE: array mx1" eval
[ t ] [ array mx1 class< ] unit-test [ t ] [ array mx1 class< ] unit-test
[ f ] [ mx1 number class< ] unit-test [ f ] [ mx1 number class< ] unit-test
[ mx1 ] [ array integer class-or ] unit-test [ mx1 ] [ array integer class-or ] unit-test
\ mx1 forget [ \ mx1 forget ] with-compilation-unit
[ f ] [ array integer class-or mx1 = ] unit-test [ f ] [ array integer class-or mx1 = ] unit-test
@ -161,7 +157,7 @@ UNION: redefine-bug-2 redefine-bug-1 quotation ;
[ t ] [ quotation redefine-bug-2 class< ] unit-test [ t ] [ quotation redefine-bug-2 class< ] unit-test
[ redefine-bug-2 ] [ fixnum quotation class-or ] unit-test [ redefine-bug-2 ] [ fixnum quotation class-or ] unit-test
"IN: temporary UNION: redefine-bug-1 bignum ;" eval [ ] [ "IN: temporary USE: math UNION: redefine-bug-1 bignum ;" eval ] unit-test
[ t ] [ bignum redefine-bug-1 class< ] unit-test [ t ] [ bignum redefine-bug-1 class< ] unit-test
[ f ] [ fixnum redefine-bug-2 class< ] unit-test [ f ] [ fixnum redefine-bug-2 class< ] unit-test
@ -177,3 +173,37 @@ FORGET: forget-class-bug-1
FORGET: forget-class-bug-2 FORGET: forget-class-bug-2
[ t ] [ integer dll class-or interned? ] unit-test [ t ] [ integer dll class-or interned? ] unit-test
DEFER: mixin-forget-test-g
[ "mixin-forget-test" forget-source ] with-compilation-unit
[ ] [
{
"USING: sequences ;"
"IN: temporary"
"MIXIN: mixin-forget-test"
"INSTANCE: sequence mixin-forget-test"
"GENERIC: mixin-forget-test-g ( x -- y )"
"M: mixin-forget-test mixin-forget-test-g ;"
} "\n" join <string-reader> "mixin-forget-test"
parse-stream drop
] unit-test
[ { } ] [ { } mixin-forget-test-g ] unit-test
[ H{ } mixin-forget-test-g ] unit-test-fails
[ ] [
{
"USING: hashtables ;"
"IN: temporary"
"MIXIN: mixin-forget-test"
"INSTANCE: hashtable mixin-forget-test"
"GENERIC: mixin-forget-test-g ( x -- y )"
"M: mixin-forget-test mixin-forget-test-g ;"
} "\n" join <string-reader> "mixin-forget-test"
parse-stream drop
] unit-test
[ { } mixin-forget-test-g ] unit-test-fails
[ H{ } ] [ H{ } mixin-forget-test-g ] unit-test

18
core/classes/classes.factor Normal file → Executable file
View File

@ -27,8 +27,7 @@ PREDICATE: class tuple-class
: predicate-effect 1 { "?" } <effect> ; : predicate-effect 1 { "?" } <effect> ;
PREDICATE: compound predicate PREDICATE: word predicate "predicating" word-prop >boolean ;
"predicating" word-prop >boolean ;
: define-predicate ( class predicate quot -- ) : define-predicate ( class predicate quot -- )
over [ over [
@ -98,7 +97,7 @@ DEFER: (class<)
: union-class< ( cls1 cls2 -- ? ) : union-class< ( cls1 cls2 -- ? )
[ flatten-union-class ] 2apply keys [ flatten-union-class ] 2apply keys
[ nip [ (class<) ] curry* contains? ] curry assoc-all? ; [ nip [ (class<) ] with contains? ] curry assoc-all? ;
: (class<) ( class1 class2 -- ? ) : (class<) ( class1 class2 -- ? )
{ {
@ -124,7 +123,7 @@ DEFER: (class<)
: largest-class ( seq -- n elt ) : largest-class ( seq -- n elt )
dup [ dup [
[ 2dup class< >r swap class< not r> and ] [ 2dup class< >r swap class< not r> and ]
curry* subset empty? with subset empty?
] curry find [ "Topological sort failed" throw ] unless* ; ] curry find [ "Topological sort failed" throw ] unless* ;
PRIVATE> PRIVATE>
@ -157,7 +156,7 @@ PRIVATE>
[ dupd classes-intersect? ] subset dup empty? [ [ dupd classes-intersect? ] subset dup empty? [
2drop f 2drop f
] [ ] [
tuck [ class< ] curry* all? [ peek ] [ drop f ] if tuck [ class< ] with all? [ peek ] [ drop f ] if
] if ; ] if ;
GENERIC: reset-class ( class -- ) GENERIC: reset-class ( class -- )
@ -168,7 +167,7 @@ M: word reset-class drop ;
! class<map ! class<map
: bigger-classes ( class -- seq ) : bigger-classes ( class -- seq )
classes [ (class<) ] curry* subset ; classes [ (class<) ] with subset ;
: bigger-classes+ ( class -- ) : bigger-classes+ ( class -- )
[ bigger-classes [ dup ] H{ } map>assoc ] keep [ bigger-classes [ dup ] H{ } map>assoc ] keep
@ -240,8 +239,6 @@ M: word uncache-class drop ;
: uncache-classes ( assoc -- ) : uncache-classes ( assoc -- )
[ drop uncache-class ] assoc-each ; [ drop uncache-class ] assoc-each ;
GENERIC: update-methods ( class -- )
PRIVATE> PRIVATE>
: define-class-props ( members superclass metaclass -- assoc ) : define-class-props ( members superclass metaclass -- assoc )
@ -253,10 +250,13 @@ PRIVATE>
: (define-class) ( word props -- ) : (define-class) ( word props -- )
over reset-class over reset-class
over reset-generic
over define-symbol
>r dup word-props r> union over set-word-props >r dup word-props r> union over set-word-props
dup intern-symbol
t "class" set-word-prop ; t "class" set-word-prop ;
GENERIC: update-methods ( class -- )
: define-class ( word members superclass metaclass -- ) : define-class ( word members superclass metaclass -- )
#! If it was already a class, update methods after. #! If it was already a class, update methods after.
define-class-props define-class-props

20
core/classes/mixin/mixin-docs.factor Normal file → Executable file
View File

@ -1,4 +1,5 @@
USING: help.markup help.syntax ; USING: help.markup help.syntax help words compiler.units
classes ;
IN: classes.mixin IN: classes.mixin
ARTICLE: "mixins" "Mixin classes" ARTICLE: "mixins" "Mixin classes"
@ -11,4 +12,21 @@ ARTICLE: "mixins" "Mixin classes"
{ $subsection mixin-class } { $subsection mixin-class }
{ $subsection mixin-class? } ; { $subsection mixin-class? } ;
HELP: mixin-class
{ $class-description "The class of mixin classes." } ;
HELP: define-mixin-class
{ $values { "class" word } }
{ $description "Defines a mixin class. This is the run time equivalent of " { $link POSTPONE: MIXIN: } "." }
{ $notes "This word must be called from inside " { $link with-compilation-unit } "." }
{ $side-effects "class" } ;
HELP: add-mixin-instance
{ $values { "class" class } { "mixin" class } }
{ $description "Defines a class to be an instance of a mixin class. This is the run time equivalent of " { $link POSTPONE: INSTANCE: } "." }
{ $notes "This word must be called from inside " { $link with-compilation-unit } "." }
{ $side-effects "class" } ;
{ mixin-class define-mixin-class add-mixin-instance POSTPONE: MIXIN: POSTPONE: INSTANCE: } related-words
ABOUT: "mixins" ABOUT: "mixins"

63
core/classes/mixin/mixin.factor Normal file → Executable file
View File

@ -1,6 +1,7 @@
! Copyright (C) 2004, 2007 Slava Pestov. ! Copyright (C) 2004, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: classes classes.union words kernel sequences ; USING: classes classes.union words kernel sequences
definitions combinators arrays ;
IN: classes.mixin IN: classes.mixin
PREDICATE: union-class mixin-class "mixin" word-prop ; PREDICATE: union-class mixin-class "mixin" word-prop ;
@ -19,11 +20,55 @@ M: mixin-class reset-class
{ } redefine-mixin-class { } redefine-mixin-class
] if ; ] if ;
TUPLE: check-mixin-class mixin ;
: check-mixin-class ( mixin -- mixin )
dup mixin-class? [
\ check-mixin-class construct-boa throw
] unless ;
: if-mixin-member? ( class mixin true false -- )
>r >r check-mixin-class 2dup members memq? r> r> if ; inline
: change-mixin-class ( class mixin quot -- )
[ members swap bootstrap-word ] swap compose keep
swap redefine-mixin-class ; inline
: add-mixin-instance ( class mixin -- ) : add-mixin-instance ( class mixin -- )
dup mixin-class? [ "Not a mixin class" throw ] unless [ 2drop ] [ [ add ] change-mixin-class ] if-mixin-member? ;
2dup members memq? [
2drop : remove-mixin-instance ( class mixin -- )
] [ [ [ swap remove ] change-mixin-class ] [ 2drop ] if-mixin-member? ;
[ members swap bootstrap-word add ] keep swap
redefine-mixin-class ! Definition protocol implementation ensures that removing an
] if ; ! INSTANCE: declaration from a source file updates the mixin.
TUPLE: mixin-instance loc class mixin ;
M: mixin-instance equal?
{
{ [ over mixin-instance? not ] [ f ] }
{ [ 2dup [ mixin-instance-class ] 2apply = not ] [ f ] }
{ [ 2dup [ mixin-instance-mixin ] 2apply = not ] [ f ] }
{ [ t ] [ t ] }
} cond 2nip ;
M: mixin-instance hashcode*
{ mixin-instance-class mixin-instance-mixin } get-slots
2array hashcode* ;
: <mixin-instance> ( class mixin -- definition )
{ set-mixin-instance-class set-mixin-instance-mixin }
mixin-instance construct ;
M: mixin-instance where mixin-instance-loc ;
M: mixin-instance set-where set-mixin-instance-loc ;
M: mixin-instance definer drop \ INSTANCE: f ;
M: mixin-instance definition drop f ;
M: mixin-instance forget*
dup mixin-instance-class
swap mixin-instance-mixin dup mixin-class?
[ remove-mixin-instance ] [ 2drop ] if ;

6
core/classes/predicate/predicate-docs.factor Normal file → Executable file
View File

@ -1,6 +1,6 @@
USING: generic help.markup help.syntax kernel kernel.private USING: generic help.markup help.syntax kernel kernel.private
namespaces sequences words arrays layouts help effects math namespaces sequences words arrays layouts help effects math
layouts classes.private classes ; layouts classes.private classes compiler.units ;
IN: classes.predicate IN: classes.predicate
ARTICLE: "predicates" "Predicate classes" ARTICLE: "predicates" "Predicate classes"
@ -15,7 +15,9 @@ ABOUT: "predicates"
HELP: define-predicate-class HELP: define-predicate-class
{ $values { "superclass" class } { "class" class } { "definition" "a quotation with stack effect " { $snippet "( superclass -- ? )" } } } { $values { "superclass" class } { "class" class } { "definition" "a quotation with stack effect " { $snippet "( superclass -- ? )" } } }
{ $description "Defines a predicate class." } ; { $description "Defines a predicate class. This is the run time equivalent of " { $link POSTPONE: PREDICATE: } "." }
{ $notes "This word must be called from inside " { $link with-compilation-unit } "." }
{ $side-effects "class" } ;
{ predicate-class define-predicate-class POSTPONE: PREDICATE: } related-words { predicate-class define-predicate-class POSTPONE: PREDICATE: } related-words

6
core/classes/union/union-docs.factor Normal file → Executable file
View File

@ -1,6 +1,6 @@
USING: generic help.markup help.syntax kernel kernel.private USING: generic help.markup help.syntax kernel kernel.private
namespaces sequences words arrays layouts help effects math namespaces sequences words arrays layouts help effects math
layouts classes.private classes ; layouts classes.private classes compiler.units ;
IN: classes.union IN: classes.union
ARTICLE: "unions" "Union classes" ARTICLE: "unions" "Union classes"
@ -17,7 +17,9 @@ ABOUT: "unions"
HELP: define-union-class HELP: define-union-class
{ $values { "class" class } { "members" "a sequence of classes" } } { $values { "class" class } { "members" "a sequence of classes" } }
{ $description "Defines a union class with specified members." } ; { $description "Defines a union class with specified members. This is the run time equivalent of " { $link POSTPONE: UNION: } "." }
{ $notes "This word must be called from inside " { $link with-compilation-unit } "." }
{ $side-effects "class" } ;
{ union-class define-union-class POSTPONE: UNION: } related-words { union-class define-union-class POSTPONE: UNION: } related-words

4
core/combinators/combinators.factor
View File

@ -63,13 +63,13 @@ M: sequence hashcode*
next-power-of-2 swap [ nip clone ] curry map ; next-power-of-2 swap [ nip clone ] curry map ;
: distribute-buckets ( assoc initial quot -- buckets ) : distribute-buckets ( assoc initial quot -- buckets )
swap rot [ length <buckets> ] keep spin [ length <buckets> ] keep
[ >r 2dup r> dup first roll call (distribute-buckets) ] each [ >r 2dup r> dup first roll call (distribute-buckets) ] each
nip ; inline nip ; inline
: hash-case-table ( default assoc -- array ) : hash-case-table ( default assoc -- array )
V{ } [ 1array ] distribute-buckets V{ } [ 1array ] distribute-buckets
[ case>quot ] curry* map ; [ case>quot ] with map ;
: hash-dispatch-quot ( table -- quot ) : hash-dispatch-quot ( table -- quot )
[ length 1- [ fixnum-bitand ] curry ] keep [ length 1- [ fixnum-bitand ] curry ] keep

119
core/compiler/compiler-docs.factor Normal file → Executable file
View File

@ -3,29 +3,14 @@ assocs words.private sequences ;
IN: compiler IN: compiler
ARTICLE: "compiler-usage" "Calling the optimizing compiler" ARTICLE: "compiler-usage" "Calling the optimizing compiler"
"The main entry point to the optimizing compiler is a single word taking a word as input:" "The main entry points to the optimizing compiler:"
{ $subsection compile } { $subsection compile }
"The above word throws an error if the word did not compile. Another variant simply prints the error and returns:"
{ $subsection try-compile }
"The optimizing compiler can also compile a single quotation:"
{ $subsection compile-quot }
{ $subsection compile-1 }
"Three utility words for bulk compilation:"
{ $subsection compile-batch }
{ $subsection compile-vocabs }
{ $subsection compile-all }
"Bulk compilation saves compile warnings and errors in a global variable, instead of printing them as they arise:"
{ $subsection compile-errors }
"The warnings and errors can be viewed later:"
{ $subsection :warnings }
{ $subsection :errors }
{ $subsection forget-errors } ;
ARTICLE: "recompile" "Automatic recompilation"
"When a word is redefined, you can recompile all affected words automatically:"
{ $subsection recompile } { $subsection recompile }
"Normally loading a source file or a module also calls " { $link recompile } ". This can be disabled by wrapping file loading in a combinator:" { $subsection recompile-all }
{ $subsection no-parse-hook } ; "Removing a word's optimized definition:"
{ $subsection decompile }
"The optimizing compiler can also compile and call a single quotation:"
{ $subsection compile-call } ;
ARTICLE: "compiler" "Optimizing compiler" ARTICLE: "compiler" "Optimizing compiler"
"Factor is a fully compiled language implementation with two distinct compilers:" "Factor is a fully compiled language implementation with two distinct compilers:"
@ -33,107 +18,33 @@ ARTICLE: "compiler" "Optimizing compiler"
{ "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 "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 " { $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." }
} }
"While the quotation compiler is transparent to the developer, the optimizing compiler is invoked explicitly. It differs in two important ways from the non-optimizing compiler:" "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; for otherwise, most of the system would be compiled with the non-optimizing compiler. See " { $link "inference" } " and " { $link "cookbook-pitfalls" } "."
{ $list
{ "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; for otherwise, most of the system would be compiled with the non-optimizing compiler. See " { $link "inference" } " and " { $link "cookbook-pitfalls" } "." }
{ "The optimizing compiler performs " { $emphasis "early binding" } "; if a compiled word " { $snippet "A" } " calls another compiled word " { $snippet "B" } " and " { $snippet "B" } " is subsequently redefined, the compiled definition of " { $snippet "A" } " will still refer to the earlier compiled definition of " { $snippet "B" } ", until " { $snippet "A" } " explicitly recompiled." }
}
{ $subsection "compiler-usage" } { $subsection "compiler-usage" }
{ $subsection "recompile" } ; { $subsection "compiler-errors" } ;
ABOUT: "compiler" ABOUT: "compiler"
HELP: compile-error
{ $values { "word" word } { "error" "an error" } }
{ $description "If inside a " { $link compile-batch } ", saves the error for future persual via " { $link :errors } " and " { $link :warnings } ", otherwise reports the error to the " { $link stdio } " stream." } ;
HELP: begin-batch
{ $values { "seq" "a sequence of words" } }
{ $description "Begins batch compilation. Any compile errors reported until a call to " { $link end-batch } " are stored in the " { $link compile-errors } " global variable." }
$low-level-note ;
HELP: compile-error.
{ $values { "pair" "a " { $snippet "{ word error }" } " pair" } }
{ $description "Prints a compiler error to the " { $link stdio } " stream." } ;
HELP: (:errors)
{ $values { "seq" "an alist" } }
{ $description "Outputs all serious compiler errors from the most recent compile batch as a sequence of " { $snippet "{ word error }" } " pairs." } ;
HELP: :errors
{ $description "Prints all serious compiler errors from the most recent compile batch to the " { $link stdio } " stream." } ;
HELP: (:warnings)
{ $values { "seq" "an alist" } }
{ $description "Outputs all ignorable compiler warnings from the most recent compile batch as a sequence of " { $snippet "{ word error }" } " pairs." } ;
HELP: :warnings
{ $description "Prints all ignorable compiler warnings from the most recent compile batch to the " { $link stdio } " stream." } ;
HELP: end-batch
{ $description "Ends batch compilation, printing a summary of the errors and warnings produced to the " { $link stdio } " stream." }
$low-level-note ;
HELP: compile HELP: compile
{ $values { "word" word } }
{ $description "Compiles a word together with any uncompiled dependencies. Does nothing if the word is already compiled." }
{ $errors "If compilation fails, this word can throw an error. In particular, if the word's stack effect cannot be inferred, this word will throw an error. The related " { $link try-compile } " word logs errors and returns rather than throwing." } ;
HELP: compile-failed
{ $values { "word" word } { "error" "an error" } }
{ $description "Called when the optimizing compiler fails to compile a word. The word is removed from the set of words pending compilation, and it's un-optimized compiled definition will be used. The error is reported by calling " { $link compile-error } "." } ;
HELP: try-compile
{ $values { "word" word } }
{ $description "Compiles a word together with any uncompiled dependencies. Does nothing if the word is already compiled." }
{ $errors "If compilation fails, this calls " { $link compile-failed } "." } ;
HELP: forget-errors
{ $values { "seq" "a sequence of words" } } { $values { "seq" "a sequence of words" } }
{ $description "If any of the words in the sequence previously failed to compile, removes the marker indicating such." { $description "Compiles a set of words. Ignores words which are already compiled." } ;
$nl
"The compiler remembers which words failed to compile as an optimization, so that it does not try to infer the stack effect of words which do not have one over and over again." }
{ $notes "Usually this word does not need to be called directly; if a word failed to compile because of a stack effect error, fixing the word definition clears the flag automatically. However, if words failed to compile due to external factors which were subsequently rectified, such as an unavailable C library or a missing or broken compiler transform, this flag can be cleared for all words:"
{ $code "all-words forget-errors" }
"Subsequent invocations of the compiler will consider all words for compilation." } ;
HELP: compile-batch HELP: recompile
{ $values { "seq" "a sequence of words" } } { $values { "seq" "a sequence of words" } }
{ $description "Compiles a batch of words. Any compile errors are summarized at the end and can be viewed with " { $link :warnings } " and " { $link :errors } "." } ; { $description "Compiles a set of words. Re-compiles words which are already compiled." } ;
{ :errors (:errors) :warnings (:warnings) } related-words HELP: compile-call
HELP: compile-vocabs
{ $values { "seq" "a sequence of strings" } }
{ $description "Compiles all words which have not been compiled yet from the given vocabularies." } ;
HELP: compile-quot
{ $values { "quot" "a quotation" } { "word" "a new, uninterned word" } }
{ $description "Creates a new uninterned word having the given quotation as its definition, and compiles it. The returned word can be passed to " { $link execute } "." }
{ $errors "Throws an error if the stack effect of the quotation cannot be inferred." } ;
HELP: compile-1
{ $values { "quot" "a quotation" } } { $values { "quot" "a quotation" } }
{ $description "Compiles and runs a quotation." } { $description "Compiles and runs a quotation." }
{ $errors "Throws an error if the stack effect of the quotation cannot be inferred." } ; { $errors "Throws an error if the stack effect of the quotation cannot be inferred." } ;
HELP: recompile
{ $description "Recompiles words whose compiled definitions have become out of date as a result of dependent words being redefined." } ;
HELP: compile-all
{ $description "Compiles all words which have not been compiled yet." } ;
HELP: recompile-all HELP: recompile-all
{ $description "Recompiles all words." } ; { $description "Recompiles all words." } ;
HELP: changed-words HELP: decompile
{ $var-description "Global variable holding words which need to be recompiled. Implemented as a hashtable where a key equals its value. This hashtable is updated by " { $link define } " when words are redefined, and inspected and cleared by " { $link recompile } "." } ;
HELP: compile-begins
{ $values { "word" word } } { $values { "word" word } }
{ $description "Prints a message stating the word is being compiled, unless we are inside a " { $link compile-batch } "." } ; { $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)
{ $values { "word" word } } { $values { "word" word } }
{ $description "Compile a word. This word recursively calls itself to compile all dependencies." } { $description "Compile a single word." }
{ $notes "This is an internal word, and user code should call " { $link compile } " instead." } ; { $notes "This is an internal word, and user code should call " { $link compile } " instead." } ;

148
core/compiler/compiler.factor Normal file → Executable file
View File

@ -1,93 +1,103 @@
! Copyright (C) 2004, 2007 Slava Pestov. ! Copyright (C) 2004, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: kernel namespaces arrays sequences io inference.backend USING: kernel namespaces arrays sequences io inference.backend
generator debugger math.parser prettyprint words continuations inference.state generator debugger math.parser prettyprint words
vocabs assocs alien.compiler ; compiler.units continuations vocabs assocs alien.compiler dlists
optimizer definitions math compiler.errors threads graphs
generic ;
IN: compiler IN: compiler
M: object inference-error-major? drop t ; SYMBOL: compiled-crossref
: compile-error ( word error -- ) compiled-crossref global [ H{ } assoc-like ] change-at
batch-mode get [
2array compile-errors get push
] [
"quiet" get [ drop ] [ print-error flush ] if drop
] if ;
: begin-batch ( seq -- ) : compiled-xref ( word dependencies -- )
batch-mode on 2dup "compiled-uses" set-word-prop
"quiet" get [ drop ] [ compiled-crossref get add-vertex ;
[ "Compiling " % length # " words..." % ] "" make
print flush
] if
V{ } clone compile-errors set-global ;
: compile-error. ( pair -- ) : compiled-unxref ( word -- )
nl dup "compiled-uses" word-prop
"While compiling " write dup first pprint ": " print compiled-crossref get remove-vertex ;
nl
second print-error ;
: (:errors) ( -- seq ) : compiled-usage ( word -- seq )
compile-errors get-global compiled-crossref get at keys ;
[ second inference-error-major? ] subset ;
: :errors (:errors) [ compile-error. ] each ; : sensitive? ( word -- ? )
dup "inline" word-prop
over "infer" word-prop
pick "specializer" word-prop
roll generic?
or or or ;
: (:warnings) ( -- seq ) : compiled-usages ( words -- seq )
compile-errors get-global compiled-crossref get [
[ second inference-error-major? not ] subset ; [
over dup set
over sensitive?
[ at namespace swap update ] [ 2drop ] if
] curry each
] H{ } make-assoc keys ;
: :warnings (:warnings) [ compile-error. ] each ; : ripple-up ( word -- )
compiled-usage [ queue-compile ] each ;
: end-batch ( -- ) : save-effect ( word effect -- )
batch-mode off over "compiled-uses" word-prop [
"quiet" get [ 2dup swap "compiled-effect" word-prop =
"Compile finished." print [ over ripple-up ] unless
nl ] when
":errors - print " write (:errors) length pprint "compiled-effect" set-word-prop ;
" compiler errors." print
":warnings - print " write (:warnings) length pprint
" compiler warnings." print
nl
] unless ;
: compile ( word -- ) : finish-compile ( word effect dependencies -- )
H{ } clone [ >r dupd save-effect r>
compiled-xts [ (compile) ] with-variable f pick compiler-error
] keep >alist finalize-compile ; over compiled-unxref
compiled-xref ;
: compile-succeeded ( word -- effect dependencies )
[
dup word-dataflow >r swap dup r> optimize generate
] computing-dependencies ;
: compile-failed ( word error -- ) : compile-failed ( word error -- )
dupd compile-error dup update-xt unchanged-word ; ! dup inference-error? [ rethrow ] unless
f pick compiled get set-at
swap compiler-error ;
: try-compile ( word -- ) : (compile) ( word -- )
[ compile ] [ compile-failed ] recover ; [ dup compile-succeeded finish-compile ]
[ dupd compile-failed f save-effect ]
recover ;
: forget-errors ( seq -- ) : delete-any ( assoc -- element )
[ f "no-effect" set-word-prop ] each ; [ [ 2drop t ] assoc-find 2drop dup ] keep delete-at ;
: compile-batch ( seq -- ) : compile-loop ( assoc -- )
dup empty? [ dup assoc-empty? [ drop ] [
drop dup delete-any (compile)
] [ yield
dup begin-batch compile-loop
dup forget-errors
[ try-compile ] each
end-batch
] if ; ] if ;
: compile-vocabs ( seq -- ) [ words ] map concat compile-batch ; : recompile ( words -- )
[
H{ } clone compile-queue set
H{ } clone compiled set
[ queue-compile ] each
compile-queue get compile-loop
compiled get >alist modify-code-heap
] with-scope ; inline
: compile-all ( -- ) vocabs compile-vocabs ; : compile ( words -- )
[ compiled? not ] subset recompile ;
: compile-quot ( quot -- word ) define-temp dup compile ; : compile-call ( quot -- )
H{ } clone changed-words
: compile-1 ( quot -- ) compile-quot execute ; [ define-temp dup 1array compile ] with-variable
execute ;
: recompile ( -- )
changed-words get [
dup keys compile-batch clear-assoc
] when* ;
: recompile-all ( -- ) : recompile-all ( -- )
all-words [ changed-word ] each recompile ; [ all-words recompile ] with-compiler-errors ;
: decompile ( word -- )
f 2array 1array modify-code-heap ;

22
core/compiler/constants/constants.factor Executable file
View File

@ -0,0 +1,22 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: math kernel layouts system ;
IN: compiler.constants
! These constants must match vm/memory.h
: card-bits 6 ;
: card-mark HEX: 40 HEX: 80 bitor ;
! These constants must match vm/layouts.h
: header-offset object tag-number neg ;
: float-offset 8 float tag-number - ;
: string-offset 3 bootstrap-cells object tag-number - ;
: profile-count-offset 7 bootstrap-cells object tag-number - ;
: byte-array-offset 2 bootstrap-cells object tag-number - ;
: alien-offset 3 bootstrap-cells object tag-number - ;
: underlying-alien-offset bootstrap-cell object tag-number - ;
: tuple-class-offset 2 bootstrap-cells tuple tag-number - ;
: class-hash-offset bootstrap-cell object tag-number - ;
: word-xt-offset 8 bootstrap-cells object tag-number - ;
: word-code-offset 9 bootstrap-cells object tag-number - ;
: compiled-header-size 8 bootstrap-cells ;

48
core/compiler/errors/errors-docs.factor Executable file
View File

@ -0,0 +1,48 @@
IN: compiler.errors
USING: help.markup help.syntax vocabs.loader words io
quotations ;
ARTICLE: "compiler-errors" "Compiler warnings and errors"
"The compiler saves compile warnings and errors in a global variable:"
{ $subsection compiler-errors }
"The warnings and errors can be viewed later:"
{ $subsection :warnings }
{ $subsection :errors }
"Normally, all warnings and errors are displayed at the end of a batch compilation, such as a call to " { $link require } " or " { $link refresh-all } ". This can be controlled with a combinator:"
{ $link with-compiler-errors } ;
HELP: compiler-errors
{ $var-description "Global variable holding an assoc mapping words to compiler errors. This variable is set by " { $link with-compiler-errors } "." } ;
HELP: compiler-error
{ $values { "error" "an error" } { "word" word } }
{ $description "If inside a " { $link with-compiler-errors } ", saves the error for future persual via " { $link :errors } " and " { $link :warnings } ", otherwise ignores the error." } ;
HELP: compiler-error.
{ $values { "error" "an error" } { "word" word } }
{ $description "Prints a compiler error to the " { $link stdio } " stream." } ;
HELP: compiler-errors.
{ $values { "errors" "an assoc mapping words to errors" } }
{ $description "Prints a set of compiler errors to the " { $link stdio } " stream." } ;
HELP: (:errors)
{ $values { "seq" "an alist" } }
{ $description "Outputs all serious compiler errors from the most recent compile." } ;
HELP: :errors
{ $description "Prints all serious compiler errors from the most recent compile to the " { $link stdio } " stream." } ;
HELP: (:warnings)
{ $values { "seq" "an alist" } }
{ $description "Outputs all ignorable compiler warnings from the most recent compile." } ;
HELP: :warnings
{ $description "Prints all ignorable compiler warnings from the most recent compile to the " { $link stdio } " stream." } ;
{ :errors (:errors) :warnings (:warnings) } related-words
HELP: with-compiler-errors
{ $values { "quot" quotation } }
{ $description "Calls the quotation and collects any compiler warnings and errors. Compiler warnings and errors are summarized at the end and can be viewed with " { $link :warnings } " and " { $link :errors } "." }
{ $notes "Nested calls to " { $link with-compiler-errors } " are ignored, and only the outermost call collects warnings and errors." } ;

59
core/compiler/errors/errors.factor Executable file
View File

@ -0,0 +1,59 @@
! Copyright (C) 2007, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel namespaces assocs prettyprint io sequences
sorting continuations debugger math ;
IN: compiler.errors
SYMBOL: compiler-errors
SYMBOL: with-compiler-errors?
: compiler-error ( error word -- )
with-compiler-errors? get [
compiler-errors get pick
[ set-at ] [ delete-at drop ] if
] [ 2drop ] if ;
: compiler-error. ( error word -- )
nl
"While compiling " write pprint ": " print
nl
print-error ;
: compiler-errors. ( assoc -- )
>alist sort-keys [ swap compiler-error. ] assoc-each ;
GENERIC: compiler-warning? ( error -- ? )
M: object compiler-warning? drop f ;
: (:errors) ( -- assoc )
compiler-errors get-global
[ nip compiler-warning? not ] assoc-subset ;
: :errors (:errors) compiler-errors. ;
: (:warnings) ( -- seq )
compiler-errors get-global
[ nip compiler-warning? ] assoc-subset ;
: :warnings (:warnings) compiler-errors. ;
: (compiler-report) ( what assoc -- )
length dup zero? [ 2drop ] [
":" write over write " - print " write pprint
" compiler " write write "." print
] if ;
: compiler-report ( -- )
"errors" (:errors) (compiler-report)
"warnings" (:warnings) (compiler-report) ;
: with-compiler-errors ( quot -- )
with-compiler-errors? get "quiet" get or [ call ] [
[
with-compiler-errors? on
V{ } clone compiler-errors set-global
[ compiler-report ] [ ] cleanup
] with-scope
] if ; inline

6
core/compiler/test/alien.factor
View File

@ -99,12 +99,6 @@ unit-test
"int" { "int" "int" "int" "int" } "stdcall" alien-indirect "int" { "int" "int" "int" "int" } "stdcall" alien-indirect
data-gc ; data-gc ;
! This is a hack -- words are compiled before top-level forms
! run.
DEFER: >> delimiter
: << \ >> parse-until >quotation call ; parsing
<< "f-stdcall" f "stdcall" add-library >> << "f-stdcall" f "stdcall" add-library >>
[ f ] [ "f-stdcall" load-library ] unit-test [ f ] [ "f-stdcall" load-library ] unit-test

48
core/compiler/test/curry.factor
View File

@ -2,43 +2,43 @@ USING: tools.test compiler quotations math kernel sequences
assocs namespaces ; assocs namespaces ;
IN: temporary IN: temporary
[ 3 ] [ 5 [ [ 2 - ] curry call ] compile-1 ] unit-test [ 3 ] [ 5 [ [ 2 - ] curry call ] compile-call ] unit-test
[ 3 ] [ [ 5 [ 2 - ] curry call ] compile-1 ] unit-test [ 3 ] [ [ 5 [ 2 - ] curry call ] compile-call ] unit-test
[ 3 ] [ [ 5 2 [ - ] 2curry call ] compile-1 ] unit-test [ 3 ] [ [ 5 2 [ - ] 2curry call ] compile-call ] unit-test
[ 3 ] [ 5 [ 2 [ - ] 2curry call ] compile-1 ] unit-test [ 3 ] [ 5 [ 2 [ - ] 2curry call ] compile-call ] unit-test
[ 3 ] [ 5 2 [ [ - ] 2curry call ] compile-1 ] unit-test [ 3 ] [ 5 2 [ [ - ] 2curry call ] compile-call ] unit-test
[ 3 ] [ 5 2 [ [ - ] 2curry 9 swap call /i ] compile-1 ] unit-test [ 3 ] [ 5 2 [ [ - ] 2curry 9 swap call /i ] compile-call ] unit-test
[ 3 ] [ 5 2 [ [ - ] 2curry >r 9 r> call /i ] compile-1 ] unit-test [ 3 ] [ 5 2 [ [ - ] 2curry >r 9 r> call /i ] compile-call ] unit-test
[ -10 -20 ] [ 10 20 -1 [ [ * ] curry 2apply ] compile-1 ] unit-test [ -10 -20 ] [ 10 20 -1 [ [ * ] curry 2apply ] compile-call ] unit-test
[ [ 5 2 - ] ] [ 5 [ [ 2 - ] curry ] compile-1 >quotation ] unit-test [ [ 5 2 - ] ] [ 5 [ [ 2 - ] curry ] compile-call >quotation ] unit-test
[ [ 5 2 - ] ] [ [ 5 [ 2 - ] curry ] compile-1 >quotation ] unit-test [ [ 5 2 - ] ] [ [ 5 [ 2 - ] curry ] compile-call >quotation ] unit-test
[ [ 5 2 - ] ] [ [ 5 2 [ - ] 2curry ] compile-1 >quotation ] unit-test [ [ 5 2 - ] ] [ [ 5 2 [ - ] 2curry ] compile-call >quotation ] unit-test
[ [ 5 2 - ] ] [ 5 [ 2 [ - ] 2curry ] compile-1 >quotation ] unit-test [ [ 5 2 - ] ] [ 5 [ 2 [ - ] 2curry ] compile-call >quotation ] unit-test
[ [ 5 2 - ] ] [ 5 2 [ [ - ] 2curry ] compile-1 >quotation ] unit-test [ [ 5 2 - ] ] [ 5 2 [ [ - ] 2curry ] compile-call >quotation ] unit-test
[ [ 6 2 + ] ] [ [ 6 2 + ] ]
[ [
2 5 2 5
[ >r [ + ] curry r> 0 < [ -2 ] [ 6 ] if swap curry ] [ >r [ + ] curry r> 0 < [ -2 ] [ 6 ] if swap curry ]
compile-1 >quotation compile-call >quotation
] unit-test ] unit-test
[ 8 ] [ 8 ]
[ [
2 5 2 5
[ >r [ + ] curry r> 0 < [ -2 ] [ 6 ] if swap curry call ] [ >r [ + ] curry r> 0 < [ -2 ] [ 6 ] if swap curry call ]
compile-1 compile-call
] unit-test ] unit-test
: foobar ( quot -- ) : foobar ( quot -- )
dup slip swap [ foobar ] [ drop ] if ; inline dup slip swap [ foobar ] [ drop ] if ; inline
[ ] [ [ [ f ] foobar ] compile-1 ] unit-test [ ] [ [ [ f ] foobar ] compile-call ] unit-test
[ { 6 7 8 } ] [ { 1 2 3 } 5 [ [ + ] curry map ] compile-1 ] unit-test [ { 6 7 8 } ] [ { 1 2 3 } 5 [ [ + ] curry map ] compile-call ] unit-test
[ { 6 7 8 } ] [ { 1 2 3 } [ 5 [ + ] curry map ] compile-1 ] unit-test [ { 6 7 8 } ] [ { 1 2 3 } [ 5 [ + ] curry map ] compile-call ] unit-test
: funky-assoc>map : funky-assoc>map
[ [
@ -46,16 +46,16 @@ IN: temporary
] { } make ; inline ] { } make ; inline
[ t ] [ [ t ] [
global [ [ drop , ] funky-assoc>map ] compile-1 global [ [ drop , ] funky-assoc>map ] compile-call
global keys = global keys =
] unit-test ] unit-test
[ 3 ] [ 1 [ 2 ] [ curry [ 3 ] [ 4 ] if ] compile-1 ] unit-test [ 3 ] [ 1 [ 2 ] [ curry [ 3 ] [ 4 ] if ] compile-call ] unit-test
[ 3 ] [ t [ 3 [ ] curry 4 [ ] curry if ] compile-1 ] unit-test [ 3 ] [ t [ 3 [ ] curry 4 [ ] curry if ] compile-call ] unit-test
[ 3 ] [ t [ 3 [ ] curry [ 4 ] if ] compile-1 ] unit-test [ 3 ] [ t [ 3 [ ] curry [ 4 ] if ] compile-call ] unit-test
[ 4 ] [ f [ 3 [ ] curry 4 [ ] curry if ] compile-1 ] unit-test [ 4 ] [ f [ 3 [ ] curry 4 [ ] curry if ] compile-call ] unit-test
[ 4 ] [ f [ [ 3 ] 4 [ ] curry if ] compile-1 ] unit-test [ 4 ] [ f [ [ 3 ] 4 [ ] curry if ] compile-call ] unit-test

134
core/compiler/test/float.factor Normal file → Executable file
View File

@ -2,84 +2,84 @@ IN: temporary
USING: compiler kernel kernel.private memory math USING: compiler kernel kernel.private memory math
math.private tools.test math.floats.private ; math.private tools.test math.floats.private ;
[ 5.0 ] [ [ 5.0 ] compile-1 data-gc data-gc data-gc ] unit-test [ 5.0 ] [ [ 5.0 ] compile-call data-gc data-gc data-gc ] unit-test
[ 2.0 3.0 ] [ 3.0 [ 2.0 swap ] compile-1 ] unit-test [ 2.0 3.0 ] [ 3.0 [ 2.0 swap ] compile-call ] unit-test
[ 1 2 3 4.0 ] [ [ 1 2 3 4.0 ] compile-1 ] unit-test [ 1 2 3 4.0 ] [ [ 1 2 3 4.0 ] compile-call ] unit-test
[ 3.0 1 2 3 ] [ 1.0 2.0 [ float+ 1 2 3 ] compile-1 ] unit-test [ 3.0 1 2 3 ] [ 1.0 2.0 [ float+ 1 2 3 ] compile-call ] unit-test
[ 5 ] [ 1.0 [ 2.0 float+ tag ] compile-1 ] unit-test [ 5 ] [ 1.0 [ 2.0 float+ tag ] compile-call ] unit-test
[ 3.0 ] [ 1.0 [ 2.0 float+ ] compile-1 ] unit-test [ 3.0 ] [ 1.0 [ 2.0 float+ ] compile-call ] unit-test
[ 3.0 ] [ 1.0 [ 2.0 swap float+ ] compile-1 ] unit-test [ 3.0 ] [ 1.0 [ 2.0 swap float+ ] compile-call ] unit-test
[ 3.0 ] [ 1.0 2.0 [ float+ ] compile-1 ] unit-test [ 3.0 ] [ 1.0 2.0 [ float+ ] compile-call ] unit-test
[ 3.0 ] [ 1.0 2.0 [ swap float+ ] compile-1 ] unit-test [ 3.0 ] [ 1.0 2.0 [ swap float+ ] compile-call ] unit-test
[ -1.0 ] [ 1.0 [ 2.0 float- ] compile-1 ] unit-test [ -1.0 ] [ 1.0 [ 2.0 float- ] compile-call ] unit-test
[ 1.0 ] [ 1.0 [ 2.0 swap float- ] compile-1 ] unit-test [ 1.0 ] [ 1.0 [ 2.0 swap float- ] compile-call ] unit-test
[ -1.0 ] [ 1.0 2.0 [ float- ] compile-1 ] unit-test [ -1.0 ] [ 1.0 2.0 [ float- ] compile-call ] unit-test
[ 1.0 ] [ 1.0 2.0 [ swap float- ] compile-1 ] unit-test [ 1.0 ] [ 1.0 2.0 [ swap float- ] compile-call ] unit-test
[ 6.0 ] [ 3.0 [ 2.0 float* ] compile-1 ] unit-test [ 6.0 ] [ 3.0 [ 2.0 float* ] compile-call ] unit-test
[ 6.0 ] [ 3.0 [ 2.0 swap float* ] compile-1 ] unit-test [ 6.0 ] [ 3.0 [ 2.0 swap float* ] compile-call ] unit-test
[ 6.0 ] [ 3.0 2.0 [ float* ] compile-1 ] unit-test [ 6.0 ] [ 3.0 2.0 [ float* ] compile-call ] unit-test
[ 6.0 ] [ 3.0 2.0 [ swap float* ] compile-1 ] unit-test [ 6.0 ] [ 3.0 2.0 [ swap float* ] compile-call ] unit-test
[ 0.5 ] [ 1.0 [ 2.0 float/f ] compile-1 ] unit-test [ 0.5 ] [ 1.0 [ 2.0 float/f ] compile-call ] unit-test
[ 2.0 ] [ 1.0 [ 2.0 swap float/f ] compile-1 ] unit-test [ 2.0 ] [ 1.0 [ 2.0 swap float/f ] compile-call ] unit-test
[ 0.5 ] [ 1.0 2.0 [ float/f ] compile-1 ] unit-test [ 0.5 ] [ 1.0 2.0 [ float/f ] compile-call ] unit-test
[ 2.0 ] [ 1.0 2.0 [ swap float/f ] compile-1 ] unit-test [ 2.0 ] [ 1.0 2.0 [ swap float/f ] compile-call ] unit-test
[ t ] [ 1.0 2.0 [ float< ] compile-1 ] unit-test [ t ] [ 1.0 2.0 [ float< ] compile-call ] unit-test
[ t ] [ 1.0 [ 2.0 float< ] compile-1 ] unit-test [ t ] [ 1.0 [ 2.0 float< ] compile-call ] unit-test
[ f ] [ 1.0 [ 2.0 swap float< ] compile-1 ] unit-test [ f ] [ 1.0 [ 2.0 swap float< ] compile-call ] unit-test
[ f ] [ 1.0 1.0 [ float< ] compile-1 ] unit-test [ f ] [ 1.0 1.0 [ float< ] compile-call ] unit-test
[ f ] [ 1.0 [ 1.0 float< ] compile-1 ] unit-test [ f ] [ 1.0 [ 1.0 float< ] compile-call ] unit-test
[ f ] [ 1.0 [ 1.0 swap float< ] compile-1 ] unit-test [ f ] [ 1.0 [ 1.0 swap float< ] compile-call ] unit-test
[ f ] [ 3.0 1.0 [ float< ] compile-1 ] unit-test [ f ] [ 3.0 1.0 [ float< ] compile-call ] unit-test
[ f ] [ 3.0 [ 1.0 float< ] compile-1 ] unit-test [ f ] [ 3.0 [ 1.0 float< ] compile-call ] unit-test
[ t ] [ 3.0 [ 1.0 swap float< ] compile-1 ] unit-test [ t ] [ 3.0 [ 1.0 swap float< ] compile-call ] unit-test
[ t ] [ 1.0 2.0 [ float<= ] compile-1 ] unit-test [ t ] [ 1.0 2.0 [ float<= ] compile-call ] unit-test
[ t ] [ 1.0 [ 2.0 float<= ] compile-1 ] unit-test [ t ] [ 1.0 [ 2.0 float<= ] compile-call ] unit-test
[ f ] [ 1.0 [ 2.0 swap float<= ] compile-1 ] unit-test [ f ] [ 1.0 [ 2.0 swap float<= ] compile-call ] unit-test
[ t ] [ 1.0 1.0 [ float<= ] compile-1 ] unit-test [ t ] [ 1.0 1.0 [ float<= ] compile-call ] unit-test
[ t ] [ 1.0 [ 1.0 float<= ] compile-1 ] unit-test [ t ] [ 1.0 [ 1.0 float<= ] compile-call ] unit-test
[ t ] [ 1.0 [ 1.0 swap float<= ] compile-1 ] unit-test [ t ] [ 1.0 [ 1.0 swap float<= ] compile-call ] unit-test
[ f ] [ 3.0 1.0 [ float<= ] compile-1 ] unit-test [ f ] [ 3.0 1.0 [ float<= ] compile-call ] unit-test
[ f ] [ 3.0 [ 1.0 float<= ] compile-1 ] unit-test [ f ] [ 3.0 [ 1.0 float<= ] compile-call ] unit-test
[ t ] [ 3.0 [ 1.0 swap float<= ] compile-1 ] unit-test [ t ] [ 3.0 [ 1.0 swap float<= ] compile-call ] unit-test
[ f ] [ 1.0 2.0 [ float> ] compile-1 ] unit-test [ f ] [ 1.0 2.0 [ float> ] compile-call ] unit-test
[ f ] [ 1.0 [ 2.0 float> ] compile-1 ] unit-test [ f ] [ 1.0 [ 2.0 float> ] compile-call ] unit-test
[ t ] [ 1.0 [ 2.0 swap float> ] compile-1 ] unit-test [ t ] [ 1.0 [ 2.0 swap float> ] compile-call ] unit-test
[ f ] [ 1.0 1.0 [ float> ] compile-1 ] unit-test [ f ] [ 1.0 1.0 [ float> ] compile-call ] unit-test
[ f ] [ 1.0 [ 1.0 float> ] compile-1 ] unit-test [ f ] [ 1.0 [ 1.0 float> ] compile-call ] unit-test
[ f ] [ 1.0 [ 1.0 swap float> ] compile-1 ] unit-test [ f ] [ 1.0 [ 1.0 swap float> ] compile-call ] unit-test
[ t ] [ 3.0 1.0 [ float> ] compile-1 ] unit-test [ t ] [ 3.0 1.0 [ float> ] compile-call ] unit-test
[ t ] [ 3.0 [ 1.0 float> ] compile-1 ] unit-test [ t ] [ 3.0 [ 1.0 float> ] compile-call ] unit-test
[ f ] [ 3.0 [ 1.0 swap float> ] compile-1 ] unit-test [ f ] [ 3.0 [ 1.0 swap float> ] compile-call ] unit-test
[ f ] [ 1.0 2.0 [ float>= ] compile-1 ] unit-test [ f ] [ 1.0 2.0 [ float>= ] compile-call ] unit-test
[ f ] [ 1.0 [ 2.0 float>= ] compile-1 ] unit-test [ f ] [ 1.0 [ 2.0 float>= ] compile-call ] unit-test
[ t ] [ 1.0 [ 2.0 swap float>= ] compile-1 ] unit-test [ t ] [ 1.0 [ 2.0 swap float>= ] compile-call ] unit-test
[ t ] [ 1.0 1.0 [ float>= ] compile-1 ] unit-test [ t ] [ 1.0 1.0 [ float>= ] compile-call ] unit-test
[ t ] [ 1.0 [ 1.0 float>= ] compile-1 ] unit-test [ t ] [ 1.0 [ 1.0 float>= ] compile-call ] unit-test
[ t ] [ 1.0 [ 1.0 swap float>= ] compile-1 ] unit-test [ t ] [ 1.0 [ 1.0 swap float>= ] compile-call ] unit-test
[ t ] [ 3.0 1.0 [ float>= ] compile-1 ] unit-test [ t ] [ 3.0 1.0 [ float>= ] compile-call ] unit-test
[ t ] [ 3.0 [ 1.0 float>= ] compile-1 ] unit-test [ t ] [ 3.0 [ 1.0 float>= ] compile-call ] unit-test
[ f ] [ 3.0 [ 1.0 swap float>= ] compile-1 ] unit-test [ f ] [ 3.0 [ 1.0 swap float>= ] compile-call ] unit-test
[ f ] [ 1.0 2.0 [ float= ] compile-1 ] unit-test [ f ] [ 1.0 2.0 [ float= ] compile-call ] unit-test
[ t ] [ 1.0 1.0 [ float= ] compile-1 ] unit-test [ t ] [ 1.0 1.0 [ float= ] compile-call ] unit-test
[ f ] [ 1.0 [ 2.0 float= ] compile-1 ] unit-test [ f ] [ 1.0 [ 2.0 float= ] compile-call ] unit-test
[ t ] [ 1.0 [ 1.0 float= ] compile-1 ] unit-test [ t ] [ 1.0 [ 1.0 float= ] compile-call ] unit-test
[ f ] [ 1.0 [ 2.0 swap float= ] compile-1 ] unit-test [ f ] [ 1.0 [ 2.0 swap float= ] compile-call ] unit-test
[ t ] [ 1.0 [ 1.0 swap float= ] compile-1 ] unit-test [ t ] [ 1.0 [ 1.0 swap float= ] compile-call ] unit-test
[ t ] [ 0.0 [ dup 0.0 float= swap -0.0 float= or ] compile-1 ] unit-test [ t ] [ 0.0 [ dup 0.0 float= swap -0.0 float= or ] compile-call ] unit-test
[ t ] [ -0.0 [ dup 0.0 float= swap -0.0 float= or ] compile-1 ] unit-test [ t ] [ -0.0 [ dup 0.0 float= swap -0.0 float= or ] compile-call ] unit-test
[ f ] [ 3.0 [ dup 0.0 float= swap -0.0 float= or ] compile-1 ] unit-test [ f ] [ 3.0 [ dup 0.0 float= swap -0.0 float= or ] compile-call ] unit-test
[ 315 315.0 ] [ 313 [ 2 fixnum+fast dup fixnum>float ] compile-1 ] unit-test [ 315 315.0 ] [ 313 [ 2 fixnum+fast dup fixnum>float ] compile-call ] unit-test

8
core/compiler/test/ifte.factor
View File

@ -98,7 +98,7 @@ DEFER: countdown-b
{ [ dup 2 mod 0 = ] [ drop "even" ] } { [ dup 2 mod 0 = ] [ drop "even" ] }
{ [ dup 2 mod 1 = ] [ drop "odd" ] } { [ dup 2 mod 1 = ] [ drop "odd" ] }
} cond } cond
] compile-1 ] compile-call
] unit-test ] unit-test
[ "odd" ] [ [ "odd" ] [
@ -107,7 +107,7 @@ DEFER: countdown-b
{ [ dup 2 mod 0 = ] [ drop "even" ] } { [ dup 2 mod 0 = ] [ drop "even" ] }
{ [ dup 2 mod 1 = ] [ drop "odd" ] } { [ dup 2 mod 1 = ] [ drop "odd" ] }
} cond } cond
] compile-1 ] compile-call
] unit-test ] unit-test
[ "neither" ] [ [ "neither" ] [
@ -118,7 +118,7 @@ DEFER: countdown-b
{ [ dup alien? ] [ drop "alien" ] } { [ dup alien? ] [ drop "alien" ] }
{ [ t ] [ drop "neither" ] } { [ t ] [ drop "neither" ] }
} cond } cond
] compile-1 ] compile-call
] unit-test ] unit-test
[ 3 ] [ [ 3 ] [
@ -127,5 +127,5 @@ DEFER: countdown-b
{ [ dup fixnum? ] [ ] } { [ dup fixnum? ] [ ] }
{ [ t ] [ drop t ] } { [ t ] [ drop t ] }
} cond } cond
] compile-1 ] compile-call
] unit-test ] unit-test

492
core/compiler/test/intrinsics.factor
View File

@ -7,258 +7,257 @@ sbufs.private strings.private slots.private alien alien.c-types
alien.syntax namespaces libc combinators.private ; alien.syntax namespaces libc combinators.private ;
! Make sure that intrinsic ops compile to correct code. ! Make sure that intrinsic ops compile to correct code.
[ ] [ 1 [ drop ] compile-1 ] unit-test [ ] [ 1 [ drop ] compile-call ] unit-test
[ ] [ 1 2 [ 2drop ] compile-1 ] unit-test [ ] [ 1 2 [ 2drop ] compile-call ] unit-test
[ ] [ 1 2 3 [ 3drop ] compile-1 ] unit-test [ ] [ 1 2 3 [ 3drop ] compile-call ] unit-test
[ 1 1 ] [ 1 [ dup ] compile-1 ] unit-test [ 1 1 ] [ 1 [ dup ] compile-call ] unit-test
[ 1 2 1 2 ] [ 1 2 [ 2dup ] compile-1 ] unit-test [ 1 2 1 2 ] [ 1 2 [ 2dup ] compile-call ] unit-test
[ 1 2 3 1 2 3 ] [ 1 2 3 [ 3dup ] compile-1 ] unit-test [ 1 2 3 1 2 3 ] [ 1 2 3 [ 3dup ] compile-call ] unit-test
[ 2 3 1 ] [ 1 2 3 [ rot ] compile-1 ] unit-test [ 2 3 1 ] [ 1 2 3 [ rot ] compile-call ] unit-test
[ 3 1 2 ] [ 1 2 3 [ -rot ] compile-1 ] unit-test [ 3 1 2 ] [ 1 2 3 [ -rot ] compile-call ] unit-test
[ 1 1 2 ] [ 1 2 [ dupd ] compile-1 ] unit-test [ 1 1 2 ] [ 1 2 [ dupd ] compile-call ] unit-test
[ 2 1 3 ] [ 1 2 3 [ swapd ] compile-1 ] unit-test [ 2 1 3 ] [ 1 2 3 [ swapd ] compile-call ] unit-test
[ 2 ] [ 1 2 [ nip ] compile-1 ] unit-test [ 2 ] [ 1 2 [ nip ] compile-call ] unit-test
[ 3 ] [ 1 2 3 [ 2nip ] compile-1 ] unit-test [ 3 ] [ 1 2 3 [ 2nip ] compile-call ] unit-test
[ 2 1 2 ] [ 1 2 [ tuck ] compile-1 ] unit-test [ 2 1 2 ] [ 1 2 [ tuck ] compile-call ] unit-test
[ 1 2 1 ] [ 1 2 [ over ] compile-1 ] unit-test [ 1 2 1 ] [ 1 2 [ over ] compile-call ] unit-test
[ 1 2 3 1 ] [ 1 2 3 [ pick ] compile-1 ] unit-test [ 1 2 3 1 ] [ 1 2 3 [ pick ] compile-call ] unit-test
[ 2 1 ] [ 1 2 [ swap ] compile-1 ] unit-test [ 2 1 ] [ 1 2 [ swap ] compile-call ] unit-test
[ 1 ] [ { 1 2 } [ 2 slot ] compile-1 ] unit-test [ 1 ] [ { 1 2 } [ 2 slot ] compile-call ] unit-test
[ 1 ] [ [ { 1 2 } 2 slot ] compile-1 ] unit-test [ 1 ] [ [ { 1 2 } 2 slot ] compile-call ] unit-test
[ 3 ] [ 3 1 2 2array [ [ 2 set-slot ] keep ] compile-1 first ] unit-test [ 3 ] [ 3 1 2 2array [ [ 2 set-slot ] keep ] compile-call first ] unit-test
[ 3 ] [ 3 1 2 [ 2array [ 2 set-slot ] keep ] compile-1 first ] unit-test [ 3 ] [ 3 1 2 [ 2array [ 2 set-slot ] keep ] compile-call first ] unit-test
[ 3 ] [ [ 3 1 2 2array [ 2 set-slot ] keep ] compile-1 first ] unit-test [ 3 ] [ [ 3 1 2 2array [ 2 set-slot ] keep ] compile-call first ] unit-test
[ 3 ] [ 3 1 2 2array [ [ 3 set-slot ] keep ] compile-1 second ] unit-test [ 3 ] [ 3 1 2 2array [ [ 3 set-slot ] keep ] compile-call second ] unit-test
[ 3 ] [ 3 1 2 [ 2array [ 3 set-slot ] keep ] compile-1 second ] unit-test [ 3 ] [ 3 1 2 [ 2array [ 3 set-slot ] keep ] compile-call second ] unit-test
[ 3 ] [ [ 3 1 2 2array [ 3 set-slot ] keep ] compile-1 second ] unit-test [ 3 ] [ [ 3 1 2 2array [ 3 set-slot ] keep ] compile-call second ] unit-test
! Write barrier hits on the wrong value were causing segfaults ! Write barrier hits on the wrong value were causing segfaults
[ -3 ] [ -3 1 2 [ 2array [ 3 set-slot ] keep ] compile-1 second ] unit-test [ -3 ] [ -3 1 2 [ 2array [ 3 set-slot ] keep ] compile-call second ] unit-test
[ CHAR: b ] [ 1 "abc" [ char-slot ] compile-1 ] unit-test [ CHAR: b ] [ 1 "abc" [ char-slot ] compile-call ] unit-test
[ CHAR: b ] [ 1 [ "abc" char-slot ] compile-1 ] unit-test [ CHAR: b ] [ 1 [ "abc" char-slot ] compile-call ] unit-test
[ CHAR: b ] [ [ 1 "abc" char-slot ] compile-1 ] unit-test [ CHAR: b ] [ [ 1 "abc" char-slot ] compile-call ] unit-test
[ "axc" ] [ CHAR: x 1 "abc" [ [ set-char-slot ] keep { string } declare dup rehash-string ] compile-1 ] unit-test [ "axc" ] [ CHAR: x 1 "abc" [ [ set-char-slot ] keep { string } declare dup rehash-string ] compile-call ] unit-test
[ "axc" ] [ CHAR: x 1 [ "abc" [ set-char-slot ] keep { string } declare dup rehash-string ] compile-1 ] unit-test [ "axc" ] [ CHAR: x 1 [ "abc" [ set-char-slot ] keep { string } declare dup rehash-string ] compile-call ] unit-test
[ "axc" ] [ CHAR: x [ 1 "abc" [ set-char-slot ] keep { string } declare dup rehash-string ] compile-1 ] unit-test [ "axc" ] [ CHAR: x [ 1 "abc" [ set-char-slot ] keep { string } declare dup rehash-string ] compile-call ] unit-test
[ ] [ [ 0 getenv ] compile-1 drop ] unit-test [ ] [ [ 0 getenv ] compile-call drop ] unit-test
[ ] [ 1 getenv [ 1 setenv ] compile-1 ] unit-test [ ] [ 1 getenv [ 1 setenv ] compile-call ] unit-test
[ ] [ 1 [ drop ] compile-1 ] unit-test [ ] [ 1 [ drop ] compile-call ] unit-test
[ ] [ [ 1 drop ] compile-1 ] unit-test [ ] [ [ 1 drop ] compile-call ] unit-test
[ ] [ [ 1 2 2drop ] compile-1 ] unit-test [ ] [ [ 1 2 2drop ] compile-call ] unit-test
[ ] [ 1 [ 2 2drop ] compile-1 ] unit-test [ ] [ 1 [ 2 2drop ] compile-call ] unit-test
[ ] [ 1 2 [ 2drop ] compile-1 ] unit-test [ ] [ 1 2 [ 2drop ] compile-call ] unit-test
[ 2 1 ] [ [ 1 2 swap ] compile-1 ] unit-test [ 2 1 ] [ [ 1 2 swap ] compile-call ] unit-test
[ 2 1 ] [ 1 [ 2 swap ] compile-1 ] unit-test [ 2 1 ] [ 1 [ 2 swap ] compile-call ] unit-test
[ 2 1 ] [ 1 2 [ swap ] compile-1 ] unit-test [ 2 1 ] [ 1 2 [ swap ] compile-call ] unit-test
[ 1 1 ] [ 1 [ dup ] compile-1 ] unit-test [ 1 1 ] [ 1 [ dup ] compile-call ] unit-test
[ 1 1 ] [ [ 1 dup ] compile-1 ] unit-test [ 1 1 ] [ [ 1 dup ] compile-call ] unit-test
[ 1 2 1 ] [ [ 1 2 over ] compile-1 ] unit-test [ 1 2 1 ] [ [ 1 2 over ] compile-call ] unit-test
[ 1 2 1 ] [ 1 [ 2 over ] compile-1 ] unit-test [ 1 2 1 ] [ 1 [ 2 over ] compile-call ] unit-test
[ 1 2 1 ] [ 1 2 [ over ] compile-1 ] unit-test [ 1 2 1 ] [ 1 2 [ over ] compile-call ] unit-test
[ 1 2 3 1 ] [ [ 1 2 3 pick ] compile-1 ] unit-test [ 1 2 3 1 ] [ [ 1 2 3 pick ] compile-call ] unit-test
[ 1 2 3 1 ] [ 1 [ 2 3 pick ] compile-1 ] unit-test [ 1 2 3 1 ] [ 1 [ 2 3 pick ] compile-call ] unit-test
[ 1 2 3 1 ] [ 1 2 [ 3 pick ] compile-1 ] unit-test [ 1 2 3 1 ] [ 1 2 [ 3 pick ] compile-call ] unit-test
[ 1 2 3 1 ] [ 1 2 3 [ pick ] compile-1 ] unit-test [ 1 2 3 1 ] [ 1 2 3 [ pick ] compile-call ] unit-test
[ 1 1 2 ] [ [ 1 2 dupd ] compile-1 ] unit-test [ 1 1 2 ] [ [ 1 2 dupd ] compile-call ] unit-test
[ 1 1 2 ] [ 1 [ 2 dupd ] compile-1 ] unit-test [ 1 1 2 ] [ 1 [ 2 dupd ] compile-call ] unit-test
[ 1 1 2 ] [ 1 2 [ dupd ] compile-1 ] unit-test [ 1 1 2 ] [ 1 2 [ dupd ] compile-call ] unit-test
[ 2 ] [ [ 1 2 nip ] compile-1 ] unit-test [ 2 ] [ [ 1 2 nip ] compile-call ] unit-test
[ 2 ] [ 1 [ 2 nip ] compile-1 ] unit-test [ 2 ] [ 1 [ 2 nip ] compile-call ] unit-test
[ 2 ] [ 1 2 [ nip ] compile-1 ] unit-test [ 2 ] [ 1 2 [ nip ] compile-call ] unit-test
[ 2 1 "hi" ] [ 1 2 [ swap "hi" ] compile-1 ] unit-test [ 2 1 "hi" ] [ 1 2 [ swap "hi" ] compile-call ] unit-test
[ 4 ] [ 12 7 [ fixnum-bitand ] compile-1 ] unit-test [ 4 ] [ 12 7 [ fixnum-bitand ] compile-call ] unit-test
[ 4 ] [ 12 [ 7 fixnum-bitand ] compile-1 ] unit-test [ 4 ] [ 12 [ 7 fixnum-bitand ] compile-call ] unit-test
[ 4 ] [ [ 12 7 fixnum-bitand ] compile-1 ] unit-test [ 4 ] [ [ 12 7 fixnum-bitand ] compile-call ] unit-test
[ 15 ] [ 12 7 [ fixnum-bitor ] compile-1 ] unit-test [ 15 ] [ 12 7 [ fixnum-bitor ] compile-call ] unit-test
[ 15 ] [ 12 [ 7 fixnum-bitor ] compile-1 ] unit-test [ 15 ] [ 12 [ 7 fixnum-bitor ] compile-call ] unit-test
[ 15 ] [ [ 12 7 fixnum-bitor ] compile-1 ] unit-test [ 15 ] [ [ 12 7 fixnum-bitor ] compile-call ] unit-test
[ 11 ] [ 12 7 [ fixnum-bitxor ] compile-1 ] unit-test [ 11 ] [ 12 7 [ fixnum-bitxor ] compile-call ] unit-test
[ 11 ] [ 12 [ 7 fixnum-bitxor ] compile-1 ] unit-test [ 11 ] [ 12 [ 7 fixnum-bitxor ] compile-call ] unit-test
[ 11 ] [ [ 12 7 fixnum-bitxor ] compile-1 ] unit-test [ 11 ] [ [ 12 7 fixnum-bitxor ] compile-call ] unit-test
[ f ] [ 12 7 [ fixnum< [ t ] [ f ] if ] compile-1 ] unit-test [ f ] [ 12 7 [ fixnum< [ t ] [ f ] if ] compile-call ] unit-test
[ f ] [ 12 [ 7 fixnum< [ t ] [ f ] if ] compile-1 ] unit-test [ f ] [ 12 [ 7 fixnum< [ t ] [ f ] if ] compile-call ] unit-test
[ f ] [ [ 12 7 fixnum< [ t ] [ f ] if ] compile-1 ] unit-test [ f ] [ [ 12 7 fixnum< [ t ] [ f ] if ] compile-call ] unit-test
[ f ] [ [ 12 12 fixnum< [ t ] [ f ] if ] compile-1 ] unit-test [ f ] [ [ 12 12 fixnum< [ t ] [ f ] if ] compile-call ] unit-test
[ f ] [ 12 12 [ fixnum< [ t ] [ f ] if ] compile-1 ] unit-test [ f ] [ 12 12 [ fixnum< [ t ] [ f ] if ] compile-call ] unit-test
[ t ] [ 12 70 [ fixnum< [ t ] [ f ] if ] compile-1 ] unit-test [ t ] [ 12 70 [ fixnum< [ t ] [ f ] if ] compile-call ] unit-test
[ t ] [ 12 [ 70 fixnum< [ t ] [ f ] if ] compile-1 ] unit-test [ t ] [ 12 [ 70 fixnum< [ t ] [ f ] if ] compile-call ] unit-test
[ t ] [ [ 12 70 fixnum< [ t ] [ f ] if ] compile-1 ] unit-test [ t ] [ [ 12 70 fixnum< [ t ] [ f ] if ] compile-call ] unit-test
[ f ] [ 12 7 [ fixnum<= [ t ] [ f ] if ] compile-1 ] unit-test [ f ] [ 12 7 [ fixnum<= [ t ] [ f ] if ] compile-call ] unit-test
[ f ] [ 12 [ 7 fixnum<= [ t ] [ f ] if ] compile-1 ] unit-test [ f ] [ 12 [ 7 fixnum<= [ t ] [ f ] if ] compile-call ] unit-test
[ f ] [ [ 12 7 fixnum<= [ t ] [ f ] if ] compile-1 ] unit-test [ f ] [ [ 12 7 fixnum<= [ t ] [ f ] if ] compile-call ] unit-test
[ t ] [ [ 12 12 fixnum<= [ t ] [ f ] if ] compile-1 ] unit-test [ t ] [ [ 12 12 fixnum<= [ t ] [ f ] if ] compile-call ] unit-test
[ t ] [ [ 12 12 fixnum<= [ t ] [ f ] if ] compile-1 ] unit-test [ t ] [ [ 12 12 fixnum<= [ t ] [ f ] if ] compile-call ] unit-test
[ t ] [ 12 12 [ fixnum<= [ t ] [ f ] if ] compile-1 ] unit-test [ t ] [ 12 12 [ fixnum<= [ t ] [ f ] if ] compile-call ] unit-test
[ t ] [ 12 70 [ fixnum<= [ t ] [ f ] if ] compile-1 ] unit-test [ t ] [ 12 70 [ fixnum<= [ t ] [ f ] if ] compile-call ] unit-test
[ t ] [ 12 [ 70 fixnum<= [ t ] [ f ] if ] compile-1 ] unit-test [ t ] [ 12 [ 70 fixnum<= [ t ] [ f ] if ] compile-call ] unit-test
[ t ] [ [ 12 70 fixnum<= [ t ] [ f ] if ] compile-1 ] unit-test [ t ] [ [ 12 70 fixnum<= [ t ] [ f ] if ] compile-call ] unit-test
[ t ] [ 12 7 [ fixnum> [ t ] [ f ] if ] compile-1 ] unit-test [ t ] [ 12 7 [ fixnum> [ t ] [ f ] if ] compile-call ] unit-test
[ t ] [ 12 [ 7 fixnum> [ t ] [ f ] if ] compile-1 ] unit-test [ t ] [ 12 [ 7 fixnum> [ t ] [ f ] if ] compile-call ] unit-test
[ t ] [ [ 12 7 fixnum> [ t ] [ f ] if ] compile-1 ] unit-test [ t ] [ [ 12 7 fixnum> [ t ] [ f ] if ] compile-call ] unit-test
[ f ] [ [ 12 12 fixnum> [ t ] [ f ] if ] compile-1 ] unit-test [ f ] [ [ 12 12 fixnum> [ t ] [ f ] if ] compile-call ] unit-test
[ f ] [ [ 12 12 fixnum> [ t ] [ f ] if ] compile-1 ] unit-test [ f ] [ [ 12 12 fixnum> [ t ] [ f ] if ] compile-call ] unit-test
[ f ] [ 12 12 [ fixnum> [ t ] [ f ] if ] compile-1 ] unit-test [ f ] [ 12 12 [ fixnum> [ t ] [ f ] if ] compile-call ] unit-test
[ f ] [ 12 70 [ fixnum> [ t ] [ f ] if ] compile-1 ] unit-test [ f ] [ 12 70 [ fixnum> [ t ] [ f ] if ] compile-call ] unit-test
[ f ] [ 12 [ 70 fixnum> [ t ] [ f ] if ] compile-1 ] unit-test [ f ] [ 12 [ 70 fixnum> [ t ] [ f ] if ] compile-call ] unit-test
[ f ] [ [ 12 70 fixnum> [ t ] [ f ] if ] compile-1 ] unit-test [ f ] [ [ 12 70 fixnum> [ t ] [ f ] if ] compile-call ] unit-test
[ t ] [ 12 7 [ fixnum>= [ t ] [ f ] if ] compile-1 ] unit-test [ t ] [ 12 7 [ fixnum>= [ t ] [ f ] if ] compile-call ] unit-test
[ t ] [ 12 [ 7 fixnum>= [ t ] [ f ] if ] compile-1 ] unit-test [ t ] [ 12 [ 7 fixnum>= [ t ] [ f ] if ] compile-call ] unit-test
[ t ] [ [ 12 7 fixnum>= [ t ] [ f ] if ] compile-1 ] unit-test [ t ] [ [ 12 7 fixnum>= [ t ] [ f ] if ] compile-call ] unit-test
[ t ] [ [ 12 12 fixnum>= [ t ] [ f ] if ] compile-1 ] unit-test [ t ] [ [ 12 12 fixnum>= [ t ] [ f ] if ] compile-call ] unit-test
[ t ] [ 12 12 [ fixnum>= [ t ] [ f ] if ] compile-1 ] unit-test [ t ] [ 12 12 [ fixnum>= [ t ] [ f ] if ] compile-call ] unit-test
[ f ] [ 12 70 [ fixnum>= [ t ] [ f ] if ] compile-1 ] unit-test [ f ] [ 12 70 [ fixnum>= [ t ] [ f ] if ] compile-call ] unit-test
[ f ] [ 12 [ 70 fixnum>= [ t ] [ f ] if ] compile-1 ] unit-test [ f ] [ 12 [ 70 fixnum>= [ t ] [ f ] if ] compile-call ] unit-test
[ f ] [ [ 12 70 fixnum>= [ t ] [ f ] if ] compile-1 ] unit-test [ f ] [ [ 12 70 fixnum>= [ t ] [ f ] if ] compile-call ] unit-test
[ f ] [ 1 2 [ eq? [ t ] [ f ] if ] compile-1 ] unit-test [ f ] [ 1 2 [ eq? [ t ] [ f ] if ] compile-call ] unit-test
[ f ] [ 1 [ 2 eq? [ t ] [ f ] if ] compile-1 ] unit-test [ f ] [ 1 [ 2 eq? [ t ] [ f ] if ] compile-call ] unit-test
[ f ] [ [ 1 2 eq? [ t ] [ f ] if ] compile-1 ] unit-test [ f ] [ [ 1 2 eq? [ t ] [ f ] if ] compile-call ] unit-test
[ t ] [ 3 3 [ eq? [ t ] [ f ] if ] compile-1 ] unit-test [ t ] [ 3 3 [ eq? [ t ] [ f ] if ] compile-call ] unit-test
[ t ] [ 3 [ 3 eq? [ t ] [ f ] if ] compile-1 ] unit-test [ t ] [ 3 [ 3 eq? [ t ] [ f ] if ] compile-call ] unit-test
[ t ] [ [ 3 3 eq? [ t ] [ f ] if ] compile-1 ] unit-test [ t ] [ [ 3 3 eq? [ t ] [ f ] if ] compile-call ] unit-test
[ -1 ] [ 0 [ fixnum-bitnot ] compile-1 ] unit-test [ -1 ] [ 0 [ fixnum-bitnot ] compile-call ] unit-test
[ -1 ] [ [ 0 fixnum-bitnot ] compile-1 ] unit-test [ -1 ] [ [ 0 fixnum-bitnot ] compile-call ] unit-test
[ 3 ] [ 13 10 [ fixnum-mod ] compile-1 ] unit-test [ 3 ] [ 13 10 [ fixnum-mod ] compile-call ] unit-test
[ 3 ] [ 13 [ 10 fixnum-mod ] compile-1 ] unit-test [ 3 ] [ 13 [ 10 fixnum-mod ] compile-call ] unit-test
[ 3 ] [ [ 13 10 fixnum-mod ] compile-1 ] unit-test [ 3 ] [ [ 13 10 fixnum-mod ] compile-call ] unit-test
[ -3 ] [ -13 10 [ fixnum-mod ] compile-1 ] unit-test [ -3 ] [ -13 10 [ fixnum-mod ] compile-call ] unit-test
[ -3 ] [ -13 [ 10 fixnum-mod ] compile-1 ] unit-test [ -3 ] [ -13 [ 10 fixnum-mod ] compile-call ] unit-test
[ -3 ] [ [ -13 10 fixnum-mod ] compile-1 ] unit-test [ -3 ] [ [ -13 10 fixnum-mod ] compile-call ] unit-test
[ 2 ] [ 4 2 [ fixnum/i ] compile-1 ] unit-test [ 2 ] [ 4 2 [ fixnum/i ] compile-call ] unit-test
[ 2 ] [ 4 [ 2 fixnum/i ] compile-1 ] unit-test [ 2 ] [ 4 [ 2 fixnum/i ] compile-call ] unit-test
[ -2 ] [ 4 [ -2 fixnum/i ] compile-1 ] unit-test [ -2 ] [ 4 [ -2 fixnum/i ] compile-call ] unit-test
[ 3 1 ] [ 10 3 [ fixnum/mod ] compile-1 ] unit-test [ 3 1 ] [ 10 3 [ fixnum/mod ] compile-call ] unit-test
[ 4 ] [ 1 3 [ fixnum+ ] compile-1 ] unit-test [ 4 ] [ 1 3 [ fixnum+ ] compile-call ] unit-test
[ 4 ] [ 1 [ 3 fixnum+ ] compile-1 ] unit-test [ 4 ] [ 1 [ 3 fixnum+ ] compile-call ] unit-test
[ 4 ] [ [ 1 3 fixnum+ ] compile-1 ] unit-test [ 4 ] [ [ 1 3 fixnum+ ] compile-call ] unit-test
[ 4 ] [ 1 3 [ fixnum+fast ] compile-1 ] unit-test [ 4 ] [ 1 3 [ fixnum+fast ] compile-call ] unit-test
[ 4 ] [ 1 [ 3 fixnum+fast ] compile-1 ] unit-test [ 4 ] [ 1 [ 3 fixnum+fast ] compile-call ] unit-test
[ 4 ] [ [ 1 3 fixnum+fast ] compile-1 ] unit-test [ 4 ] [ [ 1 3 fixnum+fast ] compile-call ] unit-test
[ 30001 ] [ 1 [ 30000 fixnum+fast ] compile-1 ] unit-test [ 30001 ] [ 1 [ 30000 fixnum+fast ] compile-call ] unit-test
[ 6 ] [ 2 3 [ fixnum*fast ] compile-1 ] unit-test [ 6 ] [ 2 3 [ fixnum*fast ] compile-call ] unit-test
[ 6 ] [ 2 [ 3 fixnum*fast ] compile-1 ] unit-test [ 6 ] [ 2 [ 3 fixnum*fast ] compile-call ] unit-test
[ 6 ] [ [ 2 3 fixnum*fast ] compile-1 ] unit-test [ 6 ] [ [ 2 3 fixnum*fast ] compile-call ] unit-test
[ -6 ] [ 2 -3 [ fixnum*fast ] compile-1 ] unit-test [ -6 ] [ 2 -3 [ fixnum*fast ] compile-call ] unit-test
[ -6 ] [ 2 [ -3 fixnum*fast ] compile-1 ] unit-test [ -6 ] [ 2 [ -3 fixnum*fast ] compile-call ] unit-test
[ -6 ] [ [ 2 -3 fixnum*fast ] compile-1 ] unit-test [ -6 ] [ [ 2 -3 fixnum*fast ] compile-call ] unit-test
[ 6 ] [ 2 3 [ fixnum* ] compile-1 ] unit-test [ 6 ] [ 2 3 [ fixnum* ] compile-call ] unit-test
[ 6 ] [ 2 [ 3 fixnum* ] compile-1 ] unit-test [ 6 ] [ 2 [ 3 fixnum* ] compile-call ] unit-test
[ 6 ] [ [ 2 3 fixnum* ] compile-1 ] unit-test [ 6 ] [ [ 2 3 fixnum* ] compile-call ] unit-test
[ -6 ] [ 2 -3 [ fixnum* ] compile-1 ] unit-test [ -6 ] [ 2 -3 [ fixnum* ] compile-call ] unit-test
[ -6 ] [ 2 [ -3 fixnum* ] compile-1 ] unit-test [ -6 ] [ 2 [ -3 fixnum* ] compile-call ] unit-test
[ -6 ] [ [ 2 -3 fixnum* ] compile-1 ] unit-test [ -6 ] [ [ 2 -3 fixnum* ] compile-call ] unit-test
[ t ] [ 3 type 3 [ type ] compile-1 eq? ] unit-test [ t ] [ 3 type 3 [ type ] compile-call eq? ] unit-test
[ t ] [ 3 >bignum type 3 >bignum [ type ] compile-1 eq? ] unit-test [ t ] [ 3 >bignum type 3 >bignum [ type ] compile-call eq? ] unit-test
[ t ] [ "hey" type "hey" [ type ] compile-1 eq? ] unit-test [ t ] [ "hey" type "hey" [ type ] compile-call eq? ] unit-test
[ t ] [ f type f [ type ] compile-1 eq? ] unit-test [ t ] [ f type f [ type ] compile-call eq? ] unit-test
[ 5 ] [ 1 2 [ eq? [ 3 ] [ 5 ] if ] compile-1 ] unit-test [ 5 ] [ 1 2 [ eq? [ 3 ] [ 5 ] if ] compile-call ] unit-test
[ 3 ] [ 2 2 [ eq? [ 3 ] [ 5 ] if ] compile-1 ] unit-test [ 3 ] [ 2 2 [ eq? [ 3 ] [ 5 ] if ] compile-call ] unit-test
[ 3 ] [ 1 2 [ fixnum< [ 3 ] [ 5 ] if ] compile-1 ] unit-test [ 3 ] [ 1 2 [ fixnum< [ 3 ] [ 5 ] if ] compile-call ] unit-test
[ 5 ] [ 2 2 [ fixnum< [ 3 ] [ 5 ] if ] compile-1 ] unit-test [ 5 ] [ 2 2 [ fixnum< [ 3 ] [ 5 ] if ] compile-call ] unit-test
[ 8 ] [ 1 3 [ fixnum-shift ] compile-1 ] unit-test [ 8 ] [ 1 3 [ fixnum-shift ] compile-call ] unit-test
[ 8 ] [ 1 [ 3 fixnum-shift ] compile-1 ] unit-test [ 8 ] [ 1 [ 3 fixnum-shift ] compile-call ] unit-test
[ 8 ] [ [ 1 3 fixnum-shift ] compile-1 ] unit-test [ 8 ] [ [ 1 3 fixnum-shift ] compile-call ] unit-test
[ -8 ] [ -1 3 [ fixnum-shift ] compile-1 ] unit-test [ -8 ] [ -1 3 [ fixnum-shift ] compile-call ] unit-test
[ -8 ] [ -1 [ 3 fixnum-shift ] compile-1 ] unit-test [ -8 ] [ -1 [ 3 fixnum-shift ] compile-call ] unit-test
[ -8 ] [ [ -1 3 fixnum-shift ] compile-1 ] unit-test [ -8 ] [ [ -1 3 fixnum-shift ] compile-call ] unit-test
[ 2 ] [ 8 -2 [ fixnum-shift ] compile-1 ] unit-test [ 2 ] [ 8 -2 [ fixnum-shift ] compile-call ] unit-test
[ 2 ] [ 8 [ -2 fixnum-shift ] compile-1 ] unit-test [ 2 ] [ 8 [ -2 fixnum-shift ] compile-call ] unit-test
[ 0 ] [ [ 123 -64 fixnum-shift ] compile-1 ] unit-test [ 0 ] [ [ 123 -64 fixnum-shift ] compile-call ] unit-test
[ 0 ] [ 123 -64 [ fixnum-shift ] compile-1 ] unit-test [ 0 ] [ 123 -64 [ fixnum-shift ] compile-call ] unit-test
[ -1 ] [ [ -123 -64 fixnum-shift ] compile-1 ] unit-test [ -1 ] [ [ -123 -64 fixnum-shift ] compile-call ] unit-test
[ -1 ] [ -123 -64 [ fixnum-shift ] compile-1 ] unit-test [ -1 ] [ -123 -64 [ fixnum-shift ] compile-call ] unit-test
[ HEX: 10000000 ] [ HEX: -10000000 >fixnum [ 0 swap fixnum- ] compile-1 ] unit-test [ HEX: 10000000 ] [ HEX: -10000000 >fixnum [ 0 swap fixnum- ] compile-call ] unit-test
[ HEX: 10000000 ] [ HEX: -fffffff >fixnum [ 1 swap fixnum- ] compile-1 ] unit-test [ HEX: 10000000 ] [ HEX: -fffffff >fixnum [ 1 swap fixnum- ] compile-call ] unit-test
[ t ] [ 1 27 fixnum-shift dup [ fixnum+ ] compile-1 1 28 fixnum-shift = ] unit-test [ t ] [ 1 27 fixnum-shift dup [ fixnum+ ] compile-call 1 28 fixnum-shift = ] unit-test
[ -268435457 ] [ 1 28 shift neg >fixnum [ -1 fixnum+ ] compile-1 ] unit-test [ -268435457 ] [ 1 28 shift neg >fixnum [ -1 fixnum+ ] compile-call ] unit-test
[ 4294967296 ] [ 1 32 [ fixnum-shift ] compile-1 ] unit-test [ 4294967296 ] [ 1 32 [ fixnum-shift ] compile-call ] unit-test
[ 4294967296 ] [ 1 [ 32 fixnum-shift ] compile-1 ] unit-test [ 4294967296 ] [ 1 [ 32 fixnum-shift ] compile-call ] unit-test
[ 4294967296 ] [ 1 [ 16 fixnum-shift 16 fixnum-shift ] compile-1 ] unit-test [ 4294967296 ] [ 1 [ 16 fixnum-shift 16 fixnum-shift ] compile-call ] unit-test
[ -4294967296 ] [ -1 32 [ fixnum-shift ] compile-1 ] unit-test [ -4294967296 ] [ -1 32 [ fixnum-shift ] compile-call ] unit-test
[ -4294967296 ] [ -1 [ 32 fixnum-shift ] compile-1 ] unit-test [ -4294967296 ] [ -1 [ 32 fixnum-shift ] compile-call ] unit-test
[ -4294967296 ] [ -1 [ 16 fixnum-shift 16 fixnum-shift ] compile-1 ] unit-test [ -4294967296 ] [ -1 [ 16 fixnum-shift 16 fixnum-shift ] compile-call ] unit-test
[ t ] [ 1 20 shift 1 20 shift [ fixnum* ] compile-1 1 40 shift = ] unit-test [ t ] [ 1 20 shift 1 20 shift [ fixnum* ] compile-call 1 40 shift = ] unit-test
[ t ] [ 1 20 shift neg 1 20 shift [ fixnum* ] compile-1 1 40 shift neg = ] unit-test [ t ] [ 1 20 shift neg 1 20 shift [ fixnum* ] compile-call 1 40 shift neg = ] unit-test
[ t ] [ 1 20 shift neg 1 20 shift neg [ fixnum* ] compile-1 1 40 shift = ] unit-test [ t ] [ 1 20 shift neg 1 20 shift neg [ fixnum* ] compile-call 1 40 shift = ] unit-test
[ -351382792 ] [ -43922849 [ 3 fixnum-shift ] compile-1 ] unit-test [ -351382792 ] [ -43922849 [ 3 fixnum-shift ] compile-call ] unit-test
[ 268435456 ] [ -268435456 >fixnum -1 [ fixnum/i ] compile-1 ] unit-test [ 268435456 ] [ -268435456 >fixnum -1 [ fixnum/i ] compile-call ] unit-test
[ 268435456 0 ] [ -268435456 >fixnum -1 [ fixnum/mod ] compile-1 ] unit-test [ 268435456 0 ] [ -268435456 >fixnum -1 [ fixnum/mod ] compile-call ] unit-test
[ t ] [ f [ f eq? ] compile-1 ] unit-test [ t ] [ f [ f eq? ] compile-call ] unit-test
! regression ! regression
[ t ] [ { 1 2 3 } { 1 2 3 } [ over type over type eq? ] compile-1 2nip ] unit-test [ t ] [ { 1 2 3 } { 1 2 3 } [ over type over type eq? ] compile-call 2nip ] unit-test
! regression ! regression
[ 3 ] [ [ 3 ] [
100001 f <array> 3 100000 pick set-nth 100001 f <array> 3 100000 pick set-nth
[ 100000 swap array-nth ] compile-1 [ 100000 swap array-nth ] compile-call
] unit-test ] unit-test
! 64-bit overflow ! 64-bit overflow
cell 8 = [ cell 8 = [
[ t ] [ 1 59 fixnum-shift dup [ fixnum+ ] compile-1 1 60 fixnum-shift = ] unit-test [ t ] [ 1 59 fixnum-shift dup [ fixnum+ ] compile-call 1 60 fixnum-shift = ] unit-test
[ -1152921504606846977 ] [ 1 60 shift neg >fixnum [ -1 fixnum+ ] compile-1 ] unit-test [ -1152921504606846977 ] [ 1 60 shift neg >fixnum [ -1 fixnum+ ] compile-call ] unit-test
[ t ] [ 1 40 shift 1 40 shift [ fixnum* ] compile-1 1 80 shift = ] unit-test [ t ] [ 1 40 shift 1 40 shift [ fixnum* ] compile-call 1 80 shift = ] unit-test
[ t ] [ 1 40 shift neg 1 40 shift [ fixnum* ] compile-1 1 80 shift neg = ] unit-test [ t ] [ 1 40 shift neg 1 40 shift [ fixnum* ] compile-call 1 80 shift neg = ] unit-test
[ t ] [ 1 40 shift neg 1 40 shift neg [ fixnum* ] compile-1 1 80 shift = ] unit-test [ t ] [ 1 40 shift neg 1 40 shift neg [ fixnum* ] compile-call 1 80 shift = ] unit-test
[ t ] [ 1 30 shift neg 1 50 shift neg [ fixnum* ] compile-1 1 80 shift = ] unit-test [ t ] [ 1 30 shift neg 1 50 shift neg [ fixnum* ] compile-call 1 80 shift = ] unit-test
[ t ] [ 1 50 shift neg 1 30 shift neg [ fixnum* ] compile-1 1 80 shift = ] unit-test [ t ] [ 1 50 shift neg 1 30 shift neg [ fixnum* ] compile-call 1 80 shift = ] unit-test
[ 18446744073709551616 ] [ 1 64 [ fixnum-shift ] compile-1 ] unit-test [ 18446744073709551616 ] [ 1 64 [ fixnum-shift ] compile-call ] unit-test
[ 18446744073709551616 ] [ 1 [ 64 fixnum-shift ] compile-1 ] unit-test [ 18446744073709551616 ] [ 1 [ 64 fixnum-shift ] compile-call ] unit-test
[ 18446744073709551616 ] [ 1 [ 32 fixnum-shift 32 fixnum-shift ] compile-1 ] unit-test [ 18446744073709551616 ] [ 1 [ 32 fixnum-shift 32 fixnum-shift ] compile-call ] unit-test
[ -18446744073709551616 ] [ -1 64 [ fixnum-shift ] compile-1 ] unit-test [ -18446744073709551616 ] [ -1 64 [ fixnum-shift ] compile-call ] unit-test
[ -18446744073709551616 ] [ -1 [ 64 fixnum-shift ] compile-1 ] unit-test [ -18446744073709551616 ] [ -1 [ 64 fixnum-shift ] compile-call ] unit-test
[ -18446744073709551616 ] [ -1 [ 32 fixnum-shift 32 fixnum-shift ] compile-1 ] unit-test [ -18446744073709551616 ] [ -1 [ 32 fixnum-shift 32 fixnum-shift ] compile-call ] unit-test
[ 1152921504606846976 ] [ -1152921504606846976 >fixnum -1 [ fixnum/i ] compile-1 ] unit-test [ 1152921504606846976 ] [ -1152921504606846976 >fixnum -1 [ fixnum/i ] compile-call ] unit-test
[ 1152921504606846976 0 ] [ -1152921504606846976 >fixnum -1 [ fixnum/mod ] compile-1 ] unit-test [ 1152921504606846976 0 ] [ -1152921504606846976 >fixnum -1 [ fixnum/mod ] compile-call ] unit-test
[ -268435457 ] [ 28 2^ [ fixnum-bitnot ] compile-1 ] unit-test [ -268435457 ] [ 28 2^ [ fixnum-bitnot ] compile-call ] unit-test
] when ] when
! Some randomized tests ! Some randomized tests
: compiled-fixnum* fixnum* ; : compiled-fixnum* fixnum* ;
\ compiled-fixnum* compile
: test-fixnum* : test-fixnum*
(random) >fixnum (random) >fixnum (random) >fixnum (random) >fixnum
@ -269,7 +268,6 @@ cell 8 = [
[ ] [ 10000 [ test-fixnum* ] times ] unit-test [ ] [ 10000 [ test-fixnum* ] times ] unit-test
: compiled-fixnum>bignum fixnum>bignum ; : compiled-fixnum>bignum fixnum>bignum ;
\ compiled-fixnum>bignum compile
: test-fixnum>bignum : test-fixnum>bignum
(random) >fixnum (random) >fixnum
@ -279,7 +277,6 @@ cell 8 = [
[ ] [ 10000 [ test-fixnum>bignum ] times ] unit-test [ ] [ 10000 [ test-fixnum>bignum ] times ] unit-test
: compiled-bignum>fixnum bignum>fixnum ; : compiled-bignum>fixnum bignum>fixnum ;
\ compiled-bignum>fixnum compile
: test-bignum>fixnum : test-bignum>fixnum
5 random [ drop (random) ] map product >bignum 5 random [ drop (random) ] map product >bignum
@ -292,84 +289,85 @@ cell 8 = [
[ t ] [ [ t ] [
most-positive-fixnum 100 - >fixnum most-positive-fixnum 100 - >fixnum
200 200
[ [ fixnum+ ] compile-1 [ bignum>fixnum ] compile-1 ] 2keep [ [ fixnum+ ] compile-call [ bignum>fixnum ] compile-call ] 2keep
[ fixnum+ >fixnum ] compile-1 [ fixnum+ >fixnum ] compile-call
= =
] unit-test ] unit-test
[ t ] [ [ t ] [
most-negative-fixnum 100 + >fixnum most-negative-fixnum 100 + >fixnum
-200 -200
[ [ fixnum+ ] compile-1 [ bignum>fixnum ] compile-1 ] 2keep [ [ fixnum+ ] compile-call [ bignum>fixnum ] compile-call ] 2keep
[ fixnum+ >fixnum ] compile-1 [ fixnum+ >fixnum ] compile-call
= =
] unit-test ] unit-test
[ t ] [ [ t ] [
most-negative-fixnum 100 + >fixnum most-negative-fixnum 100 + >fixnum
200 200
[ [ fixnum- ] compile-1 [ bignum>fixnum ] compile-1 ] 2keep [ [ fixnum- ] compile-call [ bignum>fixnum ] compile-call ] 2keep
[ fixnum- >fixnum ] compile-1 [ fixnum- >fixnum ] compile-call
= =
] unit-test ] unit-test
! Test inline allocators ! Test inline allocators
[ { 1 1 1 } ] [ [ { 1 1 1 } ] [
[ 3 1 <array> ] compile-1 [ 3 1 <array> ] compile-call
] unit-test ] unit-test
[ B{ 0 0 0 } ] [ [ B{ 0 0 0 } ] [
[ 3 <byte-array> ] compile-1 [ 3 <byte-array> ] compile-call
] unit-test ] unit-test
[ 500 ] [ [ 500 ] [
[ 500 <byte-array> length ] compile-1 [ 500 <byte-array> length ] compile-call
] unit-test ] unit-test
[ 1 2 ] [ [ 1 2 ] [
1 2 [ <complex> ] compile-1 dup real swap imaginary 1 2 [ <complex> ] compile-call
dup real-part swap imaginary-part
] unit-test ] unit-test
[ 1 2 ] [ [ 1 2 ] [
1 2 [ <ratio> ] compile-1 dup numerator swap denominator 1 2 [ <ratio> ] compile-call dup numerator swap denominator
] unit-test ] unit-test
[ \ + ] [ \ + [ <wrapper> ] compile-1 ] unit-test [ \ + ] [ \ + [ <wrapper> ] compile-call ] unit-test
[ H{ } ] [ [ H{ } ] [
100 [ (hashtable) ] compile-1 [ reset-hash ] keep 100 [ (hashtable) ] compile-call [ reset-hash ] keep
] unit-test ] unit-test
[ B{ 0 0 0 0 0 } ] [ [ B{ 0 0 0 0 0 } ] [
[ 5 <byte-array> ] compile-1 [ 5 <byte-array> ] compile-call
] unit-test ] unit-test
[ V{ 1 2 } ] [ [ V{ 1 2 } ] [
{ 1 2 3 } 2 [ array>vector ] compile-1 { 1 2 3 } 2 [ array>vector ] compile-call
] unit-test ] unit-test
[ SBUF" hello" ] [ [ SBUF" hello" ] [
"hello world" 5 [ string>sbuf ] compile-1 "hello world" 5 [ string>sbuf ] compile-call
] unit-test ] unit-test
[ [ 3 + ] ] [ [ [ 3 + ] ] [
3 [ + ] [ curry ] compile-1 3 [ + ] [ curry ] compile-call
] unit-test ] unit-test
! Alien intrinsics ! Alien intrinsics
[ 3 ] [ B{ 1 2 3 4 5 } 2 [ alien-unsigned-1 ] compile-1 ] unit-test [ 3 ] [ B{ 1 2 3 4 5 } 2 [ alien-unsigned-1 ] compile-call ] unit-test
[ 3 ] [ [ B{ 1 2 3 4 5 } 2 alien-unsigned-1 ] compile-1 ] unit-test [ 3 ] [ [ B{ 1 2 3 4 5 } 2 alien-unsigned-1 ] compile-call ] unit-test
[ 3 ] [ B{ 1 2 3 4 5 } 2 [ { byte-array fixnum } declare alien-unsigned-1 ] compile-1 ] unit-test [ 3 ] [ B{ 1 2 3 4 5 } 2 [ { byte-array fixnum } declare alien-unsigned-1 ] compile-call ] unit-test
[ 3 ] [ B{ 1 2 3 4 5 } 2 [ { c-ptr fixnum } declare alien-unsigned-1 ] compile-1 ] unit-test [ 3 ] [ B{ 1 2 3 4 5 } 2 [ { c-ptr fixnum } declare alien-unsigned-1 ] compile-call ] unit-test
[ ] [ B{ 1 2 3 4 5 } malloc-byte-array "b" set ] unit-test [ ] [ B{ 1 2 3 4 5 } malloc-byte-array "b" set ] unit-test
[ t ] [ "b" get >boolean ] unit-test [ t ] [ "b" get >boolean ] unit-test
"b" get [ "b" get [
[ 3 ] [ "b" get 2 [ alien-unsigned-1 ] compile-1 ] unit-test [ 3 ] [ "b" get 2 [ alien-unsigned-1 ] compile-call ] unit-test
[ 3 ] [ "b" get [ { alien } declare 2 alien-unsigned-1 ] compile-1 ] unit-test [ 3 ] [ "b" get [ { alien } declare 2 alien-unsigned-1 ] compile-call ] unit-test
[ 3 ] [ "b" get 2 [ { simple-alien fixnum } declare alien-unsigned-1 ] compile-1 ] unit-test [ 3 ] [ "b" get 2 [ { simple-alien fixnum } declare alien-unsigned-1 ] compile-call ] unit-test
[ 3 ] [ "b" get 2 [ { c-ptr fixnum } declare alien-unsigned-1 ] compile-1 ] unit-test [ 3 ] [ "b" get 2 [ { c-ptr fixnum } declare alien-unsigned-1 ] compile-call ] unit-test
[ ] [ "b" get free ] unit-test [ ] [ "b" get free ] unit-test
] when ] when
@ -377,61 +375,61 @@ cell 8 = [
[ ] [ "hello world" malloc-char-string "s" set ] unit-test [ ] [ "hello world" malloc-char-string "s" set ] unit-test
"s" get [ "s" get [
[ "hello world" ] [ "s" get <void*> [ { byte-array } declare *void* ] compile-1 alien>char-string ] unit-test [ "hello world" ] [ "s" get <void*> [ { byte-array } declare *void* ] compile-call alien>char-string ] unit-test
[ "hello world" ] [ "s" get <void*> [ { c-ptr } declare *void* ] compile-1 alien>char-string ] unit-test [ "hello world" ] [ "s" get <void*> [ { c-ptr } declare *void* ] compile-call alien>char-string ] unit-test
[ ] [ "s" get free ] unit-test [ ] [ "s" get free ] unit-test
] when ] when
[ ALIEN: 1234 ] [ ALIEN: 1234 [ { alien } declare <void*> ] compile-1 *void* ] unit-test [ ALIEN: 1234 ] [ ALIEN: 1234 [ { alien } declare <void*> ] compile-call *void* ] unit-test
[ ALIEN: 1234 ] [ ALIEN: 1234 [ { c-ptr } declare <void*> ] compile-1 *void* ] unit-test [ ALIEN: 1234 ] [ ALIEN: 1234 [ { c-ptr } declare <void*> ] compile-call *void* ] unit-test
[ f ] [ f [ { POSTPONE: f } declare <void*> ] compile-1 *void* ] unit-test [ f ] [ f [ { POSTPONE: f } declare <void*> ] compile-call *void* ] unit-test
[ 252 ] [ B{ 1 2 3 -4 5 } 3 [ { byte-array fixnum } declare alien-unsigned-1 ] compile-1 ] unit-test [ 252 ] [ B{ 1 2 3 -4 5 } 3 [ { byte-array fixnum } declare alien-unsigned-1 ] compile-call ] unit-test
[ -4 ] [ B{ 1 2 3 -4 5 } 3 [ { byte-array fixnum } declare alien-signed-1 ] compile-1 ] unit-test [ -4 ] [ B{ 1 2 3 -4 5 } 3 [ { byte-array fixnum } declare alien-signed-1 ] compile-call ] unit-test
: xword-def word-def [ { fixnum } declare ] swap append ; : xword-def word-def [ { fixnum } declare ] swap append ;
[ -100 ] [ -100 <char> [ { byte-array } declare *char ] compile-1 ] unit-test [ -100 ] [ -100 <char> [ { byte-array } declare *char ] compile-call ] unit-test
[ 156 ] [ -100 <uchar> [ { byte-array } declare *uchar ] compile-1 ] unit-test [ 156 ] [ -100 <uchar> [ { byte-array } declare *uchar ] compile-call ] unit-test
[ -100 ] [ -100 \ <char> xword-def compile-1 *char ] unit-test [ -100 ] [ -100 \ <char> xword-def compile-call *char ] unit-test
[ 156 ] [ -100 \ <uchar> xword-def compile-1 *uchar ] unit-test [ 156 ] [ -100 \ <uchar> xword-def compile-call *uchar ] unit-test
[ -1000 ] [ -1000 <short> [ { byte-array } declare *short ] compile-1 ] unit-test [ -1000 ] [ -1000 <short> [ { byte-array } declare *short ] compile-call ] unit-test
[ 64536 ] [ -1000 <ushort> [ { byte-array } declare *ushort ] compile-1 ] unit-test [ 64536 ] [ -1000 <ushort> [ { byte-array } declare *ushort ] compile-call ] unit-test
[ -1000 ] [ -1000 \ <short> xword-def compile-1 *short ] unit-test [ -1000 ] [ -1000 \ <short> xword-def compile-call *short ] unit-test
[ 64536 ] [ -1000 \ <ushort> xword-def compile-1 *ushort ] unit-test [ 64536 ] [ -1000 \ <ushort> xword-def compile-call *ushort ] unit-test
[ -100000 ] [ -100000 <int> [ { byte-array } declare *int ] compile-1 ] unit-test [ -100000 ] [ -100000 <int> [ { byte-array } declare *int ] compile-call ] unit-test
[ 4294867296 ] [ -100000 <uint> [ { byte-array } declare *uint ] compile-1 ] unit-test [ 4294867296 ] [ -100000 <uint> [ { byte-array } declare *uint ] compile-call ] unit-test
[ -100000 ] [ -100000 \ <int> xword-def compile-1 *int ] unit-test [ -100000 ] [ -100000 \ <int> xword-def compile-call *int ] unit-test
[ 4294867296 ] [ -100000 \ <uint> xword-def compile-1 *uint ] unit-test [ 4294867296 ] [ -100000 \ <uint> xword-def compile-call *uint ] unit-test
[ t ] [ pi pi <double> *double = ] unit-test [ t ] [ pi pi <double> *double = ] unit-test
[ t ] [ pi <double> [ { byte-array } declare *double ] compile-1 pi = ] unit-test [ t ] [ pi <double> [ { byte-array } declare *double ] compile-call pi = ] unit-test
! Silly ! Silly
[ t ] [ pi 4 <byte-array> [ [ { float byte-array } declare 0 set-alien-float ] compile-1 ] keep *float pi - -0.001 0.001 between? ] unit-test [ t ] [ pi 4 <byte-array> [ [ { float byte-array } declare 0 set-alien-float ] compile-call ] keep *float pi - -0.001 0.001 between? ] unit-test
[ t ] [ pi <float> [ { byte-array } declare *float ] compile-1 pi - -0.001 0.001 between? ] unit-test [ t ] [ pi <float> [ { byte-array } declare *float ] compile-call pi - -0.001 0.001 between? ] unit-test
[ t ] [ pi 8 <byte-array> [ [ { float byte-array } declare 0 set-alien-double ] compile-1 ] keep *double pi = ] unit-test [ t ] [ pi 8 <byte-array> [ [ { float byte-array } declare 0 set-alien-double ] compile-call ] keep *double pi = ] unit-test
[ 4 ] [ [ 4 ] [
2 B{ 1 2 3 4 5 6 } <displaced-alien> [ 2 B{ 1 2 3 4 5 6 } <displaced-alien> [
{ alien } declare 1 alien-unsigned-1 { alien } declare 1 alien-unsigned-1
] compile-1 ] compile-call
] unit-test ] unit-test
[ [
B{ 0 0 0 0 } [ { byte-array } declare <void*> ] compile-1 B{ 0 0 0 0 } [ { byte-array } declare <void*> ] compile-call
] unit-test-fails ] unit-test-fails
[ [
B{ 0 0 0 0 } [ { c-ptr } declare <void*> ] compile-1 B{ 0 0 0 0 } [ { c-ptr } declare <void*> ] compile-call
] unit-test-fails ] unit-test-fails
[ [
@ -441,5 +439,5 @@ cell 8 = [
[ [
{ [ 4444 ] [ 444 ] [ 44 ] [ 4 ] } dispatch { [ 4444 ] [ 444 ] [ 44 ] [ 4 ] } dispatch
] keep 2 fixnum+fast ] keep 2 fixnum+fast
] compile-1 ] compile-call
] unit-test ] unit-test

121
core/compiler/test/optimizer.factor
View File

@ -1,7 +1,8 @@
USING: arrays compiler generic hashtables inference kernel USING: arrays compiler generic hashtables inference kernel
kernel.private math optimizer prettyprint sequences sbufs kernel.private math optimizer prettyprint sequences sbufs
strings tools.test vectors words sequences.private quotations strings tools.test vectors words sequences.private quotations
optimizer.backend classes inference.dataflow tuples.private ; optimizer.backend classes inference.dataflow tuples.private
continuations ;
IN: temporary IN: temporary
[ H{ { 1 5 } { 3 4 } { 2 5 } } ] [ [ H{ { 1 5 } { 3 4 } { 2 5 } } ] [
@ -50,7 +51,7 @@ FORGET: xyz
GENERIC: xyz ( obj -- obj ) GENERIC: xyz ( obj -- obj )
M: array xyz xyz ; M: array xyz xyz ;
[ ] [ \ xyz compile ] unit-test [ t ] [ \ xyz compiled? ] unit-test
! Test predicate inlining ! Test predicate inlining
: pred-test-1 : pred-test-1
@ -101,14 +102,14 @@ TUPLE: pred-test ;
! regression ! regression
: bad-kill-1 [ 3 f ] [ dup bad-kill-1 ] if ; inline : bad-kill-1 ( a b -- c d e ) [ 3 f ] [ dup bad-kill-1 ] if ; inline
: bad-kill-2 bad-kill-1 drop ; : bad-kill-2 bad-kill-1 drop ;
[ 3 ] [ t bad-kill-2 ] unit-test [ 3 ] [ t bad-kill-2 ] unit-test
! regression ! regression
: (the-test) ( n -- ) dup 0 > [ 1- (the-test) ] when ; inline : (the-test) ( x -- y ) dup 0 > [ 1- (the-test) ] when ; inline
: the-test ( -- n ) 2 dup (the-test) ; : the-test ( -- x y ) 2 dup (the-test) ;
[ 2 0 ] [ the-test ] unit-test [ 2 0 ] [ the-test ] unit-test
@ -135,7 +136,7 @@ TUPLE: pred-test ;
! regression ! regression
GENERIC: void-generic ( obj -- * ) GENERIC: void-generic ( obj -- * )
: breakage "hi" void-generic ; : breakage "hi" void-generic ;
[ ] [ \ breakage compile ] unit-test [ t ] [ \ breakage compiled? ] unit-test
[ breakage ] unit-test-fails [ breakage ] unit-test-fails
! regression ! regression
@ -145,10 +146,10 @@ GENERIC: void-generic ( obj -- * )
[ f ] [ f test-2 ] unit-test [ f ] [ f test-2 ] unit-test
: branch-fold-regression-0 ( n -- ) : branch-fold-regression-0 ( m -- n )
t [ ] [ 1+ branch-fold-regression-0 ] if ; inline t [ ] [ 1+ branch-fold-regression-0 ] if ; inline
: branch-fold-regression-1 ( -- ) : branch-fold-regression-1 ( -- m )
10 branch-fold-regression-0 ; 10 branch-fold-regression-0 ;
[ 10 ] [ branch-fold-regression-1 ] unit-test [ 10 ] [ branch-fold-regression-1 ] unit-test
@ -156,7 +157,7 @@ GENERIC: void-generic ( obj -- * )
! another regression ! another regression
: constant-branch-fold-0 "hey" ; foldable : constant-branch-fold-0 "hey" ; foldable
: constant-branch-fold-1 constant-branch-fold-0 "hey" = ; inline : constant-branch-fold-1 constant-branch-fold-0 "hey" = ; inline
[ 1 ] [ [ constant-branch-fold-1 [ 1 ] [ 2 ] if ] compile-1 ] unit-test [ 1 ] [ [ constant-branch-fold-1 [ 1 ] [ 2 ] if ] compile-call ] unit-test
! another regression ! another regression
: foo f ; : foo f ;
@ -170,9 +171,11 @@ GENERIC: void-generic ( obj -- * )
] unit-test ] unit-test
! compiling <tuple> with a non-literal class failed ! compiling <tuple> with a non-literal class failed
[ t ] [ [ <tuple> ] compile-quot word? ] unit-test : <tuple>-regression <tuple> ;
GENERIC: foozul [ t ] [ \ <tuple>-regression compiled? ] unit-test
GENERIC: foozul ( a -- b )
M: reversed foozul ; M: reversed foozul ;
M: integer foozul ; M: integer foozul ;
M: slice foozul ; M: slice foozul ;
@ -184,71 +187,71 @@ M: slice foozul ;
: constant-fold-3 4 ; foldable : constant-fold-3 4 ; foldable
[ f t ] [ [ f t ] [
[ constant-fold-2 constant-fold-3 4 = ] compile-1 [ constant-fold-2 constant-fold-3 4 = ] compile-call
] unit-test ] unit-test
: constant-fold-4 f ; foldable : constant-fold-4 f ; foldable
: constant-fold-5 f ; foldable : constant-fold-5 f ; foldable
[ f ] [ [ f ] [
[ constant-fold-4 constant-fold-5 or ] compile-1 [ constant-fold-4 constant-fold-5 or ] compile-call
] unit-test ] unit-test
[ 5 ] [ 5 [ 0 + ] compile-1 ] unit-test [ 5 ] [ 5 [ 0 + ] compile-call ] unit-test
[ 5 ] [ 5 [ 0 swap + ] compile-1 ] unit-test [ 5 ] [ 5 [ 0 swap + ] compile-call ] unit-test
[ 5 ] [ 5 [ 0 - ] compile-1 ] unit-test [ 5 ] [ 5 [ 0 - ] compile-call ] unit-test
[ -5 ] [ 5 [ 0 swap - ] compile-1 ] unit-test [ -5 ] [ 5 [ 0 swap - ] compile-call ] unit-test
[ 0 ] [ 5 [ dup - ] compile-1 ] unit-test [ 0 ] [ 5 [ dup - ] compile-call ] unit-test
[ 5 ] [ 5 [ 1 * ] compile-1 ] unit-test [ 5 ] [ 5 [ 1 * ] compile-call ] unit-test
[ 5 ] [ 5 [ 1 swap * ] compile-1 ] unit-test [ 5 ] [ 5 [ 1 swap * ] compile-call ] unit-test
[ 0 ] [ 5 [ 0 * ] compile-1 ] unit-test [ 0 ] [ 5 [ 0 * ] compile-call ] unit-test
[ 0 ] [ 5 [ 0 swap * ] compile-1 ] unit-test [ 0 ] [ 5 [ 0 swap * ] compile-call ] unit-test
[ -5 ] [ 5 [ -1 * ] compile-1 ] unit-test [ -5 ] [ 5 [ -1 * ] compile-call ] unit-test
[ -5 ] [ 5 [ -1 swap * ] compile-1 ] unit-test [ -5 ] [ 5 [ -1 swap * ] compile-call ] unit-test
[ 0 ] [ 5 [ 1 mod ] compile-1 ] unit-test [ 0 ] [ 5 [ 1 mod ] compile-call ] unit-test
[ 0 ] [ 5 [ 1 rem ] compile-1 ] unit-test [ 0 ] [ 5 [ 1 rem ] compile-call ] unit-test
[ 5 ] [ 5 [ -1 bitand ] compile-1 ] unit-test [ 5 ] [ 5 [ -1 bitand ] compile-call ] unit-test
[ 0 ] [ 5 [ 0 bitand ] compile-1 ] unit-test [ 0 ] [ 5 [ 0 bitand ] compile-call ] unit-test
[ 5 ] [ 5 [ -1 swap bitand ] compile-1 ] unit-test [ 5 ] [ 5 [ -1 swap bitand ] compile-call ] unit-test
[ 0 ] [ 5 [ 0 swap bitand ] compile-1 ] unit-test [ 0 ] [ 5 [ 0 swap bitand ] compile-call ] unit-test
[ 5 ] [ 5 [ dup bitand ] compile-1 ] unit-test [ 5 ] [ 5 [ dup bitand ] compile-call ] unit-test
[ 5 ] [ 5 [ 0 bitor ] compile-1 ] unit-test [ 5 ] [ 5 [ 0 bitor ] compile-call ] unit-test
[ -1 ] [ 5 [ -1 bitor ] compile-1 ] unit-test [ -1 ] [ 5 [ -1 bitor ] compile-call ] unit-test
[ 5 ] [ 5 [ 0 swap bitor ] compile-1 ] unit-test [ 5 ] [ 5 [ 0 swap bitor ] compile-call ] unit-test
[ -1 ] [ 5 [ -1 swap bitor ] compile-1 ] unit-test [ -1 ] [ 5 [ -1 swap bitor ] compile-call ] unit-test
[ 5 ] [ 5 [ dup bitor ] compile-1 ] unit-test [ 5 ] [ 5 [ dup bitor ] compile-call ] unit-test
[ 5 ] [ 5 [ 0 bitxor ] compile-1 ] unit-test [ 5 ] [ 5 [ 0 bitxor ] compile-call ] unit-test
[ 5 ] [ 5 [ 0 swap bitxor ] compile-1 ] unit-test [ 5 ] [ 5 [ 0 swap bitxor ] compile-call ] unit-test
[ -6 ] [ 5 [ -1 bitxor ] compile-1 ] unit-test [ -6 ] [ 5 [ -1 bitxor ] compile-call ] unit-test
[ -6 ] [ 5 [ -1 swap bitxor ] compile-1 ] unit-test [ -6 ] [ 5 [ -1 swap bitxor ] compile-call ] unit-test
[ 0 ] [ 5 [ dup bitxor ] compile-1 ] unit-test [ 0 ] [ 5 [ dup bitxor ] compile-call ] unit-test
[ 0 ] [ 5 [ 0 swap shift ] compile-1 ] unit-test [ 0 ] [ 5 [ 0 swap shift ] compile-call ] unit-test
[ 5 ] [ 5 [ 0 shift ] compile-1 ] unit-test [ 5 ] [ 5 [ 0 shift ] compile-call ] unit-test
[ f ] [ 5 [ dup < ] compile-1 ] unit-test [ f ] [ 5 [ dup < ] compile-call ] unit-test
[ t ] [ 5 [ dup <= ] compile-1 ] unit-test [ t ] [ 5 [ dup <= ] compile-call ] unit-test
[ f ] [ 5 [ dup > ] compile-1 ] unit-test [ f ] [ 5 [ dup > ] compile-call ] unit-test
[ t ] [ 5 [ dup >= ] compile-1 ] unit-test [ t ] [ 5 [ dup >= ] compile-call ] unit-test
[ t ] [ 5 [ dup eq? ] compile-1 ] unit-test [ t ] [ 5 [ dup eq? ] compile-call ] unit-test
[ t ] [ 5 [ dup = ] compile-1 ] unit-test [ t ] [ 5 [ dup = ] compile-call ] unit-test
[ t ] [ 5 [ dup number= ] compile-1 ] unit-test [ t ] [ 5 [ dup number= ] compile-call ] unit-test
[ t ] [ \ vector [ \ vector = ] compile-1 ] unit-test [ t ] [ \ vector [ \ vector = ] compile-call ] unit-test
GENERIC: detect-number ( obj -- obj ) GENERIC: detect-number ( obj -- obj )
M: number detect-number ; M: number detect-number ;
[ 10 f [ <array> 0 + detect-number ] compile-1 ] unit-test-fails [ 10 f [ <array> 0 + detect-number ] compile-call ] unit-test-fails
! Regression ! Regression
[ 4 [ + ] ] [ 2 2 [ [ + ] [ call ] keep ] compile-1 ] unit-test [ 4 [ + ] ] [ 2 2 [ [ + ] [ call ] keep ] compile-call ] unit-test
! Regression ! Regression
USE: sorting USE: sorting
@ -265,7 +268,7 @@ USE: sorting.private
[ 10 ] [ [ 10 ] [
10 20 >vector <flat-slice> 10 20 >vector <flat-slice>
[ [ - ] swap old-binsearch ] compile-1 2nip [ [ - ] swap old-binsearch ] compile-call 2nip
] unit-test ] unit-test
! Regression ! Regression
@ -275,5 +278,13 @@ TUPLE: silly-tuple a b ;
T{ silly-tuple f 1 2 } T{ silly-tuple f 1 2 }
[ [
{ silly-tuple-a silly-tuple-b } [ get-slots ] keep { silly-tuple-a silly-tuple-b } [ get-slots ] keep
] compile-1 ] compile-call
] unit-test ] unit-test
! Regression
: empty-compound ;
: node-successor-f-bug ( x -- * )
[ 3 throw ] [ empty-compound ] compose [ 3 throw ] if ;
[ t ] [ \ node-successor-f-bug compiled? ] unit-test

197
core/compiler/test/redefine.factor
View File

@ -1,42 +1,175 @@
USING: compiler definitions generic assocs inference math USING: compiler definitions generic assocs inference math
namespaces parser tools.test words kernel sequences arrays io namespaces parser tools.test words kernel sequences arrays io
effects tools.test.inference ; effects tools.test.inference words.private ;
IN: temporary IN: temporary
parse-hook get [ DEFER: x-1
DEFER: foo \ foo reset-generic DEFER: x-2
DEFER: bar \ bar reset-generic
[ ] [ \ foo [ 1 2 ] define-compound ] unit-test [ [ f ] { } map>assoc modify-code-heap ] recompile-hook [
{ 0 2 } [ foo ] unit-test-effect "IN: temporary USE: math GENERIC: x-1 ( x -- y ) M: integer x-1 ;" eval
[ ] [ \ foo compile ] unit-test "IN: temporary : x-2 3 x-1 ;" eval
[ ] [ \ bar [ foo foo ] define-compound ] unit-test
[ ] [ \ bar compile ] unit-test
[ ] [ \ foo [ 1 2 3 ] define-compound ] unit-test
[ t ] [ \ bar changed-words get key? ] unit-test
[ ] [ recompile ] unit-test
{ 0 3 } [ foo ] unit-test-effect
[ f ] [ \ bar changed-words get key? ] unit-test
[ ] [ \ bar [ 1 2 ] define-compound ] unit-test
[ t ] [ \ bar changed-words get key? ] unit-test
[ ] [ recompile ] unit-test
{ 0 2 } [ bar ] unit-test-effect
[ f ] [ \ bar changed-words get key? ] unit-test
[ ] [ \ foo [ 1 2 3 ] define-compound ] unit-test
[ f ] [ \ bar changed-words get key? ] unit-test
[ ] [ \ bar [ 1 2 3 ] define-compound ] unit-test
[ t ] [ \ bar changed-words get key? ] unit-test
[ ] [ \ bar forget ] unit-test
[ f ] [ \ bar changed-words get key? ] unit-test
: xy ; [ t ] [
: yx xy ; { x-2 } compile
\ yx compile \ x-2 word-xt
\ xy [ 1 ] define-compound { x-1 } compile
[ ] [ recompile ] unit-test \ x-2 word-xt eq?
] unit-test
] with-variable
[ 1 ] [ yx ] unit-test DEFER: b
] when DEFER: c
[ ] [ "IN: temporary : a 1 2 ; : b a a ;" eval ] unit-test
[ 1 2 1 2 ] [ "USE: temporary b" eval ] unit-test
{ 0 4 } [ b ] unit-test-effect
[ ] [ "IN: temporary : a 1 2 3 ;" eval ] unit-test
[ 1 2 3 1 2 3 ] [ "USE: temporary b" eval ] unit-test
{ 0 6 } [ b ] unit-test-effect
\ b word-xt "b-xt" set
[ ] [ "IN: temporary : c b ;" eval ] unit-test
[ t ] [ "b-xt" get \ b word-xt = ] unit-test
\ c word-xt "c-xt" set
[ ] [ "IN: temporary : a 1 2 4 ;" eval ] unit-test
[ t ] [ "c-xt" get \ c word-xt = ] unit-test
[ 1 2 4 1 2 4 ] [ "USE: temporary c" eval ] unit-test
[ ] [ "IN: temporary : a 1 2 ;" eval ] unit-test
{ 0 4 } [ c ] unit-test-effect
[ f ] [ "c-xt" get \ c word-xt = ] unit-test
[ 1 2 1 2 ] [ "USE: temporary c" eval ] unit-test
[ ] [ "IN: temporary : d 3 ; inline" eval ] unit-test
[ ] [ "IN: temporary : e d d ;" eval ] unit-test
[ 3 3 ] [ "USE: temporary e" eval ] unit-test
[ ] [ "IN: temporary : d 4 ; inline" eval ] unit-test
[ 4 4 ] [ "USE: temporary e" eval ] unit-test
DEFER: x-3
[ ] [ "IN: temporary : x-3 3 ;" eval ] unit-test
DEFER: x-4
[ ] [ "IN: temporary : x-4 x-3 ;" eval ] unit-test
[ t ] [ \ x-4 compiled? ] unit-test
[ ] [ "IN: temporary USE: sequences : x-3 { } [ ] each ;" eval ] unit-test
[ f ] [ \ x-3 compiled? ] unit-test
[ f ] [ \ x-4 compiled? ] unit-test
[ ] [ "IN: temporary USING: kernel sequences ; : x-3 { } [ drop ] each ;" eval ] unit-test
[ t ] [ \ x-3 compiled? ] unit-test
[ t ] [ \ x-4 compiled? ] unit-test
[ t ] [ \ x-3 "compiled-uses" word-prop >boolean ] unit-test
[ t ] [ \ x-3 "compiled-uses" word-prop [ interned? ] all? ] unit-test
DEFER: g-test-1
DEFER: g-test-3
[ ] [ "IN: temporary USE: math GENERIC: g-test-1 ( x -- y ) M: integer g-test-1 sq ;" eval ] unit-test
[ ] [ "IN: temporary : g-test-2 ( -- y ) 3 g-test-1 ;" eval ] unit-test
[ ] [ "IN: temporary : g-test-3 ( -- y ) g-test-2 ;" eval ] unit-test
[ 25 ] [ 5 g-test-1 ] unit-test
[ ] [ "IN: temporary USE: math GENERIC: g-test-1 ( x -- y ) M: integer g-test-1 ;" eval ] unit-test
[ 5 ] [ 5 g-test-1 ] unit-test
[ t ] [
\ g-test-3 word-xt
"IN: temporary USE: math GENERIC: g-test-1 ( x -- y ) M: integer g-test-1 3 + ;" eval
\ g-test-3 word-xt eq?
] unit-test
DEFER: g-test-5
[ ] [ "IN: temporary : g-test-4 ( -- y ) 3 g-test-1 ; inline" eval ] unit-test
[ ] [ "IN: temporary : g-test-5 ( -- y ) g-test-4 ;" eval ] unit-test
[ 6 ] [ g-test-5 ] unit-test
[ ] [ "IN: temporary USE: math GENERIC: g-test-1 ( x -- y ) M: integer g-test-1 10 + ;" eval ] unit-test
[ 13 ] [ g-test-5 ] unit-test
DEFER: g-test-6
[ ] [ "IN: temporary USING: arrays kernel ; GENERIC: g-test-6 ( x -- y ) M: array g-test-6 drop 123 g-test-1 ;" eval ] unit-test
DEFER: g-test-7
[ ] [ "IN: temporary : g-test-7 { } g-test-6 ;" eval ] unit-test
[ 133 ] [ g-test-7 ] unit-test
[ ] [ "IN: temporary USE: math GENERIC: g-test-1 ( x -- y ) M: integer g-test-1 15 + ;" eval ] unit-test
[ 138 ] [ g-test-7 ] unit-test
USE: macros
DEFER: macro-test-3
[ ] [ "IN: temporary USING: macros math ; : macro-test-1 sq ;" eval ] unit-test
[ ] [ "IN: temporary USING: macros arrays quotations ; MACRO: macro-test-2 ( n word -- quot ) <array> >quotation ;" eval ] unit-test
[ ] [ "IN: temporary : macro-test-3 2 \\ macro-test-1 macro-test-2 ;" eval ] unit-test
[ 625 ] [ 5 macro-test-3 ] unit-test
[ ] [ "IN: temporary USING: macros arrays quotations kernel math ; MACRO: macro-test-2 ( n word -- quot ) 2drop [ 3 + ] ;" eval ] unit-test
[ 8 ] [ 5 macro-test-3 ] unit-test
USE: hints
DEFER: hints-test-2
[ ] [ "IN: temporary USING: math hints ; : hints-test-1 3 + ; HINTS: hints-test-1 fixnum ;" eval ] unit-test
[ ] [ "IN: temporary : hints-test-2 5 hints-test-1 ;" eval ] unit-test
[ 8 ] [ hints-test-2 ] unit-test
[ ] [ "IN: temporary USE: math : hints-test-1 5 + ;" eval ] unit-test
[ 10 ] [ hints-test-2 ] unit-test

64
core/compiler/test/simple.factor Normal file → Executable file
View File

@ -3,61 +3,63 @@ combinators.private ;
IN: temporary IN: temporary
! Test empty word ! Test empty word
[ ] [ [ ] compile-1 ] unit-test [ ] [ [ ] compile-call ] unit-test
! Test literals ! Test literals
[ 1 ] [ [ 1 ] compile-1 ] unit-test [ 1 ] [ [ 1 ] compile-call ] unit-test
[ 31 ] [ [ 31 ] compile-1 ] unit-test [ 31 ] [ [ 31 ] compile-call ] unit-test
[ 255 ] [ [ 255 ] compile-1 ] unit-test [ 255 ] [ [ 255 ] compile-call ] unit-test
[ -1 ] [ [ -1 ] compile-1 ] unit-test [ -1 ] [ [ -1 ] compile-call ] unit-test
[ 65536 ] [ [ 65536 ] compile-1 ] unit-test [ 65536 ] [ [ 65536 ] compile-call ] unit-test
[ -65536 ] [ [ -65536 ] compile-1 ] unit-test [ -65536 ] [ [ -65536 ] compile-call ] unit-test
[ "hey" ] [ [ "hey" ] compile-1 ] unit-test [ "hey" ] [ [ "hey" ] compile-call ] unit-test
! Calls ! Calls
: no-op ; : no-op ;
[ ] [ [ no-op ] compile-1 ] unit-test [ ] [ [ no-op ] compile-call ] unit-test
[ 3 ] [ [ no-op 3 ] compile-1 ] unit-test [ 3 ] [ [ no-op 3 ] compile-call ] unit-test
[ 3 ] [ [ 3 no-op ] compile-1 ] unit-test [ 3 ] [ [ 3 no-op ] compile-call ] unit-test
: bar 4 ; : bar 4 ;
[ 4 ] [ [ bar no-op ] compile-1 ] unit-test [ 4 ] [ [ bar no-op ] compile-call ] unit-test
[ 4 3 ] [ [ no-op bar 3 ] compile-1 ] unit-test [ 4 3 ] [ [ no-op bar 3 ] compile-call ] unit-test
[ 3 4 ] [ [ 3 no-op bar ] compile-1 ] unit-test [ 3 4 ] [ [ 3 no-op bar ] compile-call ] unit-test
[ ] [ no-op ] unit-test [ ] [ no-op ] unit-test
! Conditionals ! Conditionals
[ 1 ] [ t [ [ 1 ] [ 2 ] if ] compile-1 ] unit-test [ 1 ] [ t [ [ 1 ] [ 2 ] if ] compile-call ] unit-test
[ 2 ] [ f [ [ 1 ] [ 2 ] if ] compile-1 ] unit-test [ 2 ] [ f [ [ 1 ] [ 2 ] if ] compile-call ] unit-test
[ 1 3 ] [ t [ [ 1 ] [ 2 ] if 3 ] compile-1 ] unit-test [ 1 3 ] [ t [ [ 1 ] [ 2 ] if 3 ] compile-call ] unit-test
[ 2 3 ] [ f [ [ 1 ] [ 2 ] if 3 ] compile-1 ] unit-test [ 2 3 ] [ f [ [ 1 ] [ 2 ] if 3 ] compile-call ] unit-test
[ "hi" ] [ 0 [ { [ "hi" ] [ "bye" ] } dispatch ] compile-1 ] unit-test [ "hi" ] [ 0 [ { [ "hi" ] [ "bye" ] } dispatch ] compile-call ] unit-test
[ "bye" ] [ 1 [ { [ "hi" ] [ "bye" ] } dispatch ] compile-1 ] unit-test [ "bye" ] [ 1 [ { [ "hi" ] [ "bye" ] } dispatch ] compile-call ] unit-test
[ "hi" 3 ] [ 0 [ { [ "hi" ] [ "bye" ] } dispatch 3 ] compile-1 ] unit-test [ "hi" 3 ] [ 0 [ { [ "hi" ] [ "bye" ] } dispatch 3 ] compile-call ] unit-test
[ "bye" 3 ] [ 1 [ { [ "hi" ] [ "bye" ] } dispatch 3 ] compile-1 ] unit-test [ "bye" 3 ] [ 1 [ { [ "hi" ] [ "bye" ] } dispatch 3 ] compile-call ] unit-test
[ 4 1 ] [ 0 [ { [ bar 1 ] [ 3 1 ] } dispatch ] compile-1 ] unit-test [ 4 1 ] [ 0 [ { [ bar 1 ] [ 3 1 ] } dispatch ] compile-call ] unit-test
[ 3 1 ] [ 1 [ { [ bar 1 ] [ 3 1 ] } dispatch ] compile-1 ] unit-test [ 3 1 ] [ 1 [ { [ bar 1 ] [ 3 1 ] } dispatch ] compile-call ] unit-test
[ 4 1 3 ] [ 0 [ { [ bar 1 ] [ 3 1 ] } dispatch 3 ] compile-1 ] unit-test [ 4 1 3 ] [ 0 [ { [ bar 1 ] [ 3 1 ] } dispatch 3 ] compile-call ] unit-test
[ 3 1 3 ] [ 1 [ { [ bar 1 ] [ 3 1 ] } dispatch 3 ] compile-1 ] unit-test [ 3 1 3 ] [ 1 [ { [ bar 1 ] [ 3 1 ] } dispatch 3 ] compile-call ] unit-test
! Labels ! Labels
: recursive ( ? -- ) [ f recursive ] when ; inline : recursive ( ? -- ) [ f recursive ] when ; inline
[ ] [ t [ recursive ] compile-1 ] unit-test [ ] [ t [ recursive ] compile-call ] unit-test
\ recursive compile
[ ] [ t recursive ] unit-test [ ] [ t recursive ] unit-test
! Make sure error reporting works ! Make sure error reporting works
[ [ dup ] compile-1 ] unit-test-fails [ [ dup ] compile-call ] unit-test-fails
[ [ drop ] compile-1 ] unit-test-fails [ [ drop ] compile-call ] unit-test-fails
! Regression
[ ] [ [ callstack ] compile-call drop ] unit-test

3
core/compiler/test/stack-trace.factor
View File

@ -10,7 +10,6 @@ words splitting ;
: foo 3 throw 7 ; : foo 3 throw 7 ;
: bar foo 4 ; : bar foo 4 ;
: baz bar 5 ; : baz bar 5 ;
\ baz compile
[ 3 ] [ [ baz ] catch ] unit-test [ 3 ] [ [ baz ] catch ] unit-test
[ t ] [ [ t ] [
symbolic-stack-trace symbolic-stack-trace
@ -19,7 +18,6 @@ words splitting ;
] unit-test ] unit-test
: bleh [ 3 + ] map [ 0 > ] subset ; : bleh [ 3 + ] map [ 0 > ] subset ;
\ bleh compile
: stack-trace-contains? symbolic-stack-trace memq? ; : stack-trace-contains? symbolic-stack-trace memq? ;
@ -34,7 +32,6 @@ words splitting ;
] unit-test ] unit-test
: quux [ t [ "hi" throw ] when ] times ; : quux [ t [ "hi" throw ] when ] times ;
\ quux compile
[ t ] [ [ t ] [
[ 10 quux ] catch drop [ 10 quux ] catch drop

19
core/compiler/test/templates-early.factor Normal file → Executable file
View File

@ -2,7 +2,7 @@
IN: temporary IN: temporary
USING: compiler generator generator.registers USING: compiler generator generator.registers
generator.registers.private tools.test namespaces sequences generator.registers.private tools.test namespaces sequences
words kernel math effects ; words kernel math effects definitions ;
: <int-vreg> ( n -- vreg ) T{ int-regs } <vreg> ; : <int-vreg> ( n -- vreg ) T{ int-regs } <vreg> ;
@ -44,7 +44,7 @@ words kernel math effects ;
[ [
[ ] [ init-templates ] unit-test [ ] [ init-templates ] unit-test
[ ] [ init-generator ] unit-test [ ] [ \ + init-generator ] unit-test
[ t ] [ [ end-basic-block ] { } make empty? ] unit-test [ t ] [ [ end-basic-block ] { } make empty? ] unit-test
@ -68,7 +68,7 @@ words kernel math effects ;
! Test template picking strategy ! Test template picking strategy
SYMBOL: template-chosen SYMBOL: template-chosen
: template-test ( a b -- c ) + ; : template-test ( a b -- c d ) ;
\ template-test { \ template-test {
{ {
@ -76,7 +76,7 @@ SYMBOL: template-chosen
1 template-chosen get push 1 template-chosen get push
] H{ ] H{
{ +input+ { { f "obj" } { [ ] "n" } } } { +input+ { { f "obj" } { [ ] "n" } } }
{ +output+ { "obj" } } { +output+ { "obj" "obj" } }
} }
} }
{ {
@ -84,26 +84,26 @@ SYMBOL: template-chosen
2 template-chosen get push 2 template-chosen get push
] H{ ] H{
{ +input+ { { f "obj" } { f "n" } } } { +input+ { { f "obj" } { f "n" } } }
{ +output+ { "obj" } } { +output+ { "obj" "n" } }
} }
} }
} define-intrinsics } define-intrinsics
[ V{ 2 } ] [ [ V{ 2 } ] [
V{ } clone template-chosen set V{ } clone template-chosen set
[ template-test ] compile-quot drop 0 0 [ template-test ] compile-call 2drop
template-chosen get template-chosen get
] unit-test ] unit-test
[ V{ 1 } ] [ [ V{ 1 } ] [
V{ } clone template-chosen set V{ } clone template-chosen set
[ dup 0 template-test ] compile-quot drop 1 [ dup 0 template-test ] compile-call 3drop
template-chosen get template-chosen get
] unit-test ] unit-test
[ V{ 1 } ] [ [ V{ 1 } ] [
V{ } clone template-chosen set V{ } clone template-chosen set
[ 0 template-test ] compile-quot drop 1 [ 0 template-test ] compile-call 2drop
template-chosen get template-chosen get
] unit-test ] unit-test
@ -209,7 +209,8 @@ H{
{ { f "x" } { f "y" } } define-if-intrinsic { { f "x" } { f "y" } } define-if-intrinsic
[ ] [ [ ] [
[ 2 template-choice-1 template-choice-2 ] compile-quot drop [ 2 template-choice-1 template-choice-2 ]
[ define-temp ] with-compilation-unit drop
] unit-test ] unit-test
[ V{ "template-choice-1" "template-choice-2" } ] [ V{ "template-choice-1" "template-choice-2" } ]

75
core/compiler/test/templates.factor
View File

@ -1,54 +1,53 @@
! Black box testing of templating optimization ! Black box testing of templating optimization
USING: arrays compiler kernel kernel.private math USING: arrays compiler kernel kernel.private math
hashtables.private math.private namespaces sequences hashtables.private math.private namespaces sequences
sequences.private tools.test namespaces.private slots.private sequences.private tools.test namespaces.private slots.private
combinators.private byte-arrays alien layouts ; combinators.private byte-arrays alien layouts words definitions ;
IN: temporary IN: temporary
! Oops! ! Oops!
[ 5000 ] [ [ 5000 ] compile-1 ] unit-test [ 5000 ] [ [ 5000 ] compile-call ] unit-test
[ "hi" ] [ [ "hi" ] compile-1 ] unit-test [ "hi" ] [ [ "hi" ] compile-call ] unit-test
[ 1 2 3 4 ] [ [ 1 2 3 4 ] compile-1 ] unit-test [ 1 2 3 4 ] [ [ 1 2 3 4 ] compile-call ] unit-test
[ 1 1 ] [ 1 [ dup ] compile-1 ] unit-test [ 1 1 ] [ 1 [ dup ] compile-call ] unit-test
[ 0 ] [ 3 [ tag ] compile-1 ] unit-test [ 0 ] [ 3 [ tag ] compile-call ] unit-test
[ 0 3 ] [ 3 [ [ tag ] keep ] compile-1 ] unit-test [ 0 3 ] [ 3 [ [ tag ] keep ] compile-call ] unit-test
[ 2 3 ] [ 3 [ 2 swap ] compile-1 ] unit-test [ 2 3 ] [ 3 [ 2 swap ] compile-call ] unit-test
[ 2 1 3 4 ] [ 1 2 [ swap 3 4 ] compile-1 ] unit-test [ 2 1 3 4 ] [ 1 2 [ swap 3 4 ] compile-call ] unit-test
[ 2 3 4 ] [ 3 [ 2 swap 4 ] compile-1 ] unit-test [ 2 3 4 ] [ 3 [ 2 swap 4 ] compile-call ] unit-test
[ { 1 2 3 } { 1 4 3 } 3 3 ] [ { 1 2 3 } { 1 4 3 } 3 3 ]
[ { 1 2 3 } { 1 4 3 } [ over tag over tag ] compile-1 ] [ { 1 2 3 } { 1 4 3 } [ over tag over tag ] compile-call ]
unit-test unit-test
[ { 1 2 3 } { 1 4 3 } 8 8 ] [ { 1 2 3 } { 1 4 3 } 8 8 ]
[ { 1 2 3 } { 1 4 3 } [ over type over type ] compile-1 ] [ { 1 2 3 } { 1 4 3 } [ over type over type ] compile-call ]
unit-test unit-test
! Test literals in either side of a shuffle ! Test literals in either side of a shuffle
[ 4 1 ] [ 1 [ [ 3 fixnum+ ] keep ] compile-1 ] unit-test [ 4 1 ] [ 1 [ [ 3 fixnum+ ] keep ] compile-call ] unit-test
[ 2 ] [ 1 2 [ swap fixnum/i ] compile-1 ] unit-test [ 2 ] [ 1 2 [ swap fixnum/i ] compile-call ] unit-test
: foo ; : foo ;
[ 5 5 ] [ 5 5 ]
[ 1.2 [ tag [ foo ] keep ] compile-1 ] [ 1.2 [ tag [ foo ] keep ] compile-call ]
unit-test unit-test
[ 1 2 2 ] [ 1 2 2 ]
[ { 1 2 } [ dup 2 slot swap 3 slot [ foo ] keep ] compile-1 ] [ { 1 2 } [ dup 2 slot swap 3 slot [ foo ] keep ] compile-call ]
unit-test unit-test
[ 3 ] [ 3 ]
[ [
global [ 3 \ foo set ] bind global [ 3 \ foo set ] bind
\ foo [ global >n get ndrop ] compile-1 \ foo [ global >n get ndrop ] compile-call
] unit-test ] unit-test
: blech drop ; : blech drop ;
@ -56,53 +55,53 @@ unit-test
[ 3 ] [ 3 ]
[ [
global [ 3 \ foo set ] bind global [ 3 \ foo set ] bind
\ foo [ global [ get ] swap blech call ] compile-1 \ foo [ global [ get ] swap blech call ] compile-call
] unit-test ] unit-test
[ 3 ] [ 3 ]
[ [
global [ 3 \ foo set ] bind global [ 3 \ foo set ] bind
\ foo [ global [ get ] swap >n call ndrop ] compile-1 \ foo [ global [ get ] swap >n call ndrop ] compile-call
] unit-test ] unit-test
[ 3 ] [ 3 ]
[ [
global [ 3 \ foo set ] bind global [ 3 \ foo set ] bind
\ foo [ global [ get ] bind ] compile-1 \ foo [ global [ get ] bind ] compile-call
] unit-test ] unit-test
[ 12 13 ] [ [ 12 13 ] [
-12 -13 [ [ 0 swap fixnum-fast ] 2apply ] compile-1 -12 -13 [ [ 0 swap fixnum-fast ] 2apply ] compile-call
] unit-test ] unit-test
[ -1 2 ] [ 1 2 [ >r 0 swap fixnum- r> ] compile-1 ] unit-test [ -1 2 ] [ 1 2 [ >r 0 swap fixnum- r> ] compile-call ] unit-test
[ 12 13 ] [ [ 12 13 ] [
-12 -13 [ [ 0 swap fixnum- ] 2apply ] compile-1 -12 -13 [ [ 0 swap fixnum- ] 2apply ] compile-call
] unit-test ] unit-test
[ 2 ] [ [ 2 ] [
SBUF" " [ 2 slot 2 [ slot ] keep ] compile-1 nip SBUF" " [ 2 slot 2 [ slot ] keep ] compile-call nip
] unit-test ] unit-test
! Test slow shuffles ! Test slow shuffles
[ 3 1 2 3 4 5 6 7 8 9 ] [ [ 3 1 2 3 4 5 6 7 8 9 ] [
1 2 3 4 5 6 7 8 9 1 2 3 4 5 6 7 8 9
[ >r >r >r >r >r >r >r >r >r 3 r> r> r> r> r> r> r> r> r> ] [ >r >r >r >r >r >r >r >r >r 3 r> r> r> r> r> r> r> r> r> ]
compile-1 compile-call
] unit-test ] unit-test
[ 2 2 2 2 2 2 2 2 2 2 1 ] [ [ 2 2 2 2 2 2 2 2 2 2 1 ] [
1 2 1 2
[ swap >r dup dup dup dup dup dup dup dup dup r> ] compile-1 [ swap >r dup dup dup dup dup dup dup dup dup r> ] compile-call
] unit-test ] unit-test
[ ] [ [ 9 [ ] times ] compile-1 ] unit-test [ ] [ [ 9 [ ] times ] compile-call ] unit-test
[ ] [ [ ] [
[ [
[ 200 dup [ 200 3array ] curry map drop ] times [ 200 dup [ 200 3array ] curry map drop ] times
] compile-quot drop ] [ define-temp ] with-compilation-unit drop
] unit-test ] unit-test
@ -122,7 +121,7 @@ unit-test
[ 2.0 { 2.0 0.0 } ] [ [ 2.0 { 2.0 0.0 } ] [
2.0 1.0 2.0 1.0
[ float/f 0.0 [ drop (broken) ] 2keep 2array ] compile-1 [ float/f 0.0 [ drop (broken) ] 2keep 2array ] compile-call
] unit-test ] unit-test
! Regression ! Regression
@ -143,7 +142,7 @@ unit-test
[ ] [ [ ] [
H{ { 1 2 } { 3 4 } } dup hash-array H{ { 1 2 } { 3 4 } } dup hash-array
[ 0 swap hellish-bug-2 drop ] compile-1 [ 0 swap hellish-bug-2 drop ] compile-call
] unit-test ] unit-test
! Regression ! Regression
@ -160,34 +159,34 @@ TUPLE: my-tuple ;
[ 5 ] [ "hi" foox ] unit-test [ 5 ] [ "hi" foox ] unit-test
! Making sure we don't needlessly unbox/rebox ! Making sure we don't needlessly unbox/rebox
[ t 3.0 ] [ 1.0 dup [ dup 2.0 float+ >r eq? r> ] compile-1 ] unit-test [ t 3.0 ] [ 1.0 dup [ dup 2.0 float+ >r eq? r> ] compile-call ] unit-test
[ t 3.0 ] [ 1.0 dup [ dup 2.0 float+ ] compile-1 >r eq? r> ] unit-test [ t 3.0 ] [ 1.0 dup [ dup 2.0 float+ ] compile-call >r eq? r> ] unit-test
[ t ] [ 1.0 dup [ [ 2.0 float+ ] keep ] compile-1 nip eq? ] unit-test [ t ] [ 1.0 dup [ [ 2.0 float+ ] keep ] compile-call nip eq? ] unit-test
[ 1 B{ 1 2 3 4 } ] [ [ 1 B{ 1 2 3 4 } ] [
B{ 1 2 3 4 } [ B{ 1 2 3 4 } [
{ byte-array } declare { byte-array } declare
[ 0 alien-unsigned-1 ] keep [ 0 alien-unsigned-1 ] keep
] compile-1 ] compile-call
] unit-test ] unit-test
[ 1 t ] [ [ 1 t ] [
B{ 1 2 3 4 } [ B{ 1 2 3 4 } [
{ c-ptr } declare { c-ptr } declare
[ 0 alien-unsigned-1 ] keep type [ 0 alien-unsigned-1 ] keep type
] compile-1 byte-array type-number = ] compile-call byte-array type-number =
] unit-test ] unit-test
[ t ] [ [ t ] [
B{ 1 2 3 4 } [ B{ 1 2 3 4 } [
{ c-ptr } declare { c-ptr } declare
0 alien-cell type 0 alien-cell type
] compile-1 alien type-number = ] compile-call alien type-number =
] unit-test ] unit-test
[ 2 1 ] [ [ 2 1 ] [
2 1 2 1
[ 2dup fixnum< [ >r die r> ] when ] compile-1 [ 2dup fixnum< [ >r die r> ] when ] compile-call
] unit-test ] unit-test

12
core/compiler/test/tuples.factor Normal file → Executable file
View File

@ -4,11 +4,11 @@ USING: kernel tools.test compiler ;
TUPLE: color red green blue ; TUPLE: color red green blue ;
[ T{ color f 1 2 3 } ] [ T{ color f 1 2 3 } ]
[ 1 2 3 [ color construct-boa ] compile-1 ] unit-test [ 1 2 3 [ color construct-boa ] compile-call ] unit-test
[ 1 3 ] [ [ 1 3 ] [
1 2 3 color construct-boa 1 2 3 color construct-boa
[ { color-red color-blue } get-slots ] compile-1 [ { color-red color-blue } get-slots ] compile-call
] unit-test ] unit-test
[ T{ color f 10 2 20 } ] [ [ T{ color f 10 2 20 } ] [
@ -16,17 +16,17 @@ TUPLE: color red green blue ;
1 2 3 color construct-boa [ 1 2 3 color construct-boa [
[ [
{ set-color-red set-color-blue } set-slots { set-color-red set-color-blue } set-slots
] compile-1 ] compile-call
] keep ] keep
] unit-test ] unit-test
[ T{ color f f f f } ] [ T{ color f f f f } ]
[ [ color construct-empty ] compile-1 ] unit-test [ [ color construct-empty ] compile-call ] unit-test
[ T{ color "a" f "b" f } ] [ [ T{ color "a" f "b" f } ] [
"a" "b" "a" "b"
[ { set-delegate set-color-green } color construct ] [ { set-delegate set-color-green } color construct ]
compile-1 compile-call
] unit-test ] unit-test
[ T{ color f f f f } ] [ [ { } color construct ] compile-1 ] unit-test [ T{ color f f f f } ] [ [ { } color construct ] compile-call ] unit-test

70
core/compiler/units/units-docs.factor Normal file
View File

@ -0,0 +1,70 @@
USING: help.markup help.syntax words math source-files
parser quotations definitions ;
IN: compiler.units
ARTICLE: "compilation-units" "Compilation units"
"A " { $emphasis "compilation unit" } " scopes a group of related definitions. They are compiled and entered into the system in one atomic operation."
$nl
"Words defined in a compilation unit may not be called until the compilation unit is finished. The parser detects this case for parsing words and throws a " { $link staging-violation } "; calling any other word from within its own compilation unit throws an " { $link undefined } " error."
$nl
"The parser groups all definitions in a source file into one compilation unit, and parsing words do not need to concern themselves with compilation units. However, if definitions are being created at run time, a compilation unit must be created explicitly:"
{ $subsection with-compilation-unit }
"Words called to associate a definition with a source file location:"
{ $subsection remember-definition }
{ $subsection remember-class }
"Forward reference checking (see " { $link "definition-checking" } "):"
{ $subsection forward-reference? }
"A hook to be called at the end of the compilation unit. If the optimizing compiler is loaded, this compiles new words with the " { $link "compiler" } ":"
{ $subsection recompile-hook }
"Low-level compiler interface exported by the Factor VM:"
{ $subsection modify-code-heap } ;
ABOUT: "compilation-units"
HELP: redefine-error
{ $values { "definition" "a definition specifier" } }
{ $description "Throws a " { $link redefine-error } "." }
{ $error-description "Indicates that a single source file contains two definitions for the same artifact, one of which shadows the other. This is an error since it indicates a likely mistake, such as two words accidentally named the same by the developer; the error is restartable." } ;
HELP: remember-definition
{ $values { "definition" "a definition specifier" } { "loc" "a " { $snippet "{ path line# }" } " pair" } }
{ $description "Saves the location of a definition and associates this definition with the current source file."
$nl
"This is the book-keeping required to detect " { $link redefine-error } " and " { $link forward-error } "." } ;
HELP: old-definitions
{ $var-description "Stores an assoc where the keys form the set of definitions which were defined by " { $link file } " the most recent time it was loaded." } ;
HELP: new-definitions
{ $var-description "Stores an assoc where the keys form the set of definitions which were defined so far by the current parsing of " { $link file } "." } ;
HELP: forward-error
{ $values { "word" word } }
{ $description "Throws a " { $link forward-error } "." }
{ $description "Indicates a word is being referenced prior to the location of its most recent definition. This can only happen if a source file is loaded, and subsequently edited such that two dependent definitions are reversed." } ;
HELP: with-compilation-unit
{ $values { "quot" quotation } }
{ $description "Calls a quotation in a new compilation unit. The quotation can define new words and classes, as well as forget words. When the quotation returns, any changed words are recompiled, and changes are applied atomically." }
{ $notes "Compilation units may be nested."
$nl
"The parser wraps every source file in a compilation unit, so parsing words may define new words without having to perform extra work; to define new words at any other time, you must wrap your defining code with this combinator."
$nl
"Since compilation is relatively expensive, you should try to batch up as many definitions into one compilation unit as possible." } ;
HELP: recompile-hook
{ $var-description "Quotation with stack effect " { $snippet "( words -- )" } ", called at the end of " { $link with-compilation-unit } "." } ;
HELP: no-compilation-unit
{ $values { "word" word } }
{ $description "Throws a " { $link no-compilation-unit } " error." }
{ $error-description "Thrown when an attempt is made to define a word outside of a " { $link with-compilation-unit } " combinator." } ;
HELP: modify-code-heap ( alist -- )
{ $values { "alist" "an alist" } }
{ $description "Stores compiled code definitions in the code heap. The alist maps words to the following:"
{ $list
{ { $link f } " - in this case, the word is compiled with the non-optimizing compiler part of the VM." }
{ { $snippet "{ code labels rel words literals }" } " - in this case, a code heap block is allocated with the given data." }
} }
{ $notes "This word is called at the end of " { $link with-compilation-unit } "." } ;

87
core/compiler/units/units.factor Executable file
View File

@ -0,0 +1,87 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel continuations assocs namespaces sequences words
vocabs definitions hashtables ;
IN: compiler.units
SYMBOL: old-definitions
SYMBOL: new-definitions
TUPLE: redefine-error def ;
: redefine-error ( definition -- )
\ redefine-error construct-boa
{ { "Continue" t } } throw-restarts drop ;
: add-once ( key assoc -- )
2dup key? [ over redefine-error ] when dupd set-at ;
: (remember-definition) ( definition loc assoc -- )
>r over set-where r> add-once ;
: remember-definition ( definition loc -- )
new-definitions get first (remember-definition) ;
: remember-class ( class loc -- )
over new-definitions get first key? [ dup redefine-error ] when
new-definitions get second (remember-definition) ;
TUPLE: forward-error word ;
: forward-error ( word -- )
\ forward-error construct-boa throw ;
: forward-reference? ( word -- ? )
dup old-definitions get assoc-stack
[ new-definitions get assoc-stack not ]
[ drop f ] if ;
SYMBOL: recompile-hook
: <definitions> ( -- pair ) { H{ } H{ } } [ clone ] map ;
SYMBOL: definition-observers
definition-observers global [ V{ } like ] change-at
GENERIC: definitions-changed ( assoc obj -- )
: add-definition-observer ( obj -- )
definition-observers get push ;
: remove-definition-observer ( obj -- )
definition-observers get delete ;
: notify-definition-observers ( assoc -- )
definition-observers get
[ definitions-changed ] with each ;
: changed-vocabs ( assoc -- vocabs )
[ drop word? ] assoc-subset
[ drop word-vocabulary dup [ vocab ] when dup ] assoc-map ;
: changed-definitions ( -- assoc )
H{ } clone
dup forgotten-definitions get update
dup new-definitions get first update
dup new-definitions get second update
dup changed-words get update
dup dup changed-vocabs update ;
: finish-compilation-unit ( -- )
changed-words get keys recompile-hook get call
changed-definitions notify-definition-observers ;
: with-compilation-unit ( quot -- )
[
H{ } clone changed-words set
H{ } clone forgotten-definitions set
<definitions> new-definitions set
<definitions> old-definitions set
[ finish-compilation-unit ]
[ ] cleanup
] with-scope ; inline
recompile-hook global
[ [ [ f ] { } map>assoc modify-code-heap ] or ]
change-at

37
core/continuations/continuations-tests.factor Normal file → Executable file
View File

@ -41,7 +41,7 @@ IN: temporary
"!!! The following error is part of the test" print "!!! The following error is part of the test" print
[ [ "2 car" ] parse ] catch print-error [ [ "2 car" ] eval ] catch print-error
[ f throw ] unit-test-fails [ f throw ] unit-test-fails
@ -71,3 +71,38 @@ IN: temporary
[ t ] [ \ bar word-def "c" get innermost-frame-quot = ] unit-test [ t ] [ \ bar word-def "c" get innermost-frame-quot = ] unit-test
[ 1 ] [ "c" get innermost-frame-scan ] unit-test [ 1 ] [ "c" get innermost-frame-scan ] unit-test
SYMBOL: always-counter
SYMBOL: error-counter
[
0 always-counter set
0 error-counter set
[ ] [ always-counter inc ] [ error-counter inc ] cleanup
[ 1 ] [ always-counter get ] unit-test
[ 0 ] [ error-counter get ] unit-test
[ "a" ] [
[
[ "a" throw ]
[ always-counter inc ]
[ error-counter inc ] cleanup
] catch
] unit-test
[ 2 ] [ always-counter get ] unit-test
[ 1 ] [ error-counter get ] unit-test
[ "a" ] [
[
[ ]
[ always-counter inc "a" throw ]
[ error-counter inc ] cleanup
] catch
] unit-test
[ 3 ] [ always-counter get ] unit-test
[ 1 ] [ error-counter get ] unit-test
] with-scope

6
core/continuations/continuations.factor Normal file → Executable file
View File

@ -1,7 +1,7 @@
! Copyright (C) 2003, 2007 Slava Pestov. ! Copyright (C) 2003, 2007 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: arrays vectors kernel kernel.private sequences USING: arrays vectors kernel kernel.private sequences
namespaces tuples math splitting sorting quotations assocs ; namespaces math splitting sorting quotations assocs ;
IN: continuations IN: continuations
SYMBOL: error SYMBOL: error
@ -127,8 +127,8 @@ PRIVATE>
>r (catch) r> ifcc ; inline >r (catch) r> ifcc ; inline
: cleanup ( try cleanup-always cleanup-error -- ) : cleanup ( try cleanup-always cleanup-error -- )
>r [ compose (catch) ] keep r> compose over >r compose [ dip rethrow ] curry
[ dip rethrow ] curry ifcc ; inline >r (catch) r> ifcc r> call ; inline
: attempt-all ( seq quot -- obj ) : attempt-all ( seq quot -- obj )
[ [

14
core/cpu/architecture/architecture.factor
View File

@ -5,9 +5,6 @@ namespaces sequences layouts system hashtables classes alien
byte-arrays bit-arrays float-arrays combinators words ; byte-arrays bit-arrays float-arrays combinators words ;
IN: cpu.architecture IN: cpu.architecture
: set-profiler-prologues ( n -- )
39 setenv ;
SYMBOL: compiler-backend SYMBOL: compiler-backend
! A pseudo-register class for parameters spilled on the stack ! A pseudo-register class for parameters spilled on the stack
@ -46,9 +43,6 @@ HOOK: %epilogue compiler-backend ( n -- )
: %epilogue-later \ %epilogue-later , ; : %epilogue-later \ %epilogue-later , ;
! Bump profiling counter
HOOK: %profiler-prologue compiler-backend ( word -- )
! Store word XT in stack frame ! Store word XT in stack frame
HOOK: %save-word-xt compiler-backend ( -- ) HOOK: %save-word-xt compiler-backend ( -- )
@ -60,15 +54,9 @@ M: object %save-dispatch-xt %save-word-xt ;
! Call another label ! Call another label
HOOK: %call-label compiler-backend ( label -- ) HOOK: %call-label compiler-backend ( label -- )
! Call C primitive
HOOK: %call-primitive compiler-backend ( label -- )
! Local jump for branches ! Local jump for branches
HOOK: %jump-label compiler-backend ( label -- ) HOOK: %jump-label compiler-backend ( label -- )
! Far jump to C primitive
HOOK: %jump-primitive compiler-backend ( label -- )
! Test if vreg is 'f' or not ! Test if vreg is 'f' or not
HOOK: %jump-t compiler-backend ( label -- ) HOOK: %jump-t compiler-backend ( label -- )
@ -160,7 +148,7 @@ M: stack-params param-reg drop ;
GENERIC: v>operand ( obj -- operand ) GENERIC: v>operand ( obj -- operand )
M: integer v>operand tag-bits get shift ; M: integer v>operand tag-fixnum ;
M: f v>operand drop \ f tag-number ; M: f v>operand drop \ f tag-number ;

2
core/cpu/arm/allot/allot.factor
View File

@ -17,7 +17,7 @@ IN: cpu.arm.allot
R11 R11 pick ADD ! increment r11 R11 R11 pick ADD ! increment r11
R11 R12 cell <+> STR ! r11 -> nursery.here R11 R12 cell <+> STR ! r11 -> nursery.here
R11 R11 rot SUB ! old value R11 R11 rot SUB ! old value
R12 swap type-number tag-header MOV ! compute header R12 swap type-number tag-fixnum MOV ! compute header
R12 R11 0 <+> STR ! store header R12 R11 0 <+> STR ! store header
; ;

2
core/cpu/arm/architecture/architecture.factor
View File

@ -350,7 +350,7 @@ M: arm-backend %unbox-any-c-ptr ( dst src -- )
"end" get EQ B "end" get EQ B
! Is the object an alien? ! Is the object an alien?
R14 R12 header-offset <+/-> LDR R14 R12 header-offset <+/-> LDR
R14 alien type-number tag-header CMP R14 alien type-number tag-fixnum CMP
! Add byte array address to address being computed ! Add byte array address to address being computed
R11 R11 R12 NE ADD R11 R11 R12 NE ADD
! Add an offset to start of byte array's data area ! Add an offset to start of byte array's data area

2
core/cpu/arm/arm.factor
View File

@ -53,4 +53,4 @@ T{ arm-backend } compiler-backend set-global
t have-BLX? set-global t have-BLX? set-global
] when ] when
7 cells set-profiler-prologues 7 cells profiler-prologues set-global

4
core/cpu/arm/bootstrap.factor
View File

@ -1,7 +1,7 @@
! Copyright (C) 2007 Slava Pestov. ! Copyright (C) 2007 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: bootstrap.image.private kernel namespaces system USING: bootstrap.image.private kernel namespaces system
cpu.arm.assembler math layouts words vocabs ; cpu.arm.assembler math layouts words compiler.units ;
IN: bootstrap.arm IN: bootstrap.arm
! We generate ARM3 code ! We generate ARM3 code
@ -116,4 +116,4 @@ big-endian off
[ LR BX ] { } make jit-return set [ LR BX ] { } make jit-return set
"bootstrap.arm" forget-vocab [ "bootstrap.arm" forget-vocab ] with-compilation-unit

2
core/cpu/ppc/allot/allot.factor
View File

@ -18,7 +18,7 @@ IN: cpu.ppc.allot
11 11 pick ADDI ! increment r11 11 11 pick ADDI ! increment r11
11 12 cell STW ! r11 -> nursery.here 11 12 cell STW ! r11 -> nursery.here
11 11 rot SUBI ! old value 11 11 rot SUBI ! old value
type-number tag-header 12 LI ! compute header type-number tag-fixnum 12 LI ! compute header
12 11 0 STW ! store header 12 11 0 STW ! store header
; ;

39
core/cpu/ppc/architecture/architecture.factor
View File

@ -3,7 +3,8 @@
USING: alien.c-types cpu.ppc.assembler cpu.architecture generic USING: alien.c-types cpu.ppc.assembler cpu.architecture generic
kernel kernel.private math memory namespaces sequences words kernel kernel.private math memory namespaces sequences words
assocs generator generator.registers generator.fixup system assocs generator generator.registers generator.fixup system
layouts classes words.private alien combinators ; layouts classes words.private alien combinators
compiler.constants ;
IN: cpu.ppc.architecture IN: cpu.ppc.architecture
TUPLE: ppc-backend ; TUPLE: ppc-backend ;
@ -37,7 +38,7 @@ TUPLE: ppc-backend ;
: local@ ( n -- x ) : local@ ( n -- x )
reserved-area-size param-save-size + + ; inline reserved-area-size param-save-size + + ; inline
: factor-area-size 4 cells ; : factor-area-size 2 cells ;
: next-save ( n -- i ) cell - ; : next-save ( n -- i ) cell - ;
@ -77,7 +78,7 @@ M: ppc-backend load-indirect ( obj reg -- )
dup 0 LWZ ; dup 0 LWZ ;
M: ppc-backend %save-word-xt ( -- ) M: ppc-backend %save-word-xt ( -- )
0 11 LOAD32 rc-absolute-ppc-2/2 rel-current-word ; 0 11 LOAD32 rc-absolute-ppc-2/2 rel-this ;
M: ppc-backend %prologue ( n -- ) M: ppc-backend %prologue ( n -- )
0 MFLR 0 MFLR
@ -99,42 +100,22 @@ M: ppc-backend %epilogue ( n -- )
: %load-dlsym ( symbol dll register -- ) : %load-dlsym ( symbol dll register -- )
0 swap LOAD32 rc-absolute-ppc-2/2 rel-dlsym ; 0 swap LOAD32 rc-absolute-ppc-2/2 rel-dlsym ;
M: ppc-backend %profiler-prologue ( word -- )
3 load-indirect
4 3 profile-count-offset LWZ
4 4 1 v>operand ADDI
4 3 profile-count-offset STW ;
M: ppc-backend %call-label ( label -- ) BL ; M: ppc-backend %call-label ( label -- ) BL ;
M: ppc-backend %jump-label ( label -- ) B ; M: ppc-backend %jump-label ( label -- ) B ;
: %prepare-primitive ( word -- )
#! Save stack pointer to stack_chain->callstack_top, load XT
4 1 MR
0 11 LOAD32
rc-absolute-ppc-2/2 rel-word ;
: (%call) 11 MTLR BLRL ;
M: ppc-backend %call-primitive ( word -- )
%prepare-primitive (%call) ;
: (%jump) 11 MTCTR BCTR ;
M: ppc-backend %jump-primitive ( word -- )
%prepare-primitive (%jump) ;
M: ppc-backend %jump-t ( label -- ) M: ppc-backend %jump-t ( label -- )
0 "flag" operand f v>operand CMPI BNE ; 0 "flag" operand f v>operand CMPI BNE ;
: (%call) 11 MTLR BLRL ;
: dispatch-template ( word-table# quot -- ) : dispatch-template ( word-table# quot -- )
[ [
>r >r
"offset" operand "n" operand 1 SRAWI "offset" operand "n" operand 1 SRAWI
0 11 LOAD32 rc-absolute-ppc-2/2 rel-dispatch 0 11 LOAD32 rc-absolute-ppc-2/2 rel-dispatch
11 dup "offset" operand LWZX 11 dup "offset" operand LWZX
11 dup compiled-header-size ADDI 11 dup word-xt-offset LWZ
r> call r> call
] H{ ] H{
{ +input+ { { f "n" } } } { +input+ { { f "n" } } }
@ -145,7 +126,7 @@ M: ppc-backend %call-dispatch ( word-table# -- )
[ (%call) ] dispatch-template ; [ (%call) ] dispatch-template ;
M: ppc-backend %jump-dispatch ( word-table# -- ) M: ppc-backend %jump-dispatch ( word-table# -- )
[ %epilogue-later (%jump) ] dispatch-template ; [ %epilogue-later 11 MTCTR BCTR ] dispatch-template ;
M: ppc-backend %return ( -- ) %epilogue-later BLR ; M: ppc-backend %return ( -- ) %epilogue-later BLR ;
@ -295,7 +276,7 @@ M: ppc-backend %cleanup ( alien-node -- ) drop ;
M: ppc-backend value-structs? M: ppc-backend value-structs?
#! On Linux/PPC, value structs are passed in the same way #! On Linux/PPC, value structs are passed in the same way
#! as reference structs, we just have to make a copy first. #! as reference structs, we just have to make a copy first.
os "linux" = not ; linux? not ;
M: ppc-backend fp-shadows-int? ( -- ? ) macosx? ; M: ppc-backend fp-shadows-int? ( -- ? ) macosx? ;
@ -333,7 +314,7 @@ M: ppc-backend %unbox-any-c-ptr ( dst src -- )
"end" get BEQ "end" get BEQ
! Is the object an alien? ! Is the object an alien?
0 11 header-offset LWZ 0 11 header-offset LWZ
0 0 alien type-number tag-header CMPI 0 0 alien type-number tag-fixnum CMPI
"is-byte-array" get BNE "is-byte-array" get BNE
! If so, load the offset ! If so, load the offset
0 11 alien-offset LWZ 0 11 alien-offset LWZ

124
core/cpu/ppc/bootstrap.factor
View File

@ -1,7 +1,8 @@
! Copyright (C) 2007 Slava Pestov. ! Copyright (C) 2007, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: bootstrap.image.private kernel namespaces system USING: bootstrap.image.private kernel namespaces system
cpu.ppc.assembler math layouts words vocabs ; cpu.ppc.assembler generator.fixup compiler.units
compiler.constants math layouts words vocabs ;
IN: bootstrap.ppc IN: bootstrap.ppc
4 \ cell set 4 \ cell set
@ -10,12 +11,9 @@ big-endian on
4 jit-code-format set 4 jit-code-format set
: ds-reg 14 ; : ds-reg 14 ;
: word-reg 3 ;
: quot-reg 3 ; : quot-reg 3 ;
: scan-reg 5 ;
: temp-reg 6 ; : temp-reg 6 ;
: xt-reg 11 ; : aux-reg 11 ;
: factor-area-size 4 bootstrap-cells ; : factor-area-size 4 bootstrap-cells ;
@ -24,98 +22,88 @@ big-endian on
: next-save stack-frame bootstrap-cell - ; : next-save stack-frame bootstrap-cell - ;
: xt-save stack-frame 2 bootstrap-cells - ; : xt-save stack-frame 2 bootstrap-cells - ;
: array-save stack-frame 3 bootstrap-cells - ;
: scan-save stack-frame 4 bootstrap-cells - ;
[ [
temp-reg quot-reg quot-array@ LWZ ! load array ! Load word
scan-reg temp-reg scan@ ADDI ! initialize scan pointer 0 temp-reg LOAD32
] { } make jit-setup set temp-reg dup 0 LWZ
! Bump profiling counter
aux-reg temp-reg profile-count-offset LWZ
aux-reg dup 1 tag-fixnum ADDI
aux-reg temp-reg profile-count-offset STW
! Load word->code
aux-reg temp-reg word-code-offset LWZ
! Compute word XT
aux-reg dup compiled-header-size ADDI
! Jump to XT
aux-reg MTCTR
BCTR
] rc-absolute-ppc-2/2 rt-literal 1 jit-profiling jit-define
[ [
0 MFLR 0 temp-reg LOAD32 ! load XT
1 1 stack-frame neg ADDI 0 MFLR ! load return address
xt-reg 1 xt-save STW ! save XT 1 1 stack-frame neg ADDI ! create stack frame
stack-frame xt-reg LI temp-reg 1 xt-save STW ! save XT
xt-reg 1 next-save STW ! save frame size stack-frame temp-reg LI ! load frame size
temp-reg 1 array-save STW ! save array temp-reg 1 next-save STW ! save frame size
0 1 lr-save stack-frame + STW ! save return address 0 1 lr-save stack-frame + STW ! save return address
] { } make jit-prolog set ] rc-absolute-ppc-2/2 rt-label 1 jit-prolog jit-define
[ [
temp-reg scan-reg 4 LWZU ! load literal and advance 0 temp-reg LOAD32 ! load literal
temp-reg dup 0 LWZ ! indirection
temp-reg ds-reg 4 STWU ! push literal temp-reg ds-reg 4 STWU ! push literal
] { } make jit-push-literal set ] rc-absolute-ppc-2/2 rt-literal 1 jit-push-literal jit-define
[
temp-reg scan-reg 4 LWZU ! load wrapper and advance
temp-reg dup wrapper@ LWZ ! load wrapped object
temp-reg ds-reg 4 STWU ! push wrapped object
] { } make jit-push-wrapper set
[ [
0 temp-reg LOAD32 ! load primitive address
4 1 MR ! pass stack pointer to primitive 4 1 MR ! pass stack pointer to primitive
] { } make jit-word-primitive-jump set temp-reg MTCTR ! jump to primitive
BCTR
] rc-absolute-ppc-2/2 rt-primitive 1 jit-primitive jit-define
[ [
4 1 MR ! pass stack pointer to primitive 0 BL
] { } make jit-word-primitive-call set ] rc-relative-ppc-3 rt-xt 0 jit-word-call jit-define
: load-xt ( -- ) [
word-reg scan-reg 4 LWZU ! load word and advance 0 B
xt-reg word-reg word-xt@ LWZ ; ] rc-relative-ppc-3 rt-xt 0 jit-word-jump jit-define
: jit-call : jit-call-quot ( -- )
scan-reg 1 scan-save STW ! save scan pointer temp-reg quot-reg quot-xt@ LWZ ! load quotation-xt
xt-reg MTLR ! pass XT to callee temp-reg MTCTR ! jump to quotation-xt
BLRL ! call BCTR ;
scan-reg 1 scan-save LWZ ! restore scan pointer
;
: jit-jump [
xt-reg MTCTR BCTR ; 0 quot-reg LOAD32 ! point quot-reg at false branch
[ load-xt jit-call ] { } make jit-word-call set
[ load-xt jit-jump ] { } make jit-word-jump set
: load-branch
temp-reg ds-reg 0 LWZ ! load boolean temp-reg ds-reg 0 LWZ ! load boolean
0 temp-reg \ f tag-number CMPI ! compare it with f 0 temp-reg \ f tag-number CMPI ! compare it with f
quot-reg scan-reg MR ! point quot-reg at false branch
2 BNE ! skip next insn if its not f 2 BNE ! skip next insn if its not f
quot-reg dup 4 ADDI ! point quot-reg at true branch quot-reg dup 4 ADDI ! point quot-reg at true branch
quot-reg dup 4 LWZ ! load the branch quot-reg dup 0 LWZ ! load the branch
ds-reg dup 4 SUBI ! pop boolean ds-reg dup 4 SUBI ! pop boolean
scan-reg dup 12 ADDI ! advance scan pointer jit-call-quot
xt-reg quot-reg quot-xt@ LWZ ! load quotation-xt ] rc-absolute-ppc-2/2 rt-literal 1 jit-if-jump jit-define
;
[
load-branch jit-jump
] { } make jit-if-jump set
[
load-branch jit-call
] { } make jit-if-call set
[ [
0 quot-reg LOAD32 ! load dispatch array
quot-reg dup 0 LWZ ! indirection
temp-reg ds-reg 0 LWZ ! load index temp-reg ds-reg 0 LWZ ! load index
temp-reg dup 1 SRAWI ! turn it into an array offset temp-reg dup 1 SRAWI ! turn it into an array offset
quot-reg dup temp-reg ADD ! compute quotation location
quot-reg dup array-start LWZ ! load quotation
ds-reg dup 4 SUBI ! pop index ds-reg dup 4 SUBI ! pop index
scan-reg dup 4 LWZ ! load array jit-call-quot
temp-reg dup scan-reg ADD ! compute quotation location ] rc-absolute-ppc-2/2 rt-literal 1 jit-dispatch jit-define
quot-reg temp-reg array-start LWZ ! load quotation
xt-reg quot-reg quot-xt@ LWZ ! load quotation-xt
jit-jump ! execute quotation
] { } make jit-dispatch set
[ [
0 1 lr-save stack-frame + LWZ ! load return address 0 1 lr-save stack-frame + LWZ ! load return address
1 1 stack-frame ADDI ! pop stack frame 1 1 stack-frame ADDI ! pop stack frame
0 MTLR ! get ready to return 0 MTLR ! get ready to return
] { } make jit-epilog set ] f f f jit-epilog jit-define
[ BLR ] { } make jit-return set [ BLR ] f f f jit-return jit-define
"bootstrap.ppc" forget-vocab [ "bootstrap.ppc" forget-vocab ] with-compilation-unit

2
core/cpu/ppc/intrinsics/intrinsics.factor
View File

@ -8,7 +8,7 @@ generator generator.registers generator.fixup sequences.private
sbufs vectors system layouts math.floats.private sbufs vectors system layouts math.floats.private
classes tuples tuples.private sbufs.private vectors.private classes tuples tuples.private sbufs.private vectors.private
strings.private slots.private combinators bit-arrays strings.private slots.private combinators bit-arrays
float-arrays ; float-arrays compiler.constants ;
IN: cpu.ppc.intrinsics IN: cpu.ppc.intrinsics
: %slot-literal-known-tag : %slot-literal-known-tag

4
core/cpu/ppc/ppc.factor Normal file → Executable file
View File

@ -6,12 +6,10 @@ namespaces alien.c-types kernel system combinators ;
4 "longlong" c-type set-c-type-align 4 "longlong" c-type set-c-type-align
4 "ulonglong" c-type set-c-type-align 4 "ulonglong" c-type set-c-type-align
] } ] }
{ [ os "linux" = ] [ { [ linux? ] [
t "longlong" c-type set-c-type-stack-align? t "longlong" c-type set-c-type-stack-align?
t "ulonglong" c-type set-c-type-stack-align? t "ulonglong" c-type set-c-type-stack-align?
] } ] }
} cond } cond
T{ ppc-backend } compiler-backend set-global T{ ppc-backend } compiler-backend set-global
6 cells set-profiler-prologues

4
core/cpu/x86/32/32.factor
View File

@ -275,11 +275,9 @@ T{ x86-backend f 4 } compiler-backend set-global
JNE JNE
] { } define-if-intrinsic ] { } define-if-intrinsic
10 set-profiler-prologues
"-no-sse2" cli-args member? [ "-no-sse2" cli-args member? [
"Checking if your CPU supports SSE2..." print flush "Checking if your CPU supports SSE2..." print flush
[ sse2? ] compile-1 [ [ sse2? ] compile-call [
" - yes" print " - yes" print
"cpu.x86.sse2" require "cpu.x86.sse2" require
] [ ] [

3
core/cpu/x86/32/bootstrap.factor Normal file → Executable file
View File

@ -8,10 +8,9 @@ IN: bootstrap.x86
: arg0 EAX ; : arg0 EAX ;
: arg1 EDX ; : arg1 EDX ;
: temp-reg EBX ;
: stack-reg ESP ; : stack-reg ESP ;
: ds-reg ESI ; : ds-reg ESI ;
: scan-reg EBX ;
: xt-reg ECX ;
: fixnum>slot@ arg0 1 SAR ; : fixnum>slot@ arg0 1 SAR ;
"resource:core/cpu/x86/bootstrap.factor" run-file "resource:core/cpu/x86/bootstrap.factor" run-file

2
core/cpu/x86/64/64.factor
View File

@ -201,4 +201,4 @@ M: struct-type flatten-value-type ( type -- seq )
] each ] each
] if ; ] if ;
12 set-profiler-prologues 12 profiler-prologue set-global

2
core/cpu/x86/allot/allot.factor
View File

@ -30,7 +30,7 @@ IN: cpu.x86.allot
allot-reg cell [+] swap 8 align ADD ; allot-reg cell [+] swap 8 align ADD ;
: store-header ( header -- ) : store-header ( header -- )
0 object@ swap type-number tag-header MOV ; 0 object@ swap type-number tag-fixnum MOV ;
: %allot ( header size quot -- ) : %allot ( header size quot -- )
allot-reg PUSH allot-reg PUSH

25
core/cpu/x86/architecture/architecture.factor
View File

@ -3,7 +3,7 @@
USING: alien alien.c-types alien.compiler arrays USING: alien alien.c-types alien.compiler arrays
cpu.x86.assembler cpu.architecture kernel kernel.private math cpu.x86.assembler cpu.architecture kernel kernel.private math
memory namespaces sequences words generator generator.registers memory namespaces sequences words generator generator.registers
generator.fixup system layouts combinators ; generator.fixup system layouts combinators compiler.constants ;
IN: cpu.x86.architecture IN: cpu.x86.architecture
TUPLE: x86-backend cell ; TUPLE: x86-backend cell ;
@ -45,7 +45,7 @@ M: x86-backend stack-frame ( n -- i )
3 cells + 16 align cell - ; 3 cells + 16 align cell - ;
M: x86-backend %save-word-xt ( -- ) M: x86-backend %save-word-xt ( -- )
xt-reg 0 MOV rc-absolute-cell rel-current-word ; xt-reg 0 MOV rc-absolute-cell rel-this ;
: factor-area-size 4 cells ; : factor-area-size 4 cells ;
@ -70,27 +70,10 @@ M: x86-backend %prepare-alien-invoke
temp-reg v>operand 2 cells [+] ds-reg MOV temp-reg v>operand 2 cells [+] ds-reg MOV
temp-reg v>operand 3 cells [+] rs-reg MOV ; temp-reg v>operand 3 cells [+] rs-reg MOV ;
M: x86-backend %profiler-prologue ( word -- )
temp-reg load-literal
temp-reg v>operand profile-count-offset [+] 1 v>operand ADD ;
M: x86-backend %call-label ( label -- ) CALL ; M: x86-backend %call-label ( label -- ) CALL ;
M: x86-backend %jump-label ( label -- ) JMP ; M: x86-backend %jump-label ( label -- ) JMP ;
: %prepare-primitive ( word -- operand )
! Save stack pointer to stack_chain->callstack_top, load XT
! in register
stack-save-reg stack-reg MOV address-operand ;
M: x86-backend %call-primitive ( word -- )
stack-save-reg stack-reg cell neg [+] LEA
address-operand CALL ;
M: x86-backend %jump-primitive ( word -- )
stack-save-reg stack-reg MOV
address-operand JMP ;
M: x86-backend %jump-t ( label -- ) M: x86-backend %jump-t ( label -- )
"flag" operand f v>operand CMP JNE ; "flag" operand f v>operand CMP JNE ;
@ -102,7 +85,7 @@ M: x86-backend %jump-t ( label -- )
! x86, this is redundant. ! x86, this is redundant.
"scratch" operand HEX: ffffffff MOV rc-absolute-cell rel-dispatch "scratch" operand HEX: ffffffff MOV rc-absolute-cell rel-dispatch
"n" operand "n" operand "scratch" operand [+] MOV "n" operand "n" operand "scratch" operand [+] MOV
"n" operand compiled-header-size ADD ; "n" operand dup word-xt-offset [+] MOV ;
: dispatch-template ( word-table# quot -- ) : dispatch-template ( word-table# quot -- )
[ [
@ -195,7 +178,7 @@ M: x86-backend %unbox-any-c-ptr ( dst src -- )
rs-reg f v>operand CMP rs-reg f v>operand CMP
"end" get JE "end" get JE
! Is the object an alien? ! Is the object an alien?
rs-reg header-offset [+] alien type-number tag-header CMP rs-reg header-offset [+] alien type-number tag-fixnum CMP
"is-byte-array" get JNE "is-byte-array" get JNE
! If so, load the offset and add it to the address ! If so, load the offset and add it to the address
ds-reg rs-reg alien-offset [+] ADD ds-reg rs-reg alien-offset [+] ADD

4
core/cpu/x86/assembler/assembler.factor Normal file → Executable file
View File

@ -1,6 +1,6 @@
! Copyright (C) 2005, 2007 Slava Pestov. ! Copyright (C) 2005, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: arrays generator generator.fixup io.binary kernel USING: arrays generator.fixup io.binary kernel
combinators kernel.private math namespaces parser sequences combinators kernel.private math namespaces parser sequences
words system ; words system ;
IN: cpu.x86.assembler IN: cpu.x86.assembler

101
core/cpu/x86/bootstrap.factor Normal file → Executable file
View File

@ -1,103 +1,78 @@
! Copyright (C) 2007 Slava Pestov. ! Copyright (C) 2007, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: bootstrap.image.private kernel namespaces system USING: bootstrap.image.private kernel namespaces system
cpu.x86.assembler layouts vocabs math ; cpu.x86.assembler layouts compiler.units math generator.fixup
compiler.constants vocabs ;
IN: bootstrap.x86 IN: bootstrap.x86
big-endian off big-endian off
1 jit-code-format set 1 jit-code-format set
: stack-frame-size 8 bootstrap-cells ; : stack-frame-size 4 bootstrap-cells ;
: scan-save stack-reg 3 bootstrap-cells [+] ;
[ [
arg0 arg0 quot-array@ [+] MOV ! load array ! Load word
scan-reg arg0 scan@ [+] LEA ! initialize scan pointer temp-reg 0 [] MOV
] { } make jit-setup set ! Bump profiling counter
temp-reg profile-count-offset [+] 1 tag-fixnum ADD
! Load word->code
temp-reg temp-reg word-code-offset [+] MOV
! Compute word XT
temp-reg compiled-header-size ADD
! Jump to XT
temp-reg JMP
] rc-absolute-cell rt-literal 2 jit-profiling jit-define
[ [
stack-frame-size PUSH ! save stack frame size stack-frame-size PUSH ! save stack frame size
xt-reg PUSH ! save XT 0 PUSH ! push XT
arg0 PUSH ! save array arg1 PUSH ! alignment
stack-reg 4 bootstrap-cells SUB ! reserve space for scan-save ] rc-absolute-cell rt-label 6 jit-prolog jit-define
] { } make jit-prolog set
: advance-scan scan-reg bootstrap-cell ADD ;
[ [
advance-scan arg0 0 [] MOV ! load literal
ds-reg bootstrap-cell ADD ! increment datastack pointer ds-reg bootstrap-cell ADD ! increment datastack pointer
arg0 scan-reg [] MOV ! load literal
ds-reg [] arg0 MOV ! store literal on datastack ds-reg [] arg0 MOV ! store literal on datastack
] { } make jit-push-literal set ] rc-absolute-cell rt-literal 2 jit-push-literal jit-define
[
advance-scan
ds-reg bootstrap-cell ADD ! increment datastack pointer
arg0 scan-reg [] MOV ! load wrapper
arg0 dup wrapper@ [+] MOV ! load wrapper-obj slot
ds-reg [] arg0 MOV ! store literal on datastack
] { } make jit-push-wrapper set
[ [
arg1 stack-reg MOV ! pass callstack pointer as arg 2 arg1 stack-reg MOV ! pass callstack pointer as arg 2
] { } make jit-word-primitive-jump set (JMP) drop ! go
] rc-relative rt-primitive 3 jit-primitive jit-define
[ [
arg1 stack-reg bootstrap-cell neg [+] LEA ! pass callstack pointer as arg 2 (JMP) drop
] { } make jit-word-primitive-call set ] rc-relative rt-xt 1 jit-word-jump jit-define
[ [
arg0 scan-reg bootstrap-cell [+] MOV ! load word (CALL) drop
arg0 word-xt@ [+] JMP ! jump to word XT ] rc-relative rt-xt 1 jit-word-call jit-define
] { } make jit-word-jump set
[ [
advance-scan arg1 0 MOV ! load addr of true quotation
scan-save scan-reg MOV ! save scan pointer
arg0 scan-reg [] MOV ! load word
arg0 word-xt@ [+] CALL ! call word XT
scan-reg scan-save MOV ! restore scan pointer
] { } make jit-word-call set
: load-branch
arg0 ds-reg [] MOV ! load boolean arg0 ds-reg [] MOV ! load boolean
ds-reg bootstrap-cell SUB ! pop boolean ds-reg bootstrap-cell SUB ! pop boolean
arg0 \ f tag-number CMP ! compare it with f arg0 \ f tag-number CMP ! compare it with f
arg0 scan-reg 2 bootstrap-cells [+] CMOVE ! load false branch if equal arg0 arg1 [] CMOVNE ! load true branch if not equal
arg0 scan-reg 1 bootstrap-cells [+] CMOVNE ! load true branch if not equal arg0 arg1 bootstrap-cell [+] CMOVE ! load false branch if equal
scan-reg 3 bootstrap-cells ADD ! advance scan pointer arg0 quot-xt@ [+] JMP ! jump to quotation-xt
xt-reg arg0 quot-xt@ [+] MOV ! load quotation-xt ] rc-absolute-cell rt-literal 1 jit-if-jump jit-define
;
[
load-branch
xt-reg JMP
] { } make jit-if-jump set
[
load-branch
scan-save scan-reg MOV ! save scan pointer
xt-reg CALL ! call quotation
scan-reg scan-save MOV ! restore scan pointer
] { } make jit-if-call set
[ [
arg1 0 [] MOV ! load dispatch table
arg0 ds-reg [] MOV ! load index arg0 ds-reg [] MOV ! load index
fixnum>slot@ ! turn it into an array offset fixnum>slot@ ! turn it into an array offset
ds-reg bootstrap-cell SUB ! pop index ds-reg bootstrap-cell SUB ! pop index
arg0 scan-reg bootstrap-cell [+] ADD ! compute quotation location arg0 arg1 ADD ! compute quotation location
arg0 arg0 array-start [+] MOV ! load quotation arg0 arg0 array-start [+] MOV ! load quotation
xt-reg arg0 quot-xt@ [+] MOV ! load quotation-xt arg0 quot-xt@ [+] JMP ! execute branch
xt-reg JMP ! execute quotation ] rc-absolute-cell rt-literal 2 jit-dispatch jit-define
] { } make jit-dispatch set
[ [
stack-reg stack-frame-size bootstrap-cell - ADD ! unwind stack frame stack-reg stack-frame-size bootstrap-cell - ADD ! unwind stack frame
] { } make jit-epilog set ] f f f jit-epilog jit-define
[ 0 RET ] { } make jit-return set [ 0 RET ] f f f jit-return jit-define
"bootstrap.x86" forget-vocab [ "bootstrap.x86" forget-vocab ] with-compilation-unit

8
core/cpu/x86/intrinsics/intrinsics.factor
View File

@ -6,7 +6,7 @@ math.private namespaces quotations sequences
words generic byte-arrays hashtables hashtables.private words generic byte-arrays hashtables hashtables.private
generator generator.registers generator.fixup sequences.private generator generator.registers generator.fixup sequences.private
sbufs sbufs.private vectors vectors.private layouts system sbufs sbufs.private vectors vectors.private layouts system
tuples.private strings.private slots.private ; tuples.private strings.private slots.private compiler.constants ;
IN: cpu.x86.intrinsics IN: cpu.x86.intrinsics
! Type checks ! Type checks
@ -27,7 +27,7 @@ IN: cpu.x86.intrinsics
! Tag the tag ! Tag the tag
"x" operand %tag-fixnum "x" operand %tag-fixnum
! Compare with object tag number (3). ! Compare with object tag number (3).
"x" operand object tag-number tag-bits get shift CMP "x" operand object tag-number tag-fixnum CMP
"end" get JNE "end" get JNE
! If we have equality, load type from header ! If we have equality, load type from header
"x" operand "obj" operand -3 [+] MOV "x" operand "obj" operand -3 [+] MOV
@ -49,10 +49,10 @@ IN: cpu.x86.intrinsics
! Tag the tag ! Tag the tag
"x" operand %tag-fixnum "x" operand %tag-fixnum
! Compare with tuple tag number (2). ! Compare with tuple tag number (2).
"x" operand tuple tag-number tag-bits get shift CMP "x" operand tuple tag-number tag-fixnum CMP
"tuple" get JE "tuple" get JE
! Compare with object tag number (3). ! Compare with object tag number (3).
"x" operand object tag-number tag-bits get shift CMP "x" operand object tag-number tag-fixnum CMP
"object" get JE "object" get JE
"end" get JMP "end" get JMP
"object" get resolve-label "object" get resolve-label

3
core/debugger/debugger-docs.factor Normal file → Executable file
View File

@ -98,9 +98,6 @@ HELP: expired-error.
HELP: io-error. HELP: io-error.
{ $error-description "Thrown by the C streams I/O primitives if an I/O error occurs." } ; { $error-description "Thrown by the C streams I/O primitives if an I/O error occurs." } ;
HELP: undefined-word-error.
{ $error-description "Thrown if an attempt is made to call a word which was defined by " { $link POSTPONE: DEFER: } "." } ;
HELP: type-check-error. HELP: type-check-error.
{ $error-description "Thrown by various primitives if one of the inputs does not have the expected type. Generic words throw " { $link no-method } " and " { $link no-math-method } " errors in such cases instead." } ; { $error-description "Thrown by various primitives if one of the inputs does not have the expected type. Generic words throw " { $link no-method } " and " { $link no-math-method } " errors in such cases instead." } ;

25
core/debugger/debugger.factor Normal file → Executable file
View File

@ -4,7 +4,7 @@ USING: arrays definitions generic hashtables inspector io kernel
math namespaces prettyprint sequences assocs sequences.private math namespaces prettyprint sequences assocs sequences.private
strings io.styles vectors words system splitting math.parser strings io.styles vectors words system splitting math.parser
tuples continuations continuations.private combinators tuples continuations continuations.private combinators
generic.math io.streams.duplex classes generic.math io.streams.duplex classes compiler.units
generic.standard ; generic.standard ;
IN: debugger IN: debugger
@ -92,9 +92,6 @@ TUPLE: assert got expect ;
: expired-error. ( obj -- ) : expired-error. ( obj -- )
"Object did not survive image save/load: " write third . ; "Object did not survive image save/load: " write third . ;
: undefined-word-error. ( obj -- )
"Undefined word: " write third . ;
: io-error. ( error -- ) : io-error. ( error -- )
"I/O error: " write third print ; "I/O error: " write third print ;
@ -150,14 +147,14 @@ PREDICATE: array kernel-error ( obj -- ? )
{ {
{ [ dup empty? ] [ drop f ] } { [ dup empty? ] [ drop f ] }
{ [ dup first "kernel-error" = not ] [ drop f ] } { [ dup first "kernel-error" = not ] [ drop f ] }
{ [ t ] [ second 0 16 between? ] } { [ t ] [ second 0 15 between? ] }
} cond ; } cond ;
: kernel-errors : kernel-errors
second { second {
{ 0 [ expired-error. ] } { 0 [ expired-error. ] }
{ 1 [ io-error. ] } { 1 [ io-error. ] }
{ 2 [ undefined-word-error. ] } { 2 [ primitive-error. ] }
{ 3 [ type-check-error. ] } { 3 [ type-check-error. ] }
{ 4 [ divide-by-zero-error. ] } { 4 [ divide-by-zero-error. ] }
{ 5 [ signal-error. ] } { 5 [ signal-error. ] }
@ -171,7 +168,6 @@ PREDICATE: array kernel-error ( obj -- ? )
{ 13 [ retainstack-underflow. ] } { 13 [ retainstack-underflow. ] }
{ 14 [ retainstack-overflow. ] } { 14 [ retainstack-overflow. ] }
{ 15 [ memory-error. ] } { 15 [ memory-error. ] }
{ 16 [ primitive-error. ] }
} ; inline } ; inline
M: kernel-error error. dup kernel-errors case ; M: kernel-error error. dup kernel-errors case ;
@ -221,3 +217,18 @@ M: condition error-help drop f ;
M: assert summary drop "Assertion failed" ; M: assert summary drop "Assertion failed" ;
M: immutable summary drop "Sequence is immutable" ; M: immutable summary drop "Sequence is immutable" ;
M: redefine-error error.
"Re-definition of " write
redefine-error-def . ;
M: forward-error error.
"Forward reference to " write forward-error-word . ;
M: undefined summary
drop "Calling a deferred word before it has been defined" ;
M: no-compilation-unit error.
"Attempting to define " write
no-compilation-unit-definition pprint
" outside of a compilation unit" print ;

61
core/definitions/definitions-docs.factor Normal file → Executable file
View File

@ -1,4 +1,5 @@
USING: help.markup help.syntax words math ; USING: help.markup help.syntax words math source-files
parser quotations compiler.units ;
IN: definitions IN: definitions
ARTICLE: "definition-protocol" "Definition protocol" ARTICLE: "definition-protocol" "Definition protocol"
@ -13,22 +14,58 @@ $nl
{ $subsection uses } { $subsection uses }
"When a definition is changed, all definitions which depend on it are notified via a hook:" "When a definition is changed, all definitions which depend on it are notified via a hook:"
{ $subsection redefined* } { $subsection redefined* }
"Definitions must implement a few operations used for printing them in human and computer-readable form:" "Definitions must implement a few operations used for printing them in source form:"
{ $subsection synopsis* } { $subsection synopsis* }
{ $subsection definer } { $subsection definer }
{ $subsection definition } ; { $subsection definition } ;
ARTICLE: "definitions" "Definitions" ARTICLE: "definition-crossref" "Definition cross referencing"
"A " { $emphasis "definition" } " is an artifact read from a source file. This includes words, methods, and help articles. Words for working with definitions are found in the " { $vocab-link "definitions" } " vocabulary."
{ $subsection "definition-protocol" }
"A common cross-referencing system is used to track definition usages:" "A common cross-referencing system is used to track definition usages:"
{ $subsection crossref } { $subsection crossref }
{ $subsection xref } { $subsection xref }
{ $subsection unxref } { $subsection unxref }
{ $subsection delete-xref } { $subsection delete-xref }
{ $subsection usage } { $subsection usage } ;
"Implementations of the definition protocol include pathnames, words, methods, and help articles."
{ $see-also "source-files" "words" "generic" "help-impl" } ; ARTICLE: "definition-checking" "Definition sanity checking"
"When a source file is reloaded, the parser compares the previous list of definitions with the current list; any definitions which are no longer present in the file are removed by a call to " { $link forget } ". A warning message is printed if any other definitions still depend on the removed definitions."
$nl
"The parser also catches forward references when reloading source files. This is best illustrated with an example. Suppose we load a source file " { $snippet "a.factor" } ":"
{ $code
"USING: io sequences ;"
"IN: a"
": hello \"Hello\" ;"
": world \"world\" ;"
": hello-world hello " " world 3append print ;"
}
"The definitions for " { $snippet "hello" } ", " { $snippet "world" } ", and " { $snippet "hello-world" } " are in the dictionary."
$nl
"Now, after some heavily editing and refactoring, the file looks like this:"
{ $code
"USING: namespaces ;"
"IN: a"
": hello \"Hello\" % ;"
": hello-world [ hello " " % world ] \"\" make ;"
": world \"world\" % ;"
}
"Note that the developer has made a mistake, placing the definition of " { $snippet "world" } " " { $emphasis "after" } " its usage in " { $snippet "hello-world" } "."
$nl
"If the parser did not have special checks for this case, then the modified source file would still load, because when the definition of " { $snippet "hello-world" } " on line 4 is being parsed, the " { $snippet "world" } " word is already present in the dictionary from an earlier run. The developer would then not discover this mistake until attempting to load the source file into a fresh image."
$nl
"Since this is undesirable, the parser explicitly raises an error if a source file refers to a word which is in the dictionary, but defined after it is used."
{ $subsection forward-error }
"If a source file raises a " { $link forward-error } " when loaded into a development image, then it would have raised a " { $link no-word } " error when loaded into a fresh image."
$nl
"The parser also catches duplicate definitions. If an artifact is defined twice in the same source file, the earlier definition will never be accessible, and this is almost always a mistake, perhaps due to a bad choice of word names, or a copy and paste error. The parser raises an error in this case."
{ $subsection redefine-error } ;
ARTICLE: "definitions" "Definitions"
"A " { $emphasis "definition" } " is an artifact read from a source file. This includes words, methods, and help articles. Words for working with definitions are found in the " { $vocab-link "definitions" } " vocabulary. Implementations of the definition protocol include pathnames, words, methods, and help articles."
{ $subsection "definition-protocol" }
{ $subsection "definition-crossref" }
{ $subsection "definition-checking" }
{ $subsection "compilation-units" }
{ $see-also "parser" "source-files" "words" "generic" "help-impl" } ;
ABOUT: "definitions" ABOUT: "definitions"
@ -43,7 +80,13 @@ HELP: set-where
HELP: forget HELP: forget
{ $values { "defspec" "a definition specifier" } } { $values { "defspec" "a definition specifier" } }
{ $description "Forgets about a definition. For example, if it is a word, it will be removed from its vocabulary." } ; { $description "Forgets about a definition. For example, if it is a word, it will be removed from its vocabulary." }
{ $notes "This word must be called from inside " { $link with-compilation-unit } "." } ;
HELP: forget-all
{ $values { "definitions" "a sequence of definition specifiers" } }
{ $description "Forgets every definition in a sequence." }
{ $notes "This word must be called from inside " { $link with-compilation-unit } "." } ;
HELP: uses HELP: uses
{ $values { "defspec" "a definition specifier" } { "seq" "a sequence of definition specifiers" } } { $values { "defspec" "a definition specifier" } { "seq" "a sequence of definition specifiers" } }

21
core/definitions/definitions-tests.factor Normal file → Executable file
View File

@ -7,11 +7,17 @@ M: combination-1 perform-combination 2drop { } [ ] each [ ] ;
SYMBOL: generic-1 SYMBOL: generic-1
generic-1 T{ combination-1 } define-generic [
generic-1 T{ combination-1 } define-generic
[ ] <method> object \ generic-1 define-method [ ] <method> object \ generic-1 define-method
] with-compilation-unit
[ ] [ { combination-1 { object generic-1 } } forget-all ] unit-test [ ] [
[
{ combination-1 { object generic-1 } } forget-all
] with-compilation-unit
] unit-test
GENERIC: some-generic GENERIC: some-generic
@ -34,6 +40,11 @@ M: some-class some-generic ;
TUPLE: another-class some-generic ; TUPLE: another-class some-generic ;
[ ] [ [ ] [
{ some-generic some-class { another-class some-generic } } [
forget-all {
some-generic
some-class
{ another-class some-generic }
} forget-all
] with-compilation-unit
] unit-test ] unit-test

20
core/definitions/definitions.factor Normal file → Executable file
View File

@ -1,17 +1,31 @@
! Copyright (C) 2006, 2007 Slava Pestov. ! Copyright (C) 2006, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
IN: definitions IN: definitions
USING: kernel sequences namespaces assocs graphs ; USING: kernel sequences namespaces assocs graphs ;
TUPLE: no-compilation-unit definition ;
: no-compilation-unit ( definition -- * )
\ no-compilation-unit construct-boa throw ;
GENERIC: where ( defspec -- loc ) GENERIC: where ( defspec -- loc )
M: object where drop f ; M: object where drop f ;
GENERIC: set-where ( loc defspec -- ) GENERIC: set-where ( loc defspec -- )
GENERIC: forget ( defspec -- ) GENERIC: forget* ( defspec -- )
M: object forget drop ; M: object forget* drop ;
SYMBOL: forgotten-definitions
: forgotten-definition ( defspec -- )
dup forgotten-definitions get
[ no-compilation-unit ] unless*
set-at ;
: forget ( defspec -- ) dup forgotten-definition forget* ;
: forget-all ( definitions -- ) [ forget ] each ; : forget-all ( definitions -- ) [ forget ] each ;

6
core/float-arrays/float-arrays.factor Normal file → Executable file
View File

@ -1,8 +1,8 @@
! Copyright (C) 2007 Slava Pestov. ! Copyright (C) 2007, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
IN: float-arrays
USING: kernel kernel.private alien sequences USING: kernel kernel.private alien sequences
sequences.private math math.private ; sequences.private math math.private ;
IN: float-arrays
<PRIVATE <PRIVATE
@ -30,6 +30,8 @@ M: float-array equal?
over float-array? [ sequence= ] [ 2drop f ] if ; over float-array? [ sequence= ] [ 2drop f ] if ;
INSTANCE: float-array sequence INSTANCE: float-array sequence
INSTANCE: float-array simple-c-ptr
INSTANCE: float-array c-ptr
: 1float-array ( x -- array ) 1 swap <float-array> ; flushable : 1float-array ( x -- array ) 1 swap <float-array> ; flushable

74
core/flow-chart/flow-chart.factor
View File

@ -1,74 +0,0 @@
USING: kernel words math inference.dataflow sequences
optimizer.def-use combinators.private namespaces arrays
math.parser assocs prettyprint io strings inference hashtables ;
IN: flow-chart
GENERIC: flow-chart* ( n word -- value nodes )
M: word flow-chart*
2drop f f ;
M: compound flow-chart*
word-def swap 1+ [ drop <computed> ] map
[ dataflow-with compute-def-use ] keep
first dup used-by prune [ t eq? not ] subset ;
GENERIC: node-word ( node -- word )
M: #call node-word node-param ;
M: #if node-word drop \ if ;
M: #dispatch node-word drop \ dispatch ;
DEFER: flow-chart
: flow-chart-node ( value node -- )
[ node-in-d <reversed> index ] keep
node-word flow-chart , ;
SYMBOL: pruned
SYMBOL: nesting
SYMBOL: max-nesting
2 max-nesting set
: flow-chart ( n word -- seq )
[
2dup 2array ,
nesting dup inc get max-nesting get > [
2drop pruned ,
] [
flow-chart* dup length 5 > [
2drop pruned ,
] [
[ flow-chart-node ] curry* each
] if
] if
] { } make ;
: th ( n -- )
dup number>string write
100 mod dup 20 > [ 10 mod ] when
H{ { 1 "st" } { 2 "nd" } { 3 "rd" } } at "th" or write ;
: chart-heading. ( pair -- )
first2 >r 1+ th " argument to " write r> . ;
GENERIC# show-chart 1 ( seq n -- )
: indent CHAR: \s <string> write ;
M: sequence show-chart
dup indent
>r unclip chart-heading. r>
2 + [ show-chart ] curry each ;
M: word show-chart
dup indent
"... pruned" print ;
: flow-chart. ( n word -- )
flow-chart 2 show-chart ;

11
core/generator/fixup/fixup.factor Normal file → Executable file
View File

@ -69,7 +69,6 @@ SYMBOL: label-table
: rt-literal 2 ; : rt-literal 2 ;
: rt-dispatch 3 ; : rt-dispatch 3 ;
: rt-xt 4 ; : rt-xt 4 ;
: rt-xt-profiling 5 ;
: rt-label 6 ; : rt-label 6 ;
TUPLE: label-fixup label class ; TUPLE: label-fixup label class ;
@ -127,17 +126,15 @@ SYMBOL: word-table
: rel-dispatch ( word-table# class -- ) rt-dispatch rel-fixup ; : rel-dispatch ( word-table# class -- ) rt-dispatch rel-fixup ;
GENERIC# rel-word 1 ( word class -- ) : rel-word ( word class -- )
M: primitive rel-word ( word class -- )
>r word-def r> rt-primitive rel-fixup ;
M: word rel-word ( word class -- )
>r add-word r> rt-xt rel-fixup ; >r add-word r> rt-xt rel-fixup ;
: rel-literal ( literal class -- ) : rel-literal ( literal class -- )
>r add-literal r> rt-literal rel-fixup ; >r add-literal r> rt-literal rel-fixup ;
: rel-this ( class -- )
0 swap rt-label rel-fixup ;
: init-fixup ( -- ) : init-fixup ( -- )
V{ } clone relocation-table set V{ } clone relocation-table set
V{ } clone label-table set ; V{ } clone label-table set ;

29
core/generator/generator-docs.factor Normal file → Executable file
View File

@ -1,5 +1,6 @@
USING: help.markup help.syntax words debugger generator.fixup USING: help.markup help.syntax words debugger generator.fixup
generator.registers quotations kernel vectors arrays ; generator.registers quotations kernel vectors arrays effects
sequences ;
IN: generator IN: generator
ARTICLE: "generator" "Compiled code generator" ARTICLE: "generator" "Compiled code generator"
@ -13,27 +14,12 @@ $nl
{ $subsection define-if-intrinsic } { $subsection define-if-intrinsic }
{ $subsection define-if-intrinsics } { $subsection define-if-intrinsics }
"The main entry point into the code generator:" "The main entry point into the code generator:"
{ $subsection generate } { $subsection generate } ;
"Primitive compiler interface exported by the Factor VM:"
{ $subsection add-compiled-block }
{ $subsection finalize-compile } ;
ABOUT: "generator" ABOUT: "generator"
HELP: compiled-xts HELP: compiled
{ $var-description "During compilation, holds a hashtable mapping words to temporary uninterned words. The XT of each value points to the compiled code block of each key; at the end of compilation, the XT of each key is set to the XT of the value." } ; { $var-description "During compilation, holds a hashtable mapping words to 5-element arrays holding compiled code." } ;
HELP: compiling?
{ $values { "word" word } { "?" "a boolean" } }
{ $description "Tests if a word is going to be or already is compiled." } ;
HELP: finalize-compile ( xts -- )
{ $values { "xts" "an association list mapping words to uninterned words" } }
{ $description "Performs relocation, atomically changes the XT of each key to the XT of each value, and flushes the CPU instruction cache on architectures where this has to be done manually." } ;
HELP: add-compiled-block ( literals words rel labels code -- xt )
{ $values { "literals" vector } { "words" "a vector of words" } { "rel" "a vector of integers" } { "labels" "an array of integers" } { "code" "a vector of integers" } { "xt" "an uninterned word" } }
{ $description "Adds a new compiled block and outputs an uninterned word whose XT points at this block. This uninterned word can then be passed to " { $link finalize-compile } "." } ;
HELP: compiling-word HELP: compiling-word
{ $var-description "The word currently being compiled, set by " { $link generate-1 } "." } ; { $var-description "The word currently being compiled, set by " { $link generate-1 } "." } ;
@ -42,7 +28,8 @@ HELP: compiling-label
{ $var-description "The label currently being compiled, set by " { $link generate-1 } "." } ; { $var-description "The label currently being compiled, set by " { $link generate-1 } "." } ;
HELP: compiled-stack-traces? HELP: compiled-stack-traces?
{ $var-description "If set to true, compiled code blocks will retain what word they were compiled from. This information is used by " { $link :c } " to display call stack traces after an error is thrown from compiled code. This variable is on by default; the deployment tool switches it off to save some space in the deployed image." } ; { $values { "?" "a boolean" } }
{ $description "Iftrue, compiled code blocks will retain what word they were compiled from. This information is used by " { $link :c } " to display call stack traces after an error is thrown from compiled code. This is on by default; the deployment tool switches it off to save some space in the deployed image." } ;
HELP: literal-table HELP: literal-table
{ $var-description "Holds a vector of literal objects referenced from the currently compiling word. If " { $link compiled-stack-traces? } " is on, " { $link init-generator } " ensures that the first entry is the word being compiled." } ; { $var-description "Holds a vector of literal objects referenced from the currently compiling word. If " { $link compiled-stack-traces? } " is on, " { $link init-generator } " ensures that the first entry is the word being compiled." } ;
@ -69,7 +56,7 @@ HELP: generate
{ $description "Generates machine code for " { $snippet "label" } " from " { $snippet "node" } ". The value of " { $snippet "word" } " is retained for debugging purposes; it is the word which will appear in a call stack trace if this compiled code block throws an error when run." } ; { $description "Generates machine code for " { $snippet "label" } " from " { $snippet "node" } ". The value of " { $snippet "word" } " is retained for debugging purposes; it is the word which will appear in a call stack trace if this compiled code block throws an error when run." } ;
HELP: word-dataflow HELP: word-dataflow
{ $values { "word" word } { "dataflow" "a dataflow graph" } } { $values { "word" word } { "effect" effect } { "dependencies" sequence } { "dataflow" "a dataflow graph" } }
{ $description "Outputs the dataflow graph of a word, taking specializers into account (see " { $link "specializers" } ")." } ; { $description "Outputs the dataflow graph of a word, taking specializers into account (see " { $link "specializers" } ")." } ;
HELP: define-intrinsics HELP: define-intrinsics

110
core/generator/generator.factor
View File

@ -7,18 +7,28 @@ kernel.private layouts math namespaces optimizer prettyprint
quotations sequences system threads words ; quotations sequences system threads words ;
IN: generator IN: generator
SYMBOL: compiled-xts SYMBOL: compile-queue
SYMBOL: compiled
: save-xt ( word xt -- ) : 5array 3array >r 2array r> append ;
swap dup unchanged-word compiled-xts get set-at ;
: compiling? ( word -- ? ) : begin-compiling ( word -- )
f swap compiled get set-at ;
: finish-compiling ( word literals words relocation labels code -- )
5array swap compiled get set-at ;
: queue-compile ( word -- )
{ {
{ [ dup compiled-xts get key? ] [ drop t ] } { [ dup compiled get key? ] [ drop ] }
{ [ dup word-changed? ] [ drop f ] } { [ dup primitive? ] [ drop ] }
{ [ t ] [ compiled? ] } { [ dup deferred? ] [ drop ] }
{ [ t ] [ dup compile-queue get set-at ] }
} cond ; } cond ;
: maybe-compile ( word -- )
dup compiled? [ drop ] [ queue-compile ] if ;
SYMBOL: compiling-word SYMBOL: compiling-word
SYMBOL: compiling-label SYMBOL: compiling-label
@ -26,30 +36,23 @@ SYMBOL: compiling-label
! Label of current word, after prologue, makes recursion faster ! Label of current word, after prologue, makes recursion faster
SYMBOL: current-label-start SYMBOL: current-label-start
SYMBOL: compiled-stack-traces? : compiled-stack-traces? ( -- ? ) 36 getenv ;
t compiled-stack-traces? set-global : init-generator ( compiling -- )
: init-generator ( -- )
V{ } clone literal-table set V{ } clone literal-table set
V{ } clone word-table set V{ } clone word-table set
compiled-stack-traces? get compiling-word get f ? compiled-stack-traces? swap f ?
literal-table get push ; literal-table get push ;
: generate-1 ( word label node quot -- ) : generate-1 ( word label node quot -- )
pick f save-xt [ pick begin-compiling [
roll compiling-word set roll compiling-word set
pick compiling-label set pick compiling-label set
init-generator compiling-word get init-generator
call call
literal-table get >array literal-table get >array
word-table get >array word-table get >array
] { } make fixup add-compiled-block save-xt ; ] { } make fixup finish-compiling ;
: generate-profiler-prologue ( -- )
compiled-stack-traces? get [
compiling-word get %profiler-prologue
] when ;
GENERIC: generate-node ( node -- next ) GENERIC: generate-node ( node -- next )
@ -59,7 +62,6 @@ GENERIC: generate-node ( node -- next )
: generate ( word label node -- ) : generate ( word label node -- )
[ [
init-templates init-templates
generate-profiler-prologue
%save-word-xt %save-word-xt
%prologue-later %prologue-later
current-label-start define-label current-label-start define-label
@ -67,36 +69,12 @@ GENERIC: generate-node ( node -- next )
[ generate-nodes ] with-node-iterator [ generate-nodes ] with-node-iterator
] generate-1 ; ] generate-1 ;
: word-dataflow ( word -- dataflow ) : word-dataflow ( word -- effect dataflow )
[ [
dup "no-effect" word-prop [ no-effect ] when dup "no-effect" word-prop [ no-effect ] when
dup specialized-def over dup 2array 1array infer-quot dup specialized-def over dup 2array 1array infer-quot
finish-word finish-word
] with-infer nip ; ] with-infer ;
SYMBOL: compiler-hook
[ ] compiler-hook set-global
SYMBOL: compile-errors
SYMBOL: batch-mode
: compile-begins ( word -- )
compiler-hook get call
"quiet" get batch-mode get or [
drop
] [
"Compiling " write . flush
] if ;
: (compile) ( word -- )
dup compiling? not over compound? and [
dup compile-begins
dup dup word-dataflow optimize generate
] [
drop
] if ;
: intrinsics ( #call -- quot ) : intrinsics ( #call -- quot )
node-param "intrinsics" word-prop ; node-param "intrinsics" word-prop ;
@ -126,24 +104,17 @@ UNION: #terminal
! node ! node
M: node generate-node drop iterate-next ; M: node generate-node drop iterate-next ;
: %call ( word -- ) : %call ( word -- ) %call-label ;
dup primitive? [ %call-primitive ] [ %call-label ] if ;
: %jump ( word -- ) : %jump ( word -- )
{ dup compiling-label get eq? [
{ [ dup compiling-label get eq? ] [
drop current-label-start get %jump-label drop current-label-start get %jump-label
] } ] [
{ [ dup primitive? ] [
%epilogue-later %jump-primitive
] }
{ [ t ] [
%epilogue-later %jump-label %epilogue-later %jump-label
] } ] if ;
} cond ;
: generate-call ( label -- next ) : generate-call ( label -- next )
dup (compile) dup maybe-compile
end-basic-block end-basic-block
tail-call? [ tail-call? [
%jump f %jump f
@ -180,10 +151,6 @@ M: #if generate-node
with-template with-template
generate-if ; generate-if ;
: rel-current-word ( class -- )
compiling-label get add-word
swap rt-xt-profiling rel-fixup ;
! #dispatch ! #dispatch
: dispatch-branch ( node word -- label ) : dispatch-branch ( node word -- label )
gensym [ gensym [
@ -298,20 +265,3 @@ M: #r> generate-node
! #return ! #return
M: #return generate-node drop end-basic-block %return f ; M: #return generate-node drop end-basic-block %return f ;
! These constants must match vm/memory.h
: card-bits 6 ;
: card-mark HEX: 40 HEX: 80 bitor ;
! These constants must match vm/layouts.h
: header-offset object tag-number neg ;
: float-offset 8 float tag-number - ;
: string-offset 3 cells object tag-number - ;
: profile-count-offset 7 cells object tag-number - ;
: byte-array-offset 2 cells object tag-number - ;
: alien-offset 3 cells object tag-number - ;
: underlying-alien-offset cell object tag-number - ;
: tuple-class-offset 2 cells tuple tag-number - ;
: class-hash-offset cell object tag-number - ;
: word-xt-offset 8 cells object tag-number - ;
: compiled-header-size 8 cells ;

2
core/generator/registers/registers.factor
View File

@ -525,7 +525,7 @@ M: loc lazy-store
: clash? ( seq -- ? ) : clash? ( seq -- ? )
phantoms append [ phantoms append [
dup cached? [ cached-vreg ] when swap member? dup cached? [ cached-vreg ] when swap member?
] curry* contains? ; ] with contains? ;
: outputs-clash? ( -- ? ) : outputs-clash? ( -- ? )
output-vregs append clash? ; output-vregs append clash? ;

6
core/generic/generic-docs.factor Normal file → Executable file
View File

@ -44,7 +44,6 @@ $nl
{ $subsection implementors } { $subsection implementors }
"Low-level words which rebuilds the generic word after methods are added or removed, or the method combination is changed:" "Low-level words which rebuilds the generic word after methods are added or removed, or the method combination is changed:"
{ $subsection make-generic } { $subsection make-generic }
{ $subsection ?make-generic }
"A " { $emphasis "method specifier" } " refers to a method and implements the " { $link "definition-protocol" } ":" "A " { $emphasis "method specifier" } " refers to a method and implements the " { $link "definition-protocol" } ":"
{ $subsection method-spec } ; { $subsection method-spec } ;
@ -108,11 +107,6 @@ HELP: make-generic
{ $description "Regenerates the definition of a generic word by applying the method combination to the set of defined methods." } { $description "Regenerates the definition of a generic word by applying the method combination to the set of defined methods." }
$low-level-note ; $low-level-note ;
HELP: ?make-generic
{ $values { "word" generic } }
{ $description "Regenerates the definition of a generic word, unless bootstrap is in progress, in which case nothing is done. This avoids regenerating generic words multiple times during bootstrap as methods are defined. Instead, all generic words are built once at the end of the process, resulting in a performance improvement." }
$low-level-note ;
HELP: init-methods HELP: init-methods
{ $values { "word" word } } { $values { "word" word } }
{ $description "Prepare to define a generic word." } ; { $description "Prepare to define a generic word." } ;

8
core/generic/generic-tests.factor
View File

@ -120,8 +120,6 @@ TUPLE: delegating ;
[ t ] [ \ + math-generic? ] unit-test [ t ] [ \ + math-generic? ] unit-test
[ "SYMBOL: not-a-class C: not-a-class ;" parse ] unit-test-fails
! Test math-combination ! Test math-combination
[ [ [ >float ] dip ] ] [ \ real \ float math-upgrade ] unit-test [ [ [ >float ] dip ] ] [ \ real \ float math-upgrade ] unit-test
[ [ >float ] ] [ \ float \ real math-upgrade ] unit-test [ [ >float ] ] [ \ float \ real math-upgrade ] unit-test
@ -184,7 +182,11 @@ M: debug-combination perform-combination
SYMBOL: redefinition-test-generic SYMBOL: redefinition-test-generic
redefinition-test-generic T{ debug-combination } define-generic [
redefinition-test-generic
T{ debug-combination }
define-generic
] with-compilation-unit
TUPLE: redefinition-test-tuple ; TUPLE: redefinition-test-tuple ;

24
core/generic/generic.factor
View File

@ -5,8 +5,7 @@ definitions kernel.private classes classes.private
quotations arrays vocabs ; quotations arrays vocabs ;
IN: generic IN: generic
PREDICATE: compound generic ( word -- ? ) PREDICATE: word generic "combination" word-prop >boolean ;
"combination" word-prop ;
M: generic definer drop f f ; M: generic definer drop f f ;
@ -24,12 +23,7 @@ M: object perform-combination
nip [ "Invalid method combination" throw ] curry [ ] like ; nip [ "Invalid method combination" throw ] curry [ ] like ;
: make-generic ( word -- ) : make-generic ( word -- )
dup dup dup "combination" word-prop perform-combination define ;
dup "combination" word-prop perform-combination
define-compound ;
: ?make-generic ( word -- )
[ [ ] define-compound ] [ make-generic ] if-bootstrapping ;
: init-methods ( word -- ) : init-methods ( word -- )
dup "methods" word-prop dup "methods" word-prop
@ -38,7 +32,7 @@ M: object perform-combination
: define-generic ( word combination -- ) : define-generic ( word combination -- )
dupd "combination" set-word-prop dupd "combination" set-word-prop
dup init-methods ?make-generic ; dup init-methods make-generic ;
TUPLE: method loc def ; TUPLE: method loc def ;
@ -74,7 +68,7 @@ TUPLE: check-method class generic ;
] unless ; ] unless ;
: with-methods ( word quot -- ) : with-methods ( word quot -- )
swap [ "methods" word-prop swap call ] keep ?make-generic ; swap [ "methods" word-prop swap call ] keep make-generic ;
inline inline
: define-method ( method class generic -- ) : define-method ( method class generic -- )
@ -91,13 +85,13 @@ M: method-spec definer drop \ M: \ ; ;
M: method-spec definition first2 method method-def ; M: method-spec definition first2 method method-def ;
M: method-spec forget first2 [ delete-at ] with-methods ; M: method-spec forget* first2 [ delete-at ] with-methods ;
: implementors* ( classes -- words ) : implementors* ( classes -- words )
all-words [ all-words [
"methods" word-prop keys "methods" word-prop keys
swap [ key? ] curry contains? swap [ key? ] curry contains?
] curry* subset ; ] with subset ;
: implementors ( class -- seq ) : implementors ( class -- seq )
dup associate implementors* ; dup associate implementors* ;
@ -105,12 +99,10 @@ M: method-spec forget first2 [ delete-at ] with-methods ;
: forget-methods ( class -- ) : forget-methods ( class -- )
[ implementors ] keep [ swap 2array ] curry map forget-all ; [ implementors ] keep [ swap 2array ] curry map forget-all ;
M: class forget ( class -- ) M: class forget* ( class -- )
dup forget-methods dup forget-methods
dup uncache-class dup uncache-class
forget-word ; forget-word ;
M: class update-methods ( class -- ) M: class update-methods ( class -- )
[ drop ] class-usages implementors* [ make-generic ] each ;
[ class-usages implementors* [ make-generic ] each ]
if-bootstrapping ;

6
core/generic/standard/standard.factor Normal file → Executable file
View File

@ -96,7 +96,7 @@ TUPLE: no-method object generic ;
num-tags get [ num-tags get [
vtable-class vtable-class
[ swap first classes-intersect? ] curry subset [ swap first classes-intersect? ] curry subset
] curry* map ; ] with map ;
: build-type-vtable ( alist-seq -- alist-seq ) : build-type-vtable ( alist-seq -- alist-seq )
dup length [ dup length [
@ -182,3 +182,7 @@ M: standard-combination dispatch# standard-combination-# ;
M: hook-combination dispatch# drop 0 ; M: hook-combination dispatch# drop 0 ;
M: simple-generic definer drop \ GENERIC: f ; M: simple-generic definer drop \ GENERIC: f ;
M: standard-generic definer drop \ GENERIC# f ;
M: hook-generic definer drop \ HOOK: f ;

4
core/graphs/graphs.factor
View File

@ -14,10 +14,10 @@ SYMBOL: graph
graph get [ drop H{ } clone ] cache ; graph get [ drop H{ } clone ] cache ;
: add-vertex ( vertex edges graph -- ) : add-vertex ( vertex edges graph -- )
[ [ dupd nest set-at ] curry* each ] if-graph ; inline [ [ dupd nest set-at ] with each ] if-graph ; inline
: remove-vertex ( vertex edges graph -- ) : remove-vertex ( vertex edges graph -- )
[ [ graph get at delete-at ] curry* each ] if-graph ; inline [ [ graph get at delete-at ] with each ] if-graph ; inline
SYMBOL: previous SYMBOL: previous

12
core/inference/backend/backend-docs.factor Normal file → Executable file
View File

@ -1,17 +1,11 @@
USING: help.syntax help.markup words effects inference.dataflow USING: help.syntax help.markup words effects inference.dataflow
inference.backend kernel sequences kernel.private inference.state inference.backend kernel sequences
combinators combinators.private ; kernel.private combinators combinators.private ;
HELP: recursive-state
{ $var-description "During inference, holds an association list mapping words to labels." } ;
HELP: literal-expected HELP: literal-expected
{ $error-description "Thrown when inference encounters a " { $link call } " or " { $link if } " being applied to a value which is not known to be a literal. Such a form can have an arbitrary stack effect, and does not compile." } { $error-description "Thrown when inference encounters a " { $link call } " or " { $link if } " being applied to a value which is not known to be a literal. Such a form can have an arbitrary stack effect, and does not compile." }
{ $notes "This error will be thrown when compiling any combinator, such as " { $link each } ". However, words calling combinators can compile of the combinator is declared " { $link POSTPONE: inline } " and the quotation being passed in is a literal." } ; { $notes "This error will be thrown when compiling any combinator, such as " { $link each } ". However, words calling combinators can compile of the combinator is declared " { $link POSTPONE: inline } " and the quotation being passed in is a literal." } ;
HELP: terminated?
{ $var-description "During inference, a flag set to " { $link t } " if the current control flow path unconditionally throws an error." } ;
HELP: too-many->r HELP: too-many->r
{ $error-description "Thrown if inference notices a quotation pushing elements on the retain stack without popping them at the end." } { $error-description "Thrown if inference notices a quotation pushing elements on the retain stack without popping them at the end." }
{ $notes "See " { $link "shuffle-words" } " for retain stack usage conventions." } ; { $notes "See " { $link "shuffle-words" } " for retain stack usage conventions." } ;
@ -57,7 +51,7 @@ HELP: collect-recursion
{ $values { "#label" "a " { $link #label } " node" } { "seq" "a new sequence" } } { $values { "#label" "a " { $link #label } " node" } { "seq" "a new sequence" } }
{ $description "Collect the input stacks of all child " { $link #call-label } " nodes that call the given label." } ; { $description "Collect the input stacks of all child " { $link #call-label } " nodes that call the given label." } ;
HELP: inline-closure HELP: inline-word
{ $values { "word" word } } { $values { "word" word } }
{ $description "Called during inference to infer stack effects of inline words." { $description "Called during inference to infer stack effects of inline words."
$nl $nl

53
core/inference/backend/backend.factor
View File

@ -1,10 +1,10 @@
! Copyright (C) 2004, 2007 Slava Pestov. ! Copyright (C) 2004, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: inference.dataflow inference.state arrays generic io
io.streams.string kernel math namespaces parser prettyprint
sequences strings vectors words quotations effects classes
continuations debugger assocs combinators compiler.errors ;
IN: inference.backend IN: inference.backend
USING: inference.dataflow arrays generic io io.streams.string
kernel math namespaces parser prettyprint sequences
strings vectors words quotations effects classes continuations
debugger assocs combinators ;
: recursive-label ( word -- label/f ) : recursive-label ( word -- label/f )
recursive-state get at ; recursive-state get at ;
@ -18,10 +18,13 @@ debugger assocs combinators ;
local-recursive-state at ; local-recursive-state at ;
: recursive-quotation? ( quot -- ? ) : recursive-quotation? ( quot -- ? )
local-recursive-state [ first eq? ] curry* contains? ; local-recursive-state [ first eq? ] with contains? ;
TUPLE: inference-error rstate major? ; TUPLE: inference-error rstate major? ;
M: inference-error compiler-warning?
inference-error-major? not ;
: (inference-error) ( ... class important? -- * ) : (inference-error) ( ... class important? -- * )
>r construct-boa r> >r construct-boa r>
recursive-state get { recursive-state get {
@ -54,14 +57,10 @@ M: object value-literal \ literal-expected inference-warning ;
: ensure-values ( seq -- ) : ensure-values ( seq -- )
meta-d [ add-inputs ] change d-in [ + ] change ; meta-d [ add-inputs ] change d-in [ + ] change ;
SYMBOL: terminated?
: current-effect ( -- effect ) : current-effect ( -- effect )
d-in get meta-d get length <effect> d-in get meta-d get length <effect>
terminated? get over set-effect-terminated? ; terminated? get over set-effect-terminated? ;
SYMBOL: recorded
: init-inference ( -- ) : init-inference ( -- )
terminated? off terminated? off
V{ } clone meta-d set V{ } clone meta-d set
@ -77,7 +76,7 @@ GENERIC: apply-object ( obj -- )
M: object apply-object apply-literal ; M: object apply-object apply-literal ;
M: wrapper apply-object wrapped apply-literal ; M: wrapper apply-object wrapped dup depends-on apply-literal ;
: terminate ( -- ) : terminate ( -- )
terminated? on #terminate node, ; terminated? on #terminate node, ;
@ -319,7 +318,7 @@ TUPLE: unbalanced-branches-error quots in out ;
] H{ } make-assoc ; inline ] H{ } make-assoc ; inline
: (infer-branches) ( last branches -- list ) : (infer-branches) ( last branches -- list )
[ infer-branch ] curry* map [ infer-branch ] with map
dup unify-effects unify-dataflow ; inline dup unify-effects unify-dataflow ; inline
: infer-branches ( last branches node -- ) : infer-branches ( last branches node -- )
@ -345,10 +344,6 @@ TUPLE: no-effect word ;
: no-effect ( word -- * ) \ no-effect inference-warning ; : no-effect ( word -- * ) \ no-effect inference-warning ;
GENERIC: infer-word ( word -- effect )
M: word infer-word no-effect ;
TUPLE: effect-error word effect ; TUPLE: effect-error word effect ;
: effect-error ( word effect -- * ) : effect-error ( word effect -- * )
@ -364,17 +359,16 @@ TUPLE: effect-error word effect ;
over recorded get push over recorded get push
"inferred-effect" set-word-prop ; "inferred-effect" set-word-prop ;
: infer-compound ( word -- effect ) : infer-word ( word -- effect )
[
[ [
init-inference init-inference
dependencies off
dup word-def over dup infer-quot-recursive dup word-def over dup infer-quot-recursive
finish-word finish-word
current-effect current-effect
] with-scope ; ] with-scope
] [ ] [ t "no-effect" set-word-prop ] cleanup ;
M: compound infer-word
[ infer-compound ] [ ] [ t "no-effect" set-word-prop ]
cleanup ;
: custom-infer ( word -- ) : custom-infer ( word -- )
#! Customized inference behavior #! Customized inference behavior
@ -391,10 +385,6 @@ M: compound infer-word
{ [ t ] [ dup infer-word make-call-node ] } { [ t ] [ dup infer-word make-call-node ] }
} cond ; } cond ;
M: word apply-object apply-word ;
M: symbol apply-object apply-literal ;
TUPLE: recursive-declare-error word ; TUPLE: recursive-declare-error word ;
: declared-infer ( word -- ) : declared-infer ( word -- )
@ -445,7 +435,7 @@ M: #call-label collect-recursion*
[ swap [ at ] curry map ] keep [ swap [ at ] curry map ] keep
[ set ] 2each ; [ set ] 2each ;
: inline-closure ( word -- ) : inline-word ( word -- )
dup inline-block over recursive-label? [ dup inline-block over recursive-label? [
flatten-meta-d >r flatten-meta-d >r
drop join-values inline-block apply-infer drop join-values inline-block apply-infer
@ -458,18 +448,15 @@ M: #call-label collect-recursion*
apply-infer node-child node-successor splice-node drop apply-infer node-child node-successor splice-node drop
] if ; ] if ;
M: compound apply-object M: word apply-object
[ dup depends-on [
dup inline-recursive-label dup inline-recursive-label
[ declared-infer ] [ inline-closure ] if [ declared-infer ] [ inline-word ] if
] [ ] [
dup recursive-label dup recursive-label
[ declared-infer ] [ apply-word ] if [ declared-infer ] [ apply-word ] if
] if-inline ; ] if-inline ;
M: undefined apply-object
drop "Undefined word" time-bomb ;
: with-infer ( quot -- effect dataflow ) : with-infer ( quot -- effect dataflow )
[ [
[ [

14
core/inference/class/class-tests.factor Normal file → Executable file
View File

@ -3,7 +3,7 @@ USING: arrays math.private kernel math compiler inference
inference.dataflow optimizer tools.test kernel.private generic inference.dataflow optimizer tools.test kernel.private generic
sequences words inference.class quotations alien sequences words inference.class quotations alien
alien.c-types strings sbufs sequences.private alien.c-types strings sbufs sequences.private
slots.private combinators ; slots.private combinators definitions ;
! Make sure these compile even though this is invalid code ! Make sure these compile even though this is invalid code
[ ] [ [ 10 mod 3.0 /i ] dataflow optimize drop ] unit-test [ ] [ [ 10 mod 3.0 /i ] dataflow optimize drop ] unit-test
@ -14,7 +14,7 @@ slots.private combinators ;
: inlined? ( quot word -- ? ) : inlined? ( quot word -- ? )
swap dataflow optimize swap dataflow optimize
[ node-param eq? ] curry* node-exists? not ; [ node-param eq? ] with node-exists? not ;
GENERIC: mynot ( x -- y ) GENERIC: mynot ( x -- y )
@ -136,9 +136,15 @@ M: object xyz ;
] set-constraints ] set-constraints
] "constraints" set-word-prop ] "constraints" set-word-prop
DEFER: blah
[ t ] [ [ t ] [
[ dup V{ } eq? [ foo ] when ] dup second dup push [
compile-quot word? \ blah
[ dup V{ } eq? [ foo ] when ] dup second dup push define
] with-compilation-unit
\ blah compiled?
] unit-test ] unit-test
GENERIC: detect-fx ( n -- n ) GENERIC: detect-fx ( n -- n )

3
core/inference/dataflow/dataflow-docs.factor Normal file → Executable file
View File

@ -3,6 +3,3 @@ USING: inference.dataflow help.syntax help.markup ;
HELP: #return HELP: #return
{ $values { "label" "a word or " { $link f } } { "node" "a new " { $link node } } } { $values { "label" "a word or " { $link f } } { "node" "a new " { $link node } } }
{ $description "Creates a node which returns from a nested label, or if " { $snippet "label" } " is " { $link f } ", the top-level word being compiled." } ; { $description "Creates a node which returns from a nested label, or if " { $snippet "label" } " is " { $link f } ", the top-level word being compiled." } ;
HELP: d-in
{ $var-description "During inference, holds the number of inputs which the quotation has been inferred to require so far." } ;

31
core/inference/dataflow/dataflow.factor Normal file → Executable file
View File

@ -1,11 +1,9 @@
! Copyright (C) 2004, 2007 Slava Pestov. ! Copyright (C) 2004, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: arrays generic assocs kernel math namespaces parser
sequences words vectors math.intervals effects classes
inference.state ;
IN: inference.dataflow IN: inference.dataflow
USING: arrays generic assocs kernel math
namespaces parser sequences words vectors math.intervals
effects classes ;
SYMBOL: recursive-state
! Computed value ! Computed value
: <computed> \ <computed> counter ; : <computed> \ <computed> counter ;
@ -30,20 +28,8 @@ TUPLE: composed quot1 quot2 ;
C: <composed> composed C: <composed> composed
SYMBOL: d-in
SYMBOL: meta-d
SYMBOL: meta-r
UNION: special curried composed ; UNION: special curried composed ;
: push-d meta-d get push ;
: pop-d meta-d get pop ;
: peek-d meta-d get peek ;
: push-r meta-r get push ;
: pop-r meta-r get pop ;
: peek-r meta-r get peek ;
TUPLE: node param TUPLE: node param
in-d out-d in-r out-r in-d out-d in-r out-r
classes literals intervals classes literals intervals
@ -185,9 +171,6 @@ UNION: #branch #if #dispatch ;
>r r-tail flatten-curries r> set-node-out-r >r r-tail flatten-curries r> set-node-out-r
>r d-tail flatten-curries r> set-node-out-d ; >r d-tail flatten-curries r> set-node-out-d ;
SYMBOL: dataflow-graph
SYMBOL: current-node
: node, ( node -- ) : node, ( node -- )
dataflow-graph get [ dataflow-graph get [
dup current-node [ set-node-successor ] change dup current-node [ set-node-successor ] change
@ -234,7 +217,7 @@ M: node calls-label* 2drop f ;
M: #call-label calls-label* node-param eq? ; M: #call-label calls-label* node-param eq? ;
: calls-label? ( label node -- ? ) : calls-label? ( label node -- ? )
[ calls-label* ] curry* node-exists? ; [ calls-label* ] with node-exists? ;
: recursive-label? ( node -- ? ) : recursive-label? ( node -- ? )
dup node-param swap calls-label? ; dup node-param swap calls-label? ;
@ -287,10 +270,10 @@ SYMBOL: node-stack
swap node-classes at object or ; swap node-classes at object or ;
: node-input-classes ( node -- seq ) : node-input-classes ( node -- seq )
dup node-in-d [ node-class ] curry* map ; dup node-in-d [ node-class ] with map ;
: node-input-intervals ( node -- seq ) : node-input-intervals ( node -- seq )
dup node-in-d [ node-interval ] curry* map ; dup node-in-d [ node-interval ] with map ;
: node-class-first ( node -- class ) : node-class-first ( node -- class )
dup node-in-d first node-class ; dup node-in-d first node-class ;

10
core/inference/inference-docs.factor Normal file → Executable file
View File

@ -1,6 +1,6 @@
USING: help.syntax help.markup kernel sequences words io USING: help.syntax help.markup kernel sequences words io
effects inference.dataflow inference.backend effects inference.dataflow inference.backend
math combinators inference.transforms ; math combinators inference.transforms inference.state ;
IN: inference IN: inference
ARTICLE: "inference-simple" "Straight-line stack effects" ARTICLE: "inference-simple" "Straight-line stack effects"
@ -139,3 +139,11 @@ HELP: dataflow-with
{ $values { "quot" "a quotation" } { "stack" "a vector" } { "dataflow" "a dataflow node" } } { $values { "quot" "a quotation" } { "stack" "a vector" } { "dataflow" "a dataflow node" } }
{ $description "Attempts to construct a dataflow graph showing stack flow in the quotation, starting with an initial data stack of values." } { $description "Attempts to construct a dataflow graph showing stack flow in the quotation, starting with an initial data stack of values." }
{ $errors "Throws an " { $link inference-error } " if stack effect inference fails." } ; { $errors "Throws an " { $link inference-error } " if stack effect inference fails." } ;
HELP: forget-errors
{ $description "Removes markers indicating which words do not have stack effects."
$nl
"The stack effect inference code remembers which words failed to infer as an optimization, so that it does not try to infer the stack effect of words which do not have one over and over again." }
{ $notes "Usually this word does not need to be called directly; if a word failed to compile because of a stack effect error, fixing the word definition clears the flag automatically. However, if words failed to compile due to external factors which were subsequently rectified, such as an unavailable C library or a missing or broken compiler transform, this flag can be cleared for all words:"
{ $code "forget-errors" }
"Subsequent invocations of the compiler will consider all words for compilation." } ;

158
core/inference/inference-tests.factor
View File

@ -3,10 +3,9 @@ inference.dataflow kernel classes kernel.private math
math.parser math.private namespaces namespaces.private parser math.parser math.private namespaces namespaces.private parser
sequences strings vectors words quotations effects tools.test sequences strings vectors words quotations effects tools.test
continuations generic.standard sorting assocs definitions continuations generic.standard sorting assocs definitions
prettyprint io inspector bootstrap.image tuples prettyprint io inspector tuples classes.union classes.predicate
classes.union classes.predicate debugger bootstrap.image debugger threads.private io.streams.string combinators.private
bootstrap.image.private io.launcher threads.private tools.test.inference ;
io.streams.string combinators.private tools.test.inference ;
IN: temporary IN: temporary
{ 0 2 } [ 2 "Hello" ] unit-test-effect { 0 2 } [ 2 "Hello" ] unit-test-effect
@ -352,69 +351,69 @@ DEFER: bar
[ [ 3 [ ] curry 1 2 [ ] 2curry if ] infer ] unit-test-fails [ [ 3 [ ] curry 1 2 [ ] 2curry if ] infer ] unit-test-fails
! Test number protocol ! Test number protocol
{ 2 1 } [ bitor ] unit-test-effect \ bitor must-infer
{ 2 1 } [ bitand ] unit-test-effect \ bitand must-infer
{ 2 1 } [ bitxor ] unit-test-effect \ bitxor must-infer
{ 2 1 } [ mod ] unit-test-effect \ mod must-infer
{ 2 1 } [ /i ] unit-test-effect \ /i must-infer
{ 2 1 } [ /f ] unit-test-effect \ /f must-infer
{ 2 2 } [ /mod ] unit-test-effect \ /mod must-infer
{ 2 1 } [ + ] unit-test-effect \ + must-infer
{ 2 1 } [ - ] unit-test-effect \ - must-infer
{ 2 1 } [ * ] unit-test-effect \ * must-infer
{ 2 1 } [ / ] unit-test-effect \ / must-infer
{ 2 1 } [ < ] unit-test-effect \ < must-infer
{ 2 1 } [ <= ] unit-test-effect \ <= must-infer
{ 2 1 } [ > ] unit-test-effect \ > must-infer
{ 2 1 } [ >= ] unit-test-effect \ >= must-infer
{ 2 1 } [ number= ] unit-test-effect \ number= must-infer
! Test object protocol ! Test object protocol
{ 2 1 } [ = ] unit-test-effect \ = must-infer
{ 1 1 } [ clone ] unit-test-effect \ clone must-infer
{ 2 1 } [ hashcode* ] unit-test-effect \ hashcode* must-infer
! Test sequence protocol ! Test sequence protocol
{ 1 1 } [ length ] unit-test-effect \ length must-infer
{ 2 1 } [ nth ] unit-test-effect \ nth must-infer
{ 2 0 } [ set-length ] unit-test-effect \ set-length must-infer
{ 3 0 } [ set-nth ] unit-test-effect \ set-nth must-infer
{ 2 1 } [ new ] unit-test-effect \ new must-infer
{ 2 1 } [ new-resizable ] unit-test-effect \ new-resizable must-infer
{ 2 1 } [ like ] unit-test-effect \ like must-infer
{ 2 0 } [ lengthen ] unit-test-effect \ lengthen must-infer
! Test assoc protocol ! Test assoc protocol
{ 2 2 } [ at* ] unit-test-effect \ at* must-infer
{ 3 0 } [ set-at ] unit-test-effect \ set-at must-infer
{ 2 1 } [ new-assoc ] unit-test-effect \ new-assoc must-infer
{ 2 0 } [ delete-at ] unit-test-effect \ delete-at must-infer
{ 1 0 } [ clear-assoc ] unit-test-effect \ clear-assoc must-infer
{ 1 1 } [ assoc-size ] unit-test-effect \ assoc-size must-infer
{ 2 1 } [ assoc-like ] unit-test-effect \ assoc-like must-infer
{ 2 1 } [ assoc-clone-like ] unit-test-effect \ assoc-clone-like must-infer
{ 1 1 } [ >alist ] unit-test-effect \ >alist must-infer
{ 1 3 } [ [ 2drop f ] assoc-find ] unit-test-effect { 1 3 } [ [ 2drop f ] assoc-find ] unit-test-effect
! Test some random library words ! Test some random library words
{ 1 1 } [ 1quotation ] unit-test-effect \ 1quotation must-infer
{ 1 1 } [ string>number ] unit-test-effect \ string>number must-infer
{ 1 1 } [ get ] unit-test-effect \ get must-infer
{ 2 0 } [ push ] unit-test-effect \ push must-infer
{ 2 1 } [ append ] unit-test-effect \ append must-infer
{ 1 1 } [ peek ] unit-test-effect \ peek must-infer
{ 1 1 } [ reverse ] unit-test-effect \ reverse must-infer
{ 2 1 } [ member? ] unit-test-effect \ member? must-infer
{ 2 1 } [ remove ] unit-test-effect \ remove must-infer
{ 1 1 } [ natural-sort ] unit-test-effect \ natural-sort must-infer
{ 1 0 } [ forget ] unit-test-effect \ forget must-infer
{ 4 0 } [ define-class ] unit-test-effect \ define-class must-infer
{ 2 0 } [ define-tuple-class ] unit-test-effect \ define-tuple-class must-infer
{ 2 0 } [ define-union-class ] unit-test-effect \ define-union-class must-infer
{ 3 0 } [ define-predicate-class ] unit-test-effect \ define-predicate-class must-infer
! Test words with continuations ! Test words with continuations
{ 0 0 } [ [ drop ] callcc0 ] unit-test-effect { 0 0 } [ [ drop ] callcc0 ] unit-test-effect
@ -423,39 +422,36 @@ DEFER: bar
{ 2 1 } [ [ + ] [ 3drop 0 ] recover ] unit-test-effect { 2 1 } [ [ + ] [ 3drop 0 ] recover ] unit-test-effect
! Test stream protocol ! Test stream protocol
{ 2 0 } [ set-timeout ] unit-test-effect \ set-timeout must-infer
{ 2 1 } [ stream-read ] unit-test-effect \ stream-read must-infer
{ 1 1 } [ stream-read1 ] unit-test-effect \ stream-read1 must-infer
{ 1 1 } [ stream-readln ] unit-test-effect \ stream-readln must-infer
{ 2 2 } [ stream-read-until ] unit-test-effect \ stream-read-until must-infer
{ 2 0 } [ stream-write ] unit-test-effect \ stream-write must-infer
{ 2 0 } [ stream-write1 ] unit-test-effect \ stream-write1 must-infer
{ 1 0 } [ stream-nl ] unit-test-effect \ stream-nl must-infer
{ 1 0 } [ stream-close ] unit-test-effect \ stream-close must-infer
{ 3 0 } [ stream-format ] unit-test-effect \ stream-format must-infer
{ 3 0 } [ stream-write-table ] unit-test-effect \ stream-write-table must-infer
{ 1 0 } [ stream-flush ] unit-test-effect \ stream-flush must-infer
{ 2 1 } [ make-span-stream ] unit-test-effect \ make-span-stream must-infer
{ 2 1 } [ make-block-stream ] unit-test-effect \ make-block-stream must-infer
{ 2 1 } [ make-cell-stream ] unit-test-effect \ make-cell-stream must-infer
! Test stream utilities ! Test stream utilities
{ 1 1 } [ lines ] unit-test-effect \ lines must-infer
{ 1 1 } [ contents ] unit-test-effect \ contents must-infer
! Test prettyprinting ! Test prettyprinting
{ 1 0 } [ . ] unit-test-effect \ . must-infer
{ 1 0 } [ short. ] unit-test-effect \ short. must-infer
{ 1 1 } [ unparse ] unit-test-effect \ unparse must-infer
{ 1 0 } [ describe ] unit-test-effect \ describe must-infer
{ 1 0 } [ error. ] unit-test-effect \ error. must-infer
! Test odds and ends ! Test odds and ends
{ 1 1 } [ ' ] unit-test-effect \ idle-thread must-infer
{ 2 0 } [ write-image ] unit-test-effect
{ 1 1 } [ <process-stream> ] unit-test-effect
{ 0 0 } [ idle-thread ] unit-test-effect
! Incorrect stack declarations on inline recursive words should ! Incorrect stack declarations on inline recursive words should
! be caught ! be caught

10
core/inference/inference.factor Normal file → Executable file
View File

@ -1,9 +1,10 @@
! Copyright (C) 2004, 2007 Slava Pestov. ! Copyright (C) 2004, 2007 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
IN: inference USING: inference.backend inference.state inference.dataflow
USING: inference.backend inference.dataflow
inference.known-words inference.transforms inference.errors inference.known-words inference.transforms inference.errors
sequences prettyprint io effects kernel namespaces quotations ; sequences prettyprint io effects kernel namespaces quotations
words vocabs ;
IN: inference
GENERIC: infer ( quot -- effect ) GENERIC: infer ( quot -- effect )
@ -25,3 +26,6 @@ M: callable dataflow-with
V{ } like meta-d set V{ } like meta-d set
f infer-quot f infer-quot
] with-infer nip ; ] with-infer nip ;
: forget-errors ( -- )
all-words [ f "no-effect" set-word-prop ] each ;

26
core/inference/known-words/known-words.factor Normal file → Executable file
View File

@ -1,16 +1,16 @@
! Copyright (C) 2004, 2007 Slava Pestov. ! Copyright (C) 2004, 2007 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
IN: inference.known-words
USING: alien arrays bit-arrays byte-arrays classes USING: alien arrays bit-arrays byte-arrays classes
combinators.private continuations.private effects float-arrays combinators.private continuations.private effects float-arrays
generic hashtables hashtables.private inference.backend generic hashtables hashtables.private inference.state
inference.dataflow io io.backend io.files io.files.private inference.backend inference.dataflow io io.backend io.files
io.streams.c kernel kernel.private math math.private memory io.files.private io.streams.c kernel kernel.private math
namespaces namespaces.private parser prettyprint quotations math.private memory namespaces namespaces.private parser
quotations.private sbufs sbufs.private sequences prettyprint quotations quotations.private sbufs sbufs.private
sequences.private slots.private strings strings.private system sequences sequences.private slots.private strings
threads.private tuples tuples.private vectors vectors.private strings.private system threads.private tuples tuples.private
words assocs ; vectors vectors.private words words.private assocs inspector ;
IN: inference.known-words
! Shuffle words ! Shuffle words
: infer-shuffle-inputs ( shuffle node -- ) : infer-shuffle-inputs ( shuffle node -- )
@ -79,8 +79,8 @@ M: curried infer-call
M: composed infer-call M: composed infer-call
infer-uncurry infer-uncurry
infer->r peek-d infer-call infer-r> infer->r peek-d infer-call
peek-d infer-call ; terminated? get [ infer-r> peek-d infer-call ] unless ;
M: object infer-call M: object infer-call
\ literal-expected inference-warning ; \ literal-expected inference-warning ;
@ -344,8 +344,6 @@ t over set-effect-terminated?
\ <word> { object object } { word } <effect> "inferred-effect" set-word-prop \ <word> { object object } { word } <effect> "inferred-effect" set-word-prop
\ <word> make-flushable \ <word> make-flushable
\ update-xt { word } { } <effect> "inferred-effect" set-word-prop
\ word-xt { word } { integer } <effect> "inferred-effect" set-word-prop \ word-xt { word } { integer } <effect> "inferred-effect" set-word-prop
\ word-xt make-flushable \ word-xt make-flushable
@ -579,3 +577,5 @@ t over set-effect-terminated?
\ set-innermost-frame-quot { quotation callstack } { } <effect> "inferred-effect" set-word-prop \ set-innermost-frame-quot { quotation callstack } { } <effect> "inferred-effect" set-word-prop
\ (os-envs) { } { array } <effect> "inferred-effect" set-word-prop \ (os-envs) { } { array } <effect> "inferred-effect" set-word-prop
\ do-primitive [ \ do-primitive no-effect ] "infer" set-word-prop

11
core/inference/state/state-docs.factor Executable file
View File

@ -0,0 +1,11 @@
USING: help.markup help.syntax inference.state ;
HELP: d-in
{ $var-description "During inference, holds the number of inputs which the quotation has been inferred to require so far." } ;
HELP: recursive-state
{ $var-description "During inference, holds an association list mapping words to labels." } ;
HELP: terminated?
{ $var-description "During inference, a flag set to " { $link t } " if the current control flow path unconditionally throws an error." } ;

45
core/inference/state/state.factor Executable file
View File

@ -0,0 +1,45 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: assocs namespaces sequences kernel ;
IN: inference.state
! Nesting state to solve recursion
SYMBOL: recursive-state
! Number of inputs current word expects from the stack
SYMBOL: d-in
! Compile-time data stack
SYMBOL: meta-d
: push-d meta-d get push ;
: pop-d meta-d get pop ;
: peek-d meta-d get peek ;
! Compile-time retain stack
SYMBOL: meta-r
: push-r meta-r get push ;
: pop-r meta-r get pop ;
: peek-r meta-r get peek ;
! Head of dataflow IR
SYMBOL: dataflow-graph
SYMBOL: current-node
! Words that the current dataflow IR depends on
SYMBOL: dependencies
: depends-on ( word -- )
dup dependencies get dup [ set-at ] [ 3drop ] if ;
: computing-dependencies ( quot -- dependencies )
H{ } clone [ dependencies rot with-variable ] keep keys ;
inline
! Did the current control-flow path throw an error?
SYMBOL: terminated?
! Words we've inferred the stack effect of, for rollback
SYMBOL: recorded

2
core/inference/transforms/transforms.factor Normal file → Executable file
View File

@ -2,7 +2,7 @@
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: arrays kernel words sequences generic math namespaces USING: arrays kernel words sequences generic math namespaces
quotations assocs combinators math.bitfields inference.backend quotations assocs combinators math.bitfields inference.backend
inference.dataflow tuples.private ; inference.dataflow inference.state tuples.private ;
IN: inference.transforms IN: inference.transforms
: pop-literals ( n -- rstate seq ) : pop-literals ( n -- rstate seq )

2
core/io/binary/binary.factor
View File

@ -10,7 +10,7 @@ IN: io.binary
: nth-byte ( x n -- b ) -8 * shift mask-byte ; inline : nth-byte ( x n -- b ) -8 * shift mask-byte ; inline
: >le ( x n -- str ) [ nth-byte ] curry* "" map-as ; : >le ( x n -- str ) [ nth-byte ] with "" map-as ;
: >be ( x n -- str ) >le dup reverse-here ; : >be ( x n -- str ) >le dup reverse-here ;
: d>w/w ( d -- w1 w2 ) : d>w/w ( d -- w1 w2 )

12
core/io/crc32/crc32.factor Normal file → Executable file
View File

@ -1,23 +1,19 @@
! Copyright (C) 2006 Doug Coleman ! Copyright (C) 2006 Doug Coleman
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: kernel math sequences sequences.private namespaces USING: kernel math sequences sequences.private namespaces
words io io.binary io.files io.streams.string quotations ; words io io.binary io.files io.streams.string quotations
definitions ;
IN: io.crc32 IN: io.crc32
: crc32-polynomial HEX: edb88320 ; inline : crc32-polynomial HEX: edb88320 ; inline
! Generate the table at load time and define a new word with it, : crc32-table V{ } ; inline
! instead of using a variable, so that the compiler can inline
! the call to nth-unsafe
DEFER: crc32-table inline
\ crc32-table
256 [ 256 [
8 [ 8 [
dup even? >r 2/ r> [ crc32-polynomial bitxor ] unless dup even? >r 2/ r> [ crc32-polynomial bitxor ] unless
] times >bignum ] times >bignum
] map ] map 0 crc32-table copy
1quotation define-inline
: (crc32) ( crc ch -- crc ) : (crc32) ( crc ch -- crc )
>bignum dupd bitxor >bignum dupd bitxor

4
core/io/files/files.factor
View File

@ -46,7 +46,7 @@ M: object root-directory? ( path -- ? ) path-separator? ;
[ [
dup string? dup string?
[ tuck path+ directory? 2array ] [ nip ] if [ tuck path+ directory? 2array ] [ nip ] if
] curry* map ] with map
[ first special-directory? not ] subset ; [ first special-directory? not ] subset ;
: directory ( path -- seq ) : directory ( path -- seq )
@ -143,7 +143,7 @@ HOOK: binary-roots io-backend ( -- seq )
<PRIVATE <PRIVATE
: append-path ( path files -- paths ) : append-path ( path files -- paths )
[ path+ ] curry* map ; [ path+ ] with map ;
: get-paths ( dir -- paths ) : get-paths ( dir -- paths )
dup directory keys append-path ; dup directory keys append-path ;

2
core/io/streams/c/c.factor
View File

@ -61,7 +61,7 @@ M: object init-io ;
: stdout 12 getenv ; : stdout 12 getenv ;
M: object init-stdio M: object init-stdio
stdin stdout <duplex-c-stream> stdio set ; stdin stdout <duplex-c-stream> stdio set-global ;
M: object io-multiplex (sleep) ; M: object io-multiplex (sleep) ;

22
core/kernel/kernel-docs.factor Normal file → Executable file
View File

@ -26,6 +26,7 @@ $nl
{ $subsection swapd } { $subsection swapd }
{ $subsection rot } { $subsection rot }
{ $subsection -rot } { $subsection -rot }
{ $subsection spin }
{ $subsection roll } { $subsection roll }
{ $subsection -roll } { $subsection -roll }
"Sometimes an additional storage area is needed to hold objects. The " { $emphasis "retain stack" } " is an auxilliary stack for this purpose. Objects can be moved between the data and retain stacks using the following two words:" "Sometimes an additional storage area is needed to hold objects. The " { $emphasis "retain stack" } " is an auxilliary stack for this purpose. Objects can be moved between the data and retain stacks using the following two words:"
@ -37,7 +38,9 @@ $nl
{ $code { $code
": foo ( m ? n -- m+n/n )" ": foo ( m ? n -- m+n/n )"
" >r [ r> + ] [ drop r> ] if ; ! This is OK" " >r [ r> + ] [ drop r> ] if ; ! This is OK"
} ; }
"An alternative to using " { $link >r } " and " { $link r> } " is the following:"
{ $subsection dip } ;
ARTICLE: "basic-combinators" "Basic combinators" ARTICLE: "basic-combinators" "Basic combinators"
"The following pair of words invoke words and quotations reflectively:" "The following pair of words invoke words and quotations reflectively:"
@ -66,7 +69,7 @@ $nl
{ $subsection curry } { $subsection curry }
{ $subsection 2curry } { $subsection 2curry }
{ $subsection 3curry } { $subsection 3curry }
{ $subsection curry* } { $subsection with }
{ $subsection compose } { $subsection compose }
{ $subsection 3compose } { $subsection 3compose }
"Quotations also implement the sequence protocol, and can be manipulated with sequence words; see " { $link "quotations" } "." "Quotations also implement the sequence protocol, and can be manipulated with sequence words; see " { $link "quotations" } "."
@ -159,6 +162,7 @@ HELP: tuck ( x y -- y x y ) $shuffle ;
HELP: over ( x y -- x y x ) $shuffle ; HELP: over ( x y -- x y x ) $shuffle ;
HELP: pick ( x y z -- x y z x ) $shuffle ; HELP: pick ( x y z -- x y z x ) $shuffle ;
HELP: swap ( x y -- y x ) $shuffle ; HELP: swap ( x y -- y x ) $shuffle ;
HELP: spin $shuffle ;
HELP: roll $shuffle ; HELP: roll $shuffle ;
HELP: -roll $shuffle ; HELP: -roll $shuffle ;
@ -505,16 +509,16 @@ HELP: 3curry
{ $description "Outputs a " { $link callable } " which pushes " { $snippet "obj1" } ", " { $snippet "obj2" } " and " { $snippet "obj3" } ", and then calls " { $snippet "quot" } "." } { $description "Outputs a " { $link callable } " which pushes " { $snippet "obj1" } ", " { $snippet "obj2" } " and " { $snippet "obj3" } ", and then calls " { $snippet "quot" } "." }
{ $notes "This operation is efficient and does not copy the quotation." } ; { $notes "This operation is efficient and does not copy the quotation." } ;
HELP: curry* HELP: with
{ $values { "param" object } { "obj" object } { "quot" "a quotation with stack effect " { $snippet "( param elt -- ... )" } } { "obj" object } { "curry" curry } } { $values { "param" object } { "obj" object } { "quot" "a quotation with stack effect " { $snippet "( param elt -- ... )" } } { "obj" object } { "curry" curry } }
{ $description "Partial application on the left. The following two lines are equivalent:" { $description "Partial application on the left. The following two lines are equivalent:"
{ $code "swap [ swap A ] curry B" } { $code "swap [ swap A ] curry B" }
{ $code "[ A ] curry* B" } { $code "[ A ] with B" }
} }
{ $notes "This operation is efficient and does not copy the quotation." } { $notes "This operation is efficient and does not copy the quotation." }
{ $examples { $examples
{ $example "2 { 1 2 3 } [ - ] curry* map ." "{ 1 0 -1 }" } { $example "2 { 1 2 3 } [ - ] with map ." "{ 1 0 -1 }" }
} ; } ;
HELP: compose HELP: compose
@ -541,6 +545,14 @@ HELP: 3compose
"However, " { $link 3compose } " runs in constant time, and the compiler is able to compile code which calls composed quotations." "However, " { $link 3compose } " runs in constant time, and the compiler is able to compile code which calls composed quotations."
} ; } ;
HELP: dip
{ $values { "obj" object } { "quot" quotation } }
{ $description "Calls " { $snippet "quot" } " with " { $snippet "obj" } " hidden on the retain stack." }
{ $notes "The following are equivalent:"
{ $code ">r foo bar r>" }
{ $code "[ foo bar ] dip" }
} ;
HELP: while HELP: while
{ $values { "pred" "a quotation with stack effect " { $snippet "( -- ? )" } } { "body" "a quotation" } { "tail" "a quotation" } } { $values { "pred" "a quotation with stack effect " { $snippet "( -- ? )" } } { "body" "a quotation" } { "tail" "a quotation" } }
{ $description "Repeatedly calls " { $snippet "pred" } ". If it yields " { $link f } ", iteration stops, otherwise " { $snippet "quot" } " is called. After iteration stops, " { $snippet "tail" } " is called." } { $description "Repeatedly calls " { $snippet "pred" } ". If it yields " { $link f } ", iteration stops, otherwise " { $snippet "quot" } " is called. After iteration stops, " { $snippet "tail" } " is called." }

6
core/kernel/kernel-tests.factor Normal file → Executable file
View File

@ -102,3 +102,9 @@ IN: temporary
[ 3drop datastack ] unit-test-fails [ 3drop datastack ] unit-test-fails
[ ] [ :c ] unit-test [ ] [ :c ] unit-test
! Doesn't compile; important
: foo 5 + 0 [ ] each ;
[ drop foo ] unit-test-fails
[ ] [ :c ] unit-test

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