Merge branch 'master' into mswinmt

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

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 <hair> 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)))

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
 

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)))))

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)))))))