From 571d4c66db0187bdbc67111e9a1630010ef43478 Mon Sep 17 00:00:00 2001 From: ram <ram> Date: Mon, 25 Oct 1993 13:44:19 +0000 Subject: [PATCH] Generalized condition effective slot computation so that we can find slots with non-constant defaults and special-case them at MAKE-CONDITION time. --- code/error.lisp | 141 ++++++++++++++++++++++++++---------------------- 1 file changed, 77 insertions(+), 64 deletions(-) diff --git a/code/error.lisp b/code/error.lisp index c79ce537c..34b8f55bc 100644 --- a/code/error.lisp +++ b/code/error.lisp @@ -7,7 +7,7 @@ ;;; Scott Fahlman or slisp-group@cs.cmu.edu. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/error.lisp,v 1.36 1993/09/01 00:23:39 ram Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/error.lisp,v 1.37 1993/10/25 13:44:19 ram Exp $") ;;; ;;; ********************************************************************** ;;; @@ -354,7 +354,12 @@ (default-initargs () :type list) ;; ;; CPL as a list of class objects, with all non-condition classes removed. - (cpl () :type list)) + (cpl () :type list) + ;; + ;; A list of all the effective instance allocation slots of this class that + ;; have a non-constant initform or default-initarg. Values for these slots + ;; must be computed in the dynamic environment of MAKE-CONDITION. + (hairy-slots nil :type list)) ); eval-when (compile load eval) @@ -525,6 +530,14 @@ (let ((val (getf args initarg *empty-slot*))) (unless (eq val *empty-slot*) (setf (car (condition-slot-cell cslot)) val))))) + ;; + ;; Default any slots with non-constant defaults now. + (dolist (hslot (condition-class-hairy-slots class)) + (when (dolist (initarg (condition-slot-initargs hslot) t) + (unless (eq (getf initarg args *empty-slot*) *empty-slot*) + (return nil))) + (setf (getf (condition-assigned-slots res) (condition-slot-name hslot)) + (find-slot-default class hslot)))) res)) @@ -542,7 +555,6 @@ (cond ((not old-layout) (register-layout layout)) ((not *type-system-initialized*) - (setf (layout-info old-layout) (layout-info layout)) (setf (layout-class old-layout) class) (setq layout old-layout) (unless (eq (class-layout class) layout) @@ -553,6 +565,9 @@ ((not (class-layout class)) (register-layout layout))) + (setf (layout-info layout) + (layout-info (class-layout (find-class 'condition)))) + (setf (find-class name) class) ;; ;; Initialize CPL slot from layout. @@ -571,6 +586,35 @@ ); eval-when (compile load eval) + +;;; COMPUTE-EFFECTIVE-SLOTS -- Internal +;;; +;;; Compute the effective slots of class, copying inherited slots and +;;; side-effecting direct slots. +;;; +(defun compute-effective-slots (class) + (collect ((res (copy-list (condition-class-slots class)))) + (dolist (sclass (condition-class-cpl class)) + (dolist (sslot (condition-class-slots sclass)) + (let ((found (find (condition-slot-name sslot) (res) + :test #'eq))) + (cond (found + (setf (condition-slot-initargs found) + (union (condition-slot-initargs found) + (condition-slot-initargs sslot))) + (unless (condition-slot-initform-p found) + (setf (condition-slot-initform-p found) + (condition-slot-initform-p sslot)) + (setf (condition-slot-initform found) + (condition-slot-initform sslot))) + (unless (condition-slot-allocation found) + (setf (condition-slot-allocation found) + (condition-slot-allocation sslot)))) + (t + (res (copy-structure cslot))))))) + (res))) + + (defun %define-condition (name slots documentation report default-initargs) (let ((class (find-class name))) (setf (slot-class-print-function class) #'%print-condition) @@ -580,36 +624,9 @@ (setf (documentation name 'type) documentation) (dolist (slot slots) - (let* ((name (condition-slot-name slot)) - (islot (find-slot (cdr (condition-class-cpl class)) name))) - ;; - ;; Handle :allocation. If a new class slot, allocate cell. If NIL, - ;; default it. - (ecase (condition-slot-allocation slot) - (:class - (setf (condition-slot-cell slot) - (list (if (condition-slot-initform-p slot) - (let ((initform (condition-slot-initform slot))) - (if (functionp initform) - (funcall initform) - initform)) - *empty-slot*)))) - (:instance) - ((nil) - (when islot - (setf (condition-slot-allocation slot) - (condition-slot-allocation islot))))) - - ;; - ;; Default initform. - (when (and islot (not (condition-slot-initform-p slot))) - (setf (condition-slot-initform slot) - (condition-slot-initform islot)) - (setf (condition-slot-initform-p slot) - (condition-slot-initform-p islot))) - - ;; - ;; Set up reader & writer functions. + ;; + ;; Set up reader & writer functions. + (let ((name (condition-slot-name slot))) (dolist (reader (condition-slot-readers slot)) (setf (fdefinition reader) #'(lambda (condition) @@ -618,37 +635,33 @@ (setf (fdefinition writer) #'(lambda (new-value condition) (condition-writer-function condition new-value name)))))) - - (collect ((class-slots)) - ;; - ;; Direct class slots: - (dolist (slot slots) - (when (eq (condition-slot-allocation slot) :class) - (class-slots slot))) - ;; - ;; Indirect class slots: - (dolist (sclass (class-direct-superclasses class)) - (dolist (cslot (condition-class-class-slots sclass)) - (when (and (eq (condition-slot-allocation - (find-slot (condition-class-cpl class) - (condition-slot-name cslot))) - :class) - (not (member cslot (class-slots) - :key #'condition-slot-name - :test #'eq))) - (class-slots (copy-structure cslot))))) - - (dolist (slot (union slots (class-slots))) - (let ((name (condition-slot-name slot))) - (collect ((initargs (condition-slot-initargs slot) union)) - (dolist (super (class-direct-superclasses class)) - (dolist (sslot (condition-class-slots super)) - (when (eq (condition-slot-name sslot) name) - (initargs (condition-slot-initargs sslot))))) - (setf (condition-slot-initargs slot) (initargs))))) - - (setf (condition-class-class-slots class) (class-slots)))) - + + ;; + ;; Compute effective slots and set up the class and hairy slots (subsets of + ;; the effective slots.) + (let ((eslots (compute-effective-slots class)) + (e-def-initargs + (reduce #'append + (mapcar #'condition-class-default-initargs + (condition-class-cpl class))))) + (dolist (slot eslots) + (ecase (condition-slot-allocation slot) + (:class + (unless (condition-slot-cell slot) + (setf (condition-slot-cell slot) + (list (if (condition-slot-initform-p slot) + (let ((initform (condition-slot-initform slot))) + (if (functionp initform) + (funcall initform) + initform)) + *empty-slot*)))) + (push slot (condition-class-class-slots class))) + (:instance + (when (or (functionp (condition-slot-initform slot)) + (dolist (initarg (condition-slot-initargs slot) nil) + (when (functionp (getf initarg e-def-initargs)) + (return t)))) + (push slot (condition-class-hairy-slots class)))))))) name) -- GitLab