Merge git://factorcode.org/git/factor

Conflicts:

	extra/hardware-info/windows/nt/nt.factor
	extra/hardware-info/windows/windows.factor

core/bit-arrays/bit-arrays-tests.factor

@@ -46,3 +46,9 @@ IN: temporary
 [ ?{ f } ] [
     1 2 { t f t f } <slice> >bit-array
 ] unit-test
+
+[ ?{ t f t f f f } ] [ 6 ?{ t f t } resize-bit-array ] unit-test
+
+[ ?{ t t } ] [ 2 ?{ t t f t f t f t t t f t } resize-bit-array ] unit-test
+
+[ -10 ?{ } resize-bit-array ] unit-test-fails

core/bit-arrays/bit-arrays.factor

@@ -48,6 +48,9 @@ M: bit-array new drop <bit-array> ;
 M: bit-array equal?
     over bit-array? [ sequence= ] [ 2drop f ] if ;
 
+M: bit-array resize
+    resize-bit-array ;
+
 INSTANCE: bit-array sequence
 INSTANCE: bit-array simple-c-ptr
 INSTANCE: bit-array c-ptr

core/bit-vectors/bit-vectors-docs.factor

@@ -0,0 +1,33 @@
+USING: arrays bit-arrays help.markup help.syntax kernel
+bit-vectors.private combinators ;
+IN: bit-vectors
+
+ARTICLE: "bit-vectors" "Bit vectors"
+"A bit vector is a resizable mutable sequence of bits. The literal syntax is covered in " { $link "syntax-bit-vectors" } ". Bit vector words are found in the " { $vocab-link "bit-vectors" } " vocabulary."
+$nl
+"Bit vectors form a class:"
+{ $subsection bit-vector }
+{ $subsection bit-vector? }
+"Creating bit vectors:"
+{ $subsection >bit-vector }
+{ $subsection <bit-vector> }
+"If you don't care about initial capacity, a more elegant way to create a new bit vector is to write:"
+{ $code "?V{ } clone" } ;
+
+ABOUT: "bit-vectors"
+
+HELP: bit-vector
+{ $description "The class of resizable bit vectors. See " { $link "syntax-bit-vectors" } " for syntax and " { $link "bit-vectors" } " for general information." } ;
+
+HELP: <bit-vector>
+{ $values { "n" "a positive integer specifying initial capacity" } { "bit-vector" bit-vector } }
+{ $description "Creates a new bit vector that can hold " { $snippet "n" } " bits before resizing." } ;
+
+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." } ;

core/bit-vectors/bit-vectors-tests.factor

@@ -0,0 +1,14 @@
+IN: temporary
+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 ;
+
+[ t ] [
+    3 <bit-vector> dup do-it
+    3 <vector> dup do-it sequence=
+] unit-test
+
+[ t ] [ ?V{ } bit-vector? ] unit-test

core/bit-vectors/bit-vectors.factor

@@ -0,0 +1,33 @@
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: arrays kernel kernel.private math sequences
+sequences.private growable bit-arrays ;
+IN: bit-vectors
+
+<PRIVATE
+
+: bit-array>vector ( bit-array length -- bit-vector )
+    bit-vector construct-boa ; inline
+
+PRIVATE>
+
+: <bit-vector> ( n -- bit-vector )
+    <bit-array> 0 bit-array>vector ; inline
+
+: >bit-vector ( seq -- bit-vector ) ?V{ } clone-like ;
+
+M: bit-vector like
+    drop dup bit-vector? [
+        dup bit-array?
+        [ dup length bit-array>vector ] [ >bit-vector ] if
+    ] unless ;
+
+M: bit-vector new
+    drop [ <bit-array> ] keep >fixnum bit-array>vector ;
+
+M: bit-vector equal?
+    over bit-vector? [ sequence= ] [ 2drop f ] if ;
+
+M: bit-array new-resizable drop <bit-vector> ;
+
+INSTANCE: bit-vector growable

core/bootstrap/image/image.factor

@@ -320,24 +320,33 @@ M: quotation '
 ! Vectors and sbufs
 
 M: vector '
-    dup underlying ' swap length
+    dup length swap underlying '
-    vector type-number object tag-number [
+    tuple type-number tuple tag-number [
-        emit-fixnum ! length
+        4 emit-fixnum
+        vector ' emit
+        f ' emit
         emit ! array ptr
+        emit-fixnum ! length
     ] emit-object ;
 
 M: sbuf '
-    dup underlying ' swap length
+    dup length swap underlying '
-    sbuf type-number object tag-number [
+    tuple type-number tuple tag-number [
-        emit-fixnum ! length
+        4 emit-fixnum
+        sbuf ' emit
+        f ' emit
         emit ! array ptr
+        emit-fixnum ! length
     ] emit-object ;
 
 ! Hashes
 
 M: hashtable '
     [ hash-array ' ] keep
-    hashtable type-number object tag-number [
+    tuple type-number tuple tag-number [
+        5 emit-fixnum
+        hashtable ' emit
+        f ' emit
         dup hash-count emit-fixnum
         hash-deleted emit-fixnum
         emit ! array ptr

core/bootstrap/layouts/layouts.factor

@@ -8,7 +8,7 @@ BIN: 111 tag-mask set
 8 num-tags set
 3 tag-bits set
 
-23 num-types set
+20 num-types set
 
 H{
     { fixnum      BIN: 000 }
@@ -24,17 +24,14 @@ H{
 tag-numbers get H{
     { array 8 }
     { wrapper 9 }
-    { hashtable 10 }
+    { float-array 10 }
-    { vector 11 }
+    { callstack 11 }
     { string 12 }
-    { sbuf 13 }
+    { curry 13 }
     { quotation 14 }
     { dll 15 }
     { alien 16 }
     { word 17 }
     { byte-array 18 }
     { bit-array 19 }
-    { float-array 20 }
-    { curry 21 }
-    { callstack 22 }
 } union type-numbers set

core/bootstrap/primitives.factor

@@ -22,7 +22,9 @@ crossref off
        { "arm" "arm" }
    } at "/bootstrap.factor" 3append parse-file
 
-! Now we have ( syntax-quot arch-quot ) on the stack
+"resource:core/bootstrap/layouts/layouts.factor" parse-file
+
+! Now we have ( syntax-quot arch-quot layouts-quot ) on the stack
 
 ! Bring up a bare cross-compiling vocabulary.
 "syntax" vocab vocab-words bootstrap-syntax set
@@ -30,6 +32,7 @@ H{ } clone dictionary set
 H{ } clone changed-words set
 [ drop ] recompile-hook set
 
+call
 call
 call
 
@@ -39,11 +42,14 @@ call
     "alien"
     "arrays"
     "bit-arrays"
+    "bit-vectors"
     "byte-arrays"
+    "byte-vectors"
     "classes.private"
     "compiler.units"
     "continuations.private"
     "float-arrays"
+    "float-vectors"
     "generator"
     "growable"
     "hashtables"
@@ -96,12 +102,6 @@ H{ } clone update-map set
 : register-builtin ( class -- )
     dup "type" word-prop builtins get set-nth ;
 
-: intern-slots ( spec -- spec )
-    [
-        [ dup array? [ first2 create ] when ] map
-        { slot-spec f } swap append >tuple
-    ] map ;
-
 : lookup-type-number ( word -- n )
     global [ target-word ] bind type-number ;
 
@@ -110,8 +110,8 @@ H{ } clone update-map set
     dup dup lookup-type-number "type" set-word-prop
     dup f f builtin-class define-class
     dup r> builtin-predicate
-    dup r> intern-slots 2dup "slots" set-word-prop
+    dup r> 1 simple-slots 2dup "slots" set-word-prop
-    define-slots
+    dupd define-slots
     register-builtin ;
 
 H{ } clone typemap set
@@ -137,14 +137,12 @@ num-types get f <array> builtins set
     {
         { "integer" "math" }
         "numerator"
-        1
         { "numerator" "math" }
         f
     }
     {
         { "integer" "math" }
         "denominator"
-        2
         { "denominator" "math" }
         f
     }
@@ -158,14 +156,12 @@ num-types get f <array> builtins set
     {
         { "real" "math" }
         "real-part"
-        1
         { "real-part" "math" }
         f
     }
     {
         { "real" "math" }
         "imaginary-part"
-        2
         { "imaginary-part" "math" }
         f
     }
@@ -182,94 +178,32 @@ num-types get f <array> builtins set
     {
         { "object" "kernel" }
         "wrapped"
-        1
         { "wrapped" "kernel" }
         f
     }
 } define-builtin
 
-"hashtable" "hashtables" create "hashtable?" "hashtables" create
-{
-    {
-        { "array-capacity" "sequences.private" }
-        "count"
-        1
-        { "hash-count" "hashtables.private" }
-        { "set-hash-count" "hashtables.private" }
-    } {
-        { "array-capacity" "sequences.private" }
-        "deleted"
-        2
-        { "hash-deleted" "hashtables.private" }
-        { "set-hash-deleted" "hashtables.private" }
-    } {
-        { "array" "arrays" }
-        "array"
-        3
-        { "hash-array" "hashtables.private" }
-        { "set-hash-array" "hashtables.private" }
-    }
-} define-builtin
-
-"vector" "vectors" create "vector?" "vectors" create
-{
-    {
-        { "array-capacity" "sequences.private" }
-        "fill"
-        1
-        { "length" "sequences" }
-        { "set-fill" "growable" }
-    } {
-        { "array" "arrays" }
-        "underlying"
-        2
-        { "underlying" "growable" }
-        { "set-underlying" "growable" }
-    }
-} define-builtin
-
 "string" "strings" create "string?" "strings" create
 {
     {
         { "array-capacity" "sequences.private" }
         "length"
-        1
         { "length" "sequences" }
         f
     }
 } define-builtin
 
-"sbuf" "sbufs" create "sbuf?" "sbufs" create
-{
-    {
-        { "array-capacity" "sequences.private" }
-        "length"
-        1
-        { "length" "sequences" }
-        { "set-fill" "growable" }
-    }
-    {
-        { "string" "strings" }
-        "underlying"
-        2
-        { "underlying" "growable" }
-        { "set-underlying" "growable" }
-    }
-} define-builtin
-
 "quotation" "quotations" create "quotation?" "quotations" create
 {
     {
         { "object" "kernel" }
         "array"
-        1
         { "quotation-array" "quotations.private" }
         f
     }
     {
         { "object" "kernel" }
         "compiled?"
-        2
         { "quotation-compiled?" "quotations" }
         f
     }
@@ -280,7 +214,6 @@ num-types get f <array> builtins set
     {
         { "byte-array" "byte-arrays" }
         "path"
-        1
         { "(dll-path)" "alien" }
         f
     }
@@ -292,13 +225,11 @@ define-builtin
     {
         { "c-ptr" "alien" }
         "alien"
-        1
         { "underlying-alien" "alien" }
         f
     } {
         { "object" "kernel" }
         "expired?"
-        2
         { "expired?" "alien" }
         f
     }
@@ -307,45 +238,40 @@ define-builtin
 
 "word" "words" create "word?" "words" create
 {
+    f
     {
         { "object" "kernel" }
         "name"
-        2
         { "word-name" "words" }
         { "set-word-name" "words" }
     }
     {
         { "object" "kernel" }
         "vocabulary"
-        3
         { "word-vocabulary" "words" }
         { "set-word-vocabulary" "words" }
     }
     {
         { "quotation" "quotations" }
         "def"
-        4
         { "word-def" "words" }
         { "set-word-def" "words.private" }
     }
     {
         { "object" "kernel" }
         "props"
-        5
         { "word-props" "words" }
         { "set-word-props" "words" }
     }
     {
         { "object" "kernel" }
         "?"
-        6
         { "compiled?" "words" }
         f
     }
     {
         { "fixnum" "math" }
         "counter"
-        7
         { "profile-counter" "tools.profiler.private" }
         { "set-profile-counter" "tools.profiler.private" }
     }
@@ -369,14 +295,12 @@ define-builtin
     {
         { "object" "kernel" }
         "obj"
-        1
         { "curry-obj" "kernel" }
         f
     }
     {
         { "object" "kernel" }
         "obj"
-        2
         { "curry-quot" "kernel" }
         f
     }
@@ -414,6 +338,102 @@ builtins get num-tags get tail f union-class define-class
 "tombstone" "hashtables.private" lookup t
 2array >tuple 1quotation define-inline
 
+! Some tuple classes
+"hashtable" "hashtables" create
+{
+    {
+        { "array-capacity" "sequences.private" }
+        "count"
+        { "hash-count" "hashtables.private" }
+        { "set-hash-count" "hashtables.private" }
+    } {
+        { "array-capacity" "sequences.private" }
+        "deleted"
+        { "hash-deleted" "hashtables.private" }
+        { "set-hash-deleted" "hashtables.private" }
+    } {
+        { "array" "arrays" }
+        "array"
+        { "hash-array" "hashtables.private" }
+        { "set-hash-array" "hashtables.private" }
+    }
+} define-tuple-class
+
+"sbuf" "sbufs" create
+{
+    {
+        { "string" "strings" }
+        "underlying"
+        { "underlying" "growable" }
+        { "set-underlying" "growable" }
+    } {
+        { "array-capacity" "sequences.private" }
+        "length"
+        { "length" "sequences" }
+        { "set-fill" "growable" }
+    }
+} define-tuple-class
+
+"vector" "vectors" create
+{
+    {
+        { "array" "arrays" }
+        "underlying"
+        { "underlying" "growable" }
+        { "set-underlying" "growable" }
+    } {
+        { "array-capacity" "sequences.private" }
+        "fill"
+        { "length" "sequences" }
+        { "set-fill" "growable" }
+    }
+} define-tuple-class
+
+"byte-vector" "byte-vectors" create
+{
+    {
+        { "byte-array" "byte-arrays" }
+        "underlying"
+        { "underlying" "growable" }
+        { "set-underlying" "growable" }
+    } {
+        { "array-capacity" "sequences.private" }
+        "fill"
+        { "length" "sequences" }
+        { "set-fill" "growable" }
+    }
+} define-tuple-class
+
+"bit-vector" "bit-vectors" create
+{
+    {
+        { "bit-array" "bit-arrays" }
+        "underlying"
+        { "underlying" "growable" }
+        { "set-underlying" "growable" }
+    } {
+        { "array-capacity" "sequences.private" }
+        "fill"
+        { "length" "sequences" }
+        { "set-fill" "growable" }
+    }
+} define-tuple-class
+
+"float-vector" "float-vectors" create
+{
+    {
+        { "float-array" "float-arrays" }
+        "underlying"
+        { "underlying" "growable" }
+        { "set-underlying" "growable" }
+    } {
+        { "array-capacity" "sequences.private" }
+        "fill"
+        { "length" "sequences" }
+        { "set-fill" "growable" }
+    }
+} define-tuple-class
+
 ! Primitive words
 : make-primitive ( word vocab n -- )
     >r create dup reset-word r> [ do-primitive ] curry [ ] like define ;
@@ -422,7 +442,6 @@ builtins get num-tags get tail f union-class define-class
     { "(execute)" "words.private" }
     { "(call)" "kernel.private" }
     { "uncurry" "kernel.private" }
-    { "string>sbuf" "sbufs.private" }
     { "bignum>fixnum" "math.private" }
     { "float>fixnum" "math.private" }
     { "fixnum>bignum" "math.private" }
@@ -575,7 +594,6 @@ builtins get num-tags get tail f union-class define-class
     { "set-char-slot" "strings.private" }
     { "resize-array" "arrays" }
     { "resize-string" "strings" }
-    { "(hashtable)" "hashtables.private" }
     { "<array>" "arrays" }
     { "begin-scan" "memory" }
     { "next-object" "memory" }
@@ -590,7 +608,6 @@ builtins get num-tags get tail f union-class define-class
     { "fclose" "io.streams.c" }
     { "<wrapper>" "kernel" }
     { "(clone)" "kernel" }
-    { "array>vector" "vectors.private" }
     { "<string>" "strings" }
     { "(>tuple)" "tuples.private" }
     { "array>quotation" "quotations.private" }
@@ -610,6 +627,9 @@ builtins get num-tags get tail f union-class define-class
     { "set-innermost-frame-quot" "kernel.private" }
     { "call-clear" "kernel" }
     { "(os-envs)" "system" }
+    { "resize-byte-array" "byte-arrays" }
+    { "resize-bit-array" "bit-arrays" }
+    { "resize-float-array" "float-arrays" }
 }
 dup length [ >r first2 r> make-primitive ] 2each
 

core/bootstrap/syntax.factor

@@ -16,12 +16,15 @@ f swap set-vocab-source-loaded?
     ";"
     "<PRIVATE"
     "?{"
+    "?V{"
     "BIN:"
     "B{"
+    "BV{"
     "C:"
     "CHAR:"
     "DEFER:"
     "F{"
+    "FV{"
     "FORGET:"
     "GENERIC#"
     "GENERIC:"

core/byte-arrays/byte-arrays-tests.factor

@@ -0,0 +1,8 @@
+IN: temporary
+USING: tools.test byte-arrays ;
+
+[ B{ 1 2 3 0 0 0 } ] [ 6 B{ 1 2 3 } resize-byte-array ] unit-test
+
+[ B{ 1 2 } ] [ 2 B{ 1 2 3 4 5 6 7 8 9 } resize-byte-array ] unit-test
+
+[ -10 B{ } resize-byte-array ] unit-test-fails

core/byte-arrays/byte-arrays.factor

@@ -15,6 +15,9 @@ M: byte-array new drop <byte-array> ;
 M: byte-array equal?
     over byte-array? [ sequence= ] [ 2drop f ] if ;
 
+M: byte-array resize
+    resize-byte-array ;
+
 INSTANCE: byte-array sequence
 INSTANCE: byte-array simple-c-ptr
 INSTANCE: byte-array c-ptr

core/byte-vectors/byte-vectors-docs.factor

@@ -0,0 +1,34 @@
+USING: arrays byte-arrays help.markup help.syntax kernel
+byte-vectors.private combinators ;
+IN: byte-vectors
+
+ARTICLE: "byte-vectors" "Byte vectors"
+"A byte vector is a resizable mutable sequence of unsigned bytes. The literal syntax is covered in " { $link "syntax-byte-vectors" } ". Byte vector words are found in the " { $vocab-link "byte-vectors" } " vocabulary."
+$nl
+"Byte vectors form a class:"
+{ $subsection byte-vector }
+{ $subsection byte-vector? }
+"Creating byte vectors:"
+{ $subsection >byte-vector }
+{ $subsection <byte-vector> }
+"If you don't care about initial capacity, a more elegant way to create a new byte vector is to write:"
+{ $code "BV{ } clone" } ;
+
+ABOUT: "byte-vectors"
+
+HELP: byte-vector
+{ $description "The class of resizable byte vectors. See " { $link "syntax-byte-vectors" } " for syntax and " { $link "byte-vectors" } " for general information." } ;
+
+HELP: <byte-vector>
+{ $values { "n" "a positive integer specifying initial capacity" } { "byte-vector" byte-vector } }
+{ $description "Creates a new byte vector that can hold " { $snippet "n" } " bytes before resizing." } ;
+
+HELP: >byte-vector
+{ $values { "seq" "a sequence" } { "byte-vector" byte-vector } }
+{ $description "Outputs a freshly-allocated byte vector with the same elements as a given sequence." }
+{ $errors "Throws an error if the sequence contains elements other than integers." } ;
+
+HELP: byte-array>vector
+{ $values { "byte-array" "an array" } { "length" "a non-negative integer" } { "byte-vector" byte-vector } }
+{ $description "Creates a new byte vector using the array for underlying storage with the specified initial length." }
+{ $warning "This word is in the " { $vocab-link "byte-vectors.private" } " vocabulary because it does not perform type or bounds checks. User code should call " { $link >byte-vector } " instead." } ;

core/byte-vectors/byte-vectors-tests.factor

@@ -0,0 +1,14 @@
+IN: temporary
+USING: tools.test byte-vectors vectors sequences kernel ;
+
+[ 0 ] [ 123 <byte-vector> length ] unit-test
+
+: do-it
+    123 [ over push ] each ;
+
+[ t ] [
+    3 <byte-vector> do-it
+    3 <vector> do-it sequence=
+] unit-test
+
+[ t ] [ BV{ } byte-vector? ] unit-test

core/byte-vectors/byte-vectors.factor

@@ -0,0 +1,33 @@
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: arrays kernel kernel.private math sequences
+sequences.private growable byte-arrays ;
+IN: byte-vectors
+
+<PRIVATE
+
+: byte-array>vector ( byte-array capacity -- byte-vector )
+    byte-vector construct-boa ; inline
+
+PRIVATE>
+
+: <byte-vector> ( n -- byte-vector )
+    <byte-array> 0 byte-array>vector ; inline
+
+: >byte-vector ( seq -- byte-vector ) BV{ } clone-like ;
+
+M: byte-vector like
+    drop dup byte-vector? [
+        dup byte-array?
+        [ dup length byte-array>vector ] [ >byte-vector ] if
+    ] unless ;
+
+M: byte-vector new
+    drop [ <byte-array> ] keep >fixnum byte-array>vector ;
+
+M: byte-vector equal?
+    over byte-vector? [ sequence= ] [ 2drop f ] if ;
+
+M: byte-array new-resizable drop <byte-vector> ;
+
+INSTANCE: byte-vector growable

core/cpu/architecture/tags.txt

@@ -0,0 +1 @@
+compiler

core/cpu/arm/intrinsics/intrinsics.factor

@@ -383,41 +383,6 @@ IN: cpu.arm.intrinsics
     { +output+ { "out" } }
 } define-intrinsic
 
-\ (hashtable) [
-    hashtable 4 cells %allot
-    R12 f v>operand MOV
-    R12 1 %set-slot
-    R12 2 %set-slot
-    R12 3 %set-slot
-    ! Store tagged ptr in reg
-    "out" get object %store-tagged
-] H{
-    { +scratch+ { { f "out" } } }
-    { +output+ { "out" } }
-} define-intrinsic
-
-\ string>sbuf [
-    sbuf 3 cells %allot
-    "length" operand 1 %set-slot
-    "string" operand 2 %set-slot
-    "out" get object %store-tagged
-] H{
-    { +input+ { { f "string" } { f "length" } } }
-    { +scratch+ { { f "out" } } }
-    { +output+ { "out" } }
-} define-intrinsic
-
-\ array>vector [
-    vector 3 cells %allot
-    "length" operand 1 %set-slot
-    "array" operand 2 %set-slot
-    "out" get object %store-tagged
-] H{
-    { +input+ { { f "array" } { f "length" } } }
-    { +scratch+ { { f "out" } } }
-    { +output+ { "out" } }
-} define-intrinsic
-
 ! Alien intrinsics
 : %alien-accessor ( quot -- )
     "offset" operand dup %untag-fixnum

core/cpu/arm/tags.txt

@@ -0,0 +1 @@
+compiler

core/cpu/ppc/intrinsics/intrinsics.factor

@@ -586,43 +586,6 @@ IN: cpu.ppc.intrinsics
     { +output+ { "wrapper" } }
 } define-intrinsic
 
-\ (hashtable) [
-    hashtable 4 cells %allot
-    f v>operand 12 LI
-    12 11 1 cells STW
-    12 11 2 cells STW
-    12 11 3 cells STW
-    ! Store tagged ptr in reg
-    "hashtable" get object %store-tagged
-] H{
-    { +scratch+ { { f "hashtable" } } }
-    { +output+ { "hashtable" } }
-} define-intrinsic
-
-\ string>sbuf [
-    sbuf 3 cells %allot
-    "length" operand 11 1 cells STW
-    "string" operand 11 2 cells STW
-    ! Store tagged ptr in reg
-    "sbuf" get object %store-tagged
-] H{
-    { +input+ { { f "string" } { f "length" } } }
-    { +scratch+ { { f "sbuf" } } }
-    { +output+ { "sbuf" } }
-} define-intrinsic
-
-\ array>vector [
-    vector 3 cells %allot
-    "length" operand 11 1 cells STW
-    "array" operand 11 2 cells STW
-    ! Store tagged ptr in reg
-    "vector" get object %store-tagged
-] H{
-    { +input+ { { f "array" } { f "length" } } }
-    { +scratch+ { { f "vector" } } }
-    { +output+ { "vector" } }
-} define-intrinsic
-
 ! Alien intrinsics
 : %alien-accessor ( quot -- )
     "offset" operand dup %untag-fixnum

core/cpu/ppc/tags.txt

@@ -0,0 +1 @@
+compiler

core/cpu/x86/32/tags.txt

@@ -0,0 +1 @@
+compiler

core/cpu/x86/64/tags.txt

@@ -0,0 +1 @@
+compiler

core/cpu/x86/intrinsics/intrinsics.factor

@@ -447,45 +447,6 @@ IN: cpu.x86.intrinsics
     { +output+ { "wrapper" } }
 } define-intrinsic
 
-\ (hashtable) [
-    hashtable 4 cells [
-        1 object@ f v>operand MOV
-        2 object@ f v>operand MOV
-        3 object@ f v>operand MOV
-        ! Store tagged ptr in reg
-        "hashtable" get object %store-tagged
-    ] %allot
-] H{
-    { +scratch+ { { f "hashtable" } } }
-    { +output+ { "hashtable" } }
-} define-intrinsic
-
-\ string>sbuf [
-    sbuf 3 cells [
-        1 object@ "length" operand MOV
-        2 object@ "string" operand MOV
-        ! Store tagged ptr in reg
-        "sbuf" get object %store-tagged
-    ] %allot
-] H{
-    { +input+ { { f "string" } { f "length" } } }
-    { +scratch+ { { f "sbuf" } } }
-    { +output+ { "sbuf" } }
-} define-intrinsic
-
-\ array>vector [
-    vector 3 cells [
-        1 object@ "length" operand MOV
-        2 object@ "array" operand MOV
-        ! Store tagged ptr in reg
-        "vector" get object %store-tagged
-    ] %allot
-] H{
-    { +input+ { { f "array" } { f "length" } } }
-    { +scratch+ { { f "vector" } } }
-    { +output+ { "vector" } }
-} define-intrinsic
-
 ! Alien intrinsics
 : %alien-accessor ( quot -- )
     "offset" operand %untag-fixnum

core/float-arrays/float-arrays-tests.factor

@@ -2,3 +2,9 @@ IN: temporary
 USING: float-arrays tools.test ;
 
 [ F{ 1.0 1.0 1.0 } ] [ 3 1.0 <float-array> ] unit-test
+
+[ F{ 1 2 3 0 0 0 } ] [ 6 F{ 1 2 3 } resize-float-array ] unit-test
+
+[ F{ 1 2 } ] [ 2 F{ 1 2 3 4 5 6 7 8 9 } resize-float-array ] unit-test
+
+[ -10 F{ } resize-float-array ] unit-test-fails

core/float-arrays/float-arrays.factor

@@ -29,6 +29,9 @@ M: float-array new drop 0.0 <float-array> ;
 M: float-array equal?
     over float-array? [ sequence= ] [ 2drop f ] if ;
 
+M: float-array resize
+    resize-float-array ;
+
 INSTANCE: float-array sequence
 INSTANCE: float-array simple-c-ptr
 INSTANCE: float-array c-ptr

core/float-vectors/float-vectors-docs.factor

@@ -0,0 +1,34 @@
+USING: arrays float-arrays help.markup help.syntax kernel
+float-vectors.private combinators ;
+IN: float-vectors
+
+ARTICLE: "float-vectors" "Float vectors"
+"A float vector is a resizable mutable sequence of unsigned floats. The literal syntax is covered in " { $link "syntax-float-vectors" } ". Float vector words are found in the " { $vocab-link "float-vectors" } " vocabulary."
+$nl
+"Float vectors form a class:"
+{ $subsection float-vector }
+{ $subsection float-vector? }
+"Creating float vectors:"
+{ $subsection >float-vector }
+{ $subsection <float-vector> }
+"If you don't care about initial capacity, a more elegant way to create a new float vector is to write:"
+{ $code "BV{ } clone" } ;
+
+ABOUT: "float-vectors"
+
+HELP: float-vector
+{ $description "The class of resizable float vectors. See " { $link "syntax-float-vectors" } " for syntax and " { $link "float-vectors" } " for general information." } ;
+
+HELP: <float-vector>
+{ $values { "n" "a positive integer specifying initial capacity" } { "float-vector" float-vector } }
+{ $description "Creates a new float vector that can hold " { $snippet "n" } " floats before resizing." } ;
+
+HELP: >float-vector
+{ $values { "seq" "a sequence" } { "float-vector" float-vector } }
+{ $description "Outputs a freshly-allocated float vector with the same elements as a given sequence." }
+{ $errors "Throws an error if the sequence contains elements other than real numbers." } ;
+
+HELP: float-array>vector
+{ $values { "float-array" "an array" } { "length" "a non-negative integer" } { "float-vector" float-vector } }
+{ $description "Creates a new float vector using the array for underlying storage with the specified initial length." }
+{ $warning "This word is in the " { $vocab-link "float-vectors.private" } " vocabulary because it does not perform type or bounds checks. User code should call " { $link >float-vector } " instead." } ;

core/float-vectors/float-vectors-tests.factor

@@ -0,0 +1,14 @@
+IN: temporary
+USING: tools.test float-vectors vectors sequences kernel ;
+
+[ 0 ] [ 123 <float-vector> length ] unit-test
+
+: do-it
+    12345 [ over push ] each ;
+
+[ t ] [
+    3 <float-vector> do-it
+    3 <vector> do-it sequence=
+] unit-test
+
+[ t ] [ FV{ } float-vector? ] unit-test

core/float-vectors/float-vectors.factor

@@ -0,0 +1,33 @@
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: arrays kernel kernel.private math sequences
+sequences.private growable float-arrays ;
+IN: float-vectors
+
+<PRIVATE
+
+: float-array>vector ( float-array length -- float-vector )
+    float-vector construct-boa ; inline
+
+PRIVATE>
+
+: <float-vector> ( n -- float-vector )
+    0.0 <float-array> 0 float-array>vector ; inline
+
+: >float-vector ( seq -- float-vector ) FV{ } clone-like ;
+
+M: float-vector like
+    drop dup float-vector? [
+        dup float-array?
+        [ dup length float-array>vector ] [ >float-vector ] if
+    ] unless ;
+
+M: float-vector new
+    drop [ 0.0 <float-array> ] keep >fixnum float-array>vector ;
+
+M: float-vector equal?
+    over float-vector? [ sequence= ] [ 2drop f ] if ;
+
+M: float-array new-resizable drop <float-vector> ;
+
+INSTANCE: float-vector growable

core/hashtables/hashtables-docs.factor

@@ -116,10 +116,6 @@ HELP: <hashtable>
 { $values { "n" "a positive integer specifying hashtable capacity" } { "hash" "a new hashtable" } }
 { $description "Create a new hashtable capable of storing " { $snippet "n" } " key/value pairs before growing." } ;
 
-HELP: (hashtable) ( -- hash )
-{ $values { "hash" "a new hashtable" } }
-{ $description "Allocates a hashtable stub object without an underlying array. User code should call " { $link <hashtable> } " instead." } ;
-
 HELP: associate
 { $values { "value" "a value" } { "key" "a key" } { "hash" "a new " { $link hashtable } } }
 { $description "Create a new hashtable holding one key/value pair." } ;

core/hashtables/hashtables.factor

@@ -122,7 +122,7 @@ IN: hashtables
 PRIVATE>
 
 : <hashtable> ( n -- hash )
-    (hashtable) [ reset-hash ] keep ;
+    hashtable construct-empty [ reset-hash ] keep ;
 
 M: hashtable at* ( key hash -- value ? )
     key@ [ 3 fixnum+fast slot t ] [ 2drop f f ] if ;

core/inference/known-words/known-words.factor

@@ -167,9 +167,6 @@ t over set-effect-terminated?
 
 \ rehash-string { string } { } <effect> "inferred-effect" set-word-prop
 
-\ string>sbuf { string integer } { sbuf } <effect> "inferred-effect" set-word-prop
-\ string>sbuf make-flushable
-
 \ bignum>fixnum { bignum } { fixnum } <effect> "inferred-effect" set-word-prop
 \ bignum>fixnum make-foldable
 
@@ -491,12 +488,18 @@ t over set-effect-terminated?
 \ resize-array { integer array } { array } <effect> "inferred-effect" set-word-prop
 \ resize-array make-flushable
 
+\ resize-byte-array { integer byte-array } { byte-array } <effect> "inferred-effect" set-word-prop
+\ resize-byte-array make-flushable
+
+\ resize-bit-array { integer bit-array } { bit-array } <effect> "inferred-effect" set-word-prop
+\ resize-bit-array make-flushable
+
+\ resize-float-array { integer float-array } { float-array } <effect> "inferred-effect" set-word-prop
+\ resize-float-array make-flushable
+
 \ resize-string { integer string } { string } <effect> "inferred-effect" set-word-prop
 \ resize-string make-flushable
 
-\ (hashtable) { } { hashtable } <effect> "inferred-effect" set-word-prop
-\ (hashtable) make-flushable
-
 \ <array> { integer object } { array } <effect> "inferred-effect" set-word-prop
 \ <array> make-flushable
 
@@ -532,9 +535,6 @@ t over set-effect-terminated?
 \ (clone) { object } { object } <effect> "inferred-effect" set-word-prop
 \ (clone) make-flushable
 
-\ array>vector { array integer } { vector } <effect> "inferred-effect" set-word-prop
-\ array>vector make-flushable
-
 \ <string> { integer integer } { string } <effect> "inferred-effect" set-word-prop
 \ <string> make-flushable
 

core/prettyprint/backend/backend.factor

@@ -1,9 +1,10 @@
-! Copyright (C) 2003, 2007 Slava Pestov.
+! Copyright (C) 2003, 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: arrays byte-arrays bit-arrays generic hashtables io
+USING: arrays byte-arrays byte-vectors bit-arrays bit-vectors
-assocs kernel math namespaces sequences strings sbufs io.styles
+generic hashtables io assocs kernel math namespaces sequences
-vectors words prettyprint.config prettyprint.sections quotations
+strings sbufs io.styles vectors words prettyprint.config
-io io.files math.parser effects tuples classes float-arrays ;
+prettyprint.sections quotations io io.files math.parser effects
+tuples classes float-arrays float-vectors ;
 IN: prettyprint.backend
 
 GENERIC: pprint* ( obj -- )
@@ -143,8 +144,11 @@ M: quotation pprint-delims drop \ [ \ ] ;
 M: curry pprint-delims drop \ [ \ ] ;
 M: array pprint-delims drop \ { \ } ;
 M: byte-array pprint-delims drop \ B{ \ } ;
+M: byte-vector pprint-delims drop \ BV{ \ } ;
 M: bit-array pprint-delims drop \ ?{ \ } ;
+M: bit-vector pprint-delims drop \ ?V{ \ } ;
 M: float-array pprint-delims drop \ F{ \ } ;
+M: float-vector pprint-delims drop \ FV{ \ } ;
 M: vector pprint-delims drop \ V{ \ } ;
 M: hashtable pprint-delims drop \ H{ \ } ;
 M: tuple pprint-delims drop \ T{ \ } ;
@@ -155,6 +159,10 @@ GENERIC: >pprint-sequence ( obj -- seq )
 
 M: object >pprint-sequence ;
 
+M: vector >pprint-sequence ;
+M: bit-vector >pprint-sequence ;
+M: byte-vector >pprint-sequence ;
+M: float-vector >pprint-sequence ;
 M: hashtable >pprint-sequence >alist ;
 M: tuple >pprint-sequence tuple>array ;
 M: wrapper >pprint-sequence wrapped 1array ;

core/sbufs/sbufs.factor

@@ -1,9 +1,16 @@
 ! Copyright (C) 2004, 2007 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: kernel math strings kernel.private sequences.private
+USING: kernel math strings sequences.private sequences strings
-sequences strings growable strings.private sbufs.private ;
+growable strings.private ;
 IN: sbufs
 
+<PRIVATE
+
+: string>sbuf ( string length -- sbuf )
+    sbuf construct-boa ; inline
+
+PRIVATE>
+
 : <sbuf> ( n -- sbuf ) 0 <string> 0 string>sbuf ; inline
 
 M: sbuf set-nth-unsafe

core/slots/slots.factor

@@ -1,8 +1,8 @@
-! Copyright (C) 2005, 2007 Slava Pestov.
+! Copyright (C) 2005, 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: arrays kernel kernel.private math namespaces
 sequences strings words effects generic generic.standard
-classes slots.private ;
+classes slots.private combinators ;
 IN: slots
 
 TUPLE: slot-spec type name offset reader writer ;
@@ -87,14 +87,23 @@ PREDICATE: word slot-writer "writing" word-prop >boolean ;
 : simple-writer-word ( class name -- word )
     (simple-slot-word) writer-word ;
 
-: simple-slot ( class name # -- spec )
+: short-slot ( class name # -- spec )
     >r object bootstrap-word over r> f f <slot-spec>
     2over simple-reader-word over set-slot-spec-reader
     -rot simple-writer-word over set-slot-spec-writer ;
 
+: long-slot ( spec # -- spec )
+    >r [ dup array? [ first2 create ] when ] map first4 r>
+    -rot <slot-spec> ;
+
 : simple-slots ( class slots base -- specs )
-    over length [ + ] with map
+    over length [ + ] with map [
-    [ >r >r dup r> r> simple-slot ] 2map nip ;
+        {
+            { [ over not ] [ 2drop f ] }
+            { [ over string? ] [ >r dupd r> short-slot ] }
+            { [ over array? ] [ long-slot ] }
+        } cond
+    ] 2map [ ] subset nip ;
 
 : slot-of-reader ( reader specs -- spec/f )
     [ slot-spec-reader eq? ] with find nip ;

core/syntax/syntax-docs.factor

@@ -151,6 +151,18 @@ ARTICLE: "syntax-byte-arrays" "Byte array syntax"
 { $subsection POSTPONE: B{ }
 "Byte arrays are documented in " { $link "byte-arrays" } "." ;
 
+ARTICLE: "syntax-bit-vectors" "Bit vector syntax"
+{ $subsection POSTPONE: ?V{ }
+"Bit vectors are documented in " { $link "bit-vectors" } "." ;
+
+ARTICLE: "syntax-float-vectors" "Float vector syntax"
+{ $subsection POSTPONE: FV{ }
+"Float vectors are documented in " { $link "float-vectors" } "." ;
+
+ARTICLE: "syntax-byte-vectors" "Byte vector syntax"
+{ $subsection POSTPONE: BV{ }
+"Byte vectors are documented in " { $link "byte-vectors" } "." ;
+
 ARTICLE: "syntax-pathnames" "Pathname syntax"
 { $subsection POSTPONE: P" }
 "Pathnames are documented in " { $link "file-streams" } "." ;
@@ -165,11 +177,15 @@ $nl
 { $subsection "syntax-words" }
 { $subsection "syntax-quots" }
 { $subsection "syntax-arrays" }
-{ $subsection "syntax-vectors" }
 { $subsection "syntax-strings" }
-{ $subsection "syntax-sbufs" }
-{ $subsection "syntax-byte-arrays" }
 { $subsection "syntax-bit-arrays" }
+{ $subsection "syntax-byte-arrays" }
+{ $subsection "syntax-float-arrays" }
+{ $subsection "syntax-vectors" }
+{ $subsection "syntax-sbufs" }
+{ $subsection "syntax-bit-vectors" }
+{ $subsection "syntax-byte-vectors" }
+{ $subsection "syntax-float-vectors" }
 { $subsection "syntax-hashtables" }
 { $subsection "syntax-tuples" }
 { $subsection "syntax-pathnames" } ;
@@ -273,12 +289,30 @@ HELP: B{
 { $description "Marks the beginning of a literal byte array. Literal byte arrays are terminated by " { $link POSTPONE: } } "." } 
 { $examples { $code "B{ 1 2 3 }" } } ;
 
+HELP: BV{
+{ $syntax "BV{ elements... }" }
+{ $values { "elements" "a list of bytes" } }
+{ $description "Marks the beginning of a literal byte vector. Literal byte vectors are terminated by " { $link POSTPONE: } } "." } 
+{ $examples { $code "BV{ 1 2 3 12 }" } } ;
+
 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: ?V{
+{ $syntax "?V{ elements... }" }
+{ $values { "elements" "a list of booleans" } }
+{ $description "Marks the beginning of a literal bit vector. Literal bit vectors are terminated by " { $link POSTPONE: } } "." } 
+{ $examples { $code "?V{ t f t }" } } ;
+
+HELP: FV{
+{ $syntax "FV{ elements... }" }
+{ $values { "elements" "a list of real numbers" } }
+{ $description "Marks the beginning of a literal float vector. Literal float vectors are terminated by " { $link POSTPONE: } } "." } 
+{ $examples { $code "FV{ 1.0 2.0 3.0 }" } } ;
+
 HELP: F{
 { $syntax "F{ elements... }" }
 { $values { "elements" "a list of real numbers" } }

core/syntax/syntax.factor

@@ -1,11 +1,11 @@
-! Copyright (C) 2004, 2007 Slava Pestov.
+! Copyright (C) 2004, 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: alien arrays bit-arrays byte-arrays definitions generic
+USING: alien arrays bit-arrays bit-vectors byte-arrays
-hashtables kernel math namespaces parser sequences strings sbufs
+byte-vectors definitions generic hashtables kernel math
-vectors words quotations io assocs splitting tuples
+namespaces parser sequences strings sbufs vectors words
-generic.standard generic.math classes io.files vocabs
+quotations io assocs splitting tuples generic.standard
-float-arrays classes.union classes.mixin classes.predicate
+generic.math classes io.files vocabs float-arrays float-vectors
-compiler.units ;
+classes.union classes.mixin classes.predicate compiler.units ;
 IN: bootstrap.syntax
 
 ! These words are defined as a top-level form, instead of with
@@ -71,8 +71,11 @@ IN: bootstrap.syntax
     "{" [ \ } [ >array ] parse-literal ] define-syntax
     "V{" [ \ } [ >vector ] parse-literal ] define-syntax
     "B{" [ \ } [ >byte-array ] parse-literal ] define-syntax
+    "BV{" [ \ } [ >byte-vector ] parse-literal ] define-syntax
     "?{" [ \ } [ >bit-array ] parse-literal ] define-syntax
+    "?V{" [ \ } [ >bit-vector ] parse-literal ] define-syntax
     "F{" [ \ } [ >float-array ] parse-literal ] define-syntax
+    "FV{" [ \ } [ >float-vector ] parse-literal ] define-syntax
     "H{" [ \ } [ >hashtable ] parse-literal ] define-syntax
     "T{" [ \ } [ >tuple ] parse-literal ] define-syntax
     "W{" [ \ } [ first <wrapper> ] parse-literal ] define-syntax

core/tuples/tuples.factor

@@ -80,8 +80,8 @@ PRIVATE>
     } ;
 
 : define-tuple-slots ( class slots -- )
-    2dup "slot-names" set-word-prop
     dupd 4 simple-slots
+    2dup [ slot-spec-name ] map "slot-names" set-word-prop
     2dup delegate-slot-spec add* "slots" set-word-prop
     define-slots ;
 

core/vectors/vectors-docs.factor

@@ -30,10 +30,10 @@ HELP: >vector
 { $values { "seq" "a sequence" } { "vector" vector } }
 { $description "Outputs a freshly-allocated vector with the same elements as a given sequence." } ;
 
-HELP: array>vector ( array length -- vector )
+HELP: array>vector
 { $values { "array" "an array" } { "length" "a non-negative integer" } { "vector" vector } }
 { $description "Creates a new vector using the array for underlying storage with the specified initial length." }
-{ $warning "This word is in the " { $vocab-link "sequences.private" } " vocabulary because it does not perform type or bounds checks. User code should call " { $link >vector } " instead." } ;
+{ $warning "This word is in the " { $vocab-link "vectors.private" } " vocabulary because it does not perform type or bounds checks. User code should call " { $link >vector } " instead." } ;
 
 HELP: 1vector
 { $values { "x" object } { "vector" vector } }

core/vectors/vectors.factor

@@ -1,10 +1,15 @@
-! Copyright (C) 2004, 2007 Slava Pestov.
+! Copyright (C) 2004, 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: arrays kernel kernel.private math
+USING: arrays kernel math sequences sequences.private growable ;
-math.private sequences sequences.private vectors.private
-growable ;
 IN: vectors
 
+<PRIVATE
+
+: array>vector ( byte-array capacity -- byte-vector )
+    vector construct-boa ; inline
+
+PRIVATE>
+
 : <vector> ( n -- vector ) f <array> 0 array>vector ; inline
 
 : >vector ( seq -- vector ) V{ } clone-like ;

core/vocabs/loader/loader.factor

@@ -148,8 +148,16 @@ SYMBOL: load-help?
     dup update-roots
     dup modified-sources swap modified-docs ;
 
+: require-restart { { "Ignore this vocabulary" t } } ;
+
 : require-all ( seq -- )
-    [ [ require ] each ] with-compiler-errors ;
+    [
+        [
+            [ require ]
+            [ require-restart rethrow-restarts 2drop ]
+            recover
+        ] each
+    ] with-compiler-errors ;
 
 : do-refresh ( modified-sources modified-docs -- )
     2dup

extra/benchmark/bootstrap2/bootstrap2.factor

@@ -1,9 +1,14 @@
-USING: tools.deploy.private io.files system
+USING: io.files io.launcher system tools.deploy.backend
-tools.deploy.backend ;
+namespaces sequences kernel ;
 IN: benchmark.bootstrap2
 
 : bootstrap-benchmark
     "." resource-path cd
-    vm { "-output-image=foo.image" "-no-user-init" } stage2 ;
+    [
+        vm ,
+        "-i=" boot-image-name append ,
+        "-output-image=foo.image" ,
+        "-no-user-init" ,
+    ] { } make run-process drop ;
 
 MAIN: bootstrap-benchmark

extra/boids/ui/ui.factor

@@ -145,20 +145,20 @@ VARS: population-label cohesion-label alignment-label separation-label ;
   slate> over @center grid-add
 
   H{ } clone
-    T{ key-down f f "1" } C[ drop randomize    ] put-hash
+    T{ key-down f f "1" } C[ drop randomize    ] put-at
-    T{ key-down f f "2" } C[ drop sub-10-boids ] put-hash
+    T{ key-down f f "2" } C[ drop sub-10-boids ] put-at
-    T{ key-down f f "3" } C[ drop add-10-boids ] put-hash
+    T{ key-down f f "3" } C[ drop add-10-boids ] put-at
 
-    T{ key-down f f "q" } C[ drop inc-cohesion-weight ] put-hash
+    T{ key-down f f "q" } C[ drop inc-cohesion-weight ] put-at
-    T{ key-down f f "a" } C[ drop dec-cohesion-weight ] put-hash
+    T{ key-down f f "a" } C[ drop dec-cohesion-weight ] put-at
 
-    T{ key-down f f "w" } C[ drop inc-alignment-weight ] put-hash
+    T{ key-down f f "w" } C[ drop inc-alignment-weight ] put-at
-    T{ key-down f f "s" } C[ drop dec-alignment-weight ] put-hash
+    T{ key-down f f "s" } C[ drop dec-alignment-weight ] put-at
 
-    T{ key-down f f "e" } C[ drop inc-separation-weight ] put-hash
+    T{ key-down f f "e" } C[ drop inc-separation-weight ] put-at
-    T{ key-down f f "d" } C[ drop dec-separation-weight ] put-hash
+    T{ key-down f f "d" } C[ drop dec-separation-weight ] put-at
 
-    T{ key-down f f "ESC" } C[ drop toggle-loop ] put-hash
+    T{ key-down f f "ESC" } C[ drop toggle-loop ] put-at
   <handler> tuck set-gadget-delegate "Boids" open-window ;
 
 : boids-window ( -- ) [ [ boids-window* ] with-scope ] with-ui ;

extra/hardware-info/windows/ce/ce.factor

@@ -1,8 +1,8 @@
-USING: alien.c-types hardware-info hardware-info.windows
+USING: alien.c-types hardware-info kernel math namespaces
-kernel math namespaces windows windows.kernel32
+windows windows.kernel32 hardware-info.backend ;
-hardware-info.backend ;
 IN: hardware-info.windows.ce
 
+TUPLE: wince ;
 T{ wince } os set-global
 
 : memory-status ( -- MEMORYSTATUS )
@@ -10,6 +10,8 @@ T{ wince } os set-global
     "MEMORYSTATUS" heap-size over set-MEMORYSTATUS-dwLength
     [ GlobalMemoryStatus ] keep ;
 
+M: wince cpus ( -- n ) 1 ;
+
 M: wince memory-load ( -- n )
     memory-status MEMORYSTATUS-dwMemoryLoad ;
 

extra/hardware-info/windows/nt/nt.factor

@@ -3,8 +3,16 @@ kernel libc math namespaces hardware-info.backend
 windows windows.advapi32 windows.kernel32 ;
 IN: hardware-info.windows.nt
 
+TUPLE: winnt ;
+
 T{ winnt } os set-global
 
+: system-info ( -- SYSTEM_INFO )
+    "SYSTEM_INFO" <c-object> [ GetSystemInfo ] keep ;
+
+M: winnt cpus ( -- n )
+    system-info SYSTEM_INFO-dwNumberOfProcessors ;
+
 : memory-status ( -- MEMORYSTATUSEX )
     "MEMORYSTATUSEX" <c-object>
     "MEMORYSTATUSEX" heap-size over set-MEMORYSTATUSEX-dwLength

extra/hardware-info/windows/windows.factor

@@ -4,17 +4,12 @@ hardware-info.windows.backend
 words combinators vocabs.loader hardware-info.backend ;
 IN: hardware-info.windows
 
-USE: system
-
 : system-info ( -- SYSTEM_INFO )
     "SYSTEM_INFO" <c-object> [ GetSystemInfo ] keep ;
 
 : page-size ( -- n )
     system-info SYSTEM_INFO-dwPageSize ;
 
-M: windows cpus ( -- n )
-    system-info SYSTEM_INFO-dwNumberOfProcessors ;
-
 ! 386, 486, 586, 2200 (IA64), 8664 (AMD_X8664)
 : processor-type ( -- n )
     system-info SYSTEM_INFO-dwProcessorType ;
@@ -68,8 +63,7 @@ M: windows cpus ( -- n )
 : system-windows-directory ( -- str )
     \ GetSystemWindowsDirectory get-directory ;
 
-<< {
+{
     { [ wince? ] [ "hardware-info.windows.ce" ] }
     { [ winnt? ] [ "hardware-info.windows.nt" ] }
-    { [ t ] [ f ] }
+} cond [ require ] when*
-} cond [ require ] when* >>

extra/help/handbook/handbook.factor

@@ -110,15 +110,21 @@ USE: io.buffers
 ARTICLE: "collections" "Collections" 
 { $heading "Sequences" }
 { $subsection "sequences" }
-"Sequence implementations:"
+"Fixed-length sequences:"
 { $subsection "arrays" }
-{ $subsection "vectors" }
+{ $subsection "quotations" }
+"Fixed-length specialized sequences:"
+{ $subsection "strings" }
 { $subsection "bit-arrays" }
 { $subsection "byte-arrays" }
 { $subsection "float-arrays" }
-{ $subsection "strings" }
+"Resizable sequence:"
+{ $subsection "vectors" }
+"Resizable specialized sequences:"
 { $subsection "sbufs" }
-{ $subsection "quotations" }
+{ $subsection "bit-vectors" }
+{ $subsection "byte-vectors" }
+{ $subsection "float-vectors" }
 { $heading "Associative mappings" }
 { $subsection "assocs" }
 { $subsection "namespaces" }

extra/io/unix/linux/linux.factor

@@ -2,14 +2,15 @@
 ! See http://factorcode.org/license.txt for BSD license.
 IN: io.unix.linux
 USING: io.backend io.unix.backend io.unix.launcher io.unix.select
-namespaces kernel assocs unix.process ;
+namespaces kernel assocs unix.process init ;
 
 TUPLE: linux-io ;
 
 INSTANCE: linux-io unix-io
 
 M: linux-io init-io ( -- )
-    <select-mx> mx set-global
+    <select-mx> mx set-global ;
-    start-wait-thread ;
 
 T{ linux-io } set-io-backend
+
+[ start-wait-thread ] "io.unix.linux" add-init-hook

extra/math/combinatorics/authors.txt

@@ -1,2 +1,3 @@
 Slava Pestov
 Doug Coleman
+Aaron Schaefer

extra/math/combinatorics/combinatorics-docs.factor

@@ -0,0 +1,49 @@
+USING: help.markup help.syntax kernel math sequences ;
+IN: math.combinatorics
+
+HELP: factorial
+{ $values { "n" "a non-negative integer" } { "n!" integer } }
+{ $description "Outputs the product of all positive integers less than or equal to " { $snippet "n" } "." }
+{ $examples { $example "4 factorial ." "24" } } ;
+
+HELP: nPk
+{ $values { "n" "a non-negative integer" } { "k" "a non-negative integer" } { "nPk" integer } }
+{ $description "Outputs the total number of unique permutations of size " { $snippet "k" } " (order does matter) that can be taken from a set of size " { $snippet "n" } "." }
+{ $examples { $example "10 4 nPk ." "5040" } } ;
+
+HELP: nCk
+{ $values { "n" "a non-negative integer" } { "k" "a non-negative integer" } { "nCk" integer } }
+{ $description "Outputs the total number of unique combinations of size " { $snippet "k" } " (order does not matter) that can be taken from a set of size " { $snippet "n" } ". Commonly written as \"n choose k\"." }
+{ $examples { $example "10 4 nCk ." "210" } } ;
+
+HELP: permutation
+{ $values { "n" "a non-negative integer" } { "seq" sequence } { "seq" sequence } }
+{ $description "Outputs the " { $snippet "nth" } " lexicographical permutation of " { $snippet "seq" } "." }
+{ $notes "Permutations are 0-based and a bounds error will be thrown if " { $snippet "n" } " is larger than " { $snippet "seq length factorial 1-" } "." }
+{ $examples { $example "1 3 permutation ." "{ 0 2 1 }" } { $example "5 { \"apple\" \"banana\" \"orange\" } permutation ." "{ \"orange\" \"banana\" \"apple\"}" } } ;
+
+HELP: all-permutations
+{ $values { "seq" sequence } { "seq" sequence } }
+{ $description "Outputs a sequence containing all permutations of " { $snippet "seq" } " in lexicographical order." }
+{ $examples { $example "3 all-permutations ." "{ { 0 1 2 } { 0 2 1 } { 1 0 2 } { 1 2 0 } { 2 0 1 } { 2 1 0 } }" } } ;
+
+HELP: inverse-permutation
+{ $values { "seq" sequence } { "permutation" sequence } }
+{ $description "Outputs a sequence of indices representing the lexicographical permutation of " { $snippet "seq" } "." }
+{ $notes "All items in " { $snippet "seq" } " must be comparable by " { $link <=> } "." }
+{ $examples { $example "\"dcba\" inverse-permutation ." "{ 3 2 1 0 }" } { $example "{ 12 56 34 78 } inverse-permutation ." "{ 0 2 1 3 }" } } ;
+
+
+IN: math.combinatorics.private
+
+HELP: factoradic
+{ $values { "n" integer } { "seq" sequence } }
+{ $description "Converts a positive integer " { $snippet "n" } " to factoradic form.  The factoradic of an integer is its representation based on a mixed radix numerical system that corresponds to the values of " { $snippet "n" } " factorial." }
+{ $examples { $example "859 factoradic ." "{ 1 1 0 3 0 1 0 }" } } ;
+
+HELP: >permutation
+{ $values { "factoradic" sequence } { "permutation" sequence } }
+{ $description "Converts an integer represented in factoradic form into its corresponding unique permutation (0-based)." }
+{ $notes "For clarification, the following two statements are equivalent:" { $code "10 factoradic >permutation" "{ 1 2 0 0 } >permutation" } }
+{ $examples { $example "{ 0 0 0 0 } >permutation ." "{ 0 1 2 3 }" } } ;
+

extra/math/combinatorics/combinatorics-tests.factor

@@ -0,0 +1,50 @@
+USING: math.combinatorics math.combinatorics.private tools.test ;
+IN: temporary
+
+[ { } ] [ 0 factoradic ] unit-test
+[ { 1 0 } ] [ 1 factoradic ] unit-test
+[ { 1 1 0 3 0 1 0 } ] [ 859 factoradic ] unit-test
+
+[ { 0 1 2 3 } ] [ { 0 0 0 0 } >permutation ] unit-test
+[ { 0 1 3 2 } ] [ { 0 0 1 0 } >permutation ] unit-test
+[ { 1 2 0 6 3 5 4 } ] [ { 1 1 0 3 0 1 0 } >permutation ] unit-test
+
+[ { 0 1 2 3 } ] [ 0 4 permutation-indices ] unit-test
+[ { 0 1 3 2 } ] [ 1 4 permutation-indices ] unit-test
+[ { 1 2 0 6 3 5 4 } ] [ 859 7 permutation-indices ] unit-test
+
+[ { "b" "d" } ] [ { "a" "b" "c" "d" } { 1 3 } reorder ] unit-test
+[ { "a" "b" "c" "d" } ] [ { "a" "b" "c" "d" } { 0 1 2 3 } reorder ] unit-test
+[ { "d" "c" "b" "a" } ] [ { "a" "b" "c" "d" } { 3 2 1 0 } reorder ] unit-test
+[ { "d" "a" "b" "c" } ] [ { "a" "b" "c" "d" } { 3 0 1 2 } reorder ] unit-test
+
+[ 1 ] [ 0 factorial ] unit-test
+[ 1 ] [ 1 factorial ] unit-test
+[ 3628800 ] [ 10 factorial ] unit-test
+
+[ 1 ] [ 3 0 nPk ] unit-test
+[ 6 ] [ 3 2 nPk ] unit-test
+[ 6 ] [ 3 3 nPk ] unit-test
+[ 0 ] [ 3 4 nPk ] unit-test
+[ 311875200 ] [ 52 5 nPk ] unit-test
+[ 672151459757865654763838640470031391460745878674027315200000000000 ] [ 52 47 nPk ] unit-test
+
+[ 1 ] [ 3 0 nCk ] unit-test
+[ 3 ] [ 3 2 nCk ] unit-test
+[ 1 ] [ 3 3 nCk ] unit-test
+[ 0 ] [ 3 4 nCk ] unit-test
+[ 2598960 ] [ 52 5 nCk ] unit-test
+[ 2598960 ] [ 52 47 nCk ] unit-test
+
+[ { "a" "b" "c" "d" } ] [ 0 { "a" "b" "c" "d" } permutation ] unit-test
+[ { "d" "c" "b" "a" } ] [ 23 { "a" "b" "c" "d" } permutation ] unit-test
+[ { "d" "a" "b" "c" } ] [ 18 { "a" "b" "c" "d" } permutation ] unit-test
+
+[ { { "a" "b" "c" } { "a" "c" "b" }
+    { "b" "a" "c" } { "b" "c" "a" }
+    { "c" "a" "b" } { "c" "b" "a" } } ] [ { "a" "b" "c" } all-permutations ] unit-test
+
+[ { 0 1 2 } ] [ { "a" "b" "c" } inverse-permutation ] unit-test
+[ { 2 1 0 } ] [ { "c" "b" "a" } inverse-permutation ] unit-test
+[ { 3 0 2 1 } ] [ { 12 45 34 2 } inverse-permutation ] unit-test
+

extra/math/combinatorics/combinatorics.factor

@@ -1,21 +1,53 @@
-USING: kernel math math.ranges math.vectors
+! Copyright (c) 2007, 2008 Slava Pestov, Doug Coleman, Aaron Schaefer.
-sequences sorting mirrors assocs ;
+! See http://factorcode.org/license.txt for BSD license.
+USING: assocs kernel math math.ranges mirrors namespaces sequences sorting ;
 IN: math.combinatorics
 
-: possible? 0 rot between? ; inline
+<PRIVATE
 
-: nPk ( n k -- n!/k! )
+: possible? ( n m -- ? )
-    2dup possible? [ [a,b) product ] [ 2drop 0 ] if ;
+    0 rot between? ; inline
 
-: factorial ( n -- n! ) 1 nPk ;
+: twiddle ( n k -- n k )
+    2dup - dupd > [ dupd - ] when ; inline
 
-: (nCk) ( n k -- nCk )
+! See this article for explanation of the factoradic-based permutation methodology:
-    [ nPk ] 2keep - factorial / ;
+!     http://msdn2.microsoft.com/en-us/library/aa302371.aspx
 
-: twiddle 2dup - dupd < [ dupd - ] when ; inline
+: factoradic ( n -- factoradic )
+    0 [ over 0 > ] [ 1+ [ /mod ] keep swap ] [ ] unfold reverse 2nip ;
+
+: (>permutation) ( seq n -- seq )
+    [ [ dupd >= [ 1+ ] when ] curry map ] keep add* ;
+
+: >permutation ( factoradic -- permutation )
+    reverse 1 cut [ (>permutation) ] each ;
+
+: permutation-indices ( n seq -- permutation )
+    length [ factoradic ] dip 0 pad-left >permutation ;
+
+: reorder ( seq indices -- seq )
+    [ [ over nth , ] each drop ] { } make ;
+
+PRIVATE>
+
+: factorial ( n -- n! )
+    1 [ 1+ * ] reduce ;
+
+: nPk ( n k -- nPk )
+    2dup possible? [ dupd - [a,b) product ] [ 2drop 0 ] if ;
 
 : nCk ( n k -- nCk )
-    2dup possible? [ twiddle (nCk) ] [ 2drop 0 ] if ;
+    twiddle [ nPk ] keep factorial / ;
 
-: inverse-permutation ( seq -- seq )
+: permutation ( n seq -- seq )
+    tuck permutation-indices reorder ;
+
+: all-permutations ( seq -- seq )
+    [
+        [ length factorial ] keep [ permutation , ] curry each
+    ] { } make ;
+
+: inverse-permutation ( seq -- permutation )
     <enum> >alist sort-values keys ;
+

extra/math/constants/constants.factor

@@ -4,6 +4,6 @@ IN: math.constants
 
 : e ( -- e ) 2.7182818284590452354 ; inline
 : gamma ( -- gamma ) 0.57721566490153286060 ; inline
-: pi ( -- pi ) 3.14159265358979323846 ; inline
 : phi ( -- phi ) 1.61803398874989484820 ; inline
+: pi ( -- pi ) 3.14159265358979323846 ; inline
 : epsilon ( -- epsilon ) 2.2204460492503131e-16 ; inline

extra/namespaces/lib/lib.factor

@@ -16,4 +16,4 @@ IN: namespaces.lib
 
 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 
-: set* ( val var -- ) namestack* set-hash-stack ;
+: set* ( val var -- ) namestack* set-assoc-stack ;

extra/project-euler/024/024.factor

@@ -1,6 +1,6 @@
 ! Copyright (c) 2008 Aaron Schaefer.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: kernel math math.parser math.ranges namespaces sequences ;
+USING: kernel math.combinatorics math.parser ;
 IN: project-euler.024
 
 ! http://projecteuler.net/index.php?section=problems&id=24
@@ -22,23 +22,6 @@ IN: project-euler.024
 ! SOLUTION
 ! --------
 
-<PRIVATE
-
-: (>permutation) ( seq n -- seq )
-    [ [ dupd >= [ 1+ ] when ] curry map ] keep add* ;
-
-PRIVATE>
-
-: >permutation ( factoradic -- permutation )
-    reverse 1 cut [ (>permutation) ] each ;
-
-: factoradic ( k order -- factoradic )
-    [ [1,b] [ 2dup mod , /i ] each ] { } make reverse nip ;
-
-: permutation ( k seq -- seq )
-    dup length swapd factoradic >permutation
-    [ [ dupd swap nth , ] each drop ] { } make ;
-
 : euler024 ( -- answer )
     999999 10 permutation 10 swap digits>integer ;
 

extra/project-euler/032/032.factor

@@ -1,7 +1,7 @@
 ! Copyright (c) 2008 Aaron Schaefer.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: combinators.lib hashtables kernel math math.combinatorics math.parser
-    math.ranges project-euler.common project-euler.024 sequences sorting ;
+    math.ranges project-euler.common sequences sorting ;
 IN: project-euler.032
 
 ! http://projecteuler.net/index.php?section=problems&id=32

extra/project-euler/033/033.factor

@@ -0,0 +1,55 @@
+! Copyright (c) 2008 Aaron Schaefer.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel math math.ranges project-euler.common sequences ;
+IN: project-euler.033
+
+! http://projecteuler.net/index.php?section=problems&id=33
+
+! DESCRIPTION
+! -----------
+
+! The fraction 49/98 is a curious fraction, as an inexperienced mathematician
+! in attempting to simplify it may incorrectly believe that 49/98 = 4/8, which
+! is correct, is obtained by cancelling the 9s.
+
+! We shall consider fractions like, 30/50 = 3/5, to be trivial examples.
+
+! There are exactly four non-trivial examples of this type of fraction, less
+! than one in value, and containing two digits in the numerator and
+! denominator.
+
+! If the product of these four fractions is given in its lowest common terms,
+! find the value of the denominator.
+
+
+! SOLUTION
+! --------
+
+! Through analysis, you only need to check fractions fitting the pattern ax/xb
+
+<PRIVATE
+
+: source-033 ( -- seq )
+    10 99 [a,b] dup cartesian-product [ first2 < ] subset ;
+
+: safe? ( ax xb -- ? )
+    [ 10 /mod ] 2apply -roll = rot zero? not and nip ;
+
+: ax/xb ( ax xb -- z/f )
+    2dup safe? [ [ 10 /mod ] 2apply 2nip / ] [ 2drop f ] if ;
+
+: curious? ( m n -- ? )
+    2dup / [ ax/xb ] dip = ;
+
+: curious-fractions ( seq -- seq )
+    [ first2 curious? ] subset [ first2 / ] map ;
+
+PRIVATE>
+
+: euler033 ( -- answer )
+    source-033 curious-fractions product denominator ;
+
+! [ euler033 ] 100 ave-time
+! 5 ms run / 0 ms GC ave time - 100 trials
+
+MAIN: euler033

extra/project-euler/034/034.factor

@@ -0,0 +1,47 @@
+! Copyright (c) 2008 Aaron Schaefer.
+! See http://factorcode.org/license.txt for BSD license.
+USING: combinators.lib kernel math.ranges project-euler.common sequences ;
+IN: project-euler.034
+
+! http://projecteuler.net/index.php?section=problems&id=34
+
+! DESCRIPTION
+! -----------
+
+! 145 is a curious number, as 1! + 4! + 5! = 1 + 24 + 120 = 145.
+
+! Find the sum of all numbers which are equal to the sum of the factorial of
+! their digits.
+
+! Note: as 1! = 1 and 2! = 2 are not sums they are not included.
+
+
+! SOLUTION
+! --------
+
+! We can reduce the upper bound a little by calculating 7 * 9! = 2540160, and
+! then reducing one of the 9! to 2! (since the 7th digit cannot exceed 2), so we
+! get 2! + 6 * 9! = 2177282 as an upper bound.
+
+! We can then take that one more step, and notice that the largest factorial
+! sum a 7 digit number starting with 21 or 20 is 2! + 1! + 5 * 9! or 1814403.
+! So there can't be any 7 digit solutions starting with 21 or 20, and therefore
+! our numbers must be less that 2000000.
+
+<PRIVATE
+
+: digit-factorial ( n -- n! )
+    { 1 1 2 6 24 120 720 5040 40320 362880 } nth ;
+
+: factorion? ( n -- ? )
+    dup number>digits [ digit-factorial ] sigma = ;
+
+PRIVATE>
+
+: euler034 ( -- answer )
+    3 2000000 [a,b] [ factorion? ] subset sum ;
+
+! [ euler034 ] 10 ave-time
+! 15089 ms run / 725 ms GC ave time - 10 trials
+
+MAIN: euler034

extra/project-euler/035/035.factor

@@ -0,0 +1,61 @@
+! Copyright (c) 2008 Aaron Schaefer.
+! See http://factorcode.org/license.txt for BSD license.
+USING: combinators.lib kernel math math.combinatorics math.parser math.primes
+    project-euler.common sequences ;
+IN: project-euler.035
+
+! http://projecteuler.net/index.php?section=problems&id=35
+
+! DESCRIPTION
+! -----------
+
+! The number, 197, is called a circular prime because all rotations of the
+! digits: 197, 971, and 719, are themselves prime.
+
+! There are thirteen such primes below 100:
+!     2, 3, 5, 7, 11, 13, 17, 31, 37, 71, 73, 79, and 97.
+
+! How many circular primes are there below one million?
+
+
+! SOLUTION
+! --------
+
+<PRIVATE
+
+: source-035 ( -- seq )
+    1000000 primes-upto [ number>digits ] map ;
+
+: possible? ( seq -- ? )
+    dup length 1 > [
+        dup { 0 2 4 5 6 8 } swap seq-diff =
+    ] [
+        drop t
+    ] if ;
+
+: rotate ( seq n -- seq )
+    cut* swap append ;
+
+: (circular?) ( seq n -- ? )
+    dup 0 > [
+        2dup rotate 10 swap digits>integer
+        prime? [ 1- (circular?) ] [ 2drop f ] if
+    ] [
+        2drop t
+    ] if ;
+
+: circular? ( seq -- ? )
+    dup length 1- (circular?) ;
+
+PRIVATE>
+
+: euler035 ( -- answer )
+    source-035 [ possible? ] subset [ circular? ] count ;
+
+! [ euler035 ] 100 ave-time
+! 904 ms run / 86 ms GC ave time - 100 trials
+
+! TODO: try using bit arrays or other methods outlined here:
+!     http://home.comcast.net/~babdulbaki/Circular_Primes.html
+
+MAIN: euler035

extra/project-euler/036/036.factor

@@ -0,0 +1,42 @@
+! Copyright (c) 2008 Aaron Schaefer.
+! See http://factorcode.org/license.txt for BSD license.
+USING: combinators.lib kernel math.parser math.ranges sequences ;
+IN: project-euler.036
+
+! http://projecteuler.net/index.php?section=problems&id=36
+
+! DESCRIPTION
+! -----------
+
+! The decimal number, 585 = 1001001001 (binary), is palindromic in both bases.
+
+! Find the sum of all numbers, less than one million, which are palindromic in
+! base 10 and base 2.
+
+! (Please note that the palindromic number, in either base, may not include
+! leading zeros.)
+
+
+! SOLUTION
+! --------
+
+! Only check odd numbers since the binary number must begin and end with 1
+
+<PRIVATE
+
+: palindrome? ( str -- ? )
+    dup reverse = ;
+
+: both-bases? ( n -- ? )
+    { [ dup number>string palindrome? ]
+      [ dup >bin palindrome? ] } && nip ;
+
+PRIVATE>
+
+: euler036 ( -- answer )
+    1 1000000 2 <range> [ both-bases? ] subset sum ;
+
+! [ euler036 ] 100 ave-time
+! 3891 ms run / 173 ms GC ave time - 100 trials
+
+MAIN: euler036

extra/project-euler/common/common.factor

@@ -7,11 +7,11 @@ IN: project-euler.common
 
 ! Problems using each public word
 ! -------------------------------
-! cartesian-product - #4, #27
+! cartesian-product - #4, #27, #29, #32, #33
 ! collect-consecutive - #8, #11
 ! log10 - #25, #134
 ! max-path - #18, #67
-! number>digits - #16, #20, #30
+! number>digits - #16, #20, #30, #34
 ! propagate-all - #18, #67
 ! sum-proper-divisors - #21
 ! tau* - #12

extra/project-euler/project-euler.factor

@@ -1,4 +1,4 @@
-! Copyright (c) 2007 Aaron Schaefer.
+! Copyright (c) 2007, 2008 Aaron Schaefer, Samuel Tardieu.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: definitions io io.files kernel math.parser sequences vocabs
     vocabs.loader project-euler.ave-time project-euler.common math
@@ -9,8 +9,10 @@ USING: definitions io io.files kernel math.parser sequences vocabs
     project-euler.017 project-euler.018 project-euler.019 project-euler.020
     project-euler.021 project-euler.022 project-euler.023 project-euler.024
     project-euler.025 project-euler.026 project-euler.027 project-euler.028
-    project-euler.029 project-euler.030 project-euler.067 project-euler.134
+    project-euler.029 project-euler.030 project-euler.031 project-euler.032
-    project-euler.169 project-euler.173 project-euler.175 ;
+    project-euler.033 project-euler.034 project-euler.035 project-euler.036
+    project-euler.067 project-euler.134 project-euler.169 project-euler.173
+    project-euler.175 ;
 IN: project-euler
 
 <PRIVATE

extra/store/authors.txt

@@ -1 +0,0 @@
-Doug Coleman

extra/store/blob/authors.txt

@@ -1 +0,0 @@
-Doug Coleman

extra/store/blob/blob.factor

@@ -1,22 +0,0 @@
-! Copyright (C) 2006 Doug Coleman.
-! See http://factorcode.org/license.txt for BSD license.
-USING: assocs kernel io io.files namespaces serialize ;
-IN: store.blob
-
-: (save-blob) serialize ;
-
-: save-blob ( obj path -- )
-    <file-appender> [ (save-blob) ] with-stream ;
-
-: (load-blob) ( path -- seq/f )
-    dup exists? [
-        <file-reader> [
-            deserialize-sequence
-        ] with-stream
-    ] [
-        drop f
-    ] if ;
-
-: load-blob ( path -- seq/f )
-    resource-path (load-blob) ;
-

extra/store/store-tests.factor

@@ -1,35 +0,0 @@
-USING: assocs continuations debugger io.files kernel
-namespaces store tools.test ;
-IN: temporary
-
-SYMBOL: store
-SYMBOL: foo
-
-: the-store ( -- path )
-    "store-test.store" resource-path ;
-
-: delete-the-store ( -- )
-    [ the-store delete-file ] catch drop ;
-
-: load-the-store ( -- )
-    the-store load-store store set-global ;
-
-: save-the-store ( -- )
-    store save-store ;
-
-delete-the-store
-load-the-store
-
-[ f ] [ foo store get-persistent ] unit-test
-
-USE: prettyprint
-store get-global store-data .
-
-[ ] [ 100 foo store set-persistent ] unit-test
-
-[ ] [ save-the-store ] unit-test
-
-[ 100 ] [ foo store get-persistent ] unit-test
-
-delete-the-store
-f store set-global

extra/store/store.factor

@@ -1,33 +0,0 @@
-! Copyright (C) 2006, 2007 Doug Coleman.
-! See http://factorcode.org/license.txt for BSD license.
-USING: assocs io io.files kernel namespaces serialize init ;
-IN: store
-
-TUPLE: store path data ;
-
-C: <store> store
-
-: save-store ( store -- )
-    get-global dup store-data swap store-path
-    <file-writer> [ serialize ] with-stream ;
-
-: load-store ( path -- store )
-    dup exists? [
-        dup <file-reader> [ deserialize ] with-stream
-    ] [
-        H{ } clone
-    ] if <store> ;
-
-: define-store ( path id -- )
-    over >r
-    [ >r resource-path load-store r> set-global ] 2curry
-    r> add-init-hook ;
-
-: get-persistent ( key store -- value )
-    get-global store-data at ;
-
-: set-persistent ( value key store -- )
-    [ get-global store-data set-at ] keep save-store ;
-
-: init-persistent ( value key store -- )
-    2dup get-persistent [ 3drop ] [ set-persistent ] if ;

extra/ui/tools/workspace/workspace.factor

@@ -69,7 +69,11 @@ M: gadget tool-scroller drop f ;
     [ find-workspace hide-popup ] <debugger>
     "Error" show-titled-popup ;
 
-M: workspace pref-dim* drop { 600 700 } ;
+SYMBOL: workspace-dim
+
+{ 600 700 } workspace-dim set-global
+
+M: workspace pref-dim* drop workspace-dim get ;
 
 M: workspace focusable-child*
     dup workspace-popup [ ] [ workspace-listener ] ?if ;

extra/unicode/breaks/breaks-tests.factor

@@ -3,5 +3,5 @@ USING: tools.test unicode.breaks sequences math kernel ;
 [ "\u1112\u1161\u11abA\u0300a\r\r\n" ]
 [ "\r\n\raA\u0300\u1112\u1161\u11ab" string-reverse ] unit-test
 [ "dcba" ] [ "abcd" string-reverse ] unit-test
-[ 3 ] [ "\u1112\u1161\u11abA\u0300a" [ length 1- ] keep
+[ 3 ] [ "\u1112\u1161\u11abA\u0300a"
-        [ prev-grapheme ] keep prev-grapheme ] unit-test
+        dup last-grapheme head last-grapheme ] unit-test

extra/unicode/breaks/breaks.factor

@@ -85,45 +85,38 @@ DEFER: grapheme-table
 : chars ( i str n -- str[i] str[i+n] )
     swap >r dupd + r> [ ?nth ] curry 2apply ;
 
-: next-grapheme-step ( i str -- i+1 str prev-class )
+: find-index ( seq quot -- i ) find drop ; inline
-    2dup nth grapheme-class >r >r 1+ r> r> ;
+: find-last-index ( seq quot -- i ) find-last drop ; inline
 
-: (next-grapheme) ( i str prev-class -- next-i )
+: first-grapheme ( str -- i )
-    3dup drop bounds-check? [
+    unclip-slice grapheme-class over
-        >r next-grapheme-step r> over grapheme-break?
+    [ grapheme-class tuck grapheme-break? ] find-index
-        [ 2drop 1- ] [ (next-grapheme) ] if
+    nip swap length or 1+ ;
-    ] [ 2drop ] if ;
 
-: next-grapheme ( i str -- next-i )
+: (>graphemes) ( str -- )
-    next-grapheme-step (next-grapheme) ;
+    dup empty? [ drop ] [
+        dup first-grapheme cut-slice
+        swap , (>graphemes)
+    ] if ;
 
-: (>graphemes) ( i str -- )
-    2dup bounds-check? [
-        dupd [ next-grapheme ] keep
-        [ subseq , ] 2keep (>graphemes)
-    ] [ 2drop ] if ;
 : >graphemes ( str -- graphemes )
-    [ 0 swap (>graphemes) ] { } make* ;
+    [ (>graphemes) ] { } make ;
 
 : string-reverse ( str -- rts )
     >graphemes reverse concat ;
 
-: prev-grapheme-step ( i str -- i-1 str prev-class )
+: unclip-last-slice ( seq -- beginning last )
-    2dup nth grapheme-class >r >r 1- r> r> ;
+    dup 1 head-slice* swap peek ;
 
-: (prev-grapheme) ( i str next-class -- prev-i )
+: last-grapheme ( str -- i )
-    pick zero? [
+    unclip-last-slice grapheme-class swap
-        >r prev-grapheme-step r> dupd grapheme-break?
+    [ grapheme-class dup rot grapheme-break? ] find-last-index
-        [ 2drop 1- ] [ (prev-grapheme) ] if
+    nip -1 or 1+ ;
-    ] [ 2drop ] if ;
 
-: prev-grapheme ( i str -- prev-i )
+<<
-    prev-grapheme-step (prev-grapheme) ;
-
-[
     other-extend-lines process-other-extend \ other-extend define-value
 
     init-grapheme-table table
     [ make-grapheme-table finish-table ] with-variable
     \ grapheme-table define-value
-] with-compilation-unit
+>>

extra/unicode/syntax/syntax.factor

@@ -47,14 +47,6 @@ IN: unicode.syntax
     CREATE ";" parse-tokens
     categories swap seq-minus define-category ; parsing
 
-TUPLE: code-point lower title upper ;
-
-C: <code-point> code-point
-
-: set-code-point ( seq -- )
-    4 head [ multihex ] map first4
-    <code-point> swap first set ;
-
 : UNICHAR:
     ! This should be part of CHAR:
     scan name>char [ parsed ] [ "Invalid character" throw ] if* ; parsing

extra/webapps/pastebin/pastebin.factor

@@ -1,6 +1,6 @@
 USING: calendar furnace furnace.validator io.files kernel
-namespaces sequences store http.server.responders html
+namespaces sequences http.server.responders html math.parser rss
-math.parser rss xml.writer xmode.code2html ;
+xml.writer xmode.code2html ;
 IN: webapps.pastebin
 
 TUPLE: pastebin pastes ;
@@ -8,11 +8,7 @@ TUPLE: pastebin pastes ;
 : <pastebin> ( -- pastebin )
     V{ } clone pastebin construct-boa ;
 
-! Persistence
+<pastebin> pastebin set-global
-SYMBOL: store
-
-"pastebin.store" store define-store
-<pastebin> pastebin store init-persistent
 
 TUPLE: paste
 summary author channel mode contents date
@@ -25,11 +21,8 @@ TUPLE: annotation summary author mode contents ;
 
 C: <annotation> annotation
 
-: get-pastebin ( -- pastebin )
-    pastebin store get-persistent ;
-
 : get-paste ( n -- paste )
-    get-pastebin pastebin-pastes nth ;
+    pastebin get pastebin-pastes nth ;
 
 : show-paste ( n -- )
     serving-html
@@ -49,7 +42,7 @@ C: <annotation> annotation
     [
         [ show-paste ] "show-paste-quot" set
         [ new-paste ] "new-paste-quot" set
-        get-pastebin "paste-list" render-component
+        pastebin get "paste-list" render-component
     ] with-html-stream ;
 
 \ paste-list { } define-action
@@ -61,7 +54,7 @@ C: <annotation> annotation
     over length min head ;
 
 : paste-feed ( -- entries )
-    get-pastebin pastebin-pastes <reversed> 20 safe-head [
+    pastebin get pastebin-pastes <reversed> 20 safe-head [
         {
             paste-summary
             paste-link
@@ -82,10 +75,8 @@ C: <annotation> annotation
     pastebin-pastes 2dup length swap set-paste-n push ;
 
 : submit-paste ( summary author channel mode contents -- )
-    <paste> [
+    <paste> [ pastebin get add-paste ] keep
-        pastebin store get-persistent add-paste
+    paste-link permanent-redirect ;
-        store save-store
-    ] keep paste-link permanent-redirect ;
 
 \ new-paste
 \ submit-paste {

vm/alien.h

@@ -41,11 +41,7 @@ DLLEXPORT void to_value_struct(CELL src, void *dest, CELL size);
 DLLEXPORT void box_value_struct(void *src, CELL size);
 DLLEXPORT void box_small_struct(CELL x, CELL y, CELL size);
 
-INLINE F_DLL *untag_dll(CELL tagged)
+DEFINE_UNTAG(F_DLL,DLL_TYPE,dll)
-{
-	type_check(DLL_TYPE,tagged);
-	return (F_DLL*)UNTAG(tagged);
-}
 
 DECLARE_PRIMITIVE(dlopen);
 DECLARE_PRIMITIVE(dlsym);

vm/data_gc.c

@@ -177,12 +177,6 @@ CELL unaligned_object_size(CELL pointer)
 		return sizeof(F_QUOTATION);
 	case WORD_TYPE:
 		return sizeof(F_WORD);
-	case HASHTABLE_TYPE:
-		return sizeof(F_HASHTABLE);
-	case VECTOR_TYPE:
-		return sizeof(F_VECTOR);
-	case SBUF_TYPE:
-		return sizeof(F_SBUF);
 	case RATIO_TYPE:
 		return sizeof(F_RATIO);
 	case FLOAT_TYPE:

vm/errors.h

@@ -39,6 +39,13 @@ INLINE void type_check(CELL type, CELL tagged)
 	if(type_of(tagged) != type) type_error(type,tagged);
 }
 
+#define DEFINE_UNTAG(type,check,name) \
+	INLINE type *untag_##name(CELL obj) \
+	{ \
+		type_check(check,obj); \
+		return untag_object(obj); \
+	}
+
 /* Global variables used to pass fault handler state from signal handler to
 user-space */
 CELL signal_number;

vm/layouts.h

@@ -52,21 +52,18 @@ typedef signed long long s64;
 /*** Header types ***/
 #define ARRAY_TYPE 8
 #define WRAPPER_TYPE 9
-#define HASHTABLE_TYPE 10
+#define FLOAT_ARRAY_TYPE 10
-#define VECTOR_TYPE 11
+#define CALLSTACK_TYPE 11
 #define STRING_TYPE 12
-#define SBUF_TYPE 13
+#define CURRY_TYPE 13
 #define QUOTATION_TYPE 14
 #define DLL_TYPE 15
 #define ALIEN_TYPE 16
 #define WORD_TYPE 17
 #define BYTE_ARRAY_TYPE 18
 #define BIT_ARRAY_TYPE 19
-#define FLOAT_ARRAY_TYPE 20
-#define CURRY_TYPE 21
-#define CALLSTACK_TYPE 22
 
-#define TYPE_COUNT 23
+#define TYPE_COUNT 20
 
 INLINE bool immediate_p(CELL obj)
 {
@@ -103,16 +100,6 @@ typedef F_ARRAY F_BIT_ARRAY;
 
 typedef F_ARRAY F_FLOAT_ARRAY;
 
-/* Assembly code makes assumptions about the layout of this struct */
-typedef struct {
-	/* always tag_header(VECTOR_TYPE) */
-	CELL header;
-	/* tagged */
-	CELL top;
-	/* tagged */
-	CELL array;
-} F_VECTOR;
-
 /* Assembly code makes assumptions about the layout of this struct */
 typedef struct {
 	CELL header;
@@ -122,28 +109,6 @@ typedef struct {
 	CELL hashcode;
 } F_STRING;
 
-/* Assembly code makes assumptions about the layout of this struct */
-typedef struct {
-	/* always tag_header(SBUF_TYPE) */
-	CELL header;
-	/* tagged */
-	CELL top;
-	/* tagged */
-	CELL string;
-} F_SBUF;
-
-/* Assembly code makes assumptions about the layout of this struct */
-typedef struct {
-	/* always tag_header(HASHTABLE_TYPE) */
-	CELL header;
-	/* tagged */
-	CELL count;
-        /* tagged */
-        CELL deleted;
-	/* tagged */
-	CELL array;
-} F_HASHTABLE;
-
 /* The compiled code heap is structured into blocks. */
 typedef struct
 {

vm/primitives.c

@@ -4,7 +4,6 @@ void *primitives[] = {
 	primitive_execute,
 	primitive_call,
 	primitive_uncurry,
-	primitive_string_to_sbuf,
 	primitive_bignum_to_fixnum,
 	primitive_float_to_fixnum,
 	primitive_fixnum_to_bignum,
@@ -157,7 +156,6 @@ void *primitives[] = {
 	primitive_set_char_slot,
 	primitive_resize_array,
 	primitive_resize_string,
-	primitive_hashtable,
 	primitive_array,
 	primitive_begin_scan,
 	primitive_next_object,
@@ -172,7 +170,6 @@ void *primitives[] = {
 	primitive_fclose,
 	primitive_wrapper,
 	primitive_clone,
-	primitive_array_to_vector,
 	primitive_string,
 	primitive_to_tuple,
 	primitive_array_to_quotation,
@@ -192,4 +189,7 @@ void *primitives[] = {
 	primitive_set_innermost_stack_frame_quot,
 	primitive_call_clear,
 	primitive_os_envs,
+	primitive_resize_byte_array,
+	primitive_resize_bit_array,
+	primitive_resize_float_array,
 };

vm/types.c

@@ -12,6 +12,80 @@ bool to_boolean(CELL value)
 	return value != F;
 }
 
+CELL clone(CELL object)
+{
+	CELL size = object_size(object);
+	if(size == 0)
+		return object;
+	else
+	{
+		REGISTER_ROOT(object);
+		void *new_obj = allot_object(type_of(object),size);
+		UNREGISTER_ROOT(object);
+
+		CELL tag = TAG(object);
+		memcpy(new_obj,(void*)UNTAG(object),size);
+		return RETAG(new_obj,tag);
+	}
+}
+
+DEFINE_PRIMITIVE(clone)
+{
+	drepl(clone(dpeek()));
+}
+
+F_WORD *allot_word(CELL vocab, CELL name)
+{
+	REGISTER_ROOT(vocab);
+	REGISTER_ROOT(name);
+	F_WORD *word = allot_object(WORD_TYPE,sizeof(F_WORD));
+	UNREGISTER_ROOT(name);
+	UNREGISTER_ROOT(vocab);
+
+	word->hashcode = tag_fixnum(rand());
+	word->vocabulary = vocab;
+	word->name = name;
+	word->def = userenv[UNDEFINED_ENV];
+	word->props = F;
+	word->counter = tag_fixnum(0);
+	word->compiledp = F;
+	word->profiling = NULL;
+
+	REGISTER_UNTAGGED(word);
+	default_word_code(word,true);
+	UNREGISTER_UNTAGGED(word);
+
+	REGISTER_UNTAGGED(word);
+	update_word_xt(word);
+	UNREGISTER_UNTAGGED(word);
+
+	return word;
+}
+
+/* <word> ( name vocabulary -- word ) */
+DEFINE_PRIMITIVE(word)
+{
+	CELL vocab = dpop();
+	CELL name = dpop();
+	dpush(tag_object(allot_word(vocab,name)));
+}
+
+/* word-xt ( word -- xt ) */
+DEFINE_PRIMITIVE(word_xt)
+{
+	F_WORD *word = untag_word(dpeek());
+	drepl(allot_cell((CELL)word->xt));
+}
+
+DEFINE_PRIMITIVE(wrapper)
+{
+	F_WRAPPER *wrapper = allot_object(WRAPPER_TYPE,sizeof(F_WRAPPER));
+	wrapper->object = dpeek();
+	drepl(tag_object(wrapper));
+}
+
+/* Arrays */
+
 /* the array is full of undefined data, and must be correctly filled before the
 next GC. size is in cells */
 F_ARRAY *allot_array_internal(CELL type, CELL capacity)
@@ -38,41 +112,6 @@ F_ARRAY *allot_array(CELL type, CELL capacity, CELL fill)
 	return array;
 }
 
-/* size is in bytes this time */
-F_BYTE_ARRAY *allot_byte_array(CELL size)
-{
-	F_BYTE_ARRAY *array = allot_object(BYTE_ARRAY_TYPE,
-		byte_array_size(size));
-	array->capacity = tag_fixnum(size);
-	memset(array + 1,0,size);
-	return array;
-}
-
-/* size is in bits */
-F_BIT_ARRAY *allot_bit_array(CELL size)
-{
-	F_BIT_ARRAY *array = allot_object(BIT_ARRAY_TYPE,
-		bit_array_size(size));
-	array->capacity = tag_fixnum(size);
-	memset(array + 1,0,(size + 31) / 32 * 4);
-	return array;
-}
-
-/* size is in 8-byte doubles */
-F_BIT_ARRAY *allot_float_array(CELL size, double initial)
-{
-	F_FLOAT_ARRAY *array = allot_object(FLOAT_ARRAY_TYPE,
-		float_array_size(size));
-	array->capacity = tag_fixnum(size);
-
-	double *elements = (double *)AREF(array,0);
-	int i;
-	for(i = 0; i < size; i++)
-		elements[i] = initial;
-
-	return array;
-}
-
 /* push a new array on the stack */
 DEFINE_PRIMITIVE(array)
 {
@@ -81,89 +120,6 @@ DEFINE_PRIMITIVE(array)
 	dpush(tag_object(allot_array(ARRAY_TYPE,size,initial)));
 }
 
-/* push a new tuple on the stack */
-DEFINE_PRIMITIVE(tuple)
-{
-	CELL size = unbox_array_size();
-	F_ARRAY *array = allot_array(TUPLE_TYPE,size,F);
-	set_array_nth(array,0,dpop());
-	dpush(tag_tuple(array));
-}
-
-/* push a new tuple on the stack, filling its slots from the stack */
-DEFINE_PRIMITIVE(tuple_boa)
-{
-	CELL size = unbox_array_size();
-	F_ARRAY *array = allot_array(TUPLE_TYPE,size,F);
-	set_array_nth(array,0,dpop());
-
-	CELL i;
-	for(i = size - 1; i >= 2; i--)
-		set_array_nth(array,i,dpop());
-
-	dpush(tag_tuple(array));
-}
-
-/* push a new byte array on the stack */
-DEFINE_PRIMITIVE(byte_array)
-{
-	CELL size = unbox_array_size();
-	dpush(tag_object(allot_byte_array(size)));
-}
-
-/* push a new bit array on the stack */
-DEFINE_PRIMITIVE(bit_array)
-{
-	CELL size = unbox_array_size();
-	dpush(tag_object(allot_bit_array(size)));
-}
-
-/* push a new float array on the stack */
-DEFINE_PRIMITIVE(float_array)
-{
-	double initial = untag_float(dpop());
-	CELL size = unbox_array_size();
-	dpush(tag_object(allot_float_array(size,initial)));
-}
-
-CELL clone(CELL object)
-{
-	CELL size = object_size(object);
-	if(size == 0)
-		return object;
-	else
-	{
-		REGISTER_ROOT(object);
-		void *new_obj = allot_object(type_of(object),size);
-		UNREGISTER_ROOT(object);
-
-		CELL tag = TAG(object);
-		memcpy(new_obj,(void*)UNTAG(object),size);
-		return RETAG(new_obj,tag);
-	}
-}
-
-DEFINE_PRIMITIVE(clone)
-{
-	drepl(clone(dpeek()));
-}
-
-DEFINE_PRIMITIVE(tuple_to_array)
-{
-	CELL object = dpeek();
-	type_check(TUPLE_TYPE,object);
-	object = RETAG(clone(object),OBJECT_TYPE);
-	set_slot(object,0,tag_header(ARRAY_TYPE));
-	drepl(object);
-}
-
-DEFINE_PRIMITIVE(to_tuple)
-{
-	CELL object = RETAG(clone(dpeek()),TUPLE_TYPE);
-	set_slot(object,0,tag_header(TUPLE_TYPE));
-	drepl(object);
-}
-
 CELL allot_array_1(CELL obj)
 {
 	REGISTER_ROOT(obj);
@@ -235,14 +191,6 @@ DEFINE_PRIMITIVE(resize_array)
 	dpush(tag_object(reallot_array(array,capacity,F)));
 }
 
-DEFINE_PRIMITIVE(array_to_vector)
-{
-	F_VECTOR *vector = allot_object(VECTOR_TYPE,sizeof(F_VECTOR));
-	vector->top = dpop();
-	vector->array = dpop();
-	dpush(tag_object(vector));
-}
-
 F_ARRAY *growable_add(F_ARRAY *result, CELL elt, CELL *result_count)
 {
 	REGISTER_ROOT(elt);
@@ -279,6 +227,199 @@ F_ARRAY *growable_append(F_ARRAY *result, F_ARRAY *elts, CELL *result_count)
 	return result;
 }
 
+/* Byte arrays */
+
+/* must fill out array before next GC */
+F_BYTE_ARRAY *allot_byte_array_internal(CELL size)
+{
+	F_BYTE_ARRAY *array = allot_object(BYTE_ARRAY_TYPE,
+		byte_array_size(size));
+	array->capacity = tag_fixnum(size);
+	return array;
+}
+
+/* size is in bytes this time */
+F_BYTE_ARRAY *allot_byte_array(CELL size)
+{
+	F_BYTE_ARRAY *array = allot_byte_array_internal(size);
+	memset(array + 1,0,size);
+	return array;
+}
+
+/* push a new byte array on the stack */
+DEFINE_PRIMITIVE(byte_array)
+{
+	CELL size = unbox_array_size();
+	dpush(tag_object(allot_byte_array(size)));
+}
+
+F_BYTE_ARRAY *reallot_byte_array(F_BYTE_ARRAY *array, CELL capacity)
+{
+	CELL to_copy = array_capacity(array);
+	if(capacity < to_copy)
+		to_copy = capacity;
+
+	REGISTER_UNTAGGED(array);
+	F_BYTE_ARRAY *new_array = allot_byte_array(capacity);
+	UNREGISTER_UNTAGGED(array);
+
+	memcpy(new_array + 1,array + 1,to_copy);
+
+	return new_array;
+}
+
+DEFINE_PRIMITIVE(resize_byte_array)
+{
+	F_BYTE_ARRAY* array = untag_byte_array(dpop());
+	CELL capacity = unbox_array_size();
+	dpush(tag_object(reallot_byte_array(array,capacity)));
+}
+
+/* Bit arrays */
+
+/* size is in bits */
+
+F_BIT_ARRAY *allot_bit_array_internal(CELL size)
+{
+	F_BIT_ARRAY *array = allot_object(BIT_ARRAY_TYPE,bit_array_size(size));
+	array->capacity = tag_fixnum(size);
+	return array;
+}
+
+F_BIT_ARRAY *allot_bit_array(CELL size)
+{
+	F_BIT_ARRAY *array = allot_bit_array_internal(size);
+	memset(array + 1,0,bit_array_size(size));
+	return array;
+}
+
+/* push a new bit array on the stack */
+DEFINE_PRIMITIVE(bit_array)
+{
+	CELL size = unbox_array_size();
+	dpush(tag_object(allot_bit_array(size)));
+}
+
+F_BIT_ARRAY *reallot_bit_array(F_BIT_ARRAY *array, CELL capacity)
+{
+	CELL to_copy = array_capacity(array);
+	if(capacity < to_copy)
+		to_copy = capacity;
+
+	REGISTER_UNTAGGED(array);
+	F_BIT_ARRAY *new_array = allot_bit_array(capacity);
+	UNREGISTER_UNTAGGED(array);
+
+	memcpy(new_array + 1,array + 1,bit_array_size(to_copy));
+
+	return new_array;
+}
+
+DEFINE_PRIMITIVE(resize_bit_array)
+{
+	F_BYTE_ARRAY* array = untag_bit_array(dpop());
+	CELL capacity = unbox_array_size();
+	dpush(tag_object(reallot_bit_array(array,capacity)));
+}
+
+/* Float arrays */
+
+/* size is in 8-byte doubles */
+F_FLOAT_ARRAY *allot_float_array_internal(CELL size)
+{
+	F_FLOAT_ARRAY *array = allot_object(FLOAT_ARRAY_TYPE,
+		float_array_size(size));
+	array->capacity = tag_fixnum(size);
+	return array;
+}
+
+F_FLOAT_ARRAY *allot_float_array(CELL size, double initial)
+{
+	F_FLOAT_ARRAY *array = allot_float_array_internal(size);
+
+	double *elements = (double *)AREF(array,0);
+	int i;
+	for(i = 0; i < size; i++)
+		elements[i] = initial;
+
+	return array;
+}
+
+/* push a new float array on the stack */
+DEFINE_PRIMITIVE(float_array)
+{
+	double initial = untag_float(dpop());
+	CELL size = unbox_array_size();
+	dpush(tag_object(allot_float_array(size,initial)));
+}
+
+F_ARRAY *reallot_float_array(F_FLOAT_ARRAY* array, CELL capacity)
+{
+	F_FLOAT_ARRAY* new_array;
+
+	CELL to_copy = array_capacity(array);
+	if(capacity < to_copy)
+		to_copy = capacity;
+
+	REGISTER_UNTAGGED(array);
+	new_array = allot_float_array(capacity,0.0);
+	UNREGISTER_UNTAGGED(array);
+
+	memcpy(new_array + 1,array + 1,to_copy * sizeof(double));
+
+	return new_array;
+}
+
+DEFINE_PRIMITIVE(resize_float_array)
+{
+	F_FLOAT_ARRAY* array = untag_float_array(dpop());
+	CELL capacity = unbox_array_size();
+	dpush(tag_object(reallot_float_array(array,capacity)));
+}
+
+/* Tuples */
+
+/* push a new tuple on the stack */
+DEFINE_PRIMITIVE(tuple)
+{
+	CELL size = unbox_array_size();
+	F_ARRAY *array = allot_array(TUPLE_TYPE,size,F);
+	set_array_nth(array,0,dpop());
+	dpush(tag_tuple(array));
+}
+
+/* push a new tuple on the stack, filling its slots from the stack */
+DEFINE_PRIMITIVE(tuple_boa)
+{
+	CELL size = unbox_array_size();
+	F_ARRAY *array = allot_array(TUPLE_TYPE,size,F);
+	set_array_nth(array,0,dpop());
+
+	CELL i;
+	for(i = size - 1; i >= 2; i--)
+		set_array_nth(array,i,dpop());
+
+	dpush(tag_tuple(array));
+}
+
+DEFINE_PRIMITIVE(tuple_to_array)
+{
+	CELL object = dpeek();
+	type_check(TUPLE_TYPE,object);
+	object = RETAG(clone(object),OBJECT_TYPE);
+	set_slot(object,0,tag_header(ARRAY_TYPE));
+	drepl(object);
+}
+
+DEFINE_PRIMITIVE(to_tuple)
+{
+	CELL object = RETAG(clone(dpeek()),TUPLE_TYPE);
+	set_slot(object,0,tag_header(TUPLE_TYPE));
+	drepl(object);
+}
+
+/* Strings */
+
 /* untagged */
 F_STRING* allot_string_internal(CELL capacity)
 {
@@ -469,70 +610,3 @@ DEFINE_PRIMITIVE(set_char_slot)
 	CELL value = untag_fixnum_fast(dpop());
 	set_string_nth(string,index,value);
 }
-
-DEFINE_PRIMITIVE(string_to_sbuf)
-{
-	F_SBUF *sbuf = allot_object(SBUF_TYPE,sizeof(F_SBUF));
-	sbuf->top = dpop();
-	sbuf->string = dpop();
-	dpush(tag_object(sbuf));
-}
-
-DEFINE_PRIMITIVE(hashtable)
-{
-	F_HASHTABLE* hash = allot_object(HASHTABLE_TYPE,sizeof(F_HASHTABLE));
-	hash->count = F;
-	hash->deleted = F;
-	hash->array = F;
-	dpush(tag_object(hash));
-}
-
-F_WORD *allot_word(CELL vocab, CELL name)
-{
-	REGISTER_ROOT(vocab);
-	REGISTER_ROOT(name);
-	F_WORD *word = allot_object(WORD_TYPE,sizeof(F_WORD));
-	UNREGISTER_ROOT(name);
-	UNREGISTER_ROOT(vocab);
-
-	word->hashcode = tag_fixnum(rand());
-	word->vocabulary = vocab;
-	word->name = name;
-	word->def = userenv[UNDEFINED_ENV];
-	word->props = F;
-	word->counter = tag_fixnum(0);
-	word->compiledp = F;
-	word->profiling = NULL;
-
-	REGISTER_UNTAGGED(word);
-	default_word_code(word,true);
-	UNREGISTER_UNTAGGED(word);
-
-	REGISTER_UNTAGGED(word);
-	update_word_xt(word);
-	UNREGISTER_UNTAGGED(word);
-
-	return word;
-}
-
-/* <word> ( name vocabulary -- word ) */
-DEFINE_PRIMITIVE(word)
-{
-	CELL vocab = dpop();
-	CELL name = dpop();
-	dpush(tag_object(allot_word(vocab,name)));
-}
-
-/* word-xt ( word -- xt ) */
-DEFINE_PRIMITIVE(word_xt)
-{
-	F_WORD *word = untag_word(dpeek());
-	drepl(allot_cell((CELL)word->xt));
-}
-
-DEFINE_PRIMITIVE(wrapper)
-{
-	F_WRAPPER *wrapper = allot_object(WRAPPER_TYPE,sizeof(F_WRAPPER));
-	wrapper->object = dpeek();
-	drepl(tag_object(wrapper));
-}

vm/types.h

@@ -14,6 +14,8 @@ INLINE CELL string_size(CELL size)
 	return sizeof(F_STRING) + (size + 1) * CHARS;
 }
 
+DEFINE_UNTAG(F_BYTE_ARRAY,BYTE_ARRAY_TYPE,byte_array)
+
 INLINE CELL byte_array_capacity(F_BYTE_ARRAY *array)
 {
 	return untag_fixnum_fast(array->capacity);
@@ -24,6 +26,8 @@ INLINE CELL byte_array_size(CELL size)
 	return sizeof(F_BYTE_ARRAY) + size;
 }
 
+DEFINE_UNTAG(F_BIT_ARRAY,BIT_ARRAY_TYPE,bit_array)
+
 INLINE CELL bit_array_capacity(F_BIT_ARRAY *array)
 {
 	return untag_fixnum_fast(array->capacity);
@@ -34,6 +38,8 @@ INLINE CELL bit_array_size(CELL size)
 	return sizeof(F_BIT_ARRAY) + (size + 7) / 8;
 }
 
+DEFINE_UNTAG(F_FLOAT_ARRAY,FLOAT_ARRAY_TYPE,float_array)
+
 INLINE CELL float_array_capacity(F_FLOAT_ARRAY *array)
 {
 	return untag_fixnum_fast(array->capacity);
@@ -49,22 +55,14 @@ INLINE CELL callstack_size(CELL size)
 	return sizeof(F_CALLSTACK) + size;
 }
 
-INLINE F_CALLSTACK *untag_callstack(CELL obj)
+DEFINE_UNTAG(F_CALLSTACK,CALLSTACK_TYPE,callstack)
-{
-	type_check(CALLSTACK_TYPE,obj);
-	return untag_object(obj);
-}
 
 INLINE CELL tag_boolean(CELL untagged)
 {
 	return (untagged == false ? F : T);
 }
 
-INLINE F_ARRAY* untag_array(CELL tagged)
+DEFINE_UNTAG(F_ARRAY,ARRAY_TYPE,array)
-{
-	type_check(ARRAY_TYPE,tagged);
-	return untag_object(tagged);
-}
 
 #define AREF(array,index) ((CELL)(array) + sizeof(F_ARRAY) + (index) * CELLS)
 #define UNAREF(array,ptr) (((CELL)(ptr)-(CELL)(array)-sizeof(F_ARRAY)) / CELLS)
@@ -103,17 +101,9 @@ INLINE void set_string_nth(F_STRING* string, CELL index, u16 value)
 	cput(SREF(string,index),value);
 }
 
-INLINE F_QUOTATION *untag_quotation(CELL tagged)
+DEFINE_UNTAG(F_QUOTATION,QUOTATION_TYPE,quotation)
-{
-	type_check(QUOTATION_TYPE,tagged);
-	return untag_object(tagged);
-}
 
-INLINE F_WORD *untag_word(CELL tagged)
+DEFINE_UNTAG(F_WORD,WORD_TYPE,word)
-{
-	type_check(WORD_TYPE,tagged);
-	return untag_object(tagged);
-}
 
 INLINE CELL tag_tuple(F_ARRAY *tuple)
 {
@@ -144,8 +134,9 @@ DECLARE_PRIMITIVE(to_tuple);
 
 F_ARRAY *reallot_array(F_ARRAY* array, CELL capacity, CELL fill);
 DECLARE_PRIMITIVE(resize_array);
-
+DECLARE_PRIMITIVE(resize_byte_array);
-DECLARE_PRIMITIVE(array_to_vector);
+DECLARE_PRIMITIVE(resize_bit_array);
+DECLARE_PRIMITIVE(resize_float_array);
 
 F_STRING* allot_string_internal(CELL capacity);
 F_STRING* allot_string(CELL capacity, CELL fill);
@@ -178,10 +169,6 @@ DECLARE_PRIMITIVE(string_to_u16_alien);
 DECLARE_PRIMITIVE(char_slot);
 DECLARE_PRIMITIVE(set_char_slot);
 
-DECLARE_PRIMITIVE(string_to_sbuf);
-
-DECLARE_PRIMITIVE(hashtable);
-
 F_WORD *allot_word(CELL vocab, CELL name);
 DECLARE_PRIMITIVE(word);
 DECLARE_PRIMITIVE(word_xt);