extra/alien/data/map/map.factor

   1 ! (c)Joe Groff bsd license
   2 USING: accessors alien alien.c-types alien.data alien.parser arrays
   3 byte-arrays combinators effects.parser fry generalizations grouping kernel
   4 lexer locals macros make math math.ranges parser sequences
   5 sequences.generalizations sequences.private ;
   6 FROM: alien.arrays => array-length ;
   7 IN: alien.data.map
   8
   9 <PRIVATE
  10
  11 : <displaced-direct-array> ( displacement bytes length type -- direct-array )
  12     [ <displaced-alien> ] 2dip <c-direct-array> ; inline
  13
  14 TUPLE: data-map-param
  15     { c-type read-only }
  16     { count fixnum read-only }
  17     { orig read-only }
  18     { bytes c-ptr read-only }
  19     { byte-length fixnum read-only }
  20     { iter-length fixnum read-only }
  21     { iter-count fixnum read-only } ;
  22
  23 M: data-map-param length
  24     iter-count>> ; inline
  25
  26 M: data-map-param nth-unsafe
  27     {
  28         [ iter-length>> * >fixnum ]
  29         [ bytes>> ]
  30         [ count>> ]
  31         [ c-type>> ]
  32     } cleave <displaced-direct-array> ; inline
  33
  34 INSTANCE: data-map-param immutable-sequence
  35
  36 : c-type-count ( in/out -- c-type count )
  37     dup array? [ unclip swap array-length >fixnum ] [ 1 ] if ; inline
  38
  39 : c-type-iter-length ( c-type count -- iter-length )
  40     swap heap-size * >fixnum ; inline
  41
  42 : [>c-type-param] ( c-type count -- quot )
  43     2dup c-type-iter-length '[
  44         [ _ _ ] dip
  45         [ ]
  46         [ >c-ptr ]
  47         [ byte-length ] tri
  48         _
  49         2dup /i
  50         data-map-param boa
  51     ] ;
  52
  53 : [>object-param] ( class count -- quot )
  54     nip '[ _ <sliced-groups> ] ;
  55
  56 : [>param] ( type -- quot )
  57     c-type-count over c-type-name?
  58     [ [>c-type-param] ] [ [>object-param] ] if ;
  59
  60 MACRO: >param ( in -- quot: ( array -- param ) )
  61     [>param] ;
  62
  63 : [alloc-c-type-param] ( c-type count -- quot )
  64     2dup c-type-iter-length dup '[
  65         [ _ _ ] dip
  66         [
  67             _ * >fixnum [ (byte-array) dup ] keep
  68             _
  69         ] keep
  70         data-map-param boa
  71     ] ;
  72
  73 : [alloc-object-param] ( type count -- quot )
  74     "Factor sequences as data-map outputs not supported" throw ;
  75
  76 : [alloc-param] ( type -- quot )
  77     c-type-count over c-type-name?
  78     [ [alloc-c-type-param] ] [ [alloc-object-param] ] if ;
  79
  80 MACRO: alloc-param ( out -- quot: ( len -- param ) )
  81     [alloc-param] ;
  82
  83 MACRO: unpack-params ( ins -- )
  84     [ c-type-count nip '[ _ firstn-unsafe ] ] map '[ _ spread ] ;
  85
  86 MACRO: pack-params ( outs -- )
  87     [ ] [ c-type-count nip dup [ [ ndip _ ] dip set-firstn ] 3curry ] reduce
  88     fry [ call ] compose ;
  89
  90 :: [data-map] ( ins outs param-quot -- quot )
  91     ins length :> #ins
  92     outs length :> #outs
  93     #ins #outs + :> #params
  94
  95     [
  96         param-quot %
  97         [
  98             [
  99                 [ ins , \ unpack-params , \ @ , ] [ ] make ,
 100                 #outs , \ ndip , outs , \ pack-params ,
 101             ] [ ] make ,
 102             #params , \ neach ,
 103         ] [ ] make , #outs , \ nkeep ,
 104         [ orig>> ] , #outs , \ napply ,
 105     ] [ ] make fry \ call suffix ;
 106
 107 MACRO: data-map ( ins outs -- )
 108     2dup
 109     [
 110         [ [ '[ _ >param ] ] map '[ _ spread ] ]
 111         [ length dup '[ _ ndup _ nmin-length ] compose ] bi
 112     ]
 113     [ [ '[ _ alloc-param ] ] map '[ _ cleave ] ] bi* compose
 114     [data-map] ;
 115
 116 MACRO: data-map! ( ins outs -- )
 117     2dup append [ '[ _ >param ] ] map '[ _ spread ] [data-map] ;
 118
 119 : parse-data-map-effect ( accum -- accum )
 120     ")" parse-effect
 121     [ in>>  [ (parse-c-type) ] map suffix! ]
 122     [ out>> [ (parse-c-type) ] map suffix! ] bi ;
 123
 124 PRIVATE>
 125
 126 SYNTAX: data-map(
 127     parse-data-map-effect \ data-map suffix! ;
 128
 129 SYNTAX: data-map!(
 130     parse-data-map-effect \ data-map! suffix! ;
 131