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

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

(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 (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."
  (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)
  (with-output-to-string (s fstr)
    (infix-print expr s op print-level))
  fstr)