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 / wind.c < prev    next >
C/C++ Source or Header  |  1999-01-03  |  6KB  |  201 lines
  1. /* -*-C-*-
  2.  
  3. $Id: wind.c,v 1.6 1999/01/03 05:33:51 cph Exp $
  4.  
  5. Copyright (C) 1990-1999 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 "obstack.h"
  24. #include "dstack.h"
  25. #include "outf.h"
  26. extern void EXFUN (free, (PTR ptr));
  27. #define obstack_chunk_alloc xmalloc
  28. #define obstack_chunk_free free
  29.  
  30. extern void EXFUN (block_signals, (void));
  31. extern void EXFUN (unblock_signals, (void));
  32.  
  33. static void
  34. DEFUN (error, (procedure_name, message),
  35.        CONST char * procedure_name AND
  36.        CONST char * message)
  37. {
  38.   outf_fatal ("%s: %s\n", procedure_name, message);
  39.   outf_flush_fatal ();
  40.   abort ();
  41. }
  42.  
  43. static PTR
  44. DEFUN (xmalloc, (length), unsigned int length)
  45. {
  46.   extern PTR EXFUN (malloc, (unsigned int length));
  47.   PTR result = (malloc (length));
  48.   if (result == 0)
  49.     error ("malloc", "memory allocation failed");
  50.   return (result);
  51. }
  52.  
  53. struct winding_record
  54. {
  55.   struct winding_record * next;
  56.   void EXFUN ((*protector), (PTR environment));
  57.   PTR environment;
  58. };
  59.  
  60. static struct obstack dstack;
  61. static struct winding_record * current_winding_record;
  62. PTR dstack_position;
  63.  
  64. void
  65. DEFUN_VOID (dstack_initialize)
  66. {
  67.   obstack_init (&dstack);
  68.   dstack_position = 0;
  69.   current_winding_record = 0;
  70. }
  71.  
  72. void
  73. DEFUN_VOID (dstack_reset)
  74. {
  75.   block_signals ();
  76.   obstack_free ((&dstack), 0);
  77.   dstack_initialize ();
  78.   unblock_signals ();
  79. }
  80.  
  81. #define EXPORT(sp) ((PTR) (((char *) (sp)) + (sizeof (PTR))))
  82.  
  83. PTR
  84. DEFUN (dstack_alloc, (length), unsigned int length)
  85. {
  86.   PTR chunk;
  87.   block_signals ();
  88.   chunk = (obstack_alloc ((&dstack), ((sizeof (PTR)) + length)));
  89.   (* ((PTR *) chunk)) = dstack_position;
  90.   dstack_position = chunk;
  91.   unblock_signals ();
  92.   return (EXPORT (chunk));
  93. }
  94.  
  95. void
  96. DEFUN (dstack_protect, (protector, environment),
  97.        void EXFUN ((*protector), (PTR environment)) AND
  98.        PTR environment)
  99. {
  100.   struct winding_record * record =
  101.     (dstack_alloc (sizeof (struct winding_record)));
  102.   (record -> next) = current_winding_record;
  103.   (record -> protector) = protector;
  104.   (record -> environment) = environment;
  105.   current_winding_record = record;
  106. }
  107.  
  108. void
  109. DEFUN (dstack_alloc_and_protect, (length, initializer, protector),
  110.        unsigned int length AND
  111.        void EXFUN ((*initializer), (PTR environment)) AND
  112.        void EXFUN ((*protector), (PTR environment)))
  113. {
  114.   struct winding_record * record =
  115.     (dstack_alloc ((sizeof (struct winding_record)) + length));
  116.   PTR environment = (((char *) record) + (sizeof (struct winding_record)));
  117.   (*initializer) (environment);
  118.   (record -> next) = current_winding_record;
  119.   (record -> protector) = protector;
  120.   (record -> environment) = environment;
  121.   current_winding_record = record;
  122. }
  123.  
  124. void
  125. DEFUN (dstack_set_position, (position), PTR position)
  126. {
  127.   block_signals ();
  128. #define DEBUG_DSTACK
  129. #ifdef DEBUG_DSTACK
  130.   {
  131.     PTR * sp = dstack_position;
  132.     while (sp != position)
  133.       {
  134.     if (sp == 0)
  135.       error ("dstack_set_position", "position argument not found");
  136.     sp = (*sp);
  137.       }
  138.   }
  139. #endif /* DEBUG_DSTACK */
  140.   while (dstack_position != position)
  141.     {
  142.       if (dstack_position == 0)
  143.     error ("dstack_set_position", "no more stack");
  144.       if ((EXPORT (dstack_position)) == current_winding_record)
  145.     {
  146.       PTR sp = dstack_position;
  147.       struct winding_record * record = current_winding_record;
  148.       /* Must unblock signals while the protector runs, and
  149.          re-block afterwards, in case the protector does something
  150.          to change the signal mask.  Otherwise, the change to the
  151.          signal mask will be undone when the final call to
  152.          unblock_signals is performed.  */
  153.       unblock_signals ();
  154.       (* (record -> protector)) (record -> environment);
  155.       block_signals ();
  156.       if (sp != dstack_position)
  157.         error ("dstack_set_position", "stack slipped during unwind");
  158.       current_winding_record = (record -> next);
  159.     }
  160.       {
  161.     PTR * sp = dstack_position;
  162.     dstack_position = (*sp);
  163.     obstack_free ((&dstack), sp);
  164.       }
  165.     }
  166.   unblock_signals ();
  167. }
  168.  
  169. struct binding_record
  170. {
  171.   PTR * location;
  172.   PTR value;
  173. };
  174.  
  175. static void
  176. DEFUN (undo_binding, (environment), PTR environment)
  177. {
  178.   (* (((struct binding_record *) environment) -> location)) =
  179.     (((struct binding_record *) environment) -> value);
  180. }
  181.  
  182. static PTR * save_binding_location;
  183.  
  184. static void
  185. DEFUN (save_binding, (environment), PTR environment)
  186. {
  187.   (((struct binding_record *) environment) -> location) =
  188.     save_binding_location;
  189.   (((struct binding_record *) environment) -> value) =
  190.     (*save_binding_location);
  191. }
  192.  
  193. void
  194. DEFUN (dstack_bind, (location, value), PTR location AND PTR value)
  195. {
  196.   save_binding_location = location;
  197.   dstack_alloc_and_protect
  198.     ((sizeof (struct binding_record)), save_binding, undo_binding);
  199.   (* ((PTR *) location)) = value;
  200. }
  201.