home *** CD-ROM | disk | FTP | other *** search
/ NetNews Usenet Archive 1993 #1 / NN_1993_1.iso / spool / comp / lang / lisp / 3190 < prev    next >
Encoding:
Text File  |  1993-01-06  |  2.6 KB  |  62 lines
  1. Newsgroups: comp.lang.lisp
  2. Path: sparky!uunet!stanford.edu!lucid.com!karoshi!fy
  3. From: fy@lucid.com (Frank Yellin)
  4. Subject: Re: (SETF VALUES)
  5. In-Reply-To: philpot@kepler.arc.nasa.gov's message of Wed, 6 Jan 1993 21:31:39 GMT
  6. Message-ID: <FY.93Jan6155542@hardwick.lucid.com>
  7. Sender: usenet@lucid.com
  8. Organization: Lucid, Inc., Menlo Park, CA
  9. References: <1993Jan6.213139.27999@kronos.arc.nasa.gov>
  10. Date: 6 Jan 93 15:55:42
  11. Lines: 49
  12.  
  13.  
  14. In article <1993Jan6.213139.27999@kronos.arc.nasa.gov>
  15. philpot@kepler.arc.nasa.gov (Andrew Philpot) writes: 
  16.  
  17. >   Is it possible to implement (SETF VALUES) in a Lisp which doesn't
  18. >   already do this?
  19.  
  20. Always happy to help.
  21.  
  22. -- Frank Yellin
  23.    fy@lucid.com
  24.  
  25. (define-setf-method values (&rest arguments &environment environment)
  26.   (let (all-dummies all-values all-newvals all-setters all-getters)
  27.     (dolist (place arguments)
  28.       ;; look at each of the place arguments
  29.       (multiple-value-bind (dummies values newvals setter getter)
  30.           ;; get the setf method for each place argument
  31.       (get-setf-method-multiple-value place environment)
  32.         ;; collect all the dummies, and the values to bind them to
  33.     (push dummies all-dummies)   ; list of dummies for each place
  34.     (push values all-values)     ; list of values for each place
  35.     (push getter all-getters)    ; list of getters for each place
  36.         ;; Collect the setters and the newvals variables.  This is
  37.         ;; slightly complicated if (length newvals) isn't 1.  For example,
  38.         ;; (setf (values a (values b c) d) ...) should always set c to 
  39.         ;; 'nil, and (setf (values (values) b) ...) should just ignore the
  40.         ;; first value passed.
  41.     (cond ((null newvals)
  42.            ;; Will this ever happen?  A setf method expecting no newvals?
  43.                ;; Create a gensym to gets its value, and ignore it
  44.            (let ((temp (gensym)))
  45.          (push temp all-newvals)
  46.          (push `(locally (declare (ignore ,temp)) ,setter) all-setters)))
  47.           ((null (cdr newvals))    ; The most common case.
  48.                ;; Just collect the setter and the single newval slot
  49.            (push (car newvals) all-newvals)
  50.            (push setter all-setters))
  51.           (t
  52.                ;; The place argument expects multiple values.  Bind all but
  53.                ;; the first one to nil in the setter.
  54.            (push (car newvals) all-newvals)         
  55.            (push `(let ,(cdr newvals) ,setter) all-setters)))))
  56.     ;; Return the five values
  57.     (values (apply 'nconc (nreverse all-dummies))
  58.         (apply 'append (nreverse all-values))
  59.         (nreverse all-newvals)
  60.         `(values ,@(nreverse all-setters))
  61.         `(values ,@(nreverse all-getters)))))
  62.