unmaintained/alien/marshall/private/private.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 arrays
   4 combinators fry functors kernel lexer libc macros math
   5 sequences specialized-arrays libc.private
   6 combinators.short-circuit alien.data ;
   7 SPECIALIZED-ARRAY: void*
   8 IN: alien.marshall.private
   9
  10 : bool>arg ( ? -- 1/0/obj )
  11     {
  12         { t [ 1 ] }
  13         { f [ 0 ] }
  14         [ ]
  15     } case ;
  16
  17 MACRO: marshall-x* ( num-quot seq-quot -- alien )
  18     '[ bool>arg dup number? _ _ if ] ;
  19
  20 : ptr-pass-through ( obj quot -- alien )
  21     over { [ c-ptr? ] [ ] } 1&& [ drop ] [ call ] if ; inline
  22
  23 : malloc-underlying ( obj -- alien )
  24     underlying>> malloc-byte-array ;
  25
  26 FUNCTOR: define-primitive-marshallers ( TYPE -- )
  27 <TYPE> IS <${TYPE}>
  28 *TYPE IS *${TYPE}
  29 >TYPE-array IS >${TYPE}-array
  30 marshall-TYPE DEFINES marshall-${TYPE}
  31 (marshall-TYPE*) DEFINES (marshall-${TYPE}*)
  32 (marshall-TYPE**) DEFINES (marshall-${TYPE}**)
  33 marshall-TYPE* DEFINES marshall-${TYPE}*
  34 marshall-TYPE** DEFINES marshall-${TYPE}**
  35 marshall-TYPE*-free DEFINES marshall-${TYPE}*-free
  36 marshall-TYPE**-free DEFINES marshall-${TYPE}**-free
  37 unmarshall-TYPE* DEFINES unmarshall-${TYPE}*
  38 unmarshall-TYPE*-free DEFINES unmarshall-${TYPE}*-free
  39 WHERE
  40 <PRIVATE
  41 : (marshall-TYPE*) ( n/seq -- alien )
  42     [ <TYPE> malloc-byte-array ]
  43     [ >TYPE-array malloc-underlying ]
  44     marshall-x* ;
  45 PRIVATE>
  46 : marshall-TYPE* ( n/seq -- alien )
  47     [ (marshall-TYPE*) ] ptr-pass-through ;
  48 <PRIVATE
  49 : (marshall-TYPE**) ( seq -- alien )
  50     [ marshall-TYPE* ] void*-array{ } map-as malloc-underlying ;
  51 PRIVATE>
  52 : marshall-TYPE** ( seq -- alien )
  53     [ (marshall-TYPE**) ] ptr-pass-through ;
  54 : unmarshall-TYPE* ( alien -- n )
  55     *TYPE ; inline
  56 : unmarshall-TYPE*-free ( alien -- n )
  57     [ unmarshall-TYPE* ] keep add-malloc free ;
  58 ;FUNCTOR
  59
  60 SYNTAX: PRIMITIVE-MARSHALLERS:
  61 ";" parse-tokens [ define-primitive-marshallers ] each ;