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

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

* empty log message *

File size: 4.8 KB
Line 
1;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: Grobner; Base: 10 -*-
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 )
16 (:export infix-print infix-print-to-string))
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)
28 (cond
29 ((endp lst) nil)
30
31 ;; Handle *print-level*
32 ((and (numberp *print-level*)
33 (> print-level *print-level*))
34 (format stream "#"))
35
36 (t
37 (dolist (arg lst)
38 (setf true-sep sep)
39 (incf count)
40
41 (when (and alt-op
42 (> count 1)
43 (consp arg)
44 (eq alt-op (car arg)))
45 (setf arg (cadr arg)
46 true-sep alt-sep))
47 (if beg
48 (setf beg nil)
49 (format stream "~a" true-sep))
50
51 ;; If *print-length* exceeded, print ellipsis
52 (when (and (numberp *print-length*) (> count *print-length*))
53 (format stream "...")
54 (return-from infix-print-separated-list (values)))
55
56 (infix-print arg stream op print-level))))
57 (values))
58
59(defun infix-print-arg-list (lst stream print-level)
60 "Print a comma-separated list."
61 (infix-print-separated-list lst '\, stream '\, print-level))
62
63(defun infix-print-to-stream (expr &optional (stream t) (op nil) (print-level 0))
64 "Print an expression EXPR in infix notation to stream STREAM.
65If OP is not nil, the expression is parenthesized if its operator
66has lower precedence than OP. Returns (VALUES)."
67 (cond
68 ;; Handle *print-level*
69 ((and (numberp *print-level*)
70 (> print-level *print-level*))
71 (format stream "#"))
72
73 ;; Null expression is an error
74 ((null expr)
75 (error "Null expression."))
76
77 ;; Atoms are printed using ~A format directive
78 ((atom expr)
79 (format stream "~a" expr))
80
81 ;; Check if the operator of this expression has lower precedence
82 ;; than the surrounding operator, and parenthesize if necessary
83 ((and op (operator-lessp (car expr) op))
84 (format stream "(")
85 (infix-print expr stream nil (1+ print-level))
86 (format stream ")"))
87
88 ;; Unary minus needs special handling
89 ((and (eq (car expr) '-) (endp (cddr expr)))
90 (format stream "-")
91 ;; Print the second element in product context
92 (infix-print (cadr expr) stream '* (1+ print-level)))
93
94 ;; All other operators
95 (t
96 (case (car expr)
97
98 ;; Arithmetic operators
99 ((+ - * /)
100 (infix-print-separated-list
101 (cdr expr)
102 (car expr)
103 stream
104 (car expr)
105 (1+ print-level)
106 (cond ((eq (car expr) '+) '-)
107 ((eq (car expr) '-) '-)
108 (t nil))))
109
110 ;; Exponentials
111 (expt
112 (unless (= (length (cdr expr)) 2)
113 (error "expt must take 2 arguments."))
114 (infix-print-separated-list
115 (cdr expr)
116 '^
117 stream
118 '^
119 (1+ print-level)))
120
121 ;; Assuming function call
122 (otherwise
123 (cond
124 ;; Handle array references
125 ((eq (car expr) 'aref)
126 ;; Special syntax for subscripted variables
127 ;; consistent with the infix package.
128 (format stream "~a[" (cadr expr))
129 (infix-print-separated-list (cddr expr) '\, stream '\, (1+ print-level))
130 (format stream "]"))
131
132 ;; Handle lists
133 ((and (symbolp (car expr))
134 (string= (symbol-name (car expr)) "["))
135 (format stream "[")
136 (infix-print-separated-list (cdr expr) '\, stream '\, (1+ print-level))
137 (format stream "]"))
138
139
140 ;; Handle generic function call syntax
141 (t
142
143 (format stream "~a(" (car expr))
144 (infix-print-arg-list (cdr expr) stream (1+ print-level))
145 (format stream ")")))))))
146 (values))
147
148(defun infix-print-to-string (expr &optional (op nil) (print-level 0)
149 &aux (fstr (make-array '(0) :element-type 'base-char
150 :fill-pointer 0 :adjustable t)))
151 (with-output-to-string (s fstr)
152 (infix-print-to-stream expr s op print-level))
153 fstr)
154
155(defun infix-print (expr &optional (stream t) (op nil) (print-level 0))
156 "Print an expression EXPR in infix notation to stream STREAM.
157If OP is not nil, the expression is parenthesized if its operator
158has lower precedence than OP. Returns the string containing the printed
159expression, or (VALUES) if STREAM is NIL."
160 (cond
161 ((null stream)
162 (infix-print-to-string expr op print-level))
163 (t (infix-print-to-stream expr op print-level))))
Note: See TracBrowser for help on using the repository browser.