diff --git a/NEWS b/NEWS index 8eca65d7b..c28c71699 100644 --- a/NEWS +++ b/NEWS @@ -10,6 +10,8 @@ changes relative to sbcl-1.0.50: AREF, CHAR, etc. (lp#826971) * bug fix: compiler-errors causes by integer arguments with composed of multiple ranges to ARRAY-IN-BOUNDS-P. (lp#826970) + * bug fix: ,@ and ,. now signal a read-time error for certain non-list + expressions. (lp#770184) changes in sbcl-1.0.51 relative to sbcl-1.0.50: * minor incompatible change: SB-BSD-SOCKET socket streams no longer diff --git a/src/code/backq.lisp b/src/code/backq.lisp index 45a3ebda7..6b615f395 100644 --- a/src/code/backq.lisp +++ b/src/code/backq.lisp @@ -72,12 +72,21 @@ (simple-reader-error stream *bq-error*)) (let ((c (read-char stream)) (*backquote-count* (1- *backquote-count*))) - (cond ((char= c #\@) - (cons *bq-at-flag* (read stream t nil t))) - ((char= c #\.) - (cons *bq-dot-flag* (read stream t nil t))) - (t (unread-char c stream) - (cons *bq-comma-flag* (read stream t nil t)))))) + (flet ((check (what) + (let ((x (peek-char t stream t nil t))) + (when (and (char= x #\)) (eq #'read-right-paren (get-macro-character #\)))) + ;; Easier to figure out than an "unmatched parenthesis". + (simple-reader-error stream "Trailing ~A in backquoted expression." what))))) + (cond ((char= c #\@) + (check "comma-at") + (cons *bq-at-flag* (read stream t nil t))) + ((char= c #\.) + (check "comma-dot") + (cons *bq-dot-flag* (read stream t nil t))) + (t + (unread-char c stream) + (check "comma") + (cons *bq-comma-flag* (read stream t nil t))))))) (/show0 "backq.lisp 83") @@ -88,6 +97,21 @@ (or (eq flag *bq-at-flag*) (eq flag *bq-dot-flag*))))) +(defun backquote-splice (method dflag a d what stream) + (cond (dflag + (values method + (cond ((eq dflag method) + (cons a d)) + (t (list a (backquotify-1 dflag d)))))) + ((expandable-backq-expression-p a) + (values method (list a))) + ((not (and (atom a) (backq-constant-p a))) + ;; COMMA special cases a few constant atoms, which + ;; are illegal in splices. + (comma a)) + (t + (simple-reader-error stream "Invalid splice in backquote: ~A~A" what a)))) + ;;; This does the expansion from table 2. (defun backquotify (stream code) (cond ((atom code) @@ -114,23 +138,9 @@ (simple-reader-error stream ",. after dot in ~S" code)) (cond ((eq aflag *bq-at-flag*) - (if (null dflag) - (if (expandable-backq-expression-p a) - (values 'append (list a)) - (comma a)) - (values 'append - (cond ((eq dflag 'append) - (cons a d )) - (t (list a (backquotify-1 dflag d))))))) + (backquote-splice 'append dflag a d ",@" stream)) ((eq aflag *bq-dot-flag*) - (if (null dflag) - (if (expandable-backq-expression-p a) - (values 'nconc (list a)) - (comma a)) - (values 'nconc - (cond ((eq dflag 'nconc) - (cons a d)) - (t (list a (backquotify-1 dflag d))))))) + (backquote-splice 'nconc dflag a d ",." stream)) ((null dflag) (if (member aflag '(quote t nil)) (values 'quote (list a)) @@ -148,14 +158,18 @@ (/show0 "backq.lisp 139") +(defun backq-constant-p (x) + (or (numberp x) (eq x t))) + ;;; This handles the cases. (defun comma (code) (cond ((atom code) (cond ((null code) (values nil nil)) - ((or (numberp code) (eq code t)) + ((backq-constant-p code) (values t code)) - (t (values *bq-comma-flag* code)))) + (t + (values *bq-comma-flag* code)))) ((and (eq (car code) 'quote) (not (expandable-backq-expression-p (cadr code)))) (values (car code) (cadr code))) diff --git a/src/code/condition.lisp b/src/code/condition.lisp index 4b01908de..4254d8f61 100644 --- a/src/code/condition.lisp +++ b/src/code/condition.lisp @@ -766,6 +766,9 @@ (defun %report-reader-error (condition stream &key simple) (let* ((error-stream (stream-error-stream condition)) (pos (file-position-or-nil-for-error error-stream))) + (when (and pos (plusp pos)) + ;; FILE-POSITION is the next character -- error is at the previous one. + (decf pos)) (let (lineno colno) (when (and pos (< pos sb!xc:array-dimension-limit) @@ -786,22 +789,22 @@ :element-type (stream-element-type error-stream)))) (when (= pos (read-sequence string error-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) -1) - 1)))) + colno (- pos (or (position #\Newline string :from-end t) 0))))) (file-position-or-nil-for-error error-stream pos)) (pprint-logical-block (stream nil) - (format stream - "~S ~@[at ~W ~]~ - ~@[(line ~W~]~@[, column ~W) ~]~ - on ~S" - (class-name (class-of condition)) - pos lineno colno error-stream) - (when simple - (format stream ":~2I~_~?" - (simple-condition-format-control condition) - (simple-condition-format-arguments condition))))))) + (if simple + (apply #'format stream + (simple-condition-format-control condition) + (simple-condition-format-arguments condition)) + (prin1 (class-name (class-of condition)) stream)) + (format stream "~2I~@[~_~_~:{~:(~A~): ~S~:^, ~:_~}~]~_~_Stream: ~S" + (remove-if-not #'second + (list (list :line lineno) + (list :column colno) + (list :file-position pos))) + error-stream))))) ;;;; special SBCL extension conditions diff --git a/tests/backq.impure.lisp b/tests/backq.impure.lisp index 6a647039a..7632c78d4 100644 --- a/tests/backq.impure.lisp +++ b/tests/backq.impure.lisp @@ -64,3 +64,10 @@ (let ((s '``(,,@(list 1 2 3) 10))) (assert (equal (eval (eval s)) '(1 2 3 10)))) + +(with-test (:name :comma-at-number-error) + (assert (eq :error + (handler-case + (read-from-string "`(,@1)") + (reader-error () + :error))))) diff --git a/tests/signals.impure.lisp b/tests/signals.impure.lisp index 093bf23cb..1cb5fd3e8 100644 --- a/tests/signals.impure.lisp +++ b/tests/signals.impure.lisp @@ -81,3 +81,19 @@ (sb-ext:with-timeout 0.1 (sleep 1) t)))) (sb-ext:timeout () nil)))) + +(with-test (:name :sleep-many-interrupts) + (let ((n 0) + (timer nil)) + (flet ((trip () + (when (< (incf n) 5) + (sleep 0.1) + (schedule-timer timer 0.1)))) + (setf timer (make-timer #'trip)) + (schedule-timer timer 0.1) + (let ((start (get-internal-real-time))) + (sleep 1.5) + (let ((ticks (/ (float (- (get-internal-real-time) start)) + internal-time-units-per-second))) + (assert (< 1.4 ticks 1.6)) + (assert (= n 5)))))))