1 | ;;; setf.lisp |
---|
2 | ;;; |
---|
3 | ;;; Copyright (C) 2003-2006 Peter Graves |
---|
4 | ;;; $Id: setf.lisp 14399 2013-02-23 11:17:50Z mevenson $ |
---|
5 | ;;; |
---|
6 | ;;; This program is free software; you can redistribute it and/or |
---|
7 | ;;; modify it under the terms of the GNU General Public License |
---|
8 | ;;; as published by the Free Software Foundation; either version 2 |
---|
9 | ;;; of the License, or (at your option) any later version. |
---|
10 | ;;; |
---|
11 | ;;; This program is distributed in the hope that it will be useful, |
---|
12 | ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of |
---|
13 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the |
---|
14 | ;;; GNU General Public License for more details. |
---|
15 | ;;; |
---|
16 | ;;; You should have received a copy of the GNU General Public License |
---|
17 | ;;; along with this program; if not, write to the Free Software |
---|
18 | ;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. |
---|
19 | ;;; |
---|
20 | ;;; As a special exception, the copyright holders of this library give you |
---|
21 | ;;; permission to link this library with independent modules to produce an |
---|
22 | ;;; executable, regardless of the license terms of these independent |
---|
23 | ;;; modules, and to copy and distribute the resulting executable under |
---|
24 | ;;; terms of your choice, provided that you also meet, for each linked |
---|
25 | ;;; independent module, the terms and conditions of the license of that |
---|
26 | ;;; module. An independent module is a module which is not derived from |
---|
27 | ;;; or based on this library. If you modify this library, you may extend |
---|
28 | ;;; this exception to your version of the library, but you are not |
---|
29 | ;;; obligated to do so. If you do not wish to do so, delete this |
---|
30 | ;;; exception statement from your version. |
---|
31 | |
---|
32 | (in-package #:system) |
---|
33 | |
---|
34 | (defun get-setf-method-inverse (form inverse setf-function) |
---|
35 | (let ((new-var (gensym)) |
---|
36 | (vars nil) |
---|
37 | (vals nil)) |
---|
38 | (dolist (x (cdr form)) |
---|
39 | (push (gensym) vars) |
---|
40 | (push x vals)) |
---|
41 | (setq vals (nreverse vals)) |
---|
42 | (values vars vals (list new-var) |
---|
43 | (if setf-function |
---|
44 | `(,@inverse ,new-var ,@vars) |
---|
45 | (if (functionp (car inverse)) |
---|
46 | `(funcall ,@inverse ,@vars ,new-var) |
---|
47 | `(,@inverse ,@vars ,new-var))) |
---|
48 | `(,(car form) ,@vars)))) |
---|
49 | |
---|
50 | ;;; If a macro, expand one level and try again. If not, go for the |
---|
51 | ;;; SETF function. |
---|
52 | (defun expand-or-get-setf-inverse (form environment) |
---|
53 | (multiple-value-bind (expansion expanded) |
---|
54 | (macroexpand-1 form environment) |
---|
55 | (if expanded |
---|
56 | (get-setf-expansion expansion environment) |
---|
57 | (get-setf-method-inverse form `(funcall #'(setf ,(car form))) |
---|
58 | t)))) |
---|
59 | |
---|
60 | (defun get-setf-expansion (form &optional environment) |
---|
61 | (let (temp) |
---|
62 | (cond ((symbolp form) |
---|
63 | (multiple-value-bind (expansion expanded) |
---|
64 | (macroexpand-1 form environment) |
---|
65 | (if expanded |
---|
66 | (get-setf-expansion expansion environment) |
---|
67 | (let ((new-var (gensym))) |
---|
68 | (values nil nil (list new-var) |
---|
69 | `(setq ,form ,new-var) form))))) |
---|
70 | ((setq temp (get (car form) 'setf-inverse)) |
---|
71 | (get-setf-method-inverse form `(,temp) nil)) |
---|
72 | ((setq temp (get (car form) 'setf-expander)) |
---|
73 | (funcall temp form environment)) |
---|
74 | (t |
---|
75 | (expand-or-get-setf-inverse form environment))))) |
---|
76 | |
---|
77 | (defmacro setf (&rest args &environment environment) |
---|
78 | (let ((numargs (length args))) |
---|
79 | (cond |
---|
80 | ((= numargs 2) |
---|
81 | (let ((place (first args)) |
---|
82 | (value-form (second args))) |
---|
83 | (if (atom place) |
---|
84 | `(setq ,place ,value-form) |
---|
85 | (progn |
---|
86 | (multiple-value-bind (dummies vals store-vars setter getter) |
---|
87 | (get-setf-expansion place environment) |
---|
88 | (let ((inverse (get (car place) 'setf-inverse))) |
---|
89 | (if (and inverse (eq inverse (car setter))) |
---|
90 | (if (functionp inverse) |
---|
91 | `(funcall ,inverse ,@(cdr place) ,value-form) |
---|
92 | `(,inverse ,@(cdr place) ,value-form)) |
---|
93 | (if (or (null store-vars) (cdr store-vars)) |
---|
94 | `(let* (,@(mapcar #'list dummies vals)) |
---|
95 | (multiple-value-bind ,store-vars ,value-form |
---|
96 | ,setter)) |
---|
97 | `(let* (,@(mapcar #'list dummies vals) |
---|
98 | ,(list (car store-vars) value-form)) |
---|
99 | ,setter))))))))) |
---|
100 | ((oddp numargs) |
---|
101 | (error "Odd number of arguments to SETF.")) |
---|
102 | (t |
---|
103 | (do ((a args (cddr a)) (l nil)) |
---|
104 | ((null a) `(progn ,@(nreverse l))) |
---|
105 | (setq l (cons (list 'setf (car a) (cadr a)) l))))))) |
---|
106 | |
---|
107 | ;;; Redefined in define-modify-macro.lisp. |
---|
108 | (defmacro incf (place &optional (delta 1)) |
---|
109 | `(setf ,place (+ ,place ,delta))) |
---|
110 | |
---|
111 | ;;; Redefined in define-modify-macro.lisp. |
---|
112 | (defmacro decf (place &optional (delta 1)) |
---|
113 | `(setf ,place (- ,place ,delta))) |
---|
114 | |
---|
115 | ;; (defsetf subseq (sequence start &optional (end nil)) (v) |
---|
116 | ;; `(progn (replace ,sequence ,v :start1 ,start :end1 ,end) |
---|
117 | ;; ,v)) |
---|
118 | (defun %set-subseq (sequence start &rest rest) |
---|
119 | (let ((end nil) v) |
---|
120 | (ecase (length rest) |
---|
121 | (1 |
---|
122 | (setq v (car rest))) |
---|
123 | (2 |
---|
124 | (setq end (car rest) |
---|
125 | v (cadr rest)))) |
---|
126 | (progn |
---|
127 | (replace sequence v :start1 start :end1 end) |
---|
128 | v))) |
---|
129 | |
---|
130 | (defun %define-setf-macro (name expander inverse doc) |
---|
131 | (declare (ignore doc)) ; FIXME |
---|
132 | (when inverse |
---|
133 | (put name 'setf-inverse inverse)) |
---|
134 | (when expander |
---|
135 | (put name 'setf-expander expander)) |
---|
136 | name) |
---|
137 | |
---|
138 | (defmacro defsetf (access-function update-function) |
---|
139 | `(eval-when (:load-toplevel :compile-toplevel :execute) |
---|
140 | (put ',access-function 'setf-inverse ',update-function))) |
---|
141 | |
---|
142 | (defun %set-caar (x v) (set-car (car x) v)) |
---|
143 | (defun %set-cadr (x v) (set-car (cdr x) v)) |
---|
144 | (defun %set-cdar (x v) (set-cdr (car x) v)) |
---|
145 | (defun %set-cddr (x v) (set-cdr (cdr x) v)) |
---|
146 | (defun %set-caaar (x v) (set-car (caar x) v)) |
---|
147 | (defun %set-cadar (x v) (set-car (cdar x) v)) |
---|
148 | (defun %set-cdaar (x v) (set-cdr (caar x) v)) |
---|
149 | (defun %set-cddar (x v) (set-cdr (cdar x) v)) |
---|
150 | (defun %set-caadr (x v) (set-car (cadr x) v)) |
---|
151 | (defun %set-caddr (x v) (set-car (cddr x) v)) |
---|
152 | (defun %set-cdadr (x v) (set-cdr (cadr x) v)) |
---|
153 | (defun %set-cdddr (x v) (set-cdr (cddr x) v)) |
---|
154 | (defun %set-caaaar (x v) (set-car (caaar x) v)) |
---|
155 | (defun %set-cadaar (x v) (set-car (cdaar x) v)) |
---|
156 | (defun %set-cdaaar (x v) (set-cdr (caaar x) v)) |
---|
157 | (defun %set-cddaar (x v) (set-cdr (cdaar x) v)) |
---|
158 | (defun %set-caadar (x v) (set-car (cadar x) v)) |
---|
159 | (defun %set-caddar (x v) (set-car (cddar x) v)) |
---|
160 | (defun %set-cdadar (x v) (set-cdr (cadar x) v)) |
---|
161 | (defun %set-cdddar (x v) (set-cdr (cddar x) v)) |
---|
162 | (defun %set-caaadr (x v) (set-car (caadr x) v)) |
---|
163 | (defun %set-cadadr (x v) (set-car (cdadr x) v)) |
---|
164 | (defun %set-cdaadr (x v) (set-cdr (caadr x) v)) |
---|
165 | (defun %set-cddadr (x v) (set-cdr (cdadr x) v)) |
---|
166 | (defun %set-caaddr (x v) (set-car (caddr x) v)) |
---|
167 | (defun %set-cadddr (x v) (set-car (cdddr x) v)) |
---|
168 | (defun %set-cdaddr (x v) (set-cdr (caddr x) v)) |
---|
169 | (defun %set-cddddr (x v) (set-cdr (cdddr x) v)) |
---|
170 | |
---|
171 | (defsetf car set-car) |
---|
172 | (defsetf cdr set-cdr) |
---|
173 | (defsetf caar %set-caar) |
---|
174 | (defsetf cadr %set-cadr) |
---|
175 | (defsetf cdar %set-cdar) |
---|
176 | (defsetf cddr %set-cddr) |
---|
177 | (defsetf caaar %set-caaar) |
---|
178 | (defsetf cadar %set-cadar) |
---|
179 | (defsetf cdaar %set-cdaar) |
---|
180 | (defsetf cddar %set-cddar) |
---|
181 | (defsetf caadr %set-caadr) |
---|
182 | (defsetf caddr %set-caddr) |
---|
183 | (defsetf cdadr %set-cdadr) |
---|
184 | (defsetf cdddr %set-cdddr) |
---|
185 | (defsetf caaaar %set-caaaar) |
---|
186 | (defsetf cadaar %set-cadaar) |
---|
187 | (defsetf cdaaar %set-cdaaar) |
---|
188 | (defsetf cddaar %set-cddaar) |
---|
189 | (defsetf caadar %set-caadar) |
---|
190 | (defsetf caddar %set-caddar) |
---|
191 | (defsetf cdadar %set-cdadar) |
---|
192 | (defsetf cdddar %set-cdddar) |
---|
193 | (defsetf caaadr %set-caaadr) |
---|
194 | (defsetf cadadr %set-cadadr) |
---|
195 | (defsetf cdaadr %set-cdaadr) |
---|
196 | (defsetf cddadr %set-cddadr) |
---|
197 | (defsetf caaddr %set-caaddr) |
---|
198 | (defsetf cadddr %set-cadddr) |
---|
199 | (defsetf cdaddr %set-cdaddr) |
---|
200 | (defsetf cddddr %set-cddddr) |
---|
201 | |
---|
202 | (defsetf first set-car) |
---|
203 | (defsetf second %set-cadr) |
---|
204 | (defsetf third %set-caddr) |
---|
205 | (defsetf fourth %set-cadddr) |
---|
206 | (defun %set-fifth (x v) (set-car (cddddr x) v)) |
---|
207 | (defsetf fifth %set-fifth) |
---|
208 | (defun %set-sixth (x v) (set-car (cdr (cddddr x)) v)) |
---|
209 | (defsetf sixth %set-sixth) |
---|
210 | (defun %set-seventh (x v) (set-car (cddr (cddddr x)) v)) |
---|
211 | (defsetf seventh %set-seventh) |
---|
212 | (defun %set-eighth (x v) (set-car (cdddr (cddddr x)) v)) |
---|
213 | (defsetf eighth %set-eighth) |
---|
214 | (defun %set-ninth (x v) (set-car (cddddr (cddddr x)) v)) |
---|
215 | (defsetf ninth %set-ninth) |
---|
216 | (defun %set-tenth (x v) (set-car (cdr (cddddr (cddddr x))) v)) |
---|
217 | (defsetf tenth %set-tenth) |
---|
218 | |
---|
219 | (defsetf rest set-cdr) |
---|
220 | ;;Redefined in extensible-sequences-base.lisp |
---|
221 | (defsetf elt %set-elt) |
---|
222 | (defsetf nth %set-nth) |
---|
223 | (defsetf svref svset) |
---|
224 | (defsetf fill-pointer %set-fill-pointer) |
---|
225 | (defsetf subseq %set-subseq) |
---|
226 | (defsetf symbol-value set) |
---|
227 | (defsetf symbol-function %set-symbol-function) |
---|
228 | (defsetf symbol-plist %set-symbol-plist) |
---|
229 | (defsetf get put) |
---|
230 | (defsetf gethash puthash) |
---|
231 | (defsetf char set-char) |
---|
232 | (defsetf schar set-schar) |
---|
233 | (defsetf logical-pathname-translations %set-logical-pathname-translations) |
---|
234 | (defsetf readtable-case %set-readtable-case) |
---|
235 | |
---|
236 | (defsetf function-info %set-function-info) |
---|
237 | |
---|
238 | (defsetf stream-external-format %set-stream-external-format) |
---|
239 | |
---|
240 | (defsetf structure-ref structure-set) |
---|