home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 10 Tools / 10-Tools.zip / mitsch75.zip / scheme-7_5_17-src.zip / scheme-7.5.17 / src / microcode / error.c < prev    next >
C/C++ Source or Header  |  2000-12-05  |  8KB  |  306 lines
  1. /* -*-C-*-
  2.  
  3. $Id: error.c,v 1.7 2000/12/05 21:23:44 cph Exp $
  4.  
  5. Copyright (C) 1990-2000 Massachusetts Institute of Technology
  6.  
  7. This program is free software; you can redistribute it and/or modify
  8. it under the terms of the GNU General Public License as published by
  9. the Free Software Foundation; either version 2 of the License, or (at
  10. your option) any later version.
  11.  
  12. This program is distributed in the hope that it will be useful, but
  13. WITHOUT ANY WARRANTY; without even the implied warranty of
  14. MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  15. General Public License for more details.
  16.  
  17. You should have received a copy of the GNU General Public License
  18. along with this program; if not, write to the Free Software
  19. Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
  20. */
  21.  
  22. #include <stdio.h>
  23. #include "outf.h"
  24. #include "dstack.h"
  25.  
  26. static PTR
  27. DEFUN (xmalloc, (length), unsigned int length)
  28. {
  29.   extern PTR EXFUN (malloc, (unsigned int length));
  30.   PTR result = (malloc (length));
  31.   if (result == 0)
  32.     {
  33.       outf_fatal ("malloc: memory allocation failed\n");
  34.       outf_flush_fatal ();
  35.       abort ();
  36.     }
  37.   return (result);
  38. }
  39.  
  40. struct handler_record
  41. {
  42.   struct handler_record * next;
  43.   Tcondition_type type;
  44.   void EXFUN ((*handler), (Tcondition));
  45. };
  46.  
  47. struct restart_record
  48. {
  49.   struct restart_record * next;
  50.   struct condition_restart contents;
  51. };
  52.  
  53. static unsigned long next_condition_type_index;
  54. static struct handler_record * current_handler_record;
  55. static struct restart_record * current_restart_record;
  56.  
  57. void
  58. DEFUN_VOID (initialize_condition_system)
  59. {
  60.   next_condition_type_index = 0;
  61.   current_handler_record = 0;
  62.   current_restart_record = 0;
  63. }
  64.  
  65. Tcondition_type
  66. DEFUN (condition_type_allocate, (name, generalizations, reporter),
  67.        PTR name AND
  68.        Tptrvec generalizations AND
  69.        void EXFUN ((*reporter), (Tcondition condition)))
  70. {
  71.   Tptrvec EXFUN (generalizations_union, (Tptrvec generalizations));
  72.   Tcondition_type type = (xmalloc (sizeof (struct condition_type)));
  73.   Tptrvec g = (generalizations_union (generalizations));
  74.   ptrvec_adjoin (g, type);
  75.   (CONDITION_TYPE_INDEX (type)) = (next_condition_type_index++);
  76.   (CONDITION_TYPE_NAME (type)) = name;
  77.   (CONDITION_TYPE_GENERALIZATIONS (type)) = g;
  78.   (CONDITION_TYPE_REPORTER (type)) = reporter;
  79.   return (type);
  80. }
  81.  
  82. void
  83. DEFUN (condition_type_deallocate, (type), Tcondition_type type)
  84. {
  85.   ptrvec_deallocate (CONDITION_TYPE_GENERALIZATIONS (type));
  86.   free (type);
  87. }
  88.  
  89. Tcondition
  90. DEFUN (condition_allocate, (type, irritants),
  91.        Tcondition_type type AND
  92.        Tptrvec irritants)
  93. {
  94.   Tcondition condition = (xmalloc (sizeof (struct condition)));
  95.   (CONDITION_TYPE (condition)) = type;
  96.   (CONDITION_IRRITANTS (condition)) = irritants;
  97.   return (condition);
  98. }
  99.  
  100. void
  101. DEFUN (condition_deallocate, (condition), Tcondition condition)
  102. {
  103.   ptrvec_deallocate (CONDITION_IRRITANTS (condition));
  104.   free (condition);
  105. }
  106.  
  107. static Tptrvec
  108. DEFUN (generalizations_union_2, (x, y), Tptrvec x AND Tptrvec y)
  109. {
  110.   PTR * scan_x = (PTRVEC_START (x));
  111.   PTR * end_x = (scan_x + (PTRVEC_LENGTH (x)));
  112.   PTR * scan_y = (PTRVEC_START (y));
  113.   PTR * end_y = (scan_y + (PTRVEC_LENGTH (y)));
  114.   Tptrvec_length length = 0;
  115.   unsigned long ix;
  116.   unsigned long iy;
  117.   Tptrvec result;
  118.   PTR * scan_result;
  119.   while (1)
  120.     {
  121.       if (scan_x == end_x)
  122.     {
  123.       length += (end_y - scan_y);
  124.       break;
  125.     }
  126.       if (scan_y == end_y)
  127.     {
  128.       length += (end_x - scan_x);
  129.       break;
  130.     }
  131.       length += 1;
  132.       ix = (CONDITION_TYPE_INDEX ((Tcondition_type) (*scan_x)));
  133.       iy = (CONDITION_TYPE_INDEX ((Tcondition_type) (*scan_y)));
  134.       if (ix <= iy) scan_x += 1;
  135.       if (iy <= ix) scan_y += 1;
  136.     }
  137.   result = (ptrvec_allocate (length));
  138.   scan_result = (PTRVEC_START (result));
  139.   while (1)
  140.     {
  141.       if (scan_x == end_x)
  142.     {
  143.       while (scan_y < end_y) (*scan_result++) = (*scan_y++);
  144.       break;
  145.     }
  146.       if (scan_y == end_y)
  147.     {
  148.       while (scan_x < end_x) (*scan_result++) = (*scan_x++);
  149.       break;
  150.     }
  151.       ix = (CONDITION_TYPE_INDEX ((Tcondition_type) (*scan_x)));
  152.       iy = (CONDITION_TYPE_INDEX ((Tcondition_type) (*scan_y)));
  153.       if (ix == iy)
  154.     {
  155.       (*scan_result++) = (*scan_x++);
  156.       scan_y += 1;
  157.     }
  158.       else
  159.     (*scan_result++) = ((ix < iy) ? (*scan_x++) : (*scan_y++));
  160.     }
  161.   return (result);
  162. }
  163.  
  164. Tptrvec
  165. DEFUN (generalizations_union, (generalizations), Tptrvec generalizations)
  166. {
  167.   Tptrvec_length length = (PTRVEC_LENGTH (generalizations));
  168.   if (length == 0)
  169.     return (ptrvec_allocate (0));
  170.   if (length == 1)
  171.     return (ptrvec_copy (PTRVEC_REF (generalizations, 0)));
  172.   {
  173.     PTR * scan = (PTRVEC_START (generalizations));
  174.     PTR * end = (scan + length);
  175.     Tptrvec result = ((Tptrvec) (*scan++));
  176.     result = (generalizations_union_2 (result, ((Tptrvec) (*scan++))));
  177.     while (scan < end)
  178.       {
  179.     Tptrvec v = (generalizations_union_2 (result, ((Tptrvec) (*scan++))));
  180.     ptrvec_deallocate (result);
  181.     result = v;
  182.       }
  183.     return (result);
  184.   }
  185. }
  186.  
  187. void
  188. DEFUN (condition_handler_bind, (type, handler),
  189.        Tcondition_type type AND
  190.        void EXFUN ((*handler), (Tcondition condition)))
  191. {
  192.   struct handler_record * record =
  193.     (dstack_alloc (sizeof (struct handler_record)));
  194.   (record -> next) = current_handler_record;
  195.   (record -> type) = type;
  196.   (record -> handler) = handler;
  197.   dstack_bind ((¤t_handler_record), record);
  198. }
  199.  
  200. #define GENERALIZATIONS(condition)                    \
  201.   (CONDITION_TYPE_GENERALIZATIONS (CONDITION_TYPE (condition)))
  202.  
  203. void
  204. DEFUN (condition_signal, (condition), Tcondition condition)
  205. {
  206.   Tptrvec generalizations = (GENERALIZATIONS (condition));
  207.   struct handler_record * record = current_handler_record;
  208.   while (record != 0)
  209.     {
  210.       Tcondition_type type = (record -> type);
  211.       if ((type == 0) || (ptrvec_memq (generalizations, type)))
  212.     {
  213.       PTR position = dstack_position;
  214.       dstack_bind ((¤t_handler_record), (record -> next));
  215.       (* (record -> handler)) (condition);
  216.       dstack_set_position (position);
  217.     }
  218.       record = (record -> next);
  219.     }
  220. }
  221.  
  222. void
  223. DEFUN (condition_restart_bind, (name, type, procedure),
  224.        PTR name AND
  225.        Tcondition_type type AND
  226.        void EXFUN ((*procedure), (PTR argument)))
  227. {
  228.   struct restart_record * record =
  229.     (dstack_alloc (sizeof (struct restart_record)));
  230.   (record -> next) = current_restart_record;
  231.   (record -> contents . name) = name;
  232.   (record -> contents . type) = type;
  233.   (record -> contents . procedure) = procedure;
  234.   dstack_bind ((¤t_restart_record), record);
  235. }
  236.  
  237. Tcondition_restart
  238. DEFUN (condition_restart_find, (name, condition),
  239.        PTR name AND
  240.        Tcondition condition)
  241. {
  242.   struct restart_record * record = current_restart_record;
  243.   if (condition == 0)
  244.     while (record != 0)
  245.       {
  246.     if ((record -> contents . name) == name)
  247.       return (& (record -> contents));
  248.     record = (record -> next);
  249.       }
  250.   else
  251.     {
  252.       Tptrvec generalizations = (GENERALIZATIONS (condition));
  253.       while (record != 0)
  254.     {
  255.       if (((record -> contents . name) == name) &&
  256.           (ptrvec_memq (generalizations, (record -> contents . type))))
  257.         return (& (record -> contents));
  258.       record = (record -> next);
  259.     }
  260.     }
  261.   return (0);
  262. }
  263.  
  264. Tptrvec
  265. DEFUN (condition_restarts, (condition), Tcondition condition)
  266. {
  267.   struct restart_record * record = current_restart_record;
  268.   Tptrvec_length length = 0;
  269.   Tptrvec generalizations = 0;
  270.   Tptrvec result;
  271.   PTR * scan_result;
  272.   if (condition == 0)
  273.     while (record != 0)
  274.       {
  275.     length += 1;
  276.     record = (record -> next);
  277.       }
  278.   else
  279.     {
  280.       generalizations = (GENERALIZATIONS (condition));
  281.       while (record != 0)
  282.     {
  283.       if (ptrvec_memq (generalizations, (record -> contents . type)))
  284.         length += 1;
  285.       record = (record -> next);
  286.     }
  287.     }
  288.   result = (ptrvec_allocate (length));
  289.   scan_result = (PTRVEC_START (result));
  290.   record = current_restart_record;
  291.   if (condition == 0)
  292.     while (record != 0)
  293.       {
  294.     (*scan_result++) = (& (record -> contents));
  295.     record = (record -> next);
  296.       }
  297.   else
  298.     while (record != 0)
  299.       {
  300.     if (ptrvec_memq (generalizations, (record -> contents . type)))
  301.       (*scan_result++) = (& (record -> contents));
  302.     record = (record -> next);
  303.       }
  304.   return (result);
  305. }
  306.