src/setf.lisp

   1 ;;; setf.lisp ---
   2
   3 ;; JSCL is free software: you can redistribute it and/or
   4 ;; modify it under the terms of the GNU General Public License as
   5 ;; published by the Free Software Foundation, either version 3 of the
   6 ;; License, or (at your option) any later version.
   7 ;;
   8 ;; JSCL is distributed in the hope that it will be useful, but
   9 ;; WITHOUT ANY WARRANTY; without even the implied warranty of
  10 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  11 ;; General Public License for more details.
  12 ;;
  13 ;; You should have received a copy of the GNU General Public License
  14 ;; along with JSCL.  If not, see <http://www.gnu.org/licenses/>.
  15
  16
  17 ;;; Generalized references (SETF)
  18
  19 (eval-when(:compile-toplevel :load-toplevel :execute)
  20   (defvar *setf-expanders* nil)
  21   (defun !get-setf-expansion (place)
  22     (if (symbolp place)
  23         (let ((value (gensym)))
  24           (values nil
  25                   nil
  26                   `(,value)
  27                   `(setq ,place ,value)
  28                   place))
  29         (let ((place (!macroexpand-1 place)))
  30           (let* ((access-fn (car place))
  31                  (expander (cdr (assoc access-fn *setf-expanders*))))
  32             (when (null expander)
  33               (error "Unknown generalized reference."))
  34             (apply expander (cdr place)))))))
  35 (fset 'get-setf-expansion (fdefinition '!get-setf-expansion))
  36
  37 (defmacro define-setf-expander (access-fn lambda-list &body body)
  38   (unless (symbolp access-fn)
  39     (error "ACCESS-FN `~S' must be a symbol." access-fn))
  40   `(eval-when (:compile-toplevel :load-toplevel :execute)
  41      (push (cons ',access-fn (lambda ,lambda-list ,@body))
  42            *setf-expanders*)
  43      ',access-fn))
  44
  45 (defmacro setf (&rest pairs)
  46   (cond
  47     ((null pairs)
  48      nil)
  49     ((null (cdr pairs))
  50      (error "Odd number of arguments to setf."))
  51     ((null (cddr pairs))
  52      (let ((place (!macroexpand-1 (first pairs)))
  53            (value (second pairs)))
  54        (multiple-value-bind (vars vals store-vars writer-form reader-form)
  55            (!get-setf-expansion place)
  56          (declare (ignorable reader-form))
  57          ;; TODO: Optimize the expansion a little bit to avoid let*
  58          ;; or multiple-value-bind when unnecesary.
  59          `(let* ,(mapcar #'list vars vals)
  60             (multiple-value-bind ,store-vars
  61                 ,value
  62               ,writer-form)))))
  63     (t
  64      `(progn
  65         ,@(do ((pairs pairs (cddr pairs))
  66                (result '() (cons `(setf ,(car pairs) ,(cadr pairs)) result)))
  67               ((null pairs)
  68                (reverse result)))))))
  69
  70
  71
  72
  73 ;;; SETF-Based macros
  74
  75 (defmacro incf (place &optional (delta 1))
  76   (multiple-value-bind (dummies vals newval setter getter)
  77       (!get-setf-expansion place)
  78     (let ((d (gensym)))
  79       `(let* (,@(mapcar #'list dummies vals)
  80               (,d ,delta)
  81                 (,(car newval) (+ ,getter ,d))
  82                 ,@(cdr newval))
  83          ,setter))))
  84
  85 (defmacro decf (place &optional (delta 1))
  86   (multiple-value-bind (dummies vals newval setter getter)
  87       (!get-setf-expansion place)
  88     (let ((d (gensym)))
  89       `(let* (,@(mapcar #'list dummies vals)
  90               (,d ,delta)
  91               (,(car newval) (- ,getter ,d))
  92               ,@(cdr newval))
  93          ,setter))))
  94
  95 (defmacro push (x place)
  96   (multiple-value-bind (dummies vals newval setter getter)
  97       (!get-setf-expansion place)
  98     (let ((g (gensym)))
  99       `(let* ((,g ,x)
 100               ,@(mapcar #'list dummies vals)
 101               (,(car newval) (cons ,g ,getter))
 102               ,@(cdr newval))
 103          ,setter))))
 104
 105 (defmacro pop (place)
 106   (multiple-value-bind (dummies vals newval setter getter)
 107     (!get-setf-expansion place)
 108     (let ((head (gensym)))
 109       `(let* (,@(mapcar #'list dummies vals)
 110               (,head ,getter)
 111               (,(car newval) (cdr ,head))
 112               ,@(cdr newval))
 113          ,setter
 114          (car ,head)))))
 115
 116 (defmacro pushnew (x place &rest keys &key key test test-not)
 117   (declare (ignore key test test-not))
 118   (multiple-value-bind (dummies vals newval setter getter)
 119       (!get-setf-expansion place)
 120     (let ((g (gensym))
 121           (v (gensym)))
 122       `(let* ((,g ,x)
 123               ,@(mapcar #'list dummies vals)
 124               ,@(cdr newval)
 125               (,v ,getter))
 126          (if (member ,g ,v ,@keys)
 127              ,v
 128              (let ((,(car newval) (cons ,g ,getter)))
 129                ,setter))))))