1 /* print.c
2 * Copyright 1984-2017 Cisco Systems, Inc.
3 *
4 * Licensed under the Apache License, Version 2.0 (the "License");
5 * you may not use this file except in compliance with the License.
6 * You may obtain a copy of the License at
7 *
8 * http://www.apache.org/licenses/LICENSE-2.0
9 *
10 * Unless required by applicable law or agreed to in writing, software
11 * distributed under the License is distributed on an "AS IS" BASIS,
12 * WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
13 * See the License for the specific language governing permissions and
14 * limitations under the License.
15 */
16
17 #include "system.h"
18
19 /* locally defined functions */
20 static void pimmediate PROTO((ptr x));
21 static void pbox PROTO((ptr x));
22 static void pclo PROTO((ptr x));
23 static void pcode PROTO((ptr x));
24 static void pcons PROTO((ptr x));
25 static void pfile PROTO((ptr x));
26 static void pinexactnum PROTO((ptr x));
27 static IBOOL exact_real_negativep PROTO((ptr x));
28 static void pexactnum PROTO((ptr x));
29 static void prat PROTO((ptr x));
30 static void pchar PROTO((ptr x));
31 static void pstr PROTO((ptr x));
32 static void psym PROTO((ptr x));
33 static void pvec PROTO((ptr x));
34 static void pfxvector PROTO((ptr x));
35 static void pbytevector PROTO((ptr x));
36 static void pflonum PROTO((ptr x));
37 static void pfixnum PROTO((ptr x));
38 static void pbignum PROTO((ptr x));
39 static void wrint PROTO((ptr x));
40
S_print_init()41 void S_print_init() {}
42
S_prin1(x)43 void S_prin1(x) ptr x; {
44 if (Simmediatep(x)) pimmediate(x);
45 else if (Spairp(x)) pcons(x);
46 else if (Ssymbolp(x)) psym(x);
47 else if (Sfixnump(x)) pfixnum(x);
48 else if (Sbignump(x)) pbignum(x);
49 else if (Sstringp(x)) pstr(x);
50 else if (Sratnump(x)) prat(x);
51 else if (Sflonump(x)) (void) pflonum(x);
52 else if (Sinexactnump(x)) pinexactnum(x);
53 else if (Sexactnump(x)) pexactnum(x);
54 else if (Svectorp(x)) pvec(x);
55 else if (Sfxvectorp(x)) pfxvector(x);
56 else if (Sbytevectorp(x)) pbytevector(x);
57 else if (Sboxp(x)) pbox(x);
58 else if (Sprocedurep(x)) pclo(x);
59 else if (Scodep(x)) pcode(x);
60 else if (Sportp(x)) pfile(x);
61 else if (Srecordp(x)) printf("#<record>");
62 else printf("#<garbage>");
63 fflush(stdout);
64 }
65
66
pimmediate(x)67 static void pimmediate(x) ptr x; {
68 if (Scharp(x)) pchar(x);
69 else if (x == Snil) printf("()");
70 else if (x == Strue) printf("#t");
71 else if (x == Sfalse) printf("#f");
72 else if (x == Seof_object) printf("#!eof");
73 else if (x == Sbwp_object) printf("#!bwp");
74 else if (x == sunbound) printf("#<unbound>");
75 else if (x == Svoid) printf("#<void>");
76 else printf("#<garbage>");
77 }
78
pbox(x)79 static void pbox(x) ptr x; {
80 printf("#&");
81 S_prin1(Sunbox(x));
82 }
83
pclo(UNUSED ptr x)84 static void pclo(UNUSED ptr x) {
85 if (CODETYPE(CLOSCODE(x)) & (code_flag_continuation << code_flags_offset))
86 printf("#<continuation>");
87 else
88 printf("#<procedure>");
89 }
90
pcode(UNUSED ptr x)91 static void pcode(UNUSED ptr x) {
92 printf("#<code>");
93 }
94
pcons(x)95 static void pcons(x) ptr x; {
96 putchar('(');
97 while (1) {
98 S_prin1(Scar(x));
99 x = Scdr(x);
100 if (!Spairp(x)) break;
101 putchar(' ');
102 }
103 if (x!=Snil) {
104 printf(" . ");
105 S_prin1(x);
106 }
107 putchar(')');
108 }
109
110
pfile(UNUSED ptr x)111 static void pfile(UNUSED ptr x) {
112 printf("#<port>");
113 }
114
pinexactnum(x)115 static void pinexactnum(x) ptr x; {
116 S_prin1(TYPE(&INEXACTNUM_REAL_PART(x),type_flonum));
117 if (INEXACTNUM_IMAG_PART(x) >= 0.0) putchar('+');
118 S_prin1(TYPE(&INEXACTNUM_IMAG_PART(x),type_flonum));
119 putchar('i');
120 }
121
exact_real_negativep(x)122 static IBOOL exact_real_negativep(x) ptr x; {
123 if (Sratnump(x)) x = RATNUM(x);
124 return Sfixnump(x) ? UNFIX(x) < 0 : BIGSIGN(x);
125 }
126
pexactnum(x)127 static void pexactnum(x) ptr x; {
128 S_prin1(EXACTNUM_REAL_PART(x));
129 if (!exact_real_negativep(EXACTNUM_IMAG_PART(x))) putchar('+');
130 S_prin1(EXACTNUM_IMAG_PART(x));
131 putchar('i');
132 }
133
prat(x)134 static void prat(x) ptr x; {
135 wrint(RATNUM(x));
136 putchar('/');
137 wrint(RATDEN(x));
138 }
139
pchar(x)140 static void pchar(x) ptr x; {
141 int k = Schar_value(x);
142 if (k >= 256) k = '?';
143 printf("#\\");
144 putchar(k);
145 }
146
pstr(x)147 static void pstr(x) ptr x; {
148 iptr i, n = Sstring_length(x);
149
150 putchar('"');
151 for (i = 0; i < n; i += 1) {
152 int k = Sstring_ref(x, i);
153 if (k >= 256) k = '?';
154 if ((k == '\\') || (k == '"')) putchar('\\');
155 putchar(k);
156 }
157 putchar('"');
158 }
159
display_string(x)160 static void display_string(x) ptr x; {
161 iptr i, n = Sstring_length(x);
162
163 for (i = 0; i < n; i += 1) {
164 int k = Sstring_ref(x, i);
165 if (k >= 256) k = '?';
166 putchar(k);
167 }
168 }
169
psym(x)170 static void psym(x) ptr x; {
171 ptr name = SYMNAME(x);
172 if (Sstringp(name)) {
173 display_string(name);
174 } else if (Spairp(name)) {
175 if (Scar(name) != Sfalse) {
176 printf("#{");
177 display_string(Scdr(name));
178 printf(" ");
179 display_string(Scar(name));
180 printf("}");
181 } else {
182 printf("#<gensym ");
183 display_string(Scdr(name));
184 printf(">");
185 }
186 } else {
187 printf("#<gensym>");
188 }
189 }
190
pvec(x)191 static void pvec(x) ptr x; {
192 iptr n;
193
194 putchar('#');
195 n = Svector_length(x);
196 wrint(FIX(n));
197 putchar('(');
198 if (n != 0) {
199 iptr i = 0;
200
201 while (1) {
202 S_prin1(Svector_ref(x, i));
203 if (++i == n) break;
204 putchar(' ');
205 }
206 }
207 putchar(')');
208 }
209
pfxvector(x)210 static void pfxvector(x) ptr x; {
211 iptr n;
212
213 putchar('#');
214 n = Sfxvector_length(x);
215 wrint(FIX(n));
216 printf("vfx(");
217 if (n != 0) {
218 iptr i = 0;
219
220 while (1) {
221 pfixnum(Sfxvector_ref(x, i));
222 if (++i == n) break;
223 putchar(' ');
224 }
225 }
226 putchar(')');
227 }
228
pbytevector(x)229 static void pbytevector(x) ptr x; {
230 iptr n;
231
232 putchar('#');
233 n = Sbytevector_length(x);
234 wrint(FIX(n));
235 printf("vu8(");
236 if (n != 0) {
237 iptr i = 0;
238
239 while (1) {
240 pfixnum(FIX(Sbytevector_u8_ref(x, i)));
241 if (++i == n) break;
242 putchar(' ');
243 }
244 }
245 putchar(')');
246 }
247
pflonum(x)248 static void pflonum(x) ptr x; {
249 char buf[256], *s;
250
251 /* use snprintf to get it in a string */
252 (void) snprintf(buf, 256, "%.16g",FLODAT(x));
253
254 /* print the silly thing */
255 printf("%s", buf);
256
257 /* add .0 if it looks like an integer */
258 s = buf;
259 while (*s != 'E' && *s != 'e' && *s != '.')
260 if (*s++ == 0) {
261 printf(".0");
262 break;
263 }
264 }
265
pfixnum(x)266 static void pfixnum(x) ptr x; {
267 if (UNFIX(x) < 0) {
268 putchar('-');
269 x = S_sub(FIX(0), x);
270 }
271 wrint(x);
272 }
273
pbignum(x)274 static void pbignum(x) ptr x; {
275 if (BIGSIGN(x)) {
276 putchar('-');
277 x = S_sub(FIX(0), x);
278 }
279 wrint(x);
280 }
281
wrint(x)282 static void wrint(x) ptr x; {
283 ptr q, r;
284
285 S_trunc_rem(get_thread_context(), x, FIX(10), &q, &r);
286 if (q != 0) wrint(q);
287 putchar((INT)UNFIX(r) + '0');
288 }
289