X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fir1report.lisp;h=eadcf868f4a74fdcd5247f6b85b8e7d5d80c7910;hb=ba7659c92f2b7fac7e9532a3db9114c5bdc4ab55;hp=93190eb922a572098b170575d0555db69a5bef76;hpb=5ec8d0c1c8b7939818b75118b472fac1af554f9a;p=sbcl.git

diff --git a/src/compiler/ir1report.lisp b/src/compiler/ir1report.lisp
index 93190eb..eadcf86 100644
--- a/src/compiler/ir1report.lisp
+++ b/src/compiler/ir1report.lisp
@@ -178,13 +178,31 @@
 ;;; Convert a source form to a string, suitably formatted for use in
 ;;; compiler warnings.
 (defun stringify-form (form &optional (pretty t))
-  (let ((*print-level* *compiler-error-print-level*)
-	(*print-length* *compiler-error-print-length*)
-	(*print-lines* *compiler-error-print-lines*)
-	(*print-pretty* pretty))
-    (if pretty
-	(format nil "~<~@;  ~S~:>" (list form))
-	(prin1-to-string form))))
+  (with-standard-io-syntax
+   (let ((*print-readably* nil)
+         (*print-pretty* pretty)
+         (*print-level* *compiler-error-print-level*)
+         (*print-length* *compiler-error-print-length*)
+         (*print-lines* *compiler-error-print-lines*))
+     (if pretty
+         (format nil "~<~@;  ~S~:>" (list form))
+         (prin1-to-string form)))))
+
+;;; shorthand for creating debug names from source names or other
+;;; stems, e.g.
+;;;   (DEBUG-NAMIFY "FLET ~S" SOURCE-NAME)
+;;;   (DEBUG-NAMIFY "top level form ~S" FORM)
+;;;
+;;; FIXME: This function seems to have a lot in common with
+;;; STRINGIFY-FORM, and perhaps there's some way to merge the two
+;;; functions.
+(defun debug-namify (format-string &rest format-arguments)
+  (with-standard-io-syntax
+   (let ((*print-readably* nil)
+         (*package* *cl-package*)
+         (*print-length* 3)
+         (*print-level* 2))
+     (apply #'format nil format-string format-arguments))))
 
 ;;; Return a COMPILER-ERROR-CONTEXT structure describing the current
 ;;; error context, or NIL if we can't figure anything out. ARGS is a
@@ -411,7 +429,7 @@
 
 ;;; The politically correct way to print out progress messages and
 ;;; such like. We clear the current error context so that we know that
-;;; it needs to be reprinted, and we also Force-Output so that the
+;;; it needs to be reprinted, and we also FORCE-OUTPUT so that the
 ;;; message gets seen right away.
 (declaim (ftype (function (string &rest t) (values)) compiler-mumble))
 (defun compiler-mumble (format-string &rest format-args)