PCL patches (Victoria Day)

[Mike Thome <mthome@BBN.COM>]

	I've enclosed below a set of patches to fix a variety of
different problems with Victoria Day PCL.  Some of them are only for
Genera, some are applicable to all... some might have been posted
previously.  Enjoy!

	-mike (mthome@bbn.com)

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

;;;
;;; methods.lisp
;;;

;; hacked by MT to use cerror (usefully)
; original by Rick Harris

(defun check-lambda-list-congruency (generic-function method)
  (flet ((reset-gfn ()
	   (setf (generic-function-methods generic-function) nil)))
    (macrolet ((err (string &rest args)
		 `(unless (cerror "Use this method instead (purge the old methods)"
				  ,string
				  ,@args)
		    (reset-gfn))))
      (let ((methods (generic-function-methods generic-function)))
	(when methods
	  (multiple-value-bind (gf-required gf-optional gf-rest gf-key gf-allow-other-keys)
	      (method-pretty-arglist (car methods))
	    (multiple-value-bind (required optional rest key allow-other-keys)
		(method-pretty-arglist method)
	      (unless (= (length gf-required) (length required))
		(err "~S has ~D required arguments,~
                    but existing methods have ~D required arguments"
		     method (length required) (length gf-required)))
	      (unless (= (length gf-optional) (length optional))
		(err "~S has ~D optional arguments,~
                    but existing methods have ~D optional arguments"
		     method (length optional) (length gf-optional)))
	      (if (or gf-rest gf-key gf-allow-other-keys)
		  (unless (or rest key allow-other-keys)
		    (err "~S has neither &key nor &rest in its lambda-list,~
                        conflicting with existing methods" method))
		  (unless (not (or rest key allow-other-keys))
		    (err "~S has a &key or a &rest in its lambda-list,~
                        conflicting with existing methods" method))))))))))

;; fix another potential infinite loop in dcode.
;;
(defmethod install-discriminating-function
	   ((generic-function standard-generic-function) function)
  (set-funcallable-instance-function generic-function function)
  #+ignore
  (setf (generic-function-discriminator-code generic-function) function)
  #-ignore
  (setf (slot-value generic-function 'discriminator-code) function))

;;;Handle &AUX variables correctly (esp. for check-lambda-list-congruency)
(defmethod method-pretty-arglist ((method standard-method))
  (let ((required ())
	(optional ())
	(rest nil)
	(key ())
	(aux ())
	(allow-other-keys nil)
	(state 'required)
	(arglist (method-arglist method)))
    (dolist (arg arglist)
      (cond ((eq arg '&optional)         (setq state 'optional))
	    ((eq arg '&rest)             (setq state 'rest))
	    ((eq arg '&key)              (setq state 'key))
	    ((eq arg '&allow-other-keys) (setq allow-other-keys 't))
	    ((eq arg '&aux)              (setq state 'aux))
	    ((memq arg lambda-list-keywords))
	    (t
	     (ecase state
	       (required (push arg required))
	       (optional (push arg optional))
	       (key      (push arg key))
	       (rest     (setq rest arg))
	       (aux      (push arg aux))))))
    (values (nreverse required)
	    (nreverse optional)
	    rest
	    (nreverse key)
	    allow-other-keys
	    aux)))

;;;
;;; points.lisp
;;;

;; fixed to make combined methods work on unspecialized generic
;; functions. (mt 890807)
;;  Try the following before adding this patch:
;; (defmethod foo (x y z) t)
;; (defmethod foo :before (x y z) t)
;; (foo 1 2 3)                        ;blam!
;;
(defun cross-columns (columns all-methods)
  (when (and (eq (first columns) t)
	     (> (length all-methods) 1)
	     (every #'(lambda (x) (eq x t)) (cdr columns)))
    (setq columns (cons (make-cpnode (make-point-entry *the-class-t* all-methods) ())
			(cdr columns))))
  (cross-columns-main t (car columns) (cdr columns)
		      #+ignore all-methods
		      #-ignore (copy-list all-methods)))

;; make subtype relationships work.
;; construct the predicate correctly so subtypep can get the right information.
;;   - second pass - instead, we now hack subtypep correctly (?)
;; Be careful - the non-genera implementation for subtypep can easily
;;  bring a presentation-style window system to thrash-in-place, so if
;;  your system is subtypep-intensive, either do not install, or make
;;  your SUBTYPEP function work something like below (genera version)

(defun do-satisfies-deftype (name predicate)
  (let* ((specifier `(satisfies ,predicate))
	 (expand-fn ;; mthome@bbn - fast Genera implementation - see rel-7-2-patches also
        	    #+Genera
		    #'(lambda (&rest ignore)
		       (declare (ignore ignore))
		       specifier)
		    ;; tmitchel@bbn - generic code for CommonLisp
		    #-Genera
		    #'(lambda (&rest ignore)
			(declare (ignore ignore))
			`(and ,@(mapcar #'class-name
					(cdr (class-precedence-list (find-class name))))
			      ,specifier))))
    ;; Specific ports can insert their own way of doing this.  Many
    ;; ports may find the expand-fn defined above useful.
    ;;
    (or #+:Genera
	(setf (get name 'deftype) expand-fn)
	#+(and :Lucid (not :Prime))
	(system::define-macro `(deftype ,name) expand-fn nil)
	#+ExCL
	(setf (get name 'excl::deftype-expander) expand-fn)
	#+:coral
	(setf (get name 'ccl::deftype-expander) expand-fn)

	;; This is the default for ports for which we don't know any
	;; better.  Note that for most ports, providing this definition
	;; should just speed up class definition.  It shouldn't have an
	;; effect on performance of most user code.
	(eval `(deftype ,name () '(satisfies ,predicate))))))

;;; (rel-7-2-patches.lisp)
#+genera
cli::
(DEFUN SUBTYPEP (TYPE1 TYPE2 &AUX TYPE-NAME-1 TYPE-ARGS-1 TYPE-NAME-2 TYPE-ARGS-2
		 class1 class2)
  (COND ((OR (EQ TYPE1 'NIL) (EQ TYPE2 'T))
	 ;; NIL is a subtype of everything, everything is a subtype of T
	 (VALUES T T))
	((OR (EQ TYPE1 'T) (EQ TYPE2 'NIL))
	 ;; T is a subtype of T and nothing else, nothing except NIL is a subtype of NIL
	 (VALUES NIL T))
	((EQUAL TYPE1 TYPE2)
	 (VALUES T T))
	(t
	 (cond ((and (fboundp 'pcl:find-class)
		     (setq class1 (pcl:find-class type1 nil))
		     (setq class2 (pcl:find-class type2 nil)))
		(values (not (null (pcl:subclassp class1 class2))) t))
	       #+ignore
	       ((or class1 class2)
		(values nil t))		; should this be nil nil?
	       (T
		(MULTIPLE-VALUE-SETQ (TYPE1 TYPE-NAME-1 TYPE-ARGS-1)
		  (TYPE-EXPAND TYPE1 *SUBTYPEP-TERMINAL-TYPES*))
		(MULTIPLE-VALUE-SETQ (TYPE2 TYPE-NAME-2 TYPE-ARGS-2)
		  (TYPE-EXPAND TYPE2 *SUBTYPEP-TERMINAL-TYPES*))
		(LET ((FUNCTION (OR (LOOKUP-SUBTYPEP-FUNCTION TYPE-NAME-1 TYPE-NAME-2)
				    (LOOKUP-SUBTYPEP-FUNCTION TYPE-NAME-1 '*)
				    (LOOKUP-SUBTYPEP-FUNCTION '* TYPE-NAME-2)
				    (LOOKUP-SUBTYPEP-FUNCTION TYPE-NAME-1 'DEFAULT)
				    (LOOKUP-SUBTYPEP-FUNCTION 'DEFAULT TYPE-NAME-2)
				    (LOOKUP-SUBTYPEP-FUNCTION 'DEFAULT 'DEFAULT))))
		  (FUNCALL FUNCTION
			   TYPE1 TYPE-NAME-1 TYPE-ARGS-1 TYPE2 TYPE-NAME-2 TYPE-ARGS-2)))))))


;;;
;;; Patch DCODE.LISP
;;;

;;;Fix the recursion bug in expand-dcode-cache.  Replace the call to (setf
;;; generic-function-cache) with something that isn't really a generic function,
;;; because if that gf is invalid, we could recurse and get multiple stack frames
;;; trying to free the old cache.  Maybe a lot of other inconsistencies have been
;;; arising this way as well.

(defun expand-dcode-cache (generic-function
			   old-cache
			   old-size
			   line-size
			   nkeys
			   next-scan-limit
			   dcode-constructor)
  (let* ((new-size (* old-size 2))
	 (new-number-of-lines (floor new-size line-size))
	 (new-mask (make-wrapper-cache-mask new-number-of-lines))
	 (new-cache (get-generic-function-cache new-size))
	 (new-dcode nil)
	 (wrappers ())
	 (value nil))
    (flet ((%set-generic-function-cache (nv object)
	     ;; Set the generic function cache avoiding another expansion.
	     (let ((slot-name 'cache))
	       (bind-wrapper-and-static-slots--fsc object
		 (setf-slot-value-using-class-1))))
	   (collect-wrappers (loc)
	     (block collect-wrappers
	       (when (%svref old-cache loc)
		 (setq wrappers ())
		 (dotimes (i nkeys)
		   (let ((wrapper (%svref old-cache (+ i loc))))
		     (if (zerop (wrapper-cache-no wrapper))
			 ;; This wrapper is obsolete, we don't have an instance
			 ;; so there is no related trap.  Just drop this line
			 ;; on the floor.
			 (return-from collect-wrappers nil)
			 (push wrapper wrappers))))
		 (setq wrappers (nreverse wrappers)
		       value (and (< nkeys line-size)
				  (%svref old-cache (+ loc nkeys))))
		 t))))

      (flush-generic-function-caches-internal new-cache)

      (do ((old-location line-size (+ old-location line-size)))
	  ((= old-location old-size))
	(when (collect-wrappers old-location)
	  (apply #'dcode-cache-miss
		 generic-function
		 #'(lambda (&rest ignore)
		     (declare (ignore ignore))
		     value)
		 new-cache
		 new-size
		 new-mask
		 line-size
		 nkeys
		 next-scan-limit
		 nil				;Means don't allow another
						;expand while filling the
						;new cache.  This can only
						;happen in one pathological
						;case, but prevent it anyways.
		 dcode-constructor
		 wrappers)))
    
      (setq new-dcode (funcall dcode-constructor generic-function new-cache))
      (%set-generic-function-cache new-cache generic-function)
      (install-discriminating-function generic-function new-dcode)
      (free-generic-function-cache old-cache)
      new-cache)))

;;;In this patch we change the comparison from = to <, in order to avoid a cycle
;;;  of cache growing, shrinking, growing, shrinking, ....  Don't let the cache
;;;  shrink.

(defun ensure-generic-function-cache (generic-function size)
  (let ((existing (generic-function-cache generic-function)))
    (cond ((null existing)
	   (setq existing (get-generic-function-cache size))
	   (setf (generic-function-cache generic-function) existing))
	  ((< (generic-function-cache-size existing) size)
	   (free-generic-function-cache existing)
	   (setq existing (get-generic-function-cache size))
	   (setf (generic-function-cache generic-function) existing)))
    existing))