extra/slots/macros/macros.factor

   1 ! Copyright (C) 2011 Joe Groff.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: combinators compiler.units fry generalizations kernel
   4 locals macros math quotations sequences sequences.generalizations
   5 slots vectors ;
   6 IN: slots.macros
   7
   8 ! Fundamental accessors
   9
  10 <PRIVATE
  11 : define-slot ( name -- )
  12     [ define-protocol-slot ] with-compilation-unit ;
  13 PRIVATE>
  14
  15 MACRO: slot ( name -- quot: ( tuple -- value ) )
  16     [ define-slot ] [ reader-word 1quotation ] bi ;
  17 MACRO: set-slot ( name -- quot: ( value tuple -- ) )
  18     [ define-slot ] [ writer-word 1quotation ] bi ;
  19
  20
  21 ! In-place modifiers akin to *-at or *-nth
  22
  23 : change-slot ( ..a tuple name quot: ( ..a old -- ..b new ) -- ..b )
  24     '[ slot @ ] [ set-slot ] 2bi ; inline
  25
  26 : inc-slot ( tuple name -- )
  27     [ 0 or 1 + ] change-slot ; inline
  28
  29 : slot+ ( value tuple name -- )
  30     [ 0 or + ] change-slot ; inline
  31
  32 : push-slot ( value tuple name -- )
  33     [ ?push ] change-slot ; inline
  34
  35 ! Chainable setters
  36
  37 : set-slot* ( tuple value name -- tuple )
  38     swapd '[ _ set-slot ] keep ; inline
  39
  40 : change-slot* ( tuple name quot: ( ..a old -- ..b new ) -- ..b tuple )
  41     '[ _ _ change-slot ] keep ; inline
  42
  43 ! Multiple-slot accessors
  44
  45 MACRO: slots ( names -- quot: ( tuple -- values... ) )
  46     [ '[ _ slot ] ] { } map-as '[ _ cleave ] ;
  47
  48 MACRO: slots>array ( names -- quot: ( tuple -- values ) )
  49     dup length '[ _ slots _ narray ] ;
  50
  51 MACRO: set-slots ( names -- quot: ( values... tuple -- ) )
  52     [ [ '[ _ set-slot ] ] [ ] map-as ] [ length dup ] bi
  53     '[ @ _ cleave-curry _ spread* ] ;
  54
  55 MACRO: array>set-slots ( names -- quot: ( values tuple -- ) )
  56     [ length ] keep '[ [ _ firstn ] dip _ set-slots ] ;