[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 |
|
---|
| 49 | (when (and alt-op
|
---|
| 50 | (> count 1)
|
---|
| 51 | (consp arg)
|
---|
| 52 | (eq alt-op (car arg)))
|
---|
[4403] | 53 | ;;(setf arg (cadr arg) true-sep alt-sep)
|
---|
| 54 | )
|
---|
[4402] | 55 |
|
---|
[642] | 56 | (if beg
|
---|
| 57 | (setf beg nil)
|
---|
| 58 | (format stream "~a" true-sep))
|
---|
| 59 |
|
---|
| 60 | ;; If *print-length* exceeded, print ellipsis
|
---|
| 61 | (when (and (numberp *print-length*) (> count *print-length*))
|
---|
| 62 | (format stream "...")
|
---|
| 63 | (return-from infix-print-separated-list (values)))
|
---|
| 64 |
|
---|
| 65 | (infix-print arg stream op print-level))))
|
---|
| 66 | (values))
|
---|
| 67 |
|
---|
| 68 | (defun infix-print-arg-list (lst stream print-level)
|
---|
| 69 | "Print a comma-separated list."
|
---|
| 70 | (infix-print-separated-list lst '\, stream '\, print-level))
|
---|
| 71 |
|
---|
[681] | 72 | (defun infix-print-to-stream (expr &optional (stream t) (op nil) (print-level 0))
|
---|
[642] | 73 | "Print an expression EXPR in infix notation to stream STREAM.
|
---|
| 74 | If OP is not nil, the expression is parenthesized if its operator
|
---|
[683] | 75 | has lower precedence than OP. Returns (VALUES)."
|
---|
[642] | 76 | (cond
|
---|
| 77 | ;; Handle *print-level*
|
---|
| 78 | ((and (numberp *print-level*)
|
---|
| 79 | (> print-level *print-level*))
|
---|
| 80 | (format stream "#"))
|
---|
| 81 |
|
---|
| 82 | ;; Null expression is an error
|
---|
| 83 | ((null expr)
|
---|
| 84 | (error "Null expression."))
|
---|
| 85 |
|
---|
| 86 | ;; Atoms are printed using ~A format directive
|
---|
| 87 | ((atom expr)
|
---|
| 88 | (format stream "~a" expr))
|
---|
| 89 |
|
---|
| 90 | ;; Check if the operator of this expression has lower precedence
|
---|
| 91 | ;; than the surrounding operator, and parenthesize if necessary
|
---|
[4006] | 92 | ((and op
|
---|
| 93 | (operator-lessp (car expr) op))
|
---|
[642] | 94 | (format stream "(")
|
---|
| 95 | (infix-print expr stream nil (1+ print-level))
|
---|
| 96 | (format stream ")"))
|
---|
| 97 |
|
---|
| 98 | ;; Unary minus needs special handling
|
---|
| 99 | ((and (eq (car expr) '-) (endp (cddr expr)))
|
---|
| 100 | (format stream "-")
|
---|
| 101 | ;; Print the second element in product context
|
---|
| 102 | (infix-print (cadr expr) stream '* (1+ print-level)))
|
---|
| 103 |
|
---|
| 104 | ;; All other operators
|
---|
| 105 | (t
|
---|
| 106 | (case (car expr)
|
---|
| 107 |
|
---|
| 108 | ;; Arithmetic operators
|
---|
| 109 | ((+ - * /)
|
---|
| 110 | (infix-print-separated-list
|
---|
[4401] | 111 | (cdr expr)
|
---|
| 112 | (car expr)
|
---|
[642] | 113 | stream
|
---|
[4401] | 114 | (car expr)
|
---|
| 115 | (1+ print-level)
|
---|
[642] | 116 | (cond ((eq (car expr) '+) '-)
|
---|
| 117 | ((eq (car expr) '-) '-)
|
---|
| 118 | (t nil))))
|
---|
| 119 |
|
---|
| 120 | ;; Exponentials
|
---|
| 121 | (expt
|
---|
| 122 | (unless (= (length (cdr expr)) 2)
|
---|
| 123 | (error "expt must take 2 arguments."))
|
---|
| 124 | (infix-print-separated-list
|
---|
| 125 | (cdr expr)
|
---|
| 126 | '^
|
---|
| 127 | stream
|
---|
| 128 | '^
|
---|
| 129 | (1+ print-level)))
|
---|
| 130 |
|
---|
| 131 | ;; Assuming function call
|
---|
| 132 | (otherwise
|
---|
| 133 | (cond
|
---|
[4400] | 134 |
|
---|
[642] | 135 | ;; Handle array references
|
---|
| 136 | ((eq (car expr) 'aref)
|
---|
| 137 | ;; Special syntax for subscripted variables
|
---|
| 138 | ;; consistent with the infix package.
|
---|
| 139 | (format stream "~a[" (cadr expr))
|
---|
| 140 | (infix-print-separated-list (cddr expr) '\, stream '\, (1+ print-level))
|
---|
| 141 | (format stream "]"))
|
---|
[4400] | 142 |
|
---|
[642] | 143 | ;; Handle lists
|
---|
| 144 | ((and (symbolp (car expr))
|
---|
| 145 | (string= (symbol-name (car expr)) "["))
|
---|
| 146 | (format stream "[")
|
---|
| 147 | (infix-print-separated-list (cdr expr) '\, stream '\, (1+ print-level))
|
---|
| 148 | (format stream "]"))
|
---|
[4400] | 149 |
|
---|
[642] | 150 | ;; Handle generic function call syntax
|
---|
| 151 | (t
|
---|
| 152 | (format stream "~a(" (car expr))
|
---|
| 153 | (infix-print-arg-list (cdr expr) stream (1+ print-level))
|
---|
| 154 | (format stream ")")))))))
|
---|
| 155 | (values))
|
---|
[678] | 156 |
|
---|
[680] | 157 | (defun infix-print-to-string (expr &optional (op nil) (print-level 0)
|
---|
| 158 | &aux (fstr (make-array '(0) :element-type 'base-char
|
---|
| 159 | :fill-pointer 0 :adjustable t)))
|
---|
[692] | 160 | "Print an expression EXPR in infix notation to a string. If OP is
|
---|
| 161 | not nil, the expression is parenthesized if its operator has lower
|
---|
| 162 | precedence than OP. Returns the string containing the printed
|
---|
| 163 | expression."
|
---|
[678] | 164 | (with-output-to-string (s fstr)
|
---|
[682] | 165 | (infix-print-to-stream expr s op print-level))
|
---|
[678] | 166 | fstr)
|
---|
[681] | 167 |
|
---|
| 168 | (defun infix-print (expr &optional (stream t) (op nil) (print-level 0))
|
---|
[688] | 169 | "Print an expression EXPR in infix notation to stream STREAM or to
|
---|
| 170 | string if (NULL STREAM). If OP is not nil, the expression is
|
---|
| 171 | parenthesized if its operator has lower precedence than OP. Returns
|
---|
[690] | 172 | the string containing the printed expression, or (VALUES) if (NULL
|
---|
| 173 | STREAM) is true."
|
---|
[682] | 174 | (cond
|
---|
| 175 | ((null stream)
|
---|
| 176 | (infix-print-to-string expr op print-level))
|
---|
[686] | 177 | (t (infix-print-to-stream expr stream op print-level))))
|
---|