Re: new version of PCL

[Gregor.pa@Xerox.COM]

    Date: Tue, 2 Aug 88 14:26:14 CDT
    From: Rob Pettengill <rcp%sw.MCC.COM@MCC.COM>

    1.  There appears to be an extra comma in boot.lisp

Yes, there is a typo in this file in 8/1/88 PCL.  I have fixed the
version of the file on arisia.xerox.com, so you can either ftp a new
version, or make the following patch.

;from boot.lisp
(defun expand-defmethod-internal
       (generic-function-name qualifiers specialized-lambda-list body env)
  (declare (values fn-form specializers doc)
	   (ignore qualifiers))
  (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
	     (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)
			  (declare (ignore parameter))
			  (if class
			      (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 class
			      (optimize-standard-instance-access class
								 parameter
								 form
								 slots)
			      form)))
		       (t form))))
	  
	  (setq walked-lambda (walk-form method-lambda env #'walk-function))

	  ;; 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)
		    (let ((aux (memq '&aux lambda-list)))
		      (dolist (a aux) (push a original-args))
		      (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
				call-next-method-p
				next-method-p-p)
			      `(lambda ,lambda-list
				 ,@walked-declarations
				 ,.walked-lambda-body)))
	      specializers
	      documentation
	      plist)))))))
-------