From 0dcc957ae6bf24809fda82fd59c134e70058c42a Mon Sep 17 00:00:00 2001 From: William Harold Newman Date: Wed, 5 Sep 2001 04:22:32 +0000 Subject: [PATCH] 0.pre7.34: merged MNA "small defstruct patch" sbcl-devel 2001-09-03 --- src/code/defstruct.lisp | 30 +++++++++++++++++++++++------- src/code/target-defstruct.lisp | 27 ++++++++++----------------- version.lisp-expr | 2 +- 3 files changed, 34 insertions(+), 25 deletions(-) diff --git a/src/code/defstruct.lisp b/src/code/defstruct.lisp index dd97a6d..621520ea 100644 --- a/src/code/defstruct.lisp +++ b/src/code/defstruct.lisp @@ -571,7 +571,7 @@ ;;; Parse a slot description for DEFSTRUCT, add it to the description ;;; and return it. If supplied, ISLOT is a pre-initialized DSD that we ;;; modify to get the new slot. This is supplied when handling -;;; included slots. +;;; included slots. (defun parse-1-dsd (defstruct spec &optional (islot (make-defstruct-slot-description :%name "" :index 0 @@ -590,10 +590,9 @@ read-only ro-p))) (t (when (keywordp spec) - ;; FIXME: should be style warning - (warn "Keyword slot name indicates probable syntax ~ - error in DEFSTRUCT: ~S." - spec)) + (style-warn "Keyword slot name indicates probable syntax ~ + error in DEFSTRUCT: ~S." + spec)) spec)) (when (find name (dd-slots defstruct) :test #'string= :key #'dsd-%name) @@ -602,8 +601,25 @@ :format-arguments (list name))) (setf (dsd-%name islot) (string name)) (setf (dd-slots defstruct) (nconc (dd-slots defstruct) (list islot))) - (setf (dsd-accessor islot) - (symbolicate (or (dd-conc-name defstruct) "") name)) + + (let ((accessor-name (symbolicate (or (dd-conc-name defstruct) "") name)) + (predicate-name (dd-predicate defstruct))) + (setf (dsd-accessor islot) accessor-name) + (when (eql accessor-name predicate-name) + ;; Some adventurous soul has named a slot so that its accessor + ;; collides with the structure type predicate. ANSI doesn't + ;; specify what to do in this case. As of 2001-09-04, Martin + ;; Atzmueller reports that CLISP and Lispworks both give + ;; priority to the slot accessor, so that the predicate is + ;; overwritten. We might as well do the same (as well as + ;; signalling a warning). + (style-warn + "~@" + accessor-name) + (setf (dd-predicate defstruct) nil))) (when default-p (setf (dsd-default islot) default)) diff --git a/src/code/target-defstruct.lisp b/src/code/target-defstruct.lisp index 91a361b..4df8479 100644 --- a/src/code/target-defstruct.lisp +++ b/src/code/target-defstruct.lisp @@ -250,10 +250,7 @@ ;; FIXME: CMU CL used (%INSTANCEP OBJ) here. Check that ;; (TYPEP OBJ 'INSTANCE) is optimized to equally efficient code. (and (typep obj 'instance) - (let (;; FIXME: Mightn't there be a slight efficiency improvement - ;; by delaying the binding of DEPTHOID 'til it's needed? - (depthoid (layout-depthoid layout)) - (obj-layout (%instance-layout obj))) + (let ((obj-layout (%instance-layout obj))) (cond ((eq obj-layout layout) t) ;; FIXME: Does the test for LAYOUT-INVALID really belong @@ -264,9 +261,10 @@ :expected-type (layout-class obj-layout) :datum obj)) (t - (and (> (layout-depthoid obj-layout) depthoid) - (eq (svref (layout-inherits obj-layout) depthoid) - layout))))))) + (let ((depthoid (layout-depthoid layout))) + (and (> (layout-depthoid obj-layout) depthoid) + (eq (svref (layout-inherits obj-layout) depthoid) + layout)))))))) ;;;; implementing structure slot accessors as closures @@ -305,12 +303,7 @@ (unless (structure-test structure) (error 'simple-type-error :datum structure - ;; FIXME: :EXPECTED-TYPE should be something - ;; comprehensible to the user, not this. Perhaps we - ;; could work backwards from the LAYOUT-CLASS slot to - ;; find something. (Note that all four SIMPLE-TYPE-ERROR - ;; calls in this section have the same disease.) - :expected-type '(satisfies structure-test) + :expected-type (class-name (layout-class layout)) :format-control "Structure for accessor ~S is not a ~S:~% ~S" :format-arguments @@ -342,7 +335,7 @@ (unless (structure-test structure) (error 'simple-type-error :datum structure - :expected-type '(satisfies structure-test) + :expected-type (class-name (layout-class layout)) :format-control "The structure for setter ~S is not a ~S:~% ~S" :format-arguments @@ -352,7 +345,7 @@ (unless (typep-test new-value) (error 'simple-type-error :datum new-value - :expected-type '(satisfies typep-test) + :expected-type (class-name (layout-class layout)) :format-control "The new value for setter ~S is not a ~S:~% ~S" :format-arguments @@ -369,7 +362,7 @@ (unless (structure-test structure) (error 'simple-type-error :datum structure - :expected-type '(satisfies structure-test) + :expected-type (class-name (layout-class layout)) :format-control "The structure for setter ~S is not a ~S:~% ~S" :format-arguments @@ -379,7 +372,7 @@ (unless (typep-test new-value) (error 'simple-type-error :datum new-value - :expected-type '(satisfies typep-test) + :expected-type (class-name (layout-class layout)) :format-control "The new value for setter ~S is not a ~S:~% ~S" :format-arguments diff --git a/version.lisp-expr b/version.lisp-expr index 64e2199..ea6734b 100644 --- a/version.lisp-expr +++ b/version.lisp-expr @@ -18,4 +18,4 @@ ;;; for internal versions, especially for internal versions off the ;;; main CVS branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".) -"0.pre7.33" +"0.pre7.34" -- 1.7.10.4