steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

alien.marshall: refactored unmarshalling words

db4
Jeremy Hughes 2009-07-21 17:09:32 +12:00
parent 0560e3abea
commit 59091c6cf2
2 changed files with 43 additions and 24 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
extra/alien/marshall/marshall-docs.factor
View File

@ -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 }

65
extra/alien/marshall/marshall.factor
View File

@ -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?