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 kernel
   4 lexer locals macros make math math.ranges parser sequences sequences.private ;
   5 IN: alien.data.map
   6
   7 ERROR: bad-data-map-input-length byte-length iter-size remainder ;
   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 ERROR: bad-data-map-param param remainder ;
  24
  25 M: data-map-param length
  26     iter-count>> ; inline
  27
  28 M: data-map-param nth-unsafe
  29     {
  30         [ iter-length>> * >fixnum ]
  31         [ bytes>> ]
  32         [ count>> ]
  33         [ c-type>> ]
  34     } cleave <displaced-direct-array> ; inline
  35
  36 INSTANCE: data-map-param immutable-sequence
  37
  38 : c-type-count ( in/out -- c-type count iter-length )
  39     dup array? [ unclip swap product >fixnum ] [ 1 ] if
  40     2dup swap heap-size * >fixnum ; inline
  41
  42 MACRO: >param ( in -- quot: ( array -- param ) )
  43     c-type-count '[
  44         [ _ _ ] dip
  45         [ ]
  46         [ >c-ptr ]
  47         [ byte-length ] tri
  48         _
  49         2dup /i
  50         data-map-param boa
  51     ] ;
  52
  53 MACRO: alloc-param ( out -- quot: ( len -- param ) )
  54     c-type-count dup '[
  55         [ _ _ ] dip
  56         [
  57             _ * >fixnum [ (byte-array) dup ] keep
  58             _
  59         ] keep
  60         data-map-param boa
  61     ] ;
  62
  63 MACRO: unpack-params ( ins -- )
  64     [ c-type-count drop nip '[ _ firstn-unsafe ] ] map '[ _ spread ] ;
  65
  66 MACRO: pack-params ( outs -- )
  67     [ ] [ c-type-count drop nip dup [ [ ndip _ ] dip set-firstn ] 3curry ] reduce
  68     fry [ call ] compose ;
  69
  70 :: [data-map] ( ins outs param-quot -- quot )
  71     ins length :> #ins
  72     outs length :> #outs
  73     #ins #outs + :> #params
  74
  75     [
  76         param-quot %
  77         [
  78             [
  79                 [ ins , \ unpack-params , \ @ , ] [ ] make ,
  80                 #outs , \ ndip , outs , \ pack-params ,
  81             ] [ ] make ,
  82             #params , \ neach ,
  83         ] [ ] make , #outs , \ nkeep ,
  84         [ orig>> ] , #outs , \ napply ,
  85     ] [ ] make fry \ call suffix ;
  86
  87 MACRO: data-map ( ins outs -- )
  88     2dup
  89     [
  90         [ [ '[ _ >param ] ] map '[ _ spread ] ]
  91         [ length dup '[ _ ndup _ nmin-length ] compose ] bi
  92     ]
  93     [ [ '[ _ alloc-param ] ] map '[ _ cleave ] ] bi* compose
  94     [data-map] ;
  95
  96 MACRO: data-map! ( ins outs -- )
  97     2dup append [ '[ _ >param ] ] map '[ _ spread ] [data-map] ;
  98
  99 : parse-data-map-effect ( accum -- accum )
 100     ")" parse-effect
 101     [ in>>  [ parse-c-type ] map parsed ]
 102     [ out>> [ parse-c-type ] map parsed ] bi ;
 103
 104 PRIVATE>
 105
 106 SYNTAX: data-map(
 107     parse-data-map-effect \ data-map parsed ;
 108
 109 SYNTAX: data-map!(
 110     parse-data-map-effect \ data-map! parsed ;
 111