X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;ds=sidebyside;f=src%2Fcode%2Fcondition.lisp;h=935a2a66ac06bb4de35c60cec60f667a90267c66;hb=4eb1a6d3ad2b7dcc19ac0ec979a1eb1eb049659a;hp=86732a541018667c689d0bd155fd5f4a7d0fb13c;hpb=959057baab99d4328fc386aee3fcc812f5fcb3ed;p=sbcl.git

diff --git a/src/code/condition.lisp b/src/code/condition.lisp
index 86732a5..935a2a6 100644
--- a/src/code/condition.lisp
+++ b/src/code/condition.lisp
@@ -17,10 +17,12 @@
 
 ;;;; the CONDITION class
 
-(/show0 "late-target-error.lisp 20")
+(/show0 "condition.lisp 20")
 
 (eval-when (:compile-toplevel :load-toplevel :execute)
 
+(/show0 "condition.lisp 24")
+
 (def!struct (condition-class (:include slot-class)
 			     (:constructor bare-make-condition-class))
   ;; list of CONDITION-SLOT structures for the direct slots of this
@@ -33,8 +35,8 @@
   (report nil :type (or function null))
   ;; list of alternating initargs and initforms
   (default-initargs () :type list)
-  ;; class precedence list as a list of class objects, with all
-  ;; non-condition classes removed
+  ;; class precedence list as a list of CLASS objects, with all
+  ;; non-CONDITION classes removed
   (cpl () :type list)
   ;; a list of all the effective instance allocation slots of this
   ;; class that have a non-constant initform or default-initarg.
@@ -42,36 +44,39 @@
   ;; environment of MAKE-CONDITION.
   (hairy-slots nil :type list))
 
+(/show0 "condition.lisp 49")
+
 (defun make-condition-class (&rest rest)
   (apply #'bare-make-condition-class
 	 (rename-key-args '((:name :%name)) rest)))
 
+(/show0 "condition.lisp 53")
+
 ) ; EVAL-WHEN
 
-(defstruct (condition
-	    (:constructor make-condition-object (actual-initargs))
-	    (:alternate-metaclass instance
-				  condition-class
-				  make-condition-class)
-	    (:copier nil))
-  ;; actual initargs supplied to MAKE-CONDITION
-  (actual-initargs (required-argument) :type list)
-  ;; a plist mapping slot names to any values that were assigned or
-  ;; defaulted after creation
-  (assigned-slots () :type list))
+(!defstruct-with-alternate-metaclass condition
+  :slot-names (actual-initargs assigned-slots)
+  :boa-constructor %make-condition-object
+  :superclass-name instance
+  :metaclass-name condition-class
+  :metaclass-constructor make-condition-class
+  :dd-type structure)
+
+(defun make-condition-object (actual-initargs)
+  (%make-condition-object actual-initargs nil))
 
 (defstruct (condition-slot (:copier nil))
-  (name (required-argument) :type symbol)
+  (name (missing-arg) :type symbol)
   ;; list of all applicable initargs
-  (initargs (required-argument) :type list)
+  (initargs (missing-arg) :type list)
   ;; names of reader and writer functions
-  (readers (required-argument) :type list)
-  (writers (required-argument) :type list)
+  (readers (missing-arg) :type list)
+  (writers (missing-arg) :type list)
   ;; true if :INITFORM was specified
-  (initform-p (required-argument) :type (member t nil))
+  (initform-p (missing-arg) :type (member t nil))
   ;; If this is a function, call it with no args. Otherwise, it's the
   ;; actual value.
-  (initform (required-argument) :type t)
+  (initform (missing-arg) :type t)
   ;; allocation of this slot, or NIL until defaulted
   (allocation nil :type (member :instance :class nil))
   ;; If ALLOCATION is :CLASS, this is a cons whose car holds the value.
@@ -83,6 +88,7 @@
 ;;; from CMU CL, and didn't seem to be explained there, and I haven't
 ;;; figured out whether it's right. -- WHN 19990612
 (eval-when (:compile-toplevel :load-toplevel :execute)
+  (/show0 "condition.lisp 103")
   (let ((condition-class (locally
 			   ;; KLUDGE: There's a FIND-CLASS DEFTRANSFORM for
 			   ;; constant class names which creates fast but
@@ -92,7 +98,8 @@
 			   (declare (notinline sb!xc:find-class))
 			   (sb!xc:find-class 'condition))))
     (setf (condition-class-cpl condition-class)
-	  (list condition-class))))
+	  (list condition-class)))
+  (/show0 "condition.lisp 103"))
 
 (setf (condition-class-report (locally
 				;; KLUDGE: There's a FIND-CLASS DEFTRANSFORM
@@ -773,5 +780,5 @@
     "Transfer control and VALUE to a restart named USE-VALUE, or return NIL if
    none exists."))
 
-(/show0 "late-target-error.lisp end of file")
+(/show0 "condition.lisp end of file")