1 ! Copyright (C) 2004, 2010 Slava Pestov.
2 ! See http://factorcode.org/license.txt for BSD license.
3 USING: byte-arrays arrays assocs delegate kernel kernel.private math
4 math.order math.parser namespaces make parser sequences strings
5 words splitting cpu.architecture alien alien.accessors
6 alien.strings quotations layouts system compiler.units io
7 io.files io.encodings.binary io.streams.memory accessors
8 combinators effects continuations fry classes vocabs
9 vocabs.loader words.symbol macros ;
27 TUPLE: abstract-c-type
28 { class class initial: object }
29 { boxed-class class initial: object }
30 { boxer-quot callable }
31 { unboxer-quot callable }
36 { align-first integer } ;
38 TUPLE: c-type < abstract-c-type
41 { rep initial: int-rep } ;
43 : <c-type> ( -- c-type )
46 ERROR: no-c-type name ;
49 GENERIC: c-type ( name -- c-type ) foldable
51 PREDICATE: c-type-word < word
54 TUPLE: pointer { to initial: void read-only } ;
60 : resolve-typedef ( name -- c-type )
61 dup void? [ no-c-type ] when
62 dup c-type-name? [ c-type ] when ;
65 dup "c-type" word-prop resolve-typedef
66 [ ] [ no-c-type ] ?if ;
68 GENERIC: c-type-class ( name -- class )
70 M: abstract-c-type c-type-class class>> ;
72 GENERIC: c-type-boxed-class ( name -- class )
74 M: abstract-c-type c-type-boxed-class boxed-class>> ;
76 GENERIC: c-type-boxer-quot ( name -- quot )
78 M: abstract-c-type c-type-boxer-quot boxer-quot>> ;
80 GENERIC: c-type-unboxer-quot ( name -- quot )
82 M: abstract-c-type c-type-unboxer-quot unboxer-quot>> ;
84 GENERIC: c-type-rep ( name -- rep )
86 M: c-type c-type-rep rep>> ;
88 GENERIC: c-type-getter ( name -- quot )
90 M: c-type c-type-getter getter>> ;
92 GENERIC: c-type-setter ( name -- quot )
94 M: c-type c-type-setter setter>> ;
96 GENERIC: c-type-align ( name -- n ) foldable
98 M: abstract-c-type c-type-align align>> ;
100 GENERIC: c-type-align-first ( name -- n )
102 M: abstract-c-type c-type-align-first align-first>> ;
104 GENERIC: base-type ( c-type -- c-type )
106 M: c-type-name base-type c-type ;
108 M: c-type base-type ;
110 : little-endian? ( -- ? ) 1 <int> *char 1 = ; foldable
112 GENERIC: heap-size ( name -- size )
114 M: abstract-c-type heap-size size>> ;
118 MACRO: alien-value ( c-type -- quot: ( c-ptr offset -- value ) )
119 [ c-type-getter ] [ c-type-boxer-quot ] bi append ;
121 MACRO: set-alien-value ( c-type -- quot: ( value c-ptr offset -- ) )
122 [ c-type-unboxer-quot [ [ ] ] [ '[ _ 2dip ] ] if-empty ]
126 : array-accessor ( n c-ptr c-type -- c-ptr offset c-type )
127 [ swapd heap-size * >fixnum ] keep ; inline
129 : alien-element ( n c-ptr c-type -- value )
130 array-accessor alien-value ; inline
132 : set-alien-element ( value n c-ptr c-type -- )
133 array-accessor set-alien-value ; inline
135 PROTOCOL: c-type-protocol
148 CONSULT: c-type-protocol c-type-name
151 PREDICATE: typedef-word < c-type-word
152 "c-type" word-prop c-type-name? ;
154 : typedef ( old new -- )
156 [ nip define-symbol ]
157 [ swap "c-type" set-word-prop ]
160 TUPLE: long-long-type < c-type ;
162 : <long-long-type> ( -- c-type )
165 : define-deref ( c-type -- )
166 [ name>> CHAR: * prefix "alien.c-types" create ]
167 [ '[ 0 _ alien-value ] ]
168 bi (( c-ptr -- value )) define-inline ;
170 : define-out ( c-type -- )
171 [ name>> "alien.c-types" constructor-word ]
172 [ dup '[ _ heap-size (byte-array) [ 0 _ set-alien-value ] keep ] ] bi
173 (( value -- c-ptr )) define-inline ;
175 : define-primitive-type ( c-type name -- )
176 [ typedef ] [ define-deref ] [ define-out ] tri ;
178 : if-void ( c-type true false -- )
179 pick void? [ drop nip call ] [ nip call ] if ; inline
182 ptrdiff_t intptr_t uintptr_t size_t
185 CONSTANT: primitive-types
197 : >c-bool ( ? -- int ) 1 0 ? ; inline
199 : c-bool> ( int -- ? ) 0 = not ; inline
203 : 8-byte-alignment ( c-type -- c-type )
205 { [ cpu ppc? os macosx? and ] [ 4 >>align 8 >>align-first ] }
206 { [ cpu x86.32? os windows? not and ] [ 4 >>align 4 >>align-first ] }
207 [ 8 >>align 8 >>align-first ]
210 : resolve-pointer-typedef ( type -- base-type )
211 dup "c-type" word-prop dup word?
212 [ nip resolve-pointer-typedef ] [
213 pointer? [ drop void* ] when
216 : primitive-pointer-type? ( type -- ? )
218 resolve-pointer-typedef [ void? ] [ primitive-types member? ] bi or
221 : (pointer-c-type) ( void* type -- void*' )
222 [ clone ] dip c-type-boxer-quot '[ _ [ f ] if* ] >>boxer-quot ;
227 [ \ void* c-type ] dip
228 to>> dup primitive-pointer-type? [ drop ] [ (pointer-c-type) ] if ;
234 [ alien-cell ] >>getter
235 [ set-alien-cell ] >>setter
236 bootstrap-cell >>size
237 bootstrap-cell >>align
238 bootstrap-cell >>align-first
239 [ >c-ptr ] >>unboxer-quot
240 "allot_alien" >>boxer
241 "alien_offset" >>unboxer
242 \ void* define-primitive-type
247 [ alien-signed-2 ] >>getter
248 [ set-alien-signed-2 ] >>setter
252 "from_signed_2" >>boxer
253 "to_fixnum" >>unboxer
254 [ >fixnum ] >>unboxer-quot
255 \ short define-primitive-type
260 [ alien-unsigned-2 ] >>getter
261 [ set-alien-unsigned-2 ] >>setter
265 "from_unsigned_2" >>boxer
267 [ >fixnum ] >>unboxer-quot
268 \ ushort define-primitive-type
273 [ alien-signed-1 ] >>getter
274 [ set-alien-signed-1 ] >>setter
278 "from_signed_1" >>boxer
279 "to_fixnum" >>unboxer
280 [ >fixnum ] >>unboxer-quot
281 \ char define-primitive-type
286 [ alien-unsigned-1 ] >>getter
287 [ set-alien-unsigned-1 ] >>setter
291 "from_unsigned_1" >>boxer
293 [ >fixnum ] >>unboxer-quot
294 \ uchar define-primitive-type
298 math:float >>boxed-class
299 [ alien-float ] >>getter
300 [ set-alien-float ] >>setter
307 [ >float ] >>unboxer-quot
308 \ float define-primitive-type
312 math:float >>boxed-class
313 [ alien-double ] >>getter
314 [ set-alien-double ] >>setter
317 "from_double" >>boxer
318 "to_double" >>unboxer
320 [ >float ] >>unboxer-quot
321 \ double define-primitive-type
327 [ alien-signed-4 ] >>getter
328 [ set-alien-signed-4 ] >>setter
332 "from_signed_4" >>boxer
333 "to_fixnum" >>unboxer
334 [ >fixnum ] >>unboxer-quot
335 \ int define-primitive-type
340 [ alien-unsigned-4 ] >>getter
341 [ set-alien-unsigned-4 ] >>setter
345 "from_unsigned_4" >>boxer
347 [ >fixnum ] >>unboxer-quot
348 \ uint define-primitive-type
352 integer >>boxed-class
353 [ alien-signed-cell ] >>getter
354 [ set-alien-signed-cell ] >>setter
358 "from_signed_cell" >>boxer
359 "to_fixnum" >>unboxer
360 \ longlong define-primitive-type
364 integer >>boxed-class
365 [ alien-unsigned-cell ] >>getter
366 [ set-alien-unsigned-cell ] >>setter
370 "from_unsigned_cell" >>boxer
372 \ ulonglong define-primitive-type
375 \ int c-type \ long define-primitive-type
376 \ uint c-type \ ulong define-primitive-type
378 \ longlong c-type \ long define-primitive-type
379 \ ulonglong c-type \ ulong define-primitive-type
382 \ longlong c-type \ ptrdiff_t typedef
383 \ longlong c-type \ intptr_t typedef
385 \ ulonglong c-type \ uintptr_t typedef
386 \ ulonglong c-type \ size_t typedef
390 integer >>boxed-class
391 [ alien-signed-cell ] >>getter
392 [ set-alien-signed-cell ] >>setter
396 "from_signed_cell" >>boxer
397 "to_fixnum" >>unboxer
398 \ int define-primitive-type
402 integer >>boxed-class
403 [ alien-unsigned-cell ] >>getter
404 [ set-alien-unsigned-cell ] >>setter
408 "from_unsigned_cell" >>boxer
410 \ uint define-primitive-type
414 integer >>boxed-class
415 [ alien-signed-8 ] >>getter
416 [ set-alien-signed-8 ] >>setter
419 "from_signed_8" >>boxer
420 "to_signed_8" >>unboxer
421 \ longlong define-primitive-type
425 integer >>boxed-class
426 [ alien-unsigned-8 ] >>getter
427 [ set-alien-unsigned-8 ] >>setter
430 "from_unsigned_8" >>boxer
431 "to_unsigned_8" >>unboxer
432 \ ulonglong define-primitive-type
434 \ int c-type \ long define-primitive-type
435 \ uint c-type \ ulong define-primitive-type
437 \ int c-type \ ptrdiff_t typedef
438 \ int c-type \ intptr_t typedef
440 \ uint c-type \ uintptr_t typedef
441 \ uint c-type \ size_t typedef
444 cpu ppc? \ uint \ uchar ? c-type clone
445 [ >c-bool ] >>unboxer-quot
446 [ c-bool> ] >>boxer-quot
448 \ bool define-primitive-type
450 ] with-compilation-unit
452 M: char-16-rep rep-component-type drop char ;
453 M: uchar-16-rep rep-component-type drop uchar ;
454 M: short-8-rep rep-component-type drop short ;
455 M: ushort-8-rep rep-component-type drop ushort ;
456 M: int-4-rep rep-component-type drop int ;
457 M: uint-4-rep rep-component-type drop uint ;
458 M: longlong-2-rep rep-component-type drop longlong ;
459 M: ulonglong-2-rep rep-component-type drop ulonglong ;
460 M: float-4-rep rep-component-type drop float ;
461 M: double-2-rep rep-component-type drop double ;
463 : (unsigned-interval) ( bytes -- from to ) [ 0 ] dip 8 * 2^ 1 - ; foldable
464 : unsigned-interval ( c-type -- from to ) heap-size (unsigned-interval) ; foldable
465 : (signed-interval) ( bytes -- from to ) 8 * 1 - 2^ [ neg ] [ 1 - ] bi ; foldable
466 : signed-interval ( c-type -- from to ) heap-size (signed-interval) ; foldable
468 : c-type-interval ( c-type -- from to )
470 { [ dup { float double } member-eq? ] [ drop -1/0. 1/0. ] }
471 { [ dup { char short int long longlong } member-eq? ] [ signed-interval ] }
472 { [ dup { uchar ushort uint ulong ulonglong } member-eq? ] [ unsigned-interval ] }
475 : c-type-clamp ( value c-type -- value' )
476 dup { float double } member-eq?
477 [ drop ] [ c-type-interval clamp ] if ; inline