cpu.architecture alien alien.accessors alien.strings quotations
layouts system compiler.units io io.files io.encodings.binary
io.streams.memory accessors combinators effects continuations fry
-classes ;
+classes vocabs vocabs.loader ;
IN: alien.c-types
DEFER: <int>
boxer
unboxer
{ rep initial: int-rep }
-stack-align? ;
+stack-align?
+array-class
+array-constructor
+direct-array-class
+direct-array-constructor
+sequence-mixin-class ;
: <c-type> ( -- type )
\ c-type new ;
] ?if
] if ;
+: ?require-word ( word/pair -- )
+ dup word? [ drop ] [ first require ] ?if ;
+
+GENERIC: require-c-type-arrays ( c-type -- )
+
+M: object require-c-type-arrays
+ drop ;
+
+M: c-type require-c-type-arrays
+ [ array-class>> ?require-word ]
+ [ sequence-mixin-class>> ?require-word ]
+ [ direct-array-class>> ?require-word ] tri ;
+
+M: string require-c-type-arrays
+ c-type require-c-type-arrays ;
+
+M: array require-c-type-arrays
+ first c-type require-c-type-arrays ;
+
+GENERIC: c-type-array-constructor ( c-type -- word ) foldable
+
+M: string c-type-array-constructor
+ c-type c-type-array-constructor ;
+M: array c-type-array-constructor
+ first c-type c-type-array-constructor ;
+M: c-type c-type-array-constructor
+ array-constructor>> ;
+
+GENERIC: c-type-direct-array-constructor ( c-type -- word ) foldable
+
+M: string c-type-direct-array-constructor
+ c-type c-type-array-constructor ;
+M: array c-type-direct-array-constructor
+ first c-type c-type-direct-array-constructor ;
+M: c-type c-type-direct-array-constructor
+ direct-array-constructor>> ;
+
+: <c-type-array> ( len c-type -- array )
+ c-type-array-constructor execute( len -- array ) ; inline
+: <c-type-direct-array> ( len c-type -- array )
+ c-type-direct-array-constructor execute( len -- array ) ; inline
+
GENERIC: c-type-class ( name -- class )
M: abstract-c-type c-type-class class>> ;
: if-void ( type true false -- )
pick "void" = [ drop nip call ] [ nip call ] if ; inline
+: ?lookup ( vocab word -- word/pair )
+ over vocab [ swap lookup ] [ 2array ] if ;
+
+: set-array-class* ( c-type vocab-stem type-stem -- c-type )
+ {
+ [
+ [ "specialized-arrays." prepend ]
+ [ "-array" append ] bi* ?lookup >>array-class
+ ]
+ [
+ [ "specialized-arrays." prepend ]
+ [ "<" "-array>" surround ] bi* ?lookup >>array-constructor
+ ]
+ [
+ [ "specialized-arrays." prepend ]
+ [ "-sequence" append ] bi* ?lookup >>sequence-mixin-class
+ ]
+ [
+ [ "specialized-arrays.direct." prepend ]
+ [ "direct-" "-array" surround ] bi* ?lookup >>direct-array-class
+ ]
+ [
+ [ "specialized-arrays.direct." prepend ]
+ [ "<direct-" "-array>" surround ] bi* ?lookup >>direct-array-constructor
+ ]
+ } 2cleave ;
+
+: set-array-class ( c-type stem -- c-type )
+ dup set-array-class* ;
+
CONSTANT: primitive-types
{
"char" "uchar"
[ >c-ptr ] >>unboxer-quot
"box_alien" >>boxer
"alien_offset" >>unboxer
+ "alien" "void*" set-array-class*
"void*" define-primitive-type
<long-long-type>
8 >>align
"box_signed_8" >>boxer
"to_signed_8" >>unboxer
+ "longlong" set-array-class
"longlong" define-primitive-type
<long-long-type>
8 >>align
"box_unsigned_8" >>boxer
"to_unsigned_8" >>unboxer
+ "ulonglong" set-array-class
"ulonglong" define-primitive-type
<c-type>
bootstrap-cell >>align
"box_signed_cell" >>boxer
"to_fixnum" >>unboxer
+ "long" set-array-class
"long" define-primitive-type
<c-type>
bootstrap-cell >>align
"box_unsigned_cell" >>boxer
"to_cell" >>unboxer
+ "ulong" set-array-class
"ulong" define-primitive-type
<c-type>
4 >>align
"box_signed_4" >>boxer
"to_fixnum" >>unboxer
+ "int" set-array-class
"int" define-primitive-type
<c-type>
4 >>align
"box_unsigned_4" >>boxer
"to_cell" >>unboxer
+ "uint" set-array-class
"uint" define-primitive-type
<c-type>
2 >>align
"box_signed_2" >>boxer
"to_fixnum" >>unboxer
+ "short" set-array-class
"short" define-primitive-type
<c-type>
2 >>align
"box_unsigned_2" >>boxer
"to_cell" >>unboxer
+ "ushort" set-array-class
"ushort" define-primitive-type
<c-type>
1 >>align
"box_signed_1" >>boxer
"to_fixnum" >>unboxer
+ "char" set-array-class
"char" define-primitive-type
<c-type>
1 >>align
"box_unsigned_1" >>boxer
"to_cell" >>unboxer
+ "uchar" set-array-class
"uchar" define-primitive-type
<c-type>
1 >>align
"box_boolean" >>boxer
"to_boolean" >>unboxer
+ "bool" set-array-class
"bool" define-primitive-type
<c-type>
"to_float" >>unboxer
single-float-rep >>rep
[ >float ] >>unboxer-quot
+ "float" set-array-class
"float" define-primitive-type
<c-type>
"to_double" >>unboxer
double-float-rep >>rep
[ >float ] >>unboxer-quot
+ "double" set-array-class
"double" define-primitive-type
"long" "ptrdiff_t" typedef
"long" "intptr_t" typedef
"ulong" "size_t" typedef
] with-compilation-unit
+