Skip to content
Snippets Groups Projects
format.lisp 49.9 KiB
Newer Older
ram's avatar
ram committed
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471 472 473 474 475 476 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 498 499 500 501 502 503 504 505 506 507 508 509 510 511 512 513 514 515 516 517 518 519 520 521 522 523 524 525 526 527 528 529 530 531 532 533 534 535 536 537 538 539 540 541 542 543 544 545 546 547 548 549 550 551 552 553 554 555 556 557 558 559 560 561 562 563 564 565 566 567 568 569 570 571 572 573 574 575 576 577 578 579 580 581 582 583 584 585 586 587 588 589 590 591 592 593 594 595 596 597 598 599 600 601 602 603 604 605 606 607 608 609 610 611 612 613 614 615 616 617 618 619 620 621 622 623 624 625 626 627 628 629 630 631 632 633 634 635 636 637 638 639 640 641 642 643 644 645 646 647 648 649 650 651 652 653 654 655 656 657 658 659 660 661 662 663 664 665 666 667 668 669 670 671 672 673 674 675 676 677 678 679 680 681 682 683 684 685 686 687 688 689 690 691 692 693 694 695 696 697 698 699 700 701 702 703 704 705 706 707 708 709 710 711 712 713 714 715 716 717 718 719 720 721 722 723 724 725 726 727 728 729 730 731 732 733 734 735 736 737 738 739 740 741 742 743 744 745 746 747 748 749 750 751 752 753 754 755 756 757 758 759 760 761 762 763 764 765 766 767 768 769 770 771 772 773 774 775 776 777 778 779 780 781 782 783 784 785 786 787 788 789 790 791 792 793 794 795 796 797 798 799 800 801 802 803 804 805 806 807 808 809 810 811 812 813 814 815 816 817 818 819 820 821 822 823 824 825 826 827 828 829 830 831 832 833 834 835 836 837 838 839 840 841 842 843 844 845 846 847 848 849 850 851 852 853 854 855 856 857 858 859 860 861 862 863 864 865 866 867 868 869 870 871 872 873 874 875 876 877 878 879 880 881 882 883 884 885 886 887 888 889 890 891 892 893 894 895 896 897 898 899 900 901 902 903 904 905 906 907 908 909 910 911 912 913 914 915 916 917 918 919 920 921 922 923 924 925 926 927 928 929 930 931 932 933 934 935 936 937 938 939 940 941 942 943 944 945 946 947 948 949 950 951 952 953 954 955 956 957 958 959 960 961 962 963 964 965 966 967 968 969 970 971 972 973 974 975 976 977 978 979 980 981 982 983 984 985 986 987 988 989 990 991 992 993 994 995 996 997 998 999 1000
;;; -*- Log: code.log; Package: Lisp -*-
;;;
;;; **********************************************************************
;;; This code was written as part of the Spice Lisp project at
;;; Carnegie-Mellon University, and has been placed in the public domain.
;;; If you want to use this code or any part of Spice Lisp, please contact
;;; Scott Fahlman (FAHLMAN@CMUC). 
;;; **********************************************************************
;;;
;;; Functions to implement FORMAT for Spice Lisp.
;;;
;;; Original by David Adam.
;;; Re-write by Bill Maddox.
;;; Currently not maintained.
;;;
;;; FORMAT is part of the standard Spice Lisp environment.
;;;
;;; **********************************************************************

(in-package 'lisp)
(export 'format)

;;; Special variables local to FORMAT

(defvar *format-control-string* ""
  "The current FORMAT control string")

(defvar *format-index* 0
  "The current index into *format-control-string*")

(defvar *format-length* 0
  "The length of the current FORMAT control string")

(defvar *format-arguments* ()
  "Arguments to the current call of FORMAT")

(defvar *format-original-arguments* ()
 "Saved arglist from top-level FORMAT call for ~* and ~@*")

(defvar *format-stream-stack* ()
  "A stack of string streams for collecting FORMAT output")

(defvar *format-dispatch-table* ()
  "Dispatch table for FORMAT commands")


;;; Specials imported from PRINT and STREAM

(proclaim '(special *print-base* *standard-output* *terminal-io*))

;;; Specials imported from ERRORFUNS

(proclaim '(special *error-output*))



;;; ERRORS

;;; Since errors may occur while an indirect control string is being
;;; processed, i.e. by ~? or ~{~:}, some sort of backtrace is necessary
;;; in order to indicate the location in the control string where the
;;; error was detected.  To this end, errors detected by format are
;;; signalled by throwing a list of the form ((control-string args))
;;; to the tag FORMAT-ERROR.  This throw will be caught at each level
;;; of indirection, and the list of error messages re-thrown with an
;;; additional message indicating that indirection was present CONSed
;;; onto it.  Ultimately, the last throw will be caught by the top level
;;; FORMAT function, which will then signal an error to the Lisp error
;;; system in such a way that all the errror messages will be displayed
;;; in reverse order.

(defun format-error (complaint &rest args)
  (throw 'format-error
	 (list (list "~1{~:}~%~S~%~V@T^" complaint args
		     *format-control-string* (1+ *format-index*)))))



;;; MACROS

;;; This macro establishes the correct environment for processing
;;; an indirect control string.  CONTROL-STRING is the string to
;;; process, and FORMS are the forms to do the processing.  They 
;;; invariably will involve a call to SUB-FORMAT.  CONTROL-STRING
;;; is guaranteed to be evaluated exactly once.

(defmacro format-with-control-string (control-string &body forms)
  `(let ((string (if (simple-string-p ,control-string)
		     ,control-string
		     (coerce ,control-string 'simple-string))))
     (declare (simple-string string))
     (let ((error (catch 'format-error
			 (let ((*format-control-string* string)
			       (*format-length* (length string))
			       (*format-index* 0))
			   (declare (simple-string *format-control-string*)
				    (fixnum *format-length* *format-index*))
			   ,@forms
			   nil))))
       (when error
	 (throw 'format-error
	   (cons (list "While processing indirect control string~%~S~%~V@T^"
		       *format-control-string*
		       (1+ *format-index*))
	       error))))))


;;; This macro rebinds collects output to the standard output stream
;;; in a string.  For efficiency, we avoid consing a new stream on
;;; every call.  A stack of string streams is maintained in order to
;;; guarantee re-entrancy.

(defmacro format-stringify-output (&body forms)
  `(let ((*standard-output*
	  (if *format-stream-stack*
	      (pop *format-stream-stack*)
	      (make-string-output-stream))))
     (unwind-protect
      (progn ,@forms
	     (prog1
	      (get-output-stream-string *standard-output*)
	      (push *standard-output* *format-stream-stack*)))
      (get-output-stream-string *standard-output*))))



;;; Pops an argument from the current argument list.  This is either the
;;; list of arguments given to the top-level call to FORMAT, or the argument
;;; list for the current iteration in a ~{~} construct.  An error is signalled
;;; if the argument list is empty.

(defmacro pop-format-arg ()
  '(if *format-arguments*
       (pop *format-arguments*)
       (format-error "Missing argument")))


;;; This macro decomposes the argument list returned by PARSE-FORMAT-OPERATION.
;;; PARMVAR is the list of parameters.  PARMDEFS is a list of lists of the form
;;; (<var> <default>).  The FORMS are evaluated in an environment where each 
;;; <var> is bound to either the value of the parameter supplied in the 
;;; parameter list, or to its <default> value if the parameter was omitted or
;;; explicitly defaulted.

(defmacro with-format-parameters (parmvar parmdefs &body forms)
  (do ((parmdefs parmdefs (cdr parmdefs))
       (bindings () (cons `(,(caar parmdefs) (or (if ,parmvar (pop ,parmvar))
						 ,(cadar parmdefs)))
			 bindings)))
      ((null parmdefs)
       `(let ,(nreverse bindings)
	  (when ,parmvar
	    (format-error "Too many parameters"))
	  ,@forms))))



;;; CONTROL STRING PARSING 

;;; The current control string is kept in *format-control-string*. 
;;; The variable *format-index* is the position of the last character
;;; processed, indexing from zero.  The variable *format-length* is the
;;; length of the control string, which is one greater than the maximum
;;; value of *format-index*.  


;;; Gets the next character from the current control string.  It is an
;;; error if there is none.  Leave *format-index* pointing to the
;;; character returned.

(defmacro nextchar ()
  '(if (< (the fixnum (incf (the fixnum *format-index*)))
	  (the fixnum *format-length*))
       (schar *format-control-string* *format-index*)
       (format-error "Syntax error")))


;;; Returns the current character, i.e. the one pointed to by *format-index*.

(defmacro format-peek ()
  '(schar *format-control-string* *format-index*))


;;; Returns the index of the first occurrence of the specified character
;;; between indices START (inclusive) and END (exclusive) in the control
;;; string.


(defmacro format-find-char (char start end)
  `(position ,char (the simple-string *format-control-string*)
	     :start ,start :end ,end :test #'char=))


;;; Attempts to parse a parameter, starting at the current index.
;;; Returns the value of the parameter, or NIL if none is found. 
;;; On exit, *format-index* points to the first character which is
;;; not a part of the recognized parameter.

(defun format-get-parameter ()
  (case (format-peek)
    (#\# (nextchar) (length (the list *format-arguments*)))
    ((#\V #\v) (prog1 (pop-format-arg) (nextchar)))
    (#\' (prog1 (nextchar) (nextchar)))
    ((#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9)
     (do* ((number (digit-char-p (format-peek))
		   (+ (* 10 number) (digit-char-p (format-peek)))))
	  ((not (digit-char-p (nextchar))) number)))
    (#\-
     (nextchar)
     (case (format-peek)
       ((#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9)
	(do* ((number (digit-char-p (format-peek))
		      (+ (* 10 number) (digit-char-p (format-peek)))))
	     ((not (digit-char-p (nextchar))) (- number))))
       (t (decf (the fixnum *format-index*))  ; put back to out of place "-"
	  nil)))
    (#\+
     (nextchar)
     (case (format-peek)
       ((#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9)
	(do* ((number (digit-char-p (format-peek))
		      (+ (* 10 number) (digit-char-p (format-peek)))))
	     ((not (digit-char-p (nextchar))) number)))
       (t (decf (the fixnum *format-index*))  ; put back to out of place "-"
	  nil)))
    (t nil)))


;;; Parses a format directive, including flags and parameters.  On entry,
;;; *format-index* should point to the "~" preceding the command.  On
;;; exit, *format-index* points to the command character itself.
;;; Returns the list of parameters, the ":" flag, the "@" flag, and the
;;; command character as multiple values.  Explicitly defaulted parameters
;;; appear in the list of parameters as NIL.  Omitted parameters are simply 
;;; not included in the list at all.

(defun parse-format-operation ()
  (let ((ch (nextchar)))
    (values (if (or (digit-char-p ch)
		    (member ch '(#\, #\# #\V #\v #\' #\+ #\-) :test #'char=))
		(do ((parms (list (format-get-parameter))
			    (cons (format-get-parameter) parms)))
		    ((char/= (format-peek) #\,) (nreverse parms))
		  (declare (list parms))
		  (nextchar))
		'())
	    (if (char= (format-peek) #\:) (nextchar) nil)
	    (if (char= (format-peek) #\@) (nextchar) nil)
	    (format-peek))))



;;; Starting at the current value of *format-index*, finds the first
;;; occurrence of one of the specified directives. Embedded constructs,
;;; i.e. those inside ~(~), ~[~], ~{~}, or ~<~>, are ignored.  And error is
;;; signalled if no satisfactory command is found.  Otherwise, the
;;; following are returned as multiple values:
;;;
;;;     The value of *format-index* at the start of the search
;;;     The index of the "~" character preceding the command
;;;     The parameter list of the command
;;;     The ":" flag
;;;     The "@" flag
;;;     The command character
;;;
;;; Implementation note:  The present implementation is not particulary
;;; careful with storage allocation.  It would be a good idea to have
;;; a separate function for skipping embedded constructs which did not
;;; bother to cons parameter lists and then throw them away.
;;;
;;; We go to some trouble here to use POSITION for most of the searching.
;;;
;;; Another note: *FORMAT-ARGUMENTS* is let bound here so that we can
;;; guarantee that that list is not changed by FORMAT-FIND-COMMAND.
;;; This is necessary since PARSE-FORMAT-OPERATION (called below) calls
;;; FORMAT-GET-PARAMETER.  If the parameter is #\V or #\v then
;;; FORMAT-GET-PARAMETER will pop *FORMAT-ARGUMENTS*.  This causes the
;;; argument to be lost when we actually go to do the real formatting.
;;;
(defun format-find-command (command-list)
  (let ((start *format-index*)
	(*format-arguments* *format-arguments*))
    (do ((place start *format-index*)
	 (tilde (format-find-char #\~ start *format-length*)
		(format-find-char #\~ place *format-length*)))
	((not tilde)
	 (format-error "Expecting one of ~S" command-list))
      (setq *format-index* tilde)
      (multiple-value-bind (parms colon atsign command)
			   (parse-format-operation)
	(when (member command command-list :test #'char=)
	  (return (values start tilde parms colon atsign command)))
	(case command
	  (#\{ (nextchar)(format-find-command '(#\})))
	  (#\< (nextchar)(format-find-command '(#\>)))
	  (#\( (nextchar)(format-find-command '(#\))))
	  (#\[ (nextchar)(format-find-command '(#\])))
	  ((#\} #\> #\) #\])
	   (format-error "No matching bracket")))))))

 

;;; This is the FORMAT top-level function.

(defun format (destination control-string &rest format-arguments)
  "Provides various facilities for formatting output.
  CONTROL-STRING contains a string to be output, possibly with embedded
  directives, which are flagged with the escape character \"~\".  Directives
  generally expand into additional text to be output, usually consuming one
  or more of the FORMAT-ARGUMENTS in the process.  A few useful directives
  are:
        ~A or ~nA     Prints one argument as if by PRINC
        ~S or ~nS     Prints one argument as if by PRIN1
        ~D or ~nD     Prints one argument as a decimal integer
        ~%            Does a TERPRI
        ~&            Does a FRESH-LINE

         where n is the width of the field in which the object is printed.
  
  DESTINATION controls where the result will go.  If DESTINATION is T, then
  the output is sent to the standard output stream.  If it is NIL, then the
  output is returned in a string as the value of the call.  Otherwise,
  DESTINATION must be a stream to which the output will be sent.

  Example:   (FORMAT NIL \"The answer is ~D.\" 10) => \"The answer is 10.\"

  FORMAT has many additional capabilities not described here.  Consult the
  manual for details."

  (let ((*format-original-arguments* format-arguments)	;for abs. and rel. goto
	(*format-arguments* format-arguments)
	(*print-radix* nil)
	(*format-control-string*
	 (if (simple-string-p control-string)
	     control-string
	     (coerce control-string 'simple-string))))
    (declare (simple-string *format-control-string*))
    (cond
     ((not destination)
      (format-stringify-output
       (let ((errorp (catch 'format-error
		       (catch 'format-escape
			 (catch 'format-colon-escape
			   (sub-format 0 (length *format-control-string*))))
		       nil)))
	 (when errorp
	   (error "~%~:{~@?~%~}" (nreverse errorp))))))
     ((and (stringp destination) (array-has-fill-pointer-p destination))
      (with-output-to-string (*standard-output* destination)
	(let ((errorp (catch 'format-error
			(catch 'format-escape
			  (catch 'format-colon-escape
			    (sub-format 0 (length *format-control-string*))))
			nil)))
	  (when errorp
	    (error "~%~:{~@?~%~}" (nreverse errorp)))
	  nil)))
     (t
      (let ((*standard-output*
	     (if (or (eq destination 't)
		     (and (synonym-stream-p destination)
			  (eq (synonym-stream-symbol destination)
			      '*standard-output*)))
		 *standard-output*
		 destination)))
	(let ((errorp (catch 'format-error
			(catch 'format-escape
			  (catch 'format-colon-escape
			    (sub-format 0 (length *format-control-string*))))
			nil)))
	  (when errorp
	    (error "~%~:{~@?~%~}" (nreverse errorp))))
	nil)))))

;;; This function does the real work of format.  The segment of the control
;;; string between indiced START (inclusive) and END (exclusive) is processed
;;; as follows: Text not part of a directive is output without further
;;; processing.  Directives are parsed along with their parameters and flags,
;;; and the appropriate handlers invoked with the arguments COLON, ATSIGN, and
;;; PARMS. 
;;;
;;; Implementation Note: FORMAT-FIND-CHAR uses the POSITION sequence operation
;;; for speed.  This is potentially faster than character-at-a-time searching.

(defun sub-format (start end)
  (declare (fixnum start end))
  (let ((*format-index* start)
	(*format-length* end))
    (declare (fixnum *format-index* *format-length*))
    (do* ((place start *format-index*)
	  (tilde (format-find-char #\~ start end)
		 (format-find-char #\~ place end)))
	 ((not tilde)
	  (write-string *format-control-string*	*standard-output*
			:start place :end end))
      (declare (fixnum place) (type (or fixnum null) tilde))
      (when (> tilde place)
	(write-string *format-control-string* *standard-output*
		      :start place :end tilde))
      (setq *format-index* tilde)
      (multiple-value-bind
       (parms colon atsign command)
       (parse-format-operation)
       (let ((cmdfun (svref *format-dispatch-table* (char-code command))))
	 (if cmdfun
	     (funcall cmdfun colon atsign parms)
	     (format-error "Illegal FORMAT command ~~~S" command))))
      (unless (< (the fixnum (incf (the fixnum *format-index*))) end)
	(return)))))



;;; Conditional case conversion  ~( ... ~)

(defun format-capitalization (colon atsign parms)
  (when parms
    (format-error "No parameters allowed to ~~("))
  (nextchar)
  (multiple-value-bind
   (prev tilde end-parms end-colon end-atsign)
   (format-find-command '(#\)))
   (when (or end-parms end-colon end-atsign)
     (format-error "Flags or parameters not allowed"))
   (let ((string (format-stringify-output (sub-format prev tilde))))
     (declare (string string))
     (write-string
      (cond ((and atsign colon)
	     (nstring-upcase string))
	    (colon
	     (nstring-capitalize string))
	    (atsign
	     (let ((strlen (length string)))
	       (declare (fixnum strlen))
	       ;; Capitalize the first word only
	       (nstring-downcase string)
	       (do ((i 0 (1+ i)))
		   ((or (<= strlen i) (alpha-char-p (char string i)))
		    (setf (char string i) (char-upcase (char string i)))
		    string)
		 (declare (fixnum i)))))
	    (t (nstring-downcase string)))))))



;;; Up and Out (Escape)  ~^

(defun format-escape (colon atsign parms)
  (when atsign
    (format-error "FORMAT command ~~~:[~;:~]@^ is undefined" colon))
  (when (if (first parms)
	    (if (second parms)
		(if (third parms)
		    (typecase (second parms)
		      (integer
		       (<= (first parms) (second parms) (third parms)))
		      (character
		       (char< (first parms) (second parms) (third parms)))
		      (t nil))
		    (equal (first parms) (second parms)))
		(zerop (first parms)))
	    (not *format-arguments*))
    (throw (if colon 'format-colon-escape 'format-escape) nil)))


;;; Conditional expression  ~[ ... ]


;;; ~[ 

(defun format-untagged-condition ()
  (let ((test (pop-format-arg)))
    (unless (integerp test)
      (format-error "Argument to ~~[ must be integer - ~S" test))
    (do ((count 0 (1+ count)))
	((= count test)
	 (multiple-value-bind
	  (prev tilde parms colon atsign cmd)
	  (format-find-command '(#\; #\]))
	  (declare (ignore colon))
	  (when atsign
	    (format-error "Atsign flag not allowed"))
	  (when parms
	    (format-error "No parameters allowed"))
	  (sub-format prev tilde)
	  (unless (char= cmd #\])
	    (format-find-command '(#\])))))
      (multiple-value-bind
       (prev tilde parms colon atsign cmd)
       (format-find-command '(#\; #\]))
       (declare (ignore prev tilde))
       (when atsign
	 (format-error "Atsign flag not allowed"))
       (when parms
	 (format-error "Parameters not allowed"))
       (when (char= cmd #\]) (return))
       (when colon
	 (nextchar)
	 (multiple-value-bind (prev tilde parms colon atsign cmd)
			      (format-find-command '(#\; #\]))
	   (declare (ignore parms colon atsign))
	   (sub-format prev tilde)
	   (unless (char= cmd #\])
	     (format-find-command '(#\]))))
	 (return))
       (nextchar)))))


;;; ~@[

(defun format-funny-condition ()
  (multiple-value-bind
   (prev tilde parms colon atsign)
   (format-find-command '(#\]))
   (when (or colon atsign parms)
     (format-error "Flags or arguments not allowed"))
   (if *format-arguments*
       (if (car *format-arguments*)
	   (sub-format prev tilde)
	   (pop *format-arguments*))
       (format-error "Missing argument"))))


;;; ~:[ 

(defun format-boolean-condition ()
  (multiple-value-bind
   (prev tilde parms colon atsign)
   (format-find-command '(#\;))
   (when (or parms colon atsign)
     (format-error "Flags or parameters not allowed"))
   (nextchar)			  
   (if (pop-format-arg)
       (multiple-value-bind
	(prev tilde parms colon atsign)
	(format-find-command '(#\]))
	(when (or colon atsign parms)
	  (format-error "Flags or parameters not allowed"))
	(sub-format prev tilde))
       (progn
	(sub-format prev tilde)
	(format-find-command '(#\]))))))


(defun format-condition (colon atsign parms)
  (when parms
    (push (pop parms) *format-arguments*)
    (unless (null parms)
      (format-error "Too many parameters to ~[")))
  (nextchar)
  (cond (colon
	 (when atsign
	   (format-error  "~~:@[ undefined"))
	 (format-boolean-condition))
	(atsign
	 (format-funny-condition))
	(t (format-untagged-condition))))


;;; Iteration  ~{ ... ~}

(defun format-iteration (colon atsign parms)
  (with-format-parameters parms ((max-iter -1))
    (nextchar)
    (multiple-value-bind
     (prev tilde end-parms end-colon end-atsign)
     (format-find-command '(#\}))
     (when (or end-atsign end-parms)
       (format-error "Illegal terminator for ~~{"))
     (if (= prev tilde)
	 ;; Use an argument as the control string if ~{~} is empty
	 (let ((string (pop-format-arg)))
	   (unless (stringp string)
	     (format-error "Control string is not a string"))
	   (format-with-control-string string
	     (format-do-iteration 0 *format-length*
				  max-iter colon atsign end-colon)))
	 (format-do-iteration prev tilde max-iter colon atsign end-colon)))))


;;; The two catch tags FORMAT-ESCAPE and FORMAT-COLON-ESCAPE are needed here
;;; to correctly implement ~^ and ~:^.  The former aborts only the current
;;; iteration, but the latter aborts the entire iteration process.

(defun format-do-iteration (start end max-iter colon atsign at-least-once-p)
  (catch 'format-colon-escape
    (catch 'format-escape
      (if atsign
	  (do* ((count 0 (1+ count)))
	       ((or (= count max-iter)
		    (and (null *format-arguments*)
			 (if (= count 0) (not at-least-once-p) t))))
	    (catch 'format-escape
	      (if colon
		  (let* ((*format-original-arguments* (pop-format-arg))
			 (*format-arguments* *format-original-arguments*))
		    (unless (listp *format-arguments*)
		      (format-error "Argument must be a list"))
		    (sub-format start end))
		  (sub-format start end))))
	  (let* ((*format-original-arguments* (pop-format-arg))
		 (*format-arguments* *format-original-arguments*))
	    (unless (listp *format-arguments*)
	      (format-error "Argument must be a list"))
	    (do* ((count 0 (1+ count)))
		 ((or (= count max-iter)
		      (and (null *format-arguments*)
			   (if (= count 0) (not at-least-once-p) t))))
	      (catch 'format-escape
		(if colon
		    (let* ((*format-original-arguments* (pop-format-arg))
			   (*format-arguments* *format-original-arguments*))
		      (unless (listp *format-arguments*)
			(format-error "Argument must be a list of lists"))
		      (sub-format start end))
		    (sub-format start end)))))))))
  


;;; Justification  ~< ... ~>

;;; Parses a list of clauses delimited by ~; and terminated by ~>.
;;; Recursively invoke SUB-FORMAT to process them, and return a list
;;; of the results, the length of this list, and the total number of
;;; characters in the strings composing the list.

(defun format-get-trailing-segments ()
  (nextchar)
  (multiple-value-bind
   (prev tilde colon atsign parms cmd)
   (format-find-command '(#\; #\>))
   (when colon
     (format-error "~~:; allowed only after first segment in ~~<"))
   (when (or atsign parms)
     (format-error "Flags and parameters not allowed"))
   (let ((str (catch 'format-escape
		(format-stringify-output (sub-format prev tilde)))))
     (declare (string str))
     (if str
	 (if (char= cmd #\;)
	     (multiple-value-bind
	      (segments numsegs numchars)
	      (format-get-trailing-segments)
	      (values (cons str segments)
		      (1+ numsegs) (+ numchars (length str))))
	     (values (list str) 1 (length str)))
	 (values () 0 0)))))


;;; Gets the first segment, which is treated specially.  Call 
;;; FORMAT-GET-TRAILING-SEGMENTS to get the rest.

(defun format-get-segments ()
  (multiple-value-bind
   (prev tilde parms colon atsign cmd)
   (format-find-command '(#\; #\>))
   (when atsign
     (format-error "Atsign flag not allowed"))
   (let ((first-seg (format-stringify-output (sub-format prev tilde))))
     (if (char= cmd #\;)
	 (multiple-value-bind
	  (segments numsegs numchars)
	  (format-get-trailing-segments)
	  (if colon
	      (values first-seg parms segments numsegs numchars)
	      (values nil nil (cons first-seg segments) (1+ numsegs)
		      (+ (length first-seg) numchars))))
	 (values nil nil (list first-seg) 1 (length first-seg))))))


   

;;; Given the total number of SPACES needed for padding, and the number
;;; of padding segments needed (PADDINGS), returns a list of such segments.
;;; We try to allocate the spaces equally to each segment.  When this is
;;; not possible, allocate any left over spaces to the first segment.

(defun make-pad-segs (spaces padding-segs)
  (do* ((extra-space () (and (plusp extra-spaces)
			     extra-inc
			     (zerop (rem segs extra-inc))))
	(result () (cons (cond ((= segs 1) (+ min-space extra-spaces))
			       (extra-space (1+ min-space))
			       (t min-space))
			 result))
	(min-space (truncate spaces padding-segs))
	(extra-spaces (- spaces (* padding-segs min-space))
		      (if extra-space
			  (1- extra-spaces) extra-spaces))
	(extra-inc (if (plusp extra-spaces)
		       (truncate spaces extra-spaces)))
	(segs padding-segs (1- segs)))
       ((zerop segs) result)))
  

;;; Determine the actual width to be used for a field requiring WIDTH
;;; characters according to the following rule:  If WIDTH is less than or
;;; equal to MINCOL, use WIDTH as the actual width.  Otherwise, round up 
;;; to MINCOL + k * COLINC for the smallest possible positive integer k.

(defun format-round-columns (width mincol colinc)
  (if (> width mincol)
      (multiple-value-bind
       (quotient remainder)
       (floor (- width mincol) colinc)
       (+ mincol (* quotient colinc) (if (zerop remainder) 0 colinc)))
      mincol))



(defun format-justification (colon atsign parms)
  (with-format-parameters parms
    ((mincol 0) (colinc 1) (minpad 0) (padchar #\space))
    (unless (and (integerp mincol) (not (minusp mincol)))
      (format-error "Mincol must be a non-negative integer - ~S" mincol))
    (unless (and (integerp colinc) (plusp colinc))
      (format-error "Colinc must be a positive integer - ~S" colinc))
    (unless (and (integerp minpad) (not (minusp minpad)))
      (format-error "Minpad must be a non-negative integer - ~S" minpad))
    (unless (characterp padchar)
      (format-error "Padchar must be a character - ~S" padchar))
    (nextchar)
    (multiple-value-bind
	(special-arg special-parms segments numsegs numchars)
	(format-get-segments)
      (let* ((padsegs (+ (if (or colon (= numsegs 1)) 1 0)
			 (1- numsegs)
			 (if (and atsign (or (/= numsegs 1) colon))
			     1 0)))
	     (width (format-round-columns (+ numchars (* minpad padsegs))
					  mincol colinc))
	     (spaces (append (if (or colon (= numsegs 1)) () '(0))
			     (make-pad-segs (- width numchars) padsegs)
			     (if (and atsign (or (/= numsegs 1) colon))
				 () '(0)))))
	(when special-arg
	  (with-format-parameters special-parms ((spare 0)
						 (linel (or (line-length) 72)))
	    (let ((pos (or (charpos *standard-output*) 0)))
	      (when (> (+ pos width spare) linel)
		(write-string special-arg)))))
	(cond ((and atsign (= numsegs 1) (not colon))
	       (write-string (car segments))
	       (dotimes (i (car spaces)) (write-char padchar)))
	      (t
	       (do ((segs segments (cdr segs))
		    (spcs spaces (cdr spcs)))
		   ((null segs) (dotimes (i (car spcs)) (write-char padchar)))
		 (dotimes (i (car spcs)) (write-char padchar))
		 (write-string (car segs)))))))))

;;; Newline  ~&

(defun format-terpri (colon atsign parms)
  (when (or colon atsign)
    (format-error "Flags not allowed"))
  (with-format-parameters parms ((repeat-count 1))
    (dotimes (i repeat-count) (terpri))))


;;; Fresh-line  ~%

(defun format-freshline (colon atsign parms)
  (when (or colon atsign)
    (format-error "Flags not allowed"))
  (with-format-parameters parms ((repeat-count 1))
    (fresh-line)
    (dotimes (i (1- repeat-count)) (terpri))))


;;; Page  ~|

(defun format-page (colon atsign parms)
  (when (or colon atsign)
    (format-error "Flags not allowed"))
  (with-format-parameters parms ((repeat-count 1))
    (dotimes (i repeat-count) (write-char #\form))))


;;; Print a tilde  ~~

(defun format-tilde (colon atsign parms)
  (when (or colon atsign)
    (format-error "Flags not allowed"))
  (with-format-parameters parms ((repeat-count 1))
    (dotimes (i repeat-count) (write-char #\~))))


;;; Continue control string on next line  ~<newline>

(defun format-eat-whitespace ()
  (nextchar)
  (setq *format-index*
	(1- (the fixnum
		 (position-if-not #'(lambda (ch) (or (whitespace-char-p ch)
						     (char= ch #\linefeed)))
				  (the simple-string *format-control-string*)
				  :start *format-index*)))))


(defun format-newline (colon atsign parms)
  (when parms
    (format-error "Parameters not allowed"))
  (cond (colon
	 (when atsign (format-error "~:@<newline> is undefined")))
	(atsign (terpri)(format-eat-whitespace))
	(t (format-eat-whitespace))))


;;; Pluralize word  ~P

(defun format-plural (colon atsign parms)
  (when parms
    (format-error "Parameters not allowed"))
  (when colon
    ;; Back up one argument first
    (let ((cdrs (- (length (the list *format-original-arguments*))
		   (length (the list *format-arguments*))
		   1)))
      (if (minusp cdrs)
	  (format-error  "No previous argument")
	  (setq *format-arguments*
		(nthcdr cdrs *format-original-arguments*)))))
  (if (eql (pop-format-arg) 1)
      (write-string (if atsign "y" ""))
      (write-string (if atsign "ies" "s"))))



;;; Skip arguments  (relative goto)  ~*

(defun format-skip-arguments (colon atsign parms)
  (with-format-parameters parms ((count 1))
    (cond (atsign
	   (when (or (minusp count)
		     (> count (length *format-original-arguments*)))
	     (format-error "Illegal to go to non-existant argument"))
	   (setq *format-arguments*
		 (nthcdr count *format-original-arguments*)))
	  (colon
	   (let ((cdrs (- (length (the list *format-original-arguments*))
			  (length (the list *format-arguments*))
			  count)))
	     (if (minusp cdrs)
		 (format-error  "Skip to nonexistant argument")
		 (setq *format-arguments*
		       (nthcdr cdrs *format-original-arguments*)))))
	  (t
	   (if (> count (length *format-arguments*))
	       (format-error "Skip to nonexistant argument")
	       (setq *format-arguments* (nthcdr count *format-arguments*)))))))

  

;;; Indirection  ~?

(defun format-indirection (colon atsign parms)
  (if (or colon parms) (format-error "Colon flag or parameters not allowed"))
  (let ((string (pop-format-arg)))
    (unless (stringp string)
      (format-error "Indirected control string is not a string"))
    (format-with-control-string string
      (if atsign
	  (sub-format 0 *format-length*)
	  (let* ((*format-original-arguments* (pop-format-arg))
		 (*format-arguments* *format-original-arguments*))
	    (unless (listp *format-arguments*)
	      (format-error "Argument must be a list"))
	    (sub-format 0 *format-length*))))))



;;; Tabulation  ~T

(defun format-tab (colon atsign parms)
  (with-format-parameters parms ((colnum 1) (colinc 1))
    (when colon
      (format-error "Tab-to in pixel units not supported"))
    (let* ((pos (charpos *standard-output*))
	   (len (cond (pos (let ((col (if atsign (+ pos colnum) colnum)))
			     (if (> pos col)
				 (- colinc (rem (- pos col) colinc))
				 (- col pos))))
		      (atsign colnum)
		      (t 2))))
      (declare (fixnum len))
      (do ((i len (- i 40)))
	  ((<= i 40) (write-string "                                        "
				   *standard-output* :start 0 :end i))
	(declare (fixnum i))
	(write-string "                                        "
		      *standard-output*
		      :start 0
		      :end 40)))))

;;; Ascii  ~A

(defun format-princ (colon atsign parms)
  (let ((arg (pop-format-arg)))
    (if (null parms)
	(if arg (princ arg) (write-string (if colon "()" "NIL")))
	(with-format-parameters parms
	   ((mincol 0) (colinc 1) (minpad 0) (padchar #\space))
	   (format-write-field (if arg
				   (princ-to-string arg)
				   (if colon "()" "NIL"))
			       mincol colinc minpad padchar atsign)))))



;;; S-expression  ~S
	    
(defun format-prin1 (colon atsign parms)
  (let ((arg (pop-format-arg)))
    (if (null parms)
	(if arg (prin1 arg) (write-string (if colon "()" "NIL")))
	(with-format-parameters parms
	   ((mincol 0) (colinc 1) (minpad 0) (padchar #\space))
	   (format-write-field (if arg
				   (prin1-to-string arg)
				   (if colon "()" "NIL"))
			       mincol colinc minpad padchar atsign)))))



;;; Character  ~C

(defun format-print-character (colon atsign parms)
  (with-format-parameters parms ()
    (let ((char (pop-format-arg)))
      (unless (characterp char)
	(format-error "Argument must be a character"))
      (cond ((and atsign (not colon)) (prin1 char))
	    (t (format-print-named-character char colon))))))


(defun format-print-named-character (char longp)
  (when (char-bit char :control) 
    (write-string (if longp "Control-" "C-")))
  (when (char-bit char :meta)
    (write-string (if longp "Meta-" "M-")))
  (when (char-bit char :super)
    (write-string (if longp "Super-" "S-")))
  (when (char-bit char :hyper)
    (write-string (if longp "Hyper-" "H-")))
  (let* ((ch (code-char (char-code char)))	;strip funny bits
	 (name (char-name ch)))
    (cond (name (write-string (string-capitalize name)))
	  ;; Print control characters as "^"<char>
	  ((<= 0 (the fixnum (char-code char)) 31)
	   (write-char #\^)
	   (write-char (code-char (+ 64 (the fixnum (char-code char))))))
	  (t (write-char ch)))))
	  



;;; NUMERIC PRINTING


;;; Insert commas after every third digit, scanning from right to left.

(defun format-add-commas (string commachar)
  (do* ((length (length (the string string)))
	(new-length (+ length
		       (the fixnum (floor (the fixnum (1- length)) 3))))
	(new-string (make-string new-length :initial-element commachar) 
		    (replace (the string new-string)
			     (the string string)
			     :start1 (max 0 (- new-pos 3))
			     :end1 new-pos
			     :start2 (max 0 (- pos 3))
			     :end2 pos))
	(pos length  (- pos 3))
	(new-pos new-length (- new-pos 4)))
       ((not (plusp pos)) new-string)
    (declare (fixnum length new-length pos new-pos))))


;;; Output a string in a field at MINCOL wide, padding with PADCHAR.
;;; Pads on the left if PADLEFT is true, else on the right.  If the
;;; length of the string plus the minimum permissible padding, MINPAD,
;;; is greater than MINCOL, the actual field size is rounded up to
;;; MINCOL + k * COLINC for the smallest possible positive integer k.

(defun format-write-field (string mincol colinc minpad padchar padleft)
  (unless (and (integerp mincol) (not (minusp mincol)))
    (format-error "Mincol must be a non-negative integer - ~S" mincol))
  (unless (and (integerp colinc) (plusp colinc))
    (format-error "Colinc must be a positive integer - ~S" colinc))
  (unless (and (integerp minpad) (not (minusp minpad)))
    (format-error "Minpad must be a non-negative integer - ~S" minpad))
  (unless (characterp padchar)
    (format-error "Padchar must be a character - ~S" padchar))
  (let* ((strlen (length (the string string)))
	 (width (format-round-columns (+ strlen minpad) mincol colinc)))
    (cond (padleft
	   (dotimes (i (- width strlen)) (write-char padchar))
	   (write-string string))
	  (t
	   (write-string string)