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