close Warning: Can't synchronize with repository "(default)" (The repository directory has changed, you should resynchronize the repository with: trac-admin $ENV repository resync '(default)'). Look in the Trac log for more information.

source: branches/f4grobner/infix-printer.lisp

Last change on this file was 4545, checked in by Marek Rychlik, 8 years ago

* empty log message *
File size: 7.2 KB
Line 
1;;; -*- Mode: Lisp -*-
2;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
3;;;
4;;; Copyright (C) 1999, 2002, 2009, 2015 Marek Rychlik <rychlik@u.arizona.edu>
5;;;
6;;; This program is free software; you can redistribute it and/or modify
7;;; it under the terms of the GNU General Public License as published by
8;;; the Free Software Foundation; either version 2 of the License, or
9;;; (at your option) any later version.
10;;;
11;;; This program is distributed in the hope that it will be useful,
12;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
13;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
14;;; GNU General Public License for more details.
15;;;
16;;; You should have received a copy of the GNU General Public License
17;;; along with this program; if not, write to the Free Software
18;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
19;;;
20;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
21
22(defpackage "INFIX-PRINTER"
23 (:use "COMMON-LISP"
24 "INFIX" ;for operator-lessp
25 )
26 (:export infix-print infix-print-to-string infix-print-to-stream))
27
28(in-package "INFIX-PRINTER")
29
30(proclaim '(optimize (speed 0) (space 0) (safety 3) (debug 3)))
31
32(defun find-alt-op (op)
33 "Find ALT-OP, used for arguments above 1. Example:
34We should have
35 (+ X (- Y) Z) --> X - Y + Z
36so when an argument of an expression with operator '+ has an operator '-, we
37should use '- as a separator, before we render Y. Thus ALT-OP for '+ is '-"
38 (ecase op
39 (+ '-)
40 (- '-)
41 (* '/)
42 (/ '/)))
43
44(defun inverse-op (op)
45 (ecase op
46 (+ '-)
47 (- '+)
48 (* '/)
49 (/ '*)))
50
51(defun infix-print-separated-list (lst sep stream op print-level
52 &optional
53 (alt-op nil)
54 &aux
55 (beg t)
56 (count 0)
57 true-sep
58 more-args)
59 "Print a list LST using SEP as separator, to stream STREAM. Every
60argument is printed usin OP as main operator. PRINT-LEVEL is used to
61control printing nested expressions as expected: subexpressions at
62level exceeding PRINT-LEVEL are printed as ellipsis. The argument BEG
63indicates whether this is the start of a sequence of arguments with
64the main operator OP. The argument ALT-OP, if not NIL, replaces
65operator OP for list elements beyond the first one."
66
67 (cond
68 ((endp lst) nil)
69
70 ;; Handle *print-level*
71 ((and (numberp *print-level*)
72 (> print-level *print-level*))
73 (format stream "#"))
74
75 (t
76 (dolist (arg lst)
77 (setf true-sep sep)
78 (incf count)
79
80 ;; Treat negative number X as '(- (- X))
81 (when (and (realp arg) (minusp arg))
82 (setf arg (list '- (- arg))))
83
84 ;; The following code handles unary minus
85 ;; Thus:
86 ;; (+ x (- y z)) --> X + Y - Z
87 ;; (+ x (- y)) --> X - Y
88 ;; (- x (- y)) --> X + Y
89 (when (and alt-op
90 (> count 1)
91 (consp arg)
92 (eq alt-op (car arg)))
93 (psetf arg (cadr arg)
94 more-args (cddr arg))
95 (cond ((endp more-args)
96 (setf true-sep (if (eq op alt-op) (inverse-op op) alt-op)))))
97
98
99 ;; Unless at the beginning, print the separator
100 (cond
101 (beg
102 (setf beg nil))
103 (t
104 (format stream "~a" true-sep)))
105
106 ;; If *print-length* exceeded, print ellipsis
107 (when (and (numberp *print-length*) (> count *print-length*))
108 (format stream "...")
109 (return-from infix-print-separated-list (values)))
110
111 (infix-print-to-stream arg stream op print-level)
112
113 ;; Print remaining arguments
114 (unless (endp more-args)
115 (let ((x-op (inverse-op op)))
116 (format stream "~a" x-op)
117 (infix-print-separated-list more-args x-op stream sep print-level x-op)))
118 )))
119 (values))
120
121(defun infix-print-arg-list (lst stream print-level)
122 "Print a comma-separated list."
123 (infix-print-separated-list lst '\, stream '\, print-level))
124
125(defun infix-print-to-stream (expr &optional (stream t) (op nil) (print-level 0))
126 "Print an expression EXPR in infix notation to stream STREAM.
127If OP is not nil, the expression is parenthesized if its operator
128has lower precedence than OP. Returns (VALUES)."
129 (cond
130 ;; Handle *print-level*
131 ((and (numberp *print-level*)
132 (> print-level *print-level*))
133 (format stream "#"))
134
135 ;; Null expression is an error
136 ((null expr)
137 (error "Null expression."))
138
139 ;; Atoms are printed using ~A format directive
140 ((atom expr)
141 (format stream "~a" expr))
142
143 ;; Check if the operator of this expression has lower precedence
144 ;; than the surrounding operator, and parenthesize if necessary
145 ((and op
146 (operator-lessp (car expr) op))
147 (format stream "(")
148 (infix-print expr stream nil (1+ print-level))
149 (format stream ")")
150 )
151
152 ;; Unary minus needs special handling
153 ((and (eq (car expr) '-) (endp (cddr expr)))
154 (format stream "-")
155
156 ;; Print the second element in product context
157 (infix-print (cadr expr) stream '* (1+ print-level)))
158
159 ;; All other operators
160 (t
161 (case (car expr)
162
163 ;; Arithmetic operators
164 ((+ - * /)
165
166 (let ((op (car expr))
167 (args (cdr expr)))
168 (infix-print-separated-list
169 args op stream op
170 (1+ print-level)
171 (find-alt-op op))
172 )
173 )
174
175 ;; Exponentials
176 (expt
177 (unless (= (length (cdr expr)) 2)
178 (error "expt must take 2 arguments."))
179 (infix-print-separated-list
180 (cdr expr)
181 '^
182 stream
183 '^
184 (1+ print-level)))
185
186 ;; Assuming function call
187 (otherwise
188 (cond
189
190 ;; Handle array references
191 ((eq (car expr) 'aref)
192 ;; Special syntax for subscripted variables
193 ;; consistent with the infix package.
194 (format stream "~a[" (cadr expr))
195 (infix-print-separated-list (cddr expr) '\, stream '\, (1+ print-level))
196 (format stream "]"))
197
198 ;; Handle lists
199 ((and (symbolp (car expr))
200 (string= (symbol-name (car expr)) "["))
201 (format stream "[")
202 (infix-print-separated-list (cdr expr) '\, stream '\, (1+ print-level))
203 (format stream "]"))
204
205 ;; Handle generic function call syntax
206 (t
207 (format stream "~a(" (car expr))
208 (infix-print-arg-list (cdr expr) stream (1+ print-level))
209 (format stream ")")))))))
210 (values))
211
212(defun infix-print-to-string (expr &optional (op nil) (print-level 0)
213 &aux (fstr (make-array '(0) :element-type 'base-char
214 :fill-pointer 0 :adjustable t)))
215 "Print an expression EXPR in infix notation to a string. If OP is
216not nil, the expression is parenthesized if its operator has lower
217precedence than OP. Returns the string containing the printed
218expression."
219 (with-output-to-string (s fstr)
220 (infix-print-to-stream expr s op print-level))
221 fstr)
222
223(defun infix-print (expr &optional (stream t) (op nil) (print-level 0))
224 "Print an expression EXPR in infix notation to stream STREAM or to
225string if (NULL STREAM). If OP is not nil, the expression is
226parenthesized if its operator has lower precedence than OP. Returns
227the string containing the printed expression, or (VALUES) if (NULL
228STREAM) is true."
229 (cond
230 ((null stream)
231 (infix-print-to-string expr op print-level))
232 (t (infix-print-to-stream expr stream op print-level))))
Note: See TracBrowser for help on using the repository browser.