basis/tuple-arrays/tuple-arrays.factor

   1 ! Copyright (C) 2009, 2010 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: accessors arrays combinators.smart fry functors kernel
   4 kernel.private macros sequences combinators sequences.private
   5 stack-checker parser math classes.tuple classes.tuple.private ;
   6 FROM: inverse => undo ;
   7 IN: tuple-arrays
   8
   9 ERROR: not-final class ;
  10
  11 <PRIVATE
  12
  13 MACRO: boa-unsafe ( class -- quot ) tuple-layout '[ _ <tuple-boa> ] ;
  14
  15 : tuple-arity ( class -- quot ) '[ _ boa ] inputs ; inline
  16
  17 : smart-tuple>array ( tuple class -- array )
  18     '[ [ _ boa ] undo ] output>array ; inline
  19
  20 : tuple-prototype ( class -- array )
  21     [ new ] [ smart-tuple>array ] bi ; inline
  22
  23 : tuple-slice ( n seq -- slice )
  24     [ n>> [ * dup ] keep + ] [ seq>> ] bi <slice-unsafe> ; inline
  25
  26 : read-tuple ( slice class -- tuple )
  27     '[ _ boa-unsafe ] input<sequence-unsafe ; inline
  28
  29 MACRO: write-tuple ( class -- quot )
  30     [ '[ [ _ boa ] undo ] ]
  31     [ tuple-arity iota <reversed> [ '[ [ _ ] dip set-nth-unsafe ] ] map '[ _ cleave ] ]
  32     bi '[ _ dip @ ] ;
  33
  34 : check-final ( class -- )
  35     {
  36         { [ dup tuple-class? not ] [ not-a-tuple ] }
  37         { [ dup final-class? not ] [ not-final ] }
  38         [ drop ]
  39     } cond ;
  40
  41 PRIVATE>
  42
  43 FUNCTOR: define-tuple-array ( CLASS -- )
  44
  45 CLASS IS ${CLASS}
  46
  47 CLASS-array DEFINES-CLASS ${CLASS}-array
  48 CLASS-array? IS ${CLASS-array}?
  49
  50 <CLASS-array> DEFINES <${CLASS}-array>
  51 >CLASS-array DEFINES >${CLASS}-array
  52
  53 WHERE
  54
  55 CLASS check-final
  56
  57 TUPLE: CLASS-array
  58 { seq array read-only }
  59 { n array-capacity read-only }
  60 { length array-capacity read-only } ;
  61
  62 : <CLASS-array> ( length -- tuple-array )
  63     [ \ CLASS [ tuple-prototype <repetition> concat ] [ tuple-arity ] bi ] keep
  64     \ CLASS-array boa ; inline
  65
  66 M: CLASS-array length length>> ; inline
  67
  68 M: CLASS-array nth-unsafe tuple-slice \ CLASS read-tuple ; inline
  69
  70 M: CLASS-array set-nth-unsafe tuple-slice \ CLASS write-tuple ; inline
  71
  72 M: CLASS-array new-sequence drop <CLASS-array> ; inline
  73
  74 : >CLASS-array ( seq -- tuple-array ) 0 <CLASS-array> clone-like ;
  75
  76 M: CLASS-array like drop dup CLASS-array? [ >CLASS-array ] unless ; inline
  77
  78 INSTANCE: CLASS-array sequence
  79
  80 ;FUNCTOR
  81
  82 SYNTAX: TUPLE-ARRAY: scan-word define-tuple-array ;