// Dump the contents of the obarray
LOCAL void nyx_show_obarray()
{
LVAL array = getvalue(obarray);
LVAL sym;
int i;
for (i = 0; i < HSIZE; i++) {
for (sym = getelement(array, i); sym; sym = cdr(sym)) {
LVAL syma = car(sym);
printf("_sym_ = ");
xlprint(getvalue(s_stdout), syma, TRUE);
if (getvalue(syma)) {
printf(" _type_ = %s _val_ = ", _types_[ntype(getvalue(syma))]);
xlprint(getvalue(s_stdout), getvalue(syma), TRUE);
}
if (getfunction(syma)) {
printf(" _type_ = %s _fun_ = ", _types_[ntype(getfunction(syma))]);
xlprint(getvalue(s_stdout), getfunction(syma), TRUE);
}
printf("\n");
}
}
}
/* xformat - formatted output function */
LVAL xformat(void)
{
unsigned char *fmt;
LVAL stream,val;
int ch;
/* protect stream in case it is a new ustream */
xlsave1(stream);
/* get the stream and format string */
stream = xlgetarg();
if (stream == NIL)
val = stream = newustream();
else {
if (stream == s_true)
stream = getvalue(s_stdout);
else if (!streamp(stream) && !ustreamp(stream))
xlbadtype(stream);
val = NIL;
}
fmt = getstring(xlgastring());
/* process the format string */
while ((ch = *fmt++))
if (ch == '~') {
switch (*fmt++) {
case '\0':
xlerror("expecting a format directive",cvstring((char *) (fmt-1)));
case 'a': case 'A':
xlprint(stream,xlgetarg(),FALSE);
break;
case 's': case 'S':
xlprint(stream,xlgetarg(),TRUE);
break;
case '%':
xlterpri(stream);
break;
case '~':
xlputc(stream,'~');
break;
case '\n':
case '\r':
/* mac may read \r -- this should be ignored */
if (*fmt == '\r') fmt++;
while (*fmt && *fmt != '\n' && isspace(*fmt))
++fmt;
break;
default:
xlerror("unknown format directive",cvstring((char *) (fmt-1)));
}
}
else
xlputc(stream,ch);
/* return the value */
if (val) val = getstroutput(val);
xlpop();
return val;
}
/* pplist - pretty print a list */
LOCAL void pplist(LVAL expr)
{
int n;
/* if the expression will fit on one line, print it on one */
if ((n = flatsize(expr)) < ppmaxlen) {
xlprint(ppfile,expr,TRUE);
pplevel += n;
}
/* otherwise print it on several lines */
else {
n = ppmargin;
ppputc('(');
if (atomp(car(expr))) {
ppexpr(car(expr));
ppputc(' ');
ppmargin = pplevel;
expr = cdr(expr);
}
else
ppmargin = pplevel;
for (; consp(expr); expr = cdr(expr)) {
pp(car(expr));
if (consp(cdr(expr)))
ppterpri();
}
if (expr != NIL) {
ppputc(' '); ppputc('.'); ppputc(' ');
ppexpr(expr);
}
ppputc(')');
ppmargin = n;
}
}
/* 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);
}
/* flatsize - compute the size of a printed expression */
LOCAL LVAL flatsize(int pflag)
{
LVAL val;
/* get the expression */
val = xlgetarg();
xllastarg();
/* print the value to compute its size */
xlfsize = 0;
xlprint(NIL,val,pflag);
/* return the length of the expression */
return (cvfixnum((FIXTYPE)xlfsize));
}
static int breakloop(char *hdr, char *cmsg, char *emsg, NODE *arg, int cflag)
{
NODE ***oldstk,*expr,*val;
CONTEXT cntxt;
int type;
xlerrprint(hdr,cmsg,emsg,arg);
xlflush();
if (((s_tracenable)->n_info.n_xsym.xsy_value)) {
val = ((s_tlimit)->n_info.n_xsym.xsy_value);
xlbaktrace(((val) && (val)->n_type == 5) ? (int)((val)->n_info.n_xint.xi_int) : -1);
}
oldstk = xlsave(&expr,(NODE **)0);
xldebug++;
xlbegin(&cntxt,8|16|32,true);
for (type = 0; type == 0; ) {
if (type = setjmp(cntxt.c_jmpbuf))
switch (type) {
case 8:
xlflush();
type = 0;
continue;
case 16:
continue;
case 32:
if (cflag) {
stdputstr("[ continue from break loop ]\n");
continue;
}
else xlabort("this error can't be continued");
}
if (!xlread(((s_stdin)->n_info.n_xsym.xsy_value),&expr,0)) {
type = 16;
break;
}
expr = xleval(expr);
xlprint(((s_stdout)->n_info.n_xsym.xsy_value),expr,1);
xlterpri(((s_stdout)->n_info.n_xsym.xsy_value));
}
xlend(&cntxt);
xldebug--;
xlstack = oldstk;
if (type == 16) {
stdputstr("[ abort to previous level ]\n");
xlsignal(0,(NODE *)0);
}
}
/* printit - common print function */
LOCAL LVAL printit(int pflag, int tflag)
{
LVAL fptr,val;
/* get expression to print and file pointer */
val = xlgetarg();
fptr = (moreargs() ? xlgetfile() : getvalue(s_stdout));
xllastarg();
/* print the value */
xlprint(fptr,val,pflag);
/* terminate the print line if necessary */
if (tflag)
xlterpri(fptr);
/* return the result */
return (val);
}
/* trcprin1 - print to *trace-output* */
void trcprin1(LVAL expr)
{
xlprint(getvalue(s_traceout),expr,TRUE);
}
/* dbgprint - print to *debug-io* */
void dbgprint(LVAL expr)
{
xlprint(getvalue(s_debugio),expr,TRUE);
xlterpri(getvalue(s_debugio));
}
/* errprint - print to *error-output* */
void errprint(LVAL expr)
{
xlprint(getvalue(s_stderr),expr,TRUE);
xlterpri(getvalue(s_stderr));
}
/* errprint - print to *error-output* */
VOID errprint P1C(LVAL, expr)
{
xlprint(getvalue(s_stderr),expr,TRUE);
xlterpri(getvalue(s_stderr));
}
/* ppexpr - print an expression and update the indent level */
LOCAL void ppexpr(LVAL expr)
{
xlprint(ppfile,expr,TRUE);
pplevel += flatsize(expr);
}
/* flatsize - compute the flat size of an expression */
LOCAL int flatsize(LVAL expr)
{
xlfsize = 0;
xlprint(NIL,expr,TRUE);
return (xlfsize);
}
/* trcprin1 - print to *trace-output* */
VOID trcprin1 P1C(LVAL, expr)
{
xlprint(getvalue(s_traceout),expr,TRUE);
}
/* dbgprint - print to *debug-io* */
VOID dbgprint P1C(LVAL, expr)
{
xlprint(getvalue(s_debugio),expr,TRUE);
xlterpri(getvalue(s_debugio));
}
stdprint(NODE *expr)
{
xlprint(((s_stdout)->n_info.n_xsym.xsy_value),expr,1);
xlterpri(((s_stdout)->n_info.n_xsym.xsy_value));
}
/* stdprint - print to *standard-output* */
void stdprint(LVAL expr)
{
xlprint(getvalue(s_stdout),expr,TRUE);
xlterpri(getvalue(s_stdout));
}
/* 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;
}
}
/* stdprint - print to *standard-output* */
VOID stdprint P1C(LVAL, expr)
{
xlprint(getvalue(s_stdout),expr,TRUE);
xlterpri(getvalue(s_stdout));
}