basis/classes/struct/struct.factor

   1 ! (c)Joe Groff bsd license
   2 USING: accessors alien alien.c-types alien.structs
   3 alien.structs.fields arrays byte-arrays classes classes.parser
   4 classes.tuple classes.tuple.parser classes.tuple.private
   5 combinators combinators.short-circuit combinators.smart
   6 definitions functors.backend fry generalizations generic.parser
   7 kernel kernel.private lexer libc locals macros make math math.order
   8 parser quotations sequences slots slots.private struct-arrays vectors
   9 words compiler.tree.propagation.transforms specialized-arrays.uchar ;
  10 FROM: slots => reader-word writer-word ;
  11 IN: classes.struct
  12
  13 ! struct class
  14
  15 ERROR: struct-must-have-slots ;
  16
  17 TUPLE: struct
  18     { (underlying) c-ptr read-only } ;
  19
  20 TUPLE: struct-slot-spec < slot-spec
  21     c-type ;
  22
  23 PREDICATE: struct-class < tuple-class \ struct subclass-of? ;
  24
  25 : struct-slots ( struct-class -- slots )
  26     "struct-slots" word-prop ;
  27
  28 ! struct allocation
  29
  30 M: struct >c-ptr
  31     2 slot { c-ptr } declare ; inline
  32
  33 M: struct equal?
  34     {
  35         [ [ class ] bi@ = ]
  36         [ [ >c-ptr ] [ [ >c-ptr ] [ byte-length ] bi ] bi* memory= ]
  37     } 2&& ; inline
  38
  39 M: struct hashcode*
  40     [ >c-ptr ] [ byte-length ] bi <direct-uchar-array> hashcode* ; inline
  41
  42 : struct-prototype ( class -- prototype ) "prototype" word-prop ; foldable
  43
  44 : memory>struct ( ptr class -- struct )
  45     [ 1array ] dip slots>tuple ;
  46
  47 \ memory>struct [
  48     dup struct-class? [ '[ _ boa ] ] [ drop f ] if
  49 ] 1 define-partial-eval
  50
  51 <PRIVATE
  52 : (init-struct) ( class with-prototype: ( prototype -- alien ) sans-prototype: ( class -- alien ) -- alien )
  53     '[ dup struct-prototype _ _ ?if ] keep memory>struct ; inline
  54 PRIVATE>
  55
  56 : (malloc-struct) ( class -- struct )
  57     [ heap-size malloc ] keep memory>struct ; inline
  58
  59 : malloc-struct ( class -- struct )
  60     [ >c-ptr malloc-byte-array ] [ 1 swap heap-size calloc ] (init-struct) ; inline
  61
  62 : (struct) ( class -- struct )
  63     [ heap-size (byte-array) ] keep memory>struct ; inline
  64
  65 : <struct> ( class -- struct )
  66     [ >c-ptr clone ] [ heap-size <byte-array> ] (init-struct) ; inline
  67
  68 MACRO: <struct-boa> ( class -- quot: ( ... -- struct ) )
  69     [
  70         [ <wrapper> \ (struct) [ ] 2sequence ]
  71         [
  72             struct-slots
  73             [ length \ ndip ]
  74             [ [ name>> setter-word 1quotation ] map \ spread ] bi
  75         ] bi
  76     ] [ ] output>sequence ;
  77
  78 <PRIVATE
  79 : pad-struct-slots ( values class -- values' class )
  80     [ struct-slots [ initial>> ] map over length tail append ] keep ;
  81
  82 : (reader-quot) ( slot -- quot )
  83     [ c-type>> c-type-getter-boxer ]
  84     [ offset>> [ >c-ptr ] swap suffix ] bi prepend ;
  85
  86 : (writer-quot) ( slot -- quot )
  87     [ c-type>> c-setter ]
  88     [ offset>> [ >c-ptr ] swap suffix ] bi prepend ;
  89
  90 : (boxer-quot) ( class -- quot )
  91     '[ _ memory>struct ] ;
  92
  93 : (unboxer-quot) ( class -- quot )
  94     drop [ >c-ptr ] ;
  95 PRIVATE>
  96
  97 M: struct-class boa>object
  98     swap pad-struct-slots
  99     [ <struct> ] [ struct-slots ] bi
 100     [ [ (writer-quot) call( value struct -- ) ] with 2each ] curry keep ;
 101
 102 ! Struct slot accessors
 103
 104 GENERIC: struct-slot-values ( struct -- sequence )
 105
 106 M: struct-class reader-quot
 107     nip (reader-quot) ;
 108
 109 M: struct-class writer-quot
 110     nip (writer-quot) ;
 111
 112 ! c-types
 113
 114 <PRIVATE
 115 : struct-slot-values-quot ( class -- quot )
 116     struct-slots
 117     [ name>> reader-word 1quotation ] map
 118     \ cleave [ ] 2sequence
 119     \ output>array [ ] 2sequence ;
 120
 121 : define-inline-method ( class generic quot -- )
 122     [ create-method-in ] dip [ define ] [ drop make-inline ] 2bi ;
 123
 124 : (define-struct-slot-values-method) ( class -- )
 125     [ \ struct-slot-values ] [ struct-slot-values-quot ] bi
 126     define-inline-method ;
 127
 128 : clone-underlying ( struct -- byte-array )
 129     [ >c-ptr ] [ byte-length ] bi memory>byte-array ; inline
 130
 131 : (define-clone-method) ( class -- )
 132     [ \ clone ]
 133     [ \ clone-underlying swap literalize \ memory>struct [ ] 3sequence ] bi
 134     define-inline-method ;
 135
 136 : slot>field ( slot -- field )
 137     field-spec new swap {
 138         [ name>> >>name ]
 139         [ offset>> >>offset ]
 140         [ c-type>> >>type ]
 141         [ name>> reader-word >>reader ]
 142         [ name>> writer-word >>writer ]
 143     } cleave ;
 144
 145 : define-struct-for-class ( class -- )
 146     [
 147         {
 148             [ name>> ]
 149             [ "struct-size" word-prop ]
 150             [ "struct-align" word-prop ]
 151             [ struct-slots [ slot>field ] map ]
 152         } cleave
 153         struct-type (define-struct)
 154     ] [
 155         {
 156             [ name>> c-type ]
 157             [ (unboxer-quot) >>unboxer-quot ]
 158             [ (boxer-quot) >>boxer-quot ]
 159             [ >>boxed-class ]
 160         } cleave drop
 161     ] bi ;
 162
 163 : align-offset ( offset class -- offset' )
 164     c-type-align align ;
 165
 166 : struct-offsets ( slots -- size )
 167     0 [
 168         [ c-type>> align-offset ] keep
 169         [ (>>offset) ] [ c-type>> heap-size + ] 2bi
 170     ] reduce ;
 171
 172 : union-struct-offsets ( slots -- size )
 173     [ 0 >>offset c-type>> heap-size ] [ max ] map-reduce ;
 174
 175 : struct-align ( slots -- align )
 176     [ c-type>> c-type-align ] [ max ] map-reduce ;
 177 PRIVATE>
 178
 179 M: struct-class c-type
 180     name>> c-type ;
 181
 182 M: struct-class c-type-align
 183     "struct-align" word-prop ;
 184
 185 M: struct-class c-type-getter
 186     drop [ swap <displaced-alien> ] ;
 187
 188 M: struct-class c-type-setter
 189     [ c-type-getter ] [ c-type-unboxer-quot ] [ heap-size ] tri
 190     '[ @ swap @ _ memcpy ] ;
 191
 192 M: struct-class c-type-boxer-quot
 193     (boxer-quot) ;
 194
 195 M: struct-class c-type-unboxer-quot
 196     (unboxer-quot) ;
 197
 198 M: struct-class heap-size
 199     "struct-size" word-prop ;
 200
 201 M: struct byte-length
 202     class "struct-size" word-prop ; foldable
 203
 204 ! class definition
 205
 206 <PRIVATE
 207 : make-struct-prototype ( class -- prototype )
 208     [ heap-size <byte-array> ]
 209     [ memory>struct ]
 210     [ struct-slots ] tri
 211     [
 212         [ initial>> ]
 213         [ (writer-quot) ] bi
 214         over [ swapd [ call( value struct -- ) ] curry keep ] [ 2drop ] if
 215     ] each ;
 216
 217 : (struct-methods) ( class -- )
 218     [ (define-struct-slot-values-method) ]
 219     [ (define-clone-method) ]
 220     bi ;
 221
 222 : (struct-word-props) ( class slots size align -- )
 223     [
 224         [ "struct-slots" set-word-prop ]
 225         [ define-accessors ] 2bi
 226     ]
 227     [ "struct-size" set-word-prop ]
 228     [ "struct-align" set-word-prop ] tri-curry*
 229     [ tri ] 3curry
 230     [ dup make-struct-prototype "prototype" set-word-prop ]
 231     [ (struct-methods) ] tri ;
 232
 233 : check-struct-slots ( slots -- )
 234     [ c-type>> c-type drop ] each ;
 235
 236 : redefine-struct-tuple-class ( class -- )
 237     [ dup class? [ forget-class ] [ drop ] if ] [ struct f define-tuple-class ] bi ;
 238
 239 : (define-struct-class) ( class slots offsets-quot -- )
 240     [
 241         [ struct-must-have-slots ]
 242         [ drop redefine-struct-tuple-class ] if-empty
 243     ]
 244     swap '[
 245         make-slots dup
 246         [ check-struct-slots ] _ [ struct-align [ align ] keep ] tri
 247         (struct-word-props)
 248     ]
 249     [ drop define-struct-for-class ] 2tri ; inline
 250 PRIVATE>
 251
 252 : define-struct-class ( class slots -- )
 253     [ struct-offsets ] (define-struct-class) ;
 254
 255 : define-union-struct-class ( class slots -- )
 256     [ union-struct-offsets ] (define-struct-class) ;
 257
 258 ERROR: invalid-struct-slot token ;
 259
 260 : struct-slot-class ( c-type -- class' )
 261     c-type c-type-boxed-class
 262     dup \ byte-array = [ drop \ c-ptr ] when ;
 263
 264 : <struct-slot-spec> ( name c-type attributes -- slot-spec )
 265     [ struct-slot-spec new ] 3dip
 266     [ >>name ]
 267     [ [ >>c-type ] [ struct-slot-class >>class ] bi ]
 268     [ [ dup empty? ] [ peel-off-attributes ] until drop ] tri* ;
 269
 270 <PRIVATE
 271 : scan-c-type ( -- c-type )
 272     scan dup "{" = [ drop \ } parse-until >array ] when ;
 273
 274 : parse-struct-slot ( -- slot )
 275     scan scan-c-type \ } parse-until <struct-slot-spec> ;
 276
 277 : parse-struct-slots ( slots -- slots' more? )
 278     scan {
 279         { ";" [ f ] }
 280         { "{" [ parse-struct-slot over push t ] }
 281         [ invalid-struct-slot ]
 282     } case ;
 283
 284 : parse-struct-definition ( -- class slots )
 285     CREATE-CLASS 8 <vector> [ parse-struct-slots ] [ ] while >array ;
 286 PRIVATE>
 287
 288 SYNTAX: STRUCT:
 289     parse-struct-definition define-struct-class ;
 290 SYNTAX: UNION-STRUCT:
 291     parse-struct-definition define-union-struct-class ;
 292
 293 SYNTAX: S{
 294     scan-word dup struct-slots parse-tuple-literal-slots parsed ;
 295
 296 SYNTAX: S@
 297     scan-word scan-object swap memory>struct parsed ;
 298
 299 ! functor support
 300
 301 <PRIVATE
 302 : scan-c-type` ( -- c-type/param )
 303     scan dup "{" = [ drop \ } parse-until >array ] [ >string-param ] if ;
 304
 305 : parse-struct-slot` ( accum -- accum )
 306     scan-string-param scan-c-type` \ } parse-until
 307     [ <struct-slot-spec> over push ] 3curry over push-all ;
 308
 309 : parse-struct-slots` ( accum -- accum more? )
 310     scan {
 311         { ";" [ f ] }
 312         { "{" [ parse-struct-slot` t ] }
 313         [ invalid-struct-slot ]
 314     } case ;
 315 PRIVATE>
 316
 317 FUNCTOR-SYNTAX: STRUCT:
 318     scan-param parsed
 319     [ 8 <vector> ] over push-all
 320     [ parse-struct-slots` ] [ ] while
 321     [ >array define-struct-class ] over push-all ;
 322
 323 USING: vocabs vocabs.loader ;
 324
 325 "prettyprint" vocab [ "classes.struct.prettyprint" require ] when