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

Last change on this file since 4405 was 4405, checked in by Marek Rychlik, 8 years ago

* empty log message *

File size: 5.7 KB
RevLine 
[4005]1;;; -*- Mode: Lisp -*-
[642]2#|
3 *--------------------------------------------------------------------------*
4 | Copyright (C) 1994, Marek Rychlik (e-mail: rychlik@math.arizona.edu) |
5 | Department of Mathematics, University of Arizona, Tucson, AZ 85721 |
6 | |
7 | Everyone is permitted to copy, distribute and modify the code in this |
8 | directory, as long as this copyright note is preserved verbatim. |
9 *--------------------------------------------------------------------------*
10|#
11
12(defpackage "INFIX-PRINTER"
13 (:use "COMMON-LISP"
14 "INFIX" ;for operator-lessp
15 )
[685]16 (:export infix-print infix-print-to-string infix-print-to-stream))
[642]17
18(in-package "INFIX-PRINTER")
19
20(proclaim '(optimize (speed 0) (space 0) (safety 3) (debug 3)))
21
22(defun infix-print-separated-list (lst sep stream op print-level
23 &optional (alt-op nil) (alt-sep alt-op)
24 &aux
25 (beg t)
26 (count 0)
27 true-sep)
[4403]28 "Print a list LST using SEP as separator, to stream STREAM. Every argument
29is printed usin OP as main operator. PRINT-LEVEL is used to control
30printing nested expressions as expected: subexpressions at level exceeding
31PRINT-LEVEL are printed as ellipsis. The argument ALT-OP, if not NIL, replaces
32operator OP for list elements beyond the first one. Similarly, ALT-SEP replaces
33SEP for list elements beyond the first one."
34
[642]35 (cond
36 ((endp lst) nil)
37
38 ;; Handle *print-level*
39 ((and (numberp *print-level*)
40 (> print-level *print-level*))
41 (format stream "#"))
42
43 (t
44 (dolist (arg lst)
[4401]45 ;;(format t "Processing arg: ~S~%" arg)
[642]46 (setf true-sep sep)
47 (incf count)
48
[4404]49 #|
50 ;; TODO: Determine why this is here and fix it.
51 ;; If uncommented, causes (+ x (- y z)) print as "X-Y"
52 ;; which is not correct
[642]53 (when (and alt-op
54 (> count 1)
55 (consp arg)
56 (eq alt-op (car arg)))
[4404]57 (setf arg (cadr arg) true-sep alt-sep)
[4403]58 )
[4404]59 |#
[4402]60
[642]61 (if beg
62 (setf beg nil)
63 (format stream "~a" true-sep))
64
65 ;; If *print-length* exceeded, print ellipsis
66 (when (and (numberp *print-length*) (> count *print-length*))
67 (format stream "...")
68 (return-from infix-print-separated-list (values)))
69
70 (infix-print arg stream op print-level))))
71 (values))
72
73(defun infix-print-arg-list (lst stream print-level)
74 "Print a comma-separated list."
75 (infix-print-separated-list lst '\, stream '\, print-level))
76
[681]77(defun infix-print-to-stream (expr &optional (stream t) (op nil) (print-level 0))
[642]78 "Print an expression EXPR in infix notation to stream STREAM.
79If OP is not nil, the expression is parenthesized if its operator
[683]80has lower precedence than OP. Returns (VALUES)."
[642]81 (cond
82 ;; Handle *print-level*
[4405]83 ((and (numberp *print-level*)
84 (> print-level *print-level*))
85 (format stream "#"))
[642]86
[4405]87 ;; Null expression is an error
88 ((null expr)
89 (error "Null expression."))
[642]90
[4405]91 ;; Atoms are printed using ~A format directive
92 ((atom expr)
93 (format stream "~a" expr))
[642]94
[4405]95 ;; Check if the operator of this expression has lower precedence
96 ;; than the surrounding operator, and parenthesize if necessary
97 ((and op
98 (operator-lessp (car expr) op))
99 (format stream "(")
100 (infix-print expr stream nil (1+ print-level))
101 (format stream ")"))
[642]102
[4405]103 ;; Unary minus needs special handling
104 ((and (eq (car expr) '-) (endp (cddr expr)))
105 (format stream "-")
106 ;; Print the second element in product context
107 (infix-print (cadr expr) stream '* (1+ print-level)))
[642]108
[4405]109 ;; All other operators
110 (t
111 (case (car expr)
[642]112
[4405]113 ;; Arithmetic operators
114 ((+ - * /)
115 (infix-print-separated-list
116 (cdr expr)
117 (car expr)
118 stream
119 (car expr)
120 (1+ print-level)
121 (cond ((eq (car expr) '+) '-)
122 ((eq (car expr) '-) '-)
123 (t nil))))
[642]124
[4405]125 ;; Exponentials
126 (expt
127 (unless (= (length (cdr expr)) 2)
128 (error "expt must take 2 arguments."))
129 (infix-print-separated-list
130 (cdr expr)
131 '^
132 stream
133 '^
134 (1+ print-level)))
[642]135
[4405]136 ;; Assuming function call
137 (otherwise
138 (cond
[4400]139
[4405]140 ;; Handle array references
141 ((eq (car expr) 'aref)
142 ;; Special syntax for subscripted variables
143 ;; consistent with the infix package.
144 (format stream "~a[" (cadr expr))
145 (infix-print-separated-list (cddr expr) '\, stream '\, (1+ print-level))
146 (format stream "]"))
[4400]147
[4405]148 ;; Handle lists
149 ((and (symbolp (car expr))
150 (string= (symbol-name (car expr)) "["))
151 (format stream "[")
152 (infix-print-separated-list (cdr expr) '\, stream '\, (1+ print-level))
153 (format stream "]"))
[4400]154
[4405]155 ;; Handle generic function call syntax
156 (t
157 (format stream "~a(" (car expr))
158 (infix-print-arg-list (cdr expr) stream (1+ print-level))
159 (format stream ")")))))))
[642]160 (values))
[678]161
[680]162(defun infix-print-to-string (expr &optional (op nil) (print-level 0)
163 &aux (fstr (make-array '(0) :element-type 'base-char
164 :fill-pointer 0 :adjustable t)))
[692]165 "Print an expression EXPR in infix notation to a string. If OP is
166not nil, the expression is parenthesized if its operator has lower
167precedence than OP. Returns the string containing the printed
168expression."
[678]169 (with-output-to-string (s fstr)
[682]170 (infix-print-to-stream expr s op print-level))
[678]171 fstr)
[681]172
173(defun infix-print (expr &optional (stream t) (op nil) (print-level 0))
[688]174 "Print an expression EXPR in infix notation to stream STREAM or to
175string if (NULL STREAM). If OP is not nil, the expression is
176parenthesized if its operator has lower precedence than OP. Returns
[690]177the string containing the printed expression, or (VALUES) if (NULL
178STREAM) is true."
[682]179 (cond
180 ((null stream)
181 (infix-print-to-string expr op print-level))
[686]182 (t (infix-print-to-stream expr stream op print-level))))
Note: See TracBrowser for help on using the repository browser.