1 ! Copyright (C) 2004, 2010 Slava Pestov.
2 ! See https://factorcode.org/license.txt for BSD license.
3 USING: accessors alien alien.accessors arrays classes
4 combinators compiler.units cpu.architecture delegate kernel
5 layouts math math.order math.parser quotations sequences summary
6 system words words.symbol ;
20 TUPLE: abstract-c-type
21 { class class initial: object }
22 { boxed-class class initial: object }
23 { boxer-quot callable }
24 { unboxer-quot callable }
30 { align-first integer } ;
32 TUPLE: c-type < abstract-c-type
35 { rep initial: int-rep } ;
37 : <c-type> ( -- c-type )
40 ERROR: no-c-type word ;
42 M: no-c-type summary drop "Not a C type" ;
45 GENERIC: lookup-c-type ( name -- c-type ) foldable
47 PREDICATE: c-type-word < word
48 "c-type" word-prop >boolean ;
50 TUPLE: pointer { to initial: void read-only } ;
56 : resolve-typedef ( name -- c-type )
57 dup void? [ no-c-type ] when
58 dup c-type-name? [ lookup-c-type ] when ;
61 [ "c-type" word-prop resolve-typedef ]
62 [ no-c-type ] ?unless ;
64 GENERIC: c-type-class ( name -- class )
66 M: abstract-c-type c-type-class class>> ;
68 GENERIC: c-type-boxed-class ( name -- class )
70 M: abstract-c-type c-type-boxed-class boxed-class>> ;
72 GENERIC: c-type-boxer-quot ( name -- quot )
74 M: abstract-c-type c-type-boxer-quot boxer-quot>> ;
76 GENERIC: c-type-unboxer-quot ( name -- quot )
78 M: abstract-c-type c-type-unboxer-quot unboxer-quot>> ;
80 GENERIC: c-type-rep ( name -- rep )
82 M: c-type c-type-rep rep>> ;
84 GENERIC: c-type-getter ( name -- quot )
86 M: c-type c-type-getter getter>> ;
88 GENERIC: c-type-copier ( name -- quot )
90 M: c-type c-type-copier drop [ ] ;
92 GENERIC: c-type-setter ( name -- quot )
94 M: c-type c-type-setter setter>> ;
96 GENERIC: c-type-signed ( name -- boolean ) foldable
98 M: abstract-c-type c-type-signed signed>> ;
100 GENERIC: c-type-align ( name -- n ) foldable
102 M: abstract-c-type c-type-align align>> ;
104 GENERIC: c-type-align-first ( name -- n )
106 M: abstract-c-type c-type-align-first align-first>> ;
108 GENERIC: base-type ( c-type -- c-type )
110 M: c-type-name base-type lookup-c-type ;
112 M: c-type base-type ;
114 GENERIC: heap-size ( name -- size )
116 M: abstract-c-type heap-size size>> ;
120 MACRO: alien-value ( c-type -- quot: ( c-ptr offset -- value ) )
121 [ c-type-getter ] [ c-type-boxer-quot ] bi append ;
123 MACRO: alien-copy-value ( c-type -- quot: ( c-ptr offset -- value ) )
124 [ c-type-getter ] [ c-type-copier ] [ c-type-boxer-quot ] tri 3append ;
126 MACRO: set-alien-value ( c-type -- quot: ( value c-ptr offset -- ) )
127 [ c-type-unboxer-quot [ [ ] ] [ '[ _ 2dip ] ] if-empty ]
131 : array-accessor ( n c-ptr c-type -- c-ptr offset c-type )
132 [ swapd heap-size * >fixnum ] keep ; inline
134 : alien-element ( n c-ptr c-type -- value )
135 array-accessor alien-value ; inline
137 : set-alien-element ( value n c-ptr c-type -- )
138 array-accessor set-alien-value ; inline
140 PROTOCOL: c-type-protocol
155 CONSULT: c-type-protocol c-type-name
158 PREDICATE: typedef-word < c-type-word
159 "c-type" word-prop [ c-type-name? ] [ array? ] bi or ;
161 : typedef ( old new -- )
163 [ nip define-symbol ]
164 [ swap "c-type" set-word-prop ]
167 TUPLE: long-long-type < c-type ;
169 : <long-long-type> ( -- c-type )
172 : if-void ( ..a c-type true: ( ..a -- ..b ) false: ( ..a c-type -- ..b ) -- ..b )
173 pick void? [ drop nip call ] [ nip call ] if ; inline
176 ptrdiff_t intptr_t uintptr_t size_t
177 c-string int8_t uint8_t int16_t uint16_t
178 int32_t uint32_t int64_t uint64_t ;
182 s8 u8 s16 u16 s32 u32 s64 u64
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 x86.32? os windows? not and ] [ 4 >>align 4 >>align-first ] }
206 [ 8 >>align 8 >>align-first ]
209 : resolve-pointer-typedef ( type -- base-type )
210 dup "c-type" word-prop dup word?
211 [ nip resolve-pointer-typedef ] [
212 pointer? [ drop void* ] when
215 : primitive-pointer-type? ( type -- ? )
217 resolve-pointer-typedef [ void? ] [ primitive-types member? ] bi or
220 : (pointer-c-type) ( void* type -- void*' )
221 [ clone ] dip c-type-boxer-quot '[ _ [ f ] if* ] >>boxer-quot ;
225 M: pointer lookup-c-type
226 [ \ void* lookup-c-type ] dip
227 to>> dup primitive-pointer-type? [ drop ] [ (pointer-c-type) ] if ;
233 [ alien-cell ] >>getter
234 [ set-alien-cell ] >>setter
235 bootstrap-cell >>size
236 bootstrap-cell >>align
237 bootstrap-cell >>align-first
238 [ >c-ptr ] >>unboxer-quot
239 "allot_alien" >>boxer
240 "alien_offset" >>unboxer
246 [ alien-signed-2 ] >>getter
247 [ set-alien-signed-2 ] >>setter
252 "from_signed_2" >>boxer
253 "to_signed_2" >>unboxer
254 [ >fixnum ] >>unboxer-quot
260 [ alien-unsigned-2 ] >>getter
261 [ set-alien-unsigned-2 ] >>setter
265 "from_unsigned_2" >>boxer
266 "to_unsigned_2" >>unboxer
267 [ >fixnum ] >>unboxer-quot
273 [ alien-signed-1 ] >>getter
274 [ set-alien-signed-1 ] >>setter
279 "from_signed_1" >>boxer
280 "to_signed_1" >>unboxer
281 [ >fixnum ] >>unboxer-quot
287 [ alien-unsigned-1 ] >>getter
288 [ set-alien-unsigned-1 ] >>setter
292 "from_unsigned_1" >>boxer
293 "to_unsigned_1" >>unboxer
294 [ >fixnum ] >>unboxer-quot
299 math:float >>boxed-class
300 [ alien-float ] >>getter
301 [ set-alien-float ] >>setter
308 [ >float ] >>unboxer-quot
313 math:float >>boxed-class
314 [ alien-double ] >>getter
315 [ set-alien-double ] >>setter
318 "from_double" >>boxer
319 "to_double" >>unboxer
321 [ >float ] >>unboxer-quot
329 [ alien-signed-4 ] >>getter
330 [ set-alien-signed-4 ] >>setter
335 "from_signed_4" >>boxer
336 "to_signed_4" >>unboxer
337 [ >fixnum ] >>unboxer-quot
344 [ alien-unsigned-4 ] >>getter
345 [ set-alien-unsigned-4 ] >>setter
349 "from_unsigned_4" >>boxer
350 "to_unsigned_4" >>unboxer
351 [ >fixnum ] >>unboxer-quot
357 integer >>boxed-class
358 [ alien-signed-cell ] >>getter
359 [ set-alien-signed-cell ] >>setter
364 "from_signed_cell" >>boxer
365 "to_signed_8" >>unboxer
366 [ >integer ] >>unboxer-quot
372 integer >>boxed-class
373 [ alien-unsigned-cell ] >>getter
374 [ set-alien-unsigned-cell ] >>setter
378 "from_unsigned_cell" >>boxer
380 [ >integer ] >>unboxer-quot
384 \ int lookup-c-type \ long typedef
385 \ uint lookup-c-type \ ulong typedef
387 \ longlong lookup-c-type \ long typedef
388 \ ulonglong lookup-c-type \ ulong typedef
391 \ longlong lookup-c-type \ ptrdiff_t typedef
392 \ longlong lookup-c-type \ intptr_t typedef
394 \ ulonglong lookup-c-type \ uintptr_t typedef
395 \ ulonglong lookup-c-type \ size_t typedef
397 \ longlong lookup-c-type \ isize typedef
398 \ ulonglong lookup-c-type \ usize typedef
403 integer >>boxed-class
404 [ alien-signed-cell ] >>getter
405 [ set-alien-signed-cell ] >>setter
410 "from_signed_cell" >>boxer
411 "to_fixnum" >>unboxer
412 [ >integer ] >>unboxer-quot
418 integer >>boxed-class
419 [ alien-unsigned-cell ] >>getter
420 [ set-alien-unsigned-cell ] >>setter
424 "from_unsigned_cell" >>boxer
426 [ >integer ] >>unboxer-quot
432 integer >>boxed-class
433 [ alien-signed-8 ] >>getter
434 [ set-alien-signed-8 ] >>setter
438 "from_signed_8" >>boxer
439 "to_signed_8" >>unboxer
440 [ >integer ] >>unboxer-quot
446 integer >>boxed-class
447 [ alien-unsigned-8 ] >>getter
448 [ set-alien-unsigned-8 ] >>setter
451 "from_unsigned_8" >>boxer
452 "to_unsigned_8" >>unboxer
453 [ >integer ] >>unboxer-quot
456 \ int lookup-c-type \ long typedef
457 \ uint lookup-c-type \ ulong typedef
459 \ int lookup-c-type \ ptrdiff_t typedef
460 \ int lookup-c-type \ intptr_t typedef
462 \ uint lookup-c-type \ uintptr_t typedef
463 \ uint lookup-c-type \ size_t typedef
465 \ int lookup-c-type \ isize typedef
466 \ uint lookup-c-type \ usize typedef
469 \ uchar lookup-c-type clone
470 [ >c-bool ] >>unboxer-quot
471 [ c-bool> ] >>boxer-quot
475 \ char lookup-c-type int8_t typedef
476 \ short lookup-c-type int16_t typedef
477 \ int lookup-c-type int32_t typedef
478 \ longlong lookup-c-type int64_t typedef
480 \ uchar lookup-c-type uint8_t typedef
481 \ ushort lookup-c-type uint16_t typedef
482 \ uint lookup-c-type uint32_t typedef
483 \ ulonglong lookup-c-type uint64_t typedef
485 \ char lookup-c-type s8 typedef
486 \ short lookup-c-type s16 typedef
487 \ int lookup-c-type s32 typedef
488 \ longlong lookup-c-type s64 typedef
490 \ uchar lookup-c-type u8 typedef
491 \ ushort lookup-c-type u16 typedef
492 \ uint lookup-c-type u32 typedef
493 \ ulonglong lookup-c-type u64 typedef
495 \ float lookup-c-type f32 typedef
496 \ double lookup-c-type f64 typedef
497 ] with-compilation-unit
499 M: char-16-rep rep-component-type drop char ;
500 M: uchar-16-rep rep-component-type drop uchar ;
501 M: short-8-rep rep-component-type drop short ;
502 M: ushort-8-rep rep-component-type drop ushort ;
503 M: int-4-rep rep-component-type drop int ;
504 M: uint-4-rep rep-component-type drop uint ;
505 M: longlong-2-rep rep-component-type drop longlong ;
506 M: ulonglong-2-rep rep-component-type drop ulonglong ;
507 M: float-4-rep rep-component-type drop float ;
508 M: double-2-rep rep-component-type drop double ;
510 : (unsigned-interval) ( bytes -- from to ) [ 0 ] dip 8 * 2^ 1 - ; foldable
511 : unsigned-interval ( c-type -- from to ) heap-size (unsigned-interval) ; foldable
512 : (signed-interval) ( bytes -- from to ) 8 * 1 - 2^ [ neg ] [ 1 - ] bi ; foldable
513 : signed-interval ( c-type -- from to ) heap-size (signed-interval) ; foldable
515 : c-type-interval ( c-type -- from to )
517 { [ dup { float double } member-eq? ] [ drop -1/0. 1/0. ] }
518 { [ dup c-type-signed ] [ signed-interval ] }
519 { [ dup c-type-signed not ] [ unsigned-interval ] }
522 : c-type-clamp ( value c-type -- value' )
523 dup { float double } member-eq?
524 [ drop ] [ c-type-interval clamp ] if ; inline
526 GENERIC: pointer-string ( pointer -- string/f )
527 M: object pointer-string drop f ;
528 M: word pointer-string name>> ;
529 M: pointer pointer-string to>> pointer-string [ CHAR: * suffix ] [ f ] if* ;
531 GENERIC: c-type-string ( c-type -- string )
533 M: integer c-type-string number>string ;
534 M: word c-type-string name>> ;
535 M: pointer c-type-string pointer-string ;
536 M: wrapper c-type-string wrapped>> c-type-string ;
537 M: array c-type-string
539 [ [ c-type-string "[" "]" surround ] map ]
540 [ c-type-string ] bi*