home *** CD-ROM | disk | FTP | other *** search
/ NeXT Education Software Sampler 1992 Fall / NeXT Education Software Sampler 1992 Fall.iso / Programming / Source / winterp-1.13 / src-server / xlisp / xljump.c < prev    next >
Encoding:
C/C++ Source or Header  |  1991-10-04  |  5.7 KB  |  209 lines
  1. /* -*-C-*-
  2. ********************************************************************************
  3. *
  4. * File:         xljump.c
  5. * RCS:          $Header: xljump.c,v 1.4 91/03/24 22:25:06 mayer Exp $
  6. * Description:  execution context routines
  7. * Author:       David Michael Betz
  8. * Created:      
  9. * Modified:     Fri Oct  4 04:05:25 1991 (Niels Mayer) mayer@hplnpm
  10. * Language:     C
  11. * Package:      N/A
  12. * Status:       X11r5 contrib tape release
  13. *
  14. * WINTERP Copyright 1989, 1990, 1991 Hewlett-Packard Company (by Niels Mayer).
  15. * XLISP version 2.1, Copyright (c) 1989, by David Betz.
  16. *
  17. * Permission to use, copy, modify, distribute, and sell this software and its
  18. * documentation for any purpose is hereby granted without fee, provided that
  19. * the above copyright notice appear in all copies and that both that
  20. * copyright notice and this permission notice appear in supporting
  21. * documentation, and that the name of Hewlett-Packard and David Betz not be
  22. * used in advertising or publicity pertaining to distribution of the software
  23. * without specific, written prior permission.  Hewlett-Packard and David Betz
  24. * make no representations about the suitability of this software for any
  25. * purpose. It is provided "as is" without express or implied warranty.
  26. *
  27. * HEWLETT-PACKARD AND DAVID BETZ DISCLAIM ALL WARRANTIES WITH REGARD TO THIS
  28. * SOFTWARE, INCLUDING ALL IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS,
  29. * IN NO EVENT SHALL HEWLETT-PACKARD NOR DAVID BETZ BE LIABLE FOR ANY SPECIAL,
  30. * INDIRECT OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM
  31. * LOSS OF USE, DATA OR PROFITS, WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE
  32. * OR OTHER TORTIOUS ACTION, ARISING OUT OF OR IN CONNECTION WITH THE USE OR
  33. * PERFORMANCE OF THIS SOFTWARE.
  34. *
  35. * See ./winterp/COPYRIGHT for information on contacting the authors.
  36. * 
  37. * Please send modifications, improvements and bugfixes to mayer@hplabs.hp.com
  38. * Post XLISP-specific questions/information to the newsgroup comp.lang.lisp.x
  39. *
  40. ********************************************************************************
  41. */
  42. static char rcs_identity[] = "@(#)$Header: xljump.c,v 1.4 91/03/24 22:25:06 mayer Exp $";
  43.  
  44.  
  45. #include "xlisp.h"
  46.  
  47. /* external variables */
  48. extern CONTEXT *xlcontext,*xltarget;
  49. extern LVAL xlvalue,xlenv,xlfenv,xldenv;
  50. extern int xlmask;
  51.  
  52. /* xlbegin - beginning of an execution context */
  53. xlbegin(cptr,flags,expr)
  54.   CONTEXT *cptr; int flags; LVAL expr;
  55. {
  56.     cptr->c_flags = flags;
  57.     cptr->c_expr = expr;
  58.     cptr->c_xlstack = xlstack;
  59.     cptr->c_xlenv = xlenv;
  60.     cptr->c_xlfenv = xlfenv;
  61.     cptr->c_xldenv = xldenv;
  62.     cptr->c_xlcontext = xlcontext;
  63.     cptr->c_xlargv = xlargv;
  64.     cptr->c_xlargc = xlargc;
  65.     cptr->c_xlfp = xlfp;
  66.     cptr->c_xlsp = xlsp;
  67.     xlcontext = cptr;
  68. }
  69.  
  70. /* xlend - end of an execution context */
  71. xlend(cptr)
  72.   CONTEXT *cptr;
  73. {
  74.     xlcontext = cptr->c_xlcontext;
  75. }
  76.  
  77. /* xlgo - go to a label */
  78. xlgo(label)
  79.   LVAL label;
  80. {
  81.     CONTEXT *cptr;
  82.     LVAL *argv;
  83.     int argc;
  84.  
  85.     /* find a tagbody context */
  86.     for (cptr = xlcontext; cptr; cptr = cptr->c_xlcontext)
  87.     if (cptr->c_flags & CF_GO) {
  88.         argc = cptr->c_xlargc;
  89.         argv = cptr->c_xlargv;
  90.         while (--argc >= 0)
  91.         if (*argv++ == label) {
  92.             cptr->c_xlargc = argc;
  93.             cptr->c_xlargv = argv;
  94.             xljump(cptr,CF_GO,NIL);
  95.         }
  96.     }
  97.     xlfail("no target for GO");
  98. }
  99.  
  100. /* xlreturn - return from a block */
  101. xlreturn(name,val)
  102.   LVAL name,val;
  103. {
  104.     CONTEXT *cptr;
  105.  
  106.     /* find a block context */
  107.     for (cptr = xlcontext; cptr; cptr = cptr->c_xlcontext)
  108.     if (cptr->c_flags & CF_RETURN && cptr->c_expr == name)
  109.         xljump(cptr,CF_RETURN,val);
  110.     xlfail("no target for RETURN");
  111. }
  112.  
  113. /* xlthrow - throw to a catch */
  114. xlthrow(tag,val)
  115.   LVAL tag,val;
  116. {
  117.     CONTEXT *cptr;
  118.  
  119.     /* find a catch context */
  120.     for (cptr = xlcontext; cptr; cptr = cptr->c_xlcontext)
  121.     if ((cptr->c_flags & CF_THROW) && cptr->c_expr == tag)
  122.         xljump(cptr,CF_THROW,val);
  123.     xlfail("no target for THROW");
  124. }
  125.  
  126. /* xlsignal - signal an error */
  127. xlsignal(emsg,arg)
  128.   char *emsg; LVAL arg;
  129. {
  130.     CONTEXT *cptr;
  131.  
  132.     /* find an error catcher */
  133.     for (cptr = xlcontext; cptr; cptr = cptr->c_xlcontext)
  134.     if (cptr->c_flags & CF_ERROR) {
  135.         if (cptr->c_expr && emsg)
  136.         xlerrprint("error",NULL,emsg,arg);
  137.         xljump(cptr,CF_ERROR,NIL);
  138.     }
  139. }
  140.  
  141. /* xltoplevel - go back to the top level */
  142. xltoplevel()
  143. {
  144.     stdputstr("[ back to top level ]\n");
  145.     findandjump(CF_TOPLEVEL,"no top level");
  146. }
  147.  
  148. /* xlbrklevel - go back to the previous break level */
  149. xlbrklevel()
  150. {
  151.     findandjump(CF_BRKLEVEL,"no previous break level");
  152. }
  153.  
  154. /* xlcleanup - clean-up after an error */
  155. xlcleanup()
  156. {
  157.     stdputstr("[ back to previous break level ]\n");
  158.     findandjump(CF_CLEANUP,"not in a break loop");
  159. }
  160.  
  161. /* xlcontinue - continue from an error */
  162. xlcontinue()
  163. {
  164.     findandjump(CF_CONTINUE,"not in a break loop");
  165. }
  166.  
  167. /* xljump - jump to a saved execution context */
  168. xljump(target,mask,val)
  169.   CONTEXT *target; int mask; LVAL val;
  170. {
  171.     /* unwind the execution stack */
  172.     for (; xlcontext != target; xlcontext = xlcontext->c_xlcontext)
  173.  
  174.     /* check for an UNWIND-PROTECT */
  175.     if ((xlcontext->c_flags & CF_UNWIND)) {
  176.         xltarget = target;
  177.         xlmask = mask;
  178.         break;
  179.     }
  180.        
  181.     /* restore the state */
  182.     xlstack = xlcontext->c_xlstack;
  183.     xlenv = xlcontext->c_xlenv;
  184.     xlfenv = xlcontext->c_xlfenv;
  185.     xlunbind(xlcontext->c_xldenv);
  186.     xlargv = xlcontext->c_xlargv;
  187.     xlargc = xlcontext->c_xlargc;
  188.     xlfp = xlcontext->c_xlfp;
  189.     xlsp = xlcontext->c_xlsp;
  190.     xlvalue = val;
  191.  
  192.     /* call the handler */
  193.     longjmp(xlcontext->c_jmpbuf,mask);
  194. }
  195.  
  196. /* findandjump - find a target context frame and jump to it */
  197. LOCAL findandjump(mask,error)
  198.   int mask; char *error;
  199. {
  200.     CONTEXT *cptr;
  201.  
  202.     /* find a block context */
  203.     for (cptr = xlcontext; cptr; cptr = cptr->c_xlcontext)
  204.     if (cptr->c_flags & mask)
  205.         xljump(cptr,mask,NIL);
  206.     xlabort(error);
  207. }
  208.  
  209.