From 3b2dd3d280fd560a29ab9cf93ce2bf492aba2435 Mon Sep 17 00:00:00 2001 From: Jan Moringen Date: Mon, 30 Dec 2013 01:33:50 +0100 Subject: [PATCH] STREAM-ERROR-POSITION-INFO signals errors in fewer situations Previously, STREAM-ERROR-POSITION-INFO could signal errors for non-character streams and closed streams. Fixes lp1264902. --- NEWS | 1 + src/code/early-extensions.lisp | 62 ++++++++++++++++++++++++---------------- tests/condition.pure.lisp | 24 +++++++++++++++- 3 files changed, 62 insertions(+), 25 deletions(-) diff --git a/NEWS b/NEWS index bfa3018..fad437f 100644 --- a/NEWS +++ b/NEWS @@ -22,6 +22,7 @@ changes relative to sbcl-1.1.14: with bad constants. (reported by Douglas Katzman) * bug fix: CLISP can be used again as a cross-compilation host. (Thanks to Vasily Postnicov) + * bug fix: STREAM-ERROR-POSITION-INFO fails in fewer situations (lp#1264902) changes in sbcl-1.1.14 relative to sbcl-1.1.13: * optimization: complicated TYPEP tests are less opaque to the type diff --git a/src/code/early-extensions.lisp b/src/code/early-extensions.lisp index b73ac29..8e87971 100644 --- a/src/code/early-extensions.lisp +++ b/src/code/early-extensions.lisp @@ -1410,32 +1410,46 @@ to :INTERPRET, an interpreter will be used.") ;; defsystemish operation where the ERROR-STREAM had been CL:CLOSEd, ;; I think by nonlocally exiting through a WITH-OPEN-FILE, by the ;; time an error was reported.) - (if posp - (ignore-errors (file-position stream pos)) - (ignore-errors (file-position stream)))) + (ignore-errors + (if posp + (file-position stream pos) + (file-position stream)))) (defun stream-error-position-info (stream &optional position) - (unless (interactive-stream-p stream) - (let ((now (file-position-or-nil-for-error stream)) - (pos position)) - (when (and (not pos) now (plusp now)) - ;; FILE-POSITION is the next character -- error is at the previous one. - (setf pos (1- now))) - (let (lineno colno) - (when (and pos - (< pos sb!xc:array-dimension-limit) - (file-position stream :start)) - (let ((string - (make-string pos :element-type (stream-element-type stream)))) - (when (= pos (read-sequence string stream)) - ;; Lines count from 1, columns from 0. It's stupid and traditional. - (setq lineno (1+ (count #\Newline string)) - colno (- pos (or (position #\Newline string :from-end t) 0))))) - (file-position-or-nil-for-error stream now)) - (remove-if-not #'second - (list (list :line lineno) - (list :column colno) - (list :file-position pos))))))) + ;; Give up early for interactive streams and non-character stream. + (when (or (ignore-errors (interactive-stream-p stream)) + (not (subtypep (ignore-errors (stream-element-type stream)) + 'character))) + (return-from stream-error-position-info)) + + (flet ((read-content (old-position position) + "Read the content of STREAM into a buffer in order to count +lines and columns." + (unless (and old-position position + (< position sb!xc:array-dimension-limit)) + (return-from read-content)) + (let ((content + (make-string position :element-type (stream-element-type stream)))) + (when (and (file-position-or-nil-for-error stream :start) + (eql position (ignore-errors (read-sequence content stream)))) + (file-position-or-nil-for-error stream old-position) + content))) + ;; Lines count from 1, columns from 0. It's stupid and + ;; traditional. + (line (string) + (1+ (count #\Newline string))) + (column (string position) + (- position (or (position #\Newline string :from-end t) 0)))) + (let* ((stream-position (file-position-or-nil-for-error stream)) + (position (or position + ;; FILE-POSITION is the next character -- + ;; error is at the previous one. + (and stream-position (plusp stream-position) + (1- stream-position)))) + (content (read-content stream-position position))) + `(,@(when content `((:line ,(line content)) + (:column ,(column content position)))) + ,@(when position `((:file-position ,position))))))) (declaim (inline schwartzian-stable-sort-list)) (defun schwartzian-stable-sort-list (list comparator &key key) diff --git a/tests/condition.pure.lisp b/tests/condition.pure.lisp index 0430800..0ac0283 100644 --- a/tests/condition.pure.lisp +++ b/tests/condition.pure.lisp @@ -236,4 +236,26 @@ (with-test (:name (:print-undefined-function-condition)) (handler-case (funcall '#:foo) - (undefined-function (c) (princ c)))) + (undefined-function (c) (princ-to-string c)))) + +;; Printing a READER-ERROR while the underlying stream is still open +;; should print the stream position information. +(with-test (:name (reader-error :stream-error-position-info :open-stream :bug-1264902)) + (assert + (search + "Line: 1, Column: 22, File-Position: 22" + (with-input-from-string (stream "no-such-package::symbol") + (handler-case + (read stream) + (reader-error (condition) (princ-to-string condition))))))) + +;; Printing a READER-ERROR when the underlying stream has been closed +;; should still work, but the stream information will not be printed. +(with-test (:name (reader-error :stream-error-position-info :closed-stream :bug-1264902)) + (assert + (search + "Package NO-SUCH-PACKAGE does not exist" + (handler-case + (with-input-from-string (stream "no-such-package::symbol") + (read stream)) + (reader-error (condition) (princ-to-string condition)))))) -- 1.7.9.5