[armedbear-devel] Fwd: [armedbear-cvs] r13787 - trunk/abcl/src/org/armedbear/lisp
Erik Huelsmann
ehuelsmann at common-lisp.net
Tue Jan 17 19:48:29 UTC 2012
The commit below reduces the number of ANSI failures on my system from 18 to 14!
Bye,
Erik.
---------- Forwarded message ----------
From: <ehuelsmann at common-lisp.net>
Date: Tue, Jan 17, 2012 at 8:39 PM
Subject: [armedbear-cvs] r13787 - trunk/abcl/src/org/armedbear/lisp
To: armedbear-cvs at common-lisp.net
Author: ehuelsmann
Date: Tue Jan 17 11:39:54 2012
New Revision: 13787
Log:
Implement keyword argument verification in the method invocation protocol.
Modified:
trunk/abcl/src/org/armedbear/lisp/clos.lisp
Modified: trunk/abcl/src/org/armedbear/lisp/clos.lisp
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/clos.lisp Tue Jan 17 11:38:01
2012 (r13786)
+++ trunk/abcl/src/org/armedbear/lisp/clos.lisp Tue Jan 17 11:39:54
2012 (r13787)
@@ -2027,13 +2027,72 @@
(unless (subclassp (car classes) specializer)
(return (values nil t)))))))
+(defun check-applicable-method-keyword-args (gf args
+ keyword-args
+ applicable-keywords)
+ (when (oddp (length keyword-args))
+ (error 'program-error
+ :format-control "Odd number of keyword arguments in call to ~S ~
+with arguments list ~S"
+ :format-arguments (list gf args)))
+ (unless (getf keyword-args :allow-other-keys)
+ (loop for key in keyword-args by #'cddr
+ unless (or (member key applicable-keywords)
+ (eq key :allow-other-keys))
+ do (error 'program-error
+ :format-control "Invalid keyword argument ~S in call ~
+to ~S with argument list ~S."
+ :format-arguments (list key gf args)))))
+
+(defun compute-applicable-keywords (gf applicable-methods)
+ (let ((applicable-keywords
+ (getf (analyze-lambda-list (generic-function-lambda-list gf))
+ :keywords)))
+ (loop for method in applicable-methods
+ do (multiple-value-bind
+ (keywords allow-other-keys)
+ (function-keywords method)
+ (when allow-other-keys
+ (setf applicable-keywords :any)
+ (return))
+ (setf applicable-keywords
+ (union applicable-keywords keywords))))
+ applicable-keywords))
+
+(defun wrap-emfun-for-keyword-args-check (gf emfun non-keyword-args
+ applicable-keywords)
+ #'(lambda (args)
+ (check-applicable-method-keyword-args
+ gf args
+ (nthcdr non-keyword-args args) applicable-keywords)
+ (funcall emfun args)))
+
(defun slow-method-lookup (gf args)
(let ((applicable-methods (%compute-applicable-methods gf args)))
(if applicable-methods
- (let ((emfun (funcall (if (eq (class-of gf)
+the-standard-generic-function-class+)
- #'std-compute-effective-method-function
- #'compute-effective-method-function)
- gf applicable-methods)))
+ (let* ((emfun (funcall (if (eq (class-of gf)
+the-standard-generic-function-class+)
+ #'std-compute-effective-method-function
+ #'compute-effective-method-function)
+ gf applicable-methods))
+ (non-keyword-args
+ (+ (length (gf-required-args gf))
+ (length (gf-optional-args gf))))
+ (gf-lambda-list (generic-function-lambda-list gf))
+ (checks-required (and (member '&key gf-lambda-list)
+ (not (member '&allow-other-keys
+ gf-lambda-list)))
+ )
+ (applicable-keywords
+ (when checks-required
+ ;; Don't do applicable keyword checks when this is
+ ;; one of the 'exceptional four' or when the gf allows
+ ;; other keywords.
+ (compute-applicable-keywords gf applicable-methods))))
+ (when (and checks-required
+ (not (eq applicable-keywords :any)))
+ (setf emfun
+ (wrap-emfun-for-keyword-args-check gf emfun non-keyword-args
+ applicable-keywords)))
(cache-emf gf args emfun)
(funcall emfun args))
(apply #'no-applicable-method gf args))))
@@ -2407,6 +2466,7 @@
(%set-method-function method function)
(%set-method-fast-function method fast-function)
(set-reader-method-slot-name method slot-name)
+ (%set-function-keywords method nil nil)
method))
(defun add-reader-method (class function-name slot-name)
@@ -2830,8 +2890,7 @@
((null tail))
(unless (memq initarg allowable-initargs)
(error 'program-error
- :format-control "Invalid initarg ~S in call to ~S ~
-with arglist ~S."
+ :format-control "Invalid initarg ~S in call to
~S with arglist ~S."
:format-arguments (list initarg call-site args))))))))
(defun merge-initargs-sets (list1 list2)
@@ -2949,7 +3008,8 @@
&rest initargs
&key &allow-other-keys))
-(defmethod shared-initialize ((instance standard-object) slot-names
&rest initargs)
+(defmethod shared-initialize ((instance standard-object) slot-names
+ &rest initargs)
(std-shared-initialize instance slot-names initargs))
(defmethod shared-initialize ((slot slot-definition) slot-names
@@ -3372,7 +3432,6 @@
(:method ((method standard-method))
(%function-keywords method)))
-
(setf *gf-initialize-instance* (symbol-function 'initialize-instance))
(setf *gf-allocate-instance* (symbol-function 'allocate-instance))
(setf *gf-shared-initialize* (symbol-function 'shared-initialize))
_______________________________________________
armedbear-cvs mailing list
armedbear-cvs at common-lisp.net
http://lists.common-lisp.net/cgi-bin/mailman/listinfo/armedbear-cvs
More information about the armedbear-devel
mailing list