Additional fixes to Rainy Day PCL

[harrisr@turing.cs.rpi.edu (Richard Harris)]

Here are some additional fixes to Rainy Day PCL.

  Rick Harris

====================
Problem: Method calls without enough required arguments cause trouble.
         compute-applicable-methods seems to be a good place to handle
         this problem.
>> This was almost fixed in my previous message.
methods.lisp
compute-applicable-methods
  -- The previous fix was wrong:
  -- it used (length (gf-arg-info generic-function))
  -- instead of (arg-info-number-required (gf-arg-info generic-function))
  -- in the call to error.
Change:
  (defmethod compute-applicable-methods
  	   ((generic-function generic-function) arguments)
    (labels ((filter (method)
!              (every #'specializer-applicable-p (method-specializers method) arguments))
             (sorter (method-1 method-2)
To:  
  (defmethod compute-applicable-methods
  	   ((generic-function generic-function) arguments)
    (labels ((filter (method)
! 	     (let ((arguments-tail arguments))
! 	       (dolist (m-spec (method-specializers method) t)
! 		 (unless arguments-tail
! 		   (error "The function ~S requires at least ~D arguments"
! 			  (generic-function-name generic-function)
! 			  (arg-info-number-required (gf-arg-info generic-function))))
! 		 (unless (specializer-applicable-p m-spec (pop arguments-tail))
! 		   (return nil)))))
             (sorter (method-1 method-2)
compute-applicable-methods-using-classes
Change:
  (defmethod compute-applicable-methods-using-classes
  	   ((generic-function generic-function) classes)
    (labels ((filter (method)
!              (every #'specializer-applicable-using-class-p (method-specializers method)
! 							   classes))
             (sorter (method-1 method-2)
To:  
  (defmethod compute-applicable-methods-using-classes
  	   ((generic-function generic-function) classes)
    (labels ((filter (method)
! 	     (let ((classes-tail classes))
! 	       (dolist (m-spec (method-specializers method) t)
! 		 (unless classes-tail
! 		   (error "The function ~S requires at least ~D arguments"
! 			  (generic-function-name generic-function)
! 			  (arg-info-number-required (gf-arg-info generic-function))))
! 		 (unless (specializer-applicable-using-class-p
! 			  m-spec (pop classes-tail))
! 		   (return nil)))))
             (sorter (method-1 method-2)
construct.lisp
compute-constructor-code ((class std-class) (constructor constructor))
Change:
  	 (make
  	   (compute-applicable-methods #'make-instance (list class)))
  	 (default
! 	   (compute-applicable-methods #'default-initargs (list class)))
  	 (allocate
  	   (compute-applicable-methods #'allocate-instance (list class)))
  	 (initialize
  	   (compute-applicable-methods #'initialize-instance (list proto)))
  	 (shared
  	   (compute-applicable-methods #'shared-initialize (list proto t)))
- 	 (supplied-initarg-names
- 	   (constructor-supplied-initarg-names constructor))
  	 (code-generators
  	   (constructor-code-generators constructor)))
To:
  	 (make
  	   (compute-applicable-methods #'make-instance (list class)))
+ 	 (supplied-initarg-names
+ 	   (constructor-supplied-initarg-names constructor))
  	 (default
! 	   (compute-applicable-methods #'default-initargs
! 				       (list class supplied-initarg-names))) ;?
  	 (allocate
  	   (compute-applicable-methods #'allocate-instance (list class)))
  	 (initialize
  	   (compute-applicable-methods #'initialize-instance (list proto)))
  	 (shared
  	   (compute-applicable-methods #'shared-initialize (list proto t)))
  	 (code-generators
  	   (constructor-code-generators constructor)))
      (flet ((call-code-generator (generator)
  	     (when (null generator)
====================
Problem: initial-dfun sometimes calls APPLY wtih NIL as the function.
methods.lisp
protect-cache-miss-code
Change:
  (defmacro protect-cache-miss-code (gf args &body body)
!   (once-only (gf args)
!     `(if (memq ,gf *invalid-dfuns-on-stack*)
! 	 (apply (get-secondary-dispatch-function ,gf ,args) ,args)
! 	 (let ((*invalid-dfuns-on-stack* (cons ,gf *invalid-dfuns-on-stack*)))
! 	   ,@body))))
To:  
  (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)
! 	         (no-applicable-method ,gf ,args)
! 	         (apply ,function ,args)))
! 	   (let ((*invalid-dfuns-on-stack* (cons ,gf *invalid-dfuns-on-stack*)))
! 	     ,@body)))))
====================