;;; -*- Mode: Lisp -*-
#|
  *--------------------------------------------------------------------------*
  |  Copyright (C) 1994, Marek Rychlik (e-mail: rychlik@math.arizona.edu)    |
  |    Department of Mathematics, University of Arizona, Tucson, AZ 85721    |
  |                                                                          |
  | Everyone is permitted to copy, distribute and modify the code in this    |
  | directory, as long as this copyright note is preserved verbatim.         |
  *--------------------------------------------------------------------------*
|#

(defpackage "INFIX-PRINTER"
  (:use "COMMON-LISP"
	"INFIX"				;for operator-lessp
	)
  (:export infix-print infix-print-to-string infix-print-to-stream))

(in-package "INFIX-PRINTER")

(proclaim '(optimize (speed 0) (space 0) (safety 3) (debug 3)))

(defun infix-print-separated-list (lst sep stream op print-level
				   &optional 
				     (alt-op nil) 
				     (alt-sep alt-op)
				   &aux
				     (beg t)
				     (count 0)
				     true-sep)
  "Print a list LST using SEP as separator, to stream STREAM. Every
argument is printed usin OP as main operator. PRINT-LEVEL is used to
control printing nested expressions as expected: subexpressions at
level exceeding PRINT-LEVEL are printed as ellipsis. The argument BEG
indicates whether this is the start of a sequence of arguments with
the main operator OP.  The argument ALT-OP, if not NIL, replaces
operator OP for list elements beyond the first one. Similarly, ALT-SEP
replaces SEP for list elements beyond the first one."

  (cond
   ((endp lst) nil)

   ;; Handle *print-level* 
   ((and (numberp *print-level*)
	 (> print-level *print-level*))
    (format stream "#"))

   (t
    (dolist (arg lst)

      ;;(format t "Processing arg: ~S~%" arg)
      (setf true-sep sep)

      (incf count)
	  
      ;; The following code handles unary minus
      ;; Thus:
      ;; (+ x (- y z)) --> X + Y - Z
      ;; (+ x (- y)) --> X - Y
      (when (and alt-op
		 (> count 1)
		 (consp arg)
		 (endp (cddr arg))
		 (eq alt-op (car arg)))
	(psetf arg     (cadr arg) 
	       alt-sep nil)
	;;(format t "Arg changed: ~S, true-sep: ~S~%" arg true-sep)
	)


      (cond
	(beg 
	 (setf beg nil))
	(t 
	 (format stream "~a" true-sep)))
      
      ;; If *print-length* exceeded, print ellipsis
      (when (and (numberp *print-length*) (> count *print-length*))
	(format stream "...")
	(return-from infix-print-separated-list (values)))
      
      (infix-print-to-stream arg stream op print-level)

      )))
  (values))

(defun infix-print-arg-list (lst stream print-level)
  "Print a comma-separated list."
  (infix-print-separated-list lst '\, stream '\, print-level))

(defun infix-print-to-stream (expr &optional (stream t) (op nil) (print-level 0))
  "Print an expression EXPR in infix notation to stream STREAM.
If OP is not nil, the expression is parenthesized if its operator
has lower precedence than OP. Returns (VALUES)." 
  (cond 
    ;; Handle *print-level*
    ((and (numberp *print-level*)
	  (> print-level *print-level*))
     (format stream "#"))

    ;; Null expression is an error
    ((null expr)
     (error "Null expression."))

    ;; Atoms are printed using ~A format directive
    ((atom expr)
     (format stream "~a" expr))
   
    ;; Check if the operator of this expression has lower precedence
    ;; than the surrounding operator, and parenthesize if necessary
    ((and op 
	  (operator-lessp (car expr) op))
     (format stream "(")
     (infix-print expr stream nil (1+ print-level))
     (format stream ")"))

    ;; Unary minus needs special handling
    ((and (eq (car expr) '-) (endp (cddr expr)))
     (format stream "-")

     ;; Print the second element in product context
     (infix-print (cadr expr) stream '* (1+ print-level)))

    ;; All other operators
    (t 
     (case (car expr)

       ;; Arithmetic operators
       ((+ - * /)
	(infix-print-separated-list
	 (cdr expr)			
	 (car expr)			
	 stream
	 (car expr)			
	 (1+ print-level)		
	 (cond ((eq (car expr) '+) '-)
	       ((eq (car expr) '-) '-)
	       ((eq (car expr) '*) '/)
	       ((eq (car expr) '/) '/)
	       (t nil))))

       ;; Exponentials
       (expt
	(unless (= (length (cdr expr)) 2)
	  (error "expt must take 2 arguments."))
	(infix-print-separated-list
	 (cdr expr)
	 '^
	 stream
	 '^
	 (1+ print-level)))

       ;; Assuming function call
       (otherwise		
	(cond

	  ;; Handle array references
	  ((eq (car expr) 'aref)
	   ;; Special syntax for subscripted variables
	   ;; consistent with the infix package.
	   (format stream "~a[" (cadr expr))
	   (infix-print-separated-list (cddr expr) '\, stream '\, (1+ print-level))
	   (format stream "]"))

	  ;; Handle lists
	  ((and (symbolp (car expr))
		(string= (symbol-name (car expr)) "["))
	   (format stream "[")
	   (infix-print-separated-list (cdr expr) '\, stream '\, (1+ print-level))
	   (format stream "]"))

	  ;; Handle generic function call syntax
	  (t
	   (format stream "~a(" (car expr))
	   (infix-print-arg-list (cdr expr) stream (1+ print-level))
	   (format stream ")")))))))
  (values))

(defun infix-print-to-string (expr &optional (op nil) (print-level 0)
			      &aux (fstr (make-array '(0) :element-type 'base-char
						     :fill-pointer 0 :adjustable t)))
  "Print an expression EXPR in infix notation to a string.  If OP is
not nil, the expression is parenthesized if its operator has lower
precedence than OP. Returns the string containing the printed
expression."
  (with-output-to-string (s fstr)
    (infix-print-to-stream expr s op print-level))
  fstr)

(defun infix-print (expr &optional (stream t) (op nil) (print-level 0))
  "Print an expression EXPR in infix notation to stream STREAM or to
string if (NULL STREAM).  If OP is not nil, the expression is
parenthesized if its operator has lower precedence than OP. Returns
the string containing the printed expression, or (VALUES) if (NULL
STREAM) is true."
  (cond 
    ((null stream)
     (infix-print-to-string expr op print-level))
    (t (infix-print-to-stream expr stream op print-level))))