1 ! (c)2009, 2010 Slava Pestov, Joe Groff bsd license
2 USING: accessors alien alien.c-types alien.strings arrays
3 byte-arrays cpu.architecture fry io io.encodings.binary
4 io.files io.streams.memory kernel libc math sequences words
8 GENERIC: require-c-array ( c-type -- )
10 M: array require-c-array first require-c-array ;
12 GENERIC: c-array-constructor ( c-type -- word ) foldable
14 GENERIC: c-(array)-constructor ( c-type -- word ) foldable
16 GENERIC: c-direct-array-constructor ( c-type -- word ) foldable
18 GENERIC: <c-array> ( len c-type -- array )
21 c-array-constructor execute( len -- array ) ; inline
23 GENERIC: (c-array) ( len c-type -- array )
26 c-(array)-constructor execute( len -- array ) ; inline
28 GENERIC: <c-direct-array> ( alien len c-type -- array )
30 M: word <c-direct-array>
31 c-direct-array-constructor execute( alien len -- array ) ; inline
33 : malloc-array ( n type -- array )
34 [ heap-size calloc ] [ <c-direct-array> ] 2bi ; inline
36 : (malloc-array) ( n type -- alien )
37 [ heap-size * malloc ] [ <c-direct-array> ] 2bi ; inline
39 : <c-object> ( type -- array )
40 heap-size <byte-array> ; inline
42 : (c-object) ( type -- array )
43 heap-size (byte-array) ; inline
45 : malloc-object ( type -- alien )
46 1 swap heap-size calloc ; inline
48 : (malloc-object) ( type -- alien )
49 heap-size malloc ; inline
51 : malloc-byte-array ( byte-array -- alien )
52 dup byte-length [ nip malloc dup ] 2keep memcpy ;
54 : memory>byte-array ( alien len -- byte-array )
55 [ nip (byte-array) dup ] 2keep memcpy ;
57 : malloc-string ( string encoding -- alien )
58 string>alien malloc-byte-array ;
60 M: memory-stream stream-read
62 [ index>> ] [ alien>> ] bi <displaced-alien>
63 swap memory>byte-array
64 ] [ [ + ] change-index drop ] 2bi ;
66 : byte-array>memory ( byte-array base -- )
67 swap dup byte-length memcpy ; inline
69 M: byte-vector stream-write
71 [ [ length + ] keep lengthen drop ]
72 [ '[ _ underlying>> ] 2dip memcpy ]
75 M: value-type c-type-rep drop int-rep ;
77 M: value-type c-type-getter
78 drop [ swap <displaced-alien> ] ;
80 M: value-type c-type-setter ( type -- quot )
81 [ c-type-getter ] [ c-type-unboxer-quot ] [ heap-size ] tri
82 '[ @ swap @ _ memcpy ] ;