← Back to branch summary

~ubuntu-branches/ubuntu/quantal/gclcvs/quantal

« back to all changes in this revision

Viewing changes to lsp/gcl_setf.lsp

  • Committer: Bazaar Package Importer
  • Author(s): Camm Maguire
  • Date: 2004-06-24 15:13:46 UTC
  • Revision ID: james.westby@ubuntu.com-20040624151346-xh0xaaktyyp7aorc
Tags: 2.7.0-26
C_GC_OFFSET is 2 on m68k-linux

Show diffs side-by-side

added added

removed removed

Lines of Context:
lsp/gcl_setf.lsp
 
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
;; FIXME  when all is well, remove this and the setf tests in the pcl directory
 
103
(push :setf *features*)
 
104
 
 
105
(defun get-setf-method-multiple-value (form &optional env &aux tem)
 
106
  (cond ((symbolp form)
 
107
         (let ((store (gensym)))
 
108
           (values nil nil (list store) `(setq ,form ,store) form)))
 
109
        ((or (not (consp form)) (not (symbolp (car form))))
 
110
         (error "Cannot get the setf-method of ~S." form))
 
111
        ((and env (setq tem (assoc (car form) (second env))))
 
112
         (setq tem (macroexpand form env))
 
113
         (if (eq form tem) (error "Cannot get setf-method for ~a" form))
 
114
         (return-from get-setf-method-multiple-value
 
115
                      (get-setf-method-multiple-value tem  env)))
 
116
        ((get (car form) 'setf-method)
 
117
         (apply (get (car form) 'setf-method) env (cdr form)))
 
118
        ((or (get (car form) 'setf-update-fn)
 
119
             (setq tem (get (car form) 'si::structure-access)))
 
120
         (let ((vars (mapcar #'(lambda (x)
 
121
                                 (declare (ignore x))
 
122
                                 (gensym))
 
123
                             (cdr form)))
 
124
               (store (gensym)))
 
125
           (values vars (cdr form) (list store)
 
126
                   (cond (tem
 
127
                           (setf-structure-access (car vars) (car tem)
 
128
                                                  (cdr tem) store))
 
129
                         (t
 
130
                           `(,(get (car form) 'setf-update-fn)
 
131
                             ,@vars ,store)))
 
132
                   (cons (car form) vars))))
 
133
        ((get (car form) 'setf-lambda)
 
134
         (let* ((vars (mapcar #'(lambda (x)
 
135
                                  (declare (ignore x))
 
136
                                  (gensym))
 
137
                              (cdr form)))
 
138
                (store (gensym))
 
139
                (l (get (car form) 'setf-lambda))
 
140
                ;; this looks bogus to me.  What if l is compiled?--wfs
 
141
                (f `(lambda ,(car l) #'(lambda ,(cadr l) ,@(cddr l)))))
 
142
           (values vars (cdr form) (list store)
 
143
                   (funcall (apply f vars) store)
 
144
                   (cons (car form) vars))))
 
145
        ((macro-function (car form))
 
146
         (get-setf-method-multiple-value (macroexpand form)))
 
147
        (t 
 
148
         (let ((vars (mapcar #'(lambda (x)
 
149
                                 (declare (ignore x))
 
150
                                 (gensym))
 
151
                             (cdr form)))
 
152
               (store (gensym)))
 
153
           (values vars (cdr form) (list store)
 
154
                   `(funcall
 
155
                     #'(setf ,(car form))
 
156
                     ,store ,@vars )
 
157
                   (cons (car form) vars))))))
 
158
 
 
159
 
 
160
;;;; SETF definitions.
 
161
 
 
162
(defsetf car (x) (y) `(progn (rplaca ,x ,y) ,y))
 
163
(defsetf cdr (x) (y) `(progn (rplacd ,x ,y), y))
 
164
(defsetf caar (x) (y) `(progn (rplaca (car ,x) ,y) ,y))
 
165
(defsetf cdar (x) (y) `(progn (rplacd (car ,x) ,y) ,y))
 
166
(defsetf cadr (x) (y) `(progn (rplaca (cdr ,x) ,y) ,y))
 
167
(defsetf cddr (x) (y) `(progn (rplacd (cdr ,x) ,y) ,y))
 
168
(defsetf caaar (x) (y) `(progn (rplaca (caar ,x) ,y) ,y))
 
169
(defsetf cdaar (x) (y) `(progn (rplacd (caar ,x) ,y) ,y))
 
170
(defsetf cadar (x) (y) `(progn (rplaca (cdar ,x) ,y) ,y))
 
171
(defsetf cddar (x) (y) `(progn (rplacd (cdar ,x) ,y) ,y))
 
172
(defsetf caadr (x) (y) `(progn (rplaca (cadr ,x) ,y) ,y))
 
173
(defsetf cdadr (x) (y) `(progn (rplacd (cadr ,x) ,y) ,y))
 
174
(defsetf caddr (x) (y) `(progn (rplaca (cddr ,x) ,y) ,y))
 
175
(defsetf cdddr (x) (y) `(progn (rplacd (cddr ,x) ,y) ,y))
 
176
(defsetf caaaar (x) (y) `(progn (rplaca (caaar ,x) ,y) ,y))
 
177
(defsetf cdaaar (x) (y) `(progn (rplacd (caaar ,x) ,y) ,y))
 
178
(defsetf cadaar (x) (y) `(progn (rplaca (cdaar ,x) ,y) ,y))
 
179
(defsetf cddaar (x) (y) `(progn (rplacd (cdaar ,x) ,y) ,y))
 
180
(defsetf caadar (x) (y) `(progn (rplaca (cadar ,x) ,y) ,y))
 
181
(defsetf cdadar (x) (y) `(progn (rplacd (cadar ,x) ,y) ,y))
 
182
(defsetf caddar (x) (y) `(progn (rplaca (cddar ,x) ,y) ,y))
 
183
(defsetf cdddar (x) (y) `(progn (rplacd (cddar ,x) ,y) ,y))
 
184
(defsetf caaadr (x) (y) `(progn (rplaca (caadr ,x) ,y) ,y))
 
185
(defsetf cdaadr (x) (y) `(progn (rplacd (caadr ,x) ,y) ,y))
 
186
(defsetf cadadr (x) (y) `(progn (rplaca (cdadr ,x) ,y) ,y))
 
187
(defsetf cddadr (x) (y) `(progn (rplacd (cdadr ,x) ,y) ,y))
 
188
(defsetf caaddr (x) (y) `(progn (rplaca (caddr ,x) ,y) ,y))
 
189
(defsetf cdaddr (x) (y) `(progn (rplacd (caddr ,x) ,y) ,y))
 
190
(defsetf cadddr (x) (y) `(progn (rplaca (cdddr ,x) ,y) ,y))
 
191
(defsetf cddddr (x) (y) `(progn (rplacd (cdddr ,x) ,y) ,y))
 
192
(defsetf first (x) (y) `(progn (rplaca ,x ,y) ,y))
 
193
(defsetf second (x) (y) `(progn (rplaca (cdr ,x) ,y) ,y))
 
194
(defsetf third (x) (y) `(progn (rplaca (cddr ,x) ,y) ,y))
 
195
(defsetf fourth (x) (y) `(progn (rplaca (cdddr ,x) ,y) ,y))
 
196
(defsetf fifth (x) (y) `(progn (rplaca (cddddr ,x) ,y) ,y))
 
197
(defsetf sixth (x) (y) `(progn (rplaca (nthcdr 5 ,x) ,y) ,y))
 
198
(defsetf seventh (x) (y) `(progn (rplaca (nthcdr 6 ,x) ,y) ,y))
 
199
(defsetf eighth (x) (y) `(progn (rplaca (nthcdr 7 ,x) ,y) ,y))
 
200
(defsetf ninth (x) (y) `(progn (rplaca (nthcdr 8 ,x) ,y) ,y))
 
201
(defsetf tenth (x) (y) `(progn (rplaca (nthcdr 9 ,x) ,y) ,y))
 
202
(defsetf rest (x) (y) `(progn (rplacd ,x ,y) ,y))
 
203
(defsetf svref si:svset)
 
204
(defsetf elt si:elt-set)
 
205
(defsetf symbol-value set)
 
206
(defsetf symbol-function si:fset)
 
207
(defsetf macro-function (s) (v) `(progn (si:fset ,s (cons 'macro ,v)) ,v))
 
208
(defsetf aref si:aset)
 
209
(defsetf get put-aux)
 
210
(defmacro put-aux (a b &rest l)
 
211
  `(si::sputprop ,a ,b ,(car (last l))))
 
212
(defsetf nth (n l) (v) `(progn (rplaca (nthcdr ,n ,l) ,v) ,v))
 
213
(defsetf char si:char-set)
 
214
(defsetf schar si:schar-set)
 
215
(defsetf bit si:aset)
 
216
(defsetf sbit si:aset)
 
217
(defsetf fill-pointer si:fill-pointer-set)
 
218
(defsetf symbol-plist si:set-symbol-plist)
 
219
(defsetf gethash (k h &optional d) (v) `(si:hash-set ,k ,h ,v))
 
220
(defsetf row-major-aref si:aset1)
 
221
(defsetf documentation (s d) (v)
 
222
  `(case ,d
 
223
     (variable (si:putprop ,s ,v 'variable-documentation))
 
224
     (function (si:putprop ,s ,v 'function-documentation))
 
225
     (structure (si:putprop ,s ,v 'structure-documentation))
 
226
     (type (si:putprop ,s ,v 'type-documentation))
 
227
     (setf (si:putprop ,s ,v 'setf-documentation))
 
228
     (t (error "~S is an illegal documentation type." ,d))))
 
229
 
 
230
 
 
231
(define-setf-method getf (&environment env place indicator &optional default)
 
232
  (multiple-value-bind (vars vals stores store-form access-form)
 
233
      (get-setf-method place env)
 
234
    (let ((itemp (gensym)) (store (gensym)))
 
235
      (values `(,@vars ,itemp)
 
236
              `(,@vals ,indicator)
 
237
              (list store)
 
238
              `(let ((,(car stores) (si:put-f ,access-form ,store ,itemp)))
 
239
                 ,store-form
 
240
                 ,store)
 
241
              `(getf ,access-form ,itemp ,default)))))
 
242
 
 
243
(defsetf subseq (sequence1 start1 &optional end1)
 
244
                (sequence2)
 
245
  `(replace ,sequence1 ,sequence2 :start1 ,start1 :end1 ,end1))
 
246
 
 
247
(define-setf-method the (&environment env type form)
 
248
  (multiple-value-bind (vars vals stores store-form access-form)
 
249
      (get-setf-method form env)
 
250
    (let ((store (gensym)))
 
251
      (values vars vals (list store)
 
252
              `(let ((,(car stores) (the ,type ,store))) ,store-form)
 
253
              `(the ,type ,access-form)))))
 
254
 
 
255
#|
 
256
(define-setf-method apply (&environment env fn &rest rest)
 
257
  (unless (and (consp fn) (eq (car fn) 'function) (symbolp (cadr fn))
 
258
               (null (cddr fn)))
 
259
          (error "Can't get the setf-method of ~S." fn))
 
260
  (multiple-value-bind (vars vals stores store-form access-form)
 
261
      (get-setf-method (cons (cadr fn) rest) env)
 
262
    (unless (eq (car (last store-form)) (car (last vars)))
 
263
            (error "Can't get the setf-method of ~S." fn))
 
264
    (values vars vals stores
 
265
            `(apply #',(car store-form) ,@(cdr store-form))
 
266
            `(apply #',(cadr fn) ,@(cdr access-form)))))
 
267
|#
 
268
 
 
269
(define-setf-method apply (&environment env fn &rest rest)
 
270
  (unless (and (consp fn)
 
271
               (or (eq (car fn) 'function) (eq (car fn) 'quote))
 
272
               (symbolp (cadr fn))
 
273
               (null (cddr fn)))
 
274
    (error "Can't get the setf-method of ~S." fn))
 
275
  (multiple-value-bind (vars vals stores store-form access-form)
 
276
      (get-setf-method (cons (cadr fn) rest) env)
 
277
    (cond ((eq (car (last store-form)) (car (last vars)))
 
278
           (values vars vals stores
 
279
                   `(apply #',(car store-form) ,@(cdr store-form))
 
280
                   `(apply #',(cadr fn) ,@(cdr access-form))))
 
281
          ((eq (car (last (butlast store-form))) (car (last vars)))
 
282
           (values vars vals stores
 
283
                   `(apply #',(car store-form)
 
284
                           ,@(cdr (butlast store-form 2))
 
285
                           (append ,(car (last (butlast store-form)))
 
286
                                   (list ,(car (last store-form)))))
 
287
                   `(apply #',(cadr fn) ,@(cdr access-form))))
 
288
          (t (error "Can't get the setf-method of ~S." fn)))))
 
289
 
 
290
(define-setf-method char-bit (&environment env char name)
 
291
  (multiple-value-bind (temps vals stores store-form access-form)
 
292
      (get-setf-method char env)
 
293
    (let ((ntemp (gensym))
 
294
          (store (gensym))
 
295
          (stemp (first stores)))
 
296
      (values `(,ntemp ,@temps)
 
297
              `(,name ,@vals)
 
298
              (list store)
 
299
              `(let ((,stemp (set-char-bit ,access-form ,ntemp ,store)))
 
300
                 ,store-form ,store)
 
301
              `(char-bit ,access-form ,ntemp)))))
 
302
 
 
303
(define-setf-method ldb (&environment env bytespec int)
 
304
  (multiple-value-bind (temps vals stores store-form access-form)
 
305
      (get-setf-method int env)
 
306
    (let ((btemp (gensym))
 
307
          (store (gensym))
 
308
          (stemp (first stores)))
 
309
      (values `(,btemp ,@temps)
 
310
              `(,bytespec ,@vals)
 
311
              (list store)
 
312
              `(let ((,stemp (dpb ,store ,btemp ,access-form)))
 
313
                 ,store-form ,store)
 
314
              `(ldb ,btemp ,access-form)))))
 
315
 
 
316
(define-setf-method mask-field (&environment env bytespec int)
 
317
  (multiple-value-bind (temps vals stores store-form access-form)
 
318
      (get-setf-method int env)
 
319
    (let ((btemp (gensym))
 
320
          (store (gensym))
 
321
          (stemp (first stores)))
 
322
      (values `(,btemp ,@temps)
 
323
              `(,bytespec ,@vals)
 
324
              (list store)
 
325
              `(let ((,stemp (deposit-field ,store ,btemp ,access-form)))
 
326
                 ,store-form ,store)
 
327
              `(mask-field ,btemp ,access-form)))))
 
328
 
 
329
 
 
330
;;; The expansion function for SETF.
 
331
(defun setf-expand-1 (place newvalue env &aux g)
 
332
  (when (and (consp place) (eq (car place) 'the))
 
333
        (return-from setf-expand-1
 
334
          (setf-expand-1 (caddr place) `(the ,(cadr place) ,newvalue) env)))
 
335
  (when (and (consp place) (eq (car place) 'values))
 
336
    (do ((vl (cdr place) (cdr vl))
 
337
         (sym (gensym))
 
338
         (forms nil)
 
339
         (n 0 (1+ n)))
 
340
        ((endp vl) (return-from setf-expand-1 
 
341
                                `(let ((,sym (multiple-value-list ,newvalue))) 
 
342
                                   (values ,@(nreverse forms)))))
 
343
         (declare (fixnum n) (object vl))
 
344
         (let ((method (if (symbolp (car vl)) 'setq 'setf)))
 
345
           (push `(,method ,(car vl) (nth ,n ,sym)) forms))))
 
346
  (when (symbolp place)
 
347
        (return-from setf-expand-1 `(setq ,place ,newvalue)))
 
348
  (when (and (consp place)
 
349
               (not (or (get (car place) 'setf-lambda)
 
350
                        (get (car place) 'setf-update-fn))))
 
351
          (multiple-value-setq (place g) (macroexpand place env))
 
352
          (if g (return-from setf-expand-1 (setf-expand-1 place newvalue env))))
 
353
  (when (and (symbolp (car place)) (setq g (get (car place) 'setf-update-fn)))
 
354
        (return-from setf-expand-1 `(,g ,@(cdr place) ,newvalue)))
 
355
  (cond ((and (symbolp (car place))
 
356
              (setq g (get (car place) 'structure-access)))
 
357
         (return-from setf-expand-1
 
358
           (setf-structure-access (cadr place) (car g) (cdr g) newvalue))))
 
359
             
 
360
  (multiple-value-bind (vars vals stores store-form access-form)
 
361
      (get-setf-method place env)
 
362
    (declare (ignore access-form))
 
363
    `(let* ,(mapcar #'list
 
364
                    (append vars stores)
 
365
                    (append vals (list newvalue)))
 
366
       ,store-form)))
 
367
 
 
368
(defun setf-structure-access (struct type index newvalue)
 
369
  (case type
 
370
    (list `(si:rplaca-nthcdr ,struct ,index ,newvalue))
 
371
    (vector `(si:elt-set ,struct ,index ,newvalue))
 
372
    (t `(si::structure-set ,struct ',type ,index ,newvalue))))
 
373
 
 
374
(defun setf-expand (l env)
 
375
  (cond ((endp l) nil)
 
376
        ((endp (cdr l)) (error "~S is an illegal SETF form." l))
 
377
        (t
 
378
         (cons (setf-expand-1 (car l) (cadr l) env)
 
379
               (setf-expand (cddr l) env)))))
 
380
 
 
381
 
 
382
;;; SETF macro.
 
383
 
 
384
(defun setf-helper (rest env)
 
385
  (setq rest (cdr rest))
 
386
  (cond ((endp rest) nil)
 
387
;        ((endp (cdr rest)) (error "~S is an illegal SETF form." rest))
 
388
        ((endp (cddr rest)) (setf-expand-1 (car rest) (cadr rest) env))
 
389
        (t (cons 'progn (setf-expand rest env)))))
 
390
 
 
391
;(setf (macro-function 'setf) 'setf-help)
 
392
(si::fset 'setf (cons 'macro (symbol-function 'setf-helper)))
 
393
 
 
394
;;; PSETF macro.
 
395
 
 
396
(defmacro psetf (&environment env &rest rest)
 
397
  (cond ((endp rest) nil)
 
398
        ((endp (cdr rest)) (error "~S is an illegal PSETF form." rest))
 
399
        ((endp (cddr rest))
 
400
         `(progn ,(setf-expand-1 (car rest) (cadr rest) env)
 
401
                 nil))
 
402
        (t
 
403
         (do ((r rest (cddr r))
 
404
              (pairs nil)
 
405
              (store-forms nil))
 
406
             ((endp r)
 
407
              `(let* ,pairs
 
408
                 ,@(nreverse store-forms)
 
409
                 nil))
 
410
           (when (endp (cdr r)) (error "~S is an illegal PSETF form." rest))
 
411
           (multiple-value-bind (vars vals stores store-form access-form)
 
412
               (get-setf-method (car r) env)
 
413
             (declare (ignore access-form))
 
414
             (setq store-forms (cons store-form store-forms))
 
415
             (setq pairs
 
416
                   (nconc pairs
 
417
                          (mapcar #'list
 
418
                                  (append vars stores)
 
419
                                  (append vals (list (cadr r)))))))))))
 
420
 
 
421
 
 
422
;;; SHIFTF macro.
 
423
(defmacro shiftf (&environment env &rest rest )
 
424
  (do ((r rest (cdr r))
 
425
       (pairs nil)
 
426
       (stores nil)
 
427
       (store-forms nil)
 
428
       (g (gensym))
 
429
       (access-forms nil))
 
430
      ((endp (cdr r))
 
431
       (setq stores (nreverse stores))
 
432
       (setq store-forms (nreverse store-forms))
 
433
       (setq access-forms (nreverse access-forms))
 
434
       `(let* ,(nconc pairs
 
435
                      (list (list g (car access-forms)))
 
436
                      (mapcar #'list stores (cdr access-forms))
 
437
                      (list (list (car (last stores)) (car r))))
 
438
            ,@store-forms
 
439
            ,g))
 
440
    (multiple-value-bind (vars vals stores1 store-form access-form)
 
441
        (get-setf-method (car r) env)
 
442
      (setq pairs (nconc pairs (mapcar #'list vars vals)))
 
443
      (setq stores (cons (car stores1) stores))
 
444
      (setq store-forms (cons store-form store-forms))
 
445
      (setq access-forms (cons access-form access-forms)))))
 
446
 
 
447
 
 
448
;;; ROTATEF macro.
 
449
(defmacro rotatef (&environment env &rest rest )
 
450
  (do ((r rest (cdr r))
 
451
       (pairs nil)
 
452
       (stores nil)
 
453
       (store-forms nil)
 
454
       (access-forms nil))
 
455
      ((endp r)
 
456
       (setq stores (nreverse stores))
 
457
       (setq store-forms (nreverse store-forms))
 
458
       (setq access-forms (nreverse access-forms))
 
459
       `(let* ,(nconc pairs
 
460
                      (mapcar #'list stores (cdr access-forms))
 
461
                      (list (list (car (last stores)) (car access-forms))))
 
462
            ,@store-forms
 
463
            nil
 
464
            ))
 
465
    (multiple-value-bind (vars vals stores1 store-form access-form)
 
466
        (get-setf-method (car r) env)
 
467
      (setq pairs (nconc pairs (mapcar #'list vars vals)))
 
468
      (setq stores (cons (car stores1) stores))
 
469
      (setq store-forms (cons store-form store-forms))
 
470
      (setq access-forms (cons access-form access-forms)))))
 
471
 
 
472
 
 
473
;;; DEFINE-MODIFY-MACRO macro.
 
474
(defmacro define-modify-macro (name lambda-list function &optional doc-string)
 
475
  (let ((update-form
 
476
         (do ((l lambda-list (cdr l))
 
477
              (vs nil))
 
478
             ((null l) `(list ',function access-form ,@(nreverse vs)))
 
479
           (unless (eq (car l) '&optional)
 
480
                   (if (eq (car l) '&rest)
 
481
                       (return `(list* ',function
 
482
                                       access-form
 
483
                                       ,@(nreverse vs)
 
484
                                       ,(cadr l))))
 
485
                   (if (symbolp (car l))
 
486
                       (setq vs (cons (car l) vs))
 
487
                       (setq vs (cons (caar l) vs)))))))
 
488
    `(defmacro ,name (&environment env reference . ,lambda-list)
 
489
       ,@(if doc-string (list doc-string))
 
490
       (when (symbolp reference)
 
491
             (return-from ,name
 
492
               (let ((access-form reference))
 
493
                 (list 'setq reference ,update-form))))
 
494
       (multiple-value-bind (vars vals stores store-form access-form)
 
495
           (get-setf-method reference env)
 
496
         (list 'let*
 
497
               (mapcar #'list
 
498
                       (append vars stores)
 
499
                       (append vals (list ,update-form)))
 
500
               store-form))))))))))))))))))))
 
501
 
 
502
 
 
503
;;; Some macro definitions.
 
504
 
 
505
(defmacro remf (&environment env place indicator)
 
506
  (multiple-value-bind (vars vals stores store-form access-form)
 
507
      (get-setf-method place env)
 
508
    `(let* ,(mapcar #'list vars vals)
 
509
       (multiple-value-bind (,(car stores) flag)
 
510
           (si:rem-f ,access-form ,indicator)
 
511
         ,store-form
 
512
         flag))))
 
513
 
 
514
(define-modify-macro incf (&optional (delta 1)) +)
 
515
(define-modify-macro decf (&optional (delta 1)) -)
 
516
 
 
517
(defmacro push (&environment env item place)
 
518
  (let ((myitem (gensym)))
 
519
    (when (symbolp place)
 
520
      (return-from push `(let* ((,myitem ,item))
 
521
                           (setq ,place (cons ,myitem ,place)))))
 
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 (list (list 'cons myitem access-form))))
 
527
                            ,store-form))))
 
528
 
 
529
(defmacro pushnew (&environment env item place &rest rest)
 
530
  (let ((myitem (gensym)))
 
531
    (cond ((symbolp place)
 
532
           (return-from pushnew `(let* ((,myitem ,item))
 
533
                                   (setq ,place (adjoin ,myitem ,place ,@rest))))))
 
534
    (multiple-value-bind (vars vals stores store-form access-form)
 
535
                         (get-setf-method place env)
 
536
                         `(let* ,(mapcar #'list
 
537
                                         (append (list myitem) vars stores)
 
538
                                         (append (list   item) vals
 
539
                                                 (list (list* 'adjoin myitem access-form rest))))
 
540
                            ,store-form))))
 
541
 
 
542
(defmacro pop (&environment env place)
 
543
  (when (symbolp place)
 
544
        (return-from pop
 
545
          (let ((temp (gensym)))
 
546
            `(let ((,temp (car ,place)))
 
547
                (setq ,place (cdr ,place))
 
548
                ,temp))))
 
549
  (multiple-value-bind (vars vals stores store-form access-form)
 
550
      (get-setf-method place env)
 
551
    `(let* ,(mapcar #'list
 
552
                    (append vars stores)
 
553
                    (append vals (list (list 'cdr access-form))))
 
554
       (prog1 (car ,access-form)
 
555
              ,store-form))))