diff --git a/bootfiles/18e/boot10.lisp b/bootfiles/18e/boot10.lisp new file mode 100644 index 0000000000000000000000000000000000000000..6695de8cab817e9a3bc9faae575f44c3c732f30f --- /dev/null +++ b/bootfiles/18e/boot10.lisp @@ -0,0 +1,102 @@ +;;; +;;; Bootstrap.lisp for changing slot %NAME of DEFSTRUCT-SLOT-DESCRIPTION +;;; to NAME, and making NAME hold the slot name symbol instead +;;; of a string. This is necessary for a conforming SLOT-EXISTS-P +;;; and MAKE-LOAD-FORM-SAVING-SLOTS. +;;; +;;; The build is unusual in that it requires two full builds with the +;;; same bootstrap file in a row, that is: +;;; +;;; 1. Copy this file to target:bootstrap.lisp and do a full build. +;;; Choose the CLOBBER-IT restart when asked. For an unknown +;;; reason, it doesn't work to do this programatically. +;;; +;;; 2. Leave the bootstrap file where it is and do a full build with +;;; the Lisp produced by step 1. +;;; +;;; 3. Remove the bootstrap file, and build again. +;;; + +(in-package :kernel) + +;;; +;;; Like DEFSTRUCT, but silently clobber old definitions. +;;; +(defmacro defstruct! (name &rest stuff) + `(handler-bind ((error (lambda (c) + (declare (ignore c)) + (invoke-restart 'kernel::clobber-it)))) + (defstruct ,name ,@stuff))) + +(defstruct (defstruct-slot-description + (:conc-name dsd-) + (:print-function print-defstruct-slot-description) + (:pure t) + (:make-load-form-fun :just-dump-it-normally)) + name + (index (required-argument) :type fixnum) + (accessor nil) + default + (type t) + (raw-type t :type (member t single-float double-float #+long-float long-float + complex-single-float complex-double-float + #+long-float complex-long-float + unsigned-byte)) + (read-only nil :type (member t nil))) + +(setf (info type compiler-layout 'defstruct-slot-description) + (%class-layout (find-class 'defstruct-slot-description))) + +(let ((*setf-fdefinition-hook* nil)) + (setf (fdefinition 'dsd-name) + (lambda (dsd) + (let ((name (%instance-ref dsd 1))) + (if (stringp name) + (intern name (symbol-package (dsd-accessor dsd))) + name))))) + +(defun dsd-%name (dsd) + (symbol-name (dsd-name dsd))) + +(defun parse-1-dsd (defstruct spec &optional + (islot (make-defstruct-slot-description + :name nil :index 0 :type t))) + (multiple-value-bind (name default default-p type type-p read-only ro-p) + (cond ((listp spec) + (destructuring-bind (name &optional (default nil default-p) + &key (type nil type-p) + (read-only nil ro-p)) + spec + (values name default default-p type type-p read-only ro-p))) + (t + (when (keywordp spec) + (warn "Keyword slot name indicates probable syntax ~ + error in DEFSTRUCT -- ~S." + spec)) + spec)) + (when (find name (dd-slots defstruct) :test #'string= :key #'dsd-%name) + (error 'simple-program-error + :format-control "Duplicate slot name ~S." + :format-arguments (list name))) + (setf (dsd-name islot) name) + (setf (dd-slots defstruct) (nconc (dd-slots defstruct) (list islot))) + (setf (dsd-accessor islot) (concat-pnames (dd-conc-name defstruct) name)) + (when default-p + (setf (dsd-default islot) default)) + (when type-p + (setf (dsd-type islot) + (if (eq (dsd-type islot) 't) + type + `(and ,(dsd-type islot) ,type)))) + (when ro-p + (if read-only + (setf (dsd-read-only islot) t) + (when (dsd-read-only islot) + (error "Slot ~S must be read-only in subtype ~S." name + (dsd-name islot))))) + islot)) + +(defun compare-slots (old new) + (values nil nil nil)) + +;;; end of file diff --git a/code/defstruct.lisp b/code/defstruct.lisp index 83b709d8b162cbbb88d88c7afce3565eb89ab5eb..4971320ae80bbaee59acada27d1cc16354f8ac0f 100644 --- a/code/defstruct.lisp +++ b/code/defstruct.lisp @@ -5,7 +5,7 @@ ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/defstruct.lisp,v 1.86 2003/05/12 21:54:57 gerd Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/defstruct.lisp,v 1.87 2003/05/20 18:39:36 gerd Exp $") ;;; ;;; ********************************************************************** ;;; @@ -266,6 +266,9 @@ ;; a list of (NAME . INDEX) pairs for accessors of included structures (inherited-accessor-alist () :type list)) +(defun print-defstruct-description (structure stream depth) + (declare (ignore depth)) + (format stream "#<Defstruct-Description for ~S>" (dd-name structure))) ;;; DEFSTRUCT-SLOT-DESCRIPTION holds compile-time information about structure ;;; slots. @@ -275,7 +278,9 @@ (:print-function print-defstruct-slot-description) (:pure t) (:make-load-form-fun :just-dump-it-normally)) - %name ; string name of slot + ;; + ;; The name of the slot, a symbol. + name ;; ;; its position in the implementation sequence (index (required-argument) :type fixnum) @@ -292,10 +297,12 @@ unsigned-byte)) (read-only nil :type (member t nil))) -(defun print-defstruct-description (structure stream depth) +(defun print-defstruct-slot-description (structure stream depth) (declare (ignore depth)) - (format stream "#<Defstruct-Description for ~S>" (dd-name structure))) + (format stream "#<Defstruct-Slot-Description for ~S>" (dsd-name structure))) +(defun dsd-%name (dsd) + (symbol-name (dsd-name dsd))) ;;; CLASS-STRUCTURE-P -- Internal ;;; @@ -317,20 +324,6 @@ (error "Class is not a structure class: ~S" name)) (t res)))) - -;;; DSD-Name -- External -;;; -;;; Return the name of a defstruct slot as a symbol. We store it -;;; as a string to avoid creating lots of worthless symbols at load time. -;;; -(defun dsd-name (dsd) - (intern (string (dsd-%name dsd)) - (symbol-package (dsd-accessor dsd)))) - -(defun print-defstruct-slot-description (structure stream depth) - (declare (ignore depth)) - (format stream "#<Defstruct-Slot-Description for ~S>" (dsd-name structure))) - (defun dd-maybe-make-print-method (defstruct) ;; Maybe generate CLOS DEFMETHOD forms for :print-function/:print-object. (let ((print-function-value (dd-print-function defstruct))) @@ -674,30 +667,27 @@ ;;; (defun parse-1-dsd (defstruct spec &optional (islot (make-defstruct-slot-description - :%name "" :index 0 :type t))) - (multiple-value-bind - (name default default-p type type-p read-only ro-p) - (cond - ((listp spec) - (destructuring-bind (name &optional (default nil default-p) - &key (type nil type-p) (read-only nil ro-p)) - spec - (values name default default-p type type-p read-only ro-p))) - (t - (when (keywordp spec) - (warn "Keyword slot name indicates probable syntax ~ - error in DEFSTRUCT -- ~S." - spec)) - spec)) + :name nil :index 0 :type t))) + (multiple-value-bind (name default default-p type type-p read-only ro-p) + (cond ((listp spec) + (destructuring-bind (name &optional (default nil default-p) + &key (type nil type-p) + (read-only nil ro-p)) + spec + (values name default default-p type type-p read-only ro-p))) + (t + (when (keywordp spec) + (warn "Keyword slot name indicates probable syntax ~ + error in DEFSTRUCT -- ~S." + spec)) + spec)) (when (find name (dd-slots defstruct) :test #'string= :key #'dsd-%name) (error 'simple-program-error :format-control "Duplicate slot name ~S." :format-arguments (list name))) - (setf (dsd-%name islot) (string name)) + (setf (dsd-name islot) name) (setf (dd-slots defstruct) (nconc (dd-slots defstruct) (list islot))) - (setf (dsd-accessor islot) (concat-pnames (dd-conc-name defstruct) name)) - (when default-p (setf (dsd-default islot) default)) (when type-p diff --git a/general-info/release-19a.txt b/general-info/release-19a.txt index 9a6224977cf27bbc1a44b3227a814c39e1481386..16a4d257c023d589dfc569a0f7d9e333c01ac72f 100644 --- a/general-info/release-19a.txt +++ b/general-info/release-19a.txt @@ -81,6 +81,7 @@ New in this release: - Standard methods for STANDARD-OBJECT and STRUCTURE-OBJECT defined on MAKE-LOAD-FORM. - Compliant MAKE-LOAD-FORM-SAVING-SLOTS. + - DEFSTRUCT recording slot-names as specified by users. * Numerous bugfixes: - NSET-EXCLUSIVE-OR returns the same results as SET-EXCLUSIVE-OR diff --git a/pcl/methods.lisp b/pcl/methods.lisp index fd7086eca04a2d0c2cd80dde8953f601fd399aee..1c2169fe297d9a16526dd6e6c06198ab46e2ce75 100644 --- a/pcl/methods.lisp +++ b/pcl/methods.lisp @@ -26,7 +26,7 @@ ;;; (file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/methods.lisp,v 1.31 2003/05/12 11:27:47 gerd Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/methods.lisp,v 1.32 2003/05/20 18:39:36 gerd Exp $") (in-package :pcl) @@ -225,10 +225,16 @@ "is not a non-null atom")) (defmethod legal-slot-name-p ((object standard-method) x) - (cond ((not (symbolp x)) "is not a symbol and so cannot be bound") - ((keywordp x) "is a keyword and so cannot be bound") - ((memq x '(t nil)) "cannot be bound") - ((constantp x) "is a constant and so cannot be bound") + (cond ((not (symbolp x)) + "is not a symbol and so cannot be bound") + ((keywordp x) + (if *allow-keyword-slot-names* + t + "is a keyword and so cannot be bound")) + ((memq x '(t nil)) + "cannot be bound") + ((constantp x) + "is a constant and so cannot be bound") (t t))) (defmethod legal-specializers-p ((object standard-method) x) diff --git a/pcl/std-class.lisp b/pcl/std-class.lisp index 3a36e173dd1cd4df8df985dc4f064f45d259ea91..fb012a6705c8b15b8b85dca9f573db381d27a486 100644 --- a/pcl/std-class.lisp +++ b/pcl/std-class.lisp @@ -26,7 +26,7 @@ ;;; (file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/std-class.lisp,v 1.65 2003/05/11 11:30:34 gerd Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/std-class.lisp,v 1.66 2003/05/20 18:39:36 gerd Exp $") (in-package :pcl) @@ -1064,6 +1064,13 @@ (mapc #'initialize-internal-slot-functions eslotds) eslotds)) +(defvar *allow-keyword-slot-names* nil) + +(defmethod initialize-internal-slot-functions :around + ((slotd structure-effective-slot-definition)) + (let ((*allow-keyword-slot-names* t)) + (call-next-method))) + (defmethod compute-effective-slot-definition ((class slot-class) slot-name dslotds) (declare (ignore slot-name))