;;; -*- Mode:LISP; Package:USER; Readtable:CL; Base:10 -*-


#|

The idea behind this is to "compile" format strings to make printing faster.
NFORMAT is a macro that expands into a series of print statements.

We would like this to happen:

(nformat t "~&~s" bar) => (let ((#:g001 t))
			    (fresh-line #:g001)
			    (prin1 bar #:g001))

Hard cases
~V*
~@?
~V^
~@[

These make the arguments
indeterminate.  In these cases, we give up.


|#


(defvar *bar* '())

(defun foo ()
  (dotimes (i 500)
    (format t "~V~~v&foo" 2 5)))

(defun bar ()
  (dotimes (i 500)
    (nformat t "~v~~v&foo" 2 5)))

(defconstant *tilde*  #\~)
(defconstant *atsign* #\@)
(defconstant *colon*  #\:)
(defconstant *comma*  #\,)
(defconstant *non-newline-whitespace* '(#\space #\tab))


(defconstant *format-directives*
	     '(
	       (#\A :ascii)
	       (#\B :binary)
	       (#\C :character)
	       (#\D :decimal)
	       (#\E :exponential-float)
	       (#\F :fixed-float)
	       (#\G :general-float)
	       (#\O :octal)
	       (#\P :plural)
	       (#\R :radix)
	       (#\S :s-expression)
	       (#\T :tab)
	       (#\X :hexadecimal)
	       (#\$ :dollars-float)
	       (#\% :newline)
	       (#\& :freshline)
	       (#\| :page)
	       (#\~ :tilde)
	       (#\newline :ignore-whitespace)
	       (#\* :goto)
	       (#\? :indirect)
	       (#\( :case-conversion)
	       (#\) :close-case-conversion)
	       (#\[ :conditional)
	       (#\] :close-conditional)
	       (#\; :separator)
	       (#\{ :iterate)
	       (#\} :close-iterate)
	       (#\< :justify)
	       (#\> :close-justify)
	       (#\^ :escape)
	       ))

(defun translate-directive (character)
  (let ((entry (assoc character *format-directives* :test #'char-equal)))
    (if (null entry)
	(ferror nil "~%~~~c is not a format directive." character)
	(second entry))))

(defconstant *open-delimiters-with-semicolons*
	     '(
	       :conditional
	       :justify
	       ))

(defconstant *open-delimiters-without-semicolons*
	     `(
	       :case-conversion
	       :iterate
	       ))

(defconstant *close-delimiters*
	     `(
	       :close-case-conversion
	       :close-conditional
	       :close-justify
	       :close-iterate
	       ))

(defun matching-delimiters? (open close)
  (or (and (eq open :conditional)
	   (eq close :close-conditional))
      (and (eq open :justify)
	   (eq close :close-justify))
      (and (eq open :iterate)
	   (eq close :close-iterate))
      (and (eq open :case-conversion)
	   (eq close :close-case-conversion))))
	 

(defconstant *argument-characters*
	     (list
	      #\+
	      #\-
	      #\0
	      #\1
	      #\2
	      #\3
	      #\4
	      #\5
	      #\6
	      #\7
	      #\8
	      #\9
	      #\V
	      #\#
	      #\'
	      *comma*
	      *atsign*
	      *colon*
	      ))

(defconstant *argument-delimiters*
	     (list
	       *comma*
	       *atsign*
	       *colon*
	       ))

(defun format-error (format-string position error-string &rest error-args)
  (error "~?~%~V@T
~%~3@T\"~A\"~%"
	 error-string
	 error-args
	 position
	 format-string))

(defun format-string->token-chain (string)
  (labels (
	   (glom-literals (index)
	     ;; Pull the literal strings off of the format string
	     (if (equal index (length string))
		 the-empty-chain
	     (let ((token (position *tilde* string :start index)))
	       (cond ((null token)
		      (singleton-chain (list :literal (substring string index))))
		     ((= token index) (glom-directive token))
		     (t
		      (cons-chain (list :literal (substring string index token))
				  (glom-directive token)))))))

	   (glom-directive (index)
	     ;; Index is the index of the tilde
	     ;; Scan forward to something that cannot be an argument.
	     (let* ((directive-index (position *argument-characters* string
					       :test-not #'(lambda (args char)
							     (member char args :test #'char-equal))
					       :start    (1+ index)))
		    (directive       (translate-directive (char string directive-index)))
		    (directive-args  (separate-directive-args
				       (substring string (1+ index) directive-index))))
	       ;; Suck down ~<newline> now.
	       (if (eq directive :ignore-whitespace)
		   (glom-tilde-newline (1+ directive-index)
				       #'(lambda (whitespace index)
					   (cons-chain (append (cons directive directive-args)
							       (list whitespace))
						       (glom-literals index))))
		   (cons-chain (cons directive directive-args)
			       (glom-literals (1+ directive-index))))))

	   (glom-tilde-newline (index cont)
	     (if (= index (length string))
		 (funcall cont "" index)
		 (let ((crap (position *non-newline-whitespace* string
				       :test-not #'(lambda (white char)
						     (member char white :test #'char-equal))
				       :start index)))
		   (funcall cont (substring string index crap) crap))))

	   (separate-directive-args (argstring)
	     (let ((colon nil)
		   (atsign nil))

	       (when (zerop (length argstring)) (return-from separate-directive-args (list colon atsign)))

	       ;; Pull off potential atsign
	       (when (char-equal (char argstring (1- (length argstring))) *atsign*)
		 (setq atsign t)
		 (setq argstring (substring argstring 0 (1- (length argstring)))))

	       (when (zerop (length argstring)) (return-from separate-directive-args (list colon atsign)))

	       ;; Pull off potential colon
	       (when (char-equal (char argstring (1- (length argstring))) *colon*)
		 (setq colon t)
		 (setq argstring (substring argstring 0 (1- (length argstring)))))

	       (when (zerop (length argstring)) (return-from separate-directive-args (list colon atsign)))

	       (list* colon atsign (tokenize-format-arglist (separate-numerical-args '() argstring)))))

	   (separate-numerical-args (arglist argstring)
	     (if (zerop (length argstring))
		 (reverse arglist)
		 (separate-directive-arg argstring
		   #'(lambda (smaller-argstring argument)
		       (separate-numerical-args (cons argument arglist) smaller-argstring)))))


	   (separate-directive-arg (argstring cont)
	     (let ((delimiter-index
		     (position *argument-delimiters* argstring
			       :test #'(lambda (delimiters char)
					 (member char delimiters :test #'char-equal)))))
	       (if (null delimiter-index)
		   (funcall cont "" argstring)
		   (funcall cont
			    (substring argstring (1+ delimiter-index))
			    (substring argstring 0 delimiter-index)))))
	   )

    (glom-literals 0)))

(defun tokenize-format-arglist (arglist)
  (mapcar #'tokenize-format-argument arglist))

(defun tokenize-format-argument (arg)
  (cond 
    ;; Null string means no arg
    ((= (length arg) 0) nil)
    ;; ' means literal character
    ((char-equal (char arg 0) #\') (char arg 1))
    ;; V is indirect
    ((char-equal (char arg 0) #\v) :indirect)
    ;; Otherwise a decimal fixnum
    (t (parse-integer arg :junk-allowed nil))))

(defun gobble-token (token-chain when-found if-empty if-separator if-close-delimiter)
  (if (empty-chain? token-chain)
      (funcall if-empty)
      (let ((this-token (head token-chain)))
	(cond ((separator-token? this-token) (funcall if-separator this-token (tail token-chain)))
	      ((close-delimiter? this-token) (funcall if-close-delimiter this-token (tail token-chain)))
	      ((open-separated?  this-token)
	       (descend-separated this-token (tail token-chain)
				  #'(lambda (stuff tail)
				      (funcall when-found (list this-token stuff)
					       tail))))
	      ((open-no-separated? this-token)
	       (descend this-token (tail token-chain)
			#'(lambda (stuff tail)
			    (funcall when-found (list this-token stuff) tail))))
	      (t (funcall when-found this-token (tail token-chain)))))))

(defun separator-token? (token)
  (eq (first token) :separator))

(defun close-delimiter? (token)
  (member (first token) *close-delimiters* :test #'eq))

(defun open-separated? (token)
  (member (first token) *open-delimiters-with-semicolons* :test #'eq))

(defun open-no-separated? (token)
  (member (first token) *open-delimiters-without-semicolons* :test #'eq))


(defun descend-separated (open-delimiter token-chain when-found)
  (labels ((grab-clause (token-chain current-clause other-clauses)
	     (gobble-token token-chain
			   #'(lambda (token tail)
			       (grab-clause tail (cons token current-clause) other-clauses))
			   #'(lambda ()
			       (ferror nil "Unexpected end of format string."))
			   #'(lambda (separator tail)
			       (grab-clause tail (list separator) (cons (reverse current-clause)
							   other-clauses)))
			   #'(lambda (close tail)
			       (if (matching-delimiters? (first open-delimiter) (first close))
				   (funcall when-found
						  (reverse (cons (reverse current-clause)
								 other-clauses))
					    tail)
				   (ferror nil "Unbalanced delimiters."))))))
    (grab-clause token-chain '() '())))
							   
	     

(defun descend (open-delimiter token-chain when-found)
  (labels ((grab-clause (token-chain clauses)
	     (gobble-token token-chain
			   #'(lambda (token tail)
			       (grab-clause tail (cons token clauses)))
			   #'(lambda ()
			       (if (null open-delimiter)
				   (funcall when-found (cons :sequence (reverse clauses)) nil)
				   (ferror nil "Unexpected end of format string.")))
			   #'(lambda (separator tail)
			       separator
			       tail
			       (ferror nil "Semicolon not understood in this context."))
			   #'(lambda (close tail)
			       (if (and open-delimiter
					(matching-delimiters? (first open-delimiter) (first close)))
				   (funcall when-found
					    (cons :sequence (reverse clauses))
					    tail)
				   (ferror nil "Unbalanced delimiters."))))))
    (grab-clause token-chain nil)))
							
(defun parse-token-chain (token-chain)
  (descend nil token-chain #'(lambda (clauses ignore) clauses)))

(defmacro nformat (stream-form control-string-form &rest arg-forms)
  (nformat-expander stream-form control-string-form (copylist arg-forms)))

(defun nformat-expander (stream-form control-string-form arg-forms)
  (labels ((give-up ()
	     `(FORMAT ,stream-form ,control-string-form ,@arg-forms)))
    (if (not (stringp control-string-form))
	(give-up)
	(let* ((parse-tree (parse-token-chain (format-string->token-chain control-string-form)))
		(arg?       (can-determine-arguments? parse-tree)))
	  (format t "~%Can determine arguments = ~S" arg?)
	  (if (can-determine-arguments? parse-tree)
	      (compile-nformat parse-tree stream-form arg-forms)
	      (give-up))))))

(defconstant *argument-table* (make-hash-table))

(defun can-determine-arguments? (parse-tree)
  ;; Returns T if the arguments to a format string are fixed
  (let ((key (first parse-tree)))
    (if (consp key)
	(determine-subexpression (first parse-tree) (rest parse-tree))
	(let ((arguer (gethash key *argument-table*)))
	  (if (null arguer)
	      (ferror nil "Internal error")
	      (apply arguer (rest parse-tree)))))))

(defmacro define-arguer (key name arglist &body body)
  `(PROGN (DEFUN ,name ,arglist ,@body)
	  (PUTHASH ,key (QUOTE ,name) *ARGUMENT-TABLE*)))

(define-arguer :sequence argue-sequence (&rest stuff)
  (dolist (thing stuff t)
    (when (not (can-determine-arguments? thing))
      (return-from argue-sequence nil))))

(define-arguer :literal argue-literal (string)
  string
  t)
	      
(define-arguer :freshline argue-freshline (&rest ignore)
  t)

(define-arguer :tilde argue-tilde (&rest ignore)
  t)

(define-arguer :ascii argue-ascii (&rest ignore)
  t)

(defconstant *compile-table* (make-hash-table))

(defvar *current-arg*)
(defvar *arglist*)
(defvar *streamarg*)

(defun gobble-format-arg ()
  (prog1 (nth *current-arg* *arglist*)
	 (incf *current-arg*)))

(defun make-arglist (arg-forms)
  (mapcar #'(lambda (ignore) (gensym)) arg-forms))

(defun compile-nformat (parse-tree stream-form arg-forms)
  (let ((*arglist*     (make-arglist arg-forms))
	(*current-arg* 0)
	(*streamarg*   (gensym)))
    `(LET ((,*streamarg* ,stream-form)
	   ,@(mapcar #'(lambda (argname argform) `(,argname ,argform)) *arglist* arg-forms)
	   )
       ,(compile-format parse-tree))))


(defun compile-format (parsed-string)
  (let ((compile-key (first parsed-string)))
    (if (consp compile-key)
	(compile-with-subexpression (first parsed-string) (rest parsed-string))
	(let ((compiler (gethash compile-key *compile-table*)))
	  (if (null compiler)
	      (ferror nil "Internal error")
	      (apply compiler (rest parsed-string)))))))

(defmacro define-compiler (key name arglist &body body)
  `(PROGN (DEFUN ,name ,arglist ,@body)
	  (PUTHASH ,key (QUOTE ,name) *COMPILE-TABLE*)))
       

(define-compiler :sequence compile-sequence (&rest stuff)
  `(PROGN ,@(mapcar #'compile-string (copylist stuff))))

(define-compiler :literal compile-literal (string)
  `(PRINC ,string ,*streamarg*))

(define-compiler :freshline compile-freshline (colon atsign &optional (n 1))
  (when colon (ferror nil "~~& doesn't take a colon"))
  (when atsign (ferror nil "~~& doesn't take an atsign"))
  (if (numberp n)
      (cond ((zerop n) `(PROGN))
	    ((= n 1)   `(FRESH-LINE ,*streamarg*))
	    (t `(PROGN (FRESH-LINE ,*streamarg*) (DOTIMES (I ,(1- n)) (TERPRI ,*streamarg*)))))
      `(LET ((COUNT ,(gobble-format-arg)))
	 (UNLESS (ZEROP COUNT)
	   (FRESH-LINE ,*streamarg*)
	   (DOTIMES (i (1- count))
	     (TERPRI ,*streamarg*))))))

	  
(define-compiler :newline compile-newline (colon atsign &optional (n 1))
  (when colon (ferror nil "~~% doesn't take a colon"))
  (when atsign (ferror nil "~~% doesn't take an atsign"))
  (if (numberp n)
      (cond ((zerop n) `(PROGN))
	    ((= n 1)    `(TERPRI ,*streamarg*))
	    (t `(DOTIMES (I ,n) (TERPRI ,*streamarg*))))
      `(LET ((COUNT ,(gobble-format-arg)))
	 (DOTIMES (I (1- COUNT)) (TERPRI ,*streamarg*)))))

(define-compiler :tilde compile-tilde (colon atsign &optional (n 1))
  (when colon (ferror nil "~~% doesn't take a colon"))
  (when atsign (ferror nil "~~% doesn't take an atsign"))
  (if (numberp n)
      `(PRINC ,(make-string n :initial-element #\~) ,*streamarg*)
      `(LET ((COUNT ,(gobble-format-arg)))
	 (PRINC (MAKE-STRING COUNT :initial-element #\~) ,*streamarg*))))

(define-compiler :ascii compile-ascii (colon atsign &optional
					     (mincol 0) (colinc 1) (minpad 0) (padchar #\space))
  (labels ((print-it ()
	     (let ((argnum (gobble-format-arg)))
	       (if colon
		    `(IF ,argnum
			 (PRINC ,argnum ,*streamarg*)
			 (PRINC "()" ,*streamarg*))
		    `(PRINC ,argnum ,*streamarg*)))))

  (if (and (numberp mincol) (zerop mincol) (not (member :indirect (list colinc minpad padchar))))
      ;; Easy case
      (print-it)
      (ferror nil "Don't do hard ~~a yet."))))