test/test.sod: Abbreviate the T1 class nicknames.

[sod] / src / class-finalize-impl.lisp

diff --git a/src/class-finalize-impl.lisp b/src/class-finalize-impl.lisp
index 23d7107b7a88d69a2f4937acd7014f91c52cdc36..be42f13a5d32e05498dd25921542f58311a5eebe 100644 (file)
--- a/src/class-finalize-impl.lisp
+++ b/src/class-finalize-impl.lisp
@@ -343,6 +343,41 @@ (defmethod check-sod-class ((class sod-class))
        (error "In `~A~, chain-to class `~A' is not a proper superclass"
               class chain-link)))
 
+    ;; Check that the initargs declare compatible types.  Duplicate entries,
+    ;; even within a class, are harmless, but at most one initarg in any
+    ;; class should declare a default value.
+    (with-slots (class-precedence-list) class
+      (let ((seen (make-hash-table :test #'equal)))
+       (dolist (super class-precedence-list)
+         (with-slots (initargs) super
+           (dolist (initarg (reverse initargs))
+             (let* ((initarg-name (sod-initarg-name initarg))
+                    (initarg-type (sod-initarg-type initarg))
+                    (initarg-default (sod-initarg-default initarg))
+                    (found (gethash initarg-name seen))
+                    (found-type (and found (sod-initarg-type found)))
+                    (found-default (and found (sod-initarg-default found)))
+                    (found-class (and found (sod-initarg-class found)))
+                    (found-location (and found (file-location found))))
+               (with-default-error-location (initarg)
+                 (cond ((not found)
+                        (setf (gethash initarg-name seen) initarg))
+                       ((not (c-type-equal-p initarg-type found-type))
+                        (cerror* "Inititalization argument `~A' defined ~
+                                  with incompatible types: ~
+                                  ~A in class ~A, and ~
+                                  ~A in class ~A (at ~A)"
+                               initarg-name initarg-type super
+                               found-type found-class found-location))
+                       ((and initarg-default found-default
+                             (eql super found-class))
+                        (cerror* "Initialization argument `~A' redefined ~
+                                  with default value ~
+                                  (previous definition at ~A)"
+                                 initarg-name found-location))
+                       (initarg-default
+                        (setf (gethash initarg-name seen) initarg))))))))))
+
     ;; Check for circularity in the superclass graph.  Since the superclasses
     ;; should already be acyclic, it suffices to check that our class is not
     ;; a superclass of any of its own direct superclasses.
@@ -431,13 +466,13 @@        (default-slot (class 'metaclass) (guess-metaclass class))
       (:finalized
        t))))
 
-(macrolet ((define-layout-slot (slot (class) &body body)
-            `(define-on-demand-slot sod-class ,slot (,class)
-               (check-class-is-finalized ,class)
-               ,@body)))
-  (flet ((check-class-is-finalized (class)
-          (unless (eq (sod-class-state class) :finalized)
-            (error "Class ~S is not finalized" class))))
+(flet ((check-class-is-finalized (class)
+        (unless (eq (sod-class-state class) :finalized)
+          (error "Class ~S is not finalized" class))))
+  (macrolet ((define-layout-slot (slot (class) &body body)
+              `(define-on-demand-slot sod-class ,slot (,class)
+                 (check-class-is-finalized ,class)
+                 ,@body)))
     (define-layout-slot %ilayout (class)
       (compute-ilayout class))
     (define-layout-slot effective-methods (class)