Fix conflict

basis/alarms/alarms.factor

@@ -1,7 +1,7 @@
 ! Copyright (C) 2005, 2008 Slava Pestov, Doug Coleman.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors arrays calendar combinators generic init
-kernel math namespaces sequences heaps boxes threads debugger
+kernel math namespaces sequences heaps boxes threads
 quotations assocs math.order ;
 IN: alarms
 

basis/alien/prettyprint/prettyprint.factor

@@ -0,0 +1,14 @@
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel combinators alien alien.strings alien.syntax
+prettyprint.backend prettyprint.custom prettyprint.sections ;
+IN: alien.prettyprint
+
+M: alien pprint*
+    {
+        { [ dup expired? ] [ drop \ BAD-ALIEN pprint-word ] }
+        { [ dup pinned-c-ptr? not ] [ drop "( displaced alien )" text ] }
+        [ \ ALIEN: [ alien-address pprint* ] pprint-prefix ]
+    } cond ;
+
+M: dll pprint* dll-path dup "DLL\" " "\"" pprint-string ;

basis/alien/strings/strings-docs.factor

@@ -31,10 +31,6 @@ HELP: string>symbol
 $nl
 "On Windows CE, symbols are represented as UCS2 strings, and on all other platforms they are ASCII strings." } ;
 
-HELP: utf16n
-{ $class-description "The encoding descriptor for UTF-16 without a byte order mark in native endian order. This is useful mostly for FFI calls which take input of strings of the type wchar_t*" }
-{ $see-also "encodings-introduction" } ;
-
 ARTICLE: "c-strings" "C strings"
 "C string types are arrays with shape " { $snippet "{ \"char*\" encoding }" } ", where " { $snippet "encoding" } " is an encoding descriptor. The type " { $snippet "\"char*\"" } " is an alias for " { $snippet "{ \"char*\" utf8 }" } ". See " { $link "encodings-descriptors" } " for information about encoding descriptors."
 $nl

basis/alien/strings/strings-tests.factor

@@ -1,6 +1,6 @@
 USING: alien.strings tools.test kernel libc
 io.encodings.8-bit io.encodings.utf8 io.encodings.utf16
-io.encodings.ascii alien io.encodings.string ;
+io.encodings.utf16n io.encodings.ascii alien io.encodings.string ;
 IN: alien.strings.tests
 
 [ "\u0000ff" ]

basis/alien/strings/strings.factor

@@ -2,8 +2,8 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: arrays sequences kernel accessors math alien.accessors
 alien.c-types byte-arrays words io io.encodings
-io.streams.byte-array io.streams.memory io.encodings.utf8
+io.encodings.utf8 io.streams.byte-array io.streams.memory system
-io.encodings.utf16 system alien strings cpu.architecture fry ;
+alien strings cpu.architecture fry vocabs.loader combinators ;
 IN: alien.strings
 
 GENERIC# alien>string 1 ( c-ptr encoding -- string/f )
@@ -88,27 +88,22 @@ M: string-type c-type-getter
 M: string-type c-type-setter
     drop [ set-alien-cell ] ;
 
-! Native-order UTF-16
+HOOK: alien>native-string os ( alien -- string )
 
-SINGLETON: utf16n
+HOOK: native-string>alien os ( string -- alien )
-
-: utf16n ( -- descriptor )
-    little-endian? utf16le utf16be ? ; foldable
-
-M: utf16n <decoder> drop utf16n <decoder> ;
-
-M: utf16n <encoder> drop utf16n <encoder> ;
-
-: alien>native-string ( alien -- string )
-    os windows? [ utf16n ] [ utf8 ] if alien>string ;
 
 : dll-path ( dll -- string )
     path>> alien>native-string ;
 
 : string>symbol ( str -- alien )
-    [ os wince? [ utf16n ] [ utf8 ] if string>alien ]
+    dup string?
-    over string? [ call ] [ map ] if ;
+    [ native-string>alien ]
+    [ [ native-string>alien ] map ] if ;
 
 { "char*" utf8 } "char*" typedef
-{ "char*" utf16n } "wchar_t*" typedef
 "char*" "uchar*" typedef
+
+{
+    { [ os windows? ] [ "alien.strings.windows" require ] }
+    { [ os unix? ] [ "alien.strings.unix" require ] }
+} cond

basis/alien/strings/unix/unix.factor

@@ -0,0 +1,8 @@
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: alien.strings io.encodings.utf8 system ;
+IN: alien.strings.unix
+
+M: unix alien>native-string utf8 alien>string ;
+
+M: unix native-string>alien utf8 string>alien ;

basis/alien/strings/windows/windows.factor

@@ -0,0 +1,13 @@
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: alien.strings alien.c-types io.encodings.utf8
+io.encodings.utf16n system ;
+IN: alien.strings.windows
+
+M: windows alien>native-string utf16n alien>string ;
+
+M: wince native-string>alien utf16n string>alien ;
+
+M: winnt native-string>alien utf8 string>alien ;
+
+{ "char*" utf16n } "wchar_t*" typedef

basis/alien/syntax/syntax.factor

@@ -3,8 +3,7 @@
 USING: accessors arrays alien alien.c-types alien.structs
 alien.arrays alien.strings kernel math namespaces parser
 sequences words quotations math.parser splitting grouping
-effects prettyprint prettyprint.sections prettyprint.backend
+effects assocs combinators lexer strings.parser alien.parser ;
-assocs combinators lexer strings.parser alien.parser ;
 IN: alien.syntax
 
 : DLL" lexer get skip-blank parse-string dlopen parsed ; parsing
@@ -34,12 +33,3 @@ IN: alien.syntax
     dup length
     [ [ create-in ] dip 1quotation define ] 2each ;
     parsing
-
-M: alien pprint*
-    {
-        { [ dup expired? ] [ drop \ BAD-ALIEN pprint-word ] }
-        { [ dup pinned-c-ptr? not ] [ drop "( displaced alien )" text ] }
-        [ \ ALIEN: [ alien-address pprint* ] pprint-prefix ]
-    } cond ;
-
-M: dll pprint* dll-path dup "DLL\" " "\"" pprint-string ;

basis/bit-arrays/bit-arrays.factor

@@ -2,7 +2,7 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: alien.c-types accessors math alien.accessors kernel
 kernel.private locals sequences sequences.private byte-arrays
-parser prettyprint.backend fry ;
+parser prettyprint.custom fry ;
 IN: bit-arrays
 
 TUPLE: bit-array
@@ -73,11 +73,11 @@ M: bit-array byte-length length 7 + -3 shift ;
 :: integer>bit-array ( n -- bit-array ) 
     n zero? [ 0 <bit-array> ] [
         [let | out [ n log2 1+ <bit-array> ] i! [ 0 ] n'! [ n ] |
-            [ n' zero? not ] [
+            [ n' zero? ] [
                 n' out underlying>> i set-alien-unsigned-1
                 n' -8 shift n'!
                 i 1+ i!
-            ] [ ] while
+            ] [ ] until
             out
         ]
     ] if ;

basis/bit-vectors/bit-vectors.factor

@@ -1,7 +1,7 @@
 ! Copyright (C) 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: arrays kernel kernel.private math sequences
-sequences.private growable bit-arrays prettyprint.backend
+sequences.private growable bit-arrays prettyprint.custom
 parser accessors ;
 IN: bit-vectors
 

basis/bootstrap/bootstrap-error.factor

@@ -0,0 +1,8 @@
+USING: continuations kernel io debugger vocabs words system namespaces ;
+
+:c
+:error
+"listener" vocab
+[ restarts. vocab-main execute ]
+[ die ] if*
+1 exit

basis/bootstrap/compiler/compiler.factor

@@ -5,17 +5,22 @@ sequences namespaces parser kernel kernel.private classes
 classes.private arrays hashtables vectors classes.tuple sbufs
 hashtables.private sequences.private math classes.tuple.private
 growable namespaces.private assocs words command-line vocabs io
-io.encodings.string prettyprint libc splitting math.parser
+io.encodings.string libc splitting math.parser
 compiler.units math.order compiler.tree.builder
 compiler.tree.optimizer compiler.cfg.optimizer ;
 IN: bootstrap.compiler
 
 ! Don't bring this in when deploying, since it will store a
 ! reference to 'eval' in a global variable
-"deploy-vocab" get [
+"deploy-vocab" get "staging" get or [
     "alien.remote-control" require
 ] unless
 
+"prettyprint" vocab [
+    "stack-checker.errors.prettyprint" require
+    "alien.prettyprint" require
+] when
+
 "cpu." cpu name>> append require
 
 enable-compiler
@@ -60,7 +65,7 @@ nl
 "." write flush
 
 {
-    new-sequence nth push pop peek
+    new-sequence nth push pop peek flip
 } compile-uncompiled
 
 "." write flush
@@ -86,7 +91,7 @@ nl
 "." write flush
 
 {
-    . malloc calloc free memcpy
+    malloc calloc free memcpy
 } compile-uncompiled
 
 "." write flush

basis/bootstrap/finish-bootstrap.factor

@@ -0,0 +1,16 @@
+USING: init command-line debugger system continuations
+namespaces eval kernel vocabs.loader io ;
+
+[
+    boot
+    do-init-hooks
+    [
+        (command-line) parse-command-line
+        load-vocab-roots
+        run-user-init
+        "e" get [ eval ] when*
+        ignore-cli-args? not script get and
+        [ run-script ] [ "run" get run ] if*
+        output-stream get [ stream-flush ] when*
+    ] [ print-error 1 exit ] recover
+] set-boot-quot

basis/bootstrap/finish-staging.factor

@@ -0,0 +1,10 @@
+USING: init command-line system namespaces kernel vocabs.loader
+io ;
+
+[
+    boot
+    do-init-hooks
+    (command-line) parse-command-line
+    "run" get run
+    output-stream get [ stream-flush ] when*
+] set-boot-quot

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 ;

basis/bootstrap/math/math.factor

@@ -1,5 +1,7 @@
-USE: vocabs.loader
+USING: vocabs vocabs.loader kernel ;
 
 "math.ratios" require
 "math.floats" require
 "math.complex" require
+
+"prettyprint" vocab [ "math.complex.prettyprint" require ] when

basis/bootstrap/stage2.factor

@@ -2,10 +2,10 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors init namespaces words io
 kernel.private math memory continuations kernel io.files
-io.backend system parser vocabs sequences prettyprint
+io.backend system parser vocabs sequences
 vocabs.loader combinators splitting source-files strings
 definitions assocs compiler.errors compiler.units
-math.parser generic sets debugger command-line ;
+math.parser generic sets command-line ;
 IN: bootstrap.stage2
 
 SYMBOL: core-bootstrap-time
@@ -86,25 +86,18 @@ SYMBOL: bootstrap-time
     f error set-global
     f error-continuation set-global
 
+    millis swap - bootstrap-time set-global
+    print-report
+
     "deploy-vocab" get [
         "tools.deploy.shaker" run
     ] [
-        [
+        "staging" get [
-            boot
+            "resource:basis/bootstrap/finish-staging.factor" run-file
-            do-init-hooks
+        ] [
-            handle-command-line
+            "resource:basis/bootstrap/finish-bootstrap.factor" run-file
-        ] set-boot-quot
+        ] if
-
-        millis swap - bootstrap-time set-global
-        print-report
 
         "output-image" get save-image-and-exit
     ] if
-] [
+] [ drop "resource:basis/bootstrap/bootstrap-error.factor" run-file ] recover
-    :c
-    dup print-error flush
-    "listener" vocab
-    [ restarts. vocab-main execute ]
-    [ die ] if*
-    1 exit
-] recover

basis/bootstrap/threads/threads.factor

@@ -1,7 +1,11 @@
 ! Copyright (C) 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
+USING: vocabs vocabs.loader kernel ;
 IN: bootstrap.threads
 
 USE: io.thread
 USE: threads
-USE: debugger.threads
+
+"debugger" vocab [
+    "debugger.threads" require
+] when

basis/byte-vectors/byte-vectors.factor

@@ -1,7 +1,8 @@
 ! Copyright (C) 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: arrays kernel kernel.private math sequences
-sequences.private growable byte-arrays accessors ;
+sequences.private growable byte-arrays accessors parser
+prettyprint.custom ;
 IN: byte-vectors
 
 TUPLE: byte-vector
@@ -41,4 +42,10 @@ M: byte-array like
 
 M: byte-array new-resizable drop <byte-vector> ;
 
+: BV{ \ } [ >byte-vector ] parse-literal ; parsing
+
+M: byte-vector pprint* pprint-object ;
+M: byte-vector pprint-delims drop \ BV{ \ } ;
+M: byte-vector >pprint-sequence ;
+
 INSTANCE: byte-vector growable

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/calendar/format/format.factor

@@ -1,7 +1,8 @@
-USING: math math.order math.parser math.functions kernel sequences io
+! Copyright (C) 2008 Slava Pestov.
-accessors arrays io.streams.string splitting
+! See http://factorcode.org/license.txt for BSD license.
-combinators accessors debugger
+USING: math math.order math.parser math.functions kernel
-calendar calendar.format.macros ;
+sequences io accessors arrays io.streams.string splitting
+combinators accessors calendar calendar.format.macros present ;
 IN: calendar.format
 
 : pad-00 ( n -- str ) number>string 2 CHAR: 0 pad-left ;
@@ -288,3 +289,5 @@ ERROR: invalid-timestamp-format ;
             ]
         } formatted
     ] with-string-writer ;
+
+M: timestamp present timestamp>string ;

basis/checksums/md5/md5.factor

@@ -4,7 +4,7 @@ USING: kernel io io.binary io.files io.streams.byte-array math
 math.functions math.parser namespaces splitting grouping strings
 sequences byte-arrays locals sequences.private
 io.encodings.binary symbols math.bitwise checksums
-checksums.common ;
+checksums.common checksums.stream ;
 IN: checksums.md5
 
 ! See http://www.faqs.org/rfcs/rfc1321.html
@@ -180,7 +180,7 @@ PRIVATE>
 
 SINGLETON: md5
 
-INSTANCE: md5 checksum
+INSTANCE: md5 stream-checksum
 
 M: md5 checksum-stream ( stream -- byte-array )
     drop [ initialize-md5 stream>md5 get-md5 ] with-input-stream ;

basis/checksums/openssl/openssl.factor

@@ -1,7 +1,8 @@
 ! Copyright (C) 2008 Slava Pestov
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors byte-arrays alien.c-types kernel continuations
-destructors sequences io openssl openssl.libcrypto checksums ;
+destructors sequences io openssl openssl.libcrypto checksums
+checksums.stream ;
 IN: checksums.openssl
 
 ERROR: unknown-digest name ;
@@ -12,7 +13,7 @@ TUPLE: openssl-checksum name ;
 
 : openssl-sha1 T{ openssl-checksum f "sha1" } ;
 
-INSTANCE: openssl-checksum checksum
+INSTANCE: openssl-checksum stream-checksum
 
 C: <openssl-checksum> openssl-checksum
 

basis/checksums/sha1/sha1.factor

@@ -3,7 +3,8 @@
 USING: arrays combinators kernel io io.encodings.binary io.files
 io.streams.byte-array math.vectors strings sequences namespaces
 make math parser sequences assocs grouping vectors io.binary
-hashtables symbols math.bitwise checksums checksums.common ;
+hashtables symbols math.bitwise checksums checksums.common
+checksums.stream ;
 IN: checksums.sha1
 
 ! Implemented according to RFC 3174.
@@ -113,7 +114,7 @@ SYMBOLS: h0 h1 h2 h3 h4 A B C D E w K ;
 
 SINGLETON: sha1
 
-INSTANCE: sha1 checksum
+INSTANCE: sha1 stream-checksum
 
 M: sha1 checksum-stream ( stream -- sha1 )
     drop [ initialize-sha1 stream>sha1 get-sha1 ] with-input-stream ;

basis/checksums/stream/stream.factor

@@ -0,0 +1,12 @@
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: io.encodings.binary io.streams.byte-array kernel
+checksums ;
+IN: checksums.stream
+
+MIXIN: stream-checksum
+
+M: stream-checksum checksum-bytes
+    [ binary <byte-reader> ] dip checksum-stream ;
+
+INSTANCE: stream-checksum checksum

basis/cocoa/application/application.factor

@@ -1,9 +1,9 @@
-! Copyright (C) 2006, 2007 Slava Pestov
+! Copyright (C) 2006, 2008 Slava Pestov
 ! See http://factorcode.org/license.txt for BSD license.
 USING: alien alien.syntax io kernel namespaces core-foundation
 core-foundation.run-loop cocoa.messages cocoa cocoa.classes
-cocoa.runtime sequences threads debugger init summary
+cocoa.runtime sequences threads init summary kernel.private
-kernel.private assocs ;
+assocs ;
 IN: cocoa.application
 
 : <NSString> ( str -- alien ) <CFString> -> autorelease ;

basis/cocoa/messages/messages.factor

@@ -1,22 +1,18 @@
 ! 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 quotations sequences strings words
-strings words cocoa.runtime io macros memoize debugger
+cocoa.runtime io macros memoize io.encodings.utf8
-io.encodings.ascii effects libc libc.private parser lexer init
+effects libc libc.private parser lexer init core-foundation fry
-core-foundation fry generalizations
+generalizations specialized-arrays.direct.alien ;
-specialized-arrays.direct.alien ;
 IN: cocoa.messages
 
 : make-sender ( method function -- quot )
     [ over first , f , , second , \ alien-invoke , ] [ ] make ;
 
-: sender-stub-name ( method function -- string )
-    [ % "_" % unparse % ] "" make ;
-
 : sender-stub ( method function -- word )
-    [ sender-stub-name f <word> dup ] 2keep
+    [ "( sender-stub )" f <word> dup ] 2dip
     over first large-struct? [ "_stret" append ] when
     make-sender define ;
 
@@ -78,12 +74,8 @@ MACRO: (send) ( selector super? -- quot )
 
 : send ( receiver args... selector -- return... ) f (send) ; inline
 
-\ send soft "break-after" set-word-prop
-
 : super-send ( receiver args... selector -- return... ) t (send) ; inline
 
-\ super-send soft "break-after" set-word-prop
-
 ! Runtime introspection
 SYMBOL: class-init-hooks
 
@@ -91,7 +83,7 @@ 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 [ call ] when*
+        drop over class-init-hooks get at [ assert-depth ] when*
         2dup execute dup [ 2nip ] [
             2drop "No such class: " prepend throw
         ] if
@@ -188,7 +180,7 @@ assoc-union alien>objc-types set-global
 
 : method-arg-type ( method i -- type )
     method_copyArgumentType
-    [ ascii alien>string parse-objc-type ] keep
+    [ utf8 alien>string parse-objc-type ] keep
     (free) ;
 
 : method-arg-types ( method -- args )
@@ -197,7 +189,7 @@ assoc-union alien>objc-types set-global
 
 : method-return-type ( method -- ctype )
     method_copyReturnType
-    [ ascii alien>string parse-objc-type ] keep
+    [ utf8 alien>string parse-objc-type ] keep
     (free) ;
 
 : register-objc-method ( method -- )
@@ -216,17 +208,6 @@ assoc-union alien>objc-types set-global
 : register-objc-methods ( class -- )
     [ register-objc-method ] each-method-in-class ;
 
-: method. ( method -- )
-    {
-        [ method_getName sel_getName ]
-        [ method-return-type ]
-        [ method-arg-types ]
-        [ method_getImplementation ]
-    } cleave 4array . ;
-
-: methods. ( class -- )
-    [ method. ] each-method-in-class ;
-
 : class-exists? ( string -- class ) objc_getClass >boolean ;
 
 : define-objc-class-word ( quot name -- )
@@ -238,11 +219,8 @@ assoc-union alien>objc-types set-global
 
 : import-objc-class ( name quot -- )
     over define-objc-class-word
-    '[
+    [ objc-class register-objc-methods ]
-        _
+    [ objc-meta-class register-objc-methods ] bi ;
-        [ objc-class register-objc-methods ]
-        [ objc-meta-class register-objc-methods ] bi
-    ] try ;
 
 : root-class ( class -- root )
     dup class_getSuperclass [ root-class ] [ ] ?if ;

basis/cocoa/subclassing/subclassing.factor

@@ -3,12 +3,12 @@
 USING: alien alien.c-types alien.strings arrays assocs
 combinators compiler hashtables kernel libc math namespaces
 parser sequences words cocoa.messages cocoa.runtime locals
-compiler.units io.encodings.ascii continuations make fry ;
+compiler.units io.encodings.utf8 continuations make fry ;
 IN: cocoa.subclassing
 
 : init-method ( method -- sel imp types )
     first3 swap
-    [ sel_registerName ] [ execute ] [ ascii string>alien ]
+    [ sel_registerName ] [ execute ] [ utf8 string>alien ]
     tri* ;
 
 : throw-if-false ( obj what -- )

basis/command-line/command-line.factor

@@ -1,8 +1,8 @@
 ! Copyright (C) 2003, 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: init continuations debugger hashtables io
+USING: init continuations hashtables io io.encodings.utf8
-io.encodings.utf8 io.files kernel kernel.private namespaces
+io.files kernel kernel.private namespaces parser sequences
-parser sequences strings system splitting eval vocabs.loader ;
+strings system splitting vocabs.loader ;
 IN: command-line
 
 SYMBOL: script
@@ -31,8 +31,6 @@ SYMBOL: command-line
         ] [ drop ] if
     ] when ;
 
-<PRIVATE
-
 : var-param ( name value -- ) swap set-global ;
 
 : bool-param ( name -- ) "no-" ?head not var-param ;
@@ -43,8 +41,6 @@ SYMBOL: command-line
 : run-script ( file -- )
     t "quiet" set-global run-file ;
 
-PRIVATE>
-
 : parse-command-line ( args -- )
     [ command-line off script off ] [
         unclip "-" ?head
@@ -76,15 +72,4 @@ SYMBOL: main-vocab-hook
 
 : script-mode ( -- ) ;
 
-: handle-command-line ( -- )
-    [
-        (command-line) parse-command-line
-        load-vocab-roots
-        run-user-init
-        "e" get [ eval ] when*
-        ignore-cli-args? not script get and
-        [ run-script ] [ "run" get run ] if*
-        output-stream get [ stream-flush ] when*
-    ] [ print-error 1 exit ] recover ;
-
 [ default-cli-args ] "command-line" add-init-hook

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

@@ -1,6 +1,6 @@
 USING: compiler.cfg.instructions compiler.cfg.registers
-compiler.cfg.alias-analysis cpu.architecture tools.test
+compiler.cfg.alias-analysis compiler.cfg.debugger
-kernel ;
+cpu.architecture tools.test kernel ;
 IN: compiler.cfg.alias-analysis.tests
 
 [ ] [

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/dead-code/dead-code-tests.factor

@@ -1,5 +1,6 @@
 USING: compiler.cfg.dead-code compiler.cfg.instructions
-compiler.cfg.registers cpu.architecture tools.test ;
+compiler.cfg.registers compiler.cfg.debugger
+cpu.architecture tools.test ;
 IN: compiler.cfg.dead-code.tests
 
 [ { } ] [

basis/compiler/cfg/debugger/debugger.factor

@@ -2,10 +2,12 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: kernel words sequences quotations namespaces io
 classes.tuple accessors prettyprint prettyprint.config
-compiler.tree.builder compiler.tree.optimizer
+prettyprint.backend prettyprint.custom prettyprint.sections
+parser compiler.tree.builder compiler.tree.optimizer
 compiler.cfg.builder compiler.cfg.linearization
-compiler.cfg.stack-frame compiler.cfg.linear-scan
+compiler.cfg.registers compiler.cfg.stack-frame
-compiler.cfg.two-operand compiler.cfg.optimizer ;
+compiler.cfg.linear-scan compiler.cfg.two-operand
+compiler.cfg.optimizer ;
 IN: compiler.cfg.debugger
 
 GENERIC: test-cfg ( quot -- cfgs )
@@ -40,3 +42,15 @@ SYMBOL: allocate-registers?
         instructions>> [ insn. ] each
         nl
     ] each ;
+
+! Prettyprinting
+M: vreg pprint*
+    <block
+    \ V pprint-word [ reg-class>> pprint* ] [ n>> pprint* ] bi
+    block> ;
+
+: pprint-loc ( loc word -- ) <block pprint-word n>> pprint* block> ;
+
+M: ds-loc pprint* \ D pprint-loc ;
+
+M: rs-loc pprint* \ R pprint-loc ;

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

@@ -92,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 ;
@@ -161,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-
@@ -92,9 +95,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 ] }
@@ -106,6 +113,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 ] }

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 )

basis/compiler/cfg/registers/registers.factor

@@ -1,7 +1,6 @@
 ! Copyright (C) 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: accessors namespaces kernel arrays
+USING: accessors namespaces kernel arrays parser ;
-parser prettyprint.backend prettyprint.sections ;
 IN: compiler.cfg.registers
 
 ! Virtual registers, used by CFG and machine IRs
@@ -18,20 +17,6 @@ C: <ds-loc> ds-loc
 TUPLE: rs-loc < loc ;
 C: <rs-loc> rs-loc
 
-! Prettyprinting
 : V scan-word scan-word vreg boa parsed ; parsing
-
-M: vreg pprint*
-    <block
-    \ V pprint-word [ reg-class>> pprint* ] [ n>> pprint* ] bi
-    block> ;
-
-: pprint-loc ( loc word -- ) <block pprint-word n>> pprint* block> ;
-
 : D scan-word <ds-loc> parsed ; parsing
-
-M: ds-loc pprint* \ D pprint-loc ;
-
 : R scan-word <rs-loc> parsed ; parsing
-
-M: rs-loc pprint* \ R pprint-loc ;

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/cfg/value-numbering/value-numbering-tests.factor

@@ -1,7 +1,8 @@
 IN: compiler.cfg.value-numbering.tests
 USING: compiler.cfg.value-numbering compiler.cfg.instructions
-compiler.cfg.registers cpu.architecture tools.test kernel math
+compiler.cfg.registers compiler.cfg.debugger cpu.architecture
-combinators.short-circuit accessors sequences ;
+tools.test kernel math combinators.short-circuit accessors
+sequences ;
 
 : trim-temps ( insns -- insns )
     [

basis/compiler/cfg/write-barrier/write-barrier-tests.factor

@@ -1,5 +1,6 @@
 USING: compiler.cfg.write-barrier compiler.cfg.instructions
-compiler.cfg.registers cpu.architecture arrays tools.test ;
+compiler.cfg.registers compiler.cfg.debugger cpu.architecture
+arrays tools.test ;
 IN: compiler.cfg.write-barrier.tests
 
 [

basis/compiler/codegen/codegen.factor

@@ -163,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
@@ -236,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 )
 
@@ -451,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

@@ -1,15 +1,15 @@
 ! Copyright (C) 2007, 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: arrays byte-arrays generic assocs hashtables io.binary
+USING: arrays byte-arrays byte-vectors generic assocs hashtables
-kernel kernel.private math namespaces make sequences words
+io.binary kernel kernel.private math namespaces make sequences
-quotations strings alien.accessors alien.strings layouts system
+words quotations strings alien.accessors alien.strings layouts
-combinators math.bitwise words.private math.order accessors
+system combinators math.bitwise words.private math.order
-growable cpu.architecture compiler.constants ;
+accessors growable cpu.architecture compiler.constants ;
 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/compiler.factor

@@ -1,15 +1,14 @@
 ! Copyright (C) 2004, 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: accessors kernel namespaces arrays sequences io debugger
+USING: accessors kernel namespaces arrays sequences io
-words fry continuations vocabs assocs dlists definitions
+words fry continuations vocabs assocs dlists definitions math
-math threads graphs generic combinators deques search-deques
+threads graphs generic combinators deques search-deques io
-prettyprint io stack-checker stack-checker.state
+stack-checker stack-checker.state stack-checker.inlining
-stack-checker.inlining compiler.errors compiler.units
+compiler.errors compiler.units compiler.tree.builder
-compiler.tree.builder compiler.tree.optimizer
+compiler.tree.optimizer compiler.cfg.builder
-compiler.cfg.builder compiler.cfg.optimizer
+compiler.cfg.optimizer compiler.cfg.linearization
-compiler.cfg.linearization compiler.cfg.two-operand
+compiler.cfg.two-operand compiler.cfg.linear-scan
-compiler.cfg.linear-scan compiler.cfg.stack-frame
+compiler.cfg.stack-frame compiler.codegen ;
-compiler.codegen ;
 IN: compiler
 
 SYMBOL: compile-queue
@@ -45,7 +44,7 @@ SYMBOL: +failed+
     2bi ;
 
 : start ( word -- )
-    "trace-compilation" get [ dup . flush ] when
+    "trace-compilation" get [ dup name>> print flush ] when
     H{ } clone dependencies set
     H{ } clone generic-dependencies set
     f swap compiler-error ;

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/dead-code/recursive/recursive.factor

@@ -22,14 +22,11 @@ M: #call-recursive compute-live-values*
     [ out-d>> ] [ label>> return>> in-d>> ] bi look-at-mapping ;
 
 :: drop-dead-inputs ( inputs outputs -- #shuffle )
-    [let* | live-inputs [ inputs filter-live ]
+    inputs filter-live
-            new-live-inputs [ outputs inputs filter-corresponding make-values ] |
+    outputs inputs filter-corresponding make-values
-        live-inputs
+    outputs
-        new-live-inputs
+    inputs
-        outputs
+    drop-values ;
-        inputs
-        drop-values
-    ] ;
 
 M: #enter-recursive remove-dead-code*
     [ filter-live ] change-out-d ;
@@ -79,12 +76,12 @@ M: #call-recursive remove-dead-code*
         bi
     ] ;
 
-M:: #recursive remove-dead-code* ( node -- nodes )
+M: #recursive remove-dead-code* ( node -- nodes )
-    [let* | drop-inputs [ node drop-recursive-inputs ]
+    [ drop-recursive-inputs ]
-            drop-outputs [ node drop-recursive-outputs ] |
+    [
-         node [ (remove-dead-code) ] change-child drop
+        [ (remove-dead-code) ] change-child
-         node label>> [ filter-live ] change-enter-out drop
+        dup label>> [ filter-live ] change-enter-out drop
-         { drop-inputs node drop-outputs }
+    ]
-    ] ;
+    [ drop-recursive-outputs ] tri 3array ;
 
 M: #return-recursive remove-dead-code* ;

basis/compiler/tree/debugger/debugger.factor

@@ -2,8 +2,9 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: kernel assocs match fry accessors namespaces make effects
 sequences sequences.private quotations generic macros arrays
-prettyprint prettyprint.backend prettyprint.sections math words
+prettyprint prettyprint.backend prettyprint.custom
-combinators combinators.short-circuit io sorting hints qualified
+prettyprint.sections math words combinators
+combinators.short-circuit io sorting hints qualified
 compiler.tree
 compiler.tree.recursive
 compiler.tree.normalization
@@ -150,14 +151,14 @@ SYMBOL: node-count
         H{ } clone intrinsics-called set
 
         0 swap [
-            >r 1+ r>
+            [ 1+ ] dip
             dup #call? [
                 word>> {
                     { [ dup "intrinsics" word-prop over "if-intrinsics" word-prop or ] [ intrinsics-called ] }
                     { [ dup generic? ] [ generics-called ] }
                     { [ dup method-body? ] [ methods-called ] }
                     [ words-called ]
-                } cond 1 -rot get at+
+                } cond inc-at
             ] [ drop ] if
         ] each-node
         node-count set

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
-    escape-analysis
+    dup run-escape-analysis? [
-    unbox-tuples
+        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

@@ -48,9 +48,11 @@ M: callable splicing-nodes
     ] [ 2drop f >>method f >>body f >>class drop f ] if ;
 
 : inlining-standard-method ( #call word -- class/f method/f )
-    [ in-d>> <reversed> ] [ [ dispatch# ] keep ] bi*
+    dup "methods" word-prop assoc-empty? [ 2drop f f ] [
-    [ swap nth value-info class>> dup ] dip
+        [ in-d>> <reversed> ] [ [ dispatch# ] keep ] bi*
-    specific-method ;
+        [ swap nth value-info class>> dup ] dip
+        specific-method
+    ] if ;
 
 : inline-standard-method ( #call word -- ? )
     dupd inlining-standard-method eliminate-dispatch ;
@@ -150,7 +152,7 @@ DEFER: (flat-length)
 SYMBOL: history
 
 : remember-inlining ( word -- )
-    [ [ 1 ] dip inlining-count get at+ ]
+    [ inlining-count get inc-at ]
     [ history [ swap suffix ] change ]
     bi ;
 
@@ -184,7 +186,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 +197,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 +204,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/combinators/combinators.factor

@@ -22,7 +22,7 @@ PRIVATE>
     ] (parallel-each) ; inline
 
 : parallel-filter ( seq quot -- newseq )
-    over [ pusher [ each ] dip ] dip like ; inline
+    over [ pusher [ parallel-each ] dip ] dip like ; inline
 
 <PRIVATE
 

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-tests.factor

@@ -0,0 +1,9 @@
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: core-foundation tools.test kernel ;
+IN: core-foundation
+
+[ ] [ "Hello" <CFString> CFRelease ] unit-test
+[ "Hello" ] [ "Hello" <CFString> [ CF>string ] [ CFRelease ] bi ] unit-test
+[ "Hello\u003456" ] [ "Hello\u003456" <CFString> [ CF>string ] [ CFRelease ] bi ] unit-test
+[ "Hello\u013456" ] [ "Hello\u013456" <CFString> [ CF>string ] [ CFRelease ] bi ] unit-test

basis/core-foundation/core-foundation.factor

@@ -1,7 +1,8 @@
 ! Copyright (C) 2006, 2008 Slava Pestov
 ! See http://factorcode.org/license.txt for BSD license.
 USING: alien alien.c-types alien.strings alien.syntax kernel
-math sequences io.encodings.utf16 destructors accessors combinators ;
+math sequences io.encodings.utf8 destructors accessors
+combinators byte-arrays ;
 IN: core-foundation
 
 TYPEDEF: void* CFAllocatorRef
@@ -16,13 +17,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
@@ -65,12 +70,53 @@ FUNCTION: CFURLRef CFURLCreateWithString ( CFAllocatorRef allocator, CFStringRef
 
 FUNCTION: CFURLRef CFURLCopyFileSystemPath ( CFURLRef url, int pathStyle ) ;
 
-FUNCTION: CFStringRef CFStringCreateWithCharacters ( CFAllocatorRef allocator, wchar_t* cStr, CFIndex numChars ) ;
+TYPEDEF: int CFStringEncoding
+: kCFStringEncodingMacRoman HEX: 0 ;
+: kCFStringEncodingWindowsLatin1 HEX: 0500 ;
+: kCFStringEncodingISOLatin1 HEX: 0201 ;
+: kCFStringEncodingNextStepLatin HEX: 0B01 ;
+: kCFStringEncodingASCII HEX: 0600 ;
+: kCFStringEncodingUnicode HEX: 0100 ;
+: kCFStringEncodingUTF8 HEX: 08000100 ;
+: kCFStringEncodingNonLossyASCII HEX: 0BFF ;
+: kCFStringEncodingUTF16 HEX: 0100 ;
+: kCFStringEncodingUTF16BE HEX: 10000100 ;
+: kCFStringEncodingUTF16LE HEX: 14000100 ;
+: kCFStringEncodingUTF32 HEX: 0c000100 ;
+: kCFStringEncodingUTF32BE HEX: 18000100 ;
+: kCFStringEncodingUTF32LE HEX: 1c000100 ;
+
+FUNCTION: CFStringRef CFStringCreateFromExternalRepresentation (
+   CFAllocatorRef alloc,
+   CFDataRef data,
+   CFStringEncoding encoding
+) ;
+
+FUNCTION: CFStringRef CFStringCreateWithBytes (
+   CFAllocatorRef alloc,
+   UInt8* bytes,
+   CFIndex numBytes,
+   CFStringEncoding encoding,
+   Boolean isExternalRepresentation
+) ;
 
 FUNCTION: CFIndex CFStringGetLength ( CFStringRef theString ) ;
 
 FUNCTION: void CFStringGetCharacters ( void* theString, CFIndex start, CFIndex length, void* buffer ) ;
 
+FUNCTION: Boolean CFStringGetCString (
+   CFStringRef theString,
+   char* buffer,
+   CFIndex bufferSize,
+   CFStringEncoding encoding
+) ;
+
+FUNCTION: CFStringRef CFStringCreateWithCString (
+   CFAllocatorRef alloc,
+   char* cStr,
+   CFStringEncoding encoding
+) ;
+
 FUNCTION: CFNumberRef CFNumberCreate ( CFAllocatorRef allocator, CFNumberType theType, void* valuePtr ) ;
 
 FUNCTION: CFDataRef CFDataCreate ( CFAllocatorRef allocator, uchar* bytes, CFIndex length ) ;
@@ -93,12 +139,16 @@ FUNCTION: CFTypeID CFGetTypeID ( CFTypeRef cf ) ;
     [ [ dupd ] dip CFArraySetValueAtIndex ] 2each ;
 
 : <CFString> ( string -- alien )
-    f swap dup length CFStringCreateWithCharacters ;
+    f swap utf8 string>alien kCFStringEncodingUTF8 CFStringCreateWithCString
+    [ "CFStringCreateWithCString failed" throw ] unless* ;
 
 : CF>string ( alien -- string )
-    dup CFStringGetLength 1+ "ushort" <c-array> [
+    dup CFStringGetLength 4 * 1 + <byte-array> [
-        [ 0 over CFStringGetLength ] dip CFStringGetCharacters
+        dup length
-    ] keep utf16n alien>string ;
+        kCFStringEncodingUTF8
+        CFStringGetCString
+        [ "CFStringGetCString failed" throw ] unless
+    ] keep utf8 alien>string ;
 
 : CF>string-array ( alien -- seq )
     CF>array [ CF>string ] map ;
@@ -121,18 +171,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 +208,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

@@ -1,7 +1,6 @@
 ! Copyright (C) 2008 Slava Pestov
 ! See http://factorcode.org/license.txt for BSD license.
-USING: alien.syntax kernel threads init namespaces alien
+USING: alien alien.syntax core-foundation kernel namespaces ;
-core-foundation calendar ;
 IN: core-foundation.run-loop
 
 : kCFRunLoopRunFinished 1 ; inline
@@ -10,6 +9,7 @@ IN: core-foundation.run-loop
 : kCFRunLoopRunHandledSource 4 ; inline
 
 TYPEDEF: void* CFRunLoopRef
+TYPEDEF: void* CFRunLoopSourceRef
 
 FUNCTION: CFRunLoopRef CFRunLoopGetMain ( ) ;
 FUNCTION: CFRunLoopRef CFRunLoopGetCurrent ( ) ;
@@ -20,6 +20,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? [
@@ -27,11 +39,3 @@ FUNCTION: SInt32 CFRunLoopRunInMode (
         "kCFRunLoopDefaultMode" <CFString>
         dup \ CFRunLoopDefaultMode set-global
     ] when ;
-
-: run-loop-thread ( -- )
-    CFRunLoopDefaultMode 0 f CFRunLoopRunInMode
-    kCFRunLoopRunHandledSource = [ 1 seconds sleep ] unless
-    run-loop-thread ;
-
-: start-run-loop-thread ( -- )
-    [ run-loop-thread t ] "CFRunLoop dispatcher" spawn-server drop ;

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

@@ -1,8 +1,16 @@
 ! Copyright (C) 2008 Slava Pestov
 ! See http://factorcode.org/license.txt for BSD license.
-USING: init core-foundation.run-loop ;
+USING: calendar core-foundation.run-loop init kernel threads ;
 IN: core-foundation.run-loop.thread
 
 ! Load this vocabulary if you need a run loop running.
 
+: run-loop-thread ( -- )
+    CFRunLoopDefaultMode 0 f CFRunLoopRunInMode
+    kCFRunLoopRunHandledSource = [ 1 seconds sleep ] unless
+    run-loop-thread ;
+
+: start-run-loop-thread ( -- )
+    [ run-loop-thread t ] "CFRunLoop dispatcher" spawn-server drop ;
+
 [ start-run-loop-thread ] "core-foundation.run-loop.thread" add-init-hook

basis/cpu/architecture/architecture.factor

@@ -77,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 -- )
@@ -120,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/32/bootstrap.factor

@@ -10,19 +10,19 @@ IN: bootstrap.x86
 : shift-arg ( -- reg ) ECX ;
 : div-arg ( -- reg ) EAX ;
 : mod-arg ( -- reg ) EDX ;
-: arg0 ( -- reg ) EAX ;
+: temp0 ( -- reg ) EAX ;
-: arg1 ( -- reg ) EDX ;
+: temp1 ( -- reg ) EDX ;
-: arg2 ( -- reg ) ECX ;
+: temp2 ( -- reg ) ECX ;
-: temp-reg ( -- reg ) EBX ;
+: temp3 ( -- reg ) EBX ;
 : stack-reg ( -- reg ) ESP ;
 : ds-reg ( -- reg ) ESI ;
 : rs-reg ( -- reg ) EDI ;
-: fixnum>slot@ ( -- ) arg0 1 SAR ;
+: fixnum>slot@ ( -- ) temp0 1 SAR ;
 : rex-length ( -- n ) 0 ;
 
 [
-    arg0 0 [] MOV                              ! load stack_chain
+    temp0 0 [] MOV                              ! load stack_chain
-    arg0 [] stack-reg MOV                      ! save stack pointer
+    temp0 [] stack-reg MOV                      ! save stack pointer
 ] rc-absolute-cell rt-stack-chain 2 jit-save-stack jit-define
 
 [

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/64/bootstrap.factor

@@ -9,7 +9,10 @@ IN: bootstrap.x86
 : shift-arg ( -- reg ) RCX ;
 : div-arg ( -- reg ) RAX ;
 : mod-arg ( -- reg ) RDX ;
-: temp-reg ( -- reg ) RBX ;
+: temp0 ( -- reg ) RDI ;
+: temp1 ( -- reg ) RSI ;
+: temp2 ( -- reg ) RDX ;
+: temp3 ( -- reg ) RBX ;
 : stack-reg ( -- reg ) RSP ;
 : ds-reg ( -- reg ) R14 ;
 : rs-reg ( -- reg ) R15 ;
@@ -17,14 +20,14 @@ IN: bootstrap.x86
 : rex-length ( -- n ) 1 ;
 
 [
-    arg0 0 MOV                                 ! load stack_chain
+    temp0 0 MOV                                 ! load stack_chain
-    arg0 arg0 [] MOV
+    temp0 temp0 [] MOV
-    arg0 [] stack-reg MOV                      ! save stack pointer
+    temp0 [] stack-reg MOV                      ! save stack pointer
 ] rc-absolute-cell rt-stack-chain 1 rex-length + jit-save-stack jit-define
 
 [
-    arg1 0 MOV                                 ! load XT
+    temp1 0 MOV                                 ! load XT
-    arg1 JMP                                   ! go
+    temp1 JMP                                   ! go
 ] rc-absolute-cell rt-primitive 1 rex-length + jit-primitive jit-define
 
 << "resource:basis/cpu/x86/bootstrap.factor" parse-file parsed >>

basis/cpu/x86/64/unix/bootstrap.factor

@@ -5,9 +5,6 @@ cpu.x86.assembler layouts vocabs parser ;
 IN: bootstrap.x86
 
 : stack-frame-size ( -- n ) 4 bootstrap-cells ;
-: arg0 ( -- reg ) RDI ;
-: arg1 ( -- reg ) RSI ;
-: arg2 ( -- reg ) RDX ;
 
 << "resource:basis/cpu/x86/64/bootstrap.factor" parse-file parsed >>
 call

basis/cpu/x86/64/winnt/bootstrap.factor

@@ -5,9 +5,6 @@ cpu.x86.assembler layouts vocabs parser ;
 IN: bootstrap.x86
 
 : stack-frame-size ( -- n ) 8 bootstrap-cells ;
-: arg0 ( -- reg ) RCX ;
-: arg1 ( -- reg ) RDX ;
-: arg2 ( -- reg ) R8 ;
 
 << "resource:basis/cpu/x86/64/bootstrap.factor" parse-file parsed >>
 call

basis/cpu/x86/assembler/assembler.factor

@@ -346,7 +346,7 @@ M: label JUMPcc (JUMPcc) label-fixup ;
 : LEAVE ( -- ) HEX: c9 , ;
 
 : RET ( n -- )
-    dup zero? [ drop HEX: c3 , ] [ HEX: C2 , 2, ] if ;
+    dup zero? [ drop HEX: c3 , ] [ HEX: c2 , 2, ] if ;
 
 ! Arithmetic
 
@@ -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

@@ -12,28 +12,35 @@ big-endian off
 
 [
     ! Load word
-    temp-reg 0 MOV
+    temp0 0 MOV
     ! Bump profiling counter
-    temp-reg profile-count-offset [+] 1 tag-fixnum ADD
+    temp0 profile-count-offset [+] 1 tag-fixnum ADD
     ! Load word->code
-    temp-reg temp-reg word-code-offset [+] MOV
+    temp0 temp0 word-code-offset [+] MOV
     ! Compute word XT
-    temp-reg compiled-header-size ADD
+    temp0 compiled-header-size ADD
     ! Jump to XT
-    temp-reg JMP
+    temp0 JMP
 ] rc-absolute-cell rt-immediate 1 rex-length + jit-profiling jit-define
 
 [
-    temp-reg 0 MOV                             ! load XT
+    ! load XT
-    stack-frame-size PUSH                      ! save stack frame size
+    temp0 0 MOV
-    temp-reg PUSH                              ! push XT
+    ! save stack frame size
-    stack-reg stack-frame-size 3 bootstrap-cells - SUB   ! alignment
+    stack-frame-size PUSH
+    ! push XT
+    temp0 PUSH
+    ! alignment
+    stack-reg stack-frame-size 3 bootstrap-cells - SUB
 ] rc-absolute-cell rt-label 1 rex-length + jit-prolog jit-define
 
 [
-    arg0 0 MOV                                 ! load literal
+    ! load literal
-    ds-reg bootstrap-cell ADD                  ! increment datastack pointer
+    temp0 0 MOV
-    ds-reg [] arg0 MOV                         ! store literal on datastack
+    ! increment datastack pointer
+    ds-reg bootstrap-cell ADD
+    ! store literal on datastack
+    ds-reg [] temp0 MOV
 ] rc-absolute-cell rt-immediate 1 rex-length + jit-push-immediate jit-define
 
 [
@@ -45,73 +52,85 @@ big-endian off
 ] rc-relative rt-xt 1 jit-word-call jit-define
 
 [
-    arg0 ds-reg [] MOV                         ! load boolean
+    ! load boolean
-    ds-reg bootstrap-cell SUB                  ! pop boolean
+    temp0 ds-reg [] MOV
-    arg0 \ f tag-number CMP                    ! compare boolean with f
+    ! pop boolean
-    f JNE                                      ! jump to true branch if not equal
+    ds-reg bootstrap-cell SUB
+    ! compare boolean with f
+    temp0 \ f tag-number CMP
+    ! jump to true branch if not equal
+    f JNE
 ] rc-relative rt-xt 10 rex-length 3 * + jit-if-1 jit-define
 
 [
-    f JMP                                      ! jump to false branch if equal
+    ! jump to false branch if equal
+    f JMP
 ] rc-relative rt-xt 1 jit-if-2 jit-define
 
 [
-    arg1 0 MOV                                 ! load dispatch table
+    ! load dispatch table
-    arg0 ds-reg [] MOV                         ! load index
+    temp1 0 MOV
-    fixnum>slot@                               ! turn it into an array offset
+    ! load index
-    ds-reg bootstrap-cell SUB                  ! pop index
+    temp0 ds-reg [] MOV
-    arg0 arg1 ADD                              ! compute quotation location
+    ! turn it into an array offset
-    arg0 arg0 array-start-offset [+] MOV       ! load quotation
+    fixnum>slot@
-    arg0 quot-xt-offset [+] JMP                ! execute branch
+    ! pop index
+    ds-reg bootstrap-cell SUB
+    ! compute quotation location
+    temp0 temp1 ADD
+    ! load quotation
+    temp0 temp0 array-start-offset [+] MOV
+    ! execute branch
+    temp0 quot-xt-offset [+] JMP
 ] rc-absolute-cell rt-immediate 1 rex-length + jit-dispatch jit-define
 
 : jit->r ( -- )
     rs-reg bootstrap-cell ADD
-    arg0 ds-reg [] MOV
+    temp0 ds-reg [] MOV
     ds-reg bootstrap-cell SUB
-    rs-reg [] arg0 MOV ;
+    rs-reg [] temp0 MOV ;
 
 : jit-2>r ( -- )
     rs-reg 2 bootstrap-cells ADD
-    arg0 ds-reg [] MOV
+    temp0 ds-reg [] MOV
-    arg1 ds-reg -1 bootstrap-cells [+] MOV
+    temp1 ds-reg -1 bootstrap-cells [+] MOV
     ds-reg 2 bootstrap-cells SUB
-    rs-reg [] arg0 MOV
+    rs-reg [] temp0 MOV
-    rs-reg -1 bootstrap-cells [+] arg1 MOV ;
+    rs-reg -1 bootstrap-cells [+] temp1 MOV ;
 
 : jit-3>r ( -- )
     rs-reg 3 bootstrap-cells ADD
-    arg0 ds-reg [] MOV
+    temp0 ds-reg [] MOV
-    arg1 ds-reg -1 bootstrap-cells [+] MOV
+    temp1 ds-reg -1 bootstrap-cells [+] MOV
-    arg2 ds-reg -2 bootstrap-cells [+] MOV
+    temp2 ds-reg -2 bootstrap-cells [+] MOV
     ds-reg 3 bootstrap-cells SUB
-    rs-reg [] arg0 MOV
+    rs-reg [] temp0 MOV
-    rs-reg -1 bootstrap-cells [+] arg1 MOV
+    rs-reg -1 bootstrap-cells [+] temp1 MOV
-    rs-reg -2 bootstrap-cells [+] arg2 MOV ;
+    rs-reg -2 bootstrap-cells [+] temp2 MOV ;
 
 : jit-r> ( -- )
     ds-reg bootstrap-cell ADD
-    arg0 rs-reg [] MOV
+    temp0 rs-reg [] MOV
     rs-reg bootstrap-cell SUB
-    ds-reg [] arg0 MOV ;
+    ds-reg [] temp0 MOV ;
 
 : jit-2r> ( -- )
     ds-reg 2 bootstrap-cells ADD
-    arg0 rs-reg [] MOV
+    temp0 rs-reg [] MOV
-    arg1 rs-reg -1 bootstrap-cells [+] MOV
+    temp1 rs-reg -1 bootstrap-cells [+] MOV
     rs-reg 2 bootstrap-cells SUB
-    ds-reg [] arg0 MOV
+    ds-reg [] temp0 MOV
-    ds-reg -1 bootstrap-cells [+] arg1 MOV ;
+    ds-reg -1 bootstrap-cells [+] temp1 MOV ;
 
 : jit-3r> ( -- )
     ds-reg 3 bootstrap-cells ADD
-    arg0 rs-reg [] MOV
+    temp0 rs-reg [] MOV
-    arg1 rs-reg -1 bootstrap-cells [+] MOV
+    temp1 rs-reg -1 bootstrap-cells [+] MOV
-    arg2 rs-reg -2 bootstrap-cells [+] MOV
+    temp2 rs-reg -2 bootstrap-cells [+] MOV
     rs-reg 3 bootstrap-cells SUB
-    ds-reg [] arg0 MOV
+    ds-reg [] temp0 MOV
-    ds-reg -1 bootstrap-cells [+] arg1 MOV
+    ds-reg -1 bootstrap-cells [+] temp1 MOV
-    ds-reg -2 bootstrap-cells [+] arg2 MOV ;
+    ds-reg -2 bootstrap-cells [+] temp2 MOV ;
 
 [
     jit->r
@@ -126,13 +145,14 @@ big-endian off
 ] rc-relative rt-xt 17 rex-length 6 * + jit-2dip jit-define
 
 [
-    jit-3>r                                    
+    jit-3>r
     f CALL
     jit-3r>
 ] rc-relative rt-xt 23 rex-length 8 * + jit-3dip jit-define
 
 [
-    stack-reg stack-frame-size bootstrap-cell - ADD ! unwind stack frame
+    ! unwind stack frame
+    stack-reg stack-frame-size bootstrap-cell - ADD
 ] f f f jit-epilog jit-define
 
 [ 0 RET ] f f f jit-return jit-define
@@ -141,34 +161,51 @@ big-endian off
 
 ! Quotations and words
 [
-    arg0 ds-reg [] MOV                         ! load from stack
+    ! load from stack
-    ds-reg bootstrap-cell SUB                  ! pop stack
+    temp0 ds-reg [] MOV
-    arg0 quot-xt-offset [+] JMP                ! call quotation
+    ! pop stack
+    ds-reg bootstrap-cell SUB
+    ! call quotation
+    temp0 quot-xt-offset [+] JMP
 ] f f f \ (call) define-sub-primitive
 
 [
-    arg0 ds-reg [] MOV                         ! load from stack
+    ! load from stack
-    ds-reg bootstrap-cell SUB                  ! pop stack
+    temp0 ds-reg [] MOV
-    arg0 word-xt-offset [+] JMP                ! execute word
+    ! pop stack
+    ds-reg bootstrap-cell SUB
+    ! execute word
+    temp0 word-xt-offset [+] JMP
 ] f f f \ (execute) define-sub-primitive
 
 ! Objects
 [
-    arg1 ds-reg [] MOV                         ! load from stack
+    ! load from stack
-    arg1 tag-mask get AND                      ! compute tag
+    temp0 ds-reg [] MOV
-    arg1 tag-bits get SHL                      ! tag the tag
+    ! compute tag
-    ds-reg [] arg1 MOV                         ! push to stack
+    temp0 tag-mask get AND
+    ! tag the tag
+    temp0 tag-bits get SHL
+    ! push to stack
+    ds-reg [] temp0 MOV
 ] f f f \ tag define-sub-primitive
 
 [
-    arg0 ds-reg [] MOV                         ! load slot number
+    ! load slot number
-    ds-reg bootstrap-cell SUB                  ! adjust stack pointer
+    temp0 ds-reg [] MOV
-    arg1 ds-reg [] MOV                         ! load object
+    ! adjust stack pointer
-    fixnum>slot@                               ! turn slot number into offset
+    ds-reg bootstrap-cell SUB
-    arg1 tag-bits get SHR                      ! mask off tag
+    ! load object
-    arg1 tag-bits get SHL
+    temp1 ds-reg [] MOV
-    arg0 arg1 arg0 [+] MOV                     ! load slot value
+    ! turn slot number into offset
-    ds-reg [] arg0 MOV                         ! push to stack
+    fixnum>slot@
+    ! mask off tag
+    temp1 tag-bits get SHR
+    temp1 tag-bits get SHL
+    ! load slot value
+    temp0 temp1 temp0 [+] MOV
+    ! push to stack
+    ds-reg [] temp0 MOV
 ] f f f \ slot define-sub-primitive
 
 ! Shufflers
@@ -185,100 +222,100 @@ big-endian off
 ] f f f \ 3drop define-sub-primitive
 
 [
-    arg0 ds-reg [] MOV
+    temp0 ds-reg [] MOV
     ds-reg bootstrap-cell ADD
-    ds-reg [] arg0 MOV
+    ds-reg [] temp0 MOV
 ] f f f \ dup define-sub-primitive
 
 [
-    arg0 ds-reg [] MOV
+    temp0 ds-reg [] MOV
-    arg1 ds-reg bootstrap-cell neg [+] MOV
+    temp1 ds-reg bootstrap-cell neg [+] MOV
     ds-reg 2 bootstrap-cells ADD
-    ds-reg [] arg0 MOV
+    ds-reg [] temp0 MOV
-    ds-reg bootstrap-cell neg [+] arg1 MOV
+    ds-reg bootstrap-cell neg [+] temp1 MOV
 ] f f f \ 2dup define-sub-primitive
 
 [
-    arg0 ds-reg [] MOV
+    temp0 ds-reg [] MOV
-    arg1 ds-reg -1 bootstrap-cells [+] MOV
+    temp1 ds-reg -1 bootstrap-cells [+] MOV
-    temp-reg ds-reg -2 bootstrap-cells [+] MOV
+    temp3 ds-reg -2 bootstrap-cells [+] MOV
     ds-reg 3 bootstrap-cells ADD
-    ds-reg [] arg0 MOV
+    ds-reg [] temp0 MOV
-    ds-reg -1 bootstrap-cells [+] arg1 MOV
+    ds-reg -1 bootstrap-cells [+] temp1 MOV
-    ds-reg -2 bootstrap-cells [+] temp-reg MOV
+    ds-reg -2 bootstrap-cells [+] temp3 MOV
 ] f f f \ 3dup define-sub-primitive
 
 [
-    arg0 ds-reg [] MOV
+    temp0 ds-reg [] MOV
     ds-reg bootstrap-cell SUB
-    ds-reg [] arg0 MOV
+    ds-reg [] temp0 MOV
 ] f f f \ nip define-sub-primitive
 
 [
-    arg0 ds-reg [] MOV
+    temp0 ds-reg [] MOV
     ds-reg 2 bootstrap-cells SUB
-    ds-reg [] arg0 MOV
+    ds-reg [] temp0 MOV
 ] f f f \ 2nip define-sub-primitive
 
 [
-    arg0 ds-reg -1 bootstrap-cells [+] MOV
+    temp0 ds-reg -1 bootstrap-cells [+] MOV
     ds-reg bootstrap-cell ADD
-    ds-reg [] arg0 MOV
+    ds-reg [] temp0 MOV
 ] f f f \ over define-sub-primitive
 
 [
-    arg0 ds-reg -2 bootstrap-cells [+] MOV
+    temp0 ds-reg -2 bootstrap-cells [+] MOV
     ds-reg bootstrap-cell ADD
-    ds-reg [] arg0 MOV
+    ds-reg [] temp0 MOV
 ] f f f \ pick define-sub-primitive
 
 [
-    arg0 ds-reg [] MOV
+    temp0 ds-reg [] MOV
-    arg1 ds-reg -1 bootstrap-cells [+] MOV
+    temp1 ds-reg -1 bootstrap-cells [+] MOV
-    ds-reg [] arg1 MOV
+    ds-reg [] temp1 MOV
     ds-reg bootstrap-cell ADD
-    ds-reg [] arg0 MOV
+    ds-reg [] temp0 MOV
 ] f f f \ dupd define-sub-primitive
 
 [
-    arg0 ds-reg [] MOV
+    temp0 ds-reg [] MOV
-    arg1 ds-reg -1 bootstrap-cells [+] MOV
+    temp1 ds-reg -1 bootstrap-cells [+] MOV
     ds-reg bootstrap-cell ADD
-    ds-reg [] arg0 MOV
+    ds-reg [] temp0 MOV
-    ds-reg -1 bootstrap-cells [+] arg1 MOV
+    ds-reg -1 bootstrap-cells [+] temp1 MOV
-    ds-reg -2 bootstrap-cells [+] arg0 MOV
+    ds-reg -2 bootstrap-cells [+] temp0 MOV
 ] f f f \ tuck define-sub-primitive
 
 [
-    arg0 ds-reg [] MOV
+    temp0 ds-reg [] MOV
-    arg1 ds-reg bootstrap-cell neg [+] MOV
+    temp1 ds-reg bootstrap-cell neg [+] MOV
-    ds-reg bootstrap-cell neg [+] arg0 MOV
+    ds-reg bootstrap-cell neg [+] temp0 MOV
-    ds-reg [] arg1 MOV
+    ds-reg [] temp1 MOV
 ] f f f \ swap define-sub-primitive
 
 [
-    arg0 ds-reg -1 bootstrap-cells [+] MOV
+    temp0 ds-reg -1 bootstrap-cells [+] MOV
-    arg1 ds-reg -2 bootstrap-cells [+] MOV
+    temp1 ds-reg -2 bootstrap-cells [+] MOV
-    ds-reg -2 bootstrap-cells [+] arg0 MOV
+    ds-reg -2 bootstrap-cells [+] temp0 MOV
-    ds-reg -1 bootstrap-cells [+] arg1 MOV
+    ds-reg -1 bootstrap-cells [+] temp1 MOV
 ] f f f \ swapd define-sub-primitive
 
 [
-    arg0 ds-reg [] MOV
+    temp0 ds-reg [] MOV
-    arg1 ds-reg -1 bootstrap-cells [+] MOV
+    temp1 ds-reg -1 bootstrap-cells [+] MOV
-    temp-reg ds-reg -2 bootstrap-cells [+] MOV
+    temp3 ds-reg -2 bootstrap-cells [+] MOV
-    ds-reg -2 bootstrap-cells [+] arg1 MOV
+    ds-reg -2 bootstrap-cells [+] temp1 MOV
-    ds-reg -1 bootstrap-cells [+] arg0 MOV
+    ds-reg -1 bootstrap-cells [+] temp0 MOV
-    ds-reg [] temp-reg MOV
+    ds-reg [] temp3 MOV
 ] f f f \ rot define-sub-primitive
 
 [
-    arg0 ds-reg [] MOV
+    temp0 ds-reg [] MOV
-    arg1 ds-reg -1 bootstrap-cells [+] MOV
+    temp1 ds-reg -1 bootstrap-cells [+] MOV
-    temp-reg ds-reg -2 bootstrap-cells [+] MOV
+    temp3 ds-reg -2 bootstrap-cells [+] MOV
-    ds-reg -2 bootstrap-cells [+] arg0 MOV
+    ds-reg -2 bootstrap-cells [+] temp0 MOV
-    ds-reg -1 bootstrap-cells [+] temp-reg MOV
+    ds-reg -1 bootstrap-cells [+] temp3 MOV
-    ds-reg [] arg1 MOV
+    ds-reg [] temp1 MOV
 ] f f f \ -rot define-sub-primitive
 
 [ jit->r ] f f f \ >r define-sub-primitive
@@ -287,14 +324,20 @@ big-endian off
 
 ! Comparisons
 : jit-compare ( insn -- )
-    temp-reg 0 MOV                             ! load t
+    ! load t
-    arg1 \ f tag-number MOV                    ! load f
+    temp3 0 MOV
-    arg0 ds-reg [] MOV                         ! load first value
+    ! load f
-    ds-reg bootstrap-cell SUB                  ! adjust stack pointer
+    temp1 \ f tag-number MOV
-    ds-reg [] arg0 CMP                         ! compare with second value
+    ! load first value
-    [ arg1 temp-reg ] dip execute              ! move t if true
+    temp0 ds-reg [] MOV
-    ds-reg [] arg1 MOV                         ! store
+    ! adjust stack pointer
-    ;
+    ds-reg bootstrap-cell SUB
+    ! compare with second value
+    ds-reg [] temp0 CMP
+    ! move t if true
+    [ temp1 temp3 ] dip execute
+    ! store
+    ds-reg [] temp1 MOV ;
 
 : define-jit-compare ( insn word -- )
     [ [ jit-compare ] curry rc-absolute-cell rt-immediate 1 rex-length + ] dip
@@ -308,22 +351,30 @@ big-endian off
 
 ! Math
 : jit-math ( insn -- )
-    arg0 ds-reg [] MOV                         ! load second input
+    ! load second input
-    ds-reg bootstrap-cell SUB                  ! pop stack
+    temp0 ds-reg [] MOV
-    [ ds-reg [] arg0 ] dip execute             ! compute result
+    ! pop stack
-    ;
+    ds-reg bootstrap-cell SUB
+    ! compute result
+    [ ds-reg [] temp0 ] dip execute ;
 
 [ \ ADD jit-math ] f f f \ fixnum+fast define-sub-primitive
 
 [ \ SUB jit-math ] f f f \ fixnum-fast define-sub-primitive
 
 [
-    arg0 ds-reg [] MOV                         ! load second input
+    ! load second input
-    ds-reg bootstrap-cell SUB                  ! pop stack
+    temp0 ds-reg [] MOV
-    arg1 ds-reg [] MOV                         ! load first input
+    ! pop stack
-    arg0 tag-bits get SAR                      ! untag second input
+    ds-reg bootstrap-cell SUB
-    arg0 arg1 IMUL2                            ! multiply
+    ! load first input
-    ds-reg [] arg1 MOV                         ! push result
+    temp1 ds-reg [] MOV
+    ! untag second input
+    temp0 tag-bits get SAR
+    ! multiply
+    temp0 temp1 IMUL2
+    ! push result
+    ds-reg [] temp1 MOV
 ] f f f \ fixnum*fast define-sub-primitive
 
 [ \ AND jit-math ] f f f \ fixnum-bitand define-sub-primitive
@@ -333,75 +384,106 @@ big-endian off
 [ \ XOR jit-math ] f f f \ fixnum-bitxor define-sub-primitive
 
 [
-    ds-reg [] NOT                              ! complement
+    ! complement
-    ds-reg [] tag-mask get XOR                 ! clear tag bits
+    ds-reg [] NOT
+    ! clear tag bits
+    ds-reg [] tag-mask get XOR
 ] f f f \ fixnum-bitnot define-sub-primitive
 
 [
-    shift-arg ds-reg [] MOV                    ! load shift count
+    ! load shift count
-    shift-arg tag-bits get SAR                 ! untag shift count
+    shift-arg ds-reg [] MOV
-    ds-reg bootstrap-cell SUB                  ! adjust stack pointer
+    ! untag shift count
-    temp-reg ds-reg [] MOV                     ! load value
+    shift-arg tag-bits get SAR
-    arg1 temp-reg MOV                          ! make a copy
+    ! adjust stack pointer
-    arg1 CL SHL                                ! compute positive shift value in arg1
+    ds-reg bootstrap-cell SUB
-    shift-arg NEG                              ! compute negative shift value in arg0
+    ! load value
-    temp-reg CL SAR
+    temp3 ds-reg [] MOV
-    temp-reg tag-mask get bitnot AND
+    ! make a copy
-    shift-arg 0 CMP                            ! if shift count was negative, move arg0 to arg1
+    temp1 temp3 MOV
-    arg1 temp-reg CMOVGE
+    ! compute positive shift value in temp1
-    ds-reg [] arg1 MOV                         ! push to stack
+    temp1 CL SHL
+    shift-arg NEG
+    ! compute negative shift value in temp3
+    temp3 CL SAR
+    temp3 tag-mask get bitnot AND
+    shift-arg 0 CMP
+    ! if shift count was negative, move temp0 to temp1
+    temp1 temp3 CMOVGE
+    ! push to stack
+    ds-reg [] temp1 MOV
 ] f f f \ fixnum-shift-fast define-sub-primitive
 
 : jit-fixnum-/mod ( -- )
-    temp-reg ds-reg [] MOV                     ! load second parameter
+    ! load second parameter
-    div-arg ds-reg bootstrap-cell neg [+] MOV  ! load first parameter
+    temp3 ds-reg [] MOV
-    mod-arg div-arg MOV                        ! make a copy
+    ! load first parameter
-    mod-arg bootstrap-cell-bits 1- SAR         ! sign-extend
+    div-arg ds-reg bootstrap-cell neg [+] MOV
-    temp-reg IDIV ;                            ! divide
+    ! make a copy
+    mod-arg div-arg MOV
+    ! sign-extend
+    mod-arg bootstrap-cell-bits 1- SAR
+    ! divide
+    temp3 IDIV ;
 
 [
     jit-fixnum-/mod
-    ds-reg bootstrap-cell SUB                  ! adjust stack pointer
+    ! adjust stack pointer
-    ds-reg [] mod-arg MOV                      ! push to stack
+    ds-reg bootstrap-cell SUB
+    ! push to stack
+    ds-reg [] mod-arg MOV
 ] f f f \ fixnum-mod define-sub-primitive
 
 [
     jit-fixnum-/mod
-    ds-reg bootstrap-cell SUB                  ! adjust stack pointer
+    ! adjust stack pointer
-    div-arg tag-bits get SHL                   ! tag it
+    ds-reg bootstrap-cell SUB
-    ds-reg [] div-arg MOV                      ! push to stack
+    ! tag it
+    div-arg tag-bits get SHL
+    ! push to stack
+    ds-reg [] div-arg MOV
 ] f f f \ fixnum/i-fast define-sub-primitive
 
 [
     jit-fixnum-/mod
-    div-arg tag-bits get SHL                   ! tag it
+    ! tag it
-    ds-reg [] mod-arg MOV                      ! push to stack
+    div-arg tag-bits get SHL
+    ! push to stack
+    ds-reg [] mod-arg MOV
     ds-reg bootstrap-cell neg [+] div-arg MOV
 ] f f f \ fixnum/mod-fast define-sub-primitive
 
 [
-    arg0 ds-reg [] MOV
+    temp0 ds-reg [] MOV
-    arg0 ds-reg bootstrap-cell neg [+] OR
+    ds-reg bootstrap-cell SUB
-    ds-reg bootstrap-cell ADD
+    temp0 ds-reg [] OR
-    arg0 tag-mask get AND
+    temp0 tag-mask get AND
-    arg0 \ f tag-number MOV
+    temp0 \ f tag-number MOV
-    arg1 1 tag-fixnum MOV
+    temp1 1 tag-fixnum MOV
-    arg0 arg1 CMOVE
+    temp0 temp1 CMOVE
-    ds-reg [] arg0 MOV
+    ds-reg [] temp0 MOV
 ] f f f \ both-fixnums? define-sub-primitive
 
 [
-    arg0 ds-reg [] MOV                         ! load local number
+    ! load local number
-    fixnum>slot@                               ! turn local number into offset
+    temp0 ds-reg [] MOV
-    arg0 rs-reg arg0 [+] MOV                   ! load local value
+    ! turn local number into offset
-    ds-reg [] arg0 MOV                         ! push to stack
+    fixnum>slot@
+    ! load local value
+    temp0 rs-reg temp0 [+] MOV
+    ! push to stack
+    ds-reg [] temp0 MOV
 ] f f f \ get-local define-sub-primitive
 
 [
-    arg0 ds-reg [] MOV                         ! load local count
+    ! load local count
-    ds-reg bootstrap-cell SUB                  ! adjust stack pointer
+    temp0 ds-reg [] MOV
-    fixnum>slot@                               ! turn local number into offset
+    ! adjust stack pointer
-    rs-reg arg0 SUB                            ! decrement retain stack pointer
+    ds-reg bootstrap-cell SUB
+    ! turn local number into offset
+    fixnum>slot@
+    ! decrement retain stack pointer
+    rs-reg temp0 SUB
 ] f f f \ drop-locals define-sub-primitive
 
 [ "bootstrap.x86" forget-vocab ] with-compilation-unit

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
@@ -391,7 +394,7 @@ M:: x86 %string-nth ( dst src index temp -- )
     ] with-small-register ;
 
 M:: x86 %set-string-nth-fast ( ch str index temp -- )
-    ch { index str } [| new-ch |
+    ch { index str temp } [| new-ch |
         new-ch ch ?MOV
         temp str index [+] LEA
         temp string-offset [+] new-ch 1 small-reg MOV
@@ -458,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 ( -- )
@@ -485,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 -- )
@@ -595,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/db-docs.factor

@@ -229,7 +229,7 @@ ARTICLE: "db-protocol" "Low-level database protocol"
 { $subsection db-open }
 "Closing a database:"
 { $subsection db-close }
-"Creating tatements:"
+"Creating statements:"
 { $subsection <simple-statement> }
 { $subsection <prepared-statement> }
 "Using statements with the database:"

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

@@ -22,9 +22,6 @@ M: tuple error-help class ;
 
 M: string error. print ;
 
-: :error ( -- )
-    error get error. ;
-
 : :s ( -- )
     error-continuation get data>> stack. ;
 
@@ -63,6 +60,9 @@ M: string error. print ;
     [ global [ "Error in print-error!" print drop ] bind ]
     recover ;
 
+: :error ( -- )
+    error get print-error ;
+
 : print-error-and-restarts ( error -- )
     print-error
     restarts.
@@ -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/delegate/delegate.factor

@@ -2,7 +2,7 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors parser generic kernel classes classes.tuple
 words slots assocs sequences arrays vectors definitions
-prettyprint math hashtables sets generalizations namespaces make ;
+math hashtables sets generalizations namespaces make ;
 IN: delegate
 
 : protocol-words ( protocol -- words )
@@ -100,6 +100,4 @@ M: protocol definition protocol-words show-words ;
 
 M: protocol definer drop \ PROTOCOL: \ ; ;
 
-M: protocol synopsis* word-synopsis ; ! Necessary?
-
 M: protocol group-words protocol-words ;

basis/delegate/protocols/protocols.factor

@@ -1,8 +1,7 @@
 ! Copyright (C) 2007 Daniel Ehrenberg
 ! See http://factorcode.org/license.txt for BSD license.
 USING: delegate sequences.private sequences assocs
-prettyprint.sections io definitions kernel continuations
+io definitions kernel continuations ;
-listener ;
 IN: delegate.protocols
 
 PROTOCOL: sequence-protocol
@@ -16,7 +15,7 @@ PROTOCOL: assoc-protocol
 
 PROTOCOL: input-stream-protocol
     stream-read1 stream-read stream-read-partial stream-readln
-    stream-read-until stream-read-quot ;
+    stream-read-until ;
 
 PROTOCOL: output-stream-protocol
     stream-flush stream-write1 stream-write stream-format

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"