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

Last change on this file since 4422 was 4422, checked in by Marek Rychlik, 9 years ago

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