Re: Auto-creation in a SETF method

At 12:25 PM 2/23/2004, Peter Seibel wrote:
>JP Massar <[email protected]> writes:
>
> > Suppose I've defined an class called ZOOP, and it has a slot SLOT.
> >
> >
> > Now suppose, for whatever perverted reason, I want the following:
> >
> > (let ((x nil))
> >    (setf (ZOOP-SLOT x) 23))
> >
> > to 'just work', that is, if X is not a ZOOP, I want to effectively have the
> > SETF generate
> >
> > (SETQ X (MAKE-INSTANCE :ZOOP))
>
>
>Unless I misunderstand your requirements here is--I think--an
>existance proof that it *is* possible. This also handles X being an
>arbitrary place and gives a semi-meaningful error message if X is not
>a place:
>
>   (defclass zoop () ((slot :initarg :slot :reader zoop-slot)))
>
>   (define-setf-expander zoop-slot (x &environment env)
>     (multiple-value-bind (xtemps xvals xstore-vars xwriter xreader)
>         (get-setf-expansion x env)
>       (let ((store (gensym))
>             (xstore (first xstore-vars)))
>         (if (rest xstore-vars) (error "To many store vars."))
>         (values
>          nil
>          nil
>          (list store)
>          `(let*
>               (,@(mapcar #'list xtemps xvals)
>                  (,xstore
>                   (if (typep ,xreader 'zoop) ,xreader (make-instance 
> 'zoop))))
>             (setf (slot-value ,xstore 'slot) ,store)
>             ,xwriter
>             ,store)
>          `(slot-value ,xreader 'slot)))))

Ah, wonderful!

Just incredible, super cool.

I doubt that I would have ever figured that out.  Thanks!!!

Here's my modification of your solution to work on my real problem:
not a slot accessor but in effect an array accessor.  It seems to do
the trick.

;;; If you understand this, you're a better Lisper than me.
;;; Thanks to Peter Seibel to providing the template.

(define-setf-expander gref (x &rest indices &environment env)
   (multiple-value-bind (xtemps xvals xstore-vars xwriter xreader)
       (get-setf-expansion x env)
     (let ((store (gensym))
           (xstore (first xstore-vars))
           (index-gensyms
            (loop for j from 0 for i in indices collect
                  (progn i (gensym (format nil "INDEX~D-" j))))))
       (if (rest xstore-vars) (error "To many store vars."))
       (values
        index-gensyms
        indices
        (list store)
        `(let*
             (,@(mapcar #'list xtemps xvals)
              (,xstore
               (if (ignore-errors (typep ,xreader 'garray))
                   ,xreader
                 (create-garray-from-&rest-indices ,@index-gensyms))))
           (setf-gref ,xstore ,store ,@index-gensyms)
           ,xwriter
           ,store)
        `(gref ,xreader ,@index-gensyms)))))