1 ! Copyright (C) 2004, 2010 Slava Pestov.
2 ! See http://factorcode.org/license.txt for BSD license.
3 USING: accessors alien alien.accessors arrays byte-arrays
4 classes combinators compiler.units cpu.architecture delegate
5 fry kernel layouts locals macros math math.order quotations
6 sequences system words words.symbol ;
24 TUPLE: abstract-c-type
25 { class class initial: object }
26 { boxed-class class initial: object }
27 { boxer-quot callable }
28 { unboxer-quot callable }
33 { align-first integer } ;
35 TUPLE: c-type < abstract-c-type
38 { rep initial: int-rep } ;
40 : <c-type> ( -- c-type )
43 ERROR: no-c-type name ;
46 GENERIC: c-type ( name -- c-type ) foldable
48 PREDICATE: c-type-word < word
51 TUPLE: pointer { to initial: void read-only } ;
57 : resolve-typedef ( name -- c-type )
58 dup void? [ no-c-type ] when
59 dup c-type-name? [ c-type ] when ;
62 dup "c-type" word-prop resolve-typedef
63 [ ] [ no-c-type ] ?if ;
65 GENERIC: c-type-class ( name -- class )
67 M: abstract-c-type c-type-class class>> ;
69 GENERIC: c-type-boxed-class ( name -- class )
71 M: abstract-c-type c-type-boxed-class boxed-class>> ;
73 GENERIC: c-type-boxer-quot ( name -- quot )
75 M: abstract-c-type c-type-boxer-quot boxer-quot>> ;
77 GENERIC: c-type-unboxer-quot ( name -- quot )
79 M: abstract-c-type c-type-unboxer-quot unboxer-quot>> ;
81 GENERIC: c-type-rep ( name -- rep )
83 M: c-type c-type-rep rep>> ;
85 GENERIC: c-type-getter ( name -- quot )
87 M: c-type c-type-getter getter>> ;
89 GENERIC: c-type-copier ( name -- quot )
91 M: c-type c-type-copier drop [ ] ;
93 GENERIC: c-type-setter ( name -- quot )
95 M: c-type c-type-setter setter>> ;
97 GENERIC: c-type-align ( name -- n ) foldable
99 M: abstract-c-type c-type-align align>> ;
101 GENERIC: c-type-align-first ( name -- n )
103 M: abstract-c-type c-type-align-first align-first>> ;
105 GENERIC: base-type ( c-type -- c-type )
107 M: c-type-name base-type c-type ;
109 M: c-type base-type ;
111 : little-endian? ( -- ? ) 1 int <ref> char deref 1 = ; foldable
113 GENERIC: heap-size ( name -- size )
115 M: abstract-c-type heap-size size>> ;
119 MACRO: alien-value ( c-type -- quot: ( c-ptr offset -- value ) )
120 [ c-type-getter ] [ c-type-boxer-quot ] bi append ;
122 MACRO: alien-copy-value ( c-type -- quot: ( c-ptr offset -- value ) )
123 [ c-type-getter ] [ c-type-copier ] [ c-type-boxer-quot ] tri 3append ;
125 MACRO: set-alien-value ( c-type -- quot: ( value c-ptr offset -- ) )
126 [ c-type-unboxer-quot [ [ ] ] [ '[ _ 2dip ] ] if-empty ]
130 : array-accessor ( n c-ptr c-type -- c-ptr offset c-type )
131 [ swapd heap-size * >fixnum ] keep ; inline
133 : alien-element ( n c-ptr c-type -- value )
134 array-accessor alien-value ; inline
136 : set-alien-element ( value n c-ptr c-type -- )
137 array-accessor set-alien-value ; inline
139 PROTOCOL: c-type-protocol
153 CONSULT: c-type-protocol c-type-name
156 PREDICATE: typedef-word < c-type-word
157 "c-type" word-prop [ c-type-name? ] [ array? ] bi or ;
159 : typedef ( old new -- )
161 [ nip define-symbol ]
162 [ swap "c-type" set-word-prop ]
165 TUPLE: long-long-type < c-type ;
167 : <long-long-type> ( -- c-type )
170 : define-deref ( c-type -- )
171 [ name>> CHAR: * prefix "alien.c-types" create ]
172 [ '[ 0 _ alien-value ] ]
173 bi (( c-ptr -- value )) define-inline ;
175 : define-out ( c-type -- )
176 [ name>> "alien.c-types" constructor-word ]
177 [ dup '[ _ heap-size (byte-array) [ 0 _ set-alien-value ] keep ] ] bi
178 (( value -- c-ptr )) define-inline ;
180 : define-primitive-type ( c-type name -- )
181 [ typedef ] [ define-deref ] [ define-out ] tri ;
183 : if-void ( c-type true false -- )
184 pick void? [ drop nip call ] [ nip call ] if ; inline
187 ptrdiff_t intptr_t uintptr_t size_t
190 CONSTANT: primitive-types
202 : >c-bool ( ? -- int ) 1 0 ? ; inline
204 : c-bool> ( int -- ? ) 0 = not ; inline
208 : 8-byte-alignment ( c-type -- c-type )
210 { [ cpu ppc? os macosx? and ] [ 4 >>align 8 >>align-first ] }
211 { [ cpu x86.32? os windows? not and ] [ 4 >>align 4 >>align-first ] }
212 [ 8 >>align 8 >>align-first ]
215 : resolve-pointer-typedef ( type -- base-type )
216 dup "c-type" word-prop dup word?
217 [ nip resolve-pointer-typedef ] [
218 pointer? [ drop void* ] when
221 : primitive-pointer-type? ( type -- ? )
223 resolve-pointer-typedef [ void? ] [ primitive-types member? ] bi or
226 : (pointer-c-type) ( void* type -- void*' )
227 [ clone ] dip c-type-boxer-quot '[ _ [ f ] if* ] >>boxer-quot ;
232 [ \ void* c-type ] dip
233 to>> dup primitive-pointer-type? [ drop ] [ (pointer-c-type) ] if ;
239 [ alien-cell ] >>getter
240 [ set-alien-cell ] >>setter
241 bootstrap-cell >>size
242 bootstrap-cell >>align
243 bootstrap-cell >>align-first
244 [ >c-ptr ] >>unboxer-quot
245 "allot_alien" >>boxer
246 "alien_offset" >>unboxer
247 \ void* define-primitive-type
252 [ alien-signed-2 ] >>getter
253 [ set-alien-signed-2 ] >>setter
257 "from_signed_2" >>boxer
258 "to_signed_2" >>unboxer
259 [ >fixnum ] >>unboxer-quot
260 \ short define-primitive-type
265 [ alien-unsigned-2 ] >>getter
266 [ set-alien-unsigned-2 ] >>setter
270 "from_unsigned_2" >>boxer
271 "to_unsigned_2" >>unboxer
272 [ >fixnum ] >>unboxer-quot
273 \ ushort define-primitive-type
278 [ alien-signed-1 ] >>getter
279 [ set-alien-signed-1 ] >>setter
283 "from_signed_1" >>boxer
284 "to_signed_1" >>unboxer
285 [ >fixnum ] >>unboxer-quot
286 \ char define-primitive-type
291 [ alien-unsigned-1 ] >>getter
292 [ set-alien-unsigned-1 ] >>setter
296 "from_unsigned_1" >>boxer
297 "to_unsigned_1" >>unboxer
298 [ >fixnum ] >>unboxer-quot
299 \ uchar define-primitive-type
303 math:float >>boxed-class
304 [ alien-float ] >>getter
305 [ set-alien-float ] >>setter
312 [ >float ] >>unboxer-quot
313 \ float define-primitive-type
317 math:float >>boxed-class
318 [ alien-double ] >>getter
319 [ set-alien-double ] >>setter
322 "from_double" >>boxer
323 "to_double" >>unboxer
325 [ >float ] >>unboxer-quot
326 \ double define-primitive-type
332 [ alien-signed-4 ] >>getter
333 [ set-alien-signed-4 ] >>setter
337 "from_signed_4" >>boxer
338 "to_signed_4" >>unboxer
339 [ >fixnum ] >>unboxer-quot
340 \ int define-primitive-type
345 [ alien-unsigned-4 ] >>getter
346 [ set-alien-unsigned-4 ] >>setter
350 "from_unsigned_4" >>boxer
351 "to_unsigned_4" >>unboxer
352 [ >fixnum ] >>unboxer-quot
353 \ uint define-primitive-type
357 integer >>boxed-class
358 [ alien-signed-cell ] >>getter
359 [ set-alien-signed-cell ] >>setter
363 "from_signed_cell" >>boxer
364 "to_fixnum" >>unboxer
365 [ >integer ] >>unboxer-quot
366 \ longlong define-primitive-type
370 integer >>boxed-class
371 [ alien-unsigned-cell ] >>getter
372 [ set-alien-unsigned-cell ] >>setter
376 "from_unsigned_cell" >>boxer
378 [ >integer ] >>unboxer-quot
379 \ ulonglong define-primitive-type
382 \ int c-type \ long define-primitive-type
383 \ uint c-type \ ulong define-primitive-type
385 \ longlong c-type \ long define-primitive-type
386 \ ulonglong c-type \ ulong define-primitive-type
389 \ longlong c-type \ ptrdiff_t typedef
390 \ longlong c-type \ intptr_t typedef
392 \ ulonglong c-type \ uintptr_t typedef
393 \ ulonglong c-type \ size_t typedef
397 integer >>boxed-class
398 [ alien-signed-cell ] >>getter
399 [ set-alien-signed-cell ] >>setter
403 "from_signed_cell" >>boxer
404 "to_fixnum" >>unboxer
405 [ >integer ] >>unboxer-quot
406 \ int define-primitive-type
410 integer >>boxed-class
411 [ alien-unsigned-cell ] >>getter
412 [ set-alien-unsigned-cell ] >>setter
416 "from_unsigned_cell" >>boxer
418 [ >integer ] >>unboxer-quot
419 \ uint define-primitive-type
423 integer >>boxed-class
424 [ alien-signed-8 ] >>getter
425 [ set-alien-signed-8 ] >>setter
428 "from_signed_8" >>boxer
429 "to_signed_8" >>unboxer
430 [ >integer ] >>unboxer-quot
431 \ longlong define-primitive-type
435 integer >>boxed-class
436 [ alien-unsigned-8 ] >>getter
437 [ set-alien-unsigned-8 ] >>setter
440 "from_unsigned_8" >>boxer
441 "to_unsigned_8" >>unboxer
442 [ >integer ] >>unboxer-quot
443 \ ulonglong define-primitive-type
445 \ int c-type \ long define-primitive-type
446 \ uint c-type \ ulong define-primitive-type
448 \ int c-type \ ptrdiff_t typedef
449 \ int c-type \ intptr_t typedef
451 \ uint c-type \ uintptr_t typedef
452 \ uint c-type \ size_t typedef
455 cpu ppc? \ uint \ uchar ? c-type clone
456 [ >c-bool ] >>unboxer-quot
457 [ c-bool> ] >>boxer-quot
459 \ bool define-primitive-type
461 ] with-compilation-unit
463 M: char-16-rep rep-component-type drop char ;
464 M: uchar-16-rep rep-component-type drop uchar ;
465 M: short-8-rep rep-component-type drop short ;
466 M: ushort-8-rep rep-component-type drop ushort ;
467 M: int-4-rep rep-component-type drop int ;
468 M: uint-4-rep rep-component-type drop uint ;
469 M: longlong-2-rep rep-component-type drop longlong ;
470 M: ulonglong-2-rep rep-component-type drop ulonglong ;
471 M: float-4-rep rep-component-type drop float ;
472 M: double-2-rep rep-component-type drop double ;
474 : (unsigned-interval) ( bytes -- from to ) [ 0 ] dip 8 * 2^ 1 - ; foldable
475 : unsigned-interval ( c-type -- from to ) heap-size (unsigned-interval) ; foldable
476 : (signed-interval) ( bytes -- from to ) 8 * 1 - 2^ [ neg ] [ 1 - ] bi ; foldable
477 : signed-interval ( c-type -- from to ) heap-size (signed-interval) ; foldable
479 : c-type-interval ( c-type -- from to )
481 { [ dup { float double } member-eq? ] [ drop -1/0. 1/0. ] }
482 { [ dup { char short int long longlong } member-eq? ] [ signed-interval ] }
483 { [ dup { uchar ushort uint ulong ulonglong } member-eq? ] [ unsigned-interval ] }
486 : c-type-clamp ( value c-type -- value' )
487 dup { float double } member-eq?
488 [ drop ] [ c-type-interval clamp ] if ; inline
490 :: <ref> ( value c-type -- c-ptr )
491 c-type heap-size <byte-array> :> c-ptr
492 value c-ptr 0 c-type set-alien-value
495 : deref ( c-ptr c-type -- value )
496 [ 0 ] dip alien-value ; inline