[Postmaster@bbn.com: Unable to deliver letter]

[kanderso@WILMA.BBN.COM]

Sorry if this wen't out twice.  I had a mailer problem.
------- Forwarded Message

Received: from R&B.bbn.com by CONGER.bbn.com via CHAOS with CHAOS-MAIL id 44801;
Sun 17-Apr-88 16:49:19 EDT
Date: Sun, 17 Apr 88 16:49 EDT
From: Kenneth R. Anderson <kanderson@VAX.bbn.com>
Subject: next-method-p
To: commonloops.pa@xerox.com
cc: kanderson@bbn.com
Message-ID: <880417164933.1.KANDERSON@R&B.bbn.com>


;;; From boot.lisp

;;; KRA: Added next-method-p as lexical function like call-next-method.
;;; Since we are walking the code, we could be a bit smarter about inlining
special
;;; cases.
(export 'next-method-p 'pcl)

(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)
	  (next-method-p nil)		; KRA
	  (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)
		     ((eq (car form) 'next-method-p) ; KRA
		      (setq next-method-p t)
		      form)
		     ((and (eq (car form) 'function) ; KRA
			   (eq (cadr form) 'next-method-p))
		      (setq next-method-p 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 ((not (or call-next-method-p 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))
			     ,@(if next-method-p
				   '((next-method-p () .next-method.))
				 ()))
			,@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)))
			     ,@(if next-method-p
				    '((next-method-p () .next-method.))
				  ()))
			(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))))
			     ,@ (if next-method-p
				    '((next-method-p () .next-method.))
				  ()))
			(apply (function ,walked-lambda)
			       ,@(remove '&rest original-args))))))))))))



------- End of Forwarded Message