[4005] | 1 | ;;; -*- Mode: Lisp -*-
|
---|
[642] | 2 | #|
|
---|
| 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"
|
---|
| 13 | (:use "COMMON-LISP"
|
---|
| 14 | "INFIX" ;for operator-lessp
|
---|
| 15 | )
|
---|
[685] | 16 | (:export infix-print infix-print-to-string infix-print-to-stream))
|
---|
[642] | 17 |
|
---|
| 18 | (in-package "INFIX-PRINTER")
|
---|
| 19 |
|
---|
| 20 | (proclaim '(optimize (speed 0) (space 0) (safety 3) (debug 3)))
|
---|
| 21 |
|
---|
| 22 | (defun infix-print-separated-list (lst sep stream op print-level
|
---|
| 23 | &optional (alt-op nil) (alt-sep alt-op)
|
---|
| 24 | &aux
|
---|
| 25 | (beg t)
|
---|
| 26 | (count 0)
|
---|
| 27 | true-sep)
|
---|
[4403] | 28 | "Print a list LST using SEP as separator, to stream STREAM. Every argument
|
---|
| 29 | is printed usin OP as main operator. PRINT-LEVEL is used to control
|
---|
| 30 | printing nested expressions as expected: subexpressions at level exceeding
|
---|
| 31 | PRINT-LEVEL are printed as ellipsis. The argument ALT-OP, if not NIL, replaces
|
---|
| 32 | operator OP for list elements beyond the first one. Similarly, ALT-SEP replaces
|
---|
| 33 | SEP for list elements beyond the first one."
|
---|
| 34 |
|
---|
[642] | 35 | (cond
|
---|
| 36 | ((endp lst) nil)
|
---|
| 37 |
|
---|
| 38 | ;; Handle *print-level*
|
---|
| 39 | ((and (numberp *print-level*)
|
---|
| 40 | (> print-level *print-level*))
|
---|
| 41 | (format stream "#"))
|
---|
| 42 |
|
---|
| 43 | (t
|
---|
| 44 | (dolist (arg lst)
|
---|
[4401] | 45 | ;;(format t "Processing arg: ~S~%" arg)
|
---|
[642] | 46 | (setf true-sep sep)
|
---|
| 47 | (incf count)
|
---|
| 48 |
|
---|
[4404] | 49 | #|
|
---|
| 50 | ;; TODO: Determine why this is here and fix it.
|
---|
| 51 | ;; If uncommented, causes (+ x (- y z)) print as "X-Y"
|
---|
| 52 | ;; which is not correct
|
---|
[642] | 53 | (when (and alt-op
|
---|
| 54 | (> count 1)
|
---|
| 55 | (consp arg)
|
---|
| 56 | (eq alt-op (car arg)))
|
---|
[4404] | 57 | (setf arg (cadr arg) true-sep alt-sep)
|
---|
[4403] | 58 | )
|
---|
[4404] | 59 | |#
|
---|
[4402] | 60 |
|
---|
[642] | 61 | (if beg
|
---|
| 62 | (setf beg nil)
|
---|
| 63 | (format stream "~a" true-sep))
|
---|
| 64 |
|
---|
| 65 | ;; If *print-length* exceeded, print ellipsis
|
---|
| 66 | (when (and (numberp *print-length*) (> count *print-length*))
|
---|
| 67 | (format stream "...")
|
---|
| 68 | (return-from infix-print-separated-list (values)))
|
---|
| 69 |
|
---|
| 70 | (infix-print arg stream op print-level))))
|
---|
| 71 | (values))
|
---|
| 72 |
|
---|
| 73 | (defun infix-print-arg-list (lst stream print-level)
|
---|
| 74 | "Print a comma-separated list."
|
---|
| 75 | (infix-print-separated-list lst '\, stream '\, print-level))
|
---|
| 76 |
|
---|
[681] | 77 | (defun infix-print-to-stream (expr &optional (stream t) (op nil) (print-level 0))
|
---|
[642] | 78 | "Print an expression EXPR in infix notation to stream STREAM.
|
---|
| 79 | If OP is not nil, the expression is parenthesized if its operator
|
---|
[683] | 80 | has lower precedence than OP. Returns (VALUES)."
|
---|
[642] | 81 | (cond
|
---|
| 82 | ;; Handle *print-level*
|
---|
[4405] | 83 | ((and (numberp *print-level*)
|
---|
| 84 | (> print-level *print-level*))
|
---|
| 85 | (format stream "#"))
|
---|
[642] | 86 |
|
---|
[4405] | 87 | ;; Null expression is an error
|
---|
| 88 | ((null expr)
|
---|
| 89 | (error "Null expression."))
|
---|
[642] | 90 |
|
---|
[4405] | 91 | ;; Atoms are printed using ~A format directive
|
---|
| 92 | ((atom expr)
|
---|
| 93 | (format stream "~a" expr))
|
---|
[642] | 94 |
|
---|
[4405] | 95 | ;; Check if the operator of this expression has lower precedence
|
---|
| 96 | ;; than the surrounding operator, and parenthesize if necessary
|
---|
| 97 | ((and op
|
---|
| 98 | (operator-lessp (car expr) op))
|
---|
| 99 | (format stream "(")
|
---|
| 100 | (infix-print expr stream nil (1+ print-level))
|
---|
| 101 | (format stream ")"))
|
---|
[642] | 102 |
|
---|
[4405] | 103 | ;; Unary minus needs special handling
|
---|
| 104 | ((and (eq (car expr) '-) (endp (cddr expr)))
|
---|
| 105 | (format stream "-")
|
---|
| 106 | ;; Print the second element in product context
|
---|
| 107 | (infix-print (cadr expr) stream '* (1+ print-level)))
|
---|
[642] | 108 |
|
---|
[4405] | 109 | ;; All other operators
|
---|
| 110 | (t
|
---|
| 111 | (case (car expr)
|
---|
[642] | 112 |
|
---|
[4405] | 113 | ;; Arithmetic operators
|
---|
| 114 | ((+ - * /)
|
---|
| 115 | (infix-print-separated-list
|
---|
| 116 | (cdr expr)
|
---|
| 117 | (car expr)
|
---|
| 118 | stream
|
---|
| 119 | (car expr)
|
---|
| 120 | (1+ print-level)
|
---|
| 121 | (cond ((eq (car expr) '+) '-)
|
---|
| 122 | ((eq (car expr) '-) '-)
|
---|
| 123 | (t nil))))
|
---|
[642] | 124 |
|
---|
[4405] | 125 | ;; Exponentials
|
---|
| 126 | (expt
|
---|
| 127 | (unless (= (length (cdr expr)) 2)
|
---|
| 128 | (error "expt must take 2 arguments."))
|
---|
| 129 | (infix-print-separated-list
|
---|
| 130 | (cdr expr)
|
---|
| 131 | '^
|
---|
| 132 | stream
|
---|
| 133 | '^
|
---|
| 134 | (1+ print-level)))
|
---|
[642] | 135 |
|
---|
[4405] | 136 | ;; Assuming function call
|
---|
| 137 | (otherwise
|
---|
| 138 | (cond
|
---|
[4400] | 139 |
|
---|
[4405] | 140 | ;; Handle array references
|
---|
| 141 | ((eq (car expr) 'aref)
|
---|
| 142 | ;; Special syntax for subscripted variables
|
---|
| 143 | ;; consistent with the infix package.
|
---|
| 144 | (format stream "~a[" (cadr expr))
|
---|
| 145 | (infix-print-separated-list (cddr expr) '\, stream '\, (1+ print-level))
|
---|
| 146 | (format stream "]"))
|
---|
[4400] | 147 |
|
---|
[4405] | 148 | ;; Handle lists
|
---|
| 149 | ((and (symbolp (car expr))
|
---|
| 150 | (string= (symbol-name (car expr)) "["))
|
---|
| 151 | (format stream "[")
|
---|
| 152 | (infix-print-separated-list (cdr expr) '\, stream '\, (1+ print-level))
|
---|
| 153 | (format stream "]"))
|
---|
[4400] | 154 |
|
---|
[4405] | 155 | ;; Handle generic function call syntax
|
---|
| 156 | (t
|
---|
| 157 | (format stream "~a(" (car expr))
|
---|
| 158 | (infix-print-arg-list (cdr expr) stream (1+ print-level))
|
---|
| 159 | (format stream ")")))))))
|
---|
[642] | 160 | (values))
|
---|
[678] | 161 |
|
---|
[680] | 162 | (defun infix-print-to-string (expr &optional (op nil) (print-level 0)
|
---|
| 163 | &aux (fstr (make-array '(0) :element-type 'base-char
|
---|
| 164 | :fill-pointer 0 :adjustable t)))
|
---|
[692] | 165 | "Print an expression EXPR in infix notation to a string. If OP is
|
---|
| 166 | not nil, the expression is parenthesized if its operator has lower
|
---|
| 167 | precedence than OP. Returns the string containing the printed
|
---|
| 168 | expression."
|
---|
[678] | 169 | (with-output-to-string (s fstr)
|
---|
[682] | 170 | (infix-print-to-stream expr s op print-level))
|
---|
[678] | 171 | fstr)
|
---|
[681] | 172 |
|
---|
| 173 | (defun infix-print (expr &optional (stream t) (op nil) (print-level 0))
|
---|
[688] | 174 | "Print an expression EXPR in infix notation to stream STREAM or to
|
---|
| 175 | string if (NULL STREAM). If OP is not nil, the expression is
|
---|
| 176 | parenthesized if its operator has lower precedence than OP. Returns
|
---|
[690] | 177 | the string containing the printed expression, or (VALUES) if (NULL
|
---|
| 178 | STREAM) is true."
|
---|
[682] | 179 | (cond
|
---|
| 180 | ((null stream)
|
---|
| 181 | (infix-print-to-string expr op print-level))
|
---|
[686] | 182 | (t (infix-print-to-stream expr stream op print-level))))
|
---|