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