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

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

db4
Aaron Schaefer 2008-01-06 21:42:40 -05:00
parent 50a3ad54da 4e43b946f9
commit c1103ce735
290 changed files with 5669 additions and 4847 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." } ;

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

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

@ -1,26 +1,28 @@
! 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 ;
generator command-line vocabs io prettyprint libc definitions ;
IN: bootstrap.compiler
"cpu." cpu append require
global [ { "compiler" } add-use ] bind
"-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.
nl
"Compiling some words to speed up bootstrap..." write
! 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 +40,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

66
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

423
core/bootstrap/primitives.factor Normal file → Executable file
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.
IN: bootstrap.primitives
USING: alien arrays byte-arrays generic hashtables
@ -14,13 +14,16 @@ slots classes.union words.private ;
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
@ -75,209 +78,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 +149,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 +314,7 @@ define-builtin
{ "set-word-vocabulary" "words" }
}
{
{ "object" "kernel" }
{ "quotation" "quotations" }
"def"
4
{ "word-def" "words" }
@ -605,5 +406,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" "words.private" }
{ "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

11
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
[
! 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

26
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 ;
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,19 +42,14 @@ IN: bootstrap.stage2
[ get-global " " split [ empty? not ] subset ] 2apply
seq-diff
[ "bootstrap." swap append require ] each
] no-parse-hook
init-io
init-stdio
changed-words get clear-assoc
"compile-errors" "generator" lookup [
f swap set-global
] when*
run-bootstrap-init
"Compiling remaining words..." print
all-words [ compiled? not ] subset recompile-hook get call
] with-compiler-errors
f error set-global
f error-continuation set-global
@ -82,8 +74,8 @@ IN: bootstrap.stage2
[ ] 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

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

8
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 [
@ -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,8 +250,9 @@ 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 ;
: define-class ( word members superclass metaclass -- )

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

@ -1,4 +1,4 @@
USING: help.markup help.syntax ;
USING: help.markup help.syntax help words definitions classes ;
IN: classes.mixin
ARTICLE: "mixins" "Mixin classes"
@ -11,4 +11,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 definitions ;
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 definitions ;
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

2
core/combinators/combinators.factor
View File

@ -63,7 +63,7 @@ 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

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

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

@ -1,93 +1,100 @@
! 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
words.private 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> 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." } ;

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

@ -0,0 +1,56 @@
! Copyright (C) 2007 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 set-at
] [ 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 -- ? )
: (: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

197
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
\ x-2 word-xt
\ xy [ 1 ] define-compound
{ x-1 } compile
[ ] [ recompile ] unit-test
\ x-2 word-xt eq?
] unit-test
] with-variable
[ 1 ] [ yx ] unit-test
] when
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

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

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
;

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

@ -134,7 +134,7 @@ M: ppc-backend %jump-t ( label -- )
"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" } } }
@ -295,7 +295,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 +333,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

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

@ -6,7 +6,7 @@ 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?
] }
@ -14,4 +14,4 @@ namespaces alien.c-types kernel system combinators ;
T{ ppc-backend } compiler-backend set-global
6 cells set-profiler-prologues
6 cells profiler-prologue set-global

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

23
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 ;
@ -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

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

@ -1,103 +1,78 @@
! Copyright (C) 2007 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 vocabs math generator.fixup
compiler.constants ;
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 ;
0 PUSH ! push XT
arg1 PUSH ! alignment
] rc-absolute-cell rt-xt 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 literal
ds-reg [] arg0 MOV ! store literal on datastack
] { } make jit-push-literal set
[
advance-scan
ds-reg bootstrap-cell ADD ! increment datastack pointer
arg0 scan-reg [] MOV ! load wrapper
arg0 dup wrapper@ [+] MOV ! load wrapper-obj slot
ds-reg [] arg0 MOV ! store literal on datastack
] { } make jit-push-wrapper set
] 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
(JMP) drop ! go
] rc-relative rt-primitive 3 jit-primitive jit-define
[
arg1 stack-reg bootstrap-cell neg [+] LEA ! pass callstack pointer as arg 2
] { } make jit-word-primitive-call set
(JMP) drop
] rc-relative rt-xt 1 jit-word-jump jit-define
[
arg0 scan-reg bootstrap-cell [+] MOV ! load word
arg0 word-xt@ [+] JMP ! jump to word XT
] { } make jit-word-jump set
(CALL) drop
] rc-relative rt-xt 1 jit-word-call jit-define
[
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
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

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

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

@ -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,16 @@ 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 summary
drop "Defining a word outside of a compilation unit" ;

115
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 ;
IN: definitions
ARTICLE: "definition-protocol" "Definition protocol"
@ -13,22 +14,73 @@ $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: "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 } ;
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 +95,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" } }
@ -82,3 +140,42 @@ HELP: delete-xref
{ $description "Remove the vertex which represents the definition from the " { $link crossref } " graph." }
{ $notes "This word is called before a word is forgotten." }
{ $see-also forget } ;
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." } ;

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

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

@ -1,7 +1,7 @@
! Copyright (C) 2006, 2007 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
IN: definitions
USING: kernel sequences namespaces assocs graphs ;
USING: kernel sequences namespaces assocs graphs continuations ;
GENERIC: where ( defspec -- loc )
@ -43,3 +43,61 @@ M: object redefined* drop ;
: delete-xref ( defspec -- )
dup unxref crossref get delete-at ;
GENERIC: update-methods ( class -- )
SYMBOL: changed-words
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 ;
TUPLE: no-compilation-unit word ;
: no-compilation-unit ( word -- * )
\ no-compilation-unit construct-boa throw ;
: changed-word ( word -- )
dup changed-words get
[ no-compilation-unit ] unless*
set-at ;
: with-compilation-unit ( quot -- )
[
H{ } clone changed-words set
<definitions> new-definitions set
<definitions> old-definitions set
[ changed-words get keys recompile-hook get call ]
[ ] cleanup
] with-scope ; inline

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 ;

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

@ -127,12 +127,7 @@ 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 -- )

26
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 } "." } ;
@ -69,7 +55,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

102
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
@ -30,26 +40,21 @@ SYMBOL: compiled-stack-traces?
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? get 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 +64,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 +71,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 +106,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? ] [
dup compiling-label get eq? [
drop current-label-start get %jump-label
] }
{ [ dup primitive? ] [
%epilogue-later %jump-primitive
] }
{ [ t ] [
] [
%epilogue-later %jump-label
] }
} cond ;
] if ;
: generate-call ( label -- next )
dup (compile)
dup maybe-compile
end-basic-block
tail-call? [
%jump f
@ -298,20 +271,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 ;

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 ;

18
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 -- )
@ -111,6 +105,4 @@ M: class forget ( class -- )
forget-word ;
M: class update-methods ( class -- )
[ drop ]
[ class-usages implementors* [ make-generic ] each ]
if-bootstrapping ;
class-usages implementors* [ make-generic ] each ;

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

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

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

49
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 ;
@ -22,6 +22,9 @@ debugger assocs combinators ;
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, ;
@ -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
dependencies off
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 ;
] 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 )
[
[

12
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
@ -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." } ;

25
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

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 )

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

14
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:"
@ -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 ;
@ -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

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

@ -6,6 +6,8 @@ IN: kernel
: version ( -- str ) "0.92" ; foldable
! Stack stuff
: spin ( x y z -- z y x ) swap rot ; inline
: roll ( x y z t -- y z t x ) >r rot r> swap ; inline
: -roll ( x y z t -- t x y z ) swap >r -rot r> ; inline
@ -49,7 +51,7 @@ DEFER: if
: 3slip ( quot x y z -- x y z ) >r >r >r call r> r> r> ; inline
: dip ( obj callable -- obj ) swap slip ; inline
: dip ( obj quot -- obj ) swap slip ; inline
: keep ( x quot -- x ) over slip ; inline
@ -157,4 +159,6 @@ GENERIC: construct-boa ( ... class -- tuple )
: declare ( spec -- ) drop ;
: do-primitive ( number -- ) "Improper primitive call" throw ;
PRIVATE>

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

@ -23,9 +23,9 @@ HELP: type-number
{ $description "Outputs the built-in type number instances of " { $link class } ". Will output " { $link f } " if this is not a built-in class." }
{ $see-also builtin-class } ;
HELP: tag-header
{ $values { "n" "a built-in type number" } { "tagged" integer } }
{ $description "Outputs the header for objects of type " { $snippet "n" } "." } ;
HELP: tag-fixnum
{ $values { "n" integer } { "tagged" integer } }
{ $description "Outputs a tagged fixnum." } ;
HELP: first-bignum
{ $values { "n" "smallest positive integer not representable by a fixnum" } } ;

2
core/layouts/layouts.factor Normal file → Executable file
View File

@ -21,7 +21,7 @@ SYMBOL: type-numbers
: type-number ( class -- n )
type-numbers get at ;
: tag-header ( n -- tagged )
: tag-fixnum ( n -- tagged )
tag-bits get shift ;
: first-bignum ( -- n )

4
core/listener/listener-docs.factor Normal file → Executable file
View File

@ -20,7 +20,7 @@ $nl
"The following variables can be rebound inside a nested scope to customize the behavior of a listener; this can be done to create a development tool with a custom interaction loop:"
{ $subsection listener-hook }
"Finally, the multi-line expression reading word can be used independently of the rest of the listener:"
{ $subsection parse-interactive } ;
{ $subsection read-quot } ;
ABOUT: "listener"
@ -30,7 +30,7 @@ HELP: quit-flag
HELP: listener-hook
{ $var-description "Variable holding a quotation called by the listener before reading an input expression. The UI sets this variable to a quotation which updates the stack display in a listener gadget." } ;
HELP: parse-interactive
HELP: read-quot
{ $values { "stream" "an input stream" } { "quot/f" "a parsed quotation, or " { $link f } " indicating end of file" } }
{ $description "Reads a Factor expression from the stream, possibly spanning more than line. Additional lines of input are read while the parser stack height is greater than one. Since structural parsing words push partial quotations on the stack, this will keep on reading input until all delimited parsing words are terminated." } ;

35
core/listener/listener-tests.factor Normal file → Executable file
View File

@ -1,15 +1,17 @@
USING: io io.streams.string listener tools.test parser
math namespaces continuations vocabs ;
USING: io io.streams.string io.streams.duplex listener
tools.test parser math namespaces continuations vocabs kernel ;
IN: temporary
: hello "Hi" print ; parsing
: parse-interactive ( string -- quot )
<string-reader> stream-read-quot ;
[ [ ] ] [
"USE: temporary hello" <string-reader> parse-interactive
"USE: temporary hello" parse-interactive
] unit-test
[
file-vocabs
"debugger" use+
[ [ \ + 1 2 3 4 ] ]
@ -17,20 +19,27 @@ IN: temporary
[
"cont" set
[
"\\ + 1 2 3 4"
<string-reader>
parse-interactive "cont" get continue-with
"\\ + 1 2 3 4" parse-interactive
"cont" get continue-with
] catch
":1" eval
"USE: debugger :1" eval
] callcc1
] unit-test
] with-scope
] with-file-vocabs
[ ] [ "vocabs.loader.test.c" forget-vocab ] unit-test
[ ] [
"vocabs.loader.test.c" forget-vocab
] unit-test
[
"USE: vocabs.loader.test.c" <string-reader>
parse-interactive
"USE: vocabs.loader.test.c" parse-interactive
] unit-test-fails
[ ] [ "vocabs.loader.test.c" forget-vocab ] unit-test
[ ] [
"vocabs.loader.test.c" forget-vocab
] unit-test
[ ] [
"IN: temporary : hello\n\"world\" ;" parse-interactive
drop
] unit-test

36
core/listener/listener.factor Normal file → Executable file
View File

@ -3,7 +3,7 @@
USING: arrays hashtables io kernel math memory namespaces
parser sequences strings io.styles io.streams.lines
io.streams.duplex vectors words generic system combinators
tuples continuations debugger ;
tuples continuations debugger definitions ;
IN: listener
SYMBOL: quit-flag
@ -12,31 +12,34 @@ SYMBOL: listener-hook
[ ] listener-hook set-global
GENERIC: parse-interactive ( stream -- quot/f )
GENERIC: stream-read-quot ( stream -- quot/f )
: parse-interactive-step ( lines -- quot/f )
[ parse-lines ] catch {
: parse-lines-interactive ( lines -- quot/f )
[ parse-lines in get ] with-compilation-unit in set ;
: read-quot-step ( lines -- quot/f )
[ parse-lines-interactive ] catch {
{ [ dup delegate unexpected-eof? ] [ 2drop f ] }
{ [ dup not ] [ drop ] }
{ [ t ] [ rethrow ] }
} cond ;
: parse-interactive-loop ( stream accum -- quot/f )
: read-quot-loop ( stream accum -- quot/f )
over stream-readln dup [
over push
dup parse-interactive-step dup
[ 2nip ] [ drop parse-interactive-loop ] if
dup read-quot-step dup
[ 2nip ] [ drop read-quot-loop ] if
] [
3drop f
] if ;
M: line-reader parse-interactive
[
V{ } clone parse-interactive-loop in get
] with-scope in set ;
M: line-reader stream-read-quot
V{ } clone read-quot-loop ;
M: duplex-stream parse-interactive
duplex-stream-in parse-interactive ;
M: duplex-stream stream-read-quot
duplex-stream-in stream-read-quot ;
: read-quot ( -- quot ) stdio get stream-read-quot ;
: bye ( -- ) quit-flag on ;
@ -46,9 +49,7 @@ M: duplex-stream parse-interactive
: listen ( -- )
listener-hook get call prompt.
[
stdio get parse-interactive [ call ] [ bye ] if*
] try ;
[ read-quot [ call ] [ bye ] if* ] try ;
: until-quit ( -- )
quit-flag get
@ -60,7 +61,6 @@ M: duplex-stream parse-interactive
" on " write os write "/" write cpu print ;
: listener ( -- )
print-banner
[ use [ clone ] change until-quit ] with-scope ;
print-banner [ until-quit ] with-interactive-vocabs ;
MAIN: listener

10
core/math/math-docs.factor
View File

@ -322,15 +322,17 @@ HELP: fp-nan?
{ $values { "x" real } { "?" "a boolean" } }
{ $description "Tests if " { $snippet "x" } " is an IEEE Not-a-Number value. While " { $snippet "x" } " can be any real number, this word will only ever yield true if " { $snippet "x" } " is a " { $link float } "." } ;
HELP: real ( z -- x )
HELP: real-part ( z -- x )
{ $values { "z" number } { "x" real } }
{ $description "Outputs the real part of a complex number. This acts as the identity on real numbers." }
{ $class-description "The class of real numbers, which is a disjoint union of rationals and floats." } ;
{ $description "Outputs the real part of a complex number. This acts as the identity on real numbers." } ;
HELP: imaginary ( z -- y )
HELP: imaginary-part ( z -- y )
{ $values { "z" number } { "y" real } }
{ $description "Outputs the imaginary part of a complex number. This outputs zero for real numbers." } ;
HELP: real
{ $class-description "The class of real numbers, which is a disjoint union of rationals and floats." } ;
HELP: number
{ $class-description "The class of numbers." } ;

2
core/memory/memory-tests.factor Normal file → Executable file
View File

@ -4,6 +4,8 @@ IN: temporary
TUPLE: testing x y z ;
[ save-image-and-exit ] unit-test-fails
[ ] [
num-types get [
type>class [

136
core/parser/parser-docs.factor
View File

@ -121,6 +121,8 @@ $nl
{ $code ": hello \"Hello world\" print ; parsing" }
"Parsing words must have stack effect " { $snippet "( accum -- accum )" } ", where " { $snippet "accum" } " is the accumulator vector supplied by the parser. Parsing words can read input, add word definitions to the dictionary, and do anything an ordinary word can."
$nl
"Parsing words cannot be called from the same source file where they are defined, because new definitions are only compiled at the end of the source file. An attempt to use a parsing word in its own source file raises an error:"
{ $link staging-violation }
"Tools for implementing parsing words:"
{ $subsection "reading-ahead" }
{ $subsection "parsing-word-nest" }
@ -154,44 +156,11 @@ ARTICLE: "parser-files" "Parsing source files"
{ $subsection parse-file }
{ $subsection bootstrap-file }
"The parser cross-references source files and definitions. This allows it to keep track of removed definitions, and prevent forward references and accidental redefinitions."
$nl
"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 }
{ $see-also "source-files" } ;
ARTICLE: "parser-usage" "Reflective parser usage"
"The parser can be called on a string:"
{ $subsection eval }
{ $subsection parse }
{ $subsection parse-fresh }
"The parser can also parse from a stream:"
{ $subsection parse-stream } ;
@ -204,7 +173,8 @@ $nl
{ $subsection "parser-usage" }
"The parser can be extended."
{ $subsection "parsing-words" }
{ $subsection "parser-lexer" } ;
{ $subsection "parser-lexer" }
{ $see-also "definitions" "definition-checking" } ;
ABOUT: "parser"
@ -229,23 +199,7 @@ HELP: <lexer>
HELP: location
{ $values { "loc" "a " { $snippet "{ path line# }" } " pair" } }
{ $description "Outputs the current parser location. This value can be passed to " { $link set-where } " or " { $link (save-location) } "." } ;
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: redefinition?
{ $values { "definition" "a definition specifier" } { "?" "a boolean" } }
{ $description "Tests if this definition is already present in the current source file." }
$parsing-note ;
HELP: (save-location)
{ $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 } "." } ;
{ $description "Outputs the current parser location. This value can be passed to " { $link set-where } " or " { $link remember-definition } "." } ;
HELP: save-location
{ $values { "definition" "a definition specifier" } }
@ -264,15 +218,6 @@ HELP: next-line
{ $values { "lexer" lexer } }
{ $description "Advances the lexer to the next input line, discarding the remainder of the current line." } ;
HELP: file
{ $var-description "Stores the " { $link source-file } " being parsed. The " { $link source-file-path } " of this object comes from the input parameter to " { $link parse-stream } "." } ;
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: parse-error
{ $error-description "Thrown when the parser encounters invalid input. A parse error wraps an underlying error and holds the file being parsed, line number, and column number." } ;
@ -352,7 +297,7 @@ HELP: still-parsing?
HELP: use
{ $var-description "A variable holding the current vocabulary search path as a sequence of assocs." } ;
{ use in use+ (use+) set-use set-in POSTPONE: USING: POSTPONE: USE: file-vocabs } related-words
{ use in use+ (use+) set-use set-in POSTPONE: USING: POSTPONE: USE: with-file-vocabs with-interactive-vocabs } related-words
HELP: in
{ $var-description "A variable holding the name of the current vocabulary for new definitions." } ;
@ -417,11 +362,6 @@ HELP: search
{ $description "Searches for a word by name in the current vocabulary search path. If no such word could be found, throws a " { $link no-word } " error. If the search path does not contain a word with this name but other vocabularies do, the error will have restarts offering to add vocabularies to the search path." }
$parsing-note ;
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: scan-word
{ $values { "word/number/f" "a word, number or " { $link f } } }
{ $description "Reads the next token from parser input. If the token is a valid number literal, it is converted to a number, otherwise the dictionary is searched for a word named by the token. Outputs " { $link f } " if the end of the input has been reached." }
@ -495,7 +435,7 @@ $parsing-note ;
HELP: parse-literal
{ $values { "accum" vector } { "end" word } { "quot" "a quotation with stack effect " { $snippet "( seq -- obj )" } } }
{ $description "Parses objects from parser input until " { $snippet "end" } ", applies the quotation to the resulting sequence, and adds the output value to the accumulator." }
{ $examples "This word is used to implement " { $link POSTPONE: C{ } "." }
{ $examples "This word is used to implement " { $link POSTPONE: [ } "." }
$parsing-note ;
HELP: parse-definition
@ -507,38 +447,19 @@ $parsing-note ;
HELP: bootstrap-syntax
{ $var-description "Only set during bootstrap. Stores a copy of the " { $link vocab-words } " of the host's syntax vocabulary; this allows the host's parsing words to be used during bootstrap source parsing, not the target's." } ;
HELP: file-vocabs
{ $description "Installs the initial the vocabulary search path for parsing a file. This consists of the " { $snippet "syntax" } " vocabulary together with the " { $snippet "scratchpad" } " vocabulary." } ;
HELP: parse
{ $values { "str" string } { "quot" quotation } }
{ $description "Parses Factor source code from a string. The current vocabulary search path is used." }
{ $errors "Throws a parse error if the input is malformed." } ;
HELP: with-file-vocabs
{ $values { "quot" quotation } }
{ $description "Calls the quotation in a scope with the initial the vocabulary search path for parsing a file. This consists of the " { $snippet "syntax" } " vocabulary together with the " { $snippet "scratchpad" } " vocabulary." } ;
HELP: parse-fresh
{ $values { "lines" "a sequence of strings" } { "quot" quotation } }
{ $description "Parses Factor source code in a sequence of lines. The initial vocabulary search path is used (see " { $link file-vocabs } ")." }
{ $description "Parses Factor source code in a sequence of lines. The initial vocabulary search path is used (see " { $link with-file-vocabs } ")." }
{ $errors "Throws a parse error if the input is malformed." } ;
HELP: eval
{ $values { "str" string } }
{ $description "Parses Factor source code from a string, and calls the resulting quotation. The current vocabulary search path is used." }
{ $errors "Throws an error if the input is malformed, or if the quotation throws an error." } ;
HELP: parse-hook
{ $var-description "A quotation called by " { $link parse-stream } " after parsing the input stream. The default value recompiles new word definitions; see " { $link "recompile" } " for details." } ;
{ parse-hook no-parse-hook } related-words
HELP: no-parse-hook
{ $values { "quot" "a quotation" } }
{ $description "Runs the quotation in a new dynamic scope where " { $link parse-hook } " is set to " { $link f } ", then calls the outer " { $link parse-hook } " after the quotation returns. This has the effect of postponing any recompilation to the end of a quotation." } ;
HELP: start-parsing
{ $values { "stream" "an input stream" } { "name" "a pathname string" } }
{ $description "Prepares to parse a source file by reading the entire contents of the stream and setting some variables. The pathname identifies the stream for cross-referencing purposes." }
{ $errors "Throws an I/O error if there was an error reading from the stream." }
{ $notes "This is one of the factors of " { $link parse-stream } "." } ;
{ $description "Parses Factor source code from a string, and calls the resulting quotation." }
{ $errors "Throws an error if the input is malformed, or if the evaluation itself throws an error." } ;
HELP: outside-usages
{ $values { "seq" "a sequence of definitions" } { "usages" "an association list mapping definitions to sequences of definitions" } }
@ -555,18 +476,11 @@ HELP: smudged-usage
HELP: forget-smudged
{ $description "Forgets removed definitions and prints a warning message if any of them are still referenced from other source files." } ;
HELP: record-definitions
{ $values { "file" source-file } }
{ $description "Records that all " { $link new-definitions } " were defined in " { $snippet "file" } "." } ;
HELP: finish-parsing
{ $values { "quot" "the quotation just parsed" } }
{ $description "Records information to the current " { $link file } " and prints warnings about any removed definitions which are still in use." }
{ $notes "This is one of the factors of " { $link parse-stream } "." } ;
HELP: undo-parsing
{ $description "Records information to the current " { $link file } " after an incomplete parse which ended with an error." } ;
HELP: parse-stream
{ $values { "stream" "an input stream" } { "name" "a file name for error reporting and cross-referencing" } { "quot" quotation } }
{ $description "Parses Factor source code read from the stream. The initial vocabulary search path is used." }
@ -586,28 +500,16 @@ HELP: ?run-file
{ $values { "path" "a pathname string" } }
{ $description "If the file exists, runs it with " { $link run-file } ", otherwise does nothing." } ;
HELP: reload
{ $values { "defspec" "a definition specifier" } }
{ $description "Reloads the source file containing the definition." }
{ $examples
"Reloading a word definition:"
{ $code "\\ foo reload" }
"A word's documentation:"
{ $code "\\ foo >link reload" }
"A method definition:"
{ $code "{ editor draw-gadget* } reload" }
"A help article:"
{ $code "\"handbook\" >link reload" }
} ;
HELP: bootstrap-file
{ $values { "path" "a pathname string" } }
{ $description "If bootstrapping, parses the source file and adds its top level form to the quotation being constructed with " { $link make } "; the bootstrap code uses this to build up a boot quotation to be run on image startup. If not bootstrapping, just runs the file normally." } ;
HELP: ?bootstrap-file
{ $values { "path" "a pathname string" } }
{ $description "If the file exists, loads it with " { $link bootstrap-file } ", otherwise does nothing." } ;
HELP: eval>string
{ $values { "str" string } { "output" string } }
{ $description "Evaluates the Factor code in " { $snippet "str" } " with the " { $link stdio } " stream rebound to a string output stream, then outputs the resulting string." } ;
HELP: staging-violation
{ $values { "word" word } }
{ $description "Throws a " { $link staging-violation } " error." }
{ $error-description "Thrown by the parser if a parsing word is used in the same compilation unit as where it was defined; see " { $link "compilation-units" } "." }
{ $notes "One possible workaround is to use the " { $link POSTPONE: << } " word to execute code at parse time. However, executing words defined in the same source file at parse time is still prohibited." } ;

136
core/parser/parser-tests.factor Normal file → Executable file
View File

@ -5,8 +5,6 @@ sorting tuples ;
IN: temporary
[
file-vocabs
[ 1 CHAR: a ]
[ 0 "abcd" next-char ] unit-test
@ -19,46 +17,46 @@ IN: temporary
[ 6 CHAR: \s ]
[ 0 "\\u0020hello" next-char ] unit-test
[ [ 1 [ 2 [ 3 ] 4 ] 5 ] ]
[ "1\n[\n2\n[\n3\n]\n4\n]\n5" parse ]
[ 1 [ 2 [ 3 ] 4 ] 5 ]
[ "1\n[\n2\n[\n3\n]\n4\n]\n5" eval ]
unit-test
[ [ t t f f ] ]
[ "t t f f" parse ]
[ t t f f ]
[ "t t f f" eval ]
unit-test
[ [ "hello world" ] ]
[ "\"hello world\"" parse ]
[ "hello world" ]
[ "\"hello world\"" eval ]
unit-test
[ [ "\n\r\t\\" ] ]
[ "\"\\n\\r\\t\\\\\"" parse ]
[ "\n\r\t\\" ]
[ "\"\\n\\r\\t\\\\\"" eval ]
unit-test
[ "hello world" ]
[
"IN: temporary : hello \"hello world\" ;"
parse call "USE: scratchpad hello" eval
eval "USE: temporary hello" eval
] unit-test
[ ]
[ "! This is a comment, people." parse call ]
[ "! This is a comment, people." eval ]
unit-test
! Test escapes
[ [ " " ] ]
[ "\"\\u0020\"" parse ]
[ " " ]
[ "\"\\u0020\"" eval ]
unit-test
[ [ "'" ] ]
[ "\"\\u0027\"" parse ]
[ "'" ]
[ "\"\\u0027\"" eval ]
unit-test
[ "\\u123" parse ] unit-test-fails
[ "\\u123" eval ] unit-test-fails
! Test EOL comments in multiline strings.
[ [ "Hello" ] ] [ "#! This calls until-eol.\n\"Hello\"" parse ] unit-test
[ "Hello" ] [ "#! This calls until-eol.\n\"Hello\"" eval ] unit-test
[ word ] [ \ f class ] unit-test
@ -80,7 +78,7 @@ IN: temporary
[ \ baz "declared-effect" word-prop effect-terminated? ]
unit-test
[ [ ] ] [ "IN: temporary USE: math : effect-parsing-test ( a b -- d ) - ;" parse ] unit-test
[ ] [ "IN: temporary USE: math : effect-parsing-test ( a b -- d ) - ;" eval ] unit-test
[ t ] [
"effect-parsing-test" "temporary" lookup
@ -90,7 +88,7 @@ IN: temporary
[ T{ effect f { "a" "b" } { "d" } f } ]
[ \ effect-parsing-test "declared-effect" word-prop ] unit-test
[ [ ] ] [ "IN: temporary : effect-parsing-test ;" parse ] unit-test
[ ] [ "IN: temporary : effect-parsing-test ;" eval ] unit-test
[ f ] [ \ effect-parsing-test "declared-effect" word-prop ] unit-test
@ -100,14 +98,9 @@ IN: temporary
[ "IN: temporary : missing-- ( a b ) ;" eval ] unit-test-fails
! These should throw errors
[ "HEX: zzz" parse ] unit-test-fails
[ "OCT: 999" parse ] unit-test-fails
[ "BIN: --0" parse ] unit-test-fails
[ f ] [
"IN: temporary : foo ; TUPLE: foo ;" parse drop
"foo" "temporary" lookup symbol?
] unit-test
[ "HEX: zzz" eval ] unit-test-fails
[ "OCT: 999" eval ] unit-test-fails
[ "BIN: --0" eval ] unit-test-fails
! Another funny bug
[ t ] [
@ -116,8 +109,7 @@ IN: temporary
{ "scratchpad" "arrays" } set-use
[
! This shouldn't modify in/use in the outer scope!
file-vocabs
] with-scope
] with-file-vocabs
use get { "scratchpad" "arrays" } set-use use get =
] with-scope
@ -126,13 +118,13 @@ IN: temporary
"IN: temporary USING: math prettyprint ; : foo 2 2 + . ; parsing" eval
[ [ ] ] [ "USE: temporary foo" parse ] unit-test
[ ] [ "USE: temporary foo" eval ] unit-test
"IN: temporary USING: math prettyprint ; : foo 2 2 + . ;" eval
[ t ] [
"USE: temporary foo" parse
first "foo" "temporary" lookup eq?
"USE: temporary \\ foo" eval
"foo" "temporary" lookup eq?
] unit-test
! Test smudging
@ -141,7 +133,7 @@ IN: temporary
"IN: temporary : smudge-me ;" <string-reader> "foo"
parse-stream drop
"foo" source-file source-file-definitions assoc-size
"foo" source-file source-file-definitions first assoc-size
] unit-test
[ t ] [ "smudge-me" "temporary" lookup >boolean ] unit-test
@ -158,21 +150,21 @@ IN: temporary
"IN: temporary USING: math strings ; GENERIC: smudge-me M: integer smudge-me ; M: string smudge-me ;" <string-reader> "foo"
parse-stream drop
"foo" source-file source-file-definitions assoc-size
"foo" source-file source-file-definitions first assoc-size
] unit-test
[ 1 ] [
"IN: temporary USING: arrays ; M: array smudge-me ;" <string-reader> "bar"
parse-stream drop
"bar" source-file source-file-definitions assoc-size
"bar" source-file source-file-definitions first assoc-size
] unit-test
[ 2 ] [
"IN: temporary USING: math strings ; GENERIC: smudge-me M: integer smudge-me ;" <string-reader> "foo"
parse-stream drop
"foo" source-file source-file-definitions assoc-size
"foo" source-file source-file-definitions first assoc-size
] unit-test
[ t ] [
@ -217,7 +209,7 @@ IN: temporary
[ t ] [
[
"IN: temporary : x ; : y 3 throw ; parsing y"
"IN: temporary : x ; : y 3 throw ; this is an error"
<string-reader> "a" parse-stream
] catch parse-error?
] unit-test
@ -323,24 +315,80 @@ IN: temporary
<string-reader> "removing-the-predicate" parse-stream
] catch [ redefine-error? ] is?
] unit-test
] with-scope
[ t ] [
[
"IN: temporary TUPLE: class-redef-test ; TUPLE: class-redef-test ;"
<string-reader> "redefining-a-class-1" parse-stream
] catch [ redefine-error? ] is?
] unit-test
[ ] [
"IN: temporary TUPLE: class-redef-test ; SYMBOL: class-redef-test"
<string-reader> "redefining-a-class-2" parse-stream drop
] unit-test
[ t ] [
[
"IN: temporary TUPLE: class-redef-test ; SYMBOL: class-redef-test : class-redef-test ;"
<string-reader> "redefining-a-class-3" parse-stream drop
] catch [ redefine-error? ] is?
] unit-test
[ ] [
"IN: temporary TUPLE: class-fwd-test ;"
<string-reader> "redefining-a-class-3" parse-stream drop
] unit-test
[ t ] [
[
"IN: temporary \\ class-fwd-test"
<string-reader> "redefining-a-class-3" parse-stream drop
] catch [ forward-error? ] is?
] unit-test
[ ] [
"IN: temporary TUPLE: class-fwd-test ; SYMBOL: class-fwd-test"
<string-reader> "redefining-a-class-3" parse-stream drop
] unit-test
[ t ] [
[
"IN: temporary \\ class-fwd-test"
<string-reader> "redefining-a-class-3" parse-stream drop
] catch [ forward-error? ] is?
] unit-test
[ t ] [
[
"IN: temporary : foo ; TUPLE: foo ;"
<string-reader> "redefining-a-class-4" parse-stream drop
] catch [ redefine-error? ] is?
] unit-test
] with-file-vocabs
[
: FILE file get parsed ; parsing
FILE file set
<< file get parsed >> file set
: ~a ;
: ~b ~a ;
: ~c ;
: ~d ;
H{ { ~a ~a } { ~c ~c } { ~d ~d } } old-definitions set
{ H{ { ~a ~a } { ~c ~c } { ~d ~d } } H{ } } old-definitions set
H{ { ~d ~d } } new-definitions set
{ H{ { ~d ~d } } H{ } } new-definitions set
[ V{ ~b } { ~a } { ~a ~c } ] [
smudged-usage
natural-sort
] unit-test
] with-scope
[ ] [
"IN: temporary USE: kernel PREDICATE: object foo ( x -- y ) ;" eval
] unit-test
[ t ] [
"foo?" "temporary" lookup word eq?
] unit-test

222
core/parser/parser.factor Normal file → Executable file
View File

@ -5,11 +5,9 @@ namespaces prettyprint sequences strings vectors words
quotations inspector io.styles io combinators sorting
splitting math.parser effects continuations debugger
io.files io.streams.string io.streams.lines vocabs
source-files classes hashtables ;
source-files classes hashtables compiler.errors ;
IN: parser
SYMBOL: file
TUPLE: lexer text line column ;
: <lexer> ( text -- lexer ) 1 0 lexer construct-boa ;
@ -21,29 +19,11 @@ TUPLE: lexer text line column ;
file get lexer get lexer-line 2dup and
[ >r source-file-path r> 2array ] [ 2drop f ] if ;
SYMBOL: old-definitions
SYMBOL: new-definitions
TUPLE: redefine-error def ;
M: redefine-error error.
"Re-definition of " write
redefine-error-def . ;
: redefine-error ( definition -- )
\ redefine-error construct-boa
{ { "Continue" t } } throw-restarts drop ;
: redefinition? ( definition -- ? )
dup class? [ drop f ] [ new-definitions get key? ] if ;
: (save-location) ( definition loc -- )
over redefinition? [ over redefine-error ] when
over set-where
dup new-definitions get dup [ set-at ] [ 3drop ] if ;
: save-location ( definition -- )
location (save-location) ;
location remember-definition ;
: save-class-location ( class -- )
location remember-class ;
SYMBOL: parser-notes
@ -119,7 +99,8 @@ M: lexer skip-word ( lexer -- )
TUPLE: bad-escape ;
: bad-escape ( -- * ) \ bad-escape construct-empty throw ;
: bad-escape ( -- * )
\ bad-escape construct-empty throw ;
M: bad-escape summary drop "Bad escape code" ;
@ -238,7 +219,9 @@ PREDICATE: unexpected unexpected-eof
: CREATE ( -- word ) scan create-in ;
: CREATE-CLASS ( -- word )
scan create-in dup predicate-word save-location ;
scan in get create
dup save-class-location
dup predicate-word dup set-word save-location ;
: word-restarts ( possibilities -- restarts )
natural-sort [
@ -255,18 +238,6 @@ M: no-word summary
swap words-named word-restarts throw-restarts
dup word-vocabulary (use+) ;
: forward-reference? ( word -- ? )
dup old-definitions get key?
swap new-definitions get key? not and ;
TUPLE: forward-error word ;
M: forward-error error.
"Forward reference to " write forward-error-word . ;
: forward-error ( word -- )
\ forward-error construct-boa throw ;
: check-forward ( str word -- word )
dup forward-reference? [
drop
@ -284,12 +255,27 @@ M: forward-error error.
: scan-word ( -- word/number/f )
scan dup [ dup string>number [ ] [ search ] ?if ] when ;
TUPLE: staging-violation word ;
: staging-violation ( word -- * )
\ staging-violation construct-boa throw ;
M: staging-violation summary
drop
"A parsing word cannot be used in the same file it is defined in." ;
: execute-parsing ( word -- )
new-definitions get [
dupd first key? [ staging-violation ] when
] when*
execute ;
: parse-step ( accum end -- accum ? )
scan-word {
{ [ 2dup eq? ] [ 2drop f ] }
{ [ dup not ] [ drop unexpected-eof t ] }
{ [ dup delimiter? ] [ unexpected t ] }
{ [ dup parsing? ] [ nip execute t ] }
{ [ dup parsing? ] [ nip execute-parsing t ] }
{ [ t ] [ pick push drop t ] }
} cond ;
@ -353,17 +339,58 @@ M: bad-number summary
SYMBOL: bootstrap-syntax
: file-vocabs ( -- )
: with-file-vocabs ( quot -- )
[
"scratchpad" in set
{ "syntax" "scratchpad" } set-use
bootstrap-syntax get [ use get push ] when* ;
bootstrap-syntax get [ use get push ] when*
call
] with-scope ; inline
: with-interactive-vocabs ( quot -- )
[
"scratchpad" in set
{
"arrays"
"assocs"
"combinators"
"compiler.errors"
"continuations"
"debugger"
"definitions"
"editors"
"generic"
"help"
"inspector"
"io"
"io.files"
"kernel"
"listener"
"math"
"memory"
"namespaces"
"prettyprint"
"sequences"
"slicing"
"sorting"
"strings"
"syntax"
"tools.annotations"
"tools.crossref"
"tools.memory"
"tools.profiler"
"tools.test"
"tools.time"
"vocabs"
"vocabs.loader"
"words"
"scratchpad"
} set-use
call
] with-scope ; inline
: parse-fresh ( lines -- quot )
[ file-vocabs parse-lines ] with-scope ;
SYMBOL: parse-hook
: do-parse-hook ( -- ) parse-hook get [ call ] when* ;
[ parse-lines ] with-file-vocabs ;
: parsing-file ( file -- )
"quiet" get [
@ -372,18 +399,6 @@ SYMBOL: parse-hook
"Loading " write <pathname> . flush
] if ;
: no-parse-hook ( quot -- )
>r f parse-hook r> with-variable do-parse-hook ; inline
: start-parsing ( stream name -- )
H{ } clone new-definitions set
dup [
source-file
dup file set
source-file-definitions clone old-definitions set
] [ drop ] if
contents \ contents set ;
: smudged-usage-warning ( usages removed -- )
parser-notes? [
"Warning: the following definitions were removed from sources," print
@ -407,9 +422,12 @@ SYMBOL: parse-hook
file get source-file-path =
] assoc-subset ;
: removed-definitions ( -- definitions )
new-definitions old-definitions
[ get first2 union ] 2apply diff ;
: smudged-usage ( -- usages referenced removed )
new-definitions get old-definitions get diff filter-moved
keys [
removed-definitions filter-moved keys [
outside-usages
[ empty? swap pathname? or not ] assoc-subset
dup values concat prune swap keys
@ -419,43 +437,33 @@ SYMBOL: parse-hook
smudged-usage forget-all
over empty? [ 2dup smudged-usage-warning ] unless 2drop ;
: record-definitions ( file -- )
new-definitions get swap set-source-file-definitions ;
: finish-parsing ( quot -- )
file get dup [
: finish-parsing ( contents quot -- )
file get
[ record-form ] keep
[ record-modified ] keep
[ \ contents get record-checksum ] keep
record-definitions
forget-smudged
] [
2drop
] if ;
: undo-parsing ( -- )
file get [
dup source-file-definitions new-definitions get union
swap set-source-file-definitions
] when* ;
[ record-definitions ] keep
record-checksum ;
: parse-stream ( stream name -- quot )
[
[
start-parsing
\ contents get string-lines parse-fresh
dup finish-parsing
] [ ] [ undo-parsing ] cleanup
] no-parse-hook ;
contents
dup string-lines parse-fresh
tuck finish-parsing
forget-smudged
] with-source-file
] with-compilation-unit ;
: parse-file-restarts ( file -- restarts )
"Load " swap " again" 3append t 2array 1array ;
: parse-file ( file -- quot )
[
[
[ parsing-file ] keep
[ ?resource-path <file-reader> ] keep
parse-stream
] with-compiler-errors
] [
over parse-file-restarts rethrow-restarts
drop parse-file
@ -464,59 +472,17 @@ SYMBOL: parse-hook
: run-file ( file -- )
[ [ parse-file call ] keep ] assert-depth drop ;
: reload ( defspec -- )
where first [ run-file ] when* ;
: ?run-file ( path -- )
dup ?resource-path exists? [ run-file ] [ drop ] if ;
: bootstrap-file ( path -- )
[
parse-file [ call ] curry %
] [
run-file
] if-bootstrapping ;
[ parse-file % ] [ run-file ] if-bootstrapping ;
: ?bootstrap-file ( path -- )
dup ?resource-path exists? [ bootstrap-file ] [ drop ] if ;
: parse ( str -- quot ) string-lines parse-lines ;
: eval ( str -- ) parse call ;
: eval ( str -- )
[ string-lines parse-fresh ] with-compilation-unit call ;
: eval>string ( str -- output )
[
parser-notes off
[ [ eval ] keep ] try drop
] string-out ;
global [
{
"scratchpad"
"arrays"
"assocs"
"combinators"
"compiler"
"continuations"
"debugger"
"definitions"
"generic"
"inspector"
"io"
"kernel"
"math"
"memory"
"namespaces"
"parser"
"prettyprint"
"sequences"
"slicing"
"sorting"
"strings"
"syntax"
"vocabs"
"vocabs.loader"
"words"
} set-use
"scratchpad" set-in
] bind

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