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