extra/alien/data/map/map.factor

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