source: branches/qres/ccl/lib/setf.lisp @ 14259

Last change on this file since 14259 was 14259, checked in by gz, 9 years ago

r14258 from trunk (defstruct changes)

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 35.9 KB
1;;;-*-Mode: LISP; Package: CCL -*-
3;;;   Copyright (C) 2009 Clozure Associates
4;;;   Copyright (C) 1994-2001 Digitool, Inc
5;;;   This file is part of Clozure CL. 
7;;;   Clozure CL is licensed under the terms of the Lisp Lesser GNU Public
8;;;   License , known as the LLGPL and distributed with Clozure CL as the
9;;;   file "LICENSE".  The LLGPL consists of a preamble and the LGPL,
10;;;   which is distributed with Clozure CL as the file "LGPL".  Where these
11;;;   conflict, the preamble takes precedence. 
13;;;   Clozure CL is referenced in the preamble as the "LIBRARY."
15;;;   The LLGPL is also available online at
18(in-package "CCL")
21(defvar %setf-methods% (let ((a (make-hash-table :test #'eq)))
22                         (do-all-symbols (s)
23                           (let ((f (get s 'bootstrapping-setf-method)))
24                             (when f
25                               (setf (gethash s a) f)
26                               (remprop s 'bootstrapping-setf-method))))
27                         a))
28(defun %setf-method (name)
29  (gethash name %setf-methods%))
31(defun store-setf-method (name fn &optional doc)
32  (puthash name %setf-methods% fn)
33  (when (structref-info name)
34    (structref-set-r/o name))
35  (set-documentation name 'setf doc) ;clears it if doc = nil.
36  name)
39;;; Note: The expansions for SETF and friends create needless LET-bindings of
40;;; argument values when using get-setf-method.
41;;; That's why SETF no longer uses get-setf-method.  If you change anything
42;;; here, be sure to make the corresponding change in SETF.
44(defun get-setf-expansion (form &optional env)
45  "Return five values needed by the SETF machinery: a list of temporary
46   variables, a list of values with which to fill them, a list of temporaries
47   for the new values, the setting function, and the accessing function."
48  ;This isn't actually used by setf, but it has to be compatible.
49  (get-setf-expansion-aux form env t))
51(defun get-setf-expansion-aux (form environment multiple-store-vars-p)
52  (let* ((temp nil) 
53         (accessor nil))
54    (if (atom form)
55      (progn
56        (unless (symbolp form) (signal-program-error $XNotSym form))
57        (multiple-value-bind (symbol-macro-expansion expanded)
58            (macroexpand-1 form environment)
59          (if expanded
60            (get-setf-expansion-aux symbol-macro-expansion environment
61                                    multiple-store-vars-p)
62            (let ((new-var (gensym)))
63              (values nil nil (list new-var) `(setq ,form ,new-var) form)))))
64      (multiple-value-bind (ftype local-p)
65                           (function-information (setq accessor (car form)) environment)
66        (if local-p
67          (if (eq ftype :function)
68            ;Local function or macro, so don't use global setf definitions.
69            (default-setf-method form)
70            (get-setf-expansion-aux (macroexpand-1 form environment) environment multiple-store-vars-p))
71          (cond
72           ((setq temp (gethash accessor %setf-methods%))
73            (if (symbolp temp)
74              (let ((new-var (gensym))
75                    (args nil)
76                    (vars nil)
77                    (vals nil))
78                (dolist (x (cdr form))
79                  ;; Rebinding defeats optimizations, so avoid it if can.
80                  (if (constantp x environment)
81                    (push x args)
82                    (let ((var (gensym)))
83                      (push var vars)
84                      (push var args)
85                      (push x vals))))
86                (setq args (nreverse args))
87                (values (nreverse vars) 
88                        (nreverse vals) 
89                        (list new-var)
90                        `(,temp ,@args ,new-var)
91                        `(,accessor ,@args)))
92              (multiple-value-bind (temps values storevars storeform accessform)
93                                   (funcall temp form environment)
94                (when (and (not multiple-store-vars-p) (not (= (length storevars) 1)))
95                  (signal-program-error "Multiple store variables not expected in setf expansion of ~S" form))
96                (values temps values storevars storeform accessform))))
97           ((and (setq temp (structref-info accessor environment))
98                 (accessor-structref-info-p temp)
99                 (not (refinfo-r/o (structref-info-refinfo temp))))
100            (let ((form (defstruct-ref-transform temp (%cdr form) environment t))
101                  (type (defstruct-type-for-typecheck (structref-info-type temp) environment)))
102              (if (eq type 't)
103                (get-setf-method form environment)
104                (multiple-value-bind (temps values storevars storeform accessform)
105                                     (get-setf-method form environment)
106                  (values temps values storevars
107                          (let ((storevar (first storevars)))
108                            `(the ,type
109                                  (let ((,storevar (typecheck ,storevar ,type)))
110                                    ,storeform)))
111                          `(the ,type ,accessform))))))
112           (t
113            (multiple-value-bind (res win)
114                                 (macroexpand-1 form environment)
115              (if win
116                (get-setf-expansion-aux res environment multiple-store-vars-p)
117                (default-setf-method form))))))))))
119(defun default-setf-method (form)
120  (let ((new-value (gensym))
121        (temp-vars ())
122        (temp-args ())
123        (temp-vals ()))
124    (dolist (val (cdr form))
125      (if (fixnump val)
126        (push val temp-args)
127        (let ((var (gensym)))
128          (push var temp-vars)
129          (push val temp-vals)
130          (push var temp-args))))
131    (setq temp-vars (nreverse temp-vars)
132          temp-args (nreverse temp-args)
133          temp-vals (nreverse temp-vals))
134    (values temp-vars
135            temp-vals
136            (list new-value)
137            `(funcall #'(setf ,(car form)) ,new-value ,@temp-args)
138            `(,(car form) ,@temp-args))))
140;;; The inverse for a generalized-variable reference function is stored in
141;;; one of two ways:
143;;; A SETF-INVERSE property corresponds to the short form of DEFSETF.  It is
144;;; the name of a function takes the same args as the reference form, plus a
145;;; new-value arg at the end.
147;;; A SETF-METHOD-EXPANDER property is created by the long form of DEFSETF or
148;;; by DEFINE-SETF-METHOD.  It is a function that is called on the reference
149;;; form and that produces five values: a list of temporary variables, a list
150;;; of value forms, a list of the single store-value form, a storing function,
151;;; and an accessing function.
153(eval-when (eval compile)
154  (require 'defstruct-macros))
156(defmacro set-get (symbol indicator value &optional (value1 () default-p))
157  (if default-p
158    `(put ,symbol ,indicator (progn ,value ,value1))
159    `(put ,symbol ,indicator ,value)))
161; (defsetf get set-get)
162(store-setf-method 'get 'SET-GET)
164; does this wrap a named block around the body yet ?
165(defmacro define-setf-expander (access-fn lambda-list &body body)
166  "Syntax like DEFMACRO, but creates a setf expander function. The body
167  of the definition must be a form that returns five appropriate values."
168  (unless (symbolp access-fn)
169    (signal-program-error $xnotsym access-fn))
170  (multiple-value-bind (lambda-form doc)
171                       (parse-macro-1 access-fn lambda-list body)
172    `(eval-when (load compile eval)
173       (record-source-file ',access-fn 'setf-expander)
174       (store-setf-method ',access-fn
175                          (nfunction ,access-fn ,lambda-form)
176                          ,@(when doc (list doc))))))
178(defun rename-lambda-vars (lambda-list)
179  (let* ((vars nil)
180         (temps nil)
181         (new-lambda nil)
182         (state nil))
183    (flet ((temp-symbol (s) (make-symbol (symbol-name s))))
184      (declare (inline temp-symbol))
185      (dolist (item lambda-list)
186        (if (memq item lambda-list-keywords)
187          (setq state item item (list 'quote item))
188          (if (atom item)
189            (progn
190              (push item vars))
191            (locally (declare (type cons item))
192              (when (consp (cddr item))
193                (push (caddr item) vars))
194              (if (and (eq state '&key) (consp (car item)))
195                (progn
196                  (push (cadar item) vars)
197                  (setq item `(list (list ,(list 'quote (caar item)) ,(cadar item)) ,@(cdr item))))
198                (progn 
199                  (push (car item) vars)
200                  (setq item `(list ,(car item) ,@(cdr item))))))))
201        (push item new-lambda))
202      (setq temps (mapcar #'temp-symbol vars))
203      (values `(list ,@(nreverse new-lambda)) (nreverse temps) (nreverse vars)))))
205(defmacro defsetf (access-fn &rest rest &environment env)
206  "Associates a SETF update function or macro with the specified access
207  function or macro. The format is complex. See the manual for details."
208  (unless (symbolp access-fn) (signal-program-error $xnotsym access-fn))
209  (if (non-nil-symbol-p (%car rest))
210    `(eval-when (:compile-toplevel :load-toplevel :execute)
211       (store-setf-method
212        ',access-fn
213        ',(%car rest)
214        ,@(%cdr rest)))
215    (destructuring-bind (lambda-list (store-var &rest mv-store-vars) &body body)
216        rest
217      (unless (verify-lambda-list lambda-list)
218        (signal-program-error $XBadLambdaList lambda-list))
219      (let* ((store-vars (cons store-var mv-store-vars)))
220        (multiple-value-bind (lambda-list lambda-temps lambda-vars)
221                             (rename-lambda-vars lambda-list)
222          (multiple-value-bind (body decls doc)
223                               (parse-body body env t)
224            (setq body `((block ,access-fn ,@body)))
225            (let* ((args (gensym))
226                   (dummies (gensym))
227                   (newval-vars (gensym))
228                   (new-access-form (gensym))
229                   (access-form (gensym))
230                   (environment (gensym)))
231              `(eval-when (:compile-toplevel :load-toplevel :execute)
232                 (record-source-file ',access-fn 'setf-expander)
233                 (store-setf-method 
234                  ',access-fn
235                  #'(lambda (,access-form ,environment)
236                      (declare (ignore ,environment))
237                      (do* ((,args (cdr ,access-form) (cdr ,args))
238                            (,dummies nil (cons (gensym) ,dummies))
239                            (,newval-vars (mapcar #'(lambda (v) (declare (ignore v)) (gensym)) ',store-vars))
240                            (,new-access-form nil))
241                           ((atom ,args)
242                            (setq ,new-access-form 
243                                  (cons (car ,access-form) ,dummies))
244                            (destructuring-bind ,(append lambda-vars store-vars )
245                                                `,(append ',lambda-temps ,newval-vars)
246                              ,@decls
247                              (values
248                               ,dummies
249                               (cdr ,access-form)
250                               ,newval-vars
251                               `((lambda ,,lambda-list ,,@body)
252                                 ,@,dummies)
253                               ,new-access-form))))))
254                 ,@(if doc (list doc))
255                 ',access-fn))))))))
257(defmacro define-modify-macro (name lambda-list function &optional doc-string)
258  "Creates a new read-modify-write macro like PUSH or INCF."
259  (let ((other-args nil)
260        (rest-arg nil)
261        (env (gensym))
262        (reference (gensym)))
264    ;; Parse out the variable names and rest arg from the lambda list.
265    (do ((ll lambda-list (cdr ll))
266         (arg nil))
267        ((null ll))
268      (setq arg (car ll))
269      (cond ((eq arg '&optional))
270            ((eq arg '&rest)
271             (if (symbolp (cadr ll))
272               (setq rest-arg (cadr ll))
273               (error "Non-symbol &rest arg in definition of ~S." name))
274             (if (null (cddr ll))
275               (return nil)
276               (error "Illegal stuff after &rest arg in Define-Modify-Macro.")))
277            ((memq arg '(&key &allow-other-keys &aux))
278             (error "~S not allowed in Define-Modify-Macro lambda list." arg))
279            ((symbolp arg)
280             (push arg other-args))
281            ((and (listp arg) (symbolp (car arg)))
282             (push (car arg) other-args))
283            (t (error "Illegal stuff in lambda list of Define-Modify-Macro."))))
284    (setq other-args (nreverse other-args))
285      `(defmacro ,name (,reference ,@lambda-list &environment ,env)
286         ,doc-string
287         (multiple-value-bind (dummies vals newval setter getter)
288                                (get-setf-method ,reference ,env)
289             (do ((d dummies (cdr d))
290                  (v vals (cdr v))
291                  (let-list nil (cons (list (car d) (car v)) let-list)))
292                 ((null d)
293                  (push 
294                   (list (car newval)
295                         ,(if rest-arg
296                            `(list* ',function getter ,@other-args ,rest-arg)
297                            `(list ',function getter ,@other-args)))
298                   let-list)
299                  `(let* ,(nreverse let-list)
300                     ,setter)))))))
302(defmacro incf (place &optional (delta 1) &environment env)
303  "The first argument is some location holding a number.  This number is
304incremented by the second argument, DELTA, which defaults to 1."
305  (if (and (symbolp (setq place (%symbol-macroexpand place env)))
306           (or (constantp delta)
307               (and (symbolp delta)
308                    (not (nth-value 1 (%symbol-macroexpand delta env))))))
309    `(setq ,place (+ ,place ,delta))
310    (multiple-value-bind (dummies vals newval setter getter)
311        (get-setf-method place env)
312      (let ((d (gensym))
313            ;; Doesn't propagate inferred types, but better than nothing.
314            (d-type (cond ((constantp delta) (type-of delta))
315                          ((and (consp delta) (eq (car delta) 'the)) (cadr delta))
316                          (t t)))
317            (v-type (if (and (consp place) (eq (car place) 'the)) (cadr place) t)))
318        `(let* (,@(mapcar #'list dummies vals)
319                (,d ,delta)
320                (,(car newval) (+ ,getter ,d)))
321           (declare (type ,d-type ,d) (type ,v-type ,(car newval)))
322           ,setter)))))
324(defmacro decf (place &optional (delta 1) &environment env)
325  "The first argument is some location holding a number.  This number is
326decremented by the second argument, DELTA, which defaults to 1."
327  (if (and (symbolp (setq place (%symbol-macroexpand place env)))
328           (or (constantp delta)
329               (and (symbolp delta)
330                    (not (nth-value 1 (%symbol-macroexpand delta env))))))
331    `(setq ,place (- ,place ,delta))
332    (multiple-value-bind (dummies vals newval setter getter)
333        (get-setf-method place env)
334      (let* ((d (gensym))
335             ;; Doesn't propagate inferred types, but better than nothing.
336             (d-type (cond ((constantp delta) (type-of delta))
337                           ((and (consp delta) (eq (car delta) 'the)) (cadr delta))
338                           (t t)))
339             (v-type (if (and (consp place) (eq (car place) 'the)) (cadr place) t)))
340        `(let* (,@(mapcar #'list dummies vals)
341                (,d ,delta)
342                (,(car newval) (- ,getter ,d)))
343           (declare (type ,d-type ,d) (type ,v-type ,(car newval)))
344           ,setter)))))
346(defmacro psetf (&whole call &rest pairs &environment env)  ;same structure as psetq
347  "This is to SETF as PSETQ is to SETQ. Args are alternating place
348  expressions and values to go into those places. All of the subforms and
349  values are determined, left to right, and only then are the locations
350  updated. Returns NIL."
351  (when pairs
352    (if (evenp (length pairs))
353      (let* ((places nil)
354             (values nil)
355             (tempsets nil)
356             (the-progn (list 'progn))
357             (place nil)
358             (body the-progn)
359             (valform nil))
360        (loop
361          (setq place (pop pairs) valform (pop pairs))
362          (if (null pairs) (return))
363          (push place places)
364          (push valform values)
365          (multiple-value-bind (temps vals newvals setter getter)
366                               (get-setf-method-multiple-value place env)
367            (push (list temps vals newvals setter getter) tempsets)))
368        (dolist (temp tempsets)
369          (destructuring-bind (temps vals newvals setter getter) temp
370            (declare (ignore getter))
371            (setq body
372                  `(let
373                     ,(let* ((let-list nil))
374                        (dolist (x temps (nreverse let-list))
375                          (push (list x (pop vals)) let-list)))
376                     (multiple-value-bind ,newvals ,(pop values)
377                       ,body)))
378            (push setter (cdr the-progn))))
379        (push `(setf ,place ,valform) (cdr the-progn))
380        `(progn ,body nil))
381      (error "Odd number of args in the call ~S" call))))
383;;Simple Setf specializations
387(defsetf cadr set-cadr)
388(defsetf second set-cadr)
391(defsetf cdar set-cdar)
393(defsetf caar set-caar)
395(defsetf cddr set-cddr)
397(defsetf elt set-elt)
398(defsetf aref aset)
399(defsetf svref svset)
400(defsetf char set-char)
401(defsetf bit %bitset)
403(defsetf schar set-schar)
404(defsetf sbit %sbitset)
405(defsetf symbol-value set)
406(defsetf %schar %set-schar)
409(defsetf symbol-plist set-symbol-plist)
410(defsetf nth %setnth)
412(defsetf nthcdr %set-nthcdr)
414(defsetf fill-pointer set-fill-pointer)
417(defsetf subseq (sequence start &optional (end nil)) (new-seq)
418  `(progn (replace ,sequence ,new-seq :start1 ,start :end1 ,end)
419          ,new-seq))
423(defsetf third set-caddr)
424(defsetf fourth set-cadddr)
425(defsetf fifth set-fifth)
426(defsetf sixth set-sixth)
427(defsetf seventh set-seventh)
428(defsetf eighth set-eighth)
429(defsetf ninth set-ninth)
430(defsetf tenth set-tenth)
433(defsetf caaar set-caaar)
434(defsetf caadr set-caadr)
435(defsetf cadar set-cadar)
436(defsetf caddr set-caddr)
437(defsetf cdaar set-cdaar)
438(defsetf cdadr set-cdadr)
439(defsetf cddar set-cddar)
440(defsetf cdddr set-cdddr)
445(defsetf caaaar set-caaaar)
446(defsetf caaadr set-caaadr)
447(defsetf caadar set-caadar)
448(defsetf caaddr set-caaddr)
449(defsetf cadaar set-cadaar)
450(defsetf cadadr set-cadadr)
451(defsetf caddar set-caddar)
452(defsetf cadddr set-cadddr)
455(defsetf cdaaar set-cdaaar)
456(defsetf cdaadr set-cdaadr)
457(defsetf cdadar set-cdadar)
458(defsetf cdaddr set-cdaddr)
459(defsetf cddaar set-cddaar)
460(defsetf cddadr set-cddadr)
461(defsetf cdddar set-cdddar)
462(defsetf cddddr set-cddddr)
464(defsetf %fixnum-ref %fixnum-set)
466(define-setf-method the (typespec expr &environment env)
467  (multiple-value-bind (dummies vals newval setter getter)
468                       (get-setf-method expr env)
469    (let ((store-var (gensym)))
470      (values
471       dummies
472       vals
473       (list store-var)
474       `(let ((,(car newval) ,store-var))
475                         ,setter)
476       `(the ,typespec ,getter)))))
479(define-setf-method apply (function &rest args &environment env)
480  (if (and (listp function)
481           (= (list-length function) 2)
482           (eq (first function) 'function)
483           (symbolp (second function)))
484      (setq function (second function))
485      (error
486       "Setf of Apply is only defined for function args of form #'symbol."))
487  (multiple-value-bind (dummies vals newval setter getter)
488                       (get-setf-expansion (cons function args) env)
489    ;; Make sure the place is one that we can handle.
490    ;;Mainly to insure against cases of ldb and mask-field and such creeping in.
491    (let* ((last-arg (car (last args)))
492           (last-val (car (last vals)))
493           (last-dummy (car (last dummies)))
494           (last-getter (car (last getter)))
495           (last2-setter (car (last setter 2)))
496           (last-setter (car (last setter))))
497      (cond ((and (or (and (eq last-arg last-val)
498                           (eq last-getter last-dummy))
499                      (eq last-arg last-getter))
500                  newval
501                  (null (cdr newval))
502                  (eq last-setter (car newval))
503                  (or (and (eq last-arg last-val)
504                           (eq last2-setter last-dummy))
505                      (eq last-arg last2-setter)))
506             ;; (setf (foo ... argn) bar) -> (set-foo ... argn bar)
507             (values dummies vals newval
508                     `(apply+ (function ,(car setter)) ,@(cdr setter))
509                     `(apply (function ,(car getter)) ,@(cdr getter))))
510            ((and (or (and (eq last-arg last-val)
511                           (eq last-getter last-dummy))
512                      (eq last-arg last-getter))
513                  newval
514                  (null (cdr newval))
515                  (eq (car setter) 'funcall)
516                  (eq (third setter) (car newval))
517                  (or (and (eq last-arg last-val)
518                           (eq last-setter last-dummy))
519                      (eq last-arg last-setter)))
520             ;; (setf (foo ... argn) bar) -> (funcall #'(setf foo) bar ... argn)  [with bindings for evaluation order]
521             (values dummies vals newval
522                     `(apply ,@(cdr setter))
523                     `(apply (function ,(car getter)) ,@(cdr getter))))
524            (t (error "Apply of ~S is not understood as a location for Setf."
525                      function))))))
527;;These are the supporting functions for the am-style hard-cases of setf.
528(defun assoc-2-lists (list1 list2)
529  "Not CL. Returns an assoc-like list with members taken by associating corresponding
530   elements of each list. uses list instead of cons.
531   Will stop when first list runs out."
532  (do* ((lst1 list1 (cdr lst1))
533        (lst2 list2 (cdr lst2))
534        (result nil))
535       ((null lst1) result)
536       (setq result (cons (list (car lst1)
537                                (car lst2))
538                          result))))
540(defun make-gsym-list (size)
541  "Not CL. Returns a list with size members, each being a different gensym"
542  (let ((temp nil))
543        (dotimes (arg size temp)
544          (declare (fixnum arg))
545          (setq temp (cons (gensym) temp)))))
548(define-setf-method getf (plist prop &optional (default () default-p)
549                                     &aux (prop-p (not (quoted-form-p prop)))
550                                     &environment env)
551 (multiple-value-bind (vars vals stores store-form access-form)
552                      (get-setf-method plist env)
553   (when default-p (setq default (list default)))
554   (let ((prop-var (if prop-p (gensym) prop))
555         (store-var (gensym))
556         (default-var (if default-p (list (gensym)))))
557     (values
558      `(,@vars ,.(if prop-p (list prop-var)) ,@default-var)
559      `(,@vals ,.(if prop-p (list prop)) ,@default)
560      (list store-var)
561      `(let* ((,(car stores) (setprop ,access-form ,prop-var ,store-var)))
562         ,store-form
563         ,store-var)
564      `(getf ,access-form ,prop-var ,@default-var)))))
566(define-setf-method getf-test (plist prop test &optional (default () default-p)
567                                       &aux (prop-p (not (quoted-form-p prop)))
568                                       &environment env)
569 (multiple-value-bind (vars vals stores store-form access-form)
570                      (get-setf-method plist env)
571   (when default-p (setq default (list default)))
572   (let ((prop-var (if prop-p (gensym) prop))
573         (test-var (gensym))
574         (store-var (gensym))
575         (default-var (if default-p (list (gensym)))))
576     (values
577      `(,@vars ,.(if prop-p (list prop-var)) ,test-var ,@default-var)
578      `(,@vals ,.(if prop-p (list prop)) ,test ,@default)
579      (list store-var)
580      `(let* ((,(car stores) (setprop-test ,access-form ,prop-var ,test-var ,store-var)))
581         ,store-form
582         ,store-var)
583      `(getf-test ,access-form ,prop-var ,test-var ,@default-var)))))
585(define-setf-method ldb (bytespec place &environment env)
586  "The first argument is a byte specifier. The second is any place form
587  acceptable to SETF. Replace the specified byte of the number in this
588  place with bits from the low-order end of the new value."
589  (multiple-value-bind (dummies vals newval setter getter)
590                       (get-setf-method place env)
591    (let ((btemp (gensym))
592          (gnuval (gensym)))
593      (values (cons btemp dummies)
594              (cons bytespec vals)
595              (list gnuval)
596              `(let ((,(car newval) (dpb ,gnuval ,btemp ,getter)))
597                 ,setter
598                 ,gnuval)
599              `(ldb ,btemp ,getter)))))
602(define-setf-method mask-field (bytespec place &environment env)
603  "The first argument is a byte specifier. The second is any place form
604  acceptable to SETF. Replaces the specified byte of the number in this place
605  with bits from the corresponding position in the new value."
606  (multiple-value-bind (dummies vals newval setter getter)
607                       (get-setf-method place env)
608    (let ((btemp (gensym))
609          (gnuval (gensym)))
610      (values (cons btemp dummies)
611              (cons bytespec vals)
612              (list gnuval)
613              `(let ((,(car newval) (deposit-field ,gnuval ,btemp ,getter)))
614                 ,setter
615                 ,gnuval)
616              `(mask-field ,btemp ,getter)))))
618(defmacro shiftf (arg1 arg2 &rest places-&-nuval &environment env)
619  "One or more SETF-style place expressions, followed by a single
620   value expression. Evaluates all of the expressions in turn, then
621   assigns the value of each expression to the place on its left,
622   returning the value of the leftmost."
623  (setq places-&-nuval (list* arg1 arg2 places-&-nuval))
624  (let* ((nuval (car (last places-&-nuval)))
625         (places (cdr (reverse places-&-nuval)))  ; not nreverse, since &rest arg shares structure with &whole.
626         (setters (list 'progn))
627         (last-getter nuval)
628         last-let-list
629         let-list
630         (body setters))
631    (dolist (place places)
632      (multiple-value-bind (vars values storevars setter getter)
633                           (get-setf-method-multiple-value place env)
634        (dolist (v vars)
635          (push (list v (pop values)) let-list))
636        (push setter (cdr setters))
637        (setq body
638              (if last-let-list
639                `(let* ,(nreverse last-let-list)
640                   (multiple-value-bind ,storevars ,last-getter
641                     ,body))
642                `(multiple-value-bind ,storevars ,last-getter
643                   ,body))
644              last-let-list let-list
645              let-list nil
646              last-getter getter)))
647    (if last-let-list
648      `(let* ,(nreverse last-let-list)
649         (multiple-value-prog1 ,last-getter
650           ,body))
651      `(multiple-value-prog1 ,last-getter
652         ,body))))
654;(shiftf (car x)(cadr x) 3)
657(defmacro rotatef (&rest args &environment env)
658  (let* ((setf-result nil)
659         (let-result nil)
660         (last-store nil)
661         (fixpair nil))
662    (dolist (arg args)
663      (multiple-value-bind (vars vals storevars setter getter)
664                           (get-setf-method arg env)
665        (dolist (var vars)
666          (push (list var (pop vals)) let-result))
667        (push (list last-store getter) let-result)
668        (unless fixpair (setq fixpair (car let-result)))
669        (push setter setf-result)
670        (setq last-store (car storevars))))
671    (rplaca fixpair last-store)
672    `(let* ,(nreverse let-result) ,@(nreverse setf-result) nil)))
675;(rotatef (blob x)(blob y))
676(defun blob (x) (values (car x)(cadr x)))
677(define-setf-method blob (x)
678    (let ((v1 (gensym))(v2 (gensym))(v3 (gensym)))
679    (values
680     (list v1)
681     (list x)
682     (list v2 v3)     
683     `(progn (setf (car ,v1) ,v2)
684             (setf (cadr ,v1) ,v3))     
685     `(values (car ,v1)(cadr ,v1)))))
688(defmacro rotatef (&rest args &environment env)
689  "Takes any number of SETF-style place expressions. Evaluates all of the
690   expressions in turn, then assigns to each place the value of the form to
691   its right. The rightmost form gets the value of the leftmost.
692   Returns NIL."
693  (when args
694    (let* ((places (reverse args))  ; not nreverse, since &rest arg shares structure with &whole.
695           (final-place (pop places))
696           (setters (list 'progn nil))
697           last-let-list
698           let-list
699           (body setters))
700      (multiple-value-bind (final-vars final-values final-storevars
701                                       final-setter last-getter)
702                           (get-setf-method-multiple-value final-place env)
703        (dolist (v final-vars)
704          (push (list v (pop final-values)) last-let-list))
705        (push final-setter (cdr setters))
706        (dolist (place places)
707          (multiple-value-bind (vars values storevars setter getter)
708                               (get-setf-method-multiple-value place env)
709            (dolist (v vars)
710              (push (list v (pop values)) let-list))
711            (push setter (cdr setters))
712            (setq body
713                  (if last-let-list
714                    `(let* ,(nreverse last-let-list)
715                       (multiple-value-bind ,storevars ,last-getter
716                         ,body))
717                    `(multiple-value-bind ,storevars ,last-getter
718                       ,body))
719                  last-let-list let-list
720                  let-list nil
721                  last-getter getter)))
722        (if last-let-list
723          `(let* ,(nreverse last-let-list)
724             (multiple-value-bind ,final-storevars ,last-getter
725               ,body))
726          `(multiple-value-bind ,final-storevars ,last-getter
727             ,body))))))
731(defmacro push (value place &environment env)
732  "Takes an object and a location holding a list. Conses the object onto
733  the list, returning the modified list. OBJ is evaluated before PLACE."
734  (if (not (consp place))
735    `(setq ,place (cons ,value ,place))
736    (multiple-value-bind (dummies vals store-var setter getter)
737                         (get-setf-method place env)
738      (let ((valvar (gensym)))
739        `(let* ((,valvar ,value)
740                ,@(mapcar #'list dummies vals)
741                (,(car store-var) (cons ,valvar ,getter)))
742           ,@dummies
743           ,(car store-var)
744           ,setter)))))
746(defmacro pushnew (value place &rest keys &environment env)
747  "Takes an object and a location holding a list. If the object is
748  already in the list, does nothing; otherwise, conses the object onto
749  the list. Returns the modified list. If there is a :TEST keyword, this
750  is used for the comparison."
751  (if (not (consp place))
752    `(setq ,place (adjoin ,value ,place ,@keys))
753    (let ((valvar (gensym)))
754      (multiple-value-bind (dummies vals store-var setter getter)
755                           (get-setf-method place env)
756        `(let* ((,valvar ,value)
757                ,@(mapcar #'list dummies vals)
758                (,(car store-var) (adjoin ,valvar ,getter ,@keys)))
759           ,@dummies
760           ,(car store-var)
761           ,setter)))))
763(defmacro pop (place &environment env &aux win)
764  "The argument is a location holding a list. Pops one item off the front
765  of the list and returns it."
766  (while (atom place)
767    (multiple-value-setq (place win) (macroexpand-1 place env))
768    (unless win
769      (return-from pop
770        `(prog1 (car ,place) (setq ,place (cdr (the list ,place)))))))
771  (let ((value (gensym)))
772    (multiple-value-bind (dummies vals store-var setter getter)
773                         (get-setf-method place env)
774      `(let* (,@(mapcar #'list dummies vals)
775              (,value ,getter)
776              (,(car store-var) (cdr ,value)))
777         ,@dummies
778         ,(car store-var)
779         (prog1
780           (%car ,value)
781           ,setter)))))
783(defmacro %pop (symbol)
784  `(prog1 (%car ,symbol) (setq ,symbol (%cdr ,symbol))))
787(defmacro push (item place)
788  (if (not (consp place))
789    `(setq ,place (cons ,item ,place))
790    (let* ((arg-num (1- (length place)))
791           (place-args (make-gsym-list arg-num)))
792      `(let ,(cons (list 'nu-item item)
793                   (reverse (assoc-2-lists place-args (cdr place))))
794         (setf (,(car place) ,@place-args)
795               (cons nu-item (,(car place) ,@place-args)))))))
797(defmacro pushnew (item place &rest key-args)
798  (let ((item-gsym (gensym)))
799    (if (not (consp place))
800      `(let ((,item-gsym ,item))
801         (setq ,place (adjoin ,item-gsym ,place ,@key-args)))
802      (let* ((arg-num (1- (length place)))
803             (place-args (make-gsym-list arg-num)))
804        `(let ,(cons (list item-gsym item)
805                     (reverse (assoc-2-lists place-args (cdr place))))
806           (setf (,(car place) ,@place-args)
807                 (adjoin ,item-gsym (,(car place) ,@place-args)
808                         ,@key-args)))))))
809(defmacro pop (place)
810  (if (not (consp place))               ;  screw: symbol macros.
811    `(prog1 (car ,place) (setq ,place (%cdr ,place)))
812    (let* ((arg-num (1- (length place)))
813           (place-args (make-gsym-list arg-num)))
814      `(let ,(reverse (assoc-2-lists place-args (cdr place)))
815         (prog1 (car (,(car place) ,@place-args))
816           (setf (,(car place) ,@place-args)
817                 (cdr (,(car place) ,@place-args))))))))
820(defmacro remf (place indicator &environment env)
821  "Place may be any place expression acceptable to SETF, and is expected
822  to hold a property list or (). This list is destructively altered to
823  remove the property specified by the indicator. Returns T if such a
824  property was present, NIL if not."
825  (multiple-value-bind (dummies vals newval setter getter)
826                       (get-setf-method place env)
827    (do* ((d dummies (cdr d))
828          (v vals (cdr v))
829          (let-list nil)
830          (ind-temp (gensym))
831          (local1 (gensym))
832          (local2 (gensym)))
833         ((null d)
834          (push (list ind-temp indicator) let-list)
835          (push (list (car newval) getter) let-list)
836          `(let* ,(nreverse let-list)
837             (do ((,local1 ,(car newval) (cddr ,local1))
838                  (,local2 nil ,local1))
839                 ((atom ,local1) nil)
840               (cond ((atom (cdr ,local1))
841                      (error "Odd-length property list in REMF."))
842                     ((eq (car ,local1) ,ind-temp)
843                      (cond (,local2
844                             (rplacd (cdr ,local2) (cddr ,local1))
845                             (return t))
846                            (t (setq ,(car newval) (cddr ,(car newval)))
847                               ,setter
848                               (return t))))))))
849      (push (list (car d) (car v)) let-list))))
851(defmacro remf-test (place indicator test &environment env)
852  "Place may be any place expression acceptable to SETF, and is expected
853  to hold a property list or ().  This list is destructively altered to
854  remove the property specified by the indicator.  Returns T if such a
855  property was present, NIL if not."
856  (multiple-value-bind (dummies vals newval setter getter)
857                       (get-setf-method place env)
858    (do* ((d dummies (cdr d))
859          (v vals (cdr v))
860          (let-list nil)
861          (ind-temp (gensym))
862          (test-temp (gensym))
863          (local1 (gensym))
864          (local2 (gensym)))
865         ((null d)
866          (push (list (car newval) getter) let-list)
867          (push (list ind-temp indicator) let-list)
868          (push (list test-temp test) let-list)
869          `(let* ,(nreverse let-list)
870             (do ((,local1 ,(car newval) (cddr ,local1))
871                  (,local2 nil ,local1))
872                 ((atom ,local1) nil)
873               (cond ((atom (cdr ,local1))
874                      (error "Odd-length property list in REMF."))
875                     ((funcall ,test-temp (car ,local1) ,ind-temp)
876                      (cond (,local2
877                             (rplacd (cdr ,local2) (cddr ,local1))
878                             (return t))
879                            (t (setq ,(car newval) (cddr ,(car newval)))
880                               ,setter
881                               (return t))))))))
882      (push (list (car d) (car v)) let-list))))
884(define-setf-expander values (&rest places &environment env) 
885  (let* ((setters ())
886         (getters ())
887         (all-dummies ()) 
888         (all-vals ()) 
889         (newvals ())) 
890    (dolist (place places) 
891      (multiple-value-bind (dummies vals newval setter getter) 
892          (get-setf-expansion place env) 
893        (setf all-dummies (append all-dummies dummies (cdr newval))) 
894        (setf all-vals (append all-vals vals (mapcar (constantly nil) (cdr newval)))) 
895        (setf newvals (append newvals (list (car newval)))) 
896        (push setter setters)
897        (push getter getters))) 
898      (values all-dummies all-vals newvals 
899              `(values ,@(nreverse setters)) `(values ,@(nreverse getters)))))
Note: See TracBrowser for help on using the repository browser.