Re: PCL bug or CLOS spec issue?

[Gregor.pa@Xerox.COM]

    Date: Wed, 21 Dec 88 14:50:03 PST
    From: goldman@vaxa.isi.edu

    When I try to define a recursive method for (setf foo), and it is the
    FIRST method being defined for (setf foo), I get an error message from
    PCL's code walker, because the use of (setf foo) in the body is not (yet)
    acceptable.

Resolving this kind of problem is exactly what the cleanup proposal setf
function is all about.  By assigning a default behavior to setf, it
resolves any problems having to do with trying to expand a setf before
it is defined.

Currently, PCL uses a hack to pretend that the required underlying
change to setf has been made, your example is tickling a bug in that
hack.  The following patch should solve your problem:

;from boot.lisp
(defun expand-defmethod-internal
       (generic-function-name qualifiers specialized-lambda-list body env)
  (declare (values fn-form specializers doc)
	   (ignore qualifiers))
  (when (listp generic-function-name)
    (do-standard-defsetf-1 (cadr generic-function-name)))
  (multiple-value-bind (documentation declarations real-body)
      (extract-declarations body)
    (multiple-value-bind (parameters lambda-list specializers)
	(parse-specialized-lambda-list specialized-lambda-list)

      
      (let* ((required-parameters
	       (mapcar #'(lambda (r s) (declare (ignore s)) r)
		       parameters
		       specializers))
	     (parameters-to-reference
	       (make-parameter-references specialized-lambda-list
					  required-parameters
					  declarations
					  generic-function-name
					  specializers))
	     (class-declarations 
	       `(declare
		  ,@(remove nil
			    (mapcar #'(lambda (a s) (and (symbolp s)
							 (neq s 't)
							 `(class ,a ,s)))
				    parameters
				    specializers))))
	     (method-lambda 
	       ;; Remove the documentation string and insert the
	       ;; appropriate class declarations.  The documentation
	       ;; string is removed to make it easy for us to insert
	       ;; new declarations later, they will just go after the
	       ;; cadr of the method lambda.  The class declarations
	       ;; are inserted to communicate the class of the method's
	       ;; arguments to the code walk.
	       (let ()
		 `(lambda ,lambda-list
		    ,class-declarations
		    ,@declarations
		    (progn ,@parameters-to-reference)
		    (block ,(if (listp generic-function-name)
				(cadr generic-function-name)
				generic-function-name)
		      ,@real-body))))

	     (call-next-method-p nil)   ;flag indicating that call-next-method
	                                ;should be in the method definition
	     (next-method-p-p nil)      ;flag indicating that next-method-p
                                        ;should be in the method definition
	     (save-original-args nil)   ;flag indicating whether or not the
				        ;original arguments to the method
					;must be preserved.  This happens
					;for two reasons:
	                                ; - the method takes &mumble args,
					;   so one of the lexical functions
					;   might be used in a default value
	                                ;   form
					; - call-next-method is used without
					;   arguments at least once in the
					;   body of the method
	     (original-args ())
	     (applyp nil)		;flag indicating whether or not the
					;method takes &mumble arguments. If
					;it does, it means call-next-method
					;without arguments must be APPLY'd
					;to original-args.  If this gets set
					;true, save-original-args is set so
					;as well
	     (aux-bindings ())		;Suffice to say that &aux is one of
					;damndest things to have put in a
					;language.
	     (slots (mapcar #'list required-parameters))
	     (plist ())
	     (walked-lambda nil))
	(flet ((walk-function (form context env)
		 (cond ((not (eq context ':eval)) form)
		       ((not (listp form)) form)
		       ((eq (car form) 'call-next-method)
			(setq call-next-method-p 't)
			(setq save-original-args (not (cdr form)))
			form)
		       ((eq (car form) 'next-method-p)
			(setq next-method-p-p 't)
			form)
		       ((and (eq (car form) 'function)
			     (cond ((eq (cadr form) 'call-next-method)
				    (setq call-next-method-p 't)
				    (setq save-original-args 't)
				    form)
				   ((eq (cadr form) 'next-method-p)
				    (setq next-method-p-p 't)
				    form)
				   (t nil))))
		       ((and (or (eq (car form) 'slot-value)
				 (eq (car form) 'set-slot-value))
			     (symbolp (cadr form))
			     (constantp (caddr form)))
			(multiple-value-bind (parameter class)
			    (can-optimize-access (cadr form) env)
			  (if parameter
			      (ecase (car form)
				(slot-value
				  (optimize-slot-value class form))
				(set-slot-value
				  (optimize-set-slot-value class form)))
			      form)))
		       ((eq (car form) 'standard-instance-access)
			(multiple-value-bind (parameter class)
			    (can-optimize-access (cadr form) env)
			  (if parameter
			      (optimize-standard-instance-access class
								 parameter
								 form
								 slots)
			      form)))
		       (t form))))
	  
	  (setq walked-lambda (walk-form method-lambda env #'walk-function))

	  ;;
	  ;; Add &allow-other-keys to the lambda list as an interim
	  ;; way of implementing lambda list congruence rules.
	  ;;
	  (when (and (memq '&key lambda-list)
		     (not (memq '&allow-other-keys lambda-list)))
	    (let* ((rll (reverse lambda-list))
		   (aux (memq '&aux rll)))
	      (setq lambda-list
		    (if aux
			(progn (setf (cdr aux)
				     (cons '&allow-other-keys (cdr aux)))
			       (nreverse rll))
		        (nconc (nreverse rll) (list '&allow-other-keys))))))
	  ;; Scan the lambda list to determine whether this method
	  ;; takes &mumble arguments.  If it does, we set applyp and
	  ;; save-original-args true.
	  ;; 
	  ;; This is also the place where we construct the original
	  ;; arguments lambda list if there has to be one.
	  (dolist (p lambda-list)
	    (if (memq p lambda-list-keywords)
		(if (eq p '&aux)
		    (progn
		      (setq aux-bindings (cdr (memq '&aux lambda-list)))
		      (return nil))
		    (progn
		      (setq applyp t
			    save-original-args t)
		      (push '&rest original-args)
		      (push (make-symbol "AMPERSAND-ARGS") original-args)
		      (return nil)))
		(push (make-symbol (symbol-name p)) original-args)))
	  (setq original-args (if save-original-args
				  (nreverse original-args)
				  ()))
	  
	  (multiple-value-bind (ignore walked-declarations walked-lambda-body)
	      (extract-declarations (cddr walked-lambda))
	    (declare (ignore ignore))

	    
	    (when (some #'cdr slots)
	      (setq slots (sort-slots-into-isl slots))
	      (setq plist (list* :isl slots plist))
	      (setq walked-lambda-body (add-pv-binding walked-lambda-body
						       plist
						       required-parameters
						       specializers)))
	    (when (or next-method-p-p call-next-method-p)
	      (setq plist (list* :needs-next-methods-p 't plist)))

	    (values
	      `(function ,(if (or call-next-method-p next-method-p-p)
			      (add-lexical-functions-to-method-lambda
				walked-declarations
				walked-lambda-body
				`(lambda ,lambda-list
				   ,@walked-declarations
				   ,.walked-lambda-body)
				original-args
				lambda-list
				save-original-args
				applyp
				aux-bindings
				call-next-method-p
				next-method-p-p)
			      `(lambda ,lambda-list
				 ,@walked-declarations
				 ,.walked-lambda-body)))
	      specializers
	      documentation
	      plist)))))))
-------