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.c-types alien.data alien.parser arrays
   4 byte-arrays combinators effects.parser fry generalizations grouping kernel
   5 lexer locals macros make math math.ranges parser 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 [ [ ndip _ ] dip set-firstn ] 3curry ] reduce
  89     fry [ call ] compose ;
  90
  91 :: [data-map] ( ins outs param-quot -- quot )
  92     ins length :> #ins
  93     outs length :> #outs
  94     #ins #outs + :> #params
  95
  96     [
  97         param-quot %
  98         [
  99             [
 100                 [ ins , \ unpack-params , \ @ , ] [ ] make ,
 101                 #outs , \ ndip , outs , \ pack-params ,
 102             ] [ ] make ,
 103             #params , \ neach ,
 104         ] [ ] make , #outs , \ nkeep ,
 105         [ orig>> ] , #outs , \ napply ,
 106     ] [ ] make fry \ call suffix ;
 107
 108 MACRO: data-map ( ins outs -- quot )
 109     2dup
 110     [
 111         [ [ '[ _ >param ] ] map '[ _ spread ] ]
 112         [ length dup '[ _ ndup _ nmin-length ] compose ] bi
 113     ]
 114     [ [ '[ _ alloc-param ] ] map '[ _ cleave ] ] bi* compose
 115     [data-map] ;
 116
 117 MACRO: data-map! ( ins outs -- quot )
 118     2dup append [ '[ _ >param ] ] map '[ _ spread ] [data-map] ;
 119
 120 : parse-data-map-effect ( accum -- accum )
 121     ")" parse-effect
 122     [ in>>  [ (parse-c-type) ] map suffix! ]
 123     [ out>> [ (parse-c-type) ] map suffix! ] bi ;
 124
 125 PRIVATE>
 126
 127 SYNTAX: data-map(
 128     parse-data-map-effect \ data-map suffix! ;
 129
 130 SYNTAX: data-map!(
 131     parse-data-map-effect \ data-map! suffix! ;