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

db4
Slava Pestov 2009-10-09 03:21:31 -05:00
commit 978647dc39
24 changed files with 334 additions and 157 deletions

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

@ -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 -- )
[
[ drop iota <reversed> ] [ '[ _ _ new-sequence ] ] 2bi
[ '[ @ [ _ swap set-nth-unsafe ] keep ] ] reduce
] keep
[ [nsequence] ] 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 ;

View File

@ -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
[ data>> ] map concat ;
"IDAT" find-chunks [ 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-bytes-per-pixel ( loading-png -- n )
dup color-type>> {
{ truecolor [ scale-bit-depth 3 * ] }
{ truecolor-alpha [ scale-bit-depth 4 * ] }
: png-components-per-pixel ( loading-png -- n )
color-type>> {
{ greyscale [ 1 ] }
{ truecolor [ 3 ] }
{ greyscale-alpha [ 2 ] }
{ 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 )
a b + c - { a b c } [ [ - abs ] keep 2array ] with map
:: paeth ( a b c -- p )
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 )
[ png-bytes-per-pixel ]
[ [ inflate-data ] [ interlace-method>> ] bi reverse-interlace ]
[ png-group-width ] tri group reverse-png-filter ;
: uncompress-bytes ( loading-png -- bitstream )
[ inflate-data ] [ interlace-method>> ] bi reverse-interlace ;
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 )
[ image new ] dip {
[ png-image-bytes >>bitmap ]
[ [ width>> ] [ height>> ] bi 2array >>dim ]
[ png-component >>component-type ]
} cleave ;
: scale-factor ( n -- n' )
{
{ 1 [ 255 ] }
{ 2 [ 127 ] }
{ 4 [ 17 ] }
} case ;
: decode-greyscale ( loading-png -- image )
unimplemented-color-type ;
: scale-greyscale ( byte-array loading-png -- byte-array' )
bit-depth>> {
{ 8 [ ] }
{ 16 [ 2 group [ swap ] assoc-map B{ } concat-as ] }
[ scale-factor '[ _ * ] B{ } map-as ]
} case ;
: decode-truecolor ( loading-png -- image )
loading-png>image RGB >>component-order ;
: decode-indexed-color ( loading-png -- image )
unimplemented-color-type ;
: decode-greyscale ( loading-png -- byte-array )
[ raw-bytes ] keep scale-greyscale ;
: decode-greyscale-alpha ( loading-png -- image )
unimplemented-color-type ;
: decode-greyscale-alpha ( loading-image -- byte-array )
[ raw-bytes ] [ bit-depth>> ] bi 16 = [
4 group [ first4 [ swap ] 2dip 4array ] map B{ } concat-as
] when ;
: decode-truecolor-alpha ( loading-png -- image )
loading-png>image RGBA >>component-order ;
ERROR: invalid-PLTE array ;
: 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 ] }
{ truecolor [ validate-truecolor decode-truecolor ] }
{ indexed-color [ validate-indexed-color decode-indexed-color ] }
{ greyscale-alpha [ validate-greyscale-alpha decode-greyscale-alpha ] }
{ truecolor-alpha [ validate-truecolor-alpha decode-truecolor-alpha ] }
{ greyscale [
validate-greyscale decode-greyscale L
] }
{ truecolor [
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 ;

View File

@ -1,5 +1,6 @@
USING: help.markup help.syntax alien math continuations
destructors specialized-arrays ;
USING: alien alien.c-types continuations destructors
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\" ["
" char <mapped-array> 4 <sliced-groups>"
"\"mydata.dat\" char ["
" 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\" ["
" float-4 <mapped-array>"
"\"mydata.dat\" float-4 ["
" [ 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"

View File

@ -1,7 +1,7 @@
USING: io io.mmap io.files io.files.temp io.directories kernel
tools.test continuations sequences io.encodings.ascii accessors
math compiler.tree.debugger alien.data alien.c-types
sequences.private ;
USING: alien.c-types alien.data compiler.tree.debugger
continuations io.directories io.encodings.ascii io.files
io.files.temp io.mmap kernel math sequences 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

View File

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

View File

@ -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
io.backend.unix io.ports io.mmap destructors locals accessors ;
USING: accessors destructors io.backend.unix io.mmap
io.mmap.private kernel locals math.bitwise system unix ;
IN: io.mmap.unix
:: mmap-open ( path length prot flags open-mode -- alien fd )

View File

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

View File

@ -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 )
from-size to-size /i log2 :> steps
:: check-vpack ( from-element to-element from-type to-type 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) ] ?
[ [ from-type check-vconvert-type ] bi@ ] prepose ;
:: [[vpack-unsigned]] ( from-type to-type -- quot )
[ [ from-type check-vconvert-type ] bi@ to-type (vpack-unsigned) ] ;
:: [vunpack] ( from-element to-element from-size to-size from-type to-type -- quot )
to-size from-size /i log2 :> steps
:: [[vpack-signed]] ( from-type to-type -- quot )
[ [ 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 -- )

View File

@ -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" }
{ $notes "A maximum of four input and four output arguments can be used" }
{ $see-also POSTPONE: MEMO: } ;
{ $description "Defines the given word at run time as one which memoizes its outputs given a particular input." } ;
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." }
{ $notes "A maximum of four input and four output arguments can be used" }
{ $see-also define-memoized } ;
{ $description "Defines the given word at parse time as one which memoizes its output given a particular input. The stack effect is mandatory." } ;
{ define-memoized POSTPONE: MEMO: } related-words

View File

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

View File

@ -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
parser math assocs effects definitions quotations summary
accessors fry ;
USING: kernel hashtables sequences sequences.private arrays
words namespaces make parser math assocs effects definitions
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

View File

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

View File

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

View File

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