1 ! Copyright (C) 2004, 2009 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 make 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 continuations fry classes ;
13 : little-endian? ( -- ? ) 1 <int> *char 1 = ; foldable
16 { class class initial: object }
18 { boxer-quot callable }
20 { unboxer-quot callable }
23 { reg-class initial: int-regs }
28 : <c-type> ( -- type )
34 c-types [ H{ } assoc-like ] change
37 ERROR: no-c-type name ;
39 : (c-type) ( name -- type/f )
40 c-types get-global at dup [
41 dup string? [ (c-type) ] when
45 GENERIC: c-type ( name -- type ) foldable
47 : resolve-pointer-type ( name -- name )
48 c-types get at dup string?
49 [ "*" append ] [ drop "void*" ] if
52 : resolve-typedef ( name -- type )
53 dup string? [ c-type ] when ;
55 : parse-array-type ( name -- array )
57 [ [ "]" ?tail drop string>number ] map ] dip prefix ;
59 M: string c-type ( name -- type )
60 CHAR: ] over member? [
66 "*" ?tail [ resolve-pointer-type ] [ no-c-type ] if
70 GENERIC: c-type-class ( name -- class )
72 M: c-type c-type-class class>> ;
74 M: string c-type-class c-type c-type-class ;
76 GENERIC: c-type-boxer ( name -- boxer )
78 M: c-type c-type-boxer boxer>> ;
80 M: string c-type-boxer c-type c-type-boxer ;
82 GENERIC: c-type-boxer-quot ( name -- quot )
84 M: c-type c-type-boxer-quot boxer-quot>> ;
86 M: string c-type-boxer-quot c-type c-type-boxer-quot ;
88 GENERIC: c-type-unboxer ( name -- boxer )
90 M: c-type c-type-unboxer unboxer>> ;
92 M: string c-type-unboxer c-type c-type-unboxer ;
94 GENERIC: c-type-unboxer-quot ( name -- quot )
96 M: c-type c-type-unboxer-quot unboxer-quot>> ;
98 M: string c-type-unboxer-quot c-type c-type-unboxer-quot ;
100 GENERIC: c-type-reg-class ( name -- reg-class )
102 M: c-type c-type-reg-class reg-class>> ;
104 M: string c-type-reg-class c-type c-type-reg-class ;
106 GENERIC: c-type-getter ( name -- quot )
108 M: c-type c-type-getter getter>> ;
110 M: string c-type-getter c-type c-type-getter ;
112 GENERIC: c-type-setter ( name -- quot )
114 M: c-type c-type-setter setter>> ;
116 M: string c-type-setter c-type c-type-setter ;
118 GENERIC: c-type-align ( name -- n )
120 M: c-type c-type-align align>> ;
122 M: string c-type-align c-type c-type-align ;
124 GENERIC: c-type-stack-align? ( name -- ? )
126 M: c-type c-type-stack-align? stack-align?>> ;
128 M: string c-type-stack-align? c-type c-type-stack-align? ;
130 : c-type-box ( n type -- )
132 swap c-type-boxer [ "No boxer" throw ] unless*
135 : c-type-unbox ( n ctype -- )
137 swap c-type-unboxer [ "No unboxer" throw ] unless*
140 GENERIC: box-parameter ( n ctype -- )
142 M: c-type box-parameter c-type-box ;
144 M: string box-parameter c-type box-parameter ;
146 GENERIC: box-return ( ctype -- )
148 M: c-type box-return f swap c-type-box ;
150 M: string box-return c-type box-return ;
152 GENERIC: unbox-parameter ( n ctype -- )
154 M: c-type unbox-parameter c-type-unbox ;
156 M: string unbox-parameter c-type unbox-parameter ;
158 GENERIC: unbox-return ( ctype -- )
160 M: c-type unbox-return f swap c-type-unbox ;
162 M: string unbox-return c-type unbox-return ;
164 ! These words being foldable means that words need to be
165 ! recompiled if a C type is redefined. Even so, folding the
166 ! size facilitates some optimizations.
167 GENERIC: heap-size ( type -- size ) foldable
169 M: string heap-size c-type heap-size ;
171 M: c-type heap-size size>> ;
173 GENERIC: stack-size ( type -- size ) foldable
175 M: string stack-size c-type stack-size ;
177 M: c-type stack-size size>> cell align ;
179 GENERIC: byte-length ( seq -- n ) flushable
181 M: byte-array byte-length length ;
183 M: f byte-length drop 0 ;
185 : c-getter ( name -- quot )
187 [ "Cannot read struct fields with this type" throw ]
190 : c-type-getter-boxer ( name -- quot )
191 [ c-getter ] [ c-type-boxer-quot ] bi append ;
193 : c-setter ( name -- quot )
195 [ "Cannot write struct fields with this type" throw ]
198 : <c-array> ( n type -- array )
199 heap-size * <byte-array> ; inline
201 : <c-object> ( type -- array )
202 1 swap <c-array> ; inline
204 : malloc-array ( n type -- alien )
205 heap-size calloc ; inline
207 : malloc-object ( type -- alien )
208 1 swap malloc-array ; inline
210 : malloc-byte-array ( byte-array -- alien )
211 dup byte-length [ nip malloc dup ] 2keep memcpy ;
213 : memory>byte-array ( alien len -- byte-array )
214 [ nip (byte-array) dup ] 2keep memcpy ;
216 : byte-array>memory ( byte-array base -- )
217 swap dup byte-length memcpy ;
219 : array-accessor ( type quot -- def )
221 \ swap , [ heap-size , [ * >fixnum ] % ] [ % ] bi*
224 : typedef ( old new -- ) c-types get set-at ;
226 TUPLE: long-long-type < c-type ;
228 : <long-long-type> ( -- type )
231 M: long-long-type unbox-parameter ( n type -- )
232 c-type-unboxer %unbox-long-long ;
234 M: long-long-type unbox-return ( type -- )
235 f swap unbox-parameter ;
237 M: long-long-type box-parameter ( n type -- )
238 c-type-boxer %box-long-long ;
240 M: long-long-type box-return ( type -- )
241 f swap box-parameter ;
243 : define-deref ( name -- )
244 [ CHAR: * prefix "alien.c-types" create ] [ c-getter 0 prefix ] bi
245 (( c-ptr -- value )) define-inline ;
247 : define-out ( name -- )
248 [ "alien.c-types" constructor-word ]
249 [ dup c-setter '[ _ <c-object> [ 0 @ ] keep ] ] bi
250 (( value -- c-ptr )) define-inline ;
252 : c-bool> ( int -- ? )
255 : define-primitive-type ( type name -- )
261 : expand-constants ( c-type -- c-type' )
266 def>> call( -- object )
272 : malloc-file-contents ( path -- alien len )
273 binary file-contents [ malloc-byte-array ] [ length ] bi ;
275 : if-void ( type true false -- )
276 pick "void" = [ drop nip call ] [ nip call ] if ; inline
278 CONSTANT: primitive-types
284 "longlong" "ulonglong"
292 [ alien-cell ] >>getter
293 [ [ >c-ptr ] 2dip set-alien-cell ] >>setter
294 bootstrap-cell >>size
295 bootstrap-cell >>align
296 [ >c-ptr ] >>unboxer-quot
298 "alien_offset" >>unboxer
299 "void*" define-primitive-type
303 [ alien-signed-8 ] >>getter
304 [ set-alien-signed-8 ] >>setter
307 "box_signed_8" >>boxer
308 "to_signed_8" >>unboxer
309 "longlong" define-primitive-type
313 [ alien-unsigned-8 ] >>getter
314 [ set-alien-unsigned-8 ] >>setter
317 "box_unsigned_8" >>boxer
318 "to_unsigned_8" >>unboxer
319 "ulonglong" define-primitive-type
323 [ alien-signed-cell ] >>getter
324 [ set-alien-signed-cell ] >>setter
325 bootstrap-cell >>size
326 bootstrap-cell >>align
327 "box_signed_cell" >>boxer
328 "to_fixnum" >>unboxer
329 "long" define-primitive-type
333 [ alien-unsigned-cell ] >>getter
334 [ set-alien-unsigned-cell ] >>setter
335 bootstrap-cell >>size
336 bootstrap-cell >>align
337 "box_unsigned_cell" >>boxer
339 "ulong" define-primitive-type
343 [ alien-signed-4 ] >>getter
344 [ set-alien-signed-4 ] >>setter
347 "box_signed_4" >>boxer
348 "to_fixnum" >>unboxer
349 "int" define-primitive-type
353 [ alien-unsigned-4 ] >>getter
354 [ set-alien-unsigned-4 ] >>setter
357 "box_unsigned_4" >>boxer
359 "uint" define-primitive-type
363 [ alien-signed-2 ] >>getter
364 [ set-alien-signed-2 ] >>setter
367 "box_signed_2" >>boxer
368 "to_fixnum" >>unboxer
369 "short" define-primitive-type
373 [ alien-unsigned-2 ] >>getter
374 [ set-alien-unsigned-2 ] >>setter
377 "box_unsigned_2" >>boxer
379 "ushort" define-primitive-type
383 [ alien-signed-1 ] >>getter
384 [ set-alien-signed-1 ] >>setter
387 "box_signed_1" >>boxer
388 "to_fixnum" >>unboxer
389 "char" define-primitive-type
393 [ alien-unsigned-1 ] >>getter
394 [ set-alien-unsigned-1 ] >>setter
397 "box_unsigned_1" >>boxer
399 "uchar" define-primitive-type
402 [ alien-unsigned-4 zero? not ] >>getter
403 [ [ 1 0 ? ] 2dip set-alien-unsigned-4 ] >>setter
406 "box_boolean" >>boxer
407 "to_boolean" >>unboxer
408 "bool" define-primitive-type
412 [ alien-float ] >>getter
413 [ [ >float ] 2dip set-alien-float ] >>setter
418 single-float-regs >>reg-class
419 [ >float ] >>unboxer-quot
420 "float" define-primitive-type
424 [ alien-double ] >>getter
425 [ [ >float ] 2dip set-alien-double ] >>setter
429 "to_double" >>unboxer
430 double-float-regs >>reg-class
431 [ >float ] >>unboxer-quot
432 "double" define-primitive-type
434 "long" "ptrdiff_t" typedef
435 "long" "intptr_t" typedef
436 "ulong" "size_t" typedef
437 ] with-compilation-unit