;;; format.lisp
;;;
;;; Copyright (C) 2004-2007 Peter Graves
;;; $Id$
;;;
;;; This program is free software; you can redistribute it and/or
;;; modify it under the terms of the GNU General Public License
;;; as published by the Free Software Foundation; either version 2
;;; of the License, or (at your option) any later version.
;;;
;;; This program is distributed in the hope that it will be useful,
;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;;; GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with this program; if not, write to the Free Software
;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA  02110-1301, USA.
;;;
;;; As a special exception, the copyright holders of this library give you
;;; permission to link this library with independent modules to produce an
;;; executable, regardless of the license terms of these independent
;;; modules, and to copy and distribute the resulting executable under
;;; terms of your choice, provided that you also meet, for each linked
;;; independent module, the terms and conditions of the license of that
;;; module.  An independent module is a module which is not derived from
;;; or based on this library.  If you modify this library, you may extend
;;; this exception to your version of the library, but you are not
;;; obligated to do so.  If you do not wish to do so, delete this
;;; exception statement from your version.

;;; Adapted from CMUCL/SBCL.

(in-package "SYSTEM")

;; If we're here due to an autoloader,
;; we should prevent a circular dependency:
;; when the debugger tries to print an error,
;; it autoloads us, but if that autoloading causes
;; another error, it circularly starts autoloading us.
;;
;; So, we replace whatever is in the function slot until
;; we can reliably call FORMAT
(setf (symbol-function 'format) #'sys::%format)

(require "PRINT-OBJECT")

;;; From primordial-extensions.lisp.

;;; Concatenate together the names of some strings and symbols,
;;; producing a symbol in the current package.
(eval-when (:compile-toplevel :load-toplevel :execute)
  (defun symbolicate (&rest things)
    (let ((name (apply #'concatenate 'string (mapcar #'string things))))
      (values (intern name)))))

;;; a helper function for various macros which expect clauses of a
;;; given length, etc.
;;;
;;; Return true if X is a proper list whose length is between MIN and
;;; MAX (inclusive).
(eval-when (:compile-toplevel :load-toplevel :execute)
  (defun proper-list-of-length-p (x min &optional (max min))
    ;; FIXME: This implementation will hang on circular list
    ;; structure. Since this is an error-checking utility, i.e. its
    ;; job is to deal with screwed-up input, it'd be good style to fix
    ;; it so that it can deal with circular list structure.
    (cond ((minusp max) nil)
          ((null x) (zerop min))
          ((consp x)
           (and (plusp max)
                (proper-list-of-length-p (cdr x)
                                         (if (plusp (1- min))
                                             (1- min)
                                             0)
                                         (1- max))))
          (t nil))))

;;; From early-extensions.lisp.

(defconstant form-feed-char-code 12)

(defmacro named-let (name binds &body body)
  (dolist (x binds)
    (unless (proper-list-of-length-p x 2)
      (error "malformed NAMED-LET variable spec: ~S" x)))
  `(labels ((,name ,(mapcar #'first binds) ,@body))
     (,name ,@(mapcar #'second binds))))

;;;; ONCE-ONLY
;;;;
;;;; "The macro ONCE-ONLY has been around for a long time on various
;;;; systems [..] if you can understand how to write and when to use
;;;; ONCE-ONLY, then you truly understand macro." -- Peter Norvig,
;;;; _Paradigms of Artificial Intelligence Programming: Case Studies
;;;; in Common Lisp_, p. 853

;;; ONCE-ONLY is a utility useful in writing source transforms and
;;; macros. It provides a concise way to wrap a LET around some code
;;; to ensure that some forms are only evaluated once.
;;;
;;; Create a LET* which evaluates each value expression, binding a
;;; temporary variable to the result, and wrapping the LET* around the
;;; result of the evaluation of BODY. Within the body, each VAR is
;;; bound to the corresponding temporary variable.
(defmacro once-only (specs &body body)
  (named-let frob ((specs specs)
                   (body body))
             (if (null specs)
                 `(progn ,@body)
                 (let ((spec (first specs)))
                   ;; FIXME: should just be DESTRUCTURING-BIND of SPEC
                   (unless (proper-list-of-length-p spec 2)
                     (error "malformed ONCE-ONLY binding spec: ~S" spec))
                   (let* ((name (first spec))
                          (exp-temp (gensym (symbol-name name))))
                     `(let ((,exp-temp ,(second spec))
                            (,name (gensym "ONCE-ONLY-")))
                        `(let ((,,name ,,exp-temp))
                           ,,(frob (rest specs) body))))))))

;;; From print.lisp.

;;; FLONUM-TO-STRING (and its subsidiary function FLOAT-STRING) does
;;; most of the work for all printing of floating point numbers in the
;;; printer and in FORMAT. It converts a floating point number to a
;;; string in a free or fixed format with no exponent. The
;;; interpretation of the arguments is as follows:
;;;
;;;     X       - The floating point number to convert, which must not be
;;;             negative.
;;;     WIDTH    - The preferred field width, used to determine the number
;;;             of fraction digits to produce if the FDIGITS parameter
;;;             is unspecified or NIL. If the non-fraction digits and the
;;;             decimal point alone exceed this width, no fraction digits
;;;             will be produced unless a non-NIL value of FDIGITS has been
;;;             specified. Field overflow is not considerd an error at this
;;;             level.
;;;     FDIGITS  - The number of fractional digits to produce. Insignificant
;;;             trailing zeroes may be introduced as needed. May be
;;;             unspecified or NIL, in which case as many digits as possible
;;;             are generated, subject to the constraint that there are no
;;;             trailing zeroes.
;;;     SCALE    - If this parameter is specified or non-NIL, then the number
;;;             printed is (* x (expt 10 scale)). This scaling is exact,
;;;             and cannot lose precision.
;;;     FMIN     - This parameter, if specified or non-NIL, is the minimum
;;;             number of fraction digits which will be produced, regardless
;;;             of the value of WIDTH or FDIGITS. This feature is used by
;;;             the ~E format directive to prevent complete loss of
;;;             significance in the printed value due to a bogus choice of
;;;             scale factor.
;;;
;;; Most of the optional arguments are for the benefit for FORMAT and are not
;;; used by the printer.
;;;
;;; Returns:
;;; (VALUES DIGIT-STRING DIGIT-LENGTH LEADING-POINT TRAILING-POINT DECPNT)
;;; where the results have the following interpretation:
;;;
;;;     DIGIT-STRING    - The decimal representation of X, with decimal point.
;;;     DIGIT-LENGTH    - The length of the string DIGIT-STRING.
;;;     LEADING-POINT   - True if the first character of DIGIT-STRING is the
;;;                    decimal point.
;;;     TRAILING-POINT  - True if the last character of DIGIT-STRING is the
;;;                    decimal point.
;;;     POINT-POS       - The position of the digit preceding the decimal
;;;                    point. Zero indicates point before first digit.
;;;
;;; NOTE: FLONUM-TO-STRING goes to a lot of trouble to guarantee
;;; accuracy. Specifically, the decimal number printed is the closest
;;; possible approximation to the true value of the binary number to
;;; be printed from among all decimal representations with the same
;;; number of digits. In free-format output, i.e. with the number of
;;; digits unconstrained, it is guaranteed that all the information is
;;; preserved, so that a properly- rounding reader can reconstruct the
;;; original binary number, bit-for-bit, from its printed decimal
;;; representation. Furthermore, only as many digits as necessary to
;;; satisfy this condition will be printed.
;;;
;;; FLOAT-STRING actually generates the digits for positive numbers.
;;; The algorithm is essentially that of algorithm Dragon4 in "How to
;;; Print Floating-Point Numbers Accurately" by Steele and White. The
;;; current (draft) version of this paper may be found in
;;; [CMUC]<steele>tradix.press. DO NOT EVEN THINK OF ATTEMPTING TO
;;; UNDERSTAND THIS CODE WITHOUT READING THE PAPER!

(defun flonum-to-string (x &optional width fdigits scale fmin)
  (declare (ignore fmin)) ; FIXME
  (cond ((zerop x)
         ;; Zero is a special case which FLOAT-STRING cannot handle.
         (if fdigits
             (let ((s (make-string (1+ fdigits) :initial-element #\0)))
               (setf (schar s 0) #\.)
               (values s (length s) t (zerop fdigits) 0))
             (values "." 1 t t 0)))
        (t
         (when scale
           (setf x (* x (expt 10 scale))))
         (let* ((s (float-string x))
                (length (length s))
                (index (position #\. s)))
           (when (and (< x 1)
                      (> length 0)
                      (eql (schar s 0) #\0))
             (setf s (subseq s 1)
                   length (length s)
                   index (position #\. s)))
           (when fdigits
             ;; "Leading zeros are not permitted, except that a single zero
             ;; digit is output before the decimal point if the printed value
             ;; is less than one, and this single zero digit is not output at
             ;; all if w=d+1."
             (let ((actual-fdigits (- length index 1)))
               (cond ((< actual-fdigits fdigits)
                      ;; Add the required number of trailing zeroes.
                      (setf s (concatenate 'string s
                                           (make-string (- fdigits actual-fdigits)
                                                        :initial-element #\0))
                            length (length s)))
                     ((> actual-fdigits fdigits)
                      (let* ((desired-length (+ index 1 fdigits))
                             (c (schar s desired-length)))
                        (setf s (subseq s 0 (+ index 1 fdigits))
                              length (length s)
                              index (position #\. s))
                        (when (char>= c #\5)
                          (setf s (round-up s)
                                length (length s)
                                index (position #\. s))))))))
           (when (and width (> length width))
             ;; The string is too long. Shorten it by removing insignificant
             ;; trailing zeroes if possible.
             (let ((minimum-width (+ (1+ index) (or fdigits 0))))
               (when (< minimum-width width)
                 (setf minimum-width width))
               (when (> length minimum-width)
                 ;; But we don't want to shorten e.g. "1.7d100"...
                 (when (every #'digit-char-p (subseq s (1+ index)))
                   (let ((c (schar s minimum-width)))
                     (setf s (subseq s 0 minimum-width)
                           length minimum-width)
                     (when (char>= c #\5)
                       (setf s (round-up s)
                             length (length s)
                             index (position #\. s))))))))
           (values s length (eql index 0) (eql index (1- length)) index)))))

(defun round-up (string)
  (let* ((index (position #\. string))
         (n (read-from-string (setf string (remove #\. string))))
         (s (princ-to-string (incf n))))
    (loop for char across string
      while (equal char #\0)
      do (setf s (concatenate 'string "0" s)))
    (cond ((null index)
           s)
          (t
           (when (> (length s) (length string))
             ;; Rounding up made the string longer, which means we went from (say) 99
             ;; to 100. Drop the trailing #\0 and move the #\. one character to the
             ;; right.
             (setf s (subseq s 0 (1- (length s))))
             (incf index))
           (concatenate 'string (subseq s 0 index) "." (subseq s index))))))


(defun scale-exponent (original-x)
  (let* ((x (coerce original-x 'long-float)))
    (multiple-value-bind (sig exponent) (decode-float x)
      (declare (ignore sig))
      (if (= x 0.0l0)
          (values (float 0.0l0 original-x) 1)
          (let* ((ex (locally (declare (optimize (safety 0)))
                       (the fixnum
                            (round (* exponent (log 2l0 10))))))
                 (x (if (minusp ex)
                        (if (float-denormalized-p x)
                            (* x 1.0l16 (expt 10.0l0 (- (- ex) 16)))
                            (* x 10.0l0 (expt 10.0l0 (- (- ex) 1))))
                        (/ x 10.0l0 (expt 10.0l0 (1- ex))))))
            (do ((d 10.0l0 (* d 10.0l0))
                 (y x (/ x d))
                 (ex ex (1+ ex)))
                ((< y 1.0l0)
                 (do ((m 10.0l0 (* m 10.0l0))
                      (z y (* y m))
                      (ex ex (1- ex)))
                     ((>= z 0.1l0)
                      (values (float z original-x) ex))
                   (declare (long-float m) (integer ex))))
              (declare (long-float d))))))))

(defconstant double-float-exponent-byte
  (byte 11 20))

(defun float-denormalized-p (x)
  "Return true if the double-float X is denormalized."
  (and (zerop (ldb double-float-exponent-byte (double-float-high-bits x)))
       (not (zerop x))))

;;; From early-format.lisp.

(in-package #:format)

(defparameter *format-whitespace-chars*
  (vector #\space
          #\newline
          #\tab))

(defvar *format-directive-expanders*
  (make-hash-table :test #'eq))
(defvar *format-directive-interpreters*
  (make-hash-table :test #'eq))

(defvar *default-format-error-control-string* nil)
(defvar *default-format-error-offset* nil)

;;;; specials used to communicate information

;;; Used both by the expansion stuff and the interpreter stuff. When it is
;;; non-NIL, up-up-and-out (~:^) is allowed. Otherwise, ~:^ isn't allowed.
(defvar *up-up-and-out-allowed* nil)

;;; Used by the interpreter stuff. When it's non-NIL, it's a function
;;; that will invoke PPRINT-POP in the right lexical environemnt.
(declaim (type (or null function) *logical-block-popper*))
(defvar *logical-block-popper* nil)

;;; Used by the expander stuff. This is bindable so that ~<...~:>
;;; can change it.
(defvar *expander-next-arg-macro* 'expander-next-arg)

;;; Used by the expander stuff. Initially starts as T, and gets set to NIL
;;; if someone needs to do something strange with the arg list (like use
;;; the rest, or something).
(defvar *only-simple-args*)

;;; Used by the expander stuff. We do an initial pass with this as NIL.
;;; If someone doesn't like this, they (THROW 'NEED-ORIG-ARGS NIL) and we try
;;; again with it bound to T. If this is T, we don't try to do anything
;;; fancy with args.
(defvar *orig-args-available* nil)

;;; Used by the expander stuff. List of (symbol . offset) for simple args.
(defvar *simple-args*)

;;; From late-format.lisp.

(in-package #:format)

(define-condition format-error (error)
  ((complaint :reader format-error-complaint :initarg :complaint)
   (args :reader format-error-args :initarg :args :initform nil)
   (control-string :reader format-error-control-string
                   :initarg :control-string
                   :initform *default-format-error-control-string*)
   (offset :reader format-error-offset :initarg :offset
           :initform *default-format-error-offset*)
   (print-banner :reader format-error-print-banner :initarg :print-banner
                 :initform t))
  (:report %print-format-error))

(defun %print-format-error (condition stream)
  (format stream
          "~:[~;error in format: ~]~
           ~?~@[~%  ~A~%  ~V@T^~]"
          (format-error-print-banner condition)
          (format-error-complaint condition)
          (format-error-args condition)
          (format-error-control-string condition)
          (format-error-offset condition)))

(defun missing-arg ()
  (error "Missing argument in format directive"))

(defstruct format-directive
  (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)
  (colonp nil :type (member t nil))
  (atsignp nil :type (member t nil))
  (params nil :type list))
(defmethod print-object ((x format-directive) stream)
  (print-unreadable-object (x stream)
                           (write-string (format-directive-string x)
                                         stream
                                         :start (format-directive-start x)
                                         :end (format-directive-end x))))

;;;; TOKENIZE-CONTROL-STRING

(defun tokenize-control-string (string)
  (declare (simple-string string))
  (let ((index 0)
        (end (length string))
        (result nil)
        (in-block nil)
        (pprint nil)
        (semi nil)
        (justification-semi 0))
    (declare (type index fixnum))
    (loop
      (let ((next-directive (or (position #\~ string :start index) end)))
        (declare (type index next-directive))
        (when (> next-directive index)
          (push (subseq string index next-directive) result))
        (when (= next-directive end)
          (return))
        (let* ((directive (parse-directive string next-directive))
               (directive-char (format-directive-character directive)))
          (declare (type character directive-char))
          ;; We are looking for illegal combinations of format
          ;; directives in the control string.  See the last paragraph
          ;; of CLHS 22.3.5.2: "an error is also signaled if the
          ;; ~<...~:;...~> form of ~<...~> is used in the same format
          ;; string with ~W, ~_, ~<...~:>, ~I, or ~:T."
          (cond ((char= #\< directive-char)
                 ;; Found a justification or logical block
                 (setf in-block t))
                ((and in-block (char= #\; directive-char))
                 ;; Found a semi colon in a justification or logical block
                 (setf semi t))
                ((char= #\> directive-char)
                 ;; End of justification or logical block.  Figure out which.
                 (setf in-block nil)
                 (cond ((format-directive-colonp directive)
                        ;; A logical-block directive.  Note that fact, and also
                        ;; note that we don't care if we found any ~;
                        ;; directives in the block.
                        (setf pprint t)
                        (setf semi nil))
                       (semi
                        ;; A justification block with a ~; directive in it.
                        (incf justification-semi))))
                ((and (not in-block)
                      (or (and (char= #\T directive-char) (format-directive-colonp directive))
                          (char= #\W directive-char)
                          (char= #\_ directive-char)
                          (char= #\I directive-char)))
                 (setf pprint t)))
          (push directive result)
          (setf index (format-directive-end directive)))))
    (when (and pprint (plusp justification-semi))
      (error 'format-error
             :complaint "A justification directive cannot be in the same format string~%~
             as ~~W, ~~I, ~~:T, or a logical-block directive."
             :control-string string
             :offset 0))
    (nreverse result)))

(defun parse-directive (string start)
  (let ((posn (1+ start)) (params nil) (colonp nil) (atsignp nil)
        (end (length string)))
    (flet ((get-char ()
                     (if (= posn end)
                         (error 'format-error
                                :complaint "String ended before directive was found."
                                :control-string string
                                :offset start)
                         (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)
                   (setf posn new-posn)
                   (case (get-char)
                     (#\,)
                     ((#\: #\@)
                      (decf posn))
                     (t
                      (return)))))
                ((or (char= char #\v)
                     (char= char #\V))
                 (check-ordering)
                 (push (cons posn :arg) params)
                 (incf posn)
                 (case (get-char)
                   (#\,)
                   ((#\: #\@)
                    (decf posn))
                   (t
                    (return))))
                ((char= char #\#)
                 (check-ordering)
                 (push (cons posn :remaining) params)
                 (incf posn)
                 (case (get-char)
                   (#\,)
                   ((#\: #\@)
                    (decf posn))
                   (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
                     (error 'format-error
                            :complaint "too many colons supplied"
                            :control-string string
                            :offset posn)
                     (setf colonp t)))
                ((char= char #\@)
                 (if atsignp
                     (error 'format-error
                            :complaint "too many #\\@ characters supplied"
                            :control-string string
                            :offset posn)
                     (setf atsignp t)))
                (t
                 (when (and (char= (schar string (1- posn)) #\,)
                            (or (< posn 2)
                                (char/= (schar string (- posn 2)) #\')))
                   (check-ordering)
                   (push (cons (1- posn) nil) params))
                 (return))))
        (incf posn))
      (let ((char (get-char)))
        (when (char= char #\/)
          (let ((closing-slash (position #\/ string :start (1+ posn))))
            (if closing-slash
                (setf posn closing-slash)
                (error 'format-error
                       :complaint "no matching closing slash"
                       :control-string string
                       :offset posn))))
        (make-format-directive
         :string string :start start :end (1+ posn)
         :character (char-upcase char)
         :colonp colonp :atsignp atsignp
         :params (nreverse params))))))

;;;; FORMATTER stuff

(defmacro formatter (control-string)
  `#',(%formatter control-string))

(defun %formatter (control-string)
  (block nil
    (catch 'need-orig-args
      (let* ((*simple-args* nil)
             (*only-simple-args* t)
             (guts (expand-control-string control-string))
             (args nil))
        (dolist (arg *simple-args*)
          (push `(,(car arg)
                  (error
                   'format-error
                   :complaint "required argument missing"
                   :control-string ,control-string
                   :offset ,(cdr arg)))
                args))
        (return `(lambda (stream &optional ,@args &rest args)
                   ,guts
                   args))))
    (let ((*orig-args-available* t)
          (*only-simple-args* nil))
      `(lambda (stream &rest orig-args)
         (let ((args orig-args))
           ,(expand-control-string control-string)
           args)))))

(defun expand-control-string (string)
  (let* ((string (etypecase string
                   (simple-string
                    string)
                   (string
                    (coerce string 'simple-string))))
         (*default-format-error-control-string* string)
         (directives (tokenize-control-string string)))
    `(block nil
       ,@(expand-directive-list directives))))

(defun expand-directive-list (directives)
  (let ((results nil)
        (remaining-directives directives))
    (loop
      (unless remaining-directives
        (return))
      (multiple-value-bind (form new-directives)
        (expand-directive (car remaining-directives)
                          (cdr remaining-directives))
        (when form
          (push form results))
        (setf remaining-directives new-directives)))
    (reverse results)))

(defun expand-directive (directive more-directives)
  (etypecase directive
    (format-directive
     (let ((expander
            (gethash (format-directive-character directive)
                     *format-directive-expanders*))
           (*default-format-error-offset*
            (1- (format-directive-end directive))))
       (declare (type (or null function) expander))
       (if expander
           (funcall expander directive more-directives)
           (error 'format-error
                  :complaint "unknown directive ~@[(character: ~A)~]"
                  :args (list (char-name (format-directive-character directive)))))))
    (simple-string
     (values `(write-string ,directive stream)
             more-directives))))

(defmacro expander-next-arg (string offset)
  `(if args
       (pop args)
       (error 'format-error
              :complaint "no more arguments"
              :control-string ,string
              :offset ,offset)))

(defun expand-next-arg (&optional offset)
  (if (or *orig-args-available* (not *only-simple-args*))
      `(,*expander-next-arg-macro*
        ,*default-format-error-control-string*
        ,(or offset *default-format-error-offset*))
      (let ((symbol (gensym "FORMAT-ARG-")))
        (push (cons symbol (or offset *default-format-error-offset*))
              *simple-args*)
        symbol)))

(defmacro expand-bind-defaults (specs params &body body)
  (sys::once-only ((params params))
                  (if specs
                      (collect ((expander-bindings) (runtime-bindings))
                               (dolist (spec specs)
                                 (destructuring-bind (var default) spec
                                                     (let ((symbol (gensym)))
                                                       (expander-bindings
                                                        `(,var ',symbol))
                                                       (runtime-bindings
                                                        `(list ',symbol
                                                               (let* ((param-and-offset (pop ,params))
                                                                      (offset (car param-and-offset))
                                                                      (param (cdr param-and-offset)))
                                                                 (case param
                                                                   (:arg `(or ,(expand-next-arg offset)
                                                                              ,,default))
                                                                   (:remaining
                                                                    (setf *only-simple-args* nil)
                                                                    '(length args))
                                                                   ((nil) ,default)
                                                                   (t param))))))))
                               `(let ,(expander-bindings)
                                  `(let ,(list ,@(runtime-bindings))
                                     ,@(if ,params
                                           (error
                                            'format-error
                                            :complaint
                                            "too many parameters, expected no more than ~W"
                                            :args (list ,(length specs))
                                            :offset (caar ,params)))
                                     ,,@body)))
                      `(progn
                         (when ,params
                           (error 'format-error
                                  :complaint "too many parameters, expected none"
                                  :offset (caar ,params)))
                         ,@body))))

;;;; format directive machinery

;;; FIXME: only used in this file, could be SB!XC:DEFMACRO in EVAL-WHEN
(defmacro def-complex-format-directive (char lambda-list &body body)
  (let ((defun-name
          (intern (concatenate 'string
                               (let ((name (char-name char)))
                                 (cond (name
                                        (string-capitalize name))
                                       (t
                                        (string char))))
                               "-FORMAT-DIRECTIVE-EXPANDER")))
        (directive (gensym))
        (directives (if lambda-list (car (last lambda-list)) (gensym))))
    `(progn
       (defun ,defun-name (,directive ,directives)
         ,@(if lambda-list
               `((let ,(mapcar (lambda (var)
                                 `(,var
                                   (,(sys::symbolicate "FORMAT-DIRECTIVE-" var)
                                    ,directive)))
                               (butlast lambda-list))
                   ,@body))
               `((declare (ignore ,directive ,directives))
                 ,@body)))
       (%set-format-directive-expander ,char #',defun-name))))

;;; FIXME: only used in this file, could be SB!XC:DEFMACRO in EVAL-WHEN
(defmacro def-format-directive (char lambda-list &body body)
  (let ((directives (gensym))
        (declarations nil)
        (body-without-decls body))
    (loop
      (let ((form (car body-without-decls)))
        (unless (and (consp form) (eq (car form) 'declare))
          (return))
        (push (pop body-without-decls) declarations)))
    (setf declarations (reverse declarations))
    `(def-complex-format-directive ,char (,@lambda-list ,directives)
       ,@declarations
       (values (progn ,@body-without-decls)
               ,directives))))

(eval-when (:compile-toplevel :load-toplevel :execute)

  (defun %set-format-directive-expander (char fn)
    (setf (gethash (char-upcase char) *format-directive-expanders*) fn)
    char)

  (defun %set-format-directive-interpreter (char fn)
    (setf (gethash (char-upcase char) *format-directive-interpreters*) fn)
    char)

  (defun find-directive (directives kind stop-at-semi)
    (if directives
        (let ((next (car directives)))
          (if (format-directive-p next)
              (let ((char (format-directive-character next)))
                (if (or (char= kind char)
                        (and stop-at-semi (char= char #\;)))
                    (car directives)
                    (find-directive
                     (cdr (flet ((after (char)
                                   (member (find-directive (cdr directives)
                                                           char
                                                           nil)
                                           directives)))
                            (case char
                              (#\( (after #\)))
                              (#\< (after #\>))
                              (#\[ (after #\]))
                              (#\{ (after #\}))
                              (t directives))))
                     kind stop-at-semi)))
              (find-directive (cdr directives) kind stop-at-semi)))))

  ) ; EVAL-WHEN

;;;; format directives for simple output

(def-format-directive #\A (colonp atsignp params)
  (if params
      (expand-bind-defaults ((mincol 0) (colinc 1) (minpad 0)
                             (padchar #\space))
                            params
                            `(format-princ stream ,(expand-next-arg) ',colonp ',atsignp
                                           ,mincol ,colinc ,minpad ,padchar))
      `(princ ,(if colonp
                   `(or ,(expand-next-arg) "()")
                   (expand-next-arg))
              stream)))

(def-format-directive #\S (colonp atsignp params)
  (cond (params
         (expand-bind-defaults ((mincol 0) (colinc 1) (minpad 0)
                                (padchar #\space))
                               params
                               `(format-prin1 stream ,(expand-next-arg) ,colonp ,atsignp
                                              ,mincol ,colinc ,minpad ,padchar)))
        (colonp
         `(let ((arg ,(expand-next-arg)))
            (if arg
                (prin1 arg stream)
                (princ "()" stream))))
        (t
         `(prin1 ,(expand-next-arg) stream))))

(def-format-directive #\C (colonp atsignp params)
  (expand-bind-defaults () params
                        (if colonp
                            `(format-print-named-character ,(expand-next-arg) stream)
                            (if atsignp
                                `(prin1 ,(expand-next-arg) stream)
                                `(write-char ,(expand-next-arg) stream)))))

(def-format-directive #\W (colonp atsignp params)
  (expand-bind-defaults () params
                        (if (or colonp atsignp)
                            `(let (,@(when colonp
                                       '((*print-pretty* t)))
                                   ,@(when atsignp
                                       '((*print-level* nil)
                                         (*print-length* nil))))
                               (sys::output-object ,(expand-next-arg) stream))
                            `(sys::output-object ,(expand-next-arg) stream))))

;;;; format directives for integer output

(defun expand-format-integer (base colonp atsignp params)
  (if (or colonp atsignp params)
      (expand-bind-defaults
       ((mincol 0) (padchar #\space) (commachar #\,) (commainterval 3))
       params
       `(format-print-integer stream ,(expand-next-arg) ,colonp ,atsignp
                              ,base ,mincol ,padchar ,commachar
                              ,commainterval))
      `(write ,(expand-next-arg) :stream stream :base ,base :radix nil
              :escape nil)))

(def-format-directive #\D (colonp atsignp params)
  (expand-format-integer 10 colonp atsignp params))

(def-format-directive #\B (colonp atsignp params)
  (expand-format-integer 2 colonp atsignp params))

(def-format-directive #\O (colonp atsignp params)
  (expand-format-integer 8 colonp atsignp params))

(def-format-directive #\X (colonp atsignp params)
  (expand-format-integer 16 colonp atsignp params))

(def-format-directive #\R (colonp atsignp params)
  (expand-bind-defaults
   ((base nil) (mincol 0) (padchar #\space) (commachar #\,)
    (commainterval 3))
   params
   (let ((n-arg (gensym)))
     `(let ((,n-arg ,(expand-next-arg)))
        (if ,base
            (format-print-integer stream ,n-arg ,colonp ,atsignp
                                  ,base ,mincol
                                  ,padchar ,commachar ,commainterval)
            ,(if atsignp
                 (if colonp
                     `(format-print-old-roman stream ,n-arg)
                     `(format-print-roman stream ,n-arg))
                 (if colonp
                     `(format-print-ordinal stream ,n-arg)
                     `(format-print-cardinal stream ,n-arg))))))))

;;;; format directive for pluralization

(def-format-directive #\P (colonp atsignp params end)
  (expand-bind-defaults () params
                        (let ((arg (cond
                                    ((not colonp)
                                     (expand-next-arg))
                                    (*orig-args-available*
                                     `(if (eq orig-args args)
                                          (error 'format-error
                                                 :complaint "no previous argument"
                                                 :offset ,(1- end))
                                          (do ((arg-ptr orig-args (cdr arg-ptr)))
                                              ((eq (cdr arg-ptr) args)
                                               (car arg-ptr)))))
                                    (*only-simple-args*
                                     (unless *simple-args*
                                       (error 'format-error
                                              :complaint "no previous argument"))
                                     (caar *simple-args*))
                                    (t
                                     (throw 'need-orig-args nil)))))
                          (if atsignp
                              `(write-string (if (eql ,arg 1) "y" "ies") stream)
                              `(unless (eql ,arg 1) (write-char #\s stream))))))

;;;; format directives for floating point output

(def-format-directive #\F (colonp atsignp params)
  (when colonp
    (error 'format-error
           :complaint
           "The colon modifier cannot be used with this directive."))
  (expand-bind-defaults ((w nil) (d nil) (k nil) (ovf nil) (pad #\space)) params
                        `(format-fixed stream ,(expand-next-arg) ,w ,d ,k ,ovf ,pad ,atsignp)))

(def-format-directive #\E (colonp atsignp params)
  (when colonp
    (error 'format-error
           :complaint
           "The colon modifier cannot be used with this directive."))
  (expand-bind-defaults
   ((w nil) (d nil) (e nil) (k 1) (ovf nil) (pad #\space) (mark nil))
   params
   `(format-exponential stream ,(expand-next-arg) ,w ,d ,e ,k ,ovf ,pad ,mark
                        ,atsignp)))

(def-format-directive #\G (colonp atsignp params)
  (when colonp
    (error 'format-error
           :complaint
           "The colon modifier cannot be used with this directive."))
  (expand-bind-defaults
   ((w nil) (d nil) (e nil) (k nil) (ovf nil) (pad #\space) (mark nil))
   params
   `(format-general stream ,(expand-next-arg) ,w ,d ,e ,k ,ovf ,pad ,mark ,atsignp)))

(def-format-directive #\$ (colonp atsignp params)
  (expand-bind-defaults ((d 2) (n 1) (w 0) (pad #\space)) params
                        `(format-dollars stream ,(expand-next-arg) ,d ,n ,w ,pad ,colonp
                                         ,atsignp)))

;;;; format directives for line/page breaks etc.

(def-format-directive #\% (colonp atsignp params)
  (when (or colonp atsignp)
    (error 'format-error
           :complaint
           "The colon and atsign modifiers cannot be used with this directive."
           ))
  (if params
      (expand-bind-defaults ((count 1)) params
                            `(dotimes (i ,count)
                               (terpri stream)))
      '(terpri stream)))

(def-format-directive #\& (colonp atsignp params)
  (when (or colonp atsignp)
    (error 'format-error
           :complaint
           "The colon and atsign modifiers cannot be used with this directive."
           ))
  (if params
      (expand-bind-defaults ((count 1)) params
                            `(progn
                               (fresh-line stream)
                               (dotimes (i (1- ,count))
                                 (terpri stream))))
      '(fresh-line stream)))

(def-format-directive #\| (colonp atsignp params)
  (when (or colonp atsignp)
    (error 'format-error
           :complaint
           "The colon and atsign modifiers cannot be used with this directive."
           ))
  (if params
      (expand-bind-defaults ((count 1)) params
                            `(dotimes (i ,count)
                               (write-char (code-char sys::form-feed-char-code) stream)))
      '(write-char (code-char sys::form-feed-char-code) stream)))

(def-format-directive #\~ (colonp atsignp params)
  (when (or colonp atsignp)
    (error 'format-error
           :complaint
           "The colon and atsign modifiers cannot be used with this directive."
           ))
  (if params
      (expand-bind-defaults ((count 1)) params
                            `(dotimes (i ,count)
                               (write-char #\~ stream)))
      '(write-char #\~ stream)))

(def-complex-format-directive #\newline (colonp atsignp params directives)
  (when (and colonp atsignp)
    (error 'format-error
           :complaint "both colon and atsign modifiers used simultaneously"))
  (values (expand-bind-defaults () params
                                (if atsignp
                                    '(write-char #\newline stream)
                                    nil))
          (if (and (not colonp)
                   directives
                   (simple-string-p (car directives)))
              (cons (string-left-trim *format-whitespace-chars*
                                      (car directives))
                    (cdr directives))
              directives)))

;;;; format directives for tabs and simple pretty printing

(def-format-directive #\T (colonp atsignp params)
  (if colonp
      (expand-bind-defaults ((n 1) (m 1)) params
                            `(pprint-tab ,(if atsignp :section-relative :section)
                                         ,n ,m stream))
      (if atsignp
          (expand-bind-defaults ((colrel 1) (colinc 1)) params
                                `(format-relative-tab stream ,colrel ,colinc))
          (expand-bind-defaults ((colnum 1) (colinc 1)) params
                                `(format-absolute-tab stream ,colnum ,colinc)))))

(def-format-directive #\_ (colonp atsignp params)
  (expand-bind-defaults () params
                        `(pprint-newline ,(if colonp
                                              (if atsignp
                                                  :mandatory
                                                  :fill)
                                              (if atsignp
                                                  :miser
                                                  :linear))
                                         stream)))

(def-format-directive #\I (colonp atsignp params)
  (when atsignp
    (error 'format-error
           :complaint
           "cannot use the at-sign modifier with this directive"))
  (expand-bind-defaults ((n 0)) params
                        `(pprint-indent ,(if colonp :current :block) ,n stream)))

;;;; format directive for ~*

(def-format-directive #\* (colonp atsignp params end)
  (if atsignp
      (if colonp
          (error 'format-error
                 :complaint
                 "both colon and atsign modifiers used simultaneously")
          (expand-bind-defaults ((posn 0)) params
                                (unless *orig-args-available*
                                  (throw 'need-orig-args nil))
                                `(if (<= 0 ,posn (length orig-args))
                                     (setf args (nthcdr ,posn orig-args))
                                     (error 'format-error
                                            :complaint "Index ~W out of bounds. Should have been ~
                                            between 0 and ~W."
                                            :args (list ,posn (length orig-args))
                                            :offset ,(1- end)))))
      (if colonp
          (expand-bind-defaults ((n 1)) params
                                (unless *orig-args-available*
                                  (throw 'need-orig-args nil))
                                `(do ((cur-posn 0 (1+ cur-posn))
                                      (arg-ptr orig-args (cdr arg-ptr)))
                                     ((eq arg-ptr args)
                                      (let ((new-posn (- cur-posn ,n)))
                                        (if (<= 0 new-posn (length orig-args))
                                            (setf args (nthcdr new-posn orig-args))
                                            (error 'format-error
                                                   :complaint
                                                   "Index ~W is out of bounds; should have been ~
                                                    between 0 and ~W."
                                                   :args (list new-posn (length orig-args))
                                                   :offset ,(1- end)))))))
          (if params
              (expand-bind-defaults ((n 1)) params
                                    (setf *only-simple-args* nil)
                                    `(dotimes (i ,n)
                                       ,(expand-next-arg)))
              (expand-next-arg)))))

;;;; format directive for indirection

(def-format-directive #\? (colonp atsignp params string end)
  (when colonp
    (error 'format-error
           :complaint "cannot use the colon modifier with this directive"))
  (expand-bind-defaults () params
                        `(handler-bind
                           ((format-error
                             (lambda (condition)
                               (error 'format-error
                                      :complaint
                                      "~A~%while processing indirect format string:"
                                      :args (list condition)
                                      :print-banner nil
                                      :control-string ,string
                                      :offset ,(1- end)))))
                           ,(if atsignp
                                (if *orig-args-available*
                                    `(setf args (%format stream ,(expand-next-arg) orig-args args))
                                    (throw 'need-orig-args nil))
                                `(%format stream ,(expand-next-arg) ,(expand-next-arg))))))

;;;; format directives for capitalization

(def-complex-format-directive #\( (colonp atsignp params directives)
  (let ((close (find-directive directives #\) nil)))
    (unless close
      (error 'format-error
             :complaint "no corresponding close parenthesis"))
    (let* ((posn (position close directives))
           (before (subseq directives 0 posn))
           (after (nthcdr (1+ posn) directives)))
      (values
       (expand-bind-defaults () params
                             `(let ((stream (sys::make-case-frob-stream (if (typep stream 'xp::xp-structure)
                                                                             (xp::base-stream stream)
                                                                             stream)
                                                                        ,(if colonp
                                                                             (if atsignp
                                                                                 :upcase
                                                                                 :capitalize)
                                                                             (if atsignp
                                                                                 :capitalize-first
                                                                                 :downcase)))))
                                ,@(expand-directive-list before)))
       after))))

(def-complex-format-directive #\) ()
  (error 'format-error
         :complaint "no corresponding open parenthesis"))

;;;; format directives and support functions for conditionalization

(def-complex-format-directive #\[ (colonp atsignp params directives)
  (multiple-value-bind (sublists last-semi-with-colon-p remaining)
      (parse-conditional-directive directives)
    (values
     (if atsignp
         (if colonp
             (error 'format-error
                    :complaint
                    "both colon and atsign modifiers used simultaneously")
             (if (cdr sublists)
                 (error 'format-error
                        :complaint
                        "Can only specify one section")
                 (expand-bind-defaults () params
                   (expand-maybe-conditional (car sublists)))))
         (if colonp
             (if (= (length sublists) 2)
                 (expand-bind-defaults () params
                   (expand-true-false-conditional (car sublists)
                                                  (cadr sublists)))
                 (error 'format-error
                        :complaint
                        "must specify exactly two sections"))
             (expand-bind-defaults ((index nil)) params
               (setf *only-simple-args* nil)
               (let ((clauses nil)
                     (case `(or ,index ,(expand-next-arg))))
                 (when last-semi-with-colon-p
                   (push `(t ,@(expand-directive-list (pop sublists)))
                         clauses))
                 (let ((count (length sublists)))
                   (dolist (sublist sublists)
                     (push `(,(decf count)
                             ,@(expand-directive-list sublist))
                           clauses)))
                 `(case ,case ,@clauses)))))
     remaining)))

(defun parse-conditional-directive (directives)
  (let ((sublists nil)
        (last-semi-with-colon-p nil)
        (remaining directives))
    (loop
      (let ((close-or-semi (find-directive remaining #\] t)))
        (unless close-or-semi
          (error 'format-error
                 :complaint "no corresponding close bracket"))
        (let ((posn (position close-or-semi remaining)))
          (push (subseq remaining 0 posn) sublists)
          (setf remaining (nthcdr (1+ posn) remaining))
          (when (char= (format-directive-character close-or-semi) #\])
            (return))
          (setf last-semi-with-colon-p
                (format-directive-colonp close-or-semi)))))
    (values sublists last-semi-with-colon-p remaining)))

(defun expand-maybe-conditional (sublist)
  (flet ((hairy ()
           `(let ((prev-args args)
                  (arg ,(expand-next-arg)))
              (when arg
                (setf args prev-args)
                ,@(expand-directive-list sublist)))))
    (if *only-simple-args*
        (multiple-value-bind (guts new-args)
            (let ((*simple-args* *simple-args*))
              (values (expand-directive-list sublist)
                      *simple-args*))
          (cond ((and new-args (eq *simple-args* (cdr new-args)))
                 (setf *simple-args* new-args)
                 `(when ,(caar new-args)
                    ,@guts))
                (t
                 (setf *only-simple-args* nil)
                 (hairy))))
        (hairy))))

(defun expand-true-false-conditional (true false)
  (let ((arg (expand-next-arg)))
    (flet ((hairy ()
             `(if ,arg
                  (progn
                    ,@(expand-directive-list true))
                  (progn
                    ,@(expand-directive-list false)))))
      (if *only-simple-args*
          (multiple-value-bind (true-guts true-args true-simple)
            (let ((*simple-args* *simple-args*)
                  (*only-simple-args* t))
              (values (expand-directive-list true)
                      *simple-args*
                      *only-simple-args*))
            (multiple-value-bind (false-guts false-args false-simple)
              (let ((*simple-args* *simple-args*)
                    (*only-simple-args* t))
                (values (expand-directive-list false)
                        *simple-args*
                        *only-simple-args*))
              (if (= (length true-args) (length false-args))
                  `(if ,arg
                       (progn
                         ,@true-guts)
                       ,(do ((false false-args (cdr false))
                             (true true-args (cdr true))
                             (bindings nil (cons `(,(caar false) ,(caar true))
                                                 bindings)))
                            ((eq true *simple-args*)
                             (setf *simple-args* true-args)
                             (setf *only-simple-args*
                                   (and true-simple false-simple))
                             (if bindings
                                 `(let ,bindings
                                    ,@false-guts)
                                 `(progn
                                    ,@false-guts)))))
                  (progn
                    (setf *only-simple-args* nil)
                    (hairy)))))
          (hairy)))))

(def-complex-format-directive #\; ()
  (error 'format-error
         :complaint
         "~~; directive not contained within either ~~[...~~] or ~~<...~~>"))

(def-complex-format-directive #\] ()
  (error 'format-error
         :complaint
         "no corresponding open bracket"))

;;;; format directive for up-and-out

(def-format-directive #\^ (colonp atsignp params)
  (when atsignp
    (error 'format-error
           :complaint "cannot use the at-sign modifier with this directive"))
  (when (and colonp (not *up-up-and-out-allowed*))
    (error 'format-error
           :complaint "attempt to use ~~:^ outside a ~~:{...~~} construct"))
  `(when ,(expand-bind-defaults ((arg1 nil) (arg2 nil) (arg3 nil)) params
                                `(cond (,arg3 (<= ,arg1 ,arg2 ,arg3))
                                       (,arg2 (eql ,arg1 ,arg2))
                                       (,arg1 (eql ,arg1 0))
                                       (t ,(if colonp
                                               '(null outside-args)
                                               (progn
                                                 (setf *only-simple-args* nil)
                                                 '(null args))))))
     ,(if colonp
          '(return-from outside-loop nil)
          '(return))))

;;;; format directives for iteration

(def-complex-format-directive #\{ (colonp atsignp params string end directives)
  (let ((close (find-directive directives #\} nil)))
    (unless close
      (error 'format-error
             :complaint "no corresponding close brace"))
    (let* ((closed-with-colon (format-directive-colonp close))
           (posn (position close directives)))
      (labels
        ((compute-insides ()
           (if (zerop posn)
               (if *orig-args-available*
                   `((handler-bind
                       ((format-error
                         (lambda (condition)
                           (error 'format-error
                                  :complaint
                                  "~A~%while processing indirect format string:"
                                  :args (list condition)
                                  :print-banner nil
                                  :control-string ,string
                                  :offset ,(1- end)))))
                       (setf args
                             (%format stream inside-string orig-args args))))
                   (throw 'need-orig-args nil))
               (let ((*up-up-and-out-allowed* colonp))
                 (expand-directive-list (subseq directives 0 posn)))))
         (compute-loop (count)
           (when atsignp
             (setf *only-simple-args* nil))
           `(loop
              ,@(unless closed-with-colon
                  '((when (null args)
                      (return))))
              ,@(when count
                  `((when (and ,count (minusp (decf ,count)))
                      (return))))
              ,@(if colonp
                    (let ((*expander-next-arg-macro* 'expander-next-arg)
                          (*only-simple-args* nil)
                          (*orig-args-available* t))
                      `((let* ((orig-args ,(expand-next-arg))
                               (outside-args args)
                               (args orig-args))
                          (declare (ignorable orig-args outside-args args))
                          (block nil
                            ,@(compute-insides)))))
                    (compute-insides))
              ,@(when closed-with-colon
                  '((when (null args)
                      (return))))))
         (compute-block (count)
           (if colonp
               `(block outside-loop
                  ,(compute-loop count))
               (compute-loop count)))
         (compute-bindings (count)
            (if atsignp
                (compute-block count)
                `(let* ((orig-args ,(expand-next-arg))
                        (args orig-args))
                   (declare (ignorable orig-args args))
                   ,(let ((*expander-next-arg-macro* 'expander-next-arg)
                          (*only-simple-args* nil)
                          (*orig-args-available* t))
                      (compute-block count))))))
        (values (if params
                    (expand-bind-defaults ((count nil)) params
                                          (if (zerop posn)
                                              `(let ((inside-string ,(expand-next-arg)))
                                                 ,(compute-bindings count))
                                              (compute-bindings count)))
                    (if (zerop posn)
                        `(let ((inside-string ,(expand-next-arg)))
                           ,(compute-bindings nil))
                        (compute-bindings nil)))
                (nthcdr (1+ posn) directives))))))

(def-complex-format-directive #\} ()
  (error 'format-error
         :complaint "no corresponding open brace"))

;;;; 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)
    (values
     (if (format-directive-colonp close)
         (multiple-value-bind (prefix per-line-p insides suffix)
           (parse-format-logical-block segments colonp first-semi
                                       close params string end)
           (expand-format-logical-block prefix per-line-p insides
                                        suffix atsignp))
         (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 #\> ()
  (error 'format-error
         :complaint "no corresponding open bracket"))

(defun parse-format-logical-block
  (segments colonp first-semi close params string end)
  (when params
    (error 'format-error
           :complaint "No parameters can be supplied with ~~<...~~:>."
           :offset (caar params)))
  (multiple-value-bind (prefix insides suffix)
    (multiple-value-bind (prefix-default suffix-default)
      (if colonp (values "(" ")") (values "" ""))
      (flet ((extract-string (list prefix-p)
                             (let ((directive (find-if #'format-directive-p list)))
                               (if directive
                                   (error 'format-error
                                          :complaint
                                          "cannot include format directives inside the ~
                                           ~:[suffix~;prefix~] segment of ~~<...~~:>"
                                          :args (list prefix-p)
                                          :offset (1- (format-directive-end directive)))
                                   (apply #'concatenate 'string list)))))
        (case (length segments)
          (0 (values prefix-default nil suffix-default))
          (1 (values prefix-default (car segments) suffix-default))
          (2 (values (extract-string (car segments) t)
                     (cadr segments) suffix-default))
          (3 (values (extract-string (car segments) t)
                     (cadr segments)
                     (extract-string (caddr segments) nil)))
          (t
           (error 'format-error
                  :complaint "too many segments for ~~<...~~:>")))))
    (when (format-directive-atsignp close)
      (setf insides
            (add-fill-style-newlines insides
                                     string
                                     (if first-semi
                                         (format-directive-end first-semi)
                                         end))))
    (values prefix
            (and first-semi (format-directive-atsignp first-semi))
            insides
            suffix)))

(defun add-fill-style-newlines (list string offset &optional last-directive)
  (cond
   (list
    (let ((directive (car list)))
      (cond
       ((simple-string-p directive)
        (let* ((non-space (position #\Space directive :test #'char/=))
               (newlinep (and last-directive
                              (char=
                               (format-directive-character last-directive)
                               #\Newline))))
          (cond
           ((and newlinep non-space)
            (nconc
             (list (subseq directive 0 non-space))
             (add-fill-style-newlines-aux
              (subseq directive non-space) string (+ offset non-space))
             (add-fill-style-newlines
              (cdr list) string (+ offset (length directive)))))
           (newlinep
            (cons directive
                  (add-fill-style-newlines
                   (cdr list) string (+ offset (length directive)))))
           (t
            (nconc (add-fill-style-newlines-aux directive string offset)
                   (add-fill-style-newlines
                    (cdr list) string (+ offset (length directive))))))))
       (t
        (cons directive
              (add-fill-style-newlines
               (cdr list) string
               (format-directive-end directive) directive))))))
   (t nil)))

(defun add-fill-style-newlines-aux (literal string offset)
  (let ((end (length literal))
        (posn 0))
    (collect ((results))
             (loop
               (let ((blank (position #\space literal :start posn)))
                 (when (null blank)
                   (results (subseq literal posn))
                   (return))
                 (let ((non-blank (or (position #\space literal :start blank
                                                :test #'char/=)
                                      end)))
                   (results (subseq literal posn non-blank))
                   (results (make-format-directive
                             :string string :character #\_
                             :start (+ offset non-blank) :end (+ offset non-blank)
                             :colonp t :atsignp nil :params nil))
                   (setf posn non-blank))
                 (when (= posn end)
                   (return))))
             (results))))

(defun parse-format-justification (directives)
  (let ((first-semi nil)
        (close nil)
        (remaining directives))
    (collect ((segments))
             (loop
               (let ((close-or-semi (find-directive remaining #\> t)))
                 (unless close-or-semi
                   (error 'format-error
                          :complaint "no corresponding close bracket"))
                 (let ((posn (position close-or-semi remaining)))
                   (segments (subseq remaining 0 posn))
                   (setf remaining (nthcdr (1+ posn) remaining)))
                 (when (char= (format-directive-character close-or-semi)
                              #\>)
                   (setf close close-or-semi)
                   (return))
                 (unless first-semi
                   (setf first-semi close-or-semi))))
             (values (segments) first-semi close remaining))))

(defmacro expander-pprint-next-arg (string offset)
  `(progn
     (when (null args)
       (error 'format-error
              :complaint "no more arguments"
              :control-string ,string
              :offset ,offset))
     (pprint-pop)
     (pop args)))

(defun expand-format-logical-block (prefix per-line-p insides suffix atsignp)
  `(let ((arg ,(if atsignp 'args (expand-next-arg))))
     ,@(when atsignp
         (setf *only-simple-args* nil)
         '((setf args nil)))
     (pprint-logical-block
      (stream arg
              ,(if per-line-p :per-line-prefix :prefix) ,prefix
              :suffix ,suffix)
      (let ((args arg)
            ,@(unless atsignp
                `((orig-args arg))))
        (declare (ignorable args ,@(unless atsignp '(orig-args))))
        (block nil
          ,@(let ((*expander-next-arg-macro* 'expander-pprint-next-arg)
                  (*only-simple-args* nil)
                  (*orig-args-available*
                   (if atsignp *orig-args-available* t)))
              (expand-directive-list insides)))))))

(defun expand-format-justification (segments colonp atsignp first-semi params)
  (let ((newline-segment-p
         (and first-semi
              (format-directive-colonp first-semi))))
    (expand-bind-defaults
     ((mincol 0) (colinc 1) (minpad 0) (padchar #\space))
     params
     `(let ((segments nil)
            ,@(when newline-segment-p
                '((newline-segment nil)
                  (extra-space 0)
                  (line-len 72))))
        (block nil
          ,@(when newline-segment-p
              `((setf newline-segment
                      (with-output-to-string (stream)
                        ,@(expand-directive-list (pop segments))))
                ,(expand-bind-defaults
                  ((extra 0)
                   (line-len '(ext:line-length stream)))
                  (format-directive-params first-semi)
                  `(setf extra-space ,extra line-len ,line-len))))
          ,@(mapcar (lambda (segment)
                      `(push (with-output-to-string (stream)
                               ,@(expand-directive-list segment))
                             segments))
                    segments))
        (format-justification stream
                              ,@(if newline-segment-p
                                    '(newline-segment extra-space line-len)
                                    '(nil 0 0))
                              segments ,colonp ,atsignp
                              ,mincol ,colinc ,minpad ,padchar)))))

;;;; format directive and support function for user-defined method

(def-format-directive #\/ (string start end colonp atsignp params)
  (let ((symbol (extract-user-fun-name string start end)))
    (collect ((param-names) (bindings))
             (dolist (param-and-offset params)
               (let ((param (cdr param-and-offset)))
                 (let ((param-name (gensym)))
                   (param-names param-name)
                   (bindings `(,param-name
                               ,(case param
                                  (:arg (expand-next-arg))
                                  (:remaining '(length args))
                                  (t param)))))))
             `(let ,(bindings)
                (,symbol stream ,(expand-next-arg) ,colonp ,atsignp
                 ,@(param-names))))))

(defun extract-user-fun-name (string start end)
  (let ((slash (position #\/ string :start start :end (1- end)
                         :from-end t)))
    (unless slash
      (error 'format-error
             :complaint "malformed ~~/ directive"))
    (let* ((name (string-upcase (let ((foo string))
                                  ;; Hack alert: This is to keep the compiler
                                  ;; quiet about deleting code inside the
                                  ;; subseq expansion.
                                  (subseq foo (1+ slash) (1- end)))))
           (first-colon (position #\: name))
           (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)))
      (unless package
        ;; FIXME: should be PACKAGE-ERROR? Could we just use
        ;; FIND-UNDELETED-PACKAGE-OR-LOSE?
        (error 'format-error
               :complaint "no package named ~S"
               :args (list package-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))))

;;; compile-time checking for argument mismatch.  This code is
;;; inspired by that of Gerd Moellmann, and comes decorated with
;;; FIXMEs:
(defun %compiler-walk-format-string (string args)
  (declare (type simple-string string))
  (let ((*default-format-error-control-string* string))
    (macrolet ((incf-both (&optional (increment 1))
                          `(progn
                             (incf min ,increment)
                             (incf max ,increment)))
               (walk-complex-directive (function)
                                       `(multiple-value-bind (min-inc max-inc remaining)
                                          (,function directive directives args)
                                          (incf min min-inc)
                                          (incf max max-inc)
                                          (setq directives remaining))))
      ;; FIXME: these functions take a list of arguments as well as
      ;; the directive stream.  This is to enable possibly some
      ;; limited type checking on FORMAT's arguments, as well as
      ;; simple argument count mismatch checking: when the minimum and
      ;; maximum argument counts are the same at a given point, we
      ;; know which argument is going to be used for a given
      ;; directive, and some (annotated below) require arguments of
      ;; particular types.
      (labels
        ((walk-justification (justification directives args)
                             (declare (ignore args))
                             (let ((*default-format-error-offset*
                                    (1- (format-directive-end justification))))
                               (multiple-value-bind (segments first-semi close remaining)
                                 (parse-format-justification directives)
                                 (declare (ignore segments first-semi))
                                 (cond
                                  ((not (format-directive-colonp close))
                                   (values 0 0 directives))
                                  ((format-directive-atsignp justification)
                                   (values 0 call-arguments-limit directives))
                                  ;; FIXME: here we could assert that the
                                  ;; corresponding argument was a list.
                                  (t (values 1 1 remaining))))))
         (walk-conditional (conditional directives args)
                           (let ((*default-format-error-offset*
                                  (1- (format-directive-end conditional))))
                             (multiple-value-bind (sublists last-semi-with-colon-p remaining)
                               (parse-conditional-directive directives)
                               (declare (ignore last-semi-with-colon-p))
                               (let ((sub-max
                                      (loop for s in sublists
                                        maximize (nth-value
                                                  1 (walk-directive-list s args)))))
                                 (cond
                                  ((format-directive-atsignp conditional)
                                   (values 1 (max 1 sub-max) remaining))
                                  ((loop for p in (format-directive-params conditional)
                                     thereis (or (integerp (cdr p))
                                                 (memq (cdr p) '(:remaining :arg))))
                                   (values 0 sub-max remaining))
                                  ;; FIXME: if not COLONP, then the next argument
                                  ;; must be a number.
                                  (t (values 1 (1+ sub-max) remaining)))))))
         (walk-iteration (iteration directives args)
                         (declare (ignore args))
                         (let ((*default-format-error-offset*
                                (1- (format-directive-end iteration))))
                           (let* ((close (find-directive directives #\} nil))
                                  (posn (or (position close directives)
                                            (error 'format-error
                                                   :complaint "no corresponding close brace")))
                                  (remaining (nthcdr (1+ posn) directives)))
                             ;; FIXME: if POSN is zero, the next argument must be
                             ;; a format control (either a function or a string).
                             (if (format-directive-atsignp iteration)
                                 (values (if (zerop posn) 1 0)
                                         call-arguments-limit
                                         remaining)
                                 ;; FIXME: the argument corresponding to this
                                 ;; directive must be a list.
                                 (let ((nreq (if (zerop posn) 2 1)))
                                   (values nreq nreq remaining))))))
         (walk-directive-list (directives args)
                              (let ((min 0) (max 0))
                                (loop
                                  (let ((directive (pop directives)))
                                    (when (null directive)
                                      (return (values min (min max call-arguments-limit))))
                                    (when (format-directive-p directive)
                                      (incf-both (count :arg (format-directive-params directive)
                                                        :key #'cdr))
                                      (let ((c (format-directive-character directive)))
                                        (cond
                                         ((find c "ABCDEFGORSWX$/")
                                          (incf-both))
                                         ((char= c #\P)
                                          (unless (format-directive-colonp directive)
                                            (incf-both)))
                                         ((or (find c "IT%&|_();>") (char= c #\Newline)))
                                         ;; FIXME: check correspondence of ~( and ~)
                                         ((char= c #\<)
                                          (walk-complex-directive walk-justification))
                                         ((char= c #\[)
                                          (walk-complex-directive walk-conditional))
                                         ((char= c #\{)
                                          (walk-complex-directive walk-iteration))
                                         ((char= c #\?)
                                          ;; FIXME: the argument corresponding to this
                                          ;; directive must be a format control.
                                          (cond
                                           ((format-directive-atsignp directive)
                                            (incf min)
                                            (setq max call-arguments-limit))
                                           (t (incf-both 2))))
                                         (t (throw 'give-up-format-string-walk nil))))))))))
        (catch 'give-up-format-string-walk
          (let ((directives (tokenize-control-string string)))
            (walk-directive-list directives args)))))))

;;; From target-format.lisp.

(in-package #:format)

(defun format (destination control-string &rest format-arguments)
  (etypecase destination
    (null
     (with-output-to-string (stream)
       (%format stream control-string format-arguments)))
    (string
     (with-output-to-string (stream destination)
       (%format stream control-string format-arguments)))
    ((member t)
     (%format *standard-output* control-string format-arguments)
     nil)
    (stream
     (%format (sys:out-synonym-of destination) control-string format-arguments)
     nil)
    (xp::xp-structure
     (%format destination control-string format-arguments)
     nil)))

(defun %format (stream string-or-fun orig-args &optional (args orig-args))
  (if (functionp string-or-fun)
      (apply string-or-fun stream args)
      (catch 'up-and-out
        (let* ((string (etypecase string-or-fun
                         (simple-string
                          string-or-fun)
                         (string
                          (coerce string-or-fun 'simple-string))))
               (*default-format-error-control-string* string)
               (*logical-block-popper* nil))
          (interpret-directive-list stream (tokenize-control-string string)
                                    orig-args args)))))

(defun interpret-directive-list (stream directives orig-args args)
  (if directives
      (let ((directive (car directives)))
        (etypecase directive
          (simple-string
           (write-string directive stream)
           (interpret-directive-list stream (cdr directives) orig-args args))
          (format-directive
           (multiple-value-bind (new-directives new-args)
             (let* ((character (format-directive-character directive))
                    (function
                     (gethash character *format-directive-interpreters*))
                    (*default-format-error-offset*
                     (1- (format-directive-end directive))))
               (unless function
                 (error 'format-error
                        :complaint "unknown format directive ~@[(character: ~A)~]"
                        :args (list (char-name character))))
               (multiple-value-bind (new-directives new-args)
                 (funcall function stream directive
                          (cdr directives) orig-args args)
                 (values new-directives new-args)))
             (interpret-directive-list stream new-directives
                                       orig-args new-args)))))
      args))

;;;; FORMAT directive definition macros and runtime support

(eval-when (:compile-toplevel :execute)

  ;;; This macro is used to extract the next argument from the current arg list.
  ;;; This is the version used by format directive interpreters.
  (defmacro next-arg (&optional offset)
    `(progn
       (when (null args)
         (error 'format-error
                :complaint "no more arguments"
                ,@(when offset
                    `(:offset ,offset))))
       (when *logical-block-popper*
         (funcall *logical-block-popper*))
       (pop args)))

  (defmacro def-complex-format-interpreter (char lambda-list &body body)
    (let ((defun-name
            (intern (concatenate 'string
                                 (let ((name (char-name char)))
                                   (cond (name
                                          (string-capitalize name))
                                         (t
                                          (string char))))
                                 "-FORMAT-DIRECTIVE-INTERPRETER")))
          (directive (gensym))
          (directives (if lambda-list (car (last lambda-list)) (gensym))))
      `(progn
         (defun ,defun-name (stream ,directive ,directives orig-args args)
           (declare (ignorable stream orig-args args))
           ,@(if lambda-list
                 `((let ,(mapcar (lambda (var)
                                   `(,var
                                     (,(sys::symbolicate "FORMAT-DIRECTIVE-" var)
                                      ,directive)))
                                 (butlast lambda-list))
                     (values (progn ,@body) args)))
                 `((declare (ignore ,directive ,directives))
                   ,@body)))
         (%set-format-directive-interpreter ,char #',defun-name))))

  (defmacro def-format-interpreter (char lambda-list &body body)
    (let ((directives (gensym)))
      `(def-complex-format-interpreter ,char (,@lambda-list ,directives)
         ,@body
         ,directives)))

  (defmacro interpret-bind-defaults (specs params &body body)
    (sys::once-only ((params params))
                    (collect ((bindings))
                             (dolist (spec specs)
                               (destructuring-bind (var default) spec
                                                   (bindings `(,var (let* ((param-and-offset (pop ,params))
                                                                           (offset (car param-and-offset))
                                                                           (param (cdr param-and-offset)))
                                                                      (case param
                                                                        (:arg (or (next-arg offset) ,default))
                                                                        (:remaining (length args))
                                                                        ((nil) ,default)
                                                                        (t param)))))))
                             `(let* ,(bindings)
                                (when ,params
                                  (error 'format-error
                                         :complaint
                                         "too many parameters, expected no more than ~W"
                                         :args (list ,(length specs))
                                         :offset (caar ,params)))
                                ,@body))))

  ) ; EVAL-WHEN

;;;; format interpreters and support functions for simple output

(defun format-write-field (stream string mincol colinc minpad padchar padleft)
  (unless padleft
    (write-string string stream))
  (dotimes (i minpad)
    (write-char padchar stream))
  ;; As of sbcl-0.6.12.34, we could end up here when someone tries to
  ;; print e.g. (FORMAT T "~F" "NOTFLOAT"), in which case ANSI says
  ;; we're supposed to soldier on bravely, and so we have to deal with
  ;; the unsupplied-MINCOL-and-COLINC case without blowing up.
  (when (and mincol colinc)
    (do ((chars (+ (length string) (max minpad 0)) (+ chars colinc)))
        ((>= chars mincol))
      (dotimes (i colinc)
        (write-char padchar stream))))
  (when padleft
    (write-string string stream)))

(defun format-princ (stream arg colonp atsignp mincol colinc minpad padchar)
  (format-write-field stream
                      (if (or arg (not colonp))
                          (princ-to-string arg)
                          "()")
                      mincol colinc minpad padchar atsignp))

(def-format-interpreter #\A (colonp atsignp params)
  (if params
      (interpret-bind-defaults ((mincol 0) (colinc 1) (minpad 0)
                                (padchar #\space))
                               params
                               (format-princ stream (next-arg) colonp atsignp
                                             mincol colinc minpad padchar))
      (princ (if colonp (or (next-arg) "()") (next-arg)) stream)))

(defun format-prin1 (stream arg colonp atsignp mincol colinc minpad padchar)
  (format-write-field stream
                      (if (or arg (not colonp))
                          (prin1-to-string arg)
                          "()")
                      mincol colinc minpad padchar atsignp))

(def-format-interpreter #\S (colonp atsignp params)
  (cond (params
         (interpret-bind-defaults ((mincol 0) (colinc 1) (minpad 0)
                                   (padchar #\space))
                                  params
                                  (format-prin1 stream (next-arg) colonp atsignp
                                                mincol colinc minpad padchar)))
        (colonp
         (let ((arg (next-arg)))
           (if arg
               (prin1 arg stream)
               (princ "()" stream))))
        (t
         (prin1 (next-arg) stream))))

(def-format-interpreter #\C (colonp atsignp params)
  (interpret-bind-defaults () params
                           (if colonp
                               (format-print-named-character (next-arg) stream)
                               (if atsignp
                                   (prin1 (next-arg) stream)
                                   (write-char (next-arg) stream)))))

(defun format-print-named-character (char stream)
  (let* ((name (char-name char)))
    (cond ((and name
                ;;; Fixes ANSI-TEST FORMATTER.C.2A and FORMAT.C.2A
                (not (eq 160 (char-code char))))
           (write-string (string-capitalize name) stream))
          (t
           (write-char char stream)))))

(def-format-interpreter #\W (colonp atsignp params)
  (interpret-bind-defaults () params
                           (let ((*print-pretty* (or colonp *print-pretty*))
                                 (*print-level* (unless atsignp *print-level*))
                                 (*print-length* (unless atsignp *print-length*)))
                             (sys::output-object (next-arg) stream))))

;;;; format interpreters and support functions for integer output

;;; FORMAT-PRINT-NUMBER does most of the work for the numeric printing
;;; directives. The parameters are interpreted as defined for ~D.
(defun format-print-integer (stream number print-commas-p print-sign-p
                                    radix mincol padchar commachar commainterval)
  (let ((*print-base* radix)
        (*print-radix* nil))
    (if (integerp number)
        (let* ((text (princ-to-string (abs number)))
               (commaed (if print-commas-p
                            (format-add-commas text commachar commainterval)
                            text))
               (signed (cond ((minusp number)
                              (concatenate 'string "-" commaed))
                             (print-sign-p
                              (concatenate 'string "+" commaed))
                             (t commaed))))
          ;; colinc = 1, minpad = 0, padleft = t
          (format-write-field stream signed mincol 1 0 padchar t))
        (princ number stream))))

(defun format-add-commas (string commachar commainterval)
  (let ((length (length string)))
    (multiple-value-bind (commas extra) (truncate (1- length) commainterval)
      (let ((new-string (make-string (+ length commas)))
            (first-comma (1+ extra)))
        (replace new-string string :end1 first-comma :end2 first-comma)
        (do ((src first-comma (+ src commainterval))
             (dst first-comma (+ dst commainterval 1)))
            ((= src length))
          (setf (schar new-string dst) commachar)
          (replace new-string string :start1 (1+ dst)
                   :start2 src :end2 (+ src commainterval)))
        new-string))))

;;; FIXME: This is only needed in this file, could be defined with
;;; SB!XC:DEFMACRO inside EVAL-WHEN
(defmacro interpret-format-integer (base)
  `(if (or colonp atsignp params)
       (interpret-bind-defaults
        ((mincol 0) (padchar #\space) (commachar #\,) (commainterval 3))
        params
        (format-print-integer stream (next-arg) colonp atsignp ,base mincol
                              padchar commachar commainterval))
       (write (next-arg) :stream stream :base ,base :radix nil :escape nil)))

(def-format-interpreter #\D (colonp atsignp params)
  (interpret-format-integer 10))

(def-format-interpreter #\B (colonp atsignp params)
  (interpret-format-integer 2))

(def-format-interpreter #\O (colonp atsignp params)
  (interpret-format-integer 8))

(def-format-interpreter #\X (colonp atsignp params)
  (interpret-format-integer 16))

(def-format-interpreter #\R (colonp atsignp params)
  (interpret-bind-defaults
   ((base nil) (mincol 0) (padchar #\space) (commachar #\,)
    (commainterval 3))
   params
   (let ((arg (next-arg)))
     (if base
         (format-print-integer stream arg colonp atsignp base mincol
                               padchar commachar commainterval)
         (if atsignp
             (if colonp
                 (format-print-old-roman stream arg)
                 (format-print-roman stream arg))
             (if colonp
                 (format-print-ordinal stream arg)
                 (format-print-cardinal stream arg)))))))

(defparameter *cardinal-ones*
  #(nil "one" "two" "three" "four" "five" "six" "seven" "eight" "nine"))

(defparameter *cardinal-tens*
  #(nil nil "twenty" "thirty" "forty"
        "fifty" "sixty" "seventy" "eighty" "ninety"))

(defparameter *cardinal-teens*
  #("ten" "eleven" "twelve" "thirteen" "fourteen"  ;;; RAD
          "fifteen" "sixteen" "seventeen" "eighteen" "nineteen"))

(defparameter *cardinal-periods*
  #("" " thousand" " million" " billion" " trillion" " quadrillion"
       " quintillion" " sextillion" " septillion" " octillion" " nonillion"
       " decillion" " undecillion" " duodecillion" " tredecillion"
       " quattuordecillion" " quindecillion" " sexdecillion" " septendecillion"
       " octodecillion" " novemdecillion" " vigintillion"))

(defparameter *ordinal-ones*
  #(nil "first" "second" "third" "fourth"
        "fifth" "sixth" "seventh" "eighth" "ninth"))

(defparameter *ordinal-tens*
  #(nil "tenth" "twentieth" "thirtieth" "fortieth"
        "fiftieth" "sixtieth" "seventieth" "eightieth" "ninetieth"))

(defun format-print-small-cardinal (stream n)
  (multiple-value-bind (hundreds rem) (truncate n 100)
    (when (plusp hundreds)
      (write-string (svref *cardinal-ones* hundreds) stream)
      (write-string " hundred" stream)
      (when (plusp rem)
        (write-char #\space stream)))
    (when (plusp rem)
      (multiple-value-bind (tens ones) (truncate rem 10)
        (cond ((< 1 tens)
               (write-string (svref *cardinal-tens* tens) stream)
               (when (plusp ones)
                 (write-char #\- stream)
                 (write-string (svref *cardinal-ones* ones) stream)))
              ((= tens 1)
               (write-string (svref *cardinal-teens* ones) stream))
              ((plusp ones)
               (write-string (svref *cardinal-ones* ones) stream)))))))

(defun format-print-cardinal (stream n)
  (cond ((minusp n)
         (write-string "negative " stream)
         (format-print-cardinal-aux stream (- n) 0 n))
        ((zerop n)
         (write-string "zero" stream))
        (t
         (format-print-cardinal-aux stream n 0 n))))

(defun format-print-cardinal-aux (stream n period err)
  (multiple-value-bind (beyond here) (truncate n 1000)
    (unless (<= period 20)
      (error "number too large to print in English: ~:D" err))
    (unless (zerop beyond)
      (format-print-cardinal-aux stream beyond (1+ period) err))
    (unless (zerop here)
      (unless (zerop beyond)
        (write-char #\space stream))
      (format-print-small-cardinal stream here)
      (write-string (svref *cardinal-periods* period) stream))))

(defun format-print-ordinal (stream n)
  (when (minusp n)
    (write-string "negative " stream))
  (let ((number (abs n)))
    (multiple-value-bind (top bot) (truncate number 100)
      (unless (zerop top)
        (format-print-cardinal stream (- number bot)))
      (when (and (plusp top) (plusp bot))
        (write-char #\space stream))
      (multiple-value-bind (tens ones) (truncate bot 10)
        (cond ((= bot 12) (write-string "twelfth" stream))
              ((= tens 1)
               (write-string (svref *cardinal-teens* ones) stream);;;RAD
               (write-string "th" stream))
              ((and (zerop tens) (plusp ones))
               (write-string (svref *ordinal-ones* ones) stream))
              ((and (zerop ones)(plusp tens))
               (write-string (svref *ordinal-tens* tens) stream))
              ((plusp bot)
               (write-string (svref *cardinal-tens* tens) stream)
               (write-char #\- stream)
               (write-string (svref *ordinal-ones* ones) stream))
              ((plusp number)
               (write-string "th" stream))
              (t
               (write-string "zeroth" stream)))))))

;;; Print Roman numerals

(defun format-print-old-roman (stream n)
  (unless (< 0 n 5000)
    (error "Number too large to print in old Roman numerals: ~:D" n))
  (do ((char-list '(#\D #\C #\L #\X #\V #\I) (cdr char-list))
       (val-list '(500 100 50 10 5 1) (cdr val-list))
       (cur-char #\M (car char-list))
       (cur-val 1000 (car val-list))
       (start n (do ((i start (progn
                                (write-char cur-char stream)
                                (- i cur-val))))
                    ((< i cur-val) i))))
      ((zerop start))))

(defun format-print-roman (stream n)
  (unless (< 0 n 4000)
    (error "Number too large to print in Roman numerals: ~:D" n))
  (do ((char-list '(#\D #\C #\L #\X #\V #\I) (cdr char-list))
       (val-list '(500 100 50 10 5 1) (cdr val-list))
       (sub-chars '(#\C #\X #\X #\I #\I) (cdr sub-chars))
       (sub-val '(100 10 10 1 1 0) (cdr sub-val))
       (cur-char #\M (car char-list))
       (cur-val 1000 (car val-list))
       (cur-sub-char #\C (car sub-chars))
       (cur-sub-val 100 (car sub-val))
       (start n (do ((i start (progn
                                (write-char cur-char stream)
                                (- i cur-val))))
                    ((< i cur-val)
                     (cond ((<= (- cur-val cur-sub-val) i)
                            (write-char cur-sub-char stream)
                            (write-char cur-char stream)
                            (- i (- cur-val cur-sub-val)))
                           (t i))))))
      ((zerop start))))

;;;; plural

(def-format-interpreter #\P (colonp atsignp params)
  (interpret-bind-defaults () params
                           (let ((arg (if colonp
                                          (if (eq orig-args args)
                                              (error 'format-error
                                                     :complaint "no previous argument")
                                              (do ((arg-ptr orig-args (cdr arg-ptr)))
                                                  ((eq (cdr arg-ptr) args)
                                                   (car arg-ptr))))
                                          (next-arg))))
                             (if atsignp
                                 (write-string (if (eql arg 1) "y" "ies") stream)
                                 (unless (eql arg 1) (write-char #\s stream))))))

;;;; format interpreters and support functions for floating point output

(defun decimal-string (n)
  (write-to-string n :base 10 :radix nil :escape nil))

(def-format-interpreter #\F (colonp atsignp params)
  (when colonp
    (error 'format-error
           :complaint
           "cannot specify the colon modifier with this directive"))
  (interpret-bind-defaults ((w nil) (d nil) (k nil) (ovf nil) (pad #\space))
                           params
                           (format-fixed stream (next-arg) w d k ovf pad atsignp)))

(defun format-fixed (stream number w d k ovf pad atsign)
  (if (numberp number)
      (if (floatp number)
          (format-fixed-aux stream number w d k ovf pad atsign)
          (if (rationalp number)
              (format-fixed-aux stream
                                (coerce number 'single-float)
                                w d k ovf pad atsign)
              (format-write-field stream
                                  (decimal-string number)
                                  w 1 0 #\space t)))
      (format-princ stream number nil nil w 1 0 pad)))

;;; We return true if we overflowed, so that ~G can output the overflow char
;;; instead of spaces.
(defun format-fixed-aux (stream number w d k ovf pad atsign)
  (cond
   ((and (floatp number)
         (or (sys:float-infinity-p number)
             (sys:float-nan-p number)))
    (prin1 number stream)
    nil)
   (t
    (let ((spaceleft w))
      (when (and w (or atsign (minusp (float-sign number))))
        (decf spaceleft))
      (multiple-value-bind (str len lpoint tpoint)
        (sys::flonum-to-string (abs number) spaceleft d k)
        ;;if caller specifically requested no fraction digits, suppress the
        ;;optional trailing zero
        (when (and d (zerop d))
          (setf tpoint nil))
        (when w
          (decf spaceleft len)
          ;;optional leading zero
          (when lpoint
            (if (or (> spaceleft 0) tpoint) ;force at least one digit
                (decf spaceleft)
                (setq lpoint nil)))
          ;;optional trailing zero
          (when tpoint
            (if (> spaceleft 0)
                (decf spaceleft)
                (setq tpoint nil))))
        (cond ((and w (< spaceleft 0) ovf)
               ;;field width overflow
               (dotimes (i w) (write-char ovf stream))
               t)
              (t
               (when w (dotimes (i spaceleft) (write-char pad stream)))
               (cond ((minusp (float-sign number))
                      (write-char #\- stream))
                     (atsign
                      (write-char #\+ stream)))
               (when lpoint (write-char #\0 stream))
               (write-string str stream)
               (when tpoint (write-char #\0 stream))
               nil)))))))

(def-format-interpreter #\E (colonp atsignp params)
  (when colonp
    (error 'format-error
           :complaint
           "cannot specify the colon modifier with this directive"))
  (interpret-bind-defaults
   ((w nil) (d nil) (e nil) (k 1) (ovf nil) (pad #\space) (mark nil))
   params
   (format-exponential stream (next-arg) w d e k ovf pad mark atsignp)))

(defun format-exponential (stream number w d e k ovf pad marker atsign)
  (if (numberp number)
      (if (floatp number)
          (format-exp-aux stream number w d e k ovf pad marker atsign)
          (if (rationalp number)
              (format-exp-aux stream
                              (coerce number 'single-float)
                              w d e k ovf pad marker atsign)
              (format-write-field stream
                                  (decimal-string number)
                                  w 1 0 #\space t)))
      (format-princ stream number nil nil w 1 0 pad)))

(defun format-exponent-marker (number)
  (if (typep number *read-default-float-format*)
      #\e
      (typecase number
        (single-float #\f)
        (double-float #\d)
        (short-float #\s)
        (long-float #\l))))

;;; Here we prevent the scale factor from shifting all significance out of
;;; a number to the right. We allow insignificant zeroes to be shifted in
;;; to the left right, athough it is an error to specify k and d such that this
;;; occurs. Perhaps we should detect both these condtions and flag them as
;;; errors. As for now, we let the user get away with it, and merely guarantee
;;; that at least one significant digit will appear.

;;; Raymond Toy writes: The Hyperspec seems to say that the exponent
;;; marker is always printed. Make it so. Also, the original version
;;; causes errors when printing infinities or NaN's. The Hyperspec is
;;; silent here, so let's just print out infinities and NaN's instead
;;; of causing an error.
(defun format-exp-aux (stream number w d e k ovf pad marker atsign)
  (if (and (floatp number)
           (or (sys::float-infinity-p number)
               (sys::float-nan-p number)))
      (prin1 number stream)
      (multiple-value-bind (num expt) (sys::scale-exponent (abs number))
        (let* ((expt (- expt k))
               (estr (decimal-string (abs expt)))
               (elen (if e (max (length estr) e) (length estr)))
               (fdig (if d (if (plusp k) (1+ (- d k)) d) nil))
               (fmin (if (minusp k) (- 1 k) nil))
               (spaceleft (if w
                              (- w 2 elen
                                 (if (or atsign (minusp number))
                                     1 0))
                              nil)))
          (if (and w ovf e (> elen e)) ;exponent overflow
              (dotimes (i w) (write-char ovf stream))
              (multiple-value-bind (fstr flen lpoint)
                (sys::flonum-to-string num spaceleft fdig k fmin)
                (when w
                  (decf spaceleft flen)
                  (when lpoint
                    (if (> spaceleft 0)
                        (decf spaceleft)
                        (setq lpoint nil))))
                (cond ((and w (< spaceleft 0) ovf)
                       ;;significand overflow
                       (dotimes (i w) (write-char ovf stream)))
                      (t (when w
                           (dotimes (i spaceleft) (write-char pad stream)))
                         (if (minusp number)
                             (write-char #\- stream)
                             (if atsign (write-char #\+ stream)))
                         (when lpoint (write-char #\0 stream))
                         (write-string fstr stream)
                         (write-char (if marker
                                         marker
                                         (format-exponent-marker number))
                                     stream)
                         (write-char (if (minusp expt) #\- #\+) stream)
                         (when e
                           ;;zero-fill before exponent if necessary
                           (dotimes (i (- e (length estr)))
                             (write-char #\0 stream)))
                         (write-string estr stream)))))))))

(def-format-interpreter #\G (colonp atsignp params)
  (when colonp
    (error 'format-error
           :complaint
           "cannot specify the colon modifier with this directive"))
  (interpret-bind-defaults
   ((w nil) (d nil) (e nil) (k nil) (ovf nil) (pad #\space) (mark nil))
   params
   (format-general stream (next-arg) w d e k ovf pad mark atsignp)))

(defun format-general (stream number w d e k ovf pad marker atsign)
  (if (numberp number)
      (if (floatp number)
          (format-general-aux stream number w d e k ovf pad marker atsign)
          (if (rationalp number)
              (format-general-aux stream
                                  (coerce number 'single-float)
                                  w d e k ovf pad marker atsign)
              (format-write-field stream
                                  (decimal-string number)
                                  w 1 0 #\space t)))
      (format-princ stream number nil nil w 1 0 pad)))

;;; Raymond Toy writes: same change as for format-exp-aux
(defun format-general-aux (stream number w d e k ovf pad marker atsign)
  (if (and (floatp number)
           (or (sys::float-infinity-p number)
               (sys::float-nan-p number)))
      (prin1 number stream)
      (multiple-value-bind (ignore n) (sys::scale-exponent (abs number))
        (declare (ignore ignore))
        ;; KLUDGE: Default d if omitted. The procedure is taken directly from
        ;; the definition given in the manual, and is not very efficient, since
        ;; we generate the digits twice. Future maintainers are encouraged to
        ;; improve on this. -- rtoy?? 1998??
        (unless d
          (multiple-value-bind (str len)
            (sys::flonum-to-string (abs number))
            (declare (ignore str))
            (let ((q (if (= len 1) 1 (1- len))))
              (setq d (max q (min n 7))))))
        (let* ((ee (if e (+ e 2) 4))
               (ww (if w (- w ee) nil))
               (dd (- d n)))
          (cond ((<= 0 dd d)
                 (let ((char (if (format-fixed-aux stream number ww dd nil
                                                   ovf pad atsign)
                                 ovf
                                 #\space)))
                   (dotimes (i ee) (write-char char stream))))
                (t
                 (format-exp-aux stream number w d e (or k 1)
                                 ovf pad marker atsign)))))))

(def-format-interpreter #\$ (colonp atsignp params)
  (interpret-bind-defaults ((d 2) (n 1) (w 0) (pad #\space)) params
                           (format-dollars stream (next-arg) d n w pad colonp atsignp)))

(defun format-dollars (stream number d n w pad colon atsign)
  (when (rationalp number)
    ;; This coercion to SINGLE-FLOAT seems as though it gratuitously
    ;; loses precision (why not LONG-FLOAT?) but it's the default
    ;; behavior in the ANSI spec, so in some sense it's the right
    ;; thing, and at least the user shouldn't be surprised.
    (setq number (coerce number 'single-float)))
  (if (floatp number)
      (let* ((signstr (if (minusp number) "-" (if atsign "+" "")))
             (signlen (length signstr)))
        (multiple-value-bind (str strlen ig2 ig3 pointplace)
          (sys::flonum-to-string (abs number) nil d nil)
          (declare (ignore ig2 ig3 strlen))
          (when colon
            (write-string signstr stream))
          (dotimes (i (- w signlen (max n pointplace) 1 d))
            (write-char pad stream))
          (unless colon
            (write-string signstr stream))
          (dotimes (i (- n pointplace))
            (write-char #\0 stream))
          (write-string str stream)))
      (format-write-field stream
                          (decimal-string number)
                          w 1 0 #\space t)))

;;;; FORMAT interpreters and support functions for line/page breaks etc.

(def-format-interpreter #\% (colonp atsignp params)
  (when (or colonp atsignp)
    (error 'format-error
           :complaint
           "cannot specify either colon or atsign for this directive"))
  (interpret-bind-defaults ((count 1)) params
                           (dotimes (i count)
                             (terpri stream))))

(def-format-interpreter #\& (colonp atsignp params)
  (when (or colonp atsignp)
    (error 'format-error
           :complaint
           "cannot specify either colon or atsign for this directive"))
  (interpret-bind-defaults ((count 1)) params
                           (fresh-line stream)
                           (dotimes (i (1- count))
                             (terpri stream))))

(def-format-interpreter #\| (colonp atsignp params)
  (when (or colonp atsignp)
    (error 'format-error
           :complaint
           "cannot specify either colon or atsign for this directive"))
  (interpret-bind-defaults ((count 1)) params
                           (dotimes (i count)
                             (write-char (code-char sys::form-feed-char-code) stream))))

(def-format-interpreter #\~ (colonp atsignp params)
  (when (or colonp atsignp)
    (error 'format-error
           :complaint
           "cannot specify either colon or atsign for this directive"))
  (interpret-bind-defaults ((count 1)) params
                           (dotimes (i count)
                             (write-char #\~ stream))))

(def-complex-format-interpreter #\newline (colonp atsignp params directives)
  (when (and colonp atsignp)
    (error 'format-error
           :complaint
           "cannot specify both colon and atsign for this directive"))
  (interpret-bind-defaults () params
                           (when atsignp
                             (write-char #\newline stream)))
  (if (and (not colonp)
           directives
           (simple-string-p (car directives)))
      (cons (string-left-trim *format-whitespace-chars*
                              (car directives))
            (cdr directives))
      directives))

;;;; format interpreters and support functions for tabs and simple pretty
;;;; printing

(def-format-interpreter #\T (colonp atsignp params)
  (if colonp
      (interpret-bind-defaults ((n 1) (m 1)) params
                               (pprint-tab (if atsignp :section-relative :section) n m stream))
      (if atsignp
          (interpret-bind-defaults ((colrel 1) (colinc 1)) params
                                   (format-relative-tab stream colrel colinc))
          (interpret-bind-defaults ((colnum 1) (colinc 1)) params
                                   (format-absolute-tab stream colnum colinc)))))

(defun output-spaces (stream n)
  (let ((spaces #.(make-string 100 :initial-element #\space)))
    (loop
      (when (< n (length spaces))
        (return))
      (write-string spaces stream)
      (decf n (length spaces)))
    (write-string spaces stream :end n)))

(defun format-relative-tab (stream colrel colinc)
  (if (xp::xp-structure-p stream)
      (pprint-tab :line-relative colrel colinc stream)
      (let* ((cur (charpos stream))
             (spaces (if (and cur (plusp colinc))
                         (- (* (ceiling (+ cur colrel) colinc) colinc) cur)
                         colrel)))
        (output-spaces stream spaces))))

(defun format-absolute-tab (stream colnum colinc)
  (if (xp::xp-structure-p stream)
      (pprint-tab :line colnum colinc stream)
      (let ((cur (charpos stream)))
        (cond ((null cur)
               (write-string "  " stream))
              ((< cur colnum)
               (output-spaces stream (- colnum cur)))
              (t
               (unless (zerop colinc)
                 (output-spaces stream
                                (- colinc (rem (- cur colnum) colinc)))))))))

(def-format-interpreter #\_ (colonp atsignp params)
  (interpret-bind-defaults () params
                           (pprint-newline (if colonp
                                               (if atsignp
                                                   :mandatory
                                                   :fill)
                                               (if atsignp
                                                   :miser
                                                   :linear))
                                           stream)))

(def-format-interpreter #\I (colonp atsignp params)
  (when atsignp
    (error 'format-error
           :complaint "cannot specify the at-sign modifier"))
  (interpret-bind-defaults ((n 0)) params
                           (pprint-indent (if colonp :current :block) n stream)))

;;;; format interpreter for ~*

(def-format-interpreter #\* (colonp atsignp params)
  (if atsignp
      (if colonp
          (error 'format-error
                 :complaint "cannot specify both colon and at-sign")
          (interpret-bind-defaults ((posn 0)) params
                                   (if (<= 0 posn (length orig-args))
                                       (setf args (nthcdr posn orig-args))
                                       (error 'format-error
                                              :complaint "Index ~W is out of bounds. (It should ~
                                              have been between 0 and ~W.)"
                                              :args (list posn (length orig-args))))))
      (if colonp
          (interpret-bind-defaults ((n 1)) params
                                   (do ((cur-posn 0 (1+ cur-posn))
                                        (arg-ptr orig-args (cdr arg-ptr)))
                                       ((eq arg-ptr args)
                                        (let ((new-posn (- cur-posn n)))
                                          (if (<= 0 new-posn (length orig-args))
                                              (setf args (nthcdr new-posn orig-args))
                                              (error 'format-error
                                                     :complaint
                                                     "Index ~W is out of bounds. (It should
                                                      have been between 0 and ~W.)"
                                                     :args
                                                     (list new-posn (length orig-args))))))))
          (interpret-bind-defaults ((n 1)) params
                                   (dotimes (i n)
                                     (next-arg))))))

;;;; format interpreter for indirection

(def-format-interpreter #\? (colonp atsignp params string end)
  (when colonp
    (error 'format-error
           :complaint "cannot specify the colon modifier"))
  (interpret-bind-defaults () params
                           (handler-bind
                             ((format-error
                               (lambda (condition)
                                 (error 'format-error
                                        :complaint
                                        "~A~%while processing indirect format string:"
                                        :args (list condition)
                                        :print-banner nil
                                        :control-string string
                                        :offset (1- end)))))
                             (if atsignp
                                 (setf args (%format stream (next-arg) orig-args args))
                                 (%format stream (next-arg) (next-arg))))))

;;;; format interpreters for capitalization

(def-complex-format-interpreter #\( (colonp atsignp params directives)
  (let ((close (find-directive directives #\) nil)))
    (unless close
      (error 'format-error
             :complaint "no corresponding close paren"))
    (interpret-bind-defaults () params
                             (let* ((posn (position close directives))
                                    (before (subseq directives 0 posn))
                                    (after (nthcdr (1+ posn) directives))
                                    (stream (sys::make-case-frob-stream 
                                             (if (typep stream 'xp::xp-structure)
                                                 (xp::base-stream stream)
                                                 stream)
                                             (if colonp
                                                 (if atsignp
                                                     :upcase
                                                     :capitalize)
                                                 (if atsignp
                                                     :capitalize-first
                                                     :downcase)))))
                               (setf args (interpret-directive-list stream before orig-args args))
                               after))))

(def-complex-format-interpreter #\) ()
  (error 'format-error
         :complaint "no corresponding open paren"))

;;;; format interpreters and support functions for conditionalization

(def-complex-format-interpreter #\[ (colonp atsignp params directives)
  (multiple-value-bind (sublists last-semi-with-colon-p remaining)
    (parse-conditional-directive directives)
    (setf args
          (if atsignp
              (if colonp
                  (error 'format-error
                         :complaint
                         "cannot specify both the colon and at-sign modifiers")
                  (if (cdr sublists)
                      (error 'format-error
                             :complaint
                             "can only specify one section")
                      (interpret-bind-defaults () params
                                               (let ((prev-args args)
                                                     (arg (next-arg)))
                                                 (if arg
                                                     (interpret-directive-list stream
                                                                               (car sublists)
                                                                               orig-args
                                                                               prev-args)
                                                     args)))))
              (if colonp
                  (if (= (length sublists) 2)
                      (interpret-bind-defaults () params
                                               (if (next-arg)
                                                   (interpret-directive-list stream (car sublists)
                                                                             orig-args args)
                                                   (interpret-directive-list stream (cadr sublists)
                                                                             orig-args args)))
                      (error 'format-error
                             :complaint
                             "must specify exactly two sections"))
                  (interpret-bind-defaults ((index (next-arg))) params
                                           (let* ((default (and last-semi-with-colon-p
                                                                (pop sublists)))
                                                  (last (1- (length sublists)))
                                                  (sublist
                                                   (if (<= 0 index last)
                                                       (nth (- last index) sublists)
                                                       default)))
                                             (interpret-directive-list stream sublist orig-args
                                                                       args))))))
    remaining))

(def-complex-format-interpreter #\; ()
  (error 'format-error
         :complaint
         "~~; not contained within either ~~[...~~] or ~~<...~~>"))

(def-complex-format-interpreter #\] ()
  (error 'format-error
         :complaint
         "no corresponding open bracket"))

;;;; format interpreter for up-and-out

(defvar *outside-args*)

(def-format-interpreter #\^ (colonp atsignp params)
  (when atsignp
    (error 'format-error
           :complaint "cannot specify the at-sign modifier"))
  (when (and colonp (not *up-up-and-out-allowed*))
    (error 'format-error
           :complaint "attempt to use ~~:^ outside a ~~:{...~~} construct"))
  (when (interpret-bind-defaults ((arg1 nil) (arg2 nil) (arg3 nil)) params
          (cond (arg3 (<= arg1 arg2 arg3))
                (arg2 (eql arg1 arg2))
                (arg1 (eql arg1 0))
                (t (if colonp
                       (null *outside-args*)
                       (null args)))))
    (throw (if colonp 'up-up-and-out 'up-and-out)
           args)))

;;;; format interpreters for iteration

(def-complex-format-interpreter #\{
  (colonp atsignp params string end directives)
  (let ((close (find-directive directives #\} nil)))
    (unless close
      (error 'format-error
             :complaint
             "no corresponding close brace"))
    (interpret-bind-defaults ((max-count nil)) params
      (let* ((closed-with-colon (format-directive-colonp close))
             (posn (position close directives))
             (insides (if (zerop posn)
                          (next-arg)
                          (subseq directives 0 posn)))
             (*up-up-and-out-allowed* colonp))
        (labels
            ((do-guts (orig-args args)
                      (if (zerop posn)
                          (handler-bind
                            ((format-error
                              (lambda (condition)
                                (error
                                 'format-error
                                 :complaint
                                 "~A~%while processing indirect format string:"
                                 :args (list condition)
                                 :print-banner nil
                                 :control-string string
                                 :offset (1- end)))))
                            (%format stream insides orig-args args))
                          (interpret-directive-list stream insides
                                                    orig-args args)))
             (bind-args (orig-args args)
                        (if colonp
                            (let* ((arg (next-arg))
                                   (*logical-block-popper* nil)
                                   (*outside-args* args))
                              (catch 'up-and-out
                                (do-guts arg arg))
                              args)
                            (do-guts orig-args args)))
             (do-loop (orig-args args)
                      (catch (if colonp 'up-up-and-out 'up-and-out)
                        (loop
                          (when (and (not closed-with-colon) (null args))
                            (return))
                          (when (and max-count (minusp (decf max-count)))
                            (return))
                          (setf args (bind-args orig-args args))
                          (when (and closed-with-colon (null args))
                            (return)))
                        args)))
          (if atsignp
              (setf args (do-loop orig-args args))
              (let ((arg (next-arg))
                    (*logical-block-popper* nil))
                (do-loop arg arg)))
          (nthcdr (1+ posn) directives))))))

(def-complex-format-interpreter #\} ()
  (error 'format-error
         :complaint "no corresponding open brace"))

;;;; format interpreters and support functions for justification

(def-complex-format-interpreter #\<
  (colonp atsignp params string end directives)
  (multiple-value-bind (segments first-semi close remaining)
    (parse-format-justification directives)
    (setf args
          (if (format-directive-colonp close)
              (multiple-value-bind (prefix per-line-p insides suffix)
                (parse-format-logical-block segments colonp first-semi
                                            close params string end)
                (interpret-format-logical-block stream orig-args args
                                                prefix per-line-p insides
                                                suffix atsignp))
              (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)))
                (interpret-format-justification stream orig-args args
                                                segments colonp atsignp
                                                first-semi params))))
    remaining))

(defun interpret-format-justification
  (stream orig-args args segments colonp atsignp first-semi params)
  (interpret-bind-defaults
   ((mincol 0) (colinc 1) (minpad 0) (padchar #\space))
   params
   (let ((newline-string nil)
         (strings nil)
         (extra-space 0)
         (line-len 0))
     (setf args
           (catch 'up-and-out
             (when (and first-semi (format-directive-colonp first-semi))
               (interpret-bind-defaults
                ((extra 0)
                 (len (ext:line-length stream)))
                (format-directive-params first-semi)
                (setf newline-string
                      (with-output-to-string (stream)
                        (setf args
                              (interpret-directive-list stream
                                                        (pop segments)
                                                        orig-args
                                                        args))))
                (setf extra-space extra)
                (setf line-len len)))
             (dolist (segment segments)
               (push (with-output-to-string (stream)
                       (setf args
                             (interpret-directive-list stream segment
                                                       orig-args args)))
                     strings))
             args))
     (format-justification stream newline-string extra-space line-len strings
                           colonp atsignp mincol colinc minpad padchar)))
  args)

(defun format-justification (stream newline-prefix extra-space line-len strings
                                    pad-left pad-right mincol colinc minpad padchar)
  (setf strings (reverse strings))
  (let* ((num-gaps (+ (1- (length strings))
                      (if pad-left 1 0)
                      (if pad-right 1 0)))
         (chars (+ (* num-gaps minpad)
                   (loop
                     for string in strings
                     summing (length string))))
         (length (if (> chars mincol)
                     (+ mincol (* (ceiling (- chars mincol) colinc) colinc))
                     mincol))
         (padding (+ (- length chars) (* num-gaps minpad))))
    (when (and newline-prefix
               (> (+ (or (charpos stream) 0)
                     length extra-space)
                  line-len))
      (write-string newline-prefix stream))
    (flet ((do-padding ()
                       (let ((pad-len (if (zerop num-gaps)
                                          padding
                                          (truncate padding num-gaps))))
                         (decf padding pad-len)
                         (decf num-gaps)
                         (dotimes (i pad-len) (write-char padchar stream)))))
      (when (or pad-left
                (and (not pad-right) (null (cdr strings))))
        (do-padding))
      (when strings
        (write-string (car strings) stream)
        (dolist (string (cdr strings))
          (do-padding)
          (write-string string stream)))
      (when pad-right
        (do-padding)))))

(defun interpret-format-logical-block
  (stream orig-args args prefix per-line-p insides suffix atsignp)
  (let ((arg (if atsignp args (next-arg))))
    (if per-line-p
        (pprint-logical-block
         (stream arg :per-line-prefix prefix :suffix suffix)
         (let ((*logical-block-popper* (lambda () (pprint-pop))))
           (catch 'up-and-out
             (interpret-directive-list stream insides
                                       (if atsignp orig-args arg)
                                       arg))))
        (pprint-logical-block (stream arg :prefix prefix :suffix suffix)
                              (let ((*logical-block-popper* (lambda () (pprint-pop))))
                                (catch 'up-and-out
                                  (interpret-directive-list stream insides
                                                            (if atsignp orig-args arg)
                                                            arg))))))
  (if atsignp nil args))

;;;; format interpreter and support functions for user-defined method

(def-format-interpreter #\/ (string start end colonp atsignp params)
  (let ((symbol (extract-user-fun-name string start end)))
    (collect ((args))
             (dolist (param-and-offset params)
               (let ((param (cdr param-and-offset)))
                 (case param
                   (:arg (args (next-arg)))
                   (:remaining (args (length args)))
                   (t (args param)))))
             (apply (fdefinition symbol) stream (next-arg) colonp atsignp (args)))))

(setf (symbol-function 'sys::simple-format) #'format)


(provide 'format)