A reader macro abstraction over Arc's 'setforms.

place.arc

; place.arc
;
; This software is copyright (c) Ross Angle 2011.
;
; Permission to use this software is granted under the
; Perl Foundation's Artistic License 2.0.


; This is an exploration of using the character = as a reader macro
; such that =(a b c) is interpreted as (place (a b c)), where 'place
; is a macro that uses 'setforms and returns a function that provides
; an interface to the getting and setting behaviors of the expression.
; The point is that once these are defined, many assignment-related
; macros can be written in shorter and more consistent ways, and many
; of them may not need to be written at all because an equivalent
; function would be more flexible and just as convenient.
;
; The returned function, when called with no arguments, gets the
; value. When called with one argument, it sets the value. This is
; intended to be consistent with the way 'stdin, 'stdout, and 'stderr
; work.
;
; In order to allow things like (= foo 4 bar 5) to work as they always
; do, rather than as the erroneous ((place foo) 4 bar 5), the = reader
; macro only works if it's immediately followed by an expression.
; Right now, this special-casing has a bit of a hackish
; implementation. It may be less error-prone in the long term to use a
; character other than =.
;
; This example is intended for use on Arc 3.1. It is *not* compatible
; with Lathe, my usual place to hold Arc hacks
; (http://github.com/rocketnia/lathe), since Lathe uses names like =fn
; and =mc that would suddenly be read as (place fn), (place mc), and
; so forth.
;
; This code arose from a discussion at the Arc Forum and has been
; posted at http://arclanguage.org/item?id=13298.


; Exploit a bug in Arc 3.1 to obtain the ability to use Racket
; expressions.
(mac $ (x) `(cdr `(nil . ,,x)))

(def call (self . args)
  (apply self args))

(let missing list.nil
  (def fn-place (getter setter)
    (fn ((o value missing))
      (if (is value missing)
        call.getter
        do.setter.value))))

(mac place (expr)
  (let (binds getter setter) setforms.expr
    (w/uniq g-gotten
      `(withs ,binds
         (fn-place (fn () ,getter) ,setter)))))

($.current-readtable:$.make-readtable ($.current-readtable)
  #\= 'non-terminating-macro
  (fn (ch port . ignored)
    (if (let ch2 peekc.port
          ; TODO: Figure out the standard Racket way to find
          ; symbol-terminating characters.
          (or whitec.ch2 (pos ch2 ")]")))
      do!=
      `(place ,$.read/recursive.port))))

; Change 'setforms so that (place unbound-variable) doesn't cause an
; error but ((place unbound-variable)) does. We want to be able to say
; ((place unbound-variable) initial-value) to initialize things.
(with (old-setforms  setforms
       g-val         call.uniq)
  (def setforms (expr)
    (zap macex expr)
    (if (and (isa expr 'sym) (~ssyntax expr))
      `(()
        ,expr
        (fn (,g-val) (assign ,expr ,g-val)))
      do.old-setforms.expr)))



; =====  Example utilities  =====

; NOTE: The comments on each of these utilities say what they preserve
; about the original behavior, but actually, none of them bothers to
; preserve the behavior of (atomic ...) forms in the original. It
; would require another layer of laziness, a thunk around each place
; argument, in order to do that. (The original utilities run the
; 'setforms "binds" code inside the 'atomic form, whereas (place ...)
; runs it right away and then returns the function, so the evaluation
; of (place ...) needs to be deferred.)
;
; The fact that these examples don't bother with 'atomic isn't much of
; a loss, since you can always say (atomic:mock-zap ...) if it means
; that much to you.


; ===  Imitations of '=  ===

; This macro imitates '= in every way. (Except, of course, for the
; dependencies that can be replaced in order to change its behavior.
; For instance, redefining 'expand=list won't affect this, but
; redefining 'place will. None of these imitations will be that
; precise.)
(mac mock= args
  `(do ,@(map [do `(=,car._ ,cadr._)] pair.args)))

; This is a function that behaves a bit like '=. However, its result
; is always nil, it evaluates all its arguments before performing any
; setting, and the places it sets must be given as functions by
; prefixing them with =, as follows:
;
;   (fn-simul= =foo 'this-is-foo
;              =bar.0 'this-is-bars-first-element)
;
; As with '=, if there's an odd number of arguments, the last argument
; is interpreted as a place that's to be set to nil.
;
(def fn-simul= args
  (while args
    (pop.args pop.args)))

; This is a macro such that saying (simul= a b c d e) is the same as
; saying (fn-simul= =a b =c d =e nil).
(mac simul= args
  `(fn-simul= ,@(mappend [do `(=,car._ ,cadr._)] pair.args)))

; This function imitates '= in every way, including laziness (unlike
; 'fn-simul=), but in order to accomplish that laziness, all the
; arguments all have to be wrapped in thunks. The values that are
; returned from the place thunks should be functions of the kind
; returned by (place ...). For instance, the equivalent of
; (= a b c d e) is
; (fn-= (fn () =a) (fn () b) (fn () =c) (fn () d) (fn () =e)).
(def fn-= args
  (whenlet (place-thunk . rest) args
    (iflet (val-thunk . rest) rest
      (if rest
        (do (call.place-thunk call.val-thunk)
            (apply fn-= rest))
        (call.place-thunk call.val-thunk))
      call.place-thunk.nil)))


; ===  Imitations of 'zap  ===

; This function imitates 'zap except that the place being zapped must
; be given as a function of the kind returned by (place ...). For
; instance, the equivalent of (zap + foo 2) is (fn-zap + =foo 2).
; Also, the function is evaluated before the place, rather than vice
; versa.
(def fn-zap (func place . rest)
  (do.place:apply func call.place rest))

; This macro imitates 'zap in almost every way. The exception is that
; the function is evaluated before the place, rather than vice versa.
(mac mock-zap (func place . rest)
  `(fn-zap ,func =,place ,@rest))