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 / boot.c < prev    next >
C/C++ Source or Header  |  2000-12-05  |  22KB  |  740 lines
  1. /* -*-C-*-
  2.  
  3. $Id: boot.c,v 9.104 2000/12/05 21:23:43 cph Exp $
  4.  
  5. Copyright (c) 1988-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. /* This file contains `main' and associated startup code. */
  23.  
  24. #include "scheme.h"
  25. #include "prims.h"
  26. #include "version.h"
  27. #include "option.h"
  28. #ifndef islower
  29. #include <ctype.h>
  30. #endif
  31. #include "ostop.h"
  32. #include "ostty.h"
  33.  
  34. extern PTR EXFUN (malloc, (unsigned int size));
  35. extern void EXFUN (free, (PTR ptr));
  36. extern void EXFUN (init_exit_scheme, (void));
  37. extern void EXFUN (Clear_Memory, (int, int, int));
  38. extern void EXFUN (Setup_Memory, (int, int, int));
  39. extern void EXFUN (compiler_initialize, (long fasl_p));
  40. extern SCHEME_OBJECT EXFUN (make_primitive, (char *, int));
  41. extern void EXFUN (OS_announcement, (void));
  42. extern SCHEME_OBJECT EXFUN (char_pointer_to_symbol, (unsigned char *));
  43.  
  44. static void EXFUN (Start_Scheme, (int, CONST char *));
  45. static void EXFUN (Enter_Interpreter, (void));
  46.  
  47. CONST char * scheme_program_name;
  48. CONST char * OS_Name;
  49. CONST char * OS_Variant;
  50. struct obstack scratch_obstack;
  51. PTR initial_C_stack_pointer;
  52. static char * reload_saved_string;
  53. static unsigned int reload_saved_string_length;
  54.  
  55. /* If true, this is an executable created by dump-world. */
  56. Boolean scheme_dumped_p = false;
  57.  
  58. PTR
  59. DEFUN (obstack_chunk_alloc, (size), unsigned int size)
  60. {
  61.   PTR result = (malloc (size));
  62.   if (result == 0)
  63.     {
  64.       outf_fatal ("\n%s: unable to allocate obstack chunk of %d bytes\n",
  65.            scheme_program_name, size);
  66.       Microcode_Termination (TERM_EXIT);
  67.     }
  68.   return (result);
  69. }
  70.  
  71. #define obstack_chunk_free free
  72.  
  73. #ifndef INIT_FIXED_OBJECTS
  74. #define INIT_FIXED_OBJECTS initialize_fixed_objects_vector
  75. #endif
  76.  
  77. /* Declare the outermost critical section. */
  78. DECLARE_CRITICAL_SECTION ();
  79.  
  80. #define BLOCKS_TO_BYTES(n) ((n) * 1024)
  81.  
  82. /* Exit is done in a different way on some operating systems (eg. VMS)  */
  83.  
  84. #ifndef main_name
  85. #define main_name main
  86. #endif
  87.  
  88. #define FILE_READABLE(filename) ((access ((filename), 4)) >= 0)
  89.  
  90. int
  91. DEFUN (main_name, (argc, argv),
  92.        int argc AND CONST char ** argv)
  93. {
  94.   init_exit_scheme ();
  95.   scheme_program_name = (argv[0]);
  96.   initial_C_stack_pointer = ((PTR) (&argc));
  97.  
  98. #ifdef __WIN32__
  99.   {
  100.     extern void NT_initialize_win32_system_utilities();
  101.     NT_initialize_win32_system_utilities ();
  102.   }
  103. #endif
  104. #ifdef PREALLOCATE_HEAP_MEMORY
  105.   PREALLOCATE_HEAP_MEMORY ();
  106. #endif
  107. #ifdef __OS2__
  108.   {
  109.     extern void OS2_initialize_early (void);
  110.     OS2_initialize_early ();
  111.   }
  112. #endif
  113.   obstack_init (&scratch_obstack);
  114.   dstack_initialize ();
  115.   transaction_initialize ();
  116.   reload_saved_string = 0;
  117.   reload_saved_string_length = 0;
  118.   read_command_line_options (argc, argv);
  119.  
  120.   if (scheme_dumped_p)
  121.     {
  122.       extern SCHEME_OBJECT compiler_utilities;
  123.       extern void EXFUN (compiler_reset, (SCHEME_OBJECT));
  124.  
  125.       if (! ((Heap_Size == ((long) option_heap_size))
  126.          && (Stack_Size == ((long) option_stack_size))
  127.          && (Constant_Size == ((long) option_constant_size))))
  128.     {
  129.       outf_error ("%s: warning: ignoring allocation parameters.\n",
  130.               scheme_program_name);
  131.       outf_flush_error ();
  132.     }
  133.       OS_reset ();
  134.       compiler_reset (compiler_utilities);
  135.       if (!option_band_specified)
  136.     {
  137.       outf_console ("Scheme Microcode Version %d.%d\n",
  138.                     SCHEME_VERSION, SCHEME_SUBVERSION);
  139.       OS_initialize ();
  140.       Enter_Interpreter ();
  141.     }
  142.       else
  143.     {
  144.       Clear_Memory ((BLOCKS_TO_BYTES (Heap_Size)),
  145.             (BLOCKS_TO_BYTES (Stack_Size)),
  146.             (BLOCKS_TO_BYTES (Constant_Size)));
  147.       /* We are reloading from scratch anyway. */
  148.       scheme_dumped_p = false;
  149.       if (option_fasl_file)
  150.         Start_Scheme (BOOT_FASLOAD, option_fasl_file);
  151.       else
  152.         Start_Scheme (BOOT_LOAD_BAND, option_band_file);
  153.     }
  154.     }
  155.   else
  156.     {
  157.       extern void EXFUN (initialize_primitives, (void));
  158.  
  159.       Heap_Size = option_heap_size;
  160.       Stack_Size = option_stack_size;
  161.       Constant_Size = option_constant_size;
  162.       Setup_Memory ((BLOCKS_TO_BYTES (Heap_Size)),
  163.             (BLOCKS_TO_BYTES (Stack_Size)),
  164.             (BLOCKS_TO_BYTES (Constant_Size)));
  165.  
  166. #ifdef EMPTY_LIST_VALUE
  167.       /* EMPTY_LIST_VALUE is defined if it is teh true value for '() and
  168.          EMPTY_LIST is a location used to store '() or #F
  169.      */
  170.       if (option_empty_list_eq_false)
  171.     EMPTY_LIST = SHARP_F;
  172.       else
  173.     EMPTY_LIST = EMPTY_LIST_VALUE;
  174. #endif
  175.  
  176.       initialize_primitives ();
  177.       if (! option_fasl_file)
  178.     {
  179.       compiler_initialize (0);
  180.       Start_Scheme (BOOT_LOAD_BAND, option_band_file);
  181.     }
  182. #ifdef NATIVE_CODE_IS_C
  183.       else if (! (FILE_READABLE (option_fasl_file)))
  184.       {
  185.     compiler_initialize (1);
  186.     Start_Scheme (BOOT_EXECUTE, option_fasl_file);
  187.       }
  188. #endif /* NATIVE_CODE_IS_C */
  189.       else
  190.     {
  191.       compiler_initialize (1);
  192.       Start_Scheme (BOOT_FASLOAD, option_fasl_file);
  193.     }
  194.     }
  195.   termination_init_error ();
  196.   return (0);
  197. }
  198.  
  199. static SCHEME_OBJECT
  200. DEFUN (names_to_vector, (length, names),
  201.        unsigned int length AND
  202.        unsigned char ** names)
  203. {
  204.   SCHEME_OBJECT v = (allocate_marked_vector (TC_VECTOR, length, 1));
  205.   unsigned int i;
  206.   for (i = 0; (i < length); i += 1)
  207.     {
  208.       VECTOR_SET (v, i, (char_pointer_to_symbol (names [i])));
  209.     }
  210.   return (v);
  211. }
  212.  
  213. static SCHEME_OBJECT
  214. DEFUN_VOID (fixed_objects_syscall_names)
  215. {
  216.   unsigned int length;
  217.   unsigned char ** names;
  218.   extern void EXFUN (OS_syscall_names, (unsigned int *, unsigned char ***));
  219.   OS_syscall_names ((&length), (&names));
  220.   return (names_to_vector (length, names));
  221. }
  222.  
  223. static SCHEME_OBJECT
  224. DEFUN_VOID (fixed_objects_syserr_names)
  225. {
  226.   unsigned int length;
  227.   unsigned char ** names;
  228.   extern void EXFUN (OS_syserr_names, (unsigned int *, unsigned char ***));
  229.   OS_syserr_names ((&length), (&names));
  230.   return (names_to_vector (length, names));
  231. }
  232.  
  233. void
  234. DEFUN_VOID (initialize_fixed_objects_vector)
  235. {
  236.   extern SCHEME_OBJECT EXFUN (initialize_history, (void));
  237.   extern SCHEME_OBJECT EXFUN (initialize_interrupt_handler_vector, (void));
  238.   extern SCHEME_OBJECT EXFUN (initialize_interrupt_mask_vector, (void));
  239.  
  240.   /* Create the fixed objects vector,
  241.      with 4 extra slots for expansion and debugging. */
  242.   fast SCHEME_OBJECT fixed_objects_vector =
  243.     (make_vector ((NFixed_Objects + 4), SHARP_F, false));
  244.   Fixed_Objects = fixed_objects_vector;
  245.   FAST_VECTOR_SET (fixed_objects_vector, Me_Myself, fixed_objects_vector);
  246.   FAST_VECTOR_SET
  247.     (fixed_objects_vector, Non_Object, (MAKE_OBJECT (TC_CONSTANT, 2)));
  248.   FAST_VECTOR_SET
  249.     (fixed_objects_vector,
  250.      System_Interrupt_Vector,
  251.      (initialize_interrupt_handler_vector ()));
  252.   FAST_VECTOR_SET
  253.     (fixed_objects_vector,
  254.      FIXOBJ_INTERRUPT_MASK_VECTOR,
  255.      (initialize_interrupt_mask_vector ()));
  256.   /* Error vector is not needed at boot time */
  257.   FAST_VECTOR_SET (fixed_objects_vector, System_Error_Vector, SHARP_F);
  258.   FAST_VECTOR_SET
  259.     (fixed_objects_vector,
  260.      OBArray,
  261.      (make_vector (OBARRAY_SIZE, EMPTY_LIST, false)));
  262.   FAST_VECTOR_SET
  263.     (fixed_objects_vector, Dummy_History, (initialize_history ()));
  264.   FAST_VECTOR_SET (fixed_objects_vector, State_Space_Tag, SHARP_T);
  265.   FAST_VECTOR_SET (fixed_objects_vector, Bignum_One, (long_to_bignum (1)));
  266.   FAST_VECTOR_SET (fixed_objects_vector, FIXOBJ_EDWIN_AUTO_SAVE, EMPTY_LIST);
  267.   FAST_VECTOR_SET (fixed_objects_vector, FIXOBJ_FILES_TO_DELETE, EMPTY_LIST);
  268.   FAST_VECTOR_SET
  269.     (fixed_objects_vector,
  270.      FIXOBJ_SYSTEM_CALL_NAMES,
  271.      (fixed_objects_syscall_names ()));
  272.   FAST_VECTOR_SET
  273.     (fixed_objects_vector,
  274.      FIXOBJ_SYSTEM_CALL_ERRORS,
  275.      (fixed_objects_syserr_names ()));
  276.  
  277.   (*Free++) = EMPTY_LIST;
  278.   (*Free++) = EMPTY_LIST;
  279.   FAST_VECTOR_SET
  280.     (fixed_objects_vector,
  281.      The_Work_Queue,
  282.      (MAKE_POINTER_OBJECT (TC_LIST, (Free - 2))));
  283.  
  284.   FAST_VECTOR_SET
  285.     (fixed_objects_vector,
  286.      Utilities_Vector,
  287.      (make_vector (0, SHARP_F, false)));
  288.  
  289.   FAST_VECTOR_SET
  290.     (fixed_objects_vector,
  291.      GENERIC_TRAMPOLINE_ZERO_P,
  292.      (make_primitive ("INTEGER-ZERO?", 1)));
  293.   FAST_VECTOR_SET
  294.     (fixed_objects_vector,
  295.      GENERIC_TRAMPOLINE_POSITIVE_P,
  296.      (make_primitive ("INTEGER-POSITIVE?", 1)));
  297.   FAST_VECTOR_SET
  298.     (fixed_objects_vector,
  299.      GENERIC_TRAMPOLINE_NEGATIVE_P,
  300.      (make_primitive ("INTEGER-NEGATIVE?", 1)));
  301.   FAST_VECTOR_SET
  302.     (fixed_objects_vector,
  303.      GENERIC_TRAMPOLINE_SUCCESSOR,
  304.      (make_primitive ("INTEGER-ADD-1", 1)));
  305.   FAST_VECTOR_SET
  306.     (fixed_objects_vector,
  307.      GENERIC_TRAMPOLINE_PREDECESSOR,
  308.      (make_primitive ("INTEGER-SUBTRACT-1", 1)));
  309.   FAST_VECTOR_SET
  310.     (fixed_objects_vector,
  311.      GENERIC_TRAMPOLINE_EQUAL_P,
  312.      (make_primitive ("INTEGER-EQUAL?", 2)));
  313.   FAST_VECTOR_SET
  314.     (fixed_objects_vector,
  315.      GENERIC_TRAMPOLINE_LESS_P,
  316.      (make_primitive ("INTEGER-LESS?", 2)));
  317.   FAST_VECTOR_SET
  318.     (fixed_objects_vector,
  319.      GENERIC_TRAMPOLINE_GREATER_P,
  320.      (make_primitive ("INTEGER-GREATER?", 2)));
  321.   FAST_VECTOR_SET
  322.     (fixed_objects_vector,
  323.      GENERIC_TRAMPOLINE_ADD,
  324.      (make_primitive ("INTEGER-ADD", 2)));
  325.   FAST_VECTOR_SET
  326.     (fixed_objects_vector,
  327.      GENERIC_TRAMPOLINE_SUBTRACT,
  328.      (make_primitive ("INTEGER-SUBTRACT", 2)));
  329.   FAST_VECTOR_SET
  330.     (fixed_objects_vector,
  331.      GENERIC_TRAMPOLINE_MULTIPLY,
  332.      (make_primitive ("INTEGER-MULTIPLY", 2)));
  333.   FAST_VECTOR_SET
  334.     (fixed_objects_vector,
  335.      GENERIC_TRAMPOLINE_DIVIDE,
  336.      SHARP_F);
  337.   FAST_VECTOR_SET
  338.     (fixed_objects_vector,
  339.      GENERIC_TRAMPOLINE_QUOTIENT,
  340.      SHARP_F);
  341.   FAST_VECTOR_SET
  342.     (fixed_objects_vector,
  343.      GENERIC_TRAMPOLINE_REMAINDER,
  344.      SHARP_F);
  345.   FAST_VECTOR_SET
  346.     (fixed_objects_vector,
  347.      GENERIC_TRAMPOLINE_MODULO,
  348.      SHARP_F);
  349.  
  350.   FAST_VECTOR_SET
  351.     (fixed_objects_vector,
  352.      ARITY_DISPATCHER_TAG,
  353.      char_pointer_to_symbol("#[(microcode)arity-dispatcher-tag]"));
  354.  
  355. #ifdef __WIN32__
  356.   {
  357.     extern void EXFUN (NT_initialize_fov, (SCHEME_OBJECT));
  358.     NT_initialize_fov (fixed_objects_vector);
  359.   }
  360. #endif
  361. }
  362.  
  363. /* Boot Scheme */
  364.  
  365. #ifndef ENTRY_HOOK
  366. #  define ENTRY_HOOK() do { } while (0)
  367. #endif
  368.  
  369. static void
  370. DEFUN (Start_Scheme, (Start_Prim, File_Name),
  371.        int Start_Prim AND CONST char * File_Name)
  372. {
  373.   SCHEME_OBJECT FName;
  374.   SCHEME_OBJECT expr = SHARP_F;
  375.   SCHEME_OBJECT * inner_arg;
  376.   SCHEME_OBJECT prim;
  377.   /* fast long i; */
  378.   /* Parallel processor test */
  379.   Boolean I_Am_Master = (Start_Prim != BOOT_GET_WORK);
  380.   OS_initialize ();
  381.   if (I_Am_Master)
  382.     {
  383.       outf_console ("Scheme Microcode Version %d.%d\n",
  384.             SCHEME_VERSION, SCHEME_SUBVERSION);
  385.       outf_console ("MIT Scheme running under %s\n", OS_Variant);
  386.       OS_announcement ();
  387.       outf_flush_console ();
  388.     }
  389.   if (I_Am_Master)
  390.   {
  391.     Current_State_Point = SHARP_F;
  392.     Fluid_Bindings = EMPTY_LIST;
  393.     INIT_FIXED_OBJECTS ();
  394.   }
  395.  
  396.   /* The initial program to execute is one of
  397.         (SCODE-EVAL (BINARY-FASLOAD <file-name>) SYSTEM-GLOBAL-ENVIRONMENT),
  398.     (LOAD-BAND <file-name>), or
  399.     ((GET-WORK))
  400.     (SCODE-EVAL (INITIALIZE-C-COMPILED-BLOCK <file>) GLOBAL-ENV)
  401.      depending on the value of Start_Prim. */
  402.   switch (Start_Prim)
  403.   {
  404.     case BOOT_FASLOAD:    /* (SCODE-EVAL (BINARY-FASLOAD <file>) GLOBAL-ENV) */
  405.       FName = (char_pointer_to_string ((unsigned char *) File_Name));
  406.       prim = (make_primitive ("BINARY-FASLOAD", 1));
  407.       inner_arg = Free;
  408.       *Free++ = prim;
  409.       *Free++ = FName;
  410.       prim = (make_primitive ("SCODE-EVAL", 2));
  411.       expr = MAKE_POINTER_OBJECT (TC_PCOMB2, Free);
  412.       *Free++ = prim;
  413.       *Free++ = MAKE_POINTER_OBJECT (TC_PCOMB1, inner_arg);
  414.       *Free++ = MAKE_OBJECT (GLOBAL_ENV, GO_TO_GLOBAL);
  415.       break;
  416.  
  417.     case BOOT_LOAD_BAND:    /* (LOAD-BAND <file>) */
  418.       FName = (char_pointer_to_string ((unsigned char *) File_Name));
  419.       prim = (make_primitive ("LOAD-BAND", 1));
  420.       inner_arg = Free;
  421.       *Free++ = prim;
  422.       *Free++ = FName;
  423.       expr = MAKE_POINTER_OBJECT (TC_PCOMB1, inner_arg);
  424.       break;
  425.  
  426.     case BOOT_GET_WORK:        /* ((GET-WORK)) */
  427.       prim = (make_primitive ("GET-WORK", 0));
  428.       inner_arg = Free;
  429.       *Free++ = prim;
  430.       *Free++ = SHARP_F;
  431.       expr = MAKE_POINTER_OBJECT (TC_COMBINATION, Free);
  432.       *Free++ = MAKE_OBJECT (TC_MANIFEST_VECTOR, 1);
  433.       *Free++ = MAKE_POINTER_OBJECT (TC_PCOMB1, inner_arg);
  434.       break;
  435.  
  436.     case BOOT_EXECUTE:
  437.       /* (SCODE-EVAL (INITIALIZE-C-COMPILED-BLOCK <file>) GLOBAL-ENV) */
  438.       FName = (char_pointer_to_string ((unsigned char *) File_Name));
  439.       prim = (make_primitive ("INITIALIZE-C-COMPILED-BLOCK", 1));
  440.       inner_arg = Free;
  441.       *Free++ = prim;
  442.       *Free++ = FName;
  443.       prim = (make_primitive ("SCODE-EVAL", 2));
  444.       expr = (MAKE_POINTER_OBJECT (TC_PCOMB2, Free));
  445.       *Free++ = prim;
  446.       *Free++ = (MAKE_POINTER_OBJECT (TC_PCOMB1, inner_arg));
  447.       *Free++ = (MAKE_OBJECT (GLOBAL_ENV, GO_TO_GLOBAL));
  448.       break;
  449.       
  450.  
  451.     default:
  452.       outf_fatal ("Unknown boot time option: %d\n", Start_Prim);
  453.       Microcode_Termination (TERM_BAD_PRIMITIVE);
  454.       /*NOTREACHED*/
  455.   }
  456.  
  457.   /* Setup registers */
  458.   INITIALIZE_INTERRUPTS ();
  459.   SET_INTERRUPT_MASK (0);
  460.   Env = (MAKE_OBJECT (GLOBAL_ENV, 0));
  461.   Trapping = false;
  462.   Return_Hook_Address = NULL;
  463.  
  464.   /* Give the interpreter something to chew on, and ... */
  465.  Will_Push (CONTINUATION_SIZE);
  466.   Store_Return (RC_END_OF_COMPUTATION);
  467.   Store_Expression (SHARP_F);
  468.   Save_Cont ();
  469.  Pushed ();
  470.  
  471.   Store_Expression (expr);
  472.  
  473.   /* Go to it! */
  474.   if ((Stack_Pointer <= Stack_Guard) || (Free > MemTop))
  475.   {
  476.     outf_fatal ("Configuration won't hold initial data.\n");
  477.     termination_init_error ();
  478.   }
  479.   ENTRY_HOOK ();
  480.   Enter_Interpreter ();
  481. }
  482.  
  483. #ifdef __WIN32__
  484.    extern void EXFUN (win32_enter_interpreter, (void (*) (void)));
  485. #  define HOOK_ENTER_INTERPRETER win32_enter_interpreter
  486. #else
  487. #  ifdef __OS2__
  488.      extern void EXFUN (OS2_enter_interpreter, (void (*) (void)));
  489. #    define HOOK_ENTER_INTERPRETER OS2_enter_interpreter
  490. #  else
  491. #    define HOOK_ENTER_INTERPRETER(func) func ()
  492. #  endif
  493. #endif
  494.  
  495. static void
  496. DEFUN_VOID (Do_Enter_Interpreter)
  497. {
  498.   Interpret (scheme_dumped_p);
  499.   outf_fatal ("\nThe interpreter returned to top level!\n");
  500.   Microcode_Termination (TERM_EXIT);
  501. }
  502.  
  503. static void
  504. DEFUN_VOID (Enter_Interpreter)
  505. {
  506.   HOOK_ENTER_INTERPRETER (Do_Enter_Interpreter);
  507. }
  508.  
  509. /* This must be used with care, and only synchronously. */
  510.  
  511. extern SCHEME_OBJECT EXFUN (Re_Enter_Interpreter, (void));
  512.  
  513. SCHEME_OBJECT
  514. DEFUN_VOID (Re_Enter_Interpreter)
  515. {
  516.   Interpret (true);
  517.   return  Val;
  518. }
  519.  
  520. /* Garbage collection debugging utilities. */
  521.  
  522. extern SCHEME_OBJECT
  523.   *deadly_free,
  524.   *deadly_scan;
  525.  
  526. extern unsigned long
  527.   gc_counter;
  528.  
  529. extern void EXFUN (gc_death,
  530.            (long code, char *, SCHEME_OBJECT *, SCHEME_OBJECT *));
  531. extern void EXFUN (stack_death, (CONST char *));
  532.  
  533. extern char
  534.   gc_death_message_buffer[];
  535.  
  536. SCHEME_OBJECT
  537.   *deadly_free,
  538.   *deadly_scan;
  539.  
  540. unsigned long
  541.   gc_counter = 0;
  542.  
  543. char
  544.   gc_death_message_buffer[100];
  545.  
  546. void
  547. DEFUN (gc_death, (code, message, scan, free),
  548.        long code AND char * message
  549.        AND SCHEME_OBJECT * scan AND SCHEME_OBJECT * free)
  550. {
  551.   outf_fatal ("\n%s.\n", message);
  552.   outf_fatal ("scan = 0x%lx; free = 0x%lx\n", scan, free);
  553.   deadly_scan = scan;
  554.   deadly_free = free;
  555.   Microcode_Termination (code);
  556.   /*NOTREACHED*/
  557. }
  558.  
  559. void
  560. DEFUN (stack_death, (name), CONST char * name)
  561. {
  562.   outf_fatal
  563.     ("\n%s: The stack has overflowed and overwritten adjacent memory.\n",
  564.      name);
  565.   outf_fatal ("This was probably caused by a runaway recursion.\n");
  566.   Microcode_Termination (TERM_STACK_OVERFLOW);
  567.   /*NOTREACHED*/
  568. }
  569.  
  570. /* Utility primitives. */
  571.  
  572. #define IDENTITY_LENGTH     20    /* Plenty of room */
  573. #define ID_RELEASE        0    /* System release (string) */
  574. #define ID_MICRO_VERSION    1    /* Microcode version (fixnum) */
  575. #define ID_MICRO_MOD        2    /* Microcode modification (fixnum) */
  576. #define ID_PRINTER_WIDTH    3    /* TTY width (# chars) */
  577. #define ID_PRINTER_LENGTH    4    /* TTY height (# chars) */
  578. #define ID_NEW_LINE_CHARACTER    5    /* #\Newline */
  579. #define ID_FLONUM_PRECISION    6    /* Flonum mantissa (# bits) */
  580. #define ID_FLONUM_EPSILON    7    /* Flonum epsilon (flonum) */
  581. #define ID_OS_NAME        8    /* OS name (string) */
  582. #define ID_OS_VARIANT        9    /* OS variant (string) */
  583. #define ID_STACK_TYPE        10    /* Scheme stack type (string) */
  584.  
  585. #ifdef USE_STACKLETS
  586. #define STACK_TYPE_STRING "stacklets"
  587. #else
  588. #define STACK_TYPE_STRING "standard"
  589. #endif
  590.  
  591. DEFINE_PRIMITIVE ("MICROCODE-IDENTIFY", Prim_microcode_identify, 0, 0, 0)
  592. {
  593.   fast SCHEME_OBJECT Result;
  594.   PRIMITIVE_HEADER (0);
  595.   Result = (make_vector (IDENTITY_LENGTH, SHARP_F, true));
  596.   FAST_VECTOR_SET
  597.     (Result, ID_RELEASE,
  598.      (char_pointer_to_string ((unsigned char *) SCHEME_RELEASE)));
  599.   FAST_VECTOR_SET
  600.     (Result, ID_MICRO_VERSION, (LONG_TO_UNSIGNED_FIXNUM (SCHEME_VERSION)));
  601.   FAST_VECTOR_SET
  602.     (Result, ID_MICRO_MOD, (LONG_TO_UNSIGNED_FIXNUM (SCHEME_SUBVERSION)));
  603.   FAST_VECTOR_SET
  604.     (Result, ID_PRINTER_WIDTH, (LONG_TO_UNSIGNED_FIXNUM (OS_tty_x_size ())));
  605.   FAST_VECTOR_SET
  606.     (Result, ID_PRINTER_LENGTH, (LONG_TO_UNSIGNED_FIXNUM (OS_tty_y_size ())));
  607.   FAST_VECTOR_SET
  608.     (Result, ID_NEW_LINE_CHARACTER, (ASCII_TO_CHAR ('\n')));
  609.   FAST_VECTOR_SET
  610.     (Result, ID_FLONUM_PRECISION, (LONG_TO_UNSIGNED_FIXNUM (DBL_MANT_DIG)));
  611.   FAST_VECTOR_SET
  612.     (Result, ID_FLONUM_EPSILON, (double_to_flonum ((double) DBL_EPSILON)));
  613.   FAST_VECTOR_SET
  614.     (Result, ID_OS_NAME, (char_pointer_to_string ((unsigned char *) OS_Name)));
  615.   FAST_VECTOR_SET (Result, ID_OS_VARIANT,
  616.            (char_pointer_to_string ((unsigned char *) OS_Variant)));
  617.   FAST_VECTOR_SET (Result, ID_STACK_TYPE,
  618.            (char_pointer_to_string
  619.             ((unsigned char *) STACK_TYPE_STRING)));
  620.   PRIMITIVE_RETURN (Result);
  621. }
  622.  
  623. DEFINE_PRIMITIVE ("MICROCODE-SYSTEM-CALL-NAMES", Prim_microcode_syscall_names, 0, 0, 0)
  624. {
  625.   PRIMITIVE_HEADER (0);
  626.   PRIMITIVE_RETURN (fixed_objects_syscall_names ());
  627. }
  628.  
  629. DEFINE_PRIMITIVE ("MICROCODE-SYSTEM-ERROR-NAMES", Prim_microcode_syserr_names, 0, 0, 0)
  630. {
  631.   PRIMITIVE_HEADER (0);
  632.   PRIMITIVE_RETURN (fixed_objects_syserr_names ());
  633. }
  634.  
  635. DEFINE_PRIMITIVE ("MICROCODE-TABLES-FILENAME", Prim_microcode_tables_filename, 0, 0, 0)
  636. {
  637.   PRIMITIVE_HEADER (0);
  638.   PRIMITIVE_RETURN
  639.     (char_pointer_to_string ((unsigned char *) option_utabmd_file));
  640. }
  641.  
  642. DEFINE_PRIMITIVE ("MICROCODE-LIBRARY-PATH", Prim_microcode_library_path, 0, 0, 0)
  643. {
  644.   PRIMITIVE_HEADER (0);
  645.   {
  646.     CONST char ** scan = option_library_path;
  647.     CONST char ** end = option_library_path;
  648.     while (1)
  649.       if ((*end++) == 0)
  650.     {
  651.       end -= 1;
  652.       break;
  653.     }
  654.     {
  655.       SCHEME_OBJECT result =
  656.     (allocate_marked_vector (TC_VECTOR, (end - scan), 1));
  657.       SCHEME_OBJECT * scan_result = (VECTOR_LOC (result, 0));
  658.       while (scan < end)
  659.     (*scan_result++) =
  660.       (char_pointer_to_string ((unsigned char *) *scan++));
  661.       PRIMITIVE_RETURN (result);
  662.     }
  663.   }
  664. }
  665.  
  666. static SCHEME_OBJECT
  667. DEFUN (argv_to_object, (argc, argv), int argc AND CONST char ** argv)
  668. {
  669.   SCHEME_OBJECT result = (allocate_marked_vector (TC_VECTOR, argc, 1));
  670.   CONST char ** scan = argv;
  671.   CONST char ** end = (scan + argc);
  672.   SCHEME_OBJECT * scan_result = (VECTOR_LOC (result, 0));
  673.   while (scan < end)
  674.     (*scan_result++) = (char_pointer_to_string ((unsigned char *) *scan++));
  675.   return (result);
  676. }
  677.  
  678. DEFINE_PRIMITIVE ("GET-COMMAND-LINE", Prim_get_command_line, 0, 0, 0)
  679. {
  680.   PRIMITIVE_HEADER (0);
  681.   PRIMITIVE_RETURN (argv_to_object (option_saved_argc, option_saved_argv));
  682. }
  683.  
  684. DEFINE_PRIMITIVE ("GET-UNUSED-COMMAND-LINE", Prim_get_unused_command_line, 0, 0, 0)
  685. {
  686.   PRIMITIVE_HEADER (0);
  687.   if (option_unused_argv == 0)
  688.     PRIMITIVE_RETURN (SHARP_F);
  689.   {
  690.     SCHEME_OBJECT result =
  691.       (argv_to_object (option_unused_argc, option_unused_argv));
  692.     option_unused_argv = 0;
  693.     PRIMITIVE_RETURN (result);
  694.   }
  695. }
  696.  
  697. DEFINE_PRIMITIVE ("RELOAD-SAVE-STRING", Prim_reload_save_string, 1, 1, 0)
  698. {
  699.   PRIMITIVE_HEADER (1);
  700.   if (reload_saved_string != 0)
  701.     {
  702.       free (reload_saved_string);
  703.       reload_saved_string = 0;
  704.     }
  705.   if ((ARG_REF (1)) != SHARP_F)
  706.     {
  707.       CHECK_ARG (1, STRING_P);
  708.       {
  709.     unsigned int length = (STRING_LENGTH (ARG_REF (1)));
  710.     reload_saved_string = (malloc (length));
  711.     if (reload_saved_string == 0)
  712.       error_external_return ();
  713.     reload_saved_string_length = length;
  714.     {
  715.       char * scan = ((char *) (STRING_LOC ((ARG_REF (1)), 0)));
  716.       char * end = (scan + length);
  717.       char * scan_result = reload_saved_string;
  718.       while (scan < end)
  719.         (*scan_result++) = (*scan++);
  720.     }
  721.       }
  722.     }
  723.   PRIMITIVE_RETURN (UNSPECIFIC);
  724. }
  725.  
  726. DEFINE_PRIMITIVE ("RELOAD-RETRIEVE-STRING", Prim_reload_retrieve_string, 0, 0, 0)
  727. {
  728.   PRIMITIVE_HEADER (0);
  729.   if (reload_saved_string == 0)
  730.     PRIMITIVE_RETURN (SHARP_F);
  731.   {
  732.     SCHEME_OBJECT result =
  733.       (memory_to_string (reload_saved_string_length,
  734.              ((unsigned char *) reload_saved_string)));
  735.     free (reload_saved_string);
  736.     reload_saved_string = 0;
  737.     PRIMITIVE_RETURN (result);
  738.   }
  739. }
  740.