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

alien.marshall: fixes

db4
Jeremy Hughes 2009-07-07 19:43:30 +12:00
parent 4917454b85
commit 9128952867
1 changed files with 17 additions and 19 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -1,19 +1,17 @@
! Copyright (C) 2009 Jeremy Hughes. ! Copyright (C) 2009 Jeremy Hughes.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: accessors alien alien.c-types alien.inline.types USING: accessors alien alien.c-types alien.inline.types
alien.marshall.private alien.marshall.private alien.strings byte-arrays classes
alien.strings byte-arrays classes combinators combinators combinators.short-circuit destructors fry
combinators.short-circuit destructors fry io.encodings.utf8 kernel libc sequences
io.encodings.utf8 kernel sequences specialized-arrays.alien specialized-arrays.bool
specialized-arrays.alien specialized-arrays.char specialized-arrays.double
specialized-arrays.bool specialized-arrays.char specialized-arrays.float specialized-arrays.int
specialized-arrays.double specialized-arrays.float specialized-arrays.long specialized-arrays.longlong
specialized-arrays.int specialized-arrays.long
specialized-arrays.longlong specialized-arrays.ulonglong
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.ushort strings unix.utilities specialized-arrays.ulonglong specialized-arrays.ushort strings
vocabs.parser words ; unix.utilities vocabs.parser words ;
IN: alien.marshall IN: alien.marshall
<< primitive-types [ "void*" = not ] filter << primitive-types [ "void*" = not ] filter
@ -40,7 +38,7 @@ M: alien-wrapper dynamic-cast ;
[ marshall-void* ] map >void*-array malloc-underlying ; [ marshall-void* ] map >void*-array malloc-underlying ;
: (marshall-char*-or-string) ( n/string -- alien ) : (marshall-char*-or-string) ( n/string -- alien )
string? dup string?
[ utf8 string>alien malloc-byte-array ] [ utf8 string>alien malloc-byte-array ]
[ (marshall-char*) ] if ; [ (marshall-char*) ] if ;
@ -51,15 +49,15 @@ M: alien-wrapper dynamic-cast ;
[ (marshall-char*-or-string) &free ] ptr-pass-through ; [ (marshall-char*-or-string) &free ] ptr-pass-through ;
: (marshall-char**-or-strings) ( seq -- alien ) : (marshall-char**-or-strings) ( seq -- alien )
first string? dup first string?
[ utf8 strings>alien malloc-byte-array ] [ utf8 strings>alien malloc-byte-array ]
[ (marshall-char**) ] if ; [ (marshall-char**) ] if ;
: marshall-char**-or-string ( n/string -- alien ) : marshall-char**-or-strings ( n/string -- alien )
[ (marshall-char**-or-string) ] ptr-pass-through ; [ (marshall-char**-or-strings) ] ptr-pass-through ;
: marshall-char**-or-string-free ( n/string -- alien ) : marshall-char**-or-strings-free ( n/string -- alien )
[ (marshall-char**-or-string) &free ] ptr-pass-through ; [ (marshall-char**-or-strings) &free ] ptr-pass-through ;
: primitive-marshaller ( type -- quot/f ) : primitive-marshaller ( type -- quot/f )
{ {
@ -163,7 +161,7 @@ M: alien-wrapper dynamic-cast ;
[ drop f ] [ drop f ]
} case ; } case ;
: marshall-non-ptr ( obj -- byte-array/f ) : marshall-non-pointer ( obj -- byte-array/f )
{ {
{ [ dup byte-array? ] [ ] } { [ dup byte-array? ] [ ] }
{ [ dup alien-wrapper? ] { [ dup alien-wrapper? ]
@ -236,7 +234,7 @@ M: alien-wrapper dynamic-cast ;
current-vocab lookup [ current-vocab lookup [
dup superclasses [ struct-wrapper? ] any? [ dup superclasses [ struct-wrapper? ] any? [
[ class name>> heap-size ] keep [ class name>> heap-size ] keep
'[ malloc-byte-array _ new swap >>underlying ] '[ _ malloc-byte-array _ new swap >>underlying ]
] [ drop [ ] ] if ] [ drop [ ] ] if
] [ [ ] ] if* ; ] [ [ ] ] if* ;