X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fcondition.lisp;h=0c4d22d9c3d9a190f5b48be22369a192732bfe37;hb=7a2ee8c1aff0bdd286cf5d43ab40bff7fed86bea;hp=c1dc599c132c9af0c97685fe2529098d71e042cf;hpb=9bdd2579f980573a74daabe03120ed64b1733b11;p=sbcl.git

diff --git a/src/code/condition.lisp b/src/code/condition.lisp
index c1dc599..0c4d22d 100644
--- a/src/code/condition.lisp
+++ b/src/code/condition.lisp
@@ -59,9 +59,6 @@
   :metaclass-constructor make-condition-classoid
   :dd-type structure)
 
-(defun make-condition-object (actual-initargs)
-  (%make-condition-object actual-initargs nil))
-
 (defstruct (condition-slot (:copier nil))
   (name (missing-arg) :type symbol)
   ;; list of all applicable initargs
@@ -239,19 +236,15 @@
 
 ;;;; MAKE-CONDITION
 
-(defun make-condition (type &rest args)
-  #!+sb-doc
-  "Make an instance of a condition object using the specified initargs."
-  ;; Note: ANSI specifies no exceptional situations in this function.
-  ;; signalling simple-type-error would not be wrong.
-  (let* ((type (or (and (symbolp type) (find-classoid type nil))
-                    type))
+(defun allocate-condition (type &rest initargs)
+  (let* ((type (if (symbolp type)
+                   (find-classoid type nil)
+                   type))
          (class (typecase type
                   (condition-classoid type)
                   (class
-                   ;; Punt to CLOS.
-                   (return-from make-condition
-                     (apply #'make-instance type args)))
+                   (return-from allocate-condition
+                     (apply #'allocate-condition (class-name type) initargs)))
                   (classoid
                    (error 'simple-type-error
                           :datum type
@@ -265,23 +258,37 @@
                           :format-control
                           "~s does not designate a condition class."
                           :format-arguments (list type)))))
-         (res (make-condition-object args)))
-    (setf (%instance-layout res) (classoid-layout class))
+         (condition (%make-condition-object initargs '())))
+    (setf (%instance-layout condition) (classoid-layout class))
+    (values condition class)))
+
+(defun make-condition (type &rest initargs)
+  #!+sb-doc
+  "Make an instance of a condition object using the specified initargs."
+  ;; Note: ANSI specifies no exceptional situations in this function.
+  ;; signalling simple-type-error would not be wrong.
+  (multiple-value-bind (condition class)
+      (apply #'allocate-condition type initargs)
+
     ;; Set any class slots with initargs present in this call.
     (dolist (cslot (condition-classoid-class-slots class))
       (dolist (initarg (condition-slot-initargs cslot))
-        (let ((val (getf args initarg *empty-condition-slot*)))
+        (let ((val (getf initargs initarg *empty-condition-slot*)))
           (unless (eq val *empty-condition-slot*)
             (setf (car (condition-slot-cell cslot)) val)))))
+
     ;; Default any slots with non-constant defaults now.
     (dolist (hslot (condition-classoid-hairy-slots class))
       (when (dolist (initarg (condition-slot-initargs hslot) t)
-              (unless (eq (getf args initarg *empty-condition-slot*)
+              (unless (eq (getf initargs initarg *empty-condition-slot*)
                           *empty-condition-slot*)
                 (return nil)))
-        (setf (getf (condition-assigned-slots res) (condition-slot-name hslot))
+        (setf (getf (condition-assigned-slots condition)
+                    (condition-slot-name hslot))
               (find-slot-default class hslot))))
-    res))
+
+    condition))
+
 
 ;;;; DEFINE-CONDITION
 
@@ -415,6 +422,7 @@
 
       ;; Compute effective slots and set up the class and hairy slots
       ;; (subsets of the effective slots.)
+      (setf (condition-classoid-hairy-slots class) '())
       (let ((eslots (compute-effective-slots class))
             (e-def-initargs
              (reduce #'append
@@ -525,7 +533,8 @@
                      :initform-p ',initform-p
                      :documentation ',documentation
                      :initform ,(when initform-p
-                                  `#'(lambda () ,initform)))))))
+                                  `#'(lambda () ,initform))
+                     :allocation ',allocation)))))
 
       (dolist (option options)
         (unless (consp option)
@@ -614,7 +623,9 @@
              (type-error-expected-type condition)))))
 
 (def!method print-object ((condition type-error) stream)
-  (if *print-escape*
+  (if (and *print-escape*
+           (slot-boundp condition 'expected-type)
+           (slot-boundp condition 'datum))
       (flet ((maybe-string (thing)
                (ignore-errors
                  (write-to-string thing :lines 1 :readably nil :array nil :pretty t))))
@@ -685,9 +696,10 @@
 (define-condition undefined-function (cell-error) ()
   (:report
    (lambda (condition stream)
-     (format stream
-             "The function ~/sb-impl::print-symbol-with-prefix/ is undefined."
-             (cell-error-name condition)))))
+     (let ((*package* (find-package :keyword)))
+       (format stream
+               "The function ~S is undefined."
+               (cell-error-name condition))))))
 
 (define-condition special-form-function (undefined-function) ()
   (:report
@@ -966,9 +978,9 @@
   ((name :initarg :name :reader implicit-generic-function-name))
   (:report
    (lambda (condition stream)
-     (let ((*package* (find-package :keyword)))
-       (format stream "~@<Implicitly creating new generic function ~S.~:@>"
-               (implicit-generic-function-name condition))))))
+     (format stream "~@<Implicitly creating new generic function ~
+                     ~/sb-impl::print-symbol-with-prefix/.~:@>"
+             (implicit-generic-function-name condition)))))
 
 (define-condition extension-failure (reference-condition simple-error)
   ())