0.pre7.110:

[sbcl.git] / src / compiler / ir1report.lisp

diff --git a/src/compiler/ir1report.lisp b/src/compiler/ir1report.lisp
index bfaab10..5a77869 100644 (file)
--- a/src/compiler/ir1report.lisp
+++ b/src/compiler/ir1report.lisp
@@ -64,13 +64,12 @@
   ;; a list of stringified enclosing non-original source forms
   (source nil :type list)
   ;; the stringified form in the original source that expanded into SOURCE
-  (original-source (required-argument) :type simple-string)
+  (original-source (missing-arg) :type simple-string)
   ;; a list of prefixes of "interesting" forms that enclose original-source
   (context nil :type list)
   ;; the FILE-INFO-NAME for the relevant FILE-INFO
-  (file-name (required-argument)
-            :type (or pathname (member :lisp :stream)))
-  ;; the file position at which the top-level form starts, if applicable
+  (file-name (missing-arg) :type (or pathname (member :lisp :stream)))
+  ;; the file position at which the top level form starts, if applicable
   (file-position nil :type (or index null))
   ;; the original source part of the source path
   (original-source-path nil :type list))
@@ -98,9 +97,9 @@
 ;;; it's a reasonable thing to put in SB-EXT in case some dedicated
 ;;; user wants to do some heavy tweaking to make SBCL give more
 ;;; informative output about his code.
-(defmacro def-source-context (name lambda-list &body body)
+(defmacro define-source-context (name lambda-list &body body)
   #!+sb-doc
-  "DEF-SOURCE-CONTEXT Name Lambda-List Form*
+  "DEFINE-SOURCE-CONTEXT Name Lambda-List Form*
    This macro defines how to extract an abbreviated source context from the
    Named form when it appears in the compiler input. Lambda-List is a DEFMACRO
    style lambda-list used to parse the arguments. The Body should return a
@@ -110,13 +109,17 @@
           #'(lambda (,n-whole)
               (destructuring-bind ,lambda-list ,n-whole ,@body)))))
 
-(def-source-context defstruct (name-or-options &rest slots)
+(defmacro def-source-context (&rest rest)
+  (deprecation-warning 'def-source-context 'define-source-context)
+  `(define-source-context ,@rest))
+
+(define-source-context defstruct (name-or-options &rest slots)
   (declare (ignore slots))
   `(defstruct ,(if (consp name-or-options)
                   (car name-or-options)
                   name-or-options)))
 
-(def-source-context function (thing)
+(define-source-context function (thing)
   (if (and (consp thing) (eq (first thing) 'lambda) (consp (rest thing)))
       `(lambda ,(second thing))
       `(function ,thing)))
@@ -179,13 +182,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
@@ -260,7 +281,7 @@
   (cond ((= *last-message-count* 1)
         (when terpri (terpri *error-output*)))
        ((> *last-message-count* 1)
-          (format *error-output* "~&; [Last message occurs ~D times.]~2%"
+          (format *error-output* "~&; [Last message occurs ~W times.]~2%"
                 *last-message-count*)))
   (setq *last-message-count* 0))
 
@@ -412,7 +433,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)