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

Makefile

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

core/alien/alien-docs.factor

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

core/alien/alien.factor

@@ -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
+! These mixins are not intended to be extended by user code.
-    simple-alien byte-array bit-array float-array POSTPONE: f ;
+! They are not unions, because if they were we'd have a circular
+! dependency between alien and {byte,bit,float}-arrays.
+MIXIN: simple-c-ptr
+INSTANCE: simple-alien simple-c-ptr
+INSTANCE: f simple-c-ptr
+
+MIXIN: c-ptr
+INSTANCE: alien c-ptr
+INSTANCE: f c-ptr
 
 DEFER: pinned-c-ptr?
 
@@ -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 global [ H{ } assoc-like ] change-at
-    libraries [ H{ } assoc-like ] change
-] bind
 
 TUPLE: library path abi dll ;
 

core/alien/c-types/c-types.factor

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

core/alien/compiler/compiler.factor

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

core/alien/syntax/syntax-docs.factor

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

core/alien/syntax/syntax.factor

@@ -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
+USING: arrays alien alien.c-types alien.structs alien.arrays
-namespaces parser sequences words quotations math.parser
+kernel math namespaces parser sequences words quotations
-splitting effects prettyprint prettyprint.sections
+math.parser splitting effects prettyprint prettyprint.sections
 prettyprint.backend assocs combinators ;
 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*

core/arrays/arrays-docs.factor

@@ -1,6 +1,5 @@
-USING: byte-arrays bit-arrays help.markup help.syntax
+USING: help.markup help.syntax
-kernel kernel.private prettyprint strings sbufs vectors
+kernel kernel.private prettyprint sequences.private ;
-quotations sequences.private ;
 IN: arrays
 
 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." } ;

core/bit-arrays/bit-arrays.factor

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

core/bootstrap/compiler/compiler.factor

@@ -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
+nl
-! compile-all. This set of words was determined
+"Compiling some words to speed up bootstrap..." write
-! semi-empirically using the profiler. It improves
+
-! bootstrap time significantly, because frequenly
+! Compile a set of words ahead of the full compile.
-! called words which are also quick to compile
+! This set of words was determined semi-empirically
-! are replaced by compiled definitions as soon as
+! using the profiler. It improves bootstrap time
-! possible.
+! 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

core/bootstrap/image/image-tests.factor

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

core/bootstrap/image/image.factor

@@ -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-primitive-word
-SYMBOL: jit-word-primitive-call
+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 23 }
-        { jit-prolog 24 }
+        { jit-primitive-word 24 }
-        { jit-word-primitive-jump 25 }
+        { jit-primitive 25 }
-        { jit-word-primitive-call 26 }
+        { jit-word-jump 26 }
-        { jit-word-jump 27 }
+        { jit-word-call 27 }
-        { jit-word-call 28 }
+        { jit-push-literal 28 }
-        { jit-push-wrapper 29 }
+        { jit-if-word 29 }
-        { jit-push-literal 30 }
+        { jit-if-jump 30 }
-        { jit-if-word 31 }
+        { jit-dispatch-word 31 }
-        { jit-if-jump 32 }
+        { jit-dispatch 32 }
-        { jit-if-call 33 }
+        { jit-epilog 33 }
-        { jit-dispatch-word 34 }
+        { jit-return 34 }
-        { jit-dispatch 35 }
+        { jit-profiling 35 }
-        { jit-epilog 36 }
+        { undefined-quot 37 }
-        { jit-return 37 }
     } at header-size + ;
 
 : 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-primitive-word
-        jit-word-primitive-call
+        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

core/bootstrap/primitives.factor

@@ -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 ;
+! Builtin classes
-
-{
-    { "(execute)" "words.private" }
-    { "(call)" "kernel.private" }
-    { "uncurry" "kernel.private" }
-    { "string>sbuf" "sbufs.private" }
-    { "bignum>fixnum" "math.private" }
-    { "float>fixnum" "math.private" }
-    { "fixnum>bignum" "math.private" }
-    { "float>bignum" "math.private" }
-    { "fixnum>float" "math.private" }
-    { "bignum>float" "math.private" }
-    { "<ratio>" "math.private" }
-    { "string>float" "math.private" }
-    { "float>string" "math.private" }
-    { "float>bits" "math" }
-    { "double>bits" "math" }
-    { "bits>float" "math" }
-    { "bits>double" "math" }
-    { "<complex>" "math.private" }
-    { "fixnum+" "math.private" }
-    { "fixnum+fast" "math.private" }
-    { "fixnum-" "math.private" }
-    { "fixnum-fast" "math.private" }
-    { "fixnum*" "math.private" }
-    { "fixnum*fast" "math.private" }
-    { "fixnum/i" "math.private" }
-    { "fixnum-mod" "math.private" }
-    { "fixnum/mod" "math.private" }
-    { "fixnum-bitand" "math.private" }
-    { "fixnum-bitor" "math.private" }
-    { "fixnum-bitxor" "math.private" }
-    { "fixnum-bitnot" "math.private" }
-    { "fixnum-shift" "math.private" }
-    { "fixnum<" "math.private" }
-    { "fixnum<=" "math.private" }
-    { "fixnum>" "math.private" }
-    { "fixnum>=" "math.private" }
-    { "bignum=" "math.private" }
-    { "bignum+" "math.private" }
-    { "bignum-" "math.private" }
-    { "bignum*" "math.private" }
-    { "bignum/i" "math.private" }
-    { "bignum-mod" "math.private" }
-    { "bignum/mod" "math.private" }
-    { "bignum-bitand" "math.private" }
-    { "bignum-bitor" "math.private" }
-    { "bignum-bitxor" "math.private" }
-    { "bignum-bitnot" "math.private" }
-    { "bignum-shift" "math.private" }
-    { "bignum<" "math.private" }
-    { "bignum<=" "math.private" }
-    { "bignum>" "math.private" }
-    { "bignum>=" "math.private" }
-    { "bignum-bit?" "math.private" }
-    { "bignum-log2" "math.private" }
-    { "byte-array>bignum" "math" }
-    { "float=" "math.private" }
-    { "float+" "math.private" }
-    { "float-" "math.private" }
-    { "float*" "math.private" }
-    { "float/f" "math.private" }
-    { "float-mod" "math.private" }
-    { "float<" "math.private" }
-    { "float<=" "math.private" }
-    { "float>" "math.private" }
-    { "float>=" "math.private" }
-    { "<word>" "words" }
-    { "update-xt" "words" }
-    { "word-xt" "words" }
-    { "drop" "kernel" }
-    { "2drop" "kernel" }
-    { "3drop" "kernel" }
-    { "dup" "kernel" }
-    { "2dup" "kernel" }
-    { "3dup" "kernel" }
-    { "rot" "kernel" }
-    { "-rot" "kernel" }
-    { "dupd" "kernel" }
-    { "swapd" "kernel" }
-    { "nip" "kernel" }
-    { "2nip" "kernel" }
-    { "tuck" "kernel" }
-    { "over" "kernel" }
-    { "pick" "kernel" }
-    { "swap" "kernel" }
-    { ">r" "kernel" }
-    { "r>" "kernel" }
-    { "eq?" "kernel" }
-    { "getenv" "kernel.private" }
-    { "setenv" "kernel.private" }
-    { "(stat)" "io.files.private" }
-    { "(directory)" "io.files.private" }
-    { "data-gc" "memory" }
-    { "code-gc" "memory" }
-    { "gc-time" "memory" }
-    { "save-image" "memory" }
-    { "save-image-and-exit" "memory" }
-    { "datastack" "kernel" }
-    { "retainstack" "kernel" }
-    { "callstack" "kernel" }
-    { "set-datastack" "kernel" }
-    { "set-retainstack" "kernel" }
-    { "set-callstack" "kernel" }
-    { "exit" "system" }
-    { "data-room" "memory" }
-    { "code-room" "memory" }
-    { "os-env" "system" }
-    { "millis" "system" }
-    { "type" "kernel.private" }
-    { "tag" "kernel.private" }
-    { "cwd" "io.files" }
-    { "cd" "io.files" }
-    { "add-compiled-block" "generator" }
-    { "dlopen" "alien" }
-    { "dlsym" "alien" }
-    { "dlclose" "alien" }
-    { "<byte-array>" "byte-arrays" }
-    { "<bit-array>" "bit-arrays" }
-    { "<displaced-alien>" "alien" }
-    { "alien-signed-cell" "alien" }
-    { "set-alien-signed-cell" "alien" }
-    { "alien-unsigned-cell" "alien" }
-    { "set-alien-unsigned-cell" "alien" }
-    { "alien-signed-8" "alien" }
-    { "set-alien-signed-8" "alien" }
-    { "alien-unsigned-8" "alien" }
-    { "set-alien-unsigned-8" "alien" }
-    { "alien-signed-4" "alien" }
-    { "set-alien-signed-4" "alien" }
-    { "alien-unsigned-4" "alien" }
-    { "set-alien-unsigned-4" "alien" }
-    { "alien-signed-2" "alien" }
-    { "set-alien-signed-2" "alien" }
-    { "alien-unsigned-2" "alien" }
-    { "set-alien-unsigned-2" "alien" }
-    { "alien-signed-1" "alien" }
-    { "set-alien-signed-1" "alien" }
-    { "alien-unsigned-1" "alien" }
-    { "set-alien-unsigned-1" "alien" }
-    { "alien-float" "alien" }
-    { "set-alien-float" "alien" }
-    { "alien-double" "alien" }
-    { "set-alien-double" "alien" }
-    { "alien-cell" "alien" }
-    { "set-alien-cell" "alien" }
-    { "alien>char-string" "alien" }
-    { "string>char-alien" "alien" }
-    { "alien>u16-string" "alien" }
-    { "string>u16-alien" "alien" }
-    { "(throw)" "kernel.private" }
-    { "string>memory" "alien" }
-    { "memory>string" "alien" }
-    { "alien-address" "alien" }
-    { "slot" "slots.private" }
-    { "set-slot" "slots.private" }
-    { "char-slot" "strings.private" }
-    { "set-char-slot" "strings.private" }
-    { "resize-array" "arrays" }
-    { "resize-string" "strings" }
-    { "(hashtable)" "hashtables.private" }
-    { "<array>" "arrays" }
-    { "begin-scan" "memory" }
-    { "next-object" "memory" }
-    { "end-scan" "memory" }
-    { "size" "memory" }
-    { "die" "kernel" }
-    { "finalize-compile" "generator" }
-    { "fopen" "io.streams.c" }
-    { "fgetc" "io.streams.c" }
-    { "fread" "io.streams.c" }
-    { "fwrite" "io.streams.c" }
-    { "fflush" "io.streams.c" }
-    { "fclose" "io.streams.c" }
-    { "<wrapper>" "kernel" }
-    { "(clone)" "kernel" }
-    { "array>vector" "vectors.private" }
-    { "<string>" "strings" }
-    { "(>tuple)" "tuples.private" }
-    { "array>quotation" "quotations.private" }
-    { "quotation-xt" "quotations" }
-    { "<tuple>" "tuples.private" }
-    { "tuple>array" "tuples" }
-    { "profiling" "tools.profiler.private" }
-    { "become" "kernel.private" }
-    { "(sleep)" "threads.private" }
-    { "<float-array>" "float-arrays" }
-    { "curry" "kernel" }
-    { "<tuple-boa>" "tuples.private" }
-	{ "class-hash" "kernel.private" }
-    { "callstack>array" "kernel" }
-    { "innermost-frame-quot" "kernel.private" }
-    { "innermost-frame-scan" "kernel.private" }
-    { "set-innermost-frame-quot" "kernel.private" }
-    { "call-clear" "kernel" }
-    { "strip-compiled-quotations" "quotations" }
-    { "(os-envs)" "system" }
-}
-dup length [ >r first2 r> make-primitive ] 2each
-
-! Okay, now we have primitives fleshed out. Bring up the generic
-! word system.
 : builtin-predicate ( class predicate -- )
     [
         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

core/bootstrap/stage1.factor

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

core/bootstrap/stage2.factor

@@ -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,18 +42,13 @@ IN: bootstrap.stage2
         [ get-global " " split [ empty? not ] subset ] 2apply
         seq-diff
         [ "bootstrap." swap append require ] each
-    ] no-parse-hook
 
-    init-io
+        run-bootstrap-init
-    init-stdio
 
-    changed-words get clear-assoc
+        "Compiling remaining words..." print
 
-    "compile-errors" "generator" lookup [
+        all-words [ compiled? not ] subset recompile-hook get call
-        f swap set-global
+    ] with-compiler-errors
-    ] when*
-
-    run-bootstrap-init
 
     f error set-global
     f error-continuation set-global
@@ -76,14 +68,14 @@ IN: bootstrap.stage2
         ] set-boot-quot
 
         : count-words all-words swap subset length pprint ;
-    
+
         [ compiled? ] count-words " compiled words" print
         [ symbol? ] count-words " symbol words" print
         [ ] count-words " words total" print
 
         "Bootstrapping is complete." print
-        "Now, you can run ./factor -i=" write
+        "Now, you can run Factor:" print
-        "output-image" get print flush
+        vm write " -i=" write "output-image" get print flush
 
         "output-image" get resource-path save-image-and-exit
     ] if

core/bootstrap/syntax.factor

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

core/byte-arrays/byte-arrays-docs.factor

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

core/byte-arrays/byte-arrays.factor

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

core/classes/classes-docs.factor

@@ -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" }

core/classes/classes-tests.factor

@@ -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
+[ t ] [ \ generic \ word class< ] unit-test
-[ f ] [ \ compound \ generic class< ] unit-test
+[ f ] [ \ word \ generic class< ] unit-test
 
 [ f ] [ \ reversed \ slice class< ] unit-test
 [ f ] [ \ 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
+"IN: temporary USE: math USE: arrays UNION: union-1 rational array ;" eval
-
-do-parse-hook
 
 [ 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
+"IN: temporary USE: math PREDICATE: integer union-1 even? ;" eval
-
-do-parse-hook
 
 [ 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

core/classes/classes.factor

@@ -27,8 +27,7 @@ PREDICATE: class tuple-class
 
 : predicate-effect 1 { "?" } <effect> ;
 
-PREDICATE: compound predicate
+PREDICATE: word predicate "predicating" word-prop >boolean ;
-    "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 -- )

core/classes/mixin/mixin-docs.factor

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

core/classes/mixin/mixin.factor

@@ -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
+    [ 2drop ] [ [ add ] change-mixin-class ] if-mixin-member? ;
-    2dup members memq? [
+
-        2drop
+: remove-mixin-instance ( class mixin -- )
-    ] [
+    [ [ swap remove ] change-mixin-class ] [ 2drop ] if-mixin-member? ;
-        [ members swap bootstrap-word add ] keep swap
+
-        redefine-mixin-class
+! Definition protocol implementation ensures that removing an
-    ] if ;
+! INSTANCE: declaration from a source file updates the mixin.
+TUPLE: mixin-instance loc class mixin ;
+
+M: mixin-instance equal?
+    {
+        { [ over mixin-instance? not ] [ f ] }
+        { [ 2dup [ mixin-instance-class ] 2apply = not ] [ f ] }
+        { [ 2dup [ mixin-instance-mixin ] 2apply = not ] [ f ] }
+        { [ t ] [ t ] }
+    } cond 2nip ;
+
+M: mixin-instance hashcode*
+    { mixin-instance-class mixin-instance-mixin } get-slots
+    2array hashcode* ;
+
+: <mixin-instance> ( class mixin -- definition )
+    { set-mixin-instance-class set-mixin-instance-mixin }
+    mixin-instance construct ;
+
+M: mixin-instance where mixin-instance-loc ;
+
+M: mixin-instance set-where set-mixin-instance-loc ;
+
+M: mixin-instance definer drop \ INSTANCE: f ;
+
+M: mixin-instance definition drop f ;
+
+M: mixin-instance forget
+    dup mixin-instance-class
+    swap mixin-instance-mixin dup mixin-class?
+    [ remove-mixin-instance ] [ 2drop ] if ;

core/classes/predicate/predicate-docs.factor

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

core/classes/union/union-docs.factor

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

core/combinators/combinators.factor

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

core/compiler/compiler-docs.factor

@@ -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 recompile-all }
-{ $subsection no-parse-hook } ;
+"Removing a word's optimized definition:"
+{ $subsection decompile }
+"The optimizing compiler can also compile and call a single quotation:"
+{ $subsection compile-call } ;
 
 ARTICLE: "compiler" "Optimizing compiler"
 "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:"
+"The optimizing compiler only compiles words which have a static stack effect. This means that methods defined on fundamental generic words such as " { $link nth } " should have a static stack effect; for otherwise, most of the system would be compiled with the non-optimizing compiler. See " { $link "inference" } " and " { $link "cookbook-pitfalls" } "."
-{ $list
-    { "The optimizing compiler only compiles words which have a static stack effect. This means that methods defined on fundamental generic words such as " { $link nth } " should have a static stack effect; for otherwise, most of the system would be compiled with the non-optimizing compiler. See " { $link "inference" } " and " { $link "cookbook-pitfalls" } "." }
-    { "The optimizing compiler performs " { $emphasis "early binding" } "; if a compiled word " { $snippet "A" } " calls another compiled word " { $snippet "B" } " and " { $snippet "B" } " is subsequently redefined, the compiled definition of " { $snippet "A" } " will still refer to the earlier compiled definition of " { $snippet "B" } ", until " { $snippet "A" } " explicitly recompiled." }
-}
 { $subsection "compiler-usage" }
-{ $subsection "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."
+{ $description "Compiles a set of words. Ignores words which are already compiled." } ;
-$nl
-"The compiler remembers which words failed to compile as an optimization, so that it does not try to infer the stack effect of words which do not have one over and over again." }
-{ $notes "Usually this word does not need to be called directly; if a word failed to compile because of a stack effect error, fixing the word definition clears the flag automatically. However, if words failed to compile due to external factors which were subsequently rectified, such as an unavailable C library or a missing or broken compiler transform, this flag can be cleared for all words:"
-{ $code "all-words forget-errors" }
-"Subsequent invocations of the compiler will consider all words for compilation." } ;
 
-HELP: compile-batch
+HELP: recompile
 { $values { "seq" "a sequence of words" } }
-{ $description "Compiles a batch of words. Any compile errors are summarized at the end and can be viewed with " { $link :warnings } " and " { $link :errors } "." } ;
+{ $description "Compiles a set of words. Re-compiles words which are already compiled." } ;
 
-{ :errors (:errors) :warnings (:warnings) } related-words
+HELP: compile-call
-
-HELP: compile-vocabs
-{ $values { "seq" "a sequence of strings" } }
-{ $description "Compiles all words which have not been compiled yet from the given vocabularies." } ;
-
-HELP: compile-quot
-{ $values { "quot" "a quotation" } { "word" "a new, uninterned word" } }
-{ $description "Creates a new uninterned word having the given quotation as its definition, and compiles it. The returned word can be passed to " { $link execute } "." }
-{ $errors "Throws an error if the stack effect of the quotation cannot be inferred." } ;
-
-HELP: compile-1
 { $values { "quot" "a quotation" } }
 { $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
+HELP: decompile
-{ $var-description "Global variable holding words which need to be recompiled. Implemented as a hashtable where a key equals its value. This hashtable is updated by " { $link define } " when words are redefined, and inspected and cleared by " { $link recompile } "." } ;
-
-HELP: compile-begins
 { $values { "word" word } }
-{ $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." } ;

core/compiler/compiler.factor

@@ -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
+inference.state generator debugger math.parser prettyprint words
-vocabs assocs alien.compiler ;
+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 -- )
+compiled-crossref global [ H{ } assoc-like ] change-at
-    batch-mode get [
-        2array compile-errors get push
-    ] [
-        "quiet" get [ drop ] [ print-error flush ] if drop
-    ] if ;
 
-: begin-batch ( seq -- )
+: compiled-xref ( word dependencies -- )
-    batch-mode on
+    2dup "compiled-uses" set-word-prop
-    "quiet" get [ drop ] [
+    compiled-crossref get add-vertex ;
-        [ "Compiling " % length # " words..." % ] "" make
-        print flush
-    ] if
-    V{ } clone compile-errors set-global ;
 
-: compile-error. ( pair -- )
+: compiled-unxref ( word -- )
-    nl
+    dup "compiled-uses" word-prop
-    "While compiling " write dup first pprint ": " print
+    compiled-crossref get remove-vertex ;
-    nl
-    second print-error ;
 
-: (:errors) ( -- seq )
+: compiled-usage ( word -- seq )
-    compile-errors get-global
+    compiled-crossref get at keys ;
-    [ second inference-error-major? ] subset ;
 
-: :errors (:errors) [ compile-error. ] each ;
+: sensitive? ( word -- ? )
+    dup "inline" word-prop
+    over "infer" word-prop
+    pick "specializer" word-prop
+    roll generic?
+    or or or ;
 
-: (:warnings) ( -- seq )
+: compiled-usages ( words -- seq )
-    compile-errors get-global
+    compiled-crossref get [
-    [ second inference-error-major? not ] subset ;
+        [
+            over dup set
+            over sensitive?
+            [ at namespace swap update ] [ 2drop ] if
+        ] curry each
+    ] H{ } make-assoc keys ;
 
-: :warnings (:warnings) [ compile-error. ] each ;
+: ripple-up ( word -- )
+    compiled-usage [ queue-compile ] each ;
 
-: end-batch ( -- )
+: save-effect ( word effect -- )
-    batch-mode off
+    over "compiled-uses" word-prop [
-    "quiet" get [
+        2dup swap "compiled-effect" word-prop =
-        "Compile finished." print
+        [ over ripple-up ] unless
-        nl
+    ] when
-        ":errors - print " write (:errors) length pprint
+    "compiled-effect" set-word-prop ;
-        " compiler errors." print
-        ":warnings - print " write (:warnings) length pprint
-        " compiler warnings." print
-        nl
-    ] unless ;
 
-: compile ( word -- )
+: finish-compile ( word effect dependencies -- )
-    H{ } clone [
+    >r dupd save-effect r> over compiled-unxref compiled-xref ;
-        compiled-xts [ (compile) ] with-variable
+
-    ] keep >alist finalize-compile ;
+: 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) ( word -- )
-    [ compile ] [ compile-failed ] recover ;
+    [ dup compile-succeeded finish-compile ]
+    [ dupd compile-failed f save-effect ]
+    recover ;
 
-: forget-errors ( seq -- )
+: delete-any ( assoc -- element )
-    [ f "no-effect" set-word-prop ] each ;
+    [ [ 2drop t ] assoc-find 2drop dup ] keep delete-at ;
 
-: compile-batch ( seq -- )
+: compile-loop ( assoc -- )
-    dup empty? [
+    dup assoc-empty? [ drop ] [
-        drop
+        dup delete-any (compile)
-    ] [
+        yield
-        dup begin-batch
+        compile-loop
-        dup forget-errors
-        [ try-compile ] each
-        end-batch
     ] if ;
 
-: compile-vocabs ( seq -- ) [ words ] map concat compile-batch ;
+: recompile ( words -- )
+    [
+        H{ } clone compile-queue set
+        H{ } clone compiled set
+        [ queue-compile ] each
+        compile-queue get compile-loop
+        compiled get >alist modify-code-heap
+    ] with-scope ; inline
 
-: compile-all ( -- ) vocabs compile-vocabs ;
+: compile ( words -- )
+    [ compiled? not ] subset recompile ;
 
-: compile-quot ( quot -- word ) define-temp dup compile ;
+: compile-call ( quot -- )
-
+    H{ } clone changed-words
-: compile-1 ( quot -- ) compile-quot execute ;
+    [ define-temp dup 1array compile ] with-variable
-
+    execute ;
-: recompile ( -- )
-    changed-words get [
-        dup keys compile-batch clear-assoc
-    ] when* ;
 
 : recompile-all ( -- )
-    all-words [ changed-word ] each recompile ;
+    [ all-words recompile ] with-compiler-errors ;
+
+: decompile ( word -- )
+    f 2array 1array modify-code-heap ;

core/compiler/constants/constants.factor

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

core/compiler/errors/errors-docs.factor

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

core/compiler/errors/errors.factor

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

core/compiler/test/alien.factor

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

core/compiler/test/curry.factor

@@ -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-call ] unit-test
-[ 3 ] [ [ 5 [ 2 - ] curry call ] compile-1 ] unit-test
+[ 3 ] [ [ 5 [ 2 - ] curry call ] compile-call ] unit-test
-[ 3 ] [ [ 5 2 [ - ] 2curry call ] compile-1 ] unit-test
+[ 3 ] [ [ 5 2 [ - ] 2curry call ] compile-call ] unit-test
-[ 3 ] [ 5 [ 2 [ - ] 2curry call ] compile-1 ] unit-test
+[ 3 ] [ 5 [ 2 [ - ] 2curry call ] compile-call ] unit-test
-[ 3 ] [ 5 2 [ [ - ] 2curry call ] compile-1 ] unit-test
+[ 3 ] [ 5 2 [ [ - ] 2curry call ] compile-call ] unit-test
-[ 3 ] [ 5 2 [ [ - ] 2curry 9 swap call /i ] compile-1 ] unit-test
+[ 3 ] [ 5 2 [ [ - ] 2curry 9 swap call /i ] compile-call ] unit-test
-[ 3 ] [ 5 2 [ [ - ] 2curry >r 9 r> call /i ] compile-1 ] unit-test
+[ 3 ] [ 5 2 [ [ - ] 2curry >r 9 r> call /i ] compile-call ] unit-test
 
-[ -10 -20 ] [ 10 20 -1 [ [ * ] curry 2apply ] compile-1 ] unit-test
+[ -10 -20 ] [ 10 20 -1 [ [ * ] curry 2apply ] compile-call ] unit-test
 
-[ [ 5 2 - ] ] [ 5 [ [ 2 - ] curry ] compile-1 >quotation ] unit-test
+[ [ 5 2 - ] ] [ 5 [ [ 2 - ] curry ] compile-call >quotation ] unit-test
-[ [ 5 2 - ] ] [ [ 5 [ 2 - ] curry ] compile-1 >quotation ] unit-test
+[ [ 5 2 - ] ] [ [ 5 [ 2 - ] curry ] compile-call >quotation ] unit-test
-[ [ 5 2 - ] ] [ [ 5 2 [ - ] 2curry ] compile-1 >quotation ] unit-test
+[ [ 5 2 - ] ] [ [ 5 2 [ - ] 2curry ] compile-call >quotation ] unit-test
-[ [ 5 2 - ] ] [ 5 [ 2 [ - ] 2curry ] compile-1 >quotation ] unit-test
+[ [ 5 2 - ] ] [ 5 [ 2 [ - ] 2curry ] compile-call >quotation ] unit-test
-[ [ 5 2 - ] ] [ 5 2 [ [ - ] 2curry ] compile-1 >quotation ] unit-test
+[ [ 5 2 - ] ] [ 5 2 [ [ - ] 2curry ] compile-call >quotation ] unit-test
 
 [ [ 6 2 + ] ]
 [
     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-call ] unit-test
-[ { 6 7 8 } ] [ { 1 2 3 } [ 5 [ + ] curry map ] compile-1 ] unit-test
+[ { 6 7 8 } ] [ { 1 2 3 } [ 5 [ + ] curry map ] compile-call ] unit-test
 
 : funky-assoc>map
     [
@@ -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

core/compiler/test/float.factor

@@ -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
+[ 5.0 ] [ [ 5.0 ] compile-call data-gc data-gc data-gc ] unit-test
-[ 2.0 3.0 ] [ 3.0 [ 2.0 swap ] compile-1 ] unit-test
+[ 2.0 3.0 ] [ 3.0 [ 2.0 swap ] compile-call ] unit-test
 
-[ 1 2 3 4.0 ] [ [ 1 2 3 4.0 ] compile-1 ] unit-test
+[ 1 2 3 4.0 ] [ [ 1 2 3 4.0 ] compile-call ] unit-test
 
-[ 3.0 1 2 3 ] [ 1.0 2.0 [ float+ 1 2 3 ] compile-1 ] unit-test
+[ 3.0 1 2 3 ] [ 1.0 2.0 [ float+ 1 2 3 ] compile-call ] unit-test
 
-[ 5 ] [ 1.0 [ 2.0 float+ tag ] compile-1 ] unit-test
+[ 5 ] [ 1.0 [ 2.0 float+ tag ] compile-call ] unit-test
 
-[ 3.0 ] [ 1.0 [ 2.0 float+ ] compile-1 ] unit-test
+[ 3.0 ] [ 1.0 [ 2.0 float+ ] compile-call ] unit-test
-[ 3.0 ] [ 1.0 [ 2.0 swap float+ ] compile-1 ] unit-test
+[ 3.0 ] [ 1.0 [ 2.0 swap float+ ] compile-call ] unit-test
-[ 3.0 ] [ 1.0 2.0 [ float+ ] compile-1 ] unit-test
+[ 3.0 ] [ 1.0 2.0 [ float+ ] compile-call ] unit-test
-[ 3.0 ] [ 1.0 2.0 [ swap float+ ] compile-1 ] unit-test
+[ 3.0 ] [ 1.0 2.0 [ swap float+ ] compile-call ] unit-test
 
-[ -1.0 ] [ 1.0 [ 2.0 float- ] compile-1 ] unit-test
+[ -1.0 ] [ 1.0 [ 2.0 float- ] compile-call ] unit-test
-[ 1.0 ] [ 1.0 [ 2.0 swap float- ] compile-1 ] unit-test
+[ 1.0 ] [ 1.0 [ 2.0 swap float- ] compile-call ] unit-test
-[ -1.0 ] [ 1.0 2.0 [ float- ] compile-1 ] unit-test
+[ -1.0 ] [ 1.0 2.0 [ float- ] compile-call ] unit-test
-[ 1.0 ] [ 1.0 2.0 [ swap float- ] compile-1 ] unit-test
+[ 1.0 ] [ 1.0 2.0 [ swap float- ] compile-call ] unit-test
 
-[ 6.0 ] [ 3.0 [ 2.0 float* ] compile-1 ] unit-test
+[ 6.0 ] [ 3.0 [ 2.0 float* ] compile-call ] unit-test
-[ 6.0 ] [ 3.0 [ 2.0 swap float* ] compile-1 ] unit-test
+[ 6.0 ] [ 3.0 [ 2.0 swap float* ] compile-call ] unit-test
-[ 6.0 ] [ 3.0 2.0 [ float* ] compile-1 ] unit-test
+[ 6.0 ] [ 3.0 2.0 [ float* ] compile-call ] unit-test
-[ 6.0 ] [ 3.0 2.0 [ swap float* ] compile-1 ] unit-test
+[ 6.0 ] [ 3.0 2.0 [ swap float* ] compile-call ] unit-test
 
-[ 0.5 ] [ 1.0 [ 2.0 float/f ] compile-1 ] unit-test
+[ 0.5 ] [ 1.0 [ 2.0 float/f ] compile-call ] unit-test
-[ 2.0 ] [ 1.0 [ 2.0 swap float/f ] compile-1 ] unit-test
+[ 2.0 ] [ 1.0 [ 2.0 swap float/f ] compile-call ] unit-test
-[ 0.5 ] [ 1.0 2.0 [ float/f ] compile-1 ] unit-test
+[ 0.5 ] [ 1.0 2.0 [ float/f ] compile-call ] unit-test
-[ 2.0 ] [ 1.0 2.0 [ swap float/f ] compile-1 ] unit-test
+[ 2.0 ] [ 1.0 2.0 [ swap float/f ] compile-call ] unit-test
 
-[ t ] [ 1.0 2.0 [ float< ] compile-1 ] unit-test
+[ t ] [ 1.0 2.0 [ float< ] compile-call ] unit-test
-[ t ] [ 1.0 [ 2.0 float< ] compile-1 ] unit-test
+[ t ] [ 1.0 [ 2.0 float< ] compile-call ] unit-test
-[ f ] [ 1.0 [ 2.0 swap float< ] compile-1 ] unit-test
+[ f ] [ 1.0 [ 2.0 swap float< ] compile-call ] unit-test
-[ f ] [ 1.0 1.0 [ float< ] compile-1 ] unit-test
+[ f ] [ 1.0 1.0 [ float< ] compile-call ] unit-test
-[ f ] [ 1.0 [ 1.0 float< ] compile-1 ] unit-test
+[ f ] [ 1.0 [ 1.0 float< ] compile-call ] unit-test
-[ f ] [ 1.0 [ 1.0 swap float< ] compile-1 ] unit-test
+[ f ] [ 1.0 [ 1.0 swap float< ] compile-call ] unit-test
-[ f ] [ 3.0 1.0 [ float< ] compile-1 ] unit-test
+[ f ] [ 3.0 1.0 [ float< ] compile-call ] unit-test
-[ f ] [ 3.0 [ 1.0 float< ] compile-1 ] unit-test
+[ f ] [ 3.0 [ 1.0 float< ] compile-call ] unit-test
-[ t ] [ 3.0 [ 1.0 swap float< ] compile-1 ] unit-test
+[ t ] [ 3.0 [ 1.0 swap float< ] compile-call ] unit-test
 
-[ t ] [ 1.0 2.0 [ float<= ] compile-1 ] unit-test
+[ t ] [ 1.0 2.0 [ float<= ] compile-call ] unit-test
-[ t ] [ 1.0 [ 2.0 float<= ] compile-1 ] unit-test
+[ t ] [ 1.0 [ 2.0 float<= ] compile-call ] unit-test
-[ f ] [ 1.0 [ 2.0 swap float<= ] compile-1 ] unit-test
+[ f ] [ 1.0 [ 2.0 swap float<= ] compile-call ] unit-test
-[ t ] [ 1.0 1.0 [ float<= ] compile-1 ] unit-test
+[ t ] [ 1.0 1.0 [ float<= ] compile-call ] unit-test
-[ t ] [ 1.0 [ 1.0 float<= ] compile-1 ] unit-test
+[ t ] [ 1.0 [ 1.0 float<= ] compile-call ] unit-test
-[ t ] [ 1.0 [ 1.0 swap float<= ] compile-1 ] unit-test
+[ t ] [ 1.0 [ 1.0 swap float<= ] compile-call ] unit-test
-[ f ] [ 3.0 1.0 [ float<= ] compile-1 ] unit-test
+[ f ] [ 3.0 1.0 [ float<= ] compile-call ] unit-test
-[ f ] [ 3.0 [ 1.0 float<= ] compile-1 ] unit-test
+[ f ] [ 3.0 [ 1.0 float<= ] compile-call ] unit-test
-[ t ] [ 3.0 [ 1.0 swap float<= ] compile-1 ] unit-test
+[ t ] [ 3.0 [ 1.0 swap float<= ] compile-call ] unit-test
 
-[ f ] [ 1.0 2.0 [ float> ] compile-1 ] unit-test
+[ f ] [ 1.0 2.0 [ float> ] compile-call ] unit-test
-[ f ] [ 1.0 [ 2.0 float> ] compile-1 ] unit-test
+[ f ] [ 1.0 [ 2.0 float> ] compile-call ] unit-test
-[ t ] [ 1.0 [ 2.0 swap float> ] compile-1 ] unit-test
+[ t ] [ 1.0 [ 2.0 swap float> ] compile-call ] unit-test
-[ f ] [ 1.0 1.0 [ float> ] compile-1 ] unit-test
+[ f ] [ 1.0 1.0 [ float> ] compile-call ] unit-test
-[ f ] [ 1.0 [ 1.0 float> ] compile-1 ] unit-test
+[ f ] [ 1.0 [ 1.0 float> ] compile-call ] unit-test
-[ f ] [ 1.0 [ 1.0 swap float> ] compile-1 ] unit-test
+[ f ] [ 1.0 [ 1.0 swap float> ] compile-call ] unit-test
-[ t ] [ 3.0 1.0 [ float> ] compile-1 ] unit-test
+[ t ] [ 3.0 1.0 [ float> ] compile-call ] unit-test
-[ t ] [ 3.0 [ 1.0 float> ] compile-1 ] unit-test
+[ t ] [ 3.0 [ 1.0 float> ] compile-call ] unit-test
-[ f ] [ 3.0 [ 1.0 swap float> ] compile-1 ] unit-test
+[ f ] [ 3.0 [ 1.0 swap float> ] compile-call ] unit-test
 
-[ f ] [ 1.0 2.0 [ float>= ] compile-1 ] unit-test
+[ f ] [ 1.0 2.0 [ float>= ] compile-call ] unit-test
-[ f ] [ 1.0 [ 2.0 float>= ] compile-1 ] unit-test
+[ f ] [ 1.0 [ 2.0 float>= ] compile-call ] unit-test
-[ t ] [ 1.0 [ 2.0 swap float>= ] compile-1 ] unit-test
+[ t ] [ 1.0 [ 2.0 swap float>= ] compile-call ] unit-test
-[ t ] [ 1.0 1.0 [ float>= ] compile-1 ] unit-test
+[ t ] [ 1.0 1.0 [ float>= ] compile-call ] unit-test
-[ t ] [ 1.0 [ 1.0 float>= ] compile-1 ] unit-test
+[ t ] [ 1.0 [ 1.0 float>= ] compile-call ] unit-test
-[ t ] [ 1.0 [ 1.0 swap float>= ] compile-1 ] unit-test
+[ t ] [ 1.0 [ 1.0 swap float>= ] compile-call ] unit-test
-[ t ] [ 3.0 1.0 [ float>= ] compile-1 ] unit-test
+[ t ] [ 3.0 1.0 [ float>= ] compile-call ] unit-test
-[ t ] [ 3.0 [ 1.0 float>= ] compile-1 ] unit-test
+[ t ] [ 3.0 [ 1.0 float>= ] compile-call ] unit-test
-[ f ] [ 3.0 [ 1.0 swap float>= ] compile-1 ] unit-test
+[ f ] [ 3.0 [ 1.0 swap float>= ] compile-call ] unit-test
 
-[ f ] [ 1.0 2.0 [ float= ] compile-1 ] unit-test
+[ f ] [ 1.0 2.0 [ float= ] compile-call ] unit-test
-[ t ] [ 1.0 1.0 [ float= ] compile-1 ] unit-test
+[ t ] [ 1.0 1.0 [ float= ] compile-call ] unit-test
-[ f ] [ 1.0 [ 2.0 float= ] compile-1 ] unit-test
+[ f ] [ 1.0 [ 2.0 float= ] compile-call ] unit-test
-[ t ] [ 1.0 [ 1.0 float= ] compile-1 ] unit-test
+[ t ] [ 1.0 [ 1.0 float= ] compile-call ] unit-test
-[ f ] [ 1.0 [ 2.0 swap float= ] compile-1 ] unit-test
+[ f ] [ 1.0 [ 2.0 swap float= ] compile-call ] unit-test
-[ t ] [ 1.0 [ 1.0 swap float= ] compile-1 ] unit-test
+[ t ] [ 1.0 [ 1.0 swap float= ] compile-call ] unit-test
 
-[ t ] [ 0.0 [ dup 0.0 float= swap -0.0 float= or ] compile-1 ] unit-test
+[ t ] [ 0.0 [ dup 0.0 float= swap -0.0 float= or ] compile-call ] unit-test
-[ t ] [ -0.0 [ dup 0.0 float= swap -0.0 float= or ] compile-1 ] unit-test
+[ t ] [ -0.0 [ dup 0.0 float= swap -0.0 float= or ] compile-call ] unit-test
-[ f ] [ 3.0 [ dup 0.0 float= swap -0.0 float= or ] compile-1 ] unit-test
+[ f ] [ 3.0 [ dup 0.0 float= swap -0.0 float= or ] compile-call ] unit-test
 
-[ 315 315.0 ] [ 313 [ 2 fixnum+fast dup fixnum>float ] compile-1 ] unit-test
+[ 315 315.0 ] [ 313 [ 2 fixnum+fast dup fixnum>float ] compile-call ] unit-test

core/compiler/test/ifte.factor

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

core/compiler/test/intrinsics.factor

@@ -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 [ drop ] compile-call ] unit-test
-[ ] [ 1 2 [ 2drop ] compile-1 ] unit-test
+[ ] [ 1 2 [ 2drop ] compile-call ] unit-test
-[ ] [ 1 2 3 [ 3drop ] compile-1 ] unit-test
+[ ] [ 1 2 3 [ 3drop ] compile-call ] unit-test
-[ 1 1 ] [ 1 [ dup ] compile-1 ] unit-test
+[ 1 1 ] [ 1 [ dup ] compile-call ] unit-test
-[ 1 2 1 2 ] [ 1 2 [ 2dup ] compile-1 ] unit-test
+[ 1 2 1 2 ] [ 1 2 [ 2dup ] compile-call ] unit-test
-[ 1 2 3 1 2 3 ] [ 1 2 3 [ 3dup ] compile-1 ] unit-test
+[ 1 2 3 1 2 3 ] [ 1 2 3 [ 3dup ] compile-call ] unit-test
-[ 2 3 1 ] [ 1 2 3 [ rot ] compile-1 ] unit-test
+[ 2 3 1 ] [ 1 2 3 [ rot ] compile-call ] unit-test
-[ 3 1 2 ] [ 1 2 3 [ -rot ] compile-1 ] unit-test
+[ 3 1 2 ] [ 1 2 3 [ -rot ] compile-call ] unit-test
-[ 1 1 2 ] [ 1 2 [ dupd ] compile-1 ] unit-test
+[ 1 1 2 ] [ 1 2 [ dupd ] compile-call ] unit-test
-[ 2 1 3 ] [ 1 2 3 [ swapd ] compile-1 ] unit-test
+[ 2 1 3 ] [ 1 2 3 [ swapd ] compile-call ] unit-test
-[ 2 ] [ 1 2 [ nip ] compile-1 ] unit-test
+[ 2 ] [ 1 2 [ nip ] compile-call ] unit-test
-[ 3 ] [ 1 2 3 [ 2nip ] compile-1 ] unit-test
+[ 3 ] [ 1 2 3 [ 2nip ] compile-call ] unit-test
-[ 2 1 2 ] [ 1 2 [ tuck ] compile-1 ] unit-test
+[ 2 1 2 ] [ 1 2 [ tuck ] compile-call ] unit-test
-[ 1 2 1 ] [ 1 2 [ over ] compile-1 ] unit-test
+[ 1 2 1 ] [ 1 2 [ over ] compile-call ] unit-test
-[ 1 2 3 1 ] [ 1 2 3 [ pick ] compile-1 ] unit-test
+[ 1 2 3 1 ] [ 1 2 3 [ pick ] compile-call ] unit-test
-[ 2 1 ] [ 1 2 [ swap ] compile-1 ] unit-test
+[ 2 1 ] [ 1 2 [ swap ] compile-call ] unit-test
 
-[ 1 ] [ { 1 2 } [ 2 slot ] compile-1 ] unit-test
+[ 1 ] [ { 1 2 } [ 2 slot ] compile-call ] unit-test
-[ 1 ] [ [ { 1 2 } 2 slot ] compile-1 ] unit-test
+[ 1 ] [ [ { 1 2 } 2 slot ] compile-call ] unit-test
-[ 3 ] [ 3 1 2 2array [ [ 2 set-slot ] keep ] compile-1 first ] unit-test
+[ 3 ] [ 3 1 2 2array [ [ 2 set-slot ] keep ] compile-call first ] unit-test
-[ 3 ] [ 3 1 2 [ 2array [ 2 set-slot ] keep ] compile-1 first ] unit-test
+[ 3 ] [ 3 1 2 [ 2array [ 2 set-slot ] keep ] compile-call first ] unit-test
-[ 3 ] [ [ 3 1 2 2array [ 2 set-slot ] keep ] compile-1 first ] unit-test
+[ 3 ] [ [ 3 1 2 2array [ 2 set-slot ] keep ] compile-call first ] unit-test
-[ 3 ] [ 3 1 2 2array [ [ 3 set-slot ] keep ] compile-1 second ] unit-test
+[ 3 ] [ 3 1 2 2array [ [ 3 set-slot ] keep ] compile-call second ] unit-test
-[ 3 ] [ 3 1 2 [ 2array [ 3 set-slot ] keep ] compile-1 second ] unit-test
+[ 3 ] [ 3 1 2 [ 2array [ 3 set-slot ] keep ] compile-call second ] unit-test
-[ 3 ] [ [ 3 1 2 2array [ 3 set-slot ] keep ] compile-1 second ] unit-test
+[ 3 ] [ [ 3 1 2 2array [ 3 set-slot ] keep ] compile-call second ] unit-test
 
 ! Write barrier hits on the wrong value were causing segfaults
-[ -3 ] [ -3 1 2 [ 2array [ 3 set-slot ] keep ] compile-1 second ] unit-test
+[ -3 ] [ -3 1 2 [ 2array [ 3 set-slot ] keep ] compile-call second ] unit-test
 
-[ CHAR: b ] [ 1 "abc" [ char-slot ] compile-1 ] unit-test
+[ CHAR: b ] [ 1 "abc" [ char-slot ] compile-call ] unit-test
-[ CHAR: b ] [ 1 [ "abc" char-slot ] compile-1 ] unit-test
+[ CHAR: b ] [ 1 [ "abc" char-slot ] compile-call ] unit-test
-[ CHAR: b ] [ [ 1 "abc" char-slot ] compile-1 ] unit-test
+[ CHAR: b ] [ [ 1 "abc" char-slot ] compile-call ] unit-test
 
-[ "axc" ] [ CHAR: x 1 "abc" [ [ set-char-slot ] keep { string } declare dup rehash-string ] compile-1 ] unit-test
+[ "axc" ] [ CHAR: x 1 "abc" [ [ set-char-slot ] keep { string } declare dup rehash-string ] compile-call ] unit-test
-[ "axc" ] [ CHAR: x 1 [ "abc" [ set-char-slot ] keep { string } declare dup rehash-string ] compile-1 ] unit-test
+[ "axc" ] [ CHAR: x 1 [ "abc" [ set-char-slot ] keep { string } declare dup rehash-string ] compile-call ] unit-test
-[ "axc" ] [ CHAR: x [ 1 "abc" [ set-char-slot ] keep { string } declare dup rehash-string ] compile-1 ] unit-test
+[ "axc" ] [ CHAR: x [ 1 "abc" [ set-char-slot ] keep { string } declare dup rehash-string ] compile-call ] unit-test
 
-[ ] [ [ 0 getenv ] compile-1 drop ] unit-test
+[ ] [ [ 0 getenv ] compile-call drop ] unit-test
-[ ] [ 1 getenv [ 1 setenv ] compile-1 ] unit-test
+[ ] [ 1 getenv [ 1 setenv ] compile-call ] unit-test
 
-[ ] [ 1 [ drop ] compile-1 ] unit-test
+[ ] [ 1 [ drop ] compile-call ] unit-test
-[ ] [ [ 1 drop ] compile-1 ] unit-test
+[ ] [ [ 1 drop ] compile-call ] unit-test
-[ ] [ [ 1 2 2drop ] compile-1 ] unit-test
+[ ] [ [ 1 2 2drop ] compile-call ] unit-test
-[ ] [ 1 [ 2 2drop ] compile-1 ] unit-test
+[ ] [ 1 [ 2 2drop ] compile-call ] unit-test
-[ ] [ 1 2 [ 2drop ] compile-1 ] unit-test
+[ ] [ 1 2 [ 2drop ] compile-call ] unit-test
-[ 2 1 ] [ [ 1 2 swap ] compile-1 ] unit-test
+[ 2 1 ] [ [ 1 2 swap ] compile-call ] unit-test
-[ 2 1 ] [ 1 [ 2 swap ] compile-1 ] unit-test
+[ 2 1 ] [ 1 [ 2 swap ] compile-call ] unit-test
-[ 2 1 ] [ 1 2 [ swap ] compile-1 ] unit-test
+[ 2 1 ] [ 1 2 [ swap ] compile-call ] unit-test
-[ 1 1 ] [ 1 [ dup ] compile-1 ] unit-test
+[ 1 1 ] [ 1 [ dup ] compile-call ] unit-test
-[ 1 1 ] [ [ 1 dup ] compile-1 ] unit-test
+[ 1 1 ] [ [ 1 dup ] compile-call ] unit-test
-[ 1 2 1 ] [ [ 1 2 over ] compile-1 ] unit-test
+[ 1 2 1 ] [ [ 1 2 over ] compile-call ] unit-test
-[ 1 2 1 ] [ 1 [ 2 over ] compile-1 ] unit-test
+[ 1 2 1 ] [ 1 [ 2 over ] compile-call ] unit-test
-[ 1 2 1 ] [ 1 2 [ over ] compile-1 ] unit-test
+[ 1 2 1 ] [ 1 2 [ over ] compile-call ] unit-test
-[ 1 2 3 1 ] [ [ 1 2 3 pick ] compile-1 ] unit-test
+[ 1 2 3 1 ] [ [ 1 2 3 pick ] compile-call ] unit-test
-[ 1 2 3 1 ] [ 1 [ 2 3 pick ] compile-1 ] unit-test
+[ 1 2 3 1 ] [ 1 [ 2 3 pick ] compile-call ] unit-test
-[ 1 2 3 1 ] [ 1 2 [ 3 pick ] compile-1 ] unit-test
+[ 1 2 3 1 ] [ 1 2 [ 3 pick ] compile-call ] unit-test
-[ 1 2 3 1 ] [ 1 2 3 [ pick ] compile-1 ] unit-test
+[ 1 2 3 1 ] [ 1 2 3 [ pick ] compile-call ] unit-test
-[ 1 1 2 ] [ [ 1 2 dupd ] compile-1 ] unit-test
+[ 1 1 2 ] [ [ 1 2 dupd ] compile-call ] unit-test
-[ 1 1 2 ] [ 1 [ 2 dupd ] compile-1 ] unit-test
+[ 1 1 2 ] [ 1 [ 2 dupd ] compile-call ] unit-test
-[ 1 1 2 ] [ 1 2 [ dupd ] compile-1 ] unit-test
+[ 1 1 2 ] [ 1 2 [ dupd ] compile-call ] unit-test
-[ 2 ] [ [ 1 2 nip ] compile-1 ] unit-test
+[ 2 ] [ [ 1 2 nip ] compile-call ] unit-test
-[ 2 ] [ 1 [ 2 nip ] compile-1 ] unit-test
+[ 2 ] [ 1 [ 2 nip ] compile-call ] unit-test
-[ 2 ] [ 1 2 [ nip ] compile-1 ] unit-test
+[ 2 ] [ 1 2 [ nip ] compile-call ] unit-test
 
-[ 2 1 "hi" ] [ 1 2 [ swap "hi" ] compile-1 ] unit-test
+[ 2 1 "hi" ] [ 1 2 [ swap "hi" ] compile-call ] unit-test
 
-[ 4 ] [ 12 7 [ fixnum-bitand ] compile-1 ] unit-test
+[ 4 ] [ 12 7 [ fixnum-bitand ] compile-call ] unit-test
-[ 4 ] [ 12 [ 7 fixnum-bitand ] compile-1 ] unit-test
+[ 4 ] [ 12 [ 7 fixnum-bitand ] compile-call ] unit-test
-[ 4 ] [ [ 12 7 fixnum-bitand ] compile-1 ] unit-test
+[ 4 ] [ [ 12 7 fixnum-bitand ] compile-call ] unit-test
 
-[ 15 ] [ 12 7 [ fixnum-bitor ] compile-1 ] unit-test
+[ 15 ] [ 12 7 [ fixnum-bitor ] compile-call ] unit-test
-[ 15 ] [ 12 [ 7 fixnum-bitor ] compile-1 ] unit-test
+[ 15 ] [ 12 [ 7 fixnum-bitor ] compile-call ] unit-test
-[ 15 ] [ [ 12 7 fixnum-bitor ] compile-1 ] unit-test
+[ 15 ] [ [ 12 7 fixnum-bitor ] compile-call ] unit-test
 
-[ 11 ] [ 12 7 [ fixnum-bitxor ] compile-1 ] unit-test
+[ 11 ] [ 12 7 [ fixnum-bitxor ] compile-call ] unit-test
-[ 11 ] [ 12 [ 7 fixnum-bitxor ] compile-1 ] unit-test
+[ 11 ] [ 12 [ 7 fixnum-bitxor ] compile-call ] unit-test
-[ 11 ] [ [ 12 7 fixnum-bitxor ] compile-1 ] unit-test
+[ 11 ] [ [ 12 7 fixnum-bitxor ] compile-call ] unit-test
 
-[ f ] [ 12 7 [ fixnum< [ t ] [ f ] if ] compile-1 ] unit-test
+[ f ] [ 12 7 [ fixnum< [ t ] [ f ] if ] compile-call ] unit-test
-[ f ] [ 12 [ 7 fixnum< [ t ] [ f ] if ] compile-1 ] unit-test
+[ f ] [ 12 [ 7 fixnum< [ t ] [ f ] if ] compile-call ] unit-test
-[ f ] [ [ 12 7 fixnum< [ t ] [ f ] if ] compile-1 ] unit-test
+[ f ] [ [ 12 7 fixnum< [ t ] [ f ] if ] compile-call ] unit-test
-[ f ] [ [ 12 12 fixnum< [ t ] [ f ] if ] compile-1 ] unit-test
+[ f ] [ [ 12 12 fixnum< [ t ] [ f ] if ] compile-call ] unit-test
-[ f ] [ 12 12 [ fixnum< [ t ] [ f ] if ] compile-1 ] unit-test
+[ f ] [ 12 12 [ fixnum< [ t ] [ f ] if ] compile-call ] unit-test
 
-[ t ] [ 12 70 [ fixnum< [ t ] [ f ] if ] compile-1 ] unit-test
+[ t ] [ 12 70 [ fixnum< [ t ] [ f ] if ] compile-call ] unit-test
-[ t ] [ 12 [ 70 fixnum< [ t ] [ f ] if ] compile-1 ] unit-test
+[ t ] [ 12 [ 70 fixnum< [ t ] [ f ] if ] compile-call ] unit-test
-[ t ] [ [ 12 70 fixnum< [ t ] [ f ] if ] compile-1 ] unit-test
+[ t ] [ [ 12 70 fixnum< [ t ] [ f ] if ] compile-call ] unit-test
 
-[ f ] [ 12 7 [ fixnum<= [ t ] [ f ] if ] compile-1 ] unit-test
+[ f ] [ 12 7 [ fixnum<= [ t ] [ f ] if ] compile-call ] unit-test
-[ f ] [ 12 [ 7 fixnum<= [ t ] [ f ] if ] compile-1 ] unit-test
+[ f ] [ 12 [ 7 fixnum<= [ t ] [ f ] if ] compile-call ] unit-test
-[ f ] [ [ 12 7 fixnum<= [ t ] [ f ] if ] compile-1 ] unit-test
+[ f ] [ [ 12 7 fixnum<= [ t ] [ f ] if ] compile-call ] unit-test
-[ t ] [ [ 12 12 fixnum<= [ t ] [ f ] if ] compile-1 ] unit-test
+[ t ] [ [ 12 12 fixnum<= [ t ] [ f ] if ] compile-call ] unit-test
-[ t ] [ [ 12 12 fixnum<= [ t ] [ f ] if ] compile-1 ] unit-test
+[ t ] [ [ 12 12 fixnum<= [ t ] [ f ] if ] compile-call ] unit-test
-[ t ] [ 12 12 [ fixnum<= [ t ] [ f ] if ] compile-1 ] unit-test
+[ t ] [ 12 12 [ fixnum<= [ t ] [ f ] if ] compile-call ] unit-test
 
-[ t ] [ 12 70 [ fixnum<= [ t ] [ f ] if ] compile-1 ] unit-test
+[ t ] [ 12 70 [ fixnum<= [ t ] [ f ] if ] compile-call ] unit-test
-[ t ] [ 12 [ 70 fixnum<= [ t ] [ f ] if ] compile-1 ] unit-test
+[ t ] [ 12 [ 70 fixnum<= [ t ] [ f ] if ] compile-call ] unit-test
-[ t ] [ [ 12 70 fixnum<= [ t ] [ f ] if ] compile-1 ] unit-test
+[ t ] [ [ 12 70 fixnum<= [ t ] [ f ] if ] compile-call ] unit-test
 
-[ t ] [ 12 7 [ fixnum> [ t ] [ f ] if ] compile-1 ] unit-test
+[ t ] [ 12 7 [ fixnum> [ t ] [ f ] if ] compile-call ] unit-test
-[ t ] [ 12 [ 7 fixnum> [ t ] [ f ] if ] compile-1 ] unit-test
+[ t ] [ 12 [ 7 fixnum> [ t ] [ f ] if ] compile-call ] unit-test
-[ t ] [ [ 12 7 fixnum> [ t ] [ f ] if ] compile-1 ] unit-test
+[ t ] [ [ 12 7 fixnum> [ t ] [ f ] if ] compile-call ] unit-test
-[ f ] [ [ 12 12 fixnum> [ t ] [ f ] if ] compile-1 ] unit-test
+[ f ] [ [ 12 12 fixnum> [ t ] [ f ] if ] compile-call ] unit-test
-[ f ] [ [ 12 12 fixnum> [ t ] [ f ] if ] compile-1 ] unit-test
+[ f ] [ [ 12 12 fixnum> [ t ] [ f ] if ] compile-call ] unit-test
-[ f ] [ 12 12 [ fixnum> [ t ] [ f ] if ] compile-1 ] unit-test
+[ f ] [ 12 12 [ fixnum> [ t ] [ f ] if ] compile-call ] unit-test
 
-[ f ] [ 12 70 [ fixnum> [ t ] [ f ] if ] compile-1 ] unit-test
+[ f ] [ 12 70 [ fixnum> [ t ] [ f ] if ] compile-call ] unit-test
-[ f ] [ 12 [ 70 fixnum> [ t ] [ f ] if ] compile-1 ] unit-test
+[ f ] [ 12 [ 70 fixnum> [ t ] [ f ] if ] compile-call ] unit-test
-[ f ] [ [ 12 70 fixnum> [ t ] [ f ] if ] compile-1 ] unit-test
+[ f ] [ [ 12 70 fixnum> [ t ] [ f ] if ] compile-call ] unit-test
 
-[ t ] [ 12 7 [ fixnum>= [ t ] [ f ] if ] compile-1 ] unit-test
+[ t ] [ 12 7 [ fixnum>= [ t ] [ f ] if ] compile-call ] unit-test
-[ t ] [ 12 [ 7 fixnum>= [ t ] [ f ] if ] compile-1 ] unit-test
+[ t ] [ 12 [ 7 fixnum>= [ t ] [ f ] if ] compile-call ] unit-test
-[ t ] [ [ 12 7 fixnum>= [ t ] [ f ] if ] compile-1 ] unit-test
+[ t ] [ [ 12 7 fixnum>= [ t ] [ f ] if ] compile-call ] unit-test
-[ t ] [ [ 12 12 fixnum>= [ t ] [ f ] if ] compile-1 ] unit-test
+[ t ] [ [ 12 12 fixnum>= [ t ] [ f ] if ] compile-call ] unit-test
-[ t ] [ 12 12 [ fixnum>= [ t ] [ f ] if ] compile-1 ] unit-test
+[ t ] [ 12 12 [ fixnum>= [ t ] [ f ] if ] compile-call ] unit-test
 
-[ f ] [ 12 70 [ fixnum>= [ t ] [ f ] if ] compile-1 ] unit-test
+[ f ] [ 12 70 [ fixnum>= [ t ] [ f ] if ] compile-call ] unit-test
-[ f ] [ 12 [ 70 fixnum>= [ t ] [ f ] if ] compile-1 ] unit-test
+[ f ] [ 12 [ 70 fixnum>= [ t ] [ f ] if ] compile-call ] unit-test
-[ f ] [ [ 12 70 fixnum>= [ t ] [ f ] if ] compile-1 ] unit-test
+[ f ] [ [ 12 70 fixnum>= [ t ] [ f ] if ] compile-call ] unit-test
 
-[ f ] [ 1 2 [ eq? [ t ] [ f ] if ] compile-1 ] unit-test
+[ f ] [ 1 2 [ eq? [ t ] [ f ] if ] compile-call ] unit-test
-[ f ] [ 1 [ 2 eq? [ t ] [ f ] if ] compile-1 ] unit-test
+[ f ] [ 1 [ 2 eq? [ t ] [ f ] if ] compile-call ] unit-test
-[ f ] [ [ 1 2 eq? [ t ] [ f ] if ] compile-1 ] unit-test
+[ f ] [ [ 1 2 eq? [ t ] [ f ] if ] compile-call ] unit-test
-[ t ] [ 3 3 [ eq? [ t ] [ f ] if ] compile-1 ] unit-test
+[ t ] [ 3 3 [ eq? [ t ] [ f ] if ] compile-call ] unit-test
-[ t ] [ 3 [ 3 eq? [ t ] [ f ] if ] compile-1 ] unit-test
+[ t ] [ 3 [ 3 eq? [ t ] [ f ] if ] compile-call ] unit-test
-[ t ] [ [ 3 3 eq? [ t ] [ f ] if ] compile-1 ] unit-test
+[ t ] [ [ 3 3 eq? [ t ] [ f ] if ] compile-call ] unit-test
 
-[ -1 ] [ 0 [ fixnum-bitnot ] compile-1 ] unit-test
+[ -1 ] [ 0 [ fixnum-bitnot ] compile-call ] unit-test
-[ -1 ] [ [ 0 fixnum-bitnot ] compile-1 ] unit-test
+[ -1 ] [ [ 0 fixnum-bitnot ] compile-call ] unit-test
 
-[ 3 ] [ 13 10 [ fixnum-mod ] compile-1 ] unit-test
+[ 3 ] [ 13 10 [ fixnum-mod ] compile-call ] unit-test
-[ 3 ] [ 13 [ 10 fixnum-mod ] compile-1 ] unit-test
+[ 3 ] [ 13 [ 10 fixnum-mod ] compile-call ] unit-test
-[ 3 ] [ [ 13 10 fixnum-mod ] compile-1 ] unit-test
+[ 3 ] [ [ 13 10 fixnum-mod ] compile-call ] unit-test
-[ -3 ] [ -13 10 [ fixnum-mod ] compile-1 ] unit-test
+[ -3 ] [ -13 10 [ fixnum-mod ] compile-call ] unit-test
-[ -3 ] [ -13 [ 10 fixnum-mod ] compile-1 ] unit-test
+[ -3 ] [ -13 [ 10 fixnum-mod ] compile-call ] unit-test
-[ -3 ] [ [ -13 10 fixnum-mod ] compile-1 ] unit-test
+[ -3 ] [ [ -13 10 fixnum-mod ] compile-call ] unit-test
 
-[ 2 ] [ 4 2 [ fixnum/i ] compile-1 ] unit-test
+[ 2 ] [ 4 2 [ fixnum/i ] compile-call ] unit-test
-[ 2 ] [ 4 [ 2 fixnum/i ] compile-1 ] unit-test
+[ 2 ] [ 4 [ 2 fixnum/i ] compile-call ] unit-test
-[ -2 ] [ 4 [ -2 fixnum/i ] compile-1 ] unit-test
+[ -2 ] [ 4 [ -2 fixnum/i ] compile-call ] unit-test
-[ 3 1 ] [ 10 3 [ fixnum/mod ] compile-1 ] unit-test
+[ 3 1 ] [ 10 3 [ fixnum/mod ] compile-call ] unit-test
 
-[ 4 ] [ 1 3 [ fixnum+ ] compile-1 ] unit-test
+[ 4 ] [ 1 3 [ fixnum+ ] compile-call ] unit-test
-[ 4 ] [ 1 [ 3 fixnum+ ] compile-1 ] unit-test
+[ 4 ] [ 1 [ 3 fixnum+ ] compile-call ] unit-test
-[ 4 ] [ [ 1 3 fixnum+ ] compile-1 ] unit-test
+[ 4 ] [ [ 1 3 fixnum+ ] compile-call ] unit-test
 
-[ 4 ] [ 1 3 [ fixnum+fast ] compile-1 ] unit-test
+[ 4 ] [ 1 3 [ fixnum+fast ] compile-call ] unit-test
-[ 4 ] [ 1 [ 3 fixnum+fast ] compile-1 ] unit-test
+[ 4 ] [ 1 [ 3 fixnum+fast ] compile-call ] unit-test
-[ 4 ] [ [ 1 3 fixnum+fast ] compile-1 ] unit-test
+[ 4 ] [ [ 1 3 fixnum+fast ] compile-call ] unit-test
 
-[ 30001 ] [ 1 [ 30000 fixnum+fast ] compile-1 ] unit-test
+[ 30001 ] [ 1 [ 30000 fixnum+fast ] compile-call ] unit-test
 
-[ 6 ] [ 2 3 [ fixnum*fast ] compile-1 ] unit-test
+[ 6 ] [ 2 3 [ fixnum*fast ] compile-call ] unit-test
-[ 6 ] [ 2 [ 3 fixnum*fast ] compile-1 ] unit-test
+[ 6 ] [ 2 [ 3 fixnum*fast ] compile-call ] unit-test
-[ 6 ] [ [ 2 3 fixnum*fast ] compile-1 ] unit-test
+[ 6 ] [ [ 2 3 fixnum*fast ] compile-call ] unit-test
-[ -6 ] [ 2 -3 [ fixnum*fast ] compile-1 ] unit-test
+[ -6 ] [ 2 -3 [ fixnum*fast ] compile-call ] unit-test
-[ -6 ] [ 2 [ -3 fixnum*fast ] compile-1 ] unit-test
+[ -6 ] [ 2 [ -3 fixnum*fast ] compile-call ] unit-test
-[ -6 ] [ [ 2 -3 fixnum*fast ] compile-1 ] unit-test
+[ -6 ] [ [ 2 -3 fixnum*fast ] compile-call ] unit-test
 
-[ 6 ] [ 2 3 [ fixnum* ] compile-1 ] unit-test
+[ 6 ] [ 2 3 [ fixnum* ] compile-call ] unit-test
-[ 6 ] [ 2 [ 3 fixnum* ] compile-1 ] unit-test
+[ 6 ] [ 2 [ 3 fixnum* ] compile-call ] unit-test
-[ 6 ] [ [ 2 3 fixnum* ] compile-1 ] unit-test
+[ 6 ] [ [ 2 3 fixnum* ] compile-call ] unit-test
-[ -6 ] [ 2 -3 [ fixnum* ] compile-1 ] unit-test
+[ -6 ] [ 2 -3 [ fixnum* ] compile-call ] unit-test
-[ -6 ] [ 2 [ -3 fixnum* ] compile-1 ] unit-test
+[ -6 ] [ 2 [ -3 fixnum* ] compile-call ] unit-test
-[ -6 ] [ [ 2 -3 fixnum* ] compile-1 ] unit-test
+[ -6 ] [ [ 2 -3 fixnum* ] compile-call ] unit-test
 
-[ t ] [ 3 type 3 [ type ] compile-1 eq? ] unit-test
+[ t ] [ 3 type 3 [ type ] compile-call eq? ] unit-test
-[ t ] [ 3 >bignum type 3 >bignum [ type ] compile-1 eq? ] unit-test
+[ t ] [ 3 >bignum type 3 >bignum [ type ] compile-call eq? ] unit-test
-[ t ] [ "hey" type "hey" [ type ] compile-1 eq? ] unit-test
+[ t ] [ "hey" type "hey" [ type ] compile-call eq? ] unit-test
-[ t ] [ f type f [ type ] compile-1 eq? ] unit-test
+[ t ] [ f type f [ type ] compile-call eq? ] unit-test
 
-[ 5 ] [ 1 2 [ eq? [ 3 ] [ 5 ] if ] compile-1 ] unit-test
+[ 5 ] [ 1 2 [ eq? [ 3 ] [ 5 ] if ] compile-call ] unit-test
-[ 3 ] [ 2 2 [ eq? [ 3 ] [ 5 ] if ] compile-1 ] unit-test
+[ 3 ] [ 2 2 [ eq? [ 3 ] [ 5 ] if ] compile-call ] unit-test
-[ 3 ] [ 1 2 [ fixnum< [ 3 ] [ 5 ] if ] compile-1 ] unit-test
+[ 3 ] [ 1 2 [ fixnum< [ 3 ] [ 5 ] if ] compile-call ] unit-test
-[ 5 ] [ 2 2 [ fixnum< [ 3 ] [ 5 ] if ] compile-1 ] unit-test
+[ 5 ] [ 2 2 [ fixnum< [ 3 ] [ 5 ] if ] compile-call ] unit-test
 
-[ 8 ] [ 1 3 [ fixnum-shift ] compile-1 ] unit-test
+[ 8 ] [ 1 3 [ fixnum-shift ] compile-call ] unit-test
-[ 8 ] [ 1 [ 3 fixnum-shift ] compile-1 ] unit-test
+[ 8 ] [ 1 [ 3 fixnum-shift ] compile-call ] unit-test
-[ 8 ] [ [ 1 3 fixnum-shift ] compile-1 ] unit-test
+[ 8 ] [ [ 1 3 fixnum-shift ] compile-call ] unit-test
-[ -8 ] [ -1 3 [ fixnum-shift ] compile-1 ] unit-test
+[ -8 ] [ -1 3 [ fixnum-shift ] compile-call ] unit-test
-[ -8 ] [ -1 [ 3 fixnum-shift ] compile-1 ] unit-test
+[ -8 ] [ -1 [ 3 fixnum-shift ] compile-call ] unit-test
-[ -8 ] [ [ -1 3 fixnum-shift ] compile-1 ] unit-test
+[ -8 ] [ [ -1 3 fixnum-shift ] compile-call ] unit-test
 
-[ 2 ] [ 8 -2 [ fixnum-shift ] compile-1 ] unit-test
+[ 2 ] [ 8 -2 [ fixnum-shift ] compile-call ] unit-test
-[ 2 ] [ 8 [ -2 fixnum-shift ] compile-1 ] unit-test
+[ 2 ] [ 8 [ -2 fixnum-shift ] compile-call ] unit-test
 
-[ 0 ] [ [ 123 -64 fixnum-shift ] compile-1 ] unit-test
+[ 0 ] [ [ 123 -64 fixnum-shift ] compile-call ] unit-test
-[ 0 ] [ 123 -64 [ fixnum-shift ] compile-1 ] unit-test
+[ 0 ] [ 123 -64 [ fixnum-shift ] compile-call ] unit-test
-[ -1 ] [ [ -123 -64 fixnum-shift ] compile-1 ] unit-test
+[ -1 ] [ [ -123 -64 fixnum-shift ] compile-call ] unit-test
-[ -1 ] [ -123 -64 [ fixnum-shift ] compile-1 ] unit-test
+[ -1 ] [ -123 -64 [ fixnum-shift ] compile-call ] unit-test
 
-[ HEX: 10000000 ] [ HEX: -10000000 >fixnum [ 0 swap fixnum- ] compile-1 ] unit-test
+[ HEX: 10000000 ] [ HEX: -10000000 >fixnum [ 0 swap fixnum- ] compile-call ] unit-test
-[ HEX: 10000000 ] [ HEX: -fffffff >fixnum [ 1 swap fixnum- ] compile-1 ] unit-test
+[ HEX: 10000000 ] [ HEX: -fffffff >fixnum [ 1 swap fixnum- ] compile-call ] unit-test
 
-[ t ] [ 1 27 fixnum-shift dup [ fixnum+ ] compile-1 1 28 fixnum-shift = ] unit-test
+[ t ] [ 1 27 fixnum-shift dup [ fixnum+ ] compile-call 1 28 fixnum-shift = ] unit-test
-[ -268435457 ] [ 1 28 shift neg >fixnum [ -1 fixnum+ ] compile-1 ] unit-test
+[ -268435457 ] [ 1 28 shift neg >fixnum [ -1 fixnum+ ] compile-call ] unit-test
 
-[ 4294967296 ] [ 1 32 [ fixnum-shift ] compile-1 ] unit-test
+[ 4294967296 ] [ 1 32 [ fixnum-shift ] compile-call ] unit-test
-[ 4294967296 ] [ 1 [ 32 fixnum-shift ] compile-1 ] unit-test
+[ 4294967296 ] [ 1 [ 32 fixnum-shift ] compile-call ] unit-test
-[ 4294967296 ] [ 1 [ 16 fixnum-shift 16 fixnum-shift ] compile-1 ] unit-test
+[ 4294967296 ] [ 1 [ 16 fixnum-shift 16 fixnum-shift ] compile-call ] unit-test
-[ -4294967296 ] [ -1 32 [ fixnum-shift ] compile-1 ] unit-test
+[ -4294967296 ] [ -1 32 [ fixnum-shift ] compile-call ] unit-test
-[ -4294967296 ] [ -1 [ 32 fixnum-shift ] compile-1 ] unit-test
+[ -4294967296 ] [ -1 [ 32 fixnum-shift ] compile-call ] unit-test
-[ -4294967296 ] [ -1 [ 16 fixnum-shift 16 fixnum-shift ] compile-1 ] unit-test
+[ -4294967296 ] [ -1 [ 16 fixnum-shift 16 fixnum-shift ] compile-call ] unit-test
 
-[ t ] [ 1 20 shift 1 20 shift [ fixnum* ] compile-1 1 40 shift = ] unit-test
+[ t ] [ 1 20 shift 1 20 shift [ fixnum* ] compile-call 1 40 shift = ] unit-test
-[ t ] [ 1 20 shift neg 1 20 shift [ fixnum* ] compile-1 1 40 shift neg = ] unit-test
+[ t ] [ 1 20 shift neg 1 20 shift [ fixnum* ] compile-call 1 40 shift neg = ] unit-test
-[ t ] [ 1 20 shift neg 1 20 shift neg [ fixnum* ] compile-1 1 40 shift = ] unit-test
+[ t ] [ 1 20 shift neg 1 20 shift neg [ fixnum* ] compile-call 1 40 shift = ] unit-test
-[ -351382792 ] [ -43922849 [ 3 fixnum-shift ] compile-1 ] unit-test
+[ -351382792 ] [ -43922849 [ 3 fixnum-shift ] compile-call ] unit-test
 
-[ 268435456 ] [ -268435456 >fixnum -1 [ fixnum/i ] compile-1 ] unit-test
+[ 268435456 ] [ -268435456 >fixnum -1 [ fixnum/i ] compile-call ] unit-test
 
-[ 268435456 0 ] [ -268435456 >fixnum -1 [ fixnum/mod ] compile-1 ] unit-test
+[ 268435456 0 ] [ -268435456 >fixnum -1 [ fixnum/mod ] compile-call ] unit-test
 
-[ t ] [ f [ f eq? ] compile-1 ] unit-test
+[ t ] [ f [ f eq? ] compile-call ] unit-test
 
 ! regression
-[ 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
+    [ t ] [ 1 59 fixnum-shift dup [ fixnum+ ] compile-call 1 60 fixnum-shift = ] unit-test
-    [ -1152921504606846977 ] [ 1 60 shift neg >fixnum [ -1 fixnum+ ] compile-1 ] unit-test
+    [ -1152921504606846977 ] [ 1 60 shift neg >fixnum [ -1 fixnum+ ] compile-call ] unit-test
     
-    [ t ] [ 1 40 shift 1 40 shift [ fixnum* ] compile-1 1 80 shift = ] unit-test
+    [ t ] [ 1 40 shift 1 40 shift [ fixnum* ] compile-call 1 80 shift = ] unit-test
-    [ t ] [ 1 40 shift neg 1 40 shift [ fixnum* ] compile-1 1 80 shift neg = ] unit-test
+    [ t ] [ 1 40 shift neg 1 40 shift [ fixnum* ] compile-call 1 80 shift neg = ] unit-test
-    [ t ] [ 1 40 shift neg 1 40 shift neg [ fixnum* ] compile-1 1 80 shift = ] unit-test
+    [ t ] [ 1 40 shift neg 1 40 shift neg [ fixnum* ] compile-call 1 80 shift = ] unit-test
-    [ t ] [ 1 30 shift neg 1 50 shift neg [ fixnum* ] compile-1 1 80 shift = ] unit-test
+    [ t ] [ 1 30 shift neg 1 50 shift neg [ fixnum* ] compile-call 1 80 shift = ] unit-test
-    [ t ] [ 1 50 shift neg 1 30 shift neg [ fixnum* ] compile-1 1 80 shift = ] unit-test
+    [ t ] [ 1 50 shift neg 1 30 shift neg [ fixnum* ] compile-call 1 80 shift = ] unit-test
 
-    [ 18446744073709551616 ] [ 1 64 [ fixnum-shift ] compile-1 ] unit-test
+    [ 18446744073709551616 ] [ 1 64 [ fixnum-shift ] compile-call ] unit-test
-    [ 18446744073709551616 ] [ 1 [ 64 fixnum-shift ] compile-1 ] unit-test
+    [ 18446744073709551616 ] [ 1 [ 64 fixnum-shift ] compile-call ] unit-test
-    [ 18446744073709551616 ] [ 1 [ 32 fixnum-shift 32 fixnum-shift ] compile-1 ] unit-test
+    [ 18446744073709551616 ] [ 1 [ 32 fixnum-shift 32 fixnum-shift ] compile-call ] unit-test
-    [ -18446744073709551616 ] [ -1 64 [ fixnum-shift ] compile-1 ] unit-test
+    [ -18446744073709551616 ] [ -1 64 [ fixnum-shift ] compile-call ] unit-test
-    [ -18446744073709551616 ] [ -1 [ 64 fixnum-shift ] compile-1 ] unit-test
+    [ -18446744073709551616 ] [ -1 [ 64 fixnum-shift ] compile-call ] unit-test
-    [ -18446744073709551616 ] [ -1 [ 32 fixnum-shift 32 fixnum-shift ] compile-1 ] unit-test
+    [ -18446744073709551616 ] [ -1 [ 32 fixnum-shift 32 fixnum-shift ] compile-call ] unit-test
     
-    [ 1152921504606846976 ] [ -1152921504606846976 >fixnum -1 [ fixnum/i ] compile-1 ] unit-test
+    [ 1152921504606846976 ] [ -1152921504606846976 >fixnum -1 [ fixnum/i ] compile-call ] unit-test
 
-    [ 1152921504606846976 0 ] [ -1152921504606846976 >fixnum -1 [ fixnum/mod ] compile-1 ] unit-test
+    [ 1152921504606846976 0 ] [ -1152921504606846976 >fixnum -1 [ fixnum/mod ] compile-call ] unit-test
 
-    [ -268435457 ] [ 28 2^ [ fixnum-bitnot ] compile-1 ] unit-test
+    [ -268435457 ] [ 28 2^ [ fixnum-bitnot ] compile-call ] unit-test
 ] when
 
 ! 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+ ] compile-call [ bignum>fixnum ] compile-call ] 2keep
-    [ fixnum+ >fixnum ] compile-1
+    [ fixnum+ >fixnum ] compile-call
     =
 ] unit-test
 
 [ t ] [
     most-negative-fixnum 100 + >fixnum
     -200
-    [ [ fixnum+ ] compile-1 [ bignum>fixnum ] compile-1 ] 2keep
+    [ [ fixnum+ ] compile-call [ bignum>fixnum ] compile-call ] 2keep
-    [ fixnum+ >fixnum ] compile-1
+    [ fixnum+ >fixnum ] compile-call
     =
 ] unit-test
 
 [ t ] [
     most-negative-fixnum 100 + >fixnum
     200
-    [ [ fixnum- ] compile-1 [ bignum>fixnum ] compile-1 ] 2keep
+    [ [ fixnum- ] compile-call [ bignum>fixnum ] compile-call ] 2keep
-    [ fixnum- >fixnum ] compile-1
+    [ fixnum- >fixnum ] compile-call
     =
 ] unit-test
 
 ! 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-call ] unit-test
-[ 3 ] [ [ B{ 1 2 3 4 5 } 2 alien-unsigned-1 ] compile-1 ] unit-test
+[ 3 ] [ [ B{ 1 2 3 4 5 } 2 alien-unsigned-1 ] compile-call ] unit-test
-[ 3 ] [ B{ 1 2 3 4 5 } 2 [ { byte-array fixnum } declare alien-unsigned-1 ] compile-1 ] unit-test
+[ 3 ] [ B{ 1 2 3 4 5 } 2 [ { byte-array fixnum } declare alien-unsigned-1 ] compile-call ] unit-test
-[ 3 ] [ B{ 1 2 3 4 5 } 2 [ { c-ptr fixnum } declare alien-unsigned-1 ] compile-1 ] unit-test
+[ 3 ] [ B{ 1 2 3 4 5 } 2 [ { c-ptr fixnum } declare alien-unsigned-1 ] compile-call ] unit-test
 
 [ ] [ B{ 1 2 3 4 5 } malloc-byte-array "b" set ] unit-test
 [ t ] [ "b" get >boolean ] unit-test
 
 "b" get [
-    [ 3 ] [ "b" get 2 [ alien-unsigned-1 ] compile-1 ] unit-test
+    [ 3 ] [ "b" get 2 [ alien-unsigned-1 ] compile-call ] unit-test
-    [ 3 ] [ "b" get [ { alien } declare 2 alien-unsigned-1 ] compile-1 ] unit-test
+    [ 3 ] [ "b" get [ { alien } declare 2 alien-unsigned-1 ] compile-call ] unit-test
-    [ 3 ] [ "b" get 2 [ { simple-alien fixnum } declare alien-unsigned-1 ] compile-1 ] unit-test
+    [ 3 ] [ "b" get 2 [ { simple-alien fixnum } declare alien-unsigned-1 ] compile-call ] unit-test
-    [ 3 ] [ "b" get 2 [ { c-ptr fixnum } declare alien-unsigned-1 ] compile-1 ] unit-test
+    [ 3 ] [ "b" get 2 [ { c-ptr fixnum } declare alien-unsigned-1 ] compile-call ] unit-test
 
     [ ] [ "b" get free ] unit-test
 ] 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*> [ { byte-array } declare *void* ] compile-call alien>char-string ] unit-test
-    [ "hello world" ] [ "s" get <void*> [ { c-ptr } declare *void* ] compile-1 alien>char-string ] unit-test
+    [ "hello world" ] [ "s" get <void*> [ { c-ptr } declare *void* ] compile-call alien>char-string ] unit-test
 
     [ ] [ "s" get free ] unit-test
 ] when
 
-[ ALIEN: 1234 ] [ ALIEN: 1234 [ { alien } declare <void*> ] compile-1 *void* ] unit-test
+[ ALIEN: 1234 ] [ ALIEN: 1234 [ { alien } declare <void*> ] compile-call *void* ] unit-test
-[ ALIEN: 1234 ] [ ALIEN: 1234 [ { c-ptr } declare <void*> ] compile-1 *void* ] unit-test
+[ ALIEN: 1234 ] [ ALIEN: 1234 [ { c-ptr } declare <void*> ] compile-call *void* ] unit-test
-[ f ] [ f [ { POSTPONE: f } declare <void*> ] compile-1 *void* ] unit-test
+[ f ] [ f [ { POSTPONE: f } declare <void*> ] compile-call *void* ] unit-test
 
-[ 252 ] [ B{ 1 2 3 -4 5 } 3 [ { byte-array fixnum } declare alien-unsigned-1 ] compile-1 ] unit-test
+[ 252 ] [ B{ 1 2 3 -4 5 } 3 [ { byte-array fixnum } declare alien-unsigned-1 ] compile-call ] unit-test
-[ -4 ] [ B{ 1 2 3 -4 5 } 3 [ { byte-array fixnum } declare alien-signed-1 ] compile-1 ] unit-test
+[ -4 ] [ B{ 1 2 3 -4 5 } 3 [ { byte-array fixnum } declare alien-signed-1 ] compile-call ] unit-test
 
 : xword-def word-def [ { fixnum } declare ] swap append ;
 
-[ -100 ] [ -100 <char> [ { byte-array } declare *char ] compile-1 ] unit-test
+[ -100 ] [ -100 <char> [ { byte-array } declare *char ] compile-call ] unit-test
-[ 156 ] [ -100 <uchar> [ { byte-array } declare *uchar ] compile-1 ] unit-test
+[ 156 ] [ -100 <uchar> [ { byte-array } declare *uchar ] compile-call ] unit-test
 
-[ -100 ] [ -100 \ <char> xword-def compile-1 *char ] unit-test
+[ -100 ] [ -100 \ <char> xword-def compile-call *char ] unit-test
-[ 156 ] [ -100 \ <uchar> xword-def compile-1 *uchar ] unit-test
+[ 156 ] [ -100 \ <uchar> xword-def compile-call *uchar ] unit-test
 
-[ -1000 ] [ -1000 <short> [ { byte-array } declare *short ] compile-1 ] unit-test
+[ -1000 ] [ -1000 <short> [ { byte-array } declare *short ] compile-call ] unit-test
-[ 64536 ] [ -1000 <ushort> [ { byte-array } declare *ushort ] compile-1 ] unit-test
+[ 64536 ] [ -1000 <ushort> [ { byte-array } declare *ushort ] compile-call ] unit-test
 
-[ -1000 ] [ -1000 \ <short> xword-def compile-1 *short ] unit-test
+[ -1000 ] [ -1000 \ <short> xword-def compile-call *short ] unit-test
-[ 64536 ] [ -1000 \ <ushort> xword-def compile-1 *ushort ] unit-test
+[ 64536 ] [ -1000 \ <ushort> xword-def compile-call *ushort ] unit-test
 
-[ -100000 ] [ -100000 <int> [ { byte-array } declare *int ] compile-1 ] unit-test
+[ -100000 ] [ -100000 <int> [ { byte-array } declare *int ] compile-call ] unit-test
-[ 4294867296 ] [ -100000 <uint> [ { byte-array } declare *uint ] compile-1 ] unit-test
+[ 4294867296 ] [ -100000 <uint> [ { byte-array } declare *uint ] compile-call ] unit-test
 
-[ -100000 ] [ -100000 \ <int> xword-def compile-1 *int ] unit-test
+[ -100000 ] [ -100000 \ <int> xword-def compile-call *int ] unit-test
-[ 4294867296 ] [ -100000 \ <uint> xword-def compile-1 *uint ] unit-test
+[ 4294867296 ] [ -100000 \ <uint> xword-def compile-call *uint ] unit-test
 
 [ t ] [ pi pi <double> *double = ] unit-test
 
-[ t ] [ pi <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 4 <byte-array> [ [ { float byte-array } declare 0 set-alien-float ] compile-call ] keep *float pi - -0.001 0.001 between? ] unit-test
-[ t ] [ pi <float> [ { byte-array } declare *float ] compile-1 pi - -0.001 0.001 between? ] unit-test
+[ t ] [ pi <float> [ { byte-array } declare *float ] compile-call pi - -0.001 0.001 between? ] unit-test
 
-[ t ] [ pi 8 <byte-array> [ [ { float byte-array } declare 0 set-alien-double ] compile-1 ] keep *double pi = ] unit-test
+[ t ] [ pi 8 <byte-array> [ [ { float byte-array } declare 0 set-alien-double ] compile-call ] keep *double pi = ] unit-test
 
 [ 4 ] [
     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

core/compiler/test/optimizer.factor

@@ -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) ( x -- y ) dup 0 > [ 1- (the-test) ] when ; inline
-: the-test ( -- n ) 2 dup (the-test) ;
+: the-test ( -- x y ) 2 dup (the-test) ;
 
 [ 2 0 ] [ the-test ] unit-test
 
@@ -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 + ] compile-call ] unit-test
-[ 5 ] [ 5 [ 0 swap + ] compile-1 ] unit-test
+[ 5 ] [ 5 [ 0 swap + ] compile-call ] unit-test
 
-[ 5 ] [ 5 [ 0 - ] compile-1 ] unit-test
+[ 5 ] [ 5 [ 0 - ] compile-call ] unit-test
-[ -5 ] [ 5 [ 0 swap - ] compile-1 ] unit-test
+[ -5 ] [ 5 [ 0 swap - ] compile-call ] unit-test
-[ 0 ] [ 5 [ dup - ] compile-1 ] unit-test
+[ 0 ] [ 5 [ dup - ] compile-call ] unit-test
 
-[ 5 ] [ 5 [ 1 * ] compile-1 ] unit-test
+[ 5 ] [ 5 [ 1 * ] compile-call ] unit-test
-[ 5 ] [ 5 [ 1 swap * ] compile-1 ] unit-test
+[ 5 ] [ 5 [ 1 swap * ] compile-call ] unit-test
-[ 0 ] [ 5 [ 0 * ] compile-1 ] unit-test
+[ 0 ] [ 5 [ 0 * ] compile-call ] unit-test
-[ 0 ] [ 5 [ 0 swap * ] compile-1 ] unit-test
+[ 0 ] [ 5 [ 0 swap * ] compile-call ] unit-test
-[ -5 ] [ 5 [ -1 * ] compile-1 ] unit-test
+[ -5 ] [ 5 [ -1 * ] compile-call ] unit-test
-[ -5 ] [ 5 [ -1 swap * ] compile-1 ] unit-test
+[ -5 ] [ 5 [ -1 swap * ] compile-call ] unit-test
 
-[ 0 ] [ 5 [ 1 mod ] compile-1 ] unit-test
+[ 0 ] [ 5 [ 1 mod ] compile-call ] unit-test
-[ 0 ] [ 5 [ 1 rem ] compile-1 ] unit-test
+[ 0 ] [ 5 [ 1 rem ] compile-call ] unit-test
 
-[ 5 ] [ 5 [ -1 bitand ] compile-1 ] unit-test
+[ 5 ] [ 5 [ -1 bitand ] compile-call ] unit-test
-[ 0 ] [ 5 [ 0 bitand ] compile-1 ] unit-test
+[ 0 ] [ 5 [ 0 bitand ] compile-call ] unit-test
-[ 5 ] [ 5 [ -1 swap bitand ] compile-1 ] unit-test
+[ 5 ] [ 5 [ -1 swap bitand ] compile-call ] unit-test
-[ 0 ] [ 5 [ 0 swap bitand ] compile-1 ] unit-test
+[ 0 ] [ 5 [ 0 swap bitand ] compile-call ] unit-test
-[ 5 ] [ 5 [ dup bitand ] compile-1 ] unit-test
+[ 5 ] [ 5 [ dup bitand ] compile-call ] unit-test
 
-[ 5 ] [ 5 [ 0 bitor ] compile-1 ] unit-test
+[ 5 ] [ 5 [ 0 bitor ] compile-call ] unit-test
-[ -1 ] [ 5 [ -1 bitor ] compile-1 ] unit-test
+[ -1 ] [ 5 [ -1 bitor ] compile-call ] unit-test
-[ 5 ] [ 5 [ 0 swap bitor ] compile-1 ] unit-test
+[ 5 ] [ 5 [ 0 swap bitor ] compile-call ] unit-test
-[ -1 ] [ 5 [ -1 swap bitor ] compile-1 ] unit-test
+[ -1 ] [ 5 [ -1 swap bitor ] compile-call ] unit-test
-[ 5 ] [ 5 [ dup bitor ] compile-1 ] unit-test
+[ 5 ] [ 5 [ dup bitor ] compile-call ] unit-test
 
-[ 5 ] [ 5 [ 0 bitxor ] compile-1 ] unit-test
+[ 5 ] [ 5 [ 0 bitxor ] compile-call ] unit-test
-[ 5 ] [ 5 [ 0 swap bitxor ] compile-1 ] unit-test
+[ 5 ] [ 5 [ 0 swap bitxor ] compile-call ] unit-test
-[ -6 ] [ 5 [ -1 bitxor ] compile-1 ] unit-test
+[ -6 ] [ 5 [ -1 bitxor ] compile-call ] unit-test
-[ -6 ] [ 5 [ -1 swap bitxor ] compile-1 ] unit-test
+[ -6 ] [ 5 [ -1 swap bitxor ] compile-call ] unit-test
-[ 0 ] [ 5 [ dup bitxor ] compile-1 ] unit-test
+[ 0 ] [ 5 [ dup bitxor ] compile-call ] unit-test
 
-[ 0 ] [ 5 [ 0 swap shift ] compile-1 ] unit-test
+[ 0 ] [ 5 [ 0 swap shift ] compile-call ] unit-test
-[ 5 ] [ 5 [ 0 shift ] compile-1 ] unit-test
+[ 5 ] [ 5 [ 0 shift ] compile-call ] unit-test
 
-[ f ] [ 5 [ dup < ] compile-1 ] unit-test
+[ f ] [ 5 [ dup < ] compile-call ] unit-test
-[ t ] [ 5 [ dup <= ] compile-1 ] unit-test
+[ t ] [ 5 [ dup <= ] compile-call ] unit-test
-[ f ] [ 5 [ dup > ] compile-1 ] unit-test
+[ f ] [ 5 [ dup > ] compile-call ] unit-test
-[ t ] [ 5 [ dup >= ] compile-1 ] unit-test
+[ t ] [ 5 [ dup >= ] compile-call ] unit-test
 
-[ t ] [ 5 [ dup eq? ] compile-1 ] unit-test
+[ t ] [ 5 [ dup eq? ] compile-call ] unit-test
-[ t ] [ 5 [ dup = ] compile-1 ] unit-test
+[ t ] [ 5 [ dup = ] compile-call ] unit-test
-[ t ] [ 5 [ dup number= ] compile-1 ] unit-test
+[ t ] [ 5 [ dup number= ] compile-call ] unit-test
-[ t ] [ \ vector [ \ vector = ] compile-1 ] unit-test
+[ t ] [ \ vector [ \ vector = ] compile-call ] unit-test
 
 GENERIC: detect-number ( obj -- obj )
 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

core/compiler/test/redefine.factor

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

core/compiler/test/simple.factor

@@ -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
+[ 1 ] [ [ 1 ] compile-call ] unit-test
-[ 31 ] [ [ 31 ] compile-1 ] unit-test
+[ 31 ] [ [ 31 ] compile-call ] unit-test
-[ 255 ] [ [ 255 ] compile-1 ] unit-test
+[ 255 ] [ [ 255 ] compile-call ] unit-test
-[ -1 ] [ [ -1 ] compile-1 ] unit-test
+[ -1 ] [ [ -1 ] compile-call ] unit-test
-[ 65536 ] [ [ 65536 ] compile-1 ] unit-test
+[ 65536 ] [ [ 65536 ] compile-call ] unit-test
-[ -65536 ] [ [ -65536 ] compile-1 ] unit-test
+[ -65536 ] [ [ -65536 ] compile-call ] unit-test
-[ "hey" ] [ [ "hey" ] compile-1 ] unit-test
+[ "hey" ] [ [ "hey" ] compile-call ] unit-test
 
 ! Calls
 : no-op ;
 
-[ ] [ [ no-op ] compile-1 ] unit-test
+[ ] [ [ no-op ] compile-call ] unit-test
-[ 3 ] [ [ no-op 3 ] compile-1 ] unit-test
+[ 3 ] [ [ no-op 3 ] compile-call ] unit-test
-[ 3 ] [ [ 3 no-op ] compile-1 ] unit-test
+[ 3 ] [ [ 3 no-op ] compile-call ] unit-test
 
 : bar 4 ;
 
-[ 4 ] [ [ bar no-op ] compile-1 ] unit-test
+[ 4 ] [ [ bar no-op ] compile-call ] unit-test
-[ 4 3 ] [ [ no-op bar 3 ] compile-1 ] unit-test
+[ 4 3 ] [ [ no-op bar 3 ] compile-call ] unit-test
-[ 3 4 ] [ [ 3 no-op bar ] compile-1 ] unit-test
+[ 3 4 ] [ [ 3 no-op bar ] compile-call ] unit-test
 
 [ ] [ no-op ] unit-test
 
 ! Conditionals
 
-[ 1 ] [ t [ [ 1 ] [ 2 ] if ] compile-1 ] unit-test
+[ 1 ] [ t [ [ 1 ] [ 2 ] if ] compile-call ] unit-test
-[ 2 ] [ f [ [ 1 ] [ 2 ] if ] compile-1 ] unit-test
+[ 2 ] [ f [ [ 1 ] [ 2 ] if ] compile-call ] unit-test
-[ 1 3 ] [ t [ [ 1 ] [ 2 ] if 3 ] compile-1 ] unit-test
+[ 1 3 ] [ t [ [ 1 ] [ 2 ] if 3 ] compile-call ] unit-test
-[ 2 3 ] [ f [ [ 1 ] [ 2 ] if 3 ] compile-1 ] unit-test
+[ 2 3 ] [ f [ [ 1 ] [ 2 ] if 3 ] compile-call ] unit-test
 
-[ "hi" ] [ 0 [ { [ "hi" ] [ "bye" ] } dispatch ] compile-1 ] unit-test
+[ "hi" ] [ 0 [ { [ "hi" ] [ "bye" ] } dispatch ] compile-call ] unit-test
-[ "bye" ] [ 1 [ { [ "hi" ] [ "bye" ] } dispatch ] compile-1 ] unit-test
+[ "bye" ] [ 1 [ { [ "hi" ] [ "bye" ] } dispatch ] compile-call ] unit-test
 
-[ "hi" 3 ] [ 0 [ { [ "hi" ] [ "bye" ] } dispatch 3 ] compile-1 ] unit-test
+[ "hi" 3 ] [ 0 [ { [ "hi" ] [ "bye" ] } dispatch 3 ] compile-call ] unit-test
-[ "bye" 3 ] [ 1 [ { [ "hi" ] [ "bye" ] } dispatch 3 ] compile-1 ] unit-test
+[ "bye" 3 ] [ 1 [ { [ "hi" ] [ "bye" ] } dispatch 3 ] compile-call ] unit-test
 
-[ 4 1 ] [ 0 [ { [ bar 1 ] [ 3 1 ] } dispatch ] compile-1 ] unit-test
+[ 4 1 ] [ 0 [ { [ bar 1 ] [ 3 1 ] } dispatch ] compile-call ] unit-test
-[ 3 1 ] [ 1 [ { [ bar 1 ] [ 3 1 ] } dispatch ] compile-1 ] unit-test
+[ 3 1 ] [ 1 [ { [ bar 1 ] [ 3 1 ] } dispatch ] compile-call ] unit-test
-[ 4 1 3 ] [ 0 [ { [ bar 1 ] [ 3 1 ] } dispatch 3 ] compile-1 ] unit-test
+[ 4 1 3 ] [ 0 [ { [ bar 1 ] [ 3 1 ] } dispatch 3 ] compile-call ] unit-test
-[ 3 1 3 ] [ 1 [ { [ bar 1 ] [ 3 1 ] } dispatch 3 ] compile-1 ] unit-test
+[ 3 1 3 ] [ 1 [ { [ bar 1 ] [ 3 1 ] } dispatch 3 ] compile-call ] unit-test
 
 ! Labels
 
 : recursive ( ? -- ) [ f recursive ] when ; inline
 
-[ ] [ t [ recursive ] compile-1 ] unit-test
+[ ] [ t [ recursive ] compile-call ] unit-test
-
-\ recursive compile
 
 [ ] [ t recursive ] unit-test
 
 ! Make sure error reporting works
 
-[ [ dup ] compile-1 ] unit-test-fails
+[ [ dup ] compile-call ] unit-test-fails
-[ [ drop ] compile-1 ] unit-test-fails
+[ [ drop ] compile-call ] unit-test-fails
+
+! Regression
+
+[ ] [ [ callstack ] compile-call drop ] unit-test

core/compiler/test/stack-trace.factor

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

core/compiler/test/templates-early.factor

@@ -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" } ]

core/compiler/test/templates.factor

@@ -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
+[ 5000 ] [ [ 5000 ] compile-call ] unit-test
-[ "hi" ] [ [ "hi" ] compile-1 ] unit-test
+[ "hi" ] [ [ "hi" ] compile-call ] unit-test
 
-[ 1 2 3 4 ] [ [ 1 2 3 4 ] compile-1 ] unit-test
+[ 1 2 3 4 ] [ [ 1 2 3 4 ] compile-call ] unit-test
 
-[ 1 1 ] [ 1 [ dup ] compile-1 ] unit-test
+[ 1 1 ] [ 1 [ dup ] compile-call ] unit-test
-[ 0 ] [ 3 [ tag ] compile-1 ] unit-test
+[ 0 ] [ 3 [ tag ] compile-call ] unit-test
-[ 0 3 ] [ 3 [ [ tag ] keep ] compile-1 ] unit-test
+[ 0 3 ] [ 3 [ [ tag ] keep ] compile-call ] unit-test
 
-[ 2 3 ] [ 3 [ 2 swap ] compile-1 ] unit-test
+[ 2 3 ] [ 3 [ 2 swap ] compile-call ] unit-test
 
-[ 2 1 3 4 ] [ 1 2 [ swap 3 4 ] compile-1 ] unit-test
+[ 2 1 3 4 ] [ 1 2 [ swap 3 4 ] compile-call ] unit-test
 
-[ 2 3 4 ] [ 3 [ 2 swap 4 ] compile-1 ] unit-test
+[ 2 3 4 ] [ 3 [ 2 swap 4 ] compile-call ] unit-test
 
 [ { 1 2 3 } { 1 4 3 } 3 3 ]
-[ { 1 2 3 } { 1 4 3 } [ 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

core/compiler/test/tuples.factor

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

core/continuations/continuations-tests.factor

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

core/continuations/continuations.factor

@@ -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
+    over >r compose [ dip rethrow ] curry
-    [ dip rethrow ] curry ifcc ; inline
+    >r (catch) r> ifcc r> call ; inline
 
 : attempt-all ( seq quot -- obj )
     [

core/cpu/architecture/architecture.factor

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

core/cpu/arm/allot/allot.factor

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

core/cpu/arm/architecture/architecture.factor

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

core/cpu/arm/arm.factor

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

core/cpu/ppc/allot/allot.factor

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

core/cpu/ppc/architecture/architecture.factor

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

core/cpu/ppc/ppc.factor

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

core/cpu/x86/32/32.factor

@@ -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
     ] [

core/cpu/x86/32/bootstrap.factor

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

core/cpu/x86/64/64.factor

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

core/cpu/x86/allot/allot.factor

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

core/cpu/x86/architecture/architecture.factor

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

core/cpu/x86/assembler/assembler.factor

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

core/cpu/x86/bootstrap.factor

@@ -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 ;
+: stack-frame-size 4 bootstrap-cells ;
-
-: scan-save stack-reg 3 bootstrap-cells [+] ;
 
 [
-    arg0 arg0 quot-array@ [+] MOV              ! load array
+    ! Load word
-    scan-reg arg0 scan@ [+] LEA                ! initialize scan pointer
+    temp-reg 0 [] MOV
-] { } make jit-setup set                       
+    ! Bump profiling counter
+    temp-reg profile-count-offset [+] 1 tag-fixnum ADD
+    ! Load word->code
+    temp-reg temp-reg word-code-offset [+] MOV
+    ! Compute word XT
+    temp-reg compiled-header-size ADD
+    ! Jump to XT
+    temp-reg JMP
+] rc-absolute-cell rt-literal 2 jit-profiling jit-define
 
-[                                       
+[
-    stack-frame-size PUSH                      ! save stack frame size       
+    stack-frame-size PUSH                      ! save stack frame size
-    xt-reg PUSH                                ! save XT
+    0 PUSH                                     ! push XT
-    arg0 PUSH                                  ! save array
+    arg1 PUSH                                  ! alignment
-    stack-reg 4 bootstrap-cells SUB            ! reserve space for scan-save
+] rc-absolute-cell rt-xt 6 jit-prolog jit-define
-] { } make jit-prolog set                      
-                                               
-: advance-scan scan-reg bootstrap-cell ADD ;   
-                                               
-[                                              
-    advance-scan                               
-    ds-reg bootstrap-cell ADD                  ! increment datastack pointer
-    arg0 scan-reg [] MOV                       ! load literal
-    ds-reg [] arg0 MOV                         ! store literal on datastack
-] { } make jit-push-literal set                
 
-[                                              
+[
-    advance-scan                               
+    arg0 0 [] MOV                              ! load literal
     ds-reg bootstrap-cell ADD                  ! increment datastack pointer
-    arg0 scan-reg [] MOV                       ! load wrapper
-    arg0 dup wrapper@ [+] MOV                  ! load wrapper-obj slot
     ds-reg [] arg0 MOV                         ! store literal on datastack
-] { } make jit-push-wrapper set                
+] rc-absolute-cell rt-literal 2 jit-push-literal jit-define
-                                               
+
-[                                              
+[
     arg1 stack-reg MOV                         ! pass callstack pointer as arg 2
-] { } make jit-word-primitive-jump set         
+    (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
+    (CALL) drop
-] { } make jit-word-jump set                   
+] rc-relative rt-xt 1 jit-word-call jit-define
-                                               
+
-[                                              
+[
-    advance-scan                               
+    arg1 0 MOV                                 ! load addr of true quotation
-    scan-save scan-reg MOV                     ! save scan pointer
-    arg0 scan-reg [] MOV                       ! load word
-    arg0 word-xt@ [+] CALL                     ! call word XT
-    scan-reg scan-save MOV                     ! restore scan pointer
-] { } make jit-word-call set                   
-                                               
-: load-branch                                  
     arg0 ds-reg [] MOV                         ! load boolean
     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 arg1 [] CMOVNE                        ! load true branch if not equal
-    arg0 scan-reg 1 bootstrap-cells [+] CMOVNE ! load true branch if not equal
+    arg0 arg1 bootstrap-cell [+] CMOVE         ! load false branch if equal
-    scan-reg 3 bootstrap-cells ADD             ! advance scan pointer
+    arg0 quot-xt@ [+] JMP                      ! jump to quotation-xt
-    xt-reg arg0 quot-xt@ [+] MOV               ! load quotation-xt
+] rc-absolute-cell rt-literal 1 jit-if-jump jit-define
-    ;
-
-[
-    load-branch
-    xt-reg JMP
-] { } make jit-if-jump set
-
-[
-    load-branch
-    scan-save scan-reg MOV                     ! save scan pointer
-    xt-reg CALL                                ! call quotation
-    scan-reg scan-save MOV                     ! restore scan pointer
-] { } make jit-if-call set
 
 [
+    arg1 0 [] MOV                              ! load dispatch table
     arg0 ds-reg [] MOV                         ! load index
     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
+    arg0 quot-xt@ [+] JMP                      ! execute branch
-    xt-reg JMP                                 ! execute quotation
+] rc-absolute-cell rt-literal 2 jit-dispatch jit-define
-] { } make jit-dispatch set
 
 [
     stack-reg stack-frame-size bootstrap-cell - ADD ! unwind stack frame
-] { } 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

core/cpu/x86/intrinsics/intrinsics.factor

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

core/debugger/debugger-docs.factor

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

core/debugger/debugger.factor

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

core/definitions/definitions-docs.factor

@@ -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"
+ARTICLE: "definition-crossref" "Definition cross referencing"
-"A " { $emphasis "definition" } " is an artifact read from a source file. This includes words, methods, and help articles. Words for working with definitions are found in the " { $vocab-link "definitions" } " vocabulary."
-{ $subsection "definition-protocol" }
 "A common cross-referencing system is used to track definition usages:"
 { $subsection crossref }
 { $subsection xref }
 { $subsection unxref }
 { $subsection delete-xref }
-{ $subsection usage }
+{ $subsection usage } ;
-"Implementations of the definition protocol include pathnames, words, methods, and help articles."
+
-{ $see-also "source-files" "words" "generic" "help-impl" } ;
+ARTICLE: "definition-checking" "Definition sanity checking"
+"When a source file is reloaded, the parser compares the previous list of definitions with the current list; any definitions which are no longer present in the file are removed by a call to " { $link forget } ". A warning message is printed if any other definitions still depend on the removed definitions."
+$nl
+"The parser also catches forward references when reloading source files. This is best illustrated with an example. Suppose we load a source file " { $snippet "a.factor" } ":"
+{ $code
+    "USING: io sequences ;"
+    "IN: a"
+    ": hello \"Hello\" ;"
+    ": world \"world\" ;"
+    ": hello-world hello " " world 3append print ;"
+}
+"The definitions for " { $snippet "hello" } ", " { $snippet "world" } ", and " { $snippet "hello-world" } " are in the dictionary."
+$nl
+"Now, after some heavily editing and refactoring, the file looks like this:"
+{ $code
+    "USING: namespaces ;"
+    "IN: a"
+    ": hello \"Hello\" % ;"
+    ": hello-world [ hello " " % world ] \"\" make ;"
+    ": world \"world\" % ;"
+}
+"Note that the developer has made a mistake, placing the definition of " { $snippet "world" } " " { $emphasis "after" } " its usage in " { $snippet "hello-world" } "."
+$nl
+"If the parser did not have special checks for this case, then the modified source file would still load, because when the definition of " { $snippet "hello-world" } " on line 4 is being parsed, the " { $snippet "world" } " word is already present in the dictionary from an earlier run. The developer would then not discover this mistake until attempting to load the source file into a fresh image."
+$nl
+"Since this is undesirable, the parser explicitly raises an error if a source file refers to a word which is in the dictionary, but defined after it is used."
+{ $subsection forward-error }
+"If a source file raises a " { $link forward-error } " when loaded into a development image, then it would have raised a " { $link no-word } " error when loaded into a fresh image."
+$nl
+"The parser also catches duplicate definitions. If an artifact is defined twice in the same source file, the earlier definition will never be accessible, and this is almost always a mistake, perhaps due to a bad choice of word names, or a copy and paste error. The parser raises an error in this case."
+{ $subsection redefine-error } ;
+
+ARTICLE: "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." } ;

core/definitions/definitions-tests.factor

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

core/definitions/definitions.factor

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

core/float-arrays/float-arrays.factor

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

core/flow-chart/flow-chart.factor

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

core/generator/fixup/fixup.factor

@@ -127,12 +127,7 @@ SYMBOL: word-table
 
 : rel-dispatch ( word-table# class -- ) rt-dispatch rel-fixup ;
 
-GENERIC# rel-word 1 ( word class -- )
+: rel-word ( word class -- )
-
-M: primitive rel-word ( word class -- )
-    >r word-def r> rt-primitive rel-fixup ;
-
-M: word rel-word ( word class -- )
     >r add-word r> rt-xt rel-fixup ;
 
 : rel-literal ( literal class -- )

core/generator/generator-docs.factor

@@ -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 }
+{ $subsection generate } ;
-"Primitive compiler interface exported by the Factor VM:"
-{ $subsection add-compiled-block }
-{ $subsection finalize-compile } ;
 
 ABOUT: "generator"
 
-HELP: compiled-xts
+HELP: compiled
-{ $var-description "During compilation, holds a hashtable mapping words to temporary uninterned words. The XT of each value points to the compiled code block of each key; at the end of compilation, the XT of each key is set to the XT of the value." } ;
+{ $var-description "During compilation, holds a hashtable mapping words to 5-element arrays holding compiled code." } ;
-
-HELP: compiling?
-{ $values { "word" word } { "?" "a boolean" } }
-{ $description "Tests if a word is going to be or already is compiled." } ;
-
-HELP: finalize-compile ( xts -- )
-{ $values { "xts" "an association list mapping words to uninterned words" } }
-{ $description "Performs relocation, atomically changes the XT of each key to the XT of each value, and flushes the CPU instruction cache on architectures where this has to be done manually." } ;
-
-HELP: add-compiled-block ( literals words rel labels code -- xt )
-{ $values { "literals" vector } { "words" "a vector of words" } { "rel" "a vector of integers" } { "labels" "an array of integers" } { "code" "a vector of integers" } { "xt" "an uninterned word" } }
-{ $description "Adds a new compiled block and outputs an uninterned word whose XT points at this block. This uninterned word can then be passed to " { $link finalize-compile } "." } ;
 
 HELP: compiling-word
 { $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

core/generator/generator.factor

@@ -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 -- )
+: 5array 3array >r 2array r> append ;
-    swap dup unchanged-word compiled-xts get set-at ;
 
-: compiling? ( word -- ? )
+: begin-compiling ( word -- )
+    f swap compiled get set-at ;
+
+: finish-compiling ( word literals words relocation labels code -- )
+    5array swap compiled get set-at ;
+
+: queue-compile ( word -- )
     {
-        { [ dup compiled-xts get key? ] [ drop t ] }
+        { [ dup compiled get key? ] [ drop ] }
-        { [ dup word-changed? ] [ drop f ] }
+        { [ dup primitive? ] [ drop ] }
-        { [ t ] [ compiled? ] }
+        { [ dup deferred? ] [ drop ] }
+        { [ t ] [ dup compile-queue get set-at ] }
     } cond ;
 
+: 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 ;
+    ] { } make fixup finish-compiling ;
-
-: generate-profiler-prologue ( -- )
-    compiled-stack-traces? get [
-        compiling-word get %profiler-prologue
-    ] when ;
 
 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 ;
+    ] with-infer ;
-
-SYMBOL: compiler-hook
-
-[ ] compiler-hook set-global
-
-SYMBOL: compile-errors
-
-SYMBOL: batch-mode
-
-: compile-begins ( word -- )
-    compiler-hook get call
-    "quiet" get batch-mode get or [
-        drop
-    ] [
-        "Compiling " write . flush
-    ] if ;
-
-: (compile) ( word -- )
-    dup compiling? not over compound? and [
-        dup compile-begins
-        dup dup word-dataflow optimize generate
-    ] [
-        drop
-    ] if ;
 
 : intrinsics ( #call -- quot )
     node-param "intrinsics" word-prop ;
@@ -126,24 +106,17 @@ UNION: #terminal
 ! node
 M: node generate-node drop iterate-next ;
 
-: %call ( word -- )
+: %call ( word -- ) %call-label ;
-    dup primitive? [ %call-primitive ] [ %call-label ] if ;
 
 : %jump ( word -- )
-    {
+    dup compiling-label get eq? [
-        { [ dup compiling-label get eq? ] [
+        drop current-label-start get %jump-label
-            drop current-label-start get %jump-label
+    ] [
-        ] }
+        %epilogue-later %jump-label
-        { [ dup primitive? ] [
+    ] if ;
-            %epilogue-later %jump-primitive
-        ] }
-        { [ t ] [
-            %epilogue-later %jump-label
-        ] }
-    } cond ;
 
 : 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 ;

core/generic/generic-docs.factor

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

core/generic/generic-tests.factor

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

core/generic/generic.factor

@@ -5,8 +5,7 @@ definitions kernel.private classes classes.private
 quotations arrays vocabs ;
 IN: generic
 
-PREDICATE: compound generic ( word -- ? )
+PREDICATE: word generic "combination" word-prop >boolean ;
-    "combination" word-prop ;
 
 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 dup "combination" word-prop perform-combination define ;
-    dup "combination" word-prop perform-combination
-    define-compound ;
-
-: ?make-generic ( word -- )
-    [ [ ] define-compound ] [ make-generic ] if-bootstrapping ;
 
 : init-methods ( word -- )
      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 ;
-    [ class-usages implementors* [ make-generic ] each ]
-    if-bootstrapping ;

core/generic/standard/standard.factor

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

core/inference/backend/backend-docs.factor

@@ -1,17 +1,11 @@
 USING: help.syntax help.markup words effects inference.dataflow
-inference.backend kernel sequences kernel.private
+inference.state inference.backend kernel sequences
-combinators combinators.private ;
+kernel.private combinators combinators.private ;
-
-HELP: recursive-state
-{ $var-description "During inference, holds an association list mapping words to labels." } ;
 
 HELP: literal-expected
 { $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

core/inference/backend/backend.factor

@@ -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
+        [
-        dup word-def over dup infer-quot-recursive
+            init-inference
-        finish-word
+            dependencies off
-        current-effect
+            dup word-def over dup infer-quot-recursive
-    ] with-scope ;
+            finish-word
-
+            current-effect
-M: compound infer-word
+        ] with-scope
-    [ infer-compound ] [ ] [ t "no-effect" set-word-prop ]
+    ] [ ] [ t "no-effect" set-word-prop ] cleanup ;
-    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 )
     [
         [

core/inference/class/class-tests.factor

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

core/inference/dataflow/dataflow-docs.factor

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

core/inference/dataflow/dataflow.factor

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

core/inference/inference-docs.factor

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

core/inference/inference-tests.factor

@@ -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
+prettyprint io inspector tuples classes.union classes.predicate
-classes.union classes.predicate debugger bootstrap.image
+debugger threads.private io.streams.string combinators.private
-bootstrap.image.private io.launcher threads.private
+tools.test.inference ;
-io.streams.string combinators.private tools.test.inference ;
 IN: temporary
 
 { 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
+\ bitor must-infer
-{ 2 1 } [ bitand ] unit-test-effect
+\ bitand must-infer
-{ 2 1 } [ bitxor ] unit-test-effect
+\ bitxor must-infer
-{ 2 1 } [ mod ] unit-test-effect
+\ mod must-infer
-{ 2 1 } [ /i ] unit-test-effect
+\ /i must-infer
-{ 2 1 } [ /f ] unit-test-effect
+\ /f must-infer
-{ 2 2 } [ /mod ] unit-test-effect
+\ /mod must-infer
-{ 2 1 } [ + ] unit-test-effect
+\ + must-infer
-{ 2 1 } [ - ] unit-test-effect
+\ - must-infer
-{ 2 1 } [ * ] unit-test-effect
+\ * must-infer
-{ 2 1 } [ / ] unit-test-effect
+\ / must-infer
-{ 2 1 } [ < ] unit-test-effect
+\ < must-infer
-{ 2 1 } [ <= ] unit-test-effect
+\ <= must-infer
-{ 2 1 } [ > ] unit-test-effect
+\ > must-infer
-{ 2 1 } [ >= ] unit-test-effect
+\ >= must-infer
-{ 2 1 } [ number= ] unit-test-effect
+\ number= must-infer
 
 ! Test object protocol
-{ 2 1 } [ = ] unit-test-effect
+\ = must-infer
-{ 1 1 } [ clone ] unit-test-effect
+\ clone must-infer
-{ 2 1 } [ hashcode* ] unit-test-effect
+\ hashcode* must-infer
 
 ! Test sequence protocol
-{ 1 1 } [ length ] unit-test-effect
+\ length must-infer
-{ 2 1 } [ nth ] unit-test-effect
+\ nth must-infer
-{ 2 0 } [ set-length ] unit-test-effect
+\ set-length must-infer
-{ 3 0 } [ set-nth ] unit-test-effect
+\ set-nth must-infer
-{ 2 1 } [ new ] unit-test-effect
+\ new must-infer
-{ 2 1 } [ new-resizable ] unit-test-effect
+\ new-resizable must-infer
-{ 2 1 } [ like ] unit-test-effect
+\ like must-infer
-{ 2 0 } [ lengthen ] unit-test-effect
+\ lengthen must-infer
 
 ! Test assoc protocol
-{ 2 2 } [ at* ] unit-test-effect
+\ at* must-infer
-{ 3 0 } [ set-at ] unit-test-effect
+\ set-at must-infer
-{ 2 1 } [ new-assoc ] unit-test-effect
+\ new-assoc must-infer
-{ 2 0 } [ delete-at ] unit-test-effect
+\ delete-at must-infer
-{ 1 0 } [ clear-assoc ] unit-test-effect
+\ clear-assoc must-infer
-{ 1 1 } [ assoc-size ] unit-test-effect
+\ assoc-size must-infer
-{ 2 1 } [ assoc-like ] unit-test-effect
+\ assoc-like must-infer
-{ 2 1 } [ assoc-clone-like ] unit-test-effect
+\ assoc-clone-like must-infer
-{ 1 1 } [ >alist ] unit-test-effect
+\ >alist must-infer
 { 1 3 } [ [ 2drop f ] assoc-find ] unit-test-effect
 
 ! Test some random library words
-{ 1 1 } [ 1quotation ] unit-test-effect
+\ 1quotation must-infer
-{ 1 1 } [ string>number ] unit-test-effect
+\ string>number must-infer
-{ 1 1 } [ get ] unit-test-effect
+\ get must-infer
 
-{ 2 0 } [ push ] unit-test-effect
+\ push must-infer
-{ 2 1 } [ append ] unit-test-effect
+\ append must-infer
-{ 1 1 } [ peek ] unit-test-effect
+\ peek must-infer
 
-{ 1 1 } [ reverse ] unit-test-effect
+\ reverse must-infer
-{ 2 1 } [ member? ] unit-test-effect
+\ member? must-infer
-{ 2 1 } [ remove ] unit-test-effect
+\ remove must-infer
-{ 1 1 } [ natural-sort ] unit-test-effect
+\ natural-sort must-infer
 
-{ 1 0 } [ forget ] unit-test-effect
+\ forget must-infer
-{ 4 0 } [ define-class ] unit-test-effect
+\ define-class must-infer
-{ 2 0 } [ define-tuple-class ] unit-test-effect
+\ define-tuple-class must-infer
-{ 2 0 } [ define-union-class ] unit-test-effect
+\ define-union-class must-infer
-{ 3 0 } [ define-predicate-class ] unit-test-effect
+\ define-predicate-class must-infer
 
 ! Test words with continuations
 { 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
+\ set-timeout must-infer
-{ 2 1 } [ stream-read ] unit-test-effect
+\ stream-read must-infer
-{ 1 1 } [ stream-read1 ] unit-test-effect
+\ stream-read1 must-infer
-{ 1 1 } [ stream-readln ] unit-test-effect
+\ stream-readln must-infer
-{ 2 2 } [ stream-read-until ] unit-test-effect
+\ stream-read-until must-infer
-{ 2 0 } [ stream-write ] unit-test-effect
+\ stream-write must-infer
-{ 2 0 } [ stream-write1 ] unit-test-effect
+\ stream-write1 must-infer
-{ 1 0 } [ stream-nl ] unit-test-effect
+\ stream-nl must-infer
-{ 1 0 } [ stream-close ] unit-test-effect
+\ stream-close must-infer
-{ 3 0 } [ stream-format ] unit-test-effect
+\ stream-format must-infer
-{ 3 0 } [ stream-write-table ] unit-test-effect
+\ stream-write-table must-infer
-{ 1 0 } [ stream-flush ] unit-test-effect
+\ stream-flush must-infer
-{ 2 1 } [ make-span-stream ] unit-test-effect
+\ make-span-stream must-infer
-{ 2 1 } [ make-block-stream ] unit-test-effect
+\ make-block-stream must-infer
-{ 2 1 } [ make-cell-stream ] unit-test-effect
+\ make-cell-stream must-infer
 
 ! Test stream utilities
-{ 1 1 } [ lines ] unit-test-effect
+\ lines must-infer
-{ 1 1 } [ contents ] unit-test-effect
+\ contents must-infer
 
 ! Test prettyprinting
-{ 1 0 } [ . ] unit-test-effect
+\ . must-infer
-{ 1 0 } [ short. ] unit-test-effect
+\ short. must-infer
-{ 1 1 } [ unparse ] unit-test-effect
+\ unparse must-infer
 
-{ 1 0 } [ describe ] unit-test-effect
+\ describe must-infer
-{ 1 0 } [ error. ] unit-test-effect
+\ error. must-infer
 
 ! Test odds and ends
-{ 1 1 } [ ' ] unit-test-effect
+\ idle-thread must-infer
-{ 2 0 } [ write-image ] unit-test-effect
-{ 1 1 } [ <process-stream> ] unit-test-effect
-{ 0 0 } [ idle-thread ] unit-test-effect
 
 ! Incorrect stack declarations on inline recursive words should
 ! be caught

core/inference/inference.factor

@@ -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.state inference.dataflow
-USING: inference.backend 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 ;

core/inference/known-words/known-words.factor

@@ -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
+generic hashtables hashtables.private inference.state
-inference.dataflow io io.backend io.files io.files.private
+inference.backend inference.dataflow io io.backend io.files
-io.streams.c kernel kernel.private math math.private memory
+io.files.private io.streams.c kernel kernel.private math
-namespaces namespaces.private parser prettyprint quotations
+math.private memory namespaces namespaces.private parser
-quotations.private sbufs sbufs.private sequences
+prettyprint quotations quotations.private sbufs sbufs.private
-sequences.private slots.private strings strings.private system
+sequences sequences.private slots.private strings
-threads.private tuples tuples.private vectors vectors.private
+strings.private system threads.private tuples tuples.private
-words assocs ;
+vectors vectors.private words words.private assocs inspector ;
+IN: inference.known-words
 
 ! Shuffle words
 : 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>
+    infer->r peek-d infer-call
-    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

core/inference/state/state-docs.factor

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

core/inference/state/state.factor

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

core/inference/transforms/transforms.factor

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

core/io/crc32/crc32.factor

@@ -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,
+: crc32-table V{ } ; inline
-! instead of using a variable, so that the compiler can inline
-! the call to nth-unsafe
-DEFER: crc32-table inline
 
-\ crc32-table
 256 [
     8 [
         dup even? >r 2/ r> [ crc32-polynomial bitxor ] unless
     ] times >bignum
-] map
+] map 0 crc32-table copy
-1quotation define-inline
 
 : (crc32) ( crc ch -- crc )
     >bignum dupd bitxor

core/kernel/kernel-docs.factor

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

core/kernel/kernel-tests.factor

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

core/kernel/kernel.factor

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

core/layouts/layouts-docs.factor

@@ -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
+HELP: tag-fixnum
-{ $values { "n" "a built-in type number" } { "tagged" integer } }
+{ $values { "n" integer } { "tagged" integer } }
-{ $description "Outputs the header for objects of type " { $snippet "n" } "." } ;
+{ $description "Outputs a tagged fixnum." } ;
 
 HELP: first-bignum
 { $values { "n" "smallest positive integer not representable by a fixnum" } } ;

core/layouts/layouts.factor

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

core/listener/listener-docs.factor

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

core/listener/listener-tests.factor

@@ -1,15 +1,17 @@
-USING: io io.streams.string listener tools.test parser
+USING: io io.streams.string io.streams.duplex listener
-math namespaces continuations vocabs ;
+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" 
+                "\\ + 1 2 3 4" parse-interactive
-                <string-reader>
+                "cont" get continue-with
-                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>
+    "USE: vocabs.loader.test.c" parse-interactive
-    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

core/listener/listener.factor

@@ -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-interactive ( lines -- quot/f )
-    [ parse-lines ] catch {
+    [ 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
+        dup read-quot-step dup
-        [ 2nip ] [ drop parse-interactive-loop ] if
+        [ 2nip ] [ drop read-quot-loop ] if
     ] [
         3drop f
     ] if ;
 
-M: line-reader parse-interactive
+M: line-reader stream-read-quot
-    [
+    V{ } clone read-quot-loop ;
-        V{ } clone parse-interactive-loop in get
-    ] with-scope in set ;
 
-M: duplex-stream parse-interactive
+M: duplex-stream stream-read-quot
-    duplex-stream-in parse-interactive ;
+    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.
-    [
+    [ read-quot [ call ] [ bye ] if* ] try ;
-        stdio get parse-interactive [ 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
+    print-banner [ until-quit ] with-interactive-vocabs ;
-    [ use [ clone ] change until-quit ] with-scope ;
 
 MAIN: listener

core/math/math-docs.factor

@@ -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." }
+{ $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." } ;
 
-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." } ;
 

core/memory/memory-tests.factor

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

core/parser/parser-docs.factor

@@ -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) } "." } ;
+{ $description "Outputs the current parser location. This value can be passed to " { $link set-where } " or " { $link remember-definition } "." } ;
-
-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 } "." } ;
 
 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
+HELP: with-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." } ;
+{ $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
-{ $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: 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." }
+{ $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 quotation throws an error." } ;
+{ $errors "Throws an error if the input is malformed, or if the evaluation itself 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 } "." } ;
 
 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." } ;

core/parser/parser-tests.factor

@@ -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 [ 2 [ 3 ] 4 ] 5 ]
-    [ "1\n[\n2\n[\n3\n]\n4\n]\n5" parse ]
+    [ "1\n[\n2\n[\n3\n]\n4\n]\n5" eval ]
     unit-test
 
-    [ [ t t f f ] ]
+    [ t t f f ]
-    [ "t t f f" parse ]
+    [ "t t f f" eval ]
     unit-test
 
-    [ [ "hello world" ] ]
+    [ "hello world" ]
-    [ "\"hello world\"" parse ]
+    [ "\"hello world\"" eval ]
     unit-test
 
-    [ [ "\n\r\t\\" ] ]
+    [ "\n\r\t\\" ]
-    [ "\"\\n\\r\\t\\\\\"" parse ]
+    [ "\"\\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
+    [ "HEX: zzz" eval ] unit-test-fails
-    [ "OCT: 999" parse ] unit-test-fails
+    [ "OCT: 999" eval ] unit-test-fails
-    [ "BIN: --0" parse ] unit-test-fails
+    [ "BIN: --0" eval ] unit-test-fails
-
-    [ f ] [
-        "IN: temporary : foo ; TUPLE: foo ;" parse drop
-        "foo" "temporary" lookup symbol?
-    ] unit-test
 
     ! 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-file-vocabs
-            ] with-scope
 
             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
+        "USE: temporary \\ foo" eval
-        first "foo" "temporary" lookup eq?
+        "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 get parsed >> file set
-
-    FILE 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

core/parser/parser.factor

@@ -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
+        "scratchpad" in set
-    bootstrap-syntax get [ use get push ] when* ;
+        { "syntax" "scratchpad" } set-use
+        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 ;
+    [ parse-lines ] with-file-vocabs ;
-
-SYMBOL: parse-hook
-
-: do-parse-hook ( -- ) parse-hook get [ call ] when* ;
 
 : 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
+    removed-definitions filter-moved keys [
-    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 -- )
+: finish-parsing ( contents quot -- )
-    new-definitions get swap set-source-file-definitions ;
+    file get
-
+    [ record-form ] keep
-: finish-parsing ( quot -- )
+    [ record-modified ] keep
-    file get dup [
+    [ record-definitions ] keep
-        [ record-form ] keep
+    record-checksum ;
-        [ 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* ;
 
 : parse-stream ( stream name -- quot )
     [
         [
-            start-parsing
+            contents
-            \ contents get string-lines parse-fresh
+            dup string-lines parse-fresh
-            dup finish-parsing
+            tuck finish-parsing
-        ] [ ] [ undo-parsing ] cleanup
+            forget-smudged
-    ] no-parse-hook ;
+        ] 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
+            [ parsing-file ] keep
-        parse-stream
+            [ ?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 % ] [ run-file ] if-bootstrapping ;
-        parse-file [ call ] curry %
-    ] [
-        run-file
-    ] if-bootstrapping ;
 
-: ?bootstrap-file ( path -- )
+: eval ( str -- )
-    dup ?resource-path exists? [ bootstrap-file ] [ drop ] if ;
+    [ string-lines parse-fresh ] with-compilation-unit call ;
-
-: parse ( str -- quot ) string-lines parse-lines ;
-
-: eval ( str -- ) parse 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