X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fsharpm.lisp;h=3f898b0b41a7248c25925152f91a0b4fa5b92e15;hb=15d6e7c9a2c3234f95dfe278046fa2fee1b0c007;hp=b3eecb231cd562028a47d871d811eafc92ddfbc0;hpb=1bfc464c657a8f4ad24ef612f76a38d8f6f1bbad;p=sbcl.git

diff --git a/src/code/sharpm.lisp b/src/code/sharpm.lisp
index b3eecb2..3f898b0 100644
--- a/src/code/sharpm.lisp
+++ b/src/code/sharpm.lisp
@@ -96,12 +96,13 @@
 			 dimensions axis seq))
 	(let ((len (length seq)))
 	  (dims len)
-	  (unless (= axis (1- dimensions))
-	    (when (zerop len)
-	      (%reader-error stream
-			     "#~WA axis ~W is empty, but is not ~
-			      the last dimension."
-			     dimensions axis))
+	  (unless (or (= axis (1- dimensions))
+		      ;; ANSI: "If some dimension of the array whose
+		      ;; representation is being parsed is found to be
+		      ;; 0, all dimensions to the right (i.e., the
+		      ;; higher numbered dimensions) are also
+		      ;; considered to be 0."
+		      (= len 0))
 	    (setq seq (elt seq 0))))))))
 
 ;;;; reading structure instances: the #S readmacro
@@ -118,18 +119,51 @@
       (%reader-error stream "non-list following #S: ~S" body))
     (unless (symbolp (car body))
       (%reader-error stream "Structure type is not a symbol: ~S" (car body)))
-    (let ((class (sb!xc:find-class (car body) nil)))
-      (unless (typep class 'sb!xc:structure-class)
+    (let ((classoid (find-classoid (car body) nil)))
+      (unless (typep classoid 'structure-classoid)
 	(%reader-error stream "~S is not a defined structure type."
 		       (car body)))
       (let ((def-con (dd-default-constructor
 		      (layout-info
-		       (class-layout class)))))
+		       (classoid-layout classoid)))))
 	(unless def-con
 	  (%reader-error
 	   stream "The ~S structure does not have a default constructor."
 	   (car body)))
-	(apply (fdefinition def-con) (rest body))))))
+	(when (and (atom (rest body))
+		   (not (null (rest body))))
+	  (%reader-error
+	   stream "improper list for #S: ~S." body))
+	(apply (fdefinition def-con)
+	       (loop for tail on (rest body) by #'cddr
+		     with slot-name = (and (consp tail) (car tail))
+		     do (progn
+			  (when (null (cdr tail))
+			    (%reader-error
+			     stream
+			     "the arglist for the ~S constructor in #S ~
+                              has an odd length: ~S."
+			     (car body) (rest body)))
+			  (when (or (atom (cdr tail))
+				    (and (atom (cddr tail))
+					 (not (null (cddr tail)))))
+			    (%reader-error
+			     stream
+			     "the arglist for the ~S constructor in #S ~
+                              is improper: ~S."
+			     (car body) (rest body)))
+			  (when (not (typep (car tail) 'string-designator))
+			    (%reader-error
+			     stream
+			     "a slot name in #S is not a string ~
+                              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)))
+		     collect (intern (string (car tail)) *keyword-package*)
+		     collect (cadr tail)))))))
 
 ;;;; reading numbers: the #B, #C, #O, #R, and #X readmacros
 
@@ -183,12 +217,13 @@
 ;; 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)))
+  (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*))
 	 (setf (gethash tree *sharp-equal-circle-table*) t)
-	 (cond ((typep tree 'structure-object)
+	 (cond ((typep tree '(or structure-object standard-object))
 		(do ((i 1 (1+ i))
 		     (end (%instance-length tree)))
 		    ((= i end))
@@ -408,9 +443,9 @@
   (set-dispatch-macro-character #\# #\| #'sharp-vertical-bar)
   (set-dispatch-macro-character #\# #\p #'sharp-p)
   (set-dispatch-macro-character #\# #\P #'sharp-p)
-  (set-dispatch-macro-character #\# #\  #'sharp-illegal)
   (set-dispatch-macro-character #\# #\) #'sharp-illegal)
   (set-dispatch-macro-character #\# #\< #'sharp-illegal)
-  ;; FIXME: Should linefeed/newline go in this list too?
-  (dolist (cc '#.(list tab-char-code form-feed-char-code return-char-code))
+  (set-dispatch-macro-character #\# #\Space #'sharp-illegal)
+  (dolist (cc '#.(list tab-char-code form-feed-char-code return-char-code
+                       line-feed-char-code backspace-char-code))
     (set-dispatch-macro-character #\# (code-char cc) #'sharp-illegal)))