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

Last change on this file since 4444 was 4434, checked in by Marek Rychlik, 8 years ago
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
[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
[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))
149 (format stream ")"))
[642]150
[4405]151 ;; Unary minus needs special handling
152 ((and (eq (car expr) '-) (endp (cddr expr)))
153 (format stream "-")
[4415]154
[4405]155 ;; Print the second element in product context
156 (infix-print (cadr expr) stream '* (1+ print-level)))
[642]157
[4405]158 ;; All other operators
159 (t
160 (case (car expr)
[642]161
[4405]162 ;; Arithmetic operators
163 ((+ - * /)
[4423]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 )
[642]173
[4405]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)))
[642]184
[4405]185 ;; Assuming function call
186 (otherwise
187 (cond
[4400]188
[4405]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 "]"))
[4400]196
[4405]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 "]"))
[4400]203
[4405]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 ")")))))))
[642]209 (values))
[678]210
[680]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)))
[692]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."
[678]218 (with-output-to-string (s fstr)
[682]219 (infix-print-to-stream expr s op print-level))
[678]220 fstr)
[681]221
222(defun infix-print (expr &optional (stream t) (op nil) (print-level 0))
[688]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
[690]226the string containing the printed expression, or (VALUES) if (NULL
227STREAM) is true."
[682]228 (cond
229 ((null stream)
230 (infix-print-to-string expr op print-level))
[686]231 (t (infix-print-to-stream expr stream op print-level))))
Note: See TracBrowser for help on using the repository browser.