- (lambda (,n-whole)
- (destructuring-bind ,lambda-list ,n-whole ,@body)))))
-
-(defmacro def-source-context (&rest rest)
- (deprecation-warning 'def-source-context 'define-source-context)
- `(define-source-context ,@rest))
+ (lambda (,n-whole)
+ (destructuring-bind ,lambda-list ,n-whole ,@body)))))
- (current (rest rpath)))
- (loop
- (when (atom form)
- (aver (null current))
- (return))
- (let ((head (first form)))
- (when (symbolp head)
- (let ((name (symbol-name head)))
- (when (and (>= (length name) 3) (string= name "DEF" :end1 3))
- (context (source-form-context form))))))
- (when (null current) (return))
- (setq form (nth (pop current) form)))
-
- (cond ((context)
- (values form (context)))
- ((and path root)
- (let ((c (source-form-context root)))
- (values form (if c (list c) nil))))
- (t
- (values '(unable to locate source)
- '((some strange place)))))))))
+ (current (rest rpath)))
+ (loop
+ (when (atom form)
+ (aver (null current))
+ (return))
+ (let ((head (first form)))
+ (when (symbolp head)
+ (let ((name (symbol-name head)))
+ (when (and (>= (length name) 3) (string= name "DEF" :end1 3))
+ (context (source-form-context form))))))
+ (when (null current) (return))
+ (setq form (nth (pop current) form)))
+
+ (cond ((context)
+ (values form (context)))
+ ((and path root)
+ (let ((c (source-form-context root)))
+ (values form (if c (list c) nil))))
+ (t
+ (values '(unable to locate source)
+ '((some strange place)))))))))
- 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)))))))))))
+ 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)))))))))))
- (let ((file (compiler-error-context-file-name context))
- (in (compiler-error-context-context context))
- (form (compiler-error-context-original-source context))
- (enclosing (compiler-error-context-enclosing-source context))
- (source (compiler-error-context-source context))
- (last *last-error-context*))
-
- (unless (and last
- (equal file (compiler-error-context-file-name last)))
- (when (pathnamep file)
- (note-message-repeats stream)
- (setq last nil)
- (format stream "~2&; file: ~A~%" (namestring file))))
-
- (unless (and last
- (equal in (compiler-error-context-context last)))
- (note-message-repeats stream)
- (setq last nil)
- (pprint-logical-block (stream nil :per-line-prefix "; ")
- (format stream "in:~{~<~% ~4:;~{ ~S~}~>~^ =>~}" in))
- (terpri stream))
-
- (unless (and last
- (string= form
- (compiler-error-context-original-source last)))
- (note-message-repeats stream)
- (setq last nil)
- (pprint-logical-block (stream nil :per-line-prefix "; ")
- (format stream " ~A" form))
- (fresh-line stream))
-
- (unless (and last
- (equal enclosing
- (compiler-error-context-enclosing-source last)))
- (when enclosing
- (note-message-repeats stream)
- (setq last nil)
- (format stream "~&; --> ~{~<~%; --> ~1:;~A~> ~}~%" enclosing)))
-
- (unless (and last
- (equal source (compiler-error-context-source last)))
- (setq *last-format-string* nil)
- (when source
- (note-message-repeats stream)
- (dolist (src source)
- (fresh-line stream)
- (write-string "; ==>" stream)
- (terpri stream)
- (pprint-logical-block (stream nil :per-line-prefix "; ")
- (write-string src stream)))))))
- (t
- (fresh-line stream)
- (note-message-repeats stream)
- (setq *last-format-string* nil)))
-
+ (let ((file (compiler-error-context-file-name context))
+ (in (compiler-error-context-context context))
+ (form (compiler-error-context-original-source context))
+ (enclosing (compiler-error-context-enclosing-source context))
+ (source (compiler-error-context-source context))
+ (last *last-error-context*))
+
+ (unless (and last
+ (equal file (compiler-error-context-file-name last)))
+ (when (pathnamep file)
+ (note-message-repeats stream)
+ (setq last nil)
+ (format stream "~2&; file: ~A~%" (namestring file))))
+
+ (unless (and last
+ (equal in (compiler-error-context-context last)))
+ (note-message-repeats stream)
+ (setq last nil)
+ (pprint-logical-block (stream nil :per-line-prefix "; ")
+ (format stream "in:~{~<~% ~4:;~{ ~S~}~>~^ =>~}" in))
+ (terpri stream))
+
+ (unless (and last
+ (string= form
+ (compiler-error-context-original-source last)))
+ (note-message-repeats stream)
+ (setq last nil)
+ (pprint-logical-block (stream nil :per-line-prefix "; ")
+ (format stream " ~A" form))
+ (fresh-line stream))
+
+ (unless (and last
+ (equal enclosing
+ (compiler-error-context-enclosing-source last)))
+ (when enclosing
+ (note-message-repeats stream)
+ (setq last nil)
+ (format stream "~&; --> ~{~<~%; --> ~1:;~A~> ~}~%" enclosing)))
+
+ (unless (and last
+ (equal source (compiler-error-context-source last)))
+ (setq *last-format-string* nil)
+ (when source
+ (note-message-repeats stream)
+ (dolist (src source)
+ (fresh-line stream)
+ (write-string "; ==>" stream)
+ (terpri stream)
+ (pprint-logical-block (stream nil :per-line-prefix "; ")
+ (write-string src stream)))))))
+ (t
+ (fresh-line stream)
+ (note-message-repeats stream)
+ (setq *last-format-string* nil)))
+
(setq *last-error-context* context))
;; FIXME: this testing for effective equality of compiler messages
;; is ugly, and really ought to be done at a higher level.
(unless (and (equal format-string *last-format-string*)
(setq *last-error-context* context))
;; FIXME: this testing for effective equality of compiler messages
;; is ugly, and really ought to be done at a higher level.
(unless (and (equal format-string *last-format-string*)
- ;; effects on the return codes of COMPILE-FILE, so it's nice
- ;; for users to be able to pick them out by lexical search
- ;; through the output.
- (what (etypecase condition
- (style-warning 'style-warning)
- (warning 'warning)
- ((or error compiler-error) 'error))))
+ ;; effects on the return codes of COMPILE-FILE, so it's nice
+ ;; for users to be able to pick them out by lexical search
+ ;; through the output.
+ (what (etypecase condition
+ (style-warning 'style-warning)
+ (warning 'warning)
+ ((or error compiler-error) 'error))))
- (with-unique-names (block)
- `(block ,block
- (let ((,condition
- (coerce-to-condition ,datum ,args
- 'simple-compiler-note
- 'with-condition)))
- (restart-case
- (signal ,condition)
- (muffle-warning ()
- (return-from ,block (values))))
- ,@body
- (values))))))
+ (with-unique-names (block)
+ `(block ,block
+ (let ((,condition
+ (coerce-to-condition ,datum ,args
+ 'simple-compiler-note
+ 'with-condition)))
+ (restart-case
+ (signal ,condition)
+ (muffle-warning ()
+ (return-from ,block (values))))
+ ,@body
+ (values))))))
- (apply #'compiler-notify rest)
- (with-condition (condition (car rest) (cdr rest))
- (let ((stream *error-output*))
- (pprint-logical-block (stream nil :per-line-prefix ";")
- (format stream " note: ~3I~_")
- (pprint-logical-block (stream nil)
- (format stream "~A" condition)))
- ;; (outside logical block, no per-line-prefix)
- (fresh-line stream))))))
+ (apply #'compiler-notify rest)
+ (with-condition (condition (car rest) (cdr rest))
+ (let ((stream *error-output*))
+ (pprint-logical-block (stream nil :per-line-prefix ";")
+ (format stream " note: ~3I~_")
+ (pprint-logical-block (stream nil)
+ (format stream "~A" condition)))
+ ;; (outside logical block, no per-line-prefix)
+ (fresh-line stream))))))
- ;; Check for boundness so we don't blow up if we're called
- ;; when IR1 conversion isn't going on.
- (boundp '*lexenv*)
- (or
- ;; FIXME: I'm pretty sure the INHIBIT-WARNINGS test below
- ;; isn't a good idea; we should have INHIBIT-WARNINGS
- ;; affect compiler notes, not STYLE-WARNINGs. And I'm not
- ;; sure what the BOUNDP '*LEXENV* test above is for; it's
- ;; likely a good idea, but it probably deserves an
- ;; explanatory comment.
- (policy *lexenv* (= inhibit-warnings 3))
- ;; KLUDGE: weird decoupling between here and where we're
- ;; going to signal the condition. I don't think we can
- ;; rewrite this using SIGNAL and RESTART-CASE (to take
- ;; advantage of the (SATISFIES HANDLE-CONDITION-P)
- ;; handler, because if that doesn't handle it the ordinary
- ;; compiler handlers will trigger.
- (typep
- (ecase kind
- (:variable (make-condition 'warning))
- ((:function :type) (make-condition 'style-warning)))
- (car
- (rassoc 'muffle-warning
- (lexenv-handled-conditions *lexenv*))))))
+ ;; Check for boundness so we don't blow up if we're called
+ ;; when IR1 conversion isn't going on.
+ (boundp '*lexenv*)
+ (or
+ ;; FIXME: I'm pretty sure the INHIBIT-WARNINGS test below
+ ;; isn't a good idea; we should have INHIBIT-WARNINGS
+ ;; affect compiler notes, not STYLE-WARNINGs. And I'm not
+ ;; sure what the BOUNDP '*LEXENV* test above is for; it's
+ ;; likely a good idea, but it probably deserves an
+ ;; explanatory comment.
+ (policy *lexenv* (= inhibit-warnings 3))
+ ;; KLUDGE: weird decoupling between here and where we're
+ ;; going to signal the condition. I don't think we can
+ ;; rewrite this using SIGNAL and RESTART-CASE (to take
+ ;; advantage of the (SATISFIES HANDLE-CONDITION-P)
+ ;; handler, because if that doesn't handle it the ordinary
+ ;; compiler handlers will trigger.
+ (typep
+ (ecase kind
+ (:variable (make-condition 'warning))
+ ((:function :type) (make-condition 'style-warning)))
+ (car
+ (rassoc 'muffle-warning
+ (lexenv-handled-conditions *lexenv*))))))