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

basis/alien/data/data-docs.factor

@@ -56,7 +56,6 @@ $nl
 { $subsections
     malloc-object
     malloc-byte-array
-    malloc-file-contents
 }
 "The " { $vocab-link "libc" } " vocabulary defines several words which directly call C standard library memory management functions:"
 { $subsections

basis/alien/data/data.factor

@@ -56,9 +56,6 @@ M: word <c-direct-array>
 : malloc-string ( string encoding -- alien )
     string>alien malloc-byte-array ;
 
-: malloc-file-contents ( path -- alien len )
-    binary file-contents [ malloc-byte-array ] [ length ] bi ;
-
 M: memory-stream stream-read
     [
         [ index>> ] [ alien>> ] bi <displaced-alien>
@@ -81,3 +78,4 @@ M: value-type c-type-setter ( type -- quot )
     [ c-type-getter ] [ c-type-unboxer-quot ] [ heap-size ] tri
     '[ @ swap @ _ memcpy ] ;
 
+

basis/alien/parser/parser.factor

@@ -10,7 +10,7 @@ IN: alien.parser
 : parse-c-type-name ( name -- word )
     dup search [ nip ] [ no-word ] if* ;
 
-: parse-c-type ( string -- array )
+: parse-c-type ( string -- type )
     {
         { [ dup "void" =            ] [ drop void ] }
         { [ CHAR: ] over member?    ] [ parse-array-type parse-c-type-name prefix ] }

basis/compression/inflate/inflate-tests.factor

@@ -4,7 +4,7 @@ USING: tools.test compression.inflate ;
 IN: compression.inflate.tests
 
 [
-BV{
+B{
     1 255 255 255 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
     0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 122 121 94 119
     239 237 227 88 16 16 10 5 16 17 26 172 3 20 19 245 22 54 55

basis/compression/inflate/inflate.factor

@@ -3,7 +3,7 @@
 USING: accessors arrays assocs byte-vectors combinators
 combinators.smart compression.huffman fry hashtables io.binary
 kernel literals locals math math.bitwise math.order math.ranges
-sequences sorting memoize combinators.short-circuit ;
+sequences sorting memoize combinators.short-circuit byte-arrays ;
 QUALIFIED-WITH: bitstreams bs
 IN: compression.inflate
 
@@ -88,14 +88,14 @@ CONSTANT: dist-table
 : nth* ( n seq -- elt )
     [ length 1 - swap - ] [ nth ] bi ; inline
 
-:: inflate-lz77 ( seq -- bytes )
+:: inflate-lz77 ( seq -- byte-array )
     1000 <byte-vector> :> bytes
     seq [
         dup array?
         [ first2 '[ _ 1 - bytes nth* bytes push ] times ]
         [ bytes push ] if
     ] each
-    bytes ;
+    bytes >byte-array ;
 
 :: inflate-huffman ( bitstream tables -- bytes )
     bitstream tables [ <huffman-decoder> ] with map :> tables

basis/cpu/architecture/architecture.factor

@@ -324,6 +324,46 @@ HOOK: %shr-vector-reps cpu ( -- reps )
 HOOK: %horizontal-shl-vector-reps cpu ( -- reps )
 HOOK: %horizontal-shr-vector-reps cpu ( -- reps )
 
+M: object %zero-vector-reps { } ;
+M: object %fill-vector-reps { } ;
+M: object %gather-vector-2-reps { } ;
+M: object %gather-vector-4-reps { } ;
+M: object %shuffle-vector-reps { } ;
+M: object %merge-vector-reps { } ;
+M: object %signed-pack-vector-reps { } ;
+M: object %unsigned-pack-vector-reps { } ;
+M: object %unpack-vector-head-reps { } ;
+M: object %unpack-vector-tail-reps { } ;
+M: object %integer>float-vector-reps { } ;
+M: object %float>integer-vector-reps { } ;
+M: object %compare-vector-reps drop { } ;
+M: object %compare-vector-ccs 2drop { } f ;
+M: object %test-vector-reps { } ;
+M: object %add-vector-reps { } ;
+M: object %saturated-add-vector-reps { } ;
+M: object %add-sub-vector-reps { } ;
+M: object %sub-vector-reps { } ;
+M: object %saturated-sub-vector-reps { } ;
+M: object %mul-vector-reps { } ;
+M: object %saturated-mul-vector-reps { } ;
+M: object %div-vector-reps { } ;
+M: object %min-vector-reps { } ;
+M: object %max-vector-reps { } ;
+M: object %dot-vector-reps { } ;
+M: object %sqrt-vector-reps { } ;
+M: object %horizontal-add-vector-reps { } ;
+M: object %horizontal-sub-vector-reps { } ;
+M: object %abs-vector-reps { } ;
+M: object %and-vector-reps { } ;
+M: object %andn-vector-reps { } ;
+M: object %or-vector-reps { } ;
+M: object %xor-vector-reps { } ;
+M: object %not-vector-reps { } ;
+M: object %shl-vector-reps { } ;
+M: object %shr-vector-reps { } ;
+M: object %horizontal-shl-vector-reps { } ;
+M: object %horizontal-shr-vector-reps { } ;
+
 HOOK: %unbox-alien cpu ( dst src -- )
 HOOK: %unbox-any-c-ptr cpu ( dst src temp -- )
 HOOK: %box-alien cpu ( dst src temp -- )

basis/cpu/ppc/ppc.factor

@@ -256,45 +256,6 @@ M:: ppc %binary-float-function ( dst src1 src2 func -- )
 M: ppc %single>double-float double-rep %copy ;
 M: ppc %double>single-float double-rep %copy ;
 
-! VMX/AltiVec not supported yet
-M: ppc %zero-vector-reps { } ;
-M: ppc %fill-vector-reps { } ;
-M: ppc %gather-vector-2-reps { } ;
-M: ppc %gather-vector-4-reps { } ;
-M: ppc %shuffle-vector-reps { } ;
-M: ppc %merge-vector-reps { } ;
-M: ppc %signed-pack-vector-reps { } ;
-M: ppc %unsigned-pack-vector-reps { } ;
-M: ppc %unpack-vector-reps { } ;
-M: ppc %integer>float-vector-reps { } ;
-M: ppc %float>integer-vector-reps { } ;
-M: ppc %compare-vector-reps drop { } ;
-M: ppc %test-vector-reps { } ;
-M: ppc %add-vector-reps { } ;
-M: ppc %saturated-add-vector-reps { } ;
-M: ppc %add-sub-vector-reps { } ;
-M: ppc %sub-vector-reps { } ;
-M: ppc %saturated-sub-vector-reps { } ;
-M: ppc %mul-vector-reps { } ;
-M: ppc %saturated-mul-vector-reps { } ;
-M: ppc %div-vector-reps { } ;
-M: ppc %min-vector-reps { } ;
-M: ppc %max-vector-reps { } ;
-M: ppc %dot-vector-reps { } ;
-M: ppc %sqrt-vector-reps { } ;
-M: ppc %horizontal-add-vector-reps { } ;
-M: ppc %horizontal-sub-vector-reps { } ;
-M: ppc %abs-vector-reps { } ;
-M: ppc %and-vector-reps { } ;
-M: ppc %andn-vector-reps { } ;
-M: ppc %or-vector-reps { } ;
-M: ppc %xor-vector-reps { } ;
-M: ppc %not-vector-reps { } ;
-M: ppc %shl-vector-reps { } ;
-M: ppc %shr-vector-reps { } ;
-M: ppc %horizontal-shl-vector-reps { } ;
-M: ppc %horizontal-shr-vector-reps { } ;
-
 M: ppc %unbox-alien ( dst src -- )
     alien-offset LWZ ;
 

basis/game/input/input-docs.factor

@@ -3,7 +3,7 @@ sequences strings math ;
 IN: game.input
 
 ARTICLE: "game-input" "Game controller input"
-"The " { $vocab-link "game-input" } " vocabulary provides cross-platform access to game controller devices such as joysticks and gamepads. It also provides an interface for polling raw keyboard and mouse input." $nl
+"The " { $vocab-link "game.input" } " vocabulary provides cross-platform access to game controller devices such as joysticks and gamepads. It also provides an interface for polling raw keyboard and mouse input." $nl
 "The game input interface must be initialized before being used:"
 { $subsections
     open-game-input

basis/generalizations/generalizations-docs.factor

@@ -50,6 +50,11 @@ HELP: firstn
     }
 } ;
 
+HELP: set-firstn
+{ $values { "n" integer } }
+{ $description "A generalization of " { $link set-first } " "
+"that sets the first " { $snippet "n" } " elements of a sequence from the top " { $snippet "n" } " elements of the stack." } ;
+
 HELP: npick
 { $values { "n" integer } }
 { $description "A generalization of " { $link dup } ", "
@@ -257,7 +262,7 @@ HELP: nweave
 HELP: n*quot
 { $values
      { "n" integer } { "quot" quotation }
-     { "quot'" quotation }
+     { "quotquot" quotation }
 }
 { $examples
     { $example "USING: generalizations prettyprint math ;"
@@ -303,11 +308,18 @@ HELP: ntuck
 }
 { $description "A generalization of " { $link tuck } " that can work for any stack depth. The top item will be copied and placed " { $snippet "n" } " items down on the stack." } ;
 
+HELP: nspin
+{ $values
+    { "n" integer }
+}
+{ $description "A generalization of " { $link spin } " that can work for any stack depth. The top " { $snippet "n" } " items will be reversed in order." } ;
+
 ARTICLE: "sequence-generalizations" "Generalized sequence operations"
 { $subsections
     narray
     nsequence
     firstn
+    set-firstn
     nappend
     nappend-as
 } ;
@@ -321,6 +333,7 @@ ARTICLE: "shuffle-generalizations" "Generalized shuffle words"
     nnip
     ndrop
     ntuck
+    nspin
     mnswap
     nweave
 } ;

basis/generalizations/generalizations-tests.factor

@@ -26,6 +26,8 @@ IN: generalizations.tests
 { 0 } [ 0 1 2 3 4 4 ndrop ] unit-test
 [ [ 1 ] 5 ndip ] must-infer
 [ 1 2 3 4 ] [ 2 3 4 [ 1 ] 3 ndip ] unit-test
+[ 5 nspin ] must-infer
+[ 1 5 4 3 2 ] [ 1 2 3 4 5 4 nspin ] unit-test
 
 [ 1 2 3 4 5 [ drop drop drop drop drop 2 ] 5 nkeep ] must-infer
 { 2 1 2 3 4 5 } [ 1 2 3 4 5 [ drop drop drop drop drop 2 ] 5 nkeep ] unit-test
@@ -38,6 +40,8 @@ IN: generalizations.tests
 [ { "xyc" "xyd" } ] [ "x" "y" { "c" "d" } [ 3append ] 2 nwith map ] unit-test
 
 [ 1 2 3 4 ] [ { 1 2 3 4 } 4 firstn ] unit-test
+[ { 1 2 3 4 } ] [ 1 2 3 4 { f f f f } [ 4 set-firstn ] keep ] unit-test
+[ 1 2 3 4 { f f f } [ 4 set-firstn ] keep ] must-fail
 [ ] [ { } 0 firstn ] unit-test
 [ "a" ] [ { "a" } 1 firstn ] unit-test
 

basis/generalizations/generalizations.factor

@@ -2,22 +2,19 @@
 ! Cavazos, Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: kernel sequences sequences.private math combinators
-macros quotations fry effects ;
+macros quotations fry effects memoize.private ;
 IN: generalizations
 
 <<
 
-: n*quot ( n quot -- quot' ) <repetition> concat >quotation ;
+ALIAS: n*quot (n*quot)
 
 : repeat ( n obj quot -- ) swapd times ; inline
 
 >>
 
 MACRO: nsequence ( n seq -- )
-    [
+    [ [nsequence] ] keep
-        [ drop iota <reversed> ] [ '[ _ _ new-sequence ] ] 2bi
-        [ '[ @ [ _ swap set-nth-unsafe ] keep ] ] reduce
-    ] keep
     '[ @ _ like ] ;
 
 MACRO: narray ( n -- )
@@ -27,7 +24,7 @@ MACRO: nsum ( n -- )
     1 - [ + ] n*quot ;
 
 MACRO: firstn-unsafe ( n -- )
-    iota [ '[ [ _ ] dip nth-unsafe ] ] map '[ _ cleave ] ;
+    [firstn] ;
 
 MACRO: firstn ( n -- )
     dup zero? [ drop [ drop ] ] [
@@ -51,6 +48,18 @@ MACRO: nrot ( n -- )
 MACRO: -nrot ( n -- )
     1 - [ ] [ '[ swap _ dip ] ] repeat ;
 
+MACRO: set-firstn-unsafe ( n -- )
+    [ 1 + ]
+    [ iota [ '[ _ rot [ set-nth-unsafe ] keep ] ] map ] bi
+    '[ _ -nrot _ spread drop ] ;
+
+MACRO: set-firstn ( n -- )
+    dup zero? [ drop [ drop ] ] [
+        [ 1 - swap bounds-check 2drop ]
+        [ set-firstn-unsafe ]
+        bi-curry '[ _ _ bi ]
+    ] if ;
+
 MACRO: ndrop ( n -- )
     [ drop ] n*quot ;
 
@@ -104,3 +113,6 @@ MACRO: nbi-curry ( n -- )
     [ narray concat ] dip like ; inline
 
 : nappend ( n -- seq ) narray concat ; inline
+
+MACRO: nspin ( n -- )
+    [ [ ] ] swap [ swap [ ] curry compose ] n*quot [ call ] 3append ;

basis/images/png/png.factor

@@ -3,7 +3,9 @@
 USING: accessors arrays checksums checksums.crc32 combinators
 compression.inflate fry grouping images images.loader io
 io.binary io.encodings.ascii io.encodings.string kernel locals
-math math.bitwise math.ranges sequences sorting ;
+math math.bitwise math.ranges sequences sorting assocs
+math.functions math.order ;
+QUALIFIED-WITH: bitstreams bs
 IN: images.png
 
 SINGLETON: png-image
@@ -57,13 +59,16 @@ ERROR: bad-checksum ;
     4 read = [ bad-checksum ] unless
     4 cut-slice
     [ ascii decode >>type ] [ B{ } like >>data ] bi*
-    [ over chunks>> push ] 
+    [ over chunks>> push ]
     [ type>> ] bi "IEND" =
     [ read-png-chunks ] unless ;
 
 : find-chunk ( loading-png string -- chunk )
     [ chunks>> ] dip '[ type>> _ = ] find nip ;
 
+: find-chunks ( loading-png string -- chunk )
+    [ chunks>> ] dip '[ type>> _ = ] filter ;
+
 : parse-ihdr-chunk ( loading-png -- loading-png )
     dup "IHDR" find-chunk data>> {
         [ [ 0 4 ] dip subseq be> >>width ]
@@ -76,30 +81,31 @@ ERROR: bad-checksum ;
     } cleave ;
 
 : find-compressed-bytes ( loading-png -- bytes )
-    chunks>> [ type>> "IDAT" = ] filter
+    "IDAT" find-chunks [ data>> ] map concat ;
-    [ data>> ] map concat ;
 
 ERROR: unknown-color-type n ;
 ERROR: unimplemented-color-type image ;
 
 : inflate-data ( loading-png -- bytes )
-    find-compressed-bytes zlib-inflate ; 
+    find-compressed-bytes zlib-inflate ;
 
-: scale-bit-depth ( loading-png -- n ) bit-depth>> 8 / ; inline
+: png-components-per-pixel ( loading-png -- n )
-
+    color-type>> {
-: png-bytes-per-pixel ( loading-png -- n )
+        { greyscale [ 1 ] }
-    dup color-type>> {
+        { truecolor [ 3 ] }
-        { truecolor [ scale-bit-depth 3 * ] }
+        { greyscale-alpha [ 2 ] }
-        { truecolor-alpha [ scale-bit-depth 4 * ] }
+        { indexed-color [ 1 ] }
+        { truecolor-alpha [ 4 ] }
         [ unknown-color-type ]
     } case ; inline
 
 : png-group-width ( loading-png -- n )
     ! 1 + is for the filter type, 1 byte preceding each line
-    [ png-bytes-per-pixel ] [ width>> ] bi * 1 + ;
+    [ [ png-components-per-pixel ] [ bit-depth>> ] bi * ]
+    [ width>> ] bi * 1 + ;
 
-:: paeth ( a b c -- p ) 
+:: paeth ( a b c -- p )
-    a b + c - { a b c } [ [ - abs ] keep 2array ] with map 
+    a b + c - { a b c } [ [ - abs ] keep 2array ] with map
     sort-keys first second ;
 
 :: png-unfilter-line ( width prev curr filter -- curr' )
@@ -114,10 +120,10 @@ ERROR: unimplemented-color-type image ;
         { filter-up [ [| n | n x nth n b nth + 256 wrap n x set-nth ] each ] }
         { filter-average [ [| n | n x nth n a nth n b nth + 2/ + 256 wrap n x set-nth ] each ] }
         { filter-paeth [ [| n | n x nth n a nth n b nth n c nth paeth + 256 wrap n x set-nth ] each ] }
-    } case 
+    } case
     curr width tail ;
 
-:: reverse-png-filter ( n lines -- byte-array )
+:: reverse-png-filter ( lines n -- byte-array )
     lines dup first length 0 <array> prefix
     [ n 1 - 0 <array> prepend ] map
     2 clump [
@@ -130,48 +136,82 @@ ERROR: unimplemented-color-type image ;
 
 ERROR: unimplemented-interlace ;
 
-: reverse-interlace ( byte-array loading-png -- byte-array )
+: reverse-interlace ( byte-array loading-png -- bitstream )
     {
         { interlace-none [ ] }
         { interlace-adam7 [ unimplemented-interlace ] }
         [ unimplemented-interlace ]
-    } case ;
+    } case bs:<msb0-bit-reader> ;
 
-: png-image-bytes ( loading-png -- byte-array )
+: uncompress-bytes ( loading-png -- bitstream )
-    [ png-bytes-per-pixel ]
+    [ inflate-data ] [ interlace-method>> ] bi reverse-interlace ;
-    [ [ inflate-data ] [ interlace-method>> ] bi reverse-interlace ]
+
-    [ png-group-width ] tri group reverse-png-filter ;
+ERROR: bad-filter n ;
+
+:: raw-bytes ( loading-png -- array )
+    loading-png uncompress-bytes :> bs
+    loading-png width>> :> width
+    loading-png height>> :> height
+    loading-png png-components-per-pixel :> #components
+    loading-png bit-depth>> :> bit-depth
+    bit-depth :> depth!
+    #components width * :> count!
+
+    ! Only read up to 8 bits at a time
+    bit-depth 16 = [
+        8 depth!
+        count 2 * count!
+    ] when
+
+    height [
+        8 bs bs:read dup 0 4 between? [ bad-filter ] unless
+        count [ depth bs bs:read ] replicate swap prefix
+        8 bs bs:align
+    ] replicate
+    #components bit-depth 16 = [ 2 * ] when reverse-png-filter ;
 
 ERROR: unknown-component-type n ;
 
 : png-component ( loading-png -- obj )
     bit-depth>> {
+        { 1 [ ubyte-components ] }
+        { 2 [ ubyte-components ] }
+        { 4 [ ubyte-components ] }
         { 8 [ ubyte-components ] }
         { 16 [ ushort-components ] }
         [ unknown-component-type ]
     } case ;
 
-: loading-png>image ( loading-png -- image )
+: scale-factor ( n -- n' )
-    [ image new ] dip {
+    {
-        [ png-image-bytes >>bitmap ]
+        { 1 [ 255 ] }
-        [ [ width>> ] [ height>> ] bi 2array >>dim ]
+        { 2 [ 127 ] }
-        [ png-component >>component-type ]
+        { 4 [ 17 ] }
-    } cleave ;
+    } case ;
 
-: decode-greyscale ( loading-png -- image )
+: scale-greyscale ( byte-array loading-png -- byte-array' )
-    unimplemented-color-type ;
+    bit-depth>> {
+        { 8 [ ] }
+        { 16 [ 2 group [ swap ] assoc-map B{ } concat-as ] }
+        [ scale-factor '[ _ * ] B{ } map-as ]
+    } case ;
 
-: decode-truecolor ( loading-png -- image )
+: decode-greyscale ( loading-png -- byte-array )
-    loading-png>image RGB >>component-order ;
+    [ raw-bytes ] keep scale-greyscale ;
-    
-: decode-indexed-color ( loading-png -- image )
-    unimplemented-color-type ;
 
-: decode-greyscale-alpha ( loading-png -- image )
+: decode-greyscale-alpha ( loading-image -- byte-array )
-    unimplemented-color-type ;
+    [ raw-bytes ] [ bit-depth>> ] bi 16 = [
+        4 group [ first4 [ swap ] 2dip 4array ] map B{ } concat-as
+    ] when ;
 
-: decode-truecolor-alpha ( loading-png -- image )
+ERROR: invalid-PLTE array ;
-    loading-png>image RGBA >>component-order ;
+
+: verify-PLTE ( seq -- seq )
+    dup length 3 divisor? [ invalid-PLTE ] unless ;
+
+: decode-indexed-color ( loading-image -- byte-array )
+    [ raw-bytes ] keep "PLTE" find-chunk data>> verify-PLTE
+    3 group '[ _ nth ] { } map-as B{ } concat-as ; inline
 
 ERROR: invalid-color-type/bit-depth loading-png ;
 
@@ -194,16 +234,33 @@ ERROR: invalid-color-type/bit-depth loading-png ;
 : validate-truecolor-alpha ( loading-png -- loading-png )
     { 8 16 } validate-bit-depth ;
 
-: png>image ( loading-png -- image )
+: loading-png>bitmap ( loading-png -- bytes component-order )
     dup color-type>> {
-        { greyscale [ validate-greyscale decode-greyscale ] }
+        { greyscale [
-        { truecolor [ validate-truecolor decode-truecolor ] }
+            validate-greyscale decode-greyscale L
-        { indexed-color [ validate-indexed-color decode-indexed-color ] }
+        ] }
-        { greyscale-alpha [ validate-greyscale-alpha decode-greyscale-alpha ] }
+        { truecolor [
-        { truecolor-alpha [ validate-truecolor-alpha decode-truecolor-alpha ] }
+            validate-truecolor raw-bytes RGB
+        ] }
+        { indexed-color [
+            validate-indexed-color decode-indexed-color RGB
+        ] }
+        { greyscale-alpha [
+            validate-greyscale-alpha decode-greyscale-alpha LA
+        ] }
+        { truecolor-alpha [
+            validate-truecolor-alpha raw-bytes RGBA
+        ] }
         [ unknown-color-type ]
     } case ;
 
+: loading-png>image ( loading-png -- image )
+    [ image new ] dip {
+        [ loading-png>bitmap [ >>bitmap ] [ >>component-order ] bi* ]
+        [ [ width>> ] [ height>> ] bi 2array >>dim ]
+        [ png-component >>component-type ]
+    } cleave ;
+
 : load-png ( stream -- loading-png )
     [
         <loading-png>
@@ -213,4 +270,4 @@ ERROR: invalid-color-type/bit-depth loading-png ;
     ] with-input-stream ;
 
 M: png-image stream>image
-    drop load-png png>image ;
+    drop load-png loading-png>image ;

basis/io/mmap/mmap-docs.factor

@@ -1,5 +1,6 @@
-USING: help.markup help.syntax alien math continuations
+USING: alien alien.c-types continuations destructors
-destructors specialized-arrays ;
+help.markup help.syntax kernel math quotations
+specialized-arrays ;
 IN: io.mmap
 
 HELP: mapped-file
@@ -33,9 +34,42 @@ 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." } ;
 
+HELP: <mapped-file-reader>
+{ $values { "path" "a pathname string" }  { "mmap" mapped-file } }
+{ $contract "Opens a file for reading only 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 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-array
+{ $values
+    { "path" "a pathname string" } { "c-type" c-type } { "quot" quotation }
+}
+{ $description "Memory-maps a file for reading and writing as a mapped-array of the given c-type. The mapped file is disposed of when the quotation returns, or if an error is thrown." }
+{ $examples
+    { $unchecked-example
+        "USING: alien.c-types io.mmap prettyprint specialized-arrays ;"
+        "SPECIALIZED-ARRAY: uint"
+""""resource:license.txt" uint [
+    [ . ] each
+] with-mapped-array"""
+        ""
+    }
+}
+{ $errors "Throws an error if a memory mapping could not be established." } ;
+
+HELP: with-mapped-array-reader
+{ $values
+    { "path" "a pathname string" } { "c-type" c-type } { "quot" quotation }
+}
+{ $description "Memory-maps a file for reading as a mapped-array of the given c-type. 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." } ;
+
 ARTICLE: "io.mmap.arrays" "Working with memory-mapped data"
 "The " { $link <mapped-file> } " word returns an instance of " { $link mapped-file } ", which doesn't directly support the sequence protocol. Instead, it needs to be wrapped in a specialized array of the appropriate C type:"
 { $subsections <mapped-array> }
+"Additionally, files may be opened with two combinators which take a c-type as input:"
+{ $subsections with-mapped-array }
+{ $subsections with-mapped-array-reader }
 "The appropriate specialized array type must first be generated with " { $link POSTPONE: SPECIALIZED-ARRAY: } "."
 $nl
 "Data can also be read and written from the " { $link mapped-file } " by applying low-level alien words to the " { $slot "address" } " slot. This approach is not recommended, though, since in most cases the compiler will generate efficient code for specialized array usage. See " { $link "reading-writing-memory" } " for a description of low-level memory access primitives." ;
@@ -46,10 +80,10 @@ ARTICLE: "io.mmap.examples" "Memory-mapped file examples"
     "USING: alien.c-types grouping io.mmap sequences" "specialized-arrays ;"
     "SPECIALIZED-ARRAY: char"
     ""
-    "\"mydata.dat\" ["
+    "\"mydata.dat\" char ["
-    "    char <mapped-array> 4 <sliced-groups>"
+    "    4 <sliced-groups>"
     "    [ reverse-here ] change-each"
-    "] with-mapped-file"
+    "] with-mapped-array"
 }
 "Normalize a file containing packed quadrupes of floats:"
 { $code
@@ -57,17 +91,20 @@ ARTICLE: "io.mmap.examples" "Memory-mapped file examples"
     "SIMD: float"
     "SPECIALIZED-ARRAY: float-4"
     ""
-    "\"mydata.dat\" ["
+    "\"mydata.dat\" float-4 ["
-    "    float-4 <mapped-array>"
     "    [ normalize ] change-each"
-    "] with-mapped-file"
+    "] with-mapped-array"
 } ;
 
 ARTICLE: "io.mmap" "Memory-mapped files"
 "The " { $vocab-link "io.mmap" } " vocabulary implements support for memory-mapped files."
 { $subsections <mapped-file> }
-"Memory-mapped files are disposable and can be closed with " { $link dispose } " or " { $link with-disposal } ". A utility combinator which wraps the above:"
+"Memory-mapped files are disposable and can be closed with " { $link dispose } " or " { $link with-disposal } "." $nl
+"Utility combinators which wrap the above:"
 { $subsections with-mapped-file }
+{ $subsections with-mapped-file-reader }
+{ $subsections with-mapped-array }
+{ $subsections with-mapped-array-reader }
 "Instances of " { $link mapped-file } " don't support any interesting operations in themselves. There are two facilities for accessing their contents:"
 { $subsections
     "io.mmap.arrays"

basis/io/mmap/mmap-tests.factor

@@ -1,7 +1,7 @@
-USING: io io.mmap io.files io.files.temp io.directories kernel
+USING: alien.c-types alien.data compiler.tree.debugger
-tools.test continuations sequences io.encodings.ascii accessors
+continuations io.directories io.encodings.ascii io.files
-math compiler.tree.debugger alien.data alien.c-types
+io.files.temp io.mmap kernel math sequences sequences.private
-sequences.private ;
+specialized-arrays specialized-arrays.instances.uint tools.test ;
 IN: io.mmap.tests
 
 [ "mmap-test-file.txt" temp-file delete-file ] ignore-errors
@@ -10,6 +10,19 @@ IN: io.mmap.tests
 [ 5 ] [ "mmap-test-file.txt" temp-file [ char <mapped-array> length ] with-mapped-file ] unit-test
 [ 5 ] [ "mmap-test-file.txt" temp-file [ char <mapped-array> length ] with-mapped-file-reader ] unit-test
 [ "22345" ] [ "mmap-test-file.txt" temp-file ascii file-contents ] unit-test
+
+SPECIALIZED-ARRAY: uint
+
+[ t ] [
+    "mmap-test-file.txt" temp-file uint [ sum ] with-mapped-array
+    integer?
+] unit-test
+
+[ t ] [
+    "mmap-test-file.txt" temp-file uint [ sum ] with-mapped-array-reader
+    integer?
+] unit-test
+
 [ "mmap-test-file.txt" temp-file delete-file ] ignore-errors
 
 

basis/io/mmap/mmap.factor

@@ -8,13 +8,13 @@ IN: io.mmap
 
 TUPLE: mapped-file < disposable address handle length ;
 
-HOOK: (mapped-file-reader) os ( path length -- address handle )
-HOOK: (mapped-file-r/w) os ( path length -- address handle )
-
 ERROR: bad-mmap-size n ;
 
 <PRIVATE
 
+HOOK: (mapped-file-reader) os ( path length -- address handle )
+HOOK: (mapped-file-r/w) os ( path length -- address handle )
+
 : prepare-mapped-file ( path quot -- mapped-file path' length )
     [
         [ normalize-path ] [ file-info size>> ] bi
@@ -45,6 +45,19 @@ M: mapped-file dispose* ( mmap -- ) close-mapped-file ;
 : with-mapped-file-reader ( path quot -- )
     [ <mapped-file-reader> ] dip with-disposal ; inline
 
+<PRIVATE
+
+: (with-mapped-array) ( c-type quot -- )
+    [ [ <mapped-array> ] curry ] dip compose with-disposal ; inline
+
+PRIVATE>
+
+: with-mapped-array ( path c-type quot -- )
+    [ <mapped-file> ] 2dip (with-mapped-array) ; inline
+
+: with-mapped-array-reader ( path c-type quot -- )
+    [ <mapped-file-reader> ] 2dip (with-mapped-array) ; inline
+
 {
     { [ os unix? ] [ "io.mmap.unix" require ] }
     { [ os winnt? ] [ "io.mmap.windows" require ] }

basis/io/mmap/unix/unix.factor

@@ -1,7 +1,7 @@
 ! Copyright (C) 2007 Doug Coleman.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: alien io io.files kernel math math.bitwise system unix
+USING: accessors destructors io.backend.unix io.mmap
-io.backend.unix io.ports io.mmap destructors locals accessors ;
+io.mmap.private kernel locals math.bitwise system unix ;
 IN: io.mmap.unix
 
 :: mmap-open ( path length prot flags open-mode -- alien fd )

basis/io/mmap/windows/windows.factor

@@ -1,6 +1,6 @@
 USING: alien alien.c-types arrays destructors generic io.mmap
 io.ports io.backend.windows io.files.windows io.backend.windows.privileges
-kernel libc math math.bitwise namespaces quotations sequences
+io.mmap.private kernel libc math math.bitwise namespaces quotations sequences
 windows windows.advapi32 windows.kernel32 io.backend system
 accessors locals windows.errors ;
 IN: io.mmap.windows

basis/math/vectors/conversion/conversion.factor

@@ -39,32 +39,45 @@ ERROR: bad-vconvert-input value expected-type ;
     } cond
     [ from-type check-vconvert-type ] prepose ;
 
-:: [vpack] ( from-element to-element from-size to-size from-type to-type -- quot )
+:: check-vpack ( from-element to-element from-type to-type steps -- )
-    from-size to-size /i log2 :> steps
-
     {
         [ steps 1 = not ]
         [ from-element to-element [ float-type? ] bi@ xor ]
         [ from-element unsigned-type? to-element unsigned-type? not and ]
-    } 0|| [ from-type to-type bad-vconvert ] when
+    } 0|| [ from-type to-type bad-vconvert ] when ;
 
-    to-element unsigned-type? [ to-type (vpack-unsigned) ] [ to-type (vpack-signed) ] ?
+:: [[vpack-unsigned]] ( from-type to-type -- quot )
-    [ [ from-type check-vconvert-type ] bi@ ] prepose ;
+    [ [ from-type check-vconvert-type ] bi@ to-type (vpack-unsigned) ] ;
 
-:: [vunpack] ( from-element to-element from-size to-size from-type to-type -- quot )
+:: [[vpack-signed]] ( from-type to-type -- quot )
-    to-size from-size /i log2 :> steps
+    [ [ from-type check-vconvert-type ] bi@ to-type (vpack-signed) ] ;
 
+:: [vpack] ( from-element to-element from-size to-size from-type to-type -- quot )
+    from-size to-size /i log2 :> steps
+
+    from-element to-element from-type to-type steps check-vpack
+
+    from-type to-type to-element unsigned-type?
+    [ [[vpack-unsigned]] ] [ [[vpack-signed]] ] if ;
+
+:: check-vunpack ( from-element to-element from-type to-type steps -- )
     {
         [ steps 1 = not ]
         [ from-element to-element [ float-type? ] bi@ xor ]
         [ from-element unsigned-type? not to-element unsigned-type? and ]
-    } 0|| [ from-type to-type bad-vconvert ] when
+    } 0|| [ from-type to-type bad-vconvert ] when ;
 
+:: [[vunpack]] ( from-type to-type -- quot )
     [
         from-type check-vconvert-type
         [ to-type (vunpack-head) ] [ to-type (vunpack-tail) ] bi
     ] ;
 
+:: [vunpack] ( from-element to-element from-size to-size from-type to-type -- quot )
+    to-size from-size /i log2 :> steps
+    from-element to-element from-type to-type steps check-vunpack
+    from-type to-type [[vunpack]] ; 
+
 PRIVATE>
 
 MACRO:: vconvert ( from-type to-type -- )

basis/memoize/memoize-docs.factor

@@ -19,12 +19,10 @@ ABOUT: "memoize"
 
 HELP: define-memoized
 { $values { "word" word } { "quot" quotation } { "effect" effect } }
-{ $description "defines the given word at runtime as one which memoizes its output given a particular input" }
+{ $description "Defines the given word at run time as one which memoizes its outputs given a particular input." } ;
-{ $notes "A maximum of four input and four output arguments can be used" }
-{ $see-also POSTPONE: MEMO: } ;
 
 HELP: MEMO:
 { $syntax "MEMO: word ( stack -- effect ) definition ;" }
-{ $description "defines the given word at parsetime as one which memoizes its output given a particular input. The stack effect is mandatory." }
+{ $description "Defines the given word at parse time as one which memoizes its output given a particular input. The stack effect is mandatory." } ;
-{ $notes "A maximum of four input and four output arguments can be used" }
+
-{ $see-also define-memoized } ;
+{ define-memoized POSTPONE: MEMO: } related-words

basis/memoize/memoize-tests.factor

@@ -7,9 +7,18 @@ IN: memoize.tests
 MEMO: fib ( m -- n )
     dup 1 <= [ drop 1 ] [ dup 1 - fib swap 2 - fib + ] if ;
 
+MEMO: x ( a b c d e -- f g h i j )
+    [ 1 + ] 4 ndip ;
+
 [ 89 ] [ 10 fib ] unit-test
 
-[ "USING: kernel math memoize generalizations ; IN: memoize.tests MEMO: x ( a b c d e -- f g h i j ) [ 1 + ] 4 ndip ;" eval( -- ) ] must-fail
+[
+    1 0 0 0 0
+    1 0 0 0 0
+] [
+    0 0 0 0 0 x
+    0 0 0 0 0 x
+] unit-test
 
 MEMO: see-test ( a -- b ) reverse ;
 

basis/memoize/memoize.factor

@@ -1,22 +1,36 @@
 ! Copyright (C) 2007, 2009 Slava Pestov, Daniel Ehrenberg.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: kernel hashtables sequences arrays words namespaces make
+USING: kernel hashtables sequences sequences.private arrays
-parser math assocs effects definitions quotations summary
+words namespaces make parser math assocs effects definitions
-accessors fry ;
+quotations summary accessors fry ;
 IN: memoize
 
-ERROR: too-many-arguments ;
-
-M: too-many-arguments summary
-    drop "There must be no more than 4 input and 4 output arguments" ;
-
 <PRIVATE
 
+! We can't use n*quot, narray and firstn from generalizations because
+! they're macros, and macros use memoize!
+: (n*quot) ( n quot -- quotquot )
+    <repetition> concat >quotation ;
+
+: [nsequence] ( length exemplar -- quot )
+    [ [ [ 1 - ] keep ] dip '[ _ _ _ new-sequence ] ]
+    [ drop [ [ set-nth-unsafe ] 2keep [ 1 - ] dip ] (n*quot) ] 2bi
+    [ nip ] 3append ; 
+
+: [firstn] ( length -- quot )
+    [ 0 swap ] swap
+    [ [ nth-unsafe ] 2keep [ 1 + ] dip ] (n*quot)
+    [ 2drop ] 3append ;
+
 : packer ( seq -- quot )
-    length { [ f ] [ ] [ 2array ] [ 3array ] [ 4array ] } nth ;
+    length dup 4 <=
+    [ { [ f ] [ ] [ 2array ] [ 3array ] [ 4array ] } nth ]
+    [ { } [nsequence] ] if ;
 
 : unpacker ( seq -- quot )
-    length { [ drop ] [ ] [ first2 ] [ first3 ] [ first4 ] } nth ;
+    length dup 4 <=
+    [ { [ drop ] [ ] [ first2 ] [ first3 ] [ first4 ] } nth ]
+    [ [firstn] ] if ;
 
 : pack/unpack ( quot effect -- newquot )
     [ in>> packer ] [ out>> unpacker ] bi surround ;
@@ -24,11 +38,7 @@ M: too-many-arguments summary
 : unpack/pack ( quot effect -- newquot )
     [ in>> unpacker ] [ out>> packer ] bi surround ;
 
-: check-memoized ( effect -- )
-    [ in>> ] [ out>> ] bi [ length 4 > ] either? [ too-many-arguments ] when ;
-
 : make-memoizer ( table quot effect -- quot )
-    [ check-memoized ] keep
     [ unpack/pack '[ _ _ cache ] ] keep
     pack/unpack ;
 
@@ -62,4 +72,4 @@ M: memoized reset-word
 : invalidate-memoized ( inputs... word -- )
     [ stack-effect in>> packer call ] [ "memoize" word-prop delete-at ] bi ;
 
-\ invalidate-memoized t "no-compile" set-word-prop
+\ invalidate-memoized t "no-compile" set-word-prop

basis/tools/deploy/test/8/8.factor

@@ -1,4 +1,4 @@
-USING: calendar game-input threads ui ui.gadgets.worlds kernel
+USING: calendar game.input threads ui ui.gadgets.worlds kernel
 method-chains system ;
 IN: tools.deploy.test.8
 
@@ -18,4 +18,4 @@ AFTER: my-world end-world drop close-game-input ;
         0 exit
     ] with-ui ;
 
-MAIN: test-game-input
+MAIN: test-game-input

extra/gpu/util/wasd/wasd.factor

@@ -1,5 +1,5 @@
 ! (c)2009 Joe Groff bsd license
-USING: accessors arrays combinators.smart game-input
+USING: accessors arrays combinators.smart game.input
 game.input.scancodes game.loop game.worlds
 gpu.render gpu.state kernel literals
 locals math math.constants math.functions math.matrices

vm/os-netbsd.cpp

@@ -10,7 +10,7 @@ const char *vm_executable_path()
 	static Dl_info info = {0};
 	if (!info.dli_fname)
 		dladdr((void *)main, &info);
-	return info.dli_fname;
+	return safe_strdup(info.dli_fname);
 }
 
 }