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

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/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

@@ -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>> ;
@@ -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

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

@@ -3,13 +3,13 @@
 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.utf16 system alien strings cpu.architecture ;
+io.encodings.utf16 system alien strings cpu.architecture fry ;
 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 ] ;

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

@@ -9,6 +9,8 @@ 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 ;
@@ -36,25 +38,26 @@ M: struct-type stack-size
 
 : 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 )
     [ 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" } }
@@ -88,7 +82,7 @@ HELP: typedef
 { $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

@@ -4,35 +4,9 @@ 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
-assocs combinators lexer strings.parser ;
+assocs combinators lexer strings.parser alien.parser ;
 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,22 +23,16 @@ 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*

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.backend 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>
 
@@ -84,9 +83,9 @@ M: bit-array byte-length length 7 + -3 shift ;
     ] 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/bootstrap/compiler/compiler.factor

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

basis/bootstrap/image/image.factor

@@ -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,10 +124,10 @@ 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
@@ -155,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 }
@@ -205,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.
@@ -351,7 +351,12 @@ M: wrapper '
 : pad-bytes ( seq -- newseq )
     dup length bootstrap-cell align 0 pad-right ;
 
+: check-string ( string -- )
+    [ 127 > ] contains?
+    [ "Bootstrap cannot emit non-ASCII strings" throw ] when ;
+
 : emit-string ( string -- ptr )
+    dup check-string
     string type-number object tag-number [
         dup length emit-fixnum
         f ' emit
@@ -469,10 +474,10 @@ 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

basis/bootstrap/stage2.factor

@@ -32,8 +32,8 @@ SYMBOL: bootstrap-time
 : count-words ( pred -- )
     all-words swap count number>string write ;
 
-: print-time ( us -- )
+: print-time ( ms -- )
-    1000000 /i
+    1000 /i
     60 /mod swap
     number>string write
     " minutes and " write number>string write " seconds." print ;
@@ -52,16 +52,16 @@ SYMBOL: bootstrap-time
 
 [
     ! We time bootstrap
-    micros
+    millis
 
     default-image-name "output-image" set-global
 
     "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
@@ -77,7 +77,7 @@ SYMBOL: bootstrap-time
     [
         load-components
 
-        micros over - core-bootstrap-time set-global
+        millis over - core-bootstrap-time set-global
 
         run-bootstrap-init
     ] with-compiler-errors
@@ -92,15 +92,10 @@ SYMBOL: bootstrap-time
         [
             boot
             do-init-hooks
-            [
+            handle-command-line
-                parse-command-line
-                run-user-init
-                "run" get run
-                output-stream get [ stream-flush ] when*
-            ] [ print-error 1 exit ] recover
         ] set-boot-quot
 
-        micros swap - bootstrap-time set-global
+        millis swap - bootstrap-time set-global
         print-report
 
         "output-image" get save-image-and-exit

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

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

basis/calendar/calendar-tests.factor

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

basis/calendar/calendar.factor

@@ -89,6 +89,13 @@ PRIVATE>
 : minutes-per-year ( -- ratio ) 5259492/10 ; inline
 : seconds-per-year ( -- integer ) 31556952 ; inline
 
+: monthly ( x -- y ) 12 / ; inline
+: semimonthly ( x -- y ) 24 / ; inline
+: biweekly ( x -- y ) 26 / ; inline
+: weekly ( x -- y ) 52 / ; inline
+: daily-360 ( x -- y ) 360 / ; inline
+: daily-365 ( x -- y ) 365 / ; inline
+
 :: julian-day-number ( year month day -- n )
     #! Returns a composite date number
     #! Not valid before year -4800
@@ -173,7 +180,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 +188,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 +198,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 +207,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 +216,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 +233,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 +291,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,13 +327,13 @@ 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 )
-    >r unix-1970 r> microseconds time+ ;
+    [ unix-1970 ] dip microseconds time+ ;
 
 : timestamp>micros ( timestamp -- n )
     unix-1970 (time-) 1000000 * >integer ;
@@ -343,10 +350,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 )
 

basis/calendar/format/format.factor

@@ -138,11 +138,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 +152,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 +182,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 )

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

@@ -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

basis/checksums/openssl/openssl.factor

@@ -28,7 +28,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

@@ -41,9 +41,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 ;
 

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/cocoa/application/application.factor

@@ -27,35 +27,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 +76,6 @@ M: objc-error summary ( error -- )
     running.app? [
         drop
     ] [
-        "The " swap " requires you to run Factor from an application bundle."
+        "The " " requires you to run Factor from an application bundle."
-        3append throw
+        surround throw
     ] if ;

basis/cocoa/cocoa-tests.factor

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

basis/cocoa/dialogs/dialogs.factor

@@ -1,4 +1,4 @@
-! 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 ;
@@ -29,6 +29,6 @@ IN: cocoa.dialogs
     "/" 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,11 +1,12 @@
 ! Copyright (C) 2006, 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors alien alien.c-types alien.strings arrays assocs
-combinators compiler compiler.alien kernel math namespaces make
+continuations combinators compiler compiler.alien kernel math
-parser prettyprint prettyprint.sections quotations sequences
+namespaces make parser prettyprint prettyprint.sections
-strings words cocoa.runtime io macros memoize debugger
+quotations sequences strings words cocoa.runtime io macros
-io.encodings.ascii effects libc libc.private parser lexer init
+memoize debugger io.encodings.ascii effects libc libc.private
-core-foundation fry ;
+parser lexer init core-foundation fry generalizations
+specialized-arrays.direct.alien ;
 IN: cocoa.messages
 
 : make-sender ( method function -- quot )
@@ -27,7 +28,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 +38,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,23 +63,18 @@ 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
 
@@ -89,9 +85,17 @@ MACRO: (send) ( selector super? -- quot )
 \ super-send soft "break-after" set-word-prop
 
 ! Runtime introspection
-: (objc-class) ( string word -- class )
+SYMBOL: class-init-hooks
-    dupd execute
+
-    [ ] [ "No such class: " prepend throw ] ?if ; inline
+class-init-hooks global [ H{ } clone or ] change-at
+
+: (objc-class) ( name word -- class )
+    2dup execute dup [ 2nip ] [
+        drop over class-init-hooks get at [ assert-depth ] when*
+        2dup execute dup [ 2nip ] [
+            2drop "No such class: " prepend throw
+        ] if
+    ] if ; inline
 
 : objc-class ( string -- class )
     \ objc_getClass (objc-class) ;
@@ -165,14 +169,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 ] }
@@ -203,8 +207,11 @@ 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 ;
@@ -222,23 +229,20 @@ assoc-union alien>objc-types set-global
 
 : 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
+    '[
-    [
+        _
-        dup
+        [ objc-class register-objc-methods ]
-        objc-class register-objc-methods
+        [ objc-meta-class register-objc-methods ] bi
-        objc-meta-class register-objc-methods
+    ] try ;
-    ] curry try ;
 
 : root-class ( class -- root )
     dup class_getSuperclass [ root-class ] [ ] ?if ;

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 cocoa core-foundation sequences
-sequences ;
+;
 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/subclassing/subclassing.factor

@@ -1,10 +1,9 @@
-! Copyright (C) 2006, 2008 Slava Pestov
+! Copyright (C) 2006, 2008 Slava Pestov, Joe Groff.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: alien alien.c-types alien.strings arrays assocs
 combinators compiler hashtables kernel libc math namespaces
-parser sequences words cocoa.messages cocoa.runtime
+parser sequences words cocoa.messages cocoa.runtime locals
-compiler.units io.encodings.ascii generalizations
+compiler.units io.encodings.ascii continuations make fry ;
-continuations make ;
 IN: cocoa.subclassing
 
 : init-method ( method -- sel imp types )
@@ -12,22 +11,25 @@ IN: cocoa.subclassing
     [ sel_registerName ] [ execute ] [ ascii string>alien ]
     tri* ;
 
-: throw-if-false ( YES/NO -- )
+: throw-if-false ( obj what -- )
-    zero? [ "Failed to add method or protocol to class" throw ]
+    swap { f 0 } member?
-    when ;
+    [ "Failed to " prepend throw ] [ drop ] if ;
+
+: add-method ( class sel imp types -- )
+    class_addMethod "add method to class" throw-if-false ;
 
 : add-methods ( methods class -- )
-    swap
+    '[ [ _ ] dip init-method add-method ] each ;
-    [ init-method class_addMethod throw-if-false ] with each ;
+
+: add-protocol ( class protocol -- )
+    class_addProtocol "add protocol to class" throw-if-false ;
 
 : add-protocols ( protocols class -- )
-    swap [ objc-protocol class_addProtocol throw-if-false ]
+    '[ [ _ ] dip objc-protocol add-protocol ] each ;
-    with each ;
 
-: (define-objc-class) ( protocols superclass name imeth -- )
+: (define-objc-class) ( imeth protocols superclass name -- )
-    -rot
     [ objc-class ] dip 0 objc_allocateClassPair
-    [ add-methods ] [ add-protocols ] [ objc_registerClassPair ]
+    [ add-protocols ] [ add-methods ] [ objc_registerClassPair ]
     tri ;
 
 : encode-types ( return types -- encoding )
@@ -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 ;
@@ -69,12 +69,12 @@ 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> <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.factor

@@ -3,9 +3,13 @@ locals generalizations macros fry ;
 IN: combinators.short-circuit
 
 MACRO:: n&& ( quots n -- quot )
-    [ f ]
+    [ f ] quots [| q |
-    quots [| q | { [ drop n ndup q call dup not ] [ drop n ndrop f ] } ] map
+        n
-    [ n nnip ] suffix 1array
+        [ q '[ drop _ ndup @ dup not ] ]
+        [ '[ drop _ ndrop f ] ]
+        bi 2array
+    ] map
+    n '[ _ nnip ] suffix 1array
     [ cond ] 3append ;
 
 MACRO: 0&& ( quots -- quot ) '[ _ 0 n&& ] ;
@@ -14,10 +18,13 @@ MACRO: 2&& ( quots -- quot ) '[ _ 2 n&& ] ;
 MACRO: 3&& ( quots -- quot ) '[ _ 3 n&& ] ;
 
 MACRO:: n|| ( quots n -- quot )
-    [ f ]
+    [ f ] quots [| q |
-    quots
+        n
-    [| q | { [ drop n ndup q call dup ] [ n nnip ] } ] map
+        [ q '[ drop _ ndup @ dup ] ]
-    { [ drop n ndrop t ] [ f ] } suffix 1array
+        [ '[ _ nnip ] ]
+        bi 2array
+    ] map
+    n '[ drop _ ndrop t ] [ f ] 2array suffix 1array
     [ cond ] 3append ;
 
 MACRO: 0|| ( quots -- quot ) '[ _ 0 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 debugger hashtables io
-kernel.private namespaces parser sequences strings system
+io.encodings.utf8 io.files kernel kernel.private namespaces
-splitting io.files eval ;
+parser sequences strings system splitting eval 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,33 @@ 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 ;
+<PRIVATE
 
-: cli-param ( param -- )
+: var-param ( name value -- ) swap set-global ;
-    "=" split1 [ cli-var-param ] [ cli-bool-param ] if* ;
 
-: cli-arg ( argument -- argument )
+: bool-param ( name -- ) "no-" ?head not var-param ;
-    "-" ?head [ cli-param f ] when ;
 
-: cli-args ( -- args ) 10 getenv ;
+: param ( param -- )
+    "=" split1 [ var-param ] [ bool-param ] if* ;
+
+: run-script ( file -- )
+    t "quiet" set-global run-file ;
+
+PRIVATE>
+
+: 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 +74,17 @@ 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 ( -- )
+: handle-command-line ( -- )
-    cli-args [ cli-arg ] filter
+    [
-    "script" get [ script-mode ] when
+        (command-line) parse-command-line
-    ignore-cli-args? [ drop ] [ [ run-file ] each ] if
+        load-vocab-roots
-    "e" get [ eval ] when* ;
+        run-user-init
+        "e" get [ eval ] when*
+        ignore-cli-args? not script get and
+        [ run-script ] [ "run" get run ] if*
+        output-stream get [ stream-flush ] when*
+    ] [ print-error 1 exit ] recover ;
 
 [ default-cli-args ] "command-line" add-init-hook

basis/compiler/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.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/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/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,6 +48,7 @@ IN: compiler.cfg.intrinsics
     slots.private:slot
     slots.private:set-slot
     strings.private:string-nth
+    strings.private:set-string-nth-fast
     classes.tuple.private:<tuple-boa>
     arrays:<array>
     byte-arrays:<byte-array>
@@ -85,60 +94,70 @@ 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 ] }
+        { \ math.private:<complex> [ emit-simple-allot iterate-next ] }
-        { \ alien.accessors:set-alien-unsigned-2 [ 2 emit-alien-integer-setter ] }
+        { \ math.private:<ratio> [ emit-simple-allot iterate-next ] }
-        { \ alien.accessors:alien-signed-2 [ 2 emit-alien-signed-getter ] }
+        { \ kernel:<wrapper> [ emit-simple-allot iterate-next ] }
-        { \ alien.accessors:set-alien-signed-2 [ 2 emit-alien-integer-setter ] }
+        { \ alien.accessors:alien-unsigned-1 [ 1 emit-alien-unsigned-getter iterate-next ] }
-        { \ alien.accessors:alien-unsigned-4 [ 4 emit-alien-unsigned-getter ] }
+        { \ alien.accessors:set-alien-unsigned-1 [ 1 emit-alien-integer-setter iterate-next ] }
-        { \ alien.accessors:set-alien-unsigned-4 [ 4 emit-alien-integer-setter ] }
+        { \ alien.accessors:alien-signed-1 [ 1 emit-alien-signed-getter iterate-next ] }
-        { \ alien.accessors:alien-signed-4 [ 4 emit-alien-signed-getter ] }
+        { \ alien.accessors:set-alien-signed-1 [ 1 emit-alien-integer-setter iterate-next ] }
-        { \ alien.accessors:set-alien-signed-4 [ 4 emit-alien-integer-setter ] }
+        { \ alien.accessors:alien-unsigned-2 [ 2 emit-alien-unsigned-getter iterate-next ] }
-        { \ alien.accessors:alien-cell [ emit-alien-cell-getter ] }
+        { \ alien.accessors:set-alien-unsigned-2 [ 2 emit-alien-integer-setter iterate-next ] }
-        { \ alien.accessors:set-alien-cell [ emit-alien-cell-setter ] }
+        { \ alien.accessors:alien-signed-2 [ 2 emit-alien-signed-getter iterate-next ] }
-        { \ alien.accessors:alien-float [ single-float-regs emit-alien-float-getter ] }
+        { \ alien.accessors:set-alien-signed-2 [ 2 emit-alien-integer-setter iterate-next ] }
-        { \ alien.accessors:set-alien-float [ single-float-regs emit-alien-float-setter ] }
+        { \ alien.accessors:alien-unsigned-4 [ 4 emit-alien-unsigned-getter iterate-next ] }
-        { \ alien.accessors:alien-double [ double-float-regs emit-alien-float-getter ] }
+        { \ alien.accessors:set-alien-unsigned-4 [ 4 emit-alien-integer-setter iterate-next ] }
-        { \ alien.accessors:set-alien-double [ double-float-regs emit-alien-float-setter ] }
+        { \ 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/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,17 @@
 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 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 +93,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 +111,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 +133,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 +149,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/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 )
 
@@ -264,7 +290,7 @@ M: object reg-class-full?
 
 : spill-param ( reg-class -- n reg-class )
     stack-params get
-    >r reg-size cell align 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

@@ -9,7 +9,7 @@ IN: compiler.codegen.fixup
 
 GENERIC: fixup* ( obj -- )
 
-: code-format 22 getenv ;
+: code-format ( -- n ) 22 getenv ;
 
 : compiled-offset ( -- n ) building get length code-format * ;
 
@@ -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/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
@@ -196,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" } ;

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

basis/compiler/tests/intrinsics.factor

@@ -160,6 +160,11 @@ IN: compiler.tests
 [ -2 ] [ 4 [ -2 fixnum/i ] compile-call ] unit-test
 [ 3 1 ] [ 10 3 [ fixnum/mod ] compile-call ] unit-test
 
+[ 2 ] [ 4 2 [ fixnum/i-fast ] compile-call ] unit-test
+[ 2 ] [ 4 [ 2 fixnum/i-fast ] compile-call ] unit-test
+[ -2 ] [ 4 [ -2 fixnum/i-fast ] compile-call ] unit-test
+[ 3 1 ] [ 10 3 [ fixnum/mod-fast ] compile-call ] unit-test
+
 [ 4 ] [ 1 3 [ fixnum+ ] compile-call ] unit-test
 [ 4 ] [ 1 [ 3 fixnum+ ] compile-call ] unit-test
 [ 4 ] [ [ 1 3 fixnum+ ] compile-call ] unit-test
@@ -208,6 +213,7 @@ IN: compiler.tests
 [ -1 ] [ [ -123 -64 fixnum-shift ] compile-call ] unit-test
 [ -1 ] [ -123 -64 [ fixnum-shift ] compile-call ] unit-test
 
+[ HEX: 10000000 ] [ HEX: 1000000 HEX: 10 [ fixnum* ] compile-call ] unit-test
 [ HEX: 10000000 ] [ HEX: -10000000 >fixnum [ 0 swap fixnum- ] compile-call ] unit-test
 [ HEX: 10000000 ] [ HEX: -fffffff >fixnum [ 1 swap fixnum- ] compile-call ] unit-test
 

basis/compiler/tests/optimizer.factor

@@ -286,9 +286,7 @@ HINTS: recursive-inline-hang-2 array ;
 HINTS: recursive-inline-hang-3 array ;
 
 ! Regression
-USE: sequences.private
+[ ] [ { 3append-as } compile ] unit-test
-
-[ ] [ { (3append) } compile ] unit-test
 
 ! Wow
 : counter-example ( a b c d -- a' b' c' d' )

basis/compiler/tests/spilling.factor

@@ -1,5 +1,5 @@
 USING: math.private kernel combinators accessors arrays
-generalizations float-arrays tools.test ;
+generalizations tools.test ;
 IN: compiler.tests
 
 : float-spill-bug ( a -- b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b )

basis/compiler/tree/builder/builder.factor

@@ -21,7 +21,7 @@ IN: compiler.tree.builder
 : build-tree-with ( in-stack quot -- nodes out-stack )
     #! Not safe to call from inference transforms.
     [
-        [ >vector meta-d set ]
+        [ >vector \ meta-d set ]
         [ f initial-recursive-state infer-quot ] bi*
     ] with-tree-builder nip
     unclip-last in-d>> ;

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

@@ -71,7 +71,7 @@ M: object xyz ;
     2over fixnum>= [
         3drop
     ] [
-        [ swap >r call 1 fixnum+fast r> ] keep (fx-repeat)
+        [ swap [ call 1 fixnum+fast ] dip ] keep (fx-repeat)
     ] if ; inline recursive
 
 : fx-repeat ( n quot -- )
@@ -87,10 +87,10 @@ M: object xyz ;
     2over dup xyz drop >= [
         3drop
     ] [
-        [ swap >r call 1+ r> ] keep (i-repeat)
+        [ swap [ call 1+ ] dip ] keep (i-repeat)
     ] if ; inline recursive
 
-: i-repeat >r { integer } declare r> 0 -rot (i-repeat) ; inline
+: i-repeat [ { integer } declare ] dip 0 -rot (i-repeat) ; inline
 
 [ t ] [
     [ [ dup xyz drop ] i-repeat ] \ xyz inlined?
@@ -194,7 +194,7 @@ M: fixnum annotate-entry-test-1 drop ;
     2dup >= [
         2drop
     ] [
-        >r dup annotate-entry-test-1 1+ r> (annotate-entry-test-2)
+        [ dup annotate-entry-test-1 1+ ] dip (annotate-entry-test-2)
     ] if ; inline recursive
 
 : annotate-entry-test-2 0 -rot (annotate-entry-test-2) ; inline
@@ -448,7 +448,7 @@ cell-bits 32 = [
 ] unit-test
 
 [ ] [
-    [ [ >r "A" throw r> ] [ "B" throw ] if ]
+    [ [ [ "A" throw ] dip ] [ "B" throw ] if ]
     cleaned-up-tree drop
 ] unit-test
 
@@ -463,7 +463,7 @@ cell-bits 32 = [
 : buffalo-wings ( i seq -- )
     2dup < [
         2dup chicken-fingers
-        >r 1+ r> buffalo-wings
+        [ 1+ ] dip buffalo-wings
     ] [
         2drop
     ] if ; inline recursive
@@ -482,7 +482,7 @@ cell-bits 32 = [
 : ribs ( i seq -- )
     2dup < [
         steak
-        >r 1+ r> ribs
+        [ 1+ ] dip ribs
     ] [
         2drop
     ] if ; inline recursive

basis/compiler/tree/cleanup/cleanup.factor

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

basis/compiler/tree/combinators/combinators.factor

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

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

@@ -75,9 +75,9 @@ IN: compiler.tree.dead-code.tests
     remove-dead-code
     "no-check" get [ dup check-nodes ] unless nodes>quot ;
 
-[ [ drop 1 ] ] [ [ >r 1 r> drop ] optimize-quot ] unit-test
+[ [ drop 1 ] ] [ [ [ 1 ] dip drop ] optimize-quot ] unit-test
 
-[ [ read drop 1 2 ] ] [ [ read >r 1 2 r> drop ] optimize-quot ] unit-test
+[ [ read drop 1 2 ] ] [ [ read [ 1 2 ] dip drop ] optimize-quot ] unit-test
 
 [ [ over >r + r> ] ] [ [ [ + ] [ drop ] 2bi ] optimize-quot ] unit-test
 

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

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

basis/compiler/tree/debugger/debugger.factor

@@ -93,7 +93,7 @@ M: #shuffle node>quot
         [ drop "COMPLEX SHUFFLE" , ]
     } cond ;
 
-M: #push node>quot literal>> , ;
+M: #push node>quot literal>> literalize , ;
 
 M: #call node>quot word>> , ;
 
@@ -125,9 +125,13 @@ M: node node>quot drop ;
 : nodes>quot ( node -- quot )
     [ [ node>quot ] each ] [ ] make ;
 
-: optimized. ( quot/word -- )
+GENERIC: optimized. ( quot/word -- )
-    dup word? [ specialized-def ] when
+
-    build-tree optimize-tree nodes>quot . ;
+M: method-spec optimized. first2 method optimized. ;
+
+M: word optimized. specialized-def optimized. ;
+
+M: callable optimized. build-tree optimize-tree nodes>quot . ;
 
 SYMBOL: words-called
 SYMBOL: generics-called

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

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

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

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

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

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

basis/compiler/tree/finalization/finalization.factor

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

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

@@ -34,8 +34,8 @@ sequences accessors tools.test kernel math ;
 [ ] [ [ [ 1 ] [ 2 ] if + * ] test-normalization ] unit-test
 
 DEFER: bbb
-: aaa ( x -- ) dup [ dup >r bbb r> aaa ] [ drop ] if ; inline recursive
+: aaa ( x -- ) dup [ dup [ bbb ] dip aaa ] [ drop ] if ; inline recursive
-: bbb ( x -- ) >r drop 0 r> aaa ; inline recursive
+: bbb ( x -- ) [ drop 0 ] dip aaa ; inline recursive
 
 [ ] [ [ bbb ] test-normalization ] unit-test
 

basis/compiler/tree/normalization/normalization.factor

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

basis/compiler/tree/optimizer/optimizer.factor

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

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

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

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

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

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

@@ -3,7 +3,7 @@
 USING: accessors kernel arrays sequences math math.order
 math.partial-dispatch generic generic.standard generic.math
 classes.algebra classes.union sets quotations assocs combinators
-words namespaces continuations
+words namespaces continuations classes fry
 compiler.tree
 compiler.tree.builder
 compiler.tree.recursive
@@ -20,13 +20,17 @@ SYMBOL: node-count
 : count-nodes ( nodes -- )
     0 swap [ drop 1+ ] each-node node-count set ;
 
+! We try not to inline the same word too many times, to avoid
+! combinatorial explosion
+SYMBOL: inlining-count
+
 ! Splicing nodes
 GENERIC: splicing-nodes ( #call word/quot/f -- nodes )
 
 M: word splicing-nodes
     [ [ in-d>> ] [ out-d>> ] bi ] dip #call 1array ;
 
-M: quotation splicing-nodes
+M: callable splicing-nodes
     build-sub-tree analyze-recursive normalize ;
 
 : propagate-body ( #call -- )
@@ -85,6 +89,8 @@ DEFER: (flat-length)
 
 : word-flat-length ( word -- n )
     {
+        ! special-case
+        { [ dup { dip 2dip 3dip } memq? ] [ drop 1 ] }
         ! not inline
         { [ dup inline? not ] [ drop 1 ] }
         ! recursive and inline
@@ -118,17 +124,25 @@ DEFER: (flat-length)
         bi and
     ] contains? ;
 
+: node-count-bias ( -- n )
+    45 node-count get [-] 8 /i ;
+
+: body-length-bias ( word -- n )
+    [ flat-length ] [ inlining-count get at 0 or ] bi
+    over 2 <= [ drop ] [ 2/ 1+ * ] if 24 swap [-] 4 /i ;
+
 : inlining-rank ( #call word -- n )
     [ classes-known? 2 0 ? ]
     [
         {
-            [ drop node-count get 45 swap [-] 8 /i ]
+            [ body-length-bias ]
-            [ flat-length 24 swap [-] 4 /i ]
             [ "default" word-prop -4 0 ? ]
             [ "specializer" word-prop 1 0 ? ]
             [ method-body? 1 0 ? ]
         } cleave
-    ] bi* + + + + + ;
+        node-count-bias
+        loop-nesting get 0 or 2 *
+    ] bi* + + + + + + ;
 
 : should-inline? ( #call word -- ? )
     dup "inline" word-prop [ 2drop t ] [ inlining-rank 5 >= ] if ;
@@ -136,20 +150,23 @@ DEFER: (flat-length)
 SYMBOL: history
 
 : remember-inlining ( word -- )
-    history [ swap suffix ] change ;
+    [ [ 1 ] dip inlining-count get at+ ]
+    [ history [ swap suffix ] change ]
+    bi ;
 
-: inline-word ( #call word -- ? )
+: inline-word-def ( #call word quot -- ? )
-    dup history get memq? [
+    over history get memq? [ 3drop f ] [
-        2drop f
-    ] [
         [
-            dup remember-inlining
+            swap remember-inlining
-            dupd def>> splicing-nodes >>body
+            dupd splicing-nodes >>body
             propagate-body
         ] with-scope
         t
     ] if ;
 
+: inline-word ( #call word -- ? )
+    dup def>> inline-word-def ;
+
 : inline-method-body ( #call word -- ? )
     2dup should-inline? [ inline-word ] [ 2drop f ] if ;
 
@@ -163,7 +180,11 @@ SYMBOL: history
     [ dup 1array ] [ "custom-inlining" word-prop ] bi* with-datastack
     first object swap eliminate-dispatch ;
 
-: do-inlining ( #call word -- ? )
+: inline-instance-check ( #call word -- ? )
+    over in-d>> second value-info literal>> dup class?
+    [ "predicate" word-prop '[ drop @ ] inline-word-def ] [ 3drop f ] if ;
+
+: (do-inlining) ( #call word -- ? )
     #! If the generic was defined in an outer compilation unit,
     #! then it doesn't have a definition yet; the definition
     #! is built at the end of the compilation unit. We do not
@@ -174,10 +195,17 @@ SYMBOL: history
     #! discouraged, but it should still work.)
     {
         { [ dup deferred? ] [ 2drop f ] }
-        { [ dup custom-inlining? ] [ inline-custom ] }
+        { [ dup \ instance? eq? ] [ inline-instance-check ] }
         { [ dup always-inline-word? ] [ inline-word ] }
         { [ dup standard-generic? ] [ inline-standard-method ] }
         { [ dup math-generic? ] [ inline-math-method ] }
         { [ dup method-body? ] [ inline-method-body ] }
         [ 2drop f ]
     } cond ;
+
+: do-inlining ( #call word -- ? )
+    #! Note the logic here: if there's a custom inlining hook,
+    #! it is permitted to return f, which means that we try the
+    #! normal inlining heuristic.
+    dup custom-inlining? [ 2dup inline-custom ] [ f ] if
+    [ 2drop t ] [ (do-inlining) ] if ;

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

@@ -5,7 +5,7 @@ math.partial-dispatch math.intervals math.parser math.order
 layouts words sequences sequences.private arrays assocs classes
 classes.algebra combinators generic.math splitting fry locals
 classes.tuple alien.accessors classes.tuple.private slots.private
-definitions
+definitions strings.private vectors hashtables
 stack-checker.state
 compiler.tree.comparisons
 compiler.tree.propagation.info
@@ -37,31 +37,6 @@ most-negative-fixnum most-positive-fixnum [a,b]
 
 \ bitnot { integer } "input-classes" set-word-prop
 
-{
-    fcosh
-    flog
-    fsinh
-    fexp
-    fasin
-    facosh
-    fasinh
-    ftanh
-    fatanh
-    facos
-    fpow
-    fatan
-    fatan2
-    fcos
-    ftan
-    fsin
-    fsqrt
-} [
-    dup stack-effect
-    [ in>> length real <repetition> "input-classes" set-word-prop ]
-    [ out>> length float <repetition> "default-output-classes" set-word-prop ]
-    2bi
-] each
-
 : ?change-interval ( info quot -- quot' )
     over interval>> [ [ clone ] dip change-interval ] [ 2drop ] if ; inline
 
@@ -169,10 +144,9 @@ most-negative-fixnum most-positive-fixnum [a,b]
 comparison-ops
 [ dup '[ _ define-comparison-constraints ] each-derived-op ] each
 
-generic-comparison-ops [
+! generic-comparison-ops [
-    dup specific-comparison
+!     dup specific-comparison define-comparison-constraints
-    '[ _ _ define-comparison-constraints ] each-derived-op
+! ] each
-] each
 
 ! Remove redundant comparisons
 : fold-comparison ( info1 info2 word -- info )
@@ -220,10 +194,22 @@ generic-comparison-ops [
     2bi and maybe-or-never
 ] "outputs" set-word-prop
 
+\ both-fixnums? [
+    [ class>> fixnum classes-intersect? not ] either?
+    f <literal-info> object-info ?
+] "outputs" set-word-prop
+
 {
     { >fixnum fixnum }
+    { bignum>fixnum fixnum }
+
     { >bignum bignum }
+    { fixnum>bignum bignum }
+    { float>bignum bignum }
+
     { >float float }
+    { fixnum>float float }
+    { bignum>float float }
 } [
     '[
         _
@@ -261,6 +247,10 @@ generic-comparison-ops [
     ] "custom-inlining" set-word-prop
 ] each
 
+\ string-nth [
+    2drop fixnum 0 23 2^ [a,b] <class/interval-info>
+] "outputs" set-word-prop
+
 {
     alien-signed-1
     alien-unsigned-1
@@ -302,6 +292,15 @@ generic-comparison-ops [
     "outputs" set-word-prop
 ] each
 
+! Generate more efficient code for common idiom
+\ clone [
+    in-d>> first value-info literal>> {
+        { V{ } [ [ drop { } 0 vector boa ] ] }
+        { H{ } [ [ drop hashtable new ] ] }
+        [ drop f ]
+    } case
+] "custom-inlining" set-word-prop
+
 \ slot [
     dup literal?>>
     [ literal>> swap value-info-slot ] [ 2drop object-info ] if

basis/compiler/tree/propagation/nodes/nodes.factor

@@ -6,6 +6,8 @@ compiler.tree.propagation.copy
 compiler.tree.propagation.info ;
 IN: compiler.tree.propagation.nodes
 
+SYMBOL: loop-nesting
+
 GENERIC: propagate-before ( node -- )
 
 GENERIC: propagate-after ( node -- )

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

@@ -8,7 +8,8 @@ math.functions math.private strings layouts
 compiler.tree.propagation.info compiler.tree.def-use
 compiler.tree.debugger compiler.tree.checker
 slots.private words hashtables classes assocs locals
-float-arrays system sorting ;
+specialized-arrays.double system sorting math.libm
+math.intervals ;
 IN: compiler.tree.propagation.tests
 
 \ propagate must-infer
@@ -167,7 +168,8 @@ IN: compiler.tree.propagation.tests
 
 [ V{ fixnum } ] [
     [
-        [ uchar-nth ] 2keep [ uchar-nth ] 2keep uchar-nth
+        { fixnum byte-array } declare
+        [ nth-unsafe ] 2keep [ nth-unsafe ] 2keep nth-unsafe
         >r >r 298 * r> 100 * - r> 208 * - 128 + -8 shift
         255 min 0 max
     ] final-classes
@@ -434,7 +436,7 @@ TUPLE: mixed-mutable-immutable { x integer } { y sequence read-only } ;
 ] unit-test
 
 : recursive-test-4 ( i n -- )
-    2dup < [ >r 1+ r> recursive-test-4 ] [ 2drop ] if ; inline recursive
+    2dup < [ [ 1+ ] dip recursive-test-4 ] [ 2drop ] if ; inline recursive
 
 [ ] [ [ recursive-test-4 ] final-info drop ] unit-test
 
@@ -588,12 +590,20 @@ MIXIN: empty-mixin
     [ { fixnum integer } declare bitand ] final-classes
 ] unit-test
 
-[ V{ float-array } ] [ [| | F{ } ] final-classes ] unit-test
+[ V{ double-array } ] [ [| | double-array{ } ] final-classes ] unit-test
 
 [ V{ t } ] [ [ netbsd unix? ] final-literals ] unit-test
 
 [ V{ array } ] [ [ [ <=> ] sort [ <=> ] sort ] final-classes ] unit-test
 
+[ V{ float } ] [ [ fsqrt ] final-classes ] unit-test
+
+[ V{ t } ] [ [ { fixnum } declare 10 mod >float -20 > ] final-literals ] unit-test
+
+[ T{ interval f { 0 t } { 127 t } } ] [
+    [ { integer } declare 127 bitand ] final-info first interval>>
+] unit-test
+
 ! [ V{ string } ] [
 !     [ dup string? t xor [ "A" throw ] [ ] if ] final-classes
 ! ] unit-test

basis/compiler/tree/propagation/propagation.factor

@@ -19,5 +19,6 @@ IN: compiler.tree.propagation
     H{ } clone copies set
     H{ } clone 1array value-infos set
     H{ } clone 1array constraints set
+    H{ } clone inlining-count set
     dup count-nodes
     dup (propagate) ;

basis/compiler/tree/propagation/recursive/recursive.factor

@@ -55,6 +55,8 @@ IN: compiler.tree.propagation.recursive
 M: #recursive propagate-around ( #recursive -- )
     constraints [ H{ } clone suffix ] change
     [
+        loop-nesting inc
+
         constraints [ but-last H{ } clone suffix ] change
 
         child>>
@@ -62,6 +64,8 @@ M: #recursive propagate-around ( #recursive -- )
         [ first propagate-recursive-phi ]
         [ (propagate) ]
         tri
+
+        loop-nesting dec
     ] until-fixed-point ;
 
 : recursive-phi-infos ( node -- infos )

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

@@ -2,7 +2,7 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: fry accessors kernel sequences sequences.private assocs words
 namespaces classes.algebra combinators classes classes.tuple
-classes.tuple.private continuations arrays
+classes.tuple.private continuations arrays alien.c-types
 math math.private slots generic definitions
 stack-checker.state
 compiler.tree
@@ -137,11 +137,12 @@ M: #call propagate-after
     dup word>> "input-classes" word-prop dup
     [ propagate-input-classes ] [ 2drop ] if ;
 
-M: #alien-invoke propagate-before
+: propagate-alien-invoke ( node -- )
-    out-d>> [ object-info swap set-value-info ] each ;
+    [ out-d>> ] [ params>> return>> ] bi
+    [ drop ] [ c-type-class <class-info> swap first set-value-info ] if-void ;
 
-M: #alien-indirect propagate-before
+M: #alien-invoke propagate-before propagate-alien-invoke ;
-    out-d>> [ object-info swap set-value-info ] each ;
 
-M: #return annotate-node
+M: #alien-indirect propagate-before propagate-alien-invoke ;
-    dup in-d>> (annotate-node) ;
+
+M: #return annotate-node dup in-d>> (annotate-node) ;

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

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

basis/compiler/utilities/utilities.factor

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

basis/concurrency/conditions/conditions.factor

@@ -1,6 +1,6 @@
 ! Copyright (C) 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: deques threads kernel arrays sequences alarms ;
+USING: deques threads kernel arrays sequences alarms fry ;
 IN: concurrency.conditions
 
 : notify-1 ( deque -- )
@@ -12,15 +12,18 @@ IN: concurrency.conditions
 : queue-timeout ( queue timeout -- alarm )
     #! Add an alarm which removes the current thread from the
     #! queue, and resumes it, passing it a value of t.
-    >r [ self swap push-front* ] keep [
+    [
-        [ delete-node ] [ drop node-value ] 2bi
+        [ self swap push-front* ] keep '[
-        t swap resume-with
+            _ _
-    ] 2curry r> later ;
+            [ delete-node ] [ drop node-value ] 2bi
+            t swap resume-with
+        ]
+    ] dip later ;
 
 : wait ( queue timeout status -- )
     over [
-        >r queue-timeout [ drop ] r> suspend
+        [ queue-timeout [ drop ] ] dip suspend
         [ "Timeout" throw ] [ cancel-alarm ] if
     ] [
-        >r drop [ push-front ] curry r> suspend drop
+        [ drop '[ _ push-front ] ] dip suspend drop
     ] if ;

basis/concurrency/count-downs/count-downs.factor

@@ -1,7 +1,7 @@
 ! Copyright (C) 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: dlists kernel math concurrency.promises
-concurrency.mailboxes debugger accessors ;
+concurrency.mailboxes debugger accessors fry ;
 IN: concurrency.count-downs
 
 ! http://java.sun.com/j2se/1.5.0/docs/api/java/util/concurrent/CountDownLatch.html
@@ -26,12 +26,12 @@ ERROR: count-down-already-done ;
     [ 1- >>n count-down-check ] if ;
 
 : await-timeout ( count-down timeout -- )
-    >r promise>> r> ?promise-timeout ?linked t assert= ;
+    [ promise>> ] dip ?promise-timeout ?linked t assert= ;
 
 : await ( count-down -- )
     f await-timeout ;
 
 : spawn-stage ( quot count-down -- )
-    [ [ count-down ] curry compose ] keep
+    [ '[ @ _ count-down ] ] keep
     "Count down stage"
     swap promise>> mailbox>> spawn-linked-to drop ;

basis/concurrency/distributed/distributed-tests.factor

@@ -15,7 +15,7 @@ concurrency.messaging continuations accessors prettyprint ;
 
 [ ] [
     [
-        receive first2 >r 3 + r> send
+        receive first2 [ 3 + ] dip send
         "thread-a" unregister-process
     ] "Thread A" spawn
     "thread-a" swap register-process

basis/concurrency/exchangers/exchangers.factor

@@ -1,6 +1,6 @@
 ! Copyright (C) 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: kernel threads boxes accessors ;
+USING: kernel threads boxes accessors fry ;
 IN: concurrency.exchangers
 
 ! Motivated by
@@ -14,8 +14,8 @@ TUPLE: exchanger thread object ;
 : exchange ( obj exchanger -- newobj )
     dup thread>> occupied>> [
         dup object>> box>
-        >r thread>> box> resume-with r>
+        [ thread>> box> resume-with ] dip
     ] [
         [ object>> >box ] keep
-        [ thread>> >box ] curry "exchange" suspend
+        '[ _ thread>> >box ] "exchange" suspend
     ] if ;

basis/concurrency/flags/flags-tests.factor

@@ -2,7 +2,7 @@ IN: concurrency.flags.tests
 USING: tools.test concurrency.flags concurrency.combinators
 kernel threads locals accessors calendar ;
 
-:: flag-test-1 ( -- )
+:: flag-test-1 ( -- val )
     [let | f [ <flag> ] |
         [ f raise-flag ] "Flag test" spawn drop
         f lower-flag
@@ -20,7 +20,7 @@ kernel threads locals accessors calendar ;
 
 [ f ] [ flag-test-2 ] unit-test
 
-:: flag-test-3 ( -- )
+:: flag-test-3 ( -- val )
     [let | f [ <flag> ] |
         f raise-flag
         f value>>
@@ -28,7 +28,7 @@ kernel threads locals accessors calendar ;
 
 [ t ] [ flag-test-3 ] unit-test
 
-:: flag-test-4 ( -- )
+:: flag-test-4 ( -- val )
     [let | f [ <flag> ] |
         [ f raise-flag ] "Flag test" spawn drop
         f wait-for-flag
@@ -37,7 +37,7 @@ kernel threads locals accessors calendar ;
 
 [ t ] [ flag-test-4 ] unit-test
 
-:: flag-test-5 ( -- )
+:: flag-test-5 ( -- val )
     [let | f [ <flag> ] |
         [ 1 seconds sleep f raise-flag ] "Flag test" spawn drop
         f wait-for-flag

basis/concurrency/flags/flags.factor

@@ -11,7 +11,7 @@ TUPLE: flag value threads ;
     dup value>> [ drop ] [ t >>value threads>> notify-all ] if ;
 
 : wait-for-flag-timeout ( flag timeout -- )
-    over value>> [ 2drop ] [ >r threads>> r> "flag" wait ] if ;
+    over value>> [ 2drop ] [ [ threads>> ] dip "flag" wait ] if ;
 
 : wait-for-flag ( flag -- )
     f wait-for-flag-timeout ;

basis/concurrency/futures/futures.factor

@@ -1,12 +1,12 @@
 ! Copyright (C) 2005, 2008 Chris Double, Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: concurrency.promises concurrency.mailboxes kernel arrays
-continuations accessors ;
+continuations accessors fry ;
 IN: concurrency.futures
 
 : future ( quot -- future )
     <promise> [
-        [ [ >r call r> fulfill ] 2curry "Future" ] keep
+        [ '[ @ _ fulfill ] "Future" ] keep
         mailbox>> spawn-linked-to drop
     ] keep ; inline
 

basis/concurrency/locks/locks-tests.factor

@@ -3,7 +3,7 @@ USING: tools.test concurrency.locks concurrency.count-downs
 concurrency.messaging concurrency.mailboxes locals kernel
 threads sequences calendar accessors ;
 
-:: lock-test-0 ( -- )
+:: lock-test-0 ( -- v )
     [let | v [ V{ } clone ]
            c [ 2 <count-down> ] |
 
@@ -27,7 +27,7 @@ threads sequences calendar accessors ;
            v
     ] ;
 
-:: lock-test-1 ( -- )
+:: lock-test-1 ( -- v )
     [let | v [ V{ } clone ]
            l [ <lock> ]
            c [ 2 <count-down> ] |
@@ -79,7 +79,7 @@ threads sequences calendar accessors ;
 
 [ ] [ <rw-lock> dup [ [ ] with-read-lock ] with-write-lock ] unit-test
 
-:: rw-lock-test-1 ( -- )
+:: rw-lock-test-1 ( -- v )
     [let | l [ <rw-lock> ]
            c [ 1 <count-down> ]
            c' [ 1 <count-down> ]
@@ -129,7 +129,7 @@ threads sequences calendar accessors ;
 
 [ V{ 1 2 3 4 5 6 } ] [ rw-lock-test-1 ] unit-test
 
-:: rw-lock-test-2 ( -- )
+:: rw-lock-test-2 ( -- v )
     [let | l [ <rw-lock> ]
            c [ 1 <count-down> ]
            c' [ 2 <count-down> ]
@@ -160,7 +160,7 @@ threads sequences calendar accessors ;
 [ V{ 1 2 3 } ] [ rw-lock-test-2 ] unit-test
 
 ! Test lock timeouts
-:: lock-timeout-test ( -- )
+:: lock-timeout-test ( -- v )
     [let | l [ <lock> ] |
         [
             l [ 1 seconds sleep ] with-lock
@@ -177,19 +177,6 @@ threads sequences calendar accessors ;
     thread>> name>> "Lock timeout-er" =
 ] must-fail-with
 
-:: read/write-test ( -- )
-    [let | l [ <lock> ] |
-        [
-            l [ 1 seconds sleep ] with-lock
-        ] "Lock holder" spawn drop
-
-        [
-            l 1/10 seconds [ ] with-lock-timeout
-        ] "Lock timeout-er" spawn-linked drop
-
-        receive
-    ] ;
-
 [
     <rw-lock> dup [
         1 seconds [ ] with-write-lock-timeout

basis/concurrency/locks/locks.factor

@@ -1,7 +1,8 @@
 ! Copyright (C) 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: deques dlists kernel threads continuations math
-concurrency.conditions combinators.short-circuit accessors ;
+concurrency.conditions combinators.short-circuit accessors
+locals ;
 IN: concurrency.locks
 
 ! Simple critical sections
@@ -17,16 +18,16 @@ TUPLE: lock threads owner reentrant? ;
 
 : acquire-lock ( lock timeout -- )
     over owner>>
-    [ 2dup >r threads>> r> "lock" wait ] when drop
+    [ 2dup [ threads>> ] dip "lock" wait ] when drop
     self >>owner drop ;
 
 : release-lock ( lock -- )
     f >>owner
     threads>> notify-1 ;
 
-: do-lock ( lock timeout quot acquire release -- )
+:: do-lock ( lock timeout quot acquire release -- )
-    >r >r pick rot r> call ! use up  timeout acquire
+    lock timeout acquire call
-    swap r> curry [ ] cleanup ; inline
+    quot lock release curry [ ] cleanup ; inline
 
 : (with-lock) ( lock timeout quot -- )
     [ acquire-lock ] [ release-lock ] do-lock ; inline
@@ -60,7 +61,7 @@ TUPLE: rw-lock readers writers reader# writer ;
 
 : acquire-read-lock ( lock timeout -- )
     over writer>>
-    [ 2dup >r readers>> r> "read lock" wait ] when drop
+    [ 2dup [ readers>> ] dip "read lock" wait ] when drop
     add-reader ;
 
 : notify-writer ( lock -- )
@@ -75,7 +76,7 @@ TUPLE: rw-lock readers writers reader# writer ;
 
 : acquire-write-lock ( lock timeout -- )
     over writer>> pick reader#>> 0 > or
-    [ 2dup >r writers>> r> "write lock" wait ] when drop
+    [ 2dup [ writers>> ] dip "write lock" wait ] when drop
     self >>writer drop ;
 
 : release-write-lock ( lock -- )