-;;; Generalized references (SETF)
-
-(defvar *setf-expanders* nil)
-
-(defun get-setf-expansion (place)
- (if (symbolp place)
- (let ((value (gensym)))
- (values nil
- nil
- `(,value)
- `(setq ,place ,value)
- place))
- (let ((place (!macroexpand-1 place)))
- (let* ((access-fn (car place))
- (expander (cdr (assoc access-fn *setf-expanders*))))
- (when (null expander)
- (error "Unknown generalized reference."))
- (apply expander (cdr place))))))
-
-(defmacro define-setf-expander (access-fn lambda-list &body body)
- (unless (symbolp access-fn)
- (error "ACCESS-FN `~S' must be a symbol." access-fn))
- `(progn (push (cons ',access-fn (lambda ,lambda-list ,@body))
- *setf-expanders*)
- ',access-fn))
-
-(defmacro setf (&rest pairs)
- (cond
- ((null pairs)
- nil)
- ((null (cdr pairs))
- (error "Odd number of arguments to setf."))
- ((null (cddr pairs))
- (let ((place (!macroexpand-1 (first pairs)))
- (value (second pairs)))
- (multiple-value-bind (vars vals store-vars writer-form)
- (get-setf-expansion place)
- ;; TODO: Optimize the expansion a little bit to avoid let*
- ;; or multiple-value-bind when unnecesary.
- `(let* ,(mapcar #'list vars vals)
- (multiple-value-bind ,store-vars
- ,value
- ,writer-form)))))
- (t
- `(progn
- ,@(do ((pairs pairs (cddr pairs))
- (result '() (cons `(setf ,(car pairs) ,(cadr pairs)) result)))
- ((null pairs)
- (reverse result)))))))
-