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

.gitignore

@@ -20,3 +20,4 @@ temp
 logs
 work
 build-support/wordsize
+*.bak

Makefile

@@ -161,7 +161,7 @@ factor: $(DLL_OBJS) $(EXE_OBJS)
 
 clean:
 	rm -f vm/*.o
-	rm -f factor*.dll libfactor*.*
+	rm -f factor*.dll libfactor.{a,so,dylib}
 
 vm/resources.o:
 	$(WINDRES) vm/factor.rs vm/resources.o

README.txt

@@ -43,13 +43,10 @@ Compilation will yield an executable named 'factor' on Unix,
 
 For X11 support, you need recent development libraries for libc,
 Freetype, X11, OpenGL and GLUT. On a Debian-derived Linux distribution
-(like Ubuntu), you can use the line
+(like Ubuntu), you can use the following line to grab everything:
 
     sudo apt-get install libc6-dev libfreetype6-dev libx11-dev glutg3-dev
 
-to grab everything (if you're on a non-debian-derived distro please tell
-us what the equivalent command is on there and it can be added).
-
 * Bootstrapping the Factor image
 
 Once you have compiled the Factor runtime, you must bootstrap the Factor

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
 
@@ -35,7 +35,7 @@ ERROR: bad-alarm-frequency frequency ;
     [ time>> ] dip before=? ;
 
 : reschedule-alarm ( alarm -- )
-    dup [ swap interval>> time+ ] change-time register-alarm ;
+    dup [ swap interval>> time+ now max ] change-time register-alarm ;
 
 : call-alarm ( alarm -- )
     [ entry>> box> drop ]

basis/alien/arrays/arrays-docs.factor

@@ -1,69 +1,7 @@
 IN: alien.arrays
 USING: help.syntax help.markup byte-arrays alien.c-types ;
 
-ARTICLE: "c-arrays-factor" "Converting C arrays to and from Factor arrays"
-"Each primitive C type has a pair of words, " { $snippet ">" { $emphasis "type" } "-array" } " and " { $snippet { $emphasis "type" } "-array>" } ", for converting an array of Factor objects to and from a " { $link byte-array } " of C values. This set of words consists of:"
-{ $subsection >c-bool-array      }
-{ $subsection >c-char-array      }
-{ $subsection >c-double-array    }
-{ $subsection >c-float-array     }
-{ $subsection >c-int-array       }
-{ $subsection >c-long-array      }
-{ $subsection >c-longlong-array  }
-{ $subsection >c-short-array     }
-{ $subsection >c-uchar-array     }
-{ $subsection >c-uint-array      }
-{ $subsection >c-ulong-array     }
-{ $subsection >c-ulonglong-array }
-{ $subsection >c-ushort-array    }
-{ $subsection >c-void*-array     }
-{ $subsection c-bool-array>      }
-{ $subsection c-char-array>      }
-{ $subsection c-double-array>    }
-{ $subsection c-float-array>     }
-{ $subsection c-int-array>       }
-{ $subsection c-long-array>      }
-{ $subsection c-longlong-array>  }
-{ $subsection c-short-array>     }
-{ $subsection c-uchar-array>     }
-{ $subsection c-uint-array>      }
-{ $subsection c-ulong-array>     }
-{ $subsection c-ulonglong-array> }
-{ $subsection c-ushort-array>    }
-{ $subsection c-void*-array>     } ;
-
-ARTICLE: "c-arrays-get/set" "Reading and writing elements in C arrays"
-"Each C type has a pair of words, " { $snippet { $emphasis "type" } "-nth" } " and " { $snippet "set-" { $emphasis "type" } "-nth" } ", for reading and writing values of this type stored in an array. This set of words includes but is not limited to:"
-{ $subsection char-nth }
-{ $subsection set-char-nth }
-{ $subsection uchar-nth }
-{ $subsection set-uchar-nth }
-{ $subsection short-nth }
-{ $subsection set-short-nth }
-{ $subsection ushort-nth }
-{ $subsection set-ushort-nth }
-{ $subsection int-nth }
-{ $subsection set-int-nth }
-{ $subsection uint-nth }
-{ $subsection set-uint-nth }
-{ $subsection long-nth }
-{ $subsection set-long-nth }
-{ $subsection ulong-nth }
-{ $subsection set-ulong-nth }
-{ $subsection longlong-nth }
-{ $subsection set-longlong-nth }
-{ $subsection ulonglong-nth }
-{ $subsection set-ulonglong-nth }
-{ $subsection float-nth }
-{ $subsection set-float-nth }
-{ $subsection double-nth }
-{ $subsection set-double-nth }
-{ $subsection void*-nth }
-{ $subsection set-void*-nth } ;
-
 ARTICLE: "c-arrays" "C arrays"
 "C arrays are allocated in the same manner as other C data; see " { $link "c-byte-arrays" } " and " { $link "malloc" } "."
 $nl
-"C type specifiers for array types are documented in " { $link "c-types-specs" } "."
+"C type specifiers for array types are documented in " { $link "c-types-specs" } "." ;
-{ $subsection "c-arrays-factor" }
-{ $subsection "c-arrays-get/set" } ;

basis/alien/arrays/arrays.factor

@@ -8,6 +8,8 @@ UNION: value-type array struct-type ;
 
 M: array c-type ;
 
+M: array c-type-class drop object ;
+
 M: array heap-size unclip heap-size [ * ] reduce ;
 
 M: array c-type-align first c-type-align ;

basis/alien/c-types/c-types-docs.factor

@@ -89,16 +89,6 @@ HELP: malloc-byte-array
 { $warning "Don't forget to deallocate the memory with a call to " { $link free } "." }
 { $errors "Throws an error if memory allocation fails." } ;
 
-HELP: define-nth
-{ $values { "name" "a word name" } { "vocab" "a vocabulary name" } }
-{ $description "Defines a word " { $snippet { $emphasis "name" } "-nth" } " with stack effect " { $snippet "( n c-ptr -- value )" } " for reading the value with C type " { $snippet "name" } " stored at an alien pointer, displaced by a multiple of the C type's size." }
-{ $notes "This is an internal word called when defining C types, there is no need to call it on your own." } ;
-
-HELP: define-set-nth
-{ $values { "name" "a word name" } { "vocab" "a vocabulary name" } }
-{ $description "Defines a word " { $snippet "set-" { $emphasis "name" } "-nth" } " with stack effect " { $snippet "( value n c-ptr -- )" } " for writing the value with C type " { $snippet "name" } " to an alien pointer, displaced by a multiple of the C type's size." }
-{ $notes "This is an internal word called when defining C types, there is no need to call it on your own." } ;
-
 HELP: box-parameter
 { $values { "n" integer } { "ctype" string } }
 { $description "Generates code for converting a C value stored at  offset " { $snippet "n" } " from the top of the stack into a Factor object to be pushed on the data stack." }
@@ -115,12 +105,12 @@ HELP: unbox-return
 { $notes "This is an internal word used by the compiler when compiling callbacks." } ;
 
 HELP: define-deref
-{ $values { "name" "a word name" } { "vocab" "a vocabulary name" } }
+{ $values { "name" "a word name" } }
 { $description "Defines a word " { $snippet "*name" } " with stack effect " { $snippet "( c-ptr -- value )" } " for reading a value with C type " { $snippet "name" } " stored at an alien pointer." }
 { $notes "This is an internal word called when defining C types, there is no need to call it on your own." } ;
 
 HELP: define-out
-{ $values { "name" "a word name" } { "vocab" "a vocabulary name" } }
+{ $values { "name" "a word name" } }
 { $description "Defines a word " { $snippet "<" { $emphasis "name" } ">" } " with stack effect " { $snippet "( value -- array )" } ". This word allocates a byte array large enough to hold a value with C type " { $snippet "name" } ", and writes the value at the top of the stack to the array." }
 { $notes "This is an internal word called when defining C types, there is no need to call it on your own." } ;
 
@@ -230,9 +220,7 @@ $nl
 "You can copy a range of bytes from memory into a byte array:"
 { $subsection memory>byte-array }
 "You can copy a byte array to memory unsafely:"
-{ $subsection byte-array>memory }
+{ $subsection byte-array>memory } ;
-"A wrapper for temporarily allocating a block of memory:"
-{ $subsection with-malloc } ;
 
 ARTICLE: "c-data" "Passing data between Factor and C"
 "Two defining characteristics of Factor are dynamic typing and automatic memory management, which are somewhat incompatible with the machine-level data model exposed by C. Factor's C library interface defines its own set of C data types, distinct from Factor language types, together with automatic conversion between Factor values and C types. For example, C integer types must be declared and are fixed-width, whereas Factor supports arbitrary-precision integers."

basis/alien/c-types/c-types-tests.factor

@@ -8,7 +8,7 @@ sequences system libc alien.strings io.encodings.utf8 ;
 
 [ { "blah" 123 } ] [ { "blah" xyz } expand-constants ] unit-test
 
-: foo ( -- n ) "fdafd" f dlsym [ 123 ] unless* ;
+: foo ( -- n ) &: fdafd [ 123 ] unless* ;
 
 [ 123 ] [ foo ] unit-test
 
@@ -55,4 +55,6 @@ TYPEDEF: uchar* MyLPBYTE
     0 B{ 1 2 3 4 } <displaced-alien> <void*>
 ] must-fail
 
-[ t ] [ { t f t } >c-bool-array { 1 0 1 } >c-int-array = ] unit-test
+os windows? cpu x86.64? and [
+    [ -2147467259 ] [ 2147500037 <long> *long ] unit-test
+] when

basis/alien/c-types/c-types.factor

@@ -4,7 +4,7 @@ USING: byte-arrays arrays assocs kernel kernel.private libc math
 namespaces make parser sequences strings words assocs splitting
 math.parser cpu.architecture alien alien.accessors quotations
 layouts system compiler.units io.files io.encodings.binary
-accessors combinators effects continuations ;
+accessors combinators effects continuations fry ;
 IN: alien.c-types
 
 DEFER: <int>
@@ -13,13 +13,15 @@ DEFER: *char
 : little-endian? ( -- ? ) 1 <int> *char 1 = ; foldable
 
 TUPLE: c-type
+class
 boxer boxer-quot unboxer unboxer-quot
 getter setter
 reg-class size align stack-align? ;
 
 : new-c-type ( class -- type )
     new
-        int-regs >>reg-class ;
+        int-regs >>reg-class
+        object >>class ; inline
 
 : <c-type> ( -- type )
     \ c-type new-c-type ;
@@ -50,7 +52,7 @@ GENERIC: c-type ( name -- type ) foldable
 
 : parse-array-type ( name -- array )
     "[" split unclip
-    >r [ "]" ?tail drop string>number ] map r> prefix ;
+    [ [ "]" ?tail drop string>number ] map ] dip prefix ;
 
 M: string c-type ( name -- type )
     CHAR: ] over member? [
@@ -63,6 +65,12 @@ M: string c-type ( name -- type )
         ] ?if
     ] if ;
 
+GENERIC: c-type-class ( name -- class )
+
+M: c-type c-type-class class>> ;
+
+M: string c-type-class c-type c-type-class ;
+
 GENERIC: c-type-boxer ( name -- boxer )
 
 M: c-type c-type-boxer boxer>> ;
@@ -164,7 +172,7 @@ GENERIC: stack-size ( type -- size ) foldable
 
 M: string stack-size c-type stack-size ;
 
-M: c-type stack-size size>> ;
+M: c-type stack-size size>> cell align ;
 
 GENERIC: byte-length ( seq -- n ) flushable
 
@@ -172,12 +180,12 @@ M: byte-array byte-length length ;
 
 : c-getter ( name -- quot )
     c-type-getter [
-        [ "Cannot read struct fields with type" throw ]
+        [ "Cannot read struct fields with this type" throw ]
     ] unless* ;
 
 : c-setter ( name -- quot )
     c-type-setter [
-        [ "Cannot write struct fields with type" throw ]
+        [ "Cannot write struct fields with this type" throw ]
     ] unless* ;
 
 : <c-array> ( n type -- array )
@@ -193,36 +201,21 @@ M: byte-array byte-length length ;
     1 swap malloc-array ; inline
 
 : malloc-byte-array ( byte-array -- alien )
-    dup length dup malloc [ -rot memcpy ] keep ;
+    dup length [ nip malloc dup ] 2keep memcpy ;
 
 : memory>byte-array ( alien len -- byte-array )
-    dup <byte-array> [ -rot memcpy ] keep ;
+    [ nip (byte-array) dup ] 2keep memcpy ;
 
 : byte-array>memory ( byte-array base -- )
     swap dup length memcpy ;
 
-: (define-nth) ( word type quot -- )
+: array-accessor ( type quot -- def )
     [
         \ swap , [ heap-size , [ * >fixnum ] % ] [ % ] bi*
-    ] [ ] make define-inline ;
+    ] [ ] make ;
-
-: nth-word ( name vocab -- word )
-    >r "-nth" append r> create ;
-
-: define-nth ( name vocab -- )
-    dupd nth-word swap dup c-getter (define-nth) ;
-
-: set-nth-word ( name vocab -- word )
-    >r "set-" swap "-nth" 3append r> create ;
-
-: define-set-nth ( name vocab -- )
-    dupd set-nth-word swap dup c-setter (define-nth) ;
 
 : typedef ( old new -- ) c-types get set-at ;
 
-: define-c-type ( type name vocab -- )
-    >r tuck typedef r> [ define-nth ] 2keep define-set-nth ;
-
 TUPLE: long-long-type < c-type ;
 
 : <long-long-type> ( -- type )
@@ -240,62 +233,34 @@ M: long-long-type box-parameter ( n type -- )
 M: long-long-type box-return ( type -- )
     f swap box-parameter ;
 
-: define-deref ( name vocab -- )
+: define-deref ( name -- )
-    >r dup CHAR: * prefix r> create
+    [ CHAR: * prefix "alien.c-types" create ]
-    swap c-getter 0 prefix define-inline ;
+    [ c-getter 0 prefix ] bi
+    define-inline ;
 
-: define-out ( name vocab -- )
+: define-out ( name -- )
-    over [ <c-object> tuck 0 ] over c-setter append swap
+    [ "alien.c-types" constructor-word ]
-    >r >r constructor-word r> r> prefix define-inline ;
+    [ dup c-setter '[ _ <c-object> [ 0 @ ] keep ] ]
+    bi define-inline ;
 
 : c-bool> ( int -- ? )
     zero? not ;
 
-: >c-array ( seq type word -- byte-array )
-    [ [ dup length ] dip <c-array> ] dip
-    [ [ execute ] 2curry each-index ] 2keep drop ; inline
-
-: >c-array-quot ( type vocab -- quot )
-    dupd set-nth-word [ >c-array ] 2curry ;
-
-: to-array-word ( name vocab -- word )
-    >r ">c-" swap "-array" 3append r> create ;
-
-: define-to-array ( type vocab -- )
-    [ to-array-word ] 2keep >c-array-quot
-    (( array -- byte-array )) define-declared ;
-
-: c-array>quot ( type vocab -- quot )
-    [
-        \ swap ,
-        nth-word 1quotation ,
-        [ curry map ] %
-    ] [ ] make ;
-
-: from-array-word ( name vocab -- word )
-    >r "c-" swap "-array>" 3append r> create ;
-
-: define-from-array ( type vocab -- )
-    [ from-array-word ] 2keep c-array>quot
-    (( c-ptr n -- array )) define-declared ;
-
 : define-primitive-type ( type name -- )
-    "alien.c-types"
+    [ typedef ]
-    {
+    [ define-deref ]
-        [ define-c-type ]
+    [ define-out ]
-        [ define-deref ]
+    tri ;
-        [ define-to-array ]
-        [ define-from-array ]
-        [ define-out ]
-    } 2cleave ;
 
 : expand-constants ( c-type -- c-type' )
     dup array? [
-        unclip >r [
+        unclip [
-            dup word? [
+            [
-                def>> { } swap with-datastack first
+                dup word? [
-            ] when
+                    def>> { } swap with-datastack first
-        ] map r> prefix
+                ] when
+            ] map
+        ] dip prefix
     ] when ;
 
 : malloc-file-contents ( path -- alien len )
@@ -304,8 +269,20 @@ M: long-long-type box-return ( type -- )
 : if-void ( type true false -- )
     pick "void" = [ drop nip call ] [ nip call ] if ; inline
 
+: primitive-types
+    {
+        "char" "uchar"
+        "short" "ushort"
+        "int" "uint"
+        "long" "ulong"
+        "longlong" "ulonglong"
+        "float" "double"
+        "void*" "bool"
+    } ;
+
 [
     <c-type>
+        c-ptr >>class
         [ alien-cell ] >>getter
         [ set-alien-cell ] >>setter
         bootstrap-cell >>size
@@ -315,6 +292,7 @@ M: long-long-type box-return ( type -- )
     "void*" define-primitive-type
 
     <long-long-type>
+        integer >>class
         [ alien-signed-8 ] >>getter
         [ set-alien-signed-8 ] >>setter
         8 >>size
@@ -324,6 +302,7 @@ M: long-long-type box-return ( type -- )
     "longlong" define-primitive-type
 
     <long-long-type>
+        integer >>class
         [ alien-unsigned-8 ] >>getter
         [ set-alien-unsigned-8 ] >>setter
         8 >>size
@@ -333,6 +312,7 @@ M: long-long-type box-return ( type -- )
     "ulonglong" define-primitive-type
 
     <c-type>
+        integer >>class
         [ alien-signed-cell ] >>getter
         [ set-alien-signed-cell ] >>setter
         bootstrap-cell >>size
@@ -342,6 +322,7 @@ M: long-long-type box-return ( type -- )
     "long" define-primitive-type
 
     <c-type>
+        integer >>class
         [ alien-unsigned-cell ] >>getter
         [ set-alien-unsigned-cell ] >>setter
         bootstrap-cell >>size
@@ -351,6 +332,7 @@ M: long-long-type box-return ( type -- )
     "ulong" define-primitive-type
 
     <c-type>
+        integer >>class
         [ alien-signed-4 ] >>getter
         [ set-alien-signed-4 ] >>setter
         4 >>size
@@ -360,6 +342,7 @@ M: long-long-type box-return ( type -- )
     "int" define-primitive-type
 
     <c-type>
+        integer >>class
         [ alien-unsigned-4 ] >>getter
         [ set-alien-unsigned-4 ] >>setter
         4 >>size
@@ -369,6 +352,7 @@ M: long-long-type box-return ( type -- )
     "uint" define-primitive-type
 
     <c-type>
+        fixnum >>class
         [ alien-signed-2 ] >>getter
         [ set-alien-signed-2 ] >>setter
         2 >>size
@@ -378,6 +362,7 @@ M: long-long-type box-return ( type -- )
     "short" define-primitive-type
 
     <c-type>
+        fixnum >>class
         [ alien-unsigned-2 ] >>getter
         [ set-alien-unsigned-2 ] >>setter
         2 >>size
@@ -387,6 +372,7 @@ M: long-long-type box-return ( type -- )
     "ushort" define-primitive-type
 
     <c-type>
+        fixnum >>class
         [ alien-signed-1 ] >>getter
         [ set-alien-signed-1 ] >>setter
         1 >>size
@@ -396,6 +382,7 @@ M: long-long-type box-return ( type -- )
     "char" define-primitive-type
 
     <c-type>
+        fixnum >>class
         [ alien-unsigned-1 ] >>getter
         [ set-alien-unsigned-1 ] >>setter
         1 >>size
@@ -414,6 +401,7 @@ M: long-long-type box-return ( type -- )
     "bool" define-primitive-type
 
     <c-type>
+        float >>class
         [ alien-float ] >>getter
         [ [ >float ] 2dip set-alien-float ] >>setter
         4 >>size
@@ -425,6 +413,7 @@ M: long-long-type box-return ( type -- )
     "float" define-primitive-type
 
     <c-type>
+        float >>class
         [ alien-double ] >>getter
         [ [ >float ] 2dip set-alien-double ] >>setter
         8 >>size
@@ -436,6 +425,6 @@ M: long-long-type box-return ( type -- )
     "double" define-primitive-type
 
     "long" "ptrdiff_t" typedef
-
+    "long" "intptr_t" typedef
     "ulong" "size_t" typedef
 ] with-compilation-unit

basis/alien/parser/parser.factor

@@ -0,0 +1,19 @@
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: alien alien.c-types arrays assocs effects grouping kernel
+parser sequences splitting words fry locals ;
+IN: alien.parser
+
+: parse-arglist ( parameters return -- types effect )
+    [ 2 group unzip [ "," ?tail drop ] map ]
+    [ [ { } ] [ 1array ] if-void ]
+    bi* <effect> ;
+
+: function-quot ( return library function types -- quot )
+    '[ _ _ _ _ alien-invoke ] ;
+
+:: define-function ( return library function parameters -- )
+    function create-in dup reset-generic
+    return library function
+    parameters return parse-arglist [ function-quot ] dip
+    define-declared ;

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,14 +2,14 @@
 ! 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 ;
+alien strings cpu.architecture fry vocabs.loader combinators ;
 IN: alien.strings
 
 GENERIC# alien>string 1 ( c-ptr encoding -- string/f )
 
 M: c-ptr alien>string
-    >r <memory-stream> r> <decoder>
+    [ <memory-stream> ] [ <decoder> ] bi*
     "\0" swap stream-read-until drop ;
 
 M: f alien>string
@@ -40,6 +40,9 @@ PREDICATE: string-type < pair
 
 M: string-type c-type ;
 
+M: string-type c-type-class
+    drop object ;
+
 M: string-type heap-size
     drop "void*" heap-size ;
 
@@ -74,10 +77,10 @@ M: string-type c-type-unboxer
     drop "void*" c-type-unboxer ;
 
 M: string-type c-type-boxer-quot
-    second [ alien>string ] curry [ ] like ;
+    second '[ _ alien>string ] ;
 
 M: string-type c-type-unboxer-quot
-    second [ string>alien ] curry [ ] like ;
+    second '[ _ string>alien ] ;
 
 M: string-type c-type-getter
     drop [ alien-cell ] ;
@@ -85,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/structs/fields/fields.factor

@@ -29,10 +29,10 @@ PREDICATE: slot-writer < word "writing" word-prop >boolean ;
     writer>> swap "writing" set-word-prop ;
 
 : reader-word ( class name vocab -- word )
-    >r >r "-" r> 3append r> create ;
+    [ "-" glue ] dip create ;
 
 : writer-word ( class name vocab -- word )
-    >r [ swap "set-" % % "-" % % ] "" make r> create ;
+    [ [ swap "set-" % % "-" % % ] "" make ] dip create ;
 
 : <field-spec> ( struct-name vocab type field-name -- spec )
     field-spec new
@@ -52,25 +52,21 @@ PREDICATE: slot-writer < word "writing" word-prop >boolean ;
         [ (>>offset) ] [ type>> heap-size + ] 2bi
     ] reduce ;
 
-: define-struct-slot-word ( spec word quot -- )
+: define-struct-slot-word ( word quot spec -- )
-    rot offset>> prefix define-inline ;
+    offset>> prefix define-inline ;
 
 : define-getter ( type spec -- )
     [ set-reader-props ] keep
-    [ ]
     [ reader>> ]
     [
         type>>
         [ c-getter ] [ c-type-boxer-quot ] bi append
-    ] tri
+    ]
-    define-struct-slot-word ;
+    [ ] tri define-struct-slot-word ;
 
 : define-setter ( type spec -- )
     [ set-writer-props ] keep
-    [ ]
+    [ writer>> ] [ type>> c-setter ] [ ] tri define-struct-slot-word ;
-    [ writer>> ]
-    [ type>> c-setter ] tri
-    define-struct-slot-word ;
 
 : define-field ( type spec -- )
     [ define-getter ] [ define-setter ] 2bi ;

basis/alien/structs/structs-tests.factor

@@ -38,7 +38,7 @@ C-UNION: barx
 [ 120 ] [ "barx" heap-size ] unit-test
 
 "help" vocab [
-    "help" "help" lookup "help" set
+    "print-topic" "help" lookup "help" set
     [ ] [ \ foox-x "help" get execute ] unit-test
     [ ] [ \ set-foox-x "help" get execute ] unit-test
 ] when

basis/alien/structs/structs.factor

@@ -1,58 +1,63 @@
 ! Copyright (C) 2004, 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors arrays generic hashtables kernel kernel.private
-math namespaces parser sequences strings words libc
+math namespaces parser sequences strings words libc fry
 alien.c-types alien.structs.fields cpu.architecture ;
 IN: alien.structs
 
-: if-value-structs? ( ctype true false -- )
-    value-structs?
-    [ drop call ] [ >r 2drop "void*" r> call ] if ; inline
-
 TUPLE: struct-type size align fields ;
 
 M: struct-type heap-size size>> ;
 
+M: struct-type c-type-class drop object ;
+
 M: struct-type c-type-align align>> ;
 
 M: struct-type c-type-stack-align? drop f ;
 
-M: struct-type unbox-parameter
+: if-value-struct ( ctype true false -- )
-    [ %unbox-struct ] [ unbox-parameter ] if-value-structs? ;
+    [ dup value-struct? ] 2dip '[ drop "void*" @ ] if ; inline
 
-M: struct-type unbox-return
+M: struct-type unbox-parameter
-    f swap %unbox-struct ;
+    [ %unbox-large-struct ] [ unbox-parameter ] if-value-struct ;
 
 M: struct-type box-parameter
-    [ %box-struct ] [ box-parameter ] if-value-structs? ;
+    [ %box-large-struct ] [ box-parameter ] if-value-struct ;
+
+: if-small-struct ( c-type true false -- ? )
+    [ dup struct-small-enough? ] 2dip '[ f swap @ ] if ; inline
+
+M: struct-type unbox-return
+    [ %unbox-small-struct ] [ %unbox-large-struct ] if-small-struct ;
 
 M: struct-type box-return
-    f swap %box-struct ;
+    [ %box-small-struct ] [ %box-large-struct ] if-small-struct ;
 
 M: struct-type stack-size
-    [ heap-size ] [ stack-size ] if-value-structs? ;
+    [ heap-size ] [ stack-size ] if-value-struct ;
 
 : c-struct? ( type -- ? ) (c-type) struct-type? ;
 
-: (define-struct) ( name vocab size align fields -- )
+: (define-struct) ( name size align fields -- )
-    >r [ align ] keep r>
+    [ [ align ] keep ] dip
     struct-type boa
-    -rot define-c-type ;
+    swap typedef ;
 
-: define-struct-early ( name vocab fields -- fields )
+: make-fields ( name vocab fields -- fields )
-    -rot [ rot first2 <field-spec> ] 2curry map ;
+    [ first2 <field-spec> ] with with map ;
 
 : compute-struct-align ( types -- n )
     [ c-type-align ] map supremum ;
 
 : define-struct ( name vocab fields -- )
-    pick >r
+    [
-    [ struct-offsets ] keep
+        [ 2drop ] [ make-fields ] 3bi
-    [ [ type>> ] map compute-struct-align ] keep
+        [ struct-offsets ] keep
-    [ (define-struct) ] keep
+        [ [ type>> ] map compute-struct-align ] keep
-    r> [ swap define-field ] curry each ;
+        [ (define-struct) ] keep
+    ] [ 2drop '[ _ swap define-field ] ] 3bi each ;
 
-: define-union ( name vocab members -- )
+: define-union ( name members -- )
     [ expand-constants ] map
     [ [ heap-size ] map supremum ] keep
     compute-struct-align f (define-struct) ;

basis/alien/syntax/syntax-docs.factor

@@ -1,5 +1,5 @@
 IN: alien.syntax
-USING: alien alien.c-types alien.structs alien.syntax.private
+USING: alien alien.c-types alien.parser alien.structs
 help.markup help.syntax ;
 
 HELP: DLL"
@@ -54,12 +54,6 @@ HELP: TYPEDEF:
 { $description "Aliases the C type " { $snippet "old" } " under the name " { $snippet "new" } " if ." }
 { $notes "This word differs from " { $link typedef } " in that it runs at parse time, to ensure correct ordering of operations when loading source files. Words defined in source files are compiled before top-level forms are run, so if a source file defines C binding words and uses " { $link typedef } ", the type alias won't be available at compile time." } ;
 
-HELP: TYPEDEF-IF:
-{ $syntax "TYPEDEF-IF: word old new" }
-{ $values { "word" "a word with stack effect " { $snippet "( -- ? )" } } { "old" "a C type" } { "new" "a C type" } }
-{ $description "Aliases the C type " { $snippet "old" } " under the name " { $snippet "new" } " if " { $snippet "word" } " evaluates to a true value." }
-{ $notes "This word differs from " { $link typedef } " in that it runs at parse time, to ensure correct ordering of operations when loading source files. Words defined in source files are compiled before top-level forms are run, so if a source file defines C binding words and uses " { $link typedef } ", the type alias won't be available at compile time." } ;
-
 HELP: C-STRUCT:
 { $syntax "C-STRUCT: name pairs... ;" }
 { $values { "name" "a new C type name" } { "pairs" "C type / field name string pairs" } }
@@ -83,12 +77,17 @@ HELP: C-ENUM:
     { $code "C-ENUM: red green blue ;" ": red 0 ;  : green 1 ;  : blue 2 ;" }
 } ;
 
+HELP: &:
+{ $syntax "&: symbol" }
+{ $values { "symbol" "A C library symbol name" } }
+{ $description "Pushes the address of a symbol named " { $snippet "symbol" } " from the current library, set with " { $link POSTPONE: LIBRARY: } "." } ;
+
 HELP: typedef
 { $values { "old" "a string" } { "new" "a string" } }
 { $description "Alises the C type " { $snippet "old" } " under the name " { $snippet "new" } "." }
 { $notes "Using this word in the same source file which defines C bindings can cause problems, because words are compiled before top-level forms are run. Use the " { $link POSTPONE: TYPEDEF: } " word instead." } ;
 
-{ POSTPONE: TYPEDEF-IF: POSTPONE: TYPEDEF: typedef } related-words
+{ POSTPONE: TYPEDEF: typedef } related-words
 
 HELP: c-struct?
 { $values { "type" "a string" } { "?" "a boolean" } }

basis/alien/syntax/syntax.factor

@@ -3,36 +3,10 @@
 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 ;
+fry ;
 IN: alien.syntax
 
-<PRIVATE
-
-: parse-arglist ( return seq -- types effect )
-    2 group dup keys swap values [ "," ?tail drop ] map
-    rot dup "void" = [ drop { } ] [ 1array ] if <effect> ;
-
-: function-quot ( type lib func types -- quot )
-    [ alien-invoke ] 2curry 2curry ;
-
-: define-function ( return library function parameters -- )
-    >r pick r> parse-arglist
-    pick create-in dup reset-generic
-    >r >r function-quot r> r> 
-    -rot define-declared ;
-
-PRIVATE>
-
-: indirect-quot ( function-ptr-quot return types abi -- quot )
-    [ alien-indirect ] 3curry compose ;
-
-: define-indirect ( abi return function-ptr-quot function-name parameters -- )
-    >r pick r> parse-arglist
-    rot create-in dup reset-generic
-    >r >r swapd roll indirect-quot r> r>
-    -rot define-declared ;
-
 : DLL" lexer get skip-blank parse-string dlopen parsed ; parsing
 
 : ALIEN: scan string>number <alien> parsed ; parsing
@@ -49,29 +23,18 @@ PRIVATE>
 : TYPEDEF:
     scan scan typedef ; parsing
 
-: TYPEDEF-IF:
-    scan-word execute scan scan rot [ typedef ] [ 2drop ] if ; parsing
-
 : C-STRUCT:
-    scan in get
+    scan in get parse-definition define-struct ; parsing
-    parse-definition
-    >r 2dup r> define-struct-early
-    define-struct ; parsing
 
 : C-UNION:
-    scan in get parse-definition define-union ; parsing
+    scan parse-definition define-union ; parsing
 
 : C-ENUM:
     ";" parse-tokens
     dup length
-    [ >r create-in r> 1quotation define ] 2each ;
+    [ [ create-in ] dip 1quotation define ] 2each ;
     parsing
 
-M: alien pprint*
+: &:
-    {
+    scan "c-library" get
-        { [ dup expired? ] [ drop \ BAD-ALIEN pprint-word ] }
+    '[ _ _ load-library dlsym ] over push-all ; parsing
-        { [ 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 ;
+parser prettyprint.custom fry ;
 IN: bit-arrays
 
 TUPLE: bit-array
@@ -24,9 +24,8 @@ TUPLE: bit-array
 : bits>bytes 7 + n>byte ; inline
 
 : (set-bits) ( bit-array n -- )
-    [ [ length bits>cells ] keep ] dip
+    [ [ length bits>cells ] keep ] dip swap underlying>>
-    [ -rot underlying>> set-uint-nth ] 2curry
+    '[ [ _ _ ] dip set-alien-unsigned-4 ] each ; inline
-    each ; inline
 
 PRIVATE>
 
@@ -74,19 +73,19 @@ 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 ;
 
 : bit-array>integer ( bit-array -- n )
-    0 swap underlying>> [ length ] keep [
+    0 swap underlying>> dup length [
-        uchar-nth swap 8 shift bitor
+        alien-unsigned-1 swap 8 shift bitor
-    ] curry each ;
+    ] with each ;
 
 INSTANCE: bit-array sequence
 

basis/bit-vectors/bit-vectors-tests.factor

@@ -4,7 +4,7 @@ USING: tools.test bit-vectors vectors sequences kernel math ;
 [ 0 ] [ 123 <bit-vector> length ] unit-test
 
 : do-it
-    1234 swap [ >r even? r> push ] curry each ;
+    1234 swap [ [ even? ] dip push ] curry each ;
 
 [ t ] [
     3 <bit-vector> dup do-it

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/help/help.factor

@@ -1,6 +1,6 @@
 USING: help help.topics help.syntax help.crossref
 help.definitions io io.files kernel namespaces vocabs sequences
-parser vocabs.loader ;
+parser vocabs.loader vocabs.loader.private accessors assocs ;
 IN: bootstrap.help
 
 : load-help ( -- )
@@ -10,8 +10,8 @@ IN: bootstrap.help
     t load-help? set-global
 
     [ drop ] load-vocab-hook [
-        vocabs
+        dictionary get values
-        [ vocab-docs-loaded? not ] filter
+        [ docs-loaded?>> not ] filter
         [ load-docs ] each
     ] with-variable ;
 

basis/bootstrap/image/download/download.factor

@@ -1,6 +1,6 @@
 ! Copyright (C) 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: http.client checksums checksums.openssl splitting assocs
+USING: http.client checksums checksums.md5 splitting assocs
 kernel io.files bootstrap.image sequences io urls ;
 IN: bootstrap.image.download
 
@@ -13,7 +13,7 @@ IN: bootstrap.image.download
 : need-new-image? ( image -- ? )
     dup exists?
     [
-        [ openssl-md5 checksum-file hex-string ]
+        [ md5 checksum-file hex-string ]
         [ download-checksums at ]
         bi = not
     ] [ drop t ] if ;

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 ;
@@ -72,7 +72,7 @@ SYMBOL: objects
 : put-object ( n obj -- ) (objects) set-at ;
 
 : cache-object ( obj quot -- value )
-    >r (objects) r> [ obj>> ] prepose cache ; inline
+    [ (objects) ] dip [ obj>> ] prepose cache ; inline
 
 ! Constants
 
@@ -97,10 +97,10 @@ SYMBOL: sub-primitives
     { [ { } make ] [ ] [ ] [ ] } spread 4array ; inline
 
 : jit-define ( quot rc rt offset name -- )
-    >r make-jit r> set ; inline
+    [ make-jit ] dip set ; inline
 
 : define-sub-primitive ( quot rc rt offset word -- )
-    >r make-jit r> sub-primitives get set-at ;
+    [ make-jit ] dip sub-primitives get set-at ;
 
 ! The image being constructed; a vector of word-size integers
 SYMBOL: image
@@ -124,12 +124,18 @@ SYMBOL: jit-primitive-word
 SYMBOL: jit-primitive
 SYMBOL: jit-word-jump
 SYMBOL: jit-word-call
-SYMBOL: jit-push-literal
 SYMBOL: jit-push-immediate
 SYMBOL: jit-if-word
-SYMBOL: jit-if-jump
+SYMBOL: jit-if-1
+SYMBOL: jit-if-2
 SYMBOL: jit-dispatch-word
 SYMBOL: jit-dispatch
+SYMBOL: jit-dip-word
+SYMBOL: jit-dip
+SYMBOL: jit-2dip-word
+SYMBOL: jit-2dip
+SYMBOL: jit-3dip-word
+SYMBOL: jit-3dip
 SYMBOL: jit-epilog
 SYMBOL: jit-return
 SYMBOL: jit-profiling
@@ -139,8 +145,8 @@ SYMBOL: jit-save-stack
 ! Default definition for undefined words
 SYMBOL: undefined-quot
 
-: userenv-offset ( symbol -- n )
+: userenvs ( -- assoc )
-    {
+    H{
         { bootstrap-boot-quot 20 }
         { bootstrap-global 21 }
         { jit-code-format 22 }
@@ -149,9 +155,9 @@ SYMBOL: undefined-quot
         { jit-primitive 25 }
         { jit-word-jump 26 }
         { jit-word-call 27 }
-        { jit-push-literal 28 }
+        { jit-if-word 28 }
-        { jit-if-word 29 }
+        { jit-if-1 29 }
-        { jit-if-jump 30 }
+        { jit-if-2 30 }
         { jit-dispatch-word 31 }
         { jit-dispatch 32 }
         { jit-epilog 33 }
@@ -160,8 +166,17 @@ SYMBOL: undefined-quot
         { jit-push-immediate 36 }
         { jit-declare-word 42 }
         { jit-save-stack 43 }
+        { jit-dip-word 44 }
+        { jit-dip 45 }
+        { jit-2dip-word 46 }
+        { jit-2dip 47 }
+        { jit-3dip-word 48 }
+        { jit-3dip 49 }
         { undefined-quot 60 }
-    } at header-size + ;
+    } ; inline
+
+: userenv-offset ( symbol -- n )
+    userenvs at header-size + ;
 
 : emit ( cell -- ) image get push ;
 
@@ -190,7 +205,7 @@ SYMBOL: undefined-quot
 : emit-fixnum ( n -- ) tag-fixnum emit ;
 
 : emit-object ( header tag quot -- addr )
-    swap here-as >r swap tag-fixnum emit call align-here r> ;
+    swap here-as [ swap tag-fixnum emit call align-here ] dip ;
     inline
 
 ! Write an object to the image.
@@ -336,7 +351,12 @@ M: wrapper '
 : pad-bytes ( seq -- newseq )
     dup length bootstrap-cell align 0 pad-right ;
 
+: check-string ( string -- )
+    [ 127 > ] contains?
+    [ "Bootstrap cannot emit non-ASCII strings" throw ] when ;
+
 : emit-string ( string -- ptr )
+    dup check-string
     string type-number object tag-number [
         dup length emit-fixnum
         f ' emit
@@ -443,6 +463,9 @@ M: quotation '
     \ dispatch jit-dispatch-word set
     \ do-primitive jit-primitive-word set
     \ declare jit-declare-word set
+    \ dip jit-dip-word set
+    \ 2dip jit-2dip-word set
+    \ 3dip jit-3dip-word set
     [ undefined ] undefined-quot set
     {
         jit-code-format
@@ -451,12 +474,18 @@ M: quotation '
         jit-primitive
         jit-word-jump
         jit-word-call
-        jit-push-literal
         jit-push-immediate
         jit-if-word
-        jit-if-jump
+        jit-if-1
+        jit-if-2
         jit-dispatch-word
         jit-dispatch
+        jit-dip-word
+        jit-dip
+        jit-2dip-word
+        jit-2dip
+        jit-3dip-word
+        jit-3dip
         jit-epilog
         jit-return
         jit-profiling

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
@@ -32,7 +32,7 @@ SYMBOL: bootstrap-time
 : count-words ( pred -- )
     all-words swap count number>string write ;
 
-: print-time ( time -- )
+: print-time ( ms -- )
     1000 /i
     60 /mod swap
     number>string write
@@ -59,15 +59,15 @@ SYMBOL: bootstrap-time
     "math compiler threads help io tools ui ui.tools unicode handbook" "include" set-global
     "" "exclude" set-global
 
-    parse-command-line
+    (command-line) parse-command-line
 
-    "-no-crossref" cli-args member? [ do-crossref ] unless
+    do-crossref
 
     ! Set dll paths
     os wince? [ "windows.ce" require ] when
     os winnt? [ "windows.nt" require ] when
 
-    "deploy-vocab" get [
+    "staging" get "deploy-vocab" get or [
         "stage2: deployment mode" print
     ] [
         "listener" require
@@ -86,30 +86,22 @@ 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
+        ] [
-            [
+            "resource:basis/bootstrap/finish-bootstrap.factor" run-file
-                parse-command-line
+        ] if
-                run-user-init
-                "run" get run
-                output-stream get [ stream-flush ] when*
-            ] [ print-error 1 exit ] recover
-        ] set-boot-quot
-
-        millis swap - bootstrap-time set-global
-        print-report
 
         "output-image" get save-image-and-exit
     ] if
 ] [
-    :c
+    drop
-    dup print-error flush
+    load-help? off
-    "listener" vocab
+    "resource:basis/bootstrap/bootstrap-error.factor" run-file
-    [ 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/boxes/boxes.factor

@@ -23,4 +23,4 @@ ERROR: box-empty box ;
     dup occupied>> [ box> t ] [ drop f f ] if ;
 
 : if-box? ( box quot -- )
-    >r ?box r> [ drop ] if ; inline
+    [ ?box ] dip [ drop ] if ; inline

basis/byte-vectors/byte-vectors.factor

@@ -0,0 +1,51 @@
+! 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 parser
+prettyprint.custom ;
+IN: byte-vectors
+
+TUPLE: byte-vector
+{ underlying byte-array }
+{ length array-capacity } ;
+
+: <byte-vector> ( n -- byte-vector )
+    (byte-array) 0 byte-vector boa ; inline
+
+: >byte-vector ( seq -- byte-vector )
+    T{ byte-vector f B{ } 0 } clone-like ;
+
+M: byte-vector like
+    drop dup byte-vector? [
+        dup byte-array?
+        [ dup length byte-vector boa ] [ >byte-vector ] if
+    ] unless ;
+
+M: byte-vector new-sequence
+    drop [ (byte-array) ] [ >fixnum ] bi byte-vector boa ;
+
+M: byte-vector equal?
+    over byte-vector? [ sequence= ] [ 2drop f ] if ;
+
+M: byte-array like
+    #! If we have an byte-array, we're done.
+    #! If we have a byte-vector, and it's at full capacity,
+    #! we're done. Otherwise, call resize-byte-array, which is a
+    #! relatively fast primitive.
+    drop dup byte-array? [
+        dup byte-vector? [
+            [ length ] [ underlying>> ] bi
+            2dup length eq?
+            [ nip ] [ resize-byte-array ] if
+        ] [ >byte-array ] if
+    ] unless ;
+
+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

@@ -365,12 +365,12 @@ HELP: unix-1970
 { $values { "timestamp" timestamp } }
 { $description "Outputs the beginning of UNIX time, or midnight, January 1, 1970." } ;
 
-HELP: millis>timestamp
+HELP: micros>timestamp
 { $values { "x" number } { "timestamp" timestamp } }
-{ $description "Converts a number of milliseconds into a timestamp value in GMT time." }
+{ $description "Converts a number of microseconds into a timestamp value in GMT time." }
 { $examples
     { $example "USING: accessors calendar prettyprint ;"
-               "1000 millis>timestamp year>> ."
+               "1000 micros>timestamp year>> ."
                "1970"
     }
 } ;

basis/calendar/calendar-tests.factor

@@ -143,10 +143,10 @@ IN: calendar.tests
 [ +gt+ ] [ 2005 1 1 12 30 0 instant <timestamp>
         2004 1 1 13 30 0 instant <timestamp> <=> ] unit-test
 
-[ t ] [ now timestamp>millis millis - 1000 < ] unit-test
+[ t ] [ now timestamp>micros micros - 1000000 < ] unit-test
-[ t ] [ 0 millis>timestamp unix-1970 = ] unit-test
+[ t ] [ 0 micros>timestamp unix-1970 = ] unit-test
-[ t ] [ 123456789000 [ millis>timestamp timestamp>millis ] keep = ] unit-test
+[ t ] [ 123456789000000 [ micros>timestamp timestamp>micros ] keep = ] unit-test
-[ t ] [ 123456789123456 [ millis>timestamp timestamp>millis ] keep = ] unit-test
+[ t ] [ 123456789123456000 [ micros>timestamp timestamp>micros ] keep = ] unit-test
 
 : checktime+ now dup clone [ rot time+ drop ] keep = ;
 

basis/calendar/calendar.factor

@@ -173,7 +173,7 @@ M: real +year ( timestamp n -- timestamp )
     12 /rem dup zero? [ drop 1- 12 ] when swap ; inline
 
 M: integer +month ( timestamp n -- timestamp )
-    [ over month>> + months/years >r >>month r> +year ] unless-zero ;
+    [ over month>> + months/years [ >>month ] dip +year ] unless-zero ;
 
 M: real +month ( timestamp n -- timestamp )
     [ float>whole-part swapd average-month * +day swap +month ] unless-zero ;
@@ -181,7 +181,7 @@ M: real +month ( timestamp n -- timestamp )
 M: integer +day ( timestamp n -- timestamp )
     [
         over >date< julian-day-number + julian-day-number>date
-        >r >r >>year r> >>month r> >>day
+        [ >>year ] [ >>month ] [ >>day ] tri*
     ] unless-zero ;
 
 M: real +day ( timestamp n -- timestamp )
@@ -191,7 +191,7 @@ M: real +day ( timestamp n -- timestamp )
     24 /rem swap ;
 
 M: integer +hour ( timestamp n -- timestamp )
-    [ over hour>> + hours/days >r >>hour r> +day ] unless-zero ;
+    [ over hour>> + hours/days [ >>hour ] dip +day ] unless-zero ;
 
 M: real +hour ( timestamp n -- timestamp )
     float>whole-part swapd 60 * +minute swap +hour ;
@@ -200,7 +200,7 @@ M: real +hour ( timestamp n -- timestamp )
     60 /rem swap ;
 
 M: integer +minute ( timestamp n -- timestamp )
-    [ over minute>> + minutes/hours >r >>minute r> +hour ] unless-zero ;
+    [ over minute>> + minutes/hours [ >>minute ] dip +hour ] unless-zero ;
 
 M: real +minute ( timestamp n -- timestamp )
     [ float>whole-part swapd 60 * +second swap +minute ] unless-zero ;
@@ -209,7 +209,7 @@ M: real +minute ( timestamp n -- timestamp )
     60 /rem swap >integer ;
 
 M: number +second ( timestamp n -- timestamp )
-    [ over second>> + seconds/minutes >r >>second r> +minute ] unless-zero ;
+    [ over second>> + seconds/minutes [ >>second ] dip +minute ] unless-zero ;
 
 : (time+)
     [ second>> +second ] keep
@@ -226,7 +226,7 @@ PRIVATE>
 GENERIC# time+ 1 ( time1 time2 -- time3 )
 
 M: timestamp time+
-    >r clone r> (time+) drop ;
+    [ clone ] dip (time+) drop ;
 
 M: duration time+
     dup timestamp? [
@@ -284,7 +284,7 @@ M: timestamp <=> ( ts1 ts2 -- n )
 : (time-) ( timestamp timestamp -- n )
     [ >gmt ] bi@
     [ [ >date< julian-day-number ] bi@ - 86400 * ] 2keep
-    [ >time< >r >r 3600 * r> 60 * r> + + ] bi@ - + ;
+    [ >time< [ [ 3600 * ] [ 60 * ] bi* ] dip + + ] bi@ - + ;
 
 M: timestamp time-
     #! Exact calendar-time difference
@@ -320,14 +320,20 @@ M: duration time-
     1970 1 1 0 0 0 instant <timestamp> ;
 
 : millis>timestamp ( x -- timestamp )
-    >r unix-1970 r> milliseconds time+ ;
+    [ unix-1970 ] dip milliseconds time+ ;
 
 : timestamp>millis ( timestamp -- n )
     unix-1970 (time-) 1000 * >integer ;
 
+: micros>timestamp ( x -- timestamp )
+    [ unix-1970 ] dip microseconds time+ ;
+
+: timestamp>micros ( timestamp -- n )
+    unix-1970 (time-) 1000000 * >integer ;
+
 : gmt ( -- timestamp )
     #! GMT time, right now
-    unix-1970 millis milliseconds time+ ;
+    unix-1970 micros microseconds time+ ;
 
 : now ( -- timestamp ) gmt >local-time ;
 : hence ( duration -- timestamp ) now swap time+ ;
@@ -337,10 +343,11 @@ M: duration time-
     #! Zeller Congruence
     #! http://web.textfiles.com/computers/formulas.txt
     #! good for any date since October 15, 1582
-    >r dup 2 <= [ 12 + >r 1- r> ] when
+    [
-    >r dup [ 4 /i + ] keep [ 100 /i - ] keep 400 /i + r>
+        dup 2 <= [ [ 1- ] [ 12 + ] bi* ] when
-        [ 1+ 3 * 5 /i + ] keep 2 * + r>
+        [ dup [ 4 /i + ] keep [ 100 /i - ] keep 400 /i + ] dip
-    1+ + 7 mod ;
+        [ 1+ 3 * 5 /i + ] keep 2 * +
+    ] dip 1+ + 7 mod ;
 
 GENERIC: days-in-year ( obj -- n )
 
@@ -404,7 +411,7 @@ PRIVATE>
 : since-1970 ( duration -- timestamp )
     unix-1970 time+ >local-time ;
 
-M: timestamp sleep-until timestamp>millis sleep-until ;
+M: timestamp sleep-until timestamp>micros sleep-until ;
 
 M: duration sleep hence sleep-until ;
 

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 ;
@@ -138,11 +139,11 @@ M: timestamp year. ( timestamp -- )
 
 : read-rfc3339-gmt-offset ( ch -- dt )
     dup CHAR: Z = [ drop instant ] [
-        >r
+        [
-        read-00 hours
+            read-00 hours
-        read1 { { CHAR: : [ read-00 ] } { f [ 0 ] } } case minutes
+            read1 { { CHAR: : [ read-00 ] } { f [ 0 ] } } case minutes
-        time+
+            time+
-        r> signed-gmt-offset
+        ] dip signed-gmt-offset
     ] if ;
 
 : read-ymd ( -- y m d )
@@ -152,8 +153,9 @@ M: timestamp year. ( timestamp -- )
     read-00 ":" expect read-00 ":" expect read-00 ;
 
 : read-rfc3339-seconds ( s -- s' ch )
-    "+-Z" read-until >r
+    "+-Z" read-until [
-    [ string>number ] [ length 10 swap ^ ] bi / + r> ;
+        [ string>number ] [ length 10 swap ^ ] bi / +
+    ] dip ;
 
 : (rfc3339>timestamp) ( -- timestamp )
     read-ymd
@@ -181,9 +183,9 @@ ERROR: invalid-timestamp-format ;
 
 : parse-rfc822-gmt-offset ( string -- dt )
     dup "GMT" = [ drop instant ] [
-        unclip >r
+        unclip [ 
-        2 cut [ string>number ] bi@ [ hours ] [ minutes ] bi* time+
+            2 cut [ string>number ] bi@ [ hours ] [ minutes ] bi* time+
-        r> signed-gmt-offset
+        ] dip signed-gmt-offset
     ] if ;
 
 : (rfc822>timestamp) ( -- timestamp )
@@ -287,3 +289,5 @@ ERROR: invalid-timestamp-format ;
             ]
         } formatted
     ] with-string-writer ;
+
+M: timestamp present timestamp>string ;

basis/calendar/model/model.factor

@@ -7,7 +7,7 @@ SYMBOL: time
 
 : (time-thread) ( -- )
     now time get set-model
-    1000 sleep (time-thread) ;
+    1 seconds sleep (time-thread) ;
 
 : time-thread ( -- )
     [

basis/channels/remote/remote.factor

@@ -14,7 +14,7 @@ IN: channels.remote
 PRIVATE>
 
 : publish ( channel -- id )
-    256 random-bits dup >r remote-channels set-at r> ;
+    256 random-bits dup [ remote-channels set-at ] dip ;
 
 : get-channel ( id -- channel )
     remote-channels at ;

basis/checksums/common/common.factor

@@ -18,4 +18,4 @@ SYMBOL: bytes-read
     ] "" make 64 group ;
 
 : update-old-new ( old new -- )
-    [ get >r get r> ] 2keep >r >r w+ dup r> set r> set ; inline
+    [ [ get ] bi@ w+ dup ] 2keep [ set ] bi@ ; inline

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
@@ -14,7 +14,7 @@ IN: checksums.md5
 SYMBOLS: a b c d old-a old-b old-c old-d ;
 
 : T ( N -- Y )
-    sin abs 4294967296 * >bignum ; foldable
+    sin abs 4294967296 * >integer ; foldable
 
 : initialize-md5 ( -- )
     0 bytes-read set
@@ -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
 
@@ -28,7 +29,7 @@ M: evp-md-context dispose
     handle>> EVP_MD_CTX_cleanup drop ;
 
 : with-evp-md-context ( quot -- )
-    maybe-init-ssl >r <evp-md-context> r> with-disposal ; inline
+    maybe-init-ssl [ <evp-md-context> ] dip with-disposal ; inline
 
 : digest-named ( name -- md )
     dup EVP_get_digestbyname

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.
@@ -41,9 +42,9 @@ SYMBOLS: h0 h1 h2 h3 h4 A B C D E w K ;
 : sha1-f ( B C D t -- f_tbcd )
     20 /i
     {   
-        { 0 [ >r over bitnot r> bitand >r bitand r> bitor ] }
+        { 0 [ [ over bitnot ] dip bitand [ bitand ] dip bitor ] }
         { 1 [ bitxor bitxor ] }
-        { 2 [ 2dup bitand >r pick bitand >r bitand r> r> bitor bitor ] }
+        { 2 [ 2dup bitand [ pick bitand [ bitand ] dip ] dip bitor bitor ] }
         { 3 [ bitxor bitxor ] }
     } case ;
 
@@ -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/sha2/sha2.factor

@@ -59,7 +59,7 @@ SYMBOLS: vars M K H S0 S1 process-M word-size block-size ;
     [ 15 - swap nth s0-256 ] 2keep
     [ 7 - swap nth ] 2keep
     [ 2 - swap nth s1-256 ] 2keep
-    >r >r + + w+ r> r> swap set-nth ; inline
+    [ + + w+ ] 2dip swap set-nth ; inline
 
 : prepare-message-schedule ( seq -- w-seq )
     word-size get group [ be> ] map block-size get 0 pad-right
@@ -71,7 +71,7 @@ SYMBOLS: vars M K H S0 S1 process-M word-size block-size ;
     [ bitxor bitand ] keep bitxor ;
 
 : maj ( x y z -- x' )
-    >r [ bitand ] 2keep bitor r> bitand bitor ;
+    [ [ bitand ] 2keep bitor ] dip bitand bitor ;
 
 : S0-256 ( x -- x' )
     [ -2 bitroll-32 ] keep
@@ -83,7 +83,7 @@ SYMBOLS: vars M K H S0 S1 process-M word-size block-size ;
     [ -11 bitroll-32 ] keep
     -25 bitroll-32 bitxor bitxor ; inline
 
-: slice3 ( n seq -- a b c ) >r dup 3 + r> <slice> first3 ; inline
+: slice3 ( n seq -- a b c ) [ dup 3 + ] dip <slice> first3 ; inline
 
 : T1 ( W n -- T1 )
     [ swap nth ] keep
@@ -105,7 +105,7 @@ SYMBOLS: vars M K H S0 S1 process-M word-size block-size ;
     d c pick exchange
     c b pick exchange
     b a pick exchange
-    >r w+ a r> set-nth ;
+    [ w+ a ] dip set-nth ;
 
 : process-chunk ( M -- )
     H get clone vars set
@@ -118,7 +118,7 @@ SYMBOLS: vars M K H S0 S1 process-M word-size block-size ;
 
 : preprocess-plaintext ( string big-endian? -- padded-string )
     #! pad 0x80 then 00 til 8 bytes left, then 64bit length in bits
-    >r >sbuf r> over [
+    [ >sbuf ] dip over [
         HEX: 80 ,
         dup length HEX: 3f bitand
         calculate-pad-length 0 <string> %

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

@@ -1,5 +1,5 @@
 USING: debugger quotations help.markup help.syntax strings alien
-core-foundation ;
+core-foundation core-foundation.strings core-foundation.arrays ;
 IN: cocoa.application
 
 HELP: <NSString>

basis/cocoa/application/application.factor

@@ -1,8 +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
+core-foundation.run-loop core-foundation.arrays
-cocoa.runtime sequences threads debugger init summary
+core-foundation.data core-foundation.strings cocoa.messages
+cocoa cocoa.classes cocoa.runtime sequences threads init summary
 kernel.private assocs ;
 IN: cocoa.application
 
@@ -27,35 +28,31 @@ IN: cocoa.application
 
 : NSApp ( -- app ) NSApplication -> sharedApplication ;
 
+: NSAnyEventMask ( -- mask ) HEX: ffffffff ; inline
+
 FUNCTION: void NSBeep ( ) ;
 
 : with-cocoa ( quot -- )
     [ NSApp drop call ] with-autorelease-pool ; inline
 
 : next-event ( app -- event )
-    0 f CFRunLoopDefaultMode 1
+    NSAnyEventMask f CFRunLoopDefaultMode 1
     -> nextEventMatchingMask:untilDate:inMode:dequeue: ;
 
 : do-event ( app -- ? )
-    dup next-event [ -> sendEvent: t ] [ drop f ] if* ;
+    dup next-event [ dupd -> sendEvent: -> updateWindows t ] [ drop f ] if* ;
 
 : add-observer ( observer selector name object -- )
-    >r >r >r >r NSNotificationCenter -> defaultCenter
+    [
-    r> r> sel_registerName
+        [ NSNotificationCenter -> defaultCenter ] 2dip
-    r> r> -> addObserver:selector:name:object: ;
+        sel_registerName
+    ] 2dip -> addObserver:selector:name:object: ;
 
 : remove-observer ( observer -- )
-    >r NSNotificationCenter -> defaultCenter r>
+    [ NSNotificationCenter -> defaultCenter ] dip
     -> removeObserver: ;
 
-: finish-launching ( -- ) NSApp -> finishLaunching ;
+: cocoa-app ( quot -- ) [ call NSApp -> run ] with-cocoa ; inline
-
-: cocoa-app ( quot -- )
-    [
-        call
-        finish-launching
-        NSApp -> run
-    ] with-cocoa ; inline
 
 : install-delegate ( receiver delegate -- )
     -> alloc -> init -> setDelegate: ;
@@ -80,6 +77,6 @@ M: objc-error summary ( error -- )
     running.app? [
         drop
     ] [
-        "The " swap " requires you to run Factor from an application bundle."
+        "The " " requires you to run Factor from an application bundle."
-        3append throw
+        surround throw
     ] if ;

basis/cocoa/cocoa-tests.factor

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

basis/cocoa/cocoa.factor

@@ -2,8 +2,8 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: compiler io kernel cocoa.runtime cocoa.subclassing
 cocoa.messages cocoa.types sequences words vocabs parser
-core-foundation namespaces assocs hashtables compiler.units
+core-foundation.bundles namespaces assocs hashtables
-lexer init ;
+compiler.units lexer init ;
 IN: cocoa
 
 : (remember-send) ( selector variable -- )

basis/cocoa/dialogs/dialogs.factor

@@ -1,7 +1,8 @@
-! Copyright (C) 2006, 2007 Slava Pestov
+! Copyright (C) 2006, 2008 Slava Pestov
 ! See http://factorcode.org/license.txt for BSD license.
 USING: kernel cocoa cocoa.messages cocoa.classes
-cocoa.application sequences splitting core-foundation ;
+cocoa.application sequences splitting core-foundation
+core-foundation.strings ;
 IN: cocoa.dialogs
 
 : <NSOpenPanel> ( -- panel )
@@ -26,9 +27,9 @@ IN: cocoa.dialogs
     [ -> filenames CF>string-array ] [ drop f ] if ;
 
 : split-path ( path -- dir file )
-    "/" last-split1 [ <NSString> ] bi@ ;
+    "/" split1-last [ <NSString> ] bi@ ;
 
 : save-panel ( path -- paths )
-    <NSSavePanel> dup
+    [ <NSSavePanel> dup ] dip
-    rot split-path -> runModalForDirectory:file: NSOKButton =
+    split-path -> runModalForDirectory:file: NSOKButton =
     [ -> filename CF>string ] [ drop f ] if ;

basis/cocoa/enumeration/enumeration.factor

@@ -1,26 +1,31 @@
-USING: kernel cocoa cocoa.types alien.c-types locals math sequences
+! Copyright (C) 2008 Joe Groff.
-vectors fry libc ;
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel cocoa cocoa.types alien.c-types locals math
+sequences vectors fry libc destructors
+specialized-arrays.direct.alien ;
 IN: cocoa.enumeration
 
 : NS-EACH-BUFFER-SIZE 16 ; inline
 
-: (with-enumeration-buffers) ( quot -- )
+: with-enumeration-buffers ( quot -- )
-    "NSFastEnumerationState" heap-size swap '[
+    [
-        NS-EACH-BUFFER-SIZE "id" heap-size * [
+        [
-            NS-EACH-BUFFER-SIZE @
+            "NSFastEnumerationState" malloc-object &free
-        ] with-malloc
+            NS-EACH-BUFFER-SIZE "id" heap-size * malloc-object &free
-    ] with-malloc ; inline
+            NS-EACH-BUFFER-SIZE
+        ] dip call
+    ] with-destructors ; inline
 
 :: (NSFastEnumeration-each) ( object quot: ( elt -- ) state stackbuf count -- )
     object state stackbuf count -> countByEnumeratingWithState:objects:count:
-    dup zero? [ drop ] [
+    dup 0 = [ drop ] [
         state NSFastEnumerationState-itemsPtr [ stackbuf ] unless*
-        '[ _ void*-nth quot call ] each
+        swap <direct-void*-array> quot each
         object quot state stackbuf count (NSFastEnumeration-each)
     ] if ; inline recursive
 
 : NSFastEnumeration-each ( object quot -- )
-    [ (NSFastEnumeration-each) ] (with-enumeration-buffers) ; inline
+    [ (NSFastEnumeration-each) ] with-enumeration-buffers ; inline
 
 : NSFastEnumeration-map ( object quot -- vector )
     NS-EACH-BUFFER-SIZE <vector>

basis/cocoa/messages/messages.factor

@@ -1,21 +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 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 ;
 
@@ -27,7 +24,7 @@ super-message-senders global [ H{ } assoc-like ] change-at
 
 : cache-stub ( method function hash -- )
     [
-        over get [ 2drop ] [ over >r sender-stub r> set ] if
+        over get [ 2drop ] [ over [ sender-stub ] dip set ] if
     ] bind ;
 
 : cache-stubs ( method -- )
@@ -37,7 +34,7 @@ super-message-senders global [ H{ } assoc-like ] change-at
 
 : <super> ( receiver -- super )
     "objc-super" <c-object> [
-        >r dup object_getClass class_getSuperclass r>
+        [ dup object_getClass class_getSuperclass ] dip
         set-objc-super-class
     ] keep
     [ set-objc-super-receiver ] keep ;
@@ -62,36 +59,35 @@ objc-methods global [ H{ } assoc-like ] change-at
     dup objc-methods get at
     [ ] [ "No such method: " prepend throw ] ?if ;
 
-: make-dip ( quot n -- quot' )
-    dup
-    \ >r <repetition> >quotation -rot
-    \ r> <repetition> >quotation 3append ;
-
 MEMO: make-prepare-send ( selector method super? -- quot )
     [
         [ \ <super> , ] when
         swap <selector> , \ selector ,
     ] [ ] make
-    swap second length 2 - make-dip ;
+    swap second length 2 - '[ _ _ ndip ] ;
 
 MACRO: (send) ( selector super? -- quot )
-    >r dup lookup-method r>
+    [ dup lookup-method ] dip
     [ make-prepare-send ] 2keep
     super-message-senders message-senders ? get at
-    [ slip execute ] 2curry ;
+    '[ _ call _ execute ] ;
 
 : 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
-: (objc-class) ( string word -- class )
+SYMBOL: class-init-hooks
-    dupd execute
+
-    [ ] [ "No such class: " prepend throw ] ?if ; inline
+class-init-hooks global [ H{ } clone or ] change-at
+
+: (objc-class) ( name word -- class )
+    2dup execute dup [ 2nip ] [
+        drop over class-init-hooks get at [ assert-depth ] when*
+        2dup execute dup [ 2nip ] [
+            2drop "No such class: " prepend throw
+        ] if
+    ] if ; inline
 
 : objc-class ( string -- class )
     \ objc_getClass (objc-class) ;
@@ -165,14 +161,14 @@ objc>alien-types get [ swap ] assoc-map
 assoc-union alien>objc-types set-global
 
 : objc-struct-type ( i string -- ctype )
-    2dup CHAR: = -rot index-from swap subseq
+    [ CHAR: = ] 2keep index-from swap subseq
     dup c-types get key? [
         "Warning: no such C type: " write dup print
         drop "void*"
     ] unless ;
 
 : (parse-objc-type) ( i string -- ctype )
-    2dup nth >r >r 1+ r> r> {
+    [ [ 1+ ] dip ] [ nth ] 2bi {
         { [ dup "rnNoORV" member? ] [ drop (parse-objc-type) ] }
         { [ dup CHAR: ^ = ] [ 3drop "void*" ] }
         { [ dup CHAR: { = ] [ drop objc-struct-type ] }
@@ -184,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 )
@@ -193,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 -- )
@@ -203,42 +199,28 @@ assoc-union alien>objc-types set-global
     objc-methods get set-at ;
 
 : each-method-in-class ( class quot -- )
-    [ 0 <uint> [ class_copyMethodList ] keep *uint over ] dip
+    [ 0 <uint> [ class_copyMethodList ] keep *uint ] dip
-    '[ _ void*-nth @ ] each (free) ; inline
+    over 0 = [ 3drop ] [
+        [ <direct-void*-array> ] dip
+        [ each ] [ drop underlying>> (free) ] 2bi
+    ] if ; inline
 
 : 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 ;
 
-: unless-defined ( class quot -- )
+: define-objc-class-word ( quot name -- )
-    >r class-exists? r> unless ; inline
+    [ class-init-hooks get set-at ]
-
-: define-objc-class-word ( name quot -- )
     [
-        over , , \ unless-defined , dup , \ objc-class ,
+        [ "cocoa.classes" create ] [ '[ _ objc-class ] ] bi
-    ] [ ] make >r "cocoa.classes" create r>
+        (( -- class )) define-declared
-    (( -- class )) define-declared ;
+    ] bi ;
 
 : import-objc-class ( name quot -- )
-    2dup unless-defined
+    over define-objc-class-word
-    dupd define-objc-class-word
+    [ objc-class register-objc-methods ]
-    [
+    [ objc-meta-class register-objc-methods ] bi ;
-        dup
-        objc-class register-objc-methods
-        objc-meta-class register-objc-methods
-    ] curry try ;
 
 : root-class ( class -- root )
     dup class_getSuperclass [ root-class ] [ ] ?if ;

basis/cocoa/nibs/nibs.factor

@@ -1,5 +1,8 @@
-USING: cocoa.application cocoa.messages cocoa.classes cocoa.runtime 
+! Copyright (C) 2008 Slava Pestov.
-kernel cocoa core-foundation alien.c-types ;
+! See http://factorcode.org/license.txt for BSD license.
+USING: cocoa.application cocoa.messages cocoa.classes
+cocoa.runtime kernel cocoa alien.c-types core-foundation
+core-foundation.arrays ;
 IN: cocoa.nibs
 
 : load-nib ( name -- )

basis/cocoa/pasteboard/pasteboard.factor

@@ -1,8 +1,8 @@
-! Copyright (C) 2006, 2007 Slava Pestov.
+! Copyright (C) 2006, 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: alien.c-types arrays kernel cocoa.messages
+USING: alien.accessors arrays kernel cocoa.messages
-cocoa.classes cocoa.application cocoa core-foundation
+cocoa.classes cocoa.application sequences cocoa core-foundation
-sequences ;
+core-foundation.strings core-foundation.arrays ;
 IN: cocoa.pasteboard
 
 : NSStringPboardType "NSStringPboardType" ;
@@ -20,11 +20,11 @@ IN: cocoa.pasteboard
 : set-pasteboard-string ( str pasteboard -- )
     NSStringPboardType <NSString>
     dup 1array pick set-pasteboard-types
-    >r swap <NSString> r> -> setString:forType: drop ;
+    [ swap <NSString> ] dip -> setString:forType: drop ;
 
 : pasteboard-error ( error -- f )
     "Pasteboard does not hold a string" <NSString>
-    0 spin set-void*-nth f ;
+    0 set-alien-cell f ;
 
 : ?pasteboard-string ( pboard error -- str/f )
     over pasteboard-string? [

basis/cocoa/plists/plists.factor

@@ -3,7 +3,7 @@
 USING: strings arrays hashtables assocs sequences
 cocoa.messages cocoa.classes cocoa.application cocoa kernel
 namespaces io.backend math cocoa.enumeration byte-arrays
-combinators alien.c-types core-foundation ;
+combinators alien.c-types core-foundation core-foundation.data ;
 IN: cocoa.plists
 
 GENERIC: >plist ( value -- plist )

basis/cocoa/subclassing/subclassing.factor

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

basis/cocoa/views/views.factor

@@ -1,8 +1,8 @@
-! Copyright (C) 2006, 2007 Slava Pestov
+! Copyright (C) 2006, 2008 Slava Pestov
 ! See http://factorcode.org/license.txt for BSD license.
-USING: alien.c-types arrays kernel math namespaces make cocoa
+USING: specialized-arrays.int arrays kernel math namespaces make
-cocoa.messages cocoa.classes cocoa.types sequences
+cocoa cocoa.messages cocoa.classes cocoa.types sequences
-continuations ;
+continuations accessors ;
 IN: cocoa.views
 
 : NSOpenGLPFAAllRenderers 1 ;
@@ -55,10 +55,9 @@ PRIVATE>
 : with-multisample ( quot -- )
     t +multisample+ pick with-variable ; inline
 
-: <PixelFormat> ( -- pixelfmt )
+: <PixelFormat> ( attributes -- pixelfmt )
-    NSOpenGLPixelFormat -> alloc [
+    NSOpenGLPixelFormat -> alloc swap [
-        NSOpenGLPFAWindow ,
+        %
-        NSOpenGLPFADoubleBuffer ,
         NSOpenGLPFADepthSize , 16 ,
         +software-renderer+ get [
             NSOpenGLPFARendererID , kCGLRendererGenericFloatID ,
@@ -69,12 +68,13 @@ PRIVATE>
             NSOpenGLPFASamples , 8 ,
         ] when
         0 ,
-    ] { } make >c-int-array
+    ] int-array{ } make underlying>>
     -> initWithAttributes:
     -> autorelease ;
 
 : <GLView> ( class dim -- view )
-    >r -> alloc 0 0 r> first2 <NSRect> <PixelFormat>
+    [ -> alloc 0 0 ] dip first2 <NSRect>
+    NSOpenGLPFAWindow NSOpenGLPFADoubleBuffer 2array <PixelFormat>
     -> initWithFrame:pixelFormat:
     dup 1 -> setPostsBoundsChangedNotifications:
     dup 1 -> setPostsFrameChangedNotifications: ;
@@ -85,10 +85,11 @@ PRIVATE>
     swap NSRect-h >fixnum 2array ;
 
 : mouse-location ( view event -- loc )
-    over >r
+    [
-    -> locationInWindow f -> convertPoint:fromView:
+        -> locationInWindow f -> convertPoint:fromView:
-    dup NSPoint-x swap NSPoint-y
+        [ NSPoint-x ] [ NSPoint-y ] bi
-    r> -> frame NSRect-h swap - 2array ;
+    ] [ drop -> frame NSRect-h ] 2bi
+    swap - 2array ;
 
 USE: opengl.gl
 USE: alien.syntax

basis/cocoa/windows/windows.factor

@@ -34,5 +34,6 @@ IN: cocoa.windows
     dup 0 -> setReleasedWhenClosed: ;
 
 : window-content-rect ( window -- rect )
-    NSWindow over -> frame rot -> styleMask
+    [ NSWindow ] dip
+    [ -> frame ] [ -> styleMask ] bi
     -> contentRectForFrameRect:styleMask: ;

basis/combinators/short-circuit/short-circuit-docs.factor

@@ -52,17 +52,17 @@ HELP: 3||
      { "quot" quotation } }
 { $description "Returns true if any quotation in the sequence returns true. Each quotation takes the same three elements from the datastack and must return a boolean." } ;
 
-HELP: n&&-rewrite
+HELP: n&&
 { $values
      { "quots" "a sequence of quotations" } { "N" integer }
      { "quot" quotation } }
-{ $description "A macro that reqrites the code to pass " { $snippet "N" } " parameters from the stack to each AND quotation." } ;
+{ $description "A macro that rewrites the code to pass " { $snippet "n" } " parameters from the stack to each AND quotation." } ;
 
-HELP: n||-rewrite
+HELP: n||
 { $values
-     { "quots" "a sequence of quotations" } { "N" integer }
+     { "quots" "a sequence of quotations" } { "n" integer }
      { "quot" quotation } }
-{ $description "A macro that reqrites the code to pass " { $snippet "N" } " parameters from the stack to each OR quotation." } ;
+{ $description "A macro that rewrites the code to pass " { $snippet "n" } " parameters from the stack to each OR quotation." } ;
 
 ARTICLE: "combinators.short-circuit" "Short-circuit combinators"
 "The " { $vocab-link "combinators.short-circuit" } " vocabulary stops a computation early once a condition is met." $nl
@@ -77,8 +77,8 @@ ARTICLE: "combinators.short-circuit" "Short-circuit combinators"
 { $subsection 2|| }
 { $subsection 3|| }
 "Generalized combinators:"
-{ $subsection n&&-rewrite }
+{ $subsection n&& }
-{ $subsection n||-rewrite }
+{ $subsection n|| }
 ;
 
 ABOUT: "combinators.short-circuit"

basis/combinators/short-circuit/short-circuit.factor

@@ -1,35 +1,33 @@
-
 USING: kernel combinators quotations arrays sequences assocs
-       locals generalizations macros fry ;
+locals generalizations macros fry ;
-
 IN: combinators.short-circuit
 
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+MACRO:: n&& ( quots n -- quot )
+    [ f ] quots [| q |
+        n
+        [ q '[ drop _ ndup @ dup not ] ]
+        [ '[ drop _ ndrop f ] ]
+        bi 2array
+    ] map
+    n '[ _ nnip ] suffix 1array
+    [ cond ] 3append ;
 
-:: n&&-rewrite ( quots N -- quot )
+MACRO: 0&& ( quots -- quot ) '[ _ 0 n&& ] ;
-   quots
+MACRO: 1&& ( quots -- quot ) '[ _ 1 n&& ] ;
-     [ '[ drop N ndup @ dup not ] [ drop N ndrop f ] 2array ]
+MACRO: 2&& ( quots -- quot ) '[ _ 2 n&& ] ;
-   map
+MACRO: 3&& ( quots -- quot ) '[ _ 3 n&& ] ;
-   [ t ] [ N nnip ] 2array suffix
-   '[ f _ cond ] ;
 
-MACRO: 0&& ( quots -- quot ) 0 n&&-rewrite ;
+MACRO:: n|| ( quots n -- quot )
-MACRO: 1&& ( quots -- quot ) 1 n&&-rewrite ;
+    [ f ] quots [| q |
-MACRO: 2&& ( quots -- quot ) 2 n&&-rewrite ;
+        n
-MACRO: 3&& ( quots -- quot ) 3 n&&-rewrite ;
+        [ q '[ drop _ ndup @ dup ] ]
+        [ '[ _ nnip ] ]
+        bi 2array
+    ] map
+    n '[ drop _ ndrop t ] [ f ] 2array suffix 1array
+    [ cond ] 3append ;
 
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+MACRO: 0|| ( quots -- quot ) '[ _ 0 n|| ] ;
-
+MACRO: 1|| ( quots -- quot ) '[ _ 1 n|| ] ;
-:: n||-rewrite ( quots N -- quot )
+MACRO: 2|| ( quots -- quot ) '[ _ 2 n|| ] ;
-   quots
+MACRO: 3|| ( quots -- quot ) '[ _ 3 n|| ] ;
-     [ '[ drop N ndup @ dup ] [ N nnip ] 2array ]
-   map
-   [ drop N ndrop t ] [ f ] 2array suffix
-   '[ f _ cond ] ;
-
-MACRO: 0|| ( quots -- quot ) 0 n||-rewrite ;
-MACRO: 1|| ( quots -- quot ) 1 n||-rewrite ;
-MACRO: 2|| ( quots -- quot ) 2 n||-rewrite ;
-MACRO: 3|| ( quots -- quot ) 3 n||-rewrite ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

basis/combinators/short-circuit/smart/smart.factor

@@ -1,7 +1,5 @@
-
 USING: kernel sequences math stack-checker effects accessors macros
-       combinators.short-circuit ;
+fry combinators.short-circuit ;
-
 IN: combinators.short-circuit.smart
 
 <PRIVATE
@@ -13,6 +11,6 @@ IN: combinators.short-circuit.smart
 
 PRIVATE>
 
-MACRO: && ( quots -- quot ) dup arity n&&-rewrite ;
+MACRO: && ( quots -- quot ) dup arity '[ _ _ n&& ] ;
 
-MACRO: || ( quots -- quot ) dup arity n||-rewrite ;
+MACRO: || ( quots -- quot ) dup arity '[ _ _ n|| ] ;

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

@@ -1,4 +1,5 @@
-USING: help.markup help.syntax parser vocabs.loader strings ;
+USING: help.markup help.syntax parser vocabs.loader strings
+command-line.private ;
 IN: command-line
 
 HELP: run-bootstrap-init
@@ -7,7 +8,10 @@ HELP: run-bootstrap-init
 HELP: run-user-init
 { $description "Runs the startup initialization file in the user's home directory, unless the " { $snippet "-no-user-init" } " command line switch was given. This file is named " { $snippet ".factor-rc" } " on Unix and " { $snippet "factor-rc" } " on Windows." } ;
 
-HELP: cli-param
+HELP: load-vocab-roots
+{ $description "Loads the newline-separated list of additional vocabulary roots from the file named " { $snippet ".factor-roots" } " on Unix and " { $snippet "factor-roots" } " on Windows." } ;
+
+HELP: param
 { $values { "param" string } }
 { $description "Process a command-line switch."
 $nl
@@ -17,10 +21,13 @@ $nl
 $nl
 "Otherwise, sets the global variable named by the parameter to " { $link t } "." } ;
 
-HELP: cli-args
+HELP: (command-line)
 { $values { "args" "a sequence of strings" } }
 { $description "Outputs the command line parameters which were passed to the Factor VM on startup." } ;
 
+HELP: command-line
+{ $var-description "The command line parameters which follow the name of the script on the command line." } ;
+
 HELP: main-vocab-hook
 { $var-description "Global variable holding a quotation which outputs a vocabulary name. UI backends set this so that the UI can automatically start if the prerequisites are met (for example, " { $snippet "$DISPLAY" } " being set on X11)." } ;
 
@@ -35,9 +42,6 @@ HELP: ignore-cli-args?
 { $values { "?" "a boolean" } }
 { $description "On Mac OS X, source files to run are supplied by the Cocoa API, so to avoid running them twice the startup code has to call this word." } ;
 
-HELP: parse-command-line
-{ $description "Called on startup to process command line arguments. This sets global variables with " { $link cli-param } ", runs source files, and evaluates the string given by the " { $snippet "-e" } " switch, if there is one." } ;
-
 ARTICLE: "runtime-cli-args" "Command line switches for the VM"
 "A handful of command line switches are processed by the VM and not the library. They control low-level features."
 { $table
@@ -64,9 +68,12 @@ ARTICLE: "bootstrap-cli-args" "Command line switches for bootstrap"
 }
 "Bootstrap can load various optional components:"
 { $table
+    { { $snippet "math" } "Rational and complex number support." }
+    { { $snippet "threads" } "Thread support." }
     { { $snippet "compiler" } "The compiler." }
     { { $snippet "tools" } "Terminal-based developer tools." }
     { { $snippet "help" } "The help system." }
+    { { $snippet "help.handbook" } "The help handbook." }
     { { $snippet "ui" } "The graphical user interface." }
     { { $snippet "ui.tools" } "Graphical developer tools." }
     { { $snippet "io" } "Non-blocking I/O and networking." }
@@ -86,7 +93,6 @@ ARTICLE: "standard-cli-args" "Command line switches for general usage"
     { { $snippet "-run=" { $emphasis "vocab" } } { { $snippet { $emphasis "vocab" } } " is the name of a vocabulary with a " { $link POSTPONE: MAIN: } " hook to run on startup, for example " { $vocab-link "listener" } ", " { $vocab-link "ui" } " or " { $vocab-link "none" } "." } }
     { { $snippet "-no-user-init" } { "Inhibits the running of user initialization files on startup. See " { $link "rc-files" } "." } }
     { { $snippet "-quiet" } { "If set, " { $link run-file } " and " { $link require } " will not print load messages." } }
-    { { $snippet "-script" } { "Equivalent to " { $snippet "-quiet -run=none" } "." $nl "On Unix systems, Factor can be used for scripting - just create an executable text file whose first line is:" { $code "#! /usr/local/bin/factor -script" } "The space after " { $snippet "#!" } " is necessary because of Factor syntax." } }
 } ;
 
 ARTICLE: "factor-boot-rc" "Bootstrap initialization file"
@@ -102,11 +108,18 @@ $nl
 "A word to run this file from an existing Factor session:"
 { $subsection run-user-init } ;
 
+ARTICLE: "factor-roots" "Additional vocabulary roots file"
+"The vocabulary roots file is named " { $snippet "factor-roots" } " on Windows and " { $snippet ".factor-roots" } " on Unix. If it exists, it is loaded every time Factor starts. It contains a newline-separated list of " { $link "vocabs.roots" } "."
+$nl
+"A word to run this file from an existing Factor session:"
+{ $subsection load-vocab-roots } ;
+
 ARTICLE: "rc-files" "Running code on startup"
-"Factor looks for two files in your home directory."
+"Factor looks for three optional files in your home directory."
 { $subsection "factor-boot-rc" }
 { $subsection "factor-rc" }
-"The " { $snippet "-no-user-init" } " command line switch will inhibit the running of these files."
+{ $subsection "factor-roots" }
+"The " { $snippet "-no-user-init" } " command line switch will inhibit loading running of these files."
 $nl
 "If you are unsure where the files should be located, evaluate the following code:"
 { $code
@@ -122,8 +135,16 @@ $nl
     "100 dpi set-global"
 } ;
 
-ARTICLE: "cli" "Command line usage"
+ARTICLE: "cli" "Command line arguments"
-"Zero or more command line arguments may be passed to the Factor runtime. Command line arguments starting with a dash (" { $snippet "-" } ") is interpreted as switches. All other arguments are taken to be file names to be run by " { $link run-file } "."
+"Factor command line usage:"
+{ $code "factor [system switches...] [script args...]" }
+"Zero or more system switches can be passed in, followed by an optional script file name. If the script file is specified, it will be run on startup, any arguments after the script file are stored in a variable, with no further processing by Factor itself:"
+{ $subsection command-line }
+"Instead of running a script, it is also possible to run a vocabulary; this invokes the vocabulary's " { $link POSTPONE: MAIN: } " word:"
+{ $code "factor [system switches...] -run=<vocab name>" }
+"If no script file or " { $snippet "-run=" } " switch is specified, Factor will start " { $link "listener" } " or " { $link "ui-tools" } ", depending on the operating system."
+$nl
+"As stated above, arguments in the first part of the command line, before the optional script name, are interpreted by to the Factor system. These arguments all start with a dash (" { $snippet "-" } ")."
 $nl
 "Switches can take one of the following three forms:"
 { $list
@@ -134,9 +155,9 @@ $nl
 { $subsection "runtime-cli-args" }
 { $subsection "bootstrap-cli-args" }
 { $subsection "standard-cli-args" }
-"The list of command line arguments can be obtained and inspected directly:"
+"The raw list of command line arguments can also be obtained and inspected directly:"
-{ $subsection cli-args }
+{ $subsection (command-line) }
-"There is a way to override the default vocabulary to run on startup:"
+"There is a way to override the default vocabulary to run on startup, if no script name or " { $snippet "-run" } " switch is specified:"
 { $subsection main-vocab-hook } ;
 
 ABOUT: "cli"

basis/command-line/command-line-tests.factor

@@ -1,12 +0,0 @@
-USING: namespaces tools.test kernel command-line ;
-IN: command-line.tests
-
-[
-    [ f ] [ "-no-user-init" cli-arg ] unit-test
-    [ f ] [ "user-init" get ] unit-test
-
-    [ f ] [ "-user-init" cli-arg ] unit-test
-    [ t ] [ "user-init" get ] unit-test
-    
-    [ "sdl.factor" ] [ "sdl.factor" cli-arg ] unit-test
-] with-scope

basis/command-line/command-line.factor

@@ -1,10 +1,15 @@
 ! Copyright (C) 2003, 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: init continuations debugger hashtables io kernel
+USING: init continuations hashtables io io.encodings.utf8
-kernel.private namespaces parser sequences strings system
+io.files kernel kernel.private namespaces parser sequences
-splitting io.files eval ;
+strings system splitting vocabs.loader ;
 IN: command-line
 
+SYMBOL: script
+SYMBOL: command-line
+
+: (command-line) ( -- args ) 10 getenv sift ;
+
 : rc-path ( name -- path )
     os windows? [ "." prepend ] unless
     home prepend-path ;
@@ -19,17 +24,29 @@ IN: command-line
         "factor-rc" rc-path ?run-file
     ] when ;
 
-: cli-var-param ( name value -- ) swap set-global ;
+: load-vocab-roots ( -- )
+    "user-init" get [
+        "factor-roots" rc-path dup exists? [
+            utf8 file-lines [ add-vocab-root ] each
+        ] [ drop ] if
+    ] when ;
 
-: cli-bool-param ( name -- ) "no-" ?head not cli-var-param ;
+: var-param ( name value -- ) swap set-global ;
 
-: cli-param ( param -- )
+: bool-param ( name -- ) "no-" ?head not var-param ;
-    "=" split1 [ cli-var-param ] [ cli-bool-param ] if* ;
 
-: cli-arg ( argument -- argument )
+: param ( param -- )
-    "-" ?head [ cli-param f ] when ;
+    "=" split1 [ var-param ] [ bool-param ] if* ;
 
-: cli-args ( -- args ) 10 getenv ;
+: run-script ( file -- )
+    t "quiet" set-global run-file ;
+
+: parse-command-line ( args -- )
+    [ command-line off script off ] [
+        unclip "-" ?head
+        [ param parse-command-line ]
+        [ script set command-line set ] if
+    ] if-empty ;
 
 SYMBOL: main-vocab-hook
 
@@ -53,14 +70,6 @@ SYMBOL: main-vocab-hook
 : ignore-cli-args? ( -- ? )
     os macosx? "run" get "ui" = and ;
 
-: script-mode ( -- )
+: script-mode ( -- ) ;
-    t "quiet" set-global
-    "none" "run" set-global ;
-
-: parse-command-line ( -- )
-    cli-args [ cli-arg ] filter
-    "script" get [ script-mode ] when
-    ignore-cli-args? [ drop ] [ [ run-file ] each ] if
-    "e" get [ eval ] when* ;
 
 [ default-cli-args ] "command-line" add-init-hook

basis/compiler/alien/alien.factor

@@ -18,7 +18,7 @@ IN: compiler.alien
     dup c-type-stack-align? [ c-type-align ] [ drop cell ] if ;
 
 : parameter-align ( n type -- n delta )
-    over >r c-type-stack-align align dup r> - ;
+    [ c-type-stack-align align dup ] [ drop ] 2bi - ;
 
 : parameter-sizes ( types -- total offsets )
     #! Compute stack frame locations.

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/builder/builder.factor

@@ -21,8 +21,6 @@ IN: compiler.cfg.builder
 
 ! Convert tree SSA IR to CFG SSA IR.
 
-: stop-iterating ( -- next ) end-basic-block f ;
-
 SYMBOL: procedures
 SYMBOL: current-word
 SYMBOL: current-label
@@ -211,7 +209,7 @@ M: #dispatch emit-node
 ! #call
 M: #call emit-node
     dup word>> dup "intrinsic" word-prop
-    [ emit-intrinsic iterate-next ] [ nip emit-call ] if ;
+    [ emit-intrinsic ] [ nip emit-call ] if ;
 
 ! #call-recursive
 M: #call-recursive emit-node label>> id>> emit-call ;
@@ -262,7 +260,7 @@ M: #terminate emit-node drop stop-iterating ;
 
 : emit-alien-node ( node quot -- next )
     [ params>> ] dip [ drop alien-stack-frame ] [ call ] 2bi
-    begin-basic-block iterate-next ; inline
+    ##branch begin-basic-block iterate-next ; inline
 
 M: #alien-invoke emit-node
     [ ##alien-invoke ] emit-alien-node ;

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/def-use/def-use.factor

@@ -12,9 +12,15 @@ M: ##write-barrier defs-vregs [ card#>> ] [ table>> ] bi 2array ;
 M: ##unary/temp defs-vregs dst/tmp-vregs ;
 M: ##allot defs-vregs dst/tmp-vregs ;
 M: ##dispatch defs-vregs temp>> 1array ;
-M: ##slot defs-vregs [ dst>> ] [ temp>> ] bi 2array ;
+M: ##slot defs-vregs dst/tmp-vregs ;
 M: ##set-slot defs-vregs temp>> 1array ;
-M: ##string-nth defs-vregs [ dst>> ] [ temp>> ] bi 2array ;
+M: ##string-nth defs-vregs dst/tmp-vregs ;
+M: ##set-string-nth-fast defs-vregs temp>> 1array ;
+M: ##compare defs-vregs dst/tmp-vregs ;
+M: ##compare-imm defs-vregs dst/tmp-vregs ;
+M: ##compare-float defs-vregs dst/tmp-vregs ;
+M: ##fixnum-mul defs-vregs [ temp1>> ] [ temp2>> ] bi 2array ;
+M: ##fixnum-mul-tail defs-vregs [ temp1>> ] [ temp2>> ] bi 2array ;
 M: insn defs-vregs drop f ;
 
 M: ##unary uses-vregs src>> 1array ;
@@ -26,11 +32,13 @@ M: ##slot-imm uses-vregs obj>> 1array ;
 M: ##set-slot uses-vregs [ src>> ] [ obj>> ] [ slot>> ] tri 3array ;
 M: ##set-slot-imm uses-vregs [ src>> ] [ obj>> ] bi 2array ;
 M: ##string-nth uses-vregs [ obj>> ] [ index>> ] bi 2array ;
+M: ##set-string-nth-fast uses-vregs [ src>> ] [ obj>> ] [ index>> ] tri 3array ;
 M: ##conditional-branch uses-vregs [ src1>> ] [ src2>> ] bi 2array ;
 M: ##compare-imm-branch uses-vregs src1>> 1array ;
 M: ##dispatch uses-vregs src>> 1array ;
 M: ##alien-getter uses-vregs src>> 1array ;
 M: ##alien-setter uses-vregs [ src>> ] [ value>> ] bi 2array ;
+M: ##fixnum-overflow uses-vregs [ src1>> ] [ src2>> ] bi 2array ;
 M: _conditional-branch uses-vregs [ src1>> ] [ src2>> ] bi 2array ;
 M: _compare-imm-branch uses-vregs src1>> 1array ;
 M: insn uses-vregs drop f ;
@@ -40,6 +48,7 @@ UNION: vreg-insn
 ##write-barrier
 ##dispatch
 ##effect
+##fixnum-overflow
 ##conditional-branch
 ##compare-imm-branch
 _conditional-branch

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,9 +66,10 @@ 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
-: ^^compare ( src1 src2 cc -- dst ) ^^i3 ##compare ; inline
+: ^^alien-global ( symbol library -- dst ) ^^i2 ##alien-global ; inline
-: ^^compare-imm ( src1 src2 cc -- dst ) ^^i3 ##compare-imm ; inline
+: ^^compare ( src1 src2 cc -- dst ) ^^i3 i ##compare ; inline
-: ^^compare-float ( src1 src2 cc -- dst ) ^^i3 ##compare-float ; inline
+: ^^compare-imm ( src1 src2 cc -- dst ) ^^i3 i ##compare-imm ; inline
+: ^^compare-float ( src1 src2 cc -- dst ) ^^i3 i ##compare-float ; inline
 : ^^offset>slot ( vreg -- vreg' ) cell 4 = [ 1 ^^shr-imm ] when ; inline
 : ^^tag-fixnum ( src -- dst ) ^^i1 ##tag-fixnum ; inline
 : ^^untag-fixnum ( src -- dst ) ^^i1 ##untag-fixnum ; inline

basis/compiler/cfg/instructions/instructions.factor

@@ -73,6 +73,7 @@ INSN: ##set-slot-imm < ##write { obj vreg } { slot integer } { tag integer } ;
 
 ! String element access
 INSN: ##string-nth < ##flushable { obj vreg } { index vreg } { temp vreg } ;
+INSN: ##set-string-nth-fast < ##effect { obj vreg } { index vreg } { temp vreg } ;
 
 ! Integer arithmetic
 INSN: ##add < ##commutative ;
@@ -91,6 +92,16 @@ 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 ;
+INSN: ##fixnum-add < ##fixnum-overflow ;
+INSN: ##fixnum-add-tail < ##fixnum-overflow ;
+INSN: ##fixnum-sub < ##fixnum-overflow ;
+INSN: ##fixnum-sub-tail < ##fixnum-overflow ;
+INSN: ##fixnum-mul < ##fixnum-overflow temp1 temp2 ;
+INSN: ##fixnum-mul-tail < ##fixnum-overflow temp1 temp2 ;
 
 : ##tag-fixnum ( dst src -- ) tag-bits get ##shl-imm ; inline
 : ##untag-fixnum ( dst src -- ) tag-bits get ##sar-imm ; inline
@@ -151,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 ;
@@ -198,11 +211,11 @@ TUPLE: ##conditional-branch < insn { src1 vreg } { src2 vreg } cc ;
 INSN: ##compare-branch < ##conditional-branch ;
 INSN: ##compare-imm-branch { src1 vreg } { src2 integer } cc ;
 
-INSN: ##compare < ##binary cc ;
+INSN: ##compare < ##binary cc temp ;
-INSN: ##compare-imm < ##binary-imm cc ;
+INSN: ##compare-imm < ##binary-imm cc temp ;
 
 INSN: ##compare-float-branch < ##conditional-branch ;
-INSN: ##compare-float < ##binary cc ;
+INSN: ##compare-float < ##binary cc temp ;
 
 ! Instructions used by machine IR only.
 INSN: _prologue stack-frame ;

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

@@ -54,15 +54,19 @@ IN: compiler.cfg.intrinsics.allot
 
 : bytes>cells ( m -- n ) cell align cell /i ;
 
-:: emit-<byte-array> ( node -- )
+: emit-allot-byte-array ( len -- dst )
-    [let | len [ node node-input-infos first literal>> ] |
+    ds-drop
-        len expand-<byte-array>? [
+    dup ^^allot-byte-array
-            [let | elt [ 0 ^^load-literal ]
+    [ store-length ] [ ds-push ] [ ] tri ;
-                   reg [ len ^^allot-byte-array ] |
+
-                ds-drop
+: emit-(byte-array) ( node -- )
-                len reg store-length
+    dup node-input-infos first literal>> dup expand-<byte-array>?
-                elt reg len bytes>cells store-initial-element
+    [ nip emit-allot-byte-array drop ] [ drop emit-primitive ] if ;
-                reg ds-push
+
-            ]
+: emit-<byte-array> ( node -- )
-        ] [ node emit-primitive ] if
+    dup node-input-infos first literal>> dup expand-<byte-array>? [
-    ] ;
+        nip
+        [ 0 ^^load-literal ] dip
+        [ emit-allot-byte-array ] keep
+        bytes>cells store-initial-element
+    ] [ drop emit-primitive ] if ;

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

@@ -3,10 +3,21 @@
 USING: sequences accessors layouts kernel math namespaces
 combinators fry locals
 compiler.tree.propagation.info
-compiler.cfg.stacks compiler.cfg.hats compiler.cfg.instructions
+compiler.cfg.hats
-compiler.cfg.utilities ;
+compiler.cfg.stacks
+compiler.cfg.iterator
+compiler.cfg.instructions
+compiler.cfg.utilities
+compiler.cfg.registers ;
 IN: compiler.cfg.intrinsics.fixnum
 
+: emit-both-fixnums? ( -- )
+    2inputs
+    ^^or
+    tag-mask get ^^and-imm
+    0 cc= ^^compare-imm
+    ds-push ;
+
 : (emit-fixnum-imm-op) ( infos insn -- dst )
     ds-drop
     [ ds-pop ]
@@ -42,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 ;
 
@@ -64,3 +78,16 @@ IN: compiler.cfg.intrinsics.fixnum
 
 : emit-fixnum>bignum ( -- )
     ds-pop ^^untag-fixnum ^^integer>bignum ds-push ;
+
+: emit-fixnum-overflow-op ( quot quot-tail -- next )
+    [ 2inputs 1 ##inc-d ] 2dip
+    tail-call? [
+        ##epilogue
+        nip call
+        stop-iterating
+    ] [
+        drop call
+        ##branch
+        begin-basic-block
+        iterate-next
+    ] if ; inline

basis/compiler/cfg/intrinsics/intrinsics.factor

@@ -8,7 +8,9 @@ compiler.cfg.intrinsics.alien
 compiler.cfg.intrinsics.allot
 compiler.cfg.intrinsics.fixnum
 compiler.cfg.intrinsics.float
-compiler.cfg.intrinsics.slots ;
+compiler.cfg.intrinsics.slots
+compiler.cfg.intrinsics.misc
+compiler.cfg.iterator ;
 QUALIFIED: kernel
 QUALIFIED: arrays
 QUALIFIED: byte-arrays
@@ -17,11 +19,17 @@ 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-
+    math.private:fixnum*
     math.private:fixnum+fast
     math.private:fixnum-fast
     math.private:fixnum-bitand
@@ -40,9 +48,11 @@ IN: compiler.cfg.intrinsics
     slots.private:slot
     slots.private:set-slot
     strings.private:string-nth
+    strings.private:set-string-nth-fast
     classes.tuple.private:<tuple-boa>
     arrays:<array>
     byte-arrays:<byte-array>
+    byte-arrays:(byte-array)
     math.private:<complex>
     math.private:<ratio>
     kernel:<wrapper>
@@ -85,60 +95,71 @@ IN: compiler.cfg.intrinsics
         alien.accessors:set-alien-double
     } [ t "intrinsic" set-word-prop ] each ;
 
-: emit-intrinsic ( node word -- )
+: 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 ] }
+        { \ kernel.private:tag [ drop emit-tag iterate-next ] }
-        { \ math.private:fixnum+fast [ [ ^^add ] [ ^^add-imm ] emit-fixnum-op ] }
+        { \ kernel.private:getenv [ emit-getenv iterate-next ] }
-        { \ math.private:fixnum-fast [ [ ^^sub ] [ ^^sub-imm ] emit-fixnum-op ] }
+        { \ math.private:both-fixnums? [ drop emit-both-fixnums? iterate-next ] }
-        { \ math.private:fixnum-bitand [ [ ^^and ] [ ^^and-imm ] emit-fixnum-op ] }
+        { \ math.private:fixnum+ [ drop [ ##fixnum-add ] [ ##fixnum-add-tail ] emit-fixnum-overflow-op ] }
-        { \ math.private:fixnum-bitor [ [ ^^or ] [ ^^or-imm ] emit-fixnum-op ] }
+        { \ math.private:fixnum- [ drop [ ##fixnum-sub ] [ ##fixnum-sub-tail ] emit-fixnum-overflow-op ] }
-        { \ math.private:fixnum-bitxor [ [ ^^xor ] [ ^^xor-imm ] emit-fixnum-op ] }
+        { \ math.private:fixnum* [ drop [ i i ##fixnum-mul ] [ i i ##fixnum-mul-tail ] emit-fixnum-overflow-op ] }
-        { \ math.private:fixnum-shift-fast [ emit-fixnum-shift-fast ] }
+        { \ math.private:fixnum+fast [ [ ^^add ] [ ^^add-imm ] emit-fixnum-op iterate-next ] }
-        { \ math.private:fixnum-bitnot [ drop emit-fixnum-bitnot ] }
+        { \ math.private:fixnum-fast [ [ ^^sub ] [ ^^sub-imm ] emit-fixnum-op iterate-next ] }
-        { \ math.private:fixnum*fast [ emit-fixnum*fast ] }
+        { \ math.private:fixnum-bitand [ [ ^^and ] [ ^^and-imm ] emit-fixnum-op iterate-next ] }
-        { \ math.private:fixnum< [ cc< emit-fixnum-comparison ] }
+        { \ math.private:fixnum-bitor [ [ ^^or ] [ ^^or-imm ] emit-fixnum-op iterate-next ] }
-        { \ math.private:fixnum<= [ cc<= emit-fixnum-comparison ] }
+        { \ math.private:fixnum-bitxor [ [ ^^xor ] [ ^^xor-imm ] emit-fixnum-op iterate-next ] }
-        { \ math.private:fixnum>= [ cc>= emit-fixnum-comparison ] }
+        { \ math.private:fixnum-shift-fast [ emit-fixnum-shift-fast iterate-next ] }
-        { \ math.private:fixnum> [ cc> emit-fixnum-comparison ] }
+        { \ math.private:fixnum-bitnot [ drop emit-fixnum-bitnot iterate-next ] }
-        { \ kernel:eq? [ cc= emit-fixnum-comparison ] }
+        { \ math.integers.private:fixnum-log2 [ drop emit-fixnum-log2 iterate-next ] }
-        { \ math.private:bignum>fixnum [ drop emit-bignum>fixnum ] }
+        { \ math.private:fixnum*fast [ emit-fixnum*fast iterate-next ] }
-        { \ math.private:fixnum>bignum [ drop emit-fixnum>bignum ] }
+        { \ math.private:fixnum< [ cc< emit-fixnum-comparison iterate-next ] }
-        { \ math.private:float+ [ drop [ ^^add-float ] emit-float-op ] }
+        { \ math.private:fixnum<= [ cc<= emit-fixnum-comparison iterate-next ] }
-        { \ math.private:float- [ drop [ ^^sub-float ] emit-float-op ] }
+        { \ math.private:fixnum>= [ cc>= emit-fixnum-comparison iterate-next ] }
-        { \ math.private:float* [ drop [ ^^mul-float ] emit-float-op ] }
+        { \ math.private:fixnum> [ cc> emit-fixnum-comparison iterate-next ] }
-        { \ math.private:float/f [ drop [ ^^div-float ] emit-float-op ] }
+        { \ kernel:eq? [ cc= emit-fixnum-comparison iterate-next ] }
-        { \ math.private:float< [ drop cc< emit-float-comparison ] }
+        { \ math.private:bignum>fixnum [ drop emit-bignum>fixnum iterate-next ] }
-        { \ math.private:float<= [ drop cc<= emit-float-comparison ] }
+        { \ math.private:fixnum>bignum [ drop emit-fixnum>bignum iterate-next ] }
-        { \ math.private:float>= [ drop cc>= emit-float-comparison ] }
+        { \ math.private:float+ [ drop [ ^^add-float ] emit-float-op iterate-next ] }
-        { \ math.private:float> [ drop cc> emit-float-comparison ] }
+        { \ math.private:float- [ drop [ ^^sub-float ] emit-float-op iterate-next ] }
-        { \ math.private:float= [ drop cc= emit-float-comparison ] }
+        { \ math.private:float* [ drop [ ^^mul-float ] emit-float-op iterate-next ] }
-        { \ math.private:float>fixnum [ drop emit-float>fixnum ] }
+        { \ math.private:float/f [ drop [ ^^div-float ] emit-float-op iterate-next ] }
-        { \ math.private:fixnum>float [ drop emit-fixnum>float ] }
+        { \ math.private:float< [ drop cc< emit-float-comparison iterate-next ] }
-        { \ slots.private:slot [ emit-slot ] }
+        { \ math.private:float<= [ drop cc<= emit-float-comparison iterate-next ] }
-        { \ slots.private:set-slot [ emit-set-slot ] }
+        { \ math.private:float>= [ drop cc>= emit-float-comparison iterate-next ] }
-        { \ strings.private:string-nth [ drop emit-string-nth ] }
+        { \ math.private:float> [ drop cc> emit-float-comparison iterate-next ] }
-        { \ classes.tuple.private:<tuple-boa> [ emit-<tuple-boa> ] }
+        { \ math.private:float= [ drop cc= emit-float-comparison iterate-next ] }
-        { \ arrays:<array> [ emit-<array> ] }
+        { \ math.private:float>fixnum [ drop emit-float>fixnum iterate-next ] }
-        { \ byte-arrays:<byte-array> [ emit-<byte-array> ] }
+        { \ math.private:fixnum>float [ drop emit-fixnum>float iterate-next ] }
-        { \ math.private:<complex> [ emit-simple-allot ] }
+        { \ slots.private:slot [ emit-slot iterate-next ] }
-        { \ math.private:<ratio> [ emit-simple-allot ] }
+        { \ slots.private:set-slot [ emit-set-slot iterate-next ] }
-        { \ kernel:<wrapper> [ emit-simple-allot ] }
+        { \ strings.private:string-nth [ drop emit-string-nth iterate-next ] }
-        { \ alien.accessors:alien-unsigned-1 [ 1 emit-alien-unsigned-getter ] }
+        { \ strings.private:set-string-nth-fast [ drop emit-set-string-nth-fast iterate-next ] }
-        { \ alien.accessors:set-alien-unsigned-1 [ 1 emit-alien-integer-setter ] }
+        { \ classes.tuple.private:<tuple-boa> [ emit-<tuple-boa> iterate-next ] }
-        { \ alien.accessors:alien-signed-1 [ 1 emit-alien-signed-getter ] }
+        { \ arrays:<array> [ emit-<array> iterate-next ] }
-        { \ alien.accessors:set-alien-signed-1 [ 1 emit-alien-integer-setter ] }
+        { \ byte-arrays:<byte-array> [ emit-<byte-array> iterate-next ] }
-        { \ alien.accessors:alien-unsigned-2 [ 2 emit-alien-unsigned-getter ] }
+        { \ byte-arrays:(byte-array) [ emit-(byte-array) iterate-next ] }
-        { \ alien.accessors:set-alien-unsigned-2 [ 2 emit-alien-integer-setter ] }
+        { \ math.private:<complex> [ emit-simple-allot iterate-next ] }
-        { \ alien.accessors:alien-signed-2 [ 2 emit-alien-signed-getter ] }
+        { \ math.private:<ratio> [ emit-simple-allot iterate-next ] }
-        { \ alien.accessors:set-alien-signed-2 [ 2 emit-alien-integer-setter ] }
+        { \ kernel:<wrapper> [ emit-simple-allot iterate-next ] }
-        { \ alien.accessors:alien-unsigned-4 [ 4 emit-alien-unsigned-getter ] }
+        { \ alien.accessors:alien-unsigned-1 [ 1 emit-alien-unsigned-getter iterate-next ] }
-        { \ alien.accessors:set-alien-unsigned-4 [ 4 emit-alien-integer-setter ] }
+        { \ alien.accessors:set-alien-unsigned-1 [ 1 emit-alien-integer-setter iterate-next ] }
-        { \ alien.accessors:alien-signed-4 [ 4 emit-alien-signed-getter ] }
+        { \ alien.accessors:alien-signed-1 [ 1 emit-alien-signed-getter iterate-next ] }
-        { \ alien.accessors:set-alien-signed-4 [ 4 emit-alien-integer-setter ] }
+        { \ alien.accessors:set-alien-signed-1 [ 1 emit-alien-integer-setter iterate-next ] }
-        { \ alien.accessors:alien-cell [ emit-alien-cell-getter ] }
+        { \ alien.accessors:alien-unsigned-2 [ 2 emit-alien-unsigned-getter iterate-next ] }
-        { \ alien.accessors:set-alien-cell [ emit-alien-cell-setter ] }
+        { \ alien.accessors:set-alien-unsigned-2 [ 2 emit-alien-integer-setter iterate-next ] }
-        { \ alien.accessors:alien-float [ single-float-regs emit-alien-float-getter ] }
+        { \ alien.accessors:alien-signed-2 [ 2 emit-alien-signed-getter iterate-next ] }
-        { \ alien.accessors:set-alien-float [ single-float-regs emit-alien-float-setter ] }
+        { \ alien.accessors:set-alien-signed-2 [ 2 emit-alien-integer-setter iterate-next ] }
-        { \ alien.accessors:alien-double [ double-float-regs emit-alien-float-getter ] }
+        { \ alien.accessors:alien-unsigned-4 [ 4 emit-alien-unsigned-getter iterate-next ] }
-        { \ alien.accessors:set-alien-double [ double-float-regs emit-alien-float-setter ] }
+        { \ alien.accessors:set-alien-unsigned-4 [ 4 emit-alien-integer-setter iterate-next ] }
+        { \ alien.accessors:alien-signed-4 [ 4 emit-alien-signed-getter iterate-next ] }
+        { \ alien.accessors:set-alien-signed-4 [ 4 emit-alien-integer-setter iterate-next ] }
+        { \ alien.accessors:alien-cell [ emit-alien-cell-getter iterate-next ] }
+        { \ alien.accessors:set-alien-cell [ emit-alien-cell-setter iterate-next ] }
+        { \ alien.accessors:alien-float [ single-float-regs emit-alien-float-getter iterate-next ] }
+        { \ alien.accessors:set-alien-float [ single-float-regs emit-alien-float-setter iterate-next ] }
+        { \ alien.accessors:alien-double [ double-float-regs emit-alien-float-getter iterate-next ] }
+        { \ alien.accessors:set-alien-double [ double-float-regs emit-alien-float-setter iterate-next ] }
     } case ;

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

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

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

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

basis/compiler/cfg/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/stack-frame/stack-frame.factor

@@ -34,6 +34,12 @@ M: insn compute-stack-frame*
 
 \ _gc t frame-required? set-word-prop
 \ _spill t frame-required? set-word-prop
+\ ##fixnum-add t frame-required? set-word-prop
+\ ##fixnum-sub t frame-required? set-word-prop
+\ ##fixnum-mul t frame-required? set-word-prop
+\ ##fixnum-add-tail f frame-required? set-word-prop
+\ ##fixnum-sub-tail f frame-required? set-word-prop
+\ ##fixnum-mul-tail f frame-required? set-word-prop
 
 : compute-stack-frame ( insns -- )
     frame-required? off

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/utilities/utilities.factor

@@ -33,5 +33,7 @@ IN: compiler.cfg.utilities
     building off
     basic-block off ;
 
+: stop-iterating ( -- next ) end-basic-block f ;
+
 : emit-primitive ( node -- )
     word>> ##call ##branch begin-basic-block ;

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

@@ -62,4 +62,8 @@ M: ##compare-imm-branch propagate
 M: ##dispatch propagate
     [ resolve ] change-src ;
 
+M: ##fixnum-overflow propagate
+    [ resolve ] change-src1
+    [ resolve ] change-src2 ;
+
 M: insn propagate ;

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

@@ -2,6 +2,7 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: kernel sequences layouts accessors combinators namespaces
 math fry
+compiler.cfg.hats
 compiler.cfg.instructions
 compiler.cfg.value-numbering.graph
 compiler.cfg.value-numbering.simplify
@@ -63,7 +64,7 @@ M: ##compare-imm-branch rewrite-tagged-comparison
 
 M: ##compare-imm rewrite-tagged-comparison
     [ dst>> ] [ (rewrite-tagged-comparison) ] bi
-    f \ ##compare-imm boa ;
+    i f \ ##compare-imm boa ;
 
 M: ##compare-imm-branch rewrite
     dup rewrite-boolean-comparison? [ rewrite-boolean-comparison ] when
@@ -78,7 +79,7 @@ M: ##compare-imm-branch rewrite
     [ dst>> ]
     [ src2>> ]
     [ src1>> vreg>vn vn>constant ] tri
-    cc= f \ ##compare-imm boa ;
+    cc= f i \ ##compare-imm boa ;
 
 M: ##compare rewrite
     dup flip-comparison? [
@@ -95,9 +96,9 @@ M: ##compare rewrite
 
 : rewrite-redundant-comparison ( insn -- insn' )
     [ cc>> ] [ dst>> ] [ src1>> vreg>expr dup op>> ] tri {
-        { \ ##compare [ >compare-expr< f \ ##compare boa ] }
+        { \ ##compare [ >compare-expr< i f \ ##compare boa ] }
-        { \ ##compare-imm [ >compare-imm-expr< f \ ##compare-imm boa ] }
+        { \ ##compare-imm [ >compare-imm-expr< i f \ ##compare-imm boa ] }
-        { \ ##compare-float [ >compare-expr< f \ ##compare-float boa ] }
+        { \ ##compare-float [ >compare-expr< i f \ ##compare-float boa ] }
     } case
     swap cc= eq? [ [ negate-cc ] change-cc ] when ;
 

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

@@ -1,6 +1,18 @@
 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
+tools.test kernel math combinators.short-circuit accessors
+sequences ;
+
+: trim-temps ( insns -- insns )
+    [
+        dup {
+            [ ##compare? ]
+            [ ##compare-imm? ]
+            [ ##compare-float? ]
+        } 1|| [ f >>temp ] when
+    ] map ;
+
 [
     {
         T{ ##peek f V int-regs 45 D 1 }
@@ -82,7 +94,7 @@ compiler.cfg.registers cpu.architecture tools.test kernel math ;
         T{ ##compare f V int-regs 4 V int-regs 2 V int-regs 1 cc> }
         T{ ##compare-imm f V int-regs 6 V int-regs 4 7 cc/= }
         T{ ##replace f V int-regs 6 D 0 }
-    } value-numbering
+    } value-numbering trim-temps
 ] unit-test
 
 [
@@ -100,7 +112,7 @@ compiler.cfg.registers cpu.architecture tools.test kernel math ;
         T{ ##compare f V int-regs 4 V int-regs 2 V int-regs 1 cc<= }
         T{ ##compare-imm f V int-regs 6 V int-regs 4 7 cc= }
         T{ ##replace f V int-regs 6 D 0 }
-    } value-numbering
+    } value-numbering trim-temps
 ] unit-test
 
 [
@@ -122,7 +134,7 @@ compiler.cfg.registers cpu.architecture tools.test kernel math ;
         T{ ##compare-float f V int-regs 12 V double-float-regs 10 V double-float-regs 11 cc< }
         T{ ##compare-imm f V int-regs 14 V int-regs 12 7 cc= }
         T{ ##replace f V int-regs 14 D 0 }
-    } value-numbering
+    } value-numbering trim-temps
 ] unit-test
 
 [
@@ -138,5 +150,5 @@ compiler.cfg.registers cpu.architecture tools.test kernel math ;
         T{ ##peek f V int-regs 30 D -2 }
         T{ ##compare f V int-regs 33 V int-regs 29 V int-regs 30 cc<= }
         T{ ##compare-imm-branch f V int-regs 33 7 cc/= }
-    } value-numbering
+    } value-numbering trim-temps
 ] unit-test

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

@@ -131,6 +131,14 @@ M: ##string-nth generate-insn
         [ temp>> register ]
     } cleave %string-nth ;
 
+M: ##set-string-nth-fast generate-insn
+    {
+        [ src>> register ]
+        [ obj>> register ]
+        [ index>> register ]
+        [ temp>> register ]
+    } cleave %set-string-nth-fast ;
+
 : dst/src ( insn -- dst src )
     [ dst>> register ] [ src>> register ] bi ; inline
 
@@ -155,6 +163,20 @@ 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
+
+: src1/src2/temp1/temp2 ( insn -- src1 src2 temp1 temp2 )
+    [ src1/src2 ] [ temp1>> register ] [ temp2>> register ] tri ; inline
+
+M: ##fixnum-add generate-insn src1/src2 %fixnum-add ;
+M: ##fixnum-add-tail generate-insn src1/src2 %fixnum-add-tail ;
+M: ##fixnum-sub generate-insn src1/src2 %fixnum-sub ;
+M: ##fixnum-sub-tail generate-insn src1/src2 %fixnum-sub-tail ;
+M: ##fixnum-mul generate-insn src1/src2/temp1/temp2 %fixnum-mul ;
+M: ##fixnum-mul-tail generate-insn src1/src2/temp1/temp2 %fixnum-mul-tail ;
 
 : dst/src/temp ( insn -- dst src temp )
     [ dst/src ] [ temp>> register ] bi ; inline
@@ -215,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 )
 
@@ -235,7 +261,7 @@ M: float-regs reg-class-variable drop float-regs ;
 GENERIC: inc-reg-class ( register-class -- )
 
 : ?dummy-stack-params ( reg-class -- )
-    dummy-stack-params? [ reg-size stack-params +@ ] [ drop ] if ;
+    dummy-stack-params? [ reg-size cell align stack-params +@ ] [ drop ] if ;
 
 : ?dummy-int-params ( reg-class -- )
     dummy-int-params? [ reg-size cell /i 1 max int-regs +@ ] [ drop ] if ;
@@ -264,7 +290,7 @@ M: object reg-class-full?
 
 : spill-param ( reg-class -- n reg-class )
     stack-params get
-    >r reg-size stack-params +@ r>
+    [ reg-size cell align stack-params +@ ] dip
     stack-params ;
 
 : fastcall-param ( reg-class -- n reg-class )
@@ -300,10 +326,10 @@ M: long-long-type flatten-value-type ( type -- types )
     ] { } make ;
 
 : each-parameter ( parameters quot -- )
-    >r [ parameter-sizes nip ] keep r> 2each ; inline
+    [ [ parameter-sizes nip ] keep ] dip 2each ; inline
 
 : reverse-each-parameter ( parameters quot -- )
-    >r [ parameter-sizes nip ] keep r> 2reverse-each ; inline
+    [ [ parameter-sizes nip ] keep ] dip 2reverse-each ; inline
 
 : reset-freg-counts ( -- )
     { int-regs float-regs stack-params } [ 0 swap set ] each ;
@@ -316,15 +342,13 @@ M: long-long-type flatten-value-type ( type -- types )
     #! Moves values from C stack to registers (if word is
     #! %load-param-reg) and registers to C stack (if word is
     #! %save-param-reg).
-    >r
+    [ alien-parameters flatten-value-types ]
-    alien-parameters
+    [ '[ alloc-parameter _ execute ] ]
-    flatten-value-types
+    bi* each-parameter ; inline
-    r> '[ alloc-parameter _ execute ] each-parameter ;
-    inline
 
 : unbox-parameters ( offset node -- )
     parameters>> [
-        %prepare-unbox >r over + r> unbox-parameter
+        %prepare-unbox [ over + ] dip unbox-parameter
     ] reverse-each-parameter drop ;
 
 : prepare-box-struct ( node -- offset )
@@ -432,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? [
@@ -491,9 +515,10 @@ M: _label generate-insn
 M: _branch generate-insn
     label>> lookup-label %jump-label ;
 
-: >compare< ( insn -- label cc src1 src2 )
+: >compare< ( insn -- dst temp cc src1 src2 )
     {
         [ dst>> register ]
+        [ temp>> register ]
         [ cc>> ]
         [ src1>> register ]
         [ src2>> ?register ]

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 * ;
 
@@ -46,28 +46,27 @@ M: integer fixup* , ;
 : indq ( elt seq -- n ) [ eq? ] with find drop ;
 
 : adjoin* ( obj table -- n )
-    2dup indq [ 2nip ] [ dup length >r push r> ] if* ;
+    2dup indq [ 2nip ] [ dup length [ push ] dip ] if* ;
 
 SYMBOL: literal-table
 
 : add-literal ( obj -- n ) literal-table get adjoin* ;
 
 : add-dlsym-literals ( symbol dll -- )
-    >r string>symbol r> 2array literal-table get push-all ;
+    [ string>symbol ] dip 2array literal-table get push-all ;
 
 : rel-dlsym ( name dll class -- )
-    >r literal-table get length >r
+    [ literal-table get length [ add-dlsym-literals ] dip ] dip
-    add-dlsym-literals
+    rt-dlsym rel-fixup ;
-    r> r> rt-dlsym rel-fixup ;
 
 : rel-word ( word class -- )
-    >r add-literal r> rt-xt rel-fixup ;
+    [ add-literal ] dip rt-xt rel-fixup ;
 
 : rel-primitive ( word class -- )
-    >r def>> first r> rt-primitive rel-fixup ;
+    [ def>> first ] dip rt-primitive rel-fixup ;
 
-: rel-literal ( literal class -- )
+: rel-immediate ( literal class -- )
-    >r add-literal r> rt-literal rel-fixup ;
+    [ add-literal ] dip rt-immediate rel-fixup ;
 
 : rel-this ( class -- )
     0 swap rt-label rel-fixup ;

basis/compiler/compiler-docs.factor

@@ -6,7 +6,7 @@ HELP: enable-compiler
 { $description "Enables the optimizing compiler." } ;
 
 HELP: disable-compiler
-{ $description "Enables the optimizing compiler." } ;
+{ $description "Disable the optimizing compiler." } ;
 
 ARTICLE: "compiler-usage" "Calling the optimizing compiler"
 "Normally, new word definitions are recompiled automatically. This can be changed:"

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 ;
@@ -91,8 +90,8 @@ t compile-dependencies? set-global
     [
         dup crossref?
         [
-            dependencies get >alist
+            dependencies get
-            generic-dependencies get >alist
+            generic-dependencies get
             compiled-xref
         ] [ drop ] if
     ] tri ;

basis/compiler/constants/constants.factor

@@ -39,13 +39,12 @@ IN: compiler.constants
 ! Relocation types
 : rt-primitive   0 ; inline
 : rt-dlsym       1 ; inline
-: rt-literal     2 ; inline
+: rt-dispatch    2 ; inline
-: rt-dispatch    3 ; inline
+: rt-xt          3 ; inline
-: rt-xt          4 ; inline
+: rt-here        4 ; inline
-: rt-here        5 ; inline
+: rt-label       5 ; inline
-: rt-label       6 ; inline
+: rt-immediate   6 ; inline
-: rt-immediate   7 ; inline
+: rt-stack-chain 7 ; inline
-: rt-stack-chain 8 ; inline
 
 : rc-absolute? ( n -- ? )
     [ rc-absolute-ppc-2/2 = ]

basis/compiler/tests/alien.factor

@@ -3,7 +3,8 @@ USING: alien alien.c-types alien.syntax compiler kernel
 namespaces namespaces tools.test sequences stack-checker
 stack-checker.errors words arrays parser quotations
 continuations effects namespaces.private io io.streams.string
-memory system threads tools.test math accessors combinators ;
+memory system threads tools.test math accessors combinators
+specialized-arrays.float ;
 
 FUNCTION: void ffi_test_0 ;
 [ ] [ ffi_test_0 ] unit-test
@@ -82,14 +83,14 @@ FUNCTION: tiny ffi_test_17 int x ;
 
 { 1 1 } [ indirect-test-1 ] must-infer-as
 
-[ 3 ] [ "ffi_test_1" f dlsym indirect-test-1 ] unit-test
+[ 3 ] [ &: ffi_test_1 indirect-test-1 ] unit-test
 
 : indirect-test-1' ( ptr -- )
     "int" { } "cdecl" alien-indirect drop ;
 
 { 1 0 } [ indirect-test-1' ] must-infer-as
 
-[ ] [ "ffi_test_1" f dlsym indirect-test-1' ] unit-test
+[ ] [ &: ffi_test_1 indirect-test-1' ] unit-test
 
 [ -1 indirect-test-1 ] must-fail
 
@@ -99,7 +100,7 @@ FUNCTION: tiny ffi_test_17 int x ;
 { 3 1 } [ indirect-test-2 ] must-infer-as
 
 [ 5 ]
-[ 2 3 "ffi_test_2" f dlsym indirect-test-2 ]
+[ 2 3 &: ffi_test_2 indirect-test-2 ]
 unit-test
 
 : indirect-test-3 ( a b c d ptr -- result )
@@ -146,13 +147,21 @@ FUNCTION: void ffi_test_20 double x1, double x2, double x3,
 
 ! Make sure XT doesn't get clobbered in stack frame
 
-: ffi_test_31 ( a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a ptr -- result y )
+: ffi_test_31 ( a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a -- result y )
-    "void"
+    "int"
     f "ffi_test_31"
     { "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" }
     alien-invoke gc 3 ;
 
-[ 3 ] [ 42 [ ] each ffi_test_31 ] unit-test
+[ 861 3 ] [ 42 [ ] each ffi_test_31 ] unit-test
+
+: ffi_test_31_point_5 ( a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a -- result )
+    "float"
+    f "ffi_test_31_point_5"
+    { "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" }
+    alien-invoke ;
+
+[ 861.0 ] [ 42 [ >float ] each ffi_test_31_point_5 ] unit-test
 
 FUNCTION: longlong ffi_test_21 long x long y ;
 
@@ -188,7 +197,11 @@ FUNCTION: int ffi_test_12 int a int b rect c int d int e int f ;
 
 FUNCTION: float ffi_test_23 ( float[3] x, float[3] y ) ;
 
-[ 32.0 ] [ { 1.0 2.0 3.0 } >c-float-array { 4.0 5.0 6.0 } >c-float-array ffi_test_23 ] unit-test
+[ 32.0 ] [
+    { 1.0 2.0 3.0 } >float-array underlying>>
+    { 4.0 5.0 6.0 } >float-array underlying>>
+    ffi_test_23
+] unit-test
 
 ! Test odd-size structs
 C-STRUCT: test-struct-1 { { "char" 1 } "x" } ;
@@ -353,7 +366,7 @@ FUNCTION: ulonglong ffi_test_38 ( ulonglong x, ulonglong y ) ;
 [ 1 2 3 ] [ callback-6 callback_test_1 1 2 3 ] unit-test
 
 : callback-7 ( -- callback )
-    "void" { } "cdecl" [ 1000 sleep ] alien-callback ;
+    "void" { } "cdecl" [ 1000000 sleep ] alien-callback ;
 
 [ 1 2 3 ] [ callback-7 callback_test_1 1 2 3 ] unit-test
 

basis/compiler/tests/codegen.factor

@@ -3,7 +3,7 @@ kernel.private math hashtables.private math.private namespaces
 sequences sequences.private tools.test namespaces.private
 slots.private sequences.private byte-arrays alien
 alien.accessors layouts words definitions compiler.units io
-combinators vectors float-arrays ;
+combinators vectors grouping make ;
 IN: compiler.tests
 
 ! Originally, this file did black box testing of templating
@@ -241,3 +241,38 @@ TUPLE: id obj ;
 
 [ "a" ] [ 1 test-2 ] unit-test
 [ "b" ] [ 2 test-2 ] unit-test
+
+! I accidentally fixnum/i-fast on PowerPC
+[ { { 1 2 } { 3 4 } } ] [
+    { 1 2 3 4 }
+    [
+        [ { array } declare 2 <groups> [ , ] each ] compile-call
+    ] { } make
+] unit-test
+
+[ 2 ] [
+    { 1 2 3 4 }
+    [ { array } declare 2 <groups> length ] compile-call
+] unit-test
+
+! Oops with new intrinsics
+: fixnum-overflow-control-flow-test ( a b -- c )
+    [ 1 fixnum- ] [ 2 fixnum- ] if 3 fixnum+fast ;
+
+[ 3 ] [ 1 t fixnum-overflow-control-flow-test ] unit-test
+[ 2 ] [ 1 f fixnum-overflow-control-flow-test ] unit-test
+
+! LOL
+: blah ( a -- b )
+    { float } declare dup 0 =
+    [ drop 1 ] [
+        dup 0 >=
+        [ 2 "double" "libm" "pow" { "double" "double" } alien-invoke ]
+        [ -0.5 "double" "libm" "pow" { "double" "double" } alien-invoke ]
+        if
+    ] if ;
+
+[ 4.0 ] [ 2.0 blah ] unit-test
+
+[ 4 ] [ 2 [ dup fixnum* ] compile-call ] unit-test
+[ 7 ] [ 2 [ dup fixnum* 3 fixnum+fast ] compile-call ] unit-test