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@ 4442

Last change on this file since 4442 was 4434, checked in by Marek Rychlik, 8 years ago
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 ;; Unary minus needs special handling
152 ((and (eq (car expr) '-) (endp (cddr expr)))
153 (format stream "-")
154
155 ;; Print the second element in product context
156 (infix-print (cadr expr) stream '* (1+ print-level)))
157
158 ;; All other operators
159 (t
160 (case (car expr)
161
162 ;; Arithmetic operators
163 ((+ - * /)
164
165 (let ((op (car expr))
166 (args (cdr expr)))
167 (infix-print-separated-list
168 args op stream op
169 (1+ print-level)
170 (find-alt-op op))
171 )
172 )
173
174 ;; Exponentials
175 (expt
176 (unless (= (length (cdr expr)) 2)
177 (error "expt must take 2 arguments."))
178 (infix-print-separated-list
179 (cdr expr)
180 '^
181 stream
182 '^
183 (1+ print-level)))
184
185 ;; Assuming function call
186 (otherwise
187 (cond
188
189 ;; Handle array references
190 ((eq (car expr) 'aref)
191 ;; Special syntax for subscripted variables
192 ;; consistent with the infix package.
193 (format stream "~a[" (cadr expr))
194 (infix-print-separated-list (cddr expr) '\, stream '\, (1+ print-level))
195 (format stream "]"))
196
197 ;; Handle lists
198 ((and (symbolp (car expr))
199 (string= (symbol-name (car expr)) "["))
200 (format stream "[")
201 (infix-print-separated-list (cdr expr) '\, stream '\, (1+ print-level))
202 (format stream "]"))
203
204 ;; Handle generic function call syntax
205 (t
206 (format stream "~a(" (car expr))
207 (infix-print-arg-list (cdr expr) stream (1+ print-level))
208 (format stream ")")))))))
209 (values))
210
211(defun infix-print-to-string (expr &optional (op nil) (print-level 0)
212 &aux (fstr (make-array '(0) :element-type 'base-char
213 :fill-pointer 0 :adjustable t)))
214 "Print an expression EXPR in infix notation to a string. If OP is
215not nil, the expression is parenthesized if its operator has lower
216precedence than OP. Returns the string containing the printed
217expression."
218 (with-output-to-string (s fstr)
219 (infix-print-to-stream expr s op print-level))
220 fstr)
221
222(defun infix-print (expr &optional (stream t) (op nil) (print-level 0))
223 "Print an expression EXPR in infix notation to stream STREAM or to
224string if (NULL STREAM). If OP is not nil, the expression is
225parenthesized if its operator has lower precedence than OP. Returns
226the string containing the printed expression, or (VALUES) if (NULL
227STREAM) is true."
228 (cond
229 ((null stream)
230 (infix-print-to-string expr op print-level))
231 (t (infix-print-to-stream expr stream op print-level))))
Note: See TracBrowser for help on using the repository browser.