;;; -*- Mode:LISP; Package:LISP-INTERNALS; Base:10; Readtable:CL -*-
;;;
;;; FORMAT.LISP
;;;
;;; FORMAT Interpreter


;; Problems:  parsing ,,, 
;; cryptic error messages.  how should they work, anyway? nice errors.
;; check types of arguments
;; piggyback stream for column counting?


;;;----------------------------------------
;;; Entry
;;;----------------------------------------


(defun format (destination control-string &rest arguments)
  (let ((stream (cond ((streamp destination)
		       destination)
		      ((eq destination NIL)
		       (make-string-output-stream))
		      ((eq destination T)
		       *standard-output*)
		      ((stringp destination)
		       (error "Can't do strings yet"))
		      (t
		       (error "Bad destination to FORMAT.")))))
    (format-main (make-string-iterator control-string)
		 (make-format-args (copy-list arguments))
		 stream)
    (cond ((eq destination NIL)
	   (get-output-stream-string stream))
	  (t
	   NIL))))


;;;----------------------------------------
;;; Representation of format arguments
;;;----------------------------------------


(defstruct format-args-rep
  "ALL-ARGUMENTS is the complete list of format arguments.  NEXT-ARGUMENT is a
list of all the arguments remaining to be processed by format.  POSITION is the
number of arguments that have been processed so far.  To remain consistent,
NEXT-ARGUMENT = (NTHCDR POSITION ALL-ARGUMENTS)."
  position all-arguments next-argument)


(defun make-format-args (format-argument-list)
  "Represent the list of format arguments in a more convenient manner."
  (make-format-args-rep :position      0
			:all-arguments format-argument-list
			:next-argument format-argument-list))


(defun next-format-arg (format-args)
  "Return the next format argument available."
  (if (format-args-rep-next-argument format-args)
      (progn (incf (format-args-rep-position format-args))
	     (pop  (format-args-rep-next-argument format-args)))
      (error "No arguments left.")))


(defun any-more-format-args? (format-args)
  "Return T if there are more format arguments available, NIL if not."
  (and (format-args-rep-next-argument format-args) t))


(defun number-of-remaining-format-args (format-args)
  (length (format-args-rep-next-argument format-args)))


(defun back-up-one-format-arg (format-args)
  (if (zerop (format-args-rep-position format-args))
      (error "Can't back up.")
      (progn
	(decf (format-args-rep-position format-args))
	(setf (format-args-rep-next-argument format-args)
	      (nthcdr (format-args-rep-position format-args)
		      (format-args-rep-all-arguments format-args))))))
    

;;;----------------------------------------
;;; String element iteration
;;;----------------------------------------


(defstruct string-iterator-rep
  string length index most-recent-twiddle-index most-recent-open-index)


(defun make-string-iterator (string)
  (make-string-iterator-rep :string string
			    :length (length string)
			    :index  0
			    :most-recent-twiddle-index NIL
			    :most-recent-open-index NIL))
  
  


(defun next-character (string-iterator)
  (let ((index (string-iterator-rep-index string-iterator)))
    (if (>= index (string-iterator-rep-length string-iterator))
	(format-error string-iterator "Unexpected end of format string.")
	(prog1 (char (string-iterator-rep-string string-iterator) index)
	       (incf (string-iterator-rep-index string-iterator))))))


(defun peek-character (string-iterator)
  (let ((index (string-iterator-rep-index string-iterator)))
    (if (>= index (string-iterator-rep-length string-iterator))
	(format-error string-iterator "Unexpected end of format string.")
	(char (string-iterator-rep-string string-iterator) index))))


(defun more-characters? (string-iterator)
  (< (string-iterator-rep-index string-iterator)
     (string-iterator-rep-length string-iterator)))


(defun grab-current-index (string-iterator)
  (string-iterator-rep-index string-iterator))


(defun set-current-index (string-iterator index)
  (setf (string-iterator-rep-index string-iterator) index))


(defun note-most-recent-twiddle-index (string-iterator)
  (setf (string-iterator-rep-most-recent-twiddle-index string-iterator)
	(1- (string-iterator-rep-index string-iterator))))


(defun get-most-recent-twiddle-index (string-iterator)
  (string-iterator-rep-most-recent-twiddle-index string-iterator))


(defun note-most-recent-open-index (string-iterator)
  (setf (string-iterator-rep-most-recent-open-index string-iterator)
	(1- (string-iterator-rep-index string-iterator))))


(defun get-most-recent-open-index (string-iterator)
  (string-iterator-rep-most-recent-open-index string-iterator))


(defun get-entire-format-string (string-iterator)
  (string-iterator-rep-string string-iterator))


;;;----------------------------------------
;;; Main loop and dispatch
;;;----------------------------------------


(defun format-main (format-string-iterator format-args stream)
  (when (more-characters? format-string-iterator)
    (let ((character (next-character format-string-iterator)))
      (if (char= character #\~)
	  (multiple-value-bind (dispatch-char directive-args colonp atsignp)
	      (parse-after-twiddle format-string-iterator format-args nil)
	    (funcall (lookup-format-dispatch dispatch-char)
		     format-args
		     directive-args
		     colonp
		     atsignp
		     stream
		     format-string-iterator))
	  (write-char character stream)))
    (format-main format-string-iterator format-args stream)))

;; the following ~'s are not below:
;; F  E G $ : ~ T * ? ] } ^ )
(defun lookup-format-dispatch (dispatch-char)
  (case dispatch-char
    (#\A 'format-A)
    (#\B 'format-B)
    (#\C 'format-C)
    (#\D 'format-D)
    (#\O 'format-O)
    (#\P 'format-P)
    (#\R 'format-R)
    (#\S 'format-S)
    (#\X 'format-X)
    (#\% 'format-%)
    (#\& 'format-&)
    (#\( 'format-\()
    (#\[ 'format-[)
    (#\{ 'format-{)
    (#\< 'format-<)
    (t
     (error "Unrecognized format dispatch character ~C." dispatch-char))))


;;;----------------------------------------
;;; Parsing the format string
;;;----------------------------------------


;(defun parse-after-twiddle (format-string-iterator format-args)
;  "Begin parsing the format string immediately after a ~.  Return four values:
;\(1) the format dispatch character, (2) a list of the prefix parameters, (3) a
;boolean value indicating whether or not a colon modifier was specified, and (4)
;a boolean value indicating whether or not an at-sign modifier was specified."
;  (let (dispatch-char parameters colonp at-sign-p)
;    (loop
;      (if (not (more-characters? format-string-iterator))
;	  (error "Unexpected end of format.")
;	  (let ((next-char 
;		  (char-upcase (next-character format-string-iterator))))
;	    (cond
;	      ((find next-char "+-0123456789")
;	       (push (pluck-integer next-char format-string-iterator) 
;		     parameters))
;	      ((char= next-char #\V)
;	       (push (next-format-arg format-args) parameters))
;	      ((char= next-char #\,)
;	       (when (char= (peek-character format-string-iterator) #\,)
;		 (push NIL parameters)))
;	      ((char= next-char #\#)
;	       (push (number-of-remaining-format-args format-args) parameters))
;	      ((char= next-char #\')
;	       (push (next-character format-string-iterator) parameters))
;	      ((char= next-char #\:)
;	       (if colonp
;		   (error "More than one colon in format directive.")
;		   (setq colonp t)))
;	      ((char= next-char #\@)
;	       (if at-sign-p
;		   (error "More than one at-sign in format directive.")
;		   (setq at-sign-p t)))
;	      (t
;	       (setq dispatch-char next-char)
;	       (return))))))
;    (values dispatch-char (nreverse parameters) colonp at-sign-p)))


(defun parse-after-twiddle (format-string-iterator format-args vacuous-p)
  "Parse a format directive, immediately following a twiddle.  If VACUOUS-P is
true, then treat all prefix parameters as NIL, and no side effects will happen
to FORMAT-ARGS.  Return five values:  (1) the format dispatch character, (2) a
list of the prefix parameters, (3) a boolean value indicating whether or not a
colon modifier was specified, (4) a boolean value indicating whether or not an
at-sign modifier was specified, and (5) a string containing the text of the
format directive."
  (note-most-recent-twiddle-index format-string-iterator)
  (let (dispatch-char parameters colonp at-sign-p text)
    (let ((type-of-last-thing :TWIDDLE))
      (loop
	(let ((next-char (char-upcase (next-character format-string-iterator))))
	  (push next-char text)
	  (cond
	    ((find next-char "+-0123456789V#'")
	     (require-can-follow :ARGUMENT type-of-last-thing)
	     (push 
	       (if vacuous-p
		   NIL
		   (case next-char
		     (#\V (next-format-arg format-args))
		     (#\# (number-of-remaining-format-args format-args))
		     (#\' (next-character format-string-iterator))
		     (t   (pluck-integer next-char format-string-iterator))))
	       parameters)
	     (setq type-of-last-thing :ARGUMENT))
	    ((char= next-char #\,)
	     (require-can-follow :COMMA type-of-last-thing)
	     (when (member type-of-last-thing '(:TWIDDLE :COMMA))
	       (push NIL parameters))
	     (setq type-of-last-thing :COMMA))
	    ((char= next-char #\:)
	     (require-can-follow :COLON type-of-last-thing)
	     (setq colonp t)
	     (setq type-of-last-thing :COLON))
	    ((char= next-char #\@)
	     (require-can-follow :AT-SIGN type-of-last-thing)
	     (setq at-sign-p t)
	     (setq type-of-last-thing :AT-SIGN))
	    (t
	     (require-can-follow :DIRECTIVE type-of-last-thing)
	     (setq dispatch-char next-char)
	     (return))))))
    (values dispatch-char 
	    (nreverse parameters)
	    colonp 
	    at-sign-p
	    (coerce-vector-or-list-to-string (nreverse text)))))

		      
(defun require-can-follow (foo bar)
  "Raise an error if FOO can't follow BAR."
  (unless 
    (member foo
	    (case bar
	      (:TWIDDLE  '(:ARGUMENT :COMMA :COLON :AT-SIGN :DIRECTIVE))
	      (:ARGUMENT '(:COMMA :COLON :AT-SIGN :DIRECTIVE))
	      (:COMMA    '(:ARGUMENT :COMMA))
	      (:COLON    '(:AT-SIGN :DIRECTIVE))
	      (:AT-SIGN  '(:DIRECTIVE))))
    (error "Bad parameter syntax.")))


(defun pluck-integer (first-char format-string-iterator)
  (let ((digits (list first-char)))
    (loop
      (let ((next-char (peek-character format-string-iterator)))
	(cond
	  ((digit-char-p next-char)
	   (next-character format-string-iterator)
	   (push next-char digits))
	  ((find next-char "+-Vv#'")
	   (error "Bad syntax after numeric argument."))
	  (t
	   (return)))))
    (parse-integer (coerce-vector-or-list-to-string (nreverse digits)))))


(defun scan-a-chunk (terminating-character format-string-iterator)
  "March along the format string until a twiddle-TERMINATING-CHARACTER or a
twiddle-semicolon directive is encountered.  Skip over any nested ~(-~), 
~[-~], ~{-~}, or ~<-~> pairs.  Return three values:  a string containing the
characters scanned over (without the directive that terminated it), the
character that terminated it, and a string containing the format directive
that terminated it."
  (let ((characters (make-string-output-stream))
	(actual-terminating-character NIL)
	(terminating-string)
	(paren-depth 0)
	(bracket-depth 0)
	(brace-depth 0)
	(angle-depth 0))
    (loop 
      (let ((character (next-character format-string-iterator)))
	(if (char= character #\~)
	    (multiple-value-bind 
	      (dispatch-char ignore1 ignore2 ignore3 directive-string)
		(parse-after-twiddle format-string-iterator nil t)
	      (if (and (or (char= dispatch-char terminating-character)
			   (char= dispatch-char #\;))
		       (zerop paren-depth)
		       (zerop bracket-depth)
		       (zerop brace-depth)
		       (zerop angle-depth))
		  (progn (setq actual-terminating-character dispatch-char)
			 (setq terminating-string directive-string)
			 (return))
		  (progn (write-char #\~ characters)
			 (write-string directive-string characters)
			 (case dispatch-char
			   (#\( (incf paren-depth))
			   (#\) (decf paren-depth))
			   (#\[ (incf bracket-depth))
			   (#\] (decf bracket-depth))
			   (#\{ (incf brace-depth))
			   (#\} (decf brace-depth))
			   (#\< (incf angle-depth))
			   (#\> (decf angle-depth))))))
	    (write-char character characters))))
    (values (get-output-stream-string characters) 
	    actual-terminating-character
	    terminating-string)))

		  
;;;----------------------------------------
;;; Error checking
;;;----------------------------------------


(defun maximum-prefix-arguments (maximum prefix-arguments 
				 format-string-iterator)
  "Raise an error if there are more than MAXIMUM elements in PREFIX-ARGUMENTS."
  (let ((length (length prefix-arguments)))
    (when (> length maximum)
      (format-error format-string-iterator
		    "More than ~S prefix parameters supplied to this format directive."
		    maximum))))


(defun forbid-atsign (atsignp format-string-iterator)
  "Raise an error if ATSIGNP is true."
  (when atsignp
    (format-error format-string-iterator
		  "A @ modifier is not allowed in this format directive.")))
 
 
(defun forbid-colon (colonp format-string-iterator)
  "Raise an error if COLONP is true."
  (when colonp
    (format-error format-string-iterator
		  "A : modifier is not allowed in this format directive.")))


(defun forbid-both (colonp atsignp format-string-iterator)
  "Raise an error if both COLONP and ATSIGNP are true."
  (when (and colonp atsignp)
    (format-error format-string-iterator
		  "A :@ modifier is not allowed in this format directive.")))


;;;----------------------------------------
;;; Ugly format directives
;;;----------------------------------------


(defun format-A (format-args directive-args colonp atsignp stream
                format-string-iterator)
  (maximum-prefix-arguments 4 directive-args format-string-iterator)
  (let ((object (next-format-arg format-args)))
    (cond ((and (null object) (not colonp))
	   (setq object "nil"))
	  ((and (null object) colonp)
	   (setq object "()")))
    (if (not directive-args)
	(princ object stream) ;; the easy case
	(let ((mincol  (or (first directive-args) 0))
	      (colinc  (or (second directive-args) 1))
	      (minpad  (or (third directive-args) 0))
	      (padchar (or (fourth directive-args) #\Space))
	      (string  (princ-to-string object)))
	  (pad string atsignp stream mincol colinc minpad padchar)))))


(defun format-S (format-args directive-args colonp atsignp stream
                format-string-iterator)
  (maximum-prefix-arguments 4 directive-args format-string-iterator)
  (let* ((object (next-format-arg format-args))
	 (string (if (and (null object) colonp)
		     "()"
		     (prin1-to-string object))))
    (if (not directive-args)
	(princ string stream) ;; the easy case
	(let ((mincol  (or (first directive-args) 0))
	      (colinc  (or (second directive-args) 1))
	      (minpad  (or (third directive-args) 0))
	      (padchar (or (fourth directive-args) #\Space)))
	  (pad string atsignp stream mincol colinc minpad padchar)))))


(defun pad (string pad-left-p stream mincol colinc minpad padchar)
  (let* 
    ((length         (length string))
     (space-to-fill  (max 0 (- mincol length)))
     (padding-length (max minpad (* colinc (ceiling space-to-fill colinc))))
     (padding-string (make-string padding-length :initial-element padchar)))
    (if pad-left-p
	(progn (princ padding-string stream)
	       (princ string stream))
	(progn (princ string stream)
	       (princ padding-string stream)))))


(defun integer-to-string (integer radix comma force-sign-p)
  "Return a string representing INTEGER in base RADIX.  If COMMA is not NIL, it
should be a character to use between groups of 3 digits.  If FORCE-SIGN-P is
true and the number is positive, print a + sign in front of it."
  (let ((digit-list NIL)
	(digit-count 0))
    (labels ((iter (integer)
	       (when (and comma (> digit-count 0) (= (mod digit-count 3) 0))
		 (push comma digit-list))
	       (multiple-value-bind (most-of-the-digits the-last-digit)
		   (floor integer radix)
		 (push (digit-char the-last-digit radix) digit-list)
		 (incf digit-count)
		 (when (> most-of-the-digits 0)
		   (iter most-of-the-digits)))))
      (iter (abs integer))
      (when (or force-sign-p (minusp integer))
	(push (if (minusp integer) #\- #\+) digit-list))
      (coerce-vector-or-list-to-string digit-list))))


(defun format-integer (object radix mincol padchar comma force-sign-p stream)
  (let ((string (if (integerp object)
		    (integer-to-string object radix comma force-sign-p)
		    (let ((*print-base* radix))
		      (princ-to-string object)))))
    (pad string t stream mincol 1 0 padchar)))


(defun format-D (format-args directive-args colonp atsignp stream
                format-string-iterator)
  (maximum-prefix-arguments 3 directive-args format-string-iterator)
  (let* ((object    (next-format-arg format-args))
	 (mincol    (or (first directive-args)  0))
	 (padchar   (or (second directive-args) #\Space))
	 (commachar (or (third directive-args)  #\,)))
    (format-integer object 10. mincol padchar 
		    (and colonp commachar) atsignp stream)))


(defun format-B (format-args directive-args colonp atsignp stream
                format-string-iterator)
  (maximum-prefix-arguments 3 directive-args format-string-iterator)
  (let* ((object    (next-format-arg format-args))
	 (mincol    (or (first directive-args)  0))
	 (padchar   (or (second directive-args) #\Space))
	 (commachar (or (third directive-args)  #\,)))
    (format-integer object 2. mincol padchar 
		    (and colonp commachar) atsignp stream)))


(defun format-O (format-args directive-args colonp atsignp stream
                format-string-iterator)
  (maximum-prefix-arguments 3 directive-args format-string-iterator)
  (let* ((object    (next-format-arg format-args))
	 (mincol    (or (first directive-args)  0))
	 (padchar   (or (second directive-args) #\Space))
	 (commachar (or (third directive-args)  #\,)))
    (format-integer object 8. mincol padchar 
		    (and colonp commachar) atsignp stream)))


(defun format-X (format-args directive-args colonp atsignp stream
                format-string-iterator)
  (maximum-prefix-arguments 3 directive-args format-string-iterator)
  (let* ((object    (next-format-arg format-args))
	 (mincol    (or (first directive-args)  0))
	 (padchar   (or (second directive-args) #\Space))
	 (commachar (or (third directive-args)  #\,)))
    (format-integer object 16. mincol padchar 
		    (and colonp commachar) atsignp stream)))


(defun format-R (format-args directive-args colonp atsignp stream
                format-string-iterator)
  (maximum-prefix-arguments 4 directive-args format-string-iterator)
  (let ((object (next-format-arg format-args)))
    (if directive-args
	(let ((radix     (first directive-args))
	      (mincol    (or (second directive-args) 0))
	      (padchar   (or (third directive-args) #\Space))
	      (commachar (or (fourth directive-args) #\,)))
	  (format-integer object radix mincol padchar 
			  (and colonp commachar) atsignp stream))
	(cond ((and colonp atsignp)
	       (print-old-roman-numeral object stream))
	      (atsignp
	       (print-roman-numeral object stream))
	      (colonp
	       (print-ordinal-number object stream))
	      (t
	       (print-cardinal-number object stream))))))


(defun print-roman-numeral (x stream)
  (roman-numeral-loop x 0 nil stream))


(defun print-old-roman-numeral (x stream)
  (roman-numeral-loop x 0 t stream))


(defun roman-numeral-loop (x level oldp stream)
  (when (> x 9)
    (multiple-value-bind (more-significant-digits least-significant-digit)
	(floor x 10)
      (if (> level 1)
	  (dotimes (i more-significant-digits)
	    (write-char #\M stream))
	  (roman-numeral-loop more-significant-digits (1+ level) oldp stream))
      (setq x least-significant-digit)))
  (cond ((and (= x 9) (not oldp))
	 (print-roman-I-char level stream)
	 (print-roman-I-char (1+ level) stream))
	((= x 5)
	 (print-roman-V-char level stream))
	((and (= x 4) (not oldp))
	 (print-roman-I-char level stream)
	 (print-roman-V-char level stream))
	((> x 5)
	 (print-roman-V-char level stream)
	 (dotimes (i (- x 5))
	   (print-roman-I-char level stream)))
	(t
	 (dotimes (i x)
	   (print-roman-I-char level stream)))))


(defun print-roman-I-char (level stream)	 
  (write-char (char "IXCM" level) stream))


(defun print-roman-V-char (level stream)
  (write-char (char "VLD" level) stream))


(defun format-P (format-args directive-args colonp atsignp stream
                format-string-iterator)
  (maximum-prefix-arguments 0 directive-args format-string-iterator)
  (when colonp (back-up-one-format-arg format-args))
  (let* ((next-arg (next-format-arg format-args))
	 (pluralp  (not (eql next-arg 1))))
    (write-string (cond ((and atsignp pluralp) "ies")
			(atsignp               "y")
			(pluralp               "s")
			(t		       ""))
		  stream)))
	

(defun format-C (format-args directive-args colonp atsignp stream
                format-string-iterator)
  (maximum-prefix-arguments 0 directive-args format-string-iterator)
  (let ((next-arg (next-format-arg format-args)))
    (check-type next-arg character)
    (cond ((and colonp atsignp)
	   (print-redundantly-verbose-character next-arg stream))
	  (colonp
	   (print-verbose-character next-arg stream))
	  (atsignp
	   (prin1 next-arg stream))
	  (t
	   (princ next-arg stream)))))
  

(defun format-% (format-args directive-args colonp atsignp stream
                format-string-iterator)
  (declare (ignore format-args))
  (maximum-prefix-arguments 1 directive-args format-string-iterator)
  (forbid-colon colonp format-string-iterator)
  (forbid-atsign atsignp format-string-iterator)
  (let ((number-of-times (if directive-args (first directive-args) 1)))
    (dotimes (i number-of-times)
      (terpri stream))))


(defun format-& (format-args directive-args colonp atsignp stream
                format-string-iterator)
  (declare (ignore format-args))
  (maximum-prefix-arguments 1 directive-args format-string-iterator)
  (forbid-colon colonp format-string-iterator)
  (forbid-atsign atsignp format-string-iterator)
  (let ((number-of-times (if directive-args (first directive-args) 1)))
    (when (> number-of-times 0)
      (fresh-line stream))
    (dotimes (i (1- number-of-times))
      (terpri stream))))


(defun format-\| (format-args directive-args colonp atsignp stream
                format-string-iterator)
  (declare (ignore format-args))
  (maximum-prefix-arguments 1 directive-args format-string-iterator)
  (forbid-colon colonp format-string-iterator)
  (forbid-atsign atsignp format-string-iterator)
  (let ((number-of-times (if directive-args (first directive-args) 1)))
    (dotimes (i number-of-times)
      (write-char #\Page stream))))


(defun format-~ (format-args directive-args colonp atsignp stream
                format-string-iterator)
  (declare (ignore format-args))
  (maximum-prefix-arguments 1 directive-args format-string-iterator)
  (forbid-colon colonp format-string-iterator)
  (forbid-atsign atsignp format-string-iterator)
  (let ((number-of-times (if directive-args (first directive-args) 1)))
    (dotimes (i number-of-times)
      (write-char #\~ stream))))


(defun format-NEWLINE (format-args directive-args colonp atsignp stream 
		       format-string-iterator)
  (declare (ignore format-args))
  (maximum-prefix-arguments 0 directive-args format-string-iterator)
  (forbid-both colonp atsignp format-string-iterator)
  (when atsignp
    (terpri stream))
  (unless colonp
    (loop
      (let ((next-character (peek-character format-string-iterator)))
	(if (eq (syntax-type next-character) :WHITESPACE)
	    (next-character format-string-iterator)
	    (return))))))
  

(defun format-[ (format-args directive-args colonp atsignp stream
		 format-string-iterator)
  (forbid-both colonp atsignp format-string-iterator)
  (note-most-recent-open-index format-string-iterator)
  (cond (colonp  (format-colon-[ format-args directive-args 
				 stream format-string-iterator))
	(atsignp (format-@[ format-args directive-args
			    stream format-string-iterator))
	(t       (format-n[ format-args directive-args
			    stream format-string-iterator))))


;(defun format-n[ (format-args directive-args stream format-string-iterator)
;  (maximum-prefix-arguments 1 directive-args format-string-iterator)
;  (let ((n           (if directive-args 
;			 (first directive-args)
;			 (next-format-arg format-args)))
;	(clauses     NIL)
;	(else-clause NIL))


(defun format-colon-[ (format-args directive-args stream 
		       format-string-iterator)
  (maximum-prefix-arguments 0 directive-args format-string-iterator)
  (let (false-string true-string)
    (multiple-value-bind (string ignore terminating-directive)
	(scan-a-chunk #\] format-string-iterator)
      (require-twiddle-semicolon terminating-directive)
      (setq false-string string))
    (multiple-value-bind (string ignore terminating-directive)
	(scan-a-chunk #\] format-string-iterator)
      (require-twiddle-] terminating-directive)
      (setq true-string string))
    (format-main (make-string-iterator (if (next-format-arg format-args)
					   true-string
					   false-string))
		 format-args
		 stream)))

(defun require-twiddle-semicolon (ignore))

(defun require-twiddle-] (twiddle-]?)
  (if (string-equal "~]" twiddle-]?)
      t
    (error "no ~] for ~[")))

						
;;;----------------------------------------
;;; Format error
;;;----------------------------------------


(defun format-error (format-string-iterator error-string &rest error-args)
  (error "~?~%~V@T
~%~3@T\"~A\"~%"
	 error-string
	 error-args
	 (+ (get-most-recent-twiddle-index format-string-iterator) 4)
	 (get-entire-format-string format-string-iterator)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
	    
	  
(defun coerce-vector-or-list-to-string (thing)
  (let* ((count  (length thing))
	 (string (array:make-string count)))
    (cond
      ((arrayp thing)
       (dotimes (i count string)
	 (setf (svref string i) (svref thing i))))
      ((listp thing)
       (dotimes (i count string)
	 (setf (svref string i) (car thing))
	 (setq thing (cdr thing))))
      (t (error "Can't coerce this for FORMAT" thing)))))