extra/alien/marshall/marshall.factor

   1 ! Copyright (C) 2009 Jeremy Hughes.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: accessors alien alien.c-types alien.inline.types
   4 alien.marshall.private alien.strings byte-arrays classes
   5 combinators combinators.short-circuit destructors fry
   6 io.encodings.utf8 kernel libc sequences
   7 specialized-arrays.alien specialized-arrays.bool
   8 specialized-arrays.char specialized-arrays.double
   9 specialized-arrays.float specialized-arrays.int
  10 specialized-arrays.long specialized-arrays.longlong
  11 specialized-arrays.short specialized-arrays.uchar
  12 specialized-arrays.uint specialized-arrays.ulong
  13 specialized-arrays.ulonglong specialized-arrays.ushort strings
  14 unix.utilities vocabs.parser words libc.private struct-arrays
  15 locals generalizations math ;
  16 IN: alien.marshall
  17
  18 << primitive-types [ [ "void*" = ] [ "bool" = ] bi or not ]
  19 filter [ define-primitive-marshallers ] each >>
  20
  21 TUPLE: alien-wrapper { underlying alien } ;
  22 TUPLE: struct-wrapper < alien-wrapper disposed ;
  23 TUPLE: class-wrapper < alien-wrapper disposed ;
  24
  25 MIXIN: c++-root
  26
  27 GENERIC: unmarshall-cast ( alien-wrapper -- alien-wrapper' )
  28
  29 M: alien-wrapper unmarshall-cast ;
  30 M: struct-wrapper unmarshall-cast ;
  31
  32 M: struct-wrapper dispose* underlying>> free ;
  33
  34 M: class-wrapper c++-type class name>> parse-c++-type ;
  35
  36 : marshall-pointer ( obj -- alien )
  37     {
  38         { [ dup alien? ] [ ] }
  39         { [ dup not ] [ ] }
  40         { [ dup byte-array? ] [ malloc-byte-array ] }
  41         { [ dup alien-wrapper? ] [ underlying>> ] }
  42         { [ dup struct-array? ] [ underlying>> ] }
  43     } cond ;
  44
  45 : marshall-primitive ( n -- n )
  46     [ bool>arg ] ptr-pass-through ;
  47
  48 ALIAS: marshall-void* marshall-pointer
  49
  50 : marshall-void** ( seq -- alien )
  51     [ marshall-void* ] void*-array{ } map-as malloc-underlying ;
  52
  53 : (marshall-char*-or-string) ( n/string -- alien )
  54     dup string?
  55     [ utf8 string>alien malloc-byte-array ]
  56     [ (marshall-char*) ] if ;
  57
  58 : marshall-char*-or-string ( n/string -- alien )
  59     [ (marshall-char*-or-string) ] ptr-pass-through ;
  60
  61 : (marshall-char**-or-strings) ( seq -- alien )
  62     [ marshall-char*-or-string ] void*-array{ } map-as
  63     malloc-underlying ;
  64
  65 : marshall-char**-or-strings ( seq -- alien )
  66     [ (marshall-char**-or-strings) ] ptr-pass-through ;
  67
  68 : marshall-bool ( ? -- n )
  69     >boolean [ 1 ] [ 0 ] if ;
  70
  71 : (marshall-bool*) ( ?/seq -- alien )
  72     [ marshall-bool <bool> malloc-byte-array ]
  73     [ >bool-array malloc-underlying ]
  74     marshall-x* ;
  75
  76 : marshall-bool* ( ?/seq -- alien )
  77     [ (marshall-bool*) ] ptr-pass-through ;
  78
  79 : (marshall-bool**) ( seq -- alien )
  80     [ marshall-bool* ] map >void*-array malloc-underlying ;
  81
  82 : marshall-bool** ( seq -- alien )
  83     [ (marshall-bool**) ] ptr-pass-through ;
  84
  85 : unmarshall-bool ( n -- ? )
  86     0 = not ;
  87
  88 : unmarshall-bool* ( alien -- ? )
  89     *bool unmarshall-bool ;
  90
  91 : unmarshall-bool*-free ( alien -- ? )
  92     [ *bool unmarshall-bool ] keep add-malloc free ;
  93
  94 : primitive-marshaller ( type -- quot/f )
  95     {
  96         { "bool"        [ [ ] ] }
  97         { "boolean"     [ [ marshall-bool ] ] }
  98         { "char"        [ [ marshall-primitive ] ] }
  99         { "uchar"       [ [ marshall-primitive ] ] }
 100         { "short"       [ [ marshall-primitive ] ] }
 101         { "ushort"      [ [ marshall-primitive ] ] }
 102         { "int"         [ [ marshall-primitive ] ] }
 103         { "uint"        [ [ marshall-primitive ] ] }
 104         { "long"        [ [ marshall-primitive ] ] }
 105         { "ulong"       [ [ marshall-primitive ] ] }
 106         { "long"        [ [ marshall-primitive ] ] }
 107         { "ulong"       [ [ marshall-primitive ] ] }
 108         { "float"       [ [ marshall-primitive ] ] }
 109         { "double"      [ [ marshall-primitive ] ] }
 110         { "bool*"       [ [ marshall-bool* ] ] }
 111         { "boolean*"    [ [ marshall-bool* ] ] }
 112         { "char*"       [ [ marshall-char*-or-string ] ] }
 113         { "uchar*"      [ [ marshall-uchar* ] ] }
 114         { "short*"      [ [ marshall-short* ] ] }
 115         { "ushort*"     [ [ marshall-ushort* ] ] }
 116         { "int*"        [ [ marshall-int* ] ] }
 117         { "uint*"       [ [ marshall-uint* ] ] }
 118         { "long*"       [ [ marshall-long* ] ] }
 119         { "ulong*"      [ [ marshall-ulong* ] ] }
 120         { "longlong*"   [ [ marshall-longlong* ] ] }
 121         { "ulonglong*"  [ [ marshall-ulonglong* ] ] }
 122         { "float*"      [ [ marshall-float* ] ] }
 123         { "double*"     [ [ marshall-double* ] ] }
 124         { "bool&"       [ [ marshall-bool* ] ] }
 125         { "boolean&"    [ [ marshall-bool* ] ] }
 126         { "char&"       [ [ marshall-char* ] ] }
 127         { "uchar&"      [ [ marshall-uchar* ] ] }
 128         { "short&"      [ [ marshall-short* ] ] }
 129         { "ushort&"     [ [ marshall-ushort* ] ] }
 130         { "int&"        [ [ marshall-int* ] ] }
 131         { "uint&"       [ [ marshall-uint* ] ] }
 132         { "long&"       [ [ marshall-long* ] ] }
 133         { "ulong&"      [ [ marshall-ulong* ] ] }
 134         { "longlong&"   [ [ marshall-longlong* ] ] }
 135         { "ulonglong&"  [ [ marshall-ulonglong* ] ] }
 136         { "float&"      [ [ marshall-float* ] ] }
 137         { "double&"     [ [ marshall-double* ] ] }
 138         { "void*"       [ [ marshall-void* ] ] }
 139         { "bool**"      [ [ marshall-bool** ] ] }
 140         { "boolean**"   [ [ marshall-bool** ] ] }
 141         { "char**"      [ [ marshall-char**-or-strings ] ] }
 142         { "uchar**"     [ [ marshall-uchar** ] ] }
 143         { "short**"     [ [ marshall-short** ] ] }
 144         { "ushort**"    [ [ marshall-ushort** ] ] }
 145         { "int**"       [ [ marshall-int** ] ] }
 146         { "uint**"      [ [ marshall-uint** ] ] }
 147         { "long**"      [ [ marshall-long** ] ] }
 148         { "ulong**"     [ [ marshall-ulong** ] ] }
 149         { "longlong**"  [ [ marshall-longlong** ] ] }
 150         { "ulonglong**" [ [ marshall-ulonglong** ] ] }
 151         { "float**"     [ [ marshall-float** ] ] }
 152         { "double**"    [ [ marshall-double** ] ] }
 153         { "void**"      [ [ marshall-void** ] ] }
 154         [ drop f ]
 155     } case ;
 156
 157 : marshall-non-pointer ( alien-wrapper/byte-array -- byte-array )
 158     {
 159         { [ dup byte-array? ] [ ] }
 160         { [ dup alien-wrapper? ]
 161           [ [ underlying>> ] [ class name>> heap-size ] bi
 162             memory>byte-array ] }
 163     } cond ;
 164
 165
 166 : marshaller ( type -- quot )
 167     factorize-type dup primitive-marshaller [ nip ] [
 168         pointer?
 169         [ [ marshall-pointer ] ]
 170         [ [ marshall-non-pointer ] ] if
 171     ] if* ;
 172
 173
 174 : unmarshall-char*-to-string ( alien -- string )
 175     utf8 alien>string ;
 176
 177 : unmarshall-char*-to-string-free ( alien -- string )
 178     [ unmarshall-char*-to-string ] keep add-malloc free ;
 179
 180 : primitive-unmarshaller ( type -- quot/f )
 181     {
 182         { "bool"       [ [ ] ] }
 183         { "boolean"    [ [ unmarshall-bool ] ] }
 184         { "char"       [ [ ] ] }
 185         { "uchar"      [ [ ] ] }
 186         { "short"      [ [ ] ] }
 187         { "ushort"     [ [ ] ] }
 188         { "int"        [ [ ] ] }
 189         { "uint"       [ [ ] ] }
 190         { "long"       [ [ ] ] }
 191         { "ulong"      [ [ ] ] }
 192         { "longlong"   [ [ ] ] }
 193         { "ulonglong"  [ [ ] ] }
 194         { "float"      [ [ ] ] }
 195         { "double"     [ [ ] ] }
 196         { "bool*"      [ [ unmarshall-bool*-free ] ] }
 197         { "boolean*"   [ [ unmarshall-bool*-free ] ] }
 198         { "char*"      [ [ ] ] }
 199         { "uchar*"     [ [ unmarshall-uchar*-free ] ] }
 200         { "short*"     [ [ unmarshall-short*-free ] ] }
 201         { "ushort*"    [ [ unmarshall-ushort*-free ] ] }
 202         { "int*"       [ [ unmarshall-int*-free ] ] }
 203         { "uint*"      [ [ unmarshall-uint*-free ] ] }
 204         { "long*"      [ [ unmarshall-long*-free ] ] }
 205         { "ulong*"     [ [ unmarshall-ulong*-free ] ] }
 206         { "longlong*"  [ [ unmarshall-long*-free ] ] }
 207         { "ulonglong*" [ [ unmarshall-ulong*-free ] ] }
 208         { "float*"     [ [ unmarshall-float*-free ] ] }
 209         { "double*"    [ [ unmarshall-double*-free ] ] }
 210         { "bool&"      [ [ unmarshall-bool*-free ] ] }
 211         { "boolean&"   [ [ unmarshall-bool*-free ] ] }
 212         { "char&"      [ [ ] ] }
 213         { "uchar&"     [ [ unmarshall-uchar*-free ] ] }
 214         { "short&"     [ [ unmarshall-short*-free ] ] }
 215         { "ushort&"    [ [ unmarshall-ushort*-free ] ] }
 216         { "int&"       [ [ unmarshall-int*-free ] ] }
 217         { "uint&"      [ [ unmarshall-uint*-free ] ] }
 218         { "long&"      [ [ unmarshall-long*-free ] ] }
 219         { "ulong&"     [ [ unmarshall-ulong*-free ] ] }
 220         { "longlong&"  [ [ unmarshall-longlong*-free ] ] }
 221         { "ulonglong&" [ [ unmarshall-ulonglong*-free ] ] }
 222         { "float&"     [ [ unmarshall-float*-free ] ] }
 223         { "double&"    [ [ unmarshall-double*-free ] ] }
 224         [ drop f ]
 225     } case ;
 226
 227 : struct-primitive-unmarshaller ( type -- quot/f )
 228     {
 229         { "bool"       [ [ unmarshall-bool ] ] }
 230         { "boolean"    [ [ unmarshall-bool ] ] }
 231         { "char"       [ [ ] ] }
 232         { "uchar"      [ [ ] ] }
 233         { "short"      [ [ ] ] }
 234         { "ushort"     [ [ ] ] }
 235         { "int"        [ [ ] ] }
 236         { "uint"       [ [ ] ] }
 237         { "long"       [ [ ] ] }
 238         { "ulong"      [ [ ] ] }
 239         { "longlong"   [ [ ] ] }
 240         { "ulonglong"  [ [ ] ] }
 241         { "float"      [ [ ] ] }
 242         { "double"     [ [ ] ] }
 243         { "bool*"      [ [ unmarshall-bool* ] ] }
 244         { "boolean*"   [ [ unmarshall-bool* ] ] }
 245         { "char*"      [ [ ] ] }
 246         { "uchar*"     [ [ unmarshall-uchar* ] ] }
 247         { "short*"     [ [ unmarshall-short* ] ] }
 248         { "ushort*"    [ [ unmarshall-ushort* ] ] }
 249         { "int*"       [ [ unmarshall-int* ] ] }
 250         { "uint*"      [ [ unmarshall-uint* ] ] }
 251         { "long*"      [ [ unmarshall-long* ] ] }
 252         { "ulong*"     [ [ unmarshall-ulong* ] ] }
 253         { "longlong*"  [ [ unmarshall-long* ] ] }
 254         { "ulonglong*" [ [ unmarshall-ulong* ] ] }
 255         { "float*"     [ [ unmarshall-float* ] ] }
 256         { "double*"    [ [ unmarshall-double* ] ] }
 257         { "bool&"      [ [ unmarshall-bool* ] ] }
 258         { "boolean&"   [ [ unmarshall-bool* ] ] }
 259         { "char&"      [ [ unmarshall-char* ] ] }
 260         { "uchar&"     [ [ unmarshall-uchar* ] ] }
 261         { "short&"     [ [ unmarshall-short* ] ] }
 262         { "ushort&"    [ [ unmarshall-ushort* ] ] }
 263         { "int&"       [ [ unmarshall-int* ] ] }
 264         { "uint&"      [ [ unmarshall-uint* ] ] }
 265         { "long&"      [ [ unmarshall-long* ] ] }
 266         { "ulong&"     [ [ unmarshall-ulong* ] ] }
 267         { "longlong&"  [ [ unmarshall-longlong* ] ] }
 268         { "ulonglong&" [ [ unmarshall-ulonglong* ] ] }
 269         { "float&"     [ [ unmarshall-float* ] ] }
 270         { "double&"    [ [ unmarshall-double* ] ] }
 271         [ drop f ]
 272     } case ;
 273
 274
 275 : ?malloc-byte-array ( c-type -- alien )
 276     dup alien? [ malloc-byte-array ] unless ;
 277
 278 :: x-unmarshaller ( type type-quot superclass def clean -- quot/f )
 279     type type-quot call current-vocab lookup [
 280         dup superclasses superclass swap member?
 281         [ def call ] [ drop clean call f ] if
 282     ] [ clean call f ] if* ; inline
 283
 284 : struct-unmarshaller ( type -- quot/f )
 285     [ ] \ struct-wrapper
 286     [ '[ ?malloc-byte-array _ new swap >>underlying ] ]
 287     [ ]
 288     x-unmarshaller ;
 289
 290 : class-unmarshaller ( type -- quot/f )
 291     [ type-sans-pointer "#" append ] \ class-wrapper
 292     [ '[ _ new swap >>underlying ] ]
 293     [ ]
 294     x-unmarshaller ;
 295
 296 : non-primitive-unmarshaller ( type -- quot/f )
 297     {
 298         { [ dup pointer? ] [ class-unmarshaller ] }
 299         [ struct-unmarshaller ]
 300     } cond ;
 301
 302 : unmarshaller ( type -- quot )
 303     factorize-type {
 304         [ primitive-unmarshaller ]
 305         [ non-primitive-unmarshaller ]
 306         [ drop [ ] ]
 307     } 1|| ;
 308
 309 : struct-field-unmarshaller ( type -- quot )
 310     factorize-type {
 311         [ struct-primitive-unmarshaller ]
 312         [ non-primitive-unmarshaller ]
 313         [ drop [ ] ]
 314     } 1|| ;
 315
 316 : out-arg-unmarshaller ( type -- quot )
 317     dup pointer-to-non-const-primitive?
 318     [ factorize-type primitive-unmarshaller ]
 319     [ drop [ drop ] ] if ;