1 |
|
;; Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa |
2 |
|
|
3 |
|
;; This file is part of GNU Common Lisp, herein referred to as GCL |
4 |
|
;; |
5 |
|
;; GCL is free software; you can redistribute it and/or modify it under |
6 |
|
;; the terms of the GNU LIBRARY GENERAL PUBLIC LICENSE as published by |
7 |
|
;; the Free Software Foundation; either version 2, or (at your option) |
8 |
|
;; any later version. |
9 |
|
;; |
10 |
|
;; GCL is distributed in the hope that it will be useful, but WITHOUT |
11 |
|
;; ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or |
12 |
|
;; FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public |
13 |
|
;; License for more details. |
14 |
|
;; |
15 |
|
;; You should have received a copy of the GNU Library General Public License |
16 |
|
;; along with GCL; see the file COPYING. If not, write to the Free Software |
17 |
|
;; Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. |
18 |
|
|
19 |
|
|
20 |
|
;;;; setf.lsp |
21 |
|
;;;; |
22 |
|
;;;; setf routines |
23 |
|
|
24 |
|
|
25 |
|
(in-package 'lisp) |
26 |
|
|
27 |
|
|
28 |
|
(export '(setf psetf shiftf rotatef |
29 |
|
define-modify-macro defsetf |
30 |
|
getf remf incf decf push pushnew pop |
31 |
|
define-setf-method get-setf-method get-setf-method-multiple-value)) |
32 |
|
|
33 |
|
|
34 |
|
(in-package 'system) |
35 |
|
|
36 |
|
|
37 |
|
(eval-when (compile) (proclaim '(optimize (safety 2) (space 3)))) |
38 |
|
(eval-when (eval compile) (defun si:clear-compiler-properties (symbol))) |
39 |
|
(eval-when (eval compile) (setq si:*inhibit-macro-special* nil)) |
40 |
|
|
41 |
|
|
42 |
|
;;; DEFSETF macro. |
43 |
|
(defmacro defsetf (access-fn &rest rest) |
44 |
|
(cond ((and (car rest) (or (symbolp (car rest)) (functionp (car rest)))) |
45 |
|
`(eval-when(compile eval load) |
46 |
|
(si:putprop ',access-fn ',(car rest) 'setf-update-fn) |
47 |
|
(remprop ',access-fn 'setf-lambda) |
48 |
|
(remprop ',access-fn 'setf-method) |
49 |
|
(si:putprop ',access-fn |
50 |
|
,(when (not (endp (cdr rest))) |
51 |
|
(unless (stringp (cadr rest)) |
52 |
|
(error "A doc-string expected.")) |
53 |
|
(unless (endp (cddr rest)) |
54 |
|
(error "Extra arguments.")) |
55 |
|
(cadr rest)) |
56 |
|
'setf-documentation) |
57 |
|
',access-fn)) |
58 |
|
(t |
59 |
|
(unless (= (list-length (cadr rest)) 1) |
60 |
|
(error "(store-variable) expected.")) |
61 |
|
`(eval-when (compile eval load) |
62 |
|
(si:putprop ',access-fn ',rest 'setf-lambda) |
63 |
|
(remprop ',access-fn 'setf-update-fn) |
64 |
|
(remprop ',access-fn 'setf-method) |
65 |
|
(si:putprop ',access-fn |
66 |
|
,(find-documentation (cddr rest)) |
67 |
|
'setf-documentation) |
68 |
|
',access-fn)))) |
69 |
|
|
70 |
|
|
71 |
|
;;; DEFINE-SETF-METHOD macro. |
72 |
|
(defmacro define-setf-method (access-fn &rest rest &aux args env body) |
73 |
|
(multiple-value-setq (args env) |
74 |
|
(get-&environment (car rest))) |
75 |
|
(setq body (cdr rest)) |
76 |
|
(cond (env (setq args (cons env args))) |
77 |
|
(t (setq args (cons (gensym) args)) |
78 |
|
(push `(declare (ignore ,(car args))) body))) |
79 |
|
`(eval-when (compile eval load) |
80 |
|
(si:putprop ',access-fn #'(lambda ,args ,@ body) 'setf-method) |
81 |
|
(remprop ',access-fn 'setf-lambda) |
82 |
|
(remprop ',access-fn 'setf-update-fn) |
83 |
|
(si:putprop ',access-fn |
84 |
|
,(find-documentation (cdr rest)) |
85 |
|
'setf-documentation) |
86 |
|
',access-fn)) |
87 |
|
|
88 |
|
|
89 |
|
;;; GET-SETF-METHOD. |
90 |
|
;;; It just calls GET-SETF-METHOD-MULTIPLE-VALUE |
91 |
|
;;; and checks the number of the store variable. |
92 |
|
(defun get-setf-method (form &optional env) |
93 |
|
(multiple-value-bind (vars vals stores store-form access-form) |
94 |
|
(get-setf-method-multiple-value form env) |
95 |
|
(unless (= (list-length stores) 1) |
96 |
|
(error "Multiple store-variables are not allowed.")) |
97 |
|
(values vars vals stores store-form access-form))) |
98 |
|
|
99 |
|
|
100 |
|
;;;; GET-SETF-METHOD-MULTIPLE-VALUE. |
101 |
|
|
102 |
|
(defun get-setf-method-multiple-value (form &optional env &aux tem) |
103 |
|
(cond ((symbolp form) |
104 |
|
(let ((store (gensym))) |
105 |
|
(values nil nil (list store) `(setq ,form ,store) form))) |
106 |
|
((or (not (consp form)) (not (symbolp (car form)))) |
107 |
|
(error "Cannot get the setf-method of ~S." form)) |
108 |
|
((and env (setq tem (assoc (car form) (second env)))) |
109 |
|
(setq tem (macroexpand form env)) |
110 |
|
(if (eq form tem) (error "Cannot get setf-method for ~a" form)) |
111 |
|
(return-from get-setf-method-multiple-value |
112 |
|
(get-setf-method-multiple-value tem env))) |
113 |
|
((get (car form) 'setf-method) |
114 |
|
(apply (get (car form) 'setf-method) env (cdr form))) |
115 |
|
((or (get (car form) 'setf-update-fn) |
116 |
|
(setq tem (get (car form) 'si::structure-access))) |
117 |
|
(let ((vars (mapcar #'(lambda (x) |
118 |
|
(declare (ignore x)) |
119 |
|
(gensym)) |
120 |
|
(cdr form))) |
121 |
|
(store (gensym))) |
122 |
|
(values vars (cdr form) (list store) |
123 |
|
(cond (tem |
124 |
|
(setf-structure-access (car vars) (car tem) |
125 |
|
(cdr tem) store)) |
126 |
|
(t |
127 |
|
`(,(get (car form) 'setf-update-fn) |
128 |
|
,@vars ,store))) |
129 |
|
(cons (car form) vars)))) |
130 |
|
((get (car form) 'setf-lambda) |
131 |
|
(let* ((vars (mapcar #'(lambda (x) |
132 |
|
(declare (ignore x)) |
133 |
|
(gensym)) |
134 |
|
(cdr form))) |
135 |
|
(store (gensym)) |
136 |
|
(l (get (car form) 'setf-lambda)) |
137 |
|
;; this looks bogus to me. What if l is compiled?--wfs |
138 |
|
(f `(lambda ,(car l) #'(lambda ,(cadr l) ,@(cddr l))))) |
139 |
|
(values vars (cdr form) (list store) |
140 |
|
(funcall (apply f vars) store) |
141 |
|
(cons (car form) vars)))) |
142 |
|
((macro-function (car form)) |
143 |
|
(get-setf-method-multiple-value (macroexpand form))) |
144 |
|
(t |
145 |
|
(error "Cannot expand the SETF form ~S." form)))) |
146 |
|
|
147 |
|
|
148 |
|
;;;; SETF definitions. |
149 |
|
|
150 |
|
(defsetf car (x) (y) `(progn (rplaca ,x ,y) ,y)) |
151 |
|
(defsetf cdr (x) (y) `(progn (rplacd ,x ,y), y)) |
152 |
|
(defsetf caar (x) (y) `(progn (rplaca (car ,x) ,y) ,y)) |
153 |
|
(defsetf cdar (x) (y) `(progn (rplacd (car ,x) ,y) ,y)) |
154 |
|
(defsetf cadr (x) (y) `(progn (rplaca (cdr ,x) ,y) ,y)) |
155 |
|
(defsetf cddr (x) (y) `(progn (rplacd (cdr ,x) ,y) ,y)) |
156 |
|
(defsetf caaar (x) (y) `(progn (rplaca (caar ,x) ,y) ,y)) |
157 |
|
(defsetf cdaar (x) (y) `(progn (rplacd (caar ,x) ,y) ,y)) |
158 |
|
(defsetf cadar (x) (y) `(progn (rplaca (cdar ,x) ,y) ,y)) |
159 |
|
(defsetf cddar (x) (y) `(progn (rplacd (cdar ,x) ,y) ,y)) |
160 |
|
(defsetf caadr (x) (y) `(progn (rplaca (cadr ,x) ,y) ,y)) |
161 |
|
(defsetf cdadr (x) (y) `(progn (rplacd (cadr ,x) ,y) ,y)) |
162 |
|
(defsetf caddr (x) (y) `(progn (rplaca (cddr ,x) ,y) ,y)) |
163 |
|
(defsetf cdddr (x) (y) `(progn (rplacd (cddr ,x) ,y) ,y)) |
164 |
|
(defsetf caaaar (x) (y) `(progn (rplaca (caaar ,x) ,y) ,y)) |
165 |
|
(defsetf cdaaar (x) (y) `(progn (rplacd (caaar ,x) ,y) ,y)) |
166 |
|
(defsetf cadaar (x) (y) `(progn (rplaca (cdaar ,x) ,y) ,y)) |
167 |
|
(defsetf cddaar (x) (y) `(progn (rplacd (cdaar ,x) ,y) ,y)) |
168 |
|
(defsetf caadar (x) (y) `(progn (rplaca (cadar ,x) ,y) ,y)) |
169 |
|
(defsetf cdadar (x) (y) `(progn (rplacd (cadar ,x) ,y) ,y)) |
170 |
|
(defsetf caddar (x) (y) `(progn (rplaca (cddar ,x) ,y) ,y)) |
171 |
|
(defsetf cdddar (x) (y) `(progn (rplacd (cddar ,x) ,y) ,y)) |
172 |
|
(defsetf caaadr (x) (y) `(progn (rplaca (caadr ,x) ,y) ,y)) |
173 |
|
(defsetf cdaadr (x) (y) `(progn (rplacd (caadr ,x) ,y) ,y)) |
174 |
|
(defsetf cadadr (x) (y) `(progn (rplaca (cdadr ,x) ,y) ,y)) |
175 |
|
(defsetf cddadr (x) (y) `(progn (rplacd (cdadr ,x) ,y) ,y)) |
176 |
|
(defsetf caaddr (x) (y) `(progn (rplaca (caddr ,x) ,y) ,y)) |
177 |
|
(defsetf cdaddr (x) (y) `(progn (rplacd (caddr ,x) ,y) ,y)) |
178 |
|
(defsetf cadddr (x) (y) `(progn (rplaca (cdddr ,x) ,y) ,y)) |
179 |
|
(defsetf cddddr (x) (y) `(progn (rplacd (cdddr ,x) ,y) ,y)) |
180 |
|
(defsetf first (x) (y) `(progn (rplaca ,x ,y) ,y)) |
181 |
|
(defsetf second (x) (y) `(progn (rplaca (cdr ,x) ,y) ,y)) |
182 |
|
(defsetf third (x) (y) `(progn (rplaca (cddr ,x) ,y) ,y)) |
183 |
|
(defsetf fourth (x) (y) `(progn (rplaca (cdddr ,x) ,y) ,y)) |
184 |
|
(defsetf fifth (x) (y) `(progn (rplaca (cddddr ,x) ,y) ,y)) |
185 |
|
(defsetf sixth (x) (y) `(progn (rplaca (nthcdr 5 ,x) ,y) ,y)) |
186 |
|
(defsetf seventh (x) (y) `(progn (rplaca (nthcdr 6 ,x) ,y) ,y)) |
187 |
|
(defsetf eighth (x) (y) `(progn (rplaca (nthcdr 7 ,x) ,y) ,y)) |
188 |
|
(defsetf ninth (x) (y) `(progn (rplaca (nthcdr 8 ,x) ,y) ,y)) |
189 |
|
(defsetf tenth (x) (y) `(progn (rplaca (nthcdr 9 ,x) ,y) ,y)) |
190 |
|
(defsetf rest (x) (y) `(progn (rplacd ,x ,y) ,y)) |
191 |
|
(defsetf svref si:svset) |
192 |
|
(defsetf elt si:elt-set) |
193 |
|
(defsetf symbol-value set) |
194 |
|
(defsetf symbol-function si:fset) |
195 |
|
(defsetf macro-function (s) (v) `(progn (si:fset ,s (cons 'macro ,v)) ,v)) |
196 |
|
(defsetf aref si:aset) |
197 |
|
(defsetf get put-aux) |
198 |
|
(defmacro put-aux (a b &rest l) |
199 |
|
`(si::sputprop ,a ,b ,(car (last l)))) |
200 |
|
(defsetf nth (n l) (v) `(progn (rplaca (nthcdr ,n ,l) ,v) ,v)) |
201 |
|
(defsetf char si:char-set) |
202 |
|
(defsetf schar si:schar-set) |
203 |
|
(defsetf bit si:aset) |
204 |
|
(defsetf sbit si:aset) |
205 |
|
(defsetf fill-pointer si:fill-pointer-set) |
206 |
|
(defsetf symbol-plist si:set-symbol-plist) |
207 |
|
(defsetf gethash (k h &optional d) (v) `(si:hash-set ,k ,h ,v)) |
208 |
|
(defsetf row-major-aref si:aset1) |
209 |
|
(defsetf documentation (s d) (v) |
210 |
|
`(case ,d |
211 |
|
(variable (si:putprop ,s ,v 'variable-documentation)) |
212 |
|
(function (si:putprop ,s ,v 'function-documentation)) |
213 |
|
(structure (si:putprop ,s ,v 'structure-documentation)) |
214 |
|
(type (si:putprop ,s ,v 'type-documentation)) |
215 |
|
(setf (si:putprop ,s ,v 'setf-documentation)) |
216 |
|
(t (error "~S is an illegal documentation type." ,d)))) |
217 |
|
|
218 |
|
|
219 |
|
(define-setf-method getf (&environment env place indicator &optional default) |
220 |
|
(multiple-value-bind (vars vals stores store-form access-form) |
221 |
|
(get-setf-method place env) |
222 |
|
(let ((itemp (gensym)) (store (gensym))) |
223 |
|
(values `(,@vars ,itemp) |
224 |
|
`(,@vals ,indicator) |
225 |
|
(list store) |
226 |
|
`(let ((,(car stores) (si:put-f ,access-form ,store ,itemp))) |
227 |
|
,store-form |
228 |
|
,store) |
229 |
|
`(getf ,access-form ,itemp ,default))))) |
230 |
|
|
231 |
|
(defsetf subseq (sequence1 start1 &optional end1) |
232 |
|
(sequence2) |
233 |
|
`(replace ,sequence1 ,sequence2 :start1 ,start1 :end1 ,end1)) |
234 |
|
|
235 |
|
(define-setf-method the (&environment env type form) |
236 |
|
(multiple-value-bind (vars vals stores store-form access-form) |
237 |
|
(get-setf-method form env) |
238 |
|
(let ((store (gensym))) |
239 |
|
(values vars vals (list store) |
240 |
|
`(let ((,(car stores) (the ,type ,store))) ,store-form) |
241 |
|
`(the ,type ,access-form))))) |
242 |
|
|
243 |
|
#| |
244 |
|
(define-setf-method apply (&environment env fn &rest rest) |
245 |
|
(unless (and (consp fn) (eq (car fn) 'function) (symbolp (cadr fn)) |
246 |
|
(null (cddr fn))) |
247 |
|
(error "Can't get the setf-method of ~S." fn)) |
248 |
|
(multiple-value-bind (vars vals stores store-form access-form) |
249 |
|
(get-setf-method (cons (cadr fn) rest) env) |
250 |
|
(unless (eq (car (last store-form)) (car (last vars))) |
251 |
|
(error "Can't get the setf-method of ~S." fn)) |
252 |
|
(values vars vals stores |
253 |
|
`(apply #',(car store-form) ,@(cdr store-form)) |
254 |
|
`(apply #',(cadr fn) ,@(cdr access-form))))) |
255 |
|
|# |
256 |
|
|
257 |
|
(define-setf-method apply (&environment env fn &rest rest) |
258 |
|
(unless (and (consp fn) |
259 |
|
(or (eq (car fn) 'function) (eq (car fn) 'quote)) |
260 |
|
(symbolp (cadr fn)) |
261 |
|
(null (cddr fn))) |
262 |
|
(error "Can't get the setf-method of ~S." fn)) |
263 |
|
(multiple-value-bind (vars vals stores store-form access-form) |
264 |
|
(get-setf-method (cons (cadr fn) rest) env) |
265 |
|
(cond ((eq (car (last store-form)) (car (last vars))) |
266 |
|
(values vars vals stores |
267 |
|
`(apply #',(car store-form) ,@(cdr store-form)) |
268 |
|
`(apply #',(cadr fn) ,@(cdr access-form)))) |
269 |
|
((eq (car (last (butlast store-form))) (car (last vars))) |
270 |
|
(values vars vals stores |
271 |
|
`(apply #',(car store-form) |
272 |
|
,@(cdr (butlast store-form 2)) |
273 |
|
(append ,(car (last (butlast store-form))) |
274 |
|
(list ,(car (last store-form))))) |
275 |
|
`(apply #',(cadr fn) ,@(cdr access-form)))) |
276 |
|
(t (error "Can't get the setf-method of ~S." fn))))) |
277 |
|
|
278 |
|
(define-setf-method char-bit (&environment env char name) |
279 |
|
(multiple-value-bind (temps vals stores store-form access-form) |
280 |
|
(get-setf-method char env) |
281 |
|
(let ((ntemp (gensym)) |
282 |
|
(store (gensym)) |
283 |
|
(stemp (first stores))) |
284 |
|
(values `(,ntemp ,@temps) |
285 |
|
`(,name ,@vals) |
286 |
|
(list store) |
287 |
|
`(let ((,stemp (set-char-bit ,access-form ,ntemp ,store))) |
288 |
|
,store-form ,store) |
289 |
|
`(char-bit ,access-form ,ntemp))))) |
290 |
|
|
291 |
|
(define-setf-method ldb (&environment env bytespec int) |
292 |
|
(multiple-value-bind (temps vals stores store-form access-form) |
293 |
|
(get-setf-method int env) |
294 |
|
(let ((btemp (gensym)) |
295 |
|
(store (gensym)) |
296 |
|
(stemp (first stores))) |
297 |
|
(values `(,btemp ,@temps) |
298 |
|
`(,bytespec ,@vals) |
299 |
|
(list store) |
300 |
|
`(let ((,stemp (dpb ,store ,btemp ,access-form))) |
301 |
|
,store-form ,store) |
302 |
|
`(ldb ,btemp ,access-form))))) |
303 |
|
|
304 |
|
(define-setf-method mask-field (&environment env bytespec int) |
305 |
|
(multiple-value-bind (temps vals stores store-form access-form) |
306 |
|
(get-setf-method int env) |
307 |
|
(let ((btemp (gensym)) |
308 |
|
(store (gensym)) |
309 |
|
(stemp (first stores))) |
310 |
|
(values `(,btemp ,@temps) |
311 |
|
`(,bytespec ,@vals) |
312 |
|
(list store) |
313 |
|
`(let ((,stemp (deposit-field ,store ,btemp ,access-form))) |
314 |
|
,store-form ,store) |
315 |
|
`(mask-field ,btemp ,access-form))))) |
316 |
|
|
317 |
|
|
318 |
|
;;; The expansion function for SETF. |
319 |
|
(defun setf-expand-1 (place newvalue env &aux g) |
320 |
|
(when (and (consp place) (eq (car place) 'the)) |
321 |
|
(return-from setf-expand-1 |
322 |
|
(setf-expand-1 (caddr place) `(the ,(cadr place) ,newvalue) env))) |
323 |
|
(when (and (consp place) (eq (car place) 'values)) |
324 |
|
(do ((vl (cdr place) (cdr vl)) |
325 |
|
(sym (gensym)) |
326 |
|
(forms nil) |
327 |
|
(n 0 (1+ n))) |
328 |
|
((endp vl) (return-from setf-expand-1 |
329 |
|
`(let ((,sym (multiple-value-list ,newvalue))) |
330 |
|
(values ,@(nreverse forms))))) |
331 |
|
(declare (fixnum n) (object vl)) |
332 |
|
(let ((method (if (symbolp (car vl)) 'setq 'setf))) |
333 |
|
(push `(,method ,(car vl) (nth ,n ,sym)) forms)))) |
334 |
|
(when (symbolp place) |
335 |
|
(return-from setf-expand-1 `(setq ,place ,newvalue))) |
336 |
|
(when (and (consp place) |
337 |
|
(not (or (get (car place) 'setf-lambda) |
338 |
|
(get (car place) 'setf-update-fn)))) |
339 |
|
(multiple-value-setq (place g) (macroexpand place env)) |
340 |
|
(if g (return-from setf-expand-1 (setf-expand-1 place newvalue env)))) |
341 |
|
(when (and (symbolp (car place)) (setq g (get (car place) 'setf-update-fn))) |
342 |
|
(return-from setf-expand-1 `(,g ,@(cdr place) ,newvalue))) |
343 |
|
(cond ((and (symbolp (car place)) |
344 |
|
(setq g (get (car place) 'structure-access))) |
345 |
|
(return-from setf-expand-1 |
346 |
|
(setf-structure-access (cadr place) (car g) (cdr g) newvalue)))) |
347 |
|
|
348 |
|
(multiple-value-bind (vars vals stores store-form access-form) |
349 |
|
(get-setf-method place env) |
350 |
|
(declare (ignore access-form)) |
351 |
|
`(let* ,(mapcar #'list |
352 |
|
(append vars stores) |
353 |
|
(append vals (list newvalue))) |
354 |
|
,store-form))) |
355 |
|
|
356 |
|
(defun setf-structure-access (struct type index newvalue) |
357 |
|
(case type |
358 |
|
(list `(si:rplaca-nthcdr ,struct ,index ,newvalue)) |
359 |
|
(vector `(si:elt-set ,struct ,index ,newvalue)) |
360 |
|
(t `(si::structure-set ,struct ',type ,index ,newvalue)))) |
361 |
|
|
362 |
|
(defun setf-expand (l env) |
363 |
|
(cond ((endp l) nil) |
364 |
|
((endp (cdr l)) (error "~S is an illegal SETF form." l)) |
365 |
|
(t |
366 |
|
(cons (setf-expand-1 (car l) (cadr l) env) |
367 |
|
(setf-expand (cddr l) env))))) |
368 |
|
|
369 |
|
|
370 |
|
;;; SETF macro. |
371 |
|
|
372 |
|
(defun setf-helper (rest env) |
373 |
|
(setq rest (cdr rest)) |
374 |
|
(cond ((endp rest) nil) |
375 |
|
((endp (cdr rest)) (error "~S is an illegal SETF form." rest)) |
376 |
|
((endp (cddr rest)) (setf-expand-1 (car rest) (cadr rest) env)) |
377 |
|
(t (cons 'progn (setf-expand rest env))))) |
378 |
|
|
379 |
|
;(setf (macro-function 'setf) 'setf-help) |
380 |
|
(si::fset 'setf (cons 'macro (symbol-function 'setf-helper))) |
381 |
|
|
382 |
|
;;; PSETF macro. |
383 |
|
|
384 |
|
(defmacro psetf (&environment env &rest rest) |
385 |
|
(cond ((endp rest) nil) |
386 |
|
((endp (cdr rest)) (error "~S is an illegal PSETF form." rest)) |
387 |
|
((endp (cddr rest)) |
388 |
|
`(progn ,(setf-expand-1 (car rest) (cadr rest) env) |
389 |
|
nil)) |
390 |
|
(t |
391 |
|
(do ((r rest (cddr r)) |
392 |
|
(pairs nil) |
393 |
|
(store-forms nil)) |
394 |
|
((endp r) |
395 |
|
`(let* ,pairs |
396 |
|
,@(nreverse store-forms) |
397 |
|
nil)) |
398 |
|
(when (endp (cdr r)) (error "~S is an illegal PSETF form." rest)) |
399 |
|
(multiple-value-bind (vars vals stores store-form access-form) |
400 |
|
(get-setf-method (car r) env) |
401 |
|
(declare (ignore access-form)) |
402 |
|
(setq store-forms (cons store-form store-forms)) |
403 |
|
(setq pairs |
404 |
|
(nconc pairs |
405 |
|
(mapcar #'list |
406 |
|
(append vars stores) |
407 |
|
(append vals (list (cadr r))))))))))) |
408 |
|
|
409 |
|
|
410 |
|
;;; SHIFTF macro. |
411 |
|
(defmacro shiftf (&environment env &rest rest ) |
412 |
|
(do ((r rest (cdr r)) |
413 |
|
(pairs nil) |
414 |
|
(stores nil) |
415 |
|
(store-forms nil) |
416 |
|
(g (gensym)) |
417 |
|
(access-forms nil)) |
418 |
|
((endp (cdr r)) |
419 |
|
(setq stores (nreverse stores)) |
420 |
|
(setq store-forms (nreverse store-forms)) |
421 |
|
(setq access-forms (nreverse access-forms)) |
422 |
|
`(let* ,(nconc pairs |
423 |
|
(list (list g (car access-forms))) |
424 |
|
(mapcar #'list stores (cdr access-forms)) |
425 |
|
(list (list (car (last stores)) (car r)))) |
426 |
|
,@store-forms |
427 |
|
,g)) |
428 |
|
(multiple-value-bind (vars vals stores1 store-form access-form) |
429 |
|
(get-setf-method (car r) env) |
430 |
|
(setq pairs (nconc pairs (mapcar #'list vars vals))) |
431 |
|
(setq stores (cons (car stores1) stores)) |
432 |
|
(setq store-forms (cons store-form store-forms)) |
433 |
|
(setq access-forms (cons access-form access-forms))))) |
434 |
|
|
435 |
|
|
436 |
|
;;; ROTATEF macro. |
437 |
|
(defmacro rotatef (&environment env &rest rest ) |
438 |
|
(do ((r rest (cdr r)) |
439 |
|
(pairs nil) |
440 |
|
(stores nil) |
441 |
|
(store-forms nil) |
442 |
|
(access-forms nil)) |
443 |
|
((endp r) |
444 |
|
(setq stores (nreverse stores)) |
445 |
|
(setq store-forms (nreverse store-forms)) |
446 |
|
(setq access-forms (nreverse access-forms)) |
447 |
|
`(let* ,(nconc pairs |
448 |
|
(mapcar #'list stores (cdr access-forms)) |
449 |
|
(list (list (car (last stores)) (car access-forms)))) |
450 |
|
,@store-forms |
451 |
|
nil |
452 |
|
)) |
453 |
|
(multiple-value-bind (vars vals stores1 store-form access-form) |
454 |
|
(get-setf-method (car r) env) |
455 |
|
(setq pairs (nconc pairs (mapcar #'list vars vals))) |
456 |
|
(setq stores (cons (car stores1) stores)) |
457 |
|
(setq store-forms (cons store-form store-forms)) |
458 |
|
(setq access-forms (cons access-form access-forms))))) |
459 |
|
|
460 |
|
|
461 |
|
;;; DEFINE-MODIFY-MACRO macro. |
462 |
|
(defmacro define-modify-macro (name lambda-list function &optional doc-string) |
463 |
|
(let ((update-form |
464 |
|
(do ((l lambda-list (cdr l)) |
465 |
|
(vs nil)) |
466 |
|
((null l) `(list ',function access-form ,@(nreverse vs))) |
467 |
|
(unless (eq (car l) '&optional) |
468 |
|
(if (eq (car l) '&rest) |
469 |
|
(return `(list* ',function |
470 |
|
access-form |
471 |
|
,@(nreverse vs) |
472 |
|
,(cadr l)))) |
473 |
|
(if (symbolp (car l)) |
474 |
|
(setq vs (cons (car l) vs)) |
475 |
|
(setq vs (cons (caar l) vs))))))) |
476 |
|
`(defmacro ,name (&environment env reference . ,lambda-list) |
477 |
|
,@(if doc-string (list doc-string)) |
478 |
|
(when (symbolp reference) |
479 |
|
(return-from ,name |
480 |
|
(let ((access-form reference)) |
481 |
|
(list 'setq reference ,update-form)))) |
482 |
|
(multiple-value-bind (vars vals stores store-form access-form) |
483 |
|
(get-setf-method reference env) |
484 |
|
(list 'let* |
485 |
|
(mapcar #'list |
486 |
|
(append vars stores) |
487 |
|
(append vals (list ,update-form))) |
488 |
|
store-form)))))))))))))))))))) |
489 |
|
|
490 |
|
|
491 |
|
;;; Some macro definitions. |
492 |
|
|
493 |
|
(defmacro remf (&environment env place indicator) |
494 |
|
(multiple-value-bind (vars vals stores store-form access-form) |
495 |
|
(get-setf-method place env) |
496 |
|
`(let* ,(mapcar #'list vars vals) |
497 |
|
(multiple-value-bind (,(car stores) flag) |
498 |
|
(si:rem-f ,access-form ,indicator) |
499 |
|
,store-form |
500 |
|
flag)))) |
501 |
|
|
502 |
|
(define-modify-macro incf (&optional (delta 1)) +) |
503 |
|
(define-modify-macro decf (&optional (delta 1)) -) |
504 |
|
|
505 |
|
(defmacro push (&environment env item place) |
506 |
|
(let ((myitem (gensym))) |
507 |
|
(when (symbolp place) |
508 |
|
(return-from push `(let* ((,myitem ,item)) |
509 |
|
(setq ,place (cons ,myitem ,place))))) |
510 |
|
(multiple-value-bind (vars vals stores store-form access-form) |
511 |
|
(get-setf-method place env) |
512 |
|
`(let* ,(mapcar #'list |
513 |
|
(append (list myitem) vars stores) |
514 |
|
(append (list item) vals (list (list 'cons myitem access-form)))) |
515 |
|
,store-form)))) |
516 |
|
|
517 |
|
(defmacro pushnew (&environment env item place &rest rest) |
518 |
|
(let ((myitem (gensym))) |
519 |
|
(cond ((symbolp place) |
520 |
|
(return-from pushnew `(let* ((,myitem ,item)) |
521 |
|
(setq ,place (adjoin ,myitem ,place ,@rest)))))) |
522 |
|
(multiple-value-bind (vars vals stores store-form access-form) |
523 |
|
(get-setf-method place env) |
524 |
|
`(let* ,(mapcar #'list |
525 |
|
(append (list myitem) vars stores) |
526 |
|
(append (list item) vals |
527 |
|
(list (list* 'adjoin myitem access-form rest)))) |
528 |
|
,store-form)))) |
529 |
|
|
530 |
|
(defmacro pop (&environment env place) |
531 |
|
(when (symbolp place) |
532 |
|
(return-from pop |
533 |
|
(let ((temp (gensym))) |
534 |
|
`(let ((,temp (car ,place))) |
535 |
|
(setq ,place (cdr ,place)) |
536 |
|
,temp)))) |
537 |
|
(multiple-value-bind (vars vals stores store-form access-form) |
538 |
|
(get-setf-method place env) |
539 |
|
`(let* ,(mapcar #'list |
540 |
|
(append vars stores) |
541 |
|
(append vals (list (list 'cdr access-form)))) |
542 |
|
(prog1 (car ,access-form) |
543 |
|
,store-form)))) |