summaryrefslogtreecommitdiff
path: root/xlisp/xlprin.c
diff options
context:
space:
mode:
Diffstat (limited to 'xlisp/xlprin.c')
-rw-r--r--xlisp/xlprin.c338
1 files changed, 338 insertions, 0 deletions
diff --git a/xlisp/xlprin.c b/xlisp/xlprin.c
new file mode 100644
index 0000000..60339be
--- /dev/null
+++ b/xlisp/xlprin.c
@@ -0,0 +1,338 @@
+/* xlprint - xlisp print routine */
+/* Copyright (c) 1985, by David Michael Betz
+ All Rights Reserved
+ Permission is granted for unrestricted non-commercial use
+
+ * HISTORY
+ * 28-Apr-03 Mazzoni
+ * Eliminated some compiler warnings
+ *
+ * 3-Apr-88 Dale Amon at CMU-CSD
+ * Added extern support to xlisp 2.0
+ *
+ * 18-Oct-87 Dale Amon at CMU-CSD
+ * Added print support for EXTERN nodes
+ */
+
+
+#include "string.h"
+#include "xlisp.h"
+
+/* external variables */
+extern LVAL s_printcase,k_downcase,k_const,k_nmacro;
+extern LVAL s_ifmt,s_ffmt;
+extern FUNDEF funtab[];
+extern char buf[];
+
+LOCAL void putsymbol(LVAL fptr, char *str, int escflag);
+LOCAL void putsubr(LVAL fptr, char *tag, LVAL val);
+LOCAL void putfixnum(LVAL fptr, FIXTYPE n);
+LOCAL void putflonum(LVAL fptr, FLOTYPE n);
+LOCAL void putchcode(LVAL fptr, int ch, int escflag);
+LOCAL void putstring(LVAL fptr, LVAL str);
+LOCAL void putqstring(LVAL fptr, LVAL str);
+LOCAL void putclosure(LVAL fptr, LVAL val);
+LOCAL void putoct(LVAL fptr, int n);
+
+
+/* xlprint - print an xlisp value */
+void xlprint(LVAL fptr, LVAL vptr, int flag)
+{
+ LVAL nptr,next;
+ int n,i;
+
+ /* print nil */
+ if (vptr == NIL) {
+ putsymbol(fptr,"NIL",flag);
+ return;
+ }
+
+ /* check value type */
+ switch (ntype(vptr)) {
+ case SUBR:
+ putsubr(fptr,"Subr",vptr);
+ break;
+ case FSUBR:
+ putsubr(fptr,"FSubr",vptr);
+ break;
+ case CONS:
+ xlputc(fptr,'(');
+ for (nptr = vptr; nptr != NIL; nptr = next) {
+ xlprint(fptr,car(nptr),flag);
+ if ((next = cdr(nptr))) {
+ if (consp(next))
+ xlputc(fptr,' ');
+ else {
+ xlputstr(fptr," . ");
+ xlprint(fptr,next,flag);
+ break;
+ }
+ }
+ }
+ xlputc(fptr,')');
+ break;
+ case SYMBOL:
+ putsymbol(fptr,(char *) getstring(getpname(vptr)),flag);
+ break;
+ case FIXNUM:
+ putfixnum(fptr,getfixnum(vptr));
+ break;
+ case FLONUM:
+ putflonum(fptr,getflonum(vptr));
+ break;
+ case CHAR:
+ putchcode(fptr,getchcode(vptr),flag);
+ break;
+ case STRING:
+ if (flag)
+ putqstring(fptr,vptr);
+ else
+ putstring(fptr,vptr);
+ break;
+ case STREAM:
+ putatm(fptr,"File-Stream",vptr);
+ break;
+ case USTREAM:
+ putatm(fptr,"Unnamed-Stream",vptr);
+ break;
+ case OBJECT:
+ putatm(fptr,"Object",vptr);
+ break;
+ case VECTOR:
+ xlputc(fptr,'#'); xlputc(fptr,'(');
+ for (i = 0, n = getsize(vptr); n-- > 0; ) {
+ xlprint(fptr,getelement(vptr,i++),flag);
+ if (n) xlputc(fptr,' ');
+ }
+ xlputc(fptr,')');
+ break;
+ case CLOSURE:
+ putclosure(fptr,vptr);
+ break;
+ case EXTERN:
+ if (getdesc(vptr)) {
+ (*(getdesc(vptr)->print_meth))(fptr, getinst(vptr));
+ }
+ break;
+ case FREE_NODE:
+ putatm(fptr,"Free",vptr);
+ break;
+ default:
+ putatm(fptr,"Foo",vptr);
+ break;
+ }
+}
+
+/* xlterpri - terminate the current print line */
+void xlterpri(LVAL fptr)
+{
+ xlputc(fptr,'\n');
+}
+
+/* xlputstr - output a string */
+void xlputstr(LVAL fptr, char *str)
+{
+ while (*str)
+ xlputc(fptr,*str++);
+}
+
+/* putsymbol - output a symbol */
+LOCAL void putsymbol(LVAL fptr, char *str, int escflag)
+{
+ int downcase;
+ LVAL type;
+ char *p;
+
+ /* check for printing without escapes */
+ if (!escflag) {
+ xlputstr(fptr,str);
+ return;
+ }
+
+ /* check to see if symbol needs escape characters */
+ if (tentry(*str) == k_const) {
+ for (p = str; *p; ++p)
+ if (islower(*p)
+ || ((type = tentry(*p)) != k_const
+ && (!consp(type) || car(type) != k_nmacro))) {
+ xlputc(fptr,'|');
+ while (*str) {
+ if (*str == '\\' || *str == '|')
+ xlputc(fptr,'\\');
+ xlputc(fptr,*str++);
+ }
+ xlputc(fptr,'|');
+ return;
+ }
+ }
+
+ /* get the case translation flag */
+ downcase = (getvalue(s_printcase) == k_downcase);
+
+ /* check for the first character being '#' */
+ if (*str == '#' || *str == '.' || xlisnumber(str,NULL))
+ xlputc(fptr,'\\');
+
+ /* output each character */
+ while (*str) {
+ /* don't escape colon until we add support for packages */
+ if (*str == '\\' || *str == '|' /* || *str == ':' */)
+ xlputc(fptr,'\\');
+ xlputc(fptr,(downcase && isupper(*str) ? tolower(*str++) : *str++));
+ }
+}
+
+/* putstring - output a string */
+LOCAL void putstring(LVAL fptr, LVAL str)
+{
+ unsigned char *p;
+ int ch;
+
+ /* output each character */
+ for (p = getstring(str); (ch = *p) != '\0'; ++p)
+ xlputc(fptr,ch);
+}
+
+/* putqstring - output a quoted string */
+LOCAL void putqstring(LVAL fptr, LVAL str)
+{
+ unsigned char *p;
+ int ch;
+
+ /* get the string pointer */
+ p = getstring(str);
+
+ /* output the initial quote */
+ xlputc(fptr,'"');
+
+ /* output each character in the string */
+ for (p = getstring(str); (ch = *p) != '\0'; ++p)
+
+ /* check for a control character */
+ if (ch < 040 || ch == '\\' || ch > 0176) {
+ xlputc(fptr,'\\');
+ switch (ch) {
+ case '\011':
+ xlputc(fptr,'t');
+ break;
+ case '\012':
+ xlputc(fptr,'n');
+ break;
+ case '\014':
+ xlputc(fptr,'f');
+ break;
+ case '\015':
+ xlputc(fptr,'r');
+ break;
+ case '\\':
+ xlputc(fptr,'\\');
+ break;
+ default:
+ putoct(fptr,ch);
+ break;
+ }
+ }
+
+ /* output a normal character */
+ else
+ xlputc(fptr,ch);
+
+ /* output the terminating quote */
+ xlputc(fptr,'"');
+}
+
+/* putatm - output an atom */
+void putatm(LVAL fptr, char *tag, LVAL val)
+{
+ sprintf(buf,"#<%s: #",tag); xlputstr(fptr,buf);
+ sprintf(buf,AFMT,(long unsigned int)val); xlputstr(fptr,buf);
+ xlputc(fptr,'>');
+}
+
+/* putsubr - output a subr/fsubr */
+LOCAL void putsubr(LVAL fptr, char *tag, LVAL val)
+{
+ sprintf(buf,"#<%s-%s: #",tag,funtab[getoffset(val)].fd_name);
+ xlputstr(fptr,buf);
+ sprintf(buf,AFMT,(long unsigned int)val); xlputstr(fptr,buf);
+ xlputc(fptr,'>');
+}
+
+/* putclosure - output a closure */
+LOCAL void putclosure(LVAL fptr, LVAL val)
+{
+ LVAL name;
+ if ((name = getname(val)))
+ sprintf(buf,"#<Closure-%s: #",getstring(getpname(name)));
+ else
+ strcpy(buf,"#<Closure: #");
+ xlputstr(fptr,buf);
+ sprintf(buf,AFMT,(long unsigned int)val); xlputstr(fptr,buf);
+ xlputc(fptr,'>');
+/*
+ xlputstr(fptr,"\nName: "); xlprint(fptr,getname(val),TRUE);
+ xlputstr(fptr,"\nType: "); xlprint(fptr,gettype(val),TRUE);
+ xlputstr(fptr,"\nLambda: "); xlprint(fptr,getlambda(val),TRUE);
+ xlputstr(fptr,"\nArgs: "); xlprint(fptr,getargs(val),TRUE);
+ xlputstr(fptr,"\nOargs: "); xlprint(fptr,getoargs(val),TRUE);
+ xlputstr(fptr,"\nRest: "); xlprint(fptr,getrest(val),TRUE);
+ xlputstr(fptr,"\nKargs: "); xlprint(fptr,getkargs(val),TRUE);
+ xlputstr(fptr,"\nAargs: "); xlprint(fptr,getaargs(val),TRUE);
+ xlputstr(fptr,"\nBody: "); xlprint(fptr,getbody(val),TRUE);
+ xlputstr(fptr,"\nEnv: "); xlprint(fptr,closure_getenv(val),TRUE);
+ xlputstr(fptr,"\nFenv: "); xlprint(fptr,getfenv(val),TRUE);
+*/
+}
+
+/* putfixnum - output a fixnum */
+LOCAL void putfixnum(LVAL fptr, FIXTYPE n)
+{
+ unsigned char *fmt;
+ LVAL val;
+ fmt = ((val = getvalue(s_ifmt)) && stringp(val) ? getstring(val)
+ : (unsigned char *)IFMT);
+ sprintf(buf, (char *) fmt,n);
+ xlputstr(fptr,buf);
+}
+
+/* putflonum - output a flonum */
+LOCAL void putflonum(LVAL fptr, FLOTYPE n)
+{
+ unsigned char *fmt;
+ LVAL val;
+ fmt = ((val = getvalue(s_ffmt)) && stringp(val) ? getstring(val)
+ : (unsigned char *)"%g");
+ sprintf(buf,(char *) fmt,n);
+ xlputstr(fptr,buf);
+}
+
+/* putchcode - output a character */
+LOCAL void putchcode(LVAL fptr, int ch, int escflag)
+{
+ if (escflag) {
+ switch (ch) {
+ case '\n':
+ xlputstr(fptr,"#\\Newline");
+ break;
+ case ' ':
+ xlputstr(fptr,"#\\Space");
+ break;
+ case '\t':
+ xlputstr(fptr, "#\\Tab");
+ break;
+ default:
+ sprintf(buf,"#\\%c",ch);
+ xlputstr(fptr,buf);
+ break;
+ }
+ }
+ else
+ xlputc(fptr,ch);
+}
+
+/* putoct - output an octal byte value */
+LOCAL void putoct(LVAL fptr, int n)
+{
+ sprintf(buf,"%03o",n);
+ xlputstr(fptr,buf);
+}
generated by cgit v1.2.3 (git 2.25.1) at 2024-04-26 16:21:59 +0000