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 / term.c < prev    next >
C/C++ Source or Header  |  2000-12-05  |  9KB  |  326 lines
  1. /* -*-C-*-
  2.  
  3. $Id: term.c,v 1.15 2000/12/05 21:23:48 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 "scheme.h"
  23. #include "ostop.h"
  24. #include "osio.h"
  25. #include "osfs.h"
  26. #include "osfile.h"
  27. #include "edwin.h"
  28.  
  29. extern long death_blow;
  30. extern char * Term_Messages [];
  31. extern void EXFUN (get_band_parameters, (long * heap_size, long * const_size));
  32. extern void EXFUN (Reset_Memory, (void));
  33.  
  34. #ifdef __WIN32__
  35. #  define USING_MESSAGE_BOX_FOR_FATAL_OUTPUT
  36.    extern void win32_deallocate_registers (void);
  37. #endif
  38.  
  39. #ifdef __OS2__
  40. #  define USING_MESSAGE_BOX_FOR_FATAL_OUTPUT
  41. #endif
  42.  
  43. static void EXFUN (edwin_auto_save, (void));
  44. static void EXFUN (delete_temp_files, (void));
  45.  
  46. #define BYTES_TO_BLOCKS(n) (((n) + 1023) / 1024)
  47. #define MIN_HEAP_DELTA    50
  48.  
  49. #ifndef EXIT_SCHEME
  50. #  define EXIT_SCHEME exit
  51. #endif
  52.  
  53. #ifdef EXIT_SCHEME_DECLARATIONS
  54. EXIT_SCHEME_DECLARATIONS;
  55. #endif
  56.  
  57. void
  58. DEFUN_VOID (init_exit_scheme)
  59. {
  60. #ifdef INIT_EXIT_SCHEME
  61.   INIT_EXIT_SCHEME ();
  62. #endif
  63. }
  64.  
  65. static void
  66. DEFUN (attempt_termination_backout, (code), int code)
  67. {
  68.   outf_flush_error(); /* NOT flush_fatal */
  69.   if ((WITHIN_CRITICAL_SECTION_P ())
  70.       || (code == TERM_HALT)
  71.       || (! (Valid_Fixed_Obj_Vector ())))
  72.     return;
  73.   {
  74.     SCHEME_OBJECT Term_Vector = (Get_Fixed_Obj_Slot (Termination_Proc_Vector));
  75.     if ((! (VECTOR_P (Term_Vector)))
  76.     || (((long) (VECTOR_LENGTH (Term_Vector))) <= code))
  77.       return;
  78.     {
  79.       SCHEME_OBJECT Handler = (VECTOR_REF (Term_Vector, code));
  80.       if (Handler == SHARP_F)
  81.     return;
  82.      Will_Push (CONTINUATION_SIZE
  83.         + STACK_ENV_EXTRA_SLOTS
  84.         + ((code == TERM_NO_ERROR_HANDLER) ? 5 : 4));
  85.       Store_Return (RC_HALT);
  86.       Store_Expression (LONG_TO_UNSIGNED_FIXNUM (code));
  87.       Save_Cont ();
  88.       if (code == TERM_NO_ERROR_HANDLER)
  89.     STACK_PUSH (LONG_TO_UNSIGNED_FIXNUM (death_blow));
  90.       STACK_PUSH (Val);            /* Arg 3 */
  91.       STACK_PUSH (Fetch_Env ());    /* Arg 2 */
  92.       STACK_PUSH (Fetch_Expression ()); /* Arg 1 */
  93.       STACK_PUSH (Handler);        /* The handler function */
  94.       STACK_PUSH (STACK_FRAME_HEADER
  95.           + ((code == TERM_NO_ERROR_HANDLER) ? 4 : 3));
  96.      Pushed ();
  97.       abort_to_interpreter (PRIM_NO_TRAP_APPLY);
  98.     }
  99.   }
  100. }
  101.  
  102. static void
  103. DEFUN (termination_prefix, (code), int code)
  104. {
  105.   attempt_termination_backout (code);
  106.   OS_restore_external_state ();
  107.   /* TERM_HALT is not an error condition and thus its termination
  108.      message should be considered normal output.  */
  109.   if (code == TERM_HALT)
  110.     {
  111.       outf_console ("\n%s.\n", (Term_Messages [code]));
  112.       outf_flush_console ();
  113.     }
  114.   else
  115.     {
  116. #ifdef USING_MESSAGE_BOX_FOR_FATAL_OUTPUT
  117.       outf_fatal ("Reason for termination:");
  118. #endif
  119.       outf_fatal ("\n");
  120.       if ((code < 0) || (code > MAX_TERMINATION))
  121.     outf_fatal ("Unknown termination code 0x%x", code);
  122.       else
  123.     outf_fatal ("%s", (Term_Messages [code]));
  124.       if (WITHIN_CRITICAL_SECTION_P ())
  125.     outf_fatal (" within critical section \"%s\"",
  126.             (CRITICAL_SECTION_NAME ()));
  127.       outf_fatal (".");
  128. #ifndef USING_MESSAGE_BOX_FOR_FATAL_OUTPUT
  129.       outf_fatal ("\n");
  130. #endif
  131.     }
  132. }
  133.  
  134. static void
  135. DEFUN (termination_suffix, (code, value, abnormal_p),
  136.        int code AND int value AND int abnormal_p)
  137. {
  138. #ifdef EXIT_HOOK
  139.   EXIT_HOOK (code, value, abnormal_p);
  140. #endif
  141.   edwin_auto_save ();
  142.   delete_temp_files ();
  143. #ifdef USING_MESSAGE_BOX_FOR_FATAL_OUTPUT
  144.   /* Don't put up message box for ordinary exit.  */
  145.   if (code != TERM_HALT)
  146. #endif
  147.     outf_flush_fatal();
  148. #ifdef __WIN32__
  149.   win32_deallocate_registers();
  150. #endif
  151.   Reset_Memory ();
  152.   EXIT_SCHEME (value);
  153. }
  154.  
  155. static void
  156. DEFUN (termination_suffix_trace, (code), int code)
  157. {
  158.   if (Trace_On_Error)
  159.     {
  160.       outf_error ("\n\n**** Stack trace ****\n\n");
  161.       Back_Trace (error_output);
  162.     }
  163.   termination_suffix (code, 1, 1);
  164. }
  165.  
  166. void
  167. DEFUN (Microcode_Termination, (code), int code)
  168. {
  169.   termination_prefix (code);
  170.   termination_suffix_trace (code);
  171. }
  172.  
  173. void
  174. DEFUN (termination_normal, (value), CONST int value)
  175. {
  176.   termination_prefix (TERM_HALT);
  177.   termination_suffix (TERM_HALT, value, 0);
  178. }
  179.  
  180. void
  181. DEFUN_VOID (termination_init_error)
  182. {
  183.   termination_prefix (TERM_EXIT);
  184.   termination_suffix (TERM_EXIT, 1, 1);
  185. }
  186.  
  187. void
  188. DEFUN_VOID (termination_end_of_computation)
  189. {
  190.   termination_prefix (TERM_END_OF_COMPUTATION);
  191.   Print_Expression (Val, "Final result");
  192.   outf_console("\n");
  193.   termination_suffix (TERM_END_OF_COMPUTATION, 0, 0);
  194. }
  195.  
  196. void
  197. DEFUN_VOID (termination_trap)
  198. {
  199.   /* This claims not to be abnormal so that the user will
  200.      not be asked a second time about dumping core. */
  201.   termination_prefix (TERM_TRAP);
  202.   termination_suffix (TERM_TRAP, 1, 0);
  203. }
  204.  
  205. void
  206. DEFUN_VOID (termination_no_error_handler)
  207. {
  208.   /* This does not print a back trace because the caller printed one. */
  209.   termination_prefix (TERM_NO_ERROR_HANDLER);
  210.   if (death_blow == ERR_FASL_FILE_TOO_BIG)
  211.     {
  212.       long heap_size;
  213.       long const_size;
  214.       get_band_parameters (&heap_size, &const_size);
  215.       outf_fatal ("Try again with values at least as large as\n");
  216.       outf_fatal ("  -heap %d (%d + %d)\n",
  217.            (MIN_HEAP_DELTA + (BYTES_TO_BLOCKS (heap_size))),
  218.            (BYTES_TO_BLOCKS (heap_size)),
  219.            MIN_HEAP_DELTA);
  220.       outf_fatal ("  -constant %d\n", (BYTES_TO_BLOCKS (const_size)));
  221.     }
  222.   termination_suffix (TERM_NO_ERROR_HANDLER, 1, 1);
  223. }
  224.  
  225. void
  226. DEFUN_VOID (termination_gc_out_of_space)
  227. {
  228.   termination_prefix (TERM_GC_OUT_OF_SPACE);
  229.   outf_fatal ("You are out of space at the end of a Garbage Collection!\n");
  230.   outf_fatal ("Free = 0x%lx; MemTop = 0x%lx; Heap_Top = 0x%lx\n",
  231.           Free, MemTop, Heap_Top);
  232.   outf_fatal ("Words required = %ld; Words available = %ld\n",
  233.           (MemTop - Free), GC_Space_Needed);
  234.   termination_suffix_trace (TERM_GC_OUT_OF_SPACE);
  235. }
  236.  
  237. void
  238. DEFUN_VOID (termination_eof)
  239. {
  240.   Microcode_Termination (TERM_EOF);
  241. }
  242.  
  243. void
  244. DEFUN (termination_signal, (signal_name), CONST char * signal_name)
  245. {
  246.   if (signal_name != 0)
  247.     {
  248.       termination_prefix (TERM_SIGNAL);
  249.       outf_fatal ("Killed by %s.\n", signal_name);
  250.     }
  251.   else
  252.     attempt_termination_backout (TERM_SIGNAL);
  253.   termination_suffix_trace (TERM_SIGNAL);
  254. }
  255.  
  256. static void
  257. DEFUN_VOID (edwin_auto_save)
  258. {
  259.   static SCHEME_OBJECT position;
  260.   static struct interpreter_state_s new_state;
  261.  
  262.   position =
  263.     ((Valid_Fixed_Obj_Vector ())
  264.      ? (Get_Fixed_Obj_Slot (FIXOBJ_EDWIN_AUTO_SAVE))
  265.      : EMPTY_LIST);
  266.   while (PAIR_P (position))
  267.     {
  268.       SCHEME_OBJECT entry = (PAIR_CAR (position));
  269.       position = (PAIR_CDR (position));
  270.       if ((PAIR_P (entry))
  271.       && (GROUP_P (PAIR_CAR (entry)))
  272.       && (STRING_P (PAIR_CDR (entry)))
  273.       && ((GROUP_MODIFIED_P (PAIR_CAR (entry))) == SHARP_T))
  274.     {
  275.       SCHEME_OBJECT group = (PAIR_CAR (entry));
  276.       char * namestring = ((char *) (STRING_LOC ((PAIR_CDR (entry)), 0)));
  277.       SCHEME_OBJECT text = (GROUP_TEXT (group));
  278.       unsigned char * start = (STRING_LOC (text, 0));
  279.       unsigned char * end = (start + (STRING_LENGTH (text)));
  280.       unsigned char * gap_start = (start + (GROUP_GAP_START (group)));
  281.       unsigned char * gap_end = (start + (GROUP_GAP_END (group)));
  282.       if ((start < gap_start) || (gap_end < end))
  283.         {
  284.           bind_interpreter_state (&new_state);
  285.           if ((setjmp (interpreter_catch_env)) == 0)
  286.         {
  287.           Tchannel channel;
  288.           outf_error ("Auto-saving file \"%s\"\n", namestring);
  289.           outf_flush_error ();
  290.           channel = (OS_open_output_file (namestring));
  291.           if (start < gap_start)
  292.             OS_channel_write (channel, start, (gap_start - start));
  293.           if (gap_end < end)
  294.             OS_channel_write (channel, gap_end, (end - gap_end));
  295.           OS_channel_close (channel);
  296.         }
  297.           unbind_interpreter_state (&new_state);
  298.         }
  299.     }
  300.     }
  301. }
  302.  
  303. static void
  304. DEFUN_VOID (delete_temp_files)
  305. {
  306.   static SCHEME_OBJECT position;
  307.   static struct interpreter_state_s new_state;
  308.  
  309.   position =
  310.     ((Valid_Fixed_Obj_Vector ())
  311.      ? (Get_Fixed_Obj_Slot (FIXOBJ_FILES_TO_DELETE))
  312.      : EMPTY_LIST);
  313.   while (PAIR_P (position))
  314.     {
  315.       SCHEME_OBJECT entry = (PAIR_CAR (position));
  316.       position = (PAIR_CDR (position));
  317.       if (STRING_P (entry))
  318.     {
  319.       bind_interpreter_state (&new_state);
  320.       if ((setjmp (interpreter_catch_env)) == 0)
  321.         OS_file_remove ((char *) (STRING_LOC (entry, 0)));
  322.       unbind_interpreter_state (&new_state);
  323.     }
  324.     }
  325. }
  326.