BSD 4_4 development

[unix-history] / usr / src / old / lisp / franz / frame.c

#ifndef lint
static char *rcsid =
   "$Header: frame.c,v 1.3 87/12/14 16:51:52 sklower Exp $";
#endif

/*
 * 	frame.c				$Locker:  $
 * non local goto handlers
 *
 * (c) copyright 1982, Regents of the University of California
 */


#include "global.h"
#include "frame.h"

/* 
 * This is a collection of routines for manipulating evaluation frames.
 * Such frames are generated to mark the state of execution at a certain
 * spot.  They are created upon entry to prog, do, catch, errset and
 * other misc. functions (such as eval when in *rset mode).
 *
 * As described in h/frame.h, each frame is identified by a class, which
 * says who created the frame.  The global variable errp points to the
 * first (newest) frame on the stack.  
 * The standard way to create a frame is to say
 *
 *   errp = Pushframe(class,arg1,arg2);	 /* create and link in new 
 *   					    frame of give class * /
 *
 * poping the frame must be done explicity if the routine was not exited by
 * a non-local goto.  This is done by 
 *   errp = Popframe();
 *
 * When a frame is created, it marks the current state on the runtime stack.
 * Execution will continues after the Pushframe call with the value of the
 * global variable 'retval' set to 0.  Some time later control may be thrown
 * up the stack and it will seem that Pushframe returned again.  This time
 * retval will contain a non-zero value indicating what caused the non-local
 * jump.  retval will have one of the values from C_???? in h/frame.h . 
 * It will not have just of the C_???? values, it will only have a value
 * which makes sense. For example, coming out of a Pushframe(F_CATCH,tag,nil);
 * retval will either be 0 (initially) or C_THROW, [and in addition it will
 * already have been determined that the tag of the catch matches the tag
 * being thrown, [[ this does not apply to GO's and PROG tags]] ].
 *
 * In doing throws, goto's, returns, or errors up the stack we are always
 * conscious of the possiblity of unwind-protect sitting between where 
 * control starts and where it wants to get.  Thus it may be necessary
 * to save the state of the non-local jump, give control to the unwind-protect
 * and have it continue the non-local jump. 
 */

 /*
  * Inonlocalgo(class, arg1, arg2) :: do a general non-local goto.
  *    	class - one of the C_???? in h/frame.h
  *	arg1 - tag in C_THROW, C_GO; value in C_RETURN
  *	arg2 - value in C_THROW;
  *  this handles GO's, THROW's, RETURN's  but not errors, which have more
  * state to throw and a lot of different things to do if there is no one
  * to catch the error.
  * 
  * This routine never returns.
  */

Inonlocalgo(class, arg1, arg2)
lispval arg1,arg2;
{
    struct frame *uwpframe, *Inlthrow();
    lispval handy;

    /* 
     * scan for something to match 'class', return if nothing found, or
     * if we must first handle an unwind protect.
     */
    while( uwpframe = Inlthrow(class,arg1,arg2) )
    {
	/* build error frame description to be use to continue this throw */
	protect(lispretval = handy = newdot());
    	handy->d.car = Veruwpt;
	handy = handy->d.cdr = newdot();
	handy->d.car = inewint(class);		/* remember type */
	handy = handy->d.cdr = newdot();
	handy->d.car = arg1;
	handy = handy->d.cdr = newdot();
	handy->d.car = arg2;
	retval = C_THROW;
	Iretfromfr(uwpframe);
	/* NOT REACHED */
    }

    /*
     * nothing to go to, signal the appropriate error
     */

    switch(class)
    {
    case C_GO: errorh1(Vermisc, "No prog to go to with this tag ",
			       nil,FALSE,0,arg1);
		/* NOT REACHED */

    case C_RET: errorh(Vermisc, "No prog to return from", nil, FALSE, 0);
		/* NOT REACHED */

    case C_THROW: errorh1(Vermisc, "No catch for this tag ", nil, FALSE , 0,
				  arg1);
		/* NOT REACHED */
    default: error("Internal  Inonlocalgoto error" ,FALSE);
		/* NOT REACHED */
    }
}

/*
 * Inlthrow(class,arg1,arg2) :: look up the stack for a form to handle
 * a value of 'class' being thrown.  If found, do the throw.  If an
 * unwind-protect must be done, then return a pointer to that frame
 * first.  If there is nothing to catch this throw, we return 0.
 */

struct frame *
Inlthrow(class, arg1, arg2)
lispval arg1, arg2;
{
    struct frame *uwpframe = (struct frame *)0;
    struct frame *curp;
    int pass = 1;

    restart:
	for(curp = errp; curp != (struct frame *) 0; curp = curp->olderrp)
	{
	    switch(curp->class)
	    {
	    case F_PROG: if(class == C_RET || class == C_GO)
			 {
			    if(pass == 2) return(uwpframe);
			    else 
			    {
				lispretval = arg1;
				retval = class;
				Iretfromfr(curp);
				/* NOT REACHED */
			    }
			  }
			  break;

	    case F_CATCH: if((pass == 1) && (curp->larg1 == Veruwpt))
			  {
				uwpframe = curp;
				pass = 2;
				goto restart;
			  }
			  else if(class == C_THROW 
					&& matchtags(arg1,curp->larg1))
			  {
			    if(pass == 2) return(uwpframe);
			    else 
			    {
				lispretval = arg2;	/* value thrown */
				retval = class;
				Iretfromfr(curp);
				/* NOT REACHED */
			    }
			   }
			   break;
	    
	    case F_RESET:  if(class == C_RESET)
			   {
				if(pass == 2) return(uwpframe);
				else
				{
				    retval = class;
				    Iretfromfr(curp);
				    /* NOT REACHED */
				}
			    }
			    break;

	    }
	}
	return((struct frame *)0);   /* nobody wants it */
}


#ifndef tahoe
Iretfromfr(fram)
register struct frame *fram;
{
    xpopnames(fram->svbnp);
    qretfromfr();	/* modified in sed script to point to real function */
    /* NOT REACHED */
}
#endif

/* matchtags :: return TRUE if there is any atom in common between the
 * two tags.  Either tag may be an atom or an list of atoms.
 */
matchtags(tag1,tag2)
lispval tag1, tag2;
{
    int repeat1 = FALSE;
    int repeat2 = FALSE;
    lispval temp1 = tag1;
    lispval temp2 = tag2;
    lispval t1,t2;

    if(TYPE(tag1) == ATOM) 
    {
	t1 = tag1;
    }
    else {
	t1 = tag1->d.car;
	repeat1 = TRUE;
    }

    if(TYPE(tag2) == ATOM)
    {
	t2 = tag2;
    }
    else {
	t2 = tag2->d.car;
	repeat2 = TRUE;
    }

loop:
    if(t1 == t2) return(TRUE);
    if(repeat2) 
    {
	if((temp2 = temp2->d.cdr) != nil)
	{
	    t2 = temp2->d.car;
	    goto loop;
	}
    }

    if(repeat1)
    {
        if((temp1 = temp1->d.cdr) != nil)
	{
	    t1 = temp1->d.car;
	    if(repeat2) 
	    {
	        temp2 = tag2;
		t2 = temp2->d.car;
		goto loop;
	    }
	    else t2 = tag2;
	    goto loop;
	 }
    }
    return(FALSE);
}

/*
 * framedump :: debugging routine to print the contents of the error 
 * frame
 *
 */
lispval
Lframedump()
{
    struct frame *curp;

    printf("Frame dump\n");
    for(curp = errp ; curp != (struct frame *)0 ; curp=curp->olderrp)
    {
	printf("at %x is ",curp);

	switch(curp->class) {
	case F_PROG: printf(" prog\n");
		     break;

	case F_CATCH:printf(" catching ");
		     printr(curp->larg1,stdout);
		     putchar('\n');
		     break;

	case F_RESET:printf(" reset \n");
		     break;

	case F_EVAL: printf(" eval: ");
		     printr(curp->larg1,stdout);
		     putchar('\n');
		     break;

	case F_FUNCALL: printf(" funcall: ");
		     printr(curp->larg1,stdout);
		     putchar('\n');
		     break;

	case F_TO_FORT: printf(" calling fortran:\n");
		     break;

	case F_TO_LISP: printf(" fortran calling lisp:\n");
		     break;

		
	default:
		     printf(" unknown: %d \n",curp->class);
	}
	fflush(stdout);
    }
    printf("End of stack\n");
    return(nil);
}