Changeset 284

Timestamp:

Jan 13, 2004, 5:04:46 PM (21 years ago)

Author:

Gary Byers

Message:

Check initargs via DESTRUCTURING-BIND in %SHARED-INITIALIZE.
ENSURE-CLASS-FOR-DEFCLASS and
*defclass-redefines-improperly-named-classes-pedantically*. (SETF
CLASS-NAME) isn't an accessor; the real method uses
REINITIALIZE-INSTANCE.

File:

• trunk/ccl/level-1/l1-clos.lisp (modified) (5 diffs)

trunk/ccl/level-1/l1-clos.lisp

@@ -19 +19 @@
 ;;; At this point in the load sequence, the handful of extant basic classes
 ;;; exist only in skeletal form (without direct or effective slot-definitions.)
-
+(in-package "CCL")
 
 (defun extract-slotds-with-allocation (allocation slotds)
@@ -58 +58 @@
   (unless (or (listp slot-names) (eq slot-names t))
     (report-bad-arg slot-names '(or list (eql t))))
-  (unless (plistp initargs) (report-bad-arg initargs '(satisfies plistp)))
+  ;; Check that initargs contains valid key/value pairs,
+  ;; signal a PROGRAM-ERROR otherwise.  (Yes, this is
+  ;; an obscure way to do so.)
+  (destructuring-bind (&key &allow-other-keys) initargs)
   (let* ((wrapper (instance.class-wrapper instance))
          (class (%wrapper-class wrapper)))
@@ -654 +657 @@
   (apply #'ensure-class-using-class (find-class name nil) name keys))
 
+(defparameter *defclass-redefines-improperly-named-classes-pedantically* 
+   t
+  "ANSI CL expects DEFCLASS to redefine an existing class only when
+the existing class is properly named, the MOP function ENSURE-CLASS
+redefines existing classes regardless of their CLASS-NAME.  This variable
+governs whether DEFCLASS makes that distinction or not.")
+
+(defun ensure-class-for-defclass (name &rest keys &key &allow-other-keys)
+  (record-source-file name 'class)
+  ;; Maybe record source-file information for accessors as well
+  ;; We should probably record them as "accessors of the class", since
+  ;; there won't be any other explicit defining form associated with
+  ;; them.
+  (let* ((existing-class (find-class name nil)))
+    (when (and *defclass-redefines-improperly-named-classes-pedantically* 
+               existing-class 
+              (not (eq (class-name existing-class) name)))
+      ;; Class isn't properly named; act like it didn't exist
+      (setq existing-class nil))
+    (apply #'ensure-class-using-class existing-class name keys)))
+
 
 (defun slot-plist-from-%slotd (%slotd allocation)
@@ -848 +872 @@
  :direct-slots
  `((:name prototype :initform nil :initfunction ,#'false)
-   (:name name :initargs (:name) :initform nil :initfunction ,#'false :readers (class-name) :writers ((setf class-name)))
+   (:name name :initargs (:name) :initform nil :initfunction ,#'false :readers (class-name))
    (:name precedence-list :initargs (:precedence-list) :initform nil  :initfunction ,#'false)
    (:name own-wrapper :initargs (:own-wrapper) :initform nil  :initfunction ,#'false :readers (class-own-wrapper))
@@ -1456 +1480 @@
   `(ensure-slot-id ,(slot-id.name s)))
 
+
+(defmethod (setf class-name) (new (class class))
+  (reinitialize-instance class :name new)
+  new)