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