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 infix-print-to-stream))
|
---|
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.
|
---|
65 | If OP is not nil, the expression is parenthesized if its operator
|
---|
66 | has 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 or to
|
---|
157 | string if (NULL STREAM). If OP is not nil, the expression is
|
---|
158 | parenthesized if its operator has lower precedence than OP. Returns
|
---|
159 | the string containing the printed expression, or (VALUES) if (NULL
|
---|
160 | STREAM) is true."
|
---|
161 | (cond
|
---|
162 | ((null stream)
|
---|
163 | (infix-print-to-string expr op print-level))
|
---|
164 | (t (infix-print-to-stream expr stream op print-level))))
|
---|