source: CGBLisp/trunk/src/infix-printer.lisp@ 37

#|
        $Id: infix-printer.lisp,v 1.18 2002/03/29 14:00:18 marek Exp $
  *--------------------------------------------------------------------------*
  |  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")

(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)
   ((and (numberp *print-level*) (> print-level *print-level*))
    (format stream "#"))
   (t
    (dolist (arg lst (infix-print arg stream op print-level))
      (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))
      (when (and (numberp *print-length*) (> count *print-length*))
        (format stream "..."))
      (return-from infix-print-separated-list)))))


(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 
   ((and (numberp *print-level*) (> print-level *print-level*))
    (format stream "#"))
   ((null expr) (error "Null expression."))
   ((atom expr) (format stream "~a" expr))
   ((and op (operator-lessp (car expr) op))
    (format stream "(")
    (infix-print expr stream nil (1+ print-level))
    (format stream ")"))
   ((and (eq (car expr) '-)
         (endp (cddr expr)))            ;unary minus
    (format stream "-")
    (infix-print (cadr expr) stream '* (1+ print-level)))
   (t 
    (case (car expr)
      ((+ - * /)
       (infix-print-separated-list (cdr expr) (car expr) stream (car expr) (1+ print-level)
                                   (cond ((eq (car expr) '+) '-)
                                         ((eq (car expr) '-) '-)
                                         (t nil))))
      (wedge
       (infix-print-separated-list (cdr expr) '|/\\| stream '* (1+ print-level)))
      (expt
       (unless (= (length (cdr expr)) 2)
         (error "expt must take 2 arguments."))
       (infix-print-separated-list (cdr expr) '^ stream '^ (1+ print-level)))
      (otherwise                        ;assumed function call
       (cond
        ((and (eq (car expr) 'd)
              (consp (cdr expr))
              (symbolp (cadr expr)))
         ;; Special syntax for differential forms
         (format stream "d~a" (cadr expr)))
        ((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 "]"))
        ((and (symbolp (car expr))
              (string= (symbol-name (car expr)) "["))
         (format stream "[")
         (infix-print-separated-list (cdr expr) '\, stream '\, (1+ print-level))
         (format stream "]"))
        (t
         ;; Generic function call syntax
         (format stream "~a(" (car expr))
         (infix-print-separated-list (cdr expr) '\, stream '\, (1+ print-level))
         (format stream ")"))))))))