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

basis/alien/strings/strings-tests.factor

@@ -1,6 +1,6 @@
 USING: alien.strings tools.test kernel libc
 io.encodings.8-bit io.encodings.utf8 io.encodings.utf16
-io.encodings.ascii alien ;
+io.encodings.ascii alien io.encodings.string ;
 IN: alien.strings.tests
 
 [ "\u0000ff" ]
@@ -28,3 +28,7 @@ unit-test
 ] unit-test
 
 [ f ] [ f utf8 alien>string ] unit-test
+
+[ "hello" ] [ "hello" utf16 encode utf16 decode ] unit-test
+
+[ "hello" ] [ "hello" utf16 string>alien utf16 alien>string ] unit-test

basis/bootstrap/compiler/compiler.factor

@@ -89,14 +89,24 @@ nl
     . malloc calloc free memcpy
 } compile-uncompiled
 
+"." write flush
+
 { build-tree } compile-uncompiled
 
+"." write flush
+
 { optimize-tree } compile-uncompiled
 
+"." write flush
+
 { optimize-cfg } compile-uncompiled
 
+"." write flush
+
 { (compile) } compile-uncompiled
 
+"." write flush
+
 vocabs [ words compile-uncompiled "." write flush ] each
 
 " done" print flush

basis/bootstrap/image/image.factor

@@ -368,31 +368,35 @@ M: byte-array '
 
 M: tuple ' emit-tuple ;
 
-M: tuple-layout '
-    [
-        [
-            {
-                [ hashcode>> , ]
-                [ class>> , ]
-                [ size>> , ]
-                [ superclasses>> , ]
-                [ echelon>> , ]
-            } cleave
-        ] { } make [ ' ] map
-        \ tuple-layout type-number
-        object tag-number [ emit-seq ] emit-object
-    ] cache-object ;
-
 M: tombstone '
     state>> "((tombstone))" "((empty))" ?
     "hashtables.private" lookup def>> first
     [ emit-tuple ] cache-object ;
 
 ! Arrays
-M: array '
+: emit-array ( array -- offset )
     [ ' ] map array type-number object tag-number
     [ [ length emit-fixnum ] [ emit-seq ] bi ] emit-object ;
 
+M: array ' emit-array ;
+
+! This is a hack. We need to detect arrays which are tuple
+! layout arrays so that they can be internalized, but making
+! them a built-in type is not worth it.
+PREDICATE: tuple-layout-array < array
+    dup length 5 >= [
+        [ first tuple-class? ]
+        [ second fixnum? ]
+        [ third fixnum? ]
+        tri and and
+    ] [ drop f ] if ;
+
+M: tuple-layout-array '
+    [
+        [ dup integer? [ <fake-bignum> ] when ] map
+        emit-array
+    ] cache-object ;
+
 ! Quotations
 
 M: quotation '

basis/bootstrap/random/random.factor

@@ -1,16 +0,0 @@
-USING: vocabs.loader sequences system
-random random.mersenne-twister combinators init
-namespaces random ;
-IN: bootstrap.random
-
-"random.mersenne-twister" require
-
-{
-    { [ os windows? ] [ "random.windows" require ] }
-    { [ os unix? ] [ "random.unix" require ] }
-} cond
-
-[
-    [ 32 random-bits ] with-system-random
-    <mersenne-twister> random-generator set-global
-] "bootstrap.random" add-init-hook

basis/bootstrap/stage2.factor

@@ -50,7 +50,7 @@ SYMBOL: bootstrap-time
 
     default-image-name "output-image" set-global
 
-    "math compiler threads help io tools ui ui.tools random unicode handbook" "include" set-global
+    "math compiler threads help io tools ui ui.tools unicode handbook" "include" set-global
     "" "exclude" set-global
 
     parse-command-line

basis/compiler/cfg/builder/builder.factor

@@ -125,23 +125,61 @@ M: #recursive emit-node
 : ##branch-t ( vreg -- )
     \ f tag-number cc/= ##compare-imm-branch ;
 
+: trivial-branch? ( nodes -- value ? )
+    dup length 1 = [
+        first dup #push? [ literal>> t ] [ drop f f ] if
+    ] [ drop f f ] if ;
+
+: trivial-if? ( #if -- ? )
+    children>> first2
+    [ trivial-branch? [ t eq? ] when ]
+    [ trivial-branch? [ f eq? ] when ] bi*
+    and ;
+
+: emit-trivial-if ( -- )
+    ds-pop \ f tag-number cc/= ^^compare-imm ds-push ;
+
+: trivial-not-if? ( #if -- ? )
+    children>> first2
+    [ trivial-branch? [ f eq? ] when ]
+    [ trivial-branch? [ t eq? ] when ] bi*
+    and ;
+
+: emit-trivial-not-if ( -- )
+    ds-pop \ f tag-number cc= ^^compare-imm ds-push ;
+
 M: #if emit-node
-    ds-pop ##branch-t emit-if iterate-next ;
+    {
+        { [ dup trivial-if? ] [ drop emit-trivial-if ] }
+        { [ dup trivial-not-if? ] [ drop emit-trivial-not-if ] }
+        [ ds-pop ##branch-t emit-if ]
+    } cond iterate-next ;
 
 ! #dispatch
+: trivial-dispatch-branch? ( nodes -- ? )
+    dup length 1 = [
+        first dup #call? [
+            word>> "intrinsic" word-prop not
+        ] [ drop f ] if
+    ] [ drop f ] if ;
+
 : dispatch-branch ( nodes word -- label )
-    gensym [
+    over trivial-dispatch-branch? [
-        [
+        drop first word>>
-            V{ } clone node-stack set
+    ] [
-            ##prologue
+        gensym [
-            emit-nodes
+            [
-            basic-block get [
+                V{ } clone node-stack set
-                ##epilogue
+                ##prologue
-                ##return
+                emit-nodes
-                end-basic-block
+                basic-block get [
-            ] when
+                    ##epilogue
-        ] with-cfg-builder
+                    ##return
-    ] keep ;
+                    end-basic-block
+                ] when
+            ] with-cfg-builder
+        ] keep
+    ] if ;
 
 : dispatch-branches ( node -- )
     children>> [

basis/compiler/cfg/def-use/def-use.factor

@@ -14,6 +14,7 @@ M: ##allot defs-vregs dst/tmp-vregs ;
 M: ##dispatch defs-vregs temp>> 1array ;
 M: ##slot defs-vregs [ dst>> ] [ temp>> ] bi 2array ;
 M: ##set-slot defs-vregs temp>> 1array ;
+M: ##string-nth defs-vregs [ dst>> ] [ temp>> ] bi 2array ;
 M: insn defs-vregs drop f ;
 
 M: ##unary uses-vregs src>> 1array ;
@@ -24,6 +25,7 @@ M: ##slot uses-vregs [ obj>> ] [ slot>> ] bi 2array ;
 M: ##slot-imm uses-vregs obj>> 1array ;
 M: ##set-slot uses-vregs [ src>> ] [ obj>> ] [ slot>> ] tri 3array ;
 M: ##set-slot-imm uses-vregs [ src>> ] [ obj>> ] bi 2array ;
+M: ##string-nth uses-vregs [ obj>> ] [ index>> ] bi 2array ;
 M: ##conditional-branch uses-vregs [ src1>> ] [ src2>> ] bi 2array ;
 M: ##compare-imm-branch uses-vregs src1>> 1array ;
 M: ##dispatch uses-vregs src>> 1array ;

basis/compiler/cfg/hats/hats.factor

@@ -22,6 +22,7 @@ IN: compiler.cfg.hats
 : ^^slot ( obj slot tag -- dst ) ^^i3 i ##slot ; inline
 : ^^slot-imm ( obj slot tag -- dst ) ^^i3 ##slot-imm ; inline
 : ^^set-slot ( src obj slot tag -- ) i ##set-slot ; inline
+: ^^string-nth ( obj index -- dst ) ^^i2 i ##string-nth ; inline
 : ^^add ( src1 src2 -- dst ) ^^i2 ##add ; inline
 : ^^add-imm ( src1 src2 -- dst ) ^^i2 ##add-imm ; inline
 : ^^sub ( src1 src2 -- dst ) ^^i2 ##sub ; inline

basis/compiler/cfg/instructions/instructions.factor

@@ -71,6 +71,9 @@ INSN: ##slot-imm < ##read { obj vreg } { slot integer } { tag integer } ;
 INSN: ##set-slot < ##write { obj vreg } { slot vreg } { tag integer } { temp vreg } ;
 INSN: ##set-slot-imm < ##write { obj vreg } { slot integer } { tag integer } ;
 
+! String element access
+INSN: ##string-nth < ##flushable { obj vreg } { index vreg } { temp vreg } ;
+
 ! Integer arithmetic
 INSN: ##add < ##commutative ;
 INSN: ##add-imm < ##commutative-imm ;

basis/compiler/cfg/intrinsics/alien/alien.factor

@@ -15,7 +15,7 @@ IN: compiler.cfg.intrinsics.alien
 
 : prepare-alien-accessor ( infos -- offset-vreg )
     <reversed> [ second class>> ] [ first ] bi
-    dup value-info-small-tagged? [
+    dup value-info-small-fixnum? [
         literal>> (prepare-alien-accessor-imm)
     ] [ drop (prepare-alien-accessor) ] if ;
 

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

@@ -16,14 +16,14 @@ IN: compiler.cfg.intrinsics.allot
     [ ##set-slots ] [ [ drop ] [ ds-push ] [ drop ] tri* ] 3bi ;
 
 : tuple-slot-regs ( layout -- vregs )
-    [ size>> ds-load ] [ ^^load-literal ] bi prefix ;
+    [ second ds-load ] [ ^^load-literal ] bi prefix ;
 
 : emit-<tuple-boa> ( node -- )
     dup node-input-infos peek literal>>
-    dup tuple-layout? [
+    dup array? [
         nip
         ds-drop
-        [ tuple-slot-regs ] [ size>> ^^allot-tuple ] bi
+        [ tuple-slot-regs ] [ second ^^allot-tuple ] bi
         [ tuple ##set-slots ] [ ds-push drop ] 2bi
     ] [ drop emit-primitive ] if ;
 

basis/compiler/cfg/intrinsics/fixnum/fixnum.factor

@@ -9,7 +9,10 @@ IN: compiler.cfg.intrinsics.fixnum
 
 : (emit-fixnum-imm-op) ( infos insn -- dst )
     ds-drop
-    [ ds-pop ] [ second literal>> tag-fixnum ] [ ] tri*
+    [ ds-pop ]
+    [ second literal>> [ tag-fixnum ] [ \ f tag-number ] if* ]
+    [ ]
+    tri*
     call ; inline
 
 : (emit-fixnum-op) ( insn -- dst )
@@ -25,7 +28,7 @@ IN: compiler.cfg.intrinsics.fixnum
     ] ; inline
 
 : emit-fixnum-shift-fast ( node -- )
-    dup node-input-infos dup second value-info-small-tagged? [
+    dup node-input-infos dup second value-info-small-fixnum? [
         nip
         [ ds-drop ds-pop ] dip
         second literal>> dup sgn {
@@ -48,7 +51,7 @@ IN: compiler.cfg.intrinsics.fixnum
 
 : emit-fixnum*fast ( node -- )
     node-input-infos
-    dup second value-info-small-tagged?
+    dup second value-info-small-fixnum?
     [ (emit-fixnum*fast-imm) ] [ drop (emit-fixnum*fast) ] if
     ds-push ;
 

basis/compiler/cfg/intrinsics/intrinsics.factor

@@ -14,6 +14,7 @@ QUALIFIED: arrays
 QUALIFIED: byte-arrays
 QUALIFIED: kernel.private
 QUALIFIED: slots.private
+QUALIFIED: strings.private
 QUALIFIED: classes.tuple.private
 QUALIFIED: math.private
 QUALIFIED: alien.accessors
@@ -38,6 +39,7 @@ IN: compiler.cfg.intrinsics
     kernel:eq?
     slots.private:slot
     slots.private:set-slot
+    strings.private:string-nth
     classes.tuple.private:<tuple-boa>
     arrays:<array>
     byte-arrays:<byte-array>
@@ -114,6 +116,7 @@ IN: compiler.cfg.intrinsics
         { \ math.private:fixnum>float [ drop emit-fixnum>float ] }
         { \ slots.private:slot [ emit-slot ] }
         { \ slots.private:set-slot [ emit-set-slot ] }
+        { \ strings.private:string-nth [ drop emit-string-nth ] }
         { \ classes.tuple.private:<tuple-boa> [ emit-<tuple-boa> ] }
         { \ arrays:<array> [ emit-<array> ] }
         { \ byte-arrays:<byte-array> [ emit-<byte-array> ] }

basis/compiler/cfg/intrinsics/slots/slots.factor

@@ -25,7 +25,7 @@ IN: compiler.cfg.intrinsics.slots
     dup node-input-infos
     dup first value-tag [
         nip
-        dup second value-info-small-tagged?
+        dup second value-info-small-fixnum?
         [ (emit-slot-imm) ] [ (emit-slot) ] if
         ds-push
     ] [ drop emit-primitive ] if ;
@@ -46,8 +46,11 @@ IN: compiler.cfg.intrinsics.slots
     dup second value-tag [
         nip
         [
-            dup third value-info-small-tagged?
+            dup third value-info-small-fixnum?
             [ (emit-set-slot-imm) ] [ (emit-set-slot) ] if
         ] [ first class>> immediate class<= ] bi
         [ drop ] [ i i ##write-barrier ] if
     ] [ drop emit-primitive ] if ;
+
+: emit-string-nth ( -- )
+    2inputs swap ^^untag-fixnum ^^string-nth ^^tag-fixnum ds-push ;

basis/compiler/cfg/stack-frame/stack-frame.factor

@@ -1,8 +1,8 @@
 ! Copyright (C) 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: namespaces accessors math.order assocs kernel sequences
-combinators make cpu.architecture compiler.cfg.instructions
+combinators make classes words cpu.architecture
-compiler.cfg.registers ;
+compiler.cfg.instructions compiler.cfg.registers ;
 IN: compiler.cfg.stack-frame
 
 SYMBOL: frame-required?
@@ -24,16 +24,16 @@ M: ##stack-frame compute-stack-frame*
 M: ##call compute-stack-frame*
     word>> sub-primitive>> [ frame-required? on ] unless ;
 
-M: _gc compute-stack-frame*
-    drop frame-required? on ;
-
-M: _spill compute-stack-frame*
-    drop frame-required? on ;
-
 M: _spill-counts compute-stack-frame*
     counts>> stack-frame get (>>spill-counts) ;
 
-M: insn compute-stack-frame* drop ;
+M: insn compute-stack-frame*
+    class frame-required? word-prop [
+        frame-required? on
+    ] when ;
+
+\ _gc t frame-required? set-word-prop
+\ _spill t frame-required? set-word-prop
 
 : compute-stack-frame ( insns -- )
     frame-required? off

basis/compiler/cfg/utilities/utilities.factor

@@ -1,12 +1,24 @@
 ! Copyright (C) 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: accessors kernel math layouts make sequences
+USING: accessors kernel math layouts make sequences combinators
 cpu.architecture namespaces compiler.cfg
 compiler.cfg.instructions ;
 IN: compiler.cfg.utilities
 
+: value-info-small-fixnum? ( value-info -- ? )
+    literal>> {
+        { [ dup fixnum? ] [ tag-fixnum small-enough? ] }
+        [ drop f ]
+    } cond ;
+
 : value-info-small-tagged? ( value-info -- ? )
-    literal>> dup fixnum? [ tag-fixnum small-enough? ] [ drop f ] if ;
+    dup literal?>> [
+        literal>> {
+            { [ dup fixnum? ] [ tag-fixnum small-enough? ] }
+            { [ dup not ] [ drop t ] }
+            [ drop f ]
+        } cond
+    ] [ drop f ] if ;
 
 : set-basic-block ( basic-block -- )
     [ basic-block set ] [ instructions>> building set ] bi ;

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

@@ -36,6 +36,10 @@ M: ##set-slot propagate
     [ resolve ] change-obj
     [ resolve ] change-slot ;
 
+M: ##string-nth propagate
+    [ resolve ] change-obj
+    [ resolve ] change-index ;
+
 M: ##set-slot-imm propagate
     call-next-method
     [ resolve ] change-obj ;

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

@@ -42,25 +42,75 @@ M: ##mul-imm rewrite
 
 : tag-fixnum-expr? ( expr -- ? )
     dup op>> \ ##shl-imm eq?
-    [ in2>> vn>expr value>> tag-bits get = ] [ drop f ] if ;
+    [ in2>> vn>constant tag-bits get = ] [ drop f ] if ;
 
 : rewrite-tagged-comparison? ( insn -- ? )
     #! Are we comparing two tagged fixnums? Then untag them.
-    dup ##compare-imm-branch? [
+    [ src1>> vreg>expr tag-fixnum-expr? ]
-        [ src1>> vreg>expr tag-fixnum-expr? ]
+    [ src2>> tag-mask get bitand 0 = ]
-        [ src2>> tag-mask get bitand 0 = ]
+    bi and ; inline
-        bi and
-    ] [ drop f ] if ; inline
 
-: rewrite-tagged-comparison ( insn -- insn' )
+: (rewrite-tagged-comparison) ( insn -- src1 src2 cc )
     [ src1>> vreg>expr in1>> vn>vreg ]
     [ src2>> tag-bits get neg shift ]
     [ cc>> ]
-    tri
+    tri ; inline
-    f \ ##compare-imm-branch boa ;
+
+GENERIC: rewrite-tagged-comparison ( insn -- insn' )
+
+M: ##compare-imm-branch rewrite-tagged-comparison
+    (rewrite-tagged-comparison) f \ ##compare-imm-branch boa ;
+
+M: ##compare-imm rewrite-tagged-comparison
+    [ dst>> ] [ (rewrite-tagged-comparison) ] bi
+    f \ ##compare-imm boa ;
 
 M: ##compare-imm-branch rewrite
     dup rewrite-boolean-comparison? [ rewrite-boolean-comparison ] when
-    dup rewrite-tagged-comparison? [ rewrite-tagged-comparison ] when ;
+    dup ##compare-imm-branch? [
+        dup rewrite-tagged-comparison? [ rewrite-tagged-comparison ] when
+    ] when ;
+
+: flip-comparison? ( insn -- ? )
+    dup cc>> cc= eq? [ src1>> vreg>expr constant-expr? ] [ drop f ] if ;
+
+: flip-comparison ( insn -- insn' )
+    [ dst>> ]
+    [ src2>> ]
+    [ src1>> vreg>vn vn>constant ] tri
+    cc= f \ ##compare-imm boa ;
+
+M: ##compare rewrite
+    dup flip-comparison? [
+        flip-comparison
+        dup number-values
+        rewrite
+    ] when ;
+
+: rewrite-redundant-comparison? ( insn -- ? )
+    [ src1>> vreg>expr compare-expr? ]
+    [ src2>> \ f tag-number = ]
+    [ cc>> { cc= cc/= } memq? ]
+    tri and and ; inline
+
+: rewrite-redundant-comparison ( insn -- insn' )
+    [ cc>> ] [ dst>> ] [ src1>> vreg>expr dup op>> ] tri {
+        { \ ##compare [ >compare-expr< f \ ##compare boa ] }
+        { \ ##compare-imm [ >compare-imm-expr< f \ ##compare-imm boa ] }
+        { \ ##compare-float [ >compare-expr< f \ ##compare-float boa ] }
+    } case
+    swap cc= eq? [ [ negate-cc ] change-cc ] when ;
+
+M: ##compare-imm rewrite
+    dup rewrite-redundant-comparison? [
+        rewrite-redundant-comparison
+        dup number-values rewrite
+    ] when
+    dup ##compare-imm? [
+        dup rewrite-tagged-comparison? [
+            rewrite-tagged-comparison
+            dup number-values rewrite
+        ] when
+    ] when ;
 
 M: insn rewrite ;

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

@@ -1,6 +1,6 @@
 IN: compiler.cfg.value-numbering.tests
 USING: compiler.cfg.value-numbering compiler.cfg.instructions
-compiler.cfg.registers cpu.architecture tools.test kernel ;
+compiler.cfg.registers cpu.architecture tools.test kernel math ;
 [
     {
         T{ ##peek f V int-regs 45 D 1 }
@@ -66,3 +66,77 @@ compiler.cfg.registers cpu.architecture tools.test kernel ;
         T{ ##replace f V int-regs 3 D 0 }
     } value-numbering
 ] unit-test
+
+[
+    {
+        T{ ##load-indirect 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 f V int-regs 6 V int-regs 2 V int-regs 1 cc> }
+        T{ ##replace f V int-regs 4 D 0 }
+    }
+] [
+    {
+        T{ ##load-indirect 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{ ##replace f V int-regs 6 D 0 }
+    } value-numbering
+] unit-test
+
+[
+    {
+        T{ ##load-indirect 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 f V int-regs 6 V int-regs 2 V int-regs 1 cc> }
+        T{ ##replace f V int-regs 6 D 0 }
+    }
+] [
+    {
+        T{ ##load-indirect 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{ ##replace f V int-regs 6 D 0 }
+    } value-numbering
+] unit-test
+
+[
+    {
+        T{ ##peek f V int-regs 8 D 0 }
+        T{ ##peek f V int-regs 9 D -1 }
+        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-float f V int-regs 14 V double-float-regs 10 V double-float-regs 11 cc>= }
+        T{ ##replace f V int-regs 14 D 0 }
+    }
+] [
+    {
+        T{ ##peek f V int-regs 8 D 0 }
+        T{ ##peek f V int-regs 9 D -1 }
+        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{ ##replace f V int-regs 14 D 0 }
+    } value-numbering
+] unit-test
+
+[
+    {
+        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-branch f V int-regs 29 V int-regs 30 cc<= }
+    }
+] [
+    {
+        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/= }
+    } value-numbering
+] unit-test

basis/compiler/codegen/codegen.factor

@@ -123,6 +123,14 @@ M: ##set-slot generate-insn
 M: ##set-slot-imm generate-insn
     >set-slot< %set-slot-imm ;
 
+M: ##string-nth generate-insn
+    {
+        [ dst>> register ]
+        [ obj>> register ]
+        [ index>> register ]
+        [ temp>> register ]
+    } cleave %string-nth ;
+
 : dst/src ( insn -- dst src )
     [ dst>> register ] [ src>> register ] bi ; inline
 

basis/compiler/constants/constants.factor

@@ -1,49 +1,50 @@
 ! Copyright (C) 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: math kernel layouts system ;
+USING: math kernel layouts system strings ;
 IN: compiler.constants
 
 ! These constants must match vm/memory.h
-: card-bits 8 ;
+: card-bits 8 ; inline
-: deck-bits 18 ;
+: deck-bits 18 ; inline
-: card-mark ( -- n ) HEX: 40 HEX: 80 bitor ;
+: card-mark ( -- n ) HEX: 40 HEX: 80 bitor ; inline
 
 ! These constants must match vm/layouts.h
-: header-offset ( -- n ) object tag-number neg ;
+: header-offset ( -- n ) object tag-number neg ; inline
-: float-offset ( -- n ) 8 float tag-number - ;
+: float-offset ( -- n ) 8 float tag-number - ; inline
-: string-offset ( -- n ) 4 bootstrap-cells object tag-number - ;
+: string-offset ( -- n ) 4 bootstrap-cells object tag-number - ; inline
-: profile-count-offset ( -- n ) 7 bootstrap-cells object tag-number - ;
+: string-aux-offset ( -- n ) 2 bootstrap-cells string tag-number - ; inline
-: byte-array-offset ( -- n ) 2 bootstrap-cells object tag-number - ;
+: profile-count-offset ( -- n ) 7 bootstrap-cells object tag-number - ; inline
-: alien-offset ( -- n ) 3 bootstrap-cells object tag-number - ;
+: byte-array-offset ( -- n ) 2 bootstrap-cells object tag-number - ; inline
-: underlying-alien-offset ( -- n ) bootstrap-cell object tag-number - ;
+: alien-offset ( -- n ) 3 bootstrap-cells object tag-number - ; inline
-: tuple-class-offset ( -- n ) bootstrap-cell tuple tag-number - ;
+: underlying-alien-offset ( -- n ) bootstrap-cell object tag-number - ; inline
-: class-hash-offset ( -- n ) bootstrap-cell object tag-number - ;
+: tuple-class-offset ( -- n ) bootstrap-cell tuple tag-number - ; inline
-: word-xt-offset ( -- n ) 9 bootstrap-cells object tag-number - ;
+: class-hash-offset ( -- n ) bootstrap-cell object tag-number - ; inline
-: quot-xt-offset ( -- n ) 3 bootstrap-cells object tag-number - ;
+: word-xt-offset ( -- n ) 9 bootstrap-cells object tag-number - ; inline
-: word-code-offset ( -- n ) 10 bootstrap-cells object tag-number - ;
+: quot-xt-offset ( -- n ) 3 bootstrap-cells object tag-number - ; inline
-: array-start-offset ( -- n ) 2 bootstrap-cells object tag-number - ;
+: word-code-offset ( -- n ) 10 bootstrap-cells object tag-number - ; inline
-: compiled-header-size ( -- n ) 4 bootstrap-cells ;
+: array-start-offset ( -- n ) 2 bootstrap-cells object tag-number - ; inline
+: compiled-header-size ( -- n ) 4 bootstrap-cells ; inline
 
 ! Relocation classes
-: rc-absolute-cell    0 ;
+: rc-absolute-cell    0 ; inline
-: rc-absolute         1 ;
+: rc-absolute         1 ; inline
-: rc-relative         2 ;
+: rc-relative         2 ; inline
-: rc-absolute-ppc-2/2 3 ;
+: rc-absolute-ppc-2/2 3 ; inline
-: rc-relative-ppc-2   4 ;
+: rc-relative-ppc-2   4 ; inline
-: rc-relative-ppc-3   5 ;
+: rc-relative-ppc-3   5 ; inline
-: rc-relative-arm-3   6 ;
+: rc-relative-arm-3   6 ; inline
-: rc-indirect-arm     7 ;
+: rc-indirect-arm     7 ; inline
-: rc-indirect-arm-pc  8 ;
+: rc-indirect-arm-pc  8 ; inline
 
 ! Relocation types
-: rt-primitive 0 ;
+: rt-primitive 0 ; inline
-: rt-dlsym     1 ;
+: rt-dlsym     1 ; inline
-: rt-literal   2 ;
+: rt-literal   2 ; inline
-: rt-dispatch  3 ;
+: rt-dispatch  3 ; inline
-: rt-xt        4 ;
+: rt-xt        4 ; inline
-: rt-here      5 ;
+: rt-here      5 ; inline
-: rt-label     6 ;
+: rt-label     6 ; inline
-: rt-immediate 7 ;
+: rt-immediate 7 ; inline
 
 : rc-absolute? ( n -- ? )
     [ rc-absolute-ppc-2/2 = ]

basis/compiler/tests/intrinsics.factor

@@ -4,7 +4,8 @@ continuations sequences.private hashtables.private byte-arrays
 strings.private system random layouts vectors
 sbufs strings.private slots.private alien math.order
 alien.accessors alien.c-types alien.syntax alien.strings
-namespaces libc sequences.private io.encodings.ascii ;
+namespaces libc sequences.private io.encodings.ascii
+classes ;
 IN: compiler.tests
 
 ! Make sure that intrinsic ops compile to correct code.
@@ -27,6 +28,9 @@ IN: compiler.tests
 
 [ 1 ] [ { 1 2 } [ 2 slot ] compile-call ] unit-test
 [ 1 ] [ [ { 1 2 } 2 slot ] compile-call ] unit-test
+
+[ { f f } ] [ 2 f <array> ] unit-test
+
 [ 3 ] [ 3 1 2 2array [ { array } declare [ 2 set-slot ] keep ] compile-call first ] unit-test
 [ 3 ] [ 3 1 2 [ 2array [ 2 set-slot ] keep ] compile-call first ] unit-test
 [ 3 ] [ [ 3 1 2 2array [ 2 set-slot ] keep ] compile-call first ] unit-test
@@ -37,13 +41,19 @@ IN: compiler.tests
 ! Write barrier hits on the wrong value were causing segfaults
 [ -3 ] [ -3 1 2 [ 2array [ 3 set-slot ] keep ] compile-call second ] unit-test
 
-! [ CHAR: b ] [ 1 "abc" [ char-slot ] compile-call ] unit-test
+[ CHAR: a ] [ 0 "abc" [ string-nth ] compile-call ] unit-test
-! [ CHAR: b ] [ 1 [ "abc" char-slot ] compile-call ] unit-test
+[ CHAR: a ] [ 0 [ "abc" string-nth ] compile-call ] unit-test
-! [ CHAR: b ] [ [ 1 "abc" char-slot ] compile-call ] unit-test
+[ CHAR: a ] [ [ 0 "abc" string-nth ] compile-call ] unit-test
-! 
+[ CHAR: b ] [ 1 "abc" [ string-nth ] compile-call ] unit-test
-! [ "axc" ] [ CHAR: x 1 "abc" [ [ set-char-slot ] keep { string } declare dup rehash-string ] compile-call ] unit-test
+[ CHAR: b ] [ 1 [ "abc" string-nth ] compile-call ] unit-test
-! [ "axc" ] [ CHAR: x 1 [ "abc" [ set-char-slot ] keep { string } declare dup rehash-string ] compile-call ] unit-test
+[ CHAR: b ] [ [ 1 "abc" string-nth ] compile-call ] unit-test
-! [ "axc" ] [ CHAR: x [ 1 "abc" [ set-char-slot ] keep { string } declare dup rehash-string ] compile-call ] unit-test
+
+[ HEX: 123456 ] [ 0 "\u123456bc" [ string-nth ] compile-call ] unit-test
+[ HEX: 123456 ] [ 0 [ "\u123456bc" string-nth ] compile-call ] unit-test
+[ HEX: 123456 ] [ [ 0 "\u123456bc" string-nth ] compile-call ] unit-test
+[ HEX: 123456 ] [ 1 "a\u123456c" [ string-nth ] compile-call ] unit-test
+[ HEX: 123456 ] [ 1 [ "a\u123456c" string-nth ] compile-call ] unit-test
+[ HEX: 123456 ] [ [ 1 "a\u123456c" string-nth ] compile-call ] unit-test
 
 [ ] [ [ 0 getenv ] compile-call drop ] unit-test
 [ ] [ 1 getenv [ 1 setenv ] compile-call ] unit-test
@@ -158,6 +168,10 @@ IN: compiler.tests
 [ 4 ] [ 1 [ 3 fixnum+fast ] compile-call ] unit-test
 [ 4 ] [ [ 1 3 fixnum+fast ] compile-call ] unit-test
 
+[ -2 ] [ 1 3 [ fixnum-fast ] compile-call ] unit-test
+[ -2 ] [ 1 [ 3 fixnum-fast ] compile-call ] unit-test
+[ -2 ] [ [ 1 3 fixnum-fast ] compile-call ] unit-test
+
 [ 30001 ] [ 1 [ 30000 fixnum+fast ] compile-call ] unit-test
 
 [ 6 ] [ 2 3 [ fixnum*fast ] compile-call ] unit-test
@@ -263,6 +277,8 @@ cell 8 = [
 
 : compiled-fixnum>bignum fixnum>bignum ;
 
+[ bignum ] [ 0 compiled-fixnum>bignum class ] unit-test
+
 [ ] [
     10000 [
         32 random-bits >fixnum

basis/compiler/tests/redefine12.factor

@@ -0,0 +1,20 @@
+USING: kernel tools.test eval ;
+IN: compiler.tests.redefine12
+
+! A regression that came about when fixing the
+! 'no method on classes-intersect?' bug
+
+GENERIC: g ( a -- b )
+
+M: object g drop t ;
+
+: h ( a -- b ) dup [ g ] when ;
+
+[ f ] [ f h ] unit-test
+[ t ] [ "hi" h ] unit-test
+
+TUPLE: jeah ;
+
+[ ] [ "USE: kernel IN: compiler.tests.redefine12 M: jeah g drop f ;" eval ] unit-test
+
+[ f ] [ T{ jeah } h ] unit-test

basis/compiler/tests/spilling.factor

@@ -0,0 +1,343 @@
+USING: math.private kernel combinators accessors arrays
+generalizations float-arrays tools.test ;
+IN: compiler.tests
+
+: 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 )
+    {
+        [ dup float+ ]
+        [ dup float+ ]
+        [ dup float+ ]
+        [ dup float+ ]
+        [ dup float+ ]
+        [ dup float+ ]
+        [ dup float+ ]
+        [ dup float+ ]
+        [ dup float+ ]
+        [ dup float+ ]
+        [ dup float+ ]
+        [ dup float+ ]
+        [ dup float+ ]
+        [ dup float+ ]
+        [ dup float+ ]
+        [ dup float+ ]
+        [ dup float+ ]
+        [ dup float+ ]
+        [ dup float+ ]
+        [ dup float+ ]
+        [ dup float+ ]
+        [ dup float+ ]
+        [ dup float+ ]
+        [ dup float+ ]
+        [ dup float+ ]
+        [ dup float+ ]
+        [ dup float+ ]
+        [ dup float+ ]
+        [ dup float+ ]
+        [ dup float+ ]
+        [ dup float+ ]
+        [ dup float+ ]
+        [ dup float+ ]
+        [ dup float+ ]
+        [ dup float+ ]
+        [ dup float+ ]
+        [ dup float+ ]
+        [ dup float+ ]
+    } cleave ;
+
+[ 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 compiled>> ] 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 )
+    {
+        [ dup float+ ]
+        [ float>fixnum dup fixnum+fast ]
+        [ dup float+ ]
+        [ float>fixnum dup fixnum+fast ]
+        [ dup float+ ]
+        [ float>fixnum dup fixnum+fast ]
+        [ dup float+ ]
+        [ float>fixnum dup fixnum+fast ]
+        [ dup float+ ]
+        [ float>fixnum dup fixnum+fast ]
+        [ dup float+ ]
+        [ float>fixnum dup fixnum+fast ]
+        [ dup float+ ]
+        [ float>fixnum dup fixnum+fast ]
+        [ dup float+ ]
+        [ float>fixnum dup fixnum+fast ]
+        [ dup float+ ]
+        [ float>fixnum dup fixnum+fast ]
+        [ dup float+ ]
+        [ float>fixnum dup fixnum+fast ]
+        [ dup float+ ]
+        [ float>fixnum dup fixnum+fast ]
+        [ dup float+ ]
+        [ float>fixnum dup fixnum+fast ]
+        [ dup float+ ]
+        [ float>fixnum dup fixnum+fast ]
+        [ dup float+ ]
+        [ float>fixnum dup fixnum+fast ]
+        [ dup float+ ]
+        [ float>fixnum dup fixnum+fast ]
+        [ dup float+ ]
+        [ float>fixnum dup fixnum+fast ]
+        [ dup float+ ]
+        [ float>fixnum dup fixnum+fast ]
+        [ dup float+ ]
+        [ float>fixnum dup fixnum+fast ]
+        [ dup float+ ]
+        [ float>fixnum dup fixnum+fast ]
+        [ dup float+ ]
+        [ float>fixnum dup fixnum+fast ]
+        [ dup float+ ]
+        [ float>fixnum dup fixnum+fast ]
+        [ dup float+ ]
+        [ float>fixnum dup fixnum+fast ]
+        [ dup float+ ]
+        [ float>fixnum dup fixnum+fast ]
+        [ dup float+ ]
+        [ float>fixnum dup fixnum+fast ]
+        [ dup float+ ]
+        [ float>fixnum dup fixnum+fast ]
+        [ dup float+ ]
+        [ float>fixnum dup fixnum+fast ]
+        [ dup float+ ]
+        [ float>fixnum dup fixnum+fast ]
+        [ dup float+ ]
+        [ float>fixnum dup fixnum+fast ]
+        [ dup float+ ]
+        [ float>fixnum dup fixnum+fast ]
+        [ dup float+ ]
+        [ float>fixnum dup fixnum+fast ]
+        [ dup float+ ]
+        [ float>fixnum dup fixnum+fast ]
+        [ dup float+ ]
+        [ float>fixnum dup fixnum+fast ]
+        [ dup float+ ]
+        [ float>fixnum dup fixnum+fast ]
+        [ dup float+ ]
+        [ float>fixnum dup fixnum+fast ]
+        [ dup float+ ]
+        [ float>fixnum dup fixnum+fast ]
+        [ dup float+ ]
+        [ float>fixnum dup fixnum+fast ]
+        [ dup float+ ]
+        [ float>fixnum dup fixnum+fast ]
+        [ dup float+ ]
+        [ float>fixnum dup fixnum+fast ]
+    } cleave ;
+
+[ 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 compiled>> ] unit-test
+
+: resolve-spill-bug ( a b -- c )
+    [ 1 fixnum+fast ] bi@ dup 10 fixnum< [
+        nip 2 fixnum+fast
+    ] [
+        drop {
+            [ dup fixnum+fast ]
+            [ dup fixnum+fast ]
+            [ dup fixnum+fast ]
+            [ dup fixnum+fast ]
+            [ dup fixnum+fast ]
+            [ dup fixnum+fast ]
+            [ dup fixnum+fast ]
+            [ dup fixnum+fast ]
+            [ dup fixnum+fast ]
+            [ dup fixnum+fast ]
+            [ dup fixnum+fast ]
+            [ dup fixnum+fast ]
+            [ dup fixnum+fast ]
+            [ dup fixnum+fast ]
+            [ dup fixnum+fast ]
+            [ dup fixnum+fast ]
+        } cleave
+        16 narray
+    ] if ;
+
+[ t ] [ \ resolve-spill-bug compiled>> ] unit-test
+
+[ 4 ] [ 1 1 resolve-spill-bug ] unit-test
+
+! The above don't really test spilling...
+: spill-test-1 ( a -- b )
+    dup 1 fixnum+fast
+    dup 1 fixnum+fast
+    dup 1 fixnum+fast
+    dup 1 fixnum+fast
+    dup 1 fixnum+fast
+    dup 1 fixnum+fast
+    dup 1 fixnum+fast
+    dup 1 fixnum+fast
+    dup 1 fixnum+fast
+    dup 1 fixnum+fast
+    dup 1 fixnum+fast
+    dup 1 fixnum+fast
+    dup 1 fixnum+fast
+    dup 1 fixnum+fast
+    dup 1 fixnum+fast
+    dup 1 fixnum+fast
+    dup 1 fixnum+fast
+    dup 1 fixnum+fast
+    dup 1 fixnum+fast
+    dup 1 fixnum+fast
+    dup 1 fixnum+fast
+    dup 1 fixnum+fast
+    dup 1 fixnum+fast
+    dup 1 fixnum+fast
+    dup 1 fixnum+fast
+    dup 1 fixnum+fast
+    dup 1 fixnum+fast
+    dup 1 fixnum+fast
+    dup 1 fixnum+fast fixnum>float
+    3array
+    3array [ 8 narray ] dip 2array
+    [ 8 narray [ 8 narray ] dip 2array ] dip 2array
+    2array ;
+
+[
+    {
+        1
+        {
+            { { 2 3 4 5 6 7 8 9 } { 10 11 12 13 14 15 16 17 } }
+            {
+                { 18 19 20 21 22 23 24 25 }
+                { 26 27 { 28 29 30.0 } }
+            }
+        }
+    }
+] [ 1 spill-test-1 ] unit-test
+
+: spill-test-2 ( a -- b )
+    dup 1.0 float+
+    dup 1.0 float+
+    dup 1.0 float+
+    dup 1.0 float+
+    dup 1.0 float+
+    dup 1.0 float+
+    dup 1.0 float+
+    dup 1.0 float+
+    dup 1.0 float+
+    dup 1.0 float+
+    dup 1.0 float+
+    dup 1.0 float+
+    dup 1.0 float+
+    dup 1.0 float+
+    dup 1.0 float+
+    dup 1.0 float+
+    dup 1.0 float+
+    dup 1.0 float+
+    dup 1.0 float+
+    dup 1.0 float+
+    dup 1.0 float+
+    dup 1.0 float+
+    dup 1.0 float+
+    dup 1.0 float+
+    dup 1.0 float+
+    dup 1.0 float+
+    dup 1.0 float+
+    dup 1.0 float+
+    dup 1.0 float+
+    dup 1.0 float+
+    dup 1.0 float+
+    dup 1.0 float+
+    dup 1.0 float+
+    dup 1.0 float+
+    dup 1.0 float+
+    dup 1.0 float+
+    dup 1.0 float+
+    dup 1.0 float+
+    dup 1.0 float+
+    dup 1.0 float+
+    dup 1.0 float+
+    dup 1.0 float+
+    dup 1.0 float+
+    dup 1.0 float+
+    dup 1.0 float+
+    dup 1.0 float+
+    dup 1.0 float+
+    dup 1.0 float+
+    dup 1.0 float+
+    dup 1.0 float+
+    dup 1.0 float+
+    dup 1.0 float+
+    dup 1.0 float+
+    dup 1.0 float+
+    dup 1.0 float+
+    dup 1.0 float+
+    dup 1.0 float+
+    dup 1.0 float+
+    dup 1.0 float+
+    dup 1.0 float+
+    dup 1.0 float+
+    dup 1.0 float+
+    dup 1.0 float+
+    float*
+    float*
+    float*
+    float*
+    float*
+    float*
+    float*
+    float*
+    float*
+    float*
+    float*
+    float*
+    float*
+    float*
+    float*
+    float*
+    float*
+    float*
+    float*
+    float*
+    float*
+    float*
+    float*
+    float*
+    float*
+    float*
+    float*
+    float*
+    float*
+    float*
+    float*
+    float*
+    float*
+    float*
+    float*
+    float*
+    float*
+    float*
+    float*
+    float*
+    float*
+    float*
+    float*
+    float*
+    float*
+    float*
+    float*
+    float*
+    float*
+    float*
+    float*
+    float*
+    float*
+    float*
+    float*
+    float*
+    float*
+    float*
+    float*
+    float*
+    float*
+    float*
+    float* ;
+
+[ t ] [ 1.0 spill-test-2 1.0 \ spill-test-2 def>> call = ] unit-test

basis/compiler/tests/templates.factor

@@ -3,7 +3,7 @@ kernel.private math hashtables.private math.private namespaces
 sequences sequences.private tools.test namespaces.private
 slots.private sequences.private byte-arrays alien
 alien.accessors layouts words definitions compiler.units io
-combinators vectors ;
+combinators vectors float-arrays ;
 IN: compiler.tests
 
 ! Originally, this file did black box testing of templating
@@ -206,167 +206,6 @@ TUPLE: my-tuple ;
     ] compile-call
 ] unit-test
 
-: 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 )
-    {
-        [ dup float+ ]
-        [ dup float+ ]
-        [ dup float+ ]
-        [ dup float+ ]
-        [ dup float+ ]
-        [ dup float+ ]
-        [ dup float+ ]
-        [ dup float+ ]
-        [ dup float+ ]
-        [ dup float+ ]
-        [ dup float+ ]
-        [ dup float+ ]
-        [ dup float+ ]
-        [ dup float+ ]
-        [ dup float+ ]
-        [ dup float+ ]
-        [ dup float+ ]
-        [ dup float+ ]
-        [ dup float+ ]
-        [ dup float+ ]
-        [ dup float+ ]
-        [ dup float+ ]
-        [ dup float+ ]
-        [ dup float+ ]
-        [ dup float+ ]
-        [ dup float+ ]
-        [ dup float+ ]
-        [ dup float+ ]
-        [ dup float+ ]
-        [ dup float+ ]
-        [ dup float+ ]
-        [ dup float+ ]
-        [ dup float+ ]
-        [ dup float+ ]
-        [ dup float+ ]
-        [ dup float+ ]
-        [ dup float+ ]
-        [ dup float+ ]
-    } cleave ;
-
-[ 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 compiled>> ] 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 )
-    {
-        [ dup float+ ]
-        [ float>fixnum dup fixnum+fast ]
-        [ dup float+ ]
-        [ float>fixnum dup fixnum+fast ]
-        [ dup float+ ]
-        [ float>fixnum dup fixnum+fast ]
-        [ dup float+ ]
-        [ float>fixnum dup fixnum+fast ]
-        [ dup float+ ]
-        [ float>fixnum dup fixnum+fast ]
-        [ dup float+ ]
-        [ float>fixnum dup fixnum+fast ]
-        [ dup float+ ]
-        [ float>fixnum dup fixnum+fast ]
-        [ dup float+ ]
-        [ float>fixnum dup fixnum+fast ]
-        [ dup float+ ]
-        [ float>fixnum dup fixnum+fast ]
-        [ dup float+ ]
-        [ float>fixnum dup fixnum+fast ]
-        [ dup float+ ]
-        [ float>fixnum dup fixnum+fast ]
-        [ dup float+ ]
-        [ float>fixnum dup fixnum+fast ]
-        [ dup float+ ]
-        [ float>fixnum dup fixnum+fast ]
-        [ dup float+ ]
-        [ float>fixnum dup fixnum+fast ]
-        [ dup float+ ]
-        [ float>fixnum dup fixnum+fast ]
-        [ dup float+ ]
-        [ float>fixnum dup fixnum+fast ]
-        [ dup float+ ]
-        [ float>fixnum dup fixnum+fast ]
-        [ dup float+ ]
-        [ float>fixnum dup fixnum+fast ]
-        [ dup float+ ]
-        [ float>fixnum dup fixnum+fast ]
-        [ dup float+ ]
-        [ float>fixnum dup fixnum+fast ]
-        [ dup float+ ]
-        [ float>fixnum dup fixnum+fast ]
-        [ dup float+ ]
-        [ float>fixnum dup fixnum+fast ]
-        [ dup float+ ]
-        [ float>fixnum dup fixnum+fast ]
-        [ dup float+ ]
-        [ float>fixnum dup fixnum+fast ]
-        [ dup float+ ]
-        [ float>fixnum dup fixnum+fast ]
-        [ dup float+ ]
-        [ float>fixnum dup fixnum+fast ]
-        [ dup float+ ]
-        [ float>fixnum dup fixnum+fast ]
-        [ dup float+ ]
-        [ float>fixnum dup fixnum+fast ]
-        [ dup float+ ]
-        [ float>fixnum dup fixnum+fast ]
-        [ dup float+ ]
-        [ float>fixnum dup fixnum+fast ]
-        [ dup float+ ]
-        [ float>fixnum dup fixnum+fast ]
-        [ dup float+ ]
-        [ float>fixnum dup fixnum+fast ]
-        [ dup float+ ]
-        [ float>fixnum dup fixnum+fast ]
-        [ dup float+ ]
-        [ float>fixnum dup fixnum+fast ]
-        [ dup float+ ]
-        [ float>fixnum dup fixnum+fast ]
-        [ dup float+ ]
-        [ float>fixnum dup fixnum+fast ]
-        [ dup float+ ]
-        [ float>fixnum dup fixnum+fast ]
-        [ dup float+ ]
-        [ float>fixnum dup fixnum+fast ]
-    } cleave ;
-
-[ 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 compiled>> ] unit-test
-
-: resolve-spill-bug ( a b -- c )
-    [ 1 fixnum+fast ] bi@ dup 10 fixnum< [
-        nip 2 fixnum+fast
-    ] [
-        drop {
-            [ dup fixnum+fast ]
-            [ dup fixnum+fast ]
-            [ dup fixnum+fast ]
-            [ dup fixnum+fast ]
-            [ dup fixnum+fast ]
-            [ dup fixnum+fast ]
-            [ dup fixnum+fast ]
-            [ dup fixnum+fast ]
-            [ dup fixnum+fast ]
-            [ dup fixnum+fast ]
-            [ dup fixnum+fast ]
-            [ dup fixnum+fast ]
-            [ dup fixnum+fast ]
-            [ dup fixnum+fast ]
-            [ dup fixnum+fast ]
-            [ dup fixnum+fast ]
-        } cleave
-        16 narray
-    ] if ;
-
-[ t ] [ \ resolve-spill-bug compiled>> ] unit-test
-
-[ 4 ] [ 1 1 resolve-spill-bug ] unit-test
-
 ! Regression
 : dispatch-alignment-regression ( -- c )
     { tuple vector } 3 slot { word } declare

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

@@ -307,5 +307,5 @@ SYMBOL: value-infos
 : immutable-tuple-boa? ( #call -- ? )
     dup word>> \ <tuple-boa> eq? [
         dup in-d>> peek node-value-info
-        literal>> class>> immutable-tuple-class?
+        literal>> first immutable-tuple-class?
     ] [ drop f ] if ;

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

@@ -131,7 +131,7 @@ DEFER: (flat-length)
     ] bi* + + + + + ;
 
 : should-inline? ( #call word -- ? )
-    inlining-rank 5 >= ;
+    dup "inline" word-prop [ 2drop t ] [ inlining-rank 5 >= ] if ;
 
 SYMBOL: history
 

basis/compiler/tree/propagation/known-words/known-words.factor

@@ -281,7 +281,7 @@ generic-comparison-ops [
 
 { <tuple> <tuple-boa> } [
     [
-        literal>> dup tuple-layout? [ class>> ] [ drop tuple ] if <class-info>
+        literal>> dup array? [ first ] [ drop tuple ] if <class-info>
         [ clear ] dip
     ] "outputs" set-word-prop
 ] each

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

@@ -379,7 +379,7 @@ TUPLE: mutable-tuple-test { x sequence } ;
     [ T{ mutable-tuple-test f "hey" } x>> ] final-classes
 ] unit-test
 
-[ V{ tuple-layout } ] [
+[ V{ array } ] [
     [ T{ mutable-tuple-test f "hey" } layout-of ] final-classes
 ] unit-test
 

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

@@ -45,7 +45,7 @@ UNION: fixed-length-sequence array byte-array string ;
 
 : propagate-<tuple-boa> ( #call -- info )
     in-d>> unclip-last
-    value-info literal>> class>> (propagate-tuple-constructor) ;
+    value-info literal>> first (propagate-tuple-constructor) ;
 
 : propagate-<complex> ( #call -- info )
     in-d>> [ value-info ] map complex <tuple-info> ;

basis/concurrency/mailboxes/mailboxes.factor

@@ -2,7 +2,7 @@
 ! See http://factorcode.org/license.txt for BSD license.
 IN: concurrency.mailboxes
 USING: dlists deques threads sequences continuations
-destructors namespaces random math quotations words kernel
+destructors namespaces math quotations words kernel
 arrays assocs init system concurrency.conditions accessors
 debugger debugger.threads locals ;
 

basis/concurrency/messaging/messaging.factor

@@ -4,7 +4,7 @@
 ! Concurrency library for Factor, based on Erlang/Termite style
 ! concurrency.
 USING: kernel threads concurrency.mailboxes continuations
-namespaces assocs random accessors summary ;
+namespaces assocs accessors summary ;
 IN: concurrency.messaging
 
 GENERIC: send ( message thread -- )
@@ -40,7 +40,7 @@ M: thread send ( message thread -- )
 TUPLE: synchronous data sender tag ;
 
 : <synchronous> ( data -- sync )
-    self 256 random-bits synchronous boa ;
+    self synchronous counter synchronous boa ;
 
 TUPLE: reply data tag ;
 

basis/cpu/architecture/architecture.factor

@@ -58,6 +58,8 @@ HOOK: %slot-imm cpu ( dst obj slot tag -- )
 HOOK: %set-slot cpu ( src obj slot tag temp -- )
 HOOK: %set-slot-imm cpu ( src obj slot tag -- )
 
+HOOK: %string-nth cpu ( dst obj index temp -- )
+
 HOOK: %add     cpu ( dst src1 src2 -- )
 HOOK: %add-imm cpu ( dst src1 src2 -- )
 HOOK: %sub     cpu ( dst src1 src2 -- )

basis/cpu/ppc/bootstrap.factor

@@ -11,8 +11,8 @@ big-endian on
 
 4 jit-code-format set
 
-: ds-reg 30 ;
+: ds-reg 29 ;
-: rs-reg 31 ;
+: rs-reg 30 ;
 
 : factor-area-size ( -- n ) 4 bootstrap-cells ;
 

basis/cpu/ppc/ppc.factor

@@ -1,28 +1,18 @@
 ! Copyright (C) 2005, 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: alien.c-types
+USING: accessors assocs sequences kernel combinators make math
-accessors
+math.order math.ranges system namespaces locals layouts words
-cpu.architecture
+alien alien.c-types cpu.architecture cpu.ppc.assembler
-compiler.cfg.registers
+compiler.cfg.registers compiler.cfg.instructions
-cpu.ppc.assembler
+compiler.constants compiler.codegen compiler.codegen.fixup
-kernel
+compiler.cfg.intrinsics compiler.cfg.stack-frame ;
-locals
-layouts
-combinators
-make
-compiler.cfg.instructions
-math.order
-system
-math
-compiler.constants
-namespaces compiler.codegen.fixup ;
 IN: cpu.ppc
 
 ! PowerPC register assignments:
-! r2-r28: integer vregs
+! r2-r27: integer vregs
-! r29: integer scratch
+! r28: integer scratch
-! r30: data stack
+! r29: data stack
-! r31: retain stack
+! r30: retain stack
 ! f0-f29: float vregs
 ! f30, f31: float scratch
 
@@ -36,17 +26,21 @@ IN: cpu.ppc
         t "longlong" c-type (>>stack-align?)
         t "ulonglong" c-type (>>stack-align?)
     ] }
-} cond >>
+} cond
+
+enable-float-intrinsics
+
+\ ##integer>float t frame-required? set-word-prop
+\ ##float>integer t frame-required? set-word-prop >>
 
 M: ppc machine-registers
     {
-        { int-regs T{ range f 2 27 1 } }
+        { int-regs T{ range f 2 26 1 } }
-        { double-float-regs T{ range f 0 28 1 } }
+        { double-float-regs T{ range f 0 29 1 } }
     } ;
 
-: scratch-reg 29 ; inline
+: scratch-reg 28 ; inline
-: fp-scratch-reg-1 30 ; inline
+: fp-scratch-reg 30 ; inline
-: fp-scratch-reg-2 31 ; inline
 
 M: ppc two-operand? f ;
 
@@ -57,13 +51,13 @@ M:: ppc %load-indirect ( reg obj -- )
     obj rc-absolute-ppc-2/2 rel-literal
     reg reg 0 LWZ ;
 
-: ds-reg 30 ; inline
+: ds-reg 29 ; inline
-: rs-reg 31 ; inline
+: rs-reg 30 ; inline
 
 GENERIC: loc-reg ( loc -- reg )
 
-M: ds-loc log-reg drop ds-reg ;
+M: ds-loc loc-reg drop ds-reg ;
-M: rs-loc log-reg drop rs-reg ;
+M: rs-loc loc-reg drop rs-reg ;
 
 : loc>operand ( loc -- reg n )
     [ loc-reg ] [ n>> cells neg ] bi ; inline
@@ -82,12 +76,15 @@ M: ppc %inc-r ( n -- ) rs-reg (%inc) ;
         { macosx [ 6 ] }
     } case cells ; foldable
 
-: lr-save ( -- n )
+! The start of the stack frame contains the size of this frame
-    os {
+! as well as the currently executing XT
-        { linux [ 1 ] }
+: factor-area-size ( -- n ) 2 cells ; foldable
-        { macosx [ 2 ] }
+: next-save ( n -- i ) cell - ;
-    } case cells ; foldable
+: xt-save ( n -- i ) 2 cells - ;
 
+! Next, we have the spill area as well as the FFI parameter area.
+! They overlap, since basic blocks with FFI calls will never
+! spill.
 : param@ ( n -- x ) reserved-area-size + ; inline
 
 : param-save-size ( -- n ) 8 cells ; foldable
@@ -95,19 +92,38 @@ M: ppc %inc-r ( n -- ) rs-reg (%inc) ;
 : local@ ( n -- x )
     reserved-area-size param-save-size + + ; inline
 
-: factor-area-size ( -- n ) 2 cells ; foldable
+: spill-integer-base ( -- n )
+    stack-frame get spill-counts>> double-float-regs swap at
+    double-float-regs reg-size * ;
 
-: next-save ( n -- i ) cell - ;
+: spill-integer@ ( n -- offset )
+    cells spill-integer-base + param@ ;
 
-: xt-save ( n -- i ) 2 cells - ;
+: spill-float@ ( n -- offset )
+    double-float-regs reg-size * param@ ;
+
+! Some FP intrinsics need a temporary scratch area in the stack
+! frame, 8 bytes in size
+: scratch@ ( n -- offset )
+   stack-frame get total-size>>
+   factor-area-size -
+   param-save-size -
+   + ;
+
+! Finally we have the linkage area
+: lr-save ( -- n )
+    os {
+        { linux [ 1 ] }
+        { macosx [ 2 ] }
+    } case cells ; foldable
 
 M: ppc stack-frame-size ( stack-frame -- i )
     [ spill-counts>> [ swap reg-size * ] { } assoc>map sum ]
     [ params>> ]
     [ return>> ]
     tri + +
-    reserved-area-size +
     param-save-size +
+    reserved-area-size +
     factor-area-size +
     4 cells align ;
 
@@ -137,9 +153,25 @@ M: ppc %slot-imm ( dst obj slot tag -- ) (%slot-imm) LWZ ;
 M: ppc %set-slot ( src obj slot tag temp -- ) (%slot) STW ;
 M: ppc %set-slot-imm ( src obj slot tag -- ) (%slot-imm) STW ;
 
+M:: ppc %string-nth ( dst src index temp -- )
+    [
+        "end" define-label
+        temp src index ADD
+        dst temp string-offset LBZ
+        temp src string-aux-offset LWZ
+        0 temp \ f tag-number CMPI
+        "end" get BEQ
+        temp temp index ADD
+        temp temp index ADD
+        temp temp byte-array-offset LHZ
+        temp temp 8 SLWI
+        dst dst temp OR
+        "end" resolve-label
+    ] with-scope ;
+
 M: ppc %add     ADD ;
 M: ppc %add-imm ADDI ;
-M: ppc %sub     swapd SUBF ;
+M: ppc %sub     swap SUBF ;
 M: ppc %sub-imm SUBI ;
 M: ppc %mul     MULLW ;
 M: ppc %mul-imm MULLI ;
@@ -156,44 +188,42 @@ M: ppc %not     NOT ;
 
 : bignum@ ( n -- offset ) cells bignum tag-number - ; inline
 
-M: ppc %integer>bignum ( dst src temp -- )
+M:: ppc %integer>bignum ( dst src temp -- )
     [
-        { "end" "non-zero" "pos" "store" } [ define-label ] each
+        "end" define-label
-        dst 0 >bignum %load-immediate
+        dst 0 >bignum %load-indirect
         ! Is it zero? Then just go to the end and return this zero
         0 src 0 CMPI
         "end" get BEQ
         ! Allocate a bignum
         dst 4 cells bignum temp %allot
         ! Write length
-        2 temp LI
+        2 tag-fixnum temp LI
-        dst 1 bignum@ temp STW
+        temp dst 1 bignum@ STW
-        ! Store value
-        dst 3 bignum@ src STW
         ! Compute sign
         temp src MR
-        temp cell-bits 1- SRAWI
+        temp temp cell-bits 1- SRAWI
         temp temp 1 ANDI
         ! Store sign
-        dst 2 bignum@ temp STW
+        temp dst 2 bignum@ STW
         ! Make negative value positive
         temp temp temp ADD
         temp temp NEG
         temp temp 1 ADDI
         temp src temp MULLW
         ! Store the bignum
-        dst 3 bignum@ temp STW
+        temp dst 3 bignum@ STW
         "end" resolve-label
     ] with-scope ;
 
-M:: %bignum>integer ( dst src temp -- )
+M:: ppc %bignum>integer ( dst src temp -- )
     [
         "end" define-label
         temp src 1 bignum@ LWZ
         ! if the length is 1, its just the sign and nothing else,
         ! so output 0
         0 dst LI
-        0 temp 1 v>operand CMPI
+        0 temp 1 tag-fixnum CMPI
         "end" get BEQ
         ! load the value
         dst src 3 bignum@ LWZ
@@ -203,6 +233,7 @@ M:: %bignum>integer ( dst src temp -- )
         ! and 1 into -1
         temp temp temp ADD
         temp temp 1 SUBI
+        temp temp NEG
         ! multiply value by sign
         dst dst temp MULLW
         "end" resolve-label
@@ -213,28 +244,32 @@ M: ppc %sub-float FSUB ;
 M: ppc %mul-float FMUL ;
 M: ppc %div-float FDIV ;
 
-M: ppc %integer>float ( dst src -- )
+M:: ppc %integer>float ( dst src -- )
     HEX: 4330 scratch-reg LIS
-    scratch-reg 1 0 param@ STW
+    scratch-reg 1 0 scratch@ STW
     scratch-reg src MR
     scratch-reg dup HEX: 8000 XORIS
-    scratch-reg 1 cell param@ STW
+    scratch-reg 1 4 scratch@ STW
-    fp-scratch-reg-2 1 0 param@ LFD
+    dst 1 0 scratch@ LFD
-    4503601774854144.0 scratch-reg load-indirect
+    scratch-reg 4503601774854144.0 %load-indirect
-    fp-scratch-reg-2 scratch-reg float-offset LFD
+    fp-scratch-reg scratch-reg float-offset LFD
-    fp-scratch-reg-2 fp-scratch-reg-2 fp-scratch-reg-2 FSUB ;
+    dst dst fp-scratch-reg FSUB ;
 
 M:: ppc %float>integer ( dst src -- )
-    fp-scratch-reg-1 src FCTIWZ
+    fp-scratch-reg src FCTIWZ
-    fp-scratch-reg-2 1 0 param@ STFD
+    fp-scratch-reg 1 0 scratch@ STFD
-    dst 1 4 param@ LWZ ;
+    dst 1 4 scratch@ LWZ ;
 
 M: ppc %copy ( dst src -- ) MR ;
 
-M: ppc %copy-float ( dst src -- ) MFR ;
+M: ppc %copy-float ( dst src -- ) FMR ;
 
 M: ppc %unbox-float ( dst src -- ) float-offset LFD ;
 
+M:: ppc %box-float ( dst src temp -- )
+    dst 16 float temp %allot
+    src dst float-offset STFD ;
+
 M:: ppc %unbox-any-c-ptr ( dst src temp -- )
     [
         { "is-byte-array" "end" "start" } [ define-label ] each
@@ -277,9 +312,9 @@ M:: ppc %box-alien ( dst src temp -- )
         "f" get BEQ
         dst 4 cells alien temp %allot
         ! Store offset
-        dst src 3 alien@ STW
+        src dst 3 alien@ STW
-        temp \ f tag-number %load-immediate
         ! Store expired slot
+        temp \ f tag-number %load-immediate
         temp dst 1 alien@ STW
         ! Store underlying-alien slot
         temp dst 2 alien@ STW
@@ -289,7 +324,7 @@ M:: ppc %box-alien ( dst src temp -- )
 M: ppc %alien-unsigned-1 0 LBZ ;
 M: ppc %alien-unsigned-2 0 LHZ ;
 
-M: ppc %alien-signed-1 dupd 0 LBZ EXTSB ;
+M: ppc %alien-signed-1 dupd 0 LBZ dup EXTSB ;
 M: ppc %alien-signed-2 0 LHA ;
 
 M: ppc %alien-cell 0 LWZ ;
@@ -297,45 +332,47 @@ M: ppc %alien-cell 0 LWZ ;
 M: ppc %alien-float 0 LFS ;
 M: ppc %alien-double 0 LFD ;
 
-M: ppc %set-alien-integer-1 0 STB ;
+M: ppc %set-alien-integer-1 swap 0 STB ;
-M: ppc %set-alien-integer-2 0 STH ;
+M: ppc %set-alien-integer-2 swap 0 STH ;
 
-M: ppc %set-alien-cell 0 STW ;
+M: ppc %set-alien-cell swap 0 STW ;
 
-M: ppc %set-alien-float 0 STFS ;
+M: ppc %set-alien-float swap 0 STFS ;
-M: ppc %set-alien-double 0 STFD ;
+M: ppc %set-alien-double swap 0 STFD ;
+
+: %load-dlsym ( symbol dll register -- )
+    0 swap LOAD32 rc-absolute-ppc-2/2 rel-dlsym ;
 
 : load-zone-ptr ( reg -- )
     [ "nursery" f ] dip %load-dlsym ;
 
 : load-allot-ptr ( nursery-ptr allot-ptr -- )
-    [ drop load-zone-ptr ] [ swap cell LWZ ] 2bi ;
+    [ drop load-zone-ptr ] [ swap 4 LWZ ] 2bi ;
 
-:: inc-allot-ptr ( nursery-ptr n -- )
+:: inc-allot-ptr ( nursery-ptr allot-ptr n -- )
-    scratch-reg inc-allot-ptr 4 LWZ
+    scratch-reg allot-ptr n 8 align ADDI
-    scratch-reg scratch-reg n 8 align ADD
+    scratch-reg nursery-ptr 4 STW ;
-    scratch-reg inc-allot-ptr 4 STW ;
 
-:: store-header ( temp class -- )
+:: store-header ( dst class -- )
     class type-number tag-fixnum scratch-reg LI
-    temp scratch-reg 0 STW ;
+    scratch-reg dst 0 STW ;
 
 : store-tagged ( dst tag -- )
     dupd tag-number ORI ;
 
 M:: ppc %allot ( dst size class nursery-ptr -- )
     nursery-ptr dst load-allot-ptr
+    nursery-ptr dst size inc-allot-ptr
     dst class store-header
-    dst class store-tagged
+    dst class store-tagged ;
-    nursery-ptr size inc-allot-ptr ;
 
-: %alien-global ( dest name -- )
+: %alien-global ( dst name -- )
-    [ f swap %load-dlsym ] [ drop dup 0 LWZ ] 2bi ;
+    [ f rot %load-dlsym ] [ drop dup 0 LWZ ] 2bi ;
 
-: load-cards-offset ( dest -- )
+: load-cards-offset ( dst -- )
     "cards_offset" %alien-global ;
 
-: load-decks-offset ( dest -- )
+: load-decks-offset ( dst -- )
     "decks_offset" %alien-global ;
 
 M:: ppc %write-barrier ( src card# table -- )
@@ -359,18 +396,17 @@ M: ppc %gc
     11 11 1024 ADDI ! add ALLOT_BUFFER_ZONE to here
     11 0 12 CMP ! is here >= end?
     "end" get BLE
-    0 frame-required
     %prepare-alien-invoke
     "minor_gc" f %alien-invoke
     "end" resolve-label ;
 
 M: ppc %prologue ( n -- )
-    0 scrach-reg LOAD32 rc-absolute-ppc-2/2 rel-this
+    0 11 LOAD32 rc-absolute-ppc-2/2 rel-this
     0 MFLR
     1 1 pick neg ADDI
-    scrach-reg 1 pick xt-save STW
+    11 1 pick xt-save STW
-    dup scrach-reg LI
+    dup 11 LI
-    scrach-reg 1 pick next-save STW
+    11 1 pick next-save STW
     0 1 rot lr-save + STW ;
 
 M: ppc %epilogue ( n -- )
@@ -384,19 +420,19 @@ M: ppc %epilogue ( n -- )
 
 :: (%boolean) ( dst word -- )
     "end" define-label
-    \ f tag-number %load-immediate
+    dst \ f tag-number %load-immediate
     "end" get word execute
     dst \ t %load-indirect
     "end" get resolve-label ; inline
 
 : %boolean ( dst cc -- )
     negate-cc {
-        { cc< [ \ BLT %boolean ] }
+        { cc< [ \ BLT (%boolean) ] }
-        { cc<= [ \ BLE %boolean ] }
+        { cc<= [ \ BLE (%boolean) ] }
-        { cc> [ \ BGT %boolean ] }
+        { cc> [ \ BGT (%boolean) ] }
-        { cc>= [ \ BGE %boolean ] }
+        { cc>= [ \ BGE (%boolean) ] }
-        { cc= [ \ BEQ %boolean ] }
+        { cc= [ \ BEQ (%boolean) ] }
-        { cc/= [ \ BNE %boolean ] }
+        { cc/= [ \ BNE (%boolean) ] }
     } case ;
 
 : (%compare) ( src1 src2 -- ) [ 0 ] dip CMP ; inline
@@ -421,32 +457,11 @@ M: ppc %compare-branch (%compare) %branch ;
 M: ppc %compare-imm-branch (%compare-imm) %branch ;
 M: ppc %compare-float-branch (%compare-float) %branch ;
 
-: spill-integer-base ( stack-frame -- n )
+M: ppc %spill-integer ( src n -- ) spill-integer@ 1 swap STW ;
-    [ params>> ] [ return>> ] bi + ;
+M: ppc %reload-integer ( dst n -- ) spill-integer@ 1 swap LWZ ;
 
-: stack@ 1 swap ; inline
+M: ppc %spill-float ( src n -- ) spill-float@ 1 swap STFD ;
-
+M: ppc %reload-float ( dst n -- ) spill-float@ 1 swap LFD ;
-: spill-integer@ ( n -- op )
-    cells
-    stack-frame get spill-integer-base
-    + stack@ ;
-
-: spill-float-base ( stack-frame -- n )
-    [ spill-counts>> int-regs swap at int-regs reg-size * ]
-    [ params>> ]
-    [ return>> ]
-    tri + + ;
-
-: spill-float@ ( n -- op )
-    double-float-regs reg-size *
-    stack-frame get spill-float-base
-    + stack@ ;
-
-M: ppc %spill-integer ( src n -- ) spill-integer@ STW ;
-M: ppc %reload-integer ( dst n -- ) spill-integer@ LWZ ;
-
-M: ppc %spill-float ( src n -- ) spill-float@ STFD ;
-M: ppc %reload-float ( dst n -- ) spill-float@ LFD ;
 
 M: ppc %loop-entry ;
 
@@ -560,7 +575,7 @@ M: ppc %alien-invoke ( symbol dll -- )
     11 %load-dlsym 11 MTLR BLRL ;
 
 M: ppc %alien-callback ( quot -- )
-    3 load-indirect "c_to_factor" f %alien-invoke ;
+    3 swap %load-indirect "c_to_factor" f %alien-invoke ;
 
 M: ppc %prepare-alien-indirect ( -- )
     "unbox_alien" f %alien-invoke

basis/cpu/x86/tags.txt

@@ -0,0 +1,2 @@
+unportable
+compiler

basis/cpu/x86/x86.factor

@@ -1,6 +1,6 @@
 ! Copyright (C) 2005, 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: accessors assocs alien alien.c-types arrays
+USING: accessors assocs alien alien.c-types arrays strings
 cpu.x86.assembler cpu.x86.assembler.private cpu.architecture
 kernel kernel.private math memory namespaces make sequences
 words system layouts combinators math.order fry locals
@@ -278,27 +278,47 @@ M:: x86 %box-alien ( dst src temp -- )
 : small-regs ( -- regs ) { EAX ECX EDX EBX } ; inline
 
 : small-reg-that-isn't ( exclude -- reg' )
-    small-reg-4 small-regs [ eq? not ] with find nip ;
+    small-regs swap [ small-reg-4 ] map '[ _ memq? not ] find nip ;
 
 : with-save/restore ( reg quot -- )
     [ drop PUSH ] [ call ] [ drop POP ] 2tri ; inline
 
-:: with-small-register ( dst src quot: ( dst src -- ) -- )
+:: with-small-register ( dst exclude quot: ( new-dst -- ) -- )
     #! If the destination register overlaps a small register, we
     #! call the quot with that. Otherwise, we find a small
-    #! register that is not equal to src, and call quot, saving
+    #! register that is not in exclude, and call quot, saving
     #! and restoring the small register.
-    dst small-reg-4 small-regs memq? [ dst src quot call ] [
+    dst small-reg-4 small-regs memq? [ dst quot call ] [
-        src small-reg-that-isn't
+        exclude small-reg-that-isn't
-        [| new-dst |
+        [ quot call ] with-save/restore
-            new-dst src quot call
-            dst new-dst MOV
-        ] with-save/restore
     ] if ; inline
 
-: %alien-integer-getter ( dst src size quot -- )
+M:: x86 %string-nth ( dst src index temp -- )
-    '[ [ dup _ small-reg dup ] [ [] ] bi* MOV @ ]
+    "end" define-label
-    with-small-register ; inline
+    dst { src index temp } [| new-dst |
+        temp src index [+] LEA
+        new-dst 1 small-reg temp string-offset [+] MOV
+        new-dst new-dst 1 small-reg MOVZX
+        temp src string-aux-offset [+] MOV
+        temp \ f tag-number CMP
+        "end" get JE
+        new-dst temp XCHG
+        new-dst index ADD
+        new-dst index ADD
+        new-dst 2 small-reg new-dst byte-array-offset [+] MOV
+        new-dst new-dst 2 small-reg MOVZX
+        new-dst 8 SHL
+        new-dst temp OR
+        "end" resolve-label
+        dst new-dst ?MOV
+    ] with-small-register ;
+
+:: %alien-integer-getter ( dst src size quot -- )
+    dst { src } [| new-dst |
+        new-dst dup size small-reg dup src [] MOV
+        quot call
+        dst new-dst ?MOV
+    ] with-small-register ; inline
 
 : %alien-unsigned-getter ( dst src size -- )
     [ MOVZX ] %alien-integer-getter ; inline
@@ -320,7 +340,7 @@ M: x86 %alien-float dupd [] MOVSS dup CVTSS2SD ;
 M: x86 %alien-double [] MOVSD ;
 
 :: %alien-integer-setter ( ptr value size -- )
-    value ptr [| new-value ptr |
+    value { ptr } [| new-value |
         new-value value ?MOV
         ptr [] new-value size small-reg MOV
     ] with-small-register ; inline

basis/help/handbook/handbook.factor

@@ -86,14 +86,11 @@ ARTICLE: "objects" "Objects"
 { $subsection "slots" }
 { $subsection "mirrors" } ;
 
-USE: random
-
 ARTICLE: "numbers" "Numbers"
 { $subsection "arithmetic" }
 { $subsection "math-constants" }
 { $subsection "math-functions" }
 { $subsection "number-strings" }
-{ $subsection "random" }
 "Number implementations:"
 { $subsection "integers" }
 { $subsection "rationals" }

basis/hints/hints.factor

@@ -64,10 +64,12 @@ IN: hints
 { first first2 first3 first4 }
 [ { array } "specializer" set-word-prop ] each
 
-{ peek pop* pop push } [
+{ peek pop* pop } [
     { vector } "specializer" set-word-prop
 ] each
 
+\ push { { vector } { sbuf } } "specializer" set-word-prop
+
 \ push-all
 { { string sbuf } { array vector } { byte-array byte-vector } }
 "specializer" set-word-prop

basis/io/buffers/buffers.factor

@@ -36,9 +36,7 @@ M: buffer dispose* ptr>> free ;
     [ ptr>> ] [ pos>> ] bi alien-unsigned-1 ; inline
 
 : buffer-pop ( buffer -- byte )
-    [ buffer-peek ] [ 1 swap buffer-consume ] bi ;
+    [ buffer-peek ] [ 1 swap buffer-consume ] bi ; inline
-
-HINTS: buffer-pop buffer ;
 
 : buffer-length ( buffer -- n )
     [ fill>> ] [ pos>> ] bi - ; inline
@@ -69,14 +67,13 @@ HINTS: n>buffer fixnum buffer ;
 HINTS: >buffer byte-array buffer ;
 
 : byte>buffer ( byte buffer -- )
+    [ >fixnum ] dip
     [ [ ptr>> ] [ fill>> ] bi set-alien-unsigned-1 ]
     [ 1 swap n>buffer ]
-    bi ;
+    bi ; inline
-
-HINTS: byte>buffer fixnum buffer ;
 
 : search-buffer-until ( pos fill ptr separators -- n )
-    [ [ swap alien-unsigned-1 ] dip memq? ] 2curry find-from drop ;
+    [ [ swap alien-unsigned-1 ] dip memq? ] 2curry find-from drop ; inline
 
 : finish-buffer-until ( buffer n -- byte-array separator )
     [
@@ -86,7 +83,7 @@ HINTS: byte>buffer fixnum buffer ;
     ] [
         [ buffer-length ] keep
         buffer-read f
-    ] if* ;
+    ] if* ; inline
 
 : buffer-until ( separators buffer -- byte-array separator )
     swap [ { [ ] [ pos>> ] [ fill>> ] [ ptr>> ] } cleave ] dip

basis/io/encodings/ascii/ascii.factor

@@ -9,7 +9,7 @@ IN: io.encodings.ascii
 
 : decode-if< ( stream encoding max -- character )
     nip swap stream-read1 dup
-    [ tuck > [ drop replacement-char ] unless ] [ 2drop f ] if ; inline
+    [ tuck > [ >fixnum ] [ drop replacement-char ] if ] [ 2drop f ] if ; inline
 PRIVATE>
 
 SINGLETON: ascii

basis/io/ports/ports.factor

@@ -39,7 +39,7 @@ HOOK: (wait-to-read) io-backend ( port -- )
 
 M: input-port stream-read1
     dup check-disposed
-    dup wait-to-read [ drop f ] [ buffer>> buffer-pop ] if ;
+    dup wait-to-read [ drop f ] [ buffer>> buffer-pop ] if ; inline
 
 : read-step ( count port -- byte-array/f )
     dup wait-to-read [ 2drop f ] [ buffer>> buffer-read ] if ;
@@ -100,12 +100,12 @@ TUPLE: output-port < buffered-port ;
 
 : wait-to-write ( len port -- )
     tuck buffer>> buffer-capacity <=
-    [ drop ] [ stream-flush ] if ;
+    [ drop ] [ stream-flush ] if ; inline
 
 M: output-port stream-write1
     dup check-disposed
     1 over wait-to-write
-    buffer>> byte>buffer ;
+    buffer>> byte>buffer ; inline
 
 M: output-port stream-write
     dup check-disposed
@@ -161,4 +161,4 @@ HINTS: decoder-read-until { string input-port utf8 } { string input-port ascii }
 
 HINTS: decoder-readln { input-port utf8 } { input-port ascii } ;
 
-HINTS: decoder-write { string output-port utf8 } { string output-port ascii } ;
+HINTS: encoder-write { string output-port utf8 } { string output-port ascii } ;

basis/io/streams/memory/memory.factor

@@ -1,6 +1,6 @@
 ! Copyright (C) 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: kernel accessors alien.accessors math io ;
+USING: kernel accessors alien alien.c-types alien.accessors math io ;
 IN: io.streams.memory
 
 TUPLE: memory-stream alien index ;
@@ -11,3 +11,9 @@ TUPLE: memory-stream alien index ;
 M: memory-stream stream-read1
     [ [ alien>> ] [ index>> ] bi alien-unsigned-1 ]
     [ [ 1+ ] change-index drop ] bi ;
+
+M: memory-stream stream-read
+    [
+        [ index>> ] [ alien>> ] bi <displaced-alien>
+        swap memory>byte-array
+    ] [ [ + ] change-index drop ] 2bi ;

basis/locals/locals-tests.factor

@@ -1,7 +1,8 @@
 USING: locals math sequences tools.test hashtables words kernel
 namespaces arrays strings prettyprint io.streams.string parser
 accessors generic eval combinators combinators.short-circuit
-combinators.short-circuit.smart math.order math.functions ;
+combinators.short-circuit.smart math.order math.functions
+definitions compiler.units ;
 IN: locals.tests
 
 :: foo ( a b -- a a ) a a ;
@@ -378,6 +379,12 @@ M:: sequence method-with-locals ( a -- y ) a reverse ;
 
 [ 9 ] [ 3 big-case-test ] unit-test
 
+GENERIC: lambda-method-forget-test ( a -- b )
+
+M:: integer lambda-method-forget-test ( a -- b ) ;
+
+[ ] [ [ { integer lambda-method-forget-test } forget ] with-compilation-unit ] unit-test
+
 ! :: wlet-&&-test ( a -- ? )
 !     [wlet | is-integer? [ a integer? ]
 !             is-even? [ a even? ]

basis/locals/locals.factor

@@ -450,7 +450,7 @@ M: lambda-method definition
     "lambda" word-prop body>> ;
 
 M: lambda-method reset-word
-    [ f "lambda" set-word-prop ] [ call-next-method ] bi ;
+    [ call-next-method ] [ f "lambda" set-word-prop ] bi ;
 
 INTERSECTION: lambda-memoized memoized lambda-word ;
 

basis/math/intervals/intervals-tests.factor

@@ -83,8 +83,6 @@ IN: math.intervals.tests
     0 1 (a,b) 1 2 [a,b] interval-union 0 2 (a,b] =
 ] unit-test
 
-[ f ] [ 0 1 (a,b) f interval-union ] unit-test
-
 [ t ] [
     0 1 (a,b) 0 1 [a,b] interval-intersect 0 1 (a,b) =
 ] unit-test

basis/math/intervals/intervals.factor

@@ -115,14 +115,10 @@ TUPLE: interval { from read-only } { to read-only } ;
         { [ dup empty-interval eq? ] [ nip ] }
         { [ over empty-interval eq? ] [ drop ] }
         [
-            2dup and [
+            [ interval>points ] bi@ swapd
-                [ interval>points ] bi@ swapd
+            [ [ swap endpoint< ] most ]
-                [ [ swap endpoint< ] most ]
+            [ [ swap endpoint> ] most ] 2bi*
-                [ [ swap endpoint> ] most ] 2bi*
+            <interval>
-                <interval>
-            ] [
-                or
-            ] if
         ]
     } cond ;
 
@@ -133,13 +129,7 @@ TUPLE: interval { from read-only } { to read-only } ;
     {
         { [ dup empty-interval eq? ] [ drop ] }
         { [ over empty-interval eq? ] [ nip ] }
-        [
+        [ [ interval>points 2array ] bi@ append points>interval ]
-            2dup and [
-                [ interval>points 2array ] bi@ append points>interval
-            ] [
-                2drop f
-            ] if
-        ]
     } cond ;
 
 : interval-subset? ( i1 i2 -- ? )
@@ -183,7 +173,6 @@ TUPLE: interval { from read-only } { to read-only } ;
 : interval-length ( int -- n )
     {
         { [ dup empty-interval eq? ] [ drop 0 ] }
-        { [ dup not ] [ drop 0 ] }
         [ interval>points [ first ] bi@ swap - ]
     } cond ;
 

basis/mirrors/mirrors.factor

@@ -44,7 +44,7 @@ M: mirror >alist ( mirror -- alist )
     [ object>> [ swap slot ] curry ] bi
     map zip ;
 
-M: mirror assoc-size object>> layout-of size>> ;
+M: mirror assoc-size object>> layout-of second ;
 
 INSTANCE: mirror assoc
 

basis/prettyprint/backend/backend.factor

@@ -233,6 +233,3 @@ M: wrapper pprint*
     ] [
         pprint-object
     ] if ;
-
-M: tuple-layout pprint*
-    "( tuple layout )" swap present-text ;

basis/random/mersenne-twister/mersenne-twister.factor

@@ -68,3 +68,10 @@ M: mersenne-twister random-32* ( mt -- r )
     [ next-index ]
     [ seq>> nth mt-temper ]
     [ [ 1+ ] change-i drop ] tri ;
+
+USE: init
+
+[
+    [ 32 random-bits ] with-system-random
+    <mersenne-twister> random-generator set-global
+] "bootstrap.random" add-init-hook

basis/random/random.factor

@@ -60,3 +60,12 @@ PRIVATE>
 
 : with-secure-random ( quot -- )
     secure-random-generator get swap with-random ; inline
+
+USE: vocabs.loader
+
+{
+    { [ os windows? ] [ "random.windows" require ] }
+    { [ os unix? ] [ "random.unix" require ] }
+} cond
+
+"random.mersenne-twister" require

basis/regexp/parser/parser.factor

@@ -233,15 +233,22 @@ ERROR: invalid-range a b ;
 SINGLETON: beginning-of-input
 SINGLETON: end-of-input
 
-! : beginning-of-input ( -- obj ) 
+: newlines ( -- obj1 obj2 obj3 )
-: handle-front-anchor ( -- ) front-anchor push-stack ;
-: end-of-line ( -- obj )
-    end-of-input
     CHAR: \r <constant>
     CHAR: \n <constant>
-    2dup 2array <concatenation> 4array <alternation> lookahead boa ;
+    2dup 2array <concatenation> ;
 
-: handle-back-anchor ( -- ) end-of-line push-stack ;
+: beginning-of-line ( -- obj )
+    beginning-of-input newlines 4array <alternation> lookbehind boa ;
+
+: end-of-line ( -- obj )
+    end-of-input newlines 4array <alternation> lookahead boa ;
+
+: handle-front-anchor ( -- )
+    get-multiline beginning-of-line beginning-of-input ? push-stack ;
+
+: handle-back-anchor ( -- )
+    get-multiline end-of-line end-of-input ? push-stack ;
 
 ERROR: bad-character-class obj ;
 ERROR: expected-posix-class ;
@@ -412,16 +419,11 @@ DEFER: handle-left-bracket
     [ [ push ] keep current-regexp get (>>stack) ]
     [ finish-regexp-parse push-stack ] bi* ;
 
-
 : parse-regexp-token ( token -- ? )
     {
-! todo: only match these at beginning/end of regexp
+        { CHAR: ( [ handle-left-parenthesis t ] } ! handle (?..) at beginning?
-        { CHAR: ^ [ handle-front-anchor t ] }
-        { CHAR: $ [ handle-back-anchor t ] }
-
-        { CHAR: . [ handle-dot t ] }
-        { CHAR: ( [ handle-left-parenthesis t ] }
         { CHAR: ) [ handle-right-parenthesis f ] }
+        { CHAR: . [ handle-dot t ] }
         { CHAR: | [ handle-pipe t ] }
         { CHAR: ? [ handle-question t ] }
         { CHAR: * [ handle-star t ] }
@@ -429,16 +431,28 @@ DEFER: handle-left-bracket
         { CHAR: { [ handle-left-brace t ] }
         { CHAR: [ [ handle-left-bracket t ] }
         { CHAR: \ [ handle-escape t ] }
-        [ <constant> push-stack t ]
+        [
+            dup CHAR: $ = peek1 f = and [
+                drop
+                handle-back-anchor f
+            ] [
+                <constant> push-stack t
+            ] if
+        ]
     } case ;
 
 : (parse-regexp) ( -- )
     read1 [ parse-regexp-token [ (parse-regexp) ] when ] when* ;
 
+: parse-regexp-beginning ( -- )
+    peek1 CHAR: ^ = [ drop1 handle-front-anchor ] when ;
+
 : parse-regexp ( regexp -- )
     dup current-regexp [
         raw>> [
-            <string-reader> [ (parse-regexp) ] with-input-stream
+            <string-reader> [
+                parse-regexp-beginning (parse-regexp)
+            ] with-input-stream
         ] unless-empty
         current-regexp get
         stack finish-regexp-parse

basis/regexp/regexp-tests.factor

@@ -331,4 +331,3 @@ IN: regexp-tests
 [ { 0 3 } ] [ "abc" "(ab|a)(bc)?" <regexp> first-match ] unit-test
 
 [ { 23 24 } ] [ "aaaaaaaaaaaaaaaaaaaaaaab" "((a*)*b)*b" <regexp> first-match ] unit-test
-

basis/regexp/regexp.factor

@@ -92,7 +92,6 @@ IN: regexp
     reversed-regexp initial-option
     construct-regexp ;
 
-
 : parsing-regexp ( accum end -- accum )
     lexer get dup skip-blank
     [ [ index-from dup 1+ swap ] 2keep swapd subseq swap ] change-lexer-column
@@ -112,7 +111,6 @@ IN: regexp
 : R{ CHAR: } parsing-regexp ; parsing
 : R| CHAR: | parsing-regexp ; parsing
 
-
 : find-regexp-syntax ( string -- prefix suffix )
     {
         { "R/ "  "/"  }

basis/regexp/traversal/traversal.factor

@@ -2,7 +2,8 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors assocs combinators kernel math math.ranges
 quotations sequences regexp.parser regexp.classes fry arrays
-combinators.short-circuit regexp.utils prettyprint regexp.nfa ;
+combinators.short-circuit regexp.utils prettyprint regexp.nfa
+shuffle ;
 IN: regexp.traversal
 
 TUPLE: dfa-traverser
@@ -23,8 +24,7 @@ TUPLE: dfa-traverser
     [ dfa-table>> ] [ dfa-traversal-flags>> ] bi
     dfa-traverser new
         swap >>traversal-flags
-        swap [ start-state>> >>current-state ] keep
+        swap [ start-state>> >>current-state ] [ >>dfa-table ] bi
-        >>dfa-table
         swap >>text
         t >>traverse-forward
         0 >>start-index
@@ -116,7 +116,7 @@ M: capture-group-off flag-action ( dfa-traverser flag -- )
     V{ } clone >>matches ;
 
 : match-literal ( transition from-state table -- to-state/f )
-    transitions>> at* [ at ] [ 2drop f ] if ;
+    transitions>> at at ;
 
 : match-class ( transition from-state table -- to-state/f )
     transitions>> at* [
@@ -124,8 +124,7 @@ M: capture-group-off flag-action ( dfa-traverser flag -- )
     ] [ drop ] if ;
 
 : match-default ( transition from-state table -- to-state/f )
-    [ nip ] dip transitions>> at*
+    nipd transitions>> at t swap at ;
-    [ t swap at* [ ] [ drop f ] if ] [ drop f ] if ;
 
 : match-transition ( obj from-state dfa -- to-state/f )
     { [ match-literal ] [ match-class ] [ match-default ] } 3|| ;

basis/stack-checker/known-words/known-words.factor

@@ -108,7 +108,7 @@ M: object infer-call*
 
 : infer-<tuple-boa> ( -- )
     \ <tuple-boa>
-    peek-d literal value>> size>> 1+ { tuple } <effect>
+    peek-d literal value>> second 1+ { tuple } <effect>
     apply-word/effect ;
 
 : infer-(throw) ( -- )
@@ -561,9 +561,6 @@ do-primitive alien-invoke alien-indirect alien-callback
 \ <tuple> { tuple-layout } { tuple } define-primitive
 \ <tuple> make-flushable
 
-\ <tuple-layout> { word fixnum array fixnum } { tuple-layout } define-primitive
-\ <tuple-layout> make-foldable
-
 \ datastack { } { array } define-primitive
 \ datastack make-flushable
 

basis/tools/deploy/backend/backend.factor

@@ -42,7 +42,7 @@ IN: tools.deploy.backend
         { "compiler" deploy-compiler? }
         { "threads"  deploy-threads?  }
         { "ui"       deploy-ui?       }
-        { "random"   deploy-random?   }
+        { "unicode"  deploy-unicode?  }
     } [ nip get ] assoc-filter keys
     native-io? [ "io" suffix ] when ;
 

basis/tools/deploy/config/config-docs.factor

@@ -16,7 +16,7 @@ ARTICLE: "deploy-flags" "Deployment flags"
 "There are two sets of deployment flags. The first set controls the major subsystems which are to be included in the deployment image:"
 { $subsection deploy-math?     }
 { $subsection deploy-compiler? }
-{ $subsection deploy-random?   }
+{ $subsection deploy-unicode?   }
 { $subsection deploy-threads?  }
 { $subsection deploy-ui?       }
 "The second set of flags controls the level of stripping to be performed on the deployment image; there is a trade-off between image size, and retaining functionality which is required by the application:"
@@ -73,10 +73,10 @@ HELP: deploy-compiler?
 $nl
 "On by default. Most programs should be compiled, not only for performance but because features which depend on the C library interface only function after compilation." } ;
 
-HELP: deploy-random?
+HELP: deploy-unicode?
-{ $description "Deploy flag. If set, the random number generator protocol is included, together with two implementations: a native OS-specific random number generator, and the Mersenne Twister."
+{ $description "Deploy flag. If set, full Unicode " { $link POSTPONE: CHAR: } " syntax is included."
 $nl
-"On by default. If your program does not generate random numbers you can disable this to save some space." } ;
+"Off by default. If your program needs to use " { $link POSTPONE: CHAR: } " with named characters, enable this flag." } ;
 
 HELP: deploy-threads?
 { $description "Deploy flag. If set, thread support will be included in the final image."

basis/tools/deploy/config/config.factor

@@ -10,7 +10,7 @@ SYMBOL: deploy-name
 SYMBOL: deploy-ui?
 SYMBOL: deploy-compiler?
 SYMBOL: deploy-math?
-SYMBOL: deploy-random?
+SYMBOL: deploy-unicode?
 SYMBOL: deploy-threads?
 
 SYMBOL: deploy-io
@@ -58,7 +58,7 @@ SYMBOL: deploy-image
         { deploy-reflection         1 }
         { deploy-compiler?          t }
         { deploy-threads?           t }
-        { deploy-random?            t }
+        { deploy-unicode?           f }
         { deploy-math?              t }
         { deploy-word-props?        f }
         { deploy-word-defs?         f }

basis/tools/deploy/test/1/deploy.factor

@@ -1,7 +1,6 @@
 USING: tools.deploy.config ;
 H{
     { deploy-threads? t }
-    { deploy-random? f }
     { deploy-c-types? f }
     { deploy-ui? f }
     { deploy-word-props? f }

basis/tools/deploy/test/2/deploy.factor

@@ -1,7 +1,6 @@
 USING: tools.deploy.config ;
 H{
     { deploy-threads? t }
-    { deploy-random? f }
     { deploy-c-types? f }
     { deploy-ui? f }
     { deploy-word-props? f }

basis/tools/deploy/test/3/deploy.factor

@@ -1,7 +1,6 @@
 USING: tools.deploy.config ;
 H{
     { deploy-threads? t }
-    { deploy-random? f }
     { deploy-c-types? f }
     { deploy-ui? f }
     { deploy-word-props? f }

basis/tools/deploy/test/4/deploy.factor

@@ -1,7 +1,6 @@
 USING: tools.deploy.config ;
 H{
     { deploy-threads? t }
-    { deploy-random? f }
     { deploy-c-types? f }
     { deploy-ui? f }
     { deploy-word-props? f }

basis/tools/deploy/test/5/deploy.factor

@@ -1,7 +1,6 @@
 USING: tools.deploy.config ;
 H{
     { deploy-threads? t }
-    { deploy-random? f }
     { deploy-c-types? f }
     { deploy-ui? f }
     { deploy-word-props? f }

basis/tools/deploy/test/6/deploy.factor

@@ -5,7 +5,6 @@ H{
     { deploy-io 1 }
     { deploy-name "tools.deploy.test.6" }
     { deploy-math? t }
-    { deploy-random? f }
     { deploy-compiler? t }
     { deploy-ui? f }
     { deploy-c-types? f }

basis/ui/tools/deploy/deploy.factor

@@ -36,7 +36,7 @@ TUPLE: deploy-gadget < pack vocab settings ;
     deploy-compiler? get "Use optimizing compiler" <checkbox> add-gadget
     deploy-math? get "Rational and complex number support" <checkbox> add-gadget
     deploy-threads? get "Threading support" <checkbox> add-gadget
-    deploy-random? get "Random number generator support" <checkbox> add-gadget
+    deploy-unicode? get "Unicode character literal support" <checkbox> add-gadget
     deploy-word-props? get "Retain all word properties" <checkbox> add-gadget
     deploy-word-defs? get "Retain all word definitions" <checkbox> add-gadget
     deploy-c-types? get "Retain all C types" <checkbox> add-gadget ;

core/bootstrap/layouts/layouts.factor

@@ -9,7 +9,7 @@ BIN: 111 tag-mask set
 8 num-tags set
 3 tag-bits set
 
-18 num-types set
+17 num-types set
 
 H{
     { fixnum      BIN: 000 }
@@ -29,9 +29,8 @@ tag-numbers get H{
     { byte-array 10 }
     { callstack 11 }
     { string 12 }
-    { tuple-layout 13 }
+    { word 13 }
     { quotation 14 }
     { dll 15 }
     { alien 16 }
-    { word 17 }
 } assoc-union type-numbers set

core/bootstrap/primitives.factor

@@ -147,7 +147,6 @@ bootstrapping? on
 "alien" "alien" create register-builtin
 "word" "words" create register-builtin
 "byte-array" "byte-arrays" create register-builtin
-"tuple-layout" "classes.tuple.private" create register-builtin
 
 ! For predicate classes
 "predicate-instance?" "classes.predicate" create drop
@@ -272,14 +271,6 @@ bi
 
 "callstack" "kernel" create { } define-builtin
 
-"tuple-layout" "classes.tuple.private" create {
-    { "hashcode" { "fixnum" "math" } read-only }
-    { "class" { "word" "words" } initial: t read-only }
-    { "size" { "fixnum" "math" } read-only }
-    { "superclasses" { "array" "arrays" } initial: { } read-only }
-    { "echelon" { "fixnum" "math" } read-only }
-} define-builtin
-
 "tuple" "kernel" create
 [ { } define-builtin ]
 [ define-tuple-layout ]
@@ -510,7 +501,6 @@ tuple
     { "array>quotation" "quotations.private" }
     { "quotation-xt" "quotations" }
     { "<tuple>" "classes.tuple.private" }
-    { "<tuple-layout>" "classes.tuple.private" }
     { "profiling" "tools.profiler.private" }
     { "become" "kernel.private" }
     { "(sleep)" "threads.private" }

core/bootstrap/stage1.factor

@@ -49,4 +49,5 @@ load-help? off
             1 exit
         ] if
     ] %
-] [ ] make bootstrap-boot-quot set
+] [ ] make
+bootstrap-boot-quot set

core/classes/algebra/algebra.factor

@@ -20,6 +20,14 @@ C: <anonymous-complement> anonymous-complement
 : 2cache ( key1 key2 assoc quot -- value )
     >r >r 2array r> [ first2 ] r> compose cache ; inline
 
+GENERIC: valid-class? ( obj -- ? )
+
+M: class valid-class? drop t ;
+M: anonymous-union valid-class? members>> [ valid-class? ] all? ;
+M: anonymous-intersection valid-class? participants>> [ valid-class? ] all? ;
+M: anonymous-complement valid-class? class>> valid-class? ;
+M: word valid-class? drop f ;
+
 DEFER: (class<=)
 
 : class<= ( first second -- ? )

core/classes/classes-tests.factor

@@ -79,3 +79,37 @@ USE: multiline
     : q ( -- b ) j new g ;"> <string-reader>
     "class-intersect-no-method-b" parse-stream drop
 ] unit-test
+
+! Similar problem, but with anonymous classes
+[ ] [
+    <" IN: classes.test.c
+    USE: kernel
+    GENERIC: g ( a -- b )
+    M: object g ;
+    TUPLE: z ;"> <string-reader>
+    "class-intersect-no-method-c" parse-stream drop
+] unit-test
+
+[ ] [
+    <" IN: classes.test.d
+    USE: classes.test.c
+    USE: kernel
+    : q ( a -- b ) dup z? [ g ] unless ;"> <string-reader>
+    "class-intersect-no-method-d" parse-stream drop
+] unit-test
+
+! Now, the user removes the z class and adds a method,
+[ ] [
+    <" IN: classes.test.c
+    USE: kernel
+    GENERIC: g ( a -- b )
+    M: object g ;
+    TUPLE: j ;
+    M: j g ;"> <string-reader>
+    "class-intersect-no-method-c" parse-stream drop
+] unit-test
+
+TUPLE: forgotten-predicate-test ;
+
+[ ] [ [ \ forgotten-predicate-test forget ] with-compilation-unit ] unit-test
+[ f ] [ \ forgotten-predicate-test? predicate? ] unit-test

core/classes/classes.factor

@@ -32,8 +32,7 @@ SYMBOL: update-map
 
 SYMBOL: implementors-map
 
-PREDICATE: class < word
+PREDICATE: class < word "class" word-prop ;
-    "class" word-prop ;
 
 : classes ( -- seq ) implementors-map get keys ;
 
@@ -42,9 +41,12 @@ PREDICATE: class < word
 
 PREDICATE: predicate < word "predicating" word-prop >boolean ;
 
+M: predicate reset-word
+    [ call-next-method ] [ { "predicating" } reset-props ] bi ;
+
 : define-predicate ( class quot -- )
-    >r "predicate" word-prop first
+    [ "predicate" word-prop first ] dip
-    r> (( object -- ? )) define-declared ;
+    (( object -- ? )) define-declared ;
 
 : superclass ( class -- super )
     #! Output f for non-classes to work with algebra code
@@ -121,13 +123,13 @@ M: sequence implementors [ implementors ] gather ;
     ] H{ } make-assoc ;
 
 : (define-class) ( word props -- )
-    >r
+    [
-    dup class? [ dup [ implementors-map+ ] [ new-class ] bi ] unless
+        dup class? [ dup [ implementors-map+ ] [ new-class ] bi ] unless
-    dup reset-class
+        dup reset-class
-    dup deferred? [ dup define-symbol ] when
+        dup deferred? [ dup define-symbol ] when
-    dup redefined
+        dup redefined
-    dup props>>
+        dup props>>
-    r> assoc-union >>props
+    ] dip assoc-union >>props
     dup predicate-word
     [ 1quotation "predicate" set-word-prop ]
     [ swap "predicating" set-word-prop ]

core/classes/tuple/tuple-docs.factor

@@ -348,7 +348,7 @@ $nl
 { $list
     { { $snippet "\"predicate\"" } " - a quotation which tests if the top of the stack is an instance of this tuple class" }
     { { $snippet "\"slots\"" } " - a sequence of " { $link slot-spec } " instances" }
-    { { $snippet "\"tuple-layout\"" } " - a " { $link tuple-layout } " instance" }
+    { { $snippet "\"tuple-layout\"" } " - an array with the tuple size and superclasses encoded in a format amneable to fast method dispatch" }
 } } ;
 
 HELP: define-tuple-predicate
@@ -405,11 +405,11 @@ HELP: tuple>array ( tuple -- array )
 { $description "Outputs an array having the tuple's slots as elements. The first element is the tuple class word and remainder are declared slots." } ;
 
 HELP: <tuple> ( layout -- tuple )
-{ $values { "layout" tuple-layout } { "tuple" tuple } }
+{ $values { "layout" "a tuple layout array" } { "tuple" tuple } }
 { $description "Low-level tuple constructor. User code should never call this directly, and instead use " { $link new } "." } ;
 
 HELP: <tuple-boa> ( ... layout -- tuple )
-{ $values { "..." "values" } { "layout" tuple-layout } { "tuple" tuple } }
+{ $values { "..." "values" } { "layout" "a tuple layout array" } { "tuple" tuple } }
 { $description "Low-level tuple constructor. User code should never call this directly, and instead use " { $link boa } "." } ;
 
 HELP: new

core/classes/tuple/tuple-tests.factor

@@ -94,7 +94,7 @@ TUPLE: size-test a b c d ;
 
 [ t ] [
     T{ size-test } tuple-size
-    size-test tuple-layout size>> =
+    size-test tuple-layout second =
 ] unit-test
 
 GENERIC: <yo-momma>
@@ -238,12 +238,6 @@ C: <laptop> laptop
 
 test-laptop-slot-values
 
-[ laptop ] [
-    "laptop" get 1 slot
-    dup echelon>> swap
-    superclasses>> nth
-] unit-test
-
 [ "TUPLE: laptop < computer battery ;" ] [
     [ \ laptop see ] with-string-writer string-lines second
 ] unit-test

core/classes/tuple/tuple.factor

@@ -10,8 +10,6 @@ IN: classes.tuple
 PREDICATE: tuple-class < class
     "metaclass" word-prop tuple-class eq? ;
 
-M: tuple class 1 slot 2 slot { word } declare ;
-
 ERROR: not-a-tuple object ;
 
 : check-tuple ( object -- tuple )
@@ -29,10 +27,12 @@ PREDICATE: immutable-tuple-class < tuple-class ( class -- ? )
     "layout" word-prop ;
 
 : layout-of ( tuple -- layout )
-    1 slot { tuple-layout } declare ; inline
+    1 slot { array } declare ; inline
+
+M: tuple class layout-of 2 slot { word } declare ;
 
 : tuple-size ( tuple -- size )
-    layout-of size>> ; inline
+    layout-of second ; inline
 
 : prepare-tuple>array ( tuple -- n tuple layout )
     check-tuple [ tuple-size ] [ ] [ layout-of ] tri ;
@@ -59,7 +59,7 @@ PRIVATE>
 : tuple>array ( tuple -- array )
     prepare-tuple>array
     >r copy-tuple-slots r>
-    class>> prefix ;
+    first prefix ;
 
 : tuple-slots ( tuple -- seq )
     prepare-tuple>array drop copy-tuple-slots ;
@@ -90,16 +90,29 @@ ERROR: bad-superclass class ;
         2drop f
     ] if ; inline
 
-: tuple-instance? ( object class echelon -- ? )
+: tuple-instance-1? ( object class -- ? )
-    #! 4 slot == superclasses>>
+    swap dup tuple? [
+        layout-of 7 slot eq?
+    ] [ 2drop f ] if ; inline
+
+: tuple-instance? ( object class offset -- ? )
     rot dup tuple? [
-        layout-of 4 slot { array } declare
+        layout-of
-        2dup 1 slot fixnum< [ array-nth eq? ] [ 3drop f ] if
+        2dup 1 slot fixnum<=
+        [ swap slot eq? ] [ 3drop f ] if
     ] [ 3drop f ] if ; inline
 
+: layout-class-offset ( echelon -- n )
+    2 * 5 + ;
+
+: echelon-of ( class -- n )
+    tuple-layout third ;
+
 : define-tuple-predicate ( class -- )
-    dup dup tuple-layout echelon>>
+    dup dup echelon-of {
-    [ tuple-instance? ] 2curry define-predicate ;
+        { 1 [ [ tuple-instance-1? ] curry ] }
+        [ layout-class-offset [ tuple-instance? ] 2curry ]
+    } case define-predicate ;
 
 : class-size ( class -- n )
     superclasses [ "slots" word-prop length ] sigma ;
@@ -145,10 +158,14 @@ ERROR: bad-superclass class ;
     define-accessors ;
 
 : make-tuple-layout ( class -- layout )
-    [ ]
+    [
-    [ [ superclass class-size ] [ "slots" word-prop length ] bi + ]
+        {
-    [ superclasses dup length 1- ] tri
+            [ , ]
-    <tuple-layout> ;
+            [ [ superclass class-size ] [ "slots" word-prop length ] bi + , ]
+            [ superclasses length 1- , ]
+            [ superclasses [ [ , ] [ hashcode , ] bi ] each ]
+        } cleave
+    ] { } make ;
 
 : define-tuple-layout ( class -- )
     dup make-tuple-layout "layout" set-word-prop ;
@@ -169,13 +186,13 @@ ERROR: bad-superclass class ;
     [ first3 update-slot ] with map ;
 
 : permute-slots ( old-values layout -- new-values )
-    [ class>> all-slots ] [ outdated-tuples get at ] bi
+    [ first all-slots ] [ outdated-tuples get at ] bi
     compute-slot-permutation
     apply-slot-permutation ;
 
 : update-tuple ( tuple -- newtuple )
     [ tuple-slots ] [ layout-of ] bi
-    [ permute-slots ] [ class>> ] bi
+    [ permute-slots ] [ first ] bi
     slots>tuple ;
 
 : outdated-tuple? ( tuple assoc -- ? )
@@ -284,7 +301,7 @@ M: tuple-class reset-class
 M: tuple-class rank-class drop 0 ;
 
 M: tuple-class instance?
-    dup tuple-layout echelon>> tuple-instance? ;
+    dup echelon-of layout-class-offset tuple-instance? ;
 
 M: tuple-class (flatten-class) dup set ;
 

core/compiler/units/units.factor

@@ -111,7 +111,7 @@ SYMBOL: remake-generics-hook
 : (compiled-generic-usages) ( generic class -- assoc )
     [ compiled-generic-usage ] dip
     [
-        2dup [ class? ] both?
+        2dup [ valid-class? ] both?
         [ classes-intersect? ] [ 2drop f ] if nip
     ] curry assoc-filter ;
 

core/generic/parser/parser.factor

@@ -8,7 +8,7 @@ ERROR: not-in-a-method-error ;
 : CREATE-GENERIC ( -- word ) CREATE dup reset-word ;
 
 : create-method-in ( class generic -- method )
-    create-method f set-word dup save-location ;
+    create-method dup set-word dup save-location ;
 
 : CREATE-METHOD ( -- method )
     scan-word bootstrap-word scan-word create-method-in ;
@@ -18,11 +18,11 @@ SYMBOL: current-generic
 
 : with-method-definition ( quot -- parsed )
     [
-        >r
+        [
-        [ "method-class" word-prop current-class set ]
+            [ "method-class" word-prop current-class set ]
-        [ "method-generic" word-prop current-generic set ]
+            [ "method-generic" word-prop current-generic set ]
-        [ ] tri
+            [ ] tri
-        r> call
+        ] dip call
     ] with-scope ; inline
 
 : (M:) ( method def -- )

core/generic/standard/engines/tag/tag.factor

@@ -3,7 +3,7 @@
 USING: classes.private generic.standard.engines namespaces make
 arrays assocs sequences.private quotations kernel.private
 math slots.private math.private kernel accessors words
-layouts ;
+layouts sorting sequences ;
 IN: generic.standard.engines.tag
 
 TUPLE: lo-tag-dispatch-engine methods ;
@@ -23,9 +23,11 @@ C: <lo-tag-dispatch-engine> lo-tag-dispatch-engine
     ] if ;
 
 M: lo-tag-dispatch-engine engine>quot
-    methods>> engines>quots* [ >r lo-tag-number r> ] assoc-map
+    methods>> engines>quots*
+    [ >r lo-tag-number r> ] assoc-map
     [
         picker % [ tag ] % [
+            >alist sort-keys reverse
             linear-dispatch-quot
         ] [
             num-tags get direct-dispatch-quot

core/generic/standard/engines/tuple/tuple.factor

@@ -7,18 +7,28 @@ classes.algebra math math.private kernel.private
 quotations arrays definitions ;
 IN: generic.standard.engines.tuple
 
+: nth-superclass% ( n -- ) 2 * 5 + , \ slot , ; inline
+
+: nth-hashcode% ( n -- ) 2 * 6 + , \ slot , ; inline
+
+: tuple-layout% ( -- )
+    [ { tuple } declare 1 slot { array } declare ] % ; inline
+
+: tuple-layout-echelon% ( -- )
+    [ 4 slot ] % ; inline
+
 TUPLE: echelon-dispatch-engine n methods ;
 
 C: <echelon-dispatch-engine> echelon-dispatch-engine
 
-TUPLE: trivial-tuple-dispatch-engine methods ;
+TUPLE: trivial-tuple-dispatch-engine n methods ;
 
 C: <trivial-tuple-dispatch-engine> trivial-tuple-dispatch-engine
 
 TUPLE: tuple-dispatch-engine echelons ;
 
 : push-echelon ( class method assoc -- )
-    >r swap dup "layout" word-prop echelon>> r>
+    [ swap dup "layout" word-prop third ] dip
     [ ?set-at ] change-at ;
 
 : echelon-sort ( assoc -- assoc' )
@@ -38,19 +48,24 @@ TUPLE: tuple-dispatch-engine echelons ;
     \ <tuple-dispatch-engine> convert-methods ;
 
 M: trivial-tuple-dispatch-engine engine>quot
-    methods>> engines>quots* linear-dispatch-quot ;
+    [ n>> ] [ methods>> ] bi dup assoc-empty? [
+        2drop default get [ drop ] prepend
+    ] [
+        [
+            [ nth-superclass% ]
+            [ engines>quots* linear-dispatch-quot % ] bi*
+        ] [ ] make
+    ] if ;
 
-: hash-methods ( methods -- buckets )
+: hash-methods ( n methods -- buckets )
     >alist V{ } clone [ hashcode 1array ] distribute-buckets
-    [ <trivial-tuple-dispatch-engine> ] map ;
+    [ <trivial-tuple-dispatch-engine> ] with map ;
 
-: word-hashcode% ( -- ) [ 1 slot ] % ;
+: class-hash-dispatch-quot ( n methods -- quot )
-
-: class-hash-dispatch-quot ( methods -- quot )
     [
         \ dup ,
-        word-hashcode%
+        [ drop nth-hashcode% ]
-        hash-methods [ engine>quot ] map hash-dispatch-quot %
+        [ hash-methods [ engine>quot ] map hash-dispatch-quot % ] 2bi
     ] [ ] make ;
 
 : engine-word-name ( -- string )
@@ -79,29 +94,16 @@ M: engine-word irrelevant? drop t ;
     dup generic get "tuple-dispatch-generic" set-word-prop ;
 
 : define-engine-word ( quot -- word )
-    >r <engine-word> dup r> define ;
+    [ <engine-word> dup ] dip define ;
-
-: array-nth% ( n -- ) 2 + , [ slot { word } declare ] % ;
-
-: tuple-layout-superclasses% ( -- )
-    [
-        { tuple } declare
-        1 slot { tuple-layout } declare
-        4 slot { array } declare
-    ] % ; inline
 
 : tuple-dispatch-engine-body ( engine -- quot )
     [
         picker %
-        tuple-layout-superclasses%
+        tuple-layout%
-        [ n>> array-nth% ]
+        [ n>> ] [ methods>> ] bi
-        [
+        [ <trivial-tuple-dispatch-engine> engine>quot ]
-            methods>> [
+        [ class-hash-dispatch-quot ]
-                <trivial-tuple-dispatch-engine> engine>quot
+        if-small? %
-            ] [
-                class-hash-dispatch-quot
-            ] if-small? %
-        ] bi
     ] [ ] make ;
 
 M: echelon-dispatch-engine engine>quot
@@ -109,22 +111,11 @@ M: echelon-dispatch-engine engine>quot
         methods>> dup assoc-empty?
         [ drop default get ] [ values first engine>quot ] if
     ] [
-        [
+        tuple-dispatch-engine-body
-            picker %
-            tuple-layout-superclasses%
-            [ n>> array-nth% ]
-            [
-                methods>> [
-                    <trivial-tuple-dispatch-engine> engine>quot
-                ] [
-                    class-hash-dispatch-quot
-                ] if-small? %
-            ] bi
-        ] [ ] make
     ] if ;
 
-: >=-case-quot ( alist -- quot )
+: >=-case-quot ( default alist -- quot )
-    default get [ drop ] prepend swap
+    [ [ drop ] prepend ] dip
     [
         [ [ dup ] swap [ fixnum>= ] curry compose ]
         [ [ drop ] prepose ]
@@ -132,31 +123,45 @@ M: echelon-dispatch-engine engine>quot
     ] assoc-map
     alist>quot ;
 
-: tuple-layout-echelon% ( -- )
+: simplify-echelon-alist ( default alist -- default' alist' )
+    dup empty? [
+        dup first first 1 <= [
+            nip unclip second swap
+            simplify-echelon-alist
+        ] when
+    ] unless ;
+
+: echelon-case-quot ( alist -- quot )
+    #! We don't have to test for echelon 1 since all tuple
+    #! classes are at least at depth 1 in the inheritance
+    #! hierarchy.
+    default get swap simplify-echelon-alist
     [
-        { tuple } declare
+        [
-        1 slot { tuple-layout } declare
+            picker %
-        5 slot
+            tuple-layout%
-    ] % ; inline
+            tuple-layout-echelon%
+            >=-case-quot %
+        ] [ ] make
+    ] unless-empty ;
 
 M: tuple-dispatch-engine engine>quot
     [
-        picker %
-        tuple-layout-echelon%
         [
             tuple assumed set
-            echelons>> dup empty? [
+            echelons>> unclip-last
-                unclip-last
+            [
                 [
-                    [
+                    engine>quot
-                        engine>quot define-engine-word
+                    over 0 = [
+                        define-engine-word
                         [ remember-engine ] [ 1quotation ] bi
-                        dup default set
+                    ] unless
-                    ] assoc-map
+                    dup default set
-                ]
+                ] assoc-map
-                [ first2 engine>quot 2array ] bi*
+            ]
-                suffix
+            [ first2 engine>quot 2array ] bi*
-            ] unless
+            suffix
         ] with-scope
-        >=-case-quot %
+        echelon-case-quot %
     ] [ ] make ;

core/generic/standard/standard.factor

@@ -60,21 +60,22 @@ ERROR: no-method object generic ;
     [ 1quotation ] [ extra-values \ drop <repetition> ] bi*
     prepend [ ] like ;
 
+: <standard-engine> ( word -- engine )
+    object bootstrap-word assumed set {
+        [ generic set ]
+        [ "engines" word-prop forget-all ]
+        [ V{ } clone "engines" set-word-prop ]
+        [
+            "methods" word-prop
+            [ generic get mangle-method ] assoc-map
+            [ find-default default set ]
+            [ <big-dispatch-engine> ]
+            bi
+        ]
+    } cleave ;
+
 : single-combination ( word -- quot )
-    [
+    [ <standard-engine> engine>quot ] with-scope ;
-        object bootstrap-word assumed set {
-            [ generic set ]
-            [ "engines" word-prop forget-all ]
-            [ V{ } clone "engines" set-word-prop ]
-            [
-                "methods" word-prop
-                [ generic get mangle-method ] assoc-map
-                [ find-default default set ]
-                [ <big-dispatch-engine> ]
-                bi engine>quot
-            ]
-        } cleave
-    ] with-scope ;
 
 ERROR: inconsistent-next-method class generic ;
 

core/io/encodings/encodings.factor

@@ -124,11 +124,11 @@ M: object <encoder> encoder boa ;
 M: encoder stream-write1
     >encoder< encode-char ;
 
-: decoder-write ( string stream encoding -- )
+: encoder-write ( string stream encoding -- )
     [ encode-char ] 2curry each ;
 
 M: encoder stream-write
-    >encoder< decoder-write ;
+    >encoder< encoder-write ;
 
 M: encoder dispose stream>> dispose ;
 

core/kernel/kernel.factor

@@ -167,11 +167,11 @@ GENERIC: boa ( ... class -- tuple )
     compose compose ; inline
 
 ! Booleans
-: not ( obj -- ? ) f t ? ; inline
+: not ( obj -- ? ) [ f ] [ t ] if ; inline
 
 : and ( obj1 obj2 -- ? ) over ? ; inline
 
-: >boolean ( obj -- ? ) t f ? ; inline
+: >boolean ( obj -- ? ) [ t ] [ f ] if ; inline
 
 : or ( obj1 obj2 -- ? ) dupd ? ; inline
 

core/words/words.factor

@@ -204,13 +204,9 @@ GENERIC: reset-word ( word -- )
 
 M: word reset-word
     {
-        "unannotated-def"
+        "unannotated-def" "parsing" "inline" "recursive"
-        "parsing" "inline" "recursive" "foldable" "flushable"
+        "foldable" "flushable" "reading" "writing" "reader"
-        "predicating"
+        "writer" "declared-effect" "delimiter"
-        "reading" "writing"
-        "reader" "writer"
-        "constructing"
-        "declared-effect" "constructor-quot" "delimiter"
     } reset-props ;
 
 GENERIC: subwords ( word -- seq )
@@ -261,12 +257,12 @@ M: word forget*
     dup "forgotten" word-prop [ drop ] [
         [ delete-xref ]
         [ [ name>> ] [ vocabulary>> vocab-words ] bi delete-at ]
-        [ t "forgotten" set-word-prop ]
+        [ [ reset-word ] [ t "forgotten" set-word-prop ] bi ]
         tri
     ] if ;
 
 M: word hashcode*
-    nip 1 slot { fixnum } declare ;
+    nip 1 slot { fixnum } declare ; foldable
 
 M: word literalize <wrapper> ;
 

extra/advice/advice-docs.factor

@@ -0,0 +1,22 @@
+IN: advice
+USING: help.markup help.syntax tools.annotations words ;
+
+HELP: make-advised
+{ $values { "word" "a word to annotate in preparation of advising" } }
+{ $description "Prepares a word for being advised.  This is done by: "
+    { $list
+        { "Annotating it to call the appropriate words before, around, and after the original body " }
+        { "Adding " { $snippet "before" } ", " { $snippet "around" } ", and " { $snippet "after" } " properties, which will contain the advice" }
+        { "Adding an " { $snippet "advised" } "property, which can later be used to determine if a given word is defined (see " { $link advised? } ")" }
+    }
+}
+{ $see-also advised? annotate } ;
+
+HELP: advised?
+{ $values { "word" "a word" } { "?" "t or f, indicating if " { $snippet "word" } " is advised" } }
+{ $description "Determines whether or not the given word has any advice on it." } ;
+
+ARTICLE: "advice" "Advice"
+"Advice is a simple way of adding additition functionality to words by adding 'hooks' to a word, which can act before, after, or around the calling of the word." ;
+
+ABOUT: "advice"

extra/advice/advice-tests.factor

@@ -0,0 +1,40 @@
+! Copyright (C) 2008 James Cash
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel sequences math tools.test advice parser namespaces ;
+IN: advice.tests
+
+[
+: foo "foo" ; 
+\ foo make-advised
+ 
+  { "bar" "foo" } [
+     [ "bar" ] "barify" \ foo advise-before
+     foo ] unit-test
+ 
+  { "bar" "foo" "baz" } [
+      [ "baz" ] "bazify" \ foo advise-after
+      foo ] unit-test
+ 
+  { "foo" "baz" } [
+     "barify" \ foo before remove-advice
+     foo ] unit-test
+ 
+: bar ( a -- b ) 1+ ;
+\ bar make-advised
+
+  { 11 } [
+     [ 2 * ] "double" \ bar advise-before
+     5 bar
+  ] unit-test 
+
+  { 11/3 } [
+      [ 3 / ] "third" \ bar advise-after
+      5 bar
+  ] unit-test
+
+  { -2 } [
+      [ -1 * ad-do-it 3 + ] "frobnobicate" \ bar advise-around
+      5 bar
+  ] unit-test
+ 
+ ] with-scope

extra/advice/advice.factor

@@ -0,0 +1,49 @@
+! Copyright (C) 2008 James Cash
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel sequences symbols fry words assocs tools.annotations coroutines ;
+IN: advice
+
+SYMBOLS: before after around advised ;
+
+<PRIVATE
+: advise ( quot name word loc --  )
+    word-prop set-at ;
+PRIVATE>
+    
+: advise-before ( quot name word --  )
+    before advise ;
+    
+: advise-after ( quot name word --  )
+    after advise ;
+
+: advise-around ( quot name word --  )
+    [ \ coterminate suffix ] 2dip
+    around advise ;
+
+: get-advice ( word type -- seq )
+    word-prop values ;
+
+: call-before ( word --  )
+    before get-advice [ call ] each ;
+
+: call-after ( word --  )
+    after get-advice [ call ] each ;
+
+: call-around ( main word --  )
+    around get-advice [ cocreate ] map tuck 
+    [ [ coresume ] each ] [ call ] [ reverse [ coresume ] each ] tri* ;
+
+: remove-advice ( name word loc --  )
+    word-prop delete-at ;
+
+: ad-do-it ( input -- result )
+    coyield ;
+
+: advised? ( word -- ? )
+    advised word-prop ;
+    
+: make-advised ( word -- )
+    [ dup [ over dup '[ _ call-before _ _ call-around _ call-after ] ] annotate ]
+    [ { before after around } [ H{ } clone swap set-word-prop ] with each ] 
+    [ t advised set-word-prop ] tri ;
+    

extra/advice/authors.txt

@@ -0,0 +1 @@
+James Cash

extra/advice/summary.txt

@@ -0,0 +1 @@
+Implmentation of advice/aspects

extra/advice/tags.txt

@@ -0,0 +1,3 @@
+advice
+aspect
+annotations

extra/benchmark/benchmark.factor

@@ -6,12 +6,12 @@ continuations debugger ;
 IN: benchmark
 
 : run-benchmark ( vocab -- result )
-  [ [ require ] [ [ run ] benchmark ] bi ] curry
+    [ [ require ] [ [ run ] benchmark ] bi ] curry
-  [ error. f ] recover ;
+    [ error. f ] recover ;
 
 : run-benchmarks ( -- assoc )
-  "benchmark" all-child-vocabs-seq
+    "benchmark" all-child-vocabs-seq
-  [ dup run-benchmark ] { } map>assoc ;
+    [ dup run-benchmark ] { } map>assoc ;
 
 : benchmarks. ( assoc -- )
     standard-table-style [

extra/bunny/deploy.factor

@@ -4,7 +4,6 @@ H{
     { deploy-word-defs? f }
     { deploy-reflection 1 }
     { deploy-compiler? t }
-    { deploy-random? f }
     { deploy-c-types? f }
     { deploy-name "Bunny" }
     { deploy-word-props? f }

extra/hello-ui/deploy.factor

@@ -8,7 +8,6 @@ H{
     { deploy-io 2 }
     { deploy-ui? t }
     { "stop-after-last-window?" t }
-    { deploy-random? f }
     { deploy-word-defs? f }
     { deploy-compiler? t }
     { deploy-reflection 1 }

extra/hello-world/deploy.factor

@@ -5,7 +5,6 @@ H{
     { deploy-threads? f }
     { deploy-word-props? f }
     { deploy-reflection 2 }
-    { deploy-random? f }
     { deploy-io 2 }
     { deploy-math? f }
     { deploy-ui? f }

extra/inverse/inverse.factor

@@ -131,6 +131,9 @@ MACRO: undo ( quot -- ) [undo] ;
 \ pick [ >r pick r> =/fail ] define-inverse
 \ tuck [ swapd [ =/fail ] keep ] define-inverse
 
+\ not [ not ] define-inverse
+\ >boolean [ { t f } memq? assure ] define-inverse
+
 \ >r [ r> ] define-inverse
 \ r> [ >r ] define-inverse
 

extra/joystick-demo/deploy.factor

@@ -4,7 +4,6 @@ H{
     { deploy-io 2 }
     { deploy-word-defs? f }
     { deploy-c-types? t }
-    { deploy-random? t }
     { deploy-word-props? f }
     { deploy-reflection 1 }
     { deploy-threads? t }

extra/lisp/lisp-docs.factor

@@ -1,5 +1,12 @@
 IN: lisp
 USING: help.markup help.syntax ;
+HELP: <LISP
+{ $description "parsing word which converts the lisp code between <LISP and LISP> into factor quotations and calls it" }
+{ $see-also lisp-string>factor } ;
+
+HELP: lisp-string>factor
+{ $values { "str"  "a string of lisp code" } { "quot" "the quotation the lisp compiles into" } }
+{ $description "Turns a string of lisp into a factor quotation" } ;
 
 ARTICLE: "lisp" "Lisp in Factor"
 "This is a simple implementation of a Lisp dialect, which somewhat resembles Scheme." $nl

extra/lisp/lisp-tests.factor

@@ -84,4 +84,11 @@ IN: lisp.test
         <LISP ((lambda (x y) (if x (+ 1 y) (+ 2 y))) #t 3) LISP>
     ] unit-test
     
+    { { 3 3 4 } } [
+        <LISP (defun foo (x y &rest z)
+                  (cons (+ x y) z))
+              (foo 1 2 3 4)
+        LISP> cons>seq
+    ] unit-test
+    
 ] with-interactive-vocabs

extra/lisp/lisp.factor

@@ -64,14 +64,9 @@ PRIVATE>
 : macro-expand ( cons -- quot )
     uncons [ list>seq >quotation ] [ lookup-macro ] bi* call call ;
 
-<PRIVATE
-: (expand-macros) ( cons -- cons )
-    [ dup list? [ (expand-macros) dup car lisp-macro? [ macro-expand ] when ] when ] lmap ;
-PRIVATE>
-
 : expand-macros ( cons -- cons )
-    dup list? [ (expand-macros) dup car lisp-macro? [ macro-expand ] when ] when ;
+    dup list? [ [ expand-macros ] lmap dup car lisp-macro? [ macro-expand expand-macros ] when ] when ;
-
+    
 : convert-begin ( cons -- quot )
     cdr [ convert-form ] [ ] lmap-as [ 1 tail* ] [ but-last ] bi
     [ '[ { } _ with-datastack drop ] ] map prepend '[ _ [ call ] each ] ;
@@ -169,15 +164,15 @@ M: no-such-var summary drop "No such variable" ;
 
    "set" "lisp" "define-lisp-var" define-primitive
     
-   "(lambda (&rest xs) xs)" lisp-string>factor first "list" lisp-define
+   "(set 'list (lambda (&rest xs) xs))" lisp-eval
-   "(defmacro setq (var val) (list (quote set) (list (quote quote) var) val))" lisp-eval
+   "(defmacro setq (var val) (list 'set (list 'quote var) val))" lisp-eval
     
    <" (defmacro defun (name vars &rest body)
-        (list (quote setq) name (list (quote lambda) vars body))) "> lisp-eval
+        (list 'setq name (cons 'lambda (cons vars body)))) "> lisp-eval
     
-   "(defmacro if (pred tr fl) (list (quote cond) (list pred tr) (list (quote #t) fl)))" lisp-eval
+   "(defmacro if (pred tr fl) (list 'cond (list pred tr) (list (quote #t) fl)))" lisp-eval
    ;
 
 : <LISP 
-    "LISP>" parse-multiline-string define-lisp-builtins
+    "LISP>" parse-multiline-string "(begin " prepend ")" append define-lisp-builtins
-    lisp-string>factor parsed \ call parsed ; parsing
+    lisp-string>factor parsed \ call parsed ; parsing

extra/lisp/parser/parser-tests.factor

@@ -65,4 +65,16 @@ IN: lisp.parser.tests
    }
 } [
     "(1 (3 4) 2)" lisp-expr
+] unit-test
+    
+{ { T{ lisp-symbol { name "quote" } } { 1 2 3 } } } [
+    "'(1 2 3)" lisp-expr cons>seq
+] unit-test
+    
+{ { T{ lisp-symbol f "quote" } T{ lisp-symbol f "foo" } } } [
+    "'foo" lisp-expr cons>seq
+] unit-test
+    
+{ { 1 2 { T{ lisp-symbol { name "quote" } } { 3 4 } } 5 } } [
+    "(1 2 '(3 4) 5)" lisp-expr cons>seq
 ] unit-test

extra/lisp/parser/parser.factor

@@ -35,5 +35,7 @@ atom         = number
               | identifier
               | string
 s-expression = LPAREN (list-item)* RPAREN                => [[ second seq>cons ]]
-list-item    = _ ( atom | s-expression ) _               => [[ second ]]
+list-item    = _ ( atom | s-expression | quoted ) _      => [[ second ]]
-;EBNF
+quoted       = squote list-item                          => [[ second nil cons "quote" <lisp-symbol> swap cons ]]
+expr         = list-item
+;EBNF