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