/* 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,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); */ }
/* 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,val); xlputstr(fptr,buf); xlputc(fptr,'>'); }
/* putatm - output an atom */ void putatm(LVAL fptr, char *tag, LVAL val) { sprintf(buf,"#<%s: #",tag); xlputstr(fptr,buf); sprintf(buf,AFMT,val); xlputstr(fptr,buf); xlputc(fptr,'>'); }
/* 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); }
/* obshow - show the instance variables of an object */ LVAL obshow(void) { LVAL self,fptr,cls,names; int ivtotal,n; /* get self and the file pointer */ self = xlgaobject(); fptr = (moreargs() ? xlgetfile() : getvalue(s_stdout)); xllastarg(); /* get the object's class */ cls = getclass(self); /* print the object and class */ xlputstr(fptr,"Object is "); xlprint(fptr,self,TRUE); xlputstr(fptr,", Class is "); xlprint(fptr,cls,TRUE); xlterpri(fptr); /* print the object's instance variables */ for (; cls; cls = getivar(cls,SUPERCLASS)) { names = getivar(cls,IVARS); ivtotal = getivcnt(cls,IVARTOTAL); for (n = ivtotal - getivcnt(cls,IVARCNT); n < ivtotal; ++n) { xlputstr(fptr," "); xlprint(fptr,car(names),TRUE); xlputstr(fptr," = "); xlprint(fptr,getivar(self,n),TRUE); xlterpri(fptr); names = cdr(names); } } /* return the object */ return (self); }
/* 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++)); } }
/* trcputstr - print a string to *trace-output* */ void trcputstr(const char *str) { xlputstr(getvalue(s_traceout),str); }
/* dbgputstr - print a string to *debug-io* */ void dbgputstr(const char *str) { xlputstr(getvalue(s_debugio),str); }
/* errputstr - print a string to *error-output* */ void errputstr(const char *str) { xlputstr(getvalue(s_stderr),str); }
/* stdputstr - print a string to *standard-output* */ void stdputstr(const char *str) { xlputstr(getvalue(s_stdout),str); }
/* 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; } }
/* putoct - output an octal byte value */ LOCAL void putoct(LVAL fptr, int n) { sprintf(buf,"%03o",n); xlputstr(fptr,buf); }
/* errputstr - print a string to *error-output* */ VOID errputstr P1C(char *, str) { xlputstr(getvalue(s_stderr),str); }
/* dbgputstr - print a string to *debug-io* */ VOID dbgputstr P1C(char *, str) { xlputstr(getvalue(s_debugio),str); }
/* trcputstr - print a string to *trace-output* */ VOID trcputstr P1C(char *, str) { xlputstr(getvalue(s_traceout),str); }
stdputstr(char *str) { xlputstr(((s_stdout)->n_info.n_xsym.xsy_value),str); }
/* stdputstr - print a string to *standard-output* */ VOID stdputstr P1C(char *, str) { xlputstr(getvalue(s_stdout),str); }