/* 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);
}
