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)))
+ (with-unique-names (whole)
`(setf (gethash ',name *source-context-methods*)
- (lambda (,n-whole)
- (destructuring-bind ,lambda-list ,n-whole ,@body)))))
+ (lambda (,whole)
+ (destructuring-bind ,lambda-list ,whole ,@body)))))
(define-source-context defstruct (name-or-options &rest slots)
(declare (ignore slots))
`(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
;;; 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))))))))))
\f
;;;; printing error messages
;;;
;;; 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))
(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
(let ((ep (first (block-succ (component-head component)))))
(aver ep) ; else no entry points??
(multiple-value-bind (form context)
- (find-original-source
- (node-source-path (block-start-node ep)))
+ (find-original-source (node-source-path (block-start-node ep)))
(declare (ignore form))
(let ((*print-level* 2)
(*print-pretty* nil))
- (format nil "~{~{~S~^ ~}~^ => ~}" context)))))
+ (format nil "~{~{~S~^ ~}~^ => ~}"
+ #+sb-xc-host (list (list (caar context)))
+ #-sb-xc-host context)))))
\f
;;;; condition system interface
(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))
projects / sbcl.git / blobdiff