extra/slots/macros/macros.factor

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