From: Richard M K. <kr...@us...> - 2008-09-28 14:20:54
|
Update of /cvsroot/sbcl/sbcl/src/pcl In directory sc8-pr-cvs8.sourceforge.net:/tmp/cvs-serv19033/src/pcl Modified Files: methods.lisp Log Message: 1.0.20.32: Fix some bugs in GF type tracking. Index: methods.lisp =================================================================== RCS file: /cvsroot/sbcl/sbcl/src/pcl/methods.lisp,v retrieving revision 1.85 retrieving revision 1.86 diff -u -d -r1.85 -r1.86 --- methods.lisp 23 Sep 2008 22:06:05 -0000 1.85 +++ methods.lisp 28 Sep 2008 14:20:37 -0000 1.86 @@ -609,32 +609,44 @@ (gf-lambda-list (generic-function-lambda-list gf)) (tfun (constantly t)) keysp) - (multiple-value-bind - (gf.required gf.optional gf.rest ignore gf.allowp) - (%split-arglist gf-lambda-list) - (declare (ignore ignore)) - (setf (info :function :type name) - (specifier-type - `(function - (,@(mapcar tfun gf.required) - ,@(if gf.optional - `(&optional ,@(mapcar tfun gf.optional))) - ,@(if gf.rest - `(&rest t)) - ,@(let ((all-keys - (mapcar - (lambda (x) - (list x t)) - (remove-duplicates - (mapcan #'function-keywords methods))))) - (when all-keys - (setq keysp t) - `(&key ,@all-keys))) - ,@(if (and keysp gf.allowp) + (multiple-value-bind (gf.required gf.optional gf.restp gf.rest + gf.keyp gf.keys gf.allowp) + (parse-lambda-list gf-lambda-list) + (declare (ignore gf.rest)) + ;; 7.6.4 point 5 probably entails that if any method says + ;; &allow-other-keys then the gf should be construed to + ;; accept any key. + (let ((allowp (or gf.allowp + (find '&allow-other-keys methods + :test #'find + :key #'method-lambda-list)))) + (setf (info :function :type name) + (specifier-type + `(function + (,@(mapcar tfun gf.required) + ,@(if gf.optional + `(&optional ,@(mapcar tfun gf.optional))) + ,@(if gf.restp + `(&rest t)) + ,@(when gf.keyp + (let ((all-keys + (mapcar + (lambda (x) + (list x t)) + (remove-duplicates + (nconc + (mapcan #'function-keywords methods) + (mapcar #'keywordicate gf.keys)))))) + (when all-keys + (setq keysp t) + `(&key ,@all-keys)))) + ,@(when (and (not keysp) allowp) + `(&key)) + ,@(when allowp `(&allow-other-keys))) - *)) - (info :function :where-from name) :defined-method - (gf-info-needs-update gf) nil))))) + *)) + (info :function :where-from name) :defined-method + (gf-info-needs-update gf) nil)))))) (values))) (defun compute-applicable-methods-function (generic-function arguments) @@ -1663,11 +1675,11 @@ (defmethod function-keywords ((method standard-method)) (multiple-value-bind (nreq nopt keysp restp allow-other-keys-p - keywords keyword-parameters) + keywords) (analyze-lambda-list (if (consp method) (early-method-lambda-list method) (method-lambda-list method))) - (declare (ignore nreq nopt keysp restp keywords)) + (declare (ignore nreq nopt keysp restp)) (values keywords allow-other-keys-p))) (defmethod function-keyword-parameters ((method standard-method)) |