[32] | 1 | #|
|
---|
| 2 | $Id: infix-printer.lisp,v 1.18 2002/03/29 14:00:18 marek Exp $
|
---|
| 3 | *--------------------------------------------------------------------------*
|
---|
| 4 | | Copyright (C) 1994, Marek Rychlik (e-mail: rychlik@math.arizona.edu) |
|
---|
| 5 | | Department of Mathematics, University of Arizona, Tucson, AZ 85721 |
|
---|
| 6 | | |
|
---|
| 7 | | Everyone is permitted to copy, distribute and modify the code in this |
|
---|
| 8 | | directory, as long as this copyright note is preserved verbatim. |
|
---|
| 9 | *--------------------------------------------------------------------------*
|
---|
| 10 | |#
|
---|
| 11 |
|
---|
| 12 | (defpackage "INFIX-PRINTER"
|
---|
[37] | 13 | (:use "COMMON-LISP"
|
---|
| 14 | "INFIX" ;for operator-lessp
|
---|
| 15 | )
|
---|
[35] | 16 | (:export infix-print))
|
---|
[32] | 17 |
|
---|
| 18 | (in-package "INFIX-PRINTER")
|
---|
| 19 |
|
---|
[36] | 20 | (defun infix-print-separated-list (lst sep stream op print-level
|
---|
| 21 | &optional (alt-op nil) (alt-sep alt-op)
|
---|
| 22 | &aux
|
---|
| 23 | (beg t)
|
---|
| 24 | (count 0)
|
---|
| 25 | true-sep)
|
---|
| 26 | (cond
|
---|
| 27 | ((endp lst) nil)
|
---|
| 28 | ((and (numberp *print-level*) (> print-level *print-level*))
|
---|
| 29 | (format stream "#"))
|
---|
| 30 | (t
|
---|
[37] | 31 | (dolist (arg lst (infix-print arg stream op print-level))
|
---|
[36] | 32 | (setf true-sep sep)
|
---|
| 33 | (incf count)
|
---|
| 34 | (when (and alt-op (> count 1) (consp arg) (eq alt-op (car arg)))
|
---|
| 35 | (setf arg (cadr arg)
|
---|
| 36 | true-sep alt-sep))
|
---|
| 37 | (if beg
|
---|
| 38 | (setf beg nil)
|
---|
| 39 | (format stream "~a" true-sep))
|
---|
| 40 | (when (and (numberp *print-length*) (> count *print-length*))
|
---|
[39] | 41 | (format stream "...")
|
---|
| 42 | (return-from infix-print-separated-list))))))
|
---|
[36] | 43 |
|
---|
| 44 |
|
---|
[32] | 45 | (defun infix-print (expr &optional (stream t) (op nil) (print-level 0))
|
---|
| 46 | "Print an expression EXPR in infix notation to stream STREAM.
|
---|
| 47 | If OP is not nil, the expression is parenthesized if its operator
|
---|
| 48 | has lower precedence than OP."
|
---|
| 49 | (cond
|
---|
| 50 | ((and (numberp *print-level*) (> print-level *print-level*))
|
---|
| 51 | (format stream "#"))
|
---|
| 52 | ((null expr) (error "Null expression."))
|
---|
| 53 | ((atom expr) (format stream "~a" expr))
|
---|
| 54 | ((and op (operator-lessp (car expr) op))
|
---|
| 55 | (format stream "(")
|
---|
| 56 | (infix-print expr stream nil (1+ print-level))
|
---|
| 57 | (format stream ")"))
|
---|
| 58 | ((and (eq (car expr) '-)
|
---|
| 59 | (endp (cddr expr))) ;unary minus
|
---|
| 60 | (format stream "-")
|
---|
| 61 | (infix-print (cadr expr) stream '* (1+ print-level)))
|
---|
| 62 | (t
|
---|
| 63 | (case (car expr)
|
---|
| 64 | ((+ - * /)
|
---|
| 65 | (infix-print-separated-list (cdr expr) (car expr) stream (car expr) (1+ print-level)
|
---|
| 66 | (cond ((eq (car expr) '+) '-)
|
---|
| 67 | ((eq (car expr) '-) '-)
|
---|
| 68 | (t nil))))
|
---|
| 69 | (wedge
|
---|
| 70 | (infix-print-separated-list (cdr expr) '|/\\| stream '* (1+ print-level)))
|
---|
| 71 | (expt
|
---|
| 72 | (unless (= (length (cdr expr)) 2)
|
---|
| 73 | (error "expt must take 2 arguments."))
|
---|
| 74 | (infix-print-separated-list (cdr expr) '^ stream '^ (1+ print-level)))
|
---|
| 75 | (otherwise ;assumed function call
|
---|
| 76 | (cond
|
---|
| 77 | ((and (eq (car expr) 'd)
|
---|
| 78 | (consp (cdr expr))
|
---|
| 79 | (symbolp (cadr expr)))
|
---|
| 80 | ;; Special syntax for differential forms
|
---|
| 81 | (format stream "d~a" (cadr expr)))
|
---|
| 82 | ((eq (car expr) 'aref)
|
---|
| 83 | ;; Special syntax for subscripted variables
|
---|
| 84 | ;; consistent with the infix package.
|
---|
| 85 | (format stream "~a[" (cadr expr))
|
---|
| 86 | (infix-print-separated-list (cddr expr) '\, stream '\, (1+ print-level))
|
---|
| 87 | (format stream "]"))
|
---|
| 88 | ((and (symbolp (car expr))
|
---|
| 89 | (string= (symbol-name (car expr)) "["))
|
---|
| 90 | (format stream "[")
|
---|
| 91 | (infix-print-separated-list (cdr expr) '\, stream '\, (1+ print-level))
|
---|
| 92 | (format stream "]"))
|
---|
| 93 | (t
|
---|
| 94 | ;; Generic function call syntax
|
---|
| 95 | (format stream "~a(" (car expr))
|
---|
| 96 | (infix-print-separated-list (cdr expr) '\, stream '\, (1+ print-level))
|
---|
[36] | 97 | (format stream ")"))))))))
|
---|