alien.structs: struct-type now has a class slot; fix specialized complex-float/double arrays
parent
cc5476c823
commit
d19c403fee
|
@ -13,17 +13,19 @@ DEFER: *char
|
|||
|
||||
: little-endian? ( -- ? ) 1 <int> *char 1 = ; foldable
|
||||
|
||||
TUPLE: c-type
|
||||
TUPLE: abstract-c-type
|
||||
{ class class initial: object }
|
||||
boxer
|
||||
{ boxer-quot callable }
|
||||
unboxer
|
||||
{ unboxer-quot callable }
|
||||
{ getter callable }
|
||||
{ setter callable }
|
||||
{ rep initial: int-rep }
|
||||
size
|
||||
align
|
||||
align ;
|
||||
|
||||
TUPLE: c-type < abstract-c-type
|
||||
boxer
|
||||
unboxer
|
||||
{ rep initial: int-rep }
|
||||
stack-align? ;
|
||||
|
||||
: <c-type> ( -- type )
|
||||
|
@ -70,7 +72,7 @@ M: string c-type ( name -- type )
|
|||
|
||||
GENERIC: c-type-class ( name -- class )
|
||||
|
||||
M: c-type c-type-class class>> ;
|
||||
M: abstract-c-type c-type-class class>> ;
|
||||
|
||||
M: string c-type-class c-type c-type-class ;
|
||||
|
||||
|
@ -82,7 +84,7 @@ M: string c-type-boxer c-type c-type-boxer ;
|
|||
|
||||
GENERIC: c-type-boxer-quot ( name -- quot )
|
||||
|
||||
M: c-type c-type-boxer-quot boxer-quot>> ;
|
||||
M: abstract-c-type c-type-boxer-quot boxer-quot>> ;
|
||||
|
||||
M: string c-type-boxer-quot c-type c-type-boxer-quot ;
|
||||
|
||||
|
@ -94,7 +96,7 @@ M: string c-type-unboxer c-type c-type-unboxer ;
|
|||
|
||||
GENERIC: c-type-unboxer-quot ( name -- quot )
|
||||
|
||||
M: c-type c-type-unboxer-quot unboxer-quot>> ;
|
||||
M: abstract-c-type c-type-unboxer-quot unboxer-quot>> ;
|
||||
|
||||
M: string c-type-unboxer-quot c-type c-type-unboxer-quot ;
|
||||
|
||||
|
@ -118,7 +120,7 @@ M: string c-type-setter c-type c-type-setter ;
|
|||
|
||||
GENERIC: c-type-align ( name -- n )
|
||||
|
||||
M: c-type c-type-align align>> ;
|
||||
M: abstract-c-type c-type-align align>> ;
|
||||
|
||||
M: string c-type-align c-type c-type-align ;
|
||||
|
||||
|
@ -167,7 +169,7 @@ GENERIC: heap-size ( type -- size ) foldable
|
|||
|
||||
M: string heap-size c-type heap-size ;
|
||||
|
||||
M: c-type heap-size size>> ;
|
||||
M: abstract-c-type heap-size size>> ;
|
||||
|
||||
GENERIC: stack-size ( type -- size ) foldable
|
||||
|
||||
|
|
|
@ -30,6 +30,7 @@ define-struct
|
|||
T c-type
|
||||
<T> 1quotation >>unboxer-quot
|
||||
*T 1quotation >>boxer-quot
|
||||
number >>class
|
||||
drop
|
||||
|
||||
;FUNCTOR
|
||||
|
|
|
@ -6,30 +6,12 @@ alien.c-types alien.structs.fields cpu.architecture math.order
|
|||
quotations byte-arrays ;
|
||||
IN: alien.structs
|
||||
|
||||
TUPLE: struct-type
|
||||
size
|
||||
align
|
||||
fields
|
||||
{ boxer-quot callable }
|
||||
{ unboxer-quot callable }
|
||||
{ getter callable }
|
||||
{ setter callable }
|
||||
return-in-registers? ;
|
||||
TUPLE: struct-type < abstract-c-type fields return-in-registers? ;
|
||||
|
||||
M: struct-type c-type ;
|
||||
|
||||
M: struct-type heap-size size>> ;
|
||||
|
||||
M: struct-type c-type-class drop byte-array ;
|
||||
|
||||
M: struct-type c-type-align align>> ;
|
||||
|
||||
M: struct-type c-type-stack-align? drop f ;
|
||||
|
||||
M: struct-type c-type-boxer-quot boxer-quot>> ;
|
||||
|
||||
M: struct-type c-type-unboxer-quot unboxer-quot>> ;
|
||||
|
||||
: if-value-struct ( ctype true false -- )
|
||||
[ dup value-struct? ] 2dip '[ drop "void*" @ ] if ; inline
|
||||
|
||||
|
@ -56,6 +38,7 @@ M: struct-type stack-size
|
|||
: (define-struct) ( name size align fields -- )
|
||||
[ [ align ] keep ] dip
|
||||
struct-type new
|
||||
byte-array >>class
|
||||
swap >>fields
|
||||
swap >>align
|
||||
swap >>size
|
||||
|
|
|
@ -1,6 +1,7 @@
|
|||
IN: math.vectors.specialization.tests
|
||||
USING: compiler.tree.debugger math.vectors tools.test kernel
|
||||
kernel.private math specialized-arrays.double
|
||||
specialized-arrays.complex-float
|
||||
specialized-arrays.float ;
|
||||
|
||||
[ V{ t } ] [
|
||||
|
@ -9,4 +10,12 @@ specialized-arrays.float ;
|
|||
|
||||
[ V{ float } ] [
|
||||
[ { float-array float } declare v*n norm ] final-classes
|
||||
] unit-test
|
||||
|
||||
[ V{ number } ] [
|
||||
[ { complex-float-array complex-float-array } declare v. ] final-classes
|
||||
] unit-test
|
||||
|
||||
[ V{ real } ] [
|
||||
[ { complex-float-array complex } declare v*n norm ] final-classes
|
||||
] unit-test
|
Loading…
Reference in New Issue