From 17b095a5243c0ec94acb336d06cec2890159c08c Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 25 Feb 2010 04:50:31 +1300 Subject: [PATCH 1/1] Slices over specialized arrays can now be passed to C functions, written to binary output streams, and given to malloc-byte-array --- basis/alien/data/data-docs.factor | 11 +--- basis/alien/data/data.factor | 14 +++-- basis/base64/base64.factor | 4 +- basis/io/buffers/buffers-tests.factor | 5 +- basis/io/buffers/buffers.factor | 2 +- basis/io/encodings/utf32/utf32-tests.factor | 6 +-- basis/io/ports/ports-tests.factor | 54 +++---------------- basis/serialize/serialize-tests.factor | 14 ++--- .../specialized-arrays-tests.factor | 5 +- .../specialized-arrays.factor | 2 +- .../specialized-vectors.factor | 4 +- basis/ui/backend/windows/windows.factor | 2 +- .../directx/dinput/constants/constants.factor | 5 +- core/alien/alien-docs.factor | 14 +++-- core/alien/alien.factor | 28 +++++++--- core/io/files/files-tests.factor | 49 +++++++++++++++-- .../byte-array/byte-array-tests.factor | 1 + 17 files changed, 116 insertions(+), 104 deletions(-) diff --git a/basis/alien/data/data-docs.factor b/basis/alien/data/data-docs.factor index 6ab6d56bc7..4600ea6837 100644 --- a/basis/alien/data/data-docs.factor +++ b/basis/alien/data/data-docs.factor @@ -21,11 +21,6 @@ HELP: memory>byte-array { $values { "alien" c-ptr } { "len" "a non-negative integer" } { "byte-array" byte-array } } { $description "Reads " { $snippet "len" } " bytes starting from " { $snippet "base" } " and stores them in a new byte array." } ; -HELP: byte-array>memory -{ $values { "byte-array" byte-array } { "base" c-ptr } } -{ $description "Writes a byte array to memory starting from the " { $snippet "base" } " address." } -{ $warning "This word is unsafe. Improper use can corrupt memory." } ; - HELP: malloc-array { $values { "n" "a non-negative integer" } { "type" "a C type" } { "array" "a specialized array" } } { $description "Allocates an unmanaged memory block large enough to hold " { $snippet "n" } " values of a C type, then wraps the memory in a sequence object using " { $link } "." } @@ -75,9 +70,7 @@ $nl "You can unsafely copy a range of bytes from one memory location to another:" { $subsections memcpy } "You can copy a range of bytes from memory into a byte array:" -{ $subsections memory>byte-array } -"You can copy a byte array to memory unsafely:" -{ $subsections byte-array>memory } ; +{ $subsections memory>byte-array } ; ARTICLE: "c-pointers" "Passing pointers to C functions" "The following Factor objects may be passed to C function parameters with pointer types:" @@ -85,7 +78,7 @@ ARTICLE: "c-pointers" "Passing pointers to C functions" { "Instances of " { $link alien } "." } { "Instances of " { $link f } "; this is interpreted as a null pointer." } { "Instances of " { $link byte-array } "; the C function receives a pointer to the first element of the array." } - { "Any data type which defines a method on " { $link >c-ptr } " that returns an instance of one of the above. This includes " { $link "classes.struct" } " and " { $link "specialized-arrays" } "." } + { "Any data type which defines a method on " { $link >c-ptr } ". This includes " { $link "classes.struct" } " and " { $link "specialized-arrays" } "." } } "The class of primitive C pointer types:" { $subsections c-ptr } diff --git a/basis/alien/data/data.factor b/basis/alien/data/data.factor index 462bed8b76..2d572e9f13 100644 --- a/basis/alien/data/data.factor +++ b/basis/alien/data/data.factor @@ -49,7 +49,7 @@ M: word heap-size malloc ; inline : malloc-byte-array ( byte-array -- alien ) - dup byte-length [ nip malloc dup ] 2keep memcpy ; + binary-object [ nip malloc dup ] 2keep memcpy ; : memory>byte-array ( alien len -- byte-array ) [ nip (byte-array) dup ] 2keep memcpy ; @@ -63,14 +63,12 @@ M: memory-stream stream-read swap memory>byte-array ] [ [ + ] change-index drop ] 2bi ; -: byte-array>memory ( byte-array base -- ) - swap dup byte-length memcpy ; inline - M: byte-vector stream-write - [ binary-object ] dip - [ [ length + ] keep lengthen drop ] - [ '[ _ underlying>> ] 2dip memcpy ] - 3bi ; + [ dup byte-length tail-slice ] + [ [ [ byte-length ] bi@ + ] keep lengthen ] + [ drop byte-length ] + 2tri + [ >c-ptr swap >c-ptr ] dip memcpy ; M: value-type c-type-rep drop int-rep ; diff --git a/basis/base64/base64.factor b/basis/base64/base64.factor index 1a0648cef8..9a57740936 100644 --- a/basis/base64/base64.factor +++ b/basis/base64/base64.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: combinators io io.binary io.encodings.binary io.streams.byte-array kernel math namespaces -sequences strings io.crlf ; +sequences strings ; IN: base64 ERROR: malformed-base64 ; @@ -35,7 +35,7 @@ SYMBOL: column : write1-lines ( ch -- ) write1 column get [ - 1 + [ 76 = [ crlf ] when ] + 1 + [ 76 = [ B{ CHAR: \r CHAR: \n } write ] when ] [ 76 mod column set ] bi ] when* ; diff --git a/basis/io/buffers/buffers-tests.factor b/basis/io/buffers/buffers-tests.factor index 836b4d0cc8..07e783f267 100644 --- a/basis/io/buffers/buffers-tests.factor +++ b/basis/io/buffers/buffers-tests.factor @@ -4,8 +4,9 @@ kernel.private libc sequences tools.test namespaces byte-arrays strings accessors destructors ; : buffer-set ( string buffer -- ) - over >byte-array over ptr>> byte-array>memory - [ length ] dip buffer-reset ; + [ ptr>> swap >byte-array binary-object memcpy ] + [ [ length ] dip buffer-reset ] + 2bi ; : string>buffer ( string -- buffer ) dup length [ buffer-set ] keep ; diff --git a/basis/io/buffers/buffers.factor b/basis/io/buffers/buffers.factor index ce5ad2c9a0..562abad082 100644 --- a/basis/io/buffers/buffers.factor +++ b/basis/io/buffers/buffers.factor @@ -60,7 +60,7 @@ HINTS: buffer-read fixnum buffer ; HINTS: n>buffer fixnum buffer ; : >buffer ( byte-array buffer -- ) - [ buffer-end byte-array>memory ] + [ buffer-end swap binary-object memcpy ] [ [ byte-length ] dip n>buffer ] 2bi ; diff --git a/basis/io/encodings/utf32/utf32-tests.factor b/basis/io/encodings/utf32/utf32-tests.factor index 2a80e47c7b..adff0ecf4b 100644 --- a/basis/io/encodings/utf32/utf32-tests.factor +++ b/basis/io/encodings/utf32/utf32-tests.factor @@ -12,7 +12,7 @@ IN: io.encodings.utf32.tests [ { CHAR: replacement-character } ] [ B{ 0 } utf32be decode >array ] unit-test [ { } ] [ { } utf32be decode >array ] unit-test -[ { 0 0 0 CHAR: x 0 1 HEX: D1 HEX: 1E } ] [ { CHAR: x HEX: 1d11e } >string utf32be encode >array ] unit-test +[ B{ 0 0 0 CHAR: x 0 1 HEX: D1 HEX: 1E } ] [ { CHAR: x HEX: 1d11e } >string utf32be encode ] unit-test [ { CHAR: x } ] [ B{ CHAR: x 0 0 0 } utf32le decode >array ] unit-test [ { HEX: 1d11e } ] [ B{ HEX: 1e HEX: d1 1 0 } utf32le decode >array ] unit-test @@ -21,10 +21,10 @@ IN: io.encodings.utf32.tests [ { CHAR: replacement-character } ] [ B{ HEX: 1e } utf32le decode >array ] unit-test [ { } ] [ { } utf32le decode >array ] unit-test -[ { 120 0 0 0 HEX: 1e HEX: d1 1 0 } ] [ { CHAR: x HEX: 1d11e } >string utf32le encode >array ] unit-test +[ B{ 120 0 0 0 HEX: 1e HEX: d1 1 0 } ] [ { CHAR: x HEX: 1d11e } >string utf32le encode ] unit-test [ { CHAR: x } ] [ B{ HEX: ff HEX: fe 0 0 CHAR: x 0 0 0 } utf32 decode >array ] unit-test [ { CHAR: x } ] [ B{ 0 0 HEX: fe HEX: ff 0 0 0 CHAR: x } utf32 decode >array ] unit-test -[ { HEX: ff HEX: fe 0 0 120 0 0 0 HEX: 1e HEX: d1 1 0 } ] [ { CHAR: x HEX: 1d11e } >string utf32 encode >array ] unit-test +[ B{ HEX: ff HEX: fe 0 0 120 0 0 0 HEX: 1e HEX: d1 1 0 } ] [ { CHAR: x HEX: 1d11e } >string utf32 encode ] unit-test diff --git a/basis/io/ports/ports-tests.factor b/basis/io/ports/ports-tests.factor index 7d8c799017..c7af6909e1 100644 --- a/basis/io/ports/ports-tests.factor +++ b/basis/io/ports/ports-tests.factor @@ -1,7 +1,6 @@ -USING: destructors io io.encodings.binary io.files io.directories -io.files.temp io.ports kernel sequences math -specialized-arrays.instances.alien.c-types.int tools.test -specialized-arrays alien.c-types classes.struct alien ; +USING: destructors io io.directories io.encodings.binary +io.files io.files.temp kernel libc math sequences +specialized-arrays.instances.alien.c-types.int tools.test ; IN: io.ports.tests ! Make sure that writing malloced storage to a file works, and @@ -9,9 +8,11 @@ IN: io.ports.tests [ ] [ "test.txt" temp-file binary [ - 100,000 iota - 0 - 100,000 malloc-int-array &dispose [ copy ] keep write + [ + 100,000 iota + 0 + 100,000 malloc-int-array &free [ copy ] keep write + ] with-destructors ] with-file-writer ] unit-test @@ -21,43 +22,4 @@ IN: io.ports.tests ] with-file-reader ] unit-test -USE: multiline -/* -[ ] [ - BV{ 0 1 2 } "test.txt" temp-file binary set-file-contents -] unit-test - -[ t ] [ - "test.txt" temp-file binary file-contents - B{ 0 1 2 } = -] unit-test - -STRUCT: pt { x uint } { y uint } ; -SPECIALIZED-ARRAY: pt - -CONSTANT: pt-array-1 - pt-array{ S{ pt f 1 1 } S{ pt f 2 2 } S{ pt f 3 3 } } - -[ ] [ - pt-array-1 - "test.txt" temp-file binary set-file-contents -] unit-test - -[ t ] [ - "test.txt" temp-file binary file-contents - pt-array-1 >c-ptr sequence= -] unit-test - -[ ] [ - pt-array-1 rest-slice - "test.txt" temp-file binary set-file-contents -] unit-test - -[ t ] [ - "test.txt" temp-file binary file-contents - pt-array-1 rest-slice >c-ptr sequence= -] unit-test - -*/ - [ ] [ "test.txt" temp-file delete-file ] unit-test diff --git a/basis/serialize/serialize-tests.factor b/basis/serialize/serialize-tests.factor index 036356e137..9213a54004 100644 --- a/basis/serialize/serialize-tests.factor +++ b/basis/serialize/serialize-tests.factor @@ -4,7 +4,8 @@ USING: tools.test kernel serialize io io.streams.byte-array alien arrays byte-arrays bit-arrays specialized-arrays sequences math prettyprint parser classes math.constants -io.encodings.binary random assocs serialize.private alien.c-types ; +io.encodings.binary random assocs serialize.private alien.c-types +combinators.short-circuit ; SPECIALIZED-ARRAY: double IN: serialize.tests @@ -16,11 +17,12 @@ IN: serialize.tests [ t ] [ 100 [ drop - 40 [ test-serialize-cell ] all-integers? - 4 [ 40 * test-serialize-cell ] all-integers? - 4 [ 400 * test-serialize-cell ] all-integers? - 4 [ 4000 * test-serialize-cell ] all-integers? - and and and + { + [ 40 [ test-serialize-cell ] all-integers? ] + [ 4 [ 40 * test-serialize-cell ] all-integers? ] + [ 4 [ 400 * test-serialize-cell ] all-integers? ] + [ 4 [ 4000 * test-serialize-cell ] all-integers? ] + } 0&& ] all-integers? ] unit-test diff --git a/basis/specialized-arrays/specialized-arrays-tests.factor b/basis/specialized-arrays/specialized-arrays-tests.factor index c25f8ae3b1..645606edc5 100644 --- a/basis/specialized-arrays/specialized-arrays-tests.factor +++ b/basis/specialized-arrays/specialized-arrays-tests.factor @@ -1,12 +1,13 @@ IN: specialized-arrays.tests USING: tools.test alien.syntax specialized-arrays -specialized-arrays.private sequences alien.c-types accessors +specialized-arrays.private sequences alien accessors kernel arrays combinators compiler compiler.units classes.struct combinators.smart compiler.tree.debugger math libc destructors sequences.private multiline eval words vocabs namespaces assocs prettyprint alien.data math.vectors definitions compiler.test ; -FROM: alien.c-types => float ; +FROM: alien.c-types => int float bool char float ulonglong ushort uint +heap-size little-endian? ; SPECIALIZED-ARRAY: int SPECIALIZED-ARRAYS: bool ushort char uint float ulonglong ; diff --git a/basis/specialized-arrays/specialized-arrays.factor b/basis/specialized-arrays/specialized-arrays.factor index f7070c68e1..b052becfed 100644 --- a/basis/specialized-arrays/specialized-arrays.factor +++ b/basis/specialized-arrays/specialized-arrays.factor @@ -95,7 +95,7 @@ M: A resize ] [ drop ] 2bi ; inline -M: A byte-length length \ T heap-size * ; inline +M: A element-size drop \ T heap-size ; inline M: A direct-array-syntax drop \ A@ ; diff --git a/basis/specialized-vectors/specialized-vectors.factor b/basis/specialized-vectors/specialized-vectors.factor index c16fe2510d..0c0569ea9d 100644 --- a/basis/specialized-vectors/specialized-vectors.factor +++ b/basis/specialized-vectors/specialized-vectors.factor @@ -1,4 +1,4 @@ -! Copyright (C) 2008, 2009 Slava Pestov. +! Copyright (C) 2008, 2010 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: accessors alien alien.c-types alien.parser assocs compiler.units functors growable kernel lexer math namespaces @@ -26,7 +26,7 @@ V A vectors.functor:define-vector M: V contract 2drop ; inline -M: V byte-length length \ T heap-size * ; inline +M: V element-size drop \ T heap-size ; inline M: V pprint-delims drop \ V{ \ } ; diff --git a/basis/ui/backend/windows/windows.factor b/basis/ui/backend/windows/windows.factor index 5863d3f39d..0bf2e88468 100644 --- a/basis/ui/backend/windows/windows.factor +++ b/basis/ui/backend/windows/windows.factor @@ -212,7 +212,7 @@ PRIVATE> dup win32-error=0/f dup GlobalLock dup win32-error=0/f - swapd byte-array>memory + rot binary-object memcpy dup GlobalUnlock win32-error=0/f CF_UNICODETEXT swap SetClipboardData win32-error=0/f ] with-clipboard ; diff --git a/basis/windows/directx/dinput/constants/constants.factor b/basis/windows/directx/dinput/constants/constants.factor index 26f9da00ec..ba4d750174 100644 --- a/basis/windows/directx/dinput/constants/constants.factor +++ b/basis/windows/directx/dinput/constants/constants.factor @@ -72,10 +72,7 @@ M: array array-base-type first ; call swap set-global ; inline : (malloc-guid-symbol) ( symbol guid -- ) - '[ - _ execute( -- value ) - [ byte-length malloc ] [ over byte-array>memory ] bi - ] initialize ; + '[ _ execute( -- value ) malloc-byte-array ] initialize ; : define-guid-constants ( -- ) { diff --git a/core/alien/alien-docs.factor b/core/alien/alien-docs.factor index 60c1cdaf69..99f3a2b0f4 100644 --- a/core/alien/alien-docs.factor +++ b/core/alien/alien-docs.factor @@ -1,18 +1,24 @@ USING: byte-arrays arrays help.syntax help.markup alien.syntax compiler definitions math libc eval debugger parser io io.backend system alien.accessors -alien.libraries alien.c-types quotations kernel ; +alien.libraries alien.c-types quotations kernel +sequences ; IN: alien HELP: >c-ptr -{ $values { "object" object } { "c-ptr" c-ptr } } +{ $values { "obj" object } { "c-ptr" c-ptr } } { $contract "Outputs a pointer to the binary data of this object." } ; HELP: byte-length -{ $values { "object" object } { "n" "a non-negative integer" } } +{ $values { "obj" object } { "n" "a non-negative integer" } } { $contract "Outputs the number of bytes of binary data that will be output by " { $link >c-ptr } "." } ; -{ >c-ptr byte-length } related-words +HELP: element-size +{ $values { "seq" sequence } { "n" "a non-negative integer" } } +{ $contract "Outputs the number of bytes used for each element of the sequence." } +{ $notes "If a sequence class implements " { $link element-size } " and " { $link >c-ptr } ", then instances of this sequence, as well as slices of this sequence, can be used as binary objects." } ; + +{ >c-ptr element-size byte-length } related-words HELP: alien { $class-description "The class of alien pointers. See " { $link "syntax-aliens" } " for syntax and " { $link "c-data" } " for general information." } ; diff --git a/core/alien/alien.factor b/core/alien/alien.factor index 42f48f97aa..3802147838 100644 --- a/core/alien/alien.factor +++ b/core/alien/alien.factor @@ -1,30 +1,42 @@ ! Copyright (C) 2004, 2010 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: accessors assocs kernel math namespaces sequences system -kernel.private byte-arrays arrays init ; +kernel.private byte-arrays byte-vectors arrays init ; IN: alien PREDICATE: pinned-alien < alien underlying>> not ; UNION: pinned-c-ptr pinned-alien POSTPONE: f ; -GENERIC: >c-ptr ( obj -- c-ptr ) flushable +GENERIC: element-size ( seq -- n ) flushable -M: c-ptr >c-ptr ; inline +M: byte-array element-size drop 1 ; inline -GENERIC: byte-length ( seq -- n ) flushable +M: byte-vector element-size drop 1 ; inline -M: byte-array byte-length length ; inline +M: slice element-size seq>> element-size ; inline -M: f byte-length drop 0 ; inline +M: f element-size drop 1 ; inline -: binary-object ( obj -- c-ptr n ) - [ >c-ptr ] [ byte-length ] bi ; inline +GENERIC: byte-length ( obj -- n ) flushable + +M: object byte-length [ length ] [ element-size ] bi * ; inline + +GENERIC: >c-ptr ( obj -- c-ptr ) flushable + +M: c-ptr >c-ptr ; inline + +M: slice >c-ptr + [ [ from>> ] [ element-size ] bi * ] [ seq>> >c-ptr ] bi + ; inline SLOT: underlying M: object >c-ptr underlying>> ; inline +: binary-object ( obj -- c-ptr n ) + [ >c-ptr ] [ byte-length ] bi ; inline + GENERIC: expired? ( c-ptr -- ? ) flushable M: alien expired? expired>> ; diff --git a/core/io/files/files-tests.factor b/core/io/files/files-tests.factor index cf58dbfe05..5db1822d9e 100644 --- a/core/io/files/files-tests.factor +++ b/core/io/files/files-tests.factor @@ -1,8 +1,9 @@ -USING: arrays debugger.threads destructors io io.directories -io.encodings.ascii io.encodings.binary io.encodings.string -io.encodings.8-bit.latin1 io.files io.files.private -io.files.temp io.files.unique kernel make math sequences system -threads tools.test generic.single specialized-arrays alien.c-types ; +USING: alien alien.c-types arrays classes.struct +debugger.threads destructors generic.single io io.directories +io.encodings.8-bit.latin1 io.encodings.ascii +io.encodings.binary io.encodings.string io.files +io.files.private io.files.temp io.files.unique kernel make math +sequences specialized-arrays system threads tools.test ; SPECIALIZED-ARRAY: int IN: io.files.tests @@ -80,6 +81,44 @@ IN: io.files.tests byte-array>int-array ] unit-test +[ ] [ + BV{ 0 1 2 } "test.txt" temp-file binary set-file-contents +] unit-test + +[ t ] [ + "test.txt" temp-file binary file-contents + B{ 0 1 2 } = +] unit-test + +STRUCT: pt { x uint } { y uint } ; +SPECIALIZED-ARRAY: pt + +CONSTANT: pt-array-1 + pt-array{ S{ pt f 1 1 } S{ pt f 2 2 } S{ pt f 3 3 } } + +[ ] [ + pt-array-1 + "test.txt" temp-file binary set-file-contents +] unit-test + +[ t ] [ + "test.txt" temp-file binary file-contents + pt-array-1 >c-ptr sequence= +] unit-test + +! Slices should support >c-ptr and byte-length + +[ ] [ + pt-array-1 rest-slice + "test.txt" temp-file binary set-file-contents +] unit-test + +[ t ] [ + "test.txt" temp-file binary file-contents + byte-array>pt-array + pt-array-1 rest-slice sequence= +] unit-test + ! Writing strings to binary streams should fail [ "test.txt" temp-file binary [ diff --git a/core/io/streams/byte-array/byte-array-tests.factor b/core/io/streams/byte-array/byte-array-tests.factor index dc95d454fa..46e015e576 100644 --- a/core/io/streams/byte-array/byte-array-tests.factor +++ b/core/io/streams/byte-array/byte-array-tests.factor @@ -6,6 +6,7 @@ IN: io.streams.byte-array.tests [ B{ } ] [ B{ } binary [ contents ] with-byte-reader ] unit-test [ B{ 1 2 3 } ] [ binary [ B{ 1 2 3 } write ] with-byte-writer ] unit-test +[ B{ 1 2 3 4 5 6 } ] [ binary [ B{ 1 2 3 } write B{ 4 5 6 } write ] with-byte-writer ] unit-test [ B{ 1 2 3 } ] [ { 1 2 3 } binary [ 3 read ] with-byte-reader ] unit-test [ B{ BIN: 11110101 BIN: 10111111 BIN: 10000000 BIN: 10111111 BIN: 11101111 BIN: 10000000 BIN: 10111111 BIN: 11011111 BIN: 10000000 CHAR: x } ] -- 2.34.1