X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Flate-format.lisp;h=a7f32f747421af1ef6036d9a74398d42f357a3a8;hb=1d5e0a5293d69aa29c8c7b72cda555478622e913;hp=3aefd3d8e9265256235a294eb81f1d46a045d1a3;hpb=80304981972c91c1b3f3fca75f36dacf1fecf307;p=sbcl.git

diff --git a/src/code/late-format.lisp b/src/code/late-format.lisp
index 3aefd3d..a7f32f7 100644
--- a/src/code/late-format.lisp
+++ b/src/code/late-format.lisp
@@ -73,10 +73,17 @@
 			:complaint "String ended before directive was found."
 			:control-string string
 			:offset start)
-		 (schar string posn))))
+		 (schar string posn)))
+	   (check-ordering ()
+	     (when (or colonp atsignp)
+	       (error 'format-error
+		      :complaint "parameters found after #\\: or #\\@ modifier"
+		      :control-string string
+		      :offset posn))))
       (loop
 	(let ((char (get-char)))
 	  (cond ((or (char<= #\0 char #\9) (char= char #\+) (char= char #\-))
+		 (check-ordering)
 		 (multiple-value-bind (param new-posn)
 		     (parse-integer string :start posn :junk-allowed t)
 		   (push (cons posn param) params)
@@ -87,7 +94,9 @@
 		      (decf posn))
 		     (t
 		      (return)))))
-		((or (char= char #\v) (char= char #\V))
+		((or (char= char #\v)
+		     (char= char #\V))
+		 (check-ordering)
 		 (push (cons posn :arg) params)
 		 (incf posn)
 		 (case (get-char)
@@ -97,6 +106,7 @@
 		   (t
 		    (return))))
 		((char= char #\#)
+		 (check-ordering)
 		 (push (cons posn :remaining) params)
 		 (incf posn)
 		 (case (get-char)
@@ -106,12 +116,14 @@
 		   (t
 		    (return))))
 		((char= char #\')
+		 (check-ordering)
 		 (incf posn)
 		 (push (cons posn (get-char)) params)
 		 (incf posn)
 		 (unless (char= (get-char) #\,)
 		   (decf posn)))
 		((char= char #\,)
+		 (check-ordering)
 		 (push (cons posn nil) params))
 		((char= char #\:)
 		 (if colonp
@@ -129,6 +141,7 @@
 		     (setf atsignp t)))
 		(t
 		 (when (char= (schar string (1- posn)) #\,)
+		   (check-ordering)
 		   (push (cons (1- posn) nil) params))
 		 (return))))
 	(incf posn))
@@ -212,7 +225,8 @@
        (if expander
 	   (funcall expander directive more-directives)
 	   (error 'format-error
-		  :complaint "unknown directive"))))
+		  :complaint "unknown directive ~@[(character: ~A)~]"
+		  :args (list (char-name (format-directive-character directive)))))))
     (simple-string
      (values `(write-string ,directive stream)
 	     more-directives))))
@@ -935,6 +949,23 @@
 
 ;;;; format directives and support functions for justification
 
+(defparameter *illegal-inside-justification*
+  (mapcar (lambda (x) (parse-directive x 0))
+	  '("~W" "~:W" "~@W" "~:@W"
+	    "~_" "~:_" "~@_" "~:@_"
+	    "~:>" "~:@>"
+	    "~I" "~:I" "~@I" "~:@I"
+	    "~:T" "~:@T")))
+
+(defun illegal-inside-justification-p (directive)
+  (member directive *illegal-inside-justification*
+	  :test (lambda (x y)
+		  (and (format-directive-p x)
+		       (format-directive-p y)
+		       (eql (format-directive-character x) (format-directive-character y))
+		       (eql (format-directive-colonp x) (format-directive-colonp y))
+		       (eql (format-directive-atsignp x) (format-directive-atsignp y))))))
+
 (def-complex-format-directive #\< (colonp atsignp params string end directives)
   (multiple-value-bind (segments first-semi close remaining)
       (parse-format-justification directives)
@@ -945,8 +976,15 @@
 					 close params string end)
 	   (expand-format-logical-block prefix per-line-p insides
 					suffix atsignp))
-	 (expand-format-justification segments colonp atsignp
-				      first-semi params))
+	 (let ((count (reduce #'+ (mapcar (lambda (x) (count-if #'illegal-inside-justification-p x)) segments))))
+	   (when (> count 0)
+	     ;; ANSI specifies that "an error is signalled" in this
+	     ;; situation.
+	     (error 'format-error
+		    :complaint "~D illegal directive~:P found inside justification block"
+		    :args (list count)))
+	   (expand-format-justification segments colonp atsignp
+				      first-semi params)))
      remaining)))
 
 (def-complex-format-directive #\> ()
@@ -1145,8 +1183,8 @@
 				  ;; subseq expansion.
 				  (subseq foo (1+ slash) (1- end)))))
 	   (first-colon (position #\: name))
-	   (last-colon (if first-colon (position #\: name :from-end t)))
-	   (package-name (if last-colon
+	   (second-colon (if first-colon (position #\: name :start (1+ first-colon))))
+	   (package-name (if first-colon
 			     (subseq name 0 first-colon)
 			     "COMMON-LISP-USER"))
 	   (package (find-package package-name)))
@@ -1156,7 +1194,10 @@
 	(error 'format-error
 	       :complaint "no package named ~S"
 	       :args (list package-name)))
-      (intern (if first-colon
-		  (subseq name (1+ first-colon))
-		  name)
+      (intern (cond
+		((and second-colon (= second-colon (1+ first-colon)))
+		 (subseq name (1+ second-colon)))
+		(first-colon
+		 (subseq name (1+ first-colon)))
+		(t name))
 	      package))))