From aa1a5c6ea31c248587d78f62943ad749ea8fbe2f Mon Sep 17 00:00:00 2001 From: Richard M Kreuter Date: Sun, 30 Nov 2008 20:37:22 +0000 Subject: [PATCH] 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. --- package-data-list.lisp-expr | 2 +- src/code/defstruct.lisp | 96 ++++++++++++++++++------------------ src/compiler/compiler-deftype.lisp | 3 +- src/compiler/deftype.lisp | 18 ++++--- tests/deftype.impure.lisp | 7 +++ version.lisp-expr | 2 +- 6 files changed, 72 insertions(+), 56 deletions(-) diff --git a/package-data-list.lisp-expr b/package-data-list.lisp-expr index af61be5..1accc16 100644 --- 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 --- 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 "~@" - 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 "~@" + 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 --- 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 --- 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 --- 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 --- 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" -- 1.7.10.4