0.8.21.42:

[sbcl.git] / src / code / sharpm.lisp

diff --git a/src/code/sharpm.lisp b/src/code/sharpm.lisp
index 6bae634..f091b65 100644 (file)
--- a/src/code/sharpm.lisp
+++ b/src/code/sharpm.lisp
@@ -159,9 +159,12 @@
                               designator: ~S."
                             slot-name))
                          (when (not (keywordp slot-name))
-                           (style-warn "in #S ~S, the use of non-keywords ~
-                                         as slot specifiers is deprecated: ~S."
-                                       (car body) slot-name)))
+                            (warn 'structure-initarg-not-keyword
+                                  :format-control
+                                  "in #S ~S, the use of non-keywords ~
+                                   as slot specifiers is deprecated: ~S."
+                                  :format-arguments
+                                  (list (car body) slot-name))))
                     collect (intern (string (car tail)) *keyword-package*)
                     collect (cadr tail)))))))
 \f
@@ -217,7 +220,8 @@
 ;; substitutes in arrays and structures as well as lists. The first arg is an
 ;; alist of the things to be replaced assoc'd with the things to replace them.
 (defun circle-subst (old-new-alist tree)
-  (cond ((not (typep tree '(or cons (array t) structure-object standard-object)))
+  (cond ((not (typep tree
+                    '(or cons (array t) structure-object standard-object)))
         (let ((entry (find tree old-new-alist :key #'second)))
           (if entry (third entry) tree)))
        ((null (gethash tree *sharp-equal-circle-table*))
@@ -346,35 +350,41 @@
 
 (defun sharp-vertical-bar (stream sub-char numarg)
   (ignore-numarg sub-char numarg)
-  (let ((stream (in-synonym-of stream)))
-    (if (ansi-stream-p stream)
-       (prepare-for-fast-read-char stream
+  (handler-bind
+      ((character-decoding-error
+       #'(lambda (decoding-error)
+           (declare (ignorable decoding-error))
+           (style-warn "Character decoding error in a #|-comment at position ~A reading source file ~A, resyncing." (file-position stream) stream)
+           (invoke-restart 'attempt-resync))))
+    (let ((stream (in-synonym-of stream)))
+      (if (ansi-stream-p stream)
+         (prepare-for-fast-read-char stream
+           (do ((level 1)
+                (prev (fast-read-char) char)
+                (char (fast-read-char) (fast-read-char)))
+               (())
+             (cond ((and (char= prev #\|) (char= char #\#))
+                    (setq level (1- level))
+                    (when (zerop level)
+                      (done-with-fast-read-char)
+                      (return (values)))
+                    (setq char (fast-read-char)))
+                   ((and (char= prev #\#) (char= char #\|))
+                    (setq char (fast-read-char))
+                    (setq level (1+ level))))))
+         ;; fundamental-stream
          (do ((level 1)
-              (prev (fast-read-char) char)
-              (char (fast-read-char) (fast-read-char)))
+              (prev (read-char stream t) char)
+              (char (read-char stream t) (read-char stream t)))
              (())
            (cond ((and (char= prev #\|) (char= char #\#))
                   (setq level (1- level))
                   (when (zerop level)
-                    (done-with-fast-read-char)
                     (return (values)))
-                  (setq char (fast-read-char)))
+                  (setq char (read-char stream t)))
                  ((and (char= prev #\#) (char= char #\|))
-                  (setq char (fast-read-char))
-                  (setq level (1+ level))))))
-       ;; fundamental-stream
-       (do ((level 1)
-            (prev (read-char stream t) char)
-            (char (read-char stream t) (read-char stream t)))
-           (())
-         (cond ((and (char= prev #\|) (char= char #\#))
-                (setq level (1- level))
-                (when (zerop level)
-                  (return (values)))
-                (setq char (read-char stream t)))
-               ((and (char= prev #\#) (char= char #\|))
-                (setq char (read-char stream t))
-                (setq level (1+ level))))))))
+                  (setq char (read-char stream t))
+                  (setq level (1+ level)))))))))
 \f
 ;;;; a grab bag of other sharp readmacros: #', #:, and #.