xlerrprint(char *hdr, char *cmsg, char *emsg, NODE *arg)
{
sprintf(buf,"%s: %s",hdr,emsg); stdputstr(buf);
if (arg != s_unbound) { stdputstr(" - "); stdprint(arg); }
else xlterpri(((s_stdout)->n_info.n_xsym.xsy_value));
if (cmsg) { sprintf(buf,"if continued: %s\n",cmsg); stdputstr(buf); }
}
/* 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;
}
/* xterpri - terminate the current print line */
LVAL xterpri(void)
{
LVAL fptr;
/* get file pointer */
fptr = (moreargs() ? xlgetfile() : getvalue(s_stdout));
xllastarg();
/* terminate the print line and return nil */
xlterpri(fptr);
return (NIL);
}
/* 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);
}
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);
}
stdprint(NODE *expr)
{
xlprint(((s_stdout)->n_info.n_xsym.xsy_value),expr,1);
xlterpri(((s_stdout)->n_info.n_xsym.xsy_value));
}
/* 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));
}
/* stdprint - print to *standard-output* */
void stdprint(LVAL expr)
{
xlprint(getvalue(s_stdout),expr,TRUE);
xlterpri(getvalue(s_stdout));
}
/* ppterpri - terminate the print line and indent */
LOCAL void ppterpri(void)
{
xlterpri(ppfile);
for (pplevel = 0; pplevel < ppmargin; pplevel++)
xlputc(ppfile,' ');
}
/* dbgprint - print to *debug-io* */
VOID dbgprint P1C(LVAL, expr)
{
xlprint(getvalue(s_debugio),expr,TRUE);
xlterpri(getvalue(s_debugio));
}
/* errprint - print to *error-output* */
VOID errprint P1C(LVAL, expr)
{
xlprint(getvalue(s_stderr),expr,TRUE);
xlterpri(getvalue(s_stderr));
}
/* stdprint - print to *standard-output* */
VOID stdprint P1C(LVAL, expr)
{
xlprint(getvalue(s_stdout),expr,TRUE);
xlterpri(getvalue(s_stdout));
}
