/[gcl]/gcl/lsp/gcl_setf.lsp
ViewVC logotype

Diff of /gcl/lsp/gcl_setf.lsp

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.1 by camm, Sun Sep 14 02:30:35 2003 UTC revision 1.2 by camm, Sun Sep 14 02:43:06 2003 UTC
# Line 0  Line 1 
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))))

Legend:
Removed from v.1.1  
changed lines
  Added in v.1.2

savannah-hackers-public@gnu.org
ViewVC Help
Powered by ViewVC 1.1.26