format.lisp

;;; -*- Mode: Common-Lisp; Syntax: Common-Lisp; Package: LINJ; Base: 10 -*-

;;; **********************************************************************
;;; This code was written as part of the CMU Common Lisp project at
;;; Carnegie Mellon University, and has been placed in the public domain.
;;;
;;;
;;; **********************************************************************
;;;
;;; Functions to implement FORMAT and FORMATTER for CMU Common Lisp.
;;;
;;; Written by William Lott, with lots of stuff stolen from the previous
;;; version by David Adam and later rewritten by Bill Maddox.
;;; 

(in-package "LINJ")

;;This file requires the Linj readtable
(eval-when (:compile-toplevel :load-toplevel)
  (setq *readtable* *linj-readtable*))


;;This is the stream "variable" to be used in code generation

(defvar *stream*)

(defvar *result-type*)

(defun emit-format-code (type fmt stream full-args)
  (let ((*stream* stream)
	(*result-type* type))
    (%formatter fmt full-args)))

(defun gen-write-char (form)
  (ecase *result-type*
    (:expression (if (characterp form) form `(real-the char ,form)))
    (:statement `(write-char ,form ,*stream*))
    (:string-buffer `(send ,*stream* append ,form))))

(defun gen-write-string (form)
  (ecase *result-type*
    (:expression (if (stringp form) form `(real-the java.lang.string ,form)))
    (:statement `(write-string ,form ,*stream*))
    (:string-buffer `(send ,*stream* append ,form))))

(defun gen-prin1 (form)
  (ecase *result-type*
    (:expression form)
    (:statement `(prin1 ,form ,*stream*))
    (:string-buffer `(send ,*stream* append ,form))))

(defun gen-princ (form)
  (ecase *result-type*
    (:expression form)
    (:statement `(princ ,form ,*stream*))
    (:string-buffer `(send ,*stream* append ,form))))
  
(defun gen-terpri ()
  (ecase *result-type*
    (:expression '#\newline)
    (:statement `(terpri ,*stream*))
    (:string-buffer `(send ,*stream* append #\newline))))
  
(defun gen-fresh-line ()
  (ecase *result-type*
    (:expression '#\newline)
    (:statement `(fresh-line ,*stream*))
    (:string-buffer `(send ,*stream* append #\newline))))

(defun gen-progn (forms)
  (ecase *result-type*
    (:expression
     `(concat ,@forms))
    ((:statement :string-buffer)
     (if (and (not (endp forms)) (endp (rest forms)))
       (first forms)
       `(progn ,@forms)))))

(defun gen-when (test forms)
  (ecase *result-type*
    (:expression
     `(if ,test ,(gen-progn forms) ""))
    ((:statement :string-buffer)
     `(when ,test
       ,@forms))))


(defstruct (format-directive
	    (:print-function %print-format-directive))
  (string (required-argument) :type simple-string)
  (start (required-argument) :type (and unsigned-byte fixnum))
  (end (required-argument) :type (and unsigned-byte fixnum))
  (character (required-argument) :type base-char)
  (colonp nil :type (member t nil))
  (atsignp nil :type (member t nil))
  (params nil :type list))

(defun required-argument ()
  (error "Missing argument"))

(defun %print-format-directive (struct stream depth)
  (declare (ignore depth))
  (print-unreadable-object (struct stream)
    (write-string (format-directive-string struct) stream
		  :start (format-directive-start struct)
		  :end (format-directive-end struct))))

(defvar *format-directive-expanders*
  (make-array char-code-limit :initial-element nil))
(defvar *format-directive-interpreters*
  (make-array char-code-limit :initial-element nil))

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

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

(define-condition format-error (error)
  ((complaint :reader format-error-complaint :initarg :complaint)
   (arguments :reader format-error-arguments :initarg :arguments :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))

;;;; TOKENIZE-CONTROL-STRING

(defun tokenize-control-string (string)
  (declare (simple-string string))
  (let ((index 0)
	(end (length string))
	(result nil))
    (loop
      (let ((next-directive (or (position #\~ string :start index) end)))
	(when (> next-directive index)
	  (push (subseq string index next-directive) result))
	(when (= next-directive end)
	  (return))
	(let ((directive (parse-directive string next-directive)))
	  (push directive result)
	  (setf index (format-directive-end directive)))))
    (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))))
      (loop
	(let ((char (get-char)))
	  (cond ((or (char<= #\0 char #\9) (char= char #\+) (char= char #\-))
		 (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))
		 (push (cons posn :arg) params)
		 (incf posn)
		 (case (get-char)
		   (#\,)
		   ((#\: #\@)
		    (decf posn))
		   (t
		    (return))))
		((char= char #\#)
		 (push (cons posn :remaining) params)
		 (incf posn)
		 (case (get-char)
		   (#\,)
		   ((#\: #\@)
		    (decf posn))
		   (t
		    (return))))
		((char= char #\')
		 (incf posn)
		 (push (cons posn (get-char)) params)
		 (incf posn)
		 (unless (char= (get-char) #\,)
		   (decf posn)))
		((char= char #\,)
		 (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 at-signs supplied."
			    :control-string string
			    :offset posn)
		     (setf atsignp t)))
		(t
		 (when (char= (schar string (1- posn)) #\,)
		   (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))))))


;;;; Specials used to communicate information.

;;; *UP-UP-AND-OUT-ALLOWED* -- internal.
;;;
;;; 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)

;;; *LOGICAL-BLOCK-POPPER* -- internal.
;;;
;;; Used by the interpreter stuff.  When it non-NIL, its a function that will
;;; invoke PPRINT-POP in the right lexical environemnt.
;;;
(defvar *logical-block-popper* nil)

;;; *ONLY-SIMPLE-ARGS* -- internal.
;;;
;;; 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*)

;;; *ORIG-ARGS-AVAILABLE* -- internal.
;;;
;;; 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)

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

(defvar *orig-args*)
(defvar *args*)
(defvar *no-value* (list 'progn))


;;;; FORMATTER

(defun %formatter (control-string args)
  (let* ((*simple-args* nil)
	 (*only-simple-args* t)
	 (*orig-args* args)
	 (*args* args))
    (expand-control-string control-string)))


(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)))
    (ecase *result-type*
      ((:statement :string-buffer)
       `(block nil
	  ,@(expand-directive-list directives)))
      (:expression
       `(concat
	 ,@(remove '(concat) (expand-directive-list directives) :test #'equal)))))) ;;small optimization

(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))
	(unless (equal form '(progn))
	  (setq results (combine-format-form form results)))
	(setf remaining-directives new-directives)))
    (reverse results)))

(defun combine-format-form (form forms)
  (if (let-pattern (((write-string (?is ?obj (lambda (obj) (and (stringp obj) (string= obj "")))) ?ignore) form)) t)
      forms
      (or 
       (let-pattern (((write-string (?is ?string1 stringp) ?stream) form)
		     (((write-string (?is ?string2 stringp) ?ignore) . ?ignore) forms))
	 `((write-string ,(concatenate 'string ?string2 ?string1) ,?stream) ,@(rest forms)))
       (let-pattern (((terpri ?stream) form)
		     (((write-string ?string2 ?ignore) . ?ignore) forms))
	 `((write-line ,?string2 ,?stream) ,@(rest forms)))
       (let-pattern (((terpri ?stream) form)
		     (((princ ?obj ?ignore) . ?ignore) forms))
	 `((println ,?obj ,?stream) ,@(rest forms)))
       (cons form forms))))

(defun expand-directive (directive more-directives)
  (etypecase directive
    (format-directive
     (let ((expander
	    (aref *format-directive-expanders*
		  (char-code (format-directive-character directive))))
	   (*default-format-error-offset*
	    (1- (format-directive-end directive))))
       (if expander
	   (funcall expander directive more-directives)
	   (error 'format-error
		  :complaint "Unknown directive."))))
    (simple-string
     (values (gen-write-string directive)
	     more-directives))))

(defun protect (form)
  (if (or *orig-args-available* (not *only-simple-args*))
    `(if (endp args)
       (error "No more arguments.")
       (let ((arg (first args)))
	 (setq args (rest args))
	 ,form))
    form))

(defun expand-next-arg (&optional offset)
  (if (or *orig-args-available* (not *only-simple-args*))
    'arg
    (if (endp *args*)
      (error 'format-error
	     :complaint "No more arguments."
	     :control-string *default-format-error-control-string*
	     :offset (or offset *default-format-error-offset*))
      (pop *args*))))


;;;; Format directive definition macros and runtime support.

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

(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)))

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

(defmacro def-complex-format-directive (char lambda-list &body body)
  (let ((defun-name (intern (cl:format nil
				       "~:@(~:C~)-FORMAT-DIRECTIVE-EXPANDER"
				       char)))
	(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
				     (,(intern (concatenate
						'string
						"FORMAT-DIRECTIVE-"
						(symbol-name var))
					       (symbol-package 'foo))
				      ,directive)))
			       (butlast lambda-list))
		   ,@body))
	       `((declare (ignore ,directive ,directives))
		 ,@body)))
       (%set-format-directive-expander ,char #',defun-name))))

(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))))

(defmacro once-only (specs &body body)
  (labels ((frob (specs body)
	     (if (null specs)
	       `(progn ,@body)
	       (let ((spec (first specs)))
		 (when (/= (length spec) 2)
		   (error "Malformed Once-Only binding spec: ~S." spec))
		 (let ((name (first spec))
		       (exp-temp (gensym)))
		   `(let ((,exp-temp ,(second spec))
			  (,name (gensym "OO-")))
		      `(let ((,,name ,,exp-temp))
			 ,,(frob (rest specs) body))))))))
    (frob specs body)))

;; (defmacro expand-bind-defaults (specs params &body body)
;;   (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
;; 				    (progn (setf *only-simple-args* nil) (error "BUM"))
;; 				    '(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 ~D"
;; 				    :arguments (list ,(length specs))
;; 				    :offset (caar ,params)))
;; 		       ,,@body)))
;; 	`(progn
;; 	   (when ,params
;; 	     (error 'format-error
;; 		    :complaint "Too many parameters, expected no more than 0"
;; 		    :offset (caar ,params)))
;; 	   ,@body))))

(defmacro expand-bind-defaults (specs params &body body)
  (once-only ((params params))
    (if specs
      `(let ,(mapcar #'(lambda (spec)
			 (destructuring-bind (var default) spec
			   `(,var
			     (let* ((param-and-offset (pop ,params))
				    (offset (car param-and-offset))
				    (param (cdr param-and-offset)))
			       (case param
				 (:arg (let ((arg (expand-next-arg offset)))
					 (if (false-literal-p arg) ;;nil arg
					   ,default
					   arg)))
				 (:remaining
				  (if *only-simple-args*
				    (length *args*)
				    '(length args)))
;; 				 (:remaining
;; 				  (length *args*))
				 ((nil) ,default)
				 (t param))))))
		     specs)
	 (unless (endp ,params)
	   (error 'format-error
		  :complaint "Too many parameters, expected no more than ~D"
		  :arguments (list ,(length specs))
		  :offset (caar ,params)))
	 ,@body)
      `(progn
	 (when ,params
	   (error 'format-error
		  :complaint "Too many parameters, expected no more than 0"
		  :offset (caar ,params)))
	 ,@body))))

); eval-when

(defun %set-format-directive-expander (char fn)
  (setf (aref *format-directive-expanders* (char-code (char-upcase char))) 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)))))

(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-directive #\A (colonp atsignp params)
  (protect
   (if colonp
     (error "Linj separates NIL and ().  A consequence is that it doesn't make sense to use ~~:A as ~~A will never print NIL for an empty list")
     (if params
       (expand-bind-defaults
	   ((mincol 0) (colinc 1) (minpad 0) (padchar #\space)) params
	 (gen-princ `(format-write-field-to-string
		      ,(expand-next-arg)
		      ,mincol ,colinc ,minpad ,padchar ,atsignp)))
       (gen-princ (expand-next-arg))))))


(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-directive #\S (colonp atsignp params)
  (protect
   (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)
	       (princ "()"))))
	 (t
	  (gen-prin1 (expand-next-arg))))))


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


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


;;;; Integer outputting.

;;; 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))))

(defun expand-format-integer (base colonp atsignp params)
  (protect
   (if (or colonp atsignp params)
     (expand-bind-defaults
      ((mincol 0) (padchar #\space) (commachar #\,) (commainterval 3))
      params
      (gen-princ `(format-print-integer-to-string
		   ,(expand-next-arg)
		   ,colonp ,atsignp ,base ,mincol ,padchar ,commachar ,commainterval)))
     (gen-princ `(to-base ,(expand-next-arg) ,base)))))

(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)
  (protect
   (if params
     (expand-bind-defaults
      ((base 10) (mincol 0) (padchar #\space) (commachar #\,)
       (commainterval 3))
      params
      (gen-princ `(format-print-integer-to-string
		   ,(expand-next-arg)
		   ,colonp ,atsignp ,base ,mincol ,padchar ,commachar ,commainterval)))
     (if atsignp
       (if colonp
	 (gen-princ `(format-print-old-roman-to-string ,(expand-next-arg)))
	 (gen-princ `(format-print-roman-to-string ,(expand-next-arg))))
       (if colonp
	 (gen-princ `(format-print-ordinal-to-string ,(expand-next-arg)))
	 (gen-princ `(format-print-cardinal-to-string ,(expand-next-arg))))))))


;;;; Plural.

(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)))))
		(t
		 (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))))))))
      (let ((form (if atsignp
		    (gen-write-string `(if (eql ,arg 1) "y" "ies"))
		    (ecase *result-type*
		      (:expression `(if (eql ,arg 1) "s" ""))
		      (:statement `(unless (eql ,arg 1) (write-char #\s ,*stream*)))
		      (:string-buffer `(unless (eql ,arg 1) (send ,*stream* append #\s)))))))
	(if (not colonp)
	  (protect form)
	  form)))))


;;;; Floating point noise.

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

;; (def-format-directive #\F (colonp atsignp params)
;;   (when colonp
;;     (error 'format-error
;; 	   :complaint
;; 	   "Cannot specify the colon modifier with this directive."))
;;   (protect
;;    (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))))

;; (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
;;    ((or (not (or w d))
;; 	(and (floatp number)
;; 	     (or (float-infinity-p number)
;; 		 (float-nan-p number))))
;;     (prin1 number stream)
;;     nil)
;;    (t
;;     (let ((spaceleft w))
;;       (when (and w (or atsign (minusp number))) (decf spaceleft))
;;       (multiple-value-bind 
;; 	  (str len lpoint tpoint)
;; 	  (lisp::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)) (setq 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)))
;; 	       (if (minusp number)
;; 		   (write-char #\- stream)
;; 		   (if atsign (write-char #\+ stream)))
;; 	       (when lpoint (write-char #\0 stream))
;; 	       (write-string str stream)
;; 	       (when tpoint (write-char #\0 stream))
;; 	       nil)))))))

;; (def-format-directive #\E (colonp atsignp params)
;;   (when colonp
;;     (error 'format-error
;; 	   :complaint
;; 	   "Cannot specify the colon modifier with this directive."))
;;   (protect
;;    (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))))

;; (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.

;;; toy@rtp.ericsson.se:  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 (float-infinity-p number)
;; 	       (float-nan-p number)))
;;       (prin1 number stream)
;;       (multiple-value-bind (num expt)
;; 			   (lisp::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)
;; 		  (lisp::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-directive #\G (colonp atsignp params)
;;   (when colonp
;;     (error 'format-error
;; 	   :complaint
;; 	   "Cannot specify the colon modifier with this directive."))
;;   (protect
;;    (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))))

;; (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)))


;;; toy@rtp.ericsson.se:  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 (float-infinity-p number)
;; 	       (float-nan-p number)))
;;       (prin1 number stream)
;;       (multiple-value-bind (ignore n) 
;; 	  (lisp::scale-exponent (abs number))
;; 	(declare (ignore ignore))
;; 	;;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.
;; 	(unless d
;; 	  (multiple-value-bind (str len) 
;; 	      (lisp::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-directive #\$ (colonp atsignp params)
  (protect
   (expand-bind-defaults
    ((d 2) (n 1) (w 0) (pad #\space)) params
    `(format-dollars ,*stream* ,(expand-next-arg) ,d ,n ,w ,pad ,colonp
		     ,atsignp))))

;; (defun format-dollars (stream number d n w pad colon atsign)
;;   (if (rationalp number) (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)
;; 			     (lisp::flonum-to-string number nil d nil)
;; 	  (declare (ignore ig2 ig3))
;; 	  (when colon (write-string signstr stream))
;; 	  (dotimes (i (- w signlen (max 0 (- n pointplace)) strlen))
;; 	    (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)))


;;;; line/page breaks and other stuff like that.

(def-format-directive #\% (colonp atsignp params)
  (when (or colonp atsignp)
    (error 'format-error
	   :complaint
	   "Cannot specify either colon or atsign for this directive."))
  (if params
      (expand-bind-defaults
       ((count 1)) params
       (ecase *result-type*
	 (:expression
	  (make-string count :initial-element #\newline))
	 (:statement
	  `(dotimes (i ,count)
	     (terpri ,*stream*)))
	 (:string-buffer
	  `(dotimes (i ,count)
	     (send ,*stream* append #\newline)))))
      (gen-terpri)))


(def-format-directive #\& (colonp atsignp params)
  (when (or colonp atsignp)
    (error 'format-error
	   :complaint
	   "Cannot specify either colon or atsign for this directive."))
  (if params
      (expand-bind-defaults
       ((count 1)) params
       (ecase *result-type*
	 (:expression
	  (make-string count :initial-element #\newline))
	 (:statement
	  (gen-progn
	   `((fresh-line ,*stream*)
	     (dotimes (i ,(1- count))
	       (terpri ,*stream*)))))
	 (:string-buffer
	  (gen-progn
	   `((send ,*stream* append #\newline)
	     (dotimes (i ,(1- count))
	       (send ,*stream* append #\newline)))))))
      (gen-fresh-line)))


(def-format-directive #\| (colonp atsignp params)
  (when (or colonp atsignp)
    (error 'format-error
	   :complaint
	   "Cannot specify either colon or atsign for this directive."))
  (if params
      (expand-bind-defaults
       ((count 1)) params
	(ecase *result-type*
	 (:expression
	  (make-string count :initial-element #\page))
	 (:statement
	  `(dotimes (i ,count)
	     (write-char #\page ,*stream*)))
	 (:string-buffer
	  `(dotimes (i ,count)
	     (send ,*stream* append #\page)))))
      (gen-write-char '#\page)))


(def-format-directive #\~ (colonp atsignp params)
  (when (or colonp atsignp)
    (error 'format-error
	   :complaint
	   "Cannot specify either colon or atsign for this directive."))
  (if params
      (expand-bind-defaults
       ((count 1)) params
       (ecase *result-type*
	 (:expression
	  (make-string count :initial-element #\~))
	 (:statement
	  `(dotimes (i ,count)
	     (write-char #\~ ,*stream*)))
	 (:string-buffer
	  `(dotimes (i ,count)
	     (send ,*stream* append #\~)))))
      (gen-write-char '#\~)))


(def-complex-format-directive #\newline (colonp atsignp params directives)
  (when (and colonp atsignp)
    (error 'format-error
	   :complaint
	   "Cannot specify both colon and atsign for this directive."))
  (values (expand-bind-defaults () params
	    (if atsignp
		(gen-write-char '#\newline)
		(gen-progn '())))
	  (if (and (not colonp)
		   directives
		   (simple-string-p (car directives)))
	      (cons (string-left-trim '(#\space #\newline #\tab)
				      (car directives))
		    (cdr directives))
	      directives)))




;;;; Tab and simple pretty-printing noise.

(def-format-directive #\T (colonp atsignp params)
  (declare (ignore colonp atsignp));;HACK this shouldn't be ignored
  (if params
      (expand-bind-defaults
       ((count 1)) params
       (ecase *result-type*
	 (:expression
	  (make-string count :initial-element #\tab))
	 (:statement
	  `(dotimes (i ,count)
	     (write-char #\tab ,*stream*)))
	 (:string-buffer
	  `(dotimes (i ,count)
	     (send ,*stream* append #\tab)))))
      (gen-write-char '#\tab)))


(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 (pp:pretty-stream-p stream)
;;       (pprint-tab :line-relative colrel colinc stream)
;;       (let* ((cur (lisp::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 (pp:pretty-stream-p stream)
;;       (pprint-tab :line colnum colinc stream)
;;       (let ((cur (lisp::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-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 specify the at-sign modifier."))
  (expand-bind-defaults ((n 0)) params
    `(pprint-indent ,(if colonp :current :block) ,n ,*stream*)))




;;;; *

(def-format-directive #\* (colonp atsignp params end)
  (if atsignp
      (if colonp
	  (error 'format-error
		 :complaint "Cannot specify both colon and at-sign.")
	  (expand-bind-defaults ((posn 0)) params
	    (if *orig-args-available*
	      `(if (<= 0 ,posn (length orig-args))
		 (setf args (nthcdr ,posn orig-args))
		 (error 'format-error
			:complaint "Index ~D out of bounds.  Should have been ~
				    between 0 and ~D."
			:arguments (list ,posn (length orig-args))
			:offset ,(1- end)))
	      (progn
		(if (<= 0 posn (length *orig-args*))
		  (setf *args* (nthcdr posn *orig-args*))
		  (error 'format-error
			 :complaint "Index ~D out of bounds.  Should have been ~
				    between 0 and ~D."
			 :arguments (list posn (length *orig-args*))
			 :offset (1- end)))
		(gen-progn '())))))
      (if colonp
	  (expand-bind-defaults ((n 1)) params
	    (if *orig-args-available*
	      `(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 ~D out of bounds.  Should have been ~
				between 0 and ~D."
			       :arguments
			       (list new-posn (length orig-args))
			       :offset ,(1- end))))))
	      (progn
		(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 ~D out of bounds.  Should have been ~
				between 0 and ~D."
				:arguments
				(list new-posn (length *orig-args*))
				:offset (1- end))))))
		(gen-progn '()))))
	  (if params
	    (expand-bind-defaults ((n 1)) params
	      (if *orig-args-available*
		`(dotimes (i ,n)
		   ,(protect (expand-next-arg)))
		(progn
		  (dotimes (i n)
		    (expand-next-arg))
		  (gen-progn '()))))
	    (progn
	      (expand-next-arg)
	      (gen-progn '()))))))



;;;; Indirection.

(def-format-directive #\? (colonp atsignp params string end)
  (declare (ignore colonp atsignp params end))
  (when string
    (error "Can't deal with indirect format strings ~A" string)))


;;;; Capitalization.

(def-complex-format-directive #\( (colonp atsignp params directives)
  (let ((close (find-directive directives #\) nil)))
    (unless close
      (error 'format-error
	     :complaint "No corresponding close paren."))
    (let* ((posn (position close directives))
	   (before (subseq directives 0 posn))
	   (after (nthcdr (1+ posn) directives)))
      (values
       (expand-bind-defaults () params
	 (gen-write-string
	  `(,(if colonp
	       (if atsignp
		 'string-upcase
		 'string-capitalize)
	       (if atsignp
		 (error "Can't do :capitalize-first in Linj")
		 'string-downcase))
	    ,(let ((*result-type* :expression))
	       (gen-progn `(,@(expand-directive-list before)))))))
       after))))



(def-complex-format-directive #\) ()
  (error 'format-error
	 :complaint "No corresponding open paren."))




;;;; Conditionals

(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)))

(def-complex-format-directive #\[ (colonp atsignp params directives)
  (multiple-value-bind (sublists last-semi-with-colon-p remaining)
      (parse-conditional-directive directives)
    (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")
	  (expand-bind-defaults () params
	    (expand-maybe-conditional (car sublists) remaining))))
      (if colonp
	(if (= (length sublists) 2)
	  (expand-bind-defaults () params
	    (expand-true-false-conditional (car sublists)
					   (cadr sublists)
					   remaining))
	  (error 'format-error
		 :complaint
		 "Must specify exactly two sections."))
	(expand-bind-defaults ((index (expand-next-arg))) params
          (let ((clauses nil))
	    (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)))
	    (values `(case ,index ,@clauses) remaining)))))))

(defun expand-maybe-conditional (sublist directives)
  (flet ((hairy ()
	   (error "Can't treat this case")))
    (if *only-simple-args*
	(let ((test (car *args*))) ;;HACK this causes repeated evaluation
	  (let ((guts (expand-directive-list sublist)))
	    (gen-progn (cons (gen-when test guts) (expand-directive-list directives)))))
	(hairy))))

(defun expand-true-false-conditional (true false directives)
  (flet ((hairy ()
		(values
		 (let ((arg (expand-next-arg)))
		   (let ((then-forms (let ((*args* *args*))
				       (expand-directive-list (append true directives))))
			 (else-forms (let ((*args* *args*))
				       (expand-directive-list (append false directives)))))
		     (destructuring-bind (prefix l1 l2 suffix)
			 (prefix-list1-list2-suffix then-forms else-forms)
		       (let ((core (cond ((null l1)
					  `(unless ,arg ,@l2))
					 ((null l2)
					  `(when ,arg ,@l1))
					 (t
					  `(if ,arg
					     ,(gen-progn `(,@l1))
					     ,(gen-progn `(,@l2)))))))
			 (if (or prefix suffix)
			   (gen-progn `(,@prefix ,core ,@suffix))
			   core)))))
		 (list))))
    (hairy)))
;;       (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 (append true directives))
;; 			*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 (append false directives))
;; 			  *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
;; 		    (progn (setf *only-simple-args* nil) (error "BUM"))
;; 		    (hairy)))))
;; 	  (hairy))


(defun prefix-list1-list2-suffix (list1 list2)
  (labels ((prefix (l1 l2 prefix in-prefix)
		   (cond ((or (null l1) (null l2))
			  (list (reverse prefix) l1 l2 (list)))
			 ((equal (first l1) (first l2))
			  (prefix (rest l1) (rest l2) (cons (first l1) prefix) in-prefix))
			 ((not in-prefix)
			  (list (reverse prefix) l1 l2 (list)))
			 (t
			  (destructuring-bind (suffix l1 l2 ignore)
			      (prefix (reverse l1) (reverse l2) (list) (not in-prefix))
			    (declare (ignore ignore))
			    (list (reverse prefix) (reverse l1) (reverse l2) (reverse suffix)))))))
    (prefix list1 list2 (list) t)))

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





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


;;;; Up-and-out.

(defvar *outside-args*)

(def-format-directive #\^ (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 ,(case (length params)
	    (0 (if colonp
		   '(null outside-args)
		   (progn
		     (setf *only-simple-args* nil)
		     '(null args))))
	    (1 (expand-bind-defaults ((count 0)) params
		 `(zerop ,count)))
	    (2 (expand-bind-defaults ((arg1 0) (arg2 0)) params
		 `(= ,arg1 ,arg2)))
	    (t (expand-bind-defaults ((arg1 0) (arg2 0) (arg3 0)) params
		 `(<= ,arg1 ,arg2 ,arg3))))
     ,(if colonp
	  '(return-from outside-loop nil)
	  '(return))))



;;;; Iteration.
(def-complex-format-directive #\{ (colonp atsignp params string end directives)
  (declare (ignore end))
  (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*
		   (error "Can't deal with indirect format strings ~A" string)
		   (throw 'need-orig-args nil))
		 (let ((*up-up-and-out-allowed* colonp))
		   (expand-directive-list (subseq directives 0 posn)))))
	   (compute-loop-aux (count)
	     (when atsignp
	       (progn (setf *only-simple-args* nil)))
	     `(do ()
		  (,@(unless closed-with-colon
		       '((null args))))
		,@(when count
		    `((when (minusp (decf count))
			(return))))
		,@(if colonp
		      (let ((*only-simple-args* nil)
			    (*orig-args-available* t))
			`((let* ((orig-args ,(expand-next-arg))
				 (outside-args args)
				 (args orig-args))
			    (block nil
			      ,@(compute-insides)))))
		      (compute-insides))
		,@(when closed-with-colon
		    '((when (null args)
			(return))))))
	   (compute-loop ()
	     (if params
		 (expand-bind-defaults ((count nil)) params
		   (if count
		     `(let ((count ,count))
		       ,(compute-loop-aux count))
		     (compute-loop-aux nil)))
		 (compute-loop-aux nil)))
	   (compute-block ()
	     (if colonp
		 `(block outside-loop
		    ,(compute-loop))
		 (compute-loop)))
	   (compute-bindings ()
	     (if atsignp
		 `(let* ((args (list ,@*args*)))
		   ,(compute-block))
		 (if *only-simple-args*
		   `(let* ((orig-args ,(expand-next-arg))
			   (args orig-args))
		     ,(let ((*only-simple-args* nil)
			    (*orig-args-available* t))
			   (compute-block)))
		   (protect
		    `(let ((args (the cons arg)))
		      ,(compute-block)))))))
	(values (if (zerop posn)
		    `(let ((inside-string ,(expand-next-arg)))
		       ,(compute-bindings))
		    (compute-bindings))
		(nthcdr (1+ posn) directives))))))



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





;;;; 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"
;; 		    :arguments (list count)))
;; 	   (expand-format-justification segments colonp atsignp
;; 				      first-semi params)))
;;      remaining)))



;; (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))))

;; (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 '(or (lisp::line-length stream) 72)))
;; 		      (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)))))



;; (defun format-justification (stream newline-prefix extra-space line-len strings
;; 			     pad-left pad-right mincol colinc minpad padchar)
;;   (setf strings (reverse strings))
;;   (when (and (not pad-left) (not pad-right) (null (cdr strings)))
;;     (setf pad-left t))
;;   (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)))
;;     (when (and newline-prefix
;; 	       (> (+ (or (lisp::charpos stream) 0)
;; 		     length extra-space)
;; 		  line-len))
;;       (write-string newline-prefix stream))
;;     (flet ((do-padding ()
;; 	     (let ((pad-len (truncate padding num-gaps)))
;; 	       (decf padding pad-len)
;; 	       (decf num-gaps)
;; 	       (dotimes (i pad-len) (write-char padchar stream)))))
;;       (when pad-left
;; 	(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 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 nil nil))
;; 	(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 ~~<...~~:>"
;; 			      :arguments (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)
;;   (if list
;;       (let ((directive (car list)))
;; 	(if (simple-string-p directive)
;; 	    (nconc (add-fill-style-newlines-aux directive string offset)
;; 		   (add-fill-style-newlines (cdr list)
;; 					    string
;; 					    (+ offset (length directive))))
;; 	    (cons directive
;; 		  (add-fill-style-newlines (cdr list)
;; 					   string
;; 					   (format-directive-end directive)))))
;;       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))))


;;;; User-defined method.

;; (def-format-directive #\/ (string start end colonp atsignp params)
;;   (let ((symbol (extract-user-function-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-function-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
;; 				  ;; quit 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
;; 	(error 'format-error
;; 	       :complaint "No package named ~S"
;; 	       :arguments (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))))