X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fir1report.lisp;h=f598a0489007bc9d2203302313a14cdc3e509926;hb=68612b8227bdd1a9e70962201f54231c82affa17;hp=93190eb922a572098b170575d0555db69a5bef76;hpb=5ec8d0c1c8b7939818b75118b472fac1af554f9a;p=sbcl.git diff --git a/src/compiler/ir1report.lisp b/src/compiler/ir1report.lisp index 93190eb..f598a04 100644 --- a/src/compiler/ir1report.lisp +++ b/src/compiler/ir1report.lisp @@ -97,25 +97,29 @@ ;;; 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 list of subforms suitable for a \"~{~S ~}\" format string." (let ((n-whole (gensym))) `(setf (gethash ',name *source-context-methods*) - #'(lambda (,n-whole) - (destructuring-bind ,lambda-list ,n-whole ,@body))))) + (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))) @@ -125,11 +129,14 @@ (defun source-form-context (form) (cond ((atom form) nil) ((>= (length form) 2) - (funcall (gethash (first form) *source-context-methods* - #'(lambda (x) - (declare (ignore x)) - (list (first form) (second form)))) - (rest form))) + (let* ((context-fun-default (lambda (x) + (declare (ignore x)) + (list (first form) (second form)))) + (context-fun (gethash (first form) + *source-context-methods* + context-fun-default))) + (declare (type function context-fun)) + (funcall context-fun (rest form)))) (t form))) @@ -178,13 +185,40 @@ ;;; 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 a repeated idiom in creating debug names +;;; +;;; the problem, part I: We want to create debug names that look like +;;; "&MORE processor for " where might be +;;; either a source-name value (typically a symbol) or a non-symbol +;;; debug-name value (typically a string). It's awkward to handle this +;;; with FORMAT because we'd like to splice a source-name value using +;;; "~S" (to get package qualifiers) but a debug-name value using "~A" +;;; (to avoid irrelevant quotes at string splice boundaries). +;;; +;;; the problem, part II: The is represented as a pair +;;; of values, SOURCE-NAME and DEBUG-NAME, where SOURCE-NAME is used +;;; if it's not .ANONYMOUS. (This is parallel to the way that ordinarily +;;; we don't use a value if it's NIL, instead defaulting it. But we +;;; can't safely/comfortably use NIL for that in this context, since +;;; the app programmer can use NIL as a name, so we use the private +;;; symbol .ANONYMOUS. instead.) +;;; +;;; the solution: Use this function to convert whatever it is to a +;;; string, which FORMAT can then splice using "~A". +(defun as-debug-name (source-name debug-name) + (if (eql source-name '.anonymous.) + debug-name + (debug-namify "~S" source-name))) ;;; Return a COMPILER-ERROR-CONTEXT structure describing the current ;;; error context, or NIL if we can't figure anything out. ARGS is a @@ -259,7 +293,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)) @@ -366,7 +400,7 @@ (what (etypecase condition (style-warning 'style-warning) (warning 'warning) - (error 'error)))) + ((or error compiler-error) 'error)))) (multiple-value-bind (format-string format-args) (if (typep condition 'simple-condition) (values (simple-condition-format-control condition) @@ -381,37 +415,56 @@ format-args))) (values)) -;;; COMPILER-NOTE is vaguely like COMPILER-ERROR and the other -;;; condition-signalling functions, but it just writes some output -;;; instead of signalling. (In CMU CL, it did signal a condition, but -;;; this didn't seem to work all that well; it was weird to have -;;; COMPILE-FILE return with WARNINGS-P set when the only problem was -;;; that the compiler couldn't figure out how to compile something as -;;; efficiently as it liked.) -(defun compiler-note (format-string &rest format-args) +;;; The act of signalling one of these beasts must not cause WARNINGSP +;;; (or FAILUREP) to be set from COMPILE or COMPILE-FILE, so we can't +;;; inherit from WARNING or STYLE-WARNING. +;;; +;;; FIXME: the handling of compiler-notes could be unified with +;;; warnings and style-warnings (see the various handler functions +;;; below). +(define-condition compiler-note (condition) ()) +(define-condition simple-compiler-note (simple-condition compiler-note) ()) + +(defun compiler-notify (format-string &rest format-args) + ;; FORMAT-STRING and FORMAT-ARGS might well end up turning into + ;; DATUM and REST, and COERCE-TO-CONDITION will be used. (unless (if *compiler-error-context* (policy *compiler-error-context* (= inhibit-warnings 3)) (policy *lexenv* (= inhibit-warnings 3))) + (restart-case + (signal (make-condition 'simple-compiler-note + :format-control format-string + :format-arguments format-args)) + (muffle-warning () + (return-from compiler-notify (values)))) (incf *compiler-note-count*) (print-compiler-message (format nil "note: ~A" format-string) format-args)) (values)) ;;; Issue a note when we might or might not be in the compiler. -(defun maybe-compiler-note (&rest rest) +(defun maybe-compiler-notify (&rest rest) (if (boundp '*lexenv*) ; if we're in the compiler - (apply #'compiler-note rest) - (let ((stream *error-output*)) - (pprint-logical-block (stream nil :per-line-prefix ";") - - (format stream " note: ~3I~_") - (pprint-logical-block (stream nil) - (apply #'format stream rest))) - (fresh-line stream)))) ; (outside logical block, no per-line-prefix) + (apply #'compiler-notify rest) + (progn + (restart-case + (signal (make-condition 'simple-compiler-note + :format-control (car rest) + :format-arguments (cdr rest))) + (muffle-warning () + (return-from maybe-compiler-notify (values)))) + (let ((stream *error-output*)) + (pprint-logical-block (stream nil :per-line-prefix ";") + (format stream " note: ~3I~_") + (pprint-logical-block (stream nil) + (apply #'format stream rest))) + ;; (outside logical block, no per-line-prefix) + (fresh-line stream)) + (values)))) ;;; 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)