[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]

7/7 bugs

Here are some questions, bug reports, and bug fixes for 7/7/88 PCL:

1.  Question: Why is DEFINE-BUILT-IN-CLASSES no longer a macro? I
presume it is to avoid the explicit COMPILE the old version had.  What
is the right way for users to add their own built ins?

2.  Question: In METHODS.LISP and probably elsewhere there are methods
specialized on T when they should be specialized on GENERIC-FUNCTION,
say.  Is there a good reason for this?  Specializing them on T
invalidates them unnecesarily every time a new class is defined.

3.  Bug: On 3600's M-. only finds method definitions that have been
seen by ZMACS, not just loaded it.

4.  Gregor's latest version of expand-with-slots had an argument
reversed.  This version seems to work:

(defun expand-with-slots (specs whole body env gensym instance translate-fn)
  (DECLARE (IGNORE WHOLE))                      ; KRA
  (walk-form
    `(let ((,gensym ,instance))
       ,@(and (symbolp instance)
	      `((declare (variable-rebinding ,gensym ,instance))))
       ,GENSYM					; KRA: avoid compiler warnings 
       ,@body)
    env
    #'(lambda (f c e)
	(declare (ignore e))
	(expand-with-slots-internal specs
				    f
				    c
				    translate-fn))))

5. EXPAND-DEFMETHOD-INTERNAL didn't seem to work right when a method
contained a CALL-NEXT-METHOD because variables like .ISL. and .PV.
were declared special.  This version also fixes Jim Larus' complaint
about IGNORE declarations.

(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
	       (remove nil
		       (FLET ((IGNORED-P (S)	; Is S declared ignored?
				(DOLIST (D (CDR (FIRST DECLARATIONS)))
				  (WHEN (AND (EQ (FIRST D) 'IGNORE)
					     (MEMBER S (CDR D)))
				    (RETURN T)))))
			 (mapcar #'(lambda (s r)
				     (declare (ignore r))
				     (and (listp s) (NOT (IGNORED-P (CAR S)))
					  (car s)))
				 specialized-lambda-list
				 required-parameters))))
	     (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
		    ,@PARAMETERS-TO-REFERENCE
		    (block ,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))))

	  (maybe-warn-about-redundant-ignores declarations
					      parameters-to-reference
					      generic-function-name
					      specializers)
	  (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))
	      (SETQ WALKED-LAMBDA `(LAMBDA ,LAMBDA-LIST	; KRA where should this go?
				     ,@WALKED-DECLARATIONS
				     ,.WALKED-LAMBDA-BODY)))
	    (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
				walked-lambda
				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)))))))