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

Last change on this file since 14172 was 13140, checked in by gz, 10 years ago

Merge r13103 (setf values fix)

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