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

alien.marshall: marshalling word fixes

db4
Jeremy Hughes 2009-07-14 10:26:26 +12:00
parent 702419c092
commit fd23b4070f
1 changed files with 9 additions and 10 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

19
basis/alien/marshall/marshall.factor
View File

@ -34,13 +34,13 @@ M: struct-wrapper unmarshall-cast ;
{ [ dup struct-array? ] [ underlying>> ] } { [ dup struct-array? ] [ underlying>> ] }
} cond ; } cond ;
: marshall-void* ( obj -- alien )
marshall-pointer ;
: marshall-primitive ( n -- n ) : marshall-primitive ( n -- n )
[ bool>arg ] ptr-pass-through ; [ bool>arg ] ptr-pass-through ;
: marshall-void** ( obj -- alien ) ALIAS: marshall-void* marshall-pointer
[ marshall-void* ] map >void*-array malloc-underlying ;
: marshall-void** ( seq -- alien )
[ marshall-void* ] void*-array{ } map-as malloc-underlying ;
: (marshall-char*-or-string) ( n/string -- alien ) : (marshall-char*-or-string) ( n/string -- alien )
dup string? dup string?
@ -51,11 +51,10 @@ M: struct-wrapper unmarshall-cast ;
[ (marshall-char*-or-string) ] ptr-pass-through ; [ (marshall-char*-or-string) ] ptr-pass-through ;
: (marshall-char**-or-strings) ( seq -- alien ) : (marshall-char**-or-strings) ( seq -- alien )
dup first string? [ marshall-char*-or-string ] void*-array{ } map-as
[ utf8 strings>alien malloc-byte-array ] malloc-underlying ;
[ (marshall-char**) ] if ;
: marshall-char**-or-strings ( n/string -- alien ) : marshall-char**-or-strings ( seq -- alien )
[ (marshall-char**-or-strings) ] ptr-pass-through ; [ (marshall-char**-or-strings) ] ptr-pass-through ;
: marshall-bool ( ? -- n ) : marshall-bool ( ? -- n )
@ -143,7 +142,7 @@ M: struct-wrapper unmarshall-cast ;
[ drop f ] [ drop f ]
} case ; } case ;
: marshall-non-pointer ( obj -- byte-array/f ) : marshall-non-pointer ( alien-wrapper/byte-array -- byte-array )
{ {
{ [ dup byte-array? ] [ ] } { [ dup byte-array? ] [ ] }
{ [ dup alien-wrapper? ] { [ dup alien-wrapper? ]
@ -268,7 +267,7 @@ M: struct-wrapper unmarshall-cast ;
: pointer-unmarshaller ( type -- quot ) : pointer-unmarshaller ( type -- quot )
type-sans-pointer current-vocab lookup [ type-sans-pointer current-vocab lookup [
dup superclasses [ \ alien-wrapper = ] any? [ dup superclasses [ \ alien-wrapper = ] any? [
'[ _ new swap >>underlying dynamic-cast ] '[ _ new swap >>underlying unmarshall-cast ]
] [ drop [ ] ] if ] [ drop [ ] ] if
] [ [ ] ] if* ; ] [ [ ] ] if* ;