diff --git a/basis/alien/marshall/marshall.factor b/basis/alien/marshall/marshall.factor index 8ee7fc8f06..3c2cf2b80d 100644 --- a/basis/alien/marshall/marshall.factor +++ b/basis/alien/marshall/marshall.factor @@ -39,17 +39,80 @@ M: alien-wrapper dynamic-cast ; : marshall-void** ( obj -- alien ) [ marshall-void* ] map >void*-array malloc-underlying ; -: marshall-char*-or-string ( n/string -- alien ) - dup string? +: (marshall-char*-or-string) ( n/string -- alien ) + string? [ utf8 string>alien malloc-byte-array ] - [ marshall-char* ] if ; + [ (marshall-char*) ] if ; -: marshall-char**-or-strings ( seq -- alien ) - dup first string? +: marshall-char*-or-string ( n/string -- alien ) + [ (marshall-char*-or-string) ] ptr-pass-through ; + +: marshall-char*-or-string-free ( n/string -- alien ) + [ (marshall-char*-or-string) &free ] ptr-pass-through ; + +: (marshall-char**-or-strings) ( seq -- alien ) + first string? [ utf8 strings>alien malloc-byte-array ] - [ marshall-char** ] if ; + [ (marshall-char**) ] if ; + +: marshall-char**-or-string ( n/string -- alien ) + [ (marshall-char**-or-string) ] ptr-pass-through ; + +: marshall-char**-or-string-free ( n/string -- alien ) + [ (marshall-char**-or-string) &free ] ptr-pass-through ; : primitive-marshaller ( type -- quot/f ) + { + { "bool" [ [ marshall-bool ] ] } + { "char" [ [ marshall-char ] ] } + { "uchar" [ [ marshall-uchar ] ] } + { "short" [ [ marshall-short ] ] } + { "ushort" [ [ marshall-ushort ] ] } + { "int" [ [ marshall-int ] ] } + { "uint" [ [ marshall-uint ] ] } + { "long" [ [ marshall-long ] ] } + { "ulong" [ [ marshall-ulong ] ] } + { "float" [ [ marshall-float ] ] } + { "double" [ [ marshall-double ] ] } + { "bool*" [ [ marshall-bool*-free ] ] } + { "char*" [ [ marshall-char*-or-string-free ] ] } + { "uchar*" [ [ marshall-uchar*-free ] ] } + { "short*" [ [ marshall-short*-free ] ] } + { "ushort*" [ [ marshall-ushort*-free ] ] } + { "int*" [ [ marshall-int*-free ] ] } + { "uint*" [ [ marshall-uint*-free ] ] } + { "long*" [ [ marshall-long*-free ] ] } + { "ulong*" [ [ marshall-ulong*-free ] ] } + { "float*" [ [ marshall-float*-free ] ] } + { "double*" [ [ marshall-double*-free ] ] } + { "bool&" [ [ marshall-bool*-free ] ] } + { "char&" [ [ marshall-char*-free ] ] } + { "uchar&" [ [ marshall-uchar*-free ] ] } + { "short&" [ [ marshall-short*-free ] ] } + { "ushort&" [ [ marshall-ushort*-free ] ] } + { "int&" [ [ marshall-int*-free ] ] } + { "uint&" [ [ marshall-uint*-free ] ] } + { "long&" [ [ marshall-long*-free ] ] } + { "ulong&" [ [ marshall-ulong*-free ] ] } + { "float&" [ [ marshall-float*-free ] ] } + { "double&" [ [ marshall-double*-free ] ] } + { "void*" [ [ marshall-void* ] ] } + { "bool**" [ [ marshall-bool**-free ] ] } + { "char**" [ [ marshall-char**-or-strings-free ] ] } + { "uchar**" [ [ marshall-uchar**-free ] ] } + { "short**" [ [ marshall-short**-free ] ] } + { "ushort**" [ [ marshall-ushort**-free ] ] } + { "int**" [ [ marshall-int**-free ] ] } + { "uint**" [ [ marshall-uint**-free ] ] } + { "long**" [ [ marshall-long**-free ] ] } + { "ulong**" [ [ marshall-ulong**-free ] ] } + { "float**" [ [ marshall-float**-free ] ] } + { "double**" [ [ marshall-double**-free ] ] } + { "void**" [ [ marshall-void** ] ] } + [ drop f ] + } case ; + +: struct-primitive-marshaller ( type -- quot/f ) { { "bool" [ [ marshall-bool ] ] } { "char" [ [ marshall-char ] ] } @@ -100,13 +163,27 @@ M: alien-wrapper dynamic-cast ; [ drop f ] } case ; -: marshall-struct ( obj -- byte-array ) ; +: marshall-non-ptr ( obj -- byte-array/f ) + { + { [ dup byte-array? ] [ ] } + { [ dup alien-wrapper? ] + [ [ underlying>> ] [ class name>> heap-size ] bi + memory>byte-array ] } + } cond ; + : marshaller ( type -- quot ) factorize-type dup primitive-marshaller [ nip ] [ pointer? [ [ marshall-pointer ] ] - [ [ marshall-struct ] ] if + [ [ marshall-non-pointer ] ] if + ] if* ; + +: struct-field-marshaller ( type -- quot ) + factorize-type dup struct-primitive-marshaller [ nip ] [ + pointer? + [ [ marshall-pointer ] ] + [ [ marshall-non-pointer ] ] if ] if* ; @@ -155,20 +232,26 @@ M: alien-wrapper dynamic-cast ; } case ; -: unmarshall-struct ( byte-array -- byte-array' ) ; +: struct-unmarshaller ( type -- quot ) + current-vocab lookup [ + dup superclasses [ struct-wrapper? ] any? [ + [ class name>> heap-size ] keep + '[ malloc-byte-array _ new swap >>underlying ] + ] [ drop [ ] ] if + ] [ [ ] ] if* ; : pointer-unmarshaller ( type -- quot ) type-sans-pointer current-vocab lookup [ - dup superclasses [ alien-wrapper = ] any? [ - '[ _ new >>underlying dynamic-cast ] + dup superclasses [ alien-wrapper? ] any? [ + '[ _ new swap >>underlying dynamic-cast ] ] [ drop [ ] ] if ] [ [ ] ] if* ; : unmarshaller ( type -- quot ) factorize-type dup primitive-unmarshaller [ nip ] [ dup pointer? - [ '[ _ pointer-unmarshaller ] ] - [ drop [ unmarshall-struct ] ] if + [ pointer-unmarshaller ] + [ struct-unmarshaller ] if ] if* ; : out-arg-unmarshaller ( type -- quot ) diff --git a/basis/alien/marshall/private/private.factor b/basis/alien/marshall/private/private.factor index 71852abe36..afc685effb 100644 --- a/basis/alien/marshall/private/private.factor +++ b/basis/alien/marshall/private/private.factor @@ -15,6 +15,9 @@ IN: alien.marshall.private MACRO: marshall-x* ( num-quot seq-quot -- alien ) '[ bool>arg dup number? _ _ if ] ; +: ptr-pass-through ( obj quot -- alien ) + over c-ptr? [ drop ] [ call ] if ; + : malloc-underlying ( obj -- alien ) underlying>> malloc-byte-array ; @@ -22,22 +25,30 @@ FUNCTOR: define-primitive-marshallers ( TYPE -- ) IS <${TYPE}> >TYPE-array IS >${TYPE}-array marshall-TYPE DEFINES marshall-${TYPE} +(marshall-TYPE*) DEFINES (marshall-${TYPE}*) +(marshall-TYPE**) DEFINES (marshall-${TYPE}**) marshall-TYPE* DEFINES marshall-${TYPE}* marshall-TYPE** DEFINES marshall-${TYPE}** +marshall-TYPE*-free DEFINES marshall-${TYPE}*-free +marshall-TYPE**-free DEFINES marshall-${TYPE}**-free WHERE : marshall-TYPE ( n -- byte-array ) - dup c-ptr? [ bool>arg ] unless ; + [ bool>arg ] ptr-pass-through ; +: (marshall-TYPE*) ( n/seq -- alien ) + [ malloc-byte-array ] + [ >TYPE-array malloc-underlying ] + marshall-x* ; +: (marshall-TYPE**) ( seq -- alien ) + [ >TYPE-array malloc-underlying ] + map >void*-array malloc-underlying ; : marshall-TYPE* ( n/seq -- alien ) - dup c-ptr? [ - [ malloc-byte-array ] - [ >TYPE-array malloc-underlying ] - marshall-x* &free - ] unless ; + [ (marshall-TYPE*) ] ptr-pass-through ; : marshall-TYPE** ( seq -- alien ) - dup c-ptr? [ - [ >TYPE-array malloc-underlying ] - map >void*-array malloc-underlying &free - ] unless ; + [ (marshall-TYPE**) ] ptr-pass-through ; +: marshall-TYPE*-free ( n/seq -- alien ) + [ (marshall-TYPE*) &free ] ptr-pass-through ; +: marshall-TYPE**-free ( seq -- alien ) + [ (marshall-TYPE**) &free ] ptr-pass-through ; ;FUNCTOR SYNTAX: PRIMITIVE-MARSHALLERS: