basis/specialized-vectors/specialized-vectors.factor

   1 ! Copyright (C) 2008, 2009 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: accessors alien.c-types assocs compiler.units functors
   4 growable io kernel lexer namespaces parser prettyprint.custom
   5 sequences specialized-arrays specialized-arrays.private strings
   6 vocabs vocabs.parser ;
   7 QUALIFIED: vectors.functor
   8 IN: specialized-vectors
   9
  10 <PRIVATE
  11
  12 FUNCTOR: define-vector ( T -- )
  13
  14 V   DEFINES-CLASS ${T}-vector
  15
  16 A   IS      ${T}-array
  17 S   IS      ${T}-sequence
  18 <A> IS      <${A}>
  19
  20 >V  DEFERS >${V}
  21 V{  DEFINES ${V}{
  22
  23 WHERE
  24
  25 V A <A> vectors.functor:define-vector
  26
  27 M: V contract 2drop ;
  28
  29 M: V byte-length underlying>> byte-length ;
  30
  31 M: V pprint-delims drop \ V{ \ } ;
  32
  33 M: V >pprint-sequence ;
  34
  35 M: V pprint* pprint-object ;
  36
  37 SYNTAX: V{ \ } [ >V ] parse-literal ;
  38
  39 INSTANCE: V growable
  40 INSTANCE: V S
  41
  42 ;FUNCTOR
  43
  44 : specialized-vector-vocab ( type -- vocab )
  45     "specialized-vectors.instances." prepend ;
  46
  47 : defining-vector-message ( type -- )
  48     "quiet" get [ drop ] [
  49         "Generating specialized " " vectors..." surround print
  50     ] if ;
  51
  52 PRIVATE>
  53
  54 : define-vector-vocab ( type  -- vocab )
  55     underlying-type
  56     dup specialized-vector-vocab vocab
  57     [ ] [
  58         [ defining-vector-message ]
  59         [
  60             [
  61                 dup specialized-vector-vocab
  62                 [ define-vector ] with-current-vocab
  63             ] with-compilation-unit
  64         ]
  65         [ specialized-vector-vocab ]
  66         tri
  67     ] ?if ;
  68
  69 SYNTAX: SPECIALIZED-VECTOR:
  70     scan
  71     [ define-array-vocab use-vocab ]
  72     [ define-vector-vocab use-vocab ] bi ;