1 ! (c)2009, 2010 Slava Pestov, Joe Groff bsd license
2 USING: accessors alien alien.c-types alien.arrays alien.strings
3 arrays byte-arrays cpu.architecture fry io io.encodings.binary
4 io.files io.streams.memory kernel libc math math.functions
5 sequences words macros combinators generalizations
6 stack-checker.dependencies combinators.short-circuit ;
10 GENERIC: require-c-array ( c-type -- )
12 M: array require-c-array first require-c-array ;
14 GENERIC: c-array-constructor ( c-type -- word ) foldable
16 GENERIC: c-(array)-constructor ( c-type -- word ) foldable
18 GENERIC: c-direct-array-constructor ( c-type -- word ) foldable
20 GENERIC: <c-array> ( len c-type -- array )
23 c-array-constructor execute( len -- array ) ; inline
26 drop void* <c-array> ;
28 GENERIC: (c-array) ( len c-type -- array )
31 c-(array)-constructor execute( len -- array ) ; inline
34 drop void* (c-array) ;
36 GENERIC: <c-direct-array> ( alien len c-type -- array )
38 M: word <c-direct-array>
39 c-direct-array-constructor execute( alien len -- array ) ; inline
41 M: pointer <c-direct-array>
42 drop void* <c-direct-array> ;
44 : malloc-array ( n type -- array )
45 [ heap-size calloc ] [ <c-direct-array> ] 2bi ; inline
47 : (malloc-array) ( n type -- alien )
48 [ heap-size * malloc ] [ <c-direct-array> ] 2bi ; inline
50 : <c-object> ( type -- array )
51 heap-size <byte-array> ; inline
53 : (c-object) ( type -- array )
54 heap-size (byte-array) ; inline
56 : malloc-byte-array ( byte-array -- alien )
57 binary-object [ nip malloc dup ] 2keep memcpy ;
59 : memory>byte-array ( alien len -- byte-array )
60 [ nip (byte-array) dup ] 2keep memcpy ;
62 : malloc-string ( string encoding -- alien )
63 string>alien malloc-byte-array ;
65 M: memory-stream stream-read
67 [ index>> ] [ alien>> ] bi <displaced-alien>
68 swap memory>byte-array
69 ] [ [ + ] change-index drop ] 2bi ;
71 M: value-type c-type-rep drop int-rep ;
73 M: value-type c-type-getter
74 drop [ swap <displaced-alien> ] ;
76 M: value-type c-type-copier
77 heap-size '[ _ memory>byte-array ] ;
79 M: value-type c-type-setter
80 [ c-type-getter ] [ heap-size ] bi '[ @ swap _ memcpy ] ;
82 M: array c-type-boxer-quot
83 unclip [ array-length ] dip [ <c-direct-array> ] 2curry ;
85 M: array c-type-unboxer-quot drop [ >c-ptr ] ;
87 ERROR: local-allocation-error ;
91 : (local-allot) ( size align -- alien ) local-allocation-error ;
93 : (cleanup-allot) ( -- )
94 ! Inhibit TCO in order for the last word in the quotation
95 ! to still be abl to access scope-allocated data.
98 MACRO: (simple-local-allot) ( c-type -- quot )
100 [ dup '[ _ heap-size _ c-type-align (local-allot) ] ] bi ;
102 : [hairy-local-allot] ( c-type initial -- quot )
103 over '[ _ (simple-local-allot) _ over 0 _ set-alien-value ] ;
105 : hairy-local-allot? ( obj -- ? )
109 [ second initial: eq? ]
112 MACRO: (hairy-local-allot) ( obj -- quot )
113 dup hairy-local-allot?
114 [ first3 nip [hairy-local-allot] ]
115 [ '[ _ (simple-local-allot) ] ]
118 MACRO: (local-allots) ( c-types -- quot )
119 [ '[ _ (hairy-local-allot) ] ] map [ ] join ;
121 MACRO: box-values ( c-types -- quot )
122 [ c-type-boxer-quot ] map '[ _ spread ] ;
124 MACRO: out-parameters ( c-types -- quot )
125 [ dup hairy-local-allot? [ first ] when ] map
126 [ length ] [ [ '[ 0 _ alien-copy-value ] ] map ] bi
127 '[ _ nkeep _ spread ] ;
131 : with-scoped-allocation ( c-types quot -- )
132 [ [ (local-allots) ] [ box-values ] bi ] dip call
133 (cleanup-allot) ; inline
135 : with-out-parameters ( c-types quot -- values... )
136 [ drop (local-allots) ] [ swap out-parameters ] 2bi
137 (cleanup-allot) ; inline
139 GENERIC: binary-zero? ( value -- ? )
141 M: object binary-zero? drop f ; inline
142 M: f binary-zero? drop t ; inline
143 M: integer binary-zero? zero? ; inline
144 M: math:float binary-zero? double>bits zero? ; inline
145 M: complex binary-zero? >rect [ binary-zero? ] both? ; inline