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." "for all types except pointers to non-const primitives."
} ; } ;
HELP: pointer-unmarshaller HELP: class-unmarshaller
{ $values { $values
{ "type" " a C type string" } { "type" " a C type string" }
{ "quot" quotation } { "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.short specialized-arrays.uchar
specialized-arrays.uint specialized-arrays.ulong specialized-arrays.uint specialized-arrays.ulong
specialized-arrays.ulonglong specialized-arrays.ushort strings 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 IN: alien.marshall
<< primitive-types [ [ "void*" = ] [ "bool" = ] bi or not ] << primitive-types [ [ "void*" = ] [ "bool" = ] bi or not ]
@ -269,33 +270,51 @@ ALIAS: marshall-void* marshall-pointer
: ?malloc-byte-array ( c-type -- alien ) : ?malloc-byte-array ( c-type -- alien )
dup alien? [ malloc-byte-array ] unless ; dup alien? [ malloc-byte-array ] unless ;
: struct-unmarshaller ( type -- quot ) :: x-unmarshaller ( type type-quot wrapper-test def clean -- quot/f )
current-vocab lookup [ type type-quot call current-vocab lookup [
dup superclasses [ \ struct-wrapper = ] any? [ dup superclasses wrapper-test any?
'[ ?malloc-byte-array _ new swap >>underlying ] [ def call ] [ drop clean call f ] if
] [ drop [ ] ] if ] [ clean call f ] if* ; inline
] [ [ ] ] if* ;
: pointer-unmarshaller ( type -- quot ) : struct-unmarshaller ( type -- quot/f )
type-sans-pointer current-vocab lookup [ [ ] [ \ struct-wrapper = ]
dup superclasses [ \ alien-wrapper = ] any? [ [ '[ ?malloc-byte-array _ new swap >>underlying ] ]
'[ _ new swap >>underlying unmarshall-cast ] [ ]
] [ drop [ ] ] if x-unmarshaller ;
] [ [ ] ] if* ;
: 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 ) : unmarshaller ( type -- quot )
factorize-type dup primitive-unmarshaller [ nip ] [ factorize-type {
dup pointer? [ primitive-unmarshaller ]
[ pointer-unmarshaller ] [ non-primitive-unmarshaller ]
[ struct-unmarshaller ] if [ drop [ ] ]
] if* ; } 1|| ;
: struct-field-unmarshaller ( type -- quot ) : struct-field-unmarshaller ( type -- quot )
factorize-type dup struct-primitive-unmarshaller [ nip ] [ factorize-type {
dup pointer? [ struct-primitive-unmarshaller ]
[ pointer-unmarshaller ] [ non-primitive-unmarshaller ]
[ struct-unmarshaller ] if [ drop [ ] ]
] if* ; } 1|| ;
: out-arg-unmarshaller ( type -- quot ) : out-arg-unmarshaller ( type -- quot )
dup pointer-to-non-const-primitive? dup pointer-to-non-const-primitive?