diff --git a/basis/alien/data/data-docs.factor b/basis/alien/data/data-docs.factor index 68d5022630..0536d15736 100644 --- a/basis/alien/data/data-docs.factor +++ b/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 diff --git a/basis/alien/data/data.factor b/basis/alien/data/data.factor index 372f3e5f98..fc18921ef1 100644 --- a/basis/alien/data/data.factor +++ b/basis/alien/data/data.factor @@ -56,9 +56,6 @@ M: word : 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 @@ -81,3 +78,4 @@ M: value-type c-type-setter ( type -- quot ) [ c-type-getter ] [ c-type-unboxer-quot ] [ heap-size ] tri '[ @ swap @ _ memcpy ] ; + diff --git a/basis/alien/parser/parser.factor b/basis/alien/parser/parser.factor index 59607fa781..67f1d4e5fd 100644 --- a/basis/alien/parser/parser.factor +++ b/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 ] } diff --git a/basis/compression/inflate/inflate-tests.factor b/basis/compression/inflate/inflate-tests.factor index e2beefb9b2..7bda94a999 100644 --- a/basis/compression/inflate/inflate-tests.factor +++ b/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 diff --git a/basis/compression/inflate/inflate.factor b/basis/compression/inflate/inflate.factor index ab27c70ac0..567c435c2e 100644 --- a/basis/compression/inflate/inflate.factor +++ b/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 :> 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 [ ] with map :> tables diff --git a/basis/cpu/architecture/architecture.factor b/basis/cpu/architecture/architecture.factor index c7a7f0c5ef..8bf84f6670 100644 --- a/basis/cpu/architecture/architecture.factor +++ b/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 -- ) diff --git a/basis/cpu/ppc/ppc.factor b/basis/cpu/ppc/ppc.factor index 32c92a8da0..9237d320f3 100644 --- a/basis/cpu/ppc/ppc.factor +++ b/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 ; diff --git a/basis/game/input/input-docs.factor b/basis/game/input/input-docs.factor index bef08c4d2f..29b74ff570 100755 --- a/basis/game/input/input-docs.factor +++ b/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 diff --git a/basis/generalizations/generalizations-docs.factor b/basis/generalizations/generalizations-docs.factor index e05d871323..de74dd1ead 100644 --- a/basis/generalizations/generalizations-docs.factor +++ b/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 } ; diff --git a/basis/generalizations/generalizations-tests.factor b/basis/generalizations/generalizations-tests.factor index ec5c1ecc2d..d466d56251 100644 --- a/basis/generalizations/generalizations-tests.factor +++ b/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 diff --git a/basis/generalizations/generalizations.factor b/basis/generalizations/generalizations.factor index 03d4512196..2e9d560ae6 100644 --- a/basis/generalizations/generalizations.factor +++ b/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' ) concat >quotation ; +ALIAS: n*quot (n*quot) : repeat ( n obj quot -- ) swapd times ; inline >> MACRO: nsequence ( n seq -- ) - [ - [ drop iota ] [ '[ _ _ 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 ; diff --git a/basis/images/png/png.factor b/basis/images/png/png.factor index 08d8c56667..6ebc0f9147 100755 --- a/basis/images/png/png.factor +++ b/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 - [ 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 prefix [ n 1 - 0 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: ; -: 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 ) [ @@ -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 ; diff --git a/basis/io/mmap/mmap-docs.factor b/basis/io/mmap/mmap-docs.factor index c87a3552e4..fe16e08467 100644 --- a/basis/io/mmap/mmap-docs.factor +++ b/basis/io/mmap/mmap-docs.factor @@ -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: +{ $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 } " 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 } +"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 4 " + "\"mydata.dat\" char [" + " 4 " " [ 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 " + "\"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 } -"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" diff --git a/basis/io/mmap/mmap-tests.factor b/basis/io/mmap/mmap-tests.factor index 3ed3447603..94f8c77883 100644 --- a/basis/io/mmap/mmap-tests.factor +++ b/basis/io/mmap/mmap-tests.factor @@ -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 length ] with-mapped-file ] unit-test [ 5 ] [ "mmap-test-file.txt" temp-file [ char 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 diff --git a/basis/io/mmap/mmap.factor b/basis/io/mmap/mmap.factor index 19587cda34..5f35278b05 100644 --- a/basis/io/mmap/mmap.factor +++ b/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 ; > ] bi @@ -45,6 +45,19 @@ M: mapped-file dispose* ( mmap -- ) close-mapped-file ; : with-mapped-file-reader ( path quot -- ) [ ] dip with-disposal ; inline + ] curry ] dip compose with-disposal ; inline + +PRIVATE> + +: with-mapped-array ( path c-type quot -- ) + [ ] 2dip (with-mapped-array) ; inline + +: with-mapped-array-reader ( path c-type quot -- ) + [ ] 2dip (with-mapped-array) ; inline + { { [ os unix? ] [ "io.mmap.unix" require ] } { [ os winnt? ] [ "io.mmap.windows" require ] } diff --git a/basis/io/mmap/unix/unix.factor b/basis/io/mmap/unix/unix.factor index 7d12d52361..559417d2b9 100644 --- a/basis/io/mmap/unix/unix.factor +++ b/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 -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 ) diff --git a/basis/io/mmap/windows/windows.factor b/basis/io/mmap/windows/windows.factor index 8fdc7fefd9..a2c1f972a6 100644 --- a/basis/io/mmap/windows/windows.factor +++ b/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 diff --git a/basis/math/vectors/conversion/conversion.factor b/basis/math/vectors/conversion/conversion.factor index 863cb9fea5..f70dfc9b27 100644 --- a/basis/math/vectors/conversion/conversion.factor +++ b/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 ) - 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 -- ) diff --git a/basis/memoize/memoize-docs.factor b/basis/memoize/memoize-docs.factor index 674fa005c2..58ba60af7c 100644 --- a/basis/memoize/memoize-docs.factor +++ b/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" } -{ $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 diff --git a/basis/memoize/memoize-tests.factor b/basis/memoize/memoize-tests.factor index 771c11c130..11dfd705c2 100644 --- a/basis/memoize/memoize-tests.factor +++ b/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 ; diff --git a/basis/memoize/memoize.factor b/basis/memoize/memoize.factor index 74ca07cda3..c949c34684 100644 --- a/basis/memoize/memoize.factor +++ b/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 -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" ; - 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 \ No newline at end of file +\ invalidate-memoized t "no-compile" set-word-prop diff --git a/basis/tools/deploy/test/8/8.factor b/basis/tools/deploy/test/8/8.factor index ddf08d3654..6bbb85f9fc 100644 --- a/basis/tools/deploy/test/8/8.factor +++ b/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 \ No newline at end of file +MAIN: test-game-input diff --git a/extra/gpu/util/wasd/wasd.factor b/extra/gpu/util/wasd/wasd.factor index 1f1187fd21..bee05463af 100644 --- a/extra/gpu/util/wasd/wasd.factor +++ b/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 diff --git a/vm/os-netbsd.cpp b/vm/os-netbsd.cpp index e280d99a80..e1bdc30460 100644 --- a/vm/os-netbsd.cpp +++ b/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); } }