1 ! Copyright (C) 2004, 2008 Slava Pestov.
2 ! See http://factorcode.org/license.txt for BSD license.
3 USING: byte-arrays arrays assocs kernel kernel.private libc math
4 namespaces parser sequences strings words assocs splitting
5 math.parser cpu.architecture alien alien.accessors quotations
6 layouts system compiler.units io.files io.encodings.binary
7 accessors combinators effects ;
13 : little-endian? ( -- ? ) 1 <int> *char 1 = ; foldable
16 boxer boxer-quot unboxer unboxer-quot
18 reg-class size align stack-align? ;
20 : new-c-type ( class -- type )
22 int-regs >>reg-class ;
24 : <c-type> ( -- type )
30 c-types [ H{ } assoc-like ] change
33 ERROR: no-c-type name ;
35 : (c-type) ( name -- type/f )
36 c-types get-global at dup [
37 dup string? [ (c-type) ] when
40 GENERIC: c-type ( name -- type ) foldable
42 : resolve-pointer-type ( name -- name )
43 c-types get at dup string?
44 [ "*" append ] [ drop "void*" ] if
47 : resolve-typedef ( name -- type )
48 dup string? [ c-type ] when ;
50 : parse-array-type ( name -- array )
52 >r [ "]" ?tail drop string>number ] map r> prefix ;
54 M: string c-type ( name -- type )
55 CHAR: ] over member? [
61 "*" ?tail [ resolve-pointer-type ] [ no-c-type ] if
65 : c-type-box ( n type -- )
67 swap c-type-boxer [ "No boxer" throw ] unless*
70 : c-type-unbox ( n ctype -- )
72 swap c-type-unboxer [ "No unboxer" throw ] unless*
75 M: string c-type-align c-type c-type-align ;
77 M: string c-type-stack-align? c-type c-type-stack-align? ;
79 GENERIC: box-parameter ( n ctype -- )
81 M: c-type box-parameter c-type-box ;
83 M: string box-parameter c-type box-parameter ;
85 GENERIC: box-return ( ctype -- )
87 M: c-type box-return f swap c-type-box ;
89 M: string box-return c-type box-return ;
91 GENERIC: unbox-parameter ( n ctype -- )
93 M: c-type unbox-parameter c-type-unbox ;
95 M: string unbox-parameter c-type unbox-parameter ;
97 GENERIC: unbox-return ( ctype -- )
99 M: c-type unbox-return f swap c-type-unbox ;
101 M: string unbox-return c-type unbox-return ;
103 ! These words being foldable means that words need to be
104 ! recompiled if a C type is redefined. Even so, folding the
105 ! size facilitates some optimizations.
106 GENERIC: heap-size ( type -- size ) foldable
108 M: string heap-size c-type heap-size ;
110 M: c-type heap-size c-type-size ;
112 GENERIC: stack-size ( type -- size ) foldable
114 M: string stack-size c-type stack-size ;
116 M: c-type stack-size c-type-size ;
118 GENERIC: byte-length ( seq -- n ) flushable
120 M: byte-array byte-length length ;
122 : c-getter ( name -- quot )
123 c-type c-type-getter [
124 [ "Cannot read struct fields with type" throw ]
127 : c-setter ( name -- quot )
128 c-type c-type-setter [
129 [ "Cannot write struct fields with type" throw ]
132 : <c-array> ( n type -- array )
133 heap-size * <byte-array> ; inline
135 : <c-object> ( type -- array )
136 1 swap <c-array> ; inline
138 : malloc-array ( n type -- alien )
139 heap-size calloc ; inline
141 : malloc-object ( type -- alien )
142 1 swap malloc-array ; inline
144 : malloc-byte-array ( byte-array -- alien )
145 dup length dup malloc [ -rot memcpy ] keep ;
147 : memory>byte-array ( alien len -- byte-array )
148 dup <byte-array> [ -rot memcpy ] keep ;
150 : byte-array>memory ( byte-array base -- )
151 swap dup length memcpy ;
153 : (define-nth) ( word type quot -- )
155 \ swap , [ heap-size , [ * >fixnum ] % ] [ % ] bi*
156 ] [ ] make define-inline ;
158 : nth-word ( name vocab -- word )
159 >r "-nth" append r> create ;
161 : define-nth ( name vocab -- )
162 dupd nth-word swap dup c-getter (define-nth) ;
164 : set-nth-word ( name vocab -- word )
165 >r "set-" swap "-nth" 3append r> create ;
167 : define-set-nth ( name vocab -- )
168 dupd set-nth-word swap dup c-setter (define-nth) ;
170 : typedef ( old new -- ) c-types get set-at ;
172 : define-c-type ( type name vocab -- )
173 >r tuck typedef r> [ define-nth ] 2keep define-set-nth ;
175 TUPLE: long-long-type < c-type ;
177 : <long-long-type> ( -- type )
178 long-long-type new-c-type ;
180 M: long-long-type unbox-parameter ( n type -- )
181 c-type-unboxer %unbox-long-long ;
183 M: long-long-type unbox-return ( type -- )
184 f swap unbox-parameter ;
186 M: long-long-type box-parameter ( n type -- )
187 c-type-boxer %box-long-long ;
189 M: long-long-type box-return ( type -- )
190 f swap box-parameter ;
192 : define-deref ( name vocab -- )
193 >r dup CHAR: * prefix r> create
194 swap c-getter 0 prefix define-inline ;
196 : define-out ( name vocab -- )
197 over [ <c-object> tuck 0 ] over c-setter append swap
198 >r >r constructor-word r> r> prefix define-inline ;
200 : c-bool> ( int -- ? )
203 : >c-array ( seq type word -- byte-array )
204 [ [ dup length ] dip <c-array> ] dip
205 [ [ execute ] 2curry each-index ] 2keep drop ; inline
207 : >c-array-quot ( type vocab -- quot )
208 dupd set-nth-word [ >c-array ] 2curry ;
210 : to-array-word ( name vocab -- word )
211 >r ">c-" swap "-array" 3append r> create ;
213 : define-to-array ( type vocab -- )
214 [ to-array-word ] 2keep >c-array-quot
215 (( array -- byte-array )) define-declared ;
217 : c-array>quot ( type vocab -- quot )
220 nth-word 1quotation ,
224 : from-array-word ( name vocab -- word )
225 >r "c-" swap "-array>" 3append r> create ;
227 : define-from-array ( type vocab -- )
228 [ from-array-word ] 2keep c-array>quot
229 (( c-ptr n -- array )) define-declared ;
231 : define-primitive-type ( type name -- )
237 [ define-from-array ]
241 : expand-constants ( c-type -- c-type' )
242 #! We use def>> call instead of execute to get around
243 #! staging violations
245 unclip >r [ dup word? [ def>> call ] when ] map r> prefix
248 : malloc-file-contents ( path -- alien len )
249 binary file-contents dup malloc-byte-array swap length ;
253 [ alien-cell ] >>getter
254 [ set-alien-cell ] >>setter
255 bootstrap-cell >>size
256 bootstrap-cell >>align
258 "alien_offset" >>unboxer
259 "void*" define-primitive-type
262 [ alien-signed-8 ] >>getter
263 [ set-alien-signed-8 ] >>setter
266 "box_signed_8" >>boxer
267 "to_signed_8" >>unboxer
268 "longlong" define-primitive-type
271 [ alien-unsigned-8 ] >>getter
272 [ set-alien-unsigned-8 ] >>setter
275 "box_unsigned_8" >>boxer
276 "to_unsigned_8" >>unboxer
277 "ulonglong" define-primitive-type
280 [ alien-signed-cell ] >>getter
281 [ set-alien-signed-cell ] >>setter
282 bootstrap-cell >>size
283 bootstrap-cell >>align
284 "box_signed_cell" >>boxer
285 "to_fixnum" >>unboxer
286 "long" define-primitive-type
289 [ alien-unsigned-cell ] >>getter
290 [ set-alien-unsigned-cell ] >>setter
291 bootstrap-cell >>size
292 bootstrap-cell >>align
293 "box_unsigned_cell" >>boxer
295 "ulong" define-primitive-type
298 [ alien-signed-4 ] >>getter
299 [ set-alien-signed-4 ] >>setter
302 "box_signed_4" >>boxer
303 "to_fixnum" >>unboxer
304 "int" define-primitive-type
307 [ alien-unsigned-4 ] >>getter
308 [ set-alien-unsigned-4 ] >>setter
311 "box_unsigned_4" >>boxer
313 "uint" define-primitive-type
316 [ alien-signed-2 ] >>getter
317 [ set-alien-signed-2 ] >>setter
320 "box_signed_2" >>boxer
321 "to_fixnum" >>unboxer
322 "short" define-primitive-type
325 [ alien-unsigned-2 ] >>getter
326 [ set-alien-unsigned-2 ] >>setter
329 "box_unsigned_2" >>boxer
331 "ushort" define-primitive-type
334 [ alien-signed-1 ] >>getter
335 [ set-alien-signed-1 ] >>setter
338 "box_signed_1" >>boxer
339 "to_fixnum" >>unboxer
340 "char" define-primitive-type
343 [ alien-unsigned-1 ] >>getter
344 [ set-alien-unsigned-1 ] >>setter
347 "box_unsigned_1" >>boxer
349 "uchar" define-primitive-type
352 [ alien-unsigned-4 zero? not ] >>getter
353 [ [ 1 0 ? ] 2dip set-alien-unsigned-4 ] >>setter
356 "box_boolean" >>boxer
357 "to_boolean" >>unboxer
358 "bool" define-primitive-type
361 [ alien-float ] >>getter
362 [ [ >float ] 2dip set-alien-float ] >>setter
367 single-float-regs >>reg-class
368 [ >float ] >>unboxer-quot
369 "float" define-primitive-type
372 [ alien-double ] >>getter
373 [ [ >float ] 2dip set-alien-double ] >>setter
377 "to_double" >>unboxer
378 double-float-regs >>reg-class
379 [ >float ] >>unboxer-quot
380 "double" define-primitive-type
382 os winnt? cpu x86.64? and "longlong" "long" ? "ptrdiff_t" typedef
384 "ulong" "size_t" typedef
385 ] with-compilation-unit