/* xljump - execution context routines */
/*		Copyright (c) 1985, by David Michael Betz
		All Rights Reserved
		Permission is granted for unrestricted non-commercial use		*/

#include "xlisp.h"

/* external variables */
extern CONTEXT *xlcontext,*xltarget;
extern LVAL xlvalue,xlenv,xlfenv,xldenv;
extern int xlmask;

/* forward declarations */
#ifdef ANSI
void findandjump(int mask, char *error);
#else
FORWARD VOID findandjump();
#endif

/* xlbegin - beginning of an execution context */
VOID xlbegin(cptr,flags,expr)
  CONTEXT *cptr; int flags; LVAL expr;
{
	cptr->c_flags = flags;
	cptr->c_expr = expr;
	cptr->c_xlstack = xlstack;
	cptr->c_xlenv = xlenv;
	cptr->c_xlfenv = xlfenv;
	cptr->c_xldenv = xldenv;
	cptr->c_xlcontext = xlcontext;
	cptr->c_xlargv = xlargv;
	cptr->c_xlargc = xlargc;
	cptr->c_xlfp = xlfp;
	cptr->c_xlsp = xlsp;
	xlcontext = cptr;
}

/* xlend - end of an execution context */
VOID xlend(cptr)
  CONTEXT *cptr;
{
	xlcontext = cptr->c_xlcontext;
}

/* xlgo - go to a label */
VOID xlgo(label)
  LVAL label;
{
	CONTEXT *cptr;
	LVAL *argv;
	int argc;

	/* find a tagbody context */
	for (cptr = xlcontext; cptr; cptr = cptr->c_xlcontext)
		if (cptr->c_flags & CF_GO) {
			argc = cptr->c_xlargc;
			argv = cptr->c_xlargv;
			while (--argc >= 0)
				if (*argv++ == label) {
					cptr->c_xlargc = argc;
					cptr->c_xlargv = argv;
					xljump(cptr,CF_GO,NIL);
				}
		}
	xlfail("no target for GO");
}

/* xlreturn - return from a block */
VOID xlreturn(name,val)
  LVAL name,val;
{
	CONTEXT *cptr;

	/* find a block context */
	for (cptr = xlcontext; cptr; cptr = cptr->c_xlcontext)
		if (cptr->c_flags & CF_RETURN && cptr->c_expr == name)
			xljump(cptr,CF_RETURN,val);
	xlfail("no target for RETURN");
}

/* xlthrow - throw to a catch */
VOID xlthrow(tag,val)
  LVAL tag,val;
{
	CONTEXT *cptr;

	/* find a catch context */
	for (cptr = xlcontext; cptr; cptr = cptr->c_xlcontext)
		if ((cptr->c_flags & CF_THROW) && cptr->c_expr == tag)
			xljump(cptr,CF_THROW,val);
	xlfail("no target for THROW");
}

/* xlsignal - signal an error */
VOID xlsignal(emsg,arg)
  char *emsg; LVAL arg;
{
	CONTEXT *cptr;

	/* find an error catcher */
	for (cptr = xlcontext; cptr; cptr = cptr->c_xlcontext)
		if (cptr->c_flags & CF_ERROR) {
			if (cptr->c_expr && emsg)
				xlerrprint("error",NULL,emsg,arg);
			xljump(cptr,CF_ERROR,NIL);
		}
}

/* xltoplevel - go back to the top level */
VOID xltoplevel()
{
	stdputstr("[ back to top level ]\n");
	findandjump(CF_TOPLEVEL,"no top level");
}

/* xlbrklevel - go back to the previous break level */
VOID xlbrklevel()
{
	findandjump(CF_BRKLEVEL,"no previous break level");
}

/* xlcleanup - clean-up after an error */
VOID xlcleanup()
{
	stdputstr("[ back to previous break level ]\n");
	findandjump(CF_CLEANUP,"not in a break loop");
}

/* xlcontinue - continue from an error */
VOID xlcontinue()
{
	findandjump(CF_CONTINUE,"not in a break loop");
}

#ifdef MSC6
/* no optimization which interferes with setjmp */
#pragma optimize("elg",off)
#endif

/* xljump - jump to a saved execution context */
VOID xljump(target,mask,val)
  CONTEXT *target; int mask; LVAL val;
{
	/* unwind the execution stack */
	for (; xlcontext != target; xlcontext = xlcontext->c_xlcontext)

		/* check for an UNWIND-PROTECT */
		if ((xlcontext->c_flags & CF_UNWIND)) {
			xltarget = target;
			xlmask = mask;
			break;
		}
		   
	/* restore the state */
	xlstack = xlcontext->c_xlstack;
	xlenv = xlcontext->c_xlenv;
	xlfenv = xlcontext->c_xlfenv;
	xlunbind(xlcontext->c_xldenv);
	xlargv = xlcontext->c_xlargv;
	xlargc = xlcontext->c_xlargc;
	xlfp = xlcontext->c_xlfp;
	xlsp = xlcontext->c_xlsp;
	xlvalue = val;

	/* call the handler */
	longjmp(xlcontext->c_jmpbuf,mask);
}

#ifdef MSC6
#pragma optimize("",on)
#endif

/* findandjump - find a target context frame and jump to it */
LOCAL VOID findandjump(mask,error)
  int mask; char *error;
{
	CONTEXT *cptr;

	/* find a block context */
	for (cptr = xlcontext; cptr; cptr = cptr->c_xlcontext)
		if (cptr->c_flags & mask)
			xljump(cptr,mask,NIL);
	xlabort(error);
}