ditch string c-types
Joe Groff
parent
420e2d2308
commit
62e97c138a
|
|
@ -32,13 +32,10 @@ HELP: no-c-type
|
|||
{ $description "Throws a " { $link no-c-type } " error." }
|
||||
{ $error-description "Thrown by " { $link c-type } " if a given string does not name a C type. When thrown during compile time, indicates a typo in an " { $link alien-invoke } " or " { $link alien-callback } " form." } ;
|
||||
|
||||
HELP: c-types
|
||||
{ $var-description "Global variable holding a hashtable mapping C type names to C types. Use the " { $link c-type } " word to look up C types." } ;
|
||||
|
||||
HELP: c-type
|
||||
{ $values { "name" "a C type" } { "c-type" c-type } }
|
||||
{ $description "Looks up a C type by name." }
|
||||
{ $errors "Throws a " { $link no-c-type } " error if the type does not exist." } ;
|
||||
{ $errors "Throws a " { $link no-c-type } " error if the type does not exist, or the word is not a C type." } ;
|
||||
|
||||
HELP: c-getter
|
||||
{ $values { "name" "a C type" } { "quot" { $quotation "( c-ptr n -- obj )" } } }
|
||||
|
|
|
|||
|
|
@ -43,12 +43,6 @@ stack-align? ;
|
|||
: <c-type> ( -- c-type )
|
||||
\ c-type new ; inline
|
||||
|
||||
SYMBOL: c-types
|
||||
|
||||
global [
|
||||
c-types [ H{ } assoc-like ] change
|
||||
] bind
|
||||
|
||||
ERROR: no-c-type name ;
|
||||
|
||||
PREDICATE: c-type-word < word
|
||||
|
|
@ -70,14 +64,6 @@ M: word resolve-pointer-type
|
|||
dup "pointer-c-type" word-prop
|
||||
[ ] [ drop void* ] ?if ;
|
||||
|
||||
M: string resolve-pointer-type
|
||||
dup "*" append dup c-types get at
|
||||
[ nip ] [
|
||||
drop
|
||||
c-types get at dup c-type-name?
|
||||
[ resolve-pointer-type ] [ drop void* ] if
|
||||
] if ;
|
||||
|
||||
M: array resolve-pointer-type
|
||||
first resolve-pointer-type ;
|
||||
|
||||
|
|
@ -93,15 +79,6 @@ M: array resolve-pointer-type
|
|||
|
||||
PRIVATE>
|
||||
|
||||
M: string c-type ( name -- c-type )
|
||||
CHAR: ] over member? [
|
||||
parse-array-type prefix
|
||||
] [
|
||||
dup c-types get at [ ] [
|
||||
"*" ?tail [ resolve-pointer-type ] [ no-c-type ] if
|
||||
] ?if resolve-typedef
|
||||
] if ;
|
||||
|
||||
M: word c-type
|
||||
dup "c-type" word-prop resolve-typedef
|
||||
[ ] [ no-c-type ] ?if ;
|
||||
|
|
@ -268,12 +245,9 @@ GENERIC: typedef ( old new -- )
|
|||
PREDICATE: typedef-word < c-type-word
|
||||
"c-type" word-prop c-type-name? ;
|
||||
|
||||
M: string typedef ( old new -- ) c-types get set-at ;
|
||||
|
||||
M: word typedef ( old new -- )
|
||||
{
|
||||
[ nip define-symbol ]
|
||||
[ name>> typedef ]
|
||||
[ swap "c-type" set-word-prop ]
|
||||
[
|
||||
swap dup c-type-name? [
|
||||
|
|
|
|||
|
|
@ -16,6 +16,6 @@ STRUCT: complex-holder
|
|||
|
||||
[ C{ 1.0 2.0 } ] [ "h" get z>> ] unit-test
|
||||
|
||||
[ complex ] [ "complex-float" c-type-boxed-class ] unit-test
|
||||
[ complex ] [ complex-float c-type-boxed-class ] unit-test
|
||||
|
||||
[ complex ] [ "complex-double" c-type-boxed-class ] unit-test
|
||||
[ complex ] [ complex-double c-type-boxed-class ] unit-test
|
||||
|
|
|
|||
|
|
@ -6,8 +6,10 @@ IN: alien.complex
|
|||
|
||||
<<
|
||||
{ "float" "double" } [ dup "complex-" prepend define-complex-type ] each
|
||||
>>
|
||||
|
||||
<<
|
||||
! This overrides the fact that small structures are never returned
|
||||
! in registers on NetBSD, Linux and Solaris running on 32-bit x86.
|
||||
"complex-float" c-type t >>return-in-registers? drop
|
||||
\ complex-float c-type t >>return-in-registers? drop
|
||||
>>
|
||||
|
|
|
|||
|
|
@ -7,6 +7,8 @@ IN: alien.complex.functor
|
|||
|
||||
FUNCTOR: define-complex-type ( N T -- )
|
||||
|
||||
N-type IS ${N}
|
||||
|
||||
T-class DEFINES-CLASS ${T}
|
||||
|
||||
<T> DEFINES <${T}>
|
||||
|
|
@ -14,7 +16,7 @@ T-class DEFINES-CLASS ${T}
|
|||
|
||||
WHERE
|
||||
|
||||
STRUCT: T-class { real N } { imaginary N } ;
|
||||
STRUCT: T-class { real N-type } { imaginary N-type } ;
|
||||
|
||||
: <T> ( z -- alien )
|
||||
>rect T-class <struct-boa> >c-ptr ;
|
||||
|
|
|
|||
|
|
@ -361,13 +361,6 @@ TUPLE: a-subclass < will-become-struct ;
|
|||
|
||||
[ tuple ] [ a-subclass superclass ] unit-test
|
||||
|
||||
! Remove c-type when struct class is forgotten
|
||||
[ ] [
|
||||
"USE: classes.struct IN: classes.struct.tests TUPLE: a-struct ;" eval( -- )
|
||||
] unit-test
|
||||
|
||||
[ f ] [ "a-struct" c-types get key? ] unit-test
|
||||
|
||||
STRUCT: bit-field-test
|
||||
{ a uint bits: 12 }
|
||||
{ b int bits: 2 }
|
||||
|
|
|
|||
|
|
@ -296,9 +296,6 @@ PRIVATE>
|
|||
: define-union-struct-class ( class slots -- )
|
||||
[ compute-union-offsets ] (define-struct-class) ;
|
||||
|
||||
M: struct-class reset-class
|
||||
[ call-next-method ] [ name>> c-types get delete-at ] bi ;
|
||||
|
||||
ERROR: invalid-struct-slot token ;
|
||||
|
||||
: struct-slot-class ( c-type -- class' )
|
||||
|
|
|
|||
|
|
@ -116,10 +116,7 @@ M: A v*high [ * \ T heap-size neg shift ] 2map ; inline
|
|||
|
||||
;FUNCTOR
|
||||
|
||||
GENERIC: (underlying-type) ( c-type -- c-type' )
|
||||
|
||||
M: string (underlying-type) c-types get at ;
|
||||
M: word (underlying-type) "c-type" word-prop ;
|
||||
: (underlying-type) ( word -- c-type ) "c-type" word-prop ; inline
|
||||
|
||||
: underlying-type ( c-type -- c-type' )
|
||||
dup (underlying-type) {
|
||||
|
|
|
|||
Loading…
Reference in New Issue