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:
rm -f vm/*.o
rm -f libfactor.a
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
{ $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." }
{ $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
{ $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.
IN: alien
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
! purposes
PREDICATE: alien simple-alien
underlying-alien not ;
UNION: simple-c-ptr
simple-alien byte-array bit-array float-array POSTPONE: f ;
! These mixins are not intended to be extended by user code.
! 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?
@ -20,9 +28,6 @@ PREDICATE: alien pinned-alien
UNION: pinned-c-ptr
pinned-alien POSTPONE: f ;
UNION: c-ptr
alien bit-array byte-array float-array POSTPONE: f ;
M: f expired? drop t ;
: <alien> ( address -- alien )
@ -47,9 +52,7 @@ M: alien equal?
SYMBOL: libraries
global [
libraries [ H{ } assoc-like ] change
] bind
libraries global [ H{ } assoc-like ] change-at
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 ;
: 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 )
[
@ -207,7 +207,7 @@ M: long-long-type box-return ( type -- )
>r "c-" swap "-array>" 3append r> create ;
: 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 )
<c-type>

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

@ -2,7 +2,7 @@
! See http://factorcode.org/license.txt for BSD license.
USING: arrays generator generator.registers generator.fixup
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
alien.syntax cpu.architecture alien inspector quotations assocs
kernel.private threads continuations.private libc combinators ;
@ -387,7 +387,6 @@ TUPLE: callback-context ;
: generate-callback ( node -- )
dup alien-callback-xt dup rot [
init-templates
generate-profiler-prologue
%save-word-xt
%prologue-later
dup alien-stack-frame [

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

@ -38,7 +38,6 @@ $nl
{ $unchecked-example
"LIBRARY: foo\nFUNCTION: void the_answer ( char* question, int value ) ;"
"USE: compiler"
"\\ the_answer compile"
"\"the question\" 42 the_answer"
"The answer to the question is 42."
} }
@ -70,7 +69,7 @@ HELP: C-UNION:
HELP: C-ENUM:
{ $syntax "C-ENUM: words... ;" }
{ $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." }
{ $examples
"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.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays alien alien.c-types alien.structs kernel math
namespaces parser sequences words quotations math.parser
splitting effects prettyprint prettyprint.sections
USING: arrays alien alien.c-types alien.structs alien.arrays
kernel math namespaces parser sequences words quotations
math.parser splitting effects prettyprint prettyprint.sections
prettyprint.backend assocs combinators ;
IN: alien.syntax
@ -49,7 +49,7 @@ PRIVATE>
: C-ENUM:
";" parse-tokens
dup length
[ >r create-in r> 1quotation define-compound ] 2each ;
[ >r create-in r> 1quotation define ] 2each ;
parsing
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
kernel kernel.private prettyprint strings sbufs vectors
quotations sequences.private ;
USING: help.markup help.syntax
kernel kernel.private prettyprint sequences.private ;
IN: 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" } }
{ $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
{ $values { "seq" "a sequence" } { "array" array } }
{ $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
{ $values { "x" object } { "array" array } }
{ $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 ;
: search-alist ( key alist -- pair i )
[ first = ] curry* find swap ; inline
[ first = ] with find swap ; inline
M: sequence at*
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.
USING: math alien kernel kernel.private sequences
sequences.private ;
@ -20,7 +20,7 @@ IN: bit-arrays
: (set-bits) ( bit-array n -- )
over length bits>cells -rot [
swap rot 4 * set-alien-unsigned-4
spin 4 * set-alien-unsigned-4
] 2curry each ; inline
PRIVATE>
@ -49,3 +49,5 @@ M: bit-array equal?
over bit-array? [ sequence= ] [ 2drop f ] if ;
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
namespaces parser kernel kernel.private classes classes.private
arrays hashtables vectors tuples sbufs inference.dataflow
hashtables.private sequences.private math tuples.private
growable namespaces.private alien.remote-control assocs words
generator command-line vocabs io prettyprint libc ;
growable namespaces.private assocs words generator command-line
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
global [ { "compiler" } add-use ] bind
nl
"Compiling some words to speed up bootstrap..." write
"-no-stack-traces" cli-args member? [
f compiled-stack-traces? set-global
0 set-profiler-prologues
] when
! Compile a set of words ahead of our general
! 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.
! Compile a set of words ahead of the full compile.
! 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
@ -38,14 +42,38 @@ global [ { "compiler" } add-use ] bind
find-pair-next namestack*
bitand bitor bitxor bitnot
} compile
"." write flush
{
+ 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
} compile
"." write flush
{
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.
USING: alien arrays bit-arrays byte-arrays generic assocs
hashtables assocs hashtables.private io kernel kernel.private
@ -38,6 +38,9 @@ IN: bootstrap.image
: quot-array@ bootstrap-cell 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
SYMBOL: image
@ -58,42 +61,42 @@ SYMBOL: bootstrap-boot-quot
! JIT parameters
SYMBOL: jit-code-format
SYMBOL: jit-setup
SYMBOL: jit-prolog
SYMBOL: jit-word-primitive-jump
SYMBOL: jit-word-primitive-call
SYMBOL: jit-primitive-word
SYMBOL: jit-primitive
SYMBOL: jit-word-jump
SYMBOL: jit-word-call
SYMBOL: jit-push-wrapper
SYMBOL: jit-push-literal
SYMBOL: jit-if-word
SYMBOL: jit-if-jump
SYMBOL: jit-if-call
SYMBOL: jit-dispatch-word
SYMBOL: jit-dispatch
SYMBOL: jit-epilog
SYMBOL: jit-return
SYMBOL: jit-profiling
! Default definition for undefined words
SYMBOL: undefined-quot
: userenv-offset ( symbol -- n )
{
{ bootstrap-boot-quot 20 }
{ bootstrap-global 21 }
{ jit-code-format 22 }
{ jit-setup 23 }
{ jit-prolog 24 }
{ jit-word-primitive-jump 25 }
{ jit-word-primitive-call 26 }
{ jit-word-jump 27 }
{ jit-word-call 28 }
{ jit-push-wrapper 29 }
{ jit-push-literal 30 }
{ jit-if-word 31 }
{ jit-if-jump 32 }
{ jit-if-call 33 }
{ jit-dispatch-word 34 }
{ jit-dispatch 35 }
{ jit-epilog 36 }
{ jit-return 37 }
{ jit-prolog 23 }
{ jit-primitive-word 24 }
{ jit-primitive 25 }
{ jit-word-jump 26 }
{ jit-word-call 27 }
{ jit-push-literal 28 }
{ jit-if-word 29 }
{ jit-if-jump 30 }
{ jit-dispatch-word 31 }
{ jit-dispatch 32 }
{ jit-epilog 33 }
{ jit-return 34 }
{ jit-profiling 35 }
{ undefined-quot 37 }
} at header-size + ;
: emit ( cell -- ) image get push ;
@ -120,10 +123,10 @@ SYMBOL: jit-return
: align-here ( -- )
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 )
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
! Write an object to the image.
@ -173,7 +176,7 @@ M: fixnum '
#! When generating a 32-bit image on a 64-bit system,
#! some fixnums should be bignums.
dup most-negative-fixnum most-positive-fixnum between?
[ tag-bits get shift ] [ >bignum ' ] if ;
[ tag-fixnum ] [ >bignum ' ] if ;
! Floats
@ -213,6 +216,7 @@ M: f '
0 , ! count
0 , ! xt
0 , ! code
0 , ! profiling
] { } make
\ word type-number object tag-number
[ emit-seq ] emit-object
@ -367,31 +371,30 @@ M: curry '
: emit-jit-data ( -- )
\ if jit-if-word set
\ dispatch jit-dispatch-word set
\ do-primitive jit-primitive-word set
[ undefined ] undefined-quot set
{
jit-code-format
jit-setup
jit-prolog
jit-word-primitive-jump
jit-word-primitive-call
jit-primitive-word
jit-primitive
jit-word-jump
jit-word-call
jit-push-wrapper
jit-push-literal
jit-if-word
jit-if-jump
jit-if-call
jit-dispatch-word
jit-dispatch
jit-epilog
jit-return
jit-profiling
undefined-quot
} [ emit-userenv ] each ;
: fixup-header ( -- )
heap-size data-heap-size-offset fixup ;
: end-image ( -- )
"Building generic words..." print flush
all-words [ generic? ] subset [ make-generic ] each
"Serializing words..." print flush
emit-words
"Serializing JIT data..." print flush
@ -444,7 +447,6 @@ PRIVATE>
: make-image ( arch -- )
[
parse-hook off
prepare-image
begin-image
"resource:/core/bootstrap/stage1.factor" run-file
@ -457,5 +459,8 @@ PRIVATE>
: make-images ( -- )
{
"x86.32" "x86.64" "linux-ppc" "macosx-ppc" "arm"
"x86.32"
! "x86.64"
"linux-ppc" "macosx-ppc"
! "arm"
} [ 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.
IN: bootstrap.primitives
USING: alien arrays byte-arrays generic hashtables
hashtables.private io kernel math namespaces parser sequences
strings vectors words quotations assocs layouts classes tuples
kernel.private vocabs vocabs.loader source-files definitions
slots classes.union words.private ;
! Some very tricky code creating a bootstrap embryo in the
! host image.
slots classes.union compiler.units ;
"Creating primitives and basic runtime structures..." print flush
load-help? off
crossref off
changed-words off
! Bring up a bare cross-compiling vocabulary.
"syntax" vocab vocab-words bootstrap-syntax set
"resource:core/bootstrap/syntax.factor" parse-file
H{ } clone dictionary set
H{ } clone changed-words set
[ drop ] recompile-hook set
call
! Create some empty vocabs where the below primitives and
@ -31,6 +31,7 @@ call
"bit-arrays"
"byte-arrays"
"classes.private"
"compiler.units"
"continuations.private"
"float-arrays"
"generator"
@ -75,209 +76,7 @@ H{ } clone source-files set
H{ } clone class<map set
H{ } clone update-map set
: make-primitive ( word vocab n -- ) >r create r> 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" }
{ "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 classes
: builtin-predicate ( class predicate -- )
[
over "type" word-prop dup
@ -348,16 +147,16 @@ num-types get f <array> builtins set
{
{
{ "real" "math" }
"real"
"real-part"
1
{ "real" "math" }
{ "real-part" "math" }
f
}
{
{ "real" "math" }
"imaginary"
"imaginary-part"
2
{ "imaginary" "math" }
{ "imaginary-part" "math" }
f
}
} define-builtin
@ -513,7 +312,7 @@ define-builtin
{ "set-word-vocabulary" "words" }
}
{
{ "object" "kernel" }
{ "quotation" "quotations" }
"def"
4
{ "word-def" "words" }
@ -605,5 +404,205 @@ builtins get num-tags get tail f union-class define-class
"tombstone" "hashtables.private" lookup t
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
"build" "kernel" create build 1+ 1quotation define-compound
"build" "kernel" create build 1+ 1quotation define

13
core/bootstrap/stage1.factor
View File

@ -13,14 +13,15 @@ vocabs.loader system ;
"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
! using the host image's hashing algorithms
[
! Rehash hashtables, since bootstrap.image creates them
! using the host image's hashing algorithms
[ hashtable? ] instances [ rehash ] each
[ [ hashtable? ] instances [ rehash ] each ] %
\ boot ,
boot
] %
"math.integers" 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
io.backend system parser vocabs sequences prettyprint
vocabs.loader combinators splitting source-files strings
definitions assocs ;
definitions assocs compiler.errors compiler.units ;
IN: bootstrap.stage2
! 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
".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
parse-command-line
all-words [ dup ] H{ } map>assoc changed-words set-global
"-no-crossref" cli-args member? [
"Cross-referencing..." print flush
H{ } clone crossref set-global
@ -37,7 +35,6 @@ IN: bootstrap.stage2
] [
"listener" require
"none" require
"listener" use+
] if
[
@ -45,18 +42,13 @@ IN: bootstrap.stage2
[ get-global " " split [ empty? not ] subset ] 2apply
seq-diff
[ "bootstrap." swap append require ] each
] no-parse-hook
init-io
init-stdio
run-bootstrap-init
changed-words get clear-assoc
"Compiling remaining words..." print flush
"compile-errors" "generator" lookup [
f swap set-global
] when*
run-bootstrap-init
all-words [ compiled? not ] subset recompile-hook get call
] with-compiler-errors
f error set-global
f error-continuation set-global
@ -76,17 +68,17 @@ IN: bootstrap.stage2
] set-boot-quot
: count-words all-words swap subset length pprint ;
[ compiled? ] count-words " compiled words" print
[ symbol? ] count-words " symbol words" print
[ ] count-words " words total" print
"Bootstrapping is complete." print
"Now, you can run ./factor -i=" write
"output-image" get print flush
"Now, you can run Factor:" print
vm write " -i=" write "output-image" get print flush
"output-image" get resource-path save-image-and-exit
] if
] [
error-hook get call "listener" vocab-main execute
error. :c "listener" vocab-main execute
] recover

3
core/bootstrap/syntax.factor
View File

@ -45,7 +45,6 @@ f swap set-vocab-source-loaded?
"TUPLE:"
"T{"
"UNION:"
"USE-IF:"
"USE:"
"USING:"
"V{"
@ -63,6 +62,8 @@ f swap set-vocab-source-loaded?
"{"
"}"
"CS{"
"<<"
">>"
} [ "syntax" create drop ] each
"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
kernel help.markup help.syntax ;
USING: help.markup help.syntax ;
IN: 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.
USING: kernel kernel.private alien sequences sequences.private
math ;
IN: byte-arrays
USING: kernel kernel.private alien sequences
sequences.private math ;
M: byte-array clone (clone) ;
M: byte-array length array-capacity ;
@ -16,3 +16,5 @@ M: byte-array equal?
over byte-array? [ sequence= ] [ 2drop f ] if ;
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
{ $values { "class" class } { "predicate" "a predicate word" } { "quot" "a quotation" } }
{ $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
{ "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" }

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
tools.test vectors words quotations classes io.streams.string
classes.private classes.union classes.mixin classes.predicate
vectors ;
vectors definitions source-files ;
IN: temporary
H{ } "s" set
@ -36,8 +36,8 @@ UNION: both first-one union-class ;
[ f ] [ \ integer \ null class< ] unit-test
[ t ] [ \ null \ object class< ] unit-test
[ t ] [ \ generic \ compound class< ] unit-test
[ f ] [ \ compound \ generic class< ] unit-test
[ t ] [ \ generic \ word class< ] unit-test
[ f ] [ \ word \ generic class< ] unit-test
[ f ] [ \ reversed \ slice class< ] unit-test
[ f ] [ \ slice \ reversed class< ] unit-test
@ -62,7 +62,7 @@ UNION: bah fixnum alien ;
[ bah ] [ \ bah? "predicating" word-prop ] unit-test
! 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
! 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
"IN: temporary UNION: union-1 rational array ;" eval
do-parse-hook
"IN: temporary USE: math USE: arrays UNION: union-1 rational array ;" eval
[ t ] [ bignum union-1 class< ] unit-test
[ f ] [ union-1 number class< ] unit-test
@ -88,9 +86,7 @@ do-parse-hook
[ object ] [ fixnum float class-or ] unit-test
"IN: temporary PREDICATE: integer union-1 even? ;" eval
do-parse-hook
"IN: temporary USE: math PREDICATE: integer union-1 even? ;" eval
[ f ] [ union-1 union-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 number class< ] unit-test
"INSTANCE: array mx1" eval
"IN: temporary USE: arrays INSTANCE: array mx1" eval
[ t ] [ array mx1 class< ] unit-test
[ f ] [ mx1 number class< ] unit-test
[ mx1 ] [ array integer class-or ] unit-test
\ mx1 forget
[ \ mx1 forget ] with-compilation-unit
[ 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
[ 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
[ f ] [ fixnum redefine-bug-2 class< ] unit-test
@ -177,3 +173,37 @@ FORGET: forget-class-bug-1
FORGET: forget-class-bug-2
[ 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: compound predicate
"predicating" word-prop >boolean ;
PREDICATE: word predicate "predicating" word-prop >boolean ;
: define-predicate ( class predicate quot -- )
over [
@ -98,7 +97,7 @@ DEFER: (class<)
: union-class< ( cls1 cls2 -- ? )
[ flatten-union-class ] 2apply keys
[ nip [ (class<) ] curry* contains? ] curry assoc-all? ;
[ nip [ (class<) ] with contains? ] curry assoc-all? ;
: (class<) ( class1 class2 -- ? )
{
@ -124,7 +123,7 @@ DEFER: (class<)
: largest-class ( seq -- n elt )
dup [
[ 2dup class< >r swap class< not r> and ]
curry* subset empty?
with subset empty?
] curry find [ "Topological sort failed" throw ] unless* ;
PRIVATE>
@ -157,7 +156,7 @@ PRIVATE>
[ dupd classes-intersect? ] subset dup empty? [
2drop f
] [
tuck [ class< ] curry* all? [ peek ] [ drop f ] if
tuck [ class< ] with all? [ peek ] [ drop f ] if
] if ;
GENERIC: reset-class ( class -- )
@ -168,7 +167,7 @@ M: word reset-class drop ;
! class<map
: bigger-classes ( class -- seq )
classes [ (class<) ] curry* subset ;
classes [ (class<) ] with subset ;
: bigger-classes+ ( class -- )
[ bigger-classes [ dup ] H{ } map>assoc ] keep
@ -240,8 +239,6 @@ M: word uncache-class drop ;
: uncache-classes ( assoc -- )
[ drop uncache-class ] assoc-each ;
GENERIC: update-methods ( class -- )
PRIVATE>
: define-class-props ( members superclass metaclass -- assoc )
@ -253,10 +250,13 @@ PRIVATE>
: (define-class) ( word props -- )
over reset-class
over reset-generic
over define-symbol
>r dup word-props r> union over set-word-props
dup intern-symbol
t "class" set-word-prop ;
GENERIC: update-methods ( class -- )
: define-class ( word members superclass metaclass -- )
#! If it was already a class, update methods after.
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
ARTICLE: "mixins" "Mixin classes"
@ -11,4 +12,21 @@ ARTICLE: "mixins" "Mixin classes"
{ $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"

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.
USING: classes classes.union words kernel sequences ;
USING: classes classes.union words kernel sequences
definitions combinators arrays ;
IN: classes.mixin
PREDICATE: union-class mixin-class "mixin" word-prop ;
@ -19,11 +20,55 @@ M: mixin-class reset-class
{ } redefine-mixin-class
] 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 -- )
dup mixin-class? [ "Not a mixin class" throw ] unless
2dup members memq? [
2drop
] [
[ members swap bootstrap-word add ] keep swap
redefine-mixin-class
] if ;
[ 2drop ] [ [ add ] change-mixin-class ] if-mixin-member? ;
: remove-mixin-instance ( class mixin -- )
[ [ swap remove ] change-mixin-class ] [ 2drop ] if-mixin-member? ;
! Definition protocol implementation ensures that removing an
! 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
namespaces sequences words arrays layouts help effects math
layouts classes.private classes ;
layouts classes.private classes compiler.units ;
IN: classes.predicate
ARTICLE: "predicates" "Predicate classes"
@ -15,7 +15,9 @@ ABOUT: "predicates"
HELP: define-predicate-class
{ $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

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
namespaces sequences words arrays layouts help effects math
layouts classes.private classes ;
layouts classes.private classes compiler.units ;
IN: classes.union
ARTICLE: "unions" "Union classes"
@ -17,7 +17,9 @@ ABOUT: "unions"
HELP: define-union-class
{ $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

4
core/combinators/combinators.factor
View File

@ -63,13 +63,13 @@ M: sequence hashcode*
next-power-of-2 swap [ nip clone ] curry map ;
: 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
nip ; inline
: hash-case-table ( default assoc -- array )
V{ } [ 1array ] distribute-buckets
[ case>quot ] curry* map ;
[ case>quot ] with map ;
: hash-dispatch-quot ( table -- quot )
[ 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
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 }
"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 }
"Normally loading a source file or a module also calls " { $link recompile } ". This can be disabled by wrapping file loading in a combinator:"
{ $subsection no-parse-hook } ;
{ $subsection recompile-all }
"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"
"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 "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:"
{ $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." }
}
"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" } "."
{ $subsection "compiler-usage" }
{ $subsection "recompile" } ;
{ $subsection "compiler-errors" } ;
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
{ $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" } }
{ $description "If any of the words in the sequence previously failed to compile, removes the marker indicating such."
$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." } ;
{ $description "Compiles a set of words. Ignores words which are already compiled." } ;
HELP: compile-batch
HELP: recompile
{ $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-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
HELP: compile-call
{ $values { "quot" "a quotation" } }
{ $description "Compiles and runs a quotation." }
{ $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
{ $description "Recompiles all words." } ;
HELP: changed-words
{ $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
HELP: decompile
{ $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)
{ $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." } ;

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.
USING: kernel namespaces arrays sequences io inference.backend
generator debugger math.parser prettyprint words continuations
vocabs assocs alien.compiler ;
inference.state generator debugger math.parser prettyprint words
compiler.units continuations vocabs assocs alien.compiler dlists
optimizer definitions math compiler.errors threads graphs
generic ;
IN: compiler
M: object inference-error-major? drop t ;
SYMBOL: compiled-crossref
: compile-error ( word error -- )
batch-mode get [
2array compile-errors get push
] [
"quiet" get [ drop ] [ print-error flush ] if drop
] if ;
compiled-crossref global [ H{ } assoc-like ] change-at
: begin-batch ( seq -- )
batch-mode on
"quiet" get [ drop ] [
[ "Compiling " % length # " words..." % ] "" make
print flush
] if
V{ } clone compile-errors set-global ;
: compiled-xref ( word dependencies -- )
2dup "compiled-uses" set-word-prop
compiled-crossref get add-vertex ;
: compile-error. ( pair -- )
nl
"While compiling " write dup first pprint ": " print
nl
second print-error ;
: compiled-unxref ( word -- )
dup "compiled-uses" word-prop
compiled-crossref get remove-vertex ;
: (:errors) ( -- seq )
compile-errors get-global
[ second inference-error-major? ] subset ;
: compiled-usage ( word -- seq )
compiled-crossref get at keys ;
: :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 )
compile-errors get-global
[ second inference-error-major? not ] subset ;
: compiled-usages ( words -- seq )
compiled-crossref get [
[
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 ( -- )
batch-mode off
"quiet" get [
"Compile finished." print
nl
":errors - print " write (:errors) length pprint
" compiler errors." print
":warnings - print " write (:warnings) length pprint
" compiler warnings." print
nl
] unless ;
: save-effect ( word effect -- )
over "compiled-uses" word-prop [
2dup swap "compiled-effect" word-prop =
[ over ripple-up ] unless
] when
"compiled-effect" set-word-prop ;
: compile ( word -- )
H{ } clone [
compiled-xts [ (compile) ] with-variable
] keep >alist finalize-compile ;
: finish-compile ( word effect dependencies -- )
>r dupd save-effect r>
f pick compiler-error
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 -- )
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 ] [ compile-failed ] recover ;
: (compile) ( word -- )
[ dup compile-succeeded finish-compile ]
[ dupd compile-failed f save-effect ]
recover ;
: forget-errors ( seq -- )
[ f "no-effect" set-word-prop ] each ;
: delete-any ( assoc -- element )
[ [ 2drop t ] assoc-find 2drop dup ] keep delete-at ;
: compile-batch ( seq -- )
dup empty? [
drop
] [
dup begin-batch
dup forget-errors
[ try-compile ] each
end-batch
: compile-loop ( assoc -- )
dup assoc-empty? [ drop ] [
dup delete-any (compile)
yield
compile-loop
] 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-1 ( quot -- ) compile-quot execute ;
: recompile ( -- )
changed-words get [
dup keys compile-batch clear-assoc
] when* ;
: compile-call ( quot -- )
H{ } clone changed-words
[ define-temp dup 1array compile ] with-variable
execute ;
: 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
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 ] [ "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 ;
IN: temporary
[ 3 ] [ 5 [ [ 2 - ] curry call ] compile-1 ] unit-test
[ 3 ] [ [ 5 [ 2 - ] curry call ] compile-1 ] unit-test
[ 3 ] [ [ 5 2 [ - ] 2curry call ] compile-1 ] unit-test
[ 3 ] [ 5 [ 2 [ - ] 2curry call ] compile-1 ] unit-test
[ 3 ] [ 5 2 [ [ - ] 2curry call ] compile-1 ] unit-test
[ 3 ] [ 5 2 [ [ - ] 2curry 9 swap call /i ] compile-1 ] unit-test
[ 3 ] [ 5 2 [ [ - ] 2curry >r 9 r> call /i ] compile-1 ] unit-test
[ 3 ] [ 5 [ [ 2 - ] curry call ] compile-call ] unit-test
[ 3 ] [ [ 5 [ 2 - ] curry call ] compile-call ] unit-test
[ 3 ] [ [ 5 2 [ - ] 2curry call ] compile-call ] unit-test
[ 3 ] [ 5 [ 2 [ - ] 2curry call ] compile-call ] unit-test
[ 3 ] [ 5 2 [ [ - ] 2curry call ] compile-call ] unit-test
[ 3 ] [ 5 2 [ [ - ] 2curry 9 swap call /i ] compile-call ] 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-1 >quotation ] unit-test
[ [ 5 2 - ] ] [ [ 5 2 [ - ] 2curry ] compile-1 >quotation ] unit-test
[ [ 5 2 - ] ] [ 5 [ 2 [ - ] 2curry ] compile-1 >quotation ] unit-test
[ [ 5 2 - ] ] [ 5 2 [ [ - ] 2curry ] compile-1 >quotation ] unit-test
[ [ 5 2 - ] ] [ 5 [ [ 2 - ] curry ] compile-call >quotation ] unit-test
[ [ 5 2 - ] ] [ [ 5 [ 2 - ] curry ] compile-call >quotation ] unit-test
[ [ 5 2 - ] ] [ [ 5 2 [ - ] 2curry ] compile-call >quotation ] unit-test
[ [ 5 2 - ] ] [ 5 [ 2 [ - ] 2curry ] compile-call >quotation ] unit-test
[ [ 5 2 - ] ] [ 5 2 [ [ - ] 2curry ] compile-call >quotation ] unit-test
[ [ 6 2 + ] ]
[
2 5
[ >r [ + ] curry r> 0 < [ -2 ] [ 6 ] if swap curry ]
compile-1 >quotation
compile-call >quotation
] unit-test
[ 8 ]
[
2 5
[ >r [ + ] curry r> 0 < [ -2 ] [ 6 ] if swap curry call ]
compile-1
compile-call
] unit-test
: foobar ( quot -- )
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-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-call ] unit-test
: funky-assoc>map
[
@ -46,16 +46,16 @@ IN: temporary
] { } make ; inline
[ t ] [
global [ [ drop , ] funky-assoc>map ] compile-1
global [ [ drop , ] funky-assoc>map ] compile-call
global keys =
] 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
math.private tools.test math.floats.private ;
[ 5.0 ] [ [ 5.0 ] compile-1 data-gc data-gc data-gc ] unit-test
[ 2.0 3.0 ] [ 3.0 [ 2.0 swap ] compile-1 ] 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-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 swap float+ ] compile-1 ] unit-test
[ 3.0 ] [ 1.0 2.0 [ float+ ] compile-1 ] unit-test
[ 3.0 ] [ 1.0 2.0 [ swap 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-call ] unit-test
[ 3.0 ] [ 1.0 2.0 [ float+ ] compile-call ] 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 swap float- ] compile-1 ] unit-test
[ -1.0 ] [ 1.0 2.0 [ float- ] compile-1 ] unit-test
[ 1.0 ] [ 1.0 2.0 [ swap 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-call ] unit-test
[ -1.0 ] [ 1.0 2.0 [ float- ] compile-call ] 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 swap float* ] compile-1 ] unit-test
[ 6.0 ] [ 3.0 2.0 [ float* ] compile-1 ] unit-test
[ 6.0 ] [ 3.0 2.0 [ swap 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-call ] unit-test
[ 6.0 ] [ 3.0 2.0 [ float* ] compile-call ] 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
[ 2.0 ] [ 1.0 [ 2.0 swap float/f ] compile-1 ] unit-test
[ 0.5 ] [ 1.0 2.0 [ float/f ] compile-1 ] unit-test
[ 2.0 ] [ 1.0 2.0 [ swap 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-call ] unit-test
[ 0.5 ] [ 1.0 2.0 [ float/f ] compile-call ] 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-1 ] unit-test
[ f ] [ 1.0 [ 2.0 swap float< ] compile-1 ] unit-test
[ f ] [ 1.0 1.0 [ float< ] compile-1 ] unit-test
[ f ] [ 1.0 [ 1.0 float< ] compile-1 ] unit-test
[ f ] [ 1.0 [ 1.0 swap float< ] compile-1 ] unit-test
[ f ] [ 3.0 1.0 [ float< ] compile-1 ] unit-test
[ f ] [ 3.0 [ 1.0 float< ] compile-1 ] unit-test
[ t ] [ 3.0 [ 1.0 swap float< ] compile-1 ] unit-test
[ t ] [ 1.0 2.0 [ float< ] compile-call ] unit-test
[ t ] [ 1.0 [ 2.0 float< ] compile-call ] unit-test
[ f ] [ 1.0 [ 2.0 swap float< ] compile-call ] unit-test
[ f ] [ 1.0 1.0 [ float< ] compile-call ] unit-test
[ f ] [ 1.0 [ 1.0 float< ] compile-call ] unit-test
[ f ] [ 1.0 [ 1.0 swap float< ] compile-call ] unit-test
[ f ] [ 3.0 1.0 [ float< ] compile-call ] unit-test
[ f ] [ 3.0 [ 1.0 float< ] compile-call ] 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-1 ] unit-test
[ f ] [ 1.0 [ 2.0 swap float<= ] compile-1 ] unit-test
[ t ] [ 1.0 1.0 [ float<= ] compile-1 ] unit-test
[ t ] [ 1.0 [ 1.0 float<= ] compile-1 ] unit-test
[ t ] [ 1.0 [ 1.0 swap float<= ] compile-1 ] unit-test
[ f ] [ 3.0 1.0 [ float<= ] compile-1 ] unit-test
[ f ] [ 3.0 [ 1.0 float<= ] compile-1 ] unit-test
[ t ] [ 3.0 [ 1.0 swap float<= ] compile-1 ] unit-test
[ t ] [ 1.0 2.0 [ float<= ] compile-call ] unit-test
[ t ] [ 1.0 [ 2.0 float<= ] compile-call ] unit-test
[ f ] [ 1.0 [ 2.0 swap float<= ] compile-call ] unit-test
[ t ] [ 1.0 1.0 [ float<= ] compile-call ] unit-test
[ t ] [ 1.0 [ 1.0 float<= ] compile-call ] unit-test
[ t ] [ 1.0 [ 1.0 swap float<= ] compile-call ] unit-test
[ f ] [ 3.0 1.0 [ float<= ] compile-call ] unit-test
[ f ] [ 3.0 [ 1.0 float<= ] compile-call ] 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-1 ] unit-test
[ t ] [ 1.0 [ 2.0 swap float> ] compile-1 ] unit-test
[ f ] [ 1.0 1.0 [ float> ] compile-1 ] unit-test
[ f ] [ 1.0 [ 1.0 float> ] compile-1 ] unit-test
[ f ] [ 1.0 [ 1.0 swap float> ] compile-1 ] unit-test
[ t ] [ 3.0 1.0 [ float> ] compile-1 ] unit-test
[ t ] [ 3.0 [ 1.0 float> ] compile-1 ] unit-test
[ f ] [ 3.0 [ 1.0 swap float> ] compile-1 ] unit-test
[ f ] [ 1.0 2.0 [ float> ] compile-call ] unit-test
[ f ] [ 1.0 [ 2.0 float> ] compile-call ] unit-test
[ t ] [ 1.0 [ 2.0 swap float> ] compile-call ] unit-test
[ f ] [ 1.0 1.0 [ float> ] compile-call ] unit-test
[ f ] [ 1.0 [ 1.0 float> ] compile-call ] unit-test
[ f ] [ 1.0 [ 1.0 swap float> ] compile-call ] unit-test
[ t ] [ 3.0 1.0 [ float> ] compile-call ] unit-test
[ t ] [ 3.0 [ 1.0 float> ] compile-call ] 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-1 ] unit-test
[ t ] [ 1.0 [ 2.0 swap float>= ] compile-1 ] unit-test
[ t ] [ 1.0 1.0 [ float>= ] compile-1 ] unit-test
[ t ] [ 1.0 [ 1.0 float>= ] compile-1 ] unit-test
[ t ] [ 1.0 [ 1.0 swap float>= ] compile-1 ] unit-test
[ t ] [ 3.0 1.0 [ float>= ] compile-1 ] unit-test
[ t ] [ 3.0 [ 1.0 float>= ] compile-1 ] unit-test
[ f ] [ 3.0 [ 1.0 swap float>= ] compile-1 ] unit-test
[ f ] [ 1.0 2.0 [ float>= ] compile-call ] unit-test
[ f ] [ 1.0 [ 2.0 float>= ] compile-call ] unit-test
[ t ] [ 1.0 [ 2.0 swap float>= ] compile-call ] unit-test
[ t ] [ 1.0 1.0 [ float>= ] compile-call ] unit-test
[ t ] [ 1.0 [ 1.0 float>= ] compile-call ] unit-test
[ t ] [ 1.0 [ 1.0 swap float>= ] compile-call ] unit-test
[ t ] [ 3.0 1.0 [ float>= ] compile-call ] unit-test
[ t ] [ 3.0 [ 1.0 float>= ] compile-call ] unit-test
[ f ] [ 3.0 [ 1.0 swap float>= ] compile-call ] unit-test
[ f ] [ 1.0 2.0 [ float= ] compile-1 ] unit-test
[ t ] [ 1.0 1.0 [ float= ] compile-1 ] unit-test
[ f ] [ 1.0 [ 2.0 float= ] compile-1 ] unit-test
[ t ] [ 1.0 [ 1.0 float= ] compile-1 ] unit-test
[ f ] [ 1.0 [ 2.0 swap float= ] compile-1 ] unit-test
[ t ] [ 1.0 [ 1.0 swap float= ] compile-1 ] unit-test
[ f ] [ 1.0 2.0 [ float= ] compile-call ] unit-test
[ t ] [ 1.0 1.0 [ float= ] compile-call ] unit-test
[ f ] [ 1.0 [ 2.0 float= ] compile-call ] unit-test
[ t ] [ 1.0 [ 1.0 float= ] compile-call ] unit-test
[ f ] [ 1.0 [ 2.0 swap float= ] compile-call ] 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-1 ] unit-test
[ f ] [ 3.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-call ] 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 1 = ] [ drop "odd" ] }
} cond
] compile-1
] compile-call
] unit-test
[ "odd" ] [
@ -107,7 +107,7 @@ DEFER: countdown-b
{ [ dup 2 mod 0 = ] [ drop "even" ] }
{ [ dup 2 mod 1 = ] [ drop "odd" ] }
} cond
] compile-1
] compile-call
] unit-test
[ "neither" ] [
@ -118,7 +118,7 @@ DEFER: countdown-b
{ [ dup alien? ] [ drop "alien" ] }
{ [ t ] [ drop "neither" ] }
} cond
] compile-1
] compile-call
] unit-test
[ 3 ] [
@ -127,5 +127,5 @@ DEFER: countdown-b
{ [ dup fixnum? ] [ ] }
{ [ t ] [ drop t ] }
} cond
] compile-1
] compile-call
] 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 ;
! Make sure that intrinsic ops compile to correct code.
[ ] [ 1 [ drop ] compile-1 ] unit-test
[ ] [ 1 2 [ 2drop ] compile-1 ] unit-test
[ ] [ 1 2 3 [ 3drop ] compile-1 ] unit-test
[ 1 1 ] [ 1 [ dup ] compile-1 ] unit-test
[ 1 2 1 2 ] [ 1 2 [ 2dup ] compile-1 ] unit-test
[ 1 2 3 1 2 3 ] [ 1 2 3 [ 3dup ] compile-1 ] unit-test
[ 2 3 1 ] [ 1 2 3 [ rot ] compile-1 ] unit-test
[ 3 1 2 ] [ 1 2 3 [ -rot ] compile-1 ] unit-test
[ 1 1 2 ] [ 1 2 [ dupd ] compile-1 ] unit-test
[ 2 1 3 ] [ 1 2 3 [ swapd ] compile-1 ] unit-test
[ 2 ] [ 1 2 [ nip ] compile-1 ] unit-test
[ 3 ] [ 1 2 3 [ 2nip ] compile-1 ] unit-test
[ 2 1 2 ] [ 1 2 [ tuck ] compile-1 ] unit-test
[ 1 2 1 ] [ 1 2 [ over ] compile-1 ] unit-test
[ 1 2 3 1 ] [ 1 2 3 [ pick ] compile-1 ] unit-test
[ 2 1 ] [ 1 2 [ swap ] compile-1 ] unit-test
[ ] [ 1 [ drop ] compile-call ] unit-test
[ ] [ 1 2 [ 2drop ] compile-call ] unit-test
[ ] [ 1 2 3 [ 3drop ] compile-call ] unit-test
[ 1 1 ] [ 1 [ dup ] compile-call ] unit-test
[ 1 2 1 2 ] [ 1 2 [ 2dup ] compile-call ] unit-test
[ 1 2 3 1 2 3 ] [ 1 2 3 [ 3dup ] compile-call ] unit-test
[ 2 3 1 ] [ 1 2 3 [ rot ] compile-call ] unit-test
[ 3 1 2 ] [ 1 2 3 [ -rot ] compile-call ] unit-test
[ 1 1 2 ] [ 1 2 [ dupd ] compile-call ] unit-test
[ 2 1 3 ] [ 1 2 3 [ swapd ] compile-call ] unit-test
[ 2 ] [ 1 2 [ nip ] compile-call ] unit-test
[ 3 ] [ 1 2 3 [ 2nip ] compile-call ] unit-test
[ 2 1 2 ] [ 1 2 [ tuck ] compile-call ] unit-test
[ 1 2 1 ] [ 1 2 [ over ] compile-call ] unit-test
[ 1 2 3 1 ] [ 1 2 3 [ pick ] compile-call ] 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-1 ] 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-1 first ] unit-test
[ 3 ] [ [ 3 1 2 2array [ 2 set-slot ] keep ] compile-1 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-1 second ] unit-test
[ 3 ] [ [ 3 1 2 2array [ 3 set-slot ] keep ] compile-1 second ] unit-test
[ 1 ] [ { 1 2 } [ 2 slot ] compile-call ] unit-test
[ 1 ] [ [ { 1 2 } 2 slot ] compile-call ] 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-call 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-call 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-call second ] unit-test
! 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-1 ] 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-call ] 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-1 ] 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-call ] 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
[ ] [ 1 getenv [ 1 setenv ] compile-1 ] unit-test
[ ] [ [ 0 getenv ] compile-call drop ] unit-test
[ ] [ 1 getenv [ 1 setenv ] compile-call ] unit-test
[ ] [ 1 [ drop ] compile-1 ] unit-test
[ ] [ [ 1 drop ] compile-1 ] unit-test
[ ] [ [ 1 2 2drop ] compile-1 ] unit-test
[ ] [ 1 [ 2 2drop ] compile-1 ] unit-test
[ ] [ 1 2 [ 2drop ] compile-1 ] unit-test
[ 2 1 ] [ [ 1 2 swap ] compile-1 ] unit-test
[ 2 1 ] [ 1 [ 2 swap ] compile-1 ] unit-test
[ 2 1 ] [ 1 2 [ swap ] compile-1 ] unit-test
[ 1 1 ] [ 1 [ dup ] compile-1 ] unit-test
[ 1 1 ] [ [ 1 dup ] compile-1 ] unit-test
[ 1 2 1 ] [ [ 1 2 over ] compile-1 ] unit-test
[ 1 2 1 ] [ 1 [ 2 over ] compile-1 ] unit-test
[ 1 2 1 ] [ 1 2 [ over ] compile-1 ] unit-test
[ 1 2 3 1 ] [ [ 1 2 3 pick ] compile-1 ] unit-test
[ 1 2 3 1 ] [ 1 [ 2 3 pick ] compile-1 ] unit-test
[ 1 2 3 1 ] [ 1 2 [ 3 pick ] compile-1 ] unit-test
[ 1 2 3 1 ] [ 1 2 3 [ pick ] compile-1 ] unit-test
[ 1 1 2 ] [ [ 1 2 dupd ] compile-1 ] unit-test
[ 1 1 2 ] [ 1 [ 2 dupd ] compile-1 ] unit-test
[ 1 1 2 ] [ 1 2 [ dupd ] compile-1 ] unit-test
[ 2 ] [ [ 1 2 nip ] compile-1 ] unit-test
[ 2 ] [ 1 [ 2 nip ] compile-1 ] unit-test
[ 2 ] [ 1 2 [ nip ] compile-1 ] unit-test
[ ] [ 1 [ drop ] compile-call ] unit-test
[ ] [ [ 1 drop ] compile-call ] unit-test
[ ] [ [ 1 2 2drop ] compile-call ] unit-test
[ ] [ 1 [ 2 2drop ] compile-call ] unit-test
[ ] [ 1 2 [ 2drop ] compile-call ] unit-test
[ 2 1 ] [ [ 1 2 swap ] compile-call ] unit-test
[ 2 1 ] [ 1 [ 2 swap ] compile-call ] unit-test
[ 2 1 ] [ 1 2 [ swap ] compile-call ] unit-test
[ 1 1 ] [ 1 [ dup ] compile-call ] unit-test
[ 1 1 ] [ [ 1 dup ] compile-call ] unit-test
[ 1 2 1 ] [ [ 1 2 over ] compile-call ] unit-test
[ 1 2 1 ] [ 1 [ 2 over ] compile-call ] unit-test
[ 1 2 1 ] [ 1 2 [ over ] compile-call ] unit-test
[ 1 2 3 1 ] [ [ 1 2 3 pick ] compile-call ] unit-test
[ 1 2 3 1 ] [ 1 [ 2 3 pick ] compile-call ] unit-test
[ 1 2 3 1 ] [ 1 2 [ 3 pick ] compile-call ] unit-test
[ 1 2 3 1 ] [ 1 2 3 [ pick ] compile-call ] unit-test
[ 1 1 2 ] [ [ 1 2 dupd ] compile-call ] unit-test
[ 1 1 2 ] [ 1 [ 2 dupd ] compile-call ] unit-test
[ 1 1 2 ] [ 1 2 [ dupd ] compile-call ] unit-test
[ 2 ] [ [ 1 2 nip ] compile-call ] unit-test
[ 2 ] [ 1 [ 2 nip ] compile-call ] 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-1 ] 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-call ] 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-1 ] 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-call ] 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-1 ] 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-call ] 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-1 ] unit-test
[ f ] [ [ 12 7 fixnum< [ t ] [ f ] if ] compile-1 ] unit-test
[ f ] [ [ 12 12 fixnum< [ t ] [ f ] if ] compile-1 ] unit-test
[ f ] [ 12 12 [ 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-call ] unit-test
[ f ] [ [ 12 7 fixnum< [ t ] [ f ] if ] compile-call ] unit-test
[ f ] [ [ 12 12 fixnum< [ t ] [ f ] if ] compile-call ] 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-1 ] 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-call ] 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-1 ] unit-test
[ f ] [ [ 12 7 fixnum<= [ t ] [ f ] if ] compile-1 ] unit-test
[ t ] [ [ 12 12 fixnum<= [ t ] [ f ] if ] compile-1 ] unit-test
[ t ] [ [ 12 12 fixnum<= [ t ] [ f ] if ] compile-1 ] unit-test
[ t ] [ 12 12 [ 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-call ] unit-test
[ f ] [ [ 12 7 fixnum<= [ t ] [ f ] if ] compile-call ] unit-test
[ t ] [ [ 12 12 fixnum<= [ t ] [ f ] if ] compile-call ] unit-test
[ t ] [ [ 12 12 fixnum<= [ t ] [ f ] if ] compile-call ] 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-1 ] 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-call ] 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-1 ] unit-test
[ t ] [ [ 12 7 fixnum> [ t ] [ f ] if ] compile-1 ] unit-test
[ f ] [ [ 12 12 fixnum> [ t ] [ f ] if ] compile-1 ] unit-test
[ f ] [ [ 12 12 fixnum> [ t ] [ f ] if ] compile-1 ] unit-test
[ f ] [ 12 12 [ 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-call ] unit-test
[ t ] [ [ 12 7 fixnum> [ t ] [ f ] if ] compile-call ] unit-test
[ f ] [ [ 12 12 fixnum> [ t ] [ f ] if ] compile-call ] unit-test
[ f ] [ [ 12 12 fixnum> [ t ] [ f ] if ] compile-call ] 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-1 ] 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-call ] 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-1 ] unit-test
[ t ] [ [ 12 7 fixnum>= [ t ] [ f ] if ] compile-1 ] unit-test
[ t ] [ [ 12 12 fixnum>= [ t ] [ f ] if ] compile-1 ] unit-test
[ t ] [ 12 12 [ 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-call ] unit-test
[ t ] [ [ 12 7 fixnum>= [ t ] [ f ] if ] compile-call ] unit-test
[ t ] [ [ 12 12 fixnum>= [ t ] [ f ] if ] compile-call ] 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-1 ] 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-call ] 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-1 ] unit-test
[ f ] [ [ 1 2 eq? [ t ] [ f ] if ] compile-1 ] unit-test
[ t ] [ 3 3 [ eq? [ t ] [ f ] if ] compile-1 ] unit-test
[ t ] [ 3 [ 3 eq? [ t ] [ f ] if ] compile-1 ] unit-test
[ t ] [ [ 3 3 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-call ] unit-test
[ f ] [ [ 1 2 eq? [ t ] [ f ] if ] compile-call ] unit-test
[ t ] [ 3 3 [ eq? [ t ] [ f ] if ] compile-call ] unit-test
[ t ] [ 3 [ 3 eq? [ t ] [ f ] if ] compile-call ] 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-1 ] unit-test
[ -1 ] [ 0 [ fixnum-bitnot ] compile-call ] 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-1 ] unit-test
[ 3 ] [ [ 13 10 fixnum-mod ] compile-1 ] unit-test
[ -3 ] [ -13 10 [ fixnum-mod ] compile-1 ] unit-test
[ -3 ] [ -13 [ 10 fixnum-mod ] compile-1 ] 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-call ] unit-test
[ 3 ] [ [ 13 10 fixnum-mod ] compile-call ] unit-test
[ -3 ] [ -13 10 [ fixnum-mod ] compile-call ] unit-test
[ -3 ] [ -13 [ 10 fixnum-mod ] compile-call ] 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-1 ] unit-test
[ -2 ] [ 4 [ -2 fixnum/i ] compile-1 ] unit-test
[ 3 1 ] [ 10 3 [ fixnum/mod ] compile-1 ] unit-test
[ 2 ] [ 4 2 [ fixnum/i ] compile-call ] unit-test
[ 2 ] [ 4 [ 2 fixnum/i ] compile-call ] unit-test
[ -2 ] [ 4 [ -2 fixnum/i ] compile-call ] 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-1 ] unit-test
[ 4 ] [ [ 1 3 fixnum+ ] compile-1 ] unit-test
[ 4 ] [ 1 3 [ fixnum+ ] compile-call ] unit-test
[ 4 ] [ 1 [ 3 fixnum+ ] compile-call ] 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-1 ] 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-call ] 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-1 ] unit-test
[ 6 ] [ [ 2 3 fixnum*fast ] compile-1 ] unit-test
[ -6 ] [ 2 -3 [ fixnum*fast ] compile-1 ] unit-test
[ -6 ] [ 2 [ -3 fixnum*fast ] compile-1 ] 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-call ] unit-test
[ 6 ] [ [ 2 3 fixnum*fast ] compile-call ] unit-test
[ -6 ] [ 2 -3 [ fixnum*fast ] compile-call ] unit-test
[ -6 ] [ 2 [ -3 fixnum*fast ] compile-call ] unit-test
[ -6 ] [ [ 2 -3 fixnum*fast ] compile-call ] unit-test
[ 6 ] [ 2 3 [ fixnum* ] compile-1 ] unit-test
[ 6 ] [ 2 [ 3 fixnum* ] compile-1 ] unit-test
[ 6 ] [ [ 2 3 fixnum* ] compile-1 ] unit-test
[ -6 ] [ 2 -3 [ fixnum* ] compile-1 ] unit-test
[ -6 ] [ 2 [ -3 fixnum* ] compile-1 ] unit-test
[ -6 ] [ [ 2 -3 fixnum* ] compile-1 ] unit-test
[ 6 ] [ 2 3 [ fixnum* ] compile-call ] unit-test
[ 6 ] [ 2 [ 3 fixnum* ] compile-call ] unit-test
[ 6 ] [ [ 2 3 fixnum* ] compile-call ] unit-test
[ -6 ] [ 2 -3 [ fixnum* ] compile-call ] unit-test
[ -6 ] [ 2 [ -3 fixnum* ] compile-call ] unit-test
[ -6 ] [ [ 2 -3 fixnum* ] compile-call ] unit-test
[ t ] [ 3 type 3 [ type ] compile-1 eq? ] unit-test
[ t ] [ 3 >bignum type 3 >bignum [ type ] compile-1 eq? ] unit-test
[ t ] [ "hey" type "hey" [ type ] compile-1 eq? ] unit-test
[ t ] [ f type f [ type ] compile-1 eq? ] unit-test
[ t ] [ 3 type 3 [ type ] compile-call eq? ] unit-test
[ t ] [ 3 >bignum type 3 >bignum [ type ] compile-call eq? ] unit-test
[ t ] [ "hey" type "hey" [ type ] compile-call eq? ] unit-test
[ t ] [ f type f [ type ] compile-call eq? ] unit-test
[ 5 ] [ 1 2 [ eq? [ 3 ] [ 5 ] if ] compile-1 ] unit-test
[ 3 ] [ 2 2 [ eq? [ 3 ] [ 5 ] if ] compile-1 ] unit-test
[ 3 ] [ 1 2 [ fixnum< [ 3 ] [ 5 ] if ] compile-1 ] unit-test
[ 5 ] [ 2 2 [ fixnum< [ 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-call ] unit-test
[ 3 ] [ 1 2 [ fixnum< [ 3 ] [ 5 ] if ] compile-call ] 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-1 ] unit-test
[ 8 ] [ [ 1 3 fixnum-shift ] compile-1 ] unit-test
[ -8 ] [ -1 3 [ fixnum-shift ] compile-1 ] unit-test
[ -8 ] [ -1 [ 3 fixnum-shift ] compile-1 ] 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-call ] unit-test
[ 8 ] [ [ 1 3 fixnum-shift ] compile-call ] unit-test
[ -8 ] [ -1 3 [ fixnum-shift ] compile-call ] unit-test
[ -8 ] [ -1 [ 3 fixnum-shift ] compile-call ] 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-1 ] unit-test
[ 2 ] [ 8 -2 [ fixnum-shift ] compile-call ] 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-1 ] unit-test
[ -1 ] [ [ -123 -64 fixnum-shift ] compile-1 ] unit-test
[ -1 ] [ -123 -64 [ fixnum-shift ] compile-1 ] unit-test
[ 0 ] [ [ 123 -64 fixnum-shift ] compile-call ] unit-test
[ 0 ] [ 123 -64 [ fixnum-shift ] compile-call ] unit-test
[ -1 ] [ [ -123 -64 fixnum-shift ] compile-call ] 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: -fffffff >fixnum [ 1 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-call ] unit-test
[ t ] [ 1 27 fixnum-shift dup [ fixnum+ ] compile-1 1 28 fixnum-shift = ] unit-test
[ -268435457 ] [ 1 28 shift neg >fixnum [ -1 fixnum+ ] compile-1 ] 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-call ] unit-test
[ 4294967296 ] [ 1 32 [ fixnum-shift ] compile-1 ] unit-test
[ 4294967296 ] [ 1 [ 32 fixnum-shift ] compile-1 ] unit-test
[ 4294967296 ] [ 1 [ 16 fixnum-shift 16 fixnum-shift ] compile-1 ] unit-test
[ -4294967296 ] [ -1 32 [ fixnum-shift ] compile-1 ] unit-test
[ -4294967296 ] [ -1 [ 32 fixnum-shift ] compile-1 ] unit-test
[ -4294967296 ] [ -1 [ 16 fixnum-shift 16 fixnum-shift ] compile-1 ] unit-test
[ 4294967296 ] [ 1 32 [ fixnum-shift ] compile-call ] unit-test
[ 4294967296 ] [ 1 [ 32 fixnum-shift ] compile-call ] unit-test
[ 4294967296 ] [ 1 [ 16 fixnum-shift 16 fixnum-shift ] compile-call ] unit-test
[ -4294967296 ] [ -1 32 [ fixnum-shift ] compile-call ] unit-test
[ -4294967296 ] [ -1 [ 32 fixnum-shift ] compile-call ] 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 neg 1 20 shift [ fixnum* ] compile-1 1 40 shift neg = ] unit-test
[ t ] [ 1 20 shift neg 1 20 shift neg [ fixnum* ] compile-1 1 40 shift = ] unit-test
[ -351382792 ] [ -43922849 [ 3 fixnum-shift ] compile-1 ] 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-call 1 40 shift neg = ] 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-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
[ 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
[ 3 ] [
100001 f <array> 3 100000 pick set-nth
[ 100000 swap array-nth ] compile-1
[ 100000 swap array-nth ] compile-call
] unit-test
! 64-bit overflow
cell 8 = [
[ t ] [ 1 59 fixnum-shift dup [ fixnum+ ] compile-1 1 60 fixnum-shift = ] unit-test
[ -1152921504606846977 ] [ 1 60 shift neg >fixnum [ -1 fixnum+ ] compile-1 ] 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-call ] unit-test
[ t ] [ 1 40 shift 1 40 shift [ fixnum* ] compile-1 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 neg [ fixnum* ] compile-1 1 80 shift = ] unit-test
[ t ] [ 1 30 shift neg 1 50 shift neg [ fixnum* ] compile-1 1 80 shift = ] unit-test
[ t ] [ 1 50 shift neg 1 30 shift neg [ 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-call 1 80 shift neg = ] 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-call 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-1 ] unit-test
[ 18446744073709551616 ] [ 1 [ 32 fixnum-shift 32 fixnum-shift ] compile-1 ] unit-test
[ -18446744073709551616 ] [ -1 64 [ fixnum-shift ] compile-1 ] unit-test
[ -18446744073709551616 ] [ -1 [ 64 fixnum-shift ] compile-1 ] unit-test
[ -18446744073709551616 ] [ -1 [ 32 fixnum-shift 32 fixnum-shift ] compile-1 ] unit-test
[ 18446744073709551616 ] [ 1 64 [ fixnum-shift ] compile-call ] unit-test
[ 18446744073709551616 ] [ 1 [ 64 fixnum-shift ] compile-call ] unit-test
[ 18446744073709551616 ] [ 1 [ 32 fixnum-shift 32 fixnum-shift ] compile-call ] unit-test
[ -18446744073709551616 ] [ -1 64 [ fixnum-shift ] compile-call ] unit-test
[ -18446744073709551616 ] [ -1 [ 64 fixnum-shift ] compile-call ] 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
! Some randomized tests
: compiled-fixnum* fixnum* ;
\ compiled-fixnum* compile
: test-fixnum*
(random) >fixnum (random) >fixnum
@ -269,7 +268,6 @@ cell 8 = [
[ ] [ 10000 [ test-fixnum* ] times ] unit-test
: compiled-fixnum>bignum fixnum>bignum ;
\ compiled-fixnum>bignum compile
: test-fixnum>bignum
(random) >fixnum
@ -279,7 +277,6 @@ cell 8 = [
[ ] [ 10000 [ test-fixnum>bignum ] times ] unit-test
: compiled-bignum>fixnum bignum>fixnum ;
\ compiled-bignum>fixnum compile
: test-bignum>fixnum
5 random [ drop (random) ] map product >bignum
@ -292,84 +289,85 @@ cell 8 = [
[ t ] [
most-positive-fixnum 100 - >fixnum
200
[ [ fixnum+ ] compile-1 [ bignum>fixnum ] compile-1 ] 2keep
[ fixnum+ >fixnum ] compile-1
[ [ fixnum+ ] compile-call [ bignum>fixnum ] compile-call ] 2keep
[ fixnum+ >fixnum ] compile-call
=
] unit-test
[ t ] [
most-negative-fixnum 100 + >fixnum
-200
[ [ fixnum+ ] compile-1 [ bignum>fixnum ] compile-1 ] 2keep
[ fixnum+ >fixnum ] compile-1
[ [ fixnum+ ] compile-call [ bignum>fixnum ] compile-call ] 2keep
[ fixnum+ >fixnum ] compile-call
=
] unit-test
[ t ] [
most-negative-fixnum 100 + >fixnum
200
[ [ fixnum- ] compile-1 [ bignum>fixnum ] compile-1 ] 2keep
[ fixnum- >fixnum ] compile-1
[ [ fixnum- ] compile-call [ bignum>fixnum ] compile-call ] 2keep
[ fixnum- >fixnum ] compile-call
=
] unit-test
! Test inline allocators
[ { 1 1 1 } ] [
[ 3 1 <array> ] compile-1
[ 3 1 <array> ] compile-call
] unit-test
[ B{ 0 0 0 } ] [
[ 3 <byte-array> ] compile-1
[ 3 <byte-array> ] compile-call
] unit-test
[ 500 ] [
[ 500 <byte-array> length ] compile-1
[ 500 <byte-array> length ] compile-call
] unit-test
[ 1 2 ] [
1 2 [ <complex> ] compile-1 dup real swap imaginary
1 2 [ <complex> ] compile-call
dup real-part swap imaginary-part
] unit-test
[ 1 2 ] [
1 2 [ <ratio> ] compile-1 dup numerator swap denominator
1 2 [ <ratio> ] compile-call dup numerator swap denominator
] unit-test
[ \ + ] [ \ + [ <wrapper> ] compile-1 ] unit-test
[ \ + ] [ \ + [ <wrapper> ] compile-call ] unit-test
[ H{ } ] [
100 [ (hashtable) ] compile-1 [ reset-hash ] keep
100 [ (hashtable) ] compile-call [ reset-hash ] keep
] unit-test
[ B{ 0 0 0 0 0 } ] [
[ 5 <byte-array> ] compile-1
[ 5 <byte-array> ] compile-call
] unit-test
[ V{ 1 2 } ] [
{ 1 2 3 } 2 [ array>vector ] compile-1
{ 1 2 3 } 2 [ array>vector ] compile-call
] unit-test
[ SBUF" hello" ] [
"hello world" 5 [ string>sbuf ] compile-1
"hello world" 5 [ string>sbuf ] compile-call
] unit-test
[ [ 3 + ] ] [
3 [ + ] [ curry ] compile-1
3 [ + ] [ curry ] compile-call
] unit-test
! 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-1 ] 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 [ { c-ptr fixnum } declare 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-call ] 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-call ] unit-test
[ ] [ B{ 1 2 3 4 5 } malloc-byte-array "b" set ] unit-test
[ t ] [ "b" get >boolean ] unit-test
"b" get [
[ 3 ] [ "b" get 2 [ alien-unsigned-1 ] compile-1 ] unit-test
[ 3 ] [ "b" get [ { alien } declare 2 alien-unsigned-1 ] compile-1 ] unit-test
[ 3 ] [ "b" get 2 [ { simple-alien fixnum } declare alien-unsigned-1 ] compile-1 ] unit-test
[ 3 ] [ "b" get 2 [ { c-ptr fixnum } declare 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-call ] 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-call ] unit-test
[ ] [ "b" get free ] unit-test
] when
@ -377,61 +375,61 @@ cell 8 = [
[ ] [ "hello world" malloc-char-string "s" set ] unit-test
"s" get [
[ "hello world" ] [ "s" get <void*> [ { byte-array } declare *void* ] compile-1 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*> [ { byte-array } declare *void* ] compile-call 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
] when
[ ALIEN: 1234 ] [ ALIEN: 1234 [ { alien } declare <void*> ] compile-1 *void* ] unit-test
[ ALIEN: 1234 ] [ ALIEN: 1234 [ { c-ptr } declare <void*> ] compile-1 *void* ] unit-test
[ f ] [ f [ { POSTPONE: f } 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-call *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
[ -4 ] [ B{ 1 2 3 -4 5 } 3 [ { byte-array fixnum } declare alien-signed-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-call ] unit-test
: xword-def word-def [ { fixnum } declare ] swap append ;
[ -100 ] [ -100 <char> [ { byte-array } declare *char ] compile-1 ] unit-test
[ 156 ] [ -100 <uchar> [ { byte-array } declare *uchar ] compile-1 ] unit-test
[ -100 ] [ -100 <char> [ { byte-array } declare *char ] compile-call ] unit-test
[ 156 ] [ -100 <uchar> [ { byte-array } declare *uchar ] compile-call ] unit-test
[ -100 ] [ -100 \ <char> xword-def compile-1 *char ] unit-test
[ 156 ] [ -100 \ <uchar> xword-def compile-1 *uchar ] unit-test
[ -100 ] [ -100 \ <char> xword-def compile-call *char ] unit-test
[ 156 ] [ -100 \ <uchar> xword-def compile-call *uchar ] unit-test
[ -1000 ] [ -1000 <short> [ { byte-array } declare *short ] compile-1 ] unit-test
[ 64536 ] [ -1000 <ushort> [ { byte-array } declare *ushort ] compile-1 ] unit-test
[ -1000 ] [ -1000 <short> [ { byte-array } declare *short ] compile-call ] unit-test
[ 64536 ] [ -1000 <ushort> [ { byte-array } declare *ushort ] compile-call ] unit-test
[ -1000 ] [ -1000 \ <short> xword-def compile-1 *short ] unit-test
[ 64536 ] [ -1000 \ <ushort> xword-def compile-1 *ushort ] unit-test
[ -1000 ] [ -1000 \ <short> xword-def compile-call *short ] unit-test
[ 64536 ] [ -1000 \ <ushort> xword-def compile-call *ushort ] unit-test
[ -100000 ] [ -100000 <int> [ { byte-array } declare *int ] compile-1 ] unit-test
[ 4294867296 ] [ -100000 <uint> [ { byte-array } declare *uint ] compile-1 ] unit-test
[ -100000 ] [ -100000 <int> [ { byte-array } declare *int ] compile-call ] unit-test
[ 4294867296 ] [ -100000 <uint> [ { byte-array } declare *uint ] compile-call ] unit-test
[ -100000 ] [ -100000 \ <int> xword-def compile-1 *int ] unit-test
[ 4294867296 ] [ -100000 \ <uint> xword-def compile-1 *uint ] unit-test
[ -100000 ] [ -100000 \ <int> xword-def compile-call *int ] unit-test
[ 4294867296 ] [ -100000 \ <uint> xword-def compile-call *uint ] 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
[ 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 <float> [ { byte-array } declare *float ] compile-1 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-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 ] [
2 B{ 1 2 3 4 5 6 } <displaced-alien> [
{ alien } declare 1 alien-unsigned-1
] compile-1
] compile-call
] 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
[
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
[
@ -441,5 +439,5 @@ cell 8 = [
[
{ [ 4444 ] [ 444 ] [ 44 ] [ 4 ] } dispatch
] keep 2 fixnum+fast
] compile-1
] compile-call
] unit-test

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

@ -1,7 +1,8 @@
USING: arrays compiler generic hashtables inference kernel
kernel.private math optimizer prettyprint sequences sbufs
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
[ H{ { 1 5 } { 3 4 } { 2 5 } } ] [
@ -50,7 +51,7 @@ FORGET: xyz
GENERIC: xyz ( obj -- obj )
M: array xyz xyz ;
[ ] [ \ xyz compile ] unit-test
[ t ] [ \ xyz compiled? ] unit-test
! Test predicate inlining
: pred-test-1
@ -101,14 +102,14 @@ TUPLE: pred-test ;
! 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 ;
[ 3 ] [ t bad-kill-2 ] unit-test
! regression
: (the-test) ( n -- ) dup 0 > [ 1- (the-test) ] when ; inline
: the-test ( -- n ) 2 dup (the-test) ;
: (the-test) ( x -- y ) dup 0 > [ 1- (the-test) ] when ; inline
: the-test ( -- x y ) 2 dup (the-test) ;
[ 2 0 ] [ the-test ] unit-test
@ -135,7 +136,7 @@ TUPLE: pred-test ;
! regression
GENERIC: void-generic ( obj -- * )
: breakage "hi" void-generic ;
[ ] [ \ breakage compile ] unit-test
[ t ] [ \ breakage compiled? ] unit-test
[ breakage ] unit-test-fails
! regression
@ -145,10 +146,10 @@ GENERIC: void-generic ( obj -- * )
[ 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
: branch-fold-regression-1 ( -- )
: branch-fold-regression-1 ( -- m )
10 branch-fold-regression-0 ;
[ 10 ] [ branch-fold-regression-1 ] unit-test
@ -156,7 +157,7 @@ GENERIC: void-generic ( obj -- * )
! another regression
: constant-branch-fold-0 "hey" ; foldable
: 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
: foo f ;
@ -170,9 +171,11 @@ GENERIC: void-generic ( obj -- * )
] unit-test
! 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: integer foozul ;
M: slice foozul ;
@ -184,71 +187,71 @@ M: slice foozul ;
: constant-fold-3 4 ; foldable
[ f t ] [
[ constant-fold-2 constant-fold-3 4 = ] compile-1
[ constant-fold-2 constant-fold-3 4 = ] compile-call
] unit-test
: constant-fold-4 f ; foldable
: constant-fold-5 f ; foldable
[ f ] [
[ constant-fold-4 constant-fold-5 or ] compile-1
[ constant-fold-4 constant-fold-5 or ] compile-call
] unit-test
[ 5 ] [ 5 [ 0 + ] compile-1 ] unit-test
[ 5 ] [ 5 [ 0 swap + ] compile-1 ] unit-test
[ 5 ] [ 5 [ 0 + ] compile-call ] unit-test
[ 5 ] [ 5 [ 0 swap + ] compile-call ] unit-test
[ 5 ] [ 5 [ 0 - ] compile-1 ] unit-test
[ -5 ] [ 5 [ 0 swap - ] compile-1 ] unit-test
[ 0 ] [ 5 [ dup - ] compile-1 ] unit-test
[ 5 ] [ 5 [ 0 - ] compile-call ] unit-test
[ -5 ] [ 5 [ 0 swap - ] compile-call ] unit-test
[ 0 ] [ 5 [ dup - ] compile-call ] unit-test
[ 5 ] [ 5 [ 1 * ] compile-1 ] unit-test
[ 5 ] [ 5 [ 1 swap * ] compile-1 ] unit-test
[ 0 ] [ 5 [ 0 * ] compile-1 ] unit-test
[ 0 ] [ 5 [ 0 swap * ] compile-1 ] unit-test
[ -5 ] [ 5 [ -1 * ] compile-1 ] unit-test
[ -5 ] [ 5 [ -1 swap * ] compile-1 ] unit-test
[ 5 ] [ 5 [ 1 * ] compile-call ] unit-test
[ 5 ] [ 5 [ 1 swap * ] compile-call ] unit-test
[ 0 ] [ 5 [ 0 * ] compile-call ] unit-test
[ 0 ] [ 5 [ 0 swap * ] compile-call ] unit-test
[ -5 ] [ 5 [ -1 * ] compile-call ] unit-test
[ -5 ] [ 5 [ -1 swap * ] compile-call ] unit-test
[ 0 ] [ 5 [ 1 mod ] compile-1 ] unit-test
[ 0 ] [ 5 [ 1 rem ] compile-1 ] unit-test
[ 0 ] [ 5 [ 1 mod ] compile-call ] unit-test
[ 0 ] [ 5 [ 1 rem ] compile-call ] unit-test
[ 5 ] [ 5 [ -1 bitand ] compile-1 ] unit-test
[ 0 ] [ 5 [ 0 bitand ] compile-1 ] unit-test
[ 5 ] [ 5 [ -1 swap bitand ] compile-1 ] unit-test
[ 0 ] [ 5 [ 0 swap bitand ] compile-1 ] unit-test
[ 5 ] [ 5 [ dup bitand ] compile-1 ] unit-test
[ 5 ] [ 5 [ -1 bitand ] compile-call ] unit-test
[ 0 ] [ 5 [ 0 bitand ] compile-call ] unit-test
[ 5 ] [ 5 [ -1 swap bitand ] compile-call ] unit-test
[ 0 ] [ 5 [ 0 swap bitand ] compile-call ] unit-test
[ 5 ] [ 5 [ dup bitand ] compile-call ] unit-test
[ 5 ] [ 5 [ 0 bitor ] compile-1 ] unit-test
[ -1 ] [ 5 [ -1 bitor ] compile-1 ] unit-test
[ 5 ] [ 5 [ 0 swap bitor ] compile-1 ] unit-test
[ -1 ] [ 5 [ -1 swap bitor ] compile-1 ] unit-test
[ 5 ] [ 5 [ dup bitor ] compile-1 ] unit-test
[ 5 ] [ 5 [ 0 bitor ] compile-call ] unit-test
[ -1 ] [ 5 [ -1 bitor ] compile-call ] unit-test
[ 5 ] [ 5 [ 0 swap bitor ] compile-call ] unit-test
[ -1 ] [ 5 [ -1 swap bitor ] compile-call ] unit-test
[ 5 ] [ 5 [ dup bitor ] compile-call ] unit-test
[ 5 ] [ 5 [ 0 bitxor ] compile-1 ] unit-test
[ 5 ] [ 5 [ 0 swap bitxor ] compile-1 ] unit-test
[ -6 ] [ 5 [ -1 bitxor ] compile-1 ] unit-test
[ -6 ] [ 5 [ -1 swap bitxor ] compile-1 ] unit-test
[ 0 ] [ 5 [ dup bitxor ] compile-1 ] unit-test
[ 5 ] [ 5 [ 0 bitxor ] compile-call ] unit-test
[ 5 ] [ 5 [ 0 swap bitxor ] compile-call ] unit-test
[ -6 ] [ 5 [ -1 bitxor ] compile-call ] unit-test
[ -6 ] [ 5 [ -1 swap bitxor ] compile-call ] unit-test
[ 0 ] [ 5 [ dup bitxor ] compile-call ] unit-test
[ 0 ] [ 5 [ 0 swap shift ] compile-1 ] unit-test
[ 5 ] [ 5 [ 0 shift ] compile-1 ] unit-test
[ 0 ] [ 5 [ 0 swap shift ] compile-call ] unit-test
[ 5 ] [ 5 [ 0 shift ] compile-call ] unit-test
[ f ] [ 5 [ dup < ] compile-1 ] unit-test
[ t ] [ 5 [ dup <= ] compile-1 ] unit-test
[ f ] [ 5 [ dup > ] compile-1 ] unit-test
[ t ] [ 5 [ dup >= ] compile-1 ] unit-test
[ f ] [ 5 [ dup < ] compile-call ] unit-test
[ t ] [ 5 [ dup <= ] compile-call ] unit-test
[ f ] [ 5 [ dup > ] compile-call ] unit-test
[ t ] [ 5 [ dup >= ] compile-call ] unit-test
[ t ] [ 5 [ dup eq? ] compile-1 ] unit-test
[ t ] [ 5 [ dup = ] compile-1 ] unit-test
[ t ] [ 5 [ dup number= ] compile-1 ] unit-test
[ t ] [ \ vector [ \ vector = ] compile-1 ] unit-test
[ t ] [ 5 [ dup eq? ] compile-call ] unit-test
[ t ] [ 5 [ dup = ] compile-call ] unit-test
[ t ] [ 5 [ dup number= ] compile-call ] unit-test
[ t ] [ \ vector [ \ vector = ] compile-call ] unit-test
GENERIC: detect-number ( obj -- obj )
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
[ 4 [ + ] ] [ 2 2 [ [ + ] [ call ] keep ] compile-1 ] unit-test
[ 4 [ + ] ] [ 2 2 [ [ + ] [ call ] keep ] compile-call ] unit-test
! Regression
USE: sorting
@ -265,7 +268,7 @@ USE: sorting.private
[ 10 ] [
10 20 >vector <flat-slice>
[ [ - ] swap old-binsearch ] compile-1 2nip
[ [ - ] swap old-binsearch ] compile-call 2nip
] unit-test
! Regression
@ -275,5 +278,13 @@ TUPLE: silly-tuple a b ;
T{ silly-tuple f 1 2 }
[
{ silly-tuple-a silly-tuple-b } [ get-slots ] keep
] compile-1
] compile-call
] 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

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

@ -1,42 +1,175 @@
USING: compiler definitions generic assocs inference math
namespaces parser tools.test words kernel sequences arrays io
effects tools.test.inference ;
effects tools.test.inference words.private ;
IN: temporary
parse-hook get [
DEFER: foo \ foo reset-generic
DEFER: bar \ bar reset-generic
DEFER: x-1
DEFER: x-2
[ ] [ \ foo [ 1 2 ] define-compound ] unit-test
{ 0 2 } [ foo ] unit-test-effect
[ ] [ \ foo compile ] unit-test
[ ] [ \ 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
[ [ f ] { } map>assoc modify-code-heap ] recompile-hook [
"IN: temporary USE: math GENERIC: x-1 ( x -- y ) M: integer x-1 ;" eval
"IN: temporary : x-2 3 x-1 ;" eval
: xy ;
: yx xy ;
[ t ] [
{ x-2 } compile
\ yx compile
\ xy [ 1 ] define-compound
\ x-2 word-xt
[ ] [ recompile ] unit-test
{ x-1 } compile
[ 1 ] [ yx ] unit-test
] when
\ x-2 word-xt eq?
] unit-test
] with-variable
DEFER: b
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
! Test empty word
[ ] [ [ ] compile-1 ] unit-test
[ ] [ [ ] compile-call ] unit-test
! Test literals
[ 1 ] [ [ 1 ] compile-1 ] unit-test
[ 31 ] [ [ 31 ] compile-1 ] unit-test
[ 255 ] [ [ 255 ] compile-1 ] unit-test
[ -1 ] [ [ -1 ] compile-1 ] unit-test
[ 65536 ] [ [ 65536 ] compile-1 ] unit-test
[ -65536 ] [ [ -65536 ] compile-1 ] unit-test
[ "hey" ] [ [ "hey" ] compile-1 ] unit-test
[ 1 ] [ [ 1 ] compile-call ] unit-test
[ 31 ] [ [ 31 ] compile-call ] unit-test
[ 255 ] [ [ 255 ] compile-call ] unit-test
[ -1 ] [ [ -1 ] compile-call ] unit-test
[ 65536 ] [ [ 65536 ] compile-call ] unit-test
[ -65536 ] [ [ -65536 ] compile-call ] unit-test
[ "hey" ] [ [ "hey" ] compile-call ] unit-test
! Calls
: no-op ;
[ ] [ [ no-op ] compile-1 ] unit-test
[ 3 ] [ [ no-op 3 ] compile-1 ] unit-test
[ 3 ] [ [ 3 no-op ] compile-1 ] unit-test
[ ] [ [ no-op ] compile-call ] unit-test
[ 3 ] [ [ no-op 3 ] compile-call ] unit-test
[ 3 ] [ [ 3 no-op ] compile-call ] unit-test
: bar 4 ;
[ 4 ] [ [ bar no-op ] compile-1 ] unit-test
[ 4 3 ] [ [ no-op bar 3 ] compile-1 ] unit-test
[ 3 4 ] [ [ 3 no-op bar ] compile-1 ] unit-test
[ 4 ] [ [ bar no-op ] compile-call ] unit-test
[ 4 3 ] [ [ no-op bar 3 ] compile-call ] unit-test
[ 3 4 ] [ [ 3 no-op bar ] compile-call ] unit-test
[ ] [ no-op ] unit-test
! Conditionals
[ 1 ] [ t [ [ 1 ] [ 2 ] if ] compile-1 ] unit-test
[ 2 ] [ f [ [ 1 ] [ 2 ] if ] compile-1 ] unit-test
[ 1 3 ] [ t [ [ 1 ] [ 2 ] if 3 ] compile-1 ] unit-test
[ 2 3 ] [ f [ [ 1 ] [ 2 ] if 3 ] compile-1 ] unit-test
[ 1 ] [ t [ [ 1 ] [ 2 ] if ] compile-call ] unit-test
[ 2 ] [ f [ [ 1 ] [ 2 ] if ] compile-call ] unit-test
[ 1 3 ] [ t [ [ 1 ] [ 2 ] if 3 ] compile-call ] unit-test
[ 2 3 ] [ f [ [ 1 ] [ 2 ] if 3 ] compile-call ] unit-test
[ "hi" ] [ 0 [ { [ "hi" ] [ "bye" ] } dispatch ] compile-1 ] unit-test
[ "bye" ] [ 1 [ { [ "hi" ] [ "bye" ] } dispatch ] compile-1 ] unit-test
[ "hi" ] [ 0 [ { [ "hi" ] [ "bye" ] } dispatch ] compile-call ] unit-test
[ "bye" ] [ 1 [ { [ "hi" ] [ "bye" ] } dispatch ] compile-call ] unit-test
[ "hi" 3 ] [ 0 [ { [ "hi" ] [ "bye" ] } dispatch 3 ] compile-1 ] unit-test
[ "bye" 3 ] [ 1 [ { [ "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-call ] unit-test
[ 4 1 ] [ 0 [ { [ bar 1 ] [ 3 1 ] } dispatch ] compile-1 ] unit-test
[ 3 1 ] [ 1 [ { [ bar 1 ] [ 3 1 ] } dispatch ] compile-1 ] unit-test
[ 4 1 3 ] [ 0 [ { [ bar 1 ] [ 3 1 ] } dispatch 3 ] compile-1 ] unit-test
[ 3 1 3 ] [ 1 [ { [ bar 1 ] [ 3 1 ] } dispatch 3 ] 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-call ] 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-call ] unit-test
! Labels
: recursive ( ? -- ) [ f recursive ] when ; inline
[ ] [ t [ recursive ] compile-1 ] unit-test
\ recursive compile
[ ] [ t [ recursive ] compile-call ] unit-test
[ ] [ t recursive ] unit-test
! Make sure error reporting works
[ [ dup ] compile-1 ] unit-test-fails
[ [ drop ] compile-1 ] unit-test-fails
[ [ dup ] compile-call ] 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 ;
: bar foo 4 ;
: baz bar 5 ;
\ baz compile
[ 3 ] [ [ baz ] catch ] unit-test
[ t ] [
symbolic-stack-trace
@ -19,7 +18,6 @@ words splitting ;
] unit-test
: bleh [ 3 + ] map [ 0 > ] subset ;
\ bleh compile
: stack-trace-contains? symbolic-stack-trace memq? ;
@ -34,7 +32,6 @@ words splitting ;
] unit-test
: quux [ t [ "hi" throw ] when ] times ;
\ quux compile
[ t ] [
[ 10 quux ] catch drop

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

@ -2,7 +2,7 @@
IN: temporary
USING: compiler generator generator.registers
generator.registers.private tools.test namespaces sequences
words kernel math effects ;
words kernel math effects definitions ;
: <int-vreg> ( n -- vreg ) T{ int-regs } <vreg> ;
@ -44,7 +44,7 @@ words kernel math effects ;
[
[ ] [ init-templates ] unit-test
[ ] [ init-generator ] unit-test
[ ] [ \ + init-generator ] unit-test
[ t ] [ [ end-basic-block ] { } make empty? ] unit-test
@ -68,7 +68,7 @@ words kernel math effects ;
! Test template picking strategy
SYMBOL: template-chosen
: template-test ( a b -- c ) + ;
: template-test ( a b -- c d ) ;
\ template-test {
{
@ -76,7 +76,7 @@ SYMBOL: template-chosen
1 template-chosen get push
] H{
{ +input+ { { f "obj" } { [ ] "n" } } }
{ +output+ { "obj" } }
{ +output+ { "obj" "obj" } }
}
}
{
@ -84,26 +84,26 @@ SYMBOL: template-chosen
2 template-chosen get push
] H{
{ +input+ { { f "obj" } { f "n" } } }
{ +output+ { "obj" } }
{ +output+ { "obj" "n" } }
}
}
} define-intrinsics
[ V{ 2 } ] [
V{ } clone template-chosen set
[ template-test ] compile-quot drop
0 0 [ template-test ] compile-call 2drop
template-chosen get
] unit-test
[ V{ 1 } ] [
V{ } clone template-chosen set
[ dup 0 template-test ] compile-quot drop
1 [ dup 0 template-test ] compile-call 3drop
template-chosen get
] unit-test
[ V{ 1 } ] [
V{ } clone template-chosen set
[ 0 template-test ] compile-quot drop
1 [ 0 template-test ] compile-call 2drop
template-chosen get
] unit-test
@ -209,7 +209,8 @@ H{
{ { 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
[ 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
USING: arrays compiler kernel kernel.private math
hashtables.private math.private namespaces sequences
sequences.private tools.test namespaces.private slots.private
combinators.private byte-arrays alien layouts ;
combinators.private byte-arrays alien layouts words definitions ;
IN: temporary
! Oops!
[ 5000 ] [ [ 5000 ] compile-1 ] unit-test
[ "hi" ] [ [ "hi" ] compile-1 ] unit-test
[ 5000 ] [ [ 5000 ] compile-call ] 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
[ 0 ] [ 3 [ tag ] compile-1 ] unit-test
[ 0 3 ] [ 3 [ [ tag ] keep ] compile-1 ] unit-test
[ 1 1 ] [ 1 [ dup ] compile-call ] unit-test
[ 0 ] [ 3 [ tag ] compile-call ] 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 } [ over tag over tag ] compile-1 ]
[ { 1 2 3 } { 1 4 3 } [ over tag over tag ] compile-call ]
unit-test
[ { 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
! 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 ;
[ 5 5 ]
[ 1.2 [ tag [ foo ] keep ] compile-1 ]
[ 1.2 [ tag [ foo ] keep ] compile-call ]
unit-test
[ 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
[ 3 ]
[
global [ 3 \ foo set ] bind
\ foo [ global >n get ndrop ] compile-1
\ foo [ global >n get ndrop ] compile-call
] unit-test
: blech drop ;
@ -56,53 +55,53 @@ unit-test
[ 3 ]
[
global [ 3 \ foo set ] bind
\ foo [ global [ get ] swap blech call ] compile-1
\ foo [ global [ get ] swap blech call ] compile-call
] unit-test
[ 3 ]
[
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
[ 3 ]
[
global [ 3 \ foo set ] bind
\ foo [ global [ get ] bind ] compile-1
\ foo [ global [ get ] bind ] compile-call
] unit-test
[ 12 13 ] [
-12 -13 [ [ 0 swap fixnum-fast ] 2apply ] compile-1
-12 -13 [ [ 0 swap fixnum-fast ] 2apply ] compile-call
] 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 [ [ 0 swap fixnum- ] 2apply ] compile-1
-12 -13 [ [ 0 swap fixnum- ] 2apply ] compile-call
] unit-test
[ 2 ] [
SBUF" " [ 2 slot 2 [ slot ] keep ] compile-1 nip
SBUF" " [ 2 slot 2 [ slot ] keep ] compile-call nip
] unit-test
! Test slow shuffles
[ 3 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> ]
compile-1
compile-call
] unit-test
[ 2 2 2 2 2 2 2 2 2 2 1 ] [
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
[ ] [ [ 9 [ ] times ] compile-1 ] unit-test
[ ] [ [ 9 [ ] times ] compile-call ] unit-test
[ ] [
[
[ 200 dup [ 200 3array ] curry map drop ] times
] compile-quot drop
] [ define-temp ] with-compilation-unit drop
] unit-test
@ -122,7 +121,7 @@ unit-test
[ 2.0 { 2.0 0.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
! Regression
@ -143,7 +142,7 @@ unit-test
[ ] [
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
! Regression
@ -160,34 +159,34 @@ TUPLE: my-tuple ;
[ 5 ] [ "hi" foox ] unit-test
! 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 } ] [
B{ 1 2 3 4 } [
{ byte-array } declare
[ 0 alien-unsigned-1 ] keep
] compile-1
] compile-call
] unit-test
[ 1 t ] [
B{ 1 2 3 4 } [
{ c-ptr } declare
[ 0 alien-unsigned-1 ] keep type
] compile-1 byte-array type-number =
] compile-call byte-array type-number =
] unit-test
[ t ] [
B{ 1 2 3 4 } [
{ c-ptr } declare
0 alien-cell type
] compile-1 alien type-number =
] compile-call alien type-number =
] unit-test
[ 2 1 ] [
2 1
[ 2dup fixnum< [ >r die r> ] when ] compile-1
[ 2dup fixnum< [ >r die r> ] when ] compile-call
] 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 ;
[ 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 2 3 color construct-boa
[ { color-red color-blue } get-slots ] compile-1
[ { color-red color-blue } get-slots ] compile-call
] unit-test
[ T{ color f 10 2 20 } ] [
@ -16,17 +16,17 @@ TUPLE: color red green blue ;
1 2 3 color construct-boa [
[
{ set-color-red set-color-blue } set-slots
] compile-1
] compile-call
] keep
] unit-test
[ 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 } ] [
"a" "b"
[ { set-delegate set-color-green } color construct ]
compile-1
compile-call
] 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
[ [ "2 car" ] parse ] catch print-error
[ [ "2 car" ] eval ] catch print-error
[ f throw ] unit-test-fails
@ -71,3 +71,38 @@ IN: temporary
[ t ] [ \ bar word-def "c" get innermost-frame-quot = ] 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.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays vectors kernel kernel.private sequences
namespaces tuples math splitting sorting quotations assocs ;
namespaces math splitting sorting quotations assocs ;
IN: continuations
SYMBOL: error
@ -127,8 +127,8 @@ PRIVATE>
>r (catch) r> ifcc ; inline
: cleanup ( try cleanup-always cleanup-error -- )
>r [ compose (catch) ] keep r> compose
[ dip rethrow ] curry ifcc ; inline
over >r compose [ dip rethrow ] curry
>r (catch) r> ifcc r> call ; inline
: 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 ;
IN: cpu.architecture
: set-profiler-prologues ( n -- )
39 setenv ;
SYMBOL: compiler-backend
! A pseudo-register class for parameters spilled on the stack
@ -46,9 +43,6 @@ HOOK: %epilogue compiler-backend ( n -- )
: %epilogue-later \ %epilogue-later , ;
! Bump profiling counter
HOOK: %profiler-prologue compiler-backend ( word -- )
! Store word XT in stack frame
HOOK: %save-word-xt compiler-backend ( -- )
@ -60,15 +54,9 @@ M: object %save-dispatch-xt %save-word-xt ;
! Call another label
HOOK: %call-label compiler-backend ( label -- )
! Call C primitive
HOOK: %call-primitive compiler-backend ( label -- )
! Local jump for branches
HOOK: %jump-label compiler-backend ( label -- )
! Far jump to C primitive
HOOK: %jump-primitive compiler-backend ( label -- )
! Test if vreg is 'f' or not
HOOK: %jump-t compiler-backend ( label -- )
@ -160,7 +148,7 @@ M: stack-params param-reg drop ;
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 ;

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

@ -17,7 +17,7 @@ IN: cpu.arm.allot
R11 R11 pick ADD ! increment r11
R11 R12 cell <+> STR ! r11 -> nursery.here
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
;

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
! Is the object an alien?
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
R11 R11 R12 NE ADD
! 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
] 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.
! See http://factorcode.org/license.txt for BSD license.
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
! We generate ARM3 code
@ -116,4 +116,4 @@ big-endian off
[ 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 12 cell STW ! r11 -> nursery.here
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
;

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

@ -3,7 +3,8 @@
USING: alien.c-types cpu.ppc.assembler cpu.architecture generic
kernel kernel.private math memory namespaces sequences words
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
TUPLE: ppc-backend ;
@ -37,7 +38,7 @@ TUPLE: ppc-backend ;
: local@ ( n -- x )
reserved-area-size param-save-size + + ; inline
: factor-area-size 4 cells ;
: factor-area-size 2 cells ;
: next-save ( n -- i ) cell - ;
@ -77,7 +78,7 @@ M: ppc-backend load-indirect ( obj reg -- )
dup 0 LWZ ;
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 -- )
0 MFLR
@ -99,42 +100,22 @@ M: ppc-backend %epilogue ( n -- )
: %load-dlsym ( symbol dll register -- )
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 %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 -- )
0 "flag" operand f v>operand CMPI BNE ;
: (%call) 11 MTLR BLRL ;
: dispatch-template ( word-table# quot -- )
[
>r
"offset" operand "n" operand 1 SRAWI
0 11 LOAD32 rc-absolute-ppc-2/2 rel-dispatch
11 dup "offset" operand LWZX
11 dup compiled-header-size ADDI
11 dup word-xt-offset LWZ
r> call
] H{
{ +input+ { { f "n" } } }
@ -145,7 +126,7 @@ M: ppc-backend %call-dispatch ( word-table# -- )
[ (%call) ] dispatch-template ;
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 ;
@ -295,7 +276,7 @@ M: ppc-backend %cleanup ( alien-node -- ) drop ;
M: ppc-backend value-structs?
#! On Linux/PPC, value structs are passed in the same way
#! as reference structs, we just have to make a copy first.
os "linux" = not ;
linux? not ;
M: ppc-backend fp-shadows-int? ( -- ? ) macosx? ;
@ -333,7 +314,7 @@ M: ppc-backend %unbox-any-c-ptr ( dst src -- )
"end" get BEQ
! Is the object an alien?
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
! If so, load the offset
0 11 alien-offset LWZ

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

@ -1,121 +1,109 @@
! Copyright (C) 2007 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: bootstrap.image.private kernel namespaces system
cpu.ppc.assembler math layouts words vocabs ;
IN: bootstrap.ppc
4 \ cell set
big-endian on
4 jit-code-format set
: ds-reg 14 ;
: word-reg 3 ;
: quot-reg 3 ;
: scan-reg 5 ;
: temp-reg 6 ;
: xt-reg 11 ;
: factor-area-size 4 bootstrap-cells ;
: stack-frame
factor-area-size c-area-size + 4 bootstrap-cells align ;
: next-save stack-frame bootstrap-cell - ;
: 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
scan-reg temp-reg scan@ ADDI ! initialize scan pointer
] { } make jit-setup set
[
0 MFLR
1 1 stack-frame neg ADDI
xt-reg 1 xt-save STW ! save XT
stack-frame xt-reg LI
xt-reg 1 next-save STW ! save frame size
temp-reg 1 array-save STW ! save array
0 1 lr-save stack-frame + STW ! save return address
] { } make jit-prolog set
[
temp-reg scan-reg 4 LWZU ! load literal and advance
temp-reg ds-reg 4 STWU ! push literal
] { } make jit-push-literal set
[
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
[
4 1 MR ! pass stack pointer to primitive
] { } make jit-word-primitive-jump set
[
4 1 MR ! pass stack pointer to primitive
] { } make jit-word-primitive-call set
: load-xt ( -- )
word-reg scan-reg 4 LWZU ! load word and advance
xt-reg word-reg word-xt@ LWZ ;
: jit-call
scan-reg 1 scan-save STW ! save scan pointer
xt-reg MTLR ! pass XT to callee
BLRL ! call
scan-reg 1 scan-save LWZ ! restore scan pointer
;
: jit-jump
xt-reg MTCTR BCTR ;
[ 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
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
quot-reg dup 4 ADDI ! point quot-reg at true branch
quot-reg dup 4 LWZ ! load the branch
ds-reg dup 4 SUBI ! pop boolean
scan-reg dup 12 ADDI ! advance scan pointer
xt-reg quot-reg quot-xt@ LWZ ! load quotation-xt
;
[
load-branch jit-jump
] { } make jit-if-jump set
[
load-branch jit-call
] { } make jit-if-call set
[
temp-reg ds-reg 0 LWZ ! load index
temp-reg dup 1 SRAWI ! turn it into an array offset
ds-reg dup 4 SUBI ! pop index
scan-reg dup 4 LWZ ! load array
temp-reg dup scan-reg ADD ! compute quotation location
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
1 1 stack-frame ADDI ! pop stack frame
0 MTLR ! get ready to return
] { } make jit-epilog set
[ BLR ] { } make jit-return set
"bootstrap.ppc" forget-vocab
! Copyright (C) 2007, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: bootstrap.image.private kernel namespaces system
cpu.ppc.assembler generator.fixup compiler.units
compiler.constants math layouts words vocabs ;
IN: bootstrap.ppc
4 \ cell set
big-endian on
4 jit-code-format set
: ds-reg 14 ;
: quot-reg 3 ;
: temp-reg 6 ;
: aux-reg 11 ;
: factor-area-size 4 bootstrap-cells ;
: stack-frame
factor-area-size c-area-size + 4 bootstrap-cells align ;
: next-save stack-frame bootstrap-cell - ;
: xt-save stack-frame 2 bootstrap-cells - ;
[
! Load word
0 temp-reg LOAD32
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 temp-reg LOAD32 ! load XT
0 MFLR ! load return address
1 1 stack-frame neg ADDI ! create stack frame
temp-reg 1 xt-save STW ! save XT
stack-frame temp-reg LI ! load frame size
temp-reg 1 next-save STW ! save frame size
0 1 lr-save stack-frame + STW ! save return address
] rc-absolute-ppc-2/2 rt-label 1 jit-prolog jit-define
[
0 temp-reg LOAD32 ! load literal
temp-reg dup 0 LWZ ! indirection
temp-reg ds-reg 4 STWU ! push literal
] rc-absolute-ppc-2/2 rt-literal 1 jit-push-literal jit-define
[
0 temp-reg LOAD32 ! load primitive address
4 1 MR ! pass stack pointer to primitive
temp-reg MTCTR ! jump to primitive
BCTR
] rc-absolute-ppc-2/2 rt-primitive 1 jit-primitive jit-define
[
0 BL
] rc-relative-ppc-3 rt-xt 0 jit-word-call jit-define
[
0 B
] rc-relative-ppc-3 rt-xt 0 jit-word-jump jit-define
: jit-call-quot ( -- )
temp-reg quot-reg quot-xt@ LWZ ! load quotation-xt
temp-reg MTCTR ! jump to quotation-xt
BCTR ;
[
0 quot-reg LOAD32 ! point quot-reg at false branch
temp-reg ds-reg 0 LWZ ! load boolean
0 temp-reg \ f tag-number CMPI ! compare it with f
2 BNE ! skip next insn if its not f
quot-reg dup 4 ADDI ! point quot-reg at true branch
quot-reg dup 0 LWZ ! load the branch
ds-reg dup 4 SUBI ! pop boolean
jit-call-quot
] rc-absolute-ppc-2/2 rt-literal 1 jit-if-jump jit-define
[
0 quot-reg LOAD32 ! load dispatch array
quot-reg dup 0 LWZ ! indirection
temp-reg ds-reg 0 LWZ ! load index
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
jit-call-quot
] rc-absolute-ppc-2/2 rt-literal 1 jit-dispatch jit-define
[
0 1 lr-save stack-frame + LWZ ! load return address
1 1 stack-frame ADDI ! pop stack frame
0 MTLR ! get ready to return
] f f f jit-epilog jit-define
[ BLR ] f f f jit-return jit-define
[ "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
classes tuples tuples.private sbufs.private vectors.private
strings.private slots.private combinators bit-arrays
float-arrays ;
float-arrays compiler.constants ;
IN: cpu.ppc.intrinsics
: %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 "ulonglong" c-type set-c-type-align
] }
{ [ os "linux" = ] [
{ [ linux? ] [
t "longlong" c-type set-c-type-stack-align?
t "ulonglong" c-type set-c-type-stack-align?
] }
} cond
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
] { } define-if-intrinsic
10 set-profiler-prologues
"-no-sse2" cli-args member? [
"Checking if your CPU supports SSE2..." print flush
[ sse2? ] compile-1 [
[ sse2? ] compile-call [
" - yes" print
"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 ;
: arg1 EDX ;
: temp-reg EBX ;
: stack-reg ESP ;
: ds-reg ESI ;
: scan-reg EBX ;
: xt-reg ECX ;
: fixnum>slot@ arg0 1 SAR ;
"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
] 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 ;
: store-header ( header -- )
0 object@ swap type-number tag-header MOV ;
0 object@ swap type-number tag-fixnum MOV ;
: %allot ( header size quot -- )
allot-reg PUSH

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

@ -3,7 +3,7 @@
USING: alien alien.c-types alien.compiler arrays
cpu.x86.assembler cpu.architecture kernel kernel.private math
memory namespaces sequences words generator generator.registers
generator.fixup system layouts combinators ;
generator.fixup system layouts combinators compiler.constants ;
IN: cpu.x86.architecture
TUPLE: x86-backend cell ;
@ -45,7 +45,7 @@ M: x86-backend stack-frame ( n -- i )
3 cells + 16 align cell - ;
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 ;
@ -70,27 +70,10 @@ M: x86-backend %prepare-alien-invoke
temp-reg v>operand 2 cells [+] ds-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 %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 -- )
"flag" operand f v>operand CMP JNE ;
@ -102,7 +85,7 @@ M: x86-backend %jump-t ( label -- )
! x86, this is redundant.
"scratch" operand HEX: ffffffff MOV rc-absolute-cell rel-dispatch
"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 -- )
[
@ -195,7 +178,7 @@ M: x86-backend %unbox-any-c-ptr ( dst src -- )
rs-reg f v>operand CMP
"end" get JE
! 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
! If so, load the offset and add it to the address
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.
USING: arrays generator generator.fixup io.binary kernel
USING: arrays generator.fixup io.binary kernel
combinators kernel.private math namespaces parser sequences
words system ;
IN: cpu.x86.assembler

123
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.
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
big-endian off
1 jit-code-format set
: stack-frame-size 8 bootstrap-cells ;
: scan-save stack-reg 3 bootstrap-cells [+] ;
: stack-frame-size 4 bootstrap-cells ;
[
arg0 arg0 quot-array@ [+] MOV ! load array
scan-reg arg0 scan@ [+] LEA ! initialize scan pointer
] { } make jit-setup set
! Load word
temp-reg 0 [] MOV
! 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
xt-reg PUSH ! save XT
arg0 PUSH ! save array
stack-reg 4 bootstrap-cells SUB ! reserve space for scan-save
] { } make jit-prolog set
: advance-scan scan-reg bootstrap-cell ADD ;
[
advance-scan
ds-reg bootstrap-cell ADD ! increment datastack pointer
arg0 scan-reg [] MOV ! load literal
ds-reg [] arg0 MOV ! store literal on datastack
] { } make jit-push-literal set
[
stack-frame-size PUSH ! save stack frame size
0 PUSH ! push XT
arg1 PUSH ! alignment
] rc-absolute-cell rt-label 6 jit-prolog jit-define
[
advance-scan
[
arg0 0 [] MOV ! load literal
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
[
] rc-absolute-cell rt-literal 2 jit-push-literal jit-define
[
arg1 stack-reg MOV ! pass callstack pointer as arg 2
] { } make jit-word-primitive-jump set
[
arg1 stack-reg bootstrap-cell neg [+] LEA ! pass callstack pointer as arg 2
] { } make jit-word-primitive-call set
[
arg0 scan-reg bootstrap-cell [+] MOV ! load word
arg0 word-xt@ [+] JMP ! jump to word XT
] { } make jit-word-jump set
[
advance-scan
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
(JMP) drop ! go
] rc-relative rt-primitive 3 jit-primitive jit-define
[
(JMP) drop
] rc-relative rt-xt 1 jit-word-jump jit-define
[
(CALL) drop
] rc-relative rt-xt 1 jit-word-call jit-define
[
arg1 0 MOV ! load addr of true quotation
arg0 ds-reg [] MOV ! load boolean
ds-reg bootstrap-cell SUB ! pop boolean
arg0 \ f tag-number CMP ! compare it with f
arg0 scan-reg 2 bootstrap-cells [+] CMOVE ! load false branch if equal
arg0 scan-reg 1 bootstrap-cells [+] CMOVNE ! load true branch if not equal
scan-reg 3 bootstrap-cells ADD ! advance scan pointer
xt-reg arg0 quot-xt@ [+] MOV ! load quotation-xt
;
[
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
arg0 arg1 [] CMOVNE ! load true branch if not equal
arg0 arg1 bootstrap-cell [+] CMOVE ! load false branch if equal
arg0 quot-xt@ [+] JMP ! jump to quotation-xt
] rc-absolute-cell rt-literal 1 jit-if-jump jit-define
[
arg1 0 [] MOV ! load dispatch table
arg0 ds-reg [] MOV ! load index
fixnum>slot@ ! turn it into an array offset
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
xt-reg arg0 quot-xt@ [+] MOV ! load quotation-xt
xt-reg JMP ! execute quotation
] { } make jit-dispatch set
arg0 quot-xt@ [+] JMP ! execute branch
] rc-absolute-cell rt-literal 2 jit-dispatch jit-define
[
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
generator generator.registers generator.fixup sequences.private
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
! Type checks
@ -27,7 +27,7 @@ IN: cpu.x86.intrinsics
! Tag the tag
"x" operand %tag-fixnum
! 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
! If we have equality, load type from header
"x" operand "obj" operand -3 [+] MOV
@ -49,10 +49,10 @@ IN: cpu.x86.intrinsics
! Tag the tag
"x" operand %tag-fixnum
! 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
! 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
"end" get JMP
"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.
{ $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.
{ $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
strings io.styles vectors words system splitting math.parser
tuples continuations continuations.private combinators
generic.math io.streams.duplex classes
generic.math io.streams.duplex classes compiler.units
generic.standard ;
IN: debugger
@ -92,9 +92,6 @@ TUPLE: assert got expect ;
: expired-error. ( obj -- )
"Object did not survive image save/load: " write third . ;
: undefined-word-error. ( obj -- )
"Undefined word: " write third . ;
: io-error. ( error -- )
"I/O error: " write third print ;
@ -150,14 +147,14 @@ PREDICATE: array kernel-error ( obj -- ? )
{
{ [ dup empty? ] [ drop f ] }
{ [ dup first "kernel-error" = not ] [ drop f ] }
{ [ t ] [ second 0 16 between? ] }
{ [ t ] [ second 0 15 between? ] }
} cond ;
: kernel-errors
second {
{ 0 [ expired-error. ] }
{ 1 [ io-error. ] }
{ 2 [ undefined-word-error. ] }
{ 2 [ primitive-error. ] }
{ 3 [ type-check-error. ] }
{ 4 [ divide-by-zero-error. ] }
{ 5 [ signal-error. ] }
@ -171,7 +168,6 @@ PREDICATE: array kernel-error ( obj -- ? )
{ 13 [ retainstack-underflow. ] }
{ 14 [ retainstack-overflow. ] }
{ 15 [ memory-error. ] }
{ 16 [ primitive-error. ] }
} ; inline
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: 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
ARTICLE: "definition-protocol" "Definition protocol"
@ -13,22 +14,58 @@ $nl
{ $subsection uses }
"When a definition is changed, all definitions which depend on it are notified via a hook:"
{ $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 definer }
{ $subsection definition } ;
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."
{ $subsection "definition-protocol" }
ARTICLE: "definition-crossref" "Definition cross referencing"
"A common cross-referencing system is used to track definition usages:"
{ $subsection crossref }
{ $subsection xref }
{ $subsection unxref }
{ $subsection delete-xref }
{ $subsection usage }
"Implementations of the definition protocol include pathnames, words, methods, and help articles."
{ $see-also "source-files" "words" "generic" "help-impl" } ;
{ $subsection usage } ;
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"
@ -43,7 +80,13 @@ HELP: set-where
HELP: forget
{ $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
{ $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
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
@ -34,6 +40,11 @@ M: some-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

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.
IN: definitions
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 )
M: object where drop f ;
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 ;

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.
IN: float-arrays
USING: kernel kernel.private alien sequences
sequences.private math math.private ;
IN: float-arrays
<PRIVATE
@ -30,6 +30,8 @@ M: float-array equal?
over float-array? [ sequence= ] [ 2drop f ] if ;
INSTANCE: float-array sequence
INSTANCE: float-array simple-c-ptr
INSTANCE: float-array c-ptr
: 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 ;

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

@ -64,13 +64,12 @@ SYMBOL: label-table
rot rc-absolute-ppc-2/2 = or or ;
! Relocation types
: rt-primitive 0 ;
: rt-dlsym 1 ;
: rt-literal 2 ;
: rt-dispatch 3 ;
: rt-xt 4 ;
: rt-xt-profiling 5 ;
: rt-label 6 ;
: rt-primitive 0 ;
: rt-dlsym 1 ;
: rt-literal 2 ;
: rt-dispatch 3 ;
: rt-xt 4 ;
: rt-label 6 ;
TUPLE: label-fixup label class ;
@ -127,17 +126,15 @@ SYMBOL: word-table
: rel-dispatch ( word-table# class -- ) rt-dispatch rel-fixup ;
GENERIC# rel-word 1 ( word class -- )
M: primitive rel-word ( word class -- )
>r word-def r> rt-primitive rel-fixup ;
M: word rel-word ( word class -- )
: rel-word ( word class -- )
>r add-word r> rt-xt rel-fixup ;
: rel-literal ( literal class -- )
>r add-literal r> rt-literal rel-fixup ;
: rel-this ( class -- )
0 swap rt-label rel-fixup ;
: init-fixup ( -- )
V{ } clone relocation-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
generator.registers quotations kernel vectors arrays ;
generator.registers quotations kernel vectors arrays effects
sequences ;
IN: generator
ARTICLE: "generator" "Compiled code generator"
@ -13,27 +14,12 @@ $nl
{ $subsection define-if-intrinsic }
{ $subsection define-if-intrinsics }
"The main entry point into the code generator:"
{ $subsection generate }
"Primitive compiler interface exported by the Factor VM:"
{ $subsection add-compiled-block }
{ $subsection finalize-compile } ;
{ $subsection generate } ;
ABOUT: "generator"
HELP: compiled-xts
{ $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." } ;
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: compiled
{ $var-description "During compilation, holds a hashtable mapping words to 5-element arrays holding compiled code." } ;
HELP: compiling-word
{ $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 } "." } ;
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
{ $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." } ;
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" } ")." } ;
HELP: define-intrinsics

114
core/generator/generator.factor
View File

@ -7,18 +7,28 @@ kernel.private layouts math namespaces optimizer prettyprint
quotations sequences system threads words ;
IN: generator
SYMBOL: compiled-xts
SYMBOL: compile-queue
SYMBOL: compiled
: save-xt ( word xt -- )
swap dup unchanged-word compiled-xts get set-at ;
: 5array 3array >r 2array r> append ;
: 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 word-changed? ] [ drop f ] }
{ [ t ] [ compiled? ] }
{ [ dup compiled get key? ] [ drop ] }
{ [ dup primitive? ] [ drop ] }
{ [ dup deferred? ] [ drop ] }
{ [ t ] [ dup compile-queue get set-at ] }
} cond ;
: maybe-compile ( word -- )
dup compiled? [ drop ] [ queue-compile ] if ;
SYMBOL: compiling-word
SYMBOL: compiling-label
@ -26,30 +36,23 @@ SYMBOL: compiling-label
! Label of current word, after prologue, makes recursion faster
SYMBOL: current-label-start
SYMBOL: compiled-stack-traces?
: compiled-stack-traces? ( -- ? ) 36 getenv ;
t compiled-stack-traces? set-global
: init-generator ( -- )
: init-generator ( compiling -- )
V{ } clone literal-table set
V{ } clone word-table set
compiled-stack-traces? get compiling-word get f ?
compiled-stack-traces? swap f ?
literal-table get push ;
: generate-1 ( word label node quot -- )
pick f save-xt [
pick begin-compiling [
roll compiling-word set
pick compiling-label set
init-generator
compiling-word get init-generator
call
literal-table get >array
word-table get >array
] { } make fixup add-compiled-block save-xt ;
: generate-profiler-prologue ( -- )
compiled-stack-traces? get [
compiling-word get %profiler-prologue
] when ;
] { } make fixup finish-compiling ;
GENERIC: generate-node ( node -- next )
@ -59,7 +62,6 @@ GENERIC: generate-node ( node -- next )
: generate ( word label node -- )
[
init-templates
generate-profiler-prologue
%save-word-xt
%prologue-later
current-label-start define-label
@ -67,36 +69,12 @@ GENERIC: generate-node ( node -- next )
[ generate-nodes ] with-node-iterator
] generate-1 ;
: word-dataflow ( word -- dataflow )
: word-dataflow ( word -- effect dataflow )
[
dup "no-effect" word-prop [ no-effect ] when
dup specialized-def over dup 2array 1array infer-quot
finish-word
] with-infer nip ;
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 ;
] with-infer ;
: intrinsics ( #call -- quot )
node-param "intrinsics" word-prop ;
@ -126,24 +104,17 @@ UNION: #terminal
! node
M: node generate-node drop iterate-next ;
: %call ( word -- )
dup primitive? [ %call-primitive ] [ %call-label ] if ;
: %call ( word -- ) %call-label ;
: %jump ( word -- )
{
{ [ dup compiling-label get eq? ] [
drop current-label-start get %jump-label
] }
{ [ dup primitive? ] [
%epilogue-later %jump-primitive
] }
{ [ t ] [
%epilogue-later %jump-label
] }
} cond ;
dup compiling-label get eq? [
drop current-label-start get %jump-label
] [
%epilogue-later %jump-label
] if ;
: generate-call ( label -- next )
dup (compile)
dup maybe-compile
end-basic-block
tail-call? [
%jump f
@ -180,10 +151,6 @@ M: #if generate-node
with-template
generate-if ;
: rel-current-word ( class -- )
compiling-label get add-word
swap rt-xt-profiling rel-fixup ;
! #dispatch
: dispatch-branch ( node word -- label )
gensym [
@ -298,20 +265,3 @@ M: #r> generate-node
! #return
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 -- ? )
phantoms append [
dup cached? [ cached-vreg ] when swap member?
] curry* contains? ;
] with contains? ;
: outputs-clash? ( -- ? )
output-vregs append clash? ;

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

@ -44,7 +44,6 @@ $nl
{ $subsection implementors }
"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 }
"A " { $emphasis "method specifier" } " refers to a method and implements the " { $link "definition-protocol" } ":"
{ $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." }
$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
{ $values { "word" 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
[ "SYMBOL: not-a-class C: not-a-class ;" parse ] unit-test-fails
! Test math-combination
[ [ [ >float ] dip ] ] [ \ real \ float math-upgrade ] unit-test
[ [ >float ] ] [ \ float \ real math-upgrade ] unit-test
@ -184,7 +182,11 @@ M: debug-combination perform-combination
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 ;

24
core/generic/generic.factor
View File

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

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

@ -96,7 +96,7 @@ TUPLE: no-method object generic ;
num-tags get [
vtable-class
[ swap first classes-intersect? ] curry subset
] curry* map ;
] with map ;
: build-type-vtable ( alist-seq -- alist-seq )
dup length [
@ -182,3 +182,7 @@ M: standard-combination dispatch# standard-combination-# ;
M: hook-combination dispatch# drop 0 ;
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 ;
: 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 -- )
[ [ graph get at delete-at ] curry* each ] if-graph ; inline
[ [ graph get at delete-at ] with each ] if-graph ; inline
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
inference.backend kernel sequences kernel.private
combinators combinators.private ;
HELP: recursive-state
{ $var-description "During inference, holds an association list mapping words to labels." } ;
inference.state inference.backend kernel sequences
kernel.private combinators combinators.private ;
HELP: literal-expected
{ $error-description "Thrown when inference encounters a " { $link call } " or " { $link if } " being applied to a value which is not known to be a literal. Such a form can have an arbitrary stack effect, and does not compile." }
{ $notes "This error will be thrown when compiling any combinator, such as " { $link each } ". However, words calling combinators can compile 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
{ $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." } ;
@ -57,7 +51,7 @@ HELP: collect-recursion
{ $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." } ;
HELP: inline-closure
HELP: inline-word
{ $values { "word" word } }
{ $description "Called during inference to infer stack effects of inline words."
$nl

61
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.
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
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-state get at ;
@ -18,10 +18,13 @@ debugger assocs combinators ;
local-recursive-state at ;
: recursive-quotation? ( quot -- ? )
local-recursive-state [ first eq? ] curry* contains? ;
local-recursive-state [ first eq? ] with contains? ;
TUPLE: inference-error rstate major? ;
M: inference-error compiler-warning?
inference-error-major? not ;
: (inference-error) ( ... class important? -- * )
>r construct-boa r>
recursive-state get {
@ -54,14 +57,10 @@ M: object value-literal \ literal-expected inference-warning ;
: ensure-values ( seq -- )
meta-d [ add-inputs ] change d-in [ + ] change ;
SYMBOL: terminated?
: current-effect ( -- effect )
d-in get meta-d get length <effect>
terminated? get over set-effect-terminated? ;
SYMBOL: recorded
: init-inference ( -- )
terminated? off
V{ } clone meta-d set
@ -77,7 +76,7 @@ GENERIC: apply-object ( obj -- )
M: object apply-object apply-literal ;
M: wrapper apply-object wrapped apply-literal ;
M: wrapper apply-object wrapped dup depends-on apply-literal ;
: terminate ( -- )
terminated? on #terminate node, ;
@ -319,7 +318,7 @@ TUPLE: unbalanced-branches-error quots in out ;
] H{ } make-assoc ; inline
: (infer-branches) ( last branches -- list )
[ infer-branch ] curry* map
[ infer-branch ] with map
dup unify-effects unify-dataflow ; inline
: infer-branches ( last branches node -- )
@ -345,10 +344,6 @@ TUPLE: no-effect word ;
: no-effect ( word -- * ) \ no-effect inference-warning ;
GENERIC: infer-word ( word -- effect )
M: word infer-word no-effect ;
TUPLE: effect-error word effect ;
: effect-error ( word effect -- * )
@ -364,17 +359,16 @@ TUPLE: effect-error word effect ;
over recorded get push
"inferred-effect" set-word-prop ;
: infer-compound ( word -- effect )
: infer-word ( word -- effect )
[
init-inference
dup word-def over dup infer-quot-recursive
finish-word
current-effect
] with-scope ;
M: compound infer-word
[ infer-compound ] [ ] [ t "no-effect" set-word-prop ]
cleanup ;
[
init-inference
dependencies off
dup word-def over dup infer-quot-recursive
finish-word
current-effect
] with-scope
] [ ] [ t "no-effect" set-word-prop ] cleanup ;
: custom-infer ( word -- )
#! Customized inference behavior
@ -391,10 +385,6 @@ M: compound infer-word
{ [ t ] [ dup infer-word make-call-node ] }
} cond ;
M: word apply-object apply-word ;
M: symbol apply-object apply-literal ;
TUPLE: recursive-declare-error word ;
: declared-infer ( word -- )
@ -445,7 +435,7 @@ M: #call-label collect-recursion*
[ swap [ at ] curry map ] keep
[ set ] 2each ;
: inline-closure ( word -- )
: inline-word ( word -- )
dup inline-block over recursive-label? [
flatten-meta-d >r
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
] if ;
M: compound apply-object
[
M: word apply-object
dup depends-on [
dup inline-recursive-label
[ declared-infer ] [ inline-closure ] if
[ declared-infer ] [ inline-word ] if
] [
dup recursive-label
[ declared-infer ] [ apply-word ] if
] if-inline ;
M: undefined apply-object
drop "Undefined word" time-bomb ;
: 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
sequences words inference.class quotations alien
alien.c-types strings sbufs sequences.private
slots.private combinators ;
slots.private combinators definitions ;
! Make sure these compile even though this is invalid code
[ ] [ [ 10 mod 3.0 /i ] dataflow optimize drop ] unit-test
@ -14,7 +14,7 @@ slots.private combinators ;
: inlined? ( quot word -- ? )
swap dataflow optimize
[ node-param eq? ] curry* node-exists? not ;
[ node-param eq? ] with node-exists? not ;
GENERIC: mynot ( x -- y )
@ -136,9 +136,15 @@ M: object xyz ;
] set-constraints
] "constraints" set-word-prop
DEFER: blah
[ 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
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
{ $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." } ;
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.
USING: arrays generic assocs kernel math namespaces parser
sequences words vectors math.intervals effects classes
inference.state ;
IN: inference.dataflow
USING: arrays generic assocs kernel math
namespaces parser sequences words vectors math.intervals
effects classes ;
SYMBOL: recursive-state
! Computed value
: <computed> \ <computed> counter ;
@ -30,20 +28,8 @@ TUPLE: composed quot1 quot2 ;
C: <composed> composed
SYMBOL: d-in
SYMBOL: meta-d
SYMBOL: meta-r
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
in-d out-d in-r out-r
classes literals intervals
@ -185,9 +171,6 @@ UNION: #branch #if #dispatch ;
>r r-tail flatten-curries r> set-node-out-r
>r d-tail flatten-curries r> set-node-out-d ;
SYMBOL: dataflow-graph
SYMBOL: current-node
: node, ( node -- )
dataflow-graph get [
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? ;
: calls-label? ( label node -- ? )
[ calls-label* ] curry* node-exists? ;
[ calls-label* ] with node-exists? ;
: recursive-label? ( node -- ? )
dup node-param swap calls-label? ;
@ -287,10 +270,10 @@ SYMBOL: node-stack
swap node-classes at object or ;
: 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 )
dup node-in-d [ node-interval ] curry* map ;
dup node-in-d [ node-interval ] with map ;
: node-class-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
effects inference.dataflow inference.backend
math combinators inference.transforms ;
math combinators inference.transforms inference.state ;
IN: inference
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" } }
{ $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." } ;
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
sequences strings vectors words quotations effects tools.test
continuations generic.standard sorting assocs definitions
prettyprint io inspector bootstrap.image tuples
classes.union classes.predicate debugger bootstrap.image
bootstrap.image.private io.launcher threads.private
io.streams.string combinators.private tools.test.inference ;
prettyprint io inspector tuples classes.union classes.predicate
debugger threads.private io.streams.string combinators.private
tools.test.inference ;
IN: temporary
{ 0 2 } [ 2 "Hello" ] unit-test-effect
@ -352,69 +351,69 @@ DEFER: bar
[ [ 3 [ ] curry 1 2 [ ] 2curry if ] infer ] unit-test-fails
! Test number protocol
{ 2 1 } [ bitor ] unit-test-effect
{ 2 1 } [ bitand ] unit-test-effect
{ 2 1 } [ bitxor ] unit-test-effect
{ 2 1 } [ mod ] unit-test-effect
{ 2 1 } [ /i ] unit-test-effect
{ 2 1 } [ /f ] unit-test-effect
{ 2 2 } [ /mod ] unit-test-effect
{ 2 1 } [ + ] unit-test-effect
{ 2 1 } [ - ] unit-test-effect
{ 2 1 } [ * ] unit-test-effect
{ 2 1 } [ / ] unit-test-effect
{ 2 1 } [ < ] unit-test-effect
{ 2 1 } [ <= ] unit-test-effect
{ 2 1 } [ > ] unit-test-effect
{ 2 1 } [ >= ] unit-test-effect
{ 2 1 } [ number= ] unit-test-effect
\ bitor must-infer
\ bitand must-infer
\ bitxor must-infer
\ mod must-infer
\ /i must-infer
\ /f must-infer
\ /mod must-infer
\ + must-infer
\ - must-infer
\ * must-infer
\ / must-infer
\ < must-infer
\ <= must-infer
\ > must-infer
\ >= must-infer
\ number= must-infer
! Test object protocol
{ 2 1 } [ = ] unit-test-effect
{ 1 1 } [ clone ] unit-test-effect
{ 2 1 } [ hashcode* ] unit-test-effect
\ = must-infer
\ clone must-infer
\ hashcode* must-infer
! Test sequence protocol
{ 1 1 } [ length ] unit-test-effect
{ 2 1 } [ nth ] unit-test-effect
{ 2 0 } [ set-length ] unit-test-effect
{ 3 0 } [ set-nth ] unit-test-effect
{ 2 1 } [ new ] unit-test-effect
{ 2 1 } [ new-resizable ] unit-test-effect
{ 2 1 } [ like ] unit-test-effect
{ 2 0 } [ lengthen ] unit-test-effect
\ length must-infer
\ nth must-infer
\ set-length must-infer
\ set-nth must-infer
\ new must-infer
\ new-resizable must-infer
\ like must-infer
\ lengthen must-infer
! Test assoc protocol
{ 2 2 } [ at* ] unit-test-effect
{ 3 0 } [ set-at ] unit-test-effect
{ 2 1 } [ new-assoc ] unit-test-effect
{ 2 0 } [ delete-at ] unit-test-effect
{ 1 0 } [ clear-assoc ] unit-test-effect
{ 1 1 } [ assoc-size ] unit-test-effect
{ 2 1 } [ assoc-like ] unit-test-effect
{ 2 1 } [ assoc-clone-like ] unit-test-effect
{ 1 1 } [ >alist ] unit-test-effect
\ at* must-infer
\ set-at must-infer
\ new-assoc must-infer
\ delete-at must-infer
\ clear-assoc must-infer
\ assoc-size must-infer
\ assoc-like must-infer
\ assoc-clone-like must-infer
\ >alist must-infer
{ 1 3 } [ [ 2drop f ] assoc-find ] unit-test-effect
! Test some random library words
{ 1 1 } [ 1quotation ] unit-test-effect
{ 1 1 } [ string>number ] unit-test-effect
{ 1 1 } [ get ] unit-test-effect
\ 1quotation must-infer
\ string>number must-infer
\ get must-infer
{ 2 0 } [ push ] unit-test-effect
{ 2 1 } [ append ] unit-test-effect
{ 1 1 } [ peek ] unit-test-effect
\ push must-infer
\ append must-infer
\ peek must-infer
{ 1 1 } [ reverse ] unit-test-effect
{ 2 1 } [ member? ] unit-test-effect
{ 2 1 } [ remove ] unit-test-effect
{ 1 1 } [ natural-sort ] unit-test-effect
\ reverse must-infer
\ member? must-infer
\ remove must-infer
\ natural-sort must-infer
{ 1 0 } [ forget ] unit-test-effect
{ 4 0 } [ define-class ] unit-test-effect
{ 2 0 } [ define-tuple-class ] unit-test-effect
{ 2 0 } [ define-union-class ] unit-test-effect
{ 3 0 } [ define-predicate-class ] unit-test-effect
\ forget must-infer
\ define-class must-infer
\ define-tuple-class must-infer
\ define-union-class must-infer
\ define-predicate-class must-infer
! Test words with continuations
{ 0 0 } [ [ drop ] callcc0 ] unit-test-effect
@ -423,39 +422,36 @@ DEFER: bar
{ 2 1 } [ [ + ] [ 3drop 0 ] recover ] unit-test-effect
! Test stream protocol
{ 2 0 } [ set-timeout ] unit-test-effect
{ 2 1 } [ stream-read ] unit-test-effect
{ 1 1 } [ stream-read1 ] unit-test-effect
{ 1 1 } [ stream-readln ] unit-test-effect
{ 2 2 } [ stream-read-until ] unit-test-effect
{ 2 0 } [ stream-write ] unit-test-effect
{ 2 0 } [ stream-write1 ] unit-test-effect
{ 1 0 } [ stream-nl ] unit-test-effect
{ 1 0 } [ stream-close ] unit-test-effect
{ 3 0 } [ stream-format ] unit-test-effect
{ 3 0 } [ stream-write-table ] unit-test-effect
{ 1 0 } [ stream-flush ] unit-test-effect
{ 2 1 } [ make-span-stream ] unit-test-effect
{ 2 1 } [ make-block-stream ] unit-test-effect
{ 2 1 } [ make-cell-stream ] unit-test-effect
\ set-timeout must-infer
\ stream-read must-infer
\ stream-read1 must-infer
\ stream-readln must-infer
\ stream-read-until must-infer
\ stream-write must-infer
\ stream-write1 must-infer
\ stream-nl must-infer
\ stream-close must-infer
\ stream-format must-infer
\ stream-write-table must-infer
\ stream-flush must-infer
\ make-span-stream must-infer
\ make-block-stream must-infer
\ make-cell-stream must-infer
! Test stream utilities
{ 1 1 } [ lines ] unit-test-effect
{ 1 1 } [ contents ] unit-test-effect
\ lines must-infer
\ contents must-infer
! Test prettyprinting
{ 1 0 } [ . ] unit-test-effect
{ 1 0 } [ short. ] unit-test-effect
{ 1 1 } [ unparse ] unit-test-effect
\ . must-infer
\ short. must-infer
\ unparse must-infer
{ 1 0 } [ describe ] unit-test-effect
{ 1 0 } [ error. ] unit-test-effect
\ describe must-infer
\ error. must-infer
! Test odds and ends
{ 1 1 } [ ' ] unit-test-effect
{ 2 0 } [ write-image ] unit-test-effect
{ 1 1 } [ <process-stream> ] unit-test-effect
{ 0 0 } [ idle-thread ] unit-test-effect
\ idle-thread must-infer
! Incorrect stack declarations on inline recursive words should
! be caught

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

@ -1,9 +1,10 @@
! Copyright (C) 2004, 2007 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
IN: inference
USING: inference.backend inference.dataflow
USING: inference.backend inference.state inference.dataflow
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 )
@ -25,3 +26,6 @@ M: callable dataflow-with
V{ } like meta-d set
f infer-quot
] 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.
! See http://factorcode.org/license.txt for BSD license.
IN: inference.known-words
USING: alien arrays bit-arrays byte-arrays classes
combinators.private continuations.private effects float-arrays
generic hashtables hashtables.private inference.backend
inference.dataflow io io.backend io.files io.files.private
io.streams.c kernel kernel.private math math.private memory
namespaces namespaces.private parser prettyprint quotations
quotations.private sbufs sbufs.private sequences
sequences.private slots.private strings strings.private system
threads.private tuples tuples.private vectors vectors.private
words assocs ;
generic hashtables hashtables.private inference.state
inference.backend inference.dataflow io io.backend io.files
io.files.private io.streams.c kernel kernel.private math
math.private memory namespaces namespaces.private parser
prettyprint quotations quotations.private sbufs sbufs.private
sequences sequences.private slots.private strings
strings.private system threads.private tuples tuples.private
vectors vectors.private words words.private assocs inspector ;
IN: inference.known-words
! Shuffle words
: infer-shuffle-inputs ( shuffle node -- )
@ -79,8 +79,8 @@ M: curried infer-call
M: composed infer-call
infer-uncurry
infer->r peek-d infer-call infer-r>
peek-d infer-call ;
infer->r peek-d infer-call
terminated? get [ infer-r> peek-d infer-call ] unless ;
M: object infer-call
\ literal-expected inference-warning ;
@ -344,8 +344,6 @@ t over set-effect-terminated?
\ <word> { object object } { word } <effect> "inferred-effect" set-word-prop
\ <word> make-flushable
\ update-xt { word } { } <effect> "inferred-effect" set-word-prop
\ word-xt { word } { integer } <effect> "inferred-effect" set-word-prop
\ 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
\ (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.
USING: arrays kernel words sequences generic math namespaces
quotations assocs combinators math.bitfields inference.backend
inference.dataflow tuples.private ;
inference.dataflow inference.state tuples.private ;
IN: inference.transforms
: 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
: >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 ;
: 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
! See http://factorcode.org/license.txt for BSD license.
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
: crc32-polynomial HEX: edb88320 ; inline
! Generate the table at load time and define a new word with it,
! instead of using a variable, so that the compiler can inline
! the call to nth-unsafe
DEFER: crc32-table inline
: crc32-table V{ } ; inline
\ crc32-table
256 [
8 [
dup even? >r 2/ r> [ crc32-polynomial bitxor ] unless
] times >bignum
] map
1quotation define-inline
] map 0 crc32-table copy
: (crc32) ( crc ch -- crc )
>bignum dupd bitxor

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

@ -46,7 +46,7 @@ M: object root-directory? ( path -- ? ) path-separator? ;
[
dup string?
[ tuck path+ directory? 2array ] [ nip ] if
] curry* map
] with map
[ first special-directory? not ] subset ;
: directory ( path -- seq )
@ -143,7 +143,7 @@ HOOK: binary-roots io-backend ( -- seq )
<PRIVATE
: append-path ( path files -- paths )
[ path+ ] curry* map ;
[ path+ ] with map ;
: get-paths ( dir -- paths )
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 ;
M: object init-stdio
stdin stdout <duplex-c-stream> stdio set ;
stdin stdout <duplex-c-stream> stdio set-global ;
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 rot }
{ $subsection -rot }
{ $subsection spin }
{ $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:"
@ -37,7 +38,9 @@ $nl
{ $code
": foo ( m ? n -- m+n/n )"
" >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"
"The following pair of words invoke words and quotations reflectively:"
@ -66,7 +69,7 @@ $nl
{ $subsection curry }
{ $subsection 2curry }
{ $subsection 3curry }
{ $subsection curry* }
{ $subsection with }
{ $subsection compose }
{ $subsection 3compose }
"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: pick ( x y z -- x y z x ) $shuffle ;
HELP: swap ( x y -- y x ) $shuffle ;
HELP: spin $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" } "." }
{ $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 } }
{ $description "Partial application on the left. The following two lines are equivalent:"
{ $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." }
{ $examples
{ $example "2 { 1 2 3 } [ - ] curry* map ." "{ 1 0 -1 }" }
{ $example "2 { 1 2 3 } [ - ] with map ." "{ 1 0 -1 }" }
} ;
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."
} ;
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
{ $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." }

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

@ -102,3 +102,9 @@ IN: temporary
[ 3drop datastack ] unit-test-fails
[ ] [ :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