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 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 ;
26 TUPLE: abstract-c-type
27 { class class initial: object }
28 { boxed-class class initial: object }
29 { boxer-quot callable }
30 { unboxer-quot callable }
35 { align-first integer } ;
37 TUPLE: c-type < abstract-c-type
40 { rep initial: int-rep }
43 : <c-type> ( -- c-type )
49 c-types [ H{ } assoc-like ] change
52 ERROR: no-c-type name ;
54 PREDICATE: c-type-word < word
57 UNION: c-type-name string c-type-word ;
60 GENERIC: c-type ( name -- c-type ) foldable
62 GENERIC: resolve-pointer-type ( name -- c-type )
64 << \ void \ void* "pointer-c-type" set-word-prop >>
66 : void? ( c-type -- ? )
67 { void "void" } member? ;
69 M: word resolve-pointer-type
70 dup "pointer-c-type" word-prop
71 [ ] [ drop void* ] ?if ;
73 M: string resolve-pointer-type
74 dup "*" append dup c-types get at
77 c-types get at dup c-type-name?
78 [ resolve-pointer-type ] [ drop void* ] if
81 M: array resolve-pointer-type
82 first resolve-pointer-type ;
84 : resolve-typedef ( name -- c-type )
85 dup void? [ no-c-type ] when
86 dup c-type-name? [ c-type ] when ;
90 : parse-array-type ( name -- dims c-type )
92 [ [ "]" ?tail drop string>number ] map ] dip ;
96 M: string c-type ( name -- c-type )
97 CHAR: ] over member? [
98 parse-array-type prefix
100 dup c-types get at [ ] [
101 "*" ?tail [ resolve-pointer-type ] [ no-c-type ] if
102 ] ?if resolve-typedef
106 dup "c-type" word-prop resolve-typedef
107 [ ] [ no-c-type ] ?if ;
109 GENERIC: c-struct? ( c-type -- ? )
111 M: object c-struct? drop f ;
113 M: c-type-name c-struct? dup void? [ drop f ] [ c-type c-struct? ] if ;
115 ! These words being foldable means that words need to be
116 ! recompiled if a C type is redefined. Even so, folding the
117 ! size facilitates some optimizations.
118 GENERIC: c-type-class ( name -- class )
120 M: abstract-c-type c-type-class class>> ;
122 M: c-type-name c-type-class c-type c-type-class ;
124 GENERIC: c-type-boxed-class ( name -- class )
126 M: abstract-c-type c-type-boxed-class boxed-class>> ;
128 M: c-type-name c-type-boxed-class c-type c-type-boxed-class ;
130 GENERIC: c-type-boxer ( name -- boxer )
132 M: c-type c-type-boxer boxer>> ;
134 M: c-type-name c-type-boxer c-type c-type-boxer ;
136 GENERIC: c-type-boxer-quot ( name -- quot )
138 M: abstract-c-type c-type-boxer-quot boxer-quot>> ;
140 M: c-type-name c-type-boxer-quot c-type c-type-boxer-quot ;
142 GENERIC: c-type-unboxer ( name -- boxer )
144 M: c-type c-type-unboxer unboxer>> ;
146 M: c-type-name c-type-unboxer c-type c-type-unboxer ;
148 GENERIC: c-type-unboxer-quot ( name -- quot )
150 M: abstract-c-type c-type-unboxer-quot unboxer-quot>> ;
152 M: c-type-name c-type-unboxer-quot c-type c-type-unboxer-quot ;
154 GENERIC: c-type-rep ( name -- rep )
156 M: c-type c-type-rep rep>> ;
158 M: c-type-name c-type-rep c-type c-type-rep ;
160 GENERIC: c-type-getter ( name -- quot )
162 M: c-type c-type-getter getter>> ;
164 M: c-type-name c-type-getter c-type c-type-getter ;
166 GENERIC: c-type-setter ( name -- quot )
168 M: c-type c-type-setter setter>> ;
170 M: c-type-name c-type-setter c-type c-type-setter ;
172 GENERIC: c-type-align ( name -- n )
174 M: abstract-c-type c-type-align align>> ;
176 M: c-type-name c-type-align c-type c-type-align ;
178 GENERIC: c-type-align-first ( name -- n )
180 M: c-type-name c-type-align-first c-type c-type-align-first ;
182 M: abstract-c-type c-type-align-first align-first>> ;
184 GENERIC: c-type-stack-align? ( name -- ? )
186 M: c-type c-type-stack-align? stack-align?>> ;
188 M: c-type-name c-type-stack-align? c-type c-type-stack-align? ;
190 : c-type-box ( n c-type -- )
191 [ c-type-rep ] [ c-type-boxer [ "No boxer" throw ] unless* ] bi
194 : c-type-unbox ( n c-type -- )
195 [ c-type-rep ] [ c-type-unboxer [ "No unboxer" throw ] unless* ] bi
198 GENERIC: box-parameter ( n c-type -- )
200 M: c-type box-parameter c-type-box ;
202 M: c-type-name box-parameter c-type box-parameter ;
204 GENERIC: box-return ( c-type -- )
206 M: c-type box-return f swap c-type-box ;
208 M: c-type-name box-return c-type box-return ;
210 GENERIC: unbox-parameter ( n c-type -- )
212 M: c-type unbox-parameter c-type-unbox ;
214 M: c-type-name unbox-parameter c-type unbox-parameter ;
216 GENERIC: unbox-return ( c-type -- )
218 M: c-type unbox-return f swap c-type-unbox ;
220 M: c-type-name unbox-return c-type unbox-return ;
222 : little-endian? ( -- ? ) 1 <int> *char 1 = ; foldable
224 GENERIC: heap-size ( name -- size )
226 M: c-type-name heap-size c-type heap-size ;
228 M: abstract-c-type heap-size size>> ;
230 GENERIC: stack-size ( name -- size )
232 M: c-type-name stack-size c-type stack-size ;
234 M: c-type stack-size size>> cell align ;
236 GENERIC: byte-length ( seq -- n ) flushable
238 M: byte-array byte-length length ; inline
240 M: f byte-length drop 0 ; inline
242 : >c-bool ( ? -- int ) 1 0 ? ; inline
244 : c-bool> ( int -- ? ) 0 = not ; inline
248 : c-getter ( name -- quot )
250 [ "Cannot read struct fields with this type" throw ]
253 : c-type-getter-boxer ( name -- quot )
254 [ c-getter ] [ c-type-boxer-quot ] bi append ;
256 : c-setter ( name -- quot )
258 [ "Cannot write struct fields with this type" throw ]
261 : array-accessor ( c-type quot -- def )
263 \ swap , [ heap-size , [ * >fixnum ] % ] [ % ] bi*
266 GENERIC: typedef ( old new -- )
268 PREDICATE: typedef-word < c-type-word
269 "c-type" word-prop c-type-name? ;
271 M: string typedef ( old new -- ) c-types get set-at ;
273 M: word typedef ( old new -- )
275 [ nip define-symbol ]
277 [ swap "c-type" set-word-prop ]
279 swap dup c-type-name? [
281 "pointer-c-type" set-word-prop
286 TUPLE: long-long-type < c-type ;
288 : <long-long-type> ( -- c-type )
291 M: long-long-type unbox-parameter ( n c-type -- )
292 c-type-unboxer %unbox-long-long ;
294 M: long-long-type unbox-return ( c-type -- )
295 f swap unbox-parameter ;
297 M: long-long-type box-parameter ( n c-type -- )
298 c-type-boxer %box-long-long ;
300 M: long-long-type box-return ( c-type -- )
301 f swap box-parameter ;
303 : define-deref ( c-type -- )
304 [ name>> CHAR: * prefix "alien.c-types" create ] [ c-getter 0 prefix ] bi
305 (( c-ptr -- value )) define-inline ;
307 : define-out ( c-type -- )
308 [ name>> "alien.c-types" constructor-word ]
309 [ dup c-setter '[ _ heap-size (byte-array) [ 0 @ ] keep ] ] bi
310 (( value -- c-ptr )) define-inline ;
312 : define-primitive-type ( c-type name -- )
313 [ typedef ] [ define-deref ] [ define-out ] tri ;
315 : if-void ( c-type true false -- )
316 pick void? [ drop nip call ] [ nip call ] if ; inline
318 CONSTANT: primitive-types
330 ptrdiff_t intptr_t uintptr_t size_t
333 : 8-byte-alignment ( c-type -- c-type )
335 { [ cpu ppc? os macosx? and ] [ 4 >>align 8 >>align-first ] }
336 { [ cpu x86.32? os windows? not and ] [ 4 >>align 4 >>align-first ] }
337 [ 8 >>align 8 >>align-first ]
344 [ alien-cell ] >>getter
345 [ [ >c-ptr ] 2dip set-alien-cell ] >>setter
346 bootstrap-cell >>size
347 bootstrap-cell >>align
348 bootstrap-cell >>align-first
349 [ >c-ptr ] >>unboxer-quot
350 "allot_alien" >>boxer
351 "alien_offset" >>unboxer
352 \ void* define-primitive-type
356 integer >>boxed-class
357 [ alien-signed-4 ] >>getter
358 [ set-alien-signed-4 ] >>setter
362 "from_signed_4" >>boxer
363 "to_fixnum" >>unboxer
364 \ int define-primitive-type
368 integer >>boxed-class
369 [ alien-unsigned-4 ] >>getter
370 [ set-alien-unsigned-4 ] >>setter
374 "from_unsigned_4" >>boxer
376 \ uint define-primitive-type
381 [ alien-signed-2 ] >>getter
382 [ set-alien-signed-2 ] >>setter
386 "from_signed_2" >>boxer
387 "to_fixnum" >>unboxer
388 \ short define-primitive-type
393 [ alien-unsigned-2 ] >>getter
394 [ set-alien-unsigned-2 ] >>setter
398 "from_unsigned_2" >>boxer
400 \ ushort define-primitive-type
405 [ alien-signed-1 ] >>getter
406 [ set-alien-signed-1 ] >>setter
410 "from_signed_1" >>boxer
411 "to_fixnum" >>unboxer
412 \ char define-primitive-type
417 [ alien-unsigned-1 ] >>getter
418 [ set-alien-unsigned-1 ] >>setter
422 "from_unsigned_1" >>boxer
424 \ uchar define-primitive-type
428 [ alien-unsigned-4 c-bool> ] >>getter
429 [ [ >c-bool ] 2dip set-alien-unsigned-4 ] >>setter
433 "from_boolean" >>boxer
434 "to_boolean" >>unboxer
437 [ alien-unsigned-1 c-bool> ] >>getter
438 [ [ >c-bool ] 2dip set-alien-unsigned-1 ] >>setter
442 "from_boolean" >>boxer
443 "to_boolean" >>unboxer
445 \ bool define-primitive-type
449 math:float >>boxed-class
450 [ alien-float ] >>getter
451 [ [ >float ] 2dip set-alien-float ] >>setter
458 [ >float ] >>unboxer-quot
459 \ float define-primitive-type
463 math:float >>boxed-class
464 [ alien-double ] >>getter
465 [ [ >float ] 2dip set-alien-double ] >>setter
468 "from_double" >>boxer
469 "to_double" >>unboxer
471 [ >float ] >>unboxer-quot
472 \ double define-primitive-type
477 integer >>boxed-class
478 [ alien-signed-cell ] >>getter
479 [ set-alien-signed-cell ] >>setter
480 bootstrap-cell >>size
481 bootstrap-cell >>align
482 bootstrap-cell >>align-first
483 "from_signed_cell" >>boxer
484 "to_fixnum" >>unboxer
485 \ longlong define-primitive-type
489 integer >>boxed-class
490 [ alien-unsigned-cell ] >>getter
491 [ set-alien-unsigned-cell ] >>setter
492 bootstrap-cell >>size
493 bootstrap-cell >>align
494 bootstrap-cell >>align-first
495 "from_unsigned_cell" >>boxer
497 \ ulonglong define-primitive-type
500 \ int c-type \ long define-primitive-type
501 \ uint c-type \ ulong define-primitive-type
503 \ longlong c-type \ long define-primitive-type
504 \ ulonglong c-type \ ulong define-primitive-type
507 \ longlong c-type \ ptrdiff_t typedef
508 \ longlong c-type \ intptr_t typedef
510 \ ulonglong c-type \ uintptr_t typedef
511 \ ulonglong c-type \ size_t typedef
515 integer >>boxed-class
516 [ alien-signed-8 ] >>getter
517 [ set-alien-signed-8 ] >>setter
520 "from_signed_8" >>boxer
521 "to_signed_8" >>unboxer
522 \ longlong define-primitive-type
526 integer >>boxed-class
527 [ alien-unsigned-8 ] >>getter
528 [ set-alien-unsigned-8 ] >>setter
531 "from_unsigned_8" >>boxer
532 "to_unsigned_8" >>unboxer
533 \ ulonglong define-primitive-type
535 \ int c-type \ long define-primitive-type
536 \ uint c-type \ ulong define-primitive-type
538 \ int c-type \ ptrdiff_t typedef
539 \ int c-type \ intptr_t typedef
541 \ uint c-type \ uintptr_t typedef
542 \ uint c-type \ size_t typedef
544 ] with-compilation-unit
546 M: char-16-rep rep-component-type drop char ;
547 M: uchar-16-rep rep-component-type drop uchar ;
548 M: short-8-rep rep-component-type drop short ;
549 M: ushort-8-rep rep-component-type drop ushort ;
550 M: int-4-rep rep-component-type drop int ;
551 M: uint-4-rep rep-component-type drop uint ;
552 M: longlong-2-rep rep-component-type drop longlong ;
553 M: ulonglong-2-rep rep-component-type drop ulonglong ;
554 M: float-4-rep rep-component-type drop float ;
555 M: double-2-rep rep-component-type drop double ;
557 : rep-length ( rep -- n )
558 16 swap rep-component-type heap-size /i ; foldable
560 : (unsigned-interval) ( bytes -- from to ) [ 0 ] dip 8 * 2^ 1 - ; foldable
561 : unsigned-interval ( c-type -- from to ) heap-size (unsigned-interval) ; foldable
562 : (signed-interval) ( bytes -- from to ) 8 * 1 - 2^ [ neg ] [ 1 - ] bi ; foldable
563 : signed-interval ( c-type -- from to ) heap-size (signed-interval) ; foldable
565 : c-type-interval ( c-type -- from to )
567 { [ dup { float double } member-eq? ] [ drop -1/0. 1/0. ] }
568 { [ dup { char short int long longlong } member-eq? ] [ signed-interval ] }
569 { [ dup { uchar ushort uint ulong ulonglong } member-eq? ] [ unsigned-interval ] }
572 : c-type-clamp ( value c-type -- value' )
573 dup { float double } member-eq?
574 [ drop ] [ c-type-interval clamp ] if ; inline