alien.marshall: refactored unmarshalling words
parent
0560e3abea
commit
59091c6cf2
|
@ -327,7 +327,7 @@ HELP: out-arg-unmarshaller
|
|||
"for all types except pointers to non-const primitives."
|
||||
} ;
|
||||
|
||||
HELP: pointer-unmarshaller
|
||||
HELP: class-unmarshaller
|
||||
{ $values
|
||||
{ "type" " a C type string" }
|
||||
{ "quot" quotation }
|
||||
|
|
|
@ -11,7 +11,8 @@ specialized-arrays.long specialized-arrays.longlong
|
|||
specialized-arrays.short specialized-arrays.uchar
|
||||
specialized-arrays.uint specialized-arrays.ulong
|
||||
specialized-arrays.ulonglong specialized-arrays.ushort strings
|
||||
unix.utilities vocabs.parser words libc.private struct-arrays ;
|
||||
unix.utilities vocabs.parser words libc.private struct-arrays
|
||||
locals generalizations ;
|
||||
IN: alien.marshall
|
||||
|
||||
<< primitive-types [ [ "void*" = ] [ "bool" = ] bi or not ]
|
||||
|
@ -269,33 +270,51 @@ ALIAS: marshall-void* marshall-pointer
|
|||
: ?malloc-byte-array ( c-type -- alien )
|
||||
dup alien? [ malloc-byte-array ] unless ;
|
||||
|
||||
: struct-unmarshaller ( type -- quot )
|
||||
current-vocab lookup [
|
||||
dup superclasses [ \ struct-wrapper = ] any? [
|
||||
'[ ?malloc-byte-array _ new swap >>underlying ]
|
||||
] [ drop [ ] ] if
|
||||
] [ [ ] ] if* ;
|
||||
:: x-unmarshaller ( type type-quot wrapper-test def clean -- quot/f )
|
||||
type type-quot call current-vocab lookup [
|
||||
dup superclasses wrapper-test any?
|
||||
[ def call ] [ drop clean call f ] if
|
||||
] [ clean call f ] if* ; inline
|
||||
|
||||
: pointer-unmarshaller ( type -- quot )
|
||||
type-sans-pointer current-vocab lookup [
|
||||
dup superclasses [ \ alien-wrapper = ] any? [
|
||||
'[ _ new swap >>underlying unmarshall-cast ]
|
||||
] [ drop [ ] ] if
|
||||
] [ [ ] ] if* ;
|
||||
: struct-unmarshaller ( type -- quot/f )
|
||||
[ ] [ \ struct-wrapper = ]
|
||||
[ '[ ?malloc-byte-array _ new swap >>underlying ] ]
|
||||
[ ]
|
||||
x-unmarshaller ;
|
||||
|
||||
: class-unmarshaller ( type -- quot/f )
|
||||
[ type-sans-pointer ] [ \ alien-wrapper = ]
|
||||
[ '[ ?malloc-byte-array _ new swap >>underlying ] ]
|
||||
[ ]
|
||||
x-unmarshaller ;
|
||||
|
||||
: template-class-unmarshaller ( type -- quot/f )
|
||||
[ parse-c++-type [ name>> ] keep swap ] [ \ template-wrapper = ]
|
||||
[ '[ _ _ new swap >>type swap >>underlying unmarshall-cast ] ]
|
||||
[ drop ]
|
||||
x-unmarshaller ;
|
||||
|
||||
: non-primitive-unmarshaller ( type -- quot/f )
|
||||
{
|
||||
{ [ dup template-class? ]
|
||||
[ template-class-unmarshaller ] }
|
||||
{ [ dup pointer? ] [ class-unmarshaller ] }
|
||||
[ struct-unmarshaller ]
|
||||
} cond ;
|
||||
|
||||
: unmarshaller ( type -- quot )
|
||||
factorize-type dup primitive-unmarshaller [ nip ] [
|
||||
dup pointer?
|
||||
[ pointer-unmarshaller ]
|
||||
[ struct-unmarshaller ] if
|
||||
] if* ;
|
||||
factorize-type {
|
||||
[ primitive-unmarshaller ]
|
||||
[ non-primitive-unmarshaller ]
|
||||
[ drop [ ] ]
|
||||
} 1|| ;
|
||||
|
||||
: struct-field-unmarshaller ( type -- quot )
|
||||
factorize-type dup struct-primitive-unmarshaller [ nip ] [
|
||||
dup pointer?
|
||||
[ pointer-unmarshaller ]
|
||||
[ struct-unmarshaller ] if
|
||||
] if* ;
|
||||
factorize-type {
|
||||
[ struct-primitive-unmarshaller ]
|
||||
[ non-primitive-unmarshaller ]
|
||||
[ drop [ ] ]
|
||||
} 1|| ;
|
||||
|
||||
: out-arg-unmarshaller ( type -- quot )
|
||||
dup pointer-to-non-const-primitive?
|
||||
|
|
Loading…
Reference in New Issue