[Openmcl-cvs-notifications] r9049 - in /trunk/source: level-1/l1-clos-boot.lisp lib/macros.lisp

[gz at clozure.com]

Author: gz
Date: Mon Apr  7 23:17:29 2008
New Revision: 9049

Log:
make defclass check for illegal class options (ticket #271)

Modified:
    trunk/source/level-1/l1-clos-boot.lisp
    trunk/source/lib/macros.lisp

Modified: trunk/source/level-1/l1-clos-boot.lisp
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D
--- trunk/source/level-1/l1-clos-boot.lisp (original)
+++ trunk/source/level-1/l1-clos-boot.lisp Mon Apr  7 23:17:29 2008
@@ -3020,7 +3020,17 @@
       initvect)))
 =

 =

-(defun compute-initargs-vector (instance class functions)
+;; This is used for compile-time defclass option checking.
+(defun class-keyvect (class-arg initargs)
+  (let* ((class (if (typep class-arg 'class) class-arg (find-class class-a=
rg nil)))
+	 (meta-arg (getf initargs :metaclass (if (and class (not (typep class 'fo=
rward-referenced-class)))
+					       (class-of class)
+					       *standard-class-class*)))
+	 (meta-spec (if (quoted-form-p meta-arg) (%cadr meta-arg) meta-arg))
+	 (meta (if (typep meta-spec 'class) meta-spec (find-class meta-spec))))
+    (compute-initargs-vector class meta (list #'initialize-instance #'allo=
cate-instance #'shared-initialize) t)))
+
+(defun compute-initargs-vector (instance class functions &optional require=
-rest)
   (let ((initargs (class-slot-initargs class))
         (cpl (%inited-class-cpl class)))
     (dolist (f functions)         ; for all the functions passed
@@ -3033,8 +3043,10 @@
                   (eql instance (eql-specializer-object spec))
                   (memq spec cpl))
             (let* ((func (%inner-method-function method))
-                   (keyvect (if (logbitp $lfbits-aok-bit (lfun-bits func))
-                              (return-from compute-initargs-vector t)
+                   (keyvect (if (and (logbitp $lfbits-aok-bit (lfun-bits f=
unc))
+				     (or (not require-rest)
+					 (logbitp $lfbits-rest-bit (lfun-bits func))))
+			      (return-from compute-initargs-vector t)
                               (lfun-keyvect func))))
               (dovector (key keyvect)
                 (pushnew key initargs)))))))   ; add all of the method's k=
eys

Modified: trunk/source/lib/macros.lisp
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D
--- trunk/source/lib/macros.lisp (original)
+++ trunk/source/lib/macros.lisp Mon Apr  7 23:17:29 2008
@@ -1961,7 +1961,15 @@
                                                      (cdr opt)))) other-op=
tions)))))
 	(let* ((direct-superclasses superclasses)
 	       (direct-slot-specs (mapcar #'canonicalize-slot-spec slots))
-	       (other-options (apply #'append (mapcar #'canonicalize-defclass-opt=
ion class-options ))))
+	       (other-options (apply #'append (mapcar #'canonicalize-defclass-opt=
ion class-options )))
+	       (keyvect (class-keyvect class-name other-options)))
+	  (when (vectorp keyvect)
+	    (let ((illegal (loop for arg in other-options by #'cddr
+			      as key =3D (if (quoted-form-p arg) (%cadr arg) arg)
+			      unless (or (eq key :metaclass) (find key keyvect)) collect key)))
+	      (when illegal
+		(signal-program-error "Class option~p~{ ~s~} is not one of ~s"
+				      (length illegal) illegal keyvect))))
 	  `(progn
 	    (eval-when (:compile-toplevel)
 	      (%compile-time-defclass ',class-name ,env)