Category : Miscellaneous Language Source Code
Archive   : XLISP21D.ZIP
Filename : XLDBUG.C

 
Output of file : XLDBUG.C contained in archive : XLISP21D.ZIP
/* xldebug - xlisp debugging support */
/* Copyright (c) 1985, by David Michael Betz
All Rights Reserved
Permission is granted for unrestricted non-commercial use */

#include "xlisp.h"

/* external variables */
extern int xldebug;
extern int xlsample;
extern LVAL s_debugio,s_unbound,s_stderr;
extern LVAL s_tracenable,s_tlimit,s_breakenable;
extern LVAL true;

/* forward declarations */
#ifdef ANSI
void NEAR breakloop(char *hdr, char FAR *cmsg, char FAR *emsg, LVAL arg, int cflag);
#else
FORWARD VOID breakloop();
#endif


/* xlabort - xlisp serious error handler */
VOID xlabort(emsg)
char *emsg;
{
xlsignal(emsg,s_unbound);
xlerrprint("error",NULL,emsg,s_unbound);
xlbrklevel();
}

/* xlbreak - enter a break loop */
VOID xlbreak(emsg,arg)
char FAR *emsg; LVAL arg;
{
breakloop("break","return from BREAK",emsg,arg,TRUE);
}

/* xlfail - xlisp error handler */
VOID xlfail(emsg)
char *emsg;
{
xlerror(emsg,s_unbound);
}

/* xlerror - handle a fatal error */
LVAL xlerror(emsg,arg)
char FAR *emsg; LVAL arg;
{
if (!null(getvalue(s_breakenable)))
breakloop("error",NULL,emsg,arg,FALSE);
else {
xlsignal(emsg,arg);
xlerrprint("error",NULL,emsg,arg);
xlbrklevel();
}
return NIL; /* actually doesn't return */
}

/* xlcerror - handle a recoverable error */
VOID xlcerror(cmsg,emsg,arg)
char FAR *cmsg, FAR *emsg; LVAL arg;
{
if (!null(getvalue(s_breakenable)))
breakloop("error",cmsg,emsg,arg,TRUE);
else {
xlsignal(emsg,arg);
xlerrprint("error",NULL,emsg,arg);
xlbrklevel();
}
}

/* xlerrprint - print an error message */
VOID xlerrprint(hdr,cmsg,emsg,arg)
char *hdr, FAR *cmsg, FAR *emsg; LVAL arg;
{
/* TAA MOD -- start error message on a fresh line */
xlfreshline(getvalue(s_stderr));

/* print the error message */
#ifdef MEDMEM
sprintf(buf,"%s: ",hdr);
STRCAT(buf, emsg);
#else
sprintf(buf,"%s: %s",hdr,emsg);
#endif
errputstr(buf);

/* print the argument */
if (arg != s_unbound) {
errputstr(" - ");
errprint(arg);
}

/* no argument, just end the line */
else
errputstr("\n");

/* print the continuation message */
if (cmsg != NULL) {
#ifdef MEDMEM
strcpy(buf,"if continued: ");
STRCAT(buf, cmsg);
strcat(buf, "\n");
#else
sprintf(buf,"if continued: %s\n",cmsg);
#endif
errputstr(buf);
}
}

#ifdef NEED_TO_REPLACE_BREAKLOOP
/* $putpatch.c$: "MODULE_XLDBUG_C_BREAKLOOP_REPLACEMENT" */
#else

/* breakloop - the debug read-eval-print loop */
LOCAL VOID NEAR breakloop(hdr,cmsg,emsg,arg,cflag)
char *hdr, FAR *cmsg, FAR *emsg; LVAL arg; int cflag;
{
LVAL expr,val;
CONTEXT cntxt;
int type;

/* print the error message */
xlerrprint(hdr,cmsg,emsg,arg);

/* flush the input buffer */
xlflush();

/* do the back trace */
if (!null(getvalue(s_tracenable))) {
val = getvalue(s_tlimit);
xlbaktrace(fixp(val) ? (int)getfixnum(val) : -1);
}

/* protect some pointers */
xlsave1(expr);

/* increment the debug level */
++xldebug;

/* debug command processing loop */
xlbegin(&cntxt,CF_BRKLEVEL|CF_CLEANUP|CF_CONTINUE,true);
for (type = 0; type == 0; ) {

/* setup the continue trap */
if ((type = setjmp(cntxt.c_jmpbuf)) != 0)
switch (type) {
case CF_CLEANUP:
continue;
case CF_BRKLEVEL:
type = 0;
break;
case CF_CONTINUE:
if (cflag) {
dbgputstr("[ continue from break loop ]\n");
continue;
}
else xlabort("this error can't be continued");
}

/* print a prompt */
sprintf(buf,"%d> ",xldebug);
dbgputstr(buf);

/* read an expression and check for eof */
if (!xlread(getvalue(s_debugio),&expr)) {
type = CF_CLEANUP;
break;
}

/* save the input expression */
xlrdsave(expr);

/* evaluate the expression */
expr = xleval(expr);

/* save the result */
xlevsave(expr);

/* Show result on a new line -- TAA MOD to improve display */
xlfreshline(getvalue(s_debugio));

/* print it */
dbgprint(expr);
}
xlend(&cntxt);

/* decrement the debug level */
--xldebug;

/* restore the stack */
xlpop();

/* check for aborting to the previous level */
if (type == CF_CLEANUP)
xlbrklevel();
}
#endif

/* baktrace - do a back trace */
VOID xlbaktrace(n)
int n;
{
FRAMEP fp, p;
int argc;
for (fp = xlfp; (n < 0 || n--) && !null(*fp); fp = fp - (int)getfixnum(*fp)) {
p = fp + 1;
errputstr("Function: ");
errprint(*p++);
if ((argc = (int)getfixnum(*p++)) != 0)
errputstr("Arguments:\n");
while (--argc >= 0) {
errputstr(" ");
errprint(*p++);
}
}
}

/* xldinit - debug initialization routine */
VOID xldinit()
{
xlsample = 0;
xldebug = 0;
}



  3 Responses to “Category : Miscellaneous Language Source Code
Archive   : XLISP21D.ZIP
Filename : XLDBUG.C

  1. Very nice! Thank you for this wonderful archive. I wonder why I found it only now. Long live the BBS file archives!

  2. This is so awesome! 😀 I’d be cool if you could download an entire archive of this at once, though.

  3. But one thing that puzzles me is the “mtswslnkmcjklsdlsbdmMICROSOFT” string. There is an article about it here. It is definitely worth a read: http://www.os2museum.com/wp/mtswslnk/