home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 3: Developer Tools / Linux Cubed Series 3 - Developer Tools.iso / devel / lang / lisp / gcl-1.000 / gcl-1 / gcl-1.0 / c / catch.c < prev    next >
Encoding:
C/C++ Source or Header  |  1994-05-07  |  3.1 KB  |  160 lines
  1. /*
  2.  Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa
  3.  
  4. This file is part of GNU Common Lisp, herein referred to as GCL
  5.  
  6. GCL is free software; you can redistribute it and/or modify it under
  7. the terms of the GNU LIBRARY GENERAL PUBLIC LICENSE as published by
  8. the Free Software Foundation; either version 2, or (at your option)
  9. any later version.
  10.  
  11. GCL is distributed in the hope that it will be useful, but WITHOUT
  12. ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
  13. FITNESS FOR A PARTICULAR PURPOSE.  See the GNU Library General Public 
  14. License for more details.
  15.  
  16. You should have received a copy of the GNU Library General Public License 
  17. along with GCL; see the file COPYING.  If not, write to the Free Software
  18. Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
  19.  
  20. */
  21.  
  22. /*
  23.  
  24.     catch.c
  25.  
  26.     dynamic non-local exit
  27. */
  28.  
  29. #include "include.h"
  30.  
  31. Fcatch(args)
  32. object args;
  33. {
  34.     object *top = vs_top;
  35.     object tag;
  36.  
  37.     if (endp(args))
  38.         FEtoo_few_argumentsF(args);
  39.     eval(MMcar(args));
  40.     vs_top = top;
  41.     vs_push(vs_base[0]);
  42.     frs_push(FRS_CATCH, vs_base[0]);
  43.     if (nlj_active)
  44.         nlj_active = FALSE;
  45.     else
  46.         Fprogn(MMcdr(args));
  47.     frs_pop();
  48. }
  49.  
  50. siLerror_set()
  51. {
  52.     object *old_base = vs_base;
  53.     object *value_top;
  54.     object *old_lex = lex_env;
  55.  
  56.     check_arg(1);
  57.     vs_push(Cnil);
  58.     frs_push(FRS_CATCHALL, Cnil);
  59.     if (nlj_active) {
  60.         nlj_active = FALSE;
  61.         old_base[0] = nlj_tag;
  62.         frs_pop();
  63.         vs_base = old_base;
  64.         vs_top = vs_base+1;
  65.         lex_env = old_lex;
  66.         return;
  67.     } else {
  68.         lex_env = vs_top;
  69.         vs_push(Cnil);
  70.         vs_push(Cnil);
  71.         vs_push(Cnil);
  72.         eval(vs_base[0]);
  73.         old_base[0] = Cnil;
  74.     }
  75.     frs_pop();
  76.     lex_env = old_lex;
  77.     value_top = vs_top;
  78.     vs_top = old_base + 1;
  79.     while(vs_base<value_top) {
  80.         vs_push(vs_base[0]);
  81.         vs_base++;
  82.     }
  83.     vs_base = old_base;
  84. }
  85.  
  86. Funwind_protect(args)
  87. object args;
  88. {
  89.     object *top = vs_top;
  90.     object *value_top;
  91.     if (endp(args))
  92.         FEtoo_few_argumentsF(args);
  93.     frs_push(FRS_PROTECT, Cnil);
  94.     if (nlj_active) {
  95.         object tag = nlj_tag;
  96.         frame_ptr fr = nlj_fr;
  97.         object *base;
  98.  
  99.         value_top = vs_top;
  100.         vs_top = top;
  101.         while(vs_base<value_top) {
  102.              vs_push(vs_base[0]);
  103.             vs_base++;
  104.         }
  105.         value_top = vs_top;
  106.         nlj_active = FALSE;
  107.         frs_pop();
  108.         Fprogn(MMcdr(args));
  109.         vs_base = top;
  110.         vs_top = value_top;
  111.         if (vs_top == vs_base) vs_base[0] = Cnil;
  112.         unwind(fr, tag);
  113.         /* never reached */
  114.     } else {
  115.         eval(MMcar(args));
  116.         frs_pop();
  117.         value_top = vs_top;
  118.         vs_top = top;
  119.         while(vs_base<value_top) {
  120.              vs_push(vs_base[0]);
  121.             vs_base++;
  122.         }
  123.         value_top = vs_top;
  124.         Fprogn(MMcdr(args));
  125.         vs_base = top;
  126.         vs_top = value_top;
  127.         if (vs_top == vs_base) vs_base[0] = Cnil;
  128.     }
  129. }
  130.  
  131. Fthrow(args)
  132. object args;
  133. {
  134.     object *top = vs_top;
  135.     object tag;
  136.     frame_ptr fr;
  137.     if (endp(args) || endp(MMcdr(args)))
  138.         FEtoo_few_argumentsF(args);
  139.     if (!endp(MMcddr(args)))
  140.         FEtoo_many_argumentsF(args);
  141.     eval(MMcar(args));
  142.     vs_top = top;
  143.     tag = vs_base[0];
  144.     vs_push(tag);
  145.     fr = frs_sch_catch(tag);
  146.     if (fr == NULL)
  147.         FEerror("~S is an undefined tag.", 1, tag);
  148.     eval(MMcadr(args));
  149.     unwind(fr, tag);
  150.     /* never reached */
  151. }
  152.  
  153. init_catch()
  154. {
  155.     make_special_form("CATCH", Fcatch);
  156.     make_si_function("ERROR-SET", siLerror_set);
  157.     make_special_form("UNWIND-PROTECT", Funwind_protect);
  158.     make_special_form("THROW", Fthrow);
  159. }
  160.