;; -*- Mode:Common-Lisp; Package:FORMAT; Base:10. -*-

;;;                           RESTRICTED RIGHTS LEGEND

;;;Use, duplication, or disclosure by the Government is subject to
;;;restrictions as set forth in subdivision (c)(1)(ii) of the Rights in
;;;Technical Data and Computer Software clause at 52.227-7013.
;;;
;;;                     TEXAS INSTRUMENTS INCORPORATED.
;;;                              P.O. BOX 2909
;;;                           AUSTIN, TEXAS 78769
;;;                                 MS 2151
;;;
;;; Copyright (C) 1986-1989 Texas Instruments Incorporated. All rights reserved.

;; Function for printing or creating nicely formatted strings.
;; written by Andrew L. Ressler on September 8, 1982
;; copyright LISP MACHINE INC.
;; permission granted to anyone to use this or modify it.

;; attempt to turn format into a macro facility
;; if it can't do it easily it just makes it call format instead.


;;  6/25/86 DNG - Modified for use as a compiler optimizer; fixed to be re-entrant;
;;		updated programming style; fix so (FORMAT T ...) returns NIL.
;; 10/13/86 DNG - Suppress some of the lengthier optimizations if SPEED is not 
;;		more important than space.  Use WARN-ON-ERRORS.
;; 11/10/86 DNG - Replace uses of MEMQ; add TRY-INLINE declaration for FORMAT-CTL-REPEAT-CHAR.
;; 11/11/86 DNG - Use WRITE-CHAR instead of a WRITE-STRING of length 1.
;;		Change OPTIMIZE-LETS from T to NIL. 
;; 11/14/86 DNG - Quit optimizing when a non-constant parameter is encountered.
;;  3/13/87 DNG - Re-introduce a definition for TICL:FORMAT-MACRO for compatibility.
;;  6/29/88 CLM - Fix for spr 7665 - basically if we encounter a  do a throw to 
;;                impossible and don't try to optimize; also added a handler for a stray .
;;; 8/04/88 DNG - Optimize (FORMAT SELF ...).

(defvar format-results) 


(defvar alt-eval-immediate)  


(defvar final-format-results)


(defvar inside-conditional nil)


(defvar optimize-lets nil) ; turn this off since it doesn't seem to do anything but waste time

(proclaim '(compiler:try-inline format-get-stream format-ctl-repeat-char))

(defun speed-over-space-p ()
  compiler2:(> (opt-speed optimize-switch)
	       (opt-space optimize-switch)))

(defmacro format-macro (&rest args)
  "Like FORMAT, but use in-line code as much as possible."
  ;;  3/13/87 DNG 
  (declare (arglist stream ctl-string &rest args))
  (unless (boundp 'compiler2:p1value)
    (setq compiler2:p1value t))
  (cons (if (if compiler2:compiler-queue compiler2:compiling-common-lisp (common-lisp-on-p))
	    'common-lisp-format-macro
	  'zetalisp-format-macro)
	args))

(defmacro zetalisp-format-macro (stream ctl-string &rest args)
  (prog (( final-format-results nil ))
    (let ((format-arglist args)
	  (format-ctl-one-arg-prop nil)
	  (alt-eval-immediate nil)
	  (loop-arglist nil)
	  (value))
      (setq value
	    (catch 'impossible
	      (catch '|FORMAT-:^-POINT|
		(catch 'format-^-point
		  (cond
		    ((stringp ctl-string) (format-ctl-string-macro args ctl-string))
		    (t (return `(global:format ,stream ,ctl-string ,@args))))))))
      (if (eq value 'impossible)
	(return `(global:format ,stream ,ctl-string ,@args))))
    (return
     (let*((stream-symbol (gensym))
	   (result
	    (cond
	      ((null stream)
	       `(let ((format-string (get-format-string))
		      (*standard-output* 'format-string-stream))
		  ,@(nreverse final-format-results)
		  (prog1
		    (copy-seq (the string format-string))
		    (return-format-string format-string))))
	      ((or (eq t stream)
		  (and (consp stream) (eq (first stream) 'quote) (eq (second stream) t)))
	       `(progn
		  ,.(nreverse final-format-results) nil))
	      (t
		 (si:sublis-eval-once`((,stream-symbol . ,stream))
		   `(let ((format-string nil)
			(*standard-output* (format-get-stream ,stream-symbol)))
		    ,@(nreverse final-format-results)
		    (and (null ,stream-symbol)
			(format-return-string-stream ))))))))
       (if optimize-lets
	 (setq result (elim-lets result))
	 result)))))  


(compiler2:add-optimizer cli:format common-lisp-format-optimizer)

(deff-macro common-lisp-format-macro '(macro . common-lisp-format-optimizer))

(defun common-lisp-format-optimizer ( form &optional environment )
  ;; 11/18/87 CLM - Fix to make sure the args to a FORMAT form have
  ;;                no side-effects before they are optimized out [SPR 6815].
  ;;  8/04/88 DNG - For (FORMAT SELF ...) in a DEFMETHOD, can assume that SELF 
  ;;		must be a stream since it can't be NIL or T.
  (declare (ignore environment))
  (let (( stream (second form) )
	( ctl-string (third form) )
	( args (cdddr form) )
	( final-format-results nil ))
    (when (and (consp ctl-string)
	       (eq (first ctl-string) 'quote)
	       (stringp (second ctl-string)))
      (setf ctl-string (second ctl-string)))
    (if (or (not (stringp ctl-string))
	    compiler2:(> (opt-compilation-speed optimize-switch)
			 (opt-speed optimize-switch))
	    compiler2:(> (opt-safety optimize-switch)
			 (opt-speed-or-space optimize-switch))
	    (eq 'impossible
		(let ((format-arglist args)
		      (format-ctl-one-arg-prop 'format-ctl-common-lisp-one-arg)
		      (alt-eval-immediate 'common-lisp-eval-immediate)
		      (loop-arglist nil))
		  (catch 'impossible
		    (catch '|FORMAT-:^-POINT|
		      (catch 'format-^-point
			(compiler2:warn-on-errors ('bad-format "Error in ~S:" form)
			  (throw 'impossible
			    (format-ctl-string-macro args ctl-string)))
			'impossible))))))
	(if (eq (first form) 'format)
	    form
	  (cons 'format (cdr form)))
      (let* ((stream-symbol (gensym))
	     (result
	      (cond
		((or (eq stream 'nil)
		     (equal stream '(quote nil)))
		 (unless (or (speed-over-space-p) (neq (first form) 'format))
		   (return-from common-lisp-format-optimizer form))
		 `(let ((format-string (get-format-string ))
			(*standard-output* 'format-string-stream))
		    ,@(nreverse final-format-results)
		    (prog1
		      (copy-seq (the string format-string))
		      (return-format-string format-string))))
		((or (eq stream 't)
		     (equal stream '(quote t))
		     (eq stream '*standard-output*))
		 `(progn ,@(nreverse final-format-results)
			 nil))
		((and (or (not (symbolp stream))
			  (get stream 'special))
		      (or (and (eq stream 'self) compiler::SELF-FLAVOR-DECLARATION (speed-over-space-p)) ; 8/4/88 DNG
			  (compiler2:expr-type-p stream 'stream)))
		 `(let ((*standard-output* ,stream))
		    ,@(nreverse final-format-results)
		    nil))
		((and (not (speed-over-space-p))
		      (eq (first form) 'format))
		 (return-from common-lisp-format-optimizer form))
		((and (null compiler2:p1value)
		      (dolist (x args t)
			(unless (compiler:no-side-effects-p x) (return nil)))
		      )
		 (si:sublis-eval-once `((,stream-symbol . ,stream))
		   `(and ,stream-symbol
			 (let* ((format-string nil)
				(*standard-output* (format-get-stream ,stream-symbol)))
			   ,@(nreverse final-format-results)
			   nil))))
		(t
		 (si:sublis-eval-once`((,stream-symbol . ,stream))
		   `(let* ((format-string nil)
			   (*standard-output* (format-get-stream ,stream-symbol)))
		    ,@(nreverse final-format-results)
		    (and (null ,stream-symbol)
			 (format-return-string-stream )))))
		)))
	(if optimize-lets
	    (setq result (elim-lets result))
	  result)))))

(defun format-ctl-string-macro (args ctl-string &aux (format-params nil))
  ;; 11/11/86 DNG - Use WRITE-CHAR instead of a WRITE-STRING of length 1.
  ;; 11/14/86 DNG - Quit optimizing when a non-constant parameter is encountered.
  (unwind-protect (do
		   ((ctl-index 0) (ctl-length (array-active-length ctl-string)) (tem))
		   ((>= ctl-index ctl-length))
		   (setq tem (si:%string-search-char #\~ ctl-string ctl-index ctl-length))
		   (cond
		     ((neq tem ctl-index);Put out some literal string
		      (push
			(let ((end (if (null tem)
				       (length ctl-string)
				     tem)))
			  (if (= end (1+ ctl-index))
			      `(write-char ',(char ctl-string ctl-index))
			    `(write-string ,(subseq (the string ctl-string) ctl-index end))))
		       final-format-results)
		      (if (null tem)
			(return))
		      (setq ctl-index tem)))
		   ;; (AREF CTL-STRING CTL-INDEX) is a tilde.
		   (let ((atsign-flag nil)
			 (colon-flag nil)
			 (format-results nil)
			 (flush-let nil))
		     (if (null format-params)
		       (setq format-params (get-format-params)))
		     (store-array-leader 0 format-params 0)
		     (multiple-value-setq (tem args)
		       (format-parse-command args t))
		     (loop for i from 0 below (length format-params)
			   do (let ((parm (aref format-params i)))
				(cond ((numberp parm))
				      ((constantp parm)
				       (setf (aref format-params i)
					     (compiler2:eval-for-target parm)))
				      ;; else non-constant parameter can only be handled at run-time
				      (t (throw 'impossible 'impossible)))))
		     (multiple-value-setq (args flush-let)
		       (format-ctl-op-macro tem args (g-l-p format-params)))
		     (when (and (eq (car-safe (first format-results)) 'let)
				(not (speed-over-space-p)))
		       (throw 'impossible 'impossible))
		     (if flush-let
		       (push (cons 'progn (nreverse format-results)) final-format-results)
		       (push
			`(progn 
			       
			   ,@(nreverse format-results))
			final-format-results))))
    (and format-params (return-format-params format-params)))
  args)  


;Perform a single formatted output operation on specified args.
;Return the remaining args not used up by the operation.


(defun format-ctl-op-macro (op args params &aux tem immediate)
  (declare (special tem))
  (cond
    ((null op) (format-error "Undefined FORMAT command.") args);e.g. not interned
    ((setq tem
	   (or (and format-ctl-one-arg-prop (get op format-ctl-one-arg-prop))
	      (get op 'format-ctl-one-arg)))
     (if (setq immediate
	    (or (and alt-eval-immediate (get op alt-eval-immediate)) (get op 'eval-immediate)))
       (progn
	 (funcall immediate (car args) params)
	 (values (cdr args) t))
       (progn
	 (push `(let ((atsign-flag ',atsign-flag)
		      (colon-flag ',colon-flag))
		  (funcall ',tem ,(copy-tree (first args)) ',(copy-tree params)))
	       format-results)
	 (cdr args))))
    ((setq tem (get op 'format-ctl-no-arg))
     (if (setq immediate (get op 'eval-immediate))
       (progn
	 (funcall immediate params)
	 (values args t))
       (progn
	 (push `(let ((atsign-flag ',atsign-flag)
		      (colon-flag ',colon-flag))
		  (funcall ',tem ',(copy-tree params)))
	       format-results)
	 args)))
    ((setq tem (get op 'format-ctl-multi-arg))
     (if (setq immediate (get op 'eval-immediate))
       (values (funcall immediate args params) t)
       (push `(let ((atsign-flag ',atsign-flag)
		    (colon-flag ',colon-flag))
		(funcall ',tem ,(copy-tree args) ,(copy-tree params))) format-results)))
    ((setq tem (get op 'format-ctl-repeat-char))
     (push `(format-ctl-repeat-char ,(copy-tree (or (first params) 1)) ,tem) format-results)
     (values args t))
    (t (format-error "\"~S\" is not defined as a FORMAT command." op) args)))  



(defprop * format-ctl-ignore-macro eval-immediate)  


(defun format-ctl-ignore-macro (args params &aux (count (or (car params) 1)))
  (cond
    (atsign-flag (nthcdr count format-arglist))
    (colon-flag
     (do ((a format-arglist (cdr a))
	  (b (nthcdr count format-arglist) (cdr b)))
	 ((null a)
	  (format-error "Can't back up properly for a ~:*"))
       (and (eq b args) (return a))))
    (t (nthcdr count args)))) 



(defprop crlf crlf-macro eval-immediate)  


(defun crlf-macro (ignore)
  (and atsign-flag (push '(terpri) format-results)))  



(defprop % format-ctl-newlines-macro eval-immediate)  


(defun format-ctl-newlines-macro (params &aux (count (or (car params) 1)))
  (push (if (= count 1)
	    '(terpri  )
	    `(write-string ,(make-string count :initial-element  #\NEWLINE) ))
	format-results))




(defprop & format-ctl-fresh-line-macro eval-immediate)  


(defun format-ctl-fresh-line-macro (params &aux (count (or (car params) 1)))
  (push '(fresh-line) format-results)
  (when (> count 1 )
    (push `(write-string ,(make-string (1- count) :initial-element #\NEWLINE) )
	  format-results)))


(defprop ? format-?-macro eval-immediate) 

(defun format-?-macro (&rest ignore)
  (throw 'impossible
	 'impossible)) 


(defprop |(| |FORMAT-(-MACRO| eval-immediate) 

(defun |FORMAT-(-MACRO| (&rest ignore)
  (throw 'impossible
	 'impossible)) 


(defprop x format-ctl-hex-macro common-lisp-eval-immediate) 

(defun format-ctl-hex-macro (arg params)
  (format-ctl-decimal-macro arg params 16)) 



(defprop d format-ctl-decimal-macro eval-immediate)  


(defun format-ctl-decimal-macro (arg params &optional (*print-base* 10);Also called for octal
      &aux (width (first params)) (padchar (second params)) (commachar (third params))
      (gen-arg (gensym)))
  (declare (special tem))
  (setq padchar
	(cond
	  ((null padchar) #\SPACE)
	  ((numberp padchar) padchar)
	  (t (aref (string padchar) 0)))
	commachar
	(cond
	  ((null commachar) #\,)
	  ((numberp commachar) commachar)
	  (t (aref (string commachar) 0))))
  (if (or width colon-flag)
      (push `(let ((atsign-flag ',atsign-flag)
	       (colon-flag ',colon-flag))
	       (funcall ',tem ,(copy-tree arg) ',(copy-tree params)))
	    format-results)
      (push
	`(let ((*print-base* ,*print-base*)
	       (*nopoint t)
	       (,gen-arg ,arg))
	   ,@(if atsign-flag
		 `((if (and (numberp ,gen-arg) (not (minusp ,gen-arg)))
		       (write-char #\+)))
		 ())
	   (princ ,gen-arg))
   format-results)))
 


(defprop o format-ctl-octal-macro eval-immediate)  


(defun format-ctl-octal-macro (arg params)
  (format-ctl-decimal-macro arg params 8))  



(defprop f format-ctl-f-format-macro eval-immediate)  


(defun format-ctl-f-format-macro (arg params)
  (push
   `(let ((arg ,arg))
      (and (numberp arg) (not (floatp arg)) (setq arg (float arg)))
      (if (not (floatp arg))
	,(let ((format-results nil))
	   (format-ctl-decimal-macro 'arg ())
	   format-results)
	(si::print-flonum arg *standard-output* () (small-floatp arg) ,(first params) ())))
   format-results))  



(defprop e format-ctl-e-format-macro eval-immediate)  


(defun format-ctl-e-format-macro (arg params)
  (push
   `(let ((arg ,arg))
      (and (numberp arg) (not (floatp arg)) (setq arg (float arg)))
      (if (not (floatp arg))
	,(let ((format-results nil))
	   (format-ctl-decimal-macro 'arg ())
	   format-results)
	(si::print-flonum arg *standard-output* () (small-floatp arg) ,(first params) t)))
   format-results))  


(defprop e format-ctl-hairy-macro common-lisp-eval-immediate) 

(defprop f format-ctl-hairy-macro common-lisp-eval-immediate) 

(defprop g format-ctl-hairy-macro common-lisp-eval-immediate) 


(defun format-ctl-hairy-macro (arg &optional params)
  (declare (special tem))
  (push `(let ((atsign-flag ',atsign-flag)
	       (colon-flag ',colon-flag))
	       (funcall ',tem ,(copy-tree arg) ',(copy-tree params)))
  format-results))


(defprop a format-ctl-ascii-macro eval-immediate)  


(defun format-ctl-ascii-macro (arg params &optional prin1p)
  (let ((edge (car params))
	(padchar (cadddr params)))
    (declare (special tem))
    (if edge
	(push `(let ((atsign-flag ',atsign-flag)
	       (colon-flag ',colon-flag))
		 (funcall ',tem ,(copy-tree arg) ',(copy-tree params)))
	      format-results)
	(progn 
	  (cond
	    ((null padchar) (setq padchar #\SPACE))
	    ((not (numberp padchar)) (setq padchar (character padchar))))
	  (cond
	    (atsign-flag)			;~@5nA right justifies
	    (colon-flag
	     (if prin1p
		 (push
		   `(prin1 ,arg)
		   format-results)
		 (push
		   `(princ ,arg)
		   format-results)))
	    (prin1p (push `(prin1 ,arg) format-results))
	    (t
	     (push `(princ ,arg)
		   format-results)))
	  (cond
	    ((null atsign-flag))
	    (colon-flag
	     (if prin1p
		 (push
		   `(prin1 ,arg)
		   format-results)
		 (push
		   `(princ ,arg)
		   format-results)))
	    (prin1p (push `(prin1 ,arg) format-results))
	    (t
	     (push `(princ ,arg)
		   format-results)))))))



(defprop s format-ctl-sexp-macro eval-immediate)  


(defun format-ctl-sexp-macro (arg params)
  (format-ctl-ascii-macro arg params t))  



(defprop g format-ctl-goto-macro eval-immediate)  


(defun format-ctl-goto-macro (ignore params &aux (count (or (car params) 1)))
  (nthcdr count format-arglist))  



(defprop p format-ctl-plural-macro eval-immediate)  


(defun format-ctl-plural-macro (args ignore)
  (and colon-flag (setq args (format-ctl-ignore-macro args ())));crock: COLON-FLAG is set
  (if atsign-flag
    (push
     `(if (equal ,(car args) 1)
	(write-char #\y)
	(write-string "ies" ))
     format-results)
    (push `(or (equal ,(car args) 1) (write-char #\s)) format-results))
  (cdr args))  



(defprop q format-ctl-apply-macro eval-immediate)  


(defun format-ctl-apply-macro (arg params)
  (push `(apply ,arg ,params) format-results))  

(defun format-ctl-hairy-macro-no-arg (&optional params)
  (declare (special tem))
  (push `(let ((atsign-flag ',atsign-flag)
	       (colon-flag ',colon-flag))
	       (funcall ',tem  ',(copy-tree params)))
  format-results))
;;; PHD 6/30/86, turned TAB optimizer off, there is too much code generated.
(defprop t format-ctl-hairy-macro-no-arg  eval-immediate)  


(defun format-ctl-tab-macro (params &aux (dest (or (first params) 1)) (extra (or (second params) 1)))
  (push
   `(let ((ops (send *standard-output* :which-operations))
       (incr-ok))
   (cond
     ((or (setq incr-ok (member :increment-cursorpos ops :test #'eq))
	 (member :set-cursorpos ops :test #'eq))
      (multiple-value-bind (x y)
	(send *standard-output* :read-cursorpos ,(if colon-flag
						   :pixel
						   :character))
	(let ((new-x
	       (if (< x ,dest)
		 ,dest
		 ,(if (eql extra 1)
		    '(1+ x)
		    `(* (1+ (floor x ,extra)) ,extra)))))
	  (cond
	    (incr-ok
	     (send *standard-output* :increment-cursorpos (- new-x x) 0
		,(if colon-flag
		   :pixel
		   :character)))
	    (t
	     (send *standard-output* :set-cursorpos new-x y ,(if colon-flag
							       :pixel
							       :character)))))))
     (t (write-string  "   ")))) 
   format-results))  



(defprop [ format-ctl-start-case-macro eval-immediate)  


(defun format-ctl-start-case-macro (args params &aux (arg (car args)))
  (let ((inside-conditional t))
    (let ((clauses (format-parse-clauses '] t))
	  (remaining-args 'no-args)
	  (default nil))
      (cond
	(colon-flag
	 (cond
	   (atsign-flag (format-error "~~:@[ is not a defined FORMAT command"))
	   (t (pop args))))
	(atsign-flag (throw 'impossible
			    'impossible))
	(t (pop args)))
      (push
       `(let ((arg
	       ,(cond
		  (colon-flag
		   (cond
		     (atsign-flag (format-error "~~:@[ is not a defined FORMAT command"))
		     (t `(if ,arg
			   1
			   0))))
		  (atsign-flag `(if ,arg
				  0
				  -1))
		  ((car params) (car params))
		  (t arg))))
	  (cond
	    . ,(loop for clause on (g-l-p clauses) by #'cdddr for clause-number from 0 as string
		  = (first clause) as code =
		  (let* ((final-format-results nil)
			 (arguments (format-ctl-string-macro args string)))
		    (if (or (eq remaining-args 'no-args) (equal remaining-args arguments))
		      (setq remaining-args arguments)
		      (throw 'impossible
			     'impossible))
		    (nreverse final-format-results))
		  collect
		  (prog1
		    (if default
		      `(t . ,code)
		      `((= ,clause-number arg) . ,code))
		    (setf default (not (evenp (second clause))))))))
       format-results)
      remaining-args)))  



(defprop ] format-ctl-end-case-macro eval-immediate)  


(defun format-ctl-end-case-macro (ignore)
  (format-error "Stray ~~] in FORMAT control string"))  



(defun elim-lets (tree)
  (if (atom tree)
      tree
    (progn
      (setq tree (eliminate-lets tree))
      (elim-lets (car tree))
      (elim-lets (cdr tree))
      tree)))



(defun eliminate-lets (tree)
  (if (and (consp tree) (consp (first tree)) (consp (second tree)))
    (if (and (eq 'let (first (first tree))) (eq 'let (first (second tree))))
     ;; then maybe we can eliminate something
      (if (equal (second (first tree)) (second (second tree)))
       ;; then we can eliminate the lets probably.
	(progn
	  (setf (second tree)
		`(let ,(second (first tree))
		   ,(third (first tree))
		   ,(third (second tree))))
	  (setf (first tree) '(progn)))
	tree)
      tree)
    tree))  



(defprop \| format-ctl-forms-macro eval-immediate)  


(defun format-ctl-forms-macro (params)
  ;; 11/10/86 DNG - Use :operation-handled-p operation instead of :which-operations.
  (if colon-flag
      (push
	`(if (send *standard-output* :operation-handled-p :clear-screen)
	     (send *standard-output* :clear-screen)
	   (format-ctl-repeat-char ,(or (first params) 1) #\PAGE))
	format-results)
    (push `(format-ctl-repeat-char ,(or (first params) 1) #\PAGE)
	  format-results)))




(defprop { format-iterate-over-list-maco eval-immediate)  


(defun format-iterate-over-list-maco (&rest ignore)
  (throw 'impossible
	 'impossible))  



(defprop ^ format-ctl-terminate-macro eval-immediate)  


(defun format-ctl-terminate-macro (&rest ignore)
  (throw 'impossible
	 'impossible))

;;;clm 6/29/88
(defprop  format-hairy-justification-macro  eval-immediate)

(defprop  format-ctl-end-indent-hairy-macro eval-immediate)

(defun format-ctl-end-indent-hairy-macro (ignore)
  (format-error "Stray ~~ in FORMAT control string"))
  

;This is not so hairy as to work with ~T, tabs, crs.  I really don't see how to do that.
;It makes a list of strings, then decides how much spacing to put in,
;then goes back and outputs.


(defprop < format-hairy-justification-macro eval-immediate)  


(defun format-hairy-justification-macro (&rest ignore)
  (throw 'impossible
	 'impossible))  



(comment
(defun format-hairy-justification-macro (args params)
  (let ((mincol (or (first params) 0))
	(colinc (or (second params) 1))
	(minpad (or (third params) 0))
	(padchar (or (fourth params) #\SPACE))
	(temp-results nil))
    '(let ((newline nil)
	   (extra 0)
	   (linewidth nil)
	   (strings nil)
	   (string-ncol 0)
	   (clauses)
	   (n-padding-points -1)
	   (total-padding)
	   (n-pads)
	   (n-extra-pads))
       (push '((w-o (send *standard-output* ':which-operations))) temp-results)
       (and colon-flag (setq n-padding-points (1+ n-padding-points)))
       (and atsign-flag (setq n-padding-points (1+ n-padding-points)))
       (*catch 'format-^-point
	       (progn
		 (setq clauses (format-parse-clauses '> t))
		 (do ((specs (g-l-p clauses) (cdddr specs))
		      (str))
		     ((null specs))
		   (multiple-value (args str-code)
		      (format-ctl-string-to-string args (car specs)))
		   (push `(setq str ,str-code) temp-results)
		   (push
		    '(progn
		       (setq string-ncol (+ (string-length str) string-ncol))
		       (setq n-padding-points (1+ n-padding-points))
		       (setq strings (cons-in-area str strings format-temporary-area)))
		    temp-results))))
       (push '(setq strings (nreverse strings)) temp-results)
       (cond
	 ((and (g-l-p clauses) (oddp (cadr (g-l-p clauses))))
	  (push
	   `(progn
	      (setq newline (pop strings))
	      (and ,(caddr (g-l-p clauses))
		 (setq extra ,(or (car (g-l-p (caddr (g-l-p clauses)))) 0)
		       linewidth ,(cadr (g-l-p (caddr (g-l-p clauses))))))
	      (setq string-ncol (- string-ncol (string-length newline)))
	      (setq n-padding-points (1- n-padding-points)))
	   temp-results)))
       (push
	`(progn
	   (and (zerop n-padding-points) (setq colon-flag t
					       n-padding-points 1))
	   (setq total-padding (+ (* n-padding-points minpad) string-ncol))
	   (setq total-padding
		 (-
		  (+ mincol
		     (* colinc (floor (+ (max (- total-padding mincol) 0) (1- colinc)) colinc)))
		  string-ncol))
	   (cond
	     ((and newline (global:memq ':read-cursorpos w-o)
		   (> (+ (send *standard-output* ':read-cursorpos ':character) string-ncol
			 total-padding extra)
		      (or linewidth
			  (and (global:memq ':size-in-characters w-o)
			       (send *standard-output* ':size-in-characters))
			  95)))
	      (write-string newline)))
	   (multiple-value-setq( n-pads n-extra-pads )(floor total-padding n-padding-points))
	   (or (zerop n-extra-pads) (setq n-pads (1+ n-pads)))
	   (do ((strings strings (cdr strings))
		(pad-before-p colon-flag t))
	       ((null strings))
	     (cond
	       (pad-before-p (format-ctl-repeat-char n-pads ,padchar)
		(and (zerop (setq n-extra-pads (1- n-extra-pads))) (setq n-pads (1- n-pads)))))
	     (write-string (first strings) ))
	   ,@(and atsign-flag `((format-ctl-repeat-char n-pads ,padchar)))
	   (dolist (str (nreverse strings))
	     (return-array str))
	   (and newline (return-array newline))
	   (format-reclaim-clauses clauses))
	temp-results)
       (push (cons 'let (nreverse temp-results)) format-results)
       args))))
  



(defprop > format-ctl-end-hairy-justification-macro eval-immediate)  


(defun format-ctl-end-hairy-justification-macro (ignore)
  (format-error "Stray ~~> in FORMAT control string"))  


(defprop |(| format-ctl-start-case-convert-macro eval-immediate) 


(defun format-ctl-start-case-convert-macro (args ignore)
  (let* ((clauses (format-parse-clauses '|)| ()))
	 (final-format-results nil)
	 (arguments (format-ctl-string-macro args (aref clauses 0))))
    (push
     `(let ((case-convert
	     ,(if colon-flag
		(if atsign-flag
		  ''uppercase
		  ''cap-all-words)
		(if atsign-flag
		  ''cap-first-word
		  ''lowercase)))
	    (prev-char 0)
	    (case-converted-stream (if case-convert
				     case-converted-stream
				     *standard-output*))
	    (*standard-output* 'case-convert-stream))
	,@(nreverse final-format-results))
     format-results)
    (format-reclaim-clauses clauses)
    arguments)) 

(comment
 ;;; This function is like FORMAT-CTL-STRING except that instead of sending to
 ;;; STANDARD-OUTPUT it sends to a string and returns that as its second value.
 ;;; The returned string is in the temporary area.
 (defun format-ctl-string-to-string-macro (args str)
   (let* ((format-results)
	  (args-result (format-ctl-string args str)))
     (values args-result
	     `(let ((format-string
		     (make-array 128 ':area format-temporary-area ':type 'art-string
				 ':leader-list '(0)))
		    (standard-output 'format-string-stream))
		,@(nreverse format-results)
		(adjust-array-size format-string (array-active-length format-string)))))))