align
array-class
array-constructor
-direct-array-class
-direct-array-constructor
-sequence-mixin-class ;
+(array)-constructor
+direct-array-constructor ;
TUPLE: c-type < abstract-c-type
boxer
: ?require-word ( word/pair -- )
dup word? [ drop ] [ first require ] ?if ;
-GENERIC: require-c-type-arrays ( c-type -- )
+! 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>> ;
-M: object require-c-type-arrays
+GENERIC: require-c-array ( c-type -- )
+
+M: object require-c-array
drop ;
-M: c-type require-c-type-arrays
- [ array-class>> ?require-word ]
- [ sequence-mixin-class>> ?require-word ]
- [ direct-array-class>> ?require-word ] tri ;
+M: c-type require-c-array
+ array-class>> ?require-word ;
-M: string require-c-type-arrays
- c-type require-c-type-arrays ;
+M: string require-c-array
+ c-type require-c-array ;
-M: array require-c-type-arrays
- first c-type require-c-type-arrays ;
+M: array require-c-array
+ first c-type require-c-array ;
ERROR: specialized-array-vocab-not-loaded vocab word ;
-: c-type-array-constructor ( c-type -- word )
+: c-array-constructor ( c-type -- word )
array-constructor>> dup array?
[ first2 specialized-array-vocab-not-loaded ] when ; foldable
-: c-type-direct-array-constructor ( c-type -- word )
+: 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-type-array> ( len c-type -- array )
-M: object <c-type-array>
- c-type-array-constructor execute( len -- array ) ; inline
-M: string <c-type-array>
- c-type <c-type-array> ; inline
-M: array <c-type-array>
- first c-type <c-type-array> ; inline
-
-GENERIC: <c-type-direct-array> ( alien len c-type -- array )
-M: object <c-type-direct-array>
- c-type-direct-array-constructor execute( alien len -- array ) ; inline
-M: string <c-type-direct-array>
- c-type <c-type-direct-array> ; inline
-M: array <c-type-direct-array>
- first c-type <c-type-direct-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-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: 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 ;
]
[
[ "specialized-arrays." prepend ]
- [ "-sequence" append ] bi* ?lookup >>sequence-mixin-class
+ [ "(" "-array)" surround ] bi* ?lookup >>(array)-constructor
]
[
- [ "specialized-arrays.direct." prepend ]
- [ "direct-" "-array" surround ] bi* ?lookup >>direct-array-class
- ]
- [
- [ "specialized-arrays.direct." prepend ]
+ [ "specialized-arrays." prepend ]
[ "<direct-" "-array>" surround ] bi* ?lookup >>direct-array-constructor
]
} 2cleave ;
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
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