diff --git a/pcl/boot.lisp b/pcl/boot.lisp index f2fe7f1e354b3df53b91799d13e53e38e08b7794..c3518c30c06db5ad0475f624d654304903292fa9 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 434b20ff3040fe45c9d08f501c5a7bd74ddfaae6..ff9bb225f80d2f7a18fbfec5b8495e2c382bea4e 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 26189aa96af8ad3a7a047716d98f81cc738945bb..6f241fecce6f655e695c99c4258078682763dc97 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 e4848421ec883b117a0911bbe2e29b1867a2b703..3f44fed6419c0d70715a18cdd356dee23bf82379 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 e8294b6a0998cae9049965391c3c14ab9e55d6c5..56f91cc98f1248399a9bc3b34732e071dd660455 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 c3ca8e646ea34686c9cf6c66a18a4978ae0adfa7..2fd01dae4b014bd994771064a68927f18c12fc5d 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 cc4007d84be6e2c5fc99602d577e32d43a53d177..75627f7e4371d81d2b10742e43a6ec8fbb45d1b1 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))