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

;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: Grobner; Base: 10 -*-
#|
  *--------------------------------------------------------------------------*
  |  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))

(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)
  (cond
   ((endp lst) nil)

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

   (t
    (dolist (arg lst)
      (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)))
  (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.
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 STREAM is NIL."
  (cond 
    ((null stream)
     (infix-print-to-string expr op print-level))
    (t (infix-print-to-stream expr op print-level))))