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

Makefile

@@ -9,15 +9,16 @@ VERSION = 0.92
 
 BUNDLE = Factor.app
 LIBPATH = -L/usr/X11R6/lib
-CFLAGS = -Wall
+CFLAGS = -Wall -Werror
-FFI_TEST_CFLAGS = -fPIC
 
 ifdef DEBUG
-	CFLAGS += -g
+	CFLAGS += -g -DFACTOR_DEBUG
 else
-	CFLAGS += -O3 $(SITE_CFLAGS)
+	CFLAGS += -O3
 endif
 
+CFLAGS += $(SITE_CFLAGS)
+
 ENGINE = $(DLL_PREFIX)factor$(DLL_SUFFIX)$(DLL_EXTENSION)
 
 ifdef CONFIG
@@ -26,7 +27,10 @@ endif
 
 DLL_OBJS = $(PLAF_DLL_OBJS) \
 	vm/alien.o \
+	vm/arrays.o \
 	vm/bignum.o \
+	vm/booleans.o \
+	vm/byte_arrays.o \
 	vm/callstack.o \
 	vm/code_block.o \
 	vm/code_gc.o \
@@ -34,17 +38,22 @@ DLL_OBJS = $(PLAF_DLL_OBJS) \
 	vm/data_gc.o \
 	vm/data_heap.o \
 	vm/debug.o \
+	vm/dispatch.o \
 	vm/errors.o \
 	vm/factor.o \
 	vm/image.o \
+	vm/inline_cache.o \
 	vm/io.o \
+	vm/jit.o \
 	vm/math.o \
 	vm/primitives.o \
 	vm/profiler.o \
 	vm/quotations.o \
 	vm/run.o \
-	vm/types.o \
+	vm/strings.o \
-	vm/utilities.o
+	vm/tuples.o \
+	vm/utilities.o \
+	vm/words.o
 
 EXE_OBJS = $(PLAF_EXE_OBJS)
 
@@ -181,5 +190,5 @@ vm/ffi_test.o: vm/ffi_test.c
 
 .m.o:
 	$(CC) -c $(CFLAGS) -o $@ $<
-	
+
 .PHONY: factor

basis/alarms/alarms.factor

@@ -71,7 +71,7 @@ ERROR: bad-alarm-frequency frequency ;
     ] when* ;
 
 : init-alarms ( -- )
-    alarms global [ cancel-alarms <min-heap> ] change-at
+    alarms [ cancel-alarms <min-heap> ] change-global
     [ alarm-thread-loop t ] "Alarms" spawn-server
     alarm-thread set-global ;
 

basis/alien/libraries/libraries-docs.factor

@@ -15,7 +15,7 @@ HELP: libraries
 { $description "A global hashtable that keeps a list of open libraries. Use the " { $link add-library } " word to construct a library and add it with a single call." } ;
 
 HELP: library
-{ $values { "name" "a string" } { "library" "a hashtable" } }
+{ $values { "name" "a string" } { "library" assoc } }
 { $description "Looks up a library by its logical name. The library object is a hashtable with the following keys:"
     { $list
         { { $snippet "name" } " - the full path of the C library binary" }

basis/alien/remote-control/remote-control.factor

@@ -15,7 +15,7 @@ IN: alien.remote-control
     "void" { "long" } "cdecl" [ sleep ] alien-callback ;
 
 : ?callback ( word -- alien )
-    dup optimized>> [ execute ] [ drop f ] if ; inline
+    dup optimized? [ execute ] [ drop f ] if ; inline
 
 : init-remote-control ( -- )
     \ eval-callback ?callback 16 setenv

basis/bootstrap/compiler/compiler.factor

@@ -5,7 +5,7 @@ sequences namespaces parser kernel kernel.private classes
 classes.private arrays hashtables vectors classes.tuple sbufs
 hashtables.private sequences.private math classes.tuple.private
 growable namespaces.private assocs words command-line vocabs io
-io.encodings.string libc splitting math.parser
+io.encodings.string libc splitting math.parser memory
 compiler.units math.order compiler.tree.builder
 compiler.tree.optimizer compiler.cfg.optimizer ;
 IN: bootstrap.compiler
@@ -23,10 +23,13 @@ IN: bootstrap.compiler
 
 "cpu." cpu name>> append require
 
-enable-compiler
+enable-optimizer
+
+! Push all tuple layouts to tenured space to improve method caching
+gc
 
 : compile-unoptimized ( words -- )
-    [ optimized>> not ] filter compile ;
+    [ optimized? not ] filter compile ;
 
 nl
 "Compiling..." write flush

basis/bootstrap/image/image.factor

@@ -3,14 +3,13 @@
 USING: alien arrays byte-arrays generic assocs hashtables assocs
 hashtables.private io io.binary io.files io.encodings.binary
 io.pathnames kernel kernel.private math namespaces make parser
-prettyprint sequences sequences.private strings sbufs
+prettyprint sequences sequences.private strings sbufs vectors words
-vectors words quotations assocs system layouts splitting
+quotations assocs system layouts splitting grouping growable classes
-grouping growable classes classes.builtin classes.tuple
+classes.builtin classes.tuple classes.tuple.private vocabs
-classes.tuple.private words.private vocabs
+vocabs.loader source-files definitions debugger quotations.private
-vocabs.loader source-files definitions debugger
+sequences.private combinators math.order math.private accessors
-quotations.private sequences.private combinators
+slots.private generic.single.private compiler.units compiler.constants
-math.order math.private accessors
+fry ;
-slots.private compiler.units fry ;
 IN: bootstrap.image
 
 : arch ( os cpu -- arch )
@@ -94,13 +93,30 @@ CONSTANT: -1-offset             9
 
 SYMBOL: sub-primitives
 
-: make-jit ( quot rc rt offset -- quad )
+SYMBOL: jit-define-rc
-    [ [ call( -- ) ] { } make ] 3dip 4array ;
+SYMBOL: jit-define-rt
+SYMBOL: jit-define-offset
 
-: jit-define ( quot rc rt offset name -- )
+: compute-offset ( -- offset )
+    building get length jit-define-rc get rc-absolute-cell = bootstrap-cell 4 ? - ;
+
+: jit-rel ( rc rt -- )
+    jit-define-rt set
+    jit-define-rc set
+    compute-offset jit-define-offset set ;
+
+: make-jit ( quot -- quad )
+    [
+        call( -- )
+        jit-define-rc get
+        jit-define-rt get
+        jit-define-offset get 3array
+    ] B{ } make prefix ;
+
+: jit-define ( quot name -- )
     [ make-jit ] dip set ;
 
-: define-sub-primitive ( quot rc rt offset word -- )
+: define-sub-primitive ( quot word -- )
     [ make-jit ] dip sub-primitives get set-at ;
 
 ! The image being constructed; a vector of word-size integers
@@ -119,7 +135,6 @@ SYMBOL: bootstrap-global
 SYMBOL: bootstrap-boot-quot
 
 ! JIT parameters
-SYMBOL: jit-code-format
 SYMBOL: jit-prolog
 SYMBOL: jit-primitive-word
 SYMBOL: jit-primitive
@@ -129,20 +144,36 @@ SYMBOL: jit-push-immediate
 SYMBOL: jit-if-word
 SYMBOL: jit-if-1
 SYMBOL: jit-if-2
-SYMBOL: jit-dispatch-word
-SYMBOL: jit-dispatch
 SYMBOL: jit-dip-word
 SYMBOL: jit-dip
 SYMBOL: jit-2dip-word
 SYMBOL: jit-2dip
 SYMBOL: jit-3dip-word
 SYMBOL: jit-3dip
+SYMBOL: jit-execute-word
+SYMBOL: jit-execute-jump
+SYMBOL: jit-execute-call
 SYMBOL: jit-epilog
 SYMBOL: jit-return
 SYMBOL: jit-profiling
-SYMBOL: jit-declare-word
 SYMBOL: jit-save-stack
 
+! PIC stubs
+SYMBOL: pic-load
+SYMBOL: pic-tag
+SYMBOL: pic-hi-tag
+SYMBOL: pic-tuple
+SYMBOL: pic-hi-tag-tuple
+SYMBOL: pic-check-tag
+SYMBOL: pic-check
+SYMBOL: pic-hit
+SYMBOL: pic-miss-word
+
+! Megamorphic dispatch
+SYMBOL: mega-lookup
+SYMBOL: mega-lookup-word
+SYMBOL: mega-miss-word
+
 ! Default definition for undefined words
 SYMBOL: undefined-quot
 
@@ -150,7 +181,6 @@ SYMBOL: undefined-quot
     H{
         { bootstrap-boot-quot 20 }
         { bootstrap-global 21 }
-        { jit-code-format 22 }
         { jit-prolog 23 }
         { jit-primitive-word 24 }
         { jit-primitive 25 }
@@ -159,20 +189,32 @@ SYMBOL: undefined-quot
         { jit-if-word 28 }
         { jit-if-1 29 }
         { jit-if-2 30 }
-        { jit-dispatch-word 31 }
-        { jit-dispatch 32 }
         { jit-epilog 33 }
         { jit-return 34 }
         { jit-profiling 35 }
         { jit-push-immediate 36 }
-        { jit-declare-word 42 }
+        { jit-save-stack 38 }
-        { jit-save-stack 43 }
+        { jit-dip-word 39 }
-        { jit-dip-word 44 }
+        { jit-dip 40 }
-        { jit-dip 45 }
+        { jit-2dip-word 41 }
-        { jit-2dip-word 46 }
+        { jit-2dip 42 }
-        { jit-2dip 47 }
+        { jit-3dip-word 43 }
-        { jit-3dip-word 48 }
+        { jit-3dip 44 }
-        { jit-3dip 49 }
+        { jit-execute-word 45 }
+        { jit-execute-jump 46 }
+        { jit-execute-call 47 }
+        { pic-load 48 }
+        { pic-tag 49 }
+        { pic-hi-tag 50 }
+        { pic-tuple 51 }
+        { pic-hi-tag-tuple 52 }
+        { pic-check-tag 53 }
+        { pic-check 54 }
+        { pic-hit 55 }
+        { pic-miss-word 56 }
+        { mega-lookup 57 }
+        { mega-lookup-word 58 }
+        { mega-miss-word 59 }
         { undefined-quot 60 }
     } ; inline
 
@@ -205,8 +247,8 @@ SYMBOL: undefined-quot
 
 : emit-fixnum ( n -- ) tag-fixnum emit ;
 
-: emit-object ( header tag quot -- addr )
+: emit-object ( class quot -- addr )
-    swap here-as [ swap tag-fixnum emit call align-here ] dip ;
+    over tag-number here-as [ swap type-number tag-fixnum emit call align-here ] dip ;
     inline
 
 ! Write an object to the image.
@@ -251,7 +293,7 @@ GENERIC: ' ( obj -- ptr )
 
 M: bignum '
     [
-        bignum tag-number dup [ emit-bignum ] emit-object
+        bignum [ emit-bignum ] emit-object
     ] cache-object ;
 
 ! Fixnums
@@ -274,7 +316,7 @@ M: fake-bignum ' n>> tag-fixnum ;
 
 M: float '
     [
-        float tag-number dup [
+        float [
             align-here double>bits emit-64
         ] emit-object
     ] cache-object ;
@@ -309,7 +351,7 @@ M: f '
                     [ vocabulary>> , ]
                     [ def>> , ]
                     [ props>> , ]
-                    [ drop f , ]
+                    [ direct-entry-def>> , ] ! direct-entry-def
                     [ drop 0 , ] ! count
                     [ word-sub-primitive , ]
                     [ drop 0 , ] ! xt
@@ -318,8 +360,7 @@ M: f '
                 } cleave
             ] { } make [ ' ] map
         ] bi
-        \ word type-number object tag-number
+        \ word [ emit-seq ] emit-object
-        [ emit-seq ] emit-object
     ] keep put-object ;
 
 : word-error ( word msg -- * )
@@ -340,8 +381,7 @@ M: word ' ;
 ! Wrappers
 
 M: wrapper '
-    wrapped>> ' wrapper type-number object tag-number
+    wrapped>> ' wrapper [ emit ] emit-object ;
-    [ emit ] emit-object ;
 
 ! Strings
 : native> ( object -- object )
@@ -370,7 +410,7 @@ M: wrapper '
 
 : emit-string ( string -- ptr )
     [ length ] [ extended-part ' ] [ ] tri
-    string type-number object tag-number [
+    string [
         [ emit-fixnum ]
         [ emit ]
         [ f ' emit ascii-part pad-bytes emit-bytes ]
@@ -387,12 +427,11 @@ M: string '
 
 : emit-dummy-array ( obj type -- ptr )
     [ assert-empty ] [
-        type-number object tag-number
         [ 0 emit-fixnum ] emit-object
     ] bi* ;
 
 M: byte-array '
-    byte-array type-number object tag-number [
+    byte-array [
         dup length emit-fixnum
         pad-bytes emit-bytes
     ] emit-object ;
@@ -406,7 +445,7 @@ ERROR: tuple-removed class ;
 : (emit-tuple) ( tuple -- pointer )
     [ tuple-slots ]
     [ class transfer-word require-tuple-layout ] bi prefix [ ' ] map
-    tuple type-number dup [ emit-seq ] emit-object ;
+    tuple [ emit-seq ] emit-object ;
 
 : emit-tuple ( tuple -- pointer )
     dup class name>> "tombstone" =
@@ -421,8 +460,7 @@ M: tombstone '
 
 ! Arrays
 : emit-array ( array -- offset )
-    [ ' ] map array type-number object tag-number
+    [ ' ] map array [ [ length emit-fixnum ] [ emit-seq ] bi ] emit-object ;
-    [ [ length emit-fixnum ] [ emit-seq ] bi ] emit-object ;
 
 M: array ' emit-array ;
 
@@ -448,7 +486,7 @@ M: tuple-layout-array '
 M: quotation '
     [
         array>> '
-        quotation type-number object tag-number [
+        quotation [
             emit ! array
             f ' emit ! compiled
             f ' emit ! cached-effect
@@ -480,15 +518,16 @@ M: quotation '
 
 : emit-jit-data ( -- )
     \ if jit-if-word set
-    \ dispatch jit-dispatch-word set
     \ do-primitive jit-primitive-word set
-    \ declare jit-declare-word set
     \ dip jit-dip-word set
     \ 2dip jit-2dip-word set
     \ 3dip jit-3dip-word set
+    \ (execute) jit-execute-word set
+    \ inline-cache-miss \ pic-miss-word set
+    \ mega-cache-lookup \ mega-lookup-word set
+    \ mega-cache-miss \ mega-miss-word set
     [ undefined ] undefined-quot set
     {
-        jit-code-format
         jit-prolog
         jit-primitive-word
         jit-primitive
@@ -498,19 +537,31 @@ M: quotation '
         jit-if-word
         jit-if-1
         jit-if-2
-        jit-dispatch-word
-        jit-dispatch
         jit-dip-word
         jit-dip
         jit-2dip-word
         jit-2dip
         jit-3dip-word
         jit-3dip
+        jit-execute-word
+        jit-execute-jump
+        jit-execute-call
         jit-epilog
         jit-return
         jit-profiling
-        jit-declare-word
         jit-save-stack
+        pic-load
+        pic-tag
+        pic-hi-tag
+        pic-tuple
+        pic-hi-tag-tuple
+        pic-check-tag
+        pic-check
+        pic-hit
+        pic-miss-word
+        mega-lookup
+        mega-lookup-word
+        mega-miss-word
         undefined-quot
     } [ emit-userenv ] each ;
 

basis/bootstrap/stage2.factor

@@ -35,10 +35,6 @@ SYMBOL: bootstrap-time
     "Core bootstrap completed in " write core-bootstrap-time get print-time
     "Bootstrap completed in "      write bootstrap-time      get print-time
 
-    [ optimized>> ] 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:" print
     vm write " -i=" write "output-image" get print flush ;

basis/calendar/calendar-tests.factor

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

basis/calendar/calendar.factor

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

basis/calendar/windows/windows.factor

@@ -1,5 +1,5 @@
-USING: calendar namespaces alien.c-types system windows
+USING: calendar namespaces alien.c-types system
-windows.kernel32 kernel math combinators ;
+windows.kernel32 kernel math combinators windows.errors ;
 IN: calendar.windows
 
 M: windows gmt-offset ( -- hours minutes seconds )

basis/cocoa/cocoa.factor

@@ -7,7 +7,7 @@ compiler.units lexer init ;
 IN: cocoa
 
 : (remember-send) ( selector variable -- )
-    global [ dupd ?set-at ] change-at ;
+    [ dupd ?set-at ] change-global ;
 
 SYMBOL: sent-messages
 

basis/cocoa/dialogs/dialogs.factor

@@ -12,6 +12,9 @@ IN: cocoa.dialogs
     dup 1 -> setResolvesAliases:
     dup 1 -> setAllowsMultipleSelection: ;
 
+: <NSDirPanel> ( -- panel ) <NSOpenPanel>
+   dup 1 -> setCanChooseDirectories: ;
+
 : <NSSavePanel> ( -- panel )
     NSSavePanel -> savePanel
     dup 1 -> setCanChooseFiles:
@@ -21,10 +24,12 @@ IN: cocoa.dialogs
 CONSTANT: NSOKButton 1
 CONSTANT: NSCancelButton 0
 
-: open-panel ( -- paths )
+: (open-panel) ( panel -- paths )
-    <NSOpenPanel>
     dup -> runModal NSOKButton =
     [ -> filenames CF>string-array ] [ drop f ] if ;
+    
+: open-panel ( -- paths ) <NSOpenPanel> (open-panel) ;
+: open-dir-panel ( -- paths ) <NSDirPanel> (open-panel) ;
 
 : split-path ( path -- dir file )
     "/" split1-last [ <NSString> ] bi@ ;

basis/combinators/smart/smart.factor

@@ -18,6 +18,10 @@ MACRO: input<sequence ( quot -- newquot )
     [ infer in>> ] keep
     '[ _ firstn @ ] ;
 
+MACRO: input<sequence-unsafe ( quot -- newquot )
+    [ infer in>> ] keep
+    '[ _ firstn-unsafe @ ] ;
+
 MACRO: reduce-outputs ( quot operation -- newquot )
     [ dup infer out>> 1 [-] ] dip n*quot compose ;
 

basis/command-line/command-line-docs.factor

@@ -1,5 +1,4 @@
-USING: help.markup help.syntax parser vocabs.loader strings
+USING: help.markup help.syntax parser vocabs.loader strings ;
-command-line.private ;
 IN: command-line
 
 HELP: run-bootstrap-init
@@ -53,6 +52,7 @@ ARTICLE: "runtime-cli-args" "Command line switches for the VM"
     { { $snippet "-aging=" { $emphasis "n" } } "Size of aging generation (1), megabytes" }
     { { $snippet "-tenured=" { $emphasis "n" } } "Size of oldest generation (2), megabytes" }
     { { $snippet "-codeheap=" { $emphasis "n" } } "Code heap size, megabytes" }
+    { { $snippet "-pic=" { $emphasis "n" } } "Maximum inline cache size. Setting of 0 disables inline caching, > 1 enables polymorphic inline caching" }
     { { $snippet "-securegc" } "If specified, unused portions of the data heap will be zeroed out after every garbage collection" }
 }
 "If an " { $snippet "-i=" } " switch is not present, the default image file is used, which is usually a file named " { $snippet "factor.image" } " in the same directory as the runtime executable (on Windows and Mac OS X) or the current directory (on Unix)." ;

basis/compiler/cfg/intrinsics/allot/allot.factor

@@ -27,11 +27,11 @@ IN: compiler.cfg.intrinsics.allot
         [ tuple ##set-slots ] [ ds-push drop ] 2bi
     ] [ drop emit-primitive ] if ;
 
-: store-length ( len reg -- )
+: store-length ( len reg class -- )
-    [ ^^load-literal ] dip 1 object tag-number ##set-slot-imm ;
+    [ [ ^^load-literal ] dip 1 ] dip tag-number ##set-slot-imm ;
 
-: store-initial-element ( elt reg len -- )
+:: store-initial-element ( len reg elt class -- )
-    [ 2 + object tag-number ##set-slot-imm ] with with each ;
+    len [ [ elt reg ] dip 2 + class tag-number ##set-slot-imm ] each ;
 
 : expand-<array>? ( obj -- ? )
     dup integer? [ 0 8 between? ] [ drop f ] if ;
@@ -42,8 +42,8 @@ IN: compiler.cfg.intrinsics.allot
             [let | elt [ ds-pop ]
                    reg [ len ^^allot-array ] |
                 ds-drop
-                len reg store-length
+                len reg array store-length
-                elt reg len store-initial-element
+                len reg elt array store-initial-element
                 reg ds-push
             ]
         ] [ node emit-primitive ] if
@@ -57,16 +57,16 @@ IN: compiler.cfg.intrinsics.allot
 : emit-allot-byte-array ( len -- dst )
     ds-drop
     dup ^^allot-byte-array
-    [ store-length ] [ ds-push ] [ ] tri ;
+    [ byte-array store-length ] [ ds-push ] [ ] tri ;
 
 : emit-(byte-array) ( node -- )
     dup node-input-infos first literal>> dup expand-<byte-array>?
     [ nip emit-allot-byte-array drop ] [ drop emit-primitive ] if ;
 
-: emit-<byte-array> ( node -- )
+:: emit-<byte-array> ( node -- )
-    dup node-input-infos first literal>> dup expand-<byte-array>? [
+    node node-input-infos first literal>> dup expand-<byte-array>? [
-        nip
+        :> len
-        [ 0 ^^load-literal ] dip
+        0 ^^load-literal :> elt
-        [ emit-allot-byte-array ] keep
+        len emit-allot-byte-array :> reg
-        bytes>cells store-initial-element
+        len reg elt byte-array store-initial-element
-    ] [ drop emit-primitive ] if ;
+    ] [ drop node emit-primitive ] if ;

basis/compiler/cfg/intrinsics/intrinsics.factor

@@ -52,8 +52,6 @@ IN: compiler.cfg.intrinsics
     arrays:<array>
     byte-arrays:<byte-array>
     byte-arrays:(byte-array)
-    math.private:<complex>
-    math.private:<ratio>
     kernel:<wrapper>
     alien.accessors:alien-unsigned-1
     alien.accessors:set-alien-unsigned-1
@@ -140,8 +138,6 @@ IN: compiler.cfg.intrinsics
         { \ arrays:<array> [ emit-<array> iterate-next ] }
         { \ byte-arrays:<byte-array> [ emit-<byte-array> iterate-next ] }
         { \ byte-arrays:(byte-array) [ emit-(byte-array) iterate-next ] }
-        { \ math.private:<complex> [ emit-simple-allot iterate-next ] }
-        { \ math.private:<ratio> [ emit-simple-allot iterate-next ] }
         { \ kernel:<wrapper> [ emit-simple-allot iterate-next ] }
         { \ alien.accessors:alien-unsigned-1 [ 1 emit-alien-unsigned-getter iterate-next ] }
         { \ alien.accessors:set-alien-unsigned-1 [ 1 emit-alien-integer-setter iterate-next ] }

basis/compiler/cfg/value-numbering/value-numbering-tests.factor

@@ -92,7 +92,7 @@ sequences ;
         T{ ##load-reference f V int-regs 1 + }
         T{ ##peek f V int-regs 2 D 0 }
         T{ ##compare f V int-regs 4 V int-regs 2 V int-regs 1 cc> }
-        T{ ##compare-imm f V int-regs 6 V int-regs 4 7 cc/= }
+        T{ ##compare-imm f V int-regs 6 V int-regs 4 5 cc/= }
         T{ ##replace f V int-regs 6 D 0 }
     } value-numbering trim-temps
 ] unit-test
@@ -110,7 +110,7 @@ sequences ;
         T{ ##load-reference f V int-regs 1 + }
         T{ ##peek f V int-regs 2 D 0 }
         T{ ##compare f V int-regs 4 V int-regs 2 V int-regs 1 cc<= }
-        T{ ##compare-imm f V int-regs 6 V int-regs 4 7 cc= }
+        T{ ##compare-imm f V int-regs 6 V int-regs 4 5 cc= }
         T{ ##replace f V int-regs 6 D 0 }
     } value-numbering trim-temps
 ] unit-test
@@ -132,7 +132,7 @@ sequences ;
         T{ ##unbox-float f V double-float-regs 10 V int-regs 8 }
         T{ ##unbox-float f V double-float-regs 11 V int-regs 9 }
         T{ ##compare-float f V int-regs 12 V double-float-regs 10 V double-float-regs 11 cc< }
-        T{ ##compare-imm f V int-regs 14 V int-regs 12 7 cc= }
+        T{ ##compare-imm f V int-regs 14 V int-regs 12 5 cc= }
         T{ ##replace f V int-regs 14 D 0 }
     } value-numbering trim-temps
 ] unit-test
@@ -149,6 +149,6 @@ sequences ;
         T{ ##peek f V int-regs 29 D -1 }
         T{ ##peek f V int-regs 30 D -2 }
         T{ ##compare f V int-regs 33 V int-regs 29 V int-regs 30 cc<= }
-        T{ ##compare-imm-branch f V int-regs 33 7 cc/= }
+        T{ ##compare-imm-branch f V int-regs 33 5 cc/= }
     } value-numbering trim-temps
 ] unit-test

basis/compiler/codegen/codegen.factor

@@ -44,7 +44,7 @@ SYMBOL: calls
 
 SYMBOL: compiling-word
 
-: compiled-stack-traces? ( -- ? ) 59 getenv ;
+: compiled-stack-traces? ( -- ? ) 67 getenv ;
 
 ! Mapping _label IDs to label instances
 SYMBOL: labels

basis/compiler/codegen/fixup/fixup.factor

@@ -3,15 +3,13 @@
 USING: arrays byte-arrays byte-vectors generic assocs hashtables
 io.binary kernel kernel.private math namespaces make sequences
 words quotations strings alien.accessors alien.strings layouts
-system combinators math.bitwise words.private math.order
+system combinators math.bitwise math.order
 accessors growable cpu.architecture compiler.constants ;
 IN: compiler.codegen.fixup
 
 GENERIC: fixup* ( obj -- )
 
-: code-format ( -- n ) 22 getenv ;
+: compiled-offset ( -- n ) building get length ;
-
-: compiled-offset ( -- n ) building get length code-format * ;
 
 SYMBOL: relocation-table
 SYMBOL: label-table
@@ -25,7 +23,7 @@ TUPLE: label-fixup label class ;
 M: label-fixup fixup*
     dup class>> rc-absolute?
     [ "Absolute labels not supported" throw ] when
-    [ label>> ] [ class>> ] bi compiled-offset 4 - rot
+    [ class>> ] [ label>> ] bi compiled-offset 4 - swap
     3array label-table get push ;
 
 TUPLE: rel-fixup class type ;
@@ -58,6 +56,9 @@ SYMBOL: literal-table
 : rel-word ( word class -- )
     [ add-literal ] dip rt-xt rel-fixup ;
 
+: rel-word-direct ( word class -- )
+    [ add-literal ] dip rt-xt-direct rel-fixup ;
+
 : rel-primitive ( word class -- )
     [ def>> first add-literal ] dip rt-primitive rel-fixup ;
 
@@ -88,4 +89,4 @@ SYMBOL: literal-table
         literal-table get >array
         relocation-table get >byte-array
         label-table get resolve-labels
-    ] { } make 4array ;
+    ] B{ } make 4array ;

basis/compiler/compiler-docs.factor

@@ -1,19 +1,19 @@
 USING: assocs compiler.cfg.builder compiler.cfg.optimizer
 compiler.errors compiler.tree.builder compiler.tree.optimizer
 compiler.units help.markup help.syntax io parser quotations
-sequences words words.private ;
+sequences words ;
 IN: compiler
 
-HELP: enable-compiler
+HELP: enable-optimizer
 { $description "Enables the optimizing compiler." } ;
 
-HELP: disable-compiler
+HELP: disable-optimizer
 { $description "Disable the optimizing compiler." } ;
 
 ARTICLE: "compiler-usage" "Calling the optimizing compiler"
 "Normally, new word definitions are recompiled automatically. This can be changed:"
-{ $subsection disable-compiler }
+{ $subsection disable-optimizer }
-{ $subsection enable-compiler }
+{ $subsection enable-optimizer }
 "Removing a word's optimized definition:"
 { $subsection decompile }
 "Compiling a single quotation:"

basis/compiler/compiler.factor

@@ -2,19 +2,20 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors kernel namespaces arrays sequences io words fry
 continuations vocabs assocs dlists definitions math graphs generic
-combinators deques search-deques macros io source-files.errors
+generic.single combinators deques search-deques macros io
-stack-checker stack-checker.state stack-checker.inlining
+source-files.errors stack-checker stack-checker.state
-stack-checker.errors combinators.short-circuit compiler.errors
+stack-checker.inlining stack-checker.errors combinators.short-circuit
-compiler.units compiler.tree.builder compiler.tree.optimizer
+compiler.errors compiler.units compiler.tree.builder
-compiler.cfg.builder compiler.cfg.optimizer compiler.cfg.linearization
+compiler.tree.optimizer compiler.cfg.builder compiler.cfg.optimizer
-compiler.cfg.two-operand compiler.cfg.linear-scan
+compiler.cfg.linearization compiler.cfg.two-operand
-compiler.cfg.stack-frame compiler.codegen compiler.utilities ;
+compiler.cfg.linear-scan compiler.cfg.stack-frame compiler.codegen
+compiler.utilities ;
 IN: compiler
 
 SYMBOL: compile-queue
 SYMBOL: compiled
 
-: queue-compile? ( word -- ? )
+: compile? ( word -- ? )
     #! Don't attempt to compile certain words.
     {
         [ "forgotten" word-prop ]
@@ -24,7 +25,7 @@ SYMBOL: compiled
     } 1|| not ;
 
 : queue-compile ( word -- )
-    dup queue-compile? [ compile-queue get push-front ] [ drop ] if ;
+    dup compile? [ compile-queue get push-front ] [ drop ] if ;
 
 : recompile-callers? ( word -- ? )
     changed-effects get key? ;
@@ -41,6 +42,14 @@ SYMBOL: compiled
     H{ } clone generic-dependencies set
     clear-compiler-error ;
 
+GENERIC: no-compile? ( word -- ? )
+
+M: word no-compile? "no-compile" word-prop ;
+
+M: method-body no-compile? "method-generic" word-prop no-compile? ;
+
+M: predicate-engine-word no-compile? "owner-generic" word-prop no-compile? ;
+
 : ignore-error? ( word error -- ? )
     #! Ignore some errors on inline combinators, macros, and special
     #! words such as 'call'.
@@ -48,8 +57,8 @@ SYMBOL: compiled
         {
             [ macro? ]
             [ inline? ]
+            [ no-compile? ]
             [ "special" word-prop ]
-            [ "no-compile" word-prop ]
         } 1||
     ] [
         {
@@ -80,32 +89,46 @@ SYMBOL: compiled
 : not-compiled-def ( word error -- def )
     '[ _ _ not-compiled ] [ ] like ;
 
+: ignore-error ( word error -- * )
+    drop
+    [ clear-compiler-error ]
+    [ dup def>> deoptimize-with ]
+    bi ;
+
+: remember-error ( word error -- * )
+    [ swap <compiler-error> compiler-error ]
+    [ [ drop ] [ not-compiled-def ] 2bi deoptimize-with ]
+    2bi ;
+
 : deoptimize ( word error -- * )
     #! If the error is ignorable, compile the word with the
     #! non-optimizing compiler, using its definition. Otherwise,
     #! if the compiler error is not ignorable, use a dummy
     #! definition from 'not-compiled-def' which throws an error.
-    2dup ignore-error? [
+    {
-        drop
+        { [ dup inference-error? not ] [ rethrow ] }
-        [ dup def>> deoptimize-with ]
+        { [ 2dup ignore-error? ] [ ignore-error ] }
-        [ clear-compiler-error ]
+        [ remember-error ]
-        bi
+    } cond ;
-    ] [
+
-        [ swap <compiler-error> compiler-error ]
+: optimize? ( word -- ? )
-        [ [ drop ] [ not-compiled-def ] 2bi deoptimize-with ]
+    {
-        2bi
+        [ predicate-engine-word? ]
-    ] if ;
+        [ contains-breakpoints? ]
+        [ single-generic? ]
+    } 1|| not ;
 
 : frontend ( word -- nodes )
     #! If the word contains breakpoints, don't optimize it, since
     #! the walker does not support this.
-    dup contains-breakpoints? [ dup def>> deoptimize-with ] [
+    dup optimize?
-        [ build-tree ] [ deoptimize ] recover optimize-tree
+    [ [ build-tree ] [ deoptimize ] recover optimize-tree ]
-    ] if ;
+    [ dup def>> deoptimize-with ]
+    if ;
 
 : compile-dependency ( word -- )
     #! If a word calls an unoptimized word, try to compile the callee.
-    dup optimized>> [ drop ] [ queue-compile ] if ;
+    dup optimized? [ drop ] [ queue-compile ] if ;
 
 ! Only switch this off for debugging.
 SYMBOL: compile-dependencies?
@@ -161,15 +184,21 @@ M: optimizing-compiler recompile ( words -- alist )
     [
         <hashed-dlist> compile-queue set
         H{ } clone compiled set
-        [ queue-compile ] each
+        [
+            [ queue-compile ]
+            [ subwords [ compile-dependency ] each ] bi
+        ] each
         compile-queue get compile-loop
         compiled get >alist
     ] with-scope ;
 
-: enable-compiler ( -- )
+: with-optimizer ( quot -- )
+    [ optimizing-compiler compiler-impl ] dip with-variable ; inline
+
+: enable-optimizer ( -- )
     optimizing-compiler compiler-impl set-global ;
 
-: disable-compiler ( -- )
+: disable-optimizer ( -- )
     f compiler-impl set-global ;
 
 : recompile-all ( -- )

basis/compiler/constants/constants.factor

@@ -1,6 +1,7 @@
-! Copyright (C) 2008 Slava Pestov.
+! Copyright (C) 2008, 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: math kernel layouts system strings ;
+USING: math kernel layouts system strings words quotations byte-arrays
+alien arrays ;
 IN: compiler.constants
 
 ! These constants must match vm/memory.h
@@ -11,18 +12,17 @@ CONSTANT: deck-bits 18
 ! These constants must match vm/layouts.h
 : header-offset ( -- n ) object tag-number neg ; inline
 : float-offset ( -- n ) 8 float tag-number - ; inline
-: string-offset ( -- n ) 4 bootstrap-cells object tag-number - ; inline
+: string-offset ( -- n ) 4 bootstrap-cells string tag-number - ; inline
 : string-aux-offset ( -- n ) 2 bootstrap-cells string tag-number - ; inline
-: profile-count-offset ( -- n ) 7 bootstrap-cells object tag-number - ; inline
+: profile-count-offset ( -- n ) 7 bootstrap-cells \ word tag-number - ; inline
-: byte-array-offset ( -- n ) 2 bootstrap-cells object tag-number - ; inline
+: byte-array-offset ( -- n ) 2 bootstrap-cells byte-array tag-number - ; inline
-: alien-offset ( -- n ) 3 bootstrap-cells object tag-number - ; inline
+: alien-offset ( -- n ) 3 bootstrap-cells alien tag-number - ; inline
-: underlying-alien-offset ( -- n ) bootstrap-cell object tag-number - ; inline
+: underlying-alien-offset ( -- n ) bootstrap-cell alien tag-number - ; inline
 : tuple-class-offset ( -- n ) bootstrap-cell tuple tag-number - ; inline
-: class-hash-offset ( -- n ) bootstrap-cell object tag-number - ; inline
+: word-xt-offset ( -- n ) 9 bootstrap-cells \ word tag-number - ; inline
-: word-xt-offset ( -- n ) 9 bootstrap-cells object tag-number - ; inline
+: quot-xt-offset ( -- n ) 5 bootstrap-cells quotation tag-number - ; inline
-: quot-xt-offset ( -- n ) 5 bootstrap-cells object tag-number - ; inline
+: word-code-offset ( -- n ) 10 bootstrap-cells \ word tag-number - ; inline
-: word-code-offset ( -- n ) 10 bootstrap-cells object tag-number - ; inline
+: array-start-offset ( -- n ) 2 bootstrap-cells array tag-number - ; inline
-: array-start-offset ( -- n ) 2 bootstrap-cells object tag-number - ; inline
 : compiled-header-size ( -- n ) 5 bootstrap-cells ; inline
 
 ! Relocation classes
@@ -41,10 +41,12 @@ CONSTANT: rt-primitive   0
 CONSTANT: rt-dlsym       1
 CONSTANT: rt-dispatch    2
 CONSTANT: rt-xt          3
-CONSTANT: rt-here        4
+CONSTANT: rt-xt-direct   4
-CONSTANT: rt-this        5
+CONSTANT: rt-here        5
-CONSTANT: rt-immediate   6
+CONSTANT: rt-this        6
-CONSTANT: rt-stack-chain 7
+CONSTANT: rt-immediate   7
+CONSTANT: rt-stack-chain 8
+CONSTANT: rt-untagged    9
 
 : rc-absolute? ( n -- ? )
     [ rc-absolute-ppc-2/2 = ]

basis/compiler/tests/alien.factor

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

basis/compiler/tests/call-effect.factor

@@ -0,0 +1,14 @@
+IN: compiler.tests.call-effect
+USING: tools.test combinators generic.single sequences kernel ;
+
+: execute-ic-test ( a b -- c ) execute( a -- c ) ;
+
+! VM type check error
+[ 1 f execute-ic-test ] [ second 3 = ] must-fail-with
+
+: call-test ( q -- ) call( -- ) ;
+
+[ ] [ [ ] call-test ] unit-test
+[ ] [ f [ drop ] curry call-test ] unit-test
+[ ] [ [ ] [ ] compose call-test ] unit-test
+[ [ 1 2 3 ] call-test ] [ wrong-values? ] must-fail-with

basis/compiler/tests/codegen.factor

@@ -4,7 +4,7 @@ sequences sequences.private tools.test namespaces.private
 slots.private sequences.private byte-arrays alien
 alien.accessors layouts words definitions compiler.units io
 combinators vectors grouping make ;
-IN: compiler.tests
+IN: compiler.tests.codegen
 
 ! Originally, this file did black box testing of templating
 ! optimization. We now have a different codegen, but the tests
@@ -26,7 +26,7 @@ IN: compiler.tests
 
 [ 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 } 2 2 ]
 [ { 1 2 3 } { 1 4 3 } [ over tag over tag ] compile-call ]
 unit-test
 
@@ -37,7 +37,7 @@ unit-test
 
 : foo ( -- ) ;
 
-[ 5 5 ]
+[ 3 3 ]
 [ 1.2 [ tag [ foo ] keep ] compile-call ]
 unit-test
 
@@ -211,7 +211,7 @@ TUPLE: my-tuple ;
     { tuple vector } 3 slot { word } declare
     dup 1 slot 0 fixnum-bitand { [ ] } dispatch ;
 
-[ t ] [ \ dispatch-alignment-regression optimized>> ] unit-test
+[ t ] [ \ dispatch-alignment-regression optimized? ] unit-test
 
 [ vector ] [ dispatch-alignment-regression ] unit-test
 
@@ -281,4 +281,4 @@ TUPLE: cucumber ;
 
 M: cucumber equal? "The cucumber has no equal" throw ;
 
-[ t ] [ [ cucumber ] compile-call cucumber eq? ] unit-test
+[ t ] [ [ cucumber ] compile-call cucumber eq? ] unit-test

basis/compiler/tests/curry.factor

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

basis/compiler/tests/float.factor

@@ -1,4 +1,4 @@
-IN: compiler.tests
+IN: compiler.tests.float
 USING: compiler.units compiler kernel kernel.private memory math
 math.private tools.test math.floats.private ;
 
@@ -9,7 +9,7 @@ math.private tools.test math.floats.private ;
 
 [ 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-call ] unit-test
+[ 3 ] [ 1.0 [ 2.0 float+ tag ] compile-call ] unit-test
 
 [ 3.0 ] [ 1.0 [ 2.0 float+ ] compile-call ] unit-test
 [ 3.0 ] [ 1.0 [ 2.0 swap float+ ] compile-call ] unit-test

basis/compiler/tests/folding.factor

@@ -1,6 +1,6 @@
 USING: eval tools.test compiler.units vocabs multiline words
 kernel classes.mixin arrays ;
-IN: compiler.tests
+IN: compiler.tests.folding
 
 ! Calls to generic words were not folded away.
 

basis/compiler/tests/generic.factor

@@ -0,0 +1,11 @@
+IN: compiler.tests.generic
+USING: tools.test math kernel compiler.units definitions ;
+
+GENERIC: bad ( -- )
+M: integer bad ;
+M: object bad ;
+
+[ 0 bad ] must-fail
+[ "" bad ] must-fail
+
+[ ] [ [ \ bad forget ] with-compilation-unit ] unit-test

basis/compiler/tests/intrinsics.factor

@@ -6,7 +6,7 @@ sbufs strings.private slots.private alien math.order
 alien.accessors alien.c-types alien.syntax alien.strings
 namespaces libc sequences.private io.encodings.ascii
 classes compiler ;
-IN: compiler.tests
+IN: compiler.tests.intrinsics
 
 ! Make sure that intrinsic ops compile to correct code.
 [ ] [ 1 [ drop ] compile-call ] unit-test
@@ -342,12 +342,12 @@ cell 8 = [
 ] unit-test
 
 [ 1 2 ] [
-    1 2 [ <complex> ] compile-call
+    1 2 [ complex boa ] compile-call
     dup real-part swap imaginary-part
 ] unit-test
 
 [ 1 2 ] [
-    1 2 [ <ratio> ] compile-call dup numerator swap denominator
+    1 2 [ ratio boa ] compile-call dup numerator swap denominator
 ] unit-test
 
 [ \ + ] [ \ + [ <wrapper> ] compile-call ] unit-test

basis/compiler/tests/optimizer.factor

@@ -4,13 +4,13 @@ sbufs strings tools.test vectors words sequences.private
 quotations classes classes.algebra classes.tuple.private
 continuations growable namespaces hints alien.accessors
 compiler.tree.builder compiler.tree.optimizer sequences.deep
-compiler ;
+compiler definitions ;
-IN: optimizer.tests
+IN: compiler.tests.optimizer
 
 GENERIC: xyz ( obj -- obj )
 M: array xyz xyz ;
 
-[ t ] [ \ xyz optimized>> ] unit-test
+[ t ] [ M\ array xyz optimized? ] unit-test
 
 ! Test predicate inlining
 : pred-test-1 ( a -- b c )
@@ -95,7 +95,7 @@ TUPLE: pred-test ;
 ! regression
 GENERIC: void-generic ( obj -- * )
 : breakage ( -- * ) "hi" void-generic ;
-[ t ] [ \ breakage optimized>> ] unit-test
+[ t ] [ \ breakage optimized? ] unit-test
 [ breakage ] must-fail
 
 ! regression
@@ -120,7 +120,7 @@ GENERIC: void-generic ( obj -- * )
 ! compiling <tuple> with a non-literal class failed
 : <tuple>-regression ( class -- tuple ) <tuple> ;
 
-[ t ] [ \ <tuple>-regression optimized>> ] unit-test
+[ t ] [ \ <tuple>-regression optimized? ] unit-test
 
 GENERIC: foozul ( a -- b )
 M: reversed foozul ;
@@ -229,7 +229,7 @@ USE: binary-search.private
 : node-successor-f-bug ( x -- * )
     [ 3 throw ] [ empty-compound ] compose [ 3 throw ] if ;
 
-[ t ] [ \ node-successor-f-bug optimized>> ] unit-test
+[ t ] [ \ node-successor-f-bug optimized? ] unit-test
 
 [ ] [ [ new ] build-tree optimize-tree drop ] unit-test
 
@@ -243,7 +243,7 @@ USE: binary-search.private
         ] if
     ] if ;
 
-[ t ] [ \ lift-throw-tail-regression optimized>> ] unit-test
+[ t ] [ \ lift-throw-tail-regression optimized? ] unit-test
 [ 3 "an integer" ] [ 3 lift-throw-tail-regression ] unit-test
 [ "hi" "a string" ] [ "hi" lift-throw-tail-regression ] unit-test
 
@@ -274,7 +274,7 @@ HINTS: recursive-inline-hang array ;
 : recursive-inline-hang-1 ( -- a )
     { } recursive-inline-hang ;
 
-[ t ] [ \ recursive-inline-hang-1 optimized>> ] unit-test
+[ t ] [ \ recursive-inline-hang-1 optimized? ] unit-test
 
 DEFER: recursive-inline-hang-3
 
@@ -325,7 +325,7 @@ PREDICATE: list < improper-list
     dup "a" get { array-capacity } declare >=
     [ dup "b" get { array-capacity } declare >= [ 3 ] [ 4 ] if ] [ 5 ] if ;
 
-[ t ] [ \ interval-inference-bug optimized>> ] unit-test
+[ t ] [ \ interval-inference-bug optimized? ] unit-test
 
 [ ] [ 1 "a" set 2 "b" set ] unit-test
 [ 2 3 ] [ 2 interval-inference-bug ] unit-test
@@ -384,3 +384,9 @@ DEFER: loop-bbb
     1 >bignum 2 >bignum
     [ { bignum integer } declare [ shift ] keep 1+ ] compile-call
 ] unit-test
+
+: broken-declaration ( -- ) \ + declare ;
+
+[ f ] [ \ broken-declaration optimized? ] unit-test
+
+[ ] [ [ \ broken-declaration forget ] with-compilation-unit ] unit-test

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

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

basis/compiler/tests/peg-regression.factor

@@ -4,8 +4,8 @@
 ! optimization, which would batch generic word updates at the
 ! end of a compilation unit.
 
-USING: kernel accessors peg.ebnf ;
+USING: kernel accessors peg.ebnf words ;
-IN: compiler.tests
+IN: compiler.tests.peg-regression
 
 TUPLE: pipeline-expr background ;
 
@@ -22,5 +22,5 @@ pipeline = "hello" => [[ ast>pipeline-expr ]]
 
 USE: tools.test
 
-[ t ] [ \ expr optimized>> ] unit-test
+[ t ] [ \ expr optimized? ] unit-test
-[ t ] [ \ ast>pipeline-expr optimized>> ] unit-test
+[ t ] [ \ ast>pipeline-expr optimized? ] unit-test

basis/compiler/tests/pic-problem-1.factor

@@ -0,0 +1,14 @@
+IN: compiler.tests.pic-problem-1
+USING: kernel sequences prettyprint memory tools.test ;
+
+TUPLE: x ;
+
+M: x length drop 0 ;
+
+INSTANCE: x sequence
+
+<< gc >>
+
+CONSTANT: blah T{ x }
+
+[ T{ x } ] [ blah ] unit-test

basis/compiler/tests/redefine0.factor

@@ -104,4 +104,4 @@ quot global delete-at
         \ test-11 forget
         \ quot forget
     ] with-compilation-unit
-] unit-test
+] unit-test

basis/compiler/tests/redefine1.factor

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

basis/compiler/tests/redefine10.factor

@@ -1,6 +1,6 @@
 USING: eval tools.test compiler.units vocabs multiline words
 kernel ;
-IN: compiler.tests
+IN: compiler.tests.redefine10
 
 ! Mixin redefinition did not recompile all necessary words.
 

basis/compiler/tests/redefine11.factor

@@ -1,6 +1,6 @@
 USING: eval tools.test compiler.units vocabs multiline words
 kernel classes.mixin arrays ;
-IN: compiler.tests
+IN: compiler.tests.redefine11
 
 ! Mixin redefinition did not recompile all necessary words.
 

basis/compiler/tests/redefine14.factor

@@ -1,8 +1,8 @@
 USING: compiler.units definitions tools.test sequences ;
 IN: compiler.tests.redefine14
 
-! TUPLE: bad ;
+TUPLE: bad ;
-! 
+
-! M: bad length 1 2 3 ;
+M: bad length 1 2 3 ;
-! 
+
-! [ ] [ [ { bad length } forget ] with-compilation-unit ] unit-test
+[ ] [ [ M\ bad length forget ] with-compilation-unit ] unit-test

basis/compiler/tests/redefine15.factor

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

basis/compiler/tests/redefine17.factor

@@ -0,0 +1,49 @@
+IN: compiler.tests.redefine17
+USING: tools.test classes.mixin compiler.units arrays kernel.private
+strings sequences vocabs definitions kernel ;
+
+<< "compiler.tests.redefine17" words forget-all >>
+
+GENERIC: bong ( a -- b )
+
+M: array bong ;
+
+M: string bong length ;
+
+MIXIN: mixin
+
+INSTANCE: array mixin
+
+: blah ( a -- b ) { mixin } declare bong ;
+
+[ { } ] [ { } blah ] unit-test
+
+[ ] [ [ \ array \ mixin remove-mixin-instance ] with-compilation-unit ] unit-test
+
+[ ] [ [ \ string \ mixin add-mixin-instance ] with-compilation-unit ] unit-test
+
+[ 0 ] [ "" blah ] unit-test
+
+MIXIN: mixin1
+
+INSTANCE: string mixin1
+
+MIXIN: mixin2
+
+GENERIC: billy ( a -- b )
+
+M: mixin2 billy ;
+
+M: array billy drop "BILLY" ;
+
+INSTANCE: string mixin2
+
+: bully ( a -- b ) { mixin1 } declare billy ;
+
+[ "" ] [ "" bully ] unit-test
+
+[ ] [ [ \ string \ mixin1 remove-mixin-instance ] with-compilation-unit ] unit-test
+
+[ ] [ [ \ array \ mixin1 add-mixin-instance ] with-compilation-unit ] unit-test
+
+[ "BILLY" ] [ { } bully ] unit-test

basis/compiler/tests/redefine2.factor

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

basis/compiler/tests/redefine3.factor

@@ -1,4 +1,4 @@
-IN: compiler.tests
+IN: compiler.tests.redefine3
 USING: accessors compiler compiler.units tools.test math parser
 kernel sequences sequences.private classes.mixin generic
 definitions arrays words assocs eval ;
@@ -14,11 +14,11 @@ M: empty-mixin sheeple drop "wake up" ;
 : sheeple-test ( -- string ) { } sheeple ;
 
 [ "sheeple" ] [ sheeple-test ] unit-test
-[ t ] [ \ sheeple-test optimized>> ] unit-test
+[ t ] [ \ sheeple-test optimized? ] unit-test
 [ t ] [ object \ sheeple method \ sheeple-test "compiled-uses" word-prop key? ] unit-test
 [ f ] [ empty-mixin \ sheeple method \ sheeple-test "compiled-uses" word-prop key? ] unit-test
 
-[ ] [ "IN: compiler.tests USE: arrays INSTANCE: array empty-mixin" eval( -- ) ] unit-test
+[ ] [ "IN: compiler.tests.redefine3 USE: arrays INSTANCE: array empty-mixin" eval( -- ) ] unit-test
 
 [ "wake up" ] [ sheeple-test ] unit-test
 [ f ] [ object \ sheeple method \ sheeple-test "compiled-uses" word-prop key? ] unit-test
@@ -27,6 +27,6 @@ M: empty-mixin sheeple drop "wake up" ;
 [ ] [ [ array empty-mixin remove-mixin-instance ] with-compilation-unit ] unit-test
 
 [ "sheeple" ] [ sheeple-test ] unit-test
-[ t ] [ \ sheeple-test optimized>> ] unit-test
+[ t ] [ \ sheeple-test optimized? ] unit-test
 [ t ] [ object \ sheeple method \ sheeple-test "compiled-uses" word-prop key? ] unit-test
 [ f ] [ empty-mixin \ sheeple method \ sheeple-test "compiled-uses" word-prop key? ] unit-test

basis/compiler/tests/redefine4.factor

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

basis/compiler/tests/redefine5.factor

@@ -1,6 +1,6 @@
 USING: eval tools.test compiler.units vocabs multiline words
 kernel ;
-IN: compiler.tests
+IN: compiler.tests.redefine5
 
 ! Regression: if dispatch was eliminated but method was not inlined,
 ! compiled usage information was not recorded.

basis/compiler/tests/redefine6.factor

@@ -1,6 +1,6 @@
 USING: eval tools.test compiler.units vocabs multiline words
 kernel ;
-IN: compiler.tests
+IN: compiler.tests.redefine6
 
 ! Mixin redefinition did not recompile all necessary words.
 

basis/compiler/tests/redefine7.factor

@@ -1,6 +1,6 @@
 USING: eval tools.test compiler.units vocabs multiline words
 kernel ;
-IN: compiler.tests
+IN: compiler.tests.redefine7
 
 ! Mixin redefinition did not recompile all necessary words.
 

basis/compiler/tests/redefine8.factor

@@ -1,6 +1,6 @@
 USING: eval tools.test compiler.units vocabs multiline words
 kernel ;
-IN: compiler.tests
+IN: compiler.tests.redefine8
 
 ! Mixin redefinition did not recompile all necessary words.
 

basis/compiler/tests/redefine9.factor

@@ -1,6 +1,6 @@
 USING: eval tools.test compiler.units vocabs multiline words
 kernel generic.math ;
-IN: compiler.tests
+IN: compiler.tests.redefine9
 
 ! Mixin redefinition did not recompile all necessary words.
 

basis/compiler/tests/reload.factor

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

basis/compiler/tests/simple.factor

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

basis/compiler/tests/spilling.factor

@@ -1,6 +1,6 @@
 USING: math.private kernel combinators accessors arrays
-generalizations tools.test ;
+generalizations tools.test words ;
-IN: compiler.tests
+IN: compiler.tests.spilling
 
 : float-spill-bug ( a -- b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b )
     {
@@ -47,7 +47,7 @@ IN: compiler.tests
 [ 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 ]
 [ 1.0 float-spill-bug ] unit-test
 
-[ t ] [ \ float-spill-bug optimized>> ] unit-test
+[ t ] [ \ float-spill-bug optimized? ] unit-test
 
 : float-fixnum-spill-bug ( object -- object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object )
     {
@@ -132,7 +132,7 @@ IN: compiler.tests
 [ 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 ]
 [ 1.0 float-fixnum-spill-bug ] unit-test
 
-[ t ] [ \ float-fixnum-spill-bug optimized>> ] unit-test
+[ t ] [ \ float-fixnum-spill-bug optimized? ] unit-test
 
 : resolve-spill-bug ( a b -- c )
     [ 1 fixnum+fast ] bi@ dup 10 fixnum< [
@@ -159,7 +159,7 @@ IN: compiler.tests
         16 narray
     ] if ;
 
-[ t ] [ \ resolve-spill-bug optimized>> ] unit-test
+[ t ] [ \ resolve-spill-bug optimized? ] unit-test
 
 [ 4 ] [ 1 1 resolve-spill-bug ] unit-test
 

basis/compiler/tests/stack-trace.factor

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

basis/compiler/tests/tuples.factor

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

basis/compiler/tree/builder/builder.factor

@@ -54,15 +54,16 @@ PRIVATE>
     #! This slows down compiler.tree.propagation.inlining since then every
     #! inlined usage of a method has an inline-dependency on the mixin, and
     #! not the more specific type at the call site.
-    specialize-method? off
+    f specialize-method? [
-    [
+        [
-        #call in-d>> word/quot build-tree-with unclip-last in-d>> :> in-d
+            #call in-d>> word/quot build-tree-with unclip-last in-d>> :> in-d
-        {
+            {
-            { [ dup not ] [ ] }
+                { [ dup not ] [ ] }
-            { [ dup ends-with-terminate? ] [ #call out-d>> [ f swap #push ] map append ] }
+                { [ dup ends-with-terminate? ] [ #call out-d>> [ f swap #push ] map append ] }
-            [ in-d #call out-d>> #copy suffix ]
+                [ in-d #call out-d>> #copy suffix ]
-        } cond
+            } cond
-    ] [ dup inference-error? [ drop f ] [ rethrow ] if ] recover ;
+        ] [ dup inference-error? [ drop f ] [ rethrow ] if ] recover
+    ] with-variable ;
 
 : contains-breakpoints? ( word -- ? )
     def>> [ word? ] filter [ "break?" word-prop ] any? ;

basis/compiler/tree/debugger/debugger.factor

@@ -153,7 +153,7 @@ SYMBOL: node-count
             [ 1+ ] dip
             dup #call? [
                 word>> {
-                    { [ dup "intrinsics" word-prop over "if-intrinsics" word-prop or ] [ intrinsics-called ] }
+                    { [ dup "intrinsic" word-prop ] [ intrinsics-called ] }
                     { [ dup generic? ] [ generics-called ] }
                     { [ dup method-body? ] [ methods-called ] }
                     [ words-called ]

basis/compiler/tree/escape-analysis/check/check.factor

@@ -12,7 +12,6 @@ M: #push run-escape-analysis*
 
 M: #call run-escape-analysis*
     {
-        { [ dup word>> \ <complex> eq? ] [ t ] }
         { [ dup immutable-tuple-boa? ] [ t ] }
         [ f ] 
     } cond nip ;

basis/compiler/tree/escape-analysis/escape-analysis-tests.factor

@@ -17,7 +17,7 @@ GENERIC: count-unboxed-allocations* ( m node -- n )
     out-d>> first escaping-allocation? [ 1+ ] unless ;
 
 M: #call count-unboxed-allocations*
-    dup [ immutable-tuple-boa? ] [ word>> \ <complex> eq? ] bi or
+    dup immutable-tuple-boa?
     [ (count-unboxed-allocations) ] [ drop ] if ;
 
 M: #push count-unboxed-allocations*
@@ -291,7 +291,7 @@ C: <ro-box> ro-box
 
 [ 0 ] [ [ bad-tuple-fib-3 i>> ] count-unboxed-allocations ] unit-test
 
-[ 1 ] [ [ <complex> >rect ] count-unboxed-allocations ] unit-test
+[ 1 ] [ [ complex boa >rect ] count-unboxed-allocations ] unit-test
 
 [ 0 ] [ [ 1 cons boa 2 cons boa ] count-unboxed-allocations ] unit-test
 

basis/compiler/tree/escape-analysis/simple/simple.factor

@@ -47,9 +47,6 @@ M: #push escape-analysis*
     [ record-unknown-allocation ]
     if ;
 
-: record-complex-allocation ( #call -- )
-    [ in-d>> ] [ out-d>> first ] bi record-allocation ;
-
 : slot-offset ( #call -- n/f )
     dup in-d>>
     [ first node-value-info class>> ]
@@ -71,7 +68,6 @@ M: #push escape-analysis*
 M: #call escape-analysis*
     dup word>> {
         { \ <tuple-boa> [ record-tuple-allocation ] }
-        { \ <complex> [ record-complex-allocation ] }
         { \ slot [ record-slot-call ] }
         [ drop record-unknown-allocation ]
     } case ;

basis/compiler/tree/propagation/info/info.factor

@@ -59,29 +59,18 @@ CONSTANT: object-info T{ value-info f object full-interval }
 
 : <value-info> ( -- info ) \ value-info new ;
 
-: read-only-slots ( values class -- slots )
-    all-slots
-    [ read-only>> [ drop f ] unless ] 2map
-    f prefix ;
-
 DEFER: <literal-info>
 
+: tuple-slot-infos ( tuple -- slots )
+    [ tuple-slots ] [ class all-slots ] bi
+    [ read-only>> [ <literal-info> ] [ drop f ] if ] 2map
+    f prefix ;
+
 : init-literal-info ( info -- info )
     dup literal>> class >>class
     dup literal>> dup real? [ [a,a] >>interval ] [
         [ [-inf,inf] >>interval ] dip
-        {
+        dup tuple? [ tuple-slot-infos >>slots ] [ drop ] if
-            { [ dup complex? ] [
-                [ real-part <literal-info> ]
-                [ imaginary-part <literal-info> ] bi
-                2array >>slots
-            ] }
-            { [ dup tuple? ] [
-                [ tuple-slots [ <literal-info> ] map ] [ class ] bi
-                read-only-slots >>slots
-            ] }
-            [ drop ]
-        } cond
     ] if ; inline
 
 : init-value-info ( info -- info )

basis/compiler/tree/propagation/inlining/inlining.factor

@@ -1,7 +1,7 @@
 ! Copyright (C) 2008, 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors kernel arrays sequences math math.order
-math.partial-dispatch generic generic.standard generic.math
+math.partial-dispatch generic generic.standard generic.single generic.math
 classes.algebra classes.union sets quotations assocs combinators
 words namespaces continuations classes fry combinators.smart hints
 locals
@@ -188,9 +188,7 @@ SYMBOL: history
     { curry compose } memq? ;
 
 : never-inline-word? ( word -- ? )
-    [ deferred? ]
+    [ deferred? ] [ "default" word-prop ] [ \ call eq? ] tri or or ;
-    [ "default" word-prop ]
-    [ { call execute } memq? ] tri or or ;
 
 : custom-inlining? ( word -- ? )
     "custom-inlining" word-prop ;

basis/compiler/tree/propagation/propagation-tests.factor

@@ -9,7 +9,7 @@ compiler.tree.propagation.info compiler.tree.def-use
 compiler.tree.debugger compiler.tree.checker
 slots.private words hashtables classes assocs locals
 specialized-arrays.double system sorting math.libm
-math.intervals ;
+math.intervals quotations ;
 IN: compiler.tree.propagation.tests
 
 [ V{ } ] [ [ ] final-classes ] unit-test
@@ -357,7 +357,7 @@ TUPLE: immutable-prop-test-tuple { x sequence read-only } ;
 ] unit-test
 
 [ V{ complex } ] [
-    [ <complex> ] final-classes
+    [ complex boa ] final-classes
 ] unit-test
 
 [ V{ complex } ] [
@@ -375,7 +375,7 @@ TUPLE: immutable-prop-test-tuple { x sequence read-only } ;
 [ V{ complex } ] [
     [
         { float float object } declare
-        [ "Oops" throw ] [ <complex> ] if
+        [ "Oops" throw ] [ complex boa ] if
     ] final-classes
 ] unit-test
 
@@ -590,7 +590,7 @@ MIXIN: empty-mixin
 
 [ V{ float } ] [
     [
-        [ { float float } declare <complex> ]
+        [ { float float } declare complex boa ]
         [ 2drop C{ 0.0 0.0 } ]
         if real-part
     ] final-classes
@@ -686,3 +686,8 @@ TUPLE: littledan-2 { from read-only } { to read-only } ;
 [ V{ 0 } ] [ [ { } length ] final-literals ] unit-test
 
 [ V{ 1 } ] [ [ { } length 1+ f <array> length ] final-literals ] unit-test
+
+! Mutable tuples with circularity should not cause problems
+TUPLE: circle me ;
+
+[ ] [ circle new dup >>me 1quotation final-info drop ] unit-test

basis/compiler/tree/propagation/simple/simple.factor

@@ -109,7 +109,7 @@ M: #declare propagate-before
 
 : output-value-infos ( #call word -- infos )
     {
-        { [ dup tuple-constructor? ] [ propagate-tuple-constructor ] }
+        { [ dup \ <tuple-boa> eq? ] [ drop propagate-<tuple-boa> ] }
         { [ dup sequence-constructor? ] [ propagate-sequence-constructor ] }
         { [ dup predicate? ] [ propagate-predicate ] }
         { [ dup "outputs" word-prop ] [ call-outputs-quot ] }

basis/compiler/tree/propagation/slots/slots.factor

@@ -1,4 +1,4 @@
-! Copyright (C) 2008 Slava Pestov.
+! Copyright (C) 2008, 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: fry assocs arrays byte-arrays strings accessors sequences
 kernel slots classes.algebra classes.tuple classes.tuple.private
@@ -8,9 +8,6 @@ IN: compiler.tree.propagation.slots
 
 ! Propagation of immutable slots and array lengths
 
-! Revisit this code when delegation is removed and when complex
-! numbers become tuples.
-
 UNION: fixed-length-sequence array byte-array string ;
 
 : sequence-constructor? ( word -- ? )
@@ -29,33 +26,26 @@ UNION: fixed-length-sequence array byte-array string ;
     [ constructor-output-class <class-info> ]
     bi* value-info-intersect 1array ;
 
-: tuple-constructor? ( word -- ? )
-    { <tuple-boa> <complex> } memq? ;
-
 : fold-<tuple-boa> ( values class -- info )
     [ [ literal>> ] map ] dip prefix >tuple
     <literal-info> ;
 
+: read-only-slots ( values class -- slots )
+    all-slots
+    [ read-only>> [ value-info ] [ drop f ] if ] 2map
+    f prefix ;
+
 : (propagate-tuple-constructor) ( values class -- info )
-    [ [ value-info ] map ] dip [ read-only-slots ] keep
+    [ read-only-slots ] keep
     over rest-slice [ dup [ literal?>> ] when ] all? [
         [ rest-slice ] dip fold-<tuple-boa>
     ] [
         <tuple-info>
     ] if ;
 
-: propagate-<tuple-boa> ( #call -- info )
+: propagate-<tuple-boa> ( #call -- infos )
     in-d>> unclip-last
-    value-info literal>> first (propagate-tuple-constructor) ;
+    value-info literal>> first (propagate-tuple-constructor) 1array ;
-
-: propagate-<complex> ( #call -- info )
-    in-d>> [ value-info ] map complex <tuple-info> ;
-
-: propagate-tuple-constructor ( #call word -- infos )
-    {
-        { \ <tuple-boa> [ propagate-<tuple-boa> ] }
-        { \ <complex> [ propagate-<complex> ] }
-    } case 1array ;
 
 : read-only-slot? ( n class -- ? )
     all-slots [ offset>> = ] with find nip

basis/compiler/tree/tuple-unboxing/tuple-unboxing-tests.factor

@@ -32,7 +32,6 @@ TUPLE: empty-tuple ;
     [ dup [ drop f ] [ "A" throw ] if ]
     [ [ ] [ ] curry curry dup 2 slot swap 3 slot dup 2 slot swap 3 slot drop ]
     [ [ ] [ ] curry curry call ]
-    [ <complex> <complex> dup 1 slot drop 2 slot drop ]
     [ 1 cons boa over [ "A" throw ] when car>> ]
     [ [ <=> ] sort ]
     [ [ <=> ] with search ]

basis/compiler/tree/tuple-unboxing/tuple-unboxing.factor

@@ -36,9 +36,6 @@ M: #push unbox-tuples* ( #push -- nodes )
 : unbox-<tuple-boa> ( #call -- nodes )
     dup unbox-output? [ in-d>> 1 tail* #drop ] when ;
 
-: unbox-<complex> ( #call -- nodes )
-    dup unbox-output? [ drop { } ] when ;
-
 : (flatten-values) ( values accum -- )
     dup '[
         dup unboxed-allocation
@@ -70,7 +67,6 @@ M: #push unbox-tuples* ( #push -- nodes )
 M: #call unbox-tuples*
     dup word>> {
         { \ <tuple-boa> [ unbox-<tuple-boa> ] }
-        { \ <complex> [ unbox-<complex> ] }
         { \ slot [ unbox-slot-access ] }
         [ drop ]
     } case ;

basis/core-foundation/fsevents/fsevents.factor

@@ -151,8 +151,8 @@ SYMBOL: event-stream-callbacks
     \ event-stream-counter counter ;
 
 [
-    event-stream-callbacks global
+    event-stream-callbacks
-    [ [ drop expired? not ] assoc-filter H{ } assoc-like ] change-at
+    [ [ drop expired? not ] assoc-filter H{ } assoc-like ] change-global
 ] "core-foundation" add-init-hook
 
 : add-event-source-callback ( quot -- id )

basis/cpu/ppc/bootstrap.factor

@@ -2,15 +2,13 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: bootstrap.image.private kernel kernel.private namespaces
 system cpu.ppc.assembler compiler.codegen.fixup compiler.units
-compiler.constants math math.private layouts words words.private
+compiler.constants math math.private layouts words
 vocabs slots.private locals.backend ;
 IN: bootstrap.ppc
 
 4 \ cell set
 big-endian on
 
-4 jit-code-format set
-
 CONSTANT: ds-reg 29
 CONSTANT: rs-reg 30
 
@@ -23,7 +21,7 @@ CONSTANT: rs-reg 30
 : xt-save ( -- n ) stack-frame 2 bootstrap-cells - ;
 
 [
-    0 6 LOAD32
+    0 6 LOAD32 rc-absolute-ppc-2/2 rt-immediate jit-rel
     11 6 profile-count-offset LWZ
     11 11 1 tag-fixnum ADDI
     11 6 profile-count-offset STW
@@ -31,65 +29,50 @@ CONSTANT: rs-reg 30
     11 11 compiled-header-size ADDI
     11 MTCTR
     BCTR
-] rc-absolute-ppc-2/2 rt-immediate 1 jit-profiling jit-define
+] jit-profiling jit-define
 
 [
-    0 6 LOAD32
+    0 6 LOAD32 rc-absolute-ppc-2/2 rt-this jit-rel
     0 MFLR
     1 1 stack-frame SUBI
     6 1 xt-save STW
     stack-frame 6 LI
     6 1 next-save STW
     0 1 lr-save stack-frame + STW
-] rc-absolute-ppc-2/2 rt-this 1 jit-prolog jit-define
+] jit-prolog jit-define
 
 [
-    0 6 LOAD32
+    0 6 LOAD32 rc-absolute-ppc-2/2 rt-immediate jit-rel
     6 ds-reg 4 STWU
-] rc-absolute-ppc-2/2 rt-immediate 1 jit-push-immediate jit-define
+] jit-push-immediate jit-define
 
 [
-    0 6 LOAD32
+    0 6 LOAD32 rc-absolute-ppc-2/2 rt-stack-chain jit-rel
     7 6 0 LWZ
     1 7 0 STW
-] rc-absolute-ppc-2/2 rt-stack-chain 1 jit-save-stack jit-define
+] jit-save-stack jit-define
 
 [
-    0 6 LOAD32
+    0 6 LOAD32 rc-absolute-ppc-2/2 rt-primitive jit-rel
     6 MTCTR
     BCTR
-] rc-absolute-ppc-2/2 rt-primitive 1 jit-primitive jit-define
+] jit-primitive jit-define
 
-[ 0 BL ] rc-relative-ppc-3 rt-xt 0 jit-word-call jit-define
+[ 0 BL rc-relative-ppc-3 rt-xt-direct jit-rel ] jit-word-call jit-define
 
-[ 0 B ] rc-relative-ppc-3 rt-xt 0 jit-word-jump jit-define
+[ 0 B rc-relative-ppc-3 rt-xt jit-rel ] jit-word-jump jit-define
 
 [
     3 ds-reg 0 LWZ
     ds-reg dup 4 SUBI
     0 3 \ f tag-number CMPI
     2 BEQ
-    0 B
+    0 B rc-relative-ppc-3 rt-xt jit-rel
-] rc-relative-ppc-3 rt-xt 4 jit-if-1 jit-define
+] jit-if-1 jit-define
 
 [
-    0 B
+    0 B rc-relative-ppc-3 rt-xt jit-rel
-] rc-relative-ppc-3 rt-xt 0 jit-if-2 jit-define
+] jit-if-2 jit-define
-
-: jit-jump-quot ( -- )
-    4 3 quot-xt-offset LWZ
-    4 MTCTR
-    BCTR ;
-
-[
-    0 3 LOAD32
-    6 ds-reg 0 LWZ
-    6 6 1 SRAWI
-    3 3 6 ADD
-    3 3 array-start-offset LWZ
-    ds-reg dup 4 SUBI
-    jit-jump-quot
-] rc-absolute-ppc-2/2 rt-immediate 1 jit-dispatch jit-define
 
 : jit->r ( -- )
     4 ds-reg 0 LWZ
@@ -139,29 +122,29 @@ CONSTANT: rs-reg 30
 
 [
     jit->r
-    0 BL
+    0 BL rc-relative-ppc-3 rt-xt jit-rel
     jit-r>
-] rc-relative-ppc-3 rt-xt 3 jit-dip jit-define
+] jit-dip jit-define
 
 [
     jit-2>r
-    0 BL
+    0 BL rc-relative-ppc-3 rt-xt jit-rel
     jit-2r>
-] rc-relative-ppc-3 rt-xt 6 jit-2dip jit-define
+] jit-2dip jit-define
 
 [
     jit-3>r
-    0 BL
+    0 BL rc-relative-ppc-3 rt-xt jit-rel
     jit-3r>
-] rc-relative-ppc-3 rt-xt 8 jit-3dip jit-define
+] jit-3dip jit-define
 
 [
     0 1 lr-save stack-frame + LWZ
     1 1 stack-frame ADDI
     0 MTLR
-] f f f jit-epilog jit-define
+] jit-epilog jit-define
 
-[ BLR ] f f f jit-return jit-define
+[ BLR ] jit-return jit-define
 
 ! Sub-primitives
 
@@ -169,8 +152,10 @@ CONSTANT: rs-reg 30
 [
     3 ds-reg 0 LWZ
     ds-reg dup 4 SUBI
-    jit-jump-quot
+    4 3 quot-xt-offset LWZ
-] f f f \ (call) define-sub-primitive
+    4 MTCTR
+    BCTR
+] \ (call) define-sub-primitive
 
 [
     3 ds-reg 0 LWZ
@@ -178,7 +163,7 @@ CONSTANT: rs-reg 30
     4 3 word-xt-offset LWZ
     4 MTCTR
     BCTR
-] f f f \ (execute) define-sub-primitive
+] \ (execute) define-sub-primitive
 
 ! Objects
 [
@@ -186,7 +171,7 @@ CONSTANT: rs-reg 30
     3 3 tag-mask get ANDI
     3 3 tag-bits get SLWI
     3 ds-reg 0 STW
-] f f f \ tag define-sub-primitive
+] \ tag define-sub-primitive
 
 [
     3 ds-reg 0 LWZ
@@ -195,25 +180,25 @@ CONSTANT: rs-reg 30
     4 4 0 0 31 tag-bits get - RLWINM
     4 3 3 LWZX
     3 ds-reg 0 STW
-] f f f \ slot define-sub-primitive
+] \ slot define-sub-primitive
 
 ! Shufflers
 [
     ds-reg dup 4 SUBI
-] f f f \ drop define-sub-primitive
+] \ drop define-sub-primitive
 
 [
     ds-reg dup 8 SUBI
-] f f f \ 2drop define-sub-primitive
+] \ 2drop define-sub-primitive
 
 [
     ds-reg dup 12 SUBI
-] f f f \ 3drop define-sub-primitive
+] \ 3drop define-sub-primitive
 
 [
     3 ds-reg 0 LWZ
     3 ds-reg 4 STWU
-] f f f \ dup define-sub-primitive
+] \ dup define-sub-primitive
 
 [
     3 ds-reg 0 LWZ
@@ -221,7 +206,7 @@ CONSTANT: rs-reg 30
     ds-reg dup 8 ADDI
     3 ds-reg 0 STW
     4 ds-reg -4 STW
-] f f f \ 2dup define-sub-primitive
+] \ 2dup define-sub-primitive
 
 [
     3 ds-reg 0 LWZ
@@ -231,36 +216,36 @@ CONSTANT: rs-reg 30
     3 ds-reg 0 STW
     4 ds-reg -4 STW
     5 ds-reg -8 STW
-] f f f \ 3dup define-sub-primitive
+] \ 3dup define-sub-primitive
 
 [
     3 ds-reg 0 LWZ
     ds-reg dup 4 SUBI
     3 ds-reg 0 STW
-] f f f \ nip define-sub-primitive
+] \ nip define-sub-primitive
 
 [
     3 ds-reg 0 LWZ
     ds-reg dup 8 SUBI
     3 ds-reg 0 STW
-] f f f \ 2nip define-sub-primitive
+] \ 2nip define-sub-primitive
 
 [
     3 ds-reg -4 LWZ
     3 ds-reg 4 STWU
-] f f f \ over define-sub-primitive
+] \ over define-sub-primitive
 
 [
     3 ds-reg -8 LWZ
     3 ds-reg 4 STWU
-] f f f \ pick define-sub-primitive
+] \ pick define-sub-primitive
 
 [
     3 ds-reg 0 LWZ
     4 ds-reg -4 LWZ
     4 ds-reg 0 STW
     3 ds-reg 4 STWU
-] f f f \ dupd define-sub-primitive
+] \ dupd define-sub-primitive
 
 [
     3 ds-reg 0 LWZ
@@ -268,21 +253,21 @@ CONSTANT: rs-reg 30
     3 ds-reg 4 STWU
     4 ds-reg -4 STW
     3 ds-reg -8 STW
-] f f f \ tuck define-sub-primitive
+] \ tuck define-sub-primitive
 
 [
     3 ds-reg 0 LWZ
     4 ds-reg -4 LWZ
     3 ds-reg -4 STW
     4 ds-reg 0 STW
-] f f f \ swap define-sub-primitive
+] \ swap define-sub-primitive
 
 [
     3 ds-reg -4 LWZ
     4 ds-reg -8 LWZ
     3 ds-reg -8 STW
     4 ds-reg -4 STW
-] f f f \ swapd define-sub-primitive
+] \ swapd define-sub-primitive
 
 [
     3 ds-reg 0 LWZ
@@ -291,7 +276,7 @@ CONSTANT: rs-reg 30
     4 ds-reg -8 STW
     3 ds-reg -4 STW
     5 ds-reg 0 STW
-] f f f \ rot define-sub-primitive
+] \ rot define-sub-primitive
 
 [
     3 ds-reg 0 LWZ
@@ -300,13 +285,13 @@ CONSTANT: rs-reg 30
     3 ds-reg -8 STW
     5 ds-reg -4 STW
     4 ds-reg 0 STW
-] f f f \ -rot define-sub-primitive
+] \ -rot define-sub-primitive
 
-[ jit->r ] f f f \ load-local define-sub-primitive
+[ jit->r ] \ load-local define-sub-primitive
 
 ! Comparisons
 : jit-compare ( insn -- )
-    0 3 LOAD32
+    0 3 LOAD32 rc-absolute-ppc-2/2 rt-immediate jit-rel
     4 ds-reg 0 LWZ
     5 ds-reg -4 LWZU
     5 0 4 CMP
@@ -315,8 +300,7 @@ CONSTANT: rs-reg 30
     3 ds-reg 0 STW ;
 
 : define-jit-compare ( insn word -- )
-    [ [ jit-compare ] curry rc-absolute-ppc-2/2 rt-immediate 1 ] dip
+    [ [ jit-compare ] curry ] dip define-sub-primitive ;
-    define-sub-primitive ;
 
 \ BEQ \ eq? define-jit-compare
 \ BGE \ fixnum>= define-jit-compare
@@ -336,7 +320,7 @@ CONSTANT: rs-reg 30
     2 BNE
     1 tag-fixnum 4 LI
     4 ds-reg 0 STW
-] f f f \ both-fixnums? define-sub-primitive
+] \ both-fixnums? define-sub-primitive
 
 : jit-math ( insn -- )
     3 ds-reg 0 LWZ
@@ -344,9 +328,9 @@ CONSTANT: rs-reg 30
     [ 5 3 4 ] dip execute( dst src1 src2 -- )
     5 ds-reg 0 STW ;
 
-[ \ ADD jit-math ] f f f \ fixnum+fast define-sub-primitive
+[ \ ADD jit-math ] \ fixnum+fast define-sub-primitive
 
-[ \ SUBF jit-math ] f f f \ fixnum-fast define-sub-primitive
+[ \ SUBF jit-math ] \ fixnum-fast define-sub-primitive
 
 [
     3 ds-reg 0 LWZ
@@ -354,20 +338,20 @@ CONSTANT: rs-reg 30
     4 4 tag-bits get SRAWI
     5 3 4 MULLW
     5 ds-reg 0 STW
-] f f f \ fixnum*fast define-sub-primitive
+] \ fixnum*fast define-sub-primitive
 
-[ \ AND jit-math ] f f f \ fixnum-bitand define-sub-primitive
+[ \ AND jit-math ] \ fixnum-bitand define-sub-primitive
 
-[ \ OR jit-math ] f f f \ fixnum-bitor define-sub-primitive
+[ \ OR jit-math ] \ fixnum-bitor define-sub-primitive
 
-[ \ XOR jit-math ] f f f \ fixnum-bitxor define-sub-primitive
+[ \ XOR jit-math ] \ fixnum-bitxor define-sub-primitive
 
 [
     3 ds-reg 0 LWZ
     3 3 NOT
     3 3 tag-mask get XORI
     3 ds-reg 0 STW
-] f f f \ fixnum-bitnot define-sub-primitive
+] \ fixnum-bitnot define-sub-primitive
 
 [
     3 ds-reg 0 LWZ
@@ -382,7 +366,7 @@ CONSTANT: rs-reg 30
     2 BGT
     5 7 MR
     5 ds-reg 0 STW
-] f f f \ fixnum-shift-fast define-sub-primitive
+] \ fixnum-shift-fast define-sub-primitive
 
 [
     3 ds-reg 0 LWZ
@@ -392,7 +376,7 @@ CONSTANT: rs-reg 30
     6 5 3 MULLW
     7 6 4 SUBF
     7 ds-reg 0 STW
-] f f f \ fixnum-mod define-sub-primitive
+] \ fixnum-mod define-sub-primitive
 
 [
     3 ds-reg 0 LWZ
@@ -401,7 +385,7 @@ CONSTANT: rs-reg 30
     5 4 3 DIVW
     5 5 tag-bits get SLWI
     5 ds-reg 0 STW
-] f f f \ fixnum/i-fast define-sub-primitive
+] \ fixnum/i-fast define-sub-primitive
 
 [
     3 ds-reg 0 LWZ
@@ -412,20 +396,20 @@ CONSTANT: rs-reg 30
     5 5 tag-bits get SLWI
     5 ds-reg -4 STW
     7 ds-reg 0 STW
-] f f f \ fixnum/mod-fast define-sub-primitive
+] \ fixnum/mod-fast define-sub-primitive
 
 [
     3 ds-reg 0 LWZ
     3 3 1 SRAWI
     rs-reg 3 3 LWZX
     3 ds-reg 0 STW
-] f f f \ get-local define-sub-primitive
+] \ get-local define-sub-primitive
 
 [
     3 ds-reg 0 LWZ
     ds-reg ds-reg 4 SUBI
     3 3 1 SRAWI
     rs-reg 3 rs-reg SUBF
-] f f f \ drop-locals define-sub-primitive
+] \ drop-locals define-sub-primitive
 
 [ "bootstrap.ppc" forget-vocab ] with-compilation-unit

basis/cpu/x86/32/32.factor

@@ -309,7 +309,7 @@ FUNCTION: bool check_sse2 ( ) ;
     check_sse2 ;
 
 "-no-sse2" (command-line) member? [
-    optimizing-compiler compiler-impl [ { check_sse2 } compile ] with-variable
+    [ { check_sse2 } compile ] with-optimizer
 
     "Checking if your CPU supports SSE2..." print flush
     sse2? [

basis/cpu/x86/32/bootstrap.factor

@@ -22,13 +22,15 @@ IN: bootstrap.x86
 : rex-length ( -- n ) 0 ;
 
 [
-    temp0 0 [] MOV                              ! load stack_chain
+    ! load stack_chain
-    temp0 [] stack-reg MOV                      ! save stack pointer
+    temp0 0 [] MOV rc-absolute-cell rt-stack-chain jit-rel
-] rc-absolute-cell rt-stack-chain 2 jit-save-stack jit-define
+    ! save stack pointer
+    temp0 [] stack-reg MOV
+] jit-save-stack jit-define
 
 [
-    (JMP) drop
+    (JMP) drop rc-relative rt-primitive jit-rel
-] rc-relative rt-primitive 1 jit-primitive jit-define
+] jit-primitive jit-define
 
 << "vocab:cpu/x86/bootstrap.factor" parse-file parsed >>
 call

basis/cpu/x86/64/bootstrap.factor

@@ -20,15 +20,19 @@ IN: bootstrap.x86
 : rex-length ( -- n ) 1 ;
 
 [
-    temp0 0 MOV                                 ! load stack_chain
+    ! load stack_chain
+    temp0 0 MOV rc-absolute-cell rt-stack-chain jit-rel
     temp0 temp0 [] MOV
-    temp0 [] stack-reg MOV                      ! save stack pointer
+    ! save stack pointer
-] rc-absolute-cell rt-stack-chain 1 rex-length + jit-save-stack jit-define
+    temp0 [] stack-reg MOV
+] jit-save-stack jit-define
 
 [
-    temp1 0 MOV                                 ! load XT
+    ! load XT
-    temp1 JMP                                   ! go
+    temp1 0 MOV rc-absolute-cell rt-primitive jit-rel
-] rc-absolute-cell rt-primitive 1 rex-length + jit-primitive jit-define
+    ! go
+    temp1 JMP
+] jit-primitive jit-define
 
 << "vocab:cpu/x86/bootstrap.factor" parse-file parsed >>
 call

basis/cpu/x86/assembler/assembler-tests.factor

@@ -62,3 +62,5 @@ IN: cpu.x86.assembler.tests
 [ { HEX: 48 HEX: d3 HEX: e1 } ] [ [ RCX CL SHL ] { } make ] unit-test
 [ { HEX: 48 HEX: d3 HEX: e8 } ] [ [ RAX CL SHR ] { } make ] unit-test
 [ { HEX: 48 HEX: d3 HEX: e9 } ] [ [ RCX CL SHR ] { } make ] unit-test
+
+[ { HEX: f7 HEX: c1 HEX: d2 HEX: 04 HEX: 00 HEX: 00 } ] [ [ ECX 1234 TEST ] { } make ] unit-test

basis/cpu/x86/assembler/assembler.factor

@@ -316,15 +316,16 @@ M: operand JMP { BIN: 100 t HEX: ff } 1-operand ;
 GENERIC: CALL ( op -- )
 : (CALL) ( -- rel-class ) HEX: e8 , 0 4, rc-relative ;
 M: f CALL (CALL) 2drop ;
-M: callable CALL (CALL) rel-word ;
+M: callable CALL (CALL) rel-word-direct ;
 M: label CALL (CALL) label-fixup ;
 M: operand CALL { BIN: 010 t HEX: ff } 1-operand ;
 
 GENERIC# JUMPcc 1 ( addr opcode -- )
-: (JUMPcc) ( n -- rel-class ) extended-opcode, 0 4, rc-relative ;
+: (JUMPcc) ( addr n -- rel-class ) extended-opcode, 4, rc-relative ;
-M: f JUMPcc nip (JUMPcc) drop ;
+M: f JUMPcc [ 0 ] dip (JUMPcc) 2drop ;
-M: callable JUMPcc (JUMPcc) rel-word ;
+M: integer JUMPcc (JUMPcc) drop ;
-M: label JUMPcc (JUMPcc) label-fixup ;
+M: callable JUMPcc [ 0 ] dip (JUMPcc) rel-word ;
+M: label JUMPcc [ 0 ] dip (JUMPcc) label-fixup ;
 
 : JO  ( dst -- ) HEX: 80 JUMPcc ;
 : JNO ( dst -- ) HEX: 81 JUMPcc ;
@@ -382,6 +383,10 @@ GENERIC: CMP ( dst src -- )
 M: immediate CMP swap { BIN: 111 t HEX: 80 } immediate-1/4 ;
 M: operand CMP OCT: 070 2-operand ;
 
+GENERIC: TEST ( dst src -- )
+M: immediate TEST swap { BIN: 0 t HEX: f7 } immediate-4 ;
+M: operand TEST OCT: 204 2-operand ;
+
 : XCHG ( dst src -- ) OCT: 207 2-operand ;
 
 : BSR ( dst src -- ) swap { HEX: 0f HEX: bd } (2-operand) ;

basis/cpu/x86/bootstrap.factor

@@ -1,18 +1,16 @@
-! Copyright (C) 2007, 2008 Slava Pestov.
+! Copyright (C) 2007, 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: bootstrap.image.private kernel kernel.private namespaces
 system cpu.x86.assembler layouts compiler.units math
 math.private compiler.constants vocabs slots.private words
-words.private locals.backend ;
+locals.backend make sequences combinators arrays ;
 IN: bootstrap.x86
 
 big-endian off
 
-1 jit-code-format set
-
 [
     ! Load word
-    temp0 0 MOV
+    temp0 0 MOV rc-absolute-cell rt-immediate jit-rel
     ! Bump profiling counter
     temp0 profile-count-offset [+] 1 tag-fixnum ADD
     ! Load word->code
@@ -21,35 +19,35 @@ big-endian off
     temp0 compiled-header-size ADD
     ! Jump to XT
     temp0 JMP
-] rc-absolute-cell rt-immediate 1 rex-length + jit-profiling jit-define
+] jit-profiling jit-define
 
 [
     ! load XT
-    temp0 0 MOV
+    temp0 0 MOV rc-absolute-cell rt-this jit-rel
     ! save stack frame size
     stack-frame-size PUSH
     ! push XT
     temp0 PUSH
     ! alignment
     stack-reg stack-frame-size 3 bootstrap-cells - SUB
-] rc-absolute-cell rt-this 1 rex-length + jit-prolog jit-define
+] jit-prolog jit-define
 
 [
     ! load literal
-    temp0 0 MOV
+    temp0 0 MOV rc-absolute-cell rt-immediate jit-rel
     ! increment datastack pointer
     ds-reg bootstrap-cell ADD
     ! store literal on datastack
     ds-reg [] temp0 MOV
-] rc-absolute-cell rt-immediate 1 rex-length + jit-push-immediate jit-define
+] jit-push-immediate jit-define
 
 [
-    f JMP
+    f JMP rc-relative rt-xt jit-rel
-] rc-relative rt-xt 1 jit-word-jump jit-define
+] jit-word-jump jit-define
 
 [
-    f CALL
+    f CALL rc-relative rt-xt-direct jit-rel
-] rc-relative rt-xt 1 jit-word-call jit-define
+] jit-word-call jit-define
 
 [
     ! load boolean
@@ -59,31 +57,13 @@ big-endian off
     ! compare boolean with f
     temp0 \ f tag-number CMP
     ! jump to true branch if not equal
-    f JNE
+    f JNE rc-relative rt-xt jit-rel
-] rc-relative rt-xt 10 rex-length 3 * + jit-if-1 jit-define
+] jit-if-1 jit-define
 
 [
     ! jump to false branch if equal
-    f JMP
+    f JMP rc-relative rt-xt jit-rel
-] rc-relative rt-xt 1 jit-if-2 jit-define
+] jit-if-2 jit-define
-
-[
-    ! load dispatch table
-    temp1 0 MOV
-    ! load index
-    temp0 ds-reg [] MOV
-    ! turn it into an array offset
-    fixnum>slot@
-    ! pop index
-    ds-reg bootstrap-cell SUB
-    ! compute quotation location
-    temp0 temp1 ADD
-    ! load quotation
-    arg temp0 array-start-offset [+] MOV
-    ! execute branch. the quot must be in arg, since it might
-    ! not be compiled yet
-    arg quot-xt-offset [+] JMP
-] rc-absolute-cell rt-immediate 1 rex-length + jit-dispatch jit-define
 
 : jit->r ( -- )
     rs-reg bootstrap-cell ADD
@@ -135,30 +115,133 @@ big-endian off
 
 [
     jit->r
-    f CALL
+    f CALL rc-relative rt-xt jit-rel
     jit-r>
-] rc-relative rt-xt 11 rex-length 4 * + jit-dip jit-define
+] jit-dip jit-define
 
 [
     jit-2>r
-    f CALL
+    f CALL rc-relative rt-xt jit-rel
     jit-2r>
-] rc-relative rt-xt 17 rex-length 6 * + jit-2dip jit-define
+] jit-2dip jit-define
 
 [
     jit-3>r
-    f CALL
+    f CALL rc-relative rt-xt jit-rel
     jit-3r>
-] rc-relative rt-xt 23 rex-length 8 * + jit-3dip jit-define
+] jit-3dip jit-define
+
+: prepare-(execute) ( -- operand )
+    ! load from stack
+    temp0 ds-reg [] MOV
+    ! pop stack
+    ds-reg bootstrap-cell SUB
+    ! execute word
+    temp0 word-xt-offset [+] ;
+
+[ prepare-(execute) JMP ] jit-execute-jump jit-define
+
+[ prepare-(execute) CALL ] jit-execute-call jit-define
 
 [
     ! unwind stack frame
     stack-reg stack-frame-size bootstrap-cell - ADD
-] f f f jit-epilog jit-define
+] jit-epilog jit-define
 
-[ 0 RET ] f f f jit-return jit-define
+[ 0 RET ] jit-return jit-define
 
-! Sub-primitives
+! ! ! Polymorphic inline caches
+
+! temp0 contains the object being dispatched on
+! temp1 contains its class
+
+! Load a value from a stack position
+[
+    temp1 ds-reg HEX: ffffffff [+] MOV rc-absolute rt-untagged jit-rel
+] pic-load jit-define
+
+! Tag
+: load-tag ( -- )
+    temp1 tag-mask get AND
+    temp1 tag-bits get SHL ;
+
+[ load-tag ] pic-tag jit-define
+
+! The 'make' trick lets us compute the jump distance for the
+! conditional branches there
+
+! Hi-tag
+[
+    temp0 temp1 MOV
+    load-tag
+    temp1 object tag-number tag-fixnum CMP
+    [ temp1 temp0 object tag-number neg [+] MOV ] { } make
+    [ length JNE ] [ % ] bi
+] pic-hi-tag jit-define
+
+! Tuple
+[
+    temp0 temp1 MOV
+    load-tag
+    temp1 tuple tag-number tag-fixnum CMP
+    [ temp1 temp0 tuple tag-number neg bootstrap-cell + [+] MOV ] { } make
+    [ length JNE ] [ % ] bi
+] pic-tuple jit-define
+
+! Hi-tag and tuple
+[
+    temp0 temp1 MOV
+    load-tag
+    ! If bits 2 and 3 are set, the tag is either 6 (object) or 7 (tuple)
+    temp1 BIN: 110 tag-fixnum CMP
+    [
+        ! Untag temp0
+        temp0 tag-mask get bitnot AND
+        ! Set temp1 to 0 for objects, and 8 for tuples
+        temp1 1 tag-fixnum AND
+        bootstrap-cell 4 = [ temp1 1 SHR ] when
+        ! Load header cell or tuple layout cell
+        temp1 temp0 temp1 [+] MOV
+    ] [ ] make [ length JL ] [ % ] bi
+] pic-hi-tag-tuple jit-define
+
+[
+    temp1 HEX: ffffffff CMP rc-absolute rt-immediate jit-rel
+] pic-check-tag jit-define
+
+[
+    temp2 HEX: ffffffff MOV rc-absolute-cell rt-immediate jit-rel
+    temp1 temp2 CMP
+] pic-check jit-define
+
+[ f JE rc-relative rt-xt jit-rel ] pic-hit jit-define
+
+! ! ! Megamorphic caches
+
+[
+    ! cache = ...
+    temp0 0 MOV rc-absolute-cell rt-immediate jit-rel
+    ! key = class
+    temp2 temp1 MOV
+    bootstrap-cell 8 = [ temp2 1 SHL ] when
+    ! key &= cache.length - 1
+    temp2 mega-cache-size get 1- bootstrap-cell * AND
+    ! cache += array-start-offset
+    temp0 array-start-offset ADD
+    ! cache += key
+    temp0 temp2 ADD
+    ! if(get(cache) == class)
+    temp0 [] temp1 CMP
+    ! ... goto get(cache + bootstrap-cell)
+    [
+        temp0 temp0 bootstrap-cell [+] MOV
+        temp0 word-xt-offset [+] JMP
+    ] [ ] make
+    [ length JNE ] [ % ] bi
+    ! fall-through on miss
+] mega-lookup jit-define
+
+! ! ! Sub-primitives
 
 ! Quotations and words
 [
@@ -168,16 +251,7 @@ big-endian off
     ds-reg bootstrap-cell SUB
     ! call quotation
     arg quot-xt-offset [+] JMP
-] f f f \ (call) define-sub-primitive
+] \ (call) define-sub-primitive
-
-[
-    ! load from stack
-    temp0 ds-reg [] MOV
-    ! pop stack
-    ds-reg bootstrap-cell SUB
-    ! execute word
-    temp0 word-xt-offset [+] JMP
-] f f f \ (execute) define-sub-primitive
 
 ! Objects
 [
@@ -189,7 +263,7 @@ big-endian off
     temp0 tag-bits get SHL
     ! push to stack
     ds-reg [] temp0 MOV
-] f f f \ tag define-sub-primitive
+] \ tag define-sub-primitive
 
 [
     ! load slot number
@@ -207,26 +281,26 @@ big-endian off
     temp0 temp1 temp0 [+] MOV
     ! push to stack
     ds-reg [] temp0 MOV
-] f f f \ slot define-sub-primitive
+] \ slot define-sub-primitive
 
 ! Shufflers
 [
     ds-reg bootstrap-cell SUB
-] f f f \ drop define-sub-primitive
+] \ drop define-sub-primitive
 
 [
     ds-reg 2 bootstrap-cells SUB
-] f f f \ 2drop define-sub-primitive
+] \ 2drop define-sub-primitive
 
 [
     ds-reg 3 bootstrap-cells SUB
-] f f f \ 3drop define-sub-primitive
+] \ 3drop define-sub-primitive
 
 [
     temp0 ds-reg [] MOV
     ds-reg bootstrap-cell ADD
     ds-reg [] temp0 MOV
-] f f f \ dup define-sub-primitive
+] \ dup define-sub-primitive
 
 [
     temp0 ds-reg [] MOV
@@ -234,7 +308,7 @@ big-endian off
     ds-reg 2 bootstrap-cells ADD
     ds-reg [] temp0 MOV
     ds-reg bootstrap-cell neg [+] temp1 MOV
-] f f f \ 2dup define-sub-primitive
+] \ 2dup define-sub-primitive
 
 [
     temp0 ds-reg [] MOV
@@ -244,31 +318,31 @@ big-endian off
     ds-reg [] temp0 MOV
     ds-reg -1 bootstrap-cells [+] temp1 MOV
     ds-reg -2 bootstrap-cells [+] temp3 MOV
-] f f f \ 3dup define-sub-primitive
+] \ 3dup define-sub-primitive
 
 [
     temp0 ds-reg [] MOV
     ds-reg bootstrap-cell SUB
     ds-reg [] temp0 MOV
-] f f f \ nip define-sub-primitive
+] \ nip define-sub-primitive
 
 [
     temp0 ds-reg [] MOV
     ds-reg 2 bootstrap-cells SUB
     ds-reg [] temp0 MOV
-] f f f \ 2nip define-sub-primitive
+] \ 2nip define-sub-primitive
 
 [
     temp0 ds-reg -1 bootstrap-cells [+] MOV
     ds-reg bootstrap-cell ADD
     ds-reg [] temp0 MOV
-] f f f \ over define-sub-primitive
+] \ over define-sub-primitive
 
 [
     temp0 ds-reg -2 bootstrap-cells [+] MOV
     ds-reg bootstrap-cell ADD
     ds-reg [] temp0 MOV
-] f f f \ pick define-sub-primitive
+] \ pick define-sub-primitive
 
 [
     temp0 ds-reg [] MOV
@@ -276,7 +350,7 @@ big-endian off
     ds-reg [] temp1 MOV
     ds-reg bootstrap-cell ADD
     ds-reg [] temp0 MOV
-] f f f \ dupd define-sub-primitive
+] \ dupd define-sub-primitive
 
 [
     temp0 ds-reg [] MOV
@@ -285,21 +359,21 @@ big-endian off
     ds-reg [] temp0 MOV
     ds-reg -1 bootstrap-cells [+] temp1 MOV
     ds-reg -2 bootstrap-cells [+] temp0 MOV
-] f f f \ tuck define-sub-primitive
+] \ tuck define-sub-primitive
 
 [
     temp0 ds-reg [] MOV
     temp1 ds-reg bootstrap-cell neg [+] MOV
     ds-reg bootstrap-cell neg [+] temp0 MOV
     ds-reg [] temp1 MOV
-] f f f \ swap define-sub-primitive
+] \ swap define-sub-primitive
 
 [
     temp0 ds-reg -1 bootstrap-cells [+] MOV
     temp1 ds-reg -2 bootstrap-cells [+] MOV
     ds-reg -2 bootstrap-cells [+] temp0 MOV
     ds-reg -1 bootstrap-cells [+] temp1 MOV
-] f f f \ swapd define-sub-primitive
+] \ swapd define-sub-primitive
 
 [
     temp0 ds-reg [] MOV
@@ -308,7 +382,7 @@ big-endian off
     ds-reg -2 bootstrap-cells [+] temp1 MOV
     ds-reg -1 bootstrap-cells [+] temp0 MOV
     ds-reg [] temp3 MOV
-] f f f \ rot define-sub-primitive
+] \ rot define-sub-primitive
 
 [
     temp0 ds-reg [] MOV
@@ -317,14 +391,14 @@ big-endian off
     ds-reg -2 bootstrap-cells [+] temp0 MOV
     ds-reg -1 bootstrap-cells [+] temp3 MOV
     ds-reg [] temp1 MOV
-] f f f \ -rot define-sub-primitive
+] \ -rot define-sub-primitive
 
-[ jit->r ] f f f \ load-local define-sub-primitive
+[ jit->r ] \ load-local define-sub-primitive
 
 ! Comparisons
 : jit-compare ( insn -- )
     ! load t
-    temp3 0 MOV
+    temp3 0 MOV rc-absolute-cell rt-immediate jit-rel
     ! load f
     temp1 \ f tag-number MOV
     ! load first value
@@ -339,8 +413,7 @@ big-endian off
     ds-reg [] temp1 MOV ;
 
 : define-jit-compare ( insn word -- )
-    [ [ jit-compare ] curry rc-absolute-cell rt-immediate 1 rex-length + ] dip
+    [ [ jit-compare ] curry ] dip define-sub-primitive ;
-    define-sub-primitive ;
 
 \ CMOVE \ eq? define-jit-compare
 \ CMOVGE \ fixnum>= define-jit-compare
@@ -357,9 +430,9 @@ big-endian off
     ! compute result
     [ ds-reg [] temp0 ] dip execute( dst src -- ) ;
 
-[ \ ADD jit-math ] f f f \ fixnum+fast define-sub-primitive
+[ \ ADD jit-math ] \ fixnum+fast define-sub-primitive
 
-[ \ SUB jit-math ] f f f \ fixnum-fast define-sub-primitive
+[ \ SUB jit-math ] \ fixnum-fast define-sub-primitive
 
 [
     ! load second input
@@ -374,20 +447,20 @@ big-endian off
     temp0 temp1 IMUL2
     ! push result
     ds-reg [] temp1 MOV
-] f f f \ fixnum*fast define-sub-primitive
+] \ fixnum*fast define-sub-primitive
 
-[ \ AND jit-math ] f f f \ fixnum-bitand define-sub-primitive
+[ \ AND jit-math ] \ fixnum-bitand define-sub-primitive
 
-[ \ OR jit-math ] f f f \ fixnum-bitor define-sub-primitive
+[ \ OR jit-math ] \ fixnum-bitor define-sub-primitive
 
-[ \ XOR jit-math ] f f f \ fixnum-bitxor define-sub-primitive
+[ \ XOR jit-math ] \ fixnum-bitxor define-sub-primitive
 
 [
     ! complement
     ds-reg [] NOT
     ! clear tag bits
     ds-reg [] tag-mask get XOR
-] f f f \ fixnum-bitnot define-sub-primitive
+] \ fixnum-bitnot define-sub-primitive
 
 [
     ! load shift count
@@ -411,7 +484,7 @@ big-endian off
     temp1 temp3 CMOVGE
     ! push to stack
     ds-reg [] temp1 MOV
-] f f f \ fixnum-shift-fast define-sub-primitive
+] \ fixnum-shift-fast define-sub-primitive
 
 : jit-fixnum-/mod ( -- )
     ! load second parameter
@@ -431,7 +504,7 @@ big-endian off
     ds-reg bootstrap-cell SUB
     ! push to stack
     ds-reg [] mod-arg MOV
-] f f f \ fixnum-mod define-sub-primitive
+] \ fixnum-mod define-sub-primitive
 
 [
     jit-fixnum-/mod
@@ -441,7 +514,7 @@ big-endian off
     div-arg tag-bits get SHL
     ! push to stack
     ds-reg [] div-arg MOV
-] f f f \ fixnum/i-fast define-sub-primitive
+] \ fixnum/i-fast define-sub-primitive
 
 [
     jit-fixnum-/mod
@@ -450,7 +523,7 @@ big-endian off
     ! push to stack
     ds-reg [] mod-arg MOV
     ds-reg bootstrap-cell neg [+] div-arg MOV
-] f f f \ fixnum/mod-fast define-sub-primitive
+] \ fixnum/mod-fast define-sub-primitive
 
 [
     temp0 ds-reg [] MOV
@@ -461,7 +534,7 @@ big-endian off
     temp1 1 tag-fixnum MOV
     temp0 temp1 CMOVE
     ds-reg [] temp0 MOV
-] f f f \ both-fixnums? define-sub-primitive
+] \ both-fixnums? define-sub-primitive
 
 [
     ! load local number
@@ -472,7 +545,7 @@ big-endian off
     temp0 rs-reg temp0 [+] MOV
     ! push to stack
     ds-reg [] temp0 MOV
-] f f f \ get-local define-sub-primitive
+] \ get-local define-sub-primitive
 
 [
     ! load local count
@@ -483,6 +556,6 @@ big-endian off
     fixnum>slot@
     ! decrement retain stack pointer
     rs-reg temp0 SUB
-] f f f \ drop-locals define-sub-primitive
+] \ drop-locals define-sub-primitive
 
 [ "bootstrap.x86" forget-vocab ] with-compilation-unit

basis/debugger/debugger-docs.factor

@@ -1,6 +1,6 @@
 USING: alien arrays generic generic.math help.markup help.syntax
 kernel math memory strings sbufs vectors io io.files classes
-help generic.standard continuations io.files.private listener
+help generic.single continuations io.files.private listener
 alien.libraries ;
 IN: debugger
 

basis/debugger/debugger.factor

@@ -6,7 +6,7 @@ sequences assocs sequences.private strings io.styles
 io.pathnames vectors words system splitting math.parser
 classes.mixin classes.tuple continuations continuations.private
 combinators generic.math classes.builtin classes compiler.units
-generic.standard vocabs init kernel.private io.encodings
+generic.standard generic.single vocabs init kernel.private io.encodings
 accessors math.order destructors source-files parser
 classes.tuple.parser effects.parser lexer
 generic.parser strings.parser vocabs.loader vocabs.parser see

basis/delegate/delegate-tests.factor

@@ -1,6 +1,6 @@
 USING: delegate kernel arrays tools.test words math definitions
 compiler.units parser generic prettyprint io.streams.string
-accessors eval multiline generic.standard delegate.protocols
+accessors eval multiline generic.single delegate.protocols
 delegate.private assocs see ;
 IN: delegate.tests
 

basis/documents/elements/elements.factor

@@ -79,6 +79,13 @@ M: one-word-elt next-elt
     drop
     [ f next-word ] modify-col ;
 
+SINGLETON: word-start-elt
+
+M: word-start-elt prev-elt
+    drop one-word-elt prev-elt ;
+
+M: word-start-elt next-elt 2drop ;
+
 SINGLETON: word-elt
 
 M: word-elt prev-elt

basis/ftp/client/client.factor

@@ -66,7 +66,7 @@ ERROR: ftp-error got expected ;
 : list ( url -- ftp-response )
     utf8 open-passive-client
     ftp-list
-    lines
+    stream-lines
     <ftp-response> swap >>strings
     read-response 226 ftp-assert
     parse-list ;

basis/functors/functors-tests.factor

@@ -63,6 +63,24 @@ WHERE
 
 [ 4 ] [ 1 3 blah ] unit-test
 
+<<
+
+FUNCTOR: symbol-test ( W -- )
+
+W DEFINES ${W}
+
+WHERE
+
+SYMBOL: W
+
+;FUNCTOR
+
+"blorgh" symbol-test
+
+>>
+
+[ blorgh ] [ blorgh ] unit-test
+
 GENERIC: some-generic ( a -- b )
 
 ! Does replacing an ordinary word with a functor-generated one work?
@@ -72,6 +90,7 @@ GENERIC: some-generic ( a -- b )
     TUPLE: some-tuple ;
     : some-word ( -- ) ;
     M: some-tuple some-generic ;
+    SYMBOL: some-symbol
     "> <string-reader> "functors-test" parse-stream
 ] unit-test
 
@@ -82,6 +101,7 @@ GENERIC: some-generic ( a -- b )
         "some-tuple" "functors.tests" lookup
         "some-generic" "functors.tests" lookup method >boolean
     ] unit-test ;
+    [ t ] [ "some-symbol" "functors.tests" lookup >boolean ] unit-test
 
 test-redefinition
 
@@ -90,12 +110,14 @@ FUNCTOR: redefine-test ( W -- )
 W-word DEFINES ${W}-word
 W-tuple DEFINES-CLASS ${W}-tuple
 W-generic IS ${W}-generic
+W-symbol DEFINES ${W}-symbol
 
 WHERE
 
 TUPLE: W-tuple ;
 : W-word ( -- ) ;
 M: W-tuple W-generic ;
+SYMBOL: W-symbol
 
 ;FUNCTOR
 
@@ -105,4 +127,5 @@ M: W-tuple W-generic ;
     "> <string-reader> "functors-test" parse-stream
 ] unit-test
 
-test-redefinition
+test-redefinition
+

basis/functors/functors.factor

@@ -5,7 +5,7 @@ words interpolate namespaces sequences io.streams.string fry
 classes.mixin effects lexer parser classes.tuple.parser
 effects.parser locals.types locals.parser generic.parser
 locals.rewrite.closures vocabs.parser classes.parser
-arrays accessors ;
+arrays accessors words.symbol ;
 IN: functors
 
 ! This is a hack
@@ -18,6 +18,8 @@ IN: functors
 
 : define-declared* ( word def effect -- ) pick set-word define-declared ;
 
+TUPLE: fake-call-next-method ;
+
 TUPLE: fake-quotation seq ;
 
 GENERIC: >fake-quotations ( quot -- fake )
@@ -29,17 +31,25 @@ M: array >fake-quotations [ >fake-quotations ] { } map-as ;
 
 M: object >fake-quotations ;
 
-GENERIC: fake-quotations> ( fake -- quot )
+GENERIC: (fake-quotations>) ( fake -- )
 
-M: fake-quotation fake-quotations>
+: fake-quotations> ( fake -- quot )
-    seq>> [ fake-quotations> ] [ ] map-as ;
+    [ (fake-quotations>) ] [ ] make ;
 
-M: array fake-quotations> [ fake-quotations> ] map ;
+M: fake-quotation (fake-quotations>)
+    [ seq>> [ (fake-quotations>) ] each ] [ ] make , ;
 
-M: object fake-quotations> ;
+M: array (fake-quotations>)
+    [ [ (fake-quotations>) ] each ] { } make , ;
+
+M: fake-call-next-method (fake-quotations>)
+    drop method-body get literalize , \ (call-next-method) , ;
+
+M: object (fake-quotations>) , ;
 
 : parse-definition* ( accum -- accum )
-    parse-definition >fake-quotations parsed \ fake-quotations> parsed ;
+    parse-definition >fake-quotations parsed
+    [ fake-quotations> first ] over push-all ;
 
 : parse-declared* ( accum -- accum )
     complete-effect
@@ -64,7 +74,7 @@ SYNTAX: `TUPLE:
 SYNTAX: `M:
     scan-param parsed
     scan-param parsed
-    \ create-method-in parsed
+    [ create-method-in dup method-body set ] over push-all
     parse-definition*
     \ define* parsed ;
 
@@ -80,6 +90,10 @@ SYNTAX: `:
     parse-declared*
     \ define-declared* parsed ;
 
+SYNTAX: `SYMBOL:
+    scan-param parsed
+    \ define-symbol parsed ;
+
 SYNTAX: `SYNTAX:
     scan-param parsed
     parse-definition*
@@ -92,6 +106,8 @@ SYNTAX: `INSTANCE:
 
 SYNTAX: `inline [ word make-inline ] over push-all ;
 
+SYNTAX: `call-next-method T{ fake-call-next-method } parsed ;
+
 : (INTERPOLATE) ( accum quot -- accum )
     [ scan interpolate-locals ] dip
     '[ _ with-string-writer @ ] parsed ;
@@ -116,7 +132,9 @@ DEFER: ;FUNCTOR delimiter
         { ":" POSTPONE: `: }
         { "INSTANCE:" POSTPONE: `INSTANCE: }
         { "SYNTAX:" POSTPONE: `SYNTAX: }
+        { "SYMBOL:" POSTPONE: `SYMBOL: }
         { "inline" POSTPONE: `inline }
+        { "call-next-method" POSTPONE: `call-next-method }
     } ;
 
 : push-functor-words ( -- )

basis/generalizations/generalizations.factor

@@ -26,11 +26,14 @@ MACRO: narray ( n -- )
 MACRO: nsum ( n -- )
     1- [ + ] n*quot ;
 
+MACRO: firstn-unsafe ( n -- )
+    [ '[ [ _ ] dip nth-unsafe ] ] map '[ _ cleave ] ;
+
 MACRO: firstn ( n -- )
     dup zero? [ drop [ drop ] ] [
-        [ [ '[ [ _ ] dip nth-unsafe ] ] map ]
+        [ 1- swap bounds-check 2drop ]
-        [ 1- '[ [ _ ] dip bounds-check 2drop ] ]
+        [ firstn-unsafe ]
-        bi prefix '[ _ cleave ]
+        bi-curry '[ _ _ bi ]
     ] if ;
 
 MACRO: npick ( n -- )

basis/hints/hints.factor

@@ -1,9 +1,9 @@
-! Copyright (C) 2008 Slava Pestov.
+! Copyright (C) 2008, 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: parser words definitions kernel sequences assocs arrays
 kernel.private fry combinators accessors vectors strings sbufs
 byte-arrays byte-vectors io.binary io.streams.string splitting math
-math.parser generic generic.standard generic.standard.engines classes
+math.parser generic generic.single generic.standard classes
 hashtables namespaces ;
 IN: hints
 
@@ -42,13 +42,13 @@ SYMBOL: specialize-method?
 
 t specialize-method? set-global
 
+: method-declaration ( method -- quot )
+    [ "method-generic" word-prop dispatch# object <array> ]
+    [ "method-class" word-prop ]
+    bi prefix [ declare ] curry [ ] like ;
+
 : specialize-method ( quot method -- quot' )
-    [
+    [ specialize-method? get [ method-declaration prepend ] [ drop ] if ]
-        specialize-method? get [
-            [ "method-class" word-prop ] [ "method-generic" word-prop ] bi
-            method-declaration prepend
-        ] [ drop ] if
-    ]
     [ "method-generic" word-prop "specializer" word-prop ] bi
     [ specialize-quot ] when* ;
 
@@ -71,7 +71,7 @@ t specialize-method? set-global
 SYNTAX: HINTS:
     scan-object
     [ changed-definition ]
-    [ parse-definition "specializer" set-word-prop ] bi ;
+    [ parse-definition { } like "specializer" set-word-prop ] bi ;
 
 ! Default specializers
 { first first2 first3 first4 }

basis/http/client/client-docs.factor

@@ -1,6 +1,7 @@
 USING: http help.markup help.syntax io.pathnames io.streams.string
 io.encodings.8-bit io.encodings.binary kernel strings urls
-urls.encoding byte-arrays strings assocs sequences destructors ;
+urls.encoding byte-arrays strings assocs sequences destructors
+http.client.post-data.private ;
 IN: http.client
 
 HELP: download-failed
@@ -71,7 +72,7 @@ ARTICLE: "http.client.get" "GET requests with the HTTP client"
 { $subsection with-http-get }
 { $subsection with-http-request } ;
 
-ARTICLE: "http.client.post-data" "HTTP client submission data"
+ARTICLE: "http.client.post-data" "HTTP client post data"
 "HTTP POST and PUT request words take a post data parameter, which can be one of the following:"
 { $list
     { "a " { $link byte-array } ": the data is sent the server without further encoding" }
@@ -85,7 +86,9 @@ ARTICLE: "http.client.post-data" "HTTP client submission data"
 { $code
   "\"my-large-post-request.txt\" ascii <file-reader>"
   "[ URL\" http://www.my-company.com/web-service\" http-post ] with-disposal"
-} ;
+}
+"An internal word used to convert objects to " { $link post-data } " instances:"
+{ $subsection >post-data } ;
 
 ARTICLE: "http.client.post" "POST requests with the HTTP client"
 "Basic usage involves passing post data and a " { $link url } ", and getting a " { $link response } " and data back:"

basis/http/client/post-data/post-data-docs.factor

@@ -0,0 +1,6 @@
+IN: http.client.post-data
+USING: http http.client.post-data.private help.markup help.syntax kernel ;
+
+HELP: >post-data
+{ $values { "object" object } { "post-data" { $maybe post-data } } }
+{ $description "Converts an object into a " { $link post-data } " tuple instance." } ;

basis/io/backend/windows/nt/nt.factor

@@ -46,7 +46,7 @@ M: winnt add-completion ( win32-handle -- )
             { [ dup integer? ] [ ] }
             { [ dup array? ] [
                 first dup eof?
-                [ drop 0 ] [ (win32-error-string) throw ] if
+                [ drop 0 ] [ n>win32-error-string throw ] if
             ] }
         } cond
     ] with-timeout ;
@@ -105,7 +105,7 @@ M: winnt seek-handle ( n seek-type handle -- )
         GetLastError {
             { [ dup expected-io-error? ] [ drop f ] }
             { [ dup eof? ] [ drop t ] }
-            [ (win32-error-string) throw ]
+            [ n>win32-error-string throw ]
         } cond
     ] [ f ] if ;
 

basis/io/backend/windows/nt/privileges/privileges.factor

@@ -2,7 +2,7 @@ USING: alien alien.c-types alien.syntax arrays continuations
 destructors generic io.mmap io.ports io.backend.windows io.files.windows
 kernel libc math math.bitwise namespaces quotations sequences windows
 windows.advapi32 windows.kernel32 io.backend system accessors
-io.backend.windows.privileges ;
+io.backend.windows.privileges windows.errors ;
 IN: io.backend.windows.nt.privileges
 
 TYPEDEF: TOKEN_PRIVILEGES* PTOKEN_PRIVILEGES

basis/io/backend/windows/windows.factor

@@ -1,10 +1,10 @@
 ! Copyright (C) 2004, 2008 Mackenzie Straight, Doug Coleman.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: alien alien.c-types arrays destructors io io.backend
-io.buffers io.files io.ports io.binary io.timeouts
+io.buffers io.files io.ports io.binary io.timeouts system
-windows.errors strings kernel math namespaces sequences windows
+windows.errors strings kernel math namespaces sequences
-windows.kernel32 windows.shell32 windows.types windows.winsock
+windows.errors windows.kernel32 windows.shell32 windows.types
-splitting continuations math.bitwise system accessors ;
+windows.winsock splitting continuations math.bitwise accessors ;
 IN: io.backend.windows
 
 : set-inherit ( handle ? -- )
@@ -51,4 +51,4 @@ HOOK: add-completion io-backend ( port -- )
 : default-security-attributes ( -- obj )
     "SECURITY_ATTRIBUTES" <c-object>
     "SECURITY_ATTRIBUTES" heap-size
-    over set-SECURITY_ATTRIBUTES-nLength ;
+    over set-SECURITY_ATTRIBUTES-nLength ;

basis/io/encodings/string/string.factor

@@ -4,7 +4,7 @@ USING: io io.streams.byte-array ;
 IN: io.encodings.string
 
 : decode ( byte-array encoding -- string )
-    <byte-reader> contents ;
+    <byte-reader> stream-contents ;
 
 : encode ( string encoding -- byte-array )
     [ write ] with-byte-writer ;

basis/io/files/links/links-docs.factor

@@ -5,6 +5,10 @@ HELP: make-link
 { $values { "target" "a path to the symbolic link's target" } { "symlink" "a path to new symbolic link" } }
 { $description "Creates a symbolic link." } ;
 
+HELP: make-hard-link
+{ $values { "target" "a path to the hard link's target" } { "link" "a path to new symbolic link" } }
+{ $description "Creates a hard link." } ;
+
 HELP: read-link
 { $values { "symlink" "a path to an existing symbolic link" } { "path" "the path pointed to by the symbolic link" } }
 { $description "Reads the symbolic link and returns its target path." } ;

basis/io/files/links/links.factor

@@ -6,6 +6,8 @@ IN: io.files.links
 
 HOOK: make-link os ( target symlink -- )
 
+HOOK: make-hard-link os ( target link -- )
+
 HOOK: read-link os ( symlink -- path )
 
 : copy-link ( target symlink -- )

basis/io/files/links/unix/unix.factor

@@ -7,6 +7,9 @@ IN: io.files.links.unix
 M: unix make-link ( path1 path2 -- )
     normalize-path symlink io-error ;
 
+M: unix make-hard-link ( path1 path2 -- )
+    normalize-path link io-error ;
+
 M: unix read-link ( path -- path' )
     normalize-path read-symbolic-link ;
 

basis/io/files/windows/nt/nt.factor

@@ -4,7 +4,8 @@ io.backend.windows io.files.windows io.encodings.utf16n windows
 windows.kernel32 kernel libc math threads system environment
 alien.c-types alien.arrays alien.strings sequences combinators
 combinators.short-circuit ascii splitting alien strings assocs
-namespaces make accessors tr windows.time windows.shell32 ;
+namespaces make accessors tr windows.time windows.shell32
+windows.errors ;
 IN: io.files.windows.nt
 
 M: winnt cwd

basis/io/launcher/launcher.factor

@@ -3,9 +3,9 @@
 USING: system kernel namespaces strings hashtables sequences 
 assocs combinators vocabs.loader init threads continuations
 math accessors concurrency.flags destructors environment
-io io.backend io.timeouts io.pipes io.pipes.private io.encodings
+io io.encodings.ascii io.backend io.timeouts io.pipes
-io.streams.duplex io.ports debugger prettyprint summary
+io.pipes.private io.encodings io.streams.duplex io.ports
-calendar ;
+debugger prettyprint summary calendar ;
 IN: io.launcher
 
 TUPLE: process < identity-tuple
@@ -265,3 +265,5 @@ M: object run-pipeline-element
     { [ os winnt? ] [ "io.launcher.windows.nt" require ] }
     [ ]
 } cond
+
+: run-desc ( desc -- result ) ascii <process-reader> f swap stream-read-until drop ;

basis/io/launcher/unix/unix-tests.factor

@@ -33,7 +33,7 @@ concurrency.promises threads unix.process ;
     "cat"
     "launcher-test-1" temp-file
     2array
-    ascii <process-reader> contents
+    ascii <process-reader> stream-contents
 ] unit-test
 
 [ ] [
@@ -52,7 +52,7 @@ concurrency.promises threads unix.process ;
     "cat"
     "launcher-test-1" temp-file
     2array
-    ascii <process-reader> contents
+    ascii <process-reader> stream-contents
 ] unit-test
 
 [ ] [
@@ -70,14 +70,14 @@ concurrency.promises threads unix.process ;
     "cat"
     "launcher-test-1" temp-file
     2array
-    ascii <process-reader> contents
+    ascii <process-reader> stream-contents
 ] unit-test
 
 [ t ] [
     <process>
         "env" >>command
         { { "A" "B" } } >>environment
-    ascii <process-reader> lines
+    ascii <process-reader> stream-lines
     "A=B" swap member?
 ] unit-test
 
@@ -86,7 +86,7 @@ concurrency.promises threads unix.process ;
         "env" >>command
         { { "A" "B" } } >>environment
         +replace-environment+ >>environment-mode
-    ascii <process-reader> lines
+    ascii <process-reader> stream-lines
 ] unit-test
 
 [ "hi\n" ] [
@@ -113,13 +113,13 @@ concurrency.promises threads unix.process ;
     "append-test" temp-file utf8 file-contents
 ] unit-test
 
-[ t ] [ "ls" utf8 <process-stream> contents >boolean ] unit-test
+[ t ] [ "ls" utf8 <process-stream> stream-contents >boolean ] unit-test
 
 [ "Hello world.\n" ] [
     "cat" utf8 <process-stream> [
         "Hello world.\n" write
         output-stream get dispose
-        input-stream get contents
+        input-stream get stream-contents
     ] with-stream
 ] unit-test
 

basis/io/mmap/windows/windows.factor

@@ -2,7 +2,7 @@ USING: alien alien.c-types arrays destructors generic io.mmap
 io.ports io.backend.windows io.files.windows io.backend.windows.privileges
 kernel libc math math.bitwise namespaces quotations sequences
 windows windows.advapi32 windows.kernel32 io.backend system
-accessors locals ;
+accessors locals windows.errors ;
 IN: io.mmap.windows
 
 : create-file-mapping ( hFile lpAttributes flProtect dwMaximumSizeHigh dwMaximumSizeLow lpName -- HANDLE )
@@ -12,8 +12,8 @@ IN: io.mmap.windows
     MapViewOfFile [ win32-error=0/f ] keep ;
 
 :: mmap-open ( path length access-mode create-mode protect access -- handle handle address )
-    [let | lo [ length HEX: ffffffff bitand ]
+    [let | lo [ length 32 bits ]
-           hi [ length -32 shift HEX: ffffffff bitand ] |
+           hi [ length -32 shift 32 bits ] |
         { "SeCreateGlobalPrivilege" "SeLockMemoryPrivilege" } [
             path access-mode create-mode 0 open-file |dispose
             dup handle>> f protect hi lo f create-file-mapping |dispose

basis/io/monitors/windows/nt/nt.factor

@@ -6,7 +6,7 @@ hashtables sorting arrays combinators math.bitwise strings
 system accessors threads splitting io.backend io.backend.windows
 io.backend.windows.nt io.files.windows.nt io.monitors io.ports
 io.buffers io.files io.timeouts io.encodings.string
-io.encodings.utf16n io windows windows.kernel32 windows.types
+io.encodings.utf16n io windows.errors windows.kernel32 windows.types
 io.pathnames ;
 IN: io.monitors.windows.nt
 

basis/io/servers/connection/connection-tests.factor

@@ -35,4 +35,4 @@ concurrency.promises io.encodings.ascii io threads calendar ;
     dup start-server* sockets>> first addr>> port>> "port" set
 ] unit-test
 
-[ "Hello world." ] [ "localhost" "port" get <inet> ascii <client> drop contents ] unit-test
+[ "Hello world." ] [ "localhost" "port" get <inet> ascii <client> drop stream-contents ] unit-test

basis/io/sockets/secure/unix/unix-tests.factor

@@ -23,7 +23,7 @@ io.sockets.secure.unix.debug ;
 
 : client-test ( -- string )
     <secure-config> [
-        "127.0.0.1" "port" get ?promise <inet4> <secure> ascii <client> drop contents
+        "127.0.0.1" "port" get ?promise <inet4> <secure> ascii <client> drop stream-contents
     ] with-secure-context ;
 
 [ ] [ [ class name>> write ] server-test ] unit-test

basis/io/streams/byte-array/byte-array-tests.factor

@@ -6,7 +6,7 @@ io.encodings.utf8 io kernel arrays strings namespaces ;
 
 [ B{ BIN: 11110101 BIN: 10111111 BIN: 10000000 BIN: 10111111 BIN: 11101111 BIN: 10000000 BIN: 10111111 BIN: 11011111 BIN: 10000000 CHAR: x } ]
 [ { BIN: 101111111000000111111 BIN: 1111000000111111 BIN: 11111000000 CHAR: x } >string utf8 [ write ] with-byte-writer ] unit-test
-[ { BIN: 101111111000000111111 } t ] [ { BIN: 11110101 BIN: 10111111 BIN: 10000000 BIN: 10111111 } utf8 <byte-reader> contents dup >array swap string? ] unit-test
+[ { BIN: 101111111000000111111 } t ] [ { BIN: 11110101 BIN: 10111111 BIN: 10000000 BIN: 10111111 } utf8 <byte-reader> stream-contents dup >array swap string? ] unit-test
 
 [ B{ 121 120 } 0 ] [
     B{ 0 121 120 0 0 0 0 0 0 } binary
@@ -26,4 +26,4 @@ io.encodings.utf8 io kernel arrays strings namespaces ;
         0 seek-end input-stream get stream-seek
         read1
     ] with-byte-reader
-] unit-test
+] unit-test