New feature: initialization keyword arguments.

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

diff --git a/src/class-finalize-impl.lisp b/src/class-finalize-impl.lisp
index 36d56e0..be42f13 100644 (file)
--- a/src/class-finalize-impl.lisp
+++ b/src/class-finalize-impl.lisp
@@ -343,6 +343,41 @@
        (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.