1 /* xlprint - xlisp print routine */
2 /* Copyright (c) 1985, by David Michael Betz
3 All Rights Reserved
4 Permission is granted for unrestricted non-commercial use
5
6 * HISTORY
7 * 28-Apr-03 Mazzoni
8 * Eliminated some compiler warnings
9 *
10 * 3-Apr-88 Dale Amon at CMU-CSD
11 * Added extern support to xlisp 2.0
12 *
13 * 18-Oct-87 Dale Amon at CMU-CSD
14 * Added print support for EXTERN nodes
15 */
16
17
18 #include "string.h"
19 #include "xlisp.h"
20
21 /* external variables */
22 extern LVAL s_printcase,k_downcase,k_const,k_nmacro;
23 extern LVAL s_ifmt,s_ffmt;
24 extern FUNDEF *funtab;
25 extern char buf[];
26
27 LOCAL void putsymbol(LVAL fptr, char *str, int escflag);
28 LOCAL void putsubr(LVAL fptr, const char *tag, LVAL val);
29 LOCAL void putfixnum(LVAL fptr, FIXTYPE n);
30 LOCAL void putflonum(LVAL fptr, FLOTYPE n);
31 LOCAL void putchcode(LVAL fptr, int ch, int escflag);
32 LOCAL void putstring(LVAL fptr, LVAL str);
33 LOCAL void putqstring(LVAL fptr, LVAL str);
34 LOCAL void putclosure(LVAL fptr, LVAL val);
35 LOCAL void putoct(LVAL fptr, int n);
36
37
38 /* xlprint - print an xlisp value */
xlprint(LVAL fptr,LVAL vptr,int flag)39 void xlprint(LVAL fptr, LVAL vptr, int flag)
40 {
41 LVAL nptr,next;
42 int n,i;
43
44 /* print nil */
45 if (vptr == NIL) {
46 putsymbol(fptr,"NIL",flag);
47 return;
48 }
49
50 /* check value type */
51 switch (ntype(vptr)) {
52 case SUBR:
53 putsubr(fptr,"Subr",vptr);
54 break;
55 case FSUBR:
56 putsubr(fptr,"FSubr",vptr);
57 break;
58 case CONS:
59 xlputc(fptr,'(');
60 for (nptr = vptr; nptr != NIL; nptr = next) {
61 xlprint(fptr,car(nptr),flag);
62 if ((next = cdr(nptr))) {
63 if (consp(next))
64 xlputc(fptr,' ');
65 else {
66 xlputstr(fptr," . ");
67 xlprint(fptr,next,flag);
68 break;
69 }
70 }
71 }
72 xlputc(fptr,')');
73 break;
74 case SYMBOL:
75 putsymbol(fptr,(char *) getstring(getpname(vptr)),flag);
76 break;
77 case FIXNUM:
78 putfixnum(fptr,getfixnum(vptr));
79 break;
80 case FLONUM:
81 putflonum(fptr,getflonum(vptr));
82 break;
83 case CHAR:
84 putchcode(fptr,getchcode(vptr),flag);
85 break;
86 case STRING:
87 if (flag)
88 putqstring(fptr,vptr);
89 else
90 putstring(fptr,vptr);
91 break;
92 case STREAM:
93 putatm(fptr,"File-Stream",vptr);
94 break;
95 case USTREAM:
96 putatm(fptr,"Unnamed-Stream",vptr);
97 break;
98 case OBJECT:
99 putatm(fptr,"Object",vptr);
100 break;
101 case VECTOR:
102 xlputc(fptr,'#'); xlputc(fptr,'(');
103 for (i = 0, n = getsize(vptr); n-- > 0; ) {
104 xlprint(fptr,getelement(vptr,i++),flag);
105 if (n) xlputc(fptr,' ');
106 }
107 xlputc(fptr,')');
108 break;
109 case CLOSURE:
110 putclosure(fptr,vptr);
111 break;
112 case EXTERN:
113 if (getdesc(vptr)) {
114 (*(getdesc(vptr)->print_meth))(fptr, getinst(vptr));
115 }
116 break;
117 case FREE_NODE:
118 putatm(fptr,"Free",vptr);
119 break;
120 default:
121 putatm(fptr,"Foo",vptr);
122 break;
123 }
124 }
125
126 /* xlterpri - terminate the current print line */
xlterpri(LVAL fptr)127 void xlterpri(LVAL fptr)
128 {
129 xlputc(fptr,'\n');
130 }
131
132 /* xlputstr - output a string */
xlputstr(LVAL fptr,const char * str)133 void xlputstr(LVAL fptr, const char *str)
134 {
135 while (*str)
136 xlputc(fptr,*str++);
137 }
138
139 /* putsymbol - output a symbol */
putsymbol(LVAL fptr,char * str,int escflag)140 LOCAL void putsymbol(LVAL fptr, char *str, int escflag)
141 {
142 int downcase;
143 LVAL type;
144 char *p;
145
146 /* check for printing without escapes */
147 if (!escflag) {
148 xlputstr(fptr,str);
149 return;
150 }
151
152 /* check to see if symbol needs escape characters */
153 if (tentry(*str) == k_const) {
154 for (p = str; *p; ++p)
155 if (islower(*p)
156 || ((type = tentry(*p)) != k_const
157 && (!consp(type) || car(type) != k_nmacro))) {
158 xlputc(fptr,'|');
159 while (*str) {
160 if (*str == '\\' || *str == '|')
161 xlputc(fptr,'\\');
162 xlputc(fptr,*str++);
163 }
164 xlputc(fptr,'|');
165 return;
166 }
167 }
168
169 /* get the case translation flag */
170 downcase = (getvalue(s_printcase) == k_downcase);
171
172 /* check for the first character being '#' */
173 if (*str == '#' || *str == '.' || xlisnumber(str,NULL))
174 xlputc(fptr,'\\');
175
176 /* output each character */
177 while (*str) {
178 /* don't escape colon until we add support for packages */
179 if (*str == '\\' || *str == '|' /* || *str == ':' */)
180 xlputc(fptr,'\\');
181 xlputc(fptr,(downcase && isupper(*str) ? tolower(*str++) : *str++));
182 }
183 }
184
185 /* putstring - output a string */
putstring(LVAL fptr,LVAL str)186 LOCAL void putstring(LVAL fptr, LVAL str)
187 {
188 unsigned char *p;
189 int ch;
190
191 /* output each character */
192 for (p = getstring(str); (ch = *p) != '\0'; ++p)
193 xlputc(fptr,ch);
194 }
195
196 /* putqstring - output a quoted string */
putqstring(LVAL fptr,LVAL str)197 LOCAL void putqstring(LVAL fptr, LVAL str)
198 {
199 unsigned char *p;
200 int ch;
201
202 /* get the string pointer */
203 p = getstring(str);
204
205 /* output the initial quote */
206 xlputc(fptr,'"');
207
208 /* output each character in the string */
209 for (p = getstring(str); (ch = *p) != '\0'; ++p)
210
211 /* check for a control character */
212 if (ch < 040 || ch == '\\' || ch > 0176 /* || ch == '"' */) {
213 xlputc(fptr,'\\');
214 switch (ch) {
215 case '\011':
216 xlputc(fptr,'t');
217 break;
218 case '\012':
219 xlputc(fptr,'n');
220 break;
221 case '\014':
222 xlputc(fptr,'f');
223 break;
224 case '\015':
225 xlputc(fptr,'r');
226 break;
227 case '\\':
228 xlputc(fptr,'\\');
229 break;
230 case '"':
231 xlputc(fptr, '"');
232 break;
233 default:
234 putoct(fptr,ch);
235 break;
236 }
237 }
238
239 /* output a normal character */
240 else
241 xlputc(fptr,ch);
242
243 /* output the terminating quote */
244 xlputc(fptr,'"');
245 }
246
247 /* putatm - output an atom */
putatm(LVAL fptr,const char * tag,LVAL val)248 void putatm(LVAL fptr, const char *tag, LVAL val)
249 {
250 snprintf(buf, STRMAX, "#<%s: #", tag); xlputstr(fptr,buf);
251 sprintf(buf,AFMT,val); xlputstr(fptr,buf);
252 xlputc(fptr,'>');
253 }
254
255 /* putsubr - output a subr/fsubr */
putsubr(LVAL fptr,const char * tag,LVAL val)256 LOCAL void putsubr(LVAL fptr, const char *tag, LVAL val)
257 {
258 snprintf(buf, STRMAX, "#<%s-%s: #", tag, funtab[getoffset(val)].fd_name);
259 xlputstr(fptr,buf);
260 sprintf(buf,AFMT,val); xlputstr(fptr,buf);
261 xlputc(fptr,'>');
262 }
263
264 /* putclosure - output a closure */
putclosure(LVAL fptr,LVAL val)265 LOCAL void putclosure(LVAL fptr, LVAL val)
266 {
267 LVAL name;
268 if ((name = getname(val)))
269 snprintf(buf, STRMAX, "#<Closure-%s: #",getstring(getpname(name)));
270 else
271 strcpy(buf,"#<Closure: #");
272 xlputstr(fptr,buf);
273 sprintf(buf,AFMT,val); xlputstr(fptr,buf);
274 xlputc(fptr,'>');
275 /*
276 xlputstr(fptr,"\nName: "); xlprint(fptr,getname(val),TRUE);
277 xlputstr(fptr,"\nType: "); xlprint(fptr,gettype(val),TRUE);
278 xlputstr(fptr,"\nLambda: "); xlprint(fptr,getlambda(val),TRUE);
279 xlputstr(fptr,"\nArgs: "); xlprint(fptr,getargs(val),TRUE);
280 xlputstr(fptr,"\nOargs: "); xlprint(fptr,getoargs(val),TRUE);
281 xlputstr(fptr,"\nRest: "); xlprint(fptr,getrest(val),TRUE);
282 xlputstr(fptr,"\nKargs: "); xlprint(fptr,getkargs(val),TRUE);
283 xlputstr(fptr,"\nAargs: "); xlprint(fptr,getaargs(val),TRUE);
284 xlputstr(fptr,"\nBody: "); xlprint(fptr,getbody(val),TRUE);
285 xlputstr(fptr,"\nEnv: "); xlprint(fptr,closure_getenv(val),TRUE);
286 xlputstr(fptr,"\nFenv: "); xlprint(fptr,getfenv(val),TRUE);
287 */
288 }
289
290 /* putfixnum - output a fixnum */
putfixnum(LVAL fptr,FIXTYPE n)291 LOCAL void putfixnum(LVAL fptr, FIXTYPE n)
292 {
293 unsigned char *fmt;
294 LVAL val;
295 fmt = ((val = getvalue(s_ifmt)) && stringp(val) ? getstring(val)
296 : (unsigned char *)IFMT);
297 snprintf(buf, STRMAX, (char *) fmt, n);
298 xlputstr(fptr,buf);
299 }
300
301 /* putflonum - output a flonum */
putflonum(LVAL fptr,FLOTYPE n)302 LOCAL void putflonum(LVAL fptr, FLOTYPE n)
303 {
304 unsigned char *fmt;
305 LVAL val;
306 fmt = ((val = getvalue(s_ffmt)) && stringp(val) ? getstring(val)
307 : (unsigned char *)"%g");
308 snprintf(buf, STRMAX, (char *) fmt, n);
309 xlputstr(fptr,buf);
310 }
311
312 /* putchcode - output a character */
putchcode(LVAL fptr,int ch,int escflag)313 LOCAL void putchcode(LVAL fptr, int ch, int escflag)
314 {
315 if (escflag) {
316 switch (ch) {
317 case '\n':
318 xlputstr(fptr,"#\\Newline");
319 break;
320 case ' ':
321 xlputstr(fptr,"#\\Space");
322 break;
323 case '\t':
324 xlputstr(fptr, "#\\Tab");
325 break;
326 default:
327 sprintf(buf,"#\\%c",ch);
328 xlputstr(fptr,buf);
329 break;
330 }
331 }
332 else
333 xlputc(fptr,ch);
334 }
335
336 /* putoct - output an octal byte value */
putoct(LVAL fptr,int n)337 LOCAL void putoct(LVAL fptr, int n)
338 {
339 sprintf(buf,"%03o",n);
340 xlputstr(fptr,buf);
341 }
342