X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fsharpm.lisp;h=f091b65cbec0223627593731978c71052b0962e8;hb=ffa9a31f62e3e2abab8ebcbb3bfdab9725feaf7f;hp=6bae6346e13ae3f44be154baa5b640f9c66440cb;hpb=848db680b495956ae3968649af260e7448fa8ddc;p=sbcl.git

diff --git a/src/code/sharpm.lisp b/src/code/sharpm.lisp
index 6bae634..f091b65 100644
--- 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)))))))
 
@@ -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)))))))))
 
 ;;;; a grab bag of other sharp readmacros: #', #:, and #.