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

basis/bootstrap/compiler/compiler.factor

@@ -60,7 +60,7 @@ nl
 "." write flush
 
 {
-    new-sequence nth push pop peek
+    new-sequence nth push pop peek flip
 } compile-uncompiled
 
 "." write flush

basis/bootstrap/image/image.factor

@@ -23,7 +23,7 @@ IN: bootstrap.image
     os name>> cpu name>> arch ;
 
 : boot-image-name ( arch -- string )
-    "boot." swap ".image" 3append ;
+    "boot." ".image" surround ;
 
 : my-boot-image-name ( -- string )
     my-arch boot-image-name ;
@@ -351,7 +351,12 @@ M: wrapper '
 : pad-bytes ( seq -- newseq )
     dup length bootstrap-cell align 0 pad-right ;
 
+: check-string ( string -- )
+    [ 127 > ] contains?
+    [ "Bootstrap cannot emit non-ASCII strings" throw ] when ;
+
 : emit-string ( string -- ptr )
+    dup check-string
     string type-number object tag-number [
         dup length emit-fixnum
         f ' emit

basis/calendar/calendar-docs.factor

@@ -99,48 +99,6 @@ HELP: seconds-per-year
 { $values { "integer" integer } }
 { $description "Returns the number of seconds in a year averaged over 400 years. Used internally for adding an arbitrary real number of seconds to a timestamp." } ;
 
-HELP: biweekly
-{ $values
-     { "x" number }
-     { "y" number }
-}
-{ $description "Divides a number by the number of two week periods in a year." } ;
-
-HELP: daily-360
-{ $values
-     { "x" number }
-     { "y" number }
-}
-{ $description "Divides a number by the number of days in a 360-day year." } ;
-
-HELP: daily-365
-{ $values
-     { "x" number }
-     { "y" number }
-}
-{ $description "Divides a number by the number of days in a 365-day year." } ;
-
-HELP: monthly
-{ $values
-     { "x" number }
-     { "y" number }
-}
-{ $description "Divides a number by the number of months in a year." } ;
-
-HELP: semimonthly
-{ $values
-     { "x" number }
-     { "y" number }
-}
-{ $description "Divides a number by the number of half-months in a year. Note that biweekly has two more periods than semimonthly." } ;
-
-HELP: weekly
-{ $values
-     { "x" number }
-     { "y" number }
-}
-{ $description "Divides a number by the number of weeks in a year." } ;
-
 HELP: julian-day-number
 { $values { "year" integer } { "month" integer } { "day" integer } { "n" integer } }
 { $description "Calculates the Julian day number from a year, month, and day.  The difference between two Julian day numbers is the number of days that have elapsed between the two corresponding dates." }
@@ -582,8 +540,6 @@ ARTICLE: "calendar" "Calendar"
 { $subsection "years" }
 { $subsection "months" }
 { $subsection "days" }
-"Calculating amounts per period of time:"
-{ $subsection "time-period-calculations" }
 "Meta-data about the calendar:"
 { $subsection "calendar-facts" }
 ;
@@ -670,18 +626,6 @@ ARTICLE: "calendar-facts" "Calendar facts"
 { $subsection day-of-week }
 ;
 
-ARTICLE: "time-period-calculations" "Calculations over periods of time"
-{ $subsection monthly }
-{ $subsection semimonthly }
-{ $subsection biweekly }
-{ $subsection weekly }
-{ $subsection daily-360 }
-{ $subsection daily-365 }
-{ $subsection biweekly }
-{ $subsection biweekly }
-{ $subsection biweekly }
-;
-
 ARTICLE: "years" "Year operations"
 "Leap year predicate:"
 { $subsection leap-year? }

basis/calendar/calendar-tests.factor

@@ -167,5 +167,3 @@ IN: calendar.tests
 [ t ] [ now 50 milliseconds sleep now before? ] unit-test
 [ t ] [ now 50 milliseconds sleep now swap after? ] unit-test
 [ t ] [ now 50 milliseconds sleep now 50 milliseconds sleep now swapd between? ] unit-test
-
-[ 4+1/6 ] [ 100 semimonthly ] unit-test

basis/calendar/calendar.factor

@@ -89,13 +89,6 @@ PRIVATE>
 : minutes-per-year ( -- ratio ) 5259492/10 ; inline
 : seconds-per-year ( -- integer ) 31556952 ; inline
 
-: monthly ( x -- y ) 12 / ; inline
-: semimonthly ( x -- y ) 24 / ; inline
-: biweekly ( x -- y ) 26 / ; inline
-: weekly ( x -- y ) 52 / ; inline
-: daily-360 ( x -- y ) 360 / ; inline
-: daily-365 ( x -- y ) 365 / ; inline
-
 :: julian-day-number ( year month day -- n )
     #! Returns a composite date number
     #! Not valid before year -4800

basis/cocoa/application/application.factor

@@ -27,17 +27,19 @@ IN: cocoa.application
 
 : NSApp ( -- app ) NSApplication -> sharedApplication ;
 
+: NSAnyEventMask ( -- mask ) HEX: ffffffff ; inline
+
 FUNCTION: void NSBeep ( ) ;
 
 : with-cocoa ( quot -- )
     [ NSApp drop call ] with-autorelease-pool ; inline
 
 : next-event ( app -- event )
-    0 f CFRunLoopDefaultMode 1
+    NSAnyEventMask f CFRunLoopDefaultMode 1
     -> nextEventMatchingMask:untilDate:inMode:dequeue: ;
 
 : do-event ( app -- ? )
-    dup next-event [ -> sendEvent: t ] [ drop f ] if* ;
+    dup next-event [ dupd -> sendEvent: -> updateWindows t ] [ drop f ] if* ;
 
 : add-observer ( observer selector name object -- )
     [
@@ -49,14 +51,7 @@ FUNCTION: void NSBeep ( ) ;
     [ NSNotificationCenter -> defaultCenter ] dip
     -> removeObserver: ;
 
-: finish-launching ( -- ) NSApp -> finishLaunching ;
+: cocoa-app ( quot -- ) [ call NSApp -> run ] with-cocoa ; inline
-
-: cocoa-app ( quot -- )
-    [
-        call
-        finish-launching
-        NSApp -> run
-    ] with-cocoa ; inline
 
 : install-delegate ( receiver delegate -- )
     -> alloc -> init -> setDelegate: ;
@@ -81,6 +76,6 @@ M: objc-error summary ( error -- )
     running.app? [
         drop
     ] [
-        "The " swap " requires you to run Factor from an application bundle."
+        "The " " requires you to run Factor from an application bundle."
-        3append throw
+        surround throw
     ] if ;

basis/cocoa/cocoa-tests.factor

@@ -1,7 +1,7 @@
 IN: cocoa.tests
 USING: cocoa cocoa.messages cocoa.subclassing cocoa.types
 compiler kernel namespaces cocoa.classes tools.test memory
-compiler.units ;
+compiler.units math ;
 
 CLASS: {
     { +superclass+ "NSObject" }
@@ -45,3 +45,27 @@ Bar [
 [ 2.0 ] [ "x" get NSRect-y ] unit-test
 [ 101.0 ] [ "x" get NSRect-w ] unit-test
 [ 102.0 ] [ "x" get NSRect-h ] unit-test
+
+! Make sure that we can add methods
+CLASS: {
+    { +superclass+ "NSObject" }
+    { +name+ "Bar" }
+} {
+    "bar"
+    "NSRect"
+    { "id" "SEL" }
+    [ 2drop test-foo "x" get ]
+} {
+    "babb"
+    "int"
+    { "id" "SEL" "int" }
+    [ 2nip sq ]
+} ;
+
+[ 144 ] [
+    Bar [
+        -> alloc -> init
+        dup 12 -> babb
+        swap -> release
+    ] compile-call
+] unit-test

basis/cocoa/messages/messages.factor

@@ -1,11 +1,11 @@
 ! Copyright (C) 2006, 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors alien alien.c-types alien.strings arrays assocs
-combinators compiler compiler.alien kernel math namespaces make
+continuations combinators compiler compiler.alien kernel math
-parser prettyprint prettyprint.sections quotations sequences
+namespaces make parser prettyprint prettyprint.sections
-strings words cocoa.runtime io macros memoize debugger
+quotations sequences strings words cocoa.runtime io macros
-io.encodings.ascii effects libc libc.private parser lexer init
+memoize debugger io.encodings.ascii effects libc libc.private
-core-foundation fry generalizations
+parser lexer init core-foundation fry generalizations
 specialized-arrays.direct.alien ;
 IN: cocoa.messages
 
@@ -85,9 +85,17 @@ MACRO: (send) ( selector super? -- quot )
 \ super-send soft "break-after" set-word-prop
 
 ! Runtime introspection
-: (objc-class) ( string word -- class )
+SYMBOL: class-init-hooks
-    dupd execute
+
-    [ ] [ "No such class: " prepend throw ] ?if ; inline
+class-init-hooks global [ H{ } clone or ] change-at
+
+: (objc-class) ( name word -- class )
+    2dup execute dup [ 2nip ] [
+        drop over class-init-hooks get at [ assert-depth ] when*
+        2dup execute dup [ 2nip ] [
+            2drop "No such class: " prepend throw
+        ] if
+    ] if ; inline
 
 : objc-class ( string -- class )
     \ objc_getClass (objc-class) ;
@@ -221,23 +229,19 @@ assoc-union alien>objc-types set-global
 
 : class-exists? ( string -- class ) objc_getClass >boolean ;
 
-: unless-defined ( class quot -- )
+: define-objc-class-word ( quot name -- )
-    [ class-exists? ] dip unless ; inline
+    [ class-init-hooks get set-at ]
-
-: define-objc-class-word ( name quot -- )
     [
-        over , , \ unless-defined , dup , \ objc-class ,
+        [ "cocoa.classes" create ] [ '[ _ objc-class ] ] bi
-    ] [ ] make [ "cocoa.classes" create ] dip
+        (( -- class )) define-declared
-    (( -- class )) define-declared ;
+    ] bi ;
 
 : import-objc-class ( name quot -- )
-    2dup unless-defined
+    over define-objc-class-word
-    dupd define-objc-class-word
     '[
         _
-        dup
+        [ objc-class register-objc-methods ]
-        objc-class register-objc-methods
+        [ objc-meta-class register-objc-methods ] bi
-        objc-meta-class register-objc-methods
     ] try ;
 
 : root-class ( class -- root )

basis/cocoa/subclassing/subclassing.factor

@@ -1,10 +1,9 @@
-! Copyright (C) 2006, 2008 Slava Pestov
+! Copyright (C) 2006, 2008 Slava Pestov, Joe Groff.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: alien alien.c-types alien.strings arrays assocs
 combinators compiler hashtables kernel libc math namespaces
-parser sequences words cocoa.messages cocoa.runtime
+parser sequences words cocoa.messages cocoa.runtime locals
-compiler.units io.encodings.ascii generalizations
+compiler.units io.encodings.ascii continuations make fry ;
-continuations make ;
 IN: cocoa.subclassing
 
 : init-method ( method -- sel imp types )
@@ -12,22 +11,25 @@ IN: cocoa.subclassing
     [ sel_registerName ] [ execute ] [ ascii string>alien ]
     tri* ;
 
-: throw-if-false ( YES/NO -- )
+: throw-if-false ( obj what -- )
-    zero? [ "Failed to add method or protocol to class" throw ]
+    swap { f 0 } member?
-    when ;
+    [ "Failed to " prepend throw ] [ drop ] if ;
+
+: add-method ( class sel imp types -- )
+    class_addMethod "add method to class" throw-if-false ;
 
 : add-methods ( methods class -- )
-    swap
+    '[ [ _ ] dip init-method add-method ] each ;
-    [ init-method class_addMethod throw-if-false ] with each ;
+
+: add-protocol ( class protocol -- )
+    class_addProtocol "add protocol to class" throw-if-false ;
 
 : add-protocols ( protocols class -- )
-    swap [ objc-protocol class_addProtocol throw-if-false ]
+    '[ [ _ ] dip objc-protocol add-protocol ] each ;
-    with each ;
 
-: (define-objc-class) ( protocols superclass name imeth -- )
+: (define-objc-class) ( imeth protocols superclass name -- )
-    -rot
     [ objc-class ] dip 0 objc_allocateClassPair
-    [ add-methods ] [ add-protocols ] [ objc_registerClassPair ]
+    [ add-protocols ] [ add-methods ] [ objc_registerClassPair ]
     tri ;
 
 : encode-types ( return types -- encoding )
@@ -45,28 +47,19 @@ IN: cocoa.subclassing
         [ first4 prepare-method 3array ] map
     ] with-compilation-unit ;
 
-: types= ( a b -- ? )
+:: (redefine-objc-method) ( class method -- )
-    [ ascii alien>string ] bi@ = ;
+    method init-method [| sel imp types |
-
+        class sel class_getInstanceMethod [
-: (verify-method-type) ( class sel types -- )
+            imp method_setImplementation drop
-    [ class_getInstanceMethod method_getTypeEncoding ]
+        ] [
-    dip types=
+            class sel imp types add-method
-    [ "Objective-C method types cannot be changed once defined" throw ]
+        ] if*
-    unless ;
+    ] call ;
-: verify-method-type ( class sel imp types -- class sel imp types )
-    4 ndup nip (verify-method-type) ;
-
-: (redefine-objc-method) ( class method -- )
-    init-method ! verify-method-type
-    drop
-    [ class_getInstanceMethod ] dip method_setImplementation drop ;
     
 : redefine-objc-methods ( imeth name -- )
     dup class-exists? [
-        objc_getClass swap [ (redefine-objc-method) ] with each
+        objc_getClass '[ [ _ ] dip (redefine-objc-method) ] each
-    ] [
+    ] [ 2drop ] if ;
-        2drop
-    ] if ;
 
 SYMBOL: +name+
 SYMBOL: +protocols+
@@ -76,10 +69,10 @@ SYMBOL: +superclass+
     clone [
         prepare-methods
         +name+ get "cocoa.classes" create drop
-        +name+ get 2dup redefine-objc-methods swap [
+        +name+ get 2dup redefine-objc-methods swap
-            +protocols+ get , +superclass+ get , +name+ get , ,
+        +protocols+ get +superclass+ get +name+ get
-            \ (define-objc-class) ,
+        '[ _ _ _ _ (define-objc-class) ]
-        ] [ ] make import-objc-class
+        import-objc-class
     ] bind ;
 
 : CLASS:

basis/compiler/cfg/alias-analysis/alias-analysis.factor

@@ -1,6 +1,6 @@
 ! Copyright (C) 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: kernel math namespaces assocs hashtables sequences
+USING: kernel math namespaces assocs hashtables sequences arrays
 accessors vectors combinators sets classes compiler.cfg
 compiler.cfg.registers compiler.cfg.instructions
 compiler.cfg.copy-prop ;
@@ -194,6 +194,7 @@ M: ##slot insn-slot# slot>> constant ;
 M: ##slot-imm insn-slot# slot>> ;
 M: ##set-slot insn-slot# slot>> constant ;
 M: ##set-slot-imm insn-slot# slot>> ;
+M: ##alien-global insn-slot# [ library>> ] [ symbol>> ] bi 2array ;
 
 M: ##peek insn-object loc>> class ;
 M: ##replace insn-object loc>> class ;
@@ -201,6 +202,7 @@ M: ##slot insn-object obj>> resolve ;
 M: ##slot-imm insn-object obj>> resolve ;
 M: ##set-slot insn-object obj>> resolve ;
 M: ##set-slot-imm insn-object obj>> resolve ;
+M: ##alien-global insn-object drop \ ##alien-global ;
 
 : init-alias-analysis ( -- )
     H{ } clone histories set
@@ -224,6 +226,9 @@ M: ##load-immediate analyze-aliases*
 M: ##load-indirect analyze-aliases*
     dup dst>> set-heap-ac ;
 
+M: ##alien-global analyze-aliases*
+    dup dst>> set-heap-ac ;
+
 M: ##allot analyze-aliases*
     #! A freshly allocated object is distinct from any other
     #! object.

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

@@ -15,6 +15,7 @@ M: ##dispatch defs-vregs temp>> 1array ;
 M: ##slot defs-vregs dst/tmp-vregs ;
 M: ##set-slot defs-vregs temp>> 1array ;
 M: ##string-nth defs-vregs dst/tmp-vregs ;
+M: ##set-string-nth-fast defs-vregs temp>> 1array ;
 M: ##compare defs-vregs dst/tmp-vregs ;
 M: ##compare-imm defs-vregs dst/tmp-vregs ;
 M: ##compare-float defs-vregs dst/tmp-vregs ;
@@ -31,6 +32,7 @@ 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: ##set-string-nth-fast uses-vregs [ src>> ] [ obj>> ] [ index>> ] tri 3array ;
 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

@@ -39,6 +39,7 @@ IN: compiler.cfg.hats
 : ^^shr-imm ( src1 src2 -- dst ) ^^i2 ##shr-imm ; inline
 : ^^sar-imm ( src1 src2 -- dst ) ^^i2 ##sar-imm ; inline
 : ^^not ( src -- dst ) ^^i1 ##not ; inline
+: ^^log2 ( src -- dst ) ^^i1 ##log2 ; inline
 : ^^bignum>integer ( src -- dst ) ^^i1 i ##bignum>integer ; inline
 : ^^integer>bignum ( src -- dst ) ^^i1 i ##integer>bignum ; inline
 : ^^add-float ( src1 src2 -- dst ) ^^d2 ##add-float ; inline
@@ -65,6 +66,7 @@ IN: compiler.cfg.hats
 : ^^alien-cell ( src -- dst ) ^^i1 ##alien-cell ; inline
 : ^^alien-float ( src -- dst ) ^^d1 ##alien-float ; inline
 : ^^alien-double ( src -- dst ) ^^d1 ##alien-double ; inline
+: ^^alien-global ( symbol library -- dst ) ^^i2 ##alien-global ; inline
 : ^^compare ( src1 src2 cc -- dst ) ^^i3 i ##compare ; inline
 : ^^compare-imm ( src1 src2 cc -- dst ) ^^i3 i ##compare-imm ; inline
 : ^^compare-float ( src1 src2 cc -- dst ) ^^i3 i ##compare-float ; inline

basis/compiler/cfg/instructions/instructions.factor

@@ -73,6 +73,7 @@ INSN: ##set-slot-imm < ##write { obj vreg } { slot integer } { tag integer } ;
 
 ! String element access
 INSN: ##string-nth < ##flushable { obj vreg } { index vreg } { temp vreg } ;
+INSN: ##set-string-nth-fast < ##effect { obj vreg } { index vreg } { temp vreg } ;
 
 ! Integer arithmetic
 INSN: ##add < ##commutative ;
@@ -91,6 +92,7 @@ INSN: ##shl-imm < ##binary-imm ;
 INSN: ##shr-imm < ##binary-imm ;
 INSN: ##sar-imm < ##binary-imm ;
 INSN: ##not < ##unary ;
+INSN: ##log2 < ##unary ;
 
 ! Overflowing arithmetic
 TUPLE: ##fixnum-overflow < insn src1 src2 ;
@@ -160,6 +162,8 @@ INSN: ##set-alien-double < ##alien-setter ;
 INSN: ##allot < ##flushable size class { temp vreg } ;
 INSN: ##write-barrier < ##effect card# table ;
 
+INSN: ##alien-global < ##read symbol library ;
+
 ! FFI
 INSN: ##alien-invoke params ;
 INSN: ##alien-indirect params ;

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

@@ -12,8 +12,7 @@ compiler.cfg.registers ;
 IN: compiler.cfg.intrinsics.fixnum
 
 : emit-both-fixnums? ( -- )
-    D 0 ^^peek
+    2inputs
-    D 1 ^^peek
     ^^or
     tag-mask get ^^and-imm
     0 cc= ^^compare-imm
@@ -54,6 +53,9 @@ IN: compiler.cfg.intrinsics.fixnum
 : emit-fixnum-bitnot ( -- )
     ds-pop ^^not tag-mask get ^^xor-imm ds-push ;
 
+: emit-fixnum-log2 ( -- )
+    ds-pop ^^log2 tag-bits get ^^sub-imm ^^tag-fixnum ds-push ;
+
 : (emit-fixnum*fast) ( -- dst )
     2inputs ^^untag-fixnum ^^mul ;
 

basis/compiler/cfg/intrinsics/intrinsics.factor

@@ -9,6 +9,7 @@ compiler.cfg.intrinsics.allot
 compiler.cfg.intrinsics.fixnum
 compiler.cfg.intrinsics.float
 compiler.cfg.intrinsics.slots
+compiler.cfg.intrinsics.misc
 compiler.cfg.iterator ;
 QUALIFIED: kernel
 QUALIFIED: arrays
@@ -18,11 +19,13 @@ QUALIFIED: slots.private
 QUALIFIED: strings.private
 QUALIFIED: classes.tuple.private
 QUALIFIED: math.private
+QUALIFIED: math.integers.private
 QUALIFIED: alien.accessors
 IN: compiler.cfg.intrinsics
 
 {
     kernel.private:tag
+    kernel.private:getenv
     math.private:both-fixnums?
     math.private:fixnum+
     math.private:fixnum-
@@ -45,6 +48,7 @@ IN: compiler.cfg.intrinsics
     slots.private:slot
     slots.private:set-slot
     strings.private:string-nth
+    strings.private:set-string-nth-fast
     classes.tuple.private:<tuple-boa>
     arrays:<array>
     byte-arrays:<byte-array>
@@ -90,9 +94,13 @@ IN: compiler.cfg.intrinsics
         alien.accessors:set-alien-double
     } [ t "intrinsic" set-word-prop ] each ;
 
+: enable-fixnum-log2 ( -- )
+    \ math.integers.private:fixnum-log2 t "intrinsic" set-word-prop ;
+
 : emit-intrinsic ( node word -- node/f )
     {
         { \ kernel.private:tag [ drop emit-tag iterate-next ] }
+        { \ kernel.private:getenv [ emit-getenv iterate-next ] }
         { \ math.private:both-fixnums? [ drop emit-both-fixnums? iterate-next ] }
         { \ math.private:fixnum+ [ drop [ ##fixnum-add ] [ ##fixnum-add-tail ] emit-fixnum-overflow-op ] }
         { \ math.private:fixnum- [ drop [ ##fixnum-sub ] [ ##fixnum-sub-tail ] emit-fixnum-overflow-op ] }
@@ -104,6 +112,7 @@ IN: compiler.cfg.intrinsics
         { \ math.private:fixnum-bitxor [ [ ^^xor ] [ ^^xor-imm ] emit-fixnum-op iterate-next ] }
         { \ math.private:fixnum-shift-fast [ emit-fixnum-shift-fast iterate-next ] }
         { \ math.private:fixnum-bitnot [ drop emit-fixnum-bitnot iterate-next ] }
+        { \ math.integers.private:fixnum-log2 [ drop emit-fixnum-log2 iterate-next ] }
         { \ math.private:fixnum*fast [ emit-fixnum*fast iterate-next ] }
         { \ math.private:fixnum< [ cc< emit-fixnum-comparison iterate-next ] }
         { \ math.private:fixnum<= [ cc<= emit-fixnum-comparison iterate-next ] }
@@ -126,6 +135,7 @@ IN: compiler.cfg.intrinsics
         { \ slots.private:slot [ emit-slot iterate-next ] }
         { \ slots.private:set-slot [ emit-set-slot iterate-next ] }
         { \ strings.private:string-nth [ drop emit-string-nth iterate-next ] }
+        { \ strings.private:set-string-nth-fast [ drop emit-set-string-nth-fast iterate-next ] }
         { \ classes.tuple.private:<tuple-boa> [ emit-<tuple-boa> iterate-next ] }
         { \ arrays:<array> [ emit-<array> iterate-next ] }
         { \ byte-arrays:<byte-array> [ emit-<byte-array> iterate-next ] }

basis/compiler/cfg/intrinsics/misc/misc.factor

@@ -0,0 +1,16 @@
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: namespaces layouts sequences kernel
+accessors compiler.tree.propagation.info
+compiler.cfg.stacks compiler.cfg.hats
+compiler.cfg.instructions compiler.cfg.utilities ;
+IN: compiler.cfg.intrinsics.misc
+
+: emit-tag ( -- )
+    ds-pop tag-mask get ^^and-imm ^^tag-fixnum ds-push ;
+
+: emit-getenv ( node -- )
+    "userenv" f ^^alien-global
+    swap node-input-infos first literal>>
+    [ ds-drop 0 ^^slot-imm ] [ ds-pop ^^offset>slot 0 ^^slot ] if*
+    ds-push ;

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

@@ -6,9 +6,6 @@ compiler.cfg.stacks compiler.cfg.hats compiler.cfg.instructions
 compiler.cfg.utilities ;
 IN: compiler.cfg.intrinsics.slots
 
-: emit-tag ( -- )
-    ds-pop tag-mask get ^^and-imm ^^tag-fixnum ds-push ;
-
 : value-tag ( info -- n ) class>> class-tag ; inline
 
 : (emit-slot) ( infos -- dst )
@@ -54,3 +51,7 @@ IN: compiler.cfg.intrinsics.slots
 
 : emit-string-nth ( -- )
     2inputs swap ^^untag-fixnum ^^string-nth ^^tag-fixnum ds-push ;
+
+: emit-set-string-nth-fast ( -- )
+    3inputs [ ^^untag-fixnum ] [ ^^untag-fixnum ] [ ] tri*
+    swap i ##set-string-nth-fast ;

basis/compiler/cfg/two-operand/two-operand.factor

@@ -1,6 +1,6 @@
 ! Copyright (C) 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: accessors arrays kernel sequences sequences.deep
+USING: accessors arrays kernel sequences compiler.utilities
 compiler.cfg.instructions cpu.architecture ;
 IN: compiler.cfg.two-operand
 
@@ -55,6 +55,6 @@ M: insn convert-two-operand* ;
 : convert-two-operand ( mr -- mr' )
     [
         two-operand? [
-            [ convert-two-operand* ] map flatten
+            [ convert-two-operand* ] map-flat
         ] when
     ] change-instructions ;

basis/compiler/codegen/codegen.factor

@@ -131,6 +131,14 @@ M: ##string-nth generate-insn
         [ temp>> register ]
     } cleave %string-nth ;
 
+M: ##set-string-nth-fast generate-insn
+    {
+        [ src>> register ]
+        [ obj>> register ]
+        [ index>> register ]
+        [ temp>> register ]
+    } cleave %set-string-nth-fast ;
+
 : dst/src ( insn -- dst src )
     [ dst>> register ] [ src>> register ] bi ; inline
 
@@ -155,6 +163,7 @@ M: ##shl-imm generate-insn dst/src1/src2 %shl-imm ;
 M: ##shr-imm generate-insn dst/src1/src2 %shr-imm ;
 M: ##sar-imm generate-insn dst/src1/src2 %sar-imm ;
 M: ##not     generate-insn dst/src       %not     ;
+M: ##log2    generate-insn dst/src       %log2    ;
 
 : src1/src2 ( insn -- src1 src2 )
     [ src1>> register ] [ src2>> register ] bi ; inline
@@ -228,6 +237,10 @@ M: _gc generate-insn drop %gc ;
 
 M: ##loop-entry generate-insn drop %loop-entry ;
 
+M: ##alien-global generate-insn
+    [ dst>> register ] [ symbol>> ] [ library>> ] tri
+    %alien-global ;
+
 ! ##alien-invoke
 GENERIC: reg-size ( register-class -- n )
 
@@ -443,7 +456,7 @@ M: ##alien-indirect generate-insn
 
 TUPLE: callback-context ;
 
-: current-callback 2 getenv ;
+: current-callback ( -- id ) 2 getenv ;
 
 : wait-to-return ( token -- )
     dup current-callback eq? [

basis/compiler/codegen/fixup/fixup.factor

@@ -9,7 +9,7 @@ IN: compiler.codegen.fixup
 
 GENERIC: fixup* ( obj -- )
 
-: code-format 22 getenv ;
+: code-format ( -- n ) 22 getenv ;
 
 : compiled-offset ( -- n ) building get length code-format * ;
 

basis/compiler/tests/optimizer.factor

@@ -375,3 +375,9 @@ DEFER: loop-bbb
 : loop-ccc ( -- ) loop-bbb ;
 
 [ 0 ] [ 0 counter set loop-ccc counter get ] unit-test
+
+! Type inference issue
+[ 4 3 ] [
+    1 >bignum 2 >bignum
+    [ { bignum integer } declare [ shift ] keep 1+ ] compile-call
+] unit-test

basis/compiler/tree/cleanup/cleanup.factor

@@ -1,10 +1,11 @@
 ! Copyright (C) 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: kernel accessors sequences sequences.deep combinators fry
+USING: kernel accessors sequences combinators fry
 classes.algebra namespaces assocs words math math.private
 math.partial-dispatch math.intervals classes classes.tuple
 classes.tuple.private layouts definitions stack-checker.state
 stack-checker.branches
+compiler.utilities
 compiler.tree
 compiler.tree.combinators
 compiler.tree.propagation.info
@@ -33,7 +34,7 @@ GENERIC: cleanup* ( node -- node/nodes )
 : cleanup ( nodes -- nodes' )
     #! We don't recurse into children here, instead the methods
     #! do it since the logic is a bit more involved
-    [ cleanup* ] map flatten ;
+    [ cleanup* ] map-flat ;
 
 : cleanup-folding? ( #call -- ? )
     node-output-infos

basis/compiler/tree/combinators/combinators.factor

@@ -1,7 +1,8 @@
 ! Copyright (C) 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: assocs fry kernel accessors sequences sequences.deep arrays
+USING: assocs fry kernel accessors sequences compiler.utilities
-stack-checker.inlining namespaces compiler.tree ;
+arrays stack-checker.inlining namespaces compiler.tree
+math.order ;
 IN: compiler.tree.combinators
 
 : each-node ( nodes quot: ( node -- ) -- )
@@ -27,7 +28,7 @@ IN: compiler.tree.combinators
                 [ _ map-nodes ] change-child
             ] when
         ] if
-    ] map flatten ; inline recursive
+    ] map-flat ; inline recursive
 
 : contains-node? ( nodes quot: ( node -- ? ) -- ? )
     dup dup '[
@@ -48,12 +49,6 @@ IN: compiler.tree.combinators
 : sift-children ( seq flags -- seq' )
     zip [ nip ] assoc-filter keys ;
 
-: (3each) [ 3array flip ] dip '[ first3 @ ] ; inline
-
-: 3each ( seq1 seq2 seq3 quot -- seq ) (3each) each ; inline
-
-: 3map ( seq1 seq2 seq3 quot -- seq ) (3each) map ; inline
-
 : until-fixed-point ( #recursive quot: ( node -- ) -- )
     over label>> t >>fixed-point drop
     [ with-scope ] 2keep

basis/compiler/tree/dead-code/liveness/liveness.factor

@@ -1,7 +1,7 @@
 ! Copyright (C) 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: fry accessors namespaces assocs deques search-deques
-dlists kernel sequences sequences.deep words sets
+dlists kernel sequences compiler.utilities words sets
 stack-checker.branches compiler.tree compiler.tree.def-use
 compiler.tree.combinators ;
 IN: compiler.tree.dead-code.liveness
@@ -49,4 +49,4 @@ GENERIC: remove-dead-code* ( node -- node' )
 M: node remove-dead-code* ;
 
 : (remove-dead-code) ( nodes -- nodes' )
-    [ remove-dead-code* ] map flatten ;
+    [ remove-dead-code* ] map-flat ;

basis/compiler/tree/def-use/simplified/simplified.factor

@@ -1,6 +1,6 @@
 ! Copyright (C) 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: sequences sequences.deep kernel
+USING: sequences kernel fry vectors
 compiler.tree compiler.tree.def-use ;
 IN: compiler.tree.def-use.simplified
 
@@ -9,8 +9,6 @@ IN: compiler.tree.def-use.simplified
 ! A 'real' usage is a usage of a value that is not a #renaming.
 TUPLE: real-usage value node ;
 
-GENERIC: actually-used-by* ( value node -- real-usages )
-
 ! Def
 GENERIC: actually-defined-by* ( value node -- real-usage )
 
@@ -25,16 +23,18 @@ M: #return-recursive actually-defined-by* real-usage boa ;
 M: node actually-defined-by* real-usage boa ;
 
 ! Use
-: (actually-used-by) ( value -- real-usages )
+GENERIC# actually-used-by* 1 ( value node accum -- )
-    dup used-by [ actually-used-by* ] with map ;
+
+: (actually-used-by) ( value accum -- )
+    [ [ used-by ] keep ] dip '[ _ swap _ actually-used-by* ] each ;
 
 M: #renaming actually-used-by*
-    inputs/outputs [ indices ] dip nths
+    [ inputs/outputs [ indices ] dip nths ] dip
-    [ (actually-used-by) ] map ;
+    '[ _ (actually-used-by) ] each ;
 
-M: #return-recursive actually-used-by* real-usage boa ;
+M: #return-recursive actually-used-by* [ real-usage boa ] dip push ;
 
-M: node actually-used-by* real-usage boa ;
+M: node actually-used-by* [ real-usage boa ] dip push ;
 
 : actually-used-by ( value -- real-usages )
-    (actually-used-by) flatten ;
+    10 <vector> [ (actually-used-by) ] keep ;

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

@@ -33,4 +33,4 @@ M: #branch escape-analysis*
     2bi ;
 
 M: #phi escape-analysis*
-    [ phi-in-d>> <flipped> ] [ out-d>> ] bi merge-allocations ;
+    [ phi-in-d>> flip ] [ out-d>> ] bi merge-allocations ;

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

@@ -0,0 +1,23 @@
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: classes classes.tuple math math.private accessors
+combinators kernel compiler.tree compiler.tree.combinators
+compiler.tree.propagation.info ;
+IN: compiler.tree.escape-analysis.check
+
+GENERIC: run-escape-analysis* ( node -- ? )
+
+M: #push run-escape-analysis*
+    literal>> [ class immutable-tuple-class? ] [ complex? ] bi or ;
+
+M: #call run-escape-analysis*
+    {
+        { [ dup word>> \ <complex> eq? ] [ t ] }
+        { [ dup immutable-tuple-boa? ] [ t ] }
+        [ f ] 
+    } cond nip ;
+
+M: node run-escape-analysis* drop f ;
+
+: run-escape-analysis? ( nodes -- ? )
+    [ run-escape-analysis* ] contains-node? ;

basis/compiler/tree/finalization/finalization.factor

@@ -1,6 +1,7 @@
 ! Copyright (C) 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: kernel accessors sequences words memoize classes.builtin
+USING: kernel accessors sequences words memoize combinators
+classes classes.builtin classes.tuple math.partial-dispatch
 fry assocs
 compiler.tree
 compiler.tree.combinators
@@ -12,7 +13,7 @@ IN: compiler.tree.finalization
 ! See the comment in compiler.tree.late-optimizations.
 
 ! This pass runs after propagation, so that it can expand
-! built-in type predicates; these cannot be expanded before
+! type predicates; these cannot be expanded before
 ! propagation since we need to see 'fixnum?' instead of
 ! 'tag 0 eq?' and so on, for semantic reasoning.
 
@@ -33,16 +34,24 @@ M: #shuffle finalize*
     [ [ in-r>> ] [ out-r>> ] [ mapping>> ] tri '[ _ at ] map sequence= ]
     bi and [ drop f ] when ;
 
-: builtin-predicate? ( #call -- ? )
+MEMO: cached-expansion ( word -- nodes )
-    word>> "predicating" word-prop builtin-class? ;
-
-MEMO: builtin-predicate-expansion ( word -- nodes )
     def>> splice-final ;
 
-: expand-builtin-predicate ( #call -- nodes )
+GENERIC: finalize-word ( #call word -- nodes )
-    word>> builtin-predicate-expansion ;
+
+M: predicate finalize-word
+    "predicating" word-prop {
+        { [ dup builtin-class? ] [ drop word>> cached-expansion ] }
+        { [ dup tuple-class? ] [ drop word>> def>> splice-final ] }
+        [ drop ]
+    } cond ;
+
+! M: math-partial finalize-word
+!     dup primitive? [ drop ] [ nip cached-expansion ] if ;
+
+M: word finalize-word drop ;
 
 M: #call finalize*
-    dup builtin-predicate? [ expand-builtin-predicate ] when ;
+    dup word>> finalize-word ;
 
 M: node finalize* ;

basis/compiler/tree/normalization/normalization.factor

@@ -1,10 +1,11 @@
 ! Copyright (C) 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: fry namespaces sequences math accessors kernel arrays
-combinators sequences.deep assocs
+combinators compiler.utilities assocs
 stack-checker.backend
 stack-checker.branches
 stack-checker.inlining
+compiler.utilities
 compiler.tree
 compiler.tree.combinators
 compiler.tree.normalization.introductions
@@ -46,7 +47,7 @@ M: #branch normalize*
     [
         [
             [
-                [ normalize* ] map flatten
+                [ normalize* ] map-flat
                 introduction-stack get
                 2array
             ] with-scope
@@ -70,7 +71,7 @@ M: #phi normalize*
 
 : (normalize) ( nodes introductions -- nodes )
     introduction-stack [
-        [ normalize* ] map flatten
+        [ normalize* ] map-flat
     ] with-variable ;
 
 M: #recursive normalize*

basis/compiler/tree/optimizer/optimizer.factor

@@ -6,6 +6,7 @@ compiler.tree.normalization
 compiler.tree.propagation
 compiler.tree.cleanup
 compiler.tree.escape-analysis
+compiler.tree.escape-analysis.check
 compiler.tree.tuple-unboxing
 compiler.tree.identities
 compiler.tree.def-use
@@ -22,8 +23,10 @@ SYMBOL: check-optimizer?
     normalize
     propagate
     cleanup
+    dup run-escape-analysis? [
         escape-analysis
         unbox-tuples
+    ] when
     apply-identities
     compute-def-use
     remove-dead-code

basis/compiler/tree/propagation/branches/branches.factor

@@ -3,6 +3,7 @@
 USING: fry kernel sequences assocs accessors namespaces
 math.intervals arrays classes.algebra combinators columns
 stack-checker.branches
+compiler.utilities
 compiler.tree
 compiler.tree.combinators
 compiler.tree.propagation.info
@@ -78,7 +79,7 @@ SYMBOL: condition-value
 
 M: #phi propagate-before ( #phi -- )
     [ annotate-phi-inputs ]
-    [ [ phi-info-d>> <flipped> ] [ out-d>> ] bi merge-value-infos ]
+    [ [ phi-info-d>> flip ] [ out-d>> ] bi merge-value-infos ]
     bi ;
 
 : branch-phi-constraints ( output values booleans -- )
@@ -137,8 +138,8 @@ M: #phi propagate-before ( #phi -- )
 M: #phi propagate-after ( #phi -- )
     condition-value get [
         [ out-d>> ]
-        [ phi-in-d>> <flipped> ]
+        [ phi-in-d>> flip ]
-        [ phi-info-d>> <flipped> ] tri
+        [ phi-info-d>> flip ] tri
         [
             [ possible-boolean-values ] map
             branch-phi-constraints

basis/compiler/tree/propagation/copy/copy.factor

@@ -49,7 +49,7 @@ M: #renaming compute-copy-equiv* inputs/outputs are-copies-of ;
     ] 2each ;
 
 M: #phi compute-copy-equiv*
-    [ phi-in-d>> <flipped> ] [ out-d>> ] bi compute-phi-equiv ;
+    [ phi-in-d>> flip ] [ out-d>> ] bi compute-phi-equiv ;
 
 M: node compute-copy-equiv* drop ;
 

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

@@ -128,8 +128,8 @@ DEFER: (flat-length)
     45 node-count get [-] 8 /i ;
 
 : body-length-bias ( word -- n )
-    [ flat-length ] [ inlining-count get at 0 or 2/ 1+ ] bi *
+    [ flat-length ] [ inlining-count get at 0 or ] bi
-    24 swap [-] 4 /i ;
+    over 2 <= [ drop ] [ 2/ 1+ * ] if 24 swap [-] 4 /i ;
 
 : inlining-rank ( #call word -- n )
     [ classes-known? 2 0 ? ]
@@ -184,7 +184,7 @@ SYMBOL: history
     over in-d>> second value-info literal>> dup class?
     [ "predicate" word-prop '[ drop @ ] inline-word-def ] [ 3drop f ] if ;
 
-: do-inlining ( #call word -- ? )
+: (do-inlining) ( #call word -- ? )
     #! If the generic was defined in an outer compilation unit,
     #! then it doesn't have a definition yet; the definition
     #! is built at the end of the compilation unit. We do not
@@ -195,7 +195,6 @@ SYMBOL: history
     #! discouraged, but it should still work.)
     {
         { [ dup deferred? ] [ 2drop f ] }
-        { [ dup custom-inlining? ] [ inline-custom ] }
         { [ dup \ instance? eq? ] [ inline-instance-check ] }
         { [ dup always-inline-word? ] [ inline-word ] }
         { [ dup standard-generic? ] [ inline-standard-method ] }
@@ -203,3 +202,10 @@ SYMBOL: history
         { [ dup method-body? ] [ inline-method-body ] }
         [ 2drop f ]
     } cond ;
+
+: do-inlining ( #call word -- ? )
+    #! Note the logic here: if there's a custom inlining hook,
+    #! it is permitted to return f, which means that we try the
+    #! normal inlining heuristic.
+    dup custom-inlining? [ 2dup inline-custom ] [ f ] if
+    [ 2drop t ] [ (do-inlining) ] if ;

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

@@ -1,11 +1,12 @@
 ! Copyright (C) 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: kernel effects accessors math math.private math.libm
+USING: kernel effects accessors math math.private
-math.partial-dispatch math.intervals math.parser math.order
+math.integers.private math.partial-dispatch math.intervals
-layouts words sequences sequences.private arrays assocs classes
+math.parser math.order layouts words sequences sequences.private
-classes.algebra combinators generic.math splitting fry locals
+arrays assocs classes classes.algebra combinators generic.math
-classes.tuple alien.accessors classes.tuple.private slots.private
+splitting fry locals classes.tuple alien.accessors
-definitions
+classes.tuple.private slots.private definitions strings.private
+vectors hashtables
 stack-checker.state
 compiler.tree.comparisons
 compiler.tree.propagation.info
@@ -76,14 +77,17 @@ most-negative-fixnum most-positive-fixnum [a,b]
         [ rational math-class-max ] dip
     ] unless ;
 
+: ensure-math-class ( class must-be -- class' )
+    [ class<= ] 2keep ? ;
+
 : number-valued ( class interval -- class' interval' )
-    [ number math-class-min ] dip ;
+    [ number ensure-math-class ] dip ;
 
 : integer-valued ( class interval -- class' interval' )
-    [ integer math-class-min ] dip ;
+    [ integer ensure-math-class ] dip ;
 
 : real-valued ( class interval -- class' interval' )
-    [ real math-class-min ] dip ;
+    [ real ensure-math-class ] dip ;
 
 : float-valued ( class interval -- class' interval' )
     over null-class? [
@@ -144,10 +148,9 @@ most-negative-fixnum most-positive-fixnum [a,b]
 comparison-ops
 [ dup '[ _ define-comparison-constraints ] each-derived-op ] each
 
-generic-comparison-ops [
+! generic-comparison-ops [
-    dup specific-comparison
+!     dup specific-comparison define-comparison-constraints
-    '[ _ _ define-comparison-constraints ] each-derived-op
+! ] each
-] each
 
 ! Remove redundant comparisons
 : fold-comparison ( info1 info2 word -- info )
@@ -195,6 +198,11 @@ generic-comparison-ops [
     2bi and maybe-or-never
 ] "outputs" set-word-prop
 
+\ both-fixnums? [
+    [ class>> fixnum classes-intersect? not ] either?
+    f <literal-info> object-info ?
+] "outputs" set-word-prop
+
 {
     { >fixnum fixnum }
     { bignum>fixnum fixnum }
@@ -226,7 +234,7 @@ generic-comparison-ops [
 } [
     [
         in-d>> second value-info >literal<
-        [ power-of-2? [ 1- bitand ] f ? ] when
+        [ dup integer? [ power-of-2? [ 1- bitand ] f ? ] [ drop f ] if ] when
     ] "custom-inlining" set-word-prop
 ] each
 
@@ -243,6 +251,19 @@ generic-comparison-ops [
     ] "custom-inlining" set-word-prop
 ] each
 
+{ numerator denominator }
+[ [ drop integer <class-info> ] "outputs" set-word-prop ] each
+
+{ (log2) fixnum-log2 bignum-log2 } [
+    [
+        [ class>> ] [ interval>> interval-log2 ] bi <class/interval-info>
+    ] "outputs" set-word-prop
+] each
+
+\ string-nth [
+    2drop fixnum 0 23 2^ [a,b] <class/interval-info>
+] "outputs" set-word-prop
+
 {
     alien-signed-1
     alien-unsigned-1
@@ -284,6 +305,15 @@ generic-comparison-ops [
     "outputs" set-word-prop
 ] each
 
+! Generate more efficient code for common idiom
+\ clone [
+    in-d>> first value-info literal>> {
+        { V{ } [ [ drop { } 0 vector boa ] ] }
+        { H{ } [ [ drop hashtable new ] ] }
+        [ drop f ]
+    } case
+] "custom-inlining" set-word-prop
+
 \ slot [
     dup literal?>>
     [ literal>> swap value-info-slot ] [ 2drop object-info ] if

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

@@ -8,7 +8,8 @@ math.functions math.private strings layouts
 compiler.tree.propagation.info compiler.tree.def-use
 compiler.tree.debugger compiler.tree.checker
 slots.private words hashtables classes assocs locals
-specialized-arrays.double system sorting math.libm ;
+specialized-arrays.double system sorting math.libm
+math.intervals ;
 IN: compiler.tree.propagation.tests
 
 \ propagate must-infer
@@ -33,17 +34,57 @@ IN: compiler.tree.propagation.tests
 
 [ V{ fixnum } ] [ [ { fixnum } declare bitnot ] final-classes ] unit-test
 
-[ V{ number } ] [ [ + ] final-classes ] unit-test
+! Test type propagation for math ops
+: cleanup-math-class ( obj -- class )
+    { null fixnum bignum integer ratio rational float real complex number }
+    [ class= ] with find nip ;
 
-[ V{ float } ] [ [ { float integer } declare + ] final-classes ] unit-test
+: final-math-class ( quot -- class )
+    final-classes first cleanup-math-class ;
 
-[ V{ float } ] [ [ /f ] final-classes ] unit-test
+[ number ] [ [ + ] final-math-class ] unit-test
 
-[ V{ integer } ] [ [ /i ] final-classes ] unit-test
+[ bignum ] [ [ { fixnum bignum } declare + ] final-math-class ] unit-test
 
-[ V{ integer } ] [
+[ integer ] [ [ { fixnum integer } declare + ] final-math-class ] unit-test
-    [ { integer } declare bitnot ] final-classes
+
-] unit-test
+[ bignum ] [ [ { integer bignum } declare + ] final-math-class ] unit-test
+
+[ integer ] [ [ { fixnum fixnum } declare + ] final-math-class ] unit-test
+
+[ float ] [ [ { float integer } declare + ] final-math-class ] unit-test
+
+[ float ] [ [ { real float } declare + ] final-math-class ] unit-test
+
+[ float ] [ [ { float real } declare + ] final-math-class ] unit-test
+
+[ rational ] [ [ { ratio ratio } declare + ] final-math-class ] unit-test
+
+[ rational ] [ [ { rational ratio } declare + ] final-math-class ] unit-test
+
+[ number ] [ [ { complex complex } declare + ] final-math-class ] unit-test
+
+[ float ] [ [ /f ] final-math-class ] unit-test
+
+[ float ] [ [ { real real } declare /f ] final-math-class ] unit-test
+
+[ integer ] [ [ /i ] final-math-class ] unit-test
+
+[ integer ] [ [ { integer float } declare /i ] final-math-class ] unit-test
+
+[ integer ] [ [ { float float } declare /i ] final-math-class ] unit-test
+
+[ integer ] [ [ { integer } declare bitnot ] final-math-class ] unit-test
+
+[ null ] [ [ { null null } declare + ] final-math-class ] unit-test
+
+[ null ] [ [ { null fixnum } declare + ] final-math-class ] unit-test
+
+[ float ] [ [ { float fixnum } declare + ] final-math-class ] unit-test
+
+[ bignum ] [ [ { bignum bignum } declare bitxor ] final-math-class ] unit-test
+
+[ float ] [ [ { float float } declare mod ] final-math-class ] unit-test
 
 [ V{ integer } ] [ [ 255 bitand ] final-classes ] unit-test
 
@@ -65,18 +106,6 @@ IN: compiler.tree.propagation.tests
     [ { fixnum } declare 615949 * ] final-classes
 ] unit-test
 
-[ V{ null } ] [
-    [ { null null } declare + ] final-classes
-] unit-test
-
-[ V{ null } ] [
-    [ { null fixnum } declare + ] final-classes
-] unit-test
-
-[ V{ float } ] [
-    [ { float fixnum } declare + ] final-classes
-] unit-test
-
 [ V{ fixnum } ] [
     [ 255 bitand >fixnum 3 bitor ] final-classes
 ] unit-test
@@ -278,14 +307,6 @@ IN: compiler.tree.propagation.tests
     ] final-classes
 ] unit-test
 
-[ V{ float } ] [
-    [ { real float } declare + ] final-classes
-] unit-test
-
-[ V{ float } ] [
-    [ { float real } declare + ] final-classes
-] unit-test
-
 [ V{ fixnum } ] [
     [ { fixnum fixnum } declare 7 bitand neg shift ] final-classes
 ] unit-test
@@ -599,6 +620,26 @@ MIXIN: empty-mixin
 
 [ V{ t } ] [ [ { fixnum } declare 10 mod >float -20 > ] final-literals ] unit-test
 
+[ T{ interval f { 0 t } { 127 t } } ] [
+    [ { integer } declare 127 bitand ] final-info first interval>>
+] unit-test
+
+[ V{ bignum } ] [
+    [ { bignum } declare dup 1- bitxor ] final-classes
+] unit-test
+
+[ V{ bignum integer } ] [
+    [ { bignum integer } declare [ shift ] keep ] final-classes
+] unit-test
+
+[ V{ fixnum } ] [
+    [ { fixnum } declare log2 ] final-classes
+] unit-test
+
+[ V{ word } ] [
+    [ { fixnum } declare log2 0 >= ] final-classes
+] unit-test
+
 ! [ V{ string } ] [
 !     [ dup string? t xor [ "A" throw ] [ ] if ] final-classes
 ! ] unit-test

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

@@ -1,9 +1,10 @@
 ! Copyright (C) 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: namespaces assocs accessors kernel combinators
-classes.algebra sequences sequences.deep slots.private
+classes.algebra sequences slots.private fry vectors
 classes.tuple.private math math.private arrays
 stack-checker.branches
+compiler.utilities
 compiler.tree
 compiler.tree.combinators
 compiler.tree.propagation.info
@@ -21,7 +22,7 @@ GENERIC: unbox-tuples* ( node -- node/nodes )
 : (expand-#push) ( object value -- nodes )
     dup unboxed-allocation dup [
         [ object-slots ] [ drop ] [ ] tri*
-        [ (expand-#push) ] 2map
+        [ (expand-#push) ] 2map-flat
     ] [
         drop #push
     ] if ;
@@ -38,11 +39,16 @@ M: #push unbox-tuples* ( #push -- nodes )
 : unbox-<complex> ( #call -- nodes )
     dup unbox-output? [ drop { } ] when ;
 
-: (flatten-values) ( values -- values' )
+: (flatten-values) ( values accum -- )
-    [ dup unboxed-allocation [ (flatten-values) ] [ ] ?if ] map ;
+    dup '[
+        dup unboxed-allocation
+        [ _ (flatten-values) ] [ _ push ] ?if
+    ] each ;
 
 : flatten-values ( values -- values' )
-    dup empty? [ (flatten-values) flatten ] unless ;
+    dup empty? [
+        10 <vector> [ (flatten-values) ] keep
+    ] unless ;
 
 : prepare-slot-access ( #call -- tuple-values outputs slot-values )
     [ in-d>> flatten-values ]

basis/compiler/utilities/utilities.factor

@@ -0,0 +1,31 @@
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel sequences sequences.private arrays vectors fry
+math.order ;
+IN: compiler.utilities
+
+: flattener ( seq quot -- seq vector quot' )
+    over length <vector> [
+        dup
+        '[
+            @ [
+                dup array?
+                [ _ push-all ] [ _ push ] if
+            ] when*
+        ]
+    ] keep ; inline
+
+: flattening ( seq quot combinator -- seq' )
+    [ flattener ] dip dip { } like ; inline
+
+: map-flat ( seq quot -- seq' ) [ each ] flattening ; inline
+
+: 2map-flat ( seq quot -- seq' ) [ 2each ] flattening ; inline
+
+: (3each) ( seq1 seq2 seq3 quot -- n quot' )
+    [ [ [ length ] tri@ min min ] 3keep ] dip
+    '[ [ _ nth-unsafe ] [ _ nth-unsafe ] [ _ nth-unsafe ] tri @ ] ; inline
+
+: 3each ( seq1 seq2 seq3 quot -- seq ) (3each) each ; inline
+
+: 3map ( seq1 seq2 seq3 quot -- seq ) (3each) map ; inline

basis/concurrency/messaging/messaging-docs.factor

@@ -8,20 +8,20 @@ HELP: send
 { $values { "message" object } 
           { "thread" thread } 
 }
-{ $description "Send the message to the thread by placing it in the threades mailbox. This is an asynchronous operation and will return immediately. The receving thread will act on the message the next time it retrieves that item from its mailbox (usually using the " { $link receive } " word. The message can be any Factor object. For destinations that are instances of remote-thread the message must be a serializable Factor type." } 
+{ $description "Send the message to the thread by placing it in the threads mailbox. This is an asynchronous operation and will return immediately. The receving thread will act on the message the next time it retrieves that item from its mailbox (usually using the " { $link receive } " word. The message can be any Factor object. For destinations that are instances of remote-thread the message must be a serializable Factor type." } 
 { $see-also receive receive-if } ;
 
 HELP: receive
 { $values { "message" object } 
 }
-{ $description "Return a message from the current threades mailbox. If the box is empty, suspend the thread until another thread places an item in the mailbox (usually via the " { $link send } " word." } 
+{ $description "Return a message from the current threads mailbox. If the box is empty, suspend the thread until another thread places an item in the mailbox (usually via the " { $link send } " word." } 
 { $see-also send receive-if } ;
 
 HELP: receive-if
 { $values { "pred" "a predicate with stack effect " { $snippet "( obj -- ? )" } }  
           { "message" object } 
 }
-{ $description "Return the first message from the current threades mailbox that satisfies the predicate. To satisfy the predicate, " { $snippet "pred" } " is called with the item on the stack and the predicate should leave a boolean indicating whether it was satisfied or not. If nothing in the mailbox satisfies the predicate then the thread will block until something does." } 
+{ $description "Return the first message from the current threads mailbox that satisfies the predicate. To satisfy the predicate, " { $snippet "pred" } " is called with the item on the stack and the predicate should leave a boolean indicating whether it was satisfied or not. If nothing in the mailbox satisfies the predicate then the thread will block until something does." } 
 { $see-also send receive } ;
 
 HELP: spawn-linked
@@ -29,7 +29,7 @@ HELP: spawn-linked
           { "name" string }
           { "thread" thread } 
 }
-{ $description "Start a thread which runs the given quotation. If that quotation throws an error which is not caught then the error will get propagated to the thread that spawned it. This can be used to set up 'supervisor' threades that restart child threades that crash due to uncaught errors.\n" } 
+{ $description "Start a thread which runs the given quotation. If that quotation throws an error which is not caught then the error will get propagated to the thread that spawned it. This can be used to set up 'supervisor' threads that restart child threads that crash due to uncaught errors.\n" } 
 { $see-also spawn } ;
 
 ARTICLE: { "concurrency" "messaging" } "Sending and receiving messages"
@@ -64,7 +64,7 @@ ARTICLE: { "concurrency" "synchronous-sends" } "Synchronous sends"
 ARTICLE: { "concurrency" "exceptions" } "Linked exceptions"
 "A thread can handle exceptions using the standard Factor exception handling mechanism. If an exception is uncaught the thread will terminate. For example:" 
 { $code "[ 1 0 / \"This will not print\" print ] \"division-by-zero\" spawn" } 
-"Processes can be linked so that a parent thread can receive the exception that caused the child thread to terminate. In this way 'supervisor' threades can be created that are notified when child threades terminate and possibly restart them."
+"Processes can be linked so that a parent thread can receive the exception that caused the child thread to terminate. In this way 'supervisor' threads can be created that are notified when child threads terminate and possibly restart them."
 { $subsection spawn-linked }
 "This will create a unidirectional link, such that if an uncaught exception causes the child to terminate, the parent thread can catch it:"
 { $code "["
@@ -74,11 +74,11 @@ ARTICLE: { "concurrency" "exceptions" } "Linked exceptions"
 "Exceptions are only raised in the parent when the parent does a " { $link receive } " or " { $link receive-if } ". This is because the exception is sent from the child to the parent as a message." ;
 
 ARTICLE: "concurrency.messaging" "Message-passing concurrency"
-"The " { $vocab-link "concurrency.messaging" } " vocabulary is based upon the style of concurrency used in systems like Erlang and Termite. It is built on top of the standard Factor lightweight thread system."
+"The " { $vocab-link "concurrency.messaging" } " vocabulary is based upon the style of concurrency used in systems like Erlang and Termite. It is built on top of " { $link "threads" } "."
 $nl
-"A concurrency oriented program is one in which multiple threades run simultaneously in a single Factor image or across multiple running Factor instances. The threades can communicate with each other by asynchronous message sends."
+"A concurrency-oriented program is one in which multiple threads run simultaneously in a single Factor image or across multiple running Factor instances. The threads can communicate with each other by asynchronous message sends."
 $nl
-"Although threades can share data via Factor's mutable data structures it is not recommended to mix shared state with message passing as it can lead to confusing code."
+"Although threads can share data via Factor's mutable data structures it is not recommended to mix shared state with message passing as it can lead to confusing code."
 { $subsection { "concurrency" "messaging" } }
 { $subsection { "concurrency" "synchronous-sends" } } 
 { $subsection { "concurrency" "exceptions" } } ;

basis/core-foundation/core-foundation.factor

@@ -16,13 +16,17 @@ TYPEDEF: void* CFStringRef
 TYPEDEF: void* CFURLRef
 TYPEDEF: void* CFUUIDRef
 TYPEDEF: void* CFTypeRef
+TYPEDEF: void* CFFileDescriptorRef
 TYPEDEF: bool Boolean
 TYPEDEF: long CFIndex
 TYPEDEF: int SInt32
 TYPEDEF: uint UInt32
 TYPEDEF: ulong CFTypeID
+TYPEDEF: UInt32 CFOptionFlags
 TYPEDEF: double CFTimeInterval
 TYPEDEF: double CFAbsoluteTime
+TYPEDEF: int CFFileDescriptorNativeDescriptor
+TYPEDEF: void* CFFileDescriptorCallBack
 
 TYPEDEF: int CFNumberType
 : kCFNumberSInt8Type 1 ; inline
@@ -121,18 +125,35 @@ FUNCTION: CFTypeID CFGetTypeID ( CFTypeRef cf ) ;
     ] keep CFRelease ;
 
 GENERIC: <CFNumber> ( number -- alien )
+
 M: integer <CFNumber>
     [ f kCFNumberLongLongType ] dip <longlong> CFNumberCreate ;
+
 M: float <CFNumber>
     [ f kCFNumberDoubleType ] dip <double> CFNumberCreate ;
+
 M: t <CFNumber>
     drop f kCFNumberIntType 1 <int> CFNumberCreate ;
+
 M: f <CFNumber>
     drop f kCFNumberIntType 0 <int> CFNumberCreate ;
 
 : <CFData> ( byte-array -- alien )
     [ f ] dip dup length CFDataCreate ;
 
+FUNCTION: CFFileDescriptorRef CFFileDescriptorCreate (
+    CFAllocatorRef allocator,
+    CFFileDescriptorNativeDescriptor fd,
+    Boolean closeOnInvalidate,
+    CFFileDescriptorCallBack callout, 
+    CFFileDescriptorContext* context
+) ;
+
+FUNCTION: void CFFileDescriptorEnableCallBacks (
+    CFFileDescriptorRef f,
+    CFOptionFlags callBackTypes
+) ;
+
 : load-framework ( name -- )
     dup <CFBundle> [
         CFBundleLoadExecutable drop
@@ -141,8 +162,11 @@ M: f <CFNumber>
     ] ?if ;
 
 TUPLE: CFRelease-destructor alien disposed ;
+
 M: CFRelease-destructor dispose* alien>> CFRelease ;
+
 : &CFRelease ( alien -- alien )
     dup f CFRelease-destructor boa &dispose drop ; inline
+
 : |CFRelease ( alien -- alien )
     dup f CFRelease-destructor boa |dispose drop ; inline

basis/core-foundation/run-loop/run-loop.factor

@@ -10,6 +10,7 @@ IN: core-foundation.run-loop
 : kCFRunLoopRunHandledSource 4 ; inline
 
 TYPEDEF: void* CFRunLoopRef
+TYPEDEF: void* CFRunLoopSourceRef
 
 FUNCTION: CFRunLoopRef CFRunLoopGetMain ( ) ;
 FUNCTION: CFRunLoopRef CFRunLoopGetCurrent ( ) ;
@@ -20,6 +21,18 @@ FUNCTION: SInt32 CFRunLoopRunInMode (
    Boolean returnAfterSourceHandled
 ) ;
 
+FUNCTION: CFRunLoopSourceRef CFFileDescriptorCreateRunLoopSource (
+    CFAllocatorRef allocator,
+    CFFileDescriptorRef f,
+    CFIndex order
+) ;
+
+FUNCTION: void CFRunLoopAddSource (
+   CFRunLoopRef rl,
+   CFRunLoopSourceRef source,
+   CFStringRef mode
+) ;
+
 : CFRunLoopDefaultMode ( -- alien )
     #! Ugly, but we don't have static NSStrings
     \ CFRunLoopDefaultMode get-global dup expired? [

basis/cpu/architecture/architecture.factor

@@ -59,6 +59,7 @@ 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: %set-string-nth-fast cpu ( ch obj index temp -- )
 
 HOOK: %add     cpu ( dst src1 src2 -- )
 HOOK: %add-imm cpu ( dst src1 src2 -- )
@@ -76,6 +77,7 @@ HOOK: %shl-imm cpu ( dst src1 src2 -- )
 HOOK: %shr-imm cpu ( dst src1 src2 -- )
 HOOK: %sar-imm cpu ( dst src1 src2 -- )
 HOOK: %not     cpu ( dst src -- )
+HOOK: %log2    cpu ( dst src -- )
 
 HOOK: %fixnum-add cpu ( src1 src2 -- )
 HOOK: %fixnum-add-tail cpu ( src1 src2 -- )
@@ -119,6 +121,8 @@ HOOK: %set-alien-cell      cpu ( ptr value -- )
 HOOK: %set-alien-float     cpu ( ptr value -- )
 HOOK: %set-alien-double    cpu ( ptr value -- )
 
+HOOK: %alien-global cpu ( dst symbol library -- )
+
 HOOK: %allot cpu ( dst size class temp -- )
 HOOK: %write-barrier cpu ( src card# table -- )
 HOOK: %gc cpu ( -- )

basis/cpu/ppc/bootstrap.factor

@@ -329,14 +329,15 @@ big-endian on
 ! Math
 [
     3 ds-reg 0 LWZ
-    4 ds-reg -4 LWZ
+    ds-reg ds-reg 4 SUBI
+    4 ds-reg 0 LWZ
     3 3 4 OR
     3 3 tag-mask get ANDI
     \ f tag-number 4 LI
     0 3 0 CMPI
     2 BNE
     1 tag-fixnum 4 LI
-    4 ds-reg 4 STWU
+    4 ds-reg 0 STW
 ] f f f \ both-fixnums? define-sub-primitive
 
 : jit-math ( insn -- )

basis/cpu/ppc/ppc.factor

@@ -37,8 +37,8 @@ M: ppc %load-immediate ( reg n -- ) swap LOAD ;
 M: ppc %load-indirect ( reg obj -- )
     [ 0 swap LOAD32 ] [ rc-absolute-ppc-2/2 rel-immediate ] bi* ;
 
-: %load-dlsym ( symbol dll register -- )
+M: ppc %alien-global ( register symbol dll -- )
-    0 swap LOAD32 rc-absolute-ppc-2/2 rel-dlsym ;
+    [ 0 swap LOAD32 ] 2dip rc-absolute-ppc-2/2 rel-dlsym ;
 
 : ds-reg 29 ; inline
 : rs-reg 30 ; inline
@@ -139,17 +139,21 @@ M:: ppc %string-nth ( dst src index temp -- )
         "end" define-label
         temp src index ADD
         dst temp string-offset LBZ
+        0 dst HEX: 80 CMPI
+        "end" get BLT
         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
+        temp temp 7 SLWI
-        dst dst temp OR
+        dst dst temp XOR
         "end" resolve-label
     ] with-scope ;
 
+M:: ppc %set-string-nth-fast ( ch obj index temp -- )
+    temp obj index ADD
+    ch temp string-offset STB ;
+
 M: ppc %add     ADD ;
 M: ppc %add-imm ADDI ;
 M: ppc %sub     swap SUBF ;
@@ -168,7 +172,7 @@ M: ppc %sar-imm SRAWI ;
 M: ppc %not     NOT ;
 
 : %alien-invoke-tail ( func dll -- )
-    scratch-reg %load-dlsym scratch-reg MTCTR BCTR ;
+    [ scratch-reg ] 2dip %alien-global scratch-reg MTCTR BCTR ;
 
 :: exchange-regs ( r1 r2 -- )
     scratch-reg r1 MR
@@ -407,7 +411,7 @@ M: ppc %set-alien-float swap 0 STFS ;
 M: ppc %set-alien-double swap 0 STFD ;
 
 : load-zone-ptr ( reg -- )
-    [ "nursery" f ] dip %load-dlsym ;
+    "nursery" f %alien-global ;
 
 : load-allot-ptr ( nursery-ptr allot-ptr -- )
     [ drop load-zone-ptr ] [ swap 4 LWZ ] 2bi ;
@@ -429,14 +433,11 @@ M:: ppc %allot ( dst size class nursery-ptr -- )
     dst class store-header
     dst class store-tagged ;
 
-: %alien-global ( dst name -- )
-    [ f rot %load-dlsym ] [ drop dup 0 LWZ ] 2bi ;
-
 : load-cards-offset ( dst -- )
-    "cards_offset" %alien-global ;
+    [ "cards_offset" f %alien-global ] [ dup 0 LWZ ] bi ;
 
 : load-decks-offset ( dst -- )
-    "decks_offset" %alien-global ;
+    [ "decks_offset" f %alien-global ] [ dup 0 LWZ ] bi  ;
 
 M:: ppc %write-barrier ( src card# table -- )
     card-mark scratch-reg LI
@@ -623,14 +624,14 @@ M: ppc %prepare-alien-invoke
     #! Save Factor stack pointers in case the C code calls a
     #! callback which does a GC, which must reliably trace
     #! all roots.
-    "stack_chain" f scratch-reg %load-dlsym
+    scratch-reg "stack_chain" f %alien-global
     scratch-reg scratch-reg 0 LWZ
     1 scratch-reg 0 STW
     ds-reg scratch-reg 8 STW
     rs-reg scratch-reg 12 STW ;
 
 M: ppc %alien-invoke ( symbol dll -- )
-    11 %load-dlsym 11 MTLR BLRL ;
+    [ 11 ] 2dip %alien-global 11 MTLR BLRL ;
 
 M: ppc %alien-callback ( quot -- )
     3 swap %load-indirect "c_to_factor" f %alien-invoke ;

basis/cpu/x86/32/32.factor

@@ -44,8 +44,6 @@ M: x86.32 param-reg-2 EDX ;
 
 M: x86.32 reserved-area-size 0 ;
 
-M: x86.32 %alien-global 0 [] MOV rc-absolute-cell rel-dlsym ;
-
 M: x86.32 %alien-invoke (CALL) rel-dlsym ;
 
 M: x86.32 %alien-invoke-tail (JMP) rel-dlsym ;

basis/cpu/x86/64/64.factor

@@ -158,9 +158,6 @@ M: x86.64 %prepare-box-struct ( -- )
 
 M: x86.64 %prepare-var-args RAX RAX XOR ;
 
-M: x86.64 %alien-global
-    [ 0 MOV rc-absolute-cell rel-dlsym ] [ dup [] MOV ] bi ;
-
 M: x86.64 %alien-invoke
     R11 0 MOV
     rc-absolute-cell rel-dlsym

basis/cpu/x86/assembler/assembler.factor

@@ -384,6 +384,8 @@ M: operand CMP OCT: 070 2-operand ;
 
 : XCHG ( dst src -- ) OCT: 207 2-operand ;
 
+: BSR ( dst src -- ) swap { HEX: 0f HEX: bd } (2-operand) ;
+
 : NOT  ( dst -- ) { BIN: 010 t HEX: f7 } 1-operand ;
 : NEG  ( dst -- ) { BIN: 011 t HEX: f7 } 1-operand ;
 : MUL  ( dst -- ) { BIN: 100 t HEX: f7 } 1-operand ;

basis/cpu/x86/bootstrap.factor

@@ -381,8 +381,8 @@ big-endian off
 
 [
     arg0 ds-reg [] MOV
-    arg0 ds-reg bootstrap-cell neg [+] OR
+    ds-reg bootstrap-cell SUB
-    ds-reg bootstrap-cell ADD
+    arg0 ds-reg [] OR
     arg0 tag-mask get AND
     arg0 \ f tag-number MOV
     arg1 1 tag-fixnum MOV

basis/cpu/x86/x86.factor

@@ -5,10 +5,12 @@ 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
 compiler.constants compiler.cfg.registers
-compiler.cfg.instructions compiler.codegen
+compiler.cfg.instructions compiler.cfg.intrinsics
-compiler.codegen.fixup ;
+compiler.codegen compiler.codegen.fixup ;
 IN: cpu.x86
 
+<< enable-fixnum-log2 >>
+
 M: x86 two-operand? t ;
 
 HOOK: temp-reg-1 cpu ( -- reg )
@@ -92,6 +94,7 @@ M: x86 %shl-imm nip SHL ;
 M: x86 %shr-imm nip SHR ;
 M: x86 %sar-imm nip SAR ;
 M: x86 %not     drop NOT ;
+M: x86 %log2    BSR ;
 
 : ?MOV ( dst src -- )
     2dup = [ 2drop ] [ MOV ] if ; inline
@@ -365,23 +368,38 @@ M:: x86 %box-alien ( dst src temp -- )
 M:: x86 %string-nth ( dst src index temp -- )
     "end" define-label
     dst { src index temp } [| new-dst |
+        ! Load the least significant 7 bits into new-dst.
+        ! 8th bit indicates whether we have to load from
+        ! the aux vector or not.
         temp src index [+] LEA
         new-dst 1 small-reg temp string-offset [+] MOV
         new-dst new-dst 1 small-reg MOVZX
+        ! Do we have to look at the aux vector?
+        new-dst HEX: 80 CMP
+        "end" get JL
+        ! Yes, this is a non-ASCII character. Load aux vector
         temp src string-aux-offset [+] MOV
-        temp \ f tag-number CMP
-        "end" get JE
         new-dst temp XCHG
+        ! Compute index
         new-dst index ADD
         new-dst index ADD
+        ! Load high 16 bits
         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 7 SHL
-        new-dst temp OR
+        ! Compute code point
+        new-dst temp XOR
         "end" resolve-label
         dst new-dst ?MOV
     ] with-small-register ;
 
+M:: x86 %set-string-nth-fast ( ch str index temp -- )
+    ch { index str temp } [| new-ch |
+        new-ch ch ?MOV
+        temp str index [+] LEA
+        temp string-offset [+] new-ch 1 small-reg MOV
+    ] with-small-register ;
+
 :: %alien-integer-getter ( dst src size quot -- )
     dst { src } [| new-dst |
         new-dst dup size small-reg dup src [] MOV
@@ -443,19 +461,19 @@ M:: x86 %allot ( dst size class nursery-ptr -- )
     dst class store-tagged
     nursery-ptr size inc-allot-ptr ;
 
-HOOK: %alien-global cpu ( symbol dll register -- )
-
 M:: x86 %write-barrier ( src card# table -- )
     #! Mark the card pointed to by vreg.
     ! Mark the card
     card# src MOV
     card# card-bits SHR
-    "cards_offset" f table %alien-global
+    table "cards_offset" f %alien-global
+    table table [] MOV
     table card# [+] card-mark <byte> MOV
 
     ! Mark the card deck
     card# deck-bits card-bits - SHR
-    "decks_offset" f table %alien-global
+    table "decks_offset" f %alien-global
+    table table [] MOV
     table card# [+] card-mark <byte> MOV ;
 
 M: x86 %gc ( -- )
@@ -470,6 +488,9 @@ M: x86 %gc ( -- )
     "minor_gc" f %alien-invoke
     "end" resolve-label ;
 
+M: x86 %alien-global
+    [ 0 MOV ] 2dip rc-absolute-cell rel-dlsym ;
+
 HOOK: stack-reg cpu ( -- reg )
 
 : decr-stack-reg ( n -- )
@@ -580,7 +601,8 @@ M: x86 %prepare-alien-invoke
     #! Save Factor stack pointers in case the C code calls a
     #! callback which does a GC, which must reliably trace
     #! all roots.
-    "stack_chain" f temp-reg-1 %alien-global
+    temp-reg-1 "stack_chain" f %alien-global
+    temp-reg-1 temp-reg-1 [] MOV
     temp-reg-1 [] stack-reg MOV
     temp-reg-1 [] cell SUB
     temp-reg-1 2 cells [+] ds-reg MOV

basis/db/sqlite/sqlite.factor

@@ -164,7 +164,7 @@ M: sqlite-db <insert-user-assigned-statement> ( tuple -- statement )
 
 M: sqlite-db bind# ( spec obj -- )
     [
-        [ column-name>> ":" swap next-sql-counter 3append dup 0% ]
+        [ column-name>> ":" next-sql-counter surround dup 0% ]
         [ type>> ] bi
     ] dip <literal-bind> 1, ;
 

basis/debugger/debugger.factor

@@ -72,12 +72,6 @@ M: string error. print ;
 : try ( quot -- )
     [ print-error-and-restarts ] recover ;
 
-M: relative-underflow summary
-    drop "Too many items removed from data stack" ;
-
-M: relative-overflow summary
-    drop "Superfluous items pushed to data stack" ;
-
 : expired-error. ( obj -- )
     "Object did not survive image save/load: " write third . ;
 

basis/editors/editpadlite/authors.txt

@@ -0,0 +1,2 @@
+Ryan Murphy
+Doug Coleman

basis/editors/editpadlite/editpadlite-docs.factor

@@ -0,0 +1,7 @@
+USING: help.syntax help.markup ;
+IN: editors.editpadpro
+
+ARTICLE: "editors.editpadpro" "EditPad Pro support"
+"EditPadPro text editor integration on Windows.  Be sure to put EditPadPro in your system path so that it will be found.  Windows only." ;
+
+ABOUT: "editors.editpadpro"

basis/editors/editpadlite/editpadlite.factor

@@ -0,0 +1,16 @@
+USING: definitions kernel parser words sequences math.parser
+namespaces editors io.launcher windows.shell32 io.files
+io.paths.windows strings unicode.case make ;
+IN: editors.editpadlite
+
+: editpadlite-path ( -- path )
+    \ editpadlite-path get-global [
+        "JGsoft" t [ >lower "editpadlite.exe" tail? ] find-in-program-files
+    ] unless* ;
+
+: editpadlite ( file line -- )
+    [
+        editpadlite-path , drop ,
+    ] { } make run-detached drop ;
+
+[ editpadlite ] edit-hook set-global

basis/editors/editpadlite/summary.txt

@@ -0,0 +1 @@
+EditPadLite editor integration

basis/editors/editpadpro/editpadpro-docs.factor

@@ -1,6 +1,7 @@
 USING: help.syntax help.markup ;
+IN: editors.editpadpro
 
-ARTICLE: "editpadpro" "EditPad Pro support"
+ARTICLE: "editors.editpadpro" "EditPad Pro support"
-"Just load this module and you will be able to edit documentation with EditPadPro.  Be sure to put EditPadPro in your system path so that it will be found.  Windows only." ;
+"EditPadPro text editor integration on Windows.  Be sure to put EditPadPro in your system path so that it will be found.  Windows only." ;
 
-ABOUT: "editpadpro"
+ABOUT: "editors.editpadpro"

basis/editors/editpadpro/editpadpro.factor

@@ -1,17 +1,16 @@
 USING: definitions kernel parser words sequences math.parser
 namespaces editors io.launcher windows.shell32 io.files
-io.paths strings unicode.case make ;
+io.paths.windows strings unicode.case make ;
 IN: editors.editpadpro
 
-: editpadpro-path
+: editpadpro-path ( -- path )
     \ editpadpro-path get-global [
-        program-files "JGsoft" append-path
+        "JGsoft" t [ >lower "editpadpro.exe" tail? ] find-in-program-files
-        t [ >lower "editpadpro.exe" tail? ] find-file
     ] unless* ;
 
 : editpadpro ( file line -- )
     [
-        editpadpro-path , "/l" swap number>string append , ,
+        editpadpro-path , number>string "/l" prepend , ,
     ] { } make run-detached drop ;
 
 [ editpadpro ] edit-hook set-global

basis/editors/editplus/editplus.factor

@@ -1,10 +1,10 @@
 USING: editors io.files io.launcher kernel math.parser
-namespaces sequences windows.shell32 make ;
+namespaces sequences windows.shell32 make io.paths.windows ;
 IN: editors.editplus
 
 : editplus-path ( -- path )
     \ editplus-path get-global [
-        program-files "\\EditPlus 2\\editplus.exe" append-path
+        "EditPlus 2" t [ "editplus.exe" tail? ] find-in-program-files
     ] unless* ;
 
 : editplus ( file line -- )

basis/editors/emeditor/emeditor.factor

@@ -1,11 +1,10 @@
-USING: editors hardware-info.windows io.files io.launcher
+USING: editors io.files io.launcher kernel math.parser
-kernel math.parser namespaces sequences windows.shell32
+namespaces sequences windows.shell32 make io.paths.windows ;
-make ;
 IN: editors.emeditor
 
 : emeditor-path ( -- path )
     \ emeditor-path get-global [
-        program-files "\\EmEditor\\EmEditor.exe" append-path
+        "EmEditor" t [ "EmEditor.exe" tail? ] find-in-program-files
     ] unless* ;
 
 : emeditor ( file line -- )

basis/editors/etexteditor/etexteditor.factor

@@ -1,12 +1,12 @@
 ! Copyright (C) 2008 Kibleur Christophe.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: editors io.files io.launcher kernel math.parser
-namespaces sequences windows.shell32 make ;
+namespaces sequences windows.shell32 io.paths.windows make ;
 IN: editors.etexteditor
 
 : etexteditor-path ( -- str )
     \ etexteditor-path get-global [
-        program-files "e\\e.exe" append-path
+        "e" t [ "e.exe" tail? ] find-in-program-files
     ] unless* ;
 
 : etexteditor ( file line -- )

basis/editors/gvim/windows/windows.factor

@@ -1,9 +1,8 @@
 USING: editors.gvim io.files io.windows kernel namespaces
-sequences windows.shell32 io.paths system ;
+sequences windows.shell32 io.paths.windows system ;
 IN: editors.gvim.windows
 
 M: windows gvim-path
     \ gvim-path get-global [
-        program-files "vim" append-path
+        "vim" t [ "gvim.exe" tail? ] find-in-program-files
-        t [ "gvim.exe" tail? ] find-file
     ] unless* ;

basis/editors/notepad2/notepad2.factor

@@ -2,9 +2,9 @@ USING: editors io.files io.launcher kernel math.parser
 namespaces sequences windows.shell32 make ;
 IN: editors.notepad2
 
-: notepad2-path ( -- str )
+: notepad2-path ( -- path )
     \ notepad2-path get-global [
-        program-files "C:\\Windows\\system32\\notepad.exe" append-path
+        "C:\\Windows\\system32\\notepad.exe"
     ] unless* ;
 
 : notepad2 ( file line -- )

basis/editors/notepadpp/notepadpp.factor

@@ -1,10 +1,10 @@
 USING: editors io.files io.launcher kernel math.parser
-namespaces sequences windows.shell32 make ;
+namespaces sequences io.paths.windows make ;
 IN: editors.notepadpp
 
-: notepadpp-path
+: notepadpp-path ( -- path )
     \ notepadpp-path get-global [
-        program-files "notepad++\\notepad++.exe" append-path
+        "notepad++" t [ "notepad++.exe" tail? ] find-in-program-files
     ] unless* ;
 
 : notepadpp ( file line -- )

basis/editors/scite/scite.factor

@@ -1,23 +1,14 @@
-! Basic SciTE integration for Factor.
+! Copyright (C) 2007 Clemens F. Hofreither.
-!
+! See http://factorcode.org/license.txt for BSD license.
-! By Clemens F. Hofreither, 2007.
 ! clemens.hofreither@gmx.net
-!
+USING: io.files io.launcher kernel namespaces io.paths.windows
-! In your .factor-rc or .factor-boot-rc,
+math math.parser editors sequences make unicode.case ;
-! require this module and set the scite-path
-! variable to point to your executable,
-! if not on the path.
-!
-USING: io.files io.launcher kernel namespaces math
-math.parser editors sequences windows.shell32 make ;
 IN: editors.scite
 
 : scite-path ( -- path )
     \ scite-path get-global [
-        program-files "ScITE Source Code Editor\\SciTE.exe" append-path
+        "Scintilla Text Editor" t
-        dup exists? [
+        [ >lower "scite.exe" tail? ] find-in-program-files
-            drop program-files "wscite\\SciTE.exe" append-path
-        ] unless
     ] unless* ;
 
 : scite-command ( file line -- cmd )
@@ -25,7 +16,7 @@ IN: editors.scite
     [
         scite-path ,
         ,
-    "-goto:" swap number>string append ,
+        number>string "-goto:" prepend ,
     ] { } make ;
 
 : scite-location ( file line -- )

basis/editors/scite/summary.txt

@@ -1 +1 @@
-SciTE editor integration
+Scintilla text editor (SciTE) integration

basis/editors/ted-notepad/ted-notepad.factor

@@ -1,15 +1,16 @@
 USING: editors io.files io.launcher kernel math.parser
-namespaces sequences windows.shell32 make ;
+namespaces sequences io.paths.windows make ;
 IN: editors.ted-notepad
 
-: ted-notepad-path
+: ted-notepad-path ( -- path )
     \ ted-notepad-path get-global [
-        program-files "\\TED Notepad\\TedNPad.exe" append-path
+        "TED Notepad" t [ "TedNPad.exe" tail? ] find-in-program-files
     ] unless* ;
 
 : ted-notepad ( file line -- )
     [
-        ted-notepad-path , "/l" swap number>string append , ,
+        ted-notepad-path ,
+        number>string "/l" prepend , ,
     ] { } make run-detached drop ;
 
 [ ted-notepad ] edit-hook set-global

basis/editors/textedit/textedit.factor

@@ -1,6 +1,5 @@
 USING: definitions io.launcher kernel math math.parser parser
 namespaces prettyprint editors make ;
-
 IN: editors.textedit
 
 : textedit-location ( file line -- )
@@ -9,5 +8,3 @@ IN: editors.textedit
     try-process ;
 
 [ textedit-location ] edit-hook set-global
-
-

basis/editors/ultraedit/ultraedit.factor

@@ -1,11 +1,10 @@
 USING: editors io.files io.launcher kernel math.parser
-namespaces sequences windows.shell32 wne ;
+namespaces sequences io.paths.windows make ;
 IN: editors.ultraedit
 
 : ultraedit-path ( -- path )
     \ ultraedit-path get-global [
-        program-files
+        "IDM Computer Solutions" t [ "uedit32.exe" tail? ] find-in-program-files
-        "IDM Computer Solutions\\UltraEdit-32\\uedit32.exe" append-path
     ] unless* ;
 
 : ultraedit ( file line -- )

basis/editors/wordpad/wordpad.factor

@@ -1,14 +1,14 @@
-USING: editors hardware-info.windows io.launcher kernel
+USING: editors io.launcher kernel io.paths.windows
-math.parser namespaces sequences windows.shell32 io.files
+math.parser namespaces sequences io.files arrays ;
-arrays ;
 IN: editors.wordpad
 
 : wordpad-path ( -- path )
     \ wordpad-path get [
-        program-files "Windows NT\\Accessories\\wordpad.exe" append-path
+        "Windows NT\\Accessories" t
+        [ "wordpad.exe" tail? ] find-in-program-files
     ] unless* ;
 
 : wordpad ( file line -- )
-    drop wordpad-path swap 2array dup . run-detached drop ;
+    drop wordpad-path swap 2array run-detached drop ;
 
 [ wordpad ] edit-hook set-global

basis/grouping/grouping-tests.factor

@@ -5,7 +5,7 @@ IN: grouping.tests
 
 [ { "hell" "o wo" "rld" } ] [ "hello world" 4 group ] unit-test
 
-[ { V{ "a" "b" } V{ f f } } ] [
+[ { V{ "a" "b" } V{ 0 0 } } ] [
     V{ "a" "b" } clone 2 <groups>
     2 over set-length
     >array

basis/help/lint/lint.factor

@@ -67,7 +67,7 @@ IN: help.lint
         vocab-exists? [ "$vocab-link to non-existent vocabulary" throw ] unless
     ] each ;
 
-: check-rendering ( word element -- )
+: check-rendering ( element -- )
     [ print-topic ] with-string-writer drop ;
 
 : all-word-help ( words -- seq )
@@ -87,13 +87,14 @@ M: help-error error.
 : check-word ( word -- )
     dup word-help [
         [
-            dup word-help [
+            dup word-help '[
-                2dup check-examples
+                _ _ {
-                2dup check-values
+                    [ check-examples ]
-                2dup check-see-also
+                    [ check-values ]
-                2dup nip check-modules
+                    [ check-see-also ]
-                2dup drop check-rendering
+                    [ [ check-rendering ] [ check-modules ] bi* ]
-            ] assert-depth 2drop
+                } 2cleave
+            ] assert-depth
         ] check-something
     ] [ drop ] if ;
 
@@ -101,9 +102,9 @@ M: help-error error.
 
 : check-article ( article -- )
     [
-        dup article-content [
+        dup article-content
-            2dup check-modules check-rendering
+        '[ _ check-rendering _ check-modules ]
-        ] assert-depth 2drop
+        assert-depth
     ] check-something ;
 
 : files>vocabs ( -- assoc )

basis/html/elements/elements.factor

@@ -26,7 +26,7 @@ SYMBOL: html
     #! dynamically creating words.
     [ elements-vocab create ] 2dip define-declared ;
 
-: <foo> ( str -- <str> ) "<" swap ">" 3append ;
+: <foo> ( str -- <str> ) "<" ">" surround ;
 
 : def-for-html-word-<foo> ( name -- )
     #! Return the name and code for the <foo> patterned
@@ -49,14 +49,14 @@ SYMBOL: html
     #! word.
     foo> [ ">" write-html ] (( -- )) html-word ;
 
-: </foo> ( str -- </str> ) "</" swap ">" 3append ;
+: </foo> ( str -- </str> ) "</" ">" surround ;
 
 : def-for-html-word-</foo> ( name -- )
     #! Return the name and code for the </foo> patterned
     #! word.
     </foo> dup '[ _ write-html ] (( -- )) html-word ;
 
-: <foo/> ( str -- <str/> ) "<" swap "/>" 3append ;
+: <foo/> ( str -- <str/> ) "<" "/>" surround ;
 
 : def-for-html-word-<foo/> ( name -- )
     #! Return the name and code for the <foo/> patterned

basis/html/templates/chloe/chloe.factor

@@ -4,6 +4,7 @@ USING: accessors kernel sequences combinators kernel fry
 namespaces make classes.tuple assocs splitting words arrays io
 io.files io.encodings.utf8 io.streams.string unicode.case
 mirrors math urls present multiline quotations xml logging
+continuations
 xml.data
 html.forms
 html.elements

basis/html/templates/chloe/compiler/compiler.factor

@@ -3,7 +3,7 @@
 USING: assocs namespaces make kernel sequences accessors
 combinators strings splitting io io.streams.string present
 xml.writer xml.data xml.entities html.forms
-html.templates html.templates.chloe.syntax ;
+html.templates html.templates.chloe.syntax continuations ;
 IN: html.templates.chloe.compiler
 
 : chloe-attrs-only ( assoc -- assoc' )

basis/io/unix/files/macosx/macosx.factor

@@ -13,7 +13,8 @@ M: macosx file-systems ( -- array )
     f <void*> dup 0 getmntinfo64 dup io-error
     [ *void* ] dip
     "statfs64" heap-size [ * memory>byte-array ] keep group
-    [ [ new-file-system-info ] dip statfs>file-system-info ] map ;
+    [ statfs64-f_mntonname utf8 alien>string file-system-info ] map ;
+    ! [ [ new-file-system-info ] dip statfs>file-system-info ] map ;
 
 M: macosx new-file-system-info macosx-file-system-info new ;
 

basis/io/unix/kqueue/kqueue.factor

@@ -1,11 +1,8 @@
 ! Copyright (C) 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: alien.c-types kernel math math.bitwise namespaces
+USING: accessors alien.c-types combinators io.unix.backend
-locals accessors combinators threads vectors hashtables
+kernel math.bitwise sequences struct-arrays unix unix.kqueue
-sequences assocs continuations sets
+unix.time ;
-unix unix.time unix.kqueue unix.process
-io.ports io.unix.backend io.launcher io.unix.launcher
-io.monitors ;
 IN: io.unix.kqueue
 
 TUPLE: kqueue-mx < mx events monitors ;
@@ -19,131 +16,66 @@ TUPLE: kqueue-mx < mx events monitors ;
     kqueue-mx new-mx
         H{ } clone >>monitors
         kqueue dup io-error >>fd
-        max-events "kevent" <c-array> >>events ;
+        max-events "kevent" <struct-array> >>events ;
 
-GENERIC: io-task-filter ( task -- n )
+: make-kevent ( fd filter flags -- event )
-
-M: input-task io-task-filter drop EVFILT_READ ;
-
-M: output-task io-task-filter drop EVFILT_WRITE ;
-
-GENERIC: io-task-fflags ( task -- n )
-
-M: io-task io-task-fflags drop 0 ;
-
-: make-kevent ( task flags -- event )
     "kevent" <c-object>
-    tuck set-kevent-flags
+    [ set-kevent-flags ] keep
-    over io-task-fd over set-kevent-ident
+    [ set-kevent-filter ] keep
-    over io-task-fflags over set-kevent-fflags
+    [ set-kevent-ident ] keep ;
-    swap io-task-filter over set-kevent-filter ;
 
 : register-kevent ( kevent mx -- )
-    fd>> swap 1 f 0 f kevent
+    fd>> swap 1 f 0 f kevent io-error ;
-    0 < [ err_no ESRCH = [ (io-error) ] unless ] when ;
 
-M: kqueue-mx register-io-task ( task mx -- )
+M: kqueue-mx add-input-callback ( thread fd mx -- )
-    [ >r EV_ADD make-kevent r> register-kevent ]
+    [ call-next-method ] [
-    [ call-next-method ]
+        [ EVFILT_READ { EV_ADD EV_ONESHOT } flags make-kevent ] dip
-    2bi ;
+        register-kevent
+    ] 2bi ;
 
-M: kqueue-mx unregister-io-task ( task mx -- )
+M: kqueue-mx add-output-callback ( thread fd mx -- )
-    [ call-next-method ]
+    [ call-next-method ] [
-    [ >r EV_DELETE make-kevent r> register-kevent ]
+        [ EVFILT_WRITE EV_DELETE make-kevent ] dip
-    2bi ;
+        register-kevent
+    ] 2bi ;
+
+: cancel-input-callbacks ( fd mx -- seq )
+    [
+        [ EVFILT_READ EV_DELETE make-kevent ] dip
+        register-kevent
+    ] [ remove-input-callbacks ] 2bi ;
+
+: cancel-output-callbacks ( fd mx -- seq )
+    [
+        [ EVFILT_WRITE EV_DELETE make-kevent ] dip
+        register-kevent
+    ] [ remove-output-callbacks ] 2bi ;
+
+M: fd cancel-operation ( fd -- )
+    dup disposed>> [ drop ] [
+        fd>>
+        mx get-global
+        [ cancel-input-callbacks [ t swap resume-with ] each ]
+        [ cancel-output-callbacks [ t swap resume-with ] each ]
+        2bi
+    ] if ;
 
 : wait-kevent ( mx timespec -- n )
-    >r [ fd>> f 0 ] keep events>> max-events r> kevent
+    [
+        [ fd>> f 0 ]
+        [ events>> [ underlying>> ] [ length ] bi ] bi
+    ] dip kevent
     dup multiplexer-error ;
 
-:: kevent-read-task ( mx fd kevent -- )
-    mx fd mx reads>> at perform-io-task ;
-
-:: kevent-write-task ( mx fd kevent -- )
-    mx fd mx writes>> at perform-io-task ;
-
-:: kevent-proc-task ( mx pid kevent -- )
-    pid wait-for-pid
-    pid find-process
-    dup [ swap notify-exit ] [ 2drop ] if ;
-
-: parse-action ( mask -- changed )
-    [
-        NOTE_DELETE +remove-file+ ?flag
-        NOTE_WRITE +modify-file+ ?flag
-        NOTE_EXTEND +modify-file+ ?flag
-        NOTE_ATTRIB +modify-file+ ?flag
-        NOTE_RENAME +rename-file+ ?flag
-        NOTE_REVOKE +remove-file+ ?flag
-        drop
-    ] { } make prune ;
-
-:: kevent-vnode-task ( mx kevent fd -- )
-    ""
-    kevent kevent-fflags parse-action
-    fd mx monitors>> at queue-change ;
-
 : handle-kevent ( mx kevent -- )
-    [ ] [ kevent-ident ] [ kevent-filter ] tri {
+    [ kevent-ident swap ] [ kevent-filter ] bi {
-        { [ dup EVFILT_READ = ] [ drop kevent-read-task ] }
+        { EVFILT_READ [ input-available ] }
-        { [ dup EVFILT_WRITE = ] [ drop kevent-write-task ] }
+        { EVFILT_WRITE [ output-available ] }
-        { [ dup EVFILT_PROC = ] [ drop kevent-proc-task ] }
+    } case ;
-        { [ dup EVFILT_VNODE = ] [ drop kevent-vnode-task ] }
-    } cond ;
 
 : handle-kevents ( mx n -- )
-    [ over events>> kevent-nth handle-kevent ] with each ;
+    [ dup events>> ] dip head-slice [ handle-kevent ] with each ;
 
 M: kqueue-mx wait-for-events ( us mx -- )
     swap dup [ make-timespec ] when
     dupd wait-kevent handle-kevents ;
-
-! Procs
-: make-proc-kevent ( pid -- kevent )
-    "kevent" <c-object>
-    tuck set-kevent-ident
-    EV_ADD over set-kevent-flags
-    EVFILT_PROC over set-kevent-filter
-    NOTE_EXIT over set-kevent-fflags ;
-
-: register-pid-task ( pid mx -- )
-    swap make-proc-kevent swap register-kevent ;
-
-! VNodes
-TUPLE: vnode-monitor < monitor fd ;
-
-: vnode-fflags ( -- n )
-    {
-        NOTE_DELETE
-        NOTE_WRITE
-        NOTE_EXTEND
-        NOTE_ATTRIB
-        NOTE_LINK
-        NOTE_RENAME
-        NOTE_REVOKE
-    } flags ;
-
-: make-vnode-kevent ( fd flags -- kevent )
-    "kevent" <c-object>
-    tuck set-kevent-flags
-    tuck set-kevent-ident
-    EVFILT_VNODE over set-kevent-filter
-    vnode-fflags over set-kevent-fflags ;
-
-: register-monitor ( monitor mx -- )
-    >r dup fd>> r>
-    [ >r EV_ADD EV_CLEAR bitor make-vnode-kevent r> register-kevent drop ]
-    [ monitors>> set-at ] 3bi ;
-
-: unregister-monitor ( monitor mx -- )
-    >r fd>> r>
-    [ monitors>> delete-at ]
-    [ >r EV_DELETE make-vnode-kevent r> register-kevent ] 2bi ;
-
-: <vnode-monitor> ( path mailbox -- monitor )
-    >r [ O_RDONLY 0 open dup io-error ] keep r>
-    vnode-monitor new-monitor swap >>fd
-    [ dup kqueue-mx get register-monitor ] [ ] [ fd>> close ] cleanup ;
-
-M: vnode-monitor dispose
-    [ kqueue-mx get unregister-monitor ] [ fd>> close ] bi ;

basis/io/windows/launcher/launcher.factor

@@ -56,7 +56,7 @@ TUPLE: CreateProcess-args
 
 : escape-argument ( str -- newstr )
     CHAR: \s over member? [
-        "\"" swap fix-trailing-backslashes "\"" 3append
+        fix-trailing-backslashes "\"" dup surround
     ] when ;
 
 : join-arguments ( args -- cmd-line )

basis/logging/server/server.factor

@@ -26,7 +26,7 @@ SYMBOL: log-files
 : log-stream ( service -- stream )
     log-files get [ open-log-stream ] cache ;
 
-: multiline-header 20 CHAR: - <string> ; foldable
+: multiline-header ( -- string ) 20 CHAR: - <string> ; foldable
 
 : (write-message) ( msg name>> level multi? -- )
     [

basis/math/intervals/intervals-docs.factor

@@ -44,7 +44,8 @@ ARTICLE: "math-intervals-arithmetic" "Interval arithmetic"
 { $subsection interval-bitnot }
 { $subsection interval-recip }
 { $subsection interval-2/ }
-{ $subsection interval-abs } ;
+{ $subsection interval-abs }
+{ $subsection interval-log2 } ;
 
 ARTICLE: "math-intervals-sets" "Set-theoretic operations on intervals"
 { $subsection interval-contains? }
@@ -203,6 +204,10 @@ HELP: interval-abs
 { $values { "i1" interval } { "i2" interval } }
 { $description "Absolute value of an interval." } ;
 
+HELP: interval-log2
+{ $values { "i1" interval } { "i2" interval } }
+{ $description "Integer-valued Base-2 logarithm of an interval." } ;
+
 HELP: interval-intersect
 { $values { "i1" interval } { "i2" interval } { "i3" "an " { $link interval  } " or " { $link f } } }
 { $description "Outputs the set-theoretic intersection of " { $snippet "i1" } " and " { $snippet "i2" } ". If " { $snippet "i1" } " and " { $snippet "i2" } " do not intersect, outputs " { $link f } "." } ;

basis/math/intervals/intervals.factor

@@ -2,7 +2,7 @@
 ! See http://factorcode.org/license.txt for BSD license.
 ! Based on Slate's src/unfinished/interval.slate by Brian Rice.
 USING: accessors kernel sequences arrays math math.order
-combinators generic ;
+combinators generic layouts ;
 IN: math.intervals
 
 SYMBOL: empty-interval
@@ -365,7 +365,7 @@ SYMBOL: incomparable
         2dup [ interval-nonnegative? ] both?
         [
             [ interval>points [ first ] bi@ ] bi@
-            4array supremum 0 swap next-power-of-2 [a,b]
+            4array supremum 0 swap >integer next-power-of-2 [a,b]
         ] [ 2drop [-inf,inf] ] if
     ] do-empty-interval ;
 
@@ -373,6 +373,18 @@ SYMBOL: incomparable
     #! Inaccurate.
     interval-bitor ;
 
+: interval-log2 ( i1 -- i2 )
+    {
+        { empty-interval [ empty-interval ] }
+        { full-interval [ 0 [a,inf] ] }
+        [
+            to>> first 1 max dup most-positive-fixnum >
+            [ drop full-interval interval-log2 ]
+            [ 1+ >integer log2 0 swap [a,b] ]
+            if
+        ]
+    } case ;
+
 : assume< ( i1 i2 -- i3 )
     dup special-interval? [ drop ] [
         to>> first [-inf,a) interval-intersect

basis/math/partial-dispatch/partial-dispatch.factor

@@ -1,9 +1,9 @@
 ! Copyright (C) 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors kernel kernel.private math math.private words
-sequences parser namespaces make assocs quotations arrays locals
+sequences parser namespaces make assocs quotations arrays
 generic generic.math hashtables effects compiler.units
-classes.algebra ;
+classes.algebra fry combinators ;
 IN: math.partial-dispatch
 
 PREDICATE: math-partial < word
@@ -45,60 +45,62 @@ M: word integer-op-input-classes
         { bitnot fixnum-bitnot }
     } at swap or ;
 
-:: fixnum-integer-op ( a b fix-word big-word -- c )
+: integer-fixnum-op-quot ( fix-word big-word -- quot )
-    b tag 0 eq? [
-        a b fix-word execute
-    ] [
-       a fixnum>bignum b big-word execute
-    ] if ; inline
-
-:: integer-fixnum-op ( a b fix-word big-word -- c )
-    a tag 0 eq? [
-        a b fix-word execute
-    ] [
-        a b fixnum>bignum big-word execute
-    ] if ; inline
-
-:: integer-integer-op ( a b fix-word big-word -- c )
-    b tag 0 eq? [
-        a b fix-word big-word integer-fixnum-op
-    ] [
-        a dup tag 0 eq? [ fixnum>bignum ] when
-        b big-word execute
-    ] if ; inline
-
-: integer-op-combinator ( triple -- word )
     [
-        [ second name>> % "-" % ]
+        [ over fixnum? ] %
-        [ third name>> % "-op" % ]
+        [ '[ _ execute ] , ]
-        bi
+        [ '[ fixnum>bignum _ execute ] , ] bi*
-    ] "" make "math.partial-dispatch" lookup ;
+        \ if ,
+    ] [ ] make ;
+
+: fixnum-integer-op-quot ( fix-word big-word -- quot )
+    [
+        [ dup fixnum? ] %
+        [ '[ _ execute ] , ]
+        [ '[ [ fixnum>bignum ] dip _ execute ] , ] bi*
+        \ if ,
+    ] [ ] make ;
+
+: integer-integer-op-quot ( fix-word big-word -- quot )
+    [
+        [ dup fixnum? ] %
+        2dup integer-fixnum-op-quot ,
+        [
+            [ over fixnum? [ [ fixnum>bignum ] dip ] when ] %
+            nip ,
+        ] [ ] make ,
+        \ if ,
+    ] [ ] make ;
 
 : integer-op-word ( triple -- word )
     [ name>> ] map "-" join "math.partial-dispatch" create ;
 
-: integer-op-quot ( triple fix-word big-word -- quot )
+: integer-op-quot ( fix-word big-word triple -- quot )
-    rot integer-op-combinator 1quotation 2curry ;
+    [ second ] [ third ] bi 2array {
+        { { fixnum integer } [ fixnum-integer-op-quot ] }
+        { { integer fixnum } [ integer-fixnum-op-quot ] }
+        { { integer integer } [ integer-integer-op-quot ] }
+    } case ;
 
-: define-integer-op-word ( triple fix-word big-word -- )
+: define-integer-op-word ( fix-word big-word triple -- )
     [
-        [ 2drop integer-op-word ] [ integer-op-quot ] 3bi
+        [ 2nip integer-op-word ] [ integer-op-quot ] 3bi
         (( x y -- z )) define-declared
     ] [
-        2drop
+        2nip
         [ integer-op-word ] keep
         "derived-from" set-word-prop
     ] 3bi ;
 
 : define-integer-op-words ( triples fix-word big-word -- )
-    [ define-integer-op-word ] 2curry each ;
+    '[ [ _ _ ] dip define-integer-op-word ] each ;
 
 : integer-op-triples ( word -- triples )
     {
         { fixnum integer }
         { integer fixnum }
         { integer integer }
-    } swap [ prefix ] curry map ;
+    } swap '[ _ prefix ] map ;
 
 : define-integer-ops ( word fix-word big-word -- )
     [
@@ -138,7 +140,7 @@ SYMBOL: fast-math-ops
     [ drop math-class-max swap specific-method >boolean ] if ;
 
 : (derived-ops) ( word assoc -- words )
-    swap [ rot first eq? nip ] curry assoc-filter ;
+    swap '[ swap first _ eq? nip ] assoc-filter ;
 
 : derived-ops ( word -- words )
     [ 1array ] [ math-ops get (derived-ops) values ] bi append ;

basis/memoize/memoize-tests.factor

@@ -1,6 +1,6 @@
 ! Copyright (C) 2007 Slava Pestov, Daniel Ehrenberg.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: math kernel memoize tools.test parser
+USING: math kernel memoize tools.test parser generalizations
 prettyprint io.streams.string sequences eval ;
 IN: memoize.tests
 
@@ -9,7 +9,7 @@ MEMO: fib ( m -- n )
 
 [ 89 ] [ 10 fib ] unit-test
 
-[ "USING: kernel math memoize ; IN: memoize.tests MEMO: x ( a b c d e -- f g h i j ) >r >r >r >r 1+ r> r> r> r> ;" eval ] must-fail
+[ "USING: kernel math memoize generalizations ; IN: memoize.tests MEMO: x ( a b c d e -- f g h i j ) [ 1+ ] 4 ndip ;" eval ] must-fail
 
 MEMO: see-test ( a -- b ) reverse ;
 

basis/nmake/nmake.factor

@@ -10,7 +10,7 @@ SYMBOL: building-seq
 
 : n, ( obj n -- ) get-building-seq push ;
 : n% ( seq n -- ) get-building-seq push-all ;
-: n# ( num n -- ) >r number>string r> n% ;
+: n# ( num n -- ) [ number>string ] dip n% ;
 
 : 0, ( obj -- ) 0 n, ;
 : 0% ( seq -- ) 0 n% ;

basis/peg/peg.factor

@@ -4,8 +4,7 @@ USING: kernel sequences strings fry namespaces make math assocs
 debugger io vectors arrays math.parser math.order
 vectors combinators classes sets unicode.categories
 compiler.units parser words quotations effects memoize accessors
-locals effects splitting combinators.short-circuit
+locals effects splitting combinators.short-circuit generalizations ;
-combinators.short-circuit.smart generalizations ;
 IN: peg
 
 USE: prettyprint
@@ -278,7 +277,8 @@ GENERIC: (compile) ( peg -- quot )
 : parser-body ( parser -- quot )
   #! Return the body of the word that is the compiled version
   #! of the parser.
-  gensym 2dup swap peg>> (compile) 0 1 <effect> define-declared swap dupd id>> "peg-id" set-word-prop
+  gensym 2dup swap peg>> (compile) (( -- result )) define-declared
+  swap dupd id>> "peg-id" set-word-prop
   [ execute-parser ] curry ;
 
 : preset-parser-word ( parser -- parser word )
@@ -306,7 +306,7 @@ SYMBOL: delayed
   #! Work through all delayed parsers and recompile their
   #! words to have the correct bodies.
   delayed get [
-    call compile-parser 1quotation 0 1 <effect> define-declared
+    call compile-parser 1quotation (( -- result )) define-declared
   ] assoc-each ;
 
 : compile ( parser -- word )
@@ -421,7 +421,7 @@ M: seq-parser (compile) ( peg -- quot )
     [
       parsers>> unclip compile-parser 1quotation [ parse-seq-element ] curry ,
       [ compile-parser 1quotation [ merge-errors ] compose [ parse-seq-element ] curry , ] each 
-    ] { } make , \ && , 
+    ] { } make , \ 1&& , 
   ] [ ] make ;
 
 TUPLE: choice-parser parsers ;
@@ -431,7 +431,7 @@ M: choice-parser (compile) ( peg -- quot )
     [
       parsers>> [ compile-parser ] map 
       unclip 1quotation , [ 1quotation [ merge-errors ] compose , ] each
-    ] { } make , \ || ,
+    ] { } make , \ 0|| ,
   ] [ ] make ;
 
 TUPLE: repeat0-parser p1 ;

basis/prettyprint/backend/backend.factor

@@ -10,7 +10,7 @@ IN: prettyprint.backend
 
 GENERIC: pprint* ( obj -- )
 
-M: effect pprint* effect>string "(" swap ")" 3append text ;
+M: effect pprint* effect>string "(" ")" surround text ;
 
 : ?effect-height ( word -- n )
     stack-effect [ effect-height ] [ 0 ] if* ;

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

@@ -11,7 +11,7 @@ IN: random.mersenne-twister.tests
     100 [ 100 random ] replicate ;
 
 : test-rng ( seed quot -- )
-    >r <mersenne-twister> r> with-random ;
+    [  <mersenne-twister> ] dip with-random ;
 
 [ f ] [ 1234 [ randoms randoms = ] test-rng ] unit-test
 

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

@@ -11,48 +11,39 @@ IN: random.mersenne-twister
 
 TUPLE: mersenne-twister { seq uint-array } { i fixnum } ;
 
-: mt-n 624 ; inline
+: n 624 ; inline
-: mt-m 397 ; inline
+: m 397 ; inline
-: mt-a HEX: 9908b0df ; inline
+: a uint-array{ 0 HEX: 9908b0df } ; inline
 
-: mersenne-wrap ( n -- n' )
+: y ( n seq -- y )
-    dup mt-n > [ mt-n - ] when ; inline
+    [ nth-unsafe 31 mask-bit ]
+    [ [ 1+ ] [ nth-unsafe ] bi* 31 bits ] 2bi bitor ; inline
 
-: wrap-nth ( n seq -- obj )
+: mt[k] ( offset n seq -- )
-    [ mersenne-wrap ] dip nth-unsafe ; inline
-
-: set-wrap-nth ( obj n seq -- )
-    [ mersenne-wrap ] dip set-nth-unsafe ; inline
-
-: calculate-y ( n seq -- y )
-    [ wrap-nth 31 mask-bit ]
-    [ [ 1+ ] [ wrap-nth ] bi* 31 bits ] 2bi bitor ; inline
-
-: (mt-generate) ( n seq -- next-mt )
     [
-        calculate-y
+        [ [ + ] dip nth-unsafe ]
-        [ 2/ ] [ odd? mt-a 0 ? ] bi bitxor
+        [ y [ 2/ ] [ 1 bitand a nth ] bi bitxor ] 2bi
-    ] [
+        bitxor
-        [ mt-m + ] [ wrap-nth ] bi*
+    ] 2keep set-nth-unsafe ; inline
-    ] 2bi bitxor ; inline
 
 : mt-generate ( mt -- )
     [
-        mt-n swap seq>> '[
+        seq>>
-            _ [ (mt-generate) ] [ set-wrap-nth ] 2bi
+        [ [ n m - ] dip '[ [ m ] dip _ mt[k] ] each ]
-        ] each
+        [ [ m 1- ] dip '[ [ m n - ] [ n m - + ] bi* _ mt[k] ] each ]
+        bi
     ] [ 0 >>i drop ] bi ; inline
 
 : init-mt-formula ( i seq -- f(seq[i]) )
-    dupd wrap-nth dup -30 shift bitxor 1812433253 * + 1+ 32 bits ; inline
+    dupd nth dup -30 shift bitxor 1812433253 * + 1+ 32 bits ; inline
 
 : init-mt-rest ( seq -- )
-    mt-n 1- swap '[
+    n 1- swap '[
-        _ [ init-mt-formula ] [ [ 1+ ] dip set-wrap-nth ] 2bi
+        _ [ init-mt-formula ] [ [ 1+ ] dip set-nth ] 2bi
     ] each ; inline
 
 : init-mt-seq ( seed -- seq )
-    32 bits mt-n <uint-array>
+    32 bits n <uint-array>
     [ set-first ] [ init-mt-rest ] [ ] tri ; inline
 
 : mt-temper ( y -- yt )
@@ -62,7 +53,7 @@ TUPLE: mersenne-twister { seq uint-array } { i fixnum } ;
     dup -18 shift bitxor ; inline
 
 : next-index  ( mt -- i )
-    dup i>> dup mt-n < [ nip ] [ drop mt-generate 0 ] if ; inline
+    dup i>> dup n < [ nip ] [ drop mt-generate 0 ] if ; inline
 
 PRIVATE>
 
@@ -75,7 +66,7 @@ M: mersenne-twister seed-random ( mt seed -- )
 
 M: mersenne-twister random-32* ( mt -- r )
     [ next-index ]
-    [ seq>> wrap-nth mt-temper ]
+    [ seq>> nth-unsafe mt-temper ]
     [ [ 1+ ] change-i drop ] tri ;
 
 USE: init

basis/smtp/smtp.factor

@@ -72,10 +72,12 @@ ERROR: bad-email-address email ;
     [ bad-email-address ] unless ;
 
 : mail-from ( fromaddr -- )
-    "MAIL FROM:<" swap validate-address ">" 3append command ;
+    validate-address
+    "MAIL FROM:<" ">" surround command ;
 
 : rcpt-to ( to -- )
-    "RCPT TO:<" swap validate-address ">" 3append command ;
+    validate-address
+    "RCPT TO:<" ">" surround command ;
 
 : data ( -- )
     "DATA" command ;

basis/stack-checker/backend/backend.factor

@@ -148,7 +148,7 @@ M: object apply-object push-literal ;
         { [ dup inline? ] [ drop f ] }
         { [ dup deferred? ] [ drop f ] }
         { [ dup crossref? not ] [ drop f ] }
-        [ def>> [ [ word? ] [ primitive? not ] bi and ] contains? ]
+        [ def>> [ word? ] contains? ]
     } cond ;
 
 : ?missing-effect ( word -- )

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

@@ -99,21 +99,18 @@ M: object infer-call*
     3 infer->r infer-call 3 infer-r> ;
 
 : infer-dip ( -- )
-    commit-literals
     literals get
     [ \ dip def>> infer-quot-here ]
     [ pop 1 infer->r infer-quot-here 1 infer-r>  ]
     if-empty ;
 
 : infer-2dip ( -- )
-    commit-literals
     literals get
     [ \ 2dip def>> infer-quot-here ]
     [ pop 2 infer->r infer-quot-here 2 infer-r>  ]
     if-empty ;
 
 : infer-3dip ( -- )
-    commit-literals
     literals get
     [ \ 3dip def>> infer-quot-here ]
     [ pop 3 infer->r infer-quot-here 3 infer-r>  ]
@@ -307,7 +304,7 @@ M: object infer-call*
 \ <complex> { real real } { complex } define-primitive
 \ <complex> make-foldable
 
-\ both-fixnums? { object object } { object object object } define-primitive
+\ both-fixnums? { object object } { object } define-primitive
 
 \ fixnum+ { fixnum fixnum } { integer } define-primitive
 \ fixnum+ make-foldable
@@ -562,7 +559,8 @@ M: object infer-call*
 \ string-nth { fixnum string } { fixnum } define-primitive
 \ string-nth make-flushable
 
-\ set-string-nth { fixnum fixnum string } { } define-primitive
+\ set-string-nth-slow { fixnum fixnum string } { } define-primitive
+\ set-string-nth-fast { fixnum fixnum string } { } define-primitive
 
 \ resize-array { integer array } { array } define-primitive
 \ resize-array make-flushable

basis/state-parser/state-parser.factor

@@ -139,7 +139,7 @@ M: not-enough-characters summary ( obj -- str )
 
 : expect ( ch -- )
     get-char 2dup = [ 2drop ] [
-        >r 1string r> 1string expected
+        [ 1string ] bi@ expected
     ] if next ;
 
 : expect-string ( string -- )
@@ -155,4 +155,4 @@ M: not-enough-characters summary ( obj -- str )
     swap [ init-parser call ] with-input-stream ; inline
 
 : string-parse ( input quot -- )
-    >r <string-reader> r> state-parse ; inline
+    [ <string-reader> ] dip state-parse ; inline

basis/threads/threads-docs.factor

@@ -1,6 +1,6 @@
 USING: help.markup help.syntax kernel kernel.private io
 threads.private continuations init quotations strings
-assocs heaps boxes namespaces deques ;
+assocs heaps boxes namespaces deques dlists ;
 IN: threads
 
 ARTICLE: "threads-start/stop" "Starting and stopping threads"
@@ -82,7 +82,7 @@ $nl
 { $notes "In most cases, user code should call " { $link spawn } " instead, however for control over the error handler quotation, threads can be created with " { $link <thread> } " then passed to " { $link (spawn) } "." } ;
 
 HELP: run-queue
-{ $values { "queue" deque } }
+{ $values { "dlist" dlist } }
 { $var-description "Global variable holding the queue of runnable threads. Calls to " { $link yield } " switch to the thread which has been in the queue for the longest period of time."
 $nl
 "By convention, threads are queued with " { $link push-front } 
@@ -97,6 +97,7 @@ HELP: resume-with
 { $description "Adds a thread to the end of the run queue together with an object to pass to the thread. The thread must have previously been suspended by a call to " { $link suspend } "; the object is returned from the " { $link suspend } " call." } ;
 
 HELP: sleep-queue
+{ $values { "heap" min-heap } }
 { $var-description "A " { $link min-heap } " storing the queue of sleeping threads." } ;
 
 HELP: sleep-time

basis/threads/threads.factor

@@ -36,7 +36,7 @@ sleep-entry ;
 : tchange ( key quot -- )
     tnamespace swap change-at ; inline
 
-: threads 64 getenv ;
+: threads ( -- assoc ) 64 getenv ;
 
 : thread ( id -- thread ) threads at ;
 
@@ -73,9 +73,9 @@ PRIVATE>
 : <thread> ( quot name -- thread )
     \ thread new-thread ;
 
-: run-queue 65 getenv ;
+: run-queue ( -- dlist ) 65 getenv ;
 
-: sleep-queue 66 getenv ;
+: sleep-queue ( -- heap ) 66 getenv ;
 
 : resume ( thread -- )
     f >>state

basis/tools/annotations/annotations-docs.factor

@@ -4,9 +4,17 @@ IN: tools.annotations
 
 ARTICLE: "tools.annotations" "Word annotations"
 "The word annotation feature modifies word definitions to add debugging code. You can restore the old definition by calling " { $link reset } " on the word in question."
+$nl
+"Printing messages when a word is called or returns:"
 { $subsection watch }
+{ $subsection watch-vars }
+"Starting the walker when a word is called:"
 { $subsection breakpoint }
 { $subsection breakpoint-if }
+"Timing words:"
+{ $subsection reset-word-timing }
+{ $subsection add-timing }
+{ $subsection word-timing. }
 "All of the above words are implemented using a single combinator which applies a quotation to a word definition to yield a new definition:"
 { $subsection annotate } ;
 
@@ -63,3 +71,13 @@ HELP: word-inputs
      { "seq" sequence } }
 { $description "Makes a sequence of the inputs to a word by counting the number of inputs in the stack effect and saving that many items from the datastack." } ;
 
+HELP: add-timing
+{ $values { "word" word } }
+{ $description "Adds timing code to a word, which records its total running time, including that of words it calls, on every invocation." }
+{ $see-also "timing" "profiling" } ;
+
+HELP: reset-word-timing
+{ $description "Resets the word timing table." } ;
+
+HELP: word-timing.
+{ $description "Prints the word timing table." } ;

basis/tools/annotations/annotations-tests.factor

@@ -1,4 +1,4 @@
-USING: tools.test tools.annotations math parser eval
+USING: tools.test tools.annotations tools.time math parser eval
 io.streams.string kernel ;
 IN: tools.annotations.tests
 

basis/tools/annotations/annotations.factor

@@ -1,9 +1,9 @@
 ! Copyright (C) 2005, 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: accessors kernel words parser io summary quotations
+USING: accessors kernel math sorting words parser io summary
-sequences prettyprint continuations effects definitions
+quotations sequences prettyprint continuations effects
-compiler.units namespaces assocs tools.walker generic
+definitions compiler.units namespaces assocs tools.walker
-inspector fry ;
+tools.time generic inspector fry ;
 IN: tools.annotations
 
 GENERIC: reset ( word -- )
@@ -20,9 +20,11 @@ M: word reset
         f "unannotated-def" set-word-prop
     ] [ drop ] if ;
 
+ERROR: cannot-annotate-twice word ;
+
 : annotate ( word quot -- )
     over "unannotated-def" word-prop [
-        "Cannot annotate a word twice" throw
+        over cannot-annotate-twice
     ] when
     [
         over dup def>> "unannotated-def" set-word-prop
@@ -82,3 +84,21 @@ M: word annotate-methods
 
 : breakpoint-if ( word quot -- )
     '[ [ _ [ [ break ] when ] ] dip 3append ] annotate-methods ;
+
+SYMBOL: word-timing
+
+word-timing global [ H{ } clone or ] change-at
+
+: reset-word-timing ( -- )
+    word-timing get clear-assoc ;
+
+: (add-timing) ( def word -- def' )
+    '[ _ benchmark _ word-timing get at+ ] ;
+
+: add-timing ( word -- )
+    dup '[ _ (add-timing) ] annotate ;
+
+: word-timing. ( -- )
+    word-timing get
+    >alist [ 1000000 /f ] assoc-map sort-values
+    simple-table. ;

basis/tools/deploy/deploy-tests.factor

@@ -14,34 +14,22 @@ urls math.parser ;
 : small-enough? ( n -- ? )
     [ "test.image" temp-file file-info size>> ] [ cell 4 / * ] bi* <= ;
 
-[ ] [ "hello-world" shake-and-bake ] unit-test
+[ t ] [ "hello-world" shake-and-bake 500000 small-enough? ] unit-test
 
-[ t ] [ 500000 small-enough? ] unit-test
+[ t ] [ "sudoku" shake-and-bake 800000 small-enough? ] unit-test
 
-[ ] [ "sudoku" shake-and-bake ] unit-test
+[ t ] [ "hello-ui" shake-and-bake 1300000 small-enough? ] unit-test
-
-[ t ] [ 800000 small-enough? ] unit-test
-
-[ ] [ "hello-ui" shake-and-bake ] unit-test
-
-[ t ] [ 1300000 small-enough? ] unit-test
 
 [ "staging.math-compiler-threads-ui-strip.image" ] [
     "hello-ui" deploy-config
     [ bootstrap-profile staging-image-name file-name ] bind
 ] unit-test
 
-[ ] [ "maze" shake-and-bake ] unit-test
+[ t ] [ "maze" shake-and-bake 1200000 small-enough? ] unit-test
 
-[ t ] [ 1200000 small-enough? ] unit-test
+[ t ] [ "tetris" shake-and-bake 1500000 small-enough? ] unit-test
 
-[ ] [ "tetris" shake-and-bake ] unit-test
+[ t ] [ "bunny" shake-and-bake 2500000 small-enough? ] unit-test
-
-[ t ] [ 1500000 small-enough? ] unit-test
-
-! [ ] [ "bunny" shake-and-bake ] unit-test
-
-! [ t ] [ 2500000 small-enough? ] unit-test
 
 : run-temp-image ( -- )
     vm
@@ -110,3 +98,8 @@ M: quit-responder call-responder*
     "tools.deploy.test.7" shake-and-bake
     run-temp-image
 ] unit-test
+
+[ ] [
+    "tools.deploy.test.8" shake-and-bake
+    run-temp-image
+] unit-test

basis/tools/deploy/test/8/8.factor

@@ -0,0 +1,11 @@
+USING: kernel ;
+IN: tools.deploy.test.8
+
+: literal-merge-test-1 ( -- x ) H{ { "lil" "wayne" } } ;
+: literal-merge-test-2 ( -- x ) H{ { "lil" "wayne" } } ;
+
+: literal-merge-test ( -- )
+    literal-merge-test-1
+    literal-merge-test-2 eq? t assert= ;
+
+MAIN: literal-merge-test

basis/tools/deploy/test/8/deploy.factor

@@ -0,0 +1,15 @@
+USING: tools.deploy.config ;
+H{
+    { deploy-name "tools.deploy.test.8" }
+    { deploy-c-types? f }
+    { deploy-word-props? f }
+    { deploy-ui? f }
+    { deploy-reflection 1 }
+    { deploy-compiler? f }
+    { deploy-unicode? f }
+    { deploy-io 1 }
+    { deploy-word-defs? f }
+    { deploy-threads? f }
+    { "stop-after-last-window?" t }
+    { deploy-math? f }
+}

basis/tools/files/files.factor

@@ -1,14 +1,15 @@
 ! Copyright (C) 2008 Doug Coleman.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors arrays combinators io io.files kernel
-math.parser sequences system vocabs.loader calendar ;
+math.parser sequences system vocabs.loader calendar math
+symbols fry prettyprint ;
 IN: tools.files
 
 <PRIVATE
 
 : ls-time ( timestamp -- string )
     [ hour>> ] [ minute>> ] bi
-    [ number>string 2 CHAR: 0 pad-left ] bi@ ":" swap 3append ;
+    [ number>string 2 CHAR: 0 pad-left ] bi@ ":" glue ;
 
 : ls-timestamp ( timestamp -- string )
     [ month>> month-abbreviation ]
@@ -32,7 +33,37 @@ PRIVATE>
 : directory. ( path -- )
     [ (directory.) ] with-directory-files [ print ] each ;
 
+SYMBOLS: device-name mount-point type
+available-space free-space used-space total-space
+percent-used percent-free ;
+
+: percent ( real -- integer ) 100 * >integer ; inline
+
+: file-system-spec ( file-system-info obj -- str )
+    {
+        { device-name [ device-name>> ] }
+        { mount-point [ mount-point>> ] }
+        { type [ type>> ] }
+        { available-space [ available-space>> ] }
+        { free-space [ free-space>> ] }
+        { used-space [ used-space>> ] }
+        { total-space [ total-space>> ] }
+        { percent-used [
+            [ used-space>> ] [ total-space>> ] bi dup 0 =
+            [ 2drop 0 ] [ / percent ] if
+        ] }
+    } case ;
+
+: file-systems-info ( spec -- seq )
+    file-systems swap '[ _ [ file-system-spec ] with map ] map ;
+
+: file-systems. ( spec -- )
+    [ file-systems-info ]
+    [ [ unparse ] map ] bi prefix simple-table. ;
+
 {
     { [ os unix? ] [ "tools.files.unix" ] }
     { [ os windows? ] [ "tools.files.windows" ] }
 } cond require
+
+! { device-name free-space used-space total-space percent-used } file-systems.