bug in nested :around methods

[Gregor.pa@Xerox.COM]

    Date: Tue, 9 Feb 88 14:15:07 PST
    From: jam%entropy.ms@beaver.cs.washington.edu (John Alan McDonald)

    ;;; In PCL version 2-7-88, Symbolics Genera 7.1,
    ;;; nested :around methods cause infinite loops:

The following patch to the file boot.lisp fixes this.  To save yourself
time installing this patch, it is alright to put it in a patches file
which is loaded after all of PCL is loaded.  In other words, there is no
need to recompile all of PCL just to install this patch.

(defun expand-defmethod-body-internal
       (generic-function-name lambda-list specializers body env)
  (multiple-value-bind (doc declares real-body)
      (extract-declarations body env)
    (declare (ignore doc))			;We drop it on the floor
						;since it gets recorded
						;elsewhere.
    (let ((class-declarations 
	    `(declare ,@(mapcar #'(lambda (a s)
				    (and (symbolp s) `(class ,a ,s)))
				lambda-list
				specializers)))
	  (call-next-method-p nil)
	  (save-original-args nil)
	  (original-args ())
	  (applyp nil)
	  (walked-lambda nil))
      (flet ((walk-function (form context env &aux temp)
	       (cond ((not (eq context ':eval)) form)
		     ((not (listp form)) form)
		     ((eq (car form) 'call-next-method)
		      (setq call-next-method-p 't
			    save-original-args (not (cdr form)))
		      form)
		     ((and (eq (car form) 'function)
			   (eq (cadr form) 'call-next-method))
		      (setq call-next-method-p 't
			    save-original-args 't)
		      form)
		     ((and (or (eq (car form) 'slot-value)
			       (eq (car form) 'set-slot-value))
			   (symbolp (cadr form))
			   (constantp (caddr form))
			   (setq temp (variable-class (cadr form) env))
			   (or (not (symbolp temp))
			       (setq temp (class-named temp 't))))
		      (ecase (car form)
			(slot-value (optimize-slot-value temp form))
			(set-slot-value (optimize-set-slot-value temp form))))
		     (t form))))
	(setq walked-lambda (walk-form
			      `(lambda ,lambda-list
				 ,class-declarations
				 ,@declares
				 (block ,generic-function-name ,@real-body))
			      env
			      #'walk-function))
	(when save-original-args
	  ;; We are going to have to be able to store away the original
	  ;; arguments to the function.  Get ourselves an argument list
	  ;; to do this with.
	  (dolist (a lambda-list)
	    (if (member a lambda-list-keywords)
		(if (eq a '&aux)
		    (return)
		    (progn
		      (setq applyp t)
		      (push '&rest original-args)
		      (push (gensym) original-args)
		      (return)))
		(push (gensym) original-args)))
	  (setq original-args (reverse original-args)))

	(multiple-value-bind (doc walked-declares walked-lambda-body)
	    (extract-declarations (cddr walked-lambda))
	  (declare (ignore doc))
	  (cond ((null call-next-method-p) walked-lambda)
		((null save-original-args)
		 `(lambda ,lambda-list
		    ,@walked-declares
		    (let ((.next-method. (car *next-methods*))
			  (*next-methods* (cdr *next-methods*)))
		      (flet ((call-next-method (&rest cnm-args)
			       (apply .next-method. cnm-args)))
			,@walked-lambda-body))))
		((null applyp)
		 `(lambda ,original-args
		    (let ((.next-method. (car *next-methods*))
			  (*next-methods* (cdr *next-methods*)))
		      (flet ((call-next-method (&rest cnm-args)
			       (if cnm-args
				   (apply .next-method. cnm-args)
				   (funcall .next-method. ,@original-args))))
			(let ,(mapcar #'list lambda-list original-args)
			  ,@walked-declares
			  ,@walked-lambda-body)))))
		(t
		 `(lambda ,original-args
		    (let ((.next-method. (car *next-methods*))
			  (*next-methods* (cdr *next-methods*)))
		      (flet ((call-next-method (&rest cnm-args)
			       (if cnm-args
				   (apply .next-method. cnm-args)
				   (apply .next-method. 
					  ,@(remove '&rest original-args)))))
			(apply (function ,walked-lambda)
			       ,@(remove '&rest original-args))))))))))))
-------