1.0.22.20: Make a stab at having DEFTYPE types replace structure types.

* Probably a still bit wrong around the edges, but seems to work.

diff --git a/package-data-list.lisp-expr b/package-data-list.lisp-expr
index af61be5..1accc16 100644 (file)
--- a/package-data-list.lisp-expr
+++ b/package-data-list.lisp-expr
@@ -1677,7 +1677,7 @@ is a good idea, but see SB-SYS re. blurring of boundaries."
                "OUTPUT-SYMBOL-NAME" "%COERCE-NAME-TO-FUN"
                "INVOKE-MACROEXPAND-HOOK" "DEFAULT-STRUCTURE-PRINT"
                "LAYOUT" "LAYOUT-LENGTH" "LAYOUT-PURE" "DSD-RAW-TYPE"
-               "DEFSTRUCT-DESCRIPTION" "UNDEFINE-STRUCTURE" "DD-COPIER"
+               "DEFSTRUCT-DESCRIPTION" "UNDECLARE-STRUCTURE" "DD-COPIER"
                "UNDEFINE-FUN-NAME" "DD-TYPE" "CLASSOID-STATE" "INSTANCE"
                "*TYPE-SYSTEM-INITIALIZED*" "FIND-LAYOUT" "DSD-NAME"
                "%TYPEP" "DD-RAW-INDEX" "DD-NAME" "CLASSOID-SUBCLASSES"

diff --git a/src/code/defstruct.lisp b/src/code/defstruct.lisp
index 9743b65..41f2ff1 100644 (file)
--- a/src/code/defstruct.lisp
+++ b/src/code/defstruct.lisp
@@ -992,6 +992,46 @@
        ,(funcall (nth-value 1 (slot-accessor-transforms dd dsd))
                  '(dummy new-value instance)))))
 
+;;; Blow away all the compiler info for the structure CLASS. Iterate
+;;; over this type, clearing the compiler structure type info, and
+;;; undefining all the associated functions.  If SUBCLASSES-P, also do
+;;; the same for subclasses.  FIXME: maybe rename UNDEFINE-FUN-NAME to
+;;; UNDECLARE-FUNCTION-NAME?
+(defun undeclare-structure (classoid subclasses-p)
+  (let ((info (layout-info (classoid-layout classoid))))
+    (when (defstruct-description-p info)
+      (let ((type (dd-name info)))
+        (remhash type *typecheckfuns*)
+        (setf (info :type :compiler-layout type) nil)
+        (undefine-fun-name (dd-copier-name info))
+        (undefine-fun-name (dd-predicate-name info))
+        (dolist (slot (dd-slots info))
+          (let ((fun (dsd-accessor-name slot)))
+            (unless (accessor-inherited-data fun info)
+              (undefine-fun-name fun)
+              (unless (dsd-read-only slot)
+                (undefine-fun-name `(setf ,fun)))))))
+      ;; Clear out the SPECIFIER-TYPE cache so that subsequent
+      ;; references are unknown types.
+      (values-specifier-type-cache-clear)))
+  (when subclasses-p
+    (let ((subclasses (classoid-subclasses classoid)))
+      (when subclasses
+        (collect ((subs))
+          (dohash ((classoid layout)
+                   subclasses
+                   :locked t)
+            (declare (ignore layout))
+            (undeclare-structure classoid nil)
+            (subs (classoid-proper-name classoid)))
+          ;; Is it really necessary to warn about
+          ;; undeclaring functions for subclasses?
+          (when (subs)
+            (warn "undeclaring functions for old subclasses ~
+                               of ~S:~%  ~S"
+                  (classoid-name classoid)
+                  (subs))))))))
+
 ;;; core compile-time setup of any class with a LAYOUT, used even by
 ;;; !DEFSTRUCT-WITH-ALTERNATE-METACLASS weirdosities
 (defun %compiler-set-up-layout (dd
@@ -1019,53 +1059,15 @@
                                 "the most recently loaded"
                                 :compiler-layout clayout))
     (cond (old-layout
-           (labels
-               ;; Blow away all the compiler info for the structure
-               ;; CLASS. Iterate over this type, clearing the compiler
-               ;; structure type info, and undefining all the
-               ;; associated functions.  FIXME: maybe rename
-               ;; UNDEFINE-FUN-NAME to UNDECLARE-FUNCTION-NAME?
-               ((undeclare-structure (classoid subclasses-p)
-                  (let ((info (layout-info (classoid-layout classoid))))
-                    (when (defstruct-description-p info)
-                      (let ((type (dd-name info)))
-                        (remhash type *typecheckfuns*)
-                        (setf (info :type :compiler-layout type) nil)
-                        (undefine-fun-name (dd-copier-name info))
-                        (undefine-fun-name (dd-predicate-name info))
-                        (dolist (slot (dd-slots info))
-                          (let ((fun (dsd-accessor-name slot)))
-                            (unless (accessor-inherited-data fun info)
-                              (undefine-fun-name fun)
-                              (unless (dsd-read-only slot)
-                                (undefine-fun-name `(setf ,fun)))))))
-                      ;; Clear out the SPECIFIER-TYPE cache so that subsequent
-                      ;; references are unknown types.
-                      (values-specifier-type-cache-clear)))
-                  (when subclasses-p
-                    (collect ((subs))
-                      (dohash ((classoid layout)
-                               (classoid-subclasses classoid)
-                               :locked t)
-                        (declare (ignore layout))
-                        (undeclare-structure classoid nil)
-                        (subs (classoid-proper-name classoid)))
-                      ;; Is it really necessary to warn about
-                      ;; undeclaring functions for subclasses?
-                      (when (subs)
-                        (warn "undeclaring functions for old subclasses ~
-                               of ~S:~%  ~S"
-                              (classoid-name classoid)
-                              (subs)))))))
-             (undeclare-structure (layout-classoid old-layout)
-                                  (and (classoid-subclasses classoid)
-                                       (not (eq layout old-layout))))
-             (setf (layout-invalid layout) nil)
-             ;; FIXME: it might be polite to hold onto old-layout and
-             ;; restore it at the end of the file.  -- RMK 2008-09-19
-             ;; (International Talk Like a Pirate Day).
-             (warn "~@<Clobbering the compiler's idea of the layout of ~A.~:@>"
-                   classoid)))
+           (undeclare-structure (layout-classoid old-layout)
+                                (and (classoid-subclasses classoid)
+                                     (not (eq layout old-layout))))
+           (setf (layout-invalid layout) nil)
+           ;; FIXME: it might be polite to hold onto old-layout and
+           ;; restore it at the end of the file.  -- RMK 2008-09-19
+           ;; (International Talk Like a Pirate Day).
+           (warn "~@<Clobbering the compiler's idea of the layout of ~A.~:@>"
+                 classoid))
           (t
            (unless (eq (classoid-layout classoid) layout)
              (register-layout layout :invalidate nil))

diff --git a/src/compiler/compiler-deftype.lisp b/src/compiler/compiler-deftype.lisp
index c030974..f1453c0 100644 (file)
--- a/src/compiler/compiler-deftype.lisp
+++ b/src/compiler/compiler-deftype.lisp
@@ -22,7 +22,8 @@
        (error "illegal to redefine standard type: ~S" name)))
     (:instance
      (warn "The class ~S is being redefined to be a DEFTYPE." name)
-     (undefine-structure (layout-info (classoid-layout (find-classoid name))))
+     (undeclare-structure (find-classoid name) t)
+     ;; FIXME: shouldn't this happen only at eval-time?
      (setf (classoid-cell-classoid (find-classoid-cell name :create t)) nil)
      (setf (info :type :compiler-layout name) nil)
      (setf (info :type :kind name) :defined))

diff --git a/src/compiler/deftype.lisp b/src/compiler/deftype.lisp
index f488abf..a0a992f 100644 (file)
--- a/src/compiler/deftype.lisp
+++ b/src/compiler/deftype.lisp
@@ -16,6 +16,9 @@
         (sb!kernel::arg-count-error 'deftype (car whole) (cdr whole) nil 0 0)
         expansion)))
 
+(defun %deftype (name)
+  (setf (classoid-cell-pcl-class (find-classoid-cell name :create t)) nil))
+
 (def!macro sb!xc:deftype (name lambda-list &body body)
   #!+sb-doc
   "Define a new type, with syntax like DEFMACRO."
@@ -38,9 +41,12 @@
                            ,macro-body)
                         doc
                         nil)))))
-    `(eval-when (:compile-toplevel :load-toplevel :execute)
-       (%compiler-deftype ',name
-                          ',lambda-list
-                          ,expander-form
-                          ,doc
-                          ,source-location-form))))
+    `(progn
+       (eval-when (:compile-toplevel :load-toplevel :execute)
+         (%compiler-deftype ',name
+                            ',lambda-list
+                            ,expander-form
+                            ,doc
+                            ,source-location-form))
+       (eval-when (:load-toplevel :execute)
+         (%deftype ',name)))))

diff --git a/tests/deftype.impure.lisp b/tests/deftype.impure.lisp
index 373f6d4..b11b982 100644 (file)
--- a/tests/deftype.impure.lisp
+++ b/tests/deftype.impure.lisp
@@ -31,3 +31,10 @@
 (deftype deftype-with-empty-body ())
 (assert (subtypep 'deftype-with-empty-body nil))
 (assert (subtypep nil 'deftype-with-empty-body))
+
+;; Ensure that DEFTYPE can successfully replace a DEFSTRUCT type
+;; definition.
+(defstruct foo)
+(assert (progn (deftype foo () 'integer)
+               (null (find-class 'foo nil))
+               t))
\ No newline at end of file

diff --git a/version.lisp-expr b/version.lisp-expr
index fb1cc7a..78b60bb 100644 (file)
--- a/version.lisp-expr
+++ b/version.lisp-expr
@@ -17,4 +17,4 @@
 ;;; checkins which aren't released. (And occasionally for internal
 ;;; versions, especially for internal versions off the main CVS
 ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".)
-"1.0.22.19"
+"1.0.22.20"