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