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

basis/alien/arrays/arrays-docs.factor

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

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

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

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

@@ -55,8 +55,6 @@ TYPEDEF: uchar* MyLPBYTE
     0 B{ 1 2 3 4 } <displaced-alien> <void*>
 ] must-fail
 
-[ t ] [ { t f t } >c-bool-array { 1 0 1 } >c-int-array = ] unit-test
-
 os windows? cpu x86.64? and [
     [ -2147467259 ] [ 2147500037 <long> *long ] unit-test
 ] when

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

@@ -4,7 +4,7 @@ USING: byte-arrays arrays assocs kernel kernel.private libc math
 namespaces make parser sequences strings words assocs splitting
 math.parser cpu.architecture alien alien.accessors quotations
 layouts system compiler.units io.files io.encodings.binary
-accessors combinators effects continuations ;
+accessors combinators effects continuations fry ;
 IN: alien.c-types
 
 DEFER: <int>
@@ -21,7 +21,7 @@ reg-class size align stack-align? ;
 : new-c-type ( class -- type )
     new
         int-regs >>reg-class
-        object >>class ;
+        object >>class ; inline
 
 : <c-type> ( -- type )
     \ c-type new-c-type ;
@@ -180,12 +180,12 @@ M: byte-array byte-length length ;
 
 : c-getter ( name -- quot )
     c-type-getter [
-        [ "Cannot read struct fields with type" throw ]
+        [ "Cannot read struct fields with this type" throw ]
     ] unless* ;
 
 : c-setter ( name -- quot )
     c-type-setter [
-        [ "Cannot write struct fields with type" throw ]
+        [ "Cannot write struct fields with this type" throw ]
     ] unless* ;
 
 : <c-array> ( n type -- array )
@@ -209,28 +209,13 @@ M: byte-array byte-length length ;
 : byte-array>memory ( byte-array base -- )
     swap dup length memcpy ;
 
-: (define-nth) ( word type quot -- )
+: array-accessor ( type quot -- def )
     [
         \ swap , [ heap-size , [ * >fixnum ] % ] [ % ] bi*
-    ] [ ] make define-inline ;
+    ] [ ] make ;
-
-: nth-word ( name vocab -- word )
-    [ "-nth" append ] dip create ;
-
-: define-nth ( name vocab -- )
-    dupd nth-word swap dup c-getter (define-nth) ;
-
-: set-nth-word ( name vocab -- word )
-    [ "set-" swap "-nth" 3append ] dip create ;
-
-: define-set-nth ( name vocab -- )
-    dupd set-nth-word swap dup c-setter (define-nth) ;
 
 : typedef ( old new -- ) c-types get set-at ;
 
-: define-c-type ( type name vocab -- )
-    [ tuck typedef ] dip [ define-nth ] 2keep define-set-nth ;
-
 TUPLE: long-long-type < c-type ;
 
 : <long-long-type> ( -- type )
@@ -248,54 +233,24 @@ M: long-long-type box-parameter ( n type -- )
 M: long-long-type box-return ( type -- )
     f swap box-parameter ;
 
-: define-deref ( name vocab -- )
+: define-deref ( name -- )
-    [ dup CHAR: * prefix ] dip create
+    [ CHAR: * prefix "alien.c-types" create ]
-    swap c-getter 0 prefix define-inline ;
+    [ c-getter 0 prefix ] bi
+    define-inline ;
 
-: define-out ( name vocab -- )
+: define-out ( name -- )
-    over [ <c-object> tuck 0 ] over c-setter append swap
+    [ "alien.c-types" constructor-word ]
-    [ constructor-word ] 2dip prefix define-inline ;
+    [ dup c-setter '[ _ <c-object> [ 0 @ ] keep ] ]
+    bi define-inline ;
 
 : c-bool> ( int -- ? )
     zero? not ;
 
-: >c-array ( seq type word -- byte-array )
-    [ [ dup length ] dip <c-array> ] dip
-    [ [ execute ] 2curry each-index ] 2keep drop ; inline
-
-: >c-array-quot ( type vocab -- quot )
-    dupd set-nth-word [ >c-array ] 2curry ;
-
-: to-array-word ( name vocab -- word )
-    [ ">c-" swap "-array" 3append ] dip create ;
-
-: define-to-array ( type vocab -- )
-    [ to-array-word ] 2keep >c-array-quot
-    (( array -- byte-array )) define-declared ;
-
-: c-array>quot ( type vocab -- quot )
-    [
-        \ swap ,
-        nth-word 1quotation ,
-        [ curry map ] %
-    ] [ ] make ;
-
-: from-array-word ( name vocab -- word )
-    [ "c-" swap "-array>" 3append ] dip create ;
-
-: define-from-array ( type vocab -- )
-    [ from-array-word ] 2keep c-array>quot
-    (( c-ptr n -- array )) define-declared ;
-
 : define-primitive-type ( type name -- )
-    "alien.c-types"
+    [ typedef ]
-    {
-        [ define-c-type ]
     [ define-deref ]
-        [ define-to-array ]
-        [ define-from-array ]
     [ define-out ]
-    } 2cleave ;
+    tri ;
 
 : expand-constants ( c-type -- c-type' )
     dup array? [
@@ -314,6 +269,17 @@ M: long-long-type box-return ( type -- )
 : if-void ( type true false -- )
     pick "void" = [ drop nip call ] [ nip call ] if ; inline
 
+: primitive-types
+    {
+        "char" "uchar"
+        "short" "ushort"
+        "int" "uint"
+        "long" "ulong"
+        "longlong" "ulonglong"
+        "float" "double"
+        "void*" "bool"
+    } ;
+
 [
     <c-type>
         c-ptr >>class

basis/alien/strings/strings.factor

@@ -3,7 +3,7 @@
 USING: arrays sequences kernel accessors math alien.accessors
 alien.c-types byte-arrays words io io.encodings
 io.streams.byte-array io.streams.memory io.encodings.utf8
-io.encodings.utf16 system alien strings cpu.architecture ;
+io.encodings.utf16 system alien strings cpu.architecture fry ;
 IN: alien.strings
 
 GENERIC# alien>string 1 ( c-ptr encoding -- string/f )
@@ -77,10 +77,10 @@ M: string-type c-type-unboxer
     drop "void*" c-type-unboxer ;
 
 M: string-type c-type-boxer-quot
-    second [ alien>string ] curry [ ] like ;
+    second '[ _ alien>string ] ;
 
 M: string-type c-type-unboxer-quot
-    second [ string>alien ] curry [ ] like ;
+    second '[ _ string>alien ] ;
 
 M: string-type c-type-getter
     drop [ alien-cell ] ;

basis/alien/structs/structs.factor

@@ -38,25 +38,26 @@ M: struct-type stack-size
 
 : c-struct? ( type -- ? ) (c-type) struct-type? ;
 
-: (define-struct) ( name vocab size align fields -- )
+: (define-struct) ( name size align fields -- )
     [ [ align ] keep ] dip
     struct-type boa
-    -rot define-c-type ;
+    swap typedef ;
 
-: define-struct-early ( name vocab fields -- fields )
+: make-fields ( name vocab fields -- fields )
     [ first2 <field-spec> ] with with map ;
 
 : compute-struct-align ( types -- n )
     [ c-type-align ] map supremum ;
 
 : define-struct ( name vocab fields -- )
-    pick [
+    [
+        [ 2drop ] [ make-fields ] 3bi
         [ struct-offsets ] keep
         [ [ type>> ] map compute-struct-align ] keep
         [ (define-struct) ] keep
-    ] dip [ swap define-field ] curry each ;
+    ] [ 2drop '[ _ swap define-field ] ] 3bi each ;
 
-: define-union ( name vocab members -- )
+: define-union ( name members -- )
     [ expand-constants ] map
     [ [ heap-size ] map supremum ] keep
     compute-struct-align f (define-struct) ;

basis/alien/syntax/syntax.factor

@@ -24,13 +24,10 @@ IN: alien.syntax
     scan scan typedef ; parsing
 
 : C-STRUCT:
-    scan in get
+    scan in get parse-definition define-struct ; parsing
-    parse-definition
-    [ 2dup ] dip define-struct-early
-    define-struct ; parsing
 
 : C-UNION:
-    scan in get parse-definition define-union ; parsing
+    scan parse-definition define-union ; parsing
 
 : C-ENUM:
     ";" parse-tokens

basis/bit-arrays/bit-arrays.factor

@@ -2,7 +2,7 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: alien.c-types accessors math alien.accessors kernel
 kernel.private locals sequences sequences.private byte-arrays
-parser prettyprint.backend ;
+parser prettyprint.backend fry ;
 IN: bit-arrays
 
 TUPLE: bit-array
@@ -24,9 +24,8 @@ TUPLE: bit-array
 : bits>bytes 7 + n>byte ; inline
 
 : (set-bits) ( bit-array n -- )
-    [ [ length bits>cells ] keep ] dip
+    [ [ length bits>cells ] keep ] dip swap underlying>>
-    [ -rot underlying>> set-uint-nth ] 2curry
+    '[ [ _ _ ] dip set-alien-unsigned-4 ] each ; inline
-    each ; inline
 
 PRIVATE>
 
@@ -84,9 +83,9 @@ M: bit-array byte-length length 7 + -3 shift ;
     ] if ;
 
 : bit-array>integer ( bit-array -- n )
-    0 swap underlying>> [ length ] keep [
+    0 swap underlying>> dup length [
-        uchar-nth swap 8 shift bitor
+        alien-unsigned-1 swap 8 shift bitor
-    ] curry each ;
+    ] with each ;
 
 INSTANCE: bit-array sequence
 

basis/cocoa/enumeration/enumeration.factor

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

basis/cocoa/messages/messages.factor

@@ -5,7 +5,8 @@ combinators compiler compiler.alien kernel math namespaces make
 parser prettyprint prettyprint.sections quotations sequences
 strings words cocoa.runtime io macros memoize debugger
 io.encodings.ascii effects libc libc.private parser lexer init
-core-foundation fry generalizations ;
+core-foundation fry generalizations
+specialized-arrays.direct.alien ;
 IN: cocoa.messages
 
 : make-sender ( method function -- quot )
@@ -198,8 +199,11 @@ assoc-union alien>objc-types set-global
     objc-methods get set-at ;
 
 : each-method-in-class ( class quot -- )
-    [ 0 <uint> [ class_copyMethodList ] keep *uint over ] dip
+    [ 0 <uint> [ class_copyMethodList ] keep *uint ] dip
-    '[ _ void*-nth @ ] each (free) ; inline
+    over 0 = [ 3drop ] [
+        [ <direct-void*-array> ] dip
+        [ each ] [ drop underlying>> (free) ] 2bi
+    ] if ; inline
 
 : register-objc-methods ( class -- )
     [ register-objc-method ] each-method-in-class ;

basis/cocoa/pasteboard/pasteboard.factor

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

basis/cocoa/views/views.factor

@@ -1,8 +1,8 @@
-! Copyright (C) 2006, 2007 Slava Pestov
+! Copyright (C) 2006, 2008 Slava Pestov
 ! See http://factorcode.org/license.txt for BSD license.
-USING: alien.c-types arrays kernel math namespaces make cocoa
+USING: specialized-arrays.int arrays kernel math namespaces make
-cocoa.messages cocoa.classes cocoa.types sequences
+cocoa cocoa.messages cocoa.classes cocoa.types sequences
-continuations ;
+continuations accessors ;
 IN: cocoa.views
 
 : NSOpenGLPFAAllRenderers 1 ;
@@ -69,7 +69,7 @@ PRIVATE>
             NSOpenGLPFASamples , 8 ,
         ] when
         0 ,
-    ] { } make >c-int-array
+    ] int-array{ } make underlying>>
     -> initWithAttributes:
     -> autorelease ;
 

basis/compiler/tests/alien.factor

@@ -3,7 +3,8 @@ USING: alien alien.c-types alien.syntax compiler kernel
 namespaces namespaces tools.test sequences stack-checker
 stack-checker.errors words arrays parser quotations
 continuations effects namespaces.private io io.streams.string
-memory system threads tools.test math accessors combinators ;
+memory system threads tools.test math accessors combinators
+specialized-arrays.float ;
 
 FUNCTION: void ffi_test_0 ;
 [ ] [ ffi_test_0 ] unit-test
@@ -196,7 +197,11 @@ FUNCTION: int ffi_test_12 int a int b rect c int d int e int f ;
 
 FUNCTION: float ffi_test_23 ( float[3] x, float[3] y ) ;
 
-[ 32.0 ] [ { 1.0 2.0 3.0 } >c-float-array { 4.0 5.0 6.0 } >c-float-array ffi_test_23 ] unit-test
+[ 32.0 ] [
+    { 1.0 2.0 3.0 } >float-array underlying>>
+    { 4.0 5.0 6.0 } >float-array underlying>>
+    ffi_test_23
+] unit-test
 
 ! Test odd-size structs
 C-STRUCT: test-struct-1 { { "char" 1 } "x" } ;

basis/compiler/tests/codegen.factor

@@ -3,7 +3,7 @@ kernel.private math hashtables.private math.private namespaces
 sequences sequences.private tools.test namespaces.private
 slots.private sequences.private byte-arrays alien
 alien.accessors layouts words definitions compiler.units io
-combinators vectors float-arrays grouping make ;
+combinators vectors grouping make ;
 IN: compiler.tests
 
 ! Originally, this file did black box testing of templating

basis/compiler/tests/spilling.factor

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

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

@@ -3,7 +3,7 @@
 USING: accessors kernel arrays sequences math math.order
 math.partial-dispatch generic generic.standard generic.math
 classes.algebra classes.union sets quotations assocs combinators
-words namespaces continuations
+words namespaces continuations classes fry
 compiler.tree
 compiler.tree.builder
 compiler.tree.recursive
@@ -26,7 +26,7 @@ GENERIC: splicing-nodes ( #call word/quot/f -- nodes )
 M: word splicing-nodes
     [ [ in-d>> ] [ out-d>> ] bi ] dip #call 1array ;
 
-M: quotation splicing-nodes
+M: callable splicing-nodes
     build-sub-tree analyze-recursive normalize ;
 
 : propagate-body ( #call -- )
@@ -140,18 +140,21 @@ SYMBOL: history
 : remember-inlining ( word -- )
     history [ swap suffix ] change ;
 
-: inline-word ( #call word -- ? )
+: inline-word-def ( #call word quot -- ? )
-    dup history get memq? [
+    over history get memq? [
-        2drop f
+        3drop f
     ] [
         [
-            dup remember-inlining
+            swap remember-inlining
-            dupd def>> splicing-nodes >>body
+            dupd splicing-nodes >>body
             propagate-body
         ] with-scope
         t
     ] if ;
 
+: inline-word ( #call word -- ? )
+    dup def>> inline-word-def ;
+
 : inline-method-body ( #call word -- ? )
     2dup should-inline? [ inline-word ] [ 2drop f ] if ;
 
@@ -165,6 +168,10 @@ SYMBOL: history
     [ dup 1array ] [ "custom-inlining" word-prop ] bi* with-datastack
     first object swap eliminate-dispatch ;
 
+: inline-instance-check ( #call word -- ? )
+    over in-d>> second value-info literal>> dup class?
+    [ "predicate" word-prop '[ drop @ ] inline-word-def ] [ 3drop f ] if ;
+
 : do-inlining ( #call word -- ? )
     #! If the generic was defined in an outer compilation unit,
     #! then it doesn't have a definition yet; the definition
@@ -177,6 +184,7 @@ SYMBOL: history
     {
         { [ dup deferred? ] [ 2drop f ] }
         { [ dup custom-inlining? ] [ inline-custom ] }
+        { [ dup \ instance? eq? ] [ inline-instance-check ] }
         { [ dup always-inline-word? ] [ inline-word ] }
         { [ dup standard-generic? ] [ inline-standard-method ] }
         { [ dup math-generic? ] [ inline-math-method ] }

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

@@ -8,7 +8,7 @@ math.functions math.private strings layouts
 compiler.tree.propagation.info compiler.tree.def-use
 compiler.tree.debugger compiler.tree.checker
 slots.private words hashtables classes assocs locals
-float-arrays system sorting math.libm ;
+specialized-arrays.double system sorting math.libm ;
 IN: compiler.tree.propagation.tests
 
 \ propagate must-infer
@@ -167,7 +167,8 @@ IN: compiler.tree.propagation.tests
 
 [ V{ fixnum } ] [
     [
-        [ uchar-nth ] 2keep [ uchar-nth ] 2keep uchar-nth
+        { fixnum byte-array } declare
+        [ nth-unsafe ] 2keep [ nth-unsafe ] 2keep nth-unsafe
         >r >r 298 * r> 100 * - r> 208 * - 128 + -8 shift
         255 min 0 max
     ] final-classes
@@ -588,7 +589,7 @@ MIXIN: empty-mixin
     [ { fixnum integer } declare bitand ] final-classes
 ] unit-test
 
-[ V{ float-array } ] [ [| | F{ } ] final-classes ] unit-test
+[ V{ double-array } ] [ [| | double-array{ } ] final-classes ] unit-test
 
 [ V{ t } ] [ [ netbsd unix? ] final-literals ] unit-test
 

basis/core-foundation/core-foundation.factor

@@ -104,7 +104,7 @@ FUNCTION: CFTypeID CFGetTypeID ( CFTypeRef cf ) ;
     CF>array [ CF>string ] map ;
 
 : <CFStringArray> ( seq -- alien )
-    [ <CFString> ] map dup <CFArray> swap [ CFRelease ] each ;
+    [ <CFString> ] map [ <CFArray> ] [ [ CFRelease ] each ] bi ;
 
 : <CFFileSystemURL> ( string dir? -- url )
     [ <CFString> f over kCFURLPOSIXPathStyle ] dip

basis/core-foundation/fsevents/fsevents.factor

@@ -4,7 +4,9 @@ USING: alien alien.c-types alien.strings alien.syntax kernel
 math sequences namespaces make assocs init accessors
 continuations combinators core-foundation
 core-foundation.run-loop core-foundation.run-loop.thread
-io.encodings.utf8 destructors locals arrays ;
+io.encodings.utf8 destructors locals arrays
+specialized-arrays.direct.alien specialized-arrays.direct.int
+specialized-arrays.direct.longlong ;
 IN: core-foundation.fsevents
 
 : kFSEventStreamCreateFlagUseCFTypes 2 ; inline
@@ -160,11 +162,12 @@ SYMBOL: event-stream-callbacks
 : remove-event-source-callback ( id -- )
     event-stream-callbacks get delete-at ;
 
-:: >event-triple ( n eventPaths eventFlags eventIds -- triple )
+:: (master-event-source-callback) ( eventStream info numEvents eventPaths eventFlags eventIds -- )
-    n eventPaths void*-nth utf8 alien>string
+    eventPaths numEvents <direct-void*-array> [ utf8 alien>string ] { } map-as
-    n eventFlags int-nth
+    eventFlags numEvents <direct-int-array>
-    n eventIds longlong-nth
+    eventIds numEvents <direct-longlong-array>
-    3array ;
+    3array flip
+    info event-stream-callbacks get at [ drop ] or call ;
 
 : master-event-source-callback ( -- alien )
     "void"
@@ -176,19 +179,15 @@ SYMBOL: event-stream-callbacks
         "FSEventStreamEventFlags*"
         "FSEventStreamEventId*"
     }
-    "cdecl" [
+    "cdecl" [ (master-event-source-callback) ] alien-callback ;
-        [ >event-triple ] 3curry map
-        swap event-stream-callbacks get at
-        dup [ call drop ] [ 3drop ] if
-    ] alien-callback ;
 
 TUPLE: event-stream info handle disposed ;
 
 : <event-stream> ( quot paths latency flags -- event-stream )
-    >r >r >r
+    [
         add-event-source-callback dup
-    >r master-event-source-callback r>
+        [ master-event-source-callback ] dip
-    r> r> r> <FSEventStream>
+    ] 3dip <FSEventStream>
     dup enable-event-stream
     f event-stream boa ;
 

basis/db/postgresql/lib/lib.factor

@@ -5,7 +5,8 @@ quotations sequences db.postgresql.ffi alien alien.c-types
 db.types tools.walker ascii splitting math.parser combinators
 libc shuffle calendar.format byte-arrays destructors prettyprint
 accessors strings serialize io.encodings.binary io.encodings.utf8
-alien.strings io.streams.byte-array summary present urls ;
+alien.strings io.streams.byte-array summary present urls
+specialized-arrays.uint specialized-arrays.alien ;
 IN: db.postgresql.lib
 
 : postgresql-result-error-message ( res -- str/f )
@@ -64,7 +65,7 @@ M: postgresql-result-null summary ( obj -- str )
     } case ;
 
 : param-types ( statement -- seq )
-    in-params>> [ type>> type>oid ] map >c-uint-array ;
+    in-params>> [ type>> type>oid ] uint-array{ } map-as underlying>> ;
 
 : malloc-byte-array/length ( byte-array -- alien length )
     [ malloc-byte-array &free ] [ length ] bi ;
@@ -90,11 +91,11 @@ M: postgresql-result-null summary ( obj -- str )
     ] 2map flip [
         f f
     ] [
-        first2 [ >c-void*-array ] [ >c-uint-array ] bi*
+        first2 [ >void*-array underlying>> ] [ >uint-array underlying>> ] bi*
     ] if-empty ;
 
 : param-formats ( statement -- seq )
-    in-params>> [ type>> type>param-format ] map >c-uint-array ;
+    in-params>> [ type>> type>param-format ] uint-array{ } map-as underlying>> ;
 
 : do-postgresql-bound-statement ( statement -- res )
     [

basis/float-arrays/float-arrays-docs.factor

@@ -1,62 +0,0 @@
-USING: arrays bit-arrays vectors strings sbufs
-kernel help.markup help.syntax math ;
-IN: float-arrays
-
-ARTICLE: "float-arrays" "Float arrays"
-"Float arrays are fixed-size mutable sequences (" { $link "sequence-protocol" } ") whose elements are instances of " { $link float } ". Elements are unboxed, hence the memory usage is lower than an equivalent " { $link array } " of floats."
-$nl
-"Float array words are in the " { $vocab-link "float-arrays" } " vocabulary."
-$nl
-"Float arrays play a special role in the C library interface; they can be used to pass binary data back and forth between Factor and C. See " { $link "c-byte-arrays" } "."
-$nl
-"Float arrays form a class of objects."
-{ $subsection float-array }
-{ $subsection float-array? }
-"There are several ways to construct float arrays."
-{ $subsection >float-array }
-{ $subsection <float-array> }
-"Creating a float array from several elements on the stack:"
-{ $subsection 1float-array }
-{ $subsection 2float-array }
-{ $subsection 3float-array }
-{ $subsection 4float-array }
-"Float array literal syntax:"
-{ $subsection POSTPONE: F{ } ;
-
-ABOUT: "float-arrays"
-
-HELP: F{
-{ $syntax "F{ elements... }" }
-{ $values { "elements" "a list of real numbers" } }
-{ $description "Marks the beginning of a literal float array. Literal float arrays are terminated by " { $link POSTPONE: } } "." } 
-{ $examples { $code "F{ 1.0 2.0 3.0 }" } } ;
-
-HELP: float-array
-{ $description "The class of float arrays." } ;
-
-HELP: <float-array> ( n -- float-array )
-{ $values { "n" "a non-negative integer" } { "float-array" "a new float array" } }
-{ $description "Creates a new float array holding " { $snippet "n" } " floats with all elements initially set to " { $snippet "0.0" } "." } ;
-
-HELP: >float-array
-{ $values { "seq" "a sequence" } { "float-array" float-array } }
-{ $description "Outputs a freshly-allocated float array whose elements have the same floating-point values as a given sequence." }
-{ $errors "Throws an error if the sequence contains elements other than real numbers." } ;
-
-HELP: 1float-array
-{ $values { "x" object } { "array" float-array } }
-{ $description "Create a new float array with one element." } ;
-
-{ 1array 2array 3array 4array } related-words
-
-HELP: 2float-array
-{ $values { "x" object } { "y" object } { "array" float-array } }
-{ $description "Create a new float array with two elements, with " { $snippet "x" } " appearing first." } ;
-
-HELP: 3float-array
-{ $values { "x" object } { "y" object } { "z" object } { "array" float-array } }
-{ $description "Create a new float array with three elements, with " { $snippet "x" } " appearing first." } ;
-
-HELP: 4float-array
-{ $values { "w" object } { "x" object } { "y" object } { "z" object } { "array" float-array } }
-{ $description "Create a new float array with four elements, with " { $snippet "w" } " appearing first." } ;

basis/float-arrays/float-arrays-tests.factor

@@ -1,12 +0,0 @@
-IN: float-arrays.tests
-USING: float-arrays tools.test sequences.private ;
-
-[ F{ 0.0 0.0 0.0 } ] [ 3 <float-array> ] unit-test
-
-[ F{ 1 2 3 0 0 0 } ] [ 6 F{ 1 2 3 } resize ] unit-test
-
-[ F{ 1 2 } ] [ 2 F{ 1 2 3 4 5 6 7 8 9 } resize ] unit-test
-
-[ -10 F{ } resize ] must-fail
-
-[ F{ 1.3 } ] [ 1.3 1float-array ] unit-test

basis/float-arrays/float-arrays.factor

@@ -1,130 +0,0 @@
-! Copyright (C) 2007, 2008 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: kernel kernel.private alien.accessors sequences
-sequences.private math math.private byte-arrays accessors
-alien.c-types parser prettyprint.backend combinators ;
-IN: float-arrays
-
-TUPLE: float-array
-{ length array-capacity read-only }
-{ underlying byte-array read-only } ;
-
-: <float-array> ( n -- float-array )
-    dup "double" <c-array> float-array boa ; inline
-
-M: float-array clone
-    [ length>> ] [ underlying>> clone ] bi float-array boa ;
-
-M: float-array length length>> ;
-
-M: float-array nth-unsafe
-    underlying>> double-nth ;
-
-M: float-array set-nth-unsafe
-    [ >float ] 2dip underlying>> set-double-nth ;
-
-: >float-array ( seq -- float-array )
-    T{ float-array } clone-like ; inline
-
-M: float-array like
-    drop dup float-array? [ >float-array ] unless ;
-
-M: float-array new-sequence
-    drop <float-array> ;
-
-M: float-array equal?
-    over float-array? [ sequence= ] [ 2drop f ] if ;
-
-M: float-array resize
-    [ drop ] [
-        [ "double" heap-size * ] [ underlying>> ] bi*
-        resize-byte-array
-    ] 2bi
-    float-array boa ;
-
-M: float-array byte-length length "double" heap-size * ;
-
-INSTANCE: float-array sequence
-
-: 1float-array ( x -- array )
-    1 <float-array> [ set-first ] keep ; inline
-
-: 2float-array ( x y -- array )
-    T{ float-array } 2sequence ; inline
-
-: 3float-array ( x y z -- array )
-    T{ float-array } 3sequence ; inline
-
-: 4float-array ( w x y z -- array )
-    T{ float-array } 4sequence ; inline
-
-: F{ \ } [ >float-array ] parse-literal ; parsing
-
-M: float-array pprint-delims drop \ F{ \ } ;
-M: float-array >pprint-sequence ;
-M: float-array pprint* pprint-object ;
-
-! Specializer hints
-USING: hints math.vectors arrays ;
-
-HINTS: <float-array> { 2 } { 3 } ;
-
-HINTS: vneg { array } { float-array } ;
-HINTS: v*n { array object } { float-array float } ;
-HINTS: n*v { array object } { float float-array } ;
-HINTS: v/n { array object } { float-array float } ;
-HINTS: n/v { object array } { float float-array } ;
-HINTS: v+ { array array } { float-array float-array } ;
-HINTS: v- { array array } { float-array float-array } ;
-HINTS: v* { array array } { float-array float-array } ;
-HINTS: v/ { array array } { float-array float-array } ;
-HINTS: vmax { array array } { float-array float-array } ;
-HINTS: vmin { array array } { float-array float-array } ;
-HINTS: v. { array array } { float-array float-array } ;
-HINTS: norm-sq { array } { float-array } ;
-HINTS: norm { array } { float-array } ;
-HINTS: normalize { array } { float-array } ;
-HINTS: distance { array array } { float-array float-array } ;
-
-! Type functions
-USING: words classes.algebra compiler.tree.propagation.info
-math.intervals ;
-
-{ v+ v- v* v/ vmax vmin } [
-    [
-        [ class>> float-array class<= ] both?
-        float-array object ? <class-info>
-    ] "outputs" set-word-prop
-] each
-
-{ n*v n/v } [
-    [
-        nip class>> float-array class<= float-array object ? <class-info>
-    ] "outputs" set-word-prop
-] each
-
-{ v*n v/n } [
-    [
-        drop class>> float-array class<= float-array object ? <class-info>
-    ] "outputs" set-word-prop
-] each
-
-{ vneg normalize } [
-    [
-        class>> float-array class<= float-array object ? <class-info>
-    ] "outputs" set-word-prop
-] each
-
-\ norm-sq [
-    class>> float-array class<= [ float 0. 1/0. [a,b] <class/interval-info> ] [ object-info ] if
-] "outputs" set-word-prop
-
-\ v. [
-    [ class>> float-array class<= ] both?
-    float object ? <class-info>
-] "outputs" set-word-prop
-
-\ distance [
-    [ class>> float-array class<= ] both?
-    [ float 0. 1/0. [a,b] <class/interval-info> ] [ object-info ] if
-] "outputs" set-word-prop

basis/float-arrays/summary.txt

@@ -1 +0,0 @@
-Efficient fixed-length floating point number arrays

basis/float-vectors/float-vectors-docs.factor

@@ -1,37 +0,0 @@
-USING: arrays float-arrays help.markup help.syntax kernel
-combinators ;
-IN: float-vectors
-
-ARTICLE: "float-vectors" "Float vectors"
-"A float vector is a resizable mutable sequence of unsigned floats. 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> }
-"Literal syntax:"
-{ $subsection POSTPONE: FV{ }
-"If you don't care about initial capacity, a more elegant way to create a new float vector is to write:"
-{ $code "FV{ } clone" } ;
-
-ABOUT: "float-vectors"
-
-HELP: float-vector
-{ $description "The class of resizable float vectors. See " { $link "float-vectors" } " for 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: 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 }" } } ;

basis/float-vectors/float-vectors-tests.factor

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

basis/float-vectors/float-vectors.factor

@@ -1,38 +0,0 @@
-! 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 prettyprint.backend
-parser accessors ;
-IN: float-vectors
-
-TUPLE: float-vector
-{ underlying float-array initial: F{ } }
-{ length array-capacity } ;
-
-: <float-vector> ( n -- float-vector )
-    <float-array> 0 float-vector boa ; inline
-
-: >float-vector ( seq -- float-vector )
-    T{ float-vector f F{ } 0 } clone-like ;
-
-M: float-vector like
-    drop dup float-vector? [
-        dup float-array?
-        [ dup length float-vector boa ] [ >float-vector ] if
-    ] unless ;
-
-M: float-vector new-sequence
-    drop [ <float-array> ] [ >fixnum ] bi float-vector boa ;
-
-M: float-vector equal?
-    over float-vector? [ sequence= ] [ 2drop f ] if ;
-
-M: float-array new-resizable drop <float-vector> ;
-
-INSTANCE: float-vector growable
-
-: FV{ \ } [ >float-vector ] parse-literal ; parsing
-
-M: float-vector >pprint-sequence ;
-M: float-vector pprint-delims drop \ FV{ \ } ;
-M: float-vector pprint* pprint-object ;

basis/float-vectors/summary.txt

@@ -1 +0,0 @@
-Growable float arrays

basis/functors/functors-tests.factor

@@ -0,0 +1,47 @@
+IN: functors.tests
+USING: functors tools.test math words kernel ;
+
+<<
+
+FUNCTOR: define-box ( T -- )
+
+B DEFINES ${T}-box
+<B> DEFINES <${B}>
+
+WHERE
+
+TUPLE: B { value T } ;
+
+C: <B> B
+
+;FUNCTOR
+
+\ float define-box
+
+>>
+
+{ 1 0 } [ define-box ] must-infer-as
+
+[ T{ float-box f 5.0 } ] [ 5.0 <float-box> ] unit-test
+
+: twice ( word -- )
+    [ execute ] [ execute ] bi ; inline
+<<
+
+FUNCTOR: wrapper-test ( W -- )
+
+WW DEFINES ${W}${W}
+
+WHERE
+
+: WW W twice ; inline
+
+;FUNCTOR
+
+\ sq wrapper-test
+
+>>
+
+\ sqsq must-infer
+
+[ 16 ] [ 2 sqsq ] unit-test

basis/functors/functors.factor

@@ -0,0 +1,106 @@
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel locals.private quotations classes.tuple make
+combinators generic words interpolate namespaces sequences
+io.streams.string fry classes.mixin effects lexer parser
+classes.tuple.parser effects.parser ;
+IN: functors
+
+: scan-param ( -- obj )
+    scan-object dup special? [ literalize ] unless ;
+
+: define* ( word def effect -- ) pick set-word define-declared ;
+
+: DEFINE* ( accum -- accum ) effect get parsed \ define* parsed ;
+
+: `TUPLE:
+    scan-param parsed
+    scan {
+        { ";" [ tuple parsed f parsed ] }
+        { "<" [ scan-param [ parse-tuple-slots ] { } make parsed ] }
+        [
+            [ tuple parsed ] dip
+            [ parse-slot-name [ parse-tuple-slots ] when ] { }
+            make parsed
+        ]
+    } case
+    \ define-tuple-class parsed ; parsing
+
+: `M:
+    effect off
+    scan-param parsed
+    scan-param parsed
+    \ create-method parsed
+    parse-definition parsed
+    DEFINE* ; parsing
+
+: `C:
+    effect off
+    scan-param parsed
+    scan-param parsed
+    [ [ boa ] curry ] over push-all
+    DEFINE* ; parsing
+
+: `:
+    effect off
+    scan-param parsed
+    parse-definition parsed
+    DEFINE* ; parsing
+
+: `INSTANCE:
+    scan-param parsed
+    scan-param parsed
+    \ add-mixin-instance parsed ; parsing
+
+: `inline \ inline parsed ; parsing
+
+: `parsing \ parsing parsed ; parsing
+
+: `(
+    ")" parse-effect effect set ; parsing
+
+: (INTERPOLATE) ( accum quot -- accum )
+    [ scan interpolate-locals ] dip
+    '[ _ with-string-writer @ ] parsed ;
+
+: IS [ dup search [ ] [ no-word ] ?if ] (INTERPOLATE) ; parsing
+
+: DEFINES [ create-in ] (INTERPOLATE) ; parsing
+
+DEFER: ;FUNCTOR delimiter
+
+: functor-words ( -- assoc )
+    H{
+        { "TUPLE:" POSTPONE: `TUPLE: }
+        { "M:" POSTPONE: `M: }
+        { "C:" POSTPONE: `C: }
+        { ":" POSTPONE: `: }
+        { "INSTANCE:" POSTPONE: `INSTANCE: }
+        { "inline" POSTPONE: `inline }
+        { "parsing" POSTPONE: `parsing }
+        { "(" POSTPONE: `( }
+    } ;
+
+: push-functor-words ( -- )
+    functor-words use get push ;
+
+: pop-functor-words ( -- )
+    functor-words use get delq ;
+
+: parse-functor-body ( -- form )
+    t in-lambda? [
+        V{ } clone
+        push-functor-words
+        "WHERE" parse-bindings* \ ;FUNCTOR (parse-lambda)
+        <let*> parsed-lambda
+        pop-functor-words
+        >quotation
+    ] with-variable ;
+
+: (FUNCTOR:) ( -- word def )
+    CREATE
+    parse-locals
+    parse-functor-body swap pop-locals <lambda>
+    lambda-rewrite first ;
+
+: FUNCTOR: (FUNCTOR:) define ; parsing

basis/functors/summary.txt

@@ -0,0 +1 @@
+First-class syntax

basis/functors/tags.txt

@@ -0,0 +1 @@
+extensions

basis/help/cookbook/cookbook.factor

@@ -205,10 +205,10 @@ ARTICLE: "cookbook-io" "Input and output cookbook"
 }
 "Convert a file of 4-byte cells from little to big endian or vice versa, by directly mapping it into memory and operating on it with sequence words:"
 { $code
-    "USING: accessors grouping io.files io.mmap kernel sequences ;"
+    "USING: accessors grouping io.files io.mmap.char kernel sequences ;"
-    "\"mydata.dat\" dup file-info size>> ["
+    "\"mydata.dat\" ["
     "    4 <sliced-groups> [ reverse-here ] change-each"
-    "] with-mapped-file"
+    "] with-mapped-char-file"
 }
 "Send some bytes to a remote host:"
 { $code

basis/io/mmap/alien/alien.factor

@@ -0,0 +1,4 @@
+USING: io.mmap.functor specialized-arrays.direct.alien ;
+IN: io.mmap.alien
+
+<< "void*" define-mapped-array >>

basis/io/mmap/bool/bool.factor

@@ -0,0 +1,4 @@
+USING: io.mmap.functor specialized-arrays.direct.bool ;
+IN: io.mmap.bool
+
+<< "bool" define-mapped-array >>

basis/io/mmap/char/char.factor

@@ -0,0 +1,4 @@
+USING: io.mmap.functor specialized-arrays.direct.char ;
+IN: io.mmap.char
+
+<< "char" define-mapped-array >>

basis/io/mmap/double/double.factor

@@ -0,0 +1,4 @@
+USING: io.mmap.functor specialized-arrays.direct.double ;
+IN: io.mmap.double
+
+<< "double" define-mapped-array >>

basis/io/mmap/float/float.factor

@@ -0,0 +1,4 @@
+USING: io.mmap.functor specialized-arrays.direct.float ;
+IN: io.mmap.float
+
+<< "float" define-mapped-array >>

basis/io/mmap/functor/functor.factor

@@ -0,0 +1,28 @@
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: io.mmap functors accessors alien.c-types math kernel
+words fry ;
+IN: io.mmap.functor
+
+SLOT: address
+SLOT: length
+
+: mapped-file>direct ( mapped-file type -- alien length )
+    [ [ address>> ] [ length>> ] bi ] dip
+    heap-size [ 1- + ] keep /i ;
+
+FUNCTOR: define-mapped-array ( T -- )
+
+<mapped-A>         DEFINES <mapped-${T}-array>
+<A>                IS      <direct-${T}-array>
+with-mapped-A-file DEFINES with-mapped-${T}-file
+
+WHERE
+
+: <mapped-A> ( mapped-file -- direct-array )
+    T mapped-file>direct <A> execute ; inline
+
+: with-mapped-A-file ( path length quot -- )
+    '[ <mapped-A> execute @ ] with-mapped-file ; inline
+
+;FUNCTOR

basis/io/mmap/int/int.factor

@@ -0,0 +1,4 @@
+USING: io.mmap.functor specialized-arrays.direct.int ;
+IN: io.mmap.int
+
+<< "int" define-mapped-array >>

basis/io/mmap/long/long.factor

@@ -0,0 +1,4 @@
+USING: io.mmap.functor specialized-arrays.direct.long ;
+IN: io.mmap.long
+
+<< "long" define-mapped-array >>

basis/io/mmap/longlong/longlong.factor

@@ -0,0 +1,4 @@
+USING: io.mmap.functor specialized-arrays.direct.longlong ;
+IN: io.mmap.longlong
+
+<< "longlong" define-mapped-array >>

basis/io/mmap/mmap-docs.factor

@@ -11,13 +11,13 @@ HELP: mapped-file
 } ;
 
 HELP: <mapped-file>
-{ $values { "path" "a pathname string" } { "length" integer } { "mmap" mapped-file } }
+{ $values { "path" "a pathname string" }  { "mmap" mapped-file } }
-{ $contract "Opens a file and maps the first " { $snippet "length" } " bytes into memory. The length is permitted to exceed the length of the file on disk, in which case the remaining space is padded with zero bytes." }
+{ $contract "Opens a file and maps its contents into memory. The length is permitted to exceed the length of the file on disk, in which case the remaining space is padded with zero bytes." }
-{ $notes "You must call " { $link close-mapped-file } " when you are finished working with the returned object, to reclaim resources. The " { $link with-mapped-file } " provides an abstraction which can close the mapped file for you." }
+{ $notes "You must call " { $link dispose } " when you are finished working with the returned object, to reclaim resources. The " { $link with-mapped-file } " provides an abstraction which can close the mapped file for you." }
 { $errors "Throws an error if a memory mapping could not be established." } ;
 
 HELP: with-mapped-file
-{ $values { "path" "a pathname string" } { "length" integer } { "quot" { $quotation "( mmap -- )" } } }
+{ $values { "path" "a pathname string" } { "quot" { $quotation "( mmap -- )" } } }
 { $contract "Opens a file and maps its contents into memory, passing the " { $link mapped-file } " instance to the quotation. The mapped file is disposed of when the quotation returns, or if an error is thrown." }
 { $errors "Throws an error if a memory mapping could not be established." } ;
 
@@ -26,6 +26,33 @@ HELP: close-mapped-file
 { $contract "Releases system resources associated with the mapped file. This word should not be called by user code; use " { $link dispose } " instead." }
 { $errors "Throws an error if a memory mapping could not be established." } ;
 
+ARTICLE: "io.mmap.arrays" "Memory-mapped arrays"
+"Mapped file can be viewed as a sequence using the words in sub-vocabularies of " { $vocab-link "io.mmap" } ". For each primitive C type " { $snippet "T" } ", a set of words are defined in the vocabulary named " { $snippet "io.mmap.T" } ":"
+{ $table
+    { { $snippet "<mapped-T-array>" } { "Wraps a " { $link mapped-file } " in a sequence; stack effect " { $snippet "( mapped-file -- direct-array )" } } }
+    { { $snippet "with-mapped-T-file" } { "Maps a file into memory and wraps it in a sequence by combining " { $link with-mapped-file } " and " { $snippet "<mapped-T-array>" } "; stack effect " { $snippet "( path quot -- )" } } }
+}
+"The primitive C types for which mapped arrays exist:"
+{ $list
+    { $snippet "char" }
+    { $snippet "uchar" }
+    { $snippet "short" }
+    { $snippet "ushort" }
+    { $snippet "int" }
+    { $snippet "uint" }
+    { $snippet "long" }
+    { $snippet "ulong" }
+    { $snippet "longlong" }
+    { $snippet "ulonglong" }
+    { $snippet "float" }
+    { $snippet "double" }
+    { $snippet "void*" }
+    { $snippet "bool" }
+} ;
+
+ARTICLE: "io.mmap.low-level" "Reading and writing mapped files directly"
+"Data can be read and written from the " { $link mapped-file } " by applying low-level alien words to the " { $slot "address" } " slot. See " { $link "reading-writing-memory" } "." ;
+
 ARTICLE: "io.mmap" "Memory-mapped files"
 "The " { $vocab-link "io.mmap" } " vocabulary implements support for memory-mapped files."
 { $subsection <mapped-file> }
@@ -33,7 +60,8 @@ ARTICLE: "io.mmap" "Memory-mapped files"
 $nl
 "A utility combinator which wraps the above:"
 { $subsection with-mapped-file }
-"Memory mapped files implement the " { $link "sequence-protocol" } " and present themselves as a sequence of bytes. The underlying memory area can also be accessed directly with the " { $snippet "address" } " slot." $nl
+"Instances of " { $link mapped-file } " don't support any interesting operations in themselves. There are two facilities for accessing their contents:"
-"Data can be read and written from the memory area using alien words. See " { $link "reading-writing-memory" } "." ;
+{ $subsection "io.mmap.arrays" }
+{ $subsection "io.mmap.low-level" } ;
 
 ABOUT: "io.mmap"

basis/io/mmap/mmap-tests.factor

@@ -1,10 +1,10 @@
-USING: io io.mmap io.files kernel tools.test continuations
+USING: io io.mmap io.mmap.char io.files kernel tools.test
-sequences io.encodings.ascii accessors ;
+continuations sequences io.encodings.ascii accessors ;
 IN: io.mmap.tests
 
 [ "mmap-test-file.txt" temp-file delete-file ] ignore-errors
 [ ] [ "12345" "mmap-test-file.txt" temp-file ascii set-file-contents ] unit-test
-[ ] [ "mmap-test-file.txt" temp-file dup file-info size>> [ CHAR: 2 0 pick set-nth drop ] with-mapped-file ] unit-test
+[ ] [ "mmap-test-file.txt" temp-file [ CHAR: 2 0 pick set-nth drop ] with-mapped-char-file ] unit-test
-[ 5 ] [ "mmap-test-file.txt" temp-file dup file-info size>> [ length ] with-mapped-file ] unit-test
+[ 5 ] [ "mmap-test-file.txt" temp-file [ length ] with-mapped-char-file ] unit-test
 [ "22345" ] [ "mmap-test-file.txt" temp-file ascii file-contents ] unit-test
 [ "mmap-test-file.txt" temp-file delete-file ] ignore-errors

basis/io/mmap/mmap.factor

@@ -1,34 +1,24 @@
 ! Copyright (C) 2007, 2008 Doug Coleman, Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: continuations destructors io.backend kernel quotations
+USING: continuations destructors io.files io.backend kernel
-sequences system alien alien.accessors accessors
+quotations system alien alien.accessors accessors system
-sequences.private system vocabs.loader combinators ;
+vocabs.loader combinators alien.c-types ;
 IN: io.mmap
 
 TUPLE: mapped-file address handle length disposed ;
 
-M: mapped-file length dup check-disposed length>> ;
-
-M: mapped-file nth-unsafe
-    dup check-disposed address>> swap alien-unsigned-1 ;
-
-M: mapped-file set-nth-unsafe
-    dup check-disposed address>> swap set-alien-unsigned-1 ;
-
-INSTANCE: mapped-file sequence
-
 HOOK: (mapped-file) io-backend ( path length -- address handle )
 
-: <mapped-file> ( path length -- mmap )
+: <mapped-file> ( path -- mmap )
-    [ >r normalize-path r> (mapped-file) ] keep
+    [ normalize-path ] [ file-info size>> ] bi [ (mapped-file) ] keep
     f mapped-file boa ;
 
 HOOK: close-mapped-file io-backend ( mmap -- )
 
 M: mapped-file dispose* ( mmap -- ) close-mapped-file ;
 
-: with-mapped-file ( path length quot -- )
+: with-mapped-file ( path quot -- )
-    >r <mapped-file> r> with-disposal ; inline
+    [ <mapped-file> ] dip with-disposal ; inline
 
 {
     { [ os unix? ] [ "io.unix.mmap" require ] }

basis/io/mmap/short/short.factor

@@ -0,0 +1,4 @@
+USING: io.mmap.functor specialized-arrays.direct.short ;
+IN: io.mmap.short
+
+<< "short" define-mapped-array >>

basis/io/mmap/uchar/uchar.factor

@@ -0,0 +1,4 @@
+USING: io.mmap.functor specialized-arrays.direct.uchar ;
+IN: io.mmap.uchar
+
+<< "uchar" define-mapped-array >>

basis/io/mmap/uint/uint.factor

@@ -0,0 +1,4 @@
+USING: io.mmap.functor specialized-arrays.direct.uint ;
+IN: io.mmap.uint
+
+<< "uint" define-mapped-array >>

basis/io/mmap/ulong/ulong.factor

@@ -0,0 +1,4 @@
+USING: io.mmap.functor specialized-arrays.direct.ulong ;
+IN: io.mmap.ulong
+
+<< "ulong" define-mapped-array >>

basis/io/mmap/ulonglong/ulonglong.factor

@@ -0,0 +1,4 @@
+USING: io.mmap.functor specialized-arrays.direct.ulonglong ;
+IN: io.mmap.ulonglong
+
+<< "ulonglong" define-mapped-array >>

basis/io/mmap/ushort/ushort.factor

@@ -0,0 +1,4 @@
+USE: specialized-arrays.functor
+IN: specialized-arrays.ushort
+
+<< "ushort" define-array >>

basis/io/unix/files/files.factor

@@ -80,7 +80,7 @@ TUPLE: unix-file-system-info < file-system-info
 block-size preferred-block-size
 blocks blocks-free blocks-available
 files files-free files-available
-name-max flags id id0 id1 ;
+name-max flags id ;
 
 HOOK: new-file-system-info os ( --  file-system-info )
 
@@ -108,8 +108,6 @@ M: unix statvfs>file-system-info drop ;
         [ dup [ blocks-free>> ] [ block-size>> ] bi * >>free-space drop ]
         [ dup [ blocks>> ] [ block-size>> ] bi * >>total-space drop ]
         [ dup [ total-space>> ] [ free-space>> ] bi - >>used-space drop ]
-        [ dup id>> 2 c-uint-array> first2 [ >>id0 ] [ >>id1 ] bi* drop ]
-        [ f >>id drop ]
         [ ]
     } cleave ;
 
@@ -316,8 +314,7 @@ PRIVATE>
 <PRIVATE
 
 : make-timeval-array ( array -- byte-array )
-    [ length "timeval" <c-array> ] keep
+    [ [ "timeval" <c-object> ] unless* ] map concat ;
-    dup length [ over [ pick set-timeval-nth ] [ 2drop ] if ] 2each ;
 
 : timestamp>timeval ( timestamp -- timeval )
     unix-1970 time- duration>microseconds make-timeval ;

basis/io/unix/pipes/pipes.factor

@@ -1,11 +1,11 @@
 ! Copyright (C) 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: system alien.c-types kernel unix math sequences
+USING: system kernel unix math sequences qualified
-qualified io.unix.backend io.ports ;
+io.unix.backend io.ports specialized-arrays.int accessors ;
 IN: io.unix.pipes
 QUALIFIED: io.pipes
 
 M: unix io.pipes:(pipe) ( -- pair )
-    2 "int" <c-array>
+    2 <int-array>
-    dup pipe io-error
+    [ underlying>> pipe io-error ]
-    2 c-int-array> first2 [ <fd> init-fd ] bi@ io.pipes:pipe boa ;
+    [ first2 [ <fd> init-fd ] bi@ io.pipes:pipe boa ] bi ;

basis/io/windows/launcher/launcher.factor

@@ -6,7 +6,8 @@ windows.types math windows.kernel32
 namespaces make io.launcher kernel sequences windows.errors
 splitting system threads init strings combinators
 io.backend accessors concurrency.flags io.files assocs
-io.files.private windows destructors ;
+io.files.private windows destructors specialized-arrays.ushort
+specialized-arrays.alien ;
 IN: io.windows.launcher
 
 TUPLE: CreateProcess-args
@@ -45,7 +46,7 @@ TUPLE: CreateProcess-args
     CreateProcess win32-error=0/f ;
 
 : count-trailing-backslashes ( str n -- str n )
-    >r "\\" ?tail r> swap [
+    [ "\\" ?tail ] dip swap [
         1+ count-trailing-backslashes
     ] when ;
 
@@ -84,8 +85,7 @@ TUPLE: CreateProcess-args
 
 : fill-lpApplicationName ( process args -- process args )
     over app-name/cmd-line
-    >r >>lpApplicationName
+    [ >>lpApplicationName ] [ >>lpCommandLine ] bi* ;
-    r> >>lpCommandLine ;
 
 : fill-lpCommandLine ( process args -- process args )
     over cmd-line >>lpCommandLine ;
@@ -103,7 +103,7 @@ TUPLE: CreateProcess-args
             over get-environment
             [ swap % "=" % % "\0" % ] assoc-each
             "\0" %
-        ] "" make >c-ushort-array
+        ] ushort-array{ } make underlying>>
         >>lpEnvironment
     ] when ;
 
@@ -157,8 +157,8 @@ M: windows kill-process* ( handle -- )
 
 M: windows wait-for-processes ( -- ? )
     processes get keys dup
-    [ handle>> PROCESS_INFORMATION-hProcess ] map
+    [ handle>> PROCESS_INFORMATION-hProcess ] void*-array{ } map-as
-    dup length swap >c-void*-array 0 0
+    [ length ] [ underlying>> ] bi 0 0
     WaitForMultipleObjects
     dup HEX: ffffffff = [ win32-error ] when
     dup WAIT_TIMEOUT = [ 2drop t ] [ swap nth process-exited f ] if ;

basis/io/windows/nt/monitors/monitors.factor

@@ -1,11 +1,12 @@
 ! Copyright (C) 2008 Doug Coleman, Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: alien alien.c-types libc destructors locals kernel math
+USING: alien alien.c-types alien.strings libc destructors locals
-assocs namespaces make continuations sequences hashtables
+kernel math assocs namespaces make continuations sequences
-sorting arrays combinators math.bitwise strings system accessors
+hashtables sorting arrays combinators math.bitwise strings
-threads splitting io.backend io.windows io.windows.nt.backend
+system accessors threads splitting io.backend io.windows
-io.windows.nt.files io.monitors io.ports io.buffers io.files
+io.windows.nt.backend io.windows.nt.files io.monitors io.ports
-io.timeouts io windows windows.kernel32 windows.types ;
+io.buffers io.files io.timeouts io.encodings.string io
+windows windows.kernel32 windows.types ;
 IN: io.windows.nt.monitors
 
 : open-directory ( path -- handle )
@@ -50,7 +51,7 @@ TUPLE: win32-monitor < monitor port ;
     } case 1array ;
 
 : memory>u16-string ( alien len -- string )
-    [ memory>byte-array ] keep 2/ c-ushort-array> >string ;
+    memory>byte-array utf16n decode ;
 
 : parse-notify-record ( buffer -- path changed )
     [

basis/libc/libc-docs.factor

@@ -32,10 +32,6 @@ HELP: free
 { $values { "alien" c-ptr } }
 { $description "Deallocates a block of memory allocated by " { $link malloc } ", " { $link calloc } " or " { $link realloc } "." } ;
 
-HELP: with-malloc
-{ $values { "size" "a positive integer" } { "quot" { $quotation "( c-ptr -- )" } } }
-{ $description "Allocates a zeroed block of " { $snippet "n" } " bytes and passes it to the quotation. When the quotation returns, the block is freed." } ;
-
 HELP: &free
 { $values { "alien" c-ptr } }
 { $description "Marks the block of memory for unconditional deallocation at the end of the current " { $link with-destructors } " scope." } ;

basis/libc/libc.factor

@@ -87,9 +87,6 @@ PRIVATE>
 : memcpy ( dst src size -- )
     "void" "libc" "memcpy" { "void*" "void*" "ulong" } alien-invoke ;
 
-: with-malloc ( size quot -- )
-    swap 1 calloc [ swap keep ] [ free ] [ ] cleanup ; inline
-
 : strlen ( alien -- len )
     "size_t" "libc" "strlen" { "char*" } alien-invoke ;
 

basis/locals/locals.factor

@@ -316,27 +316,26 @@ SYMBOL: in-lambda?
     "|" parse-tokens make-locals dup push-locals
     \ ] (parse-lambda) <lambda> ;
 
-: parse-binding ( -- pair/f )
+: parse-binding ( end -- pair/f )
     scan {
         { [ dup not ] [ unexpected-eof ] }
-        { [ dup "|" = ] [ drop f ] }
+        { [ 2dup = ] [ 2drop f ] }
-        { [ dup "!" = ] [ drop POSTPONE: ! parse-binding ] }
+        [ nip scan-object 2array ]
-        [ scan-object 2array ]
     } cond ;
 
-: (parse-bindings) ( -- )
+: (parse-bindings) ( end -- )
-    parse-binding [
+    dup parse-binding dup [
         first2 [ make-local ] dip 2array ,
         (parse-bindings)
-    ] when* ;
+    ] [ 2drop ] if ;
 
-: parse-bindings ( -- bindings vars )
+: parse-bindings ( end -- bindings vars )
     [
         [ (parse-bindings) ] H{ } make-assoc
         dup push-locals
     ] { } make swap ;
 
-: parse-bindings* ( -- words assoc )
+: parse-bindings* ( end -- words assoc )
     [
         [
             namespace push-locals
@@ -345,13 +344,13 @@ SYMBOL: in-lambda?
         ] { } make-assoc
     ] { } make swap ;
 
-: (parse-wbindings) ( -- )
+: (parse-wbindings) ( end -- )
-    parse-binding [
+    dup parse-binding dup [
         first2 [ make-local-word ] keep 2array ,
         (parse-wbindings)
-    ] when* ;
+    ] [ 2drop ] if ;
 
-: parse-wbindings ( -- bindings vars )
+: parse-wbindings ( end -- bindings vars )
     [
         [ (parse-wbindings) ] H{ } make-assoc
         dup push-locals
@@ -374,12 +373,12 @@ M: wlet local-rewrite*
     let-rewrite ;
 
 : parse-locals ( -- vars assoc )
-    ")" parse-effect
+    "(" expect ")" parse-effect
     word [ over "declared-effect" set-word-prop ] when*
     in>> [ dup pair? [ first ] when ] map make-locals dup push-locals ;
 
 : parse-locals-definition ( word -- word quot )
-    "(" expect parse-locals \ ; (parse-lambda) <lambda>
+    parse-locals \ ; (parse-lambda) <lambda>
     2dup "lambda" set-word-prop
     lambda-rewrite dup length 1 = [ first ] [ bad-lambda-rewrite ] if ;
 
@@ -397,15 +396,15 @@ PRIVATE>
 : [| parse-lambda parsed-lambda ; parsing
 
 : [let
-    "|" expect parse-bindings
+    "|" expect "|" parse-bindings
     \ ] (parse-lambda) <let> parsed-lambda ; parsing
 
 : [let*
-    "|" expect parse-bindings*
+    "|" expect "|" parse-bindings*
     \ ] (parse-lambda) <let*> parsed-lambda ; parsing
 
 : [wlet
-    "|" expect parse-wbindings
+    "|" expect "|" parse-wbindings
     \ ] (parse-lambda) <wlet> parsed-lambda ; parsing
 
 : :: (::) define ; parsing

basis/nibble-arrays/nibble-arrays-tests.factor

@@ -0,0 +1,6 @@
+USING: nibble-arrays tools.test sequences kernel math ;
+IN: nibble-arrays.tests
+
+[ t ] [ 16 dup >nibble-array sequence= ] unit-test
+[ N{ 4 2 1 3 } ] [ N{ 3 1 2 4 } reverse ] unit-test
+[ N{ 1 4 9 0 9 4 } ] [ N{ 1 2 3 4 5 6 } [ sq ] map ] unit-test

basis/nibble-arrays/nibble-arrays.factor

@@ -0,0 +1,71 @@
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: math kernel sequences sequences.private byte-arrays
+alien.c-types prettyprint.backend parser accessors ;
+IN: nibble-arrays
+
+TUPLE: nibble-array
+{ length array-capacity read-only }
+{ underlying byte-array read-only } ;
+
+<PRIVATE
+
+: nibble BIN: 1111 ; inline
+
+: nibbles>bytes 1 + 2/ ; inline
+
+: byte/nibble ( n -- shift n' )
+    [ 1 bitand 2 shift ] [ -1 shift ] bi ; inline
+
+: get-nibble ( n byte -- nibble )
+    swap neg shift nibble bitand ; inline
+
+: set-nibble ( value n byte -- byte' )
+    nibble pick shift bitnot bitand -rot shift bitor ; inline
+
+: nibble@ ( n nibble-array -- shift n' byte-array )
+    [ >fixnum byte/nibble ] [ underlying>> ] bi* ; inline
+
+PRIVATE>
+
+: <nibble-array> ( n -- nibble-array )
+    dup nibbles>bytes <byte-array> nibble-array boa ; inline
+
+M: nibble-array length length>> ;
+
+M: nibble-array nth-unsafe
+    nibble@ nth-unsafe get-nibble ;
+
+M: nibble-array set-nth-unsafe
+    nibble@ [ nth-unsafe set-nibble ] 2keep set-nth-unsafe ;
+
+M: nibble-array clone
+    [ length>> ] [ underlying>> clone ] bi nibble-array boa ;
+
+: >nibble-array ( seq -- nibble-array )
+    T{ nibble-array } clone-like ; inline
+
+M: nibble-array like
+    drop dup nibble-array? [ >nibble-array ] unless ;
+
+M: nibble-array new-sequence drop <nibble-array> ;
+
+M: nibble-array equal?
+    over nibble-array? [ sequence= ] [ 2drop f ] if ;
+
+M: nibble-array resize
+    [ drop ] [
+        [ nibbles>bytes ] [ underlying>> ] bi*
+        resize-byte-array
+    ] 2bi
+    nibble-array boa ;
+
+M: nibble-array byte-length length nibbles>bytes ;
+
+: N{ \ } [ >nibble-array ] parse-literal ; parsing
+
+INSTANCE: nibble-array sequence
+
+M: nibble-array pprint-delims drop \ N{ \ } ;
+M: nibble-array >pprint-sequence ;
+M: nibble-array pprint* pprint-object ;

basis/opengl/opengl.factor

@@ -6,7 +6,8 @@ USING: alien alien.c-types continuations kernel libc math macros
 namespaces math.vectors math.constants math.functions
 math.parser opengl.gl opengl.glu combinators arrays sequences
 splitting words byte-arrays assocs colors accessors
-generalizations locals memoize ;
+generalizations locals specialized-arrays.float
+specialized-arrays.uint ;
 IN: opengl
 
 : color>raw ( object -- r g b a )
@@ -52,20 +53,20 @@ MACRO: all-enabled-client-state ( seq quot -- )
     glMatrixMode glPopMatrix ; inline
 
 : gl-material ( face pname params -- )
-    >c-float-array glMaterialfv ;
+    float-array{ } like underlying>> glMaterialfv ;
 
 : gl-vertex-pointer ( seq -- )
-    [ 2 GL_FLOAT 0 ] dip glVertexPointer ; inline
+    [ 2 GL_FLOAT 0 ] dip underlying>> glVertexPointer ; inline
 
 : gl-color-pointer ( seq -- )
-    [ 4 GL_FLOAT 0 ] dip glColorPointer ; inline
+    [ 4 GL_FLOAT 0 ] dip underlying>> glColorPointer ; inline
 
 : gl-texture-coord-pointer ( seq -- )
-    [ 2 GL_FLOAT 0 ] dip glTexCoordPointer ; inline
+    [ 2 GL_FLOAT 0 ] dip underlying>> glTexCoordPointer ; inline
 
 : line-vertices ( a b -- )
-    [ first2 [ 0.5 + ] bi@ ] bi@ 4 narray
+    [ first2 [ 0.5 + ] bi@ ] bi@ 4 float-array{ } nsequence
-    >c-float-array gl-vertex-pointer ;
+    gl-vertex-pointer ;
 
 : gl-line ( a b -- )
     line-vertices GL_LINES 0 2 glDrawArrays ;
@@ -80,7 +81,7 @@ MACRO: all-enabled-client-state ( seq quot -- )
         [ [ first 0.3 - ] [ second 0.3 - ] bi ]
         [ second 0.3 - 0.5 swap ]
         [ drop 0.5 0.5 ]
-    } cleave 10 narray >c-float-array ;
+    } cleave 10 float-array{ } nsequence ;
 
 : rect-vertices ( dim -- )
     (rect-vertices) gl-vertex-pointer ;
@@ -97,7 +98,7 @@ MACRO: all-enabled-client-state ( seq quot -- )
         [ first 0 ]
         [ first2 ]
         [ second 0 swap ]
-    } cleave 8 narray >c-float-array ;
+    } cleave 8 float-array{ } nsequence ;
 
 : fill-rect-vertices ( dim -- )
     (fill-rect-vertices) gl-vertex-pointer ;
@@ -130,10 +131,10 @@ MACRO: all-enabled-client-state ( seq quot -- )
     #! We use GL_LINE_STRIP with a duplicated first vertex
     #! instead of GL_LINE_LOOP to work around a bug in Apple's
     #! X3100 driver.
-    circle-points close-path concat >c-float-array ;
+    circle-points close-path concat >float-array ;
 
 : fill-circle-vertices ( loc dim steps -- vertices )
-    circle-points concat >c-float-array ;
+    circle-points concat >float-array ;
 
 : (gen-gl-object) ( quot -- id )
     [ 1 0 <uint> ] dip keep *uint ; inline
@@ -174,7 +175,7 @@ MACRO: all-enabled-client-state ( seq quot -- )
     glActiveTexture swap glBindTexture gl-error ;
 
 : (set-draw-buffers) ( buffers -- )
-    dup length swap >c-uint-array glDrawBuffers ;
+    [ length ] [ >uint-array underlying>> ] bi glDrawBuffers ;
 
 MACRO: set-draw-buffers ( buffers -- )
     words>values [ (set-draw-buffers) ] curry ;
@@ -219,11 +220,8 @@ TUPLE: sprite loc dim dim2 dlist texture ;
 
 : gl-translate ( point -- ) first2 0.0 glTranslated ;
 
-MEMO: (rect-texture-coords) ( -- seq )
-    { 0 0 1 0 1 1 0 1 } >c-float-array ;
-
 : rect-texture-coords ( -- )
-    (rect-texture-coords) gl-texture-coord-pointer ;
+    float-array{ 0 0 1 0 1 1 0 1 } gl-texture-coord-pointer ;
 
 : draw-sprite ( sprite -- )
     GL_TEXTURE_COORD_ARRAY [

basis/random/mersenne-twister/mersenne-twister.factor

@@ -2,9 +2,9 @@
 ! See http://factorcode.org/license.txt for BSD license.
 ! mersenne twister based on 
 ! http://www.math.sci.hiroshima-u.ac.jp/~m-mat/MT/MT2002/CODES/mt19937ar.c
-USING: arrays kernel math namespaces sequences system init
+USING: kernel math namespaces sequences system init
 accessors math.ranges random circular math.bitwise
-combinators ;
+combinators specialized-arrays.uint ;
 IN: random.mersenne-twister
 
 <PRIVATE
@@ -39,11 +39,11 @@ TUPLE: mersenne-twister seq i ;
 
 : init-mt-rest ( seq -- )
     mt-n 1- swap [
-        [ init-mt-formula ] [ >r 1+ r> set-nth ] 2bi
+        [ init-mt-formula ] [ [ 1+ ] dip set-nth ] 2bi
     ] curry each ;
 
 : init-mt-seq ( seed -- seq )
-    32 bits mt-n 0 <array> <circular>
+    32 bits mt-n <uint-array> <circular>
     [ set-first ] [ init-mt-rest ] [ ] tri ;
 
 : mt-temper ( y -- yt )

basis/serialize/serialize-tests.factor

@@ -1,10 +1,10 @@
 ! Copyright (C) 2006 Chris Double.
 ! See http://factorcode.org/license.txt for BSD license.
 ! 
-USING: tools.test kernel serialize serialize.private io
+USING: tools.test kernel serialize io io.streams.byte-array math
-io.streams.byte-array math alien arrays byte-arrays bit-arrays
+alien arrays byte-arrays bit-arrays specialized-arrays.double
-float-arrays sequences math prettyprint parser classes
+sequences math prettyprint parser classes math.constants
-math.constants io.encodings.binary random assocs ;
+io.encodings.binary random assocs serialize.private ;
 IN: serialize.tests
 
 : test-serialize-cell
@@ -48,7 +48,7 @@ C: <serialize-test> serialize-test
         T{ serialize-test f "a" 2 }
         B{ 50 13 55 64 1 }
         ?{ t f t f f t f }
-        F{ 1.0 3.0 4.0 1.0 2.35 0.33 }
+        double-array{ 1.0 3.0 4.0 1.0 2.35 0.33 }
         << 1 [ 2 ] curry parsed >>
         { { "a" "bc" } { "de" "fg" } }
         H{ { "a" "bc" } { "de" "fg" } }

basis/specialized-arrays/alien/alien.factor

@@ -0,0 +1,4 @@
+USE: specialized-arrays.functor
+IN: specialized-arrays.alien
+
+<< "void*" define-array >>

basis/specialized-arrays/authors.txt

@@ -0,0 +1 @@
+Slava Pestov

basis/specialized-arrays/bool/bool.factor

@@ -0,0 +1,4 @@
+USE: specialized-arrays.functor
+IN: specialized-arrays.bool
+
+<< "bool" define-array >>

basis/specialized-arrays/char/char.factor

@@ -0,0 +1,4 @@
+USE: specialized-arrays.functor
+IN: specialized-arrays.char
+
+<< "char" define-array >>

basis/specialized-arrays/direct/alien/alien.factor

@@ -0,0 +1,4 @@
+USING: specialized-arrays.alien specialized-arrays.direct.functor ;
+IN: specialized-arrays.direct.alien
+
+<< "void*" define-direct-array >>

basis/specialized-arrays/direct/bool/bool.factor

@@ -0,0 +1,4 @@
+USING: specialized-arrays.bool specialized-arrays.direct.functor ;
+IN: specialized-arrays.direct.bool
+
+<< "bool" define-direct-array >>

basis/specialized-arrays/direct/char/char.factor

@@ -0,0 +1,4 @@
+USING: specialized-arrays.char specialized-arrays.direct.functor ;
+IN: specialized-arrays.direct.char
+
+<< "char" define-direct-array >>

basis/specialized-arrays/direct/direct-docs.factor

@@ -0,0 +1,33 @@
+USING: help.markup help.syntax byte-arrays alien ;
+IN: specialized-arrays.direct
+
+ARTICLE: "specialized-arrays.direct" "Direct-mapped specialized arrays"
+"The " { $vocab-link "specialized-arrays.direct" } " vocabulary implements fixed-length sequence types for storing machine values in unmanaged C memory."
+$nl
+"For each primitive C type " { $snippet "T" } ", a set of words are defined:"
+{ $table
+    { { $snippet "direct-T-array" } { "The class of direct arrays with elements of type " { $snippet "T" } } }
+    { { $snippet "<direct-T-array>" } { "Constructor for arrays with elements of type " { $snippet "T" } "; stack effect " { $snippet "( alien len -- array )" } } }
+}
+"Each direct array has a " { $slot "underlying" } " slot holding an " { $link simple-alien } " pointer to the raw data. This data can be passed to C functions."
+$nl
+"The primitive C types for which direct arrays exist:"
+{ $list
+    { $snippet "char" }
+    { $snippet "uchar" }
+    { $snippet "short" }
+    { $snippet "ushort" }
+    { $snippet "int" }
+    { $snippet "uint" }
+    { $snippet "long" }
+    { $snippet "ulong" }
+    { $snippet "longlong" }
+    { $snippet "ulonglong" }
+    { $snippet "float" }
+    { $snippet "double" }
+    { $snippet "void*" }
+    { $snippet "bool" }
+}
+"Direct arrays are generated with a functor in the " { $vocab-link "specialized-arrays.direct.functor" } " vocabulary." ;
+
+ABOUT: "specialized-arrays.direct"

basis/specialized-arrays/direct/direct-tests.factor

@@ -0,0 +1,7 @@
+IN: specialized-arrays.direct.tests
+USING: specialized-arrays.direct.ushort tools.test
+specialized-arrays.ushort alien.syntax sequences ;
+
+[ ushort-array{ 0 0 0 } ] [
+    3 ALIEN: 123 100 <direct-ushort-array> new-sequence
+] unit-test

basis/specialized-arrays/direct/direct.factor

@@ -0,0 +1,3 @@
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+IN: specialized-arrays.direct

basis/specialized-arrays/direct/double/double.factor

@@ -0,0 +1,4 @@
+USING: specialized-arrays.double specialized-arrays.direct.functor ;
+IN: specialized-arrays.direct.double
+
+<< "double" define-direct-array >>

basis/specialized-arrays/direct/float/float.factor

@@ -0,0 +1,4 @@
+USING: specialized-arrays.float specialized-arrays.direct.functor ;
+IN: specialized-arrays.direct.float
+
+<< "float" define-direct-array >>

basis/specialized-arrays/direct/functor/functor.factor

@@ -0,0 +1,35 @@
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: functors sequences sequences.private kernel words classes
+math alien alien.c-types byte-arrays accessors
+specialized-arrays ;
+IN: specialized-arrays.direct.functor
+
+FUNCTOR: define-direct-array ( T -- )
+
+A'      IS ${T}-array
+>A'     IS >${T}-array
+<A'>    IS <${A'}>
+
+A       DEFINES direct-${T}-array
+<A>     DEFINES <${A}>
+
+NTH     [ T dup c-getter array-accessor ]
+SET-NTH [ T dup c-setter array-accessor ]
+
+WHERE
+
+TUPLE: A
+{ underlying alien read-only }
+{ length fixnum read-only } ;
+
+: <A> ( alien len -- direct-array ) A boa ; inline
+M: A length length>> ;
+M: A nth-unsafe underlying>> NTH call ;
+M: A set-nth-unsafe underlying>> SET-NTH call ;
+M: A like drop dup A instance? [ >A' execute ] unless ;
+M: A new-sequence drop <A'> execute ;
+
+INSTANCE: A sequence
+
+;FUNCTOR

basis/specialized-arrays/direct/int/int.factor

@@ -0,0 +1,4 @@
+USING: specialized-arrays.int specialized-arrays.direct.functor ;
+IN: specialized-arrays.direct.int
+
+<< "int" define-direct-array >>

basis/specialized-arrays/direct/long/long.factor

@@ -0,0 +1,4 @@
+USING: specialized-arrays.long specialized-arrays.direct.functor ;
+IN: specialized-arrays.direct.long
+
+<< "long" define-direct-array >>

basis/specialized-arrays/direct/longlong/longlong.factor

@@ -0,0 +1,4 @@
+USING: specialized-arrays.longlong specialized-arrays.direct.functor ;
+IN: specialized-arrays.direct.longlong
+
+<< "longlong" define-direct-array >>

basis/specialized-arrays/direct/short/short.factor

@@ -0,0 +1,4 @@
+USING: specialized-arrays.short specialized-arrays.direct.functor ;
+IN: specialized-arrays.direct.short
+
+<< "short" define-direct-array >>

basis/specialized-arrays/direct/uchar/uchar.factor

@@ -0,0 +1,4 @@
+USING: specialized-arrays.uchar specialized-arrays.direct.functor ;
+IN: specialized-arrays.direct.uchar
+
+<< "uchar" define-direct-array >>

basis/specialized-arrays/direct/uint/uint.factor

@@ -0,0 +1,4 @@
+USING: specialized-arrays.uint specialized-arrays.direct.functor ;
+IN: specialized-arrays.direct.uint
+
+<< "uint" define-direct-array >>

basis/specialized-arrays/direct/ulong/ulong.factor

@@ -0,0 +1,4 @@
+USING: specialized-arrays.ulong specialized-arrays.direct.functor ;
+IN: specialized-arrays.direct.ulong
+
+<< "ulong" define-direct-array >>

basis/specialized-arrays/direct/ulonglong/ulonglong.factor

@@ -0,0 +1,4 @@
+USING: specialized-arrays.ulonglong specialized-arrays.direct.functor ;
+IN: specialized-arrays.direct.ulonglong
+
+<< "ulonglong" define-direct-array >>

basis/specialized-arrays/direct/ushort/ushort.factor

@@ -0,0 +1,4 @@
+USING: specialized-arrays.ushort specialized-arrays.direct.functor ;
+IN: specialized-arrays.direct.ushort
+
+<< "ushort" define-direct-array >>

basis/specialized-arrays/double/double.factor

@@ -0,0 +1,4 @@
+USE: specialized-arrays.functor
+IN: specialized-arrays.double
+
+<< "double" define-array >>

basis/specialized-arrays/float/float.factor

@@ -0,0 +1,4 @@
+USE: specialized-arrays.functor
+IN: specialized-arrays.float
+
+<< "float" define-array >>

basis/specialized-arrays/functor/functor.factor

@@ -0,0 +1,71 @@
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: functors sequences sequences.private prettyprint.backend
+kernel words classes math parser alien.c-types byte-arrays
+accessors summary ;
+IN: specialized-arrays.functor
+
+ERROR: bad-byte-array-length byte-array type ;
+
+M: bad-byte-array-length summary
+    drop "Byte array length doesn't divide type width" ;
+
+FUNCTOR: define-array ( T -- )
+
+A            DEFINES ${T}-array
+<A>          DEFINES <${A}>
+>A           DEFINES >${A}
+byte-array>A DEFINES byte-array>${A}
+A{           DEFINES ${A}{
+
+NTH          [ T dup c-getter array-accessor ]
+SET-NTH      [ T dup c-setter array-accessor ]
+
+WHERE
+
+TUPLE: A
+{ length array-capacity read-only }
+{ underlying byte-array read-only } ;
+
+: <A> ( n -- specialized-array ) dup T <c-array> A boa ; inline
+
+: byte-array>A ( byte-array -- specialized-array )
+    dup length T heap-size /mod 0 = [ drop T bad-byte-array-length ] unless
+    swap A boa ; inline
+
+M: A clone [ length>> ] [ underlying>> clone ] bi A boa ;
+
+M: A length length>> ;
+
+M: A nth-unsafe underlying>> NTH call ;
+
+M: A set-nth-unsafe underlying>> SET-NTH call ;
+
+: >A ( seq -- specialized-array ) A new clone-like ; inline
+
+M: A like drop dup A instance? [ >A execute ] unless ;
+
+M: A new-sequence drop <A> execute ;
+
+M: A equal? over A instance? [ sequence= ] [ 2drop f ] if ;
+
+M: A resize
+    [ drop ] [
+        [ T heap-size * ] [ underlying>> ] bi*
+        resize-byte-array
+    ] 2bi
+    A boa ;
+
+M: A byte-length underlying>> length ;
+
+M: A pprint-delims drop A{ \ } ;
+
+M: A >pprint-sequence ;
+
+M: A pprint* pprint-object ;
+
+: A{ \ } [ >A execute ] parse-literal ; parsing
+
+INSTANCE: A sequence
+
+;FUNCTOR

basis/specialized-arrays/int/int.factor

@@ -0,0 +1,4 @@
+USE: specialized-arrays.functor
+IN: specialized-arrays.int
+
+<< "int" define-array >>

basis/specialized-arrays/long/long.factor

@@ -0,0 +1,4 @@
+USE: specialized-arrays.functor
+IN: specialized-arrays.long
+
+<< "long" define-array >>

basis/specialized-arrays/longlong/longlong.factor

@@ -0,0 +1,4 @@
+USE: specialized-arrays.functor
+IN: specialized-arrays.longlong
+
+<< "longlong" define-array >>

basis/specialized-arrays/short/short.factor

@@ -0,0 +1,4 @@
+USE: specialized-arrays.functor
+IN: specialized-arrays.short
+
+<< "short" define-array >>

basis/specialized-arrays/specialized-arrays-docs.factor

@@ -0,0 +1,40 @@
+USING: help.markup help.syntax byte-arrays ;
+IN: specialized-arrays
+
+ARTICLE: "specialized-arrays" "Specialized arrays"
+"The " { $vocab-link "specialized-arrays" } " vocabulary implements fixed-length sequence types for storing machine values in a space-efficient manner without boxing."
+$nl
+"For each primitive C type " { $snippet "T" } ", a set of words are defined in the vocabulary named " { $snippet "specialized-arrays.T" } ":"
+{ $table
+    { { $snippet "T-array" } { "The class of arrays with elements of type " { $snippet "T" } } }
+    { { $snippet "<T-array>" } { "Constructor for arrays with elements of type " { $snippet "T" } "; stack effect " { $snippet "( len -- array )" } } }
+    { { $snippet ">T-array" } { "Converts a sequence into a specialized array of type " { $snippet "T" } "; stack effect " { $snippet "( seq -- array )" } } }
+    { { $snippet "byte-array>T-array" } { "Converts a byte array into a specialized array by interpreting the bytes in as machine-specific values. Code which uses this word is unportable" } }
+    { { $snippet "T-array{" } { "Literal syntax, consists of a series of values terminated by " { $snippet "}" } } }
+}
+"Each specialized array has a " { $slot "underlying" } " slot holding a " { $link byte-array } " with the raw data. This data can be passed to C functions."
+$nl
+"The primitive C types for which specialized arrays exist:"
+{ $list
+    { $snippet "char" }
+    { $snippet "uchar" }
+    { $snippet "short" }
+    { $snippet "ushort" }
+    { $snippet "int" }
+    { $snippet "uint" }
+    { $snippet "long" }
+    { $snippet "ulong" }
+    { $snippet "longlong" }
+    { $snippet "ulonglong" }
+    { $snippet "float" }
+    { $snippet "double" }
+    { $snippet "void*" }
+    { $snippet "bool" }
+}
+"Note that " { $vocab-link "specialized-arrays.bool" } " behaves like a C " { $snippet "bool[]" } " array, and each element takes up 8 bits of space. For a more space-efficient boolean array, see " { $link "bit-arrays" } "."
+$nl
+"Specialized arrays are generated with a functor in the " { $vocab-link "specialized-arrays.functor" } " vocabulary."
+$nl
+"The " { $vocab-link "specialized-vectors" } " vocabulary provides resizable versions of the above." ;
+
+ABOUT: "specialized-arrays"

basis/specialized-arrays/specialized-arrays-tests.factor

@@ -0,0 +1,18 @@
+IN: specialized-arrays.tests
+USING: tools.test specialized-arrays sequences
+specialized-arrays.int specialized-arrays.bool
+specialized-arrays.ushort alien.c-types accessors kernel ;
+
+[ t ] [ { 1 2 3 } >int-array int-array? ] unit-test
+
+[ t ] [ int-array{ 1 2 3 } int-array? ] unit-test
+
+[ 2 ] [ int-array{ 1 2 3 } second ] unit-test
+
+[ t ] [ { t f t } >bool-array underlying>> { 1 0 1 } >int-array underlying>> = ] unit-test
+
+[ ushort-array{ 1234 } ] [
+    little-endian? B{ 210 4 } B{ 4 210 } ? byte-array>ushort-array
+] unit-test
+
+[ B{ 210 4 1 } byte-array>ushort-array ] must-fail

basis/specialized-arrays/specialized-arrays.factor

@@ -0,0 +1,3 @@
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+IN: specialized-arrays

basis/specialized-arrays/summary.txt

@@ -0,0 +1 @@
+Arrays of unboxed primitive C types

basis/specialized-arrays/uchar/uchar.factor

@@ -0,0 +1,4 @@
+USE: specialized-arrays.functor
+IN: specialized-arrays.uchar
+
+<< "uchar" define-array >>

basis/specialized-arrays/uint/uint.factor

@@ -0,0 +1,4 @@
+USE: specialized-arrays.functor
+IN: specialized-arrays.uint
+
+<< "uint" define-array >>