From 00c93ebddb9224ae6d554fa010d3c19ddbf401d9 Mon Sep 17 00:00:00 2001 From: Christophe Rhodes Date: Thu, 17 Apr 2003 15:04:22 +0000 Subject: [PATCH] 0.pre8.64: Fix FIND-CLASS of compiled-but-not-loaded structure classes ... slightly sucky hook variable in %TARGET-DEFSTRUCT, to be used by PCL ... ENSURE-NON-STANDARD-CLASS updated to cope with the possibility that a CLASSOID exists but the accessor functions aren't FBOUNDP. ... (side benefit: redefinitions of structures are now reflected in PCL classes) ... test for FIND-CLASS non-breakage. --- src/code/target-defstruct.lisp | 9 +++++++++ src/pcl/braid.lisp | 36 +++++++++++++++++++++++------------- tests/compiler-1.impure-cload.lisp | 8 ++++++++ version.lisp-expr | 2 +- 4 files changed, 41 insertions(+), 14 deletions(-) diff --git a/src/code/target-defstruct.lisp b/src/code/target-defstruct.lisp index ec62457..87aab71 100644 --- a/src/code/target-defstruct.lisp +++ b/src/code/target-defstruct.lisp @@ -142,6 +142,10 @@ ;;;; target-only parts of the DEFSTRUCT top level code +;;; A list of hooks designating functions of one argument, the +;;; classoid, to be called when a defstruct is evaluated. +(defvar *defstruct-hooks* nil) + ;;; Catch attempts to mess up definitions of symbols in the CL package. (defun protect-cl (symbol) (/show0 "entering PROTECT-CL, SYMBOL=..") @@ -236,6 +240,11 @@ (setf (fdocumentation (dd-name dd) 'type) (dd-doc dd))) + ;; the BOUNDP test here is to get past cold-init. + (when (boundp '*defstruct-hooks*) + (dolist (fun *defstruct-hooks*) + (funcall fun (find-classoid (dd-name dd))))) + (/show0 "leaving %TARGET-DEFSTRUCT") (values)) diff --git a/src/pcl/braid.lisp b/src/pcl/braid.lisp index 0fc49bb..01886b9 100644 --- a/src/pcl/braid.lisp +++ b/src/pcl/braid.lisp @@ -527,29 +527,32 @@ (defun eval-form (form) (lambda () (eval form))) -(defun slot-initargs-from-structure-slotd (slotd) - `(:name ,(structure-slotd-name slotd) - :defstruct-accessor-symbol ,(structure-slotd-accessor-symbol slotd) - :internal-reader-function ,(structure-slotd-reader-function slotd) - :internal-writer-function ,(structure-slotd-writer-function slotd) - :type ,(or (structure-slotd-type slotd) t) - :initform ,(structure-slotd-init-form slotd) - :initfunction ,(eval-form (structure-slotd-init-form slotd)))) - -(defun ensure-non-standard-class (name) +(defun ensure-non-standard-class (name &optional existing-class) (flet ((ensure (metaclass &optional (slots nil slotsp)) (let ((supers (mapcar #'classoid-name (classoid-direct-superclasses (find-classoid name))))) (if slotsp - (ensure-class-using-class nil name + (ensure-class-using-class existing-class name :metaclass metaclass :name name :direct-superclasses supers :direct-slots slots) - (ensure-class-using-class nil name + (ensure-class-using-class existing-class name :metaclass metaclass :name name - :direct-superclasses supers))))) + :direct-superclasses supers)))) + (slot-initargs-from-structure-slotd (slotd) + (let ((accessor (structure-slotd-accessor-symbol slotd))) + `(:name ,(structure-slotd-name slotd) + :defstruct-accessor-symbol ,accessor + ,@(when (fboundp accessor) + `(:internal-reader-function + (structure-slotd-reader-function slotd) + :internal-writer-function + ,(structure-slotd-writer-function slotd))) + :type ,(or (structure-slotd-type slotd) t) + :initform ,(structure-slotd-init-form slotd) + :initfunction ,(eval-form (structure-slotd-init-form slotd)))))) (cond ((structure-type-p name) (ensure 'structure-class (mapcar #'slot-initargs-from-structure-slotd @@ -558,6 +561,13 @@ (ensure 'condition-class)) (t (error "~@<~S is not the name of a class.~@:>" name))))) + +(defun maybe-reinitialize-structure-class (classoid) + (let ((class (classoid-pcl-class classoid))) + (when class + (ensure-non-standard-class (class-name class) class)))) + +(pushnew 'maybe-reinitialize-structure-class sb-kernel::*defstruct-hooks*) (defun make-class-predicate (class name) (let* ((gf (ensure-generic-function name)) diff --git a/tests/compiler-1.impure-cload.lisp b/tests/compiler-1.impure-cload.lisp index eea3feb..6d61de0 100644 --- a/tests/compiler-1.impure-cload.lisp +++ b/tests/compiler-1.impure-cload.lisp @@ -225,4 +225,12 @@ nil) '(444 #*0000))) +(defstruct some-structure a) +(eval-when (:compile-toplevel) + ;; in the big CLASS reorganization in pre8, this would fail with + ;; SOME-STRUCTURE-A is not FBOUNDP. Fixed in 0.pre8.64 + (find-class 'some-structure nil)) +(eval-when (:load-toplevel) + (assert (typep (find-class 'some-structure) 'class))) + (sb-ext:quit :unix-status 104) ; success diff --git a/version.lisp-expr b/version.lisp-expr index 0de56bf..0f5249c 100644 --- a/version.lisp-expr +++ b/version.lisp-expr @@ -18,4 +18,4 @@ ;;; versions, especially for internal versions off the main CVS ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".) -"0.pre8.63" +"0.pre8.64" -- 1.7.10.4