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

More bugs in PCL

PCL calls NO-APPLICABLE-METHOD incorrectly; it passes the arguments to the
generic function as the second argument rather than as a rest argument.  I
have made a set of changes which fixes this, included below.  In addition,
I made NO-APPLICABLE-METHOD use CERROR to signal the error; the restart
applies the generic function to the same arguments (which is why I had to
fix the problem with calling NO-APPLICABLE-METHOD incorrectly).

Also, I added "#+Genera (declare (dbg:invisible-frame :pcl-internals))" to
a number of functions so they don't appear in backtraces unless
specifically requested under Genera.  You can request invisible frames in
stack movement with control-meta-N, and c-m-P, and can see them in
backtraces with c-m-B.  You can also push :PCL-INTERNALS onto the list

I also fixed the problem with PCL EQL method dispatches; it turned out
that the problem was that at load time the "constant" in the EQL method
definition was not getting evaluated, so the constant needed to be EQL to
'(QUOTE FOO) instead of 'FOO.  Also, DEFMETHOD was not telling the
compiler that the generic function was a function, which was causing the
compiler to issue spurious warnings about calling functions which were not

I added a #+Genera clause to SETFBOUNDP.

Finally, Dave Linden (DCPL@ILA.Dialnet.Symbolics.COM) fixed a bug in the
walker handler for PROG/PROG*.  It was not possible to walk over a PROG
which had a block name, which some Genera macro was generating.

There is one remaining really irritating bug, which is that DEFCONSTRUCTOR
causes a warning that the function involved was defined twice when the
file is loaded.  This is because DEFCONSTRUCTOR expands into 

   (progn (defun <constructor-name> (&rest ignore)
	    (error "Constructor not loaded"))

That first subform should really be

   (proclaim '(function <constructor-name>))

or equivalent.  I will probably be providing such a patch soon if I can
figure out how to make it work in the Franz environment we are also using.


Here is a copy of my PCL-PATCHES file.

;;; -*- Mode: LISP; Syntax: Common-lisp; Package: PCL; Base: 10; Patch-File: T -*-
(in-package 'pcl)

(pushnew ':pcl-internals dbg:*all-invisible-frame-types*)

;;; From FIN.LISP:
;;; The inner closure of this function will have its code vector replaced
;;;  by a hand-coded fast jump to the function that is stored in the 
;;;  captured-lexical variable.  In effect, that code is a hand-
;;;  optimized version of the code for this inner closure function.
(defun make-trampoline (function)
  (declare (optimize (speed 3) (safety 0)))
  #'(lambda (&rest args)
      #+Genera (declare (dbg:invisible-frame :pcl-internals))
      (apply function args)))


(defmacro protect-cache-miss-code (gf args &body body)
  (let ((function (gensym)) (appl (gensym)))
    (once-only (gf args)
      `(if (memq ,gf *invalid-dfuns-on-stack*)
	   (multiple-value-bind (,function ,appl)
	       (get-secondary-dispatch-function ,gf ,args)
	     (if (null ,appl)
		 (apply #'no-applicable-method ,gf ,args)
		 (apply ,function ,args)))
	   (let ((*invalid-dfuns-on-stack* (cons ,gf *invalid-dfuns-on-stack*)))

(defmethod no-applicable-method (generic-function &rest args)
  (cerror "Retry call to ~S"
	  "No matching method for the generic-function ~S,~@
          when called with arguments ~S."
	  generic-function args)
  (let ((*invalid-dfuns-on-stack* (remove generic-function *invalid-dfuns-on-stack*)))
    (invalidate-discriminating-function generic-function)
    (apply generic-function args)))

;;; From DFUN.LISP:

(defun make-initial-dfun (generic-function)
  #'(lambda (&rest args)
      #+Genera (declare (dbg:invisible-frame :pcl-internals))
      (initial-dfun args generic-function)))

(defun invalidate-dfun-internal (generic-function)
  ;; Set the funcallable instance function to something that just calls
  ;; invalid-dfun, that is, arrange to use lazy evaluation to update the
  ;; dfun later.
    #'(lambda (&rest args)
	#+Genera (declare (dbg:invisible-frame :pcl-internals))
	(invalid-dfun generic-function args)))
  ;; Except that during bootstrapping, we would like to update the dfun
  ;; right away, and this arranges for that.
  (when *invalidate-discriminating-function-force-p*    
    (let ((*invalid-dfuns-on-stack*
	    (cons generic-function *invalid-dfuns-on-stack*)))
	(compute-discriminating-function generic-function)))))

(defun invalid-dfun (gf args)
  #+Genera (declare (dbg:invisible-frame :pcl-internals))
  (protect-cache-miss-code gf args
    (let ((new-dfun (compute-discriminating-function gf)))
      (set-funcallable-instance-function gf new-dfun)
      (apply gf args))))

(defun accessor-miss (gf ostate otype new object oindex ow0 ow1 field cache)
  (declare (ignore ow1))
  (let ((args (ecase otype			;The congruence rules assure
		(reader (list object))		;us that this is safe despite
		(writer (list new object)))))	;not knowing the new type yet.
    (protect-cache-miss-code gf
      (multiple-value-bind (wrappers invalidp nfunction applicable)
	  (cache-miss-values gf args)
	(multiple-value-bind (ntype nindex)
	    (accessor-miss-values gf applicable args)
	  ;; The following lexical functions change the state of the
	  ;; dfun to that which is their name.  They accept arguments
	  ;; which are the parameters of the new state, and get other
	  ;; information from the lexical variables bound above.
	  (flet ((two-class (index w0 w1)
		   (when (zerop (random 2)) (psetf w0 w1 w1 w0))
		   (ecase ntype
		     (reader (update-to-two-class-readers-dfun gf w0 w1 index))
		     (writer (update-to-two-class-writers-dfun gf w0 w1 index))
		 (one-index (index &optional field cache)
		   (ecase ntype
		       (update-to-one-index-readers-dfun gf index field cache))
		       (update-to-one-index-writers-dfun gf index field cache))
		 (n-n (&optional field cache)
		   (ecase ntype
		     (reader (update-to-n-n-readers-dfun gf field cache))
		     (writer (update-to-n-n-writers-dfun gf field cache))))
		 (checking ()
		   (update-to-checking-dfun gf nfunction))
		 (do-fill (valuep limit-fn update-fn)
		   (multiple-value-bind (nfield ncache)
		       (fill-cache field cache
				   1 valuep
				   limit-fn wrappers nindex)
		     (unless (and (= nfield field)
				  (eq ncache cache))
		       (funcall update-fn nfield ncache)))))

	    (cond ((null nfunction)
                   (apply #'no-applicable-method gf args))
		  ((null ntype)
		   (apply nfunction args))
                  ((or invalidp
                       (null nindex))
                   (apply nfunction args))
		  ((not (or (std-instance-p object)
			    (fsc-instance-p object)))
		   (apply nfunction args))
		  ((neq ntype otype)
		   (apply nfunction args))
		   (ecase ostate
		       (if (eql nindex oindex)
			   (two-class nindex ow0 wrappers)
		       (if (eql nindex oindex)
			   (one-index nindex)
		       (if (eql nindex oindex)
			   (do-fill nil
				    #'(lambda (nfield ncache)
					(one-index nindex nfield ncache)))
		       (unless (consp nindex)
			 (do-fill t
		   (apply nfunction args)))))))))

(defun checking-miss (generic-function args ofunction field cache)
  (protect-cache-miss-code generic-function
    (let* ((arg-info (gf-arg-info generic-function))
	   (nkeys (arg-info-nkeys arg-info)))
      (multiple-value-bind (wrappers invalidp nfunction)
	  (cache-miss-values generic-function args)
	(cond (invalidp
	       (apply nfunction args))
	      ((null nfunction)
	       (apply #'no-applicable-method generic-function args))
	      ((eq ofunction nfunction)
	       (multiple-value-bind (nfield ncache)
		   (fill-cache field cache nkeys nil #'checking-limit-fn wrappers nil)
		 (unless (and (= nfield field)
			      (eq ncache cache))
		   (update-to-checking-dfun generic-function
					    nfunction nfield ncache)))
	       (apply nfunction args))
	       (update-to-caching-dfun generic-function)
	       (apply nfunction args)))))))

(defun caching-miss (generic-function args ofield ocache)
  (protect-cache-miss-code generic-function
    (let* ((arg-info (gf-arg-info generic-function))
	   (nkeys (arg-info-nkeys arg-info)))
      (multiple-value-bind (wrappers invalidp function)
	  (cache-miss-values generic-function args)
	(cond (invalidp
	       (apply function args))
	      ((null function)
	       (apply #'no-applicable-method generic-function args))
	       (multiple-value-bind (nfield ncache)
		   (fill-cache ofield ocache nkeys t #'caching-limit-fn wrappers function)
		 (unless (and (= nfield ofield)
			      (eq ncache ocache))
		   (update-to-caching-dfun generic-function nfield ncache)))
	       (apply function args)))))))

;;; The dynamically adaptive method lookup algorithm is implemented is
;;; implemented as a kind of state machine.  The kinds of discriminating
;;; function is the state, the various kinds of reasons for a cache miss
;;; are the state transitions.
;;; The code which implements the transitions is all in the miss handlers
;;; for each kind of dfun.  Those appear here.
;;; Note that within the states that cache, there are dfun updates which
;;; simply select a new cache or cache field.  Those are not considered
;;; as state transitions.
(defun initial-dfun (args generic-function)
  #+Genera (declare (dbg:invisible-frame :pcl-internals))
  (protect-cache-miss-code generic-function
    (multiple-value-bind (wrappers invalidp nfunction applicable)
	(cache-miss-values generic-function args)
      (multiple-value-bind (ntype nindex)
	  (accessor-miss-values generic-function applicable args)
	(cond ((null applicable)
	       (apply #'no-applicable-method generic-function args))
	       (apply nfunction args))
	      ((and ntype nindex)
	       (ecase ntype
		 (reader (update-to-one-class-readers-dfun generic-function wrappers nindex))
		 (writer (update-to-one-class-writers-dfun generic-function wrappers nindex)))
	       (apply nfunction args))
	       (apply nfunction args))
	       (update-to-checking-dfun generic-function nfunction)
	       (apply nfunction args)))))))


;;; Make sure Genera bug mail contains the PCL bug data.  A little
;;; kludgy, but what the heck.  If they didn't mean for people to do
;;; this, they wouldn't have made private patch notes be flavored
;;; objects, right?  Right.
  (scl:defflavor pcl-private-patch-info ((description)) ())
  (scl:defmethod (sct::private-patch-info-description pcl-private-patch-info) ()
    (or description
	(setf description (string-append "PCL version: " pcl:*pcl-system-date*))))
  (scl:defmethod (sct::private-patch-info-pathname pcl-private-patch-info) ()
  (unless (find-if #'(lambda (x) (typep x 'pcl-private-patch-info)) sct::*private-patch-info*)
    (push (scl:make-instance 'pcl-private-patch-info)



;;; Remove the call to PCL-FDEFINE-HELPER; the method expansion now calls
;;; LOAD-DEFMETHOD instead.
(sys:define-function-spec-handler method (op spec &optional arg1 arg2)
  (if (eq op 'sys:validate-function-spec)
      (and (let ((gspec (cadr spec)))
	     (or (symbolp gspec)
		 (and (listp gspec)
		      (eq (car gspec) 'setf)
		      (symbolp (cadr gspec))
		      (null (cddr gspec)))))
	   (let ((tail (cddr spec)))
	     (loop (cond ((null tail) (return nil))
			 ((listp (car tail)) (return t))
			 ((atom (pop tail)))			 
			 (t (return nil))))))
      (let ((table *method-htable*)
	    (key spec))
	(case op
	  ((si:fdefinedp si:fdefinition)
	   (car (gethash key table nil)))
	    (remhash key table))
	    (let ((old (gethash key table nil))
		  (quals nil)
		  (specs nil)
		  (ptr (cddr spec)))
	      (setq specs
		    (loop (cond ((null ptr) (return nil))
				((listp (car ptr)) (return (car ptr)))
				(t (push (pop ptr) quals)))))
	      (setf (gethash key table) (cons arg1 (cdr old)))))
	    (let ((old (gethash key table nil)))
	      (getf (cdr old) arg1)))
	    (let ((old (gethash key table nil)))
	      (cdr old)))
	    (let ((old (gethash key table nil)))
	      (unless old
		(setf old (cons nil nil))
		(setf (gethash key table) old))
	      (setf (getf (cdr old) arg2) arg1)))
	    (let ((old (gethash key table nil)))
	      (when old
		(remf (cdr old) arg1))))
	    (si:function-spec-default-handler op spec arg1 arg2))))))

	   "-*-Mode: LISP; Package:(PCL LISP 1000); Base:10; Syntax:Common-lisp -*-")

(defun expand-defmethod (proto-method name qualifiers lambda-list body env)
  (when (listp name) (do-standard-defsetf-1 (cadr name)))
  (multiple-value-bind (fn-form specializers doc plist)
      (expand-defmethod-internal name qualifiers lambda-list body env)
    (let ((fn-args (cadadr fn-form))
	  (fn-body (cddadr fn-form))
	  (method-name `(method ,name ,@qualifiers ,specializers)))
	 (proclaim '(function ,name))
	 (defun ,method-name ,fn-args
	   ',(if proto-method
		 (class-name (class-of proto-method))
	   (list ,@(mapcar #'(lambda (specializer)
			       (if (and (consp specializer)
					(eq (car specializer) 'eql))
				   ``(eql ,,(cadr specializer))
	   ',(specialized-lambda-list-lambda-list lambda-list)
	   ',(getf plist :isl-cache-symbol)	;Paper over a bug in KCL by
						;passing the cache-symbol
						;here in addition to in the

(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)
	       (make-parameter-references specialized-lambda-list
		  ,@(remove nil
			    (mapcar #'(lambda (a s) (and (symbolp s)
							 (neq s 't)
							 `(class ,a ,s)))
	       ;; 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
		    (progn ,@parameters-to-reference)
		    (block ,(if (listp generic-function-name)
				(cadr generic-function-name)

	     (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
	     (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)))
		       ((eq (car form) 'next-method-p)
			(setq next-method-p-p 't)
		       ((and (eq (car form) 'function)
			     (cond ((eq (cadr form) 'call-next-method)
				    (setq call-next-method-p 't)
				    (setq save-original-args 't)
				   ((eq (cadr form) 'next-method-p)
				    (setq next-method-p-p 't)
				   (t nil))))
		       ((and (or (eq (car form) 'slot-value)
				 (eq (car form) 'set-slot-value))
			     (symbolp (cadr form))
			     (constantp (caddr form)))
			(let ((parameter
				(can-optimize-access (cadr form) required-parameters env)))
			  (if (null parameter)
			      (ecase (car form)
				  (optimize-slot-value     slots parameter form))
				  (optimize-set-slot-value slots parameter 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)
		      (setq aux-bindings (cdr (memq '&aux lambda-list)))
		      (return nil))
		      (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 (slot-name-lists-from-slots slots))
	      (setq plist (list* :isl slots plist))
	      (setq walked-lambda-body (add-pv-binding walked-lambda-body
	      (dolist (dcl-stm walked-declarations)
		(dolist (dcl (cdr dcl-stm))
		  (when (eql (car dcl) 'ignore)
		    (setf (cdr dcl) (set-difference (cdr dcl) required-parameters))))))
	    (when (or next-method-p-p call-next-method-p)
	      (setq plist (list* :needs-next-methods-p 't plist)))

	    ;;; changes are here... (mt)
	    (let ((fn-body (if (or call-next-method-p next-method-p-p)
				`(lambda ,lambda-list
			      `(lambda ,lambda-list
		`(function ,fn-body)

	   "-*-Mode: LISP; Package:(PCL LISP 1000); Base:10; Syntax:Common-lisp -*-")

(defun setfboundp (symbol)
  #+Genera (not (null (get-properties (symbol-plist symbol)
				      'lt::(derived-setf-function trivial-setf-method
					    setf-equivalence setf-method))))
  #+Lucid  (locally
	     (declare (special lucid::*setf-inverse-table*
	     (or (gethash symbol lucid::*setf-inverse-table*)
		 (gethash symbol lucid::*simple-setf-method-table*)
		 (gethash symbol lucid::*setf-method-expander-table*)))
  #+kcl    (or (get symbol 'si::setf-method)
	       (get symbol 'si::setf-update-fn)
	       (get symbol 'si::setf-lambda))
  #+Xerox  (or (get symbol :setf-inverse)
	       (get symbol 'il:setf-inverse)
	       (get symbol 'il:setfn)
	       (get symbol :shared-setf-inverse)
	       (get symbol :setf-method-expander)
	       (get symbol 'il:setf-method-expander))

  #+:coral (or (get symbol 'ccl::setf-inverse)
	       (get symbol 'ccl::setf-method-expander))
  #-(or Genera Lucid KCL Xerox :coral) nil)

  "-*- Mode:LISP; Package:(WALKER LISP 1000); Base:10; Syntax:Common-lisp -*-")

#-Genera (in-package 'WALKER)

(defun walk-prog/prog* (form context old-env sequentialp)
  (walker-environment-bind (new-env old-env)
    (let* ((possible-block-name (second form))
	   (blocked-prog (and (symbolp possible-block-name)
			      (not (eq possible-block-name 'nil)))))
      (multiple-value-bind (let/let* block-name bindings body)
	  (if blocked-prog
	      (values (car form) (cadr form) (caddr form) (cdddr form))
	      (values (car form) nil	     (cadr  form) (cddr  form)))
	(let* ((walked-bindings 
		 (walk-bindings-1 bindings
		   #'(lambda (real-body real-env)
		       (walk-tagbody-1 real-body context real-env))
	  (if block-name
		form let/let* block-name walked-bindings walked-body)
		form let/let* walked-bindings walked-body)))))))

#-Genera (in-package 'PCL)