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

@@ -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 <c-direct-array> } "." }
@@ -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 }
+{ $subsections memory>byte-array } ;
-"You can copy a byte array to memory unsafely:"
-{ $subsections byte-array>memory } ;
 
 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 }

basis/alien/data/data.factor

@@ -49,7 +49,7 @@ M: word <c-direct-array>
     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
+    [ dup byte-length tail-slice ]
-    [ [ length + ] keep lengthen drop ]
+    [ [ [ byte-length ] bi@ + ] keep lengthen ]
-    [ '[ _ underlying>> ] 2dip memcpy ]
+    [ drop byte-length ]
-    3bi ;
+    2tri
+    [ >c-ptr swap >c-ptr ] dip memcpy ;
 
 M: value-type c-type-rep drop int-rep ;
 

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

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
+    [ ptr>> swap >byte-array binary-object memcpy ]
-    [ length ] dip buffer-reset ;
+    [ [ length ] dip buffer-reset ]
+    2bi ;
 
 : string>buffer ( string -- buffer )
     dup length <buffer> [ buffer-set ] keep ;

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 ;
 

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
 

basis/io/ports/ports-tests.factor

@@ -1,7 +1,6 @@
-USING: destructors io io.encodings.binary io.files io.directories
+USING: destructors io io.directories io.encodings.binary
-io.files.temp io.ports kernel sequences math
+io.files io.files.temp kernel libc math sequences
-specialized-arrays.instances.alien.c-types.int tools.test
+specialized-arrays.instances.alien.c-types.int tools.test ;
-specialized-arrays alien.c-types classes.struct alien ;
 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 iota
-        100,000 malloc-int-array &dispose [ copy ] keep write
+            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

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?
+            [ 40 [        test-serialize-cell ] all-integers? ]
-         4 [ 400 *  test-serialize-cell ] all-integers?
+            [  4 [ 40 *   test-serialize-cell ] all-integers? ]
-         4 [ 4000 * test-serialize-cell ] all-integers?
+            [  4 [ 400 *  test-serialize-cell ] all-integers? ]
-        and and and
+            [  4 [ 4000 * test-serialize-cell ] all-integers? ]
+        } 0&&
     ] all-integers?
 ] unit-test
 

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 ;

basis/specialized-arrays/specialized-arrays.factor

@@ -95,7 +95,7 @@ M: A resize
     ] [ drop ] 2bi
     <direct-A> ; 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@ ;
 

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 <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{ \ } ;
 

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 ;

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 ) malloc-byte-array ] initialize ;
-        _ execute( -- value )
-        [ byte-length malloc ] [ over byte-array>memory ] bi
-    ] initialize ;
 
 : define-guid-constants ( -- )
     {

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." } ;

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: element-size ( seq -- n ) flushable
+
+M: byte-array element-size drop 1 ; inline
+
+M: byte-vector element-size drop 1 ; inline
+
+M: slice element-size seq>> element-size ; inline
+
+M: f element-size drop 1 ; 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
 
-GENERIC: byte-length ( seq -- n ) flushable
+M: slice >c-ptr
-
+    [ [ from>> ] [ element-size ] bi * ] [ seq>> >c-ptr ] bi
-M: byte-array byte-length length ; inline
+    <displaced-alien> ; inline
-
-M: f byte-length drop 0 ; inline
-
-: binary-object ( obj -- c-ptr n )
-    [ >c-ptr ] [ byte-length ] 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>> ;

core/io/files/files-tests.factor

@@ -1,8 +1,9 @@
-USING: arrays debugger.threads destructors io io.directories
+USING: alien alien.c-types arrays classes.struct
-io.encodings.ascii io.encodings.binary io.encodings.string
+debugger.threads destructors generic.single io io.directories
-io.encodings.8-bit.latin1 io.files io.files.private
+io.encodings.8-bit.latin1 io.encodings.ascii
-io.files.temp io.files.unique kernel make math sequences system
+io.encodings.binary io.encodings.string io.files
-threads tools.test generic.single specialized-arrays alien.c-types ;
+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 [

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