Skip to content
Snippets Groups Projects
Commit dc2326e7 authored by ram's avatar ram
Browse files

Added support for non-hierarchical "structures" when defining default accessor

closures.  Changed UNDEFINE-STRUCTURE to take a class, since that's how
compiler/proclaim is calling it.
parent 453583b8
No related branches found
No related tags found
No related merge requests found
...@@ -7,7 +7,7 @@ ...@@ -7,7 +7,7 @@
;;; Scott Fahlman or slisp-group@cs.cmu.edu. ;;; Scott Fahlman or slisp-group@cs.cmu.edu.
;;; ;;;
(ext:file-comment (ext:file-comment
"$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/defstruct.lisp,v 1.53 1993/08/22 22:21:00 wlott Exp $") "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/defstruct.lisp,v 1.54 1993/08/30 15:10:20 ram Exp $")
;;; ;;;
;;; ********************************************************************** ;;; **********************************************************************
;;; ;;;
...@@ -1058,26 +1058,50 @@ ...@@ -1058,26 +1058,50 @@
;;; (not raw.) ;;; (not raw.)
;;; ;;;
(defun structure-slot-accessor (layout dsd) (defun structure-slot-accessor (layout dsd)
#'(lambda (structure) (let ((class (layout-class layout)))
(declare (optimize (speed 3) (safety 0))) (if (typep class 'basic-structure-class)
(unless (typep-to-layout structure layout) #'(lambda (structure)
(error "Structure for accessor ~S is not a ~S:~% ~S" (declare (optimize (speed 3) (safety 0)))
(dsd-accessor dsd) (class-name (layout-class layout)) (unless (typep-to-layout structure layout)
structure)) (error "Structure for accessor ~S is not a ~S:~% ~S"
(%instance-ref structure (dsd-index dsd)))) (dsd-accessor dsd) (class-name (layout-class layout))
structure))
(%instance-ref structure (dsd-index dsd)))
#'(lambda (structure)
(declare (optimize (speed 3) (safety 0)))
(unless (%typep structure class)
(error "Structure for accessor ~S is not a ~S:~% ~S"
(dsd-accessor dsd) class
structure))
(%instance-ref structure (dsd-index dsd))))))
;;; ;;;
(defun structure-slot-setter (layout dsd) (defun structure-slot-setter (layout dsd)
#'(lambda (new-value structure) (let ((class (layout-class layout)))
(declare (optimize (speed 3) (safety 0))) (if (typep class 'basic-structure-class)
(unless (typep-to-layout structure layout) #'(lambda (new-value structure)
(error "Structure for setter ~S is not a ~S:~% ~S" (declare (optimize (speed 3) (safety 0)))
`(setf ,(dsd-accessor dsd)) (class-name (layout-class layout)) (unless (typep-to-layout structure layout)
structure)) (error "Structure for setter ~S is not a ~S:~% ~S"
(unless (typep new-value (dsd-type dsd)) `(setf ,(dsd-accessor dsd))
(error "New-Value for setter ~S is not a ~S:~% ~S." (class-name (layout-class layout))
`(setf ,(dsd-accessor dsd)) (dsd-type dsd) structure))
new-value)) (unless (%typep new-value (dsd-type dsd))
(setf (%instance-ref structure (dsd-index dsd)) new-value))) (error "New-Value for setter ~S is not a ~S:~% ~S."
`(setf ,(dsd-accessor dsd)) (dsd-type dsd)
new-value))
(setf (%instance-ref structure (dsd-index dsd)) new-value))
#'(lambda (new-value structure)
(declare (optimize (speed 3) (safety 0)))
(unless (%typep structure class)
(error "Structure for setter ~S is not a ~S:~% ~S"
`(setf ,(dsd-accessor dsd))
(class-name class)
structure))
(unless (%typep new-value (dsd-type dsd))
(error "New-Value for setter ~S is not a ~S:~% ~S."
`(setf ,(dsd-accessor dsd)) (dsd-type dsd)
new-value))
(setf (%instance-ref structure (dsd-index dsd)) new-value)))))
;;; %Defstruct -- Internal ;;; %Defstruct -- Internal
...@@ -1277,25 +1301,26 @@ ...@@ -1277,25 +1301,26 @@
;;; UNDEFINE-STRUCTURE -- Interface ;;; UNDEFINE-STRUCTURE -- Interface
;;; ;;;
;;; Blow away all the compiler info for the structure described by Info. ;;; Blow away all the compiler info for the structure CLASS.
;;; Iterate over this type, clearing the compiler structure ;;; Iterate over this type, clearing the compiler structure
;;; type info, and undefining all the associated functions. ;;; type info, and undefining all the associated functions.
;;; ;;;
(defun undefine-structure (info) (defun undefine-structure (class)
(when (defstruct-description-p info) (let ((info (layout-info (class-layout class))))
(let ((type (dd-name info))) (when (defstruct-description-p info)
(setf (info type compiler-layout type) nil) (let ((type (dd-name info)))
(undefine-function-name (dd-copier info)) (setf (info type compiler-layout type) nil)
(undefine-function-name (dd-predicate info)) (undefine-function-name (dd-copier info))
(dolist (slot (dd-slots info)) (undefine-function-name (dd-predicate info))
(let ((fun (dsd-accessor slot))) (dolist (slot (dd-slots info))
(undefine-function-name fun) (let ((fun (dsd-accessor slot)))
(unless (dsd-read-only slot) (undefine-function-name fun)
(undefine-function-name `(setf ,fun)))))) (unless (dsd-read-only slot)
;; (undefine-function-name `(setf ,fun))))))
;; Clear out the SPECIFIER-TYPE cache so that subsequent references are ;;
;; unknown types. ;; Clear out the SPECIFIER-TYPE cache so that subsequent references are
(values-specifier-type-cache-clear)) ;; unknown types.
(values-specifier-type-cache-clear)))
(undefined-value)) (undefined-value))
...@@ -1366,7 +1391,8 @@ ...@@ -1366,7 +1391,8 @@
(not (eq layout old-layout))) (not (eq layout old-layout)))
(collect ((subs)) (collect ((subs))
(do-hash (class layout (class-subclasses class)) (do-hash (class layout (class-subclasses class))
(undefine-structure (layout-info layout)) (declare (ignore layout))
(undefine-structure class)
(subs (class-proper-name class))) (subs (class-proper-name class)))
(when (subs) (when (subs)
(warn "Removing old subclasses of ~S:~% ~S" (warn "Removing old subclasses of ~S:~% ~S"
......
0% Loading or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment