Commit e972550d authored by Christophe Rhodes's avatar Christophe Rhodes
Browse files

0.8.4.23:

	Fix for bug 191c (and some of PFD's tests)
	... do proper keyword argument checking in the effective method
	... not the cleanest fix in the world (note especially
		the use of PROGN as an optimization inhibitor)
	... I'm not telling you how long it took me to find the
		NCONC -> APPEND bug in fngen.lisp
parent 3abdab00
Loading
Loading
Loading
Loading
+1 −2
Original line number Diff line number Diff line
@@ -640,8 +640,7 @@ WORKAROUND:
     classes).  This means that at present erroneous attempts to use
     WITH-SLOTS and the like on classes with metaclass STRUCTURE-CLASS
     won't get the corresponding STYLE-WARNING.
  c. the examples in CLHS 7.6.5.1 (regarding generic function lambda
     lists and &KEY arguments) do not signal errors when they should.
  c. (fixed in 0.8.4.23)

201: "Incautious type inference from compound types"
  a. (reported by APD sbcl-devel 2002-09-17)
+2 −0
Original line number Diff line number Diff line
@@ -2124,6 +2124,8 @@ changes in sbcl-0.8.5 relative to sbcl-0.8.4:
    as unknown types.  (reported by piso on #lisp)
  * bug fix: the :IF-EXISTS argument to OPEN now behaves correctly
    with values NIL and :ERROR.  (thanks to Milan Zamazal)
  * fixed bug 191c: CLOS now does proper keyword argument checking as
    described in CLHS 7.6.5 and 7.6.5.1.
  * compiler enhancement: SIGNUM is now better able to derive the type
    of its result.
  * type declarations inside WITH-SLOTS are checked.  (reported by
+1 −1
Original line number Diff line number Diff line
@@ -1907,7 +1907,7 @@ bootstrapping.
			     (method-lambda-list method)))
		     (k (member '&key ll)))
		(if k
		    (append (ldiff ll (cdr k)) '(&allow-other-keys))
		    (ldiff ll (cdr k))
		    ll))))
	(arg-info-lambda-list arg-info))))

+168 −78
Original line number Diff line number Diff line
@@ -174,6 +174,9 @@
      (get-generic-fun-info gf)
    (declare (ignore nreq nkeys arg-info))
    (let ((ll (make-fast-method-call-lambda-list metatypes applyp))
	  (check-applicable-keywords
	   (when (and applyp (gf-requires-emf-keyword-checks gf))
	     '((check-applicable-keywords))))
	  (error-p (or (eq (first effective-method) '%no-primary-method)
		       (eq (first effective-method) '%invalid-qualifiers)))
	  (mc-args-p
@@ -206,10 +209,12 @@
	     (declare (ignore .pv-cell. .next-method-call.))
	     (let ((.gf-args. ,gf-args))
	       (declare (ignorable .gf-args.))
	       ,@check-applicable-keywords
	       ,effective-method))))
	(t
	 `(lambda ,ll
	   (declare (ignore ,@(if error-p ll '(.pv-cell. .next-method-call.))))
	   ,@check-applicable-keywords
	   ,effective-method))))))

(defun expand-emf-call-method (gf form metatypes applyp env)
@@ -220,68 +225,80 @@
  (declare (ignore args))
  `(error "~S outside of a effective method form" 'call-method))

(defun memf-test-converter (form generic-function method-alist-p wrappers-p)
  (cond ((and (consp form) (eq (car form) 'call-method))
	 (case (make-effective-method-fun-type
		generic-function form method-alist-p wrappers-p)
	   (fast-method-call
	    '.fast-call-method.)
	   (t
	    '.call-method.)))
	((and (consp form) (eq (car form) 'call-method-list))
	 (case (if (every (lambda (form)
(defun make-effective-method-list-fun-type
    (generic-function form method-alist-p wrappers-p)
  (if (every (lambda (form)
	       (eq 'fast-method-call
		   (make-effective-method-fun-type
				 generic-function form
				 method-alist-p wrappers-p)))
		    generic-function form method-alist-p wrappers-p)))
	     (cdr form))
      'fast-method-call
		   t)
	   (fast-method-call
	    '.fast-call-method-list.)
	   (t
	    '.call-method-list.)))
	(t
	 (default-test-converter form))))
      t))

(defun memf-test-converter (form generic-function method-alist-p wrappers-p)
  (case (and (consp form) (car form))
    (call-method
     (case (make-effective-method-fun-type
	    generic-function form method-alist-p wrappers-p)
       (fast-method-call '.fast-call-method.)
       (t '.call-method.)))
    (call-method-list
     (case (make-effective-method-list-fun-type
	    generic-function form method-alist-p wrappers-p)
       (fast-method-call '.fast-call-method-list.)
       (t '.call-method-list.)))
    (check-applicable-keywords 'check-applicable-keywords)
    (t (default-test-converter form))))

;;; CMUCL comment (2003-10-15):
;;;
;;;   This function is called via the GET-FUNCTION mechanism on forms
;;;   of an emf lambda.  First value returned replaces FORM in the emf
;;;   lambda.  Second value is a list of variable names that become
;;;   closure variables.
(defun memf-code-converter
    (form generic-function metatypes applyp method-alist-p wrappers-p)
  (cond ((and (consp form) (eq (car form) 'call-method))
  (case (and (consp form) (car form))
    (call-method
     (let ((gensym (get-effective-method-gensym)))
	   (values (make-emf-call metatypes applyp gensym
       (values (make-emf-call
		metatypes applyp gensym
		(make-effective-method-fun-type
		 generic-function form method-alist-p wrappers-p))
	       (list gensym))))
	((and (consp form) (eq (car form) 'call-method-list))
    (call-method-list
     (let ((gensym (get-effective-method-gensym))
	       (type (if (every (lambda (form)
				  (eq 'fast-method-call
				      (make-effective-method-fun-type
				       generic-function form
				       method-alist-p wrappers-p)))
				(cdr form))
			 'fast-method-call
			 t)))
	   (type (make-effective-method-list-fun-type
		  generic-function form method-alist-p wrappers-p)))
       (values `(dolist (emf ,gensym nil)
		 ,(make-emf-call metatypes applyp 'emf type))
	       (list gensym))))
    (check-applicable-keywords
     (values `(check-applicable-keywords
	       .dfun-rest-arg. .keyargs-start. .valid-keys.)
	     '(.keyargs-start. .valid-keys.)))
    
    (t
     (default-code-converter form))))

(defun memf-constant-converter (form generic-function)
  (cond ((and (consp form) (eq (car form) 'call-method))
  (case (and (consp form) (car form))
    (call-method
     (list (cons '.meth.
		 (make-effective-method-function-simple
		  generic-function form))))
	((and (consp form) (eq (car form) 'call-method-list))
    (call-method-list
     (list (cons '.meth-list.
		 (mapcar (lambda (form)
			   (make-effective-method-function-simple
			    generic-function form))
			 (cdr form)))))
    (check-applicable-keywords
     '(.keyargs-start. .valid-keys.))
    (t
     (default-constant-converter form))))

(defvar *applicable-methods*)
(defun make-effective-method-function-internal
    (generic-function effective-method method-alist-p wrappers-p)
  (multiple-value-bind (nreq applyp metatypes nkeys arg-info)
@@ -307,27 +324,29 @@
		    (lambda (form)
		      (memf-constant-converter form generic-function)))
	(lambda (method-alist wrappers)
	  (let* ((constants
		  (mapcar (lambda (constant)
	  (multiple-value-bind (valid-keys keyargs-start)
	      (when (memq '.valid-keys. constants)
		(compute-applicable-keywords
		 generic-function *applicable-methods*))
	    (flet ((compute-constant (constant)
		     (if (consp constant)
			 (case (car constant)
			   (.meth.
				   (funcall (cdr constant)
					    method-alist wrappers))
			    (funcall (cdr constant) method-alist wrappers))
			   (.meth-list.
			    (mapcar (lambda (fn)
					     (funcall fn
						      method-alist
						      wrappers))
				      (funcall fn method-alist wrappers))
				    (cdr constant)))
			   (t constant))
				constant))
			  constants))
		 (function (set-fun-name
			    (apply cfunction constants)
			    `(combined-method ,name))))
	    (make-fast-method-call :function function
				   :arg-info arg-info)))))))
			 (case constant
			   (.keyargs-start. keyargs-start)
			   (.valid-keys. valid-keys)
			   (t constant)))))
	      (let ((fun (apply cfunction
				(mapcar #'compute-constant constants))))
		(set-fun-name fun `(combined-method ,name))
		(make-fast-method-call :function fun
				       :arg-info arg-info)))))))))

(defmacro call-method-list (&rest calls)
  `(progn ,@calls))
@@ -336,6 +355,9 @@
  `(call-method-list
    ,@(mapcar (lambda (method) `(call-method ,method ())) methods)))

(defun gf-requires-emf-keyword-checks (generic-function)
  (member '&key (gf-lambda-list generic-function)))

(defun standard-compute-effective-method
    (generic-function combin applicable-methods)
  (collect ((before) (primary) (after) (around))
@@ -359,8 +381,22 @@
	   `(%no-primary-method ',generic-function .args.))
	  ((and (null (before)) (null (after)) (null (around)))
	   ;; By returning a single call-method `form' here we enable
	   ;; an important implementation-specific optimization.
	   `(call-method ,(first (primary)) ,(rest (primary))))
	   ;; an important implementation-specific optimization; that
	   ;; is, we can use the fast method function directly as the
	   ;; effective method function.
	   ;;
	   ;; However, the requirement by ANSI (CLHS 7.6.5) on generic
	   ;; function argument checking inhibits this, as we don't
	   ;; perform this checking in fast-method-functions given
	   ;; that they are not solely used for effective method
	   ;; functions, but also in combination, when they should not
	   ;; perform argument checks.
	   (let ((call-method
		  `(call-method ,(first (primary)) ,(rest (primary)))))
	     (if (gf-requires-emf-keyword-checks generic-function)
		 ;; the PROGN inhibits the above optimization
		 `(progn ,call-method)
		 call-method)))
	  (t
	   (let ((main-effective-method
		   (if (or (before) (after))
@@ -377,6 +413,60 @@
				  (make-method ,main-effective-method)))
		 main-effective-method))))))

;;; helper code for checking keywords in generic function calls.
(defun compute-applicable-keywords (gf methods)
  (let ((any-keyp nil))
    (flet ((analyze (lambda-list)
	     (multiple-value-bind (nreq nopt keyp restp allowp keys)
		 (analyze-lambda-list lambda-list)
	       (declare (ignore nreq restp))
	       (when keyp
		 (setq any-keyp t))
	       (values nopt allowp keys))))
      (multiple-value-bind (nopt allowp keys)
	  (analyze (generic-function-lambda-list gf))
	(dolist (method methods)
	  (let ((ll (if (consp method)
			(early-method-lambda-list method)
			(method-lambda-list method))))
	    (multiple-value-bind (n allowp method-keys)
		(analyze ll)
	      (declare (ignore n))
	      (when allowp
		(return-from compute-applicable-keywords (values t nopt)))
	      (setq keys (union method-keys keys)))))
	(aver any-keyp)
	(values (if allowp t keys) nopt)))))

(defun check-applicable-keywords (args start valid-keys)
  (let ((allow-other-keys-seen nil)
	(allow-other-keys nil)
	(args (nthcdr start args)))
    (collect ((invalid))
      (loop
       (when (null args)
	 (when (and (invalid) (not allow-other-keys))
	   (error 'simple-program-error
		  :format-control "~@<invalid keyword argument~P: ~
                                   ~{~S~^, ~} (valid keys are ~{~S~^, ~}).~@:>"
		  :format-arguments (list (length (invalid)) (invalid) valid-keys)))
	 (return))
       (let ((key (pop args)))
	 (cond
	   ((not (symbolp key))
	    (error 'simple-program-error
		   :format-control "~@<keyword argument not a symbol: ~S.~@:>"
		   :format-arguments (list key)))
	   ((null args) (sb-c::%odd-key-args-error))
	   ((eq key :allow-other-keys)
	    ;; only the leftmost :ALLOW-OTHER-KEYS has any effect
	    (unless allow-other-keys-seen
	      (setq allow-other-keys-seen t
		    allow-other-keys (car args))))
	   ((eq t valid-keys))
	   ((not (memq key valid-keys)) (invalid key))))
       (pop args)))))

;;;; the STANDARD method combination type. This is coded by hand
;;;; (rather than with DEFINE-METHOD-COMBINATION) for bootstrapping
;;;; and efficiency reasons. Note that the definition of the
+28 −23
Original line number Diff line number Diff line
@@ -615,7 +615,7 @@ Except see also BREAK-VICIOUS-METACIRCLE. -- CSR, 2003-05-28

(defun use-dispatch-dfun-p (gf &optional (caching-p (use-caching-dfun-p gf)))
  (when (eq *boot-state* 'complete)
    (unless caching-p
    (unless (or caching-p (gf-requires-emf-keyword-checks gf))
      ;; This should return T when almost all dispatching is by
      ;; eql specializers or built-in classes. In other words,
      ;; return NIL if we might ever need to do more than
@@ -684,14 +684,20 @@ Except see also BREAK-VICIOUS-METACIRCLE. -- CSR, 2003-05-28
(setq *wrapper-of-cost* 15)
(setq *secondary-dfun-call-cost* 30)

(declaim (inline make-callable))
(defun make-callable (gf methods generator method-alist wrappers)
  (let* ((*applicable-methods* methods)
	 (callable (function-funcall generator method-alist wrappers)))
    callable))

(defun make-dispatch-dfun (gf)
  (values (get-dispatch-function gf) nil (dispatch-dfun-info)))

(defun get-dispatch-function (gf)
  (let ((methods (generic-function-methods gf)))
    (function-funcall (get-secondary-dispatch-function1 gf methods nil nil nil
							nil nil t)
		      nil nil)))
  (let* ((methods (generic-function-methods gf))
	 (generator (get-secondary-dispatch-function1
		     gf methods nil nil nil nil nil t)))
    (make-callable gf methods generator nil nil)))

(defun make-final-dispatch-dfun (gf)
  (make-dispatch-dfun gf))
@@ -1134,11 +1140,12 @@ Except see also BREAK-VICIOUS-METACIRCLE. -- CSR, 2003-05-28
  (let* ((for-accessor-p (eq state 'accessor))
	 (for-cache-p (or (eq state 'caching) (eq state 'accessor)))
	 (emf (if (or cam-std-p all-applicable-and-sorted-p)
		  (function-funcall (get-secondary-dispatch-function1
				     gf methods types nil (and for-cache-p
							       wrappers)
				     all-applicable-and-sorted-p)
				    nil (and for-cache-p wrappers))
		  (let ((generator
			 (get-secondary-dispatch-function1
			  gf methods types nil (and for-cache-p wrappers)
			  all-applicable-and-sorted-p)))
		    (make-callable gf methods generator
				   nil (and for-cache-p wrappers)))
		  (default-secondary-dispatch-function gf))))
    (multiple-value-bind (index accessor-type)
	(and for-accessor-p all-applicable-and-sorted-p methods
@@ -1623,14 +1630,13 @@ Except see also BREAK-VICIOUS-METACIRCLE. -- CSR, 2003-05-28
  (dolist (method (generic-function-methods generic-function))
    (remhash method *effective-method-cache*)))

(defun get-secondary-dispatch-function (gf methods types &optional
							 method-alist wrappers)
  (function-funcall (get-secondary-dispatch-function1
		     gf methods types
		     (not (null method-alist))
		     (not (null wrappers))
		     (not (methods-contain-eql-specializer-p methods)))
		    method-alist wrappers))
(defun get-secondary-dispatch-function (gf methods types
					&optional method-alist wrappers)
  (let ((generator
	 (get-secondary-dispatch-function1
	  gf methods types (not (null method-alist)) (not (null wrappers))
	  (not (methods-contain-eql-specializer-p methods)))))
    (make-callable gf methods generator method-alist wrappers)))

(defun get-secondary-dispatch-function1 (gf methods types method-alist-p
					    wrappers-p
@@ -1687,11 +1693,10 @@ Except see also BREAK-VICIOUS-METACIRCLE. -- CSR, 2003-05-28

(defun get-effective-method-function (gf methods
					 &optional method-alist wrappers)
  (function-funcall (get-secondary-dispatch-function1 gf methods nil
						      (not (null method-alist))
						      (not (null wrappers))
						      t)
		    method-alist wrappers))
  (let ((generator
	 (get-secondary-dispatch-function1
	  gf methods nil (not (null method-alist)) (not (null wrappers)) t)))
    (make-callable gf methods generator method-alist wrappers)))

(defun get-effective-method-function1 (gf methods &optional (sorted-p t))
  (get-secondary-dispatch-function1 gf methods nil nil nil t sorted-p))
Loading