extra/classes/struct/vectored/vectored.factor

   1 ! (c)2009 Joe Groff bsd license
   2 USING: accessors classes.struct classes.tuple combinators fry
   3 functors kernel locals macros math parser quotations sequences
   4 sequences.private slots specialized-arrays words ;
   5 IN: classes.struct.vectored
   6
   7 <PRIVATE
   8
   9 : array-class-of ( type -- array-type )
  10     [ define-array-vocab ] [ name>> "-array" append swap lookup-word ] bi ;
  11 : <array-class>-of ( type -- array-type )
  12     [ define-array-vocab ] [ name>> "<" "-array>" surround swap lookup-word ] bi ;
  13 : (array-class)-of ( type -- array-type )
  14     [ define-array-vocab ] [ name>> "(" "-array)" surround swap lookup-word ] bi ;
  15
  16 : >vectored-slot ( struct-slot offset -- tuple-slot )
  17     {
  18         [ drop name>> ]
  19         [ nip ]
  20         [ drop type>> array-class-of dup initial-value drop ]
  21         [ 2drop t ]
  22     } 2cleave slot-spec boa ;
  23
  24 MACRO: first-slot ( struct-class -- quot: ( struct -- value ) )
  25     struct-slots first name>> reader-word 1quotation ;
  26
  27 MACRO: set-vectored-nth ( struct-class -- quot: ( value i vector -- ) )
  28     struct-slots [
  29         name>> reader-word 1quotation dup
  30         '[ _ [ ] _ tri* set-nth-unsafe ]
  31     ] map '[ _ 3cleave ] ;
  32
  33 MACRO: <vectored-slots> ( struct-class -- quot: ( n -- slots... ) )
  34     struct-slots [ type>> <array-class>-of 1quotation ] map
  35     '[ _ cleave ] ;
  36
  37 MACRO: (vectored-slots) ( struct-class -- quot: ( n -- slots... ) )
  38     struct-slots [ type>> (array-class)-of 1quotation ] map
  39     '[ _ cleave ] ;
  40
  41 MACRO: (vectored-element>) ( struct-class -- quot: ( elt -- struct ) )
  42     [ struct-slots [ name>> reader-word 1quotation ] map ] keep
  43     '[ _ cleave _ <struct-boa> ] ;
  44
  45 SLOT: (n)
  46 SLOT: (vectored)
  47
  48 FUNCTOR: define-vectored-accessors ( S>> S<< T -- )
  49
  50 WHERE
  51
  52 M: T S>>
  53     [ (n)>> ] [ (vectored)>> S>> ] bi nth-unsafe ; inline
  54 M: T S<<
  55     [ (n)>> ] [ (vectored)>> S>> ] bi set-nth-unsafe ; inline
  56
  57 ;FUNCTOR
  58
  59 PRIVATE>
  60
  61 GENERIC: struct-transpose ( structstruct -- ssttrruucctt )
  62 GENERIC: vectored-element> ( elt -- struct )
  63
  64 FUNCTOR: define-vectored-struct ( T -- )
  65
  66 T-array [ T array-class-of ]
  67
  68 vectored-T         DEFINES-CLASS vectored-${T}
  69 vectored-T-element DEFINES-CLASS vectored-${T}-element
  70
  71 <vectored-T>       DEFINES <vectored-${T}>
  72 (vectored-T)       DEFINES (vectored-${T})
  73
  74 WHERE
  75
  76 vectored-T tuple T struct-slots [ >vectored-slot ] map-index define-tuple-class
  77
  78 TUPLE: vectored-T-element
  79     { (n)        fixnum     read-only }
  80     { (vectored) vectored-T read-only } ;
  81
  82 T struct-slots [
  83     name>> [ reader-word ] [ writer-word ] bi
  84     vectored-T-element define-vectored-accessors
  85 ] each
  86
  87 M: vectored-T-element vectored-element>
  88     T (vectored-element>) ; inline
  89
  90 M: vectored-T nth-unsafe
  91     vectored-T-element boa ; inline
  92
  93 M: vectored-T length
  94     T first-slot length ; inline
  95
  96 M: vectored-T set-nth-unsafe
  97     T set-vectored-nth ; inline
  98
  99 INSTANCE: vectored-T sequence
 100
 101 : <vectored-T> ( n -- vectored-T )
 102     T <vectored-slots> vectored-T boa ; inline
 103
 104 : (vectored-T) ( n -- vectored-T )
 105     T (vectored-slots) vectored-T boa ; inline
 106
 107 M: vectored-T struct-transpose
 108     [ vectored-element> ] T-array new map-as ; inline
 109
 110 M: T-array struct-transpose
 111     dup length [ nip <iota> ] [ drop ] [ nip (vectored-T) ] 2tri
 112     [ [ [ nth ] [ set-nth ] bi-curry* bi ] 2curry each ] keep ; inline
 113
 114 ;FUNCTOR
 115
 116 SYNTAX: VECTORED-STRUCT:
 117     scan-word define-vectored-struct ;