From 6d42033ba4d27215dda45e55df1441d733414248 Mon Sep 17 00:00:00 2001 From: gerd <gerd> Date: Sun, 4 May 2003 00:37:34 +0000 Subject: [PATCH] Detect odd-length keyword argument lists, invalid keyword arguments is methods. Change lambda-lists of some gfs and methods to include &key, or &key &allow-other-keys. Bugs found by Paul Dietz in his test suite. * src/pcl/boot.lisp (bind-args): Handle the case that &key is in the lambda-list, but no keyword args. (get-key-arg1): Additional argument first-time; check for invalid keyword arguments, and add number of args when true. (get-key-arg): Call get-key-arg1. (odd-number-of-keyword-arguments, invalid-keyword-argument): New functions. * src/pcl/init.lisp (make-instance) <symbol, class>: Add &key. (initialize-instance) <slot-object>: Likewise. (reinitialize-instance) <slot-object>: Likewise. (update-instance-for-different-class): Likewise. (update-instance-for-redefined-class): Likewise. (shared-initialize) <slot-object>: Likewise. * src/pcl/std-class.lisp (change-class): Likewise. * src/pcl/slots.lisp (allocate-instance) <standard-class>: (allocate-instance) <structure-class>: Likewise. * src/pcl/methods.lisp (reinitialize-instance) <standard-method>: Likewise. * src/pcl/generic-functions.lisp (change-class) (allocate-instance, update-instance-for-different-class) (update-instance-for-redefined-class): Add &key &allow-other-keys. * src/pcl/fsc.lisp (allocate-instance) <funcallable-standard-class>: Add &key. * src/pcl/std-class.lisp (make-defstruct-allocation-function): Fix a paren bug. --- pcl/boot.lisp | 138 +++++++++++++++++++++---------------- pcl/fsc.lisp | 6 +- pcl/generic-functions.lisp | 14 ++-- pcl/init.lisp | 17 ++--- pcl/methods.lisp | 4 +- pcl/slots.lisp | 6 +- pcl/std-class.lisp | 20 +++--- 7 files changed, 114 insertions(+), 91 deletions(-) diff --git a/pcl/boot.lisp b/pcl/boot.lisp index f2fe7f1e3..c3518c30c 100644 --- a/pcl/boot.lisp +++ b/pcl/boot.lisp @@ -25,7 +25,7 @@ ;;; ************************************************************************* (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/boot.lisp,v 1.49 2003/03/26 17:15:22 gerd Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/boot.lisp,v 1.50 2003/05/04 00:37:34 gerd Exp $") (in-package :pcl) @@ -924,77 +924,95 @@ work during bootstrapping. (defmacro bind-args ((lambda-list args) &body body) (let ((args-tail '.args-tail.) (key '.key.) - (state 'required)) + (state 'required) + (key-seen nil) + (nkeys 0)) (flet ((process-var (var) (if (memq var lambda-list-keywords) (progn - (case var + (ecase var (&optional (setq state 'optional)) - (&key (setq state 'key)) + (&key (setq state 'key key-seen t)) (&allow-other-keys) (&rest (setq state 'rest)) - (&aux (setq state 'aux)) - (otherwise - (internal-error "Encountered the non-standard ~ - lambda list keyword ~S." - var))) + (&aux (setq state 'aux))) nil) (case state - (required `((,var (pop ,args-tail)))) - (optional (cond ((not (consp var)) - `((,var (when ,args-tail (pop ,args-tail))))) - ((null (cddr var)) - `((,(car var) (if ,args-tail - (pop ,args-tail) - ,(cadr var))))) - (t - `((,(caddr var) ,args-tail) - (,(car var) (if ,args-tail - (pop ,args-tail) - ,(cadr var))))))) - (rest `((,var ,args-tail))) - (key (cond ((not (consp var)) - `((,var (get-key-arg ,(make-keyword var) - ,args-tail)))) - ((null (cddr var)) - (multiple-value-bind (keyword variable) - (if (consp (car var)) - (values (caar var) (cadar var)) - (values (make-keyword (car var)) (car var))) - `((,key (get-key-arg1 ',keyword ,args-tail)) - (,variable (if (consp ,key) - (car ,key) - ,(cadr var)))))) - (t - (multiple-value-bind (keyword variable) - (if (consp (car var)) - (values (caar var) (cadar var)) - (values (make-keyword (car var)) (car var))) - `((,key (get-key-arg1 ',keyword ,args-tail)) - (,(caddr var) ,key) - (,variable (if (consp ,key) - (car ,key) - ,(cadr var)))))))) - (aux `(,var)))))) + (required + `((,var (pop ,args-tail)))) + (optional + (cond ((not (consp var)) + `((,var (when ,args-tail (pop ,args-tail))))) + ((null (cddr var)) + `((,(car var) (if ,args-tail + (pop ,args-tail) + ,(cadr var))))) + (t + `((,(caddr var) ,args-tail) + (,(car var) (if ,args-tail + (pop ,args-tail) + ,(cadr var))))))) + (rest + `((,var ,args-tail))) + (key + (incf nkeys) + (cond ((not (consp var)) + `((,var (get-key-arg ,(make-keyword var) + ,args-tail ',(= 1 nkeys))))) + ((null (cddr var)) + (multiple-value-bind (keyword variable) + (if (consp (car var)) + (values (caar var) (cadar var)) + (values (make-keyword (car var)) (car var))) + `((,key (get-key-arg1 ',keyword ,args-tail + ',(= 1 nkeys))) + (,variable (if (consp ,key) + (car ,key) + ,(cadr var)))))) + (t + (multiple-value-bind (keyword variable) + (if (consp (car var)) + (values (caar var) (cadar var)) + (values (make-keyword (car var)) (car var))) + `((,key (get-key-arg1 ',keyword ,args-tail + ',(= 1 nkeys))) + (,(caddr var) ,key) + (,variable (if (consp ,key) + (car ,key) + ,(cadr var)))))))) + (aux + `(,var)))))) (let ((bindings (mapcan #'process-var lambda-list))) `(let* ((,args-tail ,args) - ,@bindings) - (declare (ignorable ,args-tail)) + ,@bindings + (.dummy. ,@(when (and key-seen (zerop nkeys)) + `((get-key-arg1 :allow-other-keys + ,args-tail t))))) + (declare (ignorable ,args-tail .dummy.)) ,@body))))) -(defun get-key-arg (keyword list) - (loop for (key . more) on list by #'cddr - when (null more) do - (simple-program-error "Odd number of keyword arguments.") - when (eq key keyword) - return (car more))) - -(defun get-key-arg1 (keyword list) - (loop for (key . more) on list by #'cddr - when (null more) do - (simple-program-error "Odd number of keyword arguments.") - when (eq key keyword) - return more)) +(defun odd-number-of-keyword-arguments () + (simple-program-error "Odd number of keyword arguments.")) + +(defun invalid-keyword-argument (key) + (simple-program-error "Invalid keyword argument ~s" key)) + +(defun get-key-arg (keyword list first-time) + (car (get-key-arg1 keyword list first-time))) + +(defun get-key-arg1 (keyword list first-time) + (if first-time + (loop with cell = nil + for (key . more) on list by #'cddr do + (cond ((not (symbolp key)) + (invalid-keyword-argument key)) + ((null more) + (odd-number-of-keyword-arguments)) + ((and (null cell) (eq key keyword)) + (setq cell more))) + finally (return cell)) + (loop for (key . more) on list by #'cddr + when (eq key keyword) return more))) (defun walk-method-lambda (method-lambda required-parameters env slots calls) (let ((call-next-method-p nil) ;flag indicating that call-next-method diff --git a/pcl/fsc.lisp b/pcl/fsc.lisp index 434b20ff3..ff9bb225f 100644 --- a/pcl/fsc.lisp +++ b/pcl/fsc.lisp @@ -25,7 +25,7 @@ ;;; ************************************************************************* (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/fsc.lisp,v 1.11 2003/03/22 16:15:16 gerd Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/fsc.lisp,v 1.12 2003/05/04 00:37:34 gerd Exp $") ;;; ;;; This file contains the definition of the FUNCALLABLE-STANDARD-CLASS ;;; metaclass. Much of the implementation of this metaclass is actually @@ -62,8 +62,8 @@ (or (eq new-super-meta-class *the-class-std-class*) (eq (class-of fsc) new-super-meta-class)))) -(defmethod allocate-instance - ((class funcallable-standard-class) &rest initargs) +(defmethod allocate-instance ((class funcallable-standard-class) + &rest initargs &key) (declare (ignore initargs)) (unless (class-finalized-p class) (finalize-inheritance class)) (allocate-funcallable-instance (class-wrapper class))) diff --git a/pcl/generic-functions.lisp b/pcl/generic-functions.lisp index 26189aa96..6f241fecc 100644 --- a/pcl/generic-functions.lisp +++ b/pcl/generic-functions.lisp @@ -1,7 +1,7 @@ ;;;-*-Mode:LISP; Package:PCL; Base:10; Syntax:Common-lisp -*- (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/generic-functions.lisp,v 1.23 2003/04/29 10:33:51 gerd Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/generic-functions.lisp,v 1.24 2003/05/04 00:37:33 gerd Exp $") ;;; (in-package :pcl) @@ -487,7 +487,8 @@ (defgeneric add-method (generic-function method)) ; (standard-generic-function method) -(defgeneric change-class (instance new-class-name &rest initargs)) +(defgeneric change-class (instance new-class-name &rest initargs + &key &allow-other-keys)) ; (standard-object standard-class) ; (funcallable-standard-object funcallable-standard-class) ; (t symbol) @@ -715,7 +716,7 @@ ;;; keyword arguments -(defgeneric allocate-instance (class &rest initargs)) +(defgeneric allocate-instance (class &rest initargs &key &allow-other-keys)) ; (standard-class) ; (structure-class) ; (funcallable-standard-class) @@ -768,9 +769,12 @@ (defgeneric update-dependent (metaobject dependent &rest initargs)) -(defgeneric update-instance-for-different-class (previous current &rest initargs)) +(defgeneric update-instance-for-different-class + (previous current &rest initargs &key &allow-other-keys)) -(defgeneric update-instance-for-redefined-class (instance added-slots discarded-slots property-list &rest initargs)) +(defgeneric update-instance-for-redefined-class + (instance added-slots discarded-slots property-list &rest initargs + &key &allow-other-keys)) (defgeneric writer-method-class (class direct-slot &rest initargs)) ; (slot-class t) diff --git a/pcl/init.lisp b/pcl/init.lisp index e4848421e..3f44fed64 100644 --- a/pcl/init.lisp +++ b/pcl/init.lisp @@ -26,7 +26,7 @@ ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/init.lisp,v 1.20 2003/05/02 12:43:06 gerd Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/init.lisp,v 1.21 2003/05/04 00:37:33 gerd Exp $") ;;; ;;; This file defines the initialization and related protocols. @@ -34,10 +34,10 @@ (in-package :pcl) -(defmethod make-instance ((class symbol) &rest initargs) +(defmethod make-instance ((class symbol) &rest initargs &key) (apply #'make-instance (find-class class) initargs)) -(defmethod make-instance ((class class) &rest initargs) +(defmethod make-instance ((class class) &rest initargs &key) ;; ;; Try to use an optimized constructor if there is one. (let ((instance (call-ctor class initargs))) @@ -73,16 +73,16 @@ finally (return (append supplied-initargs default-initargs)))) -(defmethod initialize-instance ((instance slot-object) &rest initargs) +(defmethod initialize-instance ((instance slot-object) &rest initargs &key) (apply #'shared-initialize instance t initargs)) -(defmethod reinitialize-instance ((instance slot-object) &rest initargs) +(defmethod reinitialize-instance ((instance slot-object) &rest initargs &key) (check-ri-initargs instance initargs) (apply #'shared-initialize instance nil initargs) instance) (defmethod update-instance-for-different-class - ((previous standard-object) (current standard-object) &rest initargs) + ((previous standard-object) (current standard-object) &rest initargs &key) ;; First we must compute the newly added slots. The spec defines ;; newly added slots as "those local slots for which no slot of ;; the same name exists in the previous class." @@ -105,7 +105,7 @@ added-slots discarded-slots property-list - &rest initargs) + &rest initargs &key) (check-initargs (class-of instance) initargs (list (list* 'update-instance-for-redefined-class @@ -134,7 +134,8 @@ ;;; no slots are set from initforms ;;; -(defmethod shared-initialize ((instance slot-object) slot-names &rest initargs) +(defmethod shared-initialize ((instance slot-object) slot-names + &rest initargs &key) (let ((structure-p (structure-class-p (class-of instance)))) (flet ((initialize-slot-from-initarg (class instance slotd) (let ((slot-initargs (slot-definition-initargs slotd))) diff --git a/pcl/methods.lisp b/pcl/methods.lisp index e8294b6a0..56f91cc98 100644 --- a/pcl/methods.lisp +++ b/pcl/methods.lisp @@ -26,7 +26,7 @@ ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/methods.lisp,v 1.27 2003/04/25 17:43:50 gerd Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/methods.lisp,v 1.28 2003/05/04 00:37:33 gerd Exp $") (in-package :pcl) @@ -160,7 +160,7 @@ (find-class 'standard-generic-function)) -(defmethod reinitialize-instance ((method standard-method) &rest initargs) +(defmethod reinitialize-instance ((method standard-method) &rest initargs &key) (declare (ignore initargs)) (error "~@<Attempt to reinitialize the method ~S. ~ Method objects cannot be reinitialized.~@:>" diff --git a/pcl/slots.lisp b/pcl/slots.lisp index c3ca8e646..2fd01dae4 100644 --- a/pcl/slots.lisp +++ b/pcl/slots.lisp @@ -26,7 +26,7 @@ ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/slots.lisp,v 1.19 2003/04/26 14:30:39 gerd Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/slots.lisp,v 1.20 2003/05/04 00:37:33 gerd Exp $") ;;; (in-package :pcl) @@ -295,12 +295,12 @@ (car position))))) -(defmethod allocate-instance ((class standard-class) &rest initargs) +(defmethod allocate-instance ((class standard-class) &rest initargs &key) (declare (ignore initargs)) (unless (class-finalized-p class) (finalize-inheritance class)) (allocate-standard-instance (class-wrapper class))) -(defmethod allocate-instance ((class structure-class) &rest initargs) +(defmethod allocate-instance ((class structure-class) &rest initargs &key) (declare (ignore initargs)) (let ((constructor (class-defstruct-constructor class))) (if constructor diff --git a/pcl/std-class.lisp b/pcl/std-class.lisp index cc4007d84..75627f7e4 100644 --- a/pcl/std-class.lisp +++ b/pcl/std-class.lisp @@ -26,7 +26,7 @@ ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/std-class.lisp,v 1.59 2003/05/03 14:46:12 gerd Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/std-class.lisp,v 1.60 2003/05/04 00:37:33 gerd Exp $") (in-package :pcl) @@ -728,10 +728,9 @@ (setf (kernel::%instance-layout instance) (kernel::compiler-layout-or-lose (kernel::dd-name dd))) (when raw-index - (setf (kernel::%instance-ref - instance raw-index - (make-array (kernel::dd-raw-length dd) - :element-type '(unsigned-byte 32))))) + (setf (kernel::%instance-ref instance raw-index) + (make-array (kernel::dd-raw-length dd) + :element-type '(unsigned-byte 32)))) instance)))) (defmethod direct-slot-definition-class ((class structure-class) @@ -1482,17 +1481,17 @@ (defmethod change-class ((instance standard-object) (new-class standard-class) - &rest initargs) + &rest initargs &key) (change-class-internal instance new-class initargs)) (defmethod change-class ((instance funcallable-standard-object) (new-class funcallable-standard-class) - &rest initargs) + &rest initargs &key) (change-class-internal instance new-class initargs)) (defmethod change-class ((instance standard-object) (new-class funcallable-standard-class) - &rest initargs) + &rest initargs &key) (declare (ignore initargs)) (error "~@<Can't change the class of ~S to ~S ~ because it isn't already an instance with metaclass ~S.~@:>" @@ -1500,13 +1499,14 @@ (defmethod change-class ((instance funcallable-standard-object) (new-class standard-class) - &rest initargs) + &rest initargs &key) (declare (ignore initargs)) (error "~@<Can't change the class of ~S to ~S ~ because it isn't already an instance with metaclass ~S.~@:>" instance new-class 'funcallable-standard-class)) -(defmethod change-class ((instance t) (new-class-name symbol) &rest initargs) +(defmethod change-class ((instance t) (new-class-name symbol) + &rest initargs &key) (apply #'change-class instance (find-class new-class-name) initargs)) -- GitLab