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.
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.
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/>.
17 ;;; Generalized references (SETF)
19 (eval-when(:compile-toplevel :load-toplevel :execute)
20 (defvar *setf-expanders* nil)
21 (defun !get-setf-expansion (place)
23 (let ((value (gensym)))
29 (let ((place (!macroexpand-1 place)))
30 (let* ((access-fn (car place))
31 (expander (cdr (assoc access-fn *setf-expanders*))))
33 (error "Unknown generalized reference."))
34 (apply expander (cdr place)))))))
35 (fset 'get-setf-expansion (fdefinition '!get-setf-expansion))
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))
45 (defmacro setf (&rest pairs)
50 (error "Odd number of arguments to setf."))
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
65 ,@(do ((pairs pairs (cddr pairs))
66 (result '() (cons `(setf ,(car pairs) ,(cadr pairs)) result)))
68 (reverse result)))))))
75 (defmacro incf (place &optional (delta 1))
76 (multiple-value-bind (dummies vals newval setter getter)
77 (!get-setf-expansion place)
79 `(let* (,@(mapcar #'list dummies vals)
81 (,(car newval) (+ ,getter ,d))
85 (defmacro decf (place &optional (delta 1))
86 (multiple-value-bind (dummies vals newval setter getter)
87 (!get-setf-expansion place)
89 `(let* (,@(mapcar #'list dummies vals)
91 (,(car newval) (- ,getter ,d))
95 (defmacro push (x place)
96 (multiple-value-bind (dummies vals newval setter getter)
97 (!get-setf-expansion place)
100 ,@(mapcar #'list dummies vals)
101 (,(car newval) (cons ,g ,getter))
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)
111 (,(car newval) (cdr ,head))
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)
123 ,@(mapcar #'list dummies vals)
126 (if (member ,g ,v ,@keys)
128 (let ((,(car newval) (cons ,g ,getter)))