home *** CD-ROM | disk | FTP | other *** search
/ Fish 'n' More 2 / fishmore-publicdomainlibraryvol.ii1991xetec.iso / fish / applications / xlispstat / xlisp / xljump.c < prev    next >
C/C++ Source or Header  |  1990-10-03  |  4KB  |  179 lines
  1. /* xljump - execution context routines */
  2. /* Copyright (c) 1989, by David Michael Betz.                            */
  3. /* You may give out copies of this software; for conditions see the file */
  4. /* COPYING included with this distribution.                              */
  5.  
  6. #include "xlisp.h"
  7. #include "osdef.h"
  8. #ifdef ANSI
  9. #include "xlproto.h"
  10. #else
  11. #include "xlfun.h"
  12. #endif ANSI
  13. #include "xlvar.h"
  14.  
  15. /* forward declarations */
  16. #ifdef ANSI
  17. void findandjump(int,char *);
  18. #else
  19. void findandjump();
  20. #endif ANSI
  21.  
  22. /* xlbegin - beginning of an execution context */
  23. void xlbegin(cptr,flags,expr)
  24.   CONTEXT *cptr; int flags; LVAL expr;
  25. {
  26.     cptr->c_flags = flags;
  27.     cptr->c_expr = expr;
  28.     cptr->c_xlstack = xlstack;
  29.     cptr->c_xlenv = xlenv;
  30.     cptr->c_xlfenv = xlfenv;
  31.     cptr->c_xldenv = xldenv;
  32.     cptr->c_xlcontext = xlcontext;
  33.     cptr->c_xlargv = xlargv;
  34.     cptr->c_xlargc = xlargc;
  35.     cptr->c_xlfp = xlfp;
  36.     cptr->c_xlsp = xlsp;
  37.     xlcontext = cptr;
  38. }
  39.  
  40. /* xlend - end of an execution context */
  41. void xlend(cptr)
  42.   CONTEXT *cptr;
  43. {
  44.     xlcontext = cptr->c_xlcontext;
  45. }
  46.  
  47. /* xlgo - go to a label */
  48. void xlgo(label)
  49.   LVAL label;
  50. {
  51.     CONTEXT *cptr;
  52.     LVAL *argv;
  53.     int argc;
  54.  
  55.     /* find a tagbody context */
  56.     for (cptr = xlcontext; cptr; cptr = cptr->c_xlcontext)
  57.     if (cptr->c_flags & CF_GO) {
  58.         argc = cptr->c_xlargc;
  59.         argv = cptr->c_xlargv;
  60.         while (--argc >= 0)
  61.         if (*argv++ == label) {
  62.             cptr->c_xlargc = argc;
  63.             cptr->c_xlargv = argv;
  64.             xljump(cptr,CF_GO,NIL);
  65.         }
  66.     }
  67.     xlfail("no target for GO");
  68. }
  69.  
  70. /* xlreturn - return from a block */
  71. void xlreturn(name,val)
  72.   LVAL name,val;
  73. {
  74.     CONTEXT *cptr;
  75.  
  76.     /* find a block context */
  77.     for (cptr = xlcontext; cptr; cptr = cptr->c_xlcontext)
  78.     if (cptr->c_flags & CF_RETURN && cptr->c_expr == name)
  79.         xljump(cptr,CF_RETURN,val);
  80.     xlfail("no target for RETURN");
  81. }
  82.  
  83. /* xlthrow - throw to a catch */
  84. void xlthrow(tag,val)
  85.   LVAL tag,val;
  86. {
  87.     CONTEXT *cptr;
  88.  
  89.     /* find a catch context */
  90.     for (cptr = xlcontext; cptr; cptr = cptr->c_xlcontext)
  91.     if ((cptr->c_flags & CF_THROW) && cptr->c_expr == tag)
  92.         xljump(cptr,CF_THROW,val);
  93.     xlfail("no target for THROW");
  94. }
  95.  
  96. /* xlsignal - signal an error */
  97. void xlsignal(emsg,arg)
  98.   char *emsg; LVAL arg;
  99. {
  100.     CONTEXT *cptr;
  101.  
  102.     /* find an error catcher */
  103.     for (cptr = xlcontext; cptr; cptr = cptr->c_xlcontext)
  104.     if (cptr->c_flags & CF_ERROR) {
  105.         if (cptr->c_expr && emsg)
  106.         xlerrprint("error",NULL,emsg,arg);
  107.         xljump(cptr,CF_ERROR,NIL);
  108.     }
  109. }
  110.  
  111. /* xltoplevel - go back to the top level */
  112. void xltoplevel()
  113. {
  114.     stdputstr("[ back to top level ]\n");
  115.     findandjump(CF_TOPLEVEL,"no top level");
  116. }
  117.  
  118. /* xlbrklevel - go back to the previous break level */
  119. void xlbrklevel()
  120. {
  121.     findandjump(CF_BRKLEVEL,"no previous break level");
  122. }
  123.  
  124. /* xlcleanup - clean-up after an error */
  125. void xlcleanup()
  126. {
  127.     stdputstr("[ back to previous break level ]\n");
  128.     findandjump(CF_CLEANUP,"not in a break loop");
  129. }
  130.  
  131. /* xlcontinue - continue from an error */
  132. void xlcontinue()
  133. {
  134.     findandjump(CF_CONTINUE,"not in a break loop");
  135. }
  136.  
  137. /* xljump - jump to a saved execution context */
  138. void xljump(target,mask,val)
  139.   CONTEXT *target; int mask; LVAL val;
  140. {
  141.     /* unwind the execution stack */
  142.     for (; xlcontext != target; xlcontext = xlcontext->c_xlcontext)
  143.  
  144.     /* check for an UNWIND-PROTECT */
  145.     if ((xlcontext->c_flags & CF_UNWIND)) {
  146.         xltarget = target;
  147.         xlmask = mask;
  148.         break;
  149.     }
  150.        
  151.     /* restore the state */
  152.     xlstack = xlcontext->c_xlstack;
  153.     xlenv = xlcontext->c_xlenv;
  154.     xlfenv = xlcontext->c_xlfenv;
  155.     xlunbind(xlcontext->c_xldenv);
  156.     xlargv = xlcontext->c_xlargv;
  157.     xlargc = xlcontext->c_xlargc;
  158.     xlfp = xlcontext->c_xlfp;
  159.     xlsp = xlcontext->c_xlsp;
  160.     xlvalue = val;
  161.  
  162.     /* call the handler */
  163.     longjmp(xlcontext->c_jmpbuf,mask);
  164. }
  165.  
  166. /* findandjump - find a target context frame and jump to it */
  167. LOCAL void findandjump(mask,error)
  168.   int mask; char *error;
  169. {
  170.     CONTEXT *cptr;
  171.  
  172.     /* find a block context */
  173.     for (cptr = xlcontext; cptr; cptr = cptr->c_xlcontext)
  174.     if (cptr->c_flags & mask)
  175.         xljump(cptr,mask,NIL);
  176.     xlabort(error);
  177. }
  178.  
  179.