basis/specialized-vectors/specialized-vectors.factor

   1 ! Copyright (C) 2008, 2010 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: accessors alien alien.c-types alien.data alien.parser
   4 classes fry functors growable kernel lexer make math parser
   5 prettyprint.custom sequences specialized-arrays vocabs.generated
   6 vocabs.loader vocabs.parser ;
   7 FROM: sequences.private => nth-unsafe ;
   8 FROM: specialized-arrays.private => nth-c-ptr direct-like ;
   9 QUALIFIED: vectors.functor
  10 IN: specialized-vectors
  11
  12 MIXIN: specialized-vector
  13
  14 <PRIVATE
  15
  16 <FUNCTOR: define-vector ( T -- )
  17
  18 V DEFINES-CLASS ${T}-vector
  19
  20 A          IS ${T}-array
  21 <A>        IS <${A}>
  22 <direct-A> IS <direct-${A}>
  23
  24 >V DEFERS >${V}
  25 V{ DEFINES ${V}{
  26
  27 WHERE
  28
  29 V A <A> vectors.functor:define-vector
  30
  31 M: V contract 2drop ; inline
  32
  33 M: V element-size drop \ T heap-size ; inline
  34
  35 M: V pprint-delims drop \ V{ \ } ;
  36
  37 M: V >pprint-sequence ;
  38
  39 M: V pprint* pprint-object ;
  40
  41 M: V >c-ptr underlying>> underlying>> ; inline
  42 M: V byte-length [ length ] [ element-size ] bi * ; inline
  43
  44 M: V direct-like drop <direct-A> ; inline
  45 M: V nth-c-ptr underlying>> nth-c-ptr ; inline
  46
  47 M: A like
  48     drop dup A instance? [
  49         dup V instance? [
  50             [ >c-ptr ] [ length>> ] bi <direct-A>
  51         ] [ \ T >c-array ] if
  52     ] unless ; inline
  53
  54 SYNTAX: V{ \ } [ >V ] parse-literal ;
  55
  56 INSTANCE: V specialized-vector
  57 INSTANCE: V growable
  58
  59 ;FUNCTOR>
  60
  61 : specialized-vector-vocab ( c-type -- vocab )
  62     [
  63         "specialized-vectors.instances." %
  64         [ vocabulary>> % "." % ]
  65         [ name>> % ]
  66         bi
  67     ] "" make ;
  68
  69 PRIVATE>
  70
  71 : push-new ( vector -- new )
  72     [ length ] keep ensure nth-unsafe ; inline
  73
  74 : define-vector-vocab ( type -- vocab )
  75     underlying-type
  76     [ specialized-vector-vocab ] [ '[ _ define-vector ] ] bi
  77     generate-vocab ;
  78
  79 SYNTAX: SPECIALIZED-VECTORS:
  80     ";" [
  81         parse-c-type
  82         [ define-array-vocab use-vocab ]
  83         [ define-vector-vocab use-vocab ] bi
  84     ] each-token ;
  85
  86 SYNTAX: SPECIALIZED-VECTOR:
  87     scan-c-type
  88     [ define-array-vocab use-vocab ]
  89     [ define-vector-vocab use-vocab ] bi ;
  90
  91 { "specialized-vectors" "mirrors" } "specialized-vectors.mirrors" require-when