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

diff --git a/src/code/late-format.lisp b/src/code/late-format.lisp
index d84c503..a7f32f7 100644
--- a/src/code/late-format.lisp
+++ b/src/code/late-format.lisp
@@ -225,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))))
@@ -948,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)
@@ -958,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 #\> ()
@@ -1158,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)))
@@ -1169,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))))