source: branches/f4grobner/infix-printer.lisp@ 4403

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

      (when (and alt-op
                 (> count 1)
                 (consp arg)
                 (eq alt-op (car arg)))
        ;;(setf arg (cadr arg) true-sep alt-sep)
        )

      (if beg
          (setf beg nil)
          (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 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) '-) '-)
              (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))))