Merge branch 'master' into experimental

Makefile

@@ -3,7 +3,7 @@ AR = ar
 LD = ld
 
 EXECUTABLE = factor
-VERSION = 0.91
+VERSION = 0.92
 
 IMAGE = factor.image
 BUNDLE = Factor.app

README.txt

@@ -146,12 +146,13 @@ usage documentation, enter the following in the UI listener:
 The Factor source tree is organized as follows:
 
   build-support/ - scripts used for compiling Factor
-  core/ - Factor core library and compiler
-  extra/ - more libraries
+  vm/ - sources for the Factor VM, written in C
+  core/ - Factor core library
+  basis/ - Factor basis library, compiler, tools
+  extra/ - more libraries and applications
   fonts/ - TrueType fonts used by UI
   misc/ - editor modes, icons, etc
   unmaintained/ - unmaintained contributions, please help!
-  vm/ - sources for the Factor VM, written in C
 
 * Community
 

basis/alarms/alarms-docs.factor

@@ -9,13 +9,19 @@ HELP: add-alarm
 { $description "Creates and registers an alarm. If " { $snippet "frequency" } " is " { $link f } ", this will be a one-time alarm, otherwise it will fire with the given frequency. The quotation will be called from the alarm thread." } ;
 
 HELP: later
-{ $values { "quot" quotation } { "dt" duration } { "alarm" alarm } }
-{ $description "Creates and registers an alarm which calls the quotation once at " { $snippet "time" } { $link from-now } "." } ;
+{ $values { "quot" quotation } { "duration" duration } { "alarm" alarm } }
+{ $description "Creates and registers an alarm which calls the quotation once at " { $snippet "time" } " from now." } ;
 
 HELP: cancel-alarm
 { $values { "alarm" alarm } }
 { $description "Cancels an alarm. Does nothing if the alarm is not active." } ;
 
+HELP: every
+{ $values
+     { "quot" quotation } { "duration" duration }
+     { "alarm" alarm } }
+{ $description "Creates and registers an alarm which calls the quotation repeatedly, using " { $snippet "dt" } " as the frequency." } ;
+
 ARTICLE: "alarms" "Alarms"
 "Alarms provide a lightweight way to schedule one-time and recurring tasks without spawning a new thread."
 { $subsection alarm }

basis/alarms/alarms.factor

@@ -1,11 +1,15 @@
 ! Copyright (C) 2005, 2008 Slava Pestov, Doug Coleman.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: arrays calendar combinators generic init kernel math
-namespaces sequences heaps boxes threads debugger quotations
-assocs math.order ;
+USING: accessors arrays calendar combinators generic init
+kernel math namespaces sequences heaps boxes threads debugger
+quotations assocs math.order ;
 IN: alarms
 
-TUPLE: alarm quot time interval entry ;
+TUPLE: alarm
+    { quot callable initial: [ ] }
+    { time timestamp }
+    interval
+    { entry box } ;
 
 <PRIVATE
 
@@ -15,31 +19,28 @@ SYMBOL: alarm-thread
 : notify-alarm-thread ( -- )
     alarm-thread get-global interrupt ;
 
-: check-alarm
-    dup duration? over not or [ "Not a duration" throw ] unless
-    over timestamp? [ "Not a timestamp" throw ] unless
-    pick callable? [ "Not a quotation" throw ] unless ; inline
+ERROR: bad-alarm-frequency frequency ;
+: check-alarm ( frequency/f -- frequency/f )
+    dup [ duration? ] [ not ] bi or [ bad-alarm-frequency ] unless ;
 
 : <alarm> ( quot time frequency -- alarm )
     check-alarm <box> alarm boa ;
 
 : register-alarm ( alarm -- )
-    dup dup alarm-time alarms get-global heap-push*
-    swap alarm-entry >box
+    dup dup time>> alarms get-global heap-push*
+    swap entry>> >box
     notify-alarm-thread ;
 
 : alarm-expired? ( alarm now -- ? )
-    >r alarm-time r> before=? ;
+    [ time>> ] dip before=? ;
 
 : reschedule-alarm ( alarm -- )
-    dup alarm-time over alarm-interval time+
-    over set-alarm-time
-    register-alarm ;
+    dup [ swap interval>> time+ ] change-time register-alarm ;
 
 : call-alarm ( alarm -- )
-    dup alarm-entry box> drop
-    dup alarm-quot "Alarm execution" spawn drop
-    dup alarm-interval [ reschedule-alarm ] [ drop ] if ;
+    [ entry>> box> drop ]
+    [ quot>> "Alarm execution" spawn drop ]
+    [ dup interval>> [ reschedule-alarm ] [ drop ] if ] tri ;
 
 : (trigger-alarms) ( alarms now -- )
     over heap-empty? [
@@ -57,7 +58,7 @@ SYMBOL: alarm-thread
 
 : next-alarm ( alarms -- timestamp/f )
     dup heap-empty?
-    [ drop f ] [ heap-peek drop alarm-time ] if ;
+    [ drop f ] [ heap-peek drop time>> ] if ;
 
 : alarm-thread-loop ( -- )
     alarms get-global
@@ -66,7 +67,7 @@ SYMBOL: alarm-thread
 
 : cancel-alarms ( alarms -- )
     [
-        heap-pop-all [ nip alarm-entry box> drop ] assoc-each
+        heap-pop-all [ nip entry>> box> drop ] assoc-each
     ] when* ;
 
 : init-alarms ( -- )
@@ -81,11 +82,11 @@ PRIVATE>
 : add-alarm ( quot time frequency -- alarm )
     <alarm> [ register-alarm ] keep ;
 
-: later ( quot dt -- alarm )
-    from-now f add-alarm ;
+: later ( quot duration -- alarm )
+    hence f add-alarm ;
 
-: every ( quot dt -- alarm )
-    [ from-now ] keep add-alarm ;
+: every ( quot duration -- alarm )
+    [ hence ] keep add-alarm ;
 
 : cancel-alarm ( alarm -- )
-    alarm-entry [ alarms get-global heap-delete ] if-box? ;
+    entry>> [ alarms get-global heap-delete ] if-box? ;

basis/alias/alias-docs.factor

@@ -0,0 +1,17 @@
+USING: kernel words help.markup help.syntax ;
+IN: alias
+
+HELP: ALIAS:
+{ $syntax "ALIAS: new-word existing-word" }
+{ $values { "new-word" word } { "existing-word" word } }
+{ $description "Creates a " { $snippet "new" } " inlined word that calls the " { $snippet "existing" } " word." }
+{ $examples
+    { $example "USING: alias prettyprint sequences ;"
+               "IN: alias.test"
+               "ALIAS: sequence-nth nth"
+               "0 { 10 20 30 } sequence-nth ."
+               "10"
+    }
+} ;
+
+

basis/alias/alias.factor

@@ -0,0 +1,18 @@
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors words quotations kernel effects sequences parser ;
+IN: alias
+
+PREDICATE: alias < word "alias" word-prop ;
+
+M: alias reset-word
+    [ call-next-method ] [ f "alias" set-word-prop ] bi ;
+
+M: alias stack-effect
+    def>> first stack-effect ;
+
+: define-alias ( new old -- )
+    [ 1quotation define-inline ]
+    [ drop t "alias" set-word-prop ] 2bi ;
+
+: ALIAS: CREATE-WORD scan-word define-alias ; parsing

basis/alien/arrays/arrays.factor

@@ -10,7 +10,7 @@ M: array c-type ;
 
 M: array heap-size unclip heap-size [ * ] reduce ;
 
-M: array c-type-align first c-type c-type-align ;
+M: array c-type-align first c-type-align ;
 
 M: array c-type-stack-align? drop f ;
 

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

@@ -1,7 +1,7 @@
 IN: alien.c-types
 USING: alien help.syntax help.markup libc kernel.private
 byte-arrays math strings hashtables alien.syntax
-bit-arrays float-arrays debugger destructors ;
+debugger destructors ;
 
 HELP: <c-type>
 { $values { "type" hashtable } }
@@ -200,7 +200,7 @@ $nl
 "Structure and union types are specified by the name of the structure or union." ;
 
 ARTICLE: "c-byte-arrays" "Passing data in byte arrays"
-"Instances of the " { $link byte-array } ", " { $link bit-array } " and " { $link float-array } " class can be passed to C functions; the C function receives a pointer to the first element of the array."
+"Instances of the " { $link byte-array } " class can be passed to C functions; the C function receives a pointer to the first element of the array."
 $nl
 "Byte arrays can be allocated directly with a byte count using the " { $link <byte-array> } " word. However in most cases, instead of computing a size in bytes directly, it is easier to use a higher-level word which expects C type and outputs a byte array large enough to hold that type:"
 { $subsection <c-object> }
@@ -253,4 +253,4 @@ $nl
 "New C types can be defined:"
 { $subsection "c-structs" }
 { $subsection "c-unions" }
-{ $subsection "reading-writing-memory" } ;
+{ $see-also "aliens" } ;

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

@@ -2,6 +2,12 @@ IN: alien.c-types.tests
 USING: alien alien.syntax alien.c-types kernel tools.test
 sequences system libc alien.strings io.encodings.utf8 ;
 
+\ expand-constants must-infer
+
+: xyz 123 ;
+
+[ { "blah" 123 } ] [ { "blah" xyz } expand-constants ] unit-test
+
 : foo ( -- n ) "fdafd" f dlsym [ 123 ] unless* ;
 
 [ 123 ] [ foo ] unit-test
@@ -48,3 +54,5 @@ 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

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

@@ -1,11 +1,10 @@
 ! Copyright (C) 2004, 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: bit-arrays byte-arrays float-arrays arrays
-assocs kernel kernel.private libc math
+USING: byte-arrays arrays assocs kernel kernel.private libc math
 namespaces 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 ;
+accessors combinators effects continuations ;
 IN: alien.c-types
 
 DEFER: <int>
@@ -38,6 +37,7 @@ ERROR: no-c-type name ;
         dup string? [ (c-type) ] when
     ] when ;
 
+! C type protocol
 GENERIC: c-type ( name -- type ) foldable
 
 : resolve-pointer-type ( name -- name )
@@ -63,6 +63,60 @@ M: string c-type ( name -- type )
         ] ?if
     ] if ;
 
+GENERIC: c-type-boxer ( name -- boxer )
+
+M: c-type c-type-boxer boxer>> ;
+
+M: string c-type-boxer c-type c-type-boxer ;
+
+GENERIC: c-type-boxer-quot ( name -- quot )
+
+M: c-type c-type-boxer-quot boxer-quot>> ;
+
+M: string c-type-boxer-quot c-type c-type-boxer-quot ;
+
+GENERIC: c-type-unboxer ( name -- boxer )
+
+M: c-type c-type-unboxer unboxer>> ;
+
+M: string c-type-unboxer c-type c-type-unboxer ;
+
+GENERIC: c-type-unboxer-quot ( name -- quot )
+
+M: c-type c-type-unboxer-quot unboxer-quot>> ;
+
+M: string c-type-unboxer-quot c-type c-type-unboxer-quot ;
+
+GENERIC: c-type-reg-class ( name -- reg-class )
+
+M: c-type c-type-reg-class reg-class>> ;
+
+M: string c-type-reg-class c-type c-type-reg-class ;
+
+GENERIC: c-type-getter ( name -- quot )
+
+M: c-type c-type-getter getter>> ;
+
+M: string c-type-getter c-type c-type-getter ;
+
+GENERIC: c-type-setter ( name -- quot )
+
+M: c-type c-type-setter setter>> ;
+
+M: string c-type-setter c-type c-type-setter ;
+
+GENERIC: c-type-align ( name -- n )
+
+M: c-type c-type-align align>> ;
+
+M: string c-type-align c-type c-type-align ;
+
+GENERIC: c-type-stack-align? ( name -- ? )
+
+M: c-type c-type-stack-align? stack-align?>> ;
+
+M: string c-type-stack-align? c-type c-type-stack-align? ;
+
 : c-type-box ( n type -- )
     dup c-type-reg-class
     swap c-type-boxer [ "No boxer" throw ] unless*
@@ -73,10 +127,6 @@ M: string c-type ( name -- type )
     swap c-type-unboxer [ "No unboxer" throw ] unless*
     %unbox ;
 
-M: string c-type-align c-type c-type-align ;
-
-M: string c-type-stack-align? c-type c-type-stack-align? ;
-
 GENERIC: box-parameter ( n ctype -- )
 
 M: c-type box-parameter c-type-box ;
@@ -108,29 +158,25 @@ GENERIC: heap-size ( type -- size ) foldable
 
 M: string heap-size c-type heap-size ;
 
-M: c-type heap-size c-type-size ;
+M: c-type heap-size size>> ;
 
 GENERIC: stack-size ( type -- size ) foldable
 
 M: string stack-size c-type stack-size ;
 
-M: c-type stack-size c-type-size ;
+M: c-type stack-size size>> ;
 
 GENERIC: byte-length ( seq -- n ) flushable
 
-M: bit-array byte-length length 7 + -3 shift ;
-
 M: byte-array byte-length length ;
 
-M: float-array byte-length length "double" heap-size * ;
-
 : c-getter ( name -- quot )
-    c-type c-type-getter [
+    c-type-getter [
         [ "Cannot read struct fields with type" throw ]
     ] unless* ;
 
 : c-setter ( name -- quot )
-    c-type c-type-setter [
+    c-type-setter [
         [ "Cannot write struct fields with type" throw ]
     ] unless* ;
 
@@ -156,7 +202,9 @@ M: float-array byte-length length "double" heap-size * ;
     swap dup length memcpy ;
 
 : (define-nth) ( word type quot -- )
-    >r heap-size [ rot * ] swap prefix r> append define-inline ;
+    [
+        \ swap , [ heap-size , [ * >fixnum ] % ] [ % ] bi*
+    ] [ ] make define-inline ;
 
 : nth-word ( name vocab -- word )
     >r "-nth" append r> create ;
@@ -203,9 +251,9 @@ M: long-long-type box-return ( type -- )
 : c-bool> ( int -- ? )
     zero? not ;
 
-: >c-array ( seq type word -- )
-    >r >r dup length dup r> <c-array> dup -roll r>
-    [ execute ] 2curry 2each ; inline
+: >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 ;
@@ -214,7 +262,8 @@ M: long-long-type box-return ( type -- )
     >r ">c-" swap "-array" 3append r> create ;
 
 : define-to-array ( type vocab -- )
-    [ to-array-word ] 2keep >c-array-quot define ;
+    [ to-array-word ] 2keep >c-array-quot
+    (( array -- byte-array )) define-declared ;
 
 : c-array>quot ( type vocab -- quot )
     [
@@ -227,7 +276,8 @@ M: long-long-type box-return ( type -- )
     >r "c-" swap "-array>" 3append r> create ;
 
 : define-from-array ( type vocab -- )
-    [ from-array-word ] 2keep c-array>quot define ;
+    [ from-array-word ] 2keep c-array>quot
+    (( c-ptr n -- array )) define-declared ;
 
 : define-primitive-type ( type name -- )
     "alien.c-types"
@@ -240,16 +290,20 @@ M: long-long-type box-return ( type -- )
     } 2cleave ;
 
 : expand-constants ( c-type -- c-type' )
-    #! We use word-def call instead of execute to get around
-    #! staging violations
     dup array? [
-        unclip >r [ dup word? [ word-def call ] when ] map
-        r> prefix
+        unclip >r [
+            dup word? [
+                def>> { } swap with-datastack first
+            ] when
+        ] map r> prefix
     ] when ;
 
 : malloc-file-contents ( path -- alien len )
     binary file-contents dup malloc-byte-array swap length ;
 
+: if-void ( type true false -- )
+    pick "void" = [ drop nip call ] [ nip call ] if ; inline
+
 [
     <c-type>
         [ alien-cell ] >>getter
@@ -352,7 +406,7 @@ M: long-long-type box-return ( type -- )
 
     <c-type>
         [ alien-unsigned-4 zero? not ] >>getter
-        [ 1 0 ? set-alien-unsigned-4 ] >>setter
+        [ [ 1 0 ? ] 2dip set-alien-unsigned-4 ] >>setter
         4 >>size
         4 >>align
         "box_boolean" >>boxer
@@ -361,7 +415,7 @@ M: long-long-type box-return ( type -- )
 
     <c-type>
         [ alien-float ] >>getter
-        [ >r >r >float r> r> set-alien-float ] >>setter
+        [ [ >float ] 2dip set-alien-float ] >>setter
         4 >>size
         4 >>align
         "box_float" >>boxer
@@ -372,7 +426,7 @@ M: long-long-type box-return ( type -- )
 
     <c-type>
         [ alien-double ] >>getter
-        [ >r >r >float r> r> set-alien-double ] >>setter
+        [ [ >float ] 2dip set-alien-double ] >>setter
         8 >>size
         8 >>align
         "box_double" >>boxer

basis/alien/remote-control/remote-control.factor

@@ -1,21 +1,21 @@
 ! Copyright (C) 2007, 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: alien alien.c-types alien.strings parser threads words
-kernel.private kernel io.encodings.utf8 ;
+USING: accessors alien alien.c-types alien.strings parser
+threads words kernel.private kernel io.encodings.utf8 eval ;
 IN: alien.remote-control
 
-: eval-callback
+: eval-callback ( -- callback )
     "void*" { "char*" } "cdecl"
     [ eval>string utf8 malloc-string ] alien-callback ;
 
-: yield-callback
+: yield-callback ( -- callback )
     "void" { } "cdecl" [ yield ] alien-callback ;
 
-: sleep-callback
+: sleep-callback ( -- callback )
     "void" { "long" } "cdecl" [ sleep ] alien-callback ;
 
 : ?callback ( word -- alien )
-    dup compiled? [ execute ] [ drop f ] if ; inline
+    dup compiled>> [ execute ] [ drop f ] if ; inline
 
 : init-remote-control ( -- )
     \ eval-callback ?callback 16 setenv

basis/alien/strings/strings-docs.factor

@@ -1,5 +1,5 @@
 USING: help.markup help.syntax strings byte-arrays alien libc
-debugger ;
+debugger io.encodings.string sequences ;
 IN: alien.strings
 
 HELP: string>alien
@@ -38,7 +38,11 @@ HELP: utf16n
 ARTICLE: "c-strings" "C strings"
 "C string types are arrays with shape " { $snippet "{ \"char*\" encoding }" } ", where " { $snippet "encoding" } " is an encoding descriptor. The type " { $snippet "\"char*\"" } " is an alias for " { $snippet "{ \"char*\" utf8 }" } ". See " { $link "encodings-descriptors" } " for information about encoding descriptors."
 $nl
-"Passing a Factor string to a C function expecting a C string allocates a " { $link byte-array } " in the Factor heap; the string is then converted to the requested format and a raw pointer is passed to the function. If the conversion fails, for example if the string contains null bytes or characters with values higher than 255, a " { $link c-string-error. } " is thrown."
+"Passing a Factor string to a C function expecting a C string allocates a " { $link byte-array } " in the Factor heap; the string is then converted to the requested format and a raw pointer is passed to the function."
+$nl
+"If the conversion fails, for example if the string contains null bytes or characters with values higher than 255, a " { $link c-string-error. } " is thrown."
+$nl
+"Care must be taken if the C function expects a " { $snippet "char*" } " with a length in bytes, rather than a null-terminated " { $snippet "char*" } "; passing the result of calling " { $link length } " on the string object will not suffice. This is because a Factor string of " { $emphasis "n" } " characters will not necessarily encode to " { $emphasis "n" } " bytes. The correct idiom for C functions which take a string with a length is to first encode the string using " { $link encode } ", and then pass the resulting byte array together with the length of this byte array."
 $nl
 "Sometimes a C function has a parameter type of " { $snippet "void*" } ", and various data types, among them strings, can be passed in. In this case, strings are not automatically converted to aliens, and instead you must call one of these words:"
 { $subsection string>alien }

basis/alien/strings/strings.factor

@@ -100,7 +100,7 @@ M: utf16n <encoder> drop utf16n <encoder> ;
     os windows? [ utf16n ] [ utf8 ] if alien>string ;
 
 : dll-path ( dll -- string )
-    (dll-path) alien>native-string ;
+    path>> alien>native-string ;
 
 : string>symbol ( str -- alien )
     [ os wince? [ utf16n ] [ utf8 ] if string>alien ]

basis/alien/structs/fields/fields.factor

@@ -0,0 +1,76 @@
+! Copyright (C) 2005, 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors arrays kernel kernel.private math namespaces
+sequences strings words effects combinators alien.c-types ;
+IN: alien.structs.fields
+
+TUPLE: field-spec name offset type reader writer ;
+
+: reader-effect ( type spec -- effect )
+    [ 1array ] [ name>> 1array ] bi* <effect> ;
+
+PREDICATE: slot-reader < word "reading" word-prop >boolean ;
+
+: set-reader-props ( class spec -- )
+    2dup reader-effect
+    over reader>>
+    swap "declared-effect" set-word-prop
+    reader>> swap "reading" set-word-prop ;
+
+: writer-effect ( type spec -- effect )
+    name>> swap 2array 0 <effect> ;
+
+PREDICATE: slot-writer < word "writing" word-prop >boolean ;
+
+: set-writer-props ( class spec -- )
+    2dup writer-effect
+    over writer>>
+    swap "declared-effect" set-word-prop
+    writer>> swap "writing" set-word-prop ;
+
+: reader-word ( class name vocab -- word )
+    >r >r "-" r> 3append r> create ;
+
+: writer-word ( class name vocab -- word )
+    >r [ swap "set-" % % "-" % % ] "" make r> create ;
+
+: <field-spec> ( struct-name vocab type field-name -- spec )
+    field-spec new
+        0 >>offset
+        swap >>name
+        swap expand-constants >>type
+        3dup name>> swap reader-word >>reader
+        3dup name>> swap writer-word >>writer
+    2nip ;
+
+: align-offset ( offset type -- offset )
+    c-type-align align ;
+
+: struct-offsets ( specs -- size )
+    0 [
+        [ type>> align-offset ] keep
+        [ (>>offset) ] [ type>> heap-size + ] 2bi
+    ] reduce ;
+
+: define-struct-slot-word ( spec word quot -- )
+    rot 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 ;
+
+: define-setter ( type spec -- )
+    [ set-writer-props ] keep
+    [ ]
+    [ writer>> ]
+    [ type>> c-setter ] tri
+    define-struct-slot-word ;
+
+: define-field ( type spec -- )
+    [ define-getter ] [ define-setter ] 2bi ;

basis/alien/structs/structs-docs.factor

@@ -1,69 +1,7 @@
+USING: accessors alien.c-types strings help.markup help.syntax
+alien.syntax sequences io arrays kernel words assocs namespaces
+accessors ;
 IN: alien.structs
-USING: alien.c-types strings help.markup help.syntax
-alien.syntax sequences io arrays slots.deprecated
-kernel words slots assocs namespaces ;
-
-! Deprecated code
-: ($spec-reader-values) ( slot-spec class -- element )
-    dup ?word-name swap 2array
-    over slot-spec-name
-    rot slot-spec-type 2array 2array
-    [ { $instance } swap suffix ] assoc-map ;
-
-: $spec-reader-values ( slot-spec class -- )
-    ($spec-reader-values) $values ;
-
-: $spec-reader-description ( slot-spec class -- )
-    [
-        "Outputs the value stored in the " ,
-        { $snippet } rot slot-spec-name suffix ,
-        " slot of " ,
-        { $instance } swap suffix ,
-        " instance." ,
-    ] { } make $description ;
-
-: $spec-reader ( reader slot-specs class -- )
-    >r slot-of-reader r>
-    over [
-        2dup $spec-reader-values
-        2dup $spec-reader-description
-    ] when 2drop ;
-
-GENERIC: slot-specs ( help-type -- specs )
-
-M: word slot-specs "slots" word-prop ;
-
-: $slot-reader ( reader -- )
-    first dup "reading" word-prop [ slot-specs ] keep
-    $spec-reader ;
-
-: $spec-writer-values ( slot-spec class -- )
-    ($spec-reader-values) reverse $values ;
-
-: $spec-writer-description ( slot-spec class -- )
-    [
-        "Stores a new value to the " ,
-        { $snippet } rot slot-spec-name suffix ,
-        " slot of " ,
-        { $instance } swap suffix ,
-        " instance." ,
-    ] { } make $description ;
-
-: $spec-writer ( writer slot-specs class -- )
-    >r slot-of-writer r>
-    over [
-        2dup $spec-writer-values
-        2dup $spec-writer-description
-        dup ?word-name 1array $side-effects
-    ] when 2drop ;
-
-: $slot-writer ( reader -- )
-    first dup "writing" word-prop [ slot-specs ] keep
-    $spec-writer ;
-
-M: string slot-specs c-type struct-type-fields ;
-
-M: array ($instance) first ($instance) " array" write ;
 
 ARTICLE: "c-structs" "C structure types"
 "A " { $snippet "struct" } " in C is essentially a block of memory with the value of each structure field stored at a fixed offset from the start of the block. The C library interface provides some utilities to define words which read and write structure fields given a base address."

basis/alien/structs/structs-tests.factor

@@ -7,7 +7,7 @@ C-STRUCT: bar
     { { "int" 8 } "y" } ;
 
 [ 36 ] [ "bar" heap-size ] unit-test
-[ t ] [ \ <displaced-alien> "bar" c-type c-type-getter memq? ] unit-test
+[ t ] [ \ <displaced-alien> "bar" c-type-getter memq? ] unit-test
 
 C-STRUCT: align-test
     { "int" "x" }

basis/alien/structs/structs.factor

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

basis/alien/syntax/syntax-docs.factor

@@ -11,7 +11,7 @@ HELP: ALIEN:
 { $syntax "ALIEN: address" }
 { $values { "address" "a non-negative integer" } }
 { $description "Creates an alien object at parse time." }
-{ $notes "Alien objects are invalidated between image saves and loads." } ;
+{ $notes "Alien objects are invalidated between image saves and loads, and hence source files should not contain alien literals; this word is for interactive use only. See " { $link "alien-expiry" } " for details." } ;
 
 ARTICLE: "syntax-aliens" "Alien object literal syntax"
 { $subsection POSTPONE: ALIEN: }

basis/alien/syntax/syntax.factor

@@ -1,9 +1,10 @@
 ! Copyright (C) 2005, 2008 Slava Pestov, Alex Chapman.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: arrays alien alien.c-types alien.structs alien.arrays
-alien.strings kernel math namespaces parser sequences words
-quotations math.parser splitting effects prettyprint
-prettyprint.sections prettyprint.backend assocs combinators ;
+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 ;
 IN: alien.syntax
 
 <PRIVATE
@@ -36,6 +37,8 @@ PRIVATE>
 
 : ALIEN: scan string>number <alien> parsed ; parsing
 
+: BAD-ALIEN <bad-alien> parsed ; parsing
+
 : LIBRARY: scan "c-library" set ; parsing
 
 : FUNCTION:
@@ -66,7 +69,7 @@ PRIVATE>
 
 M: alien pprint*
     {
-        { [ dup expired? ] [ drop "( alien expired )" text ] }
+        { [ dup expired? ] [ drop \ BAD-ALIEN pprint-word ] }
         { [ dup pinned-c-ptr? not ] [ drop "( displaced alien )" text ] }
         [ \ ALIEN: [ alien-address pprint* ] pprint-prefix ]
     } cond ;

basis/ascii/ascii.factor

@@ -1,6 +1,7 @@
 ! Copyright (C) 2005, 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: kernel math math.order sequences ;
+USING: kernel math math.order sequences
+combinators.short-circuit ;
 IN: ascii
 
 : blank? ( ch -- ? ) " \t\n\r" member? ; inline
@@ -20,7 +21,7 @@ IN: ascii
     dup printable? [ "\"\\" member? not ] [ drop f ] if ; inline
 
 : Letter? ( ch -- ? )
-    dup letter? [ drop t ] [ LETTER? ] if ; inline
+    [ [ letter? ] [ LETTER? ] ] 1|| ;
 
 : alpha? ( ch -- ? )
-    dup Letter? [ drop t ] [ digit? ] if ; inline
+    [ [ Letter? ] [ digit? ] ] 1|| ;

basis/base64/base64-tests.factor

@@ -0,0 +1,19 @@
+USING: kernel tools.test base64 strings ;
+IN: base64.tests
+
+[ "abcdefghijklmnopqrstuvwxyz" ] [ "abcdefghijklmnopqrstuvwxyz" >base64 base64> >string
+] unit-test
+[ "" ] [ "" >base64 base64> >string ] unit-test
+[ "a" ] [ "a" >base64 base64> >string ] unit-test
+[ "ab" ] [ "ab" >base64 base64> >string ] unit-test
+[ "abc" ] [ "abc" >base64 base64> >string ] unit-test
+
+! From http://en.wikipedia.org/wiki/Base64
+[ "TWFuIGlzIGRpc3Rpbmd1aXNoZWQsIG5vdCBvbmx5IGJ5IGhpcyByZWFzb24sIGJ1dCBieSB0aGlzIHNpbmd1bGFyIHBhc3Npb24gZnJvbSBvdGhlciBhbmltYWxzLCB3aGljaCBpcyBhIGx1c3Qgb2YgdGhlIG1pbmQsIHRoYXQgYnkgYSBwZXJzZXZlcmFuY2Ugb2YgZGVsaWdodCBpbiB0aGUgY29udGludWVkIGFuZCBpbmRlZmF0aWdhYmxlIGdlbmVyYXRpb24gb2Yga25vd2xlZGdlLCBleGNlZWRzIHRoZSBzaG9ydCB2ZWhlbWVuY2Ugb2YgYW55IGNhcm5hbCBwbGVhc3VyZS4=" ]
+[
+    "Man is distinguished, not only by his reason, but by this singular passion from other animals, which is a lust of the mind, that by a perseverance of delight in the continued and indefatigable generation of knowledge, exceeds the short vehemence of any carnal pleasure."
+    >base64 >string
+] unit-test
+
+\ >base64 must-infer
+\ base64> must-infer

basis/base64/base64.factor

@@ -1,11 +1,12 @@
-USING: kernel math sequences namespaces io.binary splitting
- strings hashtables ;
+! Copyright (C) 2008 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel math sequences io.binary splitting grouping ;
 IN: base64
 
 <PRIVATE
 
 : count-end ( seq quot -- count )
-    >r [ length ] keep r> find-last drop dup [ - 1- ] [ 2drop 0 ] if ;
+    >r [ length ] keep r> find-last drop dup [ - 1- ] [ 2drop 0 ] if ; inline
 
 : ch>base64 ( ch -- ch )
     "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/" nth ;
@@ -20,28 +21,26 @@ IN: base64
     } nth ;
 
 : encode3 ( seq -- seq )
-    be> 4 [ 3 swap - -6 * shift HEX: 3f bitand ch>base64 ] with map ;
+    be> 4 <reversed> [ -6 * shift HEX: 3f bitand ch>base64 ] with B{ } map-as ;
 
 : decode4 ( str -- str )
-    [ base64>ch ] map 0 [ swap 6 shift bitor ] reduce 3 >be ;
+    0 [ base64>ch swap 6 shift bitor ] reduce 3 >be ;
 
 : >base64-rem ( str -- str )
-    [ 3 0 pad-right encode3 ] keep length 1+ head 4 CHAR: = pad-right ;
+    [ 3 0 pad-right encode3 ] [ length 1+ ] bi head 4 CHAR: = pad-right ;
 
 PRIVATE>
 
 : >base64 ( seq -- base64 )
     #! cut string into two pieces, convert 3 bytes at a time
     #! pad string with = when not enough bits
-    dup length dup 3 mod - cut swap
-    [
-        3 <groups> [ encode3 % ] each
-        dup empty? [ drop ] [ >base64-rem % ] if
-    ] "" make ;
+    dup length dup 3 mod - cut
+    [ 3 <groups> [ encode3 ] map concat ]
+    [ [ "" ] [ >base64-rem ] if-empty ]
+    bi* append ;
 
 : base64> ( base64 -- str )
     #! input length must be a multiple of 4
-    [
-        [ 4 <groups> [ decode4 % ] each ] keep [ CHAR: = = not ] count-end 
-    ] SBUF" " make swap [ dup pop* ] times >string ;
-
+    [ 4 <groups> [ decode4 ] map concat ]
+    [ [ CHAR: = = not ] count-end ]
+    bi head* ;

basis/biassocs/biassocs-docs.factor

@@ -0,0 +1,28 @@
+IN: biassocs
+USING: help.markup help.syntax assocs kernel ;
+
+HELP: biassoc
+{ $class-description "The class of bidirectional assocs. Bidirectional assoc are implemented by combining two assocs, with one the transpose of the other." } ;
+
+HELP: <biassoc>
+{ $values { "exemplar" assoc } { "biassoc" biassoc } }
+{ $description "Creates a new biassoc using a new assoc of the same type as " { $snippet "exemplar" } " for underlying storage." } ;
+
+HELP: <bihash>
+{ $values { "biassoc" biassoc } }
+{ $description "Creates a new biassoc using a pair of hashtables for underlying storage." } ;
+
+HELP: once-at
+{ $values { "value" object } { "key" object } { "assoc" assoc } }
+{ $description "If the assoc does not contain the given key, adds the key/value pair to the assoc, otherwise does nothing." } ;
+
+ARTICLE: "biassocs" "Bidirectional assocs"
+"A " { $emphasis "bidirectional assoc" } " combines a pair of assocs to form a data structure where both normal assoc opeartions (eg, " { $link at } "), as well as " { $link "assocs-values" } " (eg, " { $link value-at } ") run in sub-linear time."
+$nl
+"Bidirectional assocs implement the entire assoc protocol with the exception of " { $link delete-at } ". Duplicate values are allowed, however value lookups with " { $link value-at } " only return the first key that a given value was stored with."
+{ $subsection biassoc }
+{ $subsection biassoc? }
+{ $subsection <biassoc> }
+{ $subsection <bihash> } ;
+
+ABOUT: "biassocs"

basis/biassocs/biassocs-tests.factor

@@ -0,0 +1,22 @@
+IN: biassocs.tests
+USING: biassocs assocs namespaces tools.test ;
+
+<bihash> "h" set
+
+[ 0 ] [ "h" get assoc-size ] unit-test
+
+[ ] [ 1 2 "h" get set-at ] unit-test
+
+[ 1 ] [ 2 "h" get at ] unit-test
+
+[ 2 ] [ 1 "h" get value-at ] unit-test
+
+[ 1 ] [ "h" get assoc-size ] unit-test
+
+[ ] [ 1 3 "h" get set-at ] unit-test
+
+[ 1 ] [ 3 "h" get at ] unit-test
+
+[ 2 ] [ 1 "h" get value-at ] unit-test
+
+[ 2 ] [ "h" get assoc-size ] unit-test

basis/biassocs/biassocs.factor

@@ -0,0 +1,40 @@
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel assocs accessors summary ;
+IN: biassocs
+
+TUPLE: biassoc from to ;
+
+: <biassoc> ( exemplar -- biassoc )
+    [ clone ] [ clone ] bi biassoc boa ;
+
+: <bihash> ( -- biassoc )
+    H{ } <biassoc> ;
+
+M: biassoc assoc-size from>> assoc-size ;
+
+M: biassoc at* from>> at* ;
+
+M: biassoc value-at* to>> at* ;
+
+: once-at ( value key assoc -- )
+    2dup key? [ 3drop ] [ set-at ] if ;
+
+M: biassoc set-at
+    [ from>> set-at ] [ swapd to>> once-at ] 3bi ;
+
+ERROR: no-biassoc-deletion ;
+
+M: no-biassoc-deletion summary
+    drop "biassocs do not support deletion" ;
+
+M: biassoc delete-at
+    no-biassoc-deletion ;
+
+M: biassoc >alist
+    from>> >alist ;
+
+M: biassoc clear-assoc
+    [ from>> clear-assoc ] [ to>> clear-assoc ] bi ;
+
+INSTANCE: biassoc assoc

basis/biassocs/summary.txt

@@ -0,0 +1 @@
+Bidirectional assocs

basis/binary-search/binary-search-docs.factor

@@ -0,0 +1,43 @@
+IN: binary-search
+USING: help.markup help.syntax sequences kernel math.order ;
+
+ARTICLE: "binary-search" "Binary search"
+"The " { $emphasis "binary search" } " algorithm allows elements to be located in sorted sequence in " { $snippet "O(log n)" } " time."
+{ $subsection search }
+"Variants of sequence words optimized for sorted sequences:"
+{ $subsection sorted-index }
+{ $subsection sorted-member? }
+{ $subsection sorted-memq? }
+{ $see-also "order-specifiers" "sequences-sorting" } ;
+
+ABOUT: "binary-search"
+
+HELP: search
+{ $values { "seq" "a sorted sequence" } { "quot" "a quotation with stack effect " { $snippet "( elt -- <=> )" } } { "i" "an index, or " { $link f } } { "elt" "an element, or " { $link f } } }
+{ $description "Performs a binary search on a sequence, calling the quotation to decide whether to end the search (" { $link +eq+ } "), search lower (" { $link +lt+ } ") or search higher (" { $link +gt+ } ")."
+$nl
+"If the sequence is non-empty, outputs the index and value of the closest match, which is either an element for which the quotation output " { $link +eq+ } ", or failing that, least element for which the quotation output " { $link +lt+ } "."
+$nl
+"If the sequence is empty, outputs " { $link f } " " { $link f } "." }
+{ $notes "If the sequence has at least one element, this word always outputs a valid index, because it finds the closest match, not necessarily an exact one. In this respect its behavior differs from " { $link find } "." } ;
+
+{ find find-from find-last find-last find-last-from search } related-words
+
+HELP: sorted-index
+{ $values { "obj" object } { "seq" "a sorted sequence" } { "i" "an index, or " { $link f } } }
+{ $description "Outputs the index and value of the element closest to " { $snippet "elt" } " in the sequence. See " { $link search } " for details." }
+{ $notes "If the sequence has at least one element, this word always outputs a valid index, because it finds the closest match, not necessarily an exact one. In this respect its behavior differs from " { $link index } "." } ;
+
+{ index index-from last-index last-index-from sorted-index } related-words
+
+HELP: sorted-member?
+{ $values { "obj" object } { "seq" "a sorted sequence" } { "?" "a boolean" } }
+{ $description "Tests if the sorted sequence contains " { $snippet "elt" } ". Equality is tested with " { $link = } "." } ;
+
+{ member? sorted-member? } related-words
+
+HELP: sorted-memq?
+{ $values { "obj" object } { "seq" "a sorted sequence" } { "?" "a boolean" } }
+{ $description "Tests if the sorted sequence contains " { $snippet "elt" } ". Equality is tested with " { $link eq? } "." } ;
+
+{ memq? sorted-memq? } related-words

basis/binary-search/binary-search-tests.factor

@@ -0,0 +1,17 @@
+IN: binary-search.tests
+USING: binary-search math.order vectors kernel tools.test ;
+
+\ sorted-member? must-infer
+
+[ f ] [ 3 { } [ <=> ] with search drop ] unit-test
+[ 0 ] [ 3 { 3 } [ <=> ] with search drop ] unit-test
+[ 1 ] [ 2 { 1 2 3 } [ <=> ] with search drop ] unit-test
+[ 3 ] [ 4 { 1 2 3 4 5 6 } [ <=> ] with search drop ] unit-test
+[ 2 ] [ 3.5 { 1 2 3 4 5 6 7 8 } [ <=> ] with search drop ] unit-test
+[ 4 ] [ 5.5 { 1 2 3 4 5 6 7 8 } [ <=> ] with search drop ] unit-test
+[ 10 ] [ 10 20 >vector [ <=> ] with search drop ] unit-test
+
+[ t ] [ "hello" { "alligrator" "cat" "fish" "hello" "ikarus" "java" } sorted-member? ] unit-test
+[ 3 ] [ "hey" { "alligrator" "cat" "fish" "hello" "ikarus" "java" } sorted-index ] unit-test
+[ f ] [ "hello" { "alligrator" "cat" "fish" "ikarus" "java" } sorted-member? ] unit-test
+[ f ] [ "zebra" { "alligrator" "cat" "fish" "ikarus" "java" } sorted-member? ] unit-test

basis/binary-search/binary-search.factor

@@ -0,0 +1,48 @@
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel sequences sequences.private accessors math
+math.order combinators hints arrays ;
+IN: binary-search
+
+<PRIVATE
+
+: midpoint ( seq -- elt )
+    [ midpoint@ ] keep nth-unsafe ; inline
+
+: decide ( quot seq -- quot seq <=> )
+    [ midpoint swap call ] 2keep rot ; inline
+
+: finish ( quot slice -- i elt )
+    [ [ from>> ] [ midpoint@ ] bi + ] [ seq>> ] bi
+    [ drop ] [ dup ] [ ] tri* nth ; inline
+
+: (search) ( quot: ( elt -- <=> ) seq -- i elt )
+    dup length 1 <= [
+        finish
+    ] [
+        decide {
+            { +eq+ [ finish ] }
+            { +lt+ [ dup midpoint@ head-slice (search) ] }
+            { +gt+ [ dup midpoint@ tail-slice (search) ] }
+        } case
+    ] if ; inline recursive
+
+PRIVATE>
+
+: search ( seq quot -- i elt )
+    over empty? [ 2drop f f ] [ swap <flat-slice> (search) ] if ;
+    inline
+
+: natural-search ( obj seq -- i elt )
+    [ <=> ] with search ;
+
+HINTS: natural-search array ;
+
+: sorted-index ( obj seq -- i )
+    natural-search drop ;
+
+: sorted-member? ( obj seq -- ? )
+    dupd natural-search nip = ;
+
+: sorted-memq? ( obj seq -- ? )
+    dupd natural-search nip eq? ;

basis/bit-arrays/bit-arrays-docs.factor

@@ -1,9 +1,9 @@
 USING: arrays help.markup help.syntax kernel
-kernel.private prettyprint strings vectors sbufs ;
+kernel.private math prettyprint strings vectors sbufs ;
 IN: bit-arrays
 
 ARTICLE: "bit-arrays" "Bit arrays"
-"Bit array are a fixed-size mutable sequences (" { $link "sequence-protocol" } ") whose elements are either " { $link t } " or " { $link f } ". Each element only uses one bit of storage, hence the name. The literal syntax is covered in " { $link "syntax-bit-arrays" } "."
+"Bit array are a fixed-size mutable sequences (" { $link "sequence-protocol" } ") whose elements are either " { $link t } " or " { $link f } ". Each element only uses one bit of storage, hence the name."
 $nl
 "Bit array words are in the " { $vocab-link "bit-arrays" } " vocabulary."
 $nl
@@ -17,12 +17,23 @@ $nl
 { $subsection <bit-array> }
 "Efficiently setting and clearing all bits in a bit array:"
 { $subsection set-bits }
-{ $subsection clear-bits } ;
+{ $subsection clear-bits }
+"Converting between unsigned integers and their binary representation:"
+{ $subsection integer>bit-array }
+{ $subsection bit-array>integer }
+"Bit array literal syntax:"
+{ $subsection POSTPONE: ?{ } ;
 
 ABOUT: "bit-arrays"
 
+HELP: ?{
+{ $syntax "?{ elements... }" }
+{ $values { "elements" "a list of booleans" } }
+{ $description "Marks the beginning of a literal bit array. Literal bit arrays are terminated by " { $link POSTPONE: } } "." } 
+{ $examples { $code "?{ t f t }" } } ;
+
 HELP: bit-array
-{ $description "The class of fixed-length bit arrays. See " { $link "syntax-bit-arrays" } " for syntax and " { $link "bit-arrays" } " for general information." } ;
+{ $description "The class of fixed-length bit arrays." } ;
 
 HELP: <bit-array> ( n -- bit-array )
 { $values { "n" "a non-negative integer" } { "bit-array" "a new " { $link bit-array } } }
@@ -47,3 +58,13 @@ HELP: set-bits
     { $code "[ drop t ] change-each" }
 }
 { $side-effects "bit-array" } ;
+
+HELP: integer>bit-array
+{ $values { "n" integer } { "bit-array" bit-array } }
+{ $description "Outputs a freshly-allocated bit array whose elements correspond to the bits in the binary representation of the given unsigned integer value." }
+{ $notes "The bits of the integer are stored in the resulting bit array in order of ascending significance, least significant bit first. This word will fail if passed a negative integer. If you want the two's-complement binary representation of a negative number, use " { $link bitnot } " to get the complement of the number first. This word works with fixnums or bignums of any size; it is not limited by fixnum size or machine word size." } ;
+
+HELP: bit-array>integer
+{ $values { "bit-array" bit-array } { "n" integer } }
+{ $description "Outputs the unsigned integer whose binary representation corresponds to the contents of the given bit array." }
+{ $notes "The bits of the integer are taken from the bit array in order of ascending significance, least significant bit first. This word is able to return fixnums or bignums of any size; it is not limited by fixnum size or machine word size." } ;

basis/bit-arrays/bit-arrays-tests.factor

@@ -0,0 +1,78 @@
+USING: sequences sequences.private arrays bit-arrays kernel
+tools.test math random ;
+IN: bit-arrays.tests
+
+[ 100 ] [ 100 <bit-array> length ] unit-test
+
+[
+    { t f t }
+] [
+    3 <bit-array> t 0 pick set-nth t 2 pick set-nth
+    >array
+] unit-test
+
+[
+    { t f t }
+] [
+    { t f t } >bit-array >array
+] unit-test
+
+[
+    { t f t } { f t f }
+] [
+    { t f t } >bit-array dup clone dup [ not ] change-each
+    [ >array ] bi@
+] unit-test
+
+[
+    { f f f f f }
+] [
+    { t f t t f } >bit-array dup clear-bits >array
+] unit-test
+
+[
+    { t t t t t }
+] [
+    { t f t t f } >bit-array dup set-bits >array
+] unit-test
+
+[ t ] [
+    100 [
+        drop 100 [ 2 random zero? ] replicate
+        dup >bit-array >array =
+    ] all?
+] unit-test
+
+[ ?{ f } ] [
+    1 2 { t f t f } <slice> >bit-array
+] unit-test
+
+[ ?{ f t } ] [ 0 2 ?{ f t f } subseq ] unit-test
+
+[ ?{ t f t f f f } ] [ 6 ?{ t f t } resize ] unit-test
+
+[ ?{ t t } ] [ 2 ?{ t t f t f t f t t t f t } resize ] unit-test
+
+[ -10 ?{ } resize ] must-fail
+
+[ -1 integer>bit-array ] must-fail
+[ ?{ } ] [ 0 integer>bit-array ] unit-test
+[ ?{ f t } ] [ 2 integer>bit-array ] unit-test
+[ ?{ t t t t t t t t t } ] [ 511 integer>bit-array ] unit-test
+[ ?{ 
+    t t t t t t t t   t t t t t t t t   t t t t t t t t  t t t t t t t t
+    t t t t t t t t   t t t t t t t t   t t t t t t t t  t t t t t t t t
+    t t t t t t t t   t t t t t t t t   t t t t t t t t  t t t t t t t t
+    t t t t t t t t   t t t t t t t t   t t t t t t t t  t t t t t t t t
+} ] [
+    HEX: ffffffffffffffffffffffffffffffff integer>bit-array
+] unit-test
+
+[ 14 ] [ ?{ f t t t } bit-array>integer ] unit-test
+[ 0 ] [ ?{ } bit-array>integer ] unit-test
+[ HEX: ffffffffffffffffffffffffffffffff ] [ ?{
+    t t t t t t t t   t t t t t t t t   t t t t t t t t  t t t t t t t t
+    t t t t t t t t   t t t t t t t t   t t t t t t t t  t t t t t t t t
+    t t t t t t t t   t t t t t t t t   t t t t t t t t  t t t t t t t t
+    t t t t t t t t   t t t t t t t t   t t t t t t t t  t t t t t t t t
+} bit-array>integer ] unit-test

basis/bit-arrays/bit-arrays.factor

@@ -0,0 +1,95 @@
+! Copyright (C) 2007, 2008 Slava Pestov.
+! 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 ;
+IN: bit-arrays
+
+TUPLE: bit-array
+{ length array-capacity read-only }
+{ underlying byte-array read-only } ;
+
+<PRIVATE
+
+: n>byte -3 shift ; inline
+
+: byte/bit ( n alien -- byte bit )
+    over n>byte alien-unsigned-1 swap 7 bitand ; inline
+
+: set-bit ( ? byte bit -- byte )
+    2^ rot [ bitor ] [ bitnot bitand ] if ; inline
+
+: bits>cells 31 + -5 shift ; inline
+
+: bits>bytes 7 + n>byte ; inline
+
+: (set-bits) ( bit-array n -- )
+    [ [ length bits>cells ] keep ] dip
+    [ -rot underlying>> set-uint-nth ] 2curry
+    each ; inline
+
+PRIVATE>
+
+: <bit-array> ( n -- bit-array )
+    dup bits>bytes <byte-array> bit-array boa ; inline
+
+M: bit-array length length>> ;
+
+M: bit-array nth-unsafe
+    [ >fixnum ] [ underlying>> ] bi* byte/bit bit? ;
+
+M: bit-array set-nth-unsafe
+    [ >fixnum ] [ underlying>> ] bi*
+    [ byte/bit set-bit ] 2keep
+    swap n>byte set-alien-unsigned-1 ;
+
+: clear-bits ( bit-array -- ) 0 (set-bits) ;
+
+: set-bits ( bit-array -- ) -1 (set-bits) ;
+
+M: bit-array clone
+    [ length>> ] [ underlying>> clone ] bi bit-array boa ;
+
+: >bit-array ( seq -- bit-array )
+    T{ bit-array f 0 B{ } } clone-like ; inline
+
+M: bit-array like drop dup bit-array? [ >bit-array ] unless ;
+
+M: bit-array new-sequence drop <bit-array> ;
+
+M: bit-array equal?
+    over bit-array? [ sequence= ] [ 2drop f ] if ;
+
+M: bit-array resize
+    [ drop ] [
+        [ bits>bytes ] [ underlying>> ] bi*
+        resize-byte-array
+    ] 2bi
+    bit-array boa ;
+
+M: bit-array byte-length length 7 + -3 shift ;
+
+: ?{ \ } [ >bit-array ] parse-literal ; parsing
+
+:: integer>bit-array ( n -- bit-array ) 
+    n zero? [ 0 <bit-array> ] [
+        [let | out [ n log2 1+ <bit-array> ] i! [ 0 ] n'! [ n ] |
+            [ n' zero? not ] [
+                n' out underlying>> i set-alien-unsigned-1
+                n' -8 shift n'!
+                i 1+ i!
+            ] [ ] while
+            out
+        ]
+    ] if ;
+
+: bit-array>integer ( bit-array -- n )
+    0 swap underlying>> [ length ] keep [
+        uchar-nth swap 8 shift bitor
+    ] curry each ;
+
+INSTANCE: bit-array sequence
+
+M: bit-array pprint-delims drop \ ?{ \ } ;
+M: bit-array >pprint-sequence ;
+M: bit-array pprint* pprint-object ;

basis/bit-vectors/bit-vectors-docs.factor

@@ -1,5 +1,5 @@
 USING: arrays bit-arrays help.markup help.syntax kernel
-bit-vectors.private combinators ;
+combinators ;
 IN: bit-vectors
 
 ARTICLE: "bit-vectors" "Bit vectors"
@@ -29,11 +29,6 @@ HELP: >bit-vector
 { $values { "seq" "a sequence" } { "bit-vector" bit-vector } }
 { $description "Outputs a freshly-allocated bit vector with the same elements as a given sequence." } ;
 
-HELP: bit-array>vector
-{ $values { "bit-array" "an array" } { "length" "a non-negative integer" } { "bit-vector" bit-vector } }
-{ $description "Creates a new bit vector using the array for underlying storage with the specified initial length." }
-{ $warning "This word is in the " { $vocab-link "bit-vectors.private" } " vocabulary because it does not perform type or bounds checks. User code should call " { $link >bit-vector } " instead." } ;
-
 HELP: ?V{
 { $syntax "?V{ elements... }" }
 { $values { "elements" "a list of booleans" } }

basis/bit-vectors/bit-vectors.factor

@@ -5,25 +5,12 @@ sequences.private growable bit-arrays prettyprint.backend
 parser accessors ;
 IN: bit-vectors
 
-TUPLE: bit-vector underlying fill ;
-
-M: bit-vector underlying underlying>> { bit-array } declare ;
-
-M: bit-vector set-underlying (>>underlying) ;
-
-M: bit-vector length fill>> { array-capacity } declare ;
-
-M: bit-vector set-fill (>>fill) ;
-
-<PRIVATE
-
-: bit-array>vector ( bit-array length -- bit-vector )
-    bit-vector boa ; inline
-
-PRIVATE>
+TUPLE: bit-vector
+{ underlying bit-array initial: ?{ } }
+{ length array-capacity } ;
 
 : <bit-vector> ( n -- bit-vector )
-    <bit-array> 0 bit-array>vector ; inline
+    <bit-array> 0 bit-vector boa ; inline
 
 : >bit-vector ( seq -- bit-vector )
     T{ bit-vector f ?{ } 0 } clone-like ;
@@ -31,11 +18,11 @@ PRIVATE>
 M: bit-vector like
     drop dup bit-vector? [
         dup bit-array?
-        [ dup length bit-array>vector ] [ >bit-vector ] if
+        [ dup length bit-vector boa ] [ >bit-vector ] if
     ] unless ;
 
 M: bit-vector new-sequence
-    drop [ <bit-array> ] keep >fixnum bit-array>vector ;
+    drop [ <bit-array> ] [ >fixnum ] bi bit-vector boa ;
 
 M: bit-vector equal?
     over bit-vector? [ sequence= ] [ 2drop f ] if ;
@@ -47,5 +34,5 @@ INSTANCE: bit-vector growable
 : ?V{ \ } [ >bit-vector ] parse-literal ; parsing
 
 M: bit-vector >pprint-sequence ;
-
 M: bit-vector pprint-delims drop \ ?V{ \ } ;
+M: bit-vector pprint* pprint-object ;

basis/bootstrap/compiler/compiler.factor

@@ -1,11 +1,13 @@
 ! Copyright (C) 2007, 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: compiler cpu.architecture vocabs.loader system sequences
-namespaces parser kernel kernel.private classes classes.private
-arrays hashtables vectors classes.tuple sbufs inference.dataflow
+USING: accessors compiler cpu.architecture vocabs.loader system
+sequences namespaces parser kernel kernel.private classes
+classes.private arrays hashtables vectors classes.tuple sbufs
 hashtables.private sequences.private math classes.tuple.private
-growable namespaces.private assocs words generator command-line
-vocabs io prettyprint libc compiler.units math.order ;
+growable namespaces.private assocs words command-line vocabs io
+io.encodings.string prettyprint libc splitting math.parser
+compiler.units math.order compiler.tree.builder
+compiler.tree.optimizer ;
 IN: bootstrap.compiler
 
 ! Don't bring this in when deploying, since it will store a
@@ -14,11 +16,12 @@ IN: bootstrap.compiler
     "alien.remote-control" require
 ] unless
 
-"cpu." cpu word-name append require
+"cpu." cpu name>> append require
 
 enable-compiler
 
-: compile-uncompiled [ compiled? not ] filter compile ;
+: compile-uncompiled ( words -- )
+    [ compiled>> not ] filter compile ;
 
 nl
 "Compiling..." write flush
@@ -33,16 +36,18 @@ nl
     roll -roll declare not
 
     array? hashtable? vector?
-    tuple? sbuf? node? tombstone?
+    tuple? sbuf? tombstone?
 
-    array-capacity array-nth set-array-nth
+    array-nth set-array-nth
 
     wrap probe
 
-    underlying
+    namestack*
+} compile-uncompiled
 
-    find-pair-next namestack*
+"." write flush
 
+{
     bitand bitor bitxor bitnot
 } compile-uncompiled
 
@@ -67,15 +72,27 @@ nl
 "." write flush
 
 {
-    . lines
+    memq? split harvest sift cut cut-slice start index clone
+    set-at reverse push-all class number>string string>number
 } compile-uncompiled
 
 "." write flush
 
 {
-    malloc calloc free memcpy
+    lines prefix suffix unclip new-assoc update
+    word-prop set-word-prop 1array 2array 3array ?nth
 } compile-uncompiled
 
+"." write flush
+
+{
+    . malloc calloc free memcpy
+} compile-uncompiled
+
+{ build-tree } compile-uncompiled
+
+{ optimize-tree } compile-uncompiled
+
 vocabs [ words compile-uncompiled "." write flush ] each
 
 " done" print flush

basis/bootstrap/handbook/handbook.factor

@@ -1,3 +1,4 @@
 USING: vocabs.loader vocabs kernel ;
+IN: bootstrap.handbook
 
 "bootstrap.help" vocab [ "help.handbook" require ] when

basis/bootstrap/help/help.factor

@@ -3,7 +3,7 @@ help.definitions io io.files kernel namespaces vocabs sequences
 parser vocabs.loader ;
 IN: bootstrap.help
 
-: load-help
+: load-help ( -- )
     "alien.syntax" require
     "compiler" require
 

basis/bootstrap/image/download/download.factor

@@ -1,13 +1,13 @@
 ! Copyright (C) 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-IN: bootstrap.image.download
 USING: http.client checksums checksums.openssl splitting assocs
-kernel io.files bootstrap.image sequences io ;
+kernel io.files bootstrap.image sequences io urls ;
+IN: bootstrap.image.download
 
-: url "http://factorcode.org/images/latest/" ;
+: url URL" http://factorcode.org/images/latest/" ;
 
 : download-checksums ( -- alist )
-    url "checksums.txt" append http-get
+    url "checksums.txt" >url derive-url http-get nip
     string-lines [ " " split1 ] { } map>assoc ;
 
 : need-new-image? ( image -- ? )
@@ -21,7 +21,10 @@ kernel io.files bootstrap.image sequences io ;
 : download-image ( arch -- )
     boot-image-name dup need-new-image? [
         "Downloading " write dup write "..." print
-        url prepend download
+         url over >url derive-url download
+         need-new-image? [
+             "Boot image corrupt, or checksums.txt on server out of date" throw
+         ] when
     ] [
         "Boot image up to date" print
         drop

basis/bootstrap/image/image.factor

@@ -1,19 +1,19 @@
 ! Copyright (C) 2004, 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: alien arrays bit-arrays byte-arrays generic assocs
-hashtables assocs hashtables.private io kernel kernel.private
-math namespaces parser prettyprint sequences sequences.private
-strings sbufs vectors words quotations assocs system layouts
-splitting growable classes classes.builtin classes.tuple
+USING: alien arrays byte-arrays generic assocs hashtables assocs
+hashtables.private io kernel kernel.private math namespaces
+parser prettyprint sequences sequences.private strings sbufs
+vectors words quotations assocs system layouts splitting
+grouping growable classes classes.builtin classes.tuple
 classes.tuple.private words.private io.binary io.files vocabs
-vocabs.loader source-files definitions debugger float-arrays
+vocabs.loader source-files definitions debugger
 quotations.private sequences.private combinators
-io.encodings.binary math.order accessors ;
+io.encodings.binary math.order math.private accessors slots.private ;
 IN: bootstrap.image
 
 : my-arch ( -- arch )
-    cpu word-name
-    dup "ppc" = [ >r os word-name "-" r> 3append ] when ;
+    cpu name>> 
+    dup "ppc" = [ >r os name>> "-" r> 3append ] when ;
 
 : boot-image-name ( arch -- string )
     "boot." swap ".image" 3append ;
@@ -75,7 +75,7 @@ SYMBOL: objects
 
 : data-base 1024 ; inline
 
-: userenv-size 64 ; inline
+: userenv-size 70 ; inline
 
 : header-size 10 ; inline
 
@@ -85,15 +85,16 @@ SYMBOL: objects
 : 1-offset              8 ; inline
 : -1-offset             9 ; inline
 
-: array-start 2 bootstrap-cells object tag-number - ;
-: scan@ array-start bootstrap-cell - ;
-: wrapper@ bootstrap-cell object tag-number - ;
-: word-xt@ 8 bootstrap-cells object tag-number - ;
-: quot-array@ bootstrap-cell object tag-number - ;
-: quot-xt@ 3 bootstrap-cells object tag-number - ;
+SYMBOL: sub-primitives
+
+: make-jit ( quot rc rt offset -- quad )
+    { [ { } make ] [ ] [ ] [ ] } spread 4array ; inline
 
 : jit-define ( quot rc rt offset name -- )
-    >r { [ { } make ] [ ] [ ] [ ] } spread 4array r> set ;
+    >r make-jit r> set ; inline
+
+: define-sub-primitive ( quot rc rt offset word -- )
+    >r make-jit r> sub-primitives get set-at ;
 
 ! The image being constructed; a vector of word-size integers
 SYMBOL: image
@@ -118,6 +119,7 @@ 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-dispatch-word
@@ -125,6 +127,7 @@ SYMBOL: jit-dispatch
 SYMBOL: jit-epilog
 SYMBOL: jit-return
 SYMBOL: jit-profiling
+SYMBOL: jit-declare-word
 
 ! Default definition for undefined words
 SYMBOL: undefined-quot
@@ -147,7 +150,9 @@ SYMBOL: undefined-quot
         { jit-epilog 33 }
         { jit-return 34 }
         { jit-profiling 35 }
-        { undefined-quot 37 }
+        { jit-push-immediate 36 }
+        { jit-declare-word 42 }
+        { undefined-quot 60 }
     } at header-size + ;
 
 : emit ( cell -- ) image get push ;
@@ -203,15 +208,15 @@ GENERIC: ' ( obj -- ptr )
 
 ! Bignums
 
-: bignum-bits bootstrap-cell-bits 2 - ;
+: bignum-bits ( -- n ) bootstrap-cell-bits 2 - ;
 
-: bignum-radix bignum-bits 2^ 1- ;
+: bignum-radix ( -- n ) bignum-bits 2^ 1- ;
 
 : bignum>seq ( n -- seq )
     #! n is positive or zero.
     [ dup 0 > ]
     [ [ bignum-bits neg shift ] [ bignum-radix bitand ] bi ]
-    [ ] unfold nip ;
+    [ ] produce nip ;
 
 : emit-bignum ( n -- )
     dup dup 0 < [ neg ] when bignum>seq
@@ -235,6 +240,12 @@ M: fixnum '
     bootstrap-most-positive-fixnum between?
     [ tag-fixnum ] [ >bignum ' ] if ;
 
+TUPLE: fake-bignum n ;
+
+C: <fake-bignum> fake-bignum
+
+M: fake-bignum ' n>> tag-fixnum ;
+
 ! Floats
 
 M: float '
@@ -248,18 +259,21 @@ M: float '
 
 ! Padded with fixnums for 8-byte alignment
 
-: t, t t-offset fixup ;
+: t, ( -- ) t t-offset fixup ;
 
 M: f '
     #! f is #define F RETAG(0,F_TYPE)
     drop \ f tag-number ;
 
-:  0,  0 >bignum '  0-offset fixup ;
-:  1,  1 >bignum '  1-offset fixup ;
-: -1, -1 >bignum ' -1-offset fixup ;
+:  0, ( -- )  0 >bignum '  0-offset fixup ;
+:  1, ( -- )  1 >bignum '  1-offset fixup ;
+: -1, ( -- ) -1 >bignum ' -1-offset fixup ;
 
 ! Words
 
+: word-sub-primitive ( word -- obj )
+    global [ target-word ] bind sub-primitives get at ;
+
 : emit-word ( word -- )
     [
         [ subwords [ emit-word ] each ]
@@ -267,16 +281,17 @@ M: f '
             [
                 {
                     [ hashcode , ]
-                    [ word-name , ]
-                    [ word-vocabulary , ]
-                    [ word-def , ]
-                    [ word-props , ]
+                    [ name>> , ]
+                    [ vocabulary>> , ]
+                    [ def>> , ]
+                    [ props>> , ]
+                    [ drop f , ]
+                    [ drop 0 , ] ! count
+                    [ word-sub-primitive , ]
+                    [ drop 0 , ] ! xt
+                    [ drop 0 , ] ! code
+                    [ drop 0 , ] ! profiling
                 } cleave
-                f ,
-                0 , ! count
-                0 , ! xt
-                0 , ! code
-                0 , ! profiling
             ] { } make [ ' ] map
         ] bi
         \ word type-number object tag-number
@@ -284,7 +299,7 @@ M: f '
     ] keep put-object ;
 
 : word-error ( word msg -- * )
-    [ % dup word-vocabulary % " " % word-name % ] "" make throw ;
+    [ % dup vocabulary>> % " " % name>> % ] "" make throw ;
 
 : transfer-word ( word -- word )
     [ target-word ] keep or ;
@@ -301,7 +316,7 @@ M: word ' ;
 ! Wrappers
 
 M: wrapper '
-    wrapped ' wrapper type-number object tag-number
+    wrapped>> ' wrapper type-number object tag-number
     [ emit ] emit-object ;
 
 ! Strings
@@ -341,18 +356,14 @@ M: byte-array '
         pad-bytes emit-bytes
     ] emit-object ;
 
-M: bit-array ' bit-array emit-dummy-array ;
-
-M: float-array ' float-array emit-dummy-array ;
-
 ! Tuples
 : (emit-tuple) ( tuple -- pointer )
-    [ tuple>array rest-slice ]
+    [ tuple-slots ]
     [ class transfer-word tuple-layout ] bi prefix [ ' ] map
     tuple type-number dup [ emit-seq ] emit-object ;
 
 : emit-tuple ( tuple -- pointer )
-    dup class word-name "tombstone" =
+    dup class name>> "tombstone" =
     [ [ (emit-tuple) ] cache-object ] [ (emit-tuple) ] if ;
 
 M: tuple ' emit-tuple ;
@@ -361,11 +372,11 @@ M: tuple-layout '
     [
         [
             {
-                [ layout-hashcode , ]
-                [ layout-class , ]
-                [ layout-size , ]
-                [ layout-superclasses , ]
-                [ layout-echelon , ]
+                [ hashcode>> , ]
+                [ class>> , ]
+                [ size>> , ]
+                [ superclasses>> , ]
+                [ echelon>> , ]
             } cleave
         ] { } make [ ' ] map
         \ tuple-layout type-number
@@ -373,9 +384,9 @@ M: tuple-layout '
     ] cache-object ;
 
 M: tombstone '
-    delegate
-    "((tombstone))" "((empty))" ? "hashtables.private" lookup
-    word-def first [ emit-tuple ] cache-object ;
+    state>> "((tombstone))" "((empty))" ?
+    "hashtables.private" lookup def>> first
+    [ emit-tuple ] cache-object ;
 
 ! Arrays
 M: array '
@@ -386,10 +397,10 @@ M: array '
 
 M: quotation '
     [
-        quotation-array '
+        array>> '
         quotation type-number object tag-number [
             emit ! array
-            f ' emit ! compiled?
+            f ' emit ! compiled>>
             0 emit ! xt
             0 emit ! code
         ] emit-object
@@ -404,7 +415,7 @@ M: quotation '
     [
         {
             dictionary source-files builtins
-            update-map class<=-cache
+            update-map implementors-map class<=-cache
             class-not-cache classes-intersect-cache class-and-cache
             class-or-cache
         } [ dup get swap bootstrap-word set ] each
@@ -419,6 +430,7 @@ M: quotation '
     \ if jit-if-word set
     \ dispatch jit-dispatch-word set
     \ do-primitive jit-primitive-word set
+    \ declare jit-declare-word set
     [ undefined ] undefined-quot set
     {
         jit-code-format
@@ -428,6 +440,7 @@ M: quotation '
         jit-word-jump
         jit-word-call
         jit-push-literal
+        jit-push-immediate
         jit-if-word
         jit-if-jump
         jit-dispatch-word
@@ -435,6 +448,7 @@ M: quotation '
         jit-epilog
         jit-return
         jit-profiling
+        jit-declare-word
         undefined-quot
     } [ emit-userenv ] each ;
 

basis/bootstrap/image/upload/upload.factor

@@ -12,9 +12,9 @@ SYMBOL: upload-images-destination
   "slava@factorcode.org:/var/www/factorcode.org/newsite/images/latest/"
   or ;
 
-: checksums "checksums.txt" temp-file ;
+: checksums ( -- temp ) "checksums.txt" temp-file ;
 
-: boot-image-names images [ boot-image-name ] map ;
+: boot-image-names ( -- seq ) images [ boot-image-name ] map ;
 
 : compute-checksums ( -- )
     checksums ascii [

basis/bootstrap/random/random.factor

@@ -1,6 +1,7 @@
 USING: vocabs.loader sequences system
 random random.mersenne-twister combinators init
 namespaces random ;
+IN: bootstrap.random
 
 "random.mersenne-twister" require
 

basis/bootstrap/stage2.factor

@@ -0,0 +1,107 @@
+! Copyright (C) 2004, 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors init namespaces words io
+kernel.private math memory continuations kernel io.files
+io.backend system parser vocabs sequences prettyprint
+vocabs.loader combinators splitting source-files strings
+definitions assocs compiler.errors compiler.units
+math.parser generic sets debugger command-line ;
+IN: bootstrap.stage2
+
+SYMBOL: bootstrap-time
+
+: default-image-name ( -- string )
+    vm file-name os windows? [ "." split1 drop ] when
+    ".image" append resource-path ;
+
+: do-crossref ( -- )
+    "Cross-referencing..." print flush
+    H{ } clone crossref set-global
+    xref-words
+    xref-generics
+    xref-sources ;
+
+: load-components ( -- )
+    "include" "exclude"
+    [ get-global " " split harvest ] bi@
+    diff
+    [ "bootstrap." prepend require ] each ;
+
+: count-words ( pred -- )
+    all-words swap count number>string write ;
+
+: print-report ( time -- )
+    1000 /i
+    60 /mod swap
+    "Bootstrap completed in " write number>string write
+    " minutes and " write number>string write " seconds." print
+
+    [ compiled>> ] count-words " compiled words" print
+    [ symbol? ] count-words " symbol words" print
+    [ ] count-words " words total" print
+
+    "Bootstrapping is complete." print
+    "Now, you can run Factor:" print
+    vm write " -i=" write "output-image" get print flush ;
+
+[
+    ! We time bootstrap
+    millis >r
+
+    default-image-name "output-image" set-global
+
+    "math compiler threads help io tools ui ui.tools random unicode handbook" "include" set-global
+    "" "exclude" set-global
+
+    parse-command-line
+
+    "-no-crossref" cli-args member? [ do-crossref ] unless
+
+    ! Set dll paths
+    os wince? [ "windows.ce" require ] when
+    os winnt? [ "windows.nt" require ] when
+
+    "deploy-vocab" get [
+        "stage2: deployment mode" print
+    ] [
+        "listener" require
+        "none" require
+    ] if
+
+    [
+        load-components
+
+        run-bootstrap-init
+    ] with-compiler-errors
+    :errors
+
+    f error set-global
+    f error-continuation set-global
+
+    "deploy-vocab" get [
+        "tools.deploy.shaker" run
+    ] [
+        [
+            boot
+            do-init-hooks
+            [
+                parse-command-line
+                run-user-init
+                "run" get run
+                output-stream get [ stream-flush ] when*
+            ] [ print-error 1 exit ] recover
+        ] set-boot-quot
+
+        millis r> - dup bootstrap-time set-global
+        print-report
+
+        "output-image" get save-image-and-exit
+    ] if
+] [
+    :c
+    dup print-error flush
+    "listener" vocab
+    [ restarts. vocab-main execute ]
+    [ die ] if*
+    1 exit
+] recover

basis/bootstrap/threads/threads.factor

@@ -0,0 +1,7 @@
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+IN: bootstrap.threads
+
+USE: io.thread
+USE: threads
+USE: debugger.threads

basis/bootstrap/tools/tools.factor

@@ -1,6 +1,8 @@
 USING: vocabs.loader sequences ;
+IN: bootstrap.tools
 
 {
+    "inspector"
     "bootstrap.image"
     "tools.annotations"
     "tools.crossref"