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);
}