X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fir1report.lisp;h=6a6bb12f64f340cdd8754d4a0045fd1dc54f535d;hb=debae3c18d31b5222be4d5de8dcb2601336e24a4;hp=e2ec7137182f65ebe896ce4c58bb859063f46268;hpb=af1d1e123a77bc7088d9be17139b1a54df5f75e4;p=sbcl.git diff --git a/src/compiler/ir1report.lisp b/src/compiler/ir1report.lisp index e2ec713..6a6bb12 100644 --- a/src/compiler/ir1report.lisp +++ b/src/compiler/ir1report.lisp @@ -101,21 +101,34 @@ `(lambda ,(second thing)) `(function ,thing))) +(define-source-context named-lambda (name lambda-list &body forms) + (declare (ignore lambda-list forms)) + (if (and (consp name) (eq 'eval (first name))) + (second name) + `(named-lambda ,name))) + +(defvar *source-form-context-alist* nil) + ;;; Return the first two elements of FORM if FORM is a list. Take the ;;; CAR of the second form if appropriate. (defun source-form-context (form) - (cond ((atom form) nil) - ((>= (length form) 2) - (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))) + (flet ((get-it (form) + (cond ((atom form) nil) + ((>= (length form) 2) + (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)))) + (get-it (or (cdr (assoc form *source-form-context-alist* :test #'eq)) + form)))) ;;; Given a source path, return the original source form and a ;;; description of the interesting aspects of the context in which it @@ -174,49 +187,59 @@ ;;; list of things that are going to be printed out in the error ;;; message, and can thus be blown off when they appear in the source ;;; context. -(defun find-error-context (args) +;;; +;;; If OLD-CONTEXTS is passed in, and includes a context with the +;;; same original source path as the new context would have, the old +;;; context is reused instead, and a secondary value of T is returned. +(defun find-error-context (args &optional old-contexts) (let ((context *compiler-error-context*)) (if (compiler-error-context-p context) - context - (let ((path (or (and (boundp '*current-path*) *current-path*) - (if context - (node-source-path context) - nil)))) - (when (and *source-info* path) - (multiple-value-bind (form src-context) (find-original-source path) - (collect ((full nil cons) - (short nil cons)) - (let ((forms (source-path-forms path)) - (n 0)) - (dolist (src (if (member (first forms) args) - (rest forms) - forms)) - (if (>= n *enclosing-source-cutoff*) - (short (stringify-form (if (consp src) - (car src) - src) - nil)) - (full (stringify-form src))) - (incf n))) - - (let* ((tlf (source-path-tlf-number path)) - (file-info (source-info-file-info *source-info*))) - (make-compiler-error-context - :enclosing-source (short) - :source (full) - :original-source (stringify-form form) - :context src-context - :file-name (file-info-name file-info) - :file-position - (multiple-value-bind (ignore pos) - (find-source-root tlf *source-info*) - (declare (ignore ignore)) - pos) - :original-source-path - (source-path-original-source path) - :lexenv (if context - (node-lexenv context) - (if (boundp '*lexenv*) *lexenv* nil))))))))))) + (values context t) + (let* ((path (or (and (node-p context) (node-source-path context)) + (and (boundp '*current-path*) *current-path*))) + (old + (find (when path (source-path-original-source path)) + (remove-if #'null old-contexts) + :test #'equal + :key #'compiler-error-context-original-source-path))) + (if old + (values old t) + (when (and *source-info* path) + (multiple-value-bind (form src-context) (find-original-source path) + (collect ((full nil cons) + (short nil cons)) + (let ((forms (source-path-forms path)) + (n 0)) + (dolist (src (if (member (first forms) args) + (rest forms) + forms)) + (if (>= n *enclosing-source-cutoff*) + (short (stringify-form (if (consp src) + (car src) + src) + nil)) + (full (stringify-form src))) + (incf n))) + + (let* ((tlf (source-path-tlf-number path)) + (file-info (source-info-file-info *source-info*))) + (values + (make-compiler-error-context + :enclosing-source (short) + :source (full) + :original-source (stringify-form form) + :context src-context + :file-name (file-info-name file-info) + :file-position + (multiple-value-bind (ignore pos) + (find-source-root tlf *source-info*) + (declare (ignore ignore)) + pos) + :original-source-path (source-path-original-source path) + :lexenv (if context + (node-lexenv context) + (if (boundp '*lexenv*) *lexenv* nil))) + nil)))))))))) ;;;; printing error messages @@ -258,9 +281,9 @@ ;;; ;;; We suppress printing of messages identical to the previous, but ;;; record the number of times that the message is repeated. -(defmacro print-compiler-message (stream format-string format-args) - `(with-compiler-io-syntax - (%print-compiler-message ,stream ,format-string ,format-args))) +(defun print-compiler-message (stream format-string format-args) + (with-compiler-io-syntax + (%print-compiler-message stream format-string format-args))) (defun %print-compiler-message (stream format-string format-args) (declare (type simple-string format-string)) @@ -286,7 +309,7 @@ (note-message-repeats stream) (setq last nil) (pprint-logical-block (stream nil :per-line-prefix "; ") - (format stream "in:~{~<~% ~4:;~{ ~S~}~>~^ =>~}" in)) + (format stream "in:~{~<~% ~4:;~{ ~:S~}~>~^ =>~}" in)) (terpri stream)) (unless (and last @@ -527,9 +550,11 @@ has written, having proved that it is unreachable.")) (res (or found (make-undefined-warning :name name :kind kind)))) (unless found (push res *undefined-warnings*)) - (when (or (not *undefined-warning-limit*) - (< (undefined-warning-count res) *undefined-warning-limit*)) - (push (find-error-context (list name)) - (undefined-warning-warnings res))) - (incf (undefined-warning-count res)))) + (multiple-value-bind (context old) + (find-error-context (list name) (undefined-warning-warnings res)) + (unless old + (when (or (not *undefined-warning-limit*) + (< (undefined-warning-count res) *undefined-warning-limit*)) + (push context (undefined-warning-warnings res))) + (incf (undefined-warning-count res)))))) (values))