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

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

* empty log message *

File size: 6.9 KB
RevLine 
[4005]1;;; -*- Mode: Lisp -*-
[4422]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;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
[642]21
22(defpackage "INFIX-PRINTER"
23 (:use "COMMON-LISP"
24 "INFIX" ;for operator-lessp
25 )
[685]26 (:export infix-print infix-print-to-string infix-print-to-stream))
[642]27
28(in-package "INFIX-PRINTER")
29
[4423]30;;(proclaim '(optimize (speed 0) (space 0) (safety 3) (debug 3)))
[642]31
[4423]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
[642]49(defun infix-print-separated-list (lst sep stream op print-level
[4413]50 &optional
51 (alt-op nil)
[642]52 &aux
[4412]53 (beg t)
54 (count 0)
55 true-sep)
[4414]56 "Print a list LST using SEP as separator, to stream STREAM. Every
57argument is printed usin OP as main operator. PRINT-LEVEL is used to
58control printing nested expressions as expected: subexpressions at
59level exceeding PRINT-LEVEL are printed as ellipsis. The argument BEG
60indicates whether this is the start of a sequence of arguments with
61the main operator OP. The argument ALT-OP, if not NIL, replaces
[4423]62operator OP for list elements beyond the first one."
[4403]63
[642]64 (cond
65 ((endp lst) nil)
66
67 ;; Handle *print-level*
68 ((and (numberp *print-level*)
69 (> print-level *print-level*))
70 (format stream "#"))
71
72 (t
73 (dolist (arg lst)
[4420]74 (setf true-sep sep)
[642]75 (incf count)
[4412]76
[4423]77 ;; Treat negative number X as '(- (- X))
78 (when (and (realp arg) (minusp arg))
79 (setf arg (list '- (- arg))))
80
[4418]81 ;; The following code handles unary minus
[4409]82 ;; Thus:
83 ;; (+ x (- y z)) --> X + Y - Z
84 ;; (+ x (- y)) --> X - Y
[4423]85 ;; (- x (- y)) --> X + Y
[642]86 (when (and alt-op
87 (> count 1)
88 (consp arg)
[4408]89 (endp (cddr arg))
[642]90 (eq alt-op (car arg)))
[4423]91 (psetf arg (cadr arg)
92 true-sep (if (eq op alt-op) (inverse-op op) alt-op)))
93
94 ;; Unless at the beginning, print the separator
[4415]95 (cond
96 (beg
97 (setf beg nil))
98 (t
99 (format stream "~a" true-sep)))
[642]100
101 ;; If *print-length* exceeded, print ellipsis
102 (when (and (numberp *print-length*) (> count *print-length*))
103 (format stream "...")
104 (return-from infix-print-separated-list (values)))
105
[4421]106 (infix-print-to-stream arg stream op print-level)
107
108 )))
[642]109 (values))
110
111(defun infix-print-arg-list (lst stream print-level)
112 "Print a comma-separated list."
113 (infix-print-separated-list lst '\, stream '\, print-level))
114
[681]115(defun infix-print-to-stream (expr &optional (stream t) (op nil) (print-level 0))
[642]116 "Print an expression EXPR in infix notation to stream STREAM.
117If OP is not nil, the expression is parenthesized if its operator
[683]118has lower precedence than OP. Returns (VALUES)."
[642]119 (cond
120 ;; Handle *print-level*
[4405]121 ((and (numberp *print-level*)
122 (> print-level *print-level*))
123 (format stream "#"))
[642]124
[4405]125 ;; Null expression is an error
126 ((null expr)
127 (error "Null expression."))
[642]128
[4405]129 ;; Atoms are printed using ~A format directive
130 ((atom expr)
131 (format stream "~a" expr))
[642]132
[4405]133 ;; Check if the operator of this expression has lower precedence
134 ;; than the surrounding operator, and parenthesize if necessary
135 ((and op
136 (operator-lessp (car expr) op))
137 (format stream "(")
138 (infix-print expr stream nil (1+ print-level))
139 (format stream ")"))
[642]140
[4405]141 ;; Unary minus needs special handling
142 ((and (eq (car expr) '-) (endp (cddr expr)))
143 (format stream "-")
[4415]144
[4405]145 ;; Print the second element in product context
146 (infix-print (cadr expr) stream '* (1+ print-level)))
[642]147
[4405]148 ;; All other operators
149 (t
150 (case (car expr)
[642]151
[4405]152 ;; Arithmetic operators
153 ((+ - * /)
[4423]154
155 (let ((op (car expr))
156 (args (cdr expr)))
157 (infix-print-separated-list
158 args op stream op
159 (1+ print-level)
160 (find-alt-op op))
161 )
162 )
[642]163
[4405]164 ;; Exponentials
165 (expt
166 (unless (= (length (cdr expr)) 2)
167 (error "expt must take 2 arguments."))
168 (infix-print-separated-list
169 (cdr expr)
170 '^
171 stream
172 '^
173 (1+ print-level)))
[642]174
[4405]175 ;; Assuming function call
176 (otherwise
177 (cond
[4400]178
[4405]179 ;; Handle array references
180 ((eq (car expr) 'aref)
181 ;; Special syntax for subscripted variables
182 ;; consistent with the infix package.
183 (format stream "~a[" (cadr expr))
184 (infix-print-separated-list (cddr expr) '\, stream '\, (1+ print-level))
185 (format stream "]"))
[4400]186
[4405]187 ;; Handle lists
188 ((and (symbolp (car expr))
189 (string= (symbol-name (car expr)) "["))
190 (format stream "[")
191 (infix-print-separated-list (cdr expr) '\, stream '\, (1+ print-level))
192 (format stream "]"))
[4400]193
[4405]194 ;; Handle generic function call syntax
195 (t
196 (format stream "~a(" (car expr))
197 (infix-print-arg-list (cdr expr) stream (1+ print-level))
198 (format stream ")")))))))
[642]199 (values))
[678]200
[680]201(defun infix-print-to-string (expr &optional (op nil) (print-level 0)
202 &aux (fstr (make-array '(0) :element-type 'base-char
203 :fill-pointer 0 :adjustable t)))
[692]204 "Print an expression EXPR in infix notation to a string. If OP is
205not nil, the expression is parenthesized if its operator has lower
206precedence than OP. Returns the string containing the printed
207expression."
[678]208 (with-output-to-string (s fstr)
[682]209 (infix-print-to-stream expr s op print-level))
[678]210 fstr)
[681]211
212(defun infix-print (expr &optional (stream t) (op nil) (print-level 0))
[688]213 "Print an expression EXPR in infix notation to stream STREAM or to
214string if (NULL STREAM). If OP is not nil, the expression is
215parenthesized if its operator has lower precedence than OP. Returns
[690]216the string containing the printed expression, or (VALUES) if (NULL
217STREAM) is true."
[682]218 (cond
219 ((null stream)
220 (infix-print-to-string expr op print-level))
[686]221 (t (infix-print-to-stream expr stream op print-level))))
Note: See TracBrowser for help on using the repository browser.