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
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
[4545]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
[4434]46 (+ '-)
[4423]47 (- '+)
[4434]48 (* '/)
[4423]49 (/ '*)))
50
[642]51(defun infix-print-separated-list (lst sep stream op print-level
[4413]52 &optional
53 (alt-op nil)
[642]54 &aux
[4412]55 (beg t)
56 (count 0)
[4434]57 true-sep
58 more-args)
[4414]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
[4423]65operator OP for list elements beyond the first one."
[4403]66
[642]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)
[4420]77 (setf true-sep sep)
[642]78 (incf count)
[4412]79
[4423]80 ;; Treat negative number X as '(- (- X))
81 (when (and (realp arg) (minusp arg))
82 (setf arg (list '- (- arg))))
83
[4418]84 ;; The following code handles unary minus
[4409]85 ;; Thus:
86 ;; (+ x (- y z)) --> X + Y - Z
87 ;; (+ x (- y)) --> X - Y
[4423]88 ;; (- x (- y)) --> X + Y
[642]89 (when (and alt-op
90 (> count 1)
91 (consp arg)
92 (eq alt-op (car arg)))
[4423]93 (psetf arg (cadr arg)
[4434]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
[4423]99 ;; Unless at the beginning, print the separator
[4415]100 (cond
101 (beg
102 (setf beg nil))
103 (t
104 (format stream "~a" true-sep)))
[642]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
[4421]111 (infix-print-to-stream arg stream op print-level)
112
[4434]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)))
[4421]118 )))
[642]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
[681]125(defun infix-print-to-stream (expr &optional (stream t) (op nil) (print-level 0))
[642]126 "Print an expression EXPR in infix notation to stream STREAM.
127If OP is not nil, the expression is parenthesized if its operator
[683]128has lower precedence than OP. Returns (VALUES)."
[642]129 (cond
130 ;; Handle *print-level*
[4405]131 ((and (numberp *print-level*)
132 (> print-level *print-level*))
133 (format stream "#"))
[642]134
[4405]135 ;; Null expression is an error
136 ((null expr)
137 (error "Null expression."))
[642]138
[4405]139 ;; Atoms are printed using ~A format directive
140 ((atom expr)
141 (format stream "~a" expr))
[642]142
[4405]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))
[4533]149 (format stream ")")
150 )
[642]151
[4405]152 ;; Unary minus needs special handling
153 ((and (eq (car expr) '-) (endp (cddr expr)))
154 (format stream "-")
[4415]155
[4405]156 ;; Print the second element in product context
157 (infix-print (cadr expr) stream '* (1+ print-level)))
[642]158
[4405]159 ;; All other operators
160 (t
161 (case (car expr)
[642]162
[4405]163 ;; Arithmetic operators
164 ((+ - * /)
[4423]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 )
[642]174
[4405]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)))
[642]185
[4405]186 ;; Assuming function call
187 (otherwise
188 (cond
[4400]189
[4405]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 "]"))
[4400]197
[4405]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 "]"))
[4400]204
[4405]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 ")")))))))
[642]210 (values))
[678]211
[680]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)))
[692]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."
[678]219 (with-output-to-string (s fstr)
[682]220 (infix-print-to-stream expr s op print-level))
[678]221 fstr)
[681]222
223(defun infix-print (expr &optional (stream t) (op nil) (print-level 0))
[688]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
[690]227the string containing the printed expression, or (VALUES) if (NULL
228STREAM) is true."
[682]229 (cond
230 ((null stream)
231 (infix-print-to-string expr op print-level))
[686]232 (t (infix-print-to-stream expr stream op print-level))))
Note: See TracBrowser for help on using the repository browser.