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>
{ getter callable }
{ setter callable }
size
-align ;
+align
+array-class
+array-constructor
+(array)-constructor
+direct-array-constructor ;
TUPLE: c-type < abstract-c-type
boxer
] ?if
] if ;
+: ?require-word ( word/pair -- )
+ dup word? [ drop ] [ first require ] ?if ;
+
+! These words being foldable means that words need to be
+! recompiled if a C type is redefined. Even so, folding the
+! size facilitates some optimizations.
+GENERIC: heap-size ( type -- size ) foldable
+
+M: string heap-size c-type heap-size ;
+
+M: abstract-c-type heap-size size>> ;
+
+GENERIC: require-c-array ( c-type -- )
+
+M: object require-c-array
+ drop ;
+
+M: c-type require-c-array
+ array-class>> ?require-word ;
+
+M: string require-c-array
+ c-type require-c-array ;
+
+M: array require-c-array
+ first c-type require-c-array ;
+
+ERROR: specialized-array-vocab-not-loaded vocab word ;
+
+: c-array-constructor ( c-type -- word )
+ array-constructor>> dup array?
+ [ first2 specialized-array-vocab-not-loaded ] when ; foldable
+
+: c-(array)-constructor ( c-type -- word )
+ (array)-constructor>> dup array?
+ [ first2 specialized-array-vocab-not-loaded ] when ; foldable
+
+: c-direct-array-constructor ( c-type -- word )
+ direct-array-constructor>> dup array?
+ [ first2 specialized-array-vocab-not-loaded ] when ; foldable
+
+GENERIC: <c-array> ( len c-type -- array )
+M: object <c-array>
+ c-array-constructor execute( len -- array ) ; inline
+M: string <c-array>
+ c-type <c-array> ; inline
+M: array <c-array>
+ first c-type <c-array> ; inline
+
+GENERIC: (c-array) ( len c-type -- array )
+M: object (c-array)
+ c-(array)-constructor execute( len -- array ) ; inline
+M: string (c-array)
+ c-type (c-array) ; inline
+M: array (c-array)
+ first c-type (c-array) ; inline
+
+GENERIC: <c-direct-array> ( alien len c-type -- array )
+M: object <c-direct-array>
+ c-direct-array-constructor execute( alien len -- array ) ; inline
+M: string <c-direct-array>
+ c-type <c-direct-array> ; inline
+M: array <c-direct-array>
+ first c-type <c-direct-array> ; inline
+
+: malloc-array ( n type -- alien )
+ [ heap-size calloc ] [ <c-direct-array> ] 2bi ; inline
+
+: (malloc-array) ( n type -- alien )
+ [ heap-size * malloc ] [ <c-direct-array> ] 2bi ; inline
+
GENERIC: c-type-class ( name -- class )
M: abstract-c-type c-type-class class>> ;
M: string unbox-return c-type unbox-return ;
-! These words being foldable means that words need to be
-! recompiled if a C type is redefined. Even so, folding the
-! size facilitates some optimizations.
-GENERIC: heap-size ( type -- size ) foldable
-
-M: string heap-size c-type heap-size ;
-
-M: abstract-c-type heap-size size>> ;
-
GENERIC: stack-size ( type -- size ) foldable
M: string stack-size c-type stack-size ;
GENERIC: byte-length ( seq -- n ) flushable
-M: byte-array byte-length length ;
+M: byte-array byte-length length ; inline
-M: f byte-length drop 0 ;
+M: f byte-length drop 0 ; inline
: c-getter ( name -- quot )
c-type-getter [
[ "Cannot write struct fields with this type" throw ]
] unless* ;
-: <c-array> ( n type -- array )
- heap-size * <byte-array> ; inline
-
: <c-object> ( type -- array )
- 1 swap <c-array> ; inline
+ heap-size <byte-array> ; inline
-: malloc-array ( n type -- alien )
- heap-size calloc ; inline
+: (c-object) ( type -- array )
+ heap-size (byte-array) ; inline
: malloc-object ( type -- alien )
- 1 swap malloc-array ; inline
+ 1 swap heap-size calloc ; inline
+
+: (malloc-object) ( type -- alien )
+ heap-size malloc ; inline
: malloc-byte-array ( byte-array -- alien )
dup byte-length [ nip malloc dup ] 2keep memcpy ;
] [ [ + ] change-index drop ] 2bi ;
: byte-array>memory ( byte-array base -- )
- swap dup byte-length memcpy ;
+ swap dup byte-length memcpy ; inline
: array-accessor ( type quot -- def )
[
[ define-out ]
tri ;
-: expand-constants ( c-type -- c-type' )
- dup array? [
- unclip [
- [
- dup word? [
- def>> call( -- object )
- ] when
- ] map
- ] dip prefix
- ] when ;
-
: malloc-file-contents ( path -- alien len )
binary file-contents [ malloc-byte-array ] [ length ] bi ;
: 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 ]
+ [ "(" "-array)" surround ] bi* ?lookup >>(array)-constructor
+ ]
+ [
+ [ "specialized-arrays." 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>
4 >>align
"box_float" >>boxer
"to_float" >>unboxer
- single-float-rep >>rep
+ float-rep >>rep
[ >float ] >>unboxer-quot
+ "float" set-array-class
"float" define-primitive-type
<c-type>
8 >>align
"box_double" >>boxer
"to_double" >>unboxer
- double-float-rep >>rep
+ double-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
+
projects / factor.git / blobdiff