0.8.16.27:

[sbcl.git] / src / code / late-format.lisp

diff --git a/src/code/late-format.lisp b/src/code/late-format.lisp
index fef1acc..4cb042a 100644 (file)
--- a/src/code/late-format.lisp
+++ b/src/code/late-format.lisp
@@ -9,7 +9,7 @@
 
 (in-package "SB!FORMAT")
 \f
-(define-condition format-error (error)
+(define-condition format-error (error reference-condition)
   ((complaint :reader format-error-complaint :initarg :complaint)
    (args :reader format-error-args :initarg :args :initform nil)
    (control-string :reader format-error-control-string
@@ -21,7 +21,8 @@
                     :initarg :second-relative :initform nil)
    (print-banner :reader format-error-print-banner :initarg :print-banner
                 :initform t))
-  (:report %print-format-error))
+  (:report %print-format-error)
+  (:default-initargs :references nil))
 
 (defun %print-format-error (condition stream)
   (format stream
@@ -38,7 +39,7 @@
   (string (missing-arg) :type simple-string)
   (start (missing-arg) :type (and unsigned-byte fixnum))
   (end (missing-arg) :type (and unsigned-byte fixnum))
-  (character (missing-arg) :type base-char)
+  (character (missing-arg) :type character)
   (colonp nil :type (member t nil))
   (atsignp nil :type (member t nil))
   (params nil :type list))
@@ -106,7 +107,8 @@
                :offset (min pprint-offset justification-offset)
                :second-relative (- (max pprint-offset justification-offset)
                                    (min pprint-offset justification-offset)
-                                   1))))
+                                   1)
+               :references (list '(:ansi-cl :section (22 3 5 2))))))
     (nreverse result)))
 
 (defun parse-directive (string start)
@@ -124,7 +126,8 @@
               (error 'format-error
                      :complaint "parameters found after #\\: or #\\@ modifier"
                      :control-string string
-                     :offset posn))))
+                     :offset posn
+                      :references (list '(:ansi-cl :section (22 3)))))))
       (loop
        (let ((char (get-char)))
          (cond ((or (char<= #\0 char #\9) (char= char #\+) (char= char #\-))
@@ -175,14 +178,16 @@
                     (error 'format-error
                            :complaint "too many colons supplied"
                            :control-string string
-                           :offset posn)
+                           :offset posn
+                            :references (list '(:ansi-cl :section (22 3))))
                     (setf colonp t)))
                ((char= char #\@)
                 (if atsignp
                     (error 'format-error
                            :complaint "too many #\\@ characters supplied"
                            :control-string string
-                           :offset posn)
+                           :offset posn
+                            :references (list '(:ansi-cl :section (22 3))))
                     (setf atsignp t)))
                (t
                 (when (and (char= (schar string (1- posn)) #\,)
@@ -265,8 +270,11 @@
   (etypecase directive
     (format-directive
      (let ((expander
-           (aref *format-directive-expanders*
-                 (char-code (format-directive-character directive))))
+            (let ((char (format-directive-character directive)))
+              (typecase char
+                (base-char
+                 (aref *format-directive-expanders* (char-code char)))
+                (character nil))))
           (*default-format-error-offset*
            (1- (format-directive-end directive))))
        (declare (type (or null function) expander))
@@ -680,7 +688,7 @@
                 (setf args (nthcdr ,posn orig-args))
                 (error 'format-error
                        :complaint "Index ~W out of bounds. Should have been ~
-                                   between 0 and ~W."
+                                    between 0 and ~W."
                        :args (list ,posn (length orig-args))
                        :offset ,(1- end)))))
       (if colonp
@@ -697,7 +705,7 @@
                        (error 'format-error
                               :complaint
                               "Index ~W is out of bounds; should have been ~
-                               between 0 and ~W."
+                                between 0 and ~W."
                               :args (list new-posn (length orig-args))
                               :offset ,(1- end)))))))
          (if params
@@ -1030,9 +1038,10 @@
             ;; situation.
             (error 'format-error
                    :complaint "~D illegal directive~:P found inside justification block"
-                   :args (list count)))
+                   :args (list count)
+                    :references (list '(:ansi-cl :section (22 3 5 2)))))
           (expand-format-justification segments colonp atsignp
-                                     first-semi params)))
+                                        first-semi params)))
      remaining)))
 
 (def-complex-format-directive #\> ()
@@ -1053,10 +1062,12 @@
                   (if directive
                       (error 'format-error
                              :complaint
-                             "cannot include format directives inside the ~
-                              ~:[suffix~;prefix~] segment of ~~<...~~:>"
+                              "cannot include format directives inside the ~
+                               ~:[suffix~;prefix~] segment of ~~<...~~:>"
                              :args (list prefix-p)
-                             :offset (1- (format-directive-end directive)))
+                             :offset (1- (format-directive-end directive))
+                              :references
+                              (list '(:ansi-cl :section (22 3 5 2))))
                       (apply #'concatenate 'string list)))))
        (case (length segments)
          (0 (values prefix-default nil suffix-default))
@@ -1366,7 +1377,7 @@
                        ((char= c #\P)
                         (unless (format-directive-colonp directive)
                           (incf-both)))
-                       ((or (find c "IT%&|_();>") (char= c #\Newline)))
+                       ((or (find c "IT%&|_();>~") (char= c #\Newline)))
                         ;; FIXME: check correspondence of ~( and ~)
                        ((char= c #\<)
                         (walk-complex-directive walk-justification))