[Openmcl-cvs-notifications] r16239 - /trunk/source/level-1/l1-readloop-lds.lisp

gz at clozure.com gz at clozure.com
Thu Sep 25 17:12:51 UTC 2014


Author: gz
Date: Thu Sep 25 17:12:51 2014
New Revision: 16239

Log:
add *show-condition-context*, which can be used to turn off the addition of=
 calling function and process info in %break-message

Modified:
    trunk/source/level-1/l1-readloop-lds.lisp

Modified: trunk/source/level-1/l1-readloop-lds.lisp
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D
--- trunk/source/level-1/l1-readloop-lds.lisp	(original)
+++ trunk/source/level-1/l1-readloop-lds.lisp	Thu Sep 25 17:12:51 2014
@@ -556,6 +556,10 @@
     (%break-message msg c)
     (break-loop c)))
 =

+(defvar *show-condition-context* t
+  "The type of conditions which should include the execution context as pa=
rt of their error-output message.
+   E.g. value of 'error will prevent warnings from including the calling f=
unction and process in the warning message")
+
 (defun %break-message (msg condition &optional (error-pointer *top-error-f=
rame*) (prefixchar #\>))
   (let ((*print-circle* *error-print-circle*)
         ;(*print-prett*y nil)
@@ -571,6 +575,7 @@
         (*signal-printing-errors* nil)
         (s (make-indenting-string-output-stream prefixchar nil))
         (sub (make-string-output-stream))
+        (show-context (typep condition *show-condition-context*))
         (indent 0))
     (format s "~A~@[ ~A:~] " prefixchar msg)
     (setf (indenting-string-output-stream-indent s) (setq indent (column s=
)))
@@ -578,15 +583,17 @@
     ;(format s "~A" condition) ; evil if circle
     (report-condition condition sub)
     (format s "~A" (get-output-stream-string sub))
-    (if (not (and (typep condition 'simple-program-error)
-                  (simple-program-error-context condition)))
+    (if (and show-context
+             (not (and (typep condition 'simple-program-error)
+                       (simple-program-error-context condition))))
       (format *error-output* "~&~A~%~A While executing: ~S"
               (get-output-stream-string s) prefixchar (%real-err-fn-name e=
rror-pointer))
       (format *error-output* "~&~A"
               (get-output-stream-string s)))
-    (if *current-process*
-      (format *error-output* ", in process ~a(~d).~%" (process-name *curre=
nt-process*) (process-serial-number *current-process*))
-      (format *error-output* ", in an uninitialized process~%"))
+    (when show-context
+      (if *current-process*
+        (format *error-output* ", in process ~a(~d).~%" (process-name *cur=
rent-process*) (process-serial-number *current-process*))
+        (format *error-output* ", in an uninitialized process~%")))
   (force-output *error-output*)))
 					; returns NIL
 =




More information about the Openmcl-cvs-notifications mailing list