/* -*-C-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/Attic/bchmmg.c,v 9.55 1990/06/20 21:13:44 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/Attic/bchmmg.c,v 9.56 1990/11/13 08:44:07 cph Rel $
Copyright (c) 1987, 1988, 1989, 1990 Massachusetts Institute of Technology
#include "scheme.h"
#include "prims.h"
#include "bchgcc.h"
+#include "option.h"
/* Exports */
(void) mktemp(gc_default_file_name);
flags = GC_FILE_FLAGS;
- gc_file_name = (string_option_argument ("-gcfile"));
+ gc_file_name = option_gc_file;
if (gc_file_name == 0)
{
gc_file_name = gc_default_file_name;
{
fprintf(stderr,
"%s: GC file \"%s\" cannot be opened; ",
- Saved_argv[0]), gc_file_name;
+ scheme_program_name, gc_file_name);
gc_file_name = gc_default_file_name;
fprintf(stderr,
"Using \"%s\" instead.\n",
}
fprintf(stderr,
"%s: GC file \"%s\" cannot be opened; Aborting.\n",
- Saved_argv[0], gc_file_name);
+ scheme_program_name, gc_file_name);
exit(1);
}
#ifdef _HPUX
{
fprintf(stderr,
"%s: cannot position at start of GC file \"%s\"; Aborting.\n",
- Saved_argv[0], gc_file_name);
+ scheme_program_name, gc_file_name);
exit(1);
}
}
{
fprintf(stderr,
"%s: Problems closing GC file \"%s\".\n",
- Saved_argv[0], gc_file_name);
+ scheme_program_name, gc_file_name);
}
if (gc_file_name == gc_default_file_name)
{
/* -*-C-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/boot.c,v 9.63 1990/09/08 00:09:49 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/boot.c,v 9.64 1990/11/13 08:44:14 cph Exp $
Copyright (c) 1988, 1989, 1990 Massachusetts Institute of Technology
Technology nor of any adaptation thereof in any advertising,
promotional, or sales literature without prior written consent from
MIT in each case. */
-\f
-/* This file contains the code to support startup of
- the SCHEME interpreter.
-
- The command line (when not running a dumped executable version) may
- take the following forms:
-
- scheme
-
- or
-
- scheme {band-name}
-
- or
-
- scheme {filespec}
- {-heap heap-size}
- {-stack stack-size}
- {-constant constant-size}
- {-utabmd utab-filename} or {-utab utab-filename}
- {other arguments ignored by the core microcode}
-
- with filespec either {-band band-name} or {-fasl file-name} or
- -compiler.
- arguments are optional, numbers are in 1K units. Default values
- are given above. The arguments in the long for may appear in any
- order on the command line. The allocation arguments (heap, stack,
- and constant) are ignored when scheme is an executable image. A
- warning message is printed if the command line contains them.
+/* This file contains `main' and associated startup code. */
- heap-size......number of cells to allocate for user heap; this will
- be doubled to allow for 2 space GC.
- stack-size.....number of cells for control stack. This primarily
- controls maximum depth of recursion. If the flag
- USE_STACKLETS is defined, then this controls the
- size of the stacklets (not the total stack) and
- thus affects how often new stack segments must
- be allocated.
- constant-size..number of cells for constant and pure space in the
- system.
- utab-filename..name of an alternate utabmd file to use.
-
-Additional arguments may exist for particular machines; see CONFIG.H
-for details. They are created by defining a macro Command_Line_Args.
-
-*/
-\f
#include "scheme.h"
#include "prims.h"
#include "version.h"
-#include "paths.h"
+#include "option.h"
#ifndef islower
#include <ctype.h>
#endif
extern PTR EXFUN (malloc, (unsigned int size));
extern void EXFUN (free, (PTR ptr));
+extern void EXFUN (init_exit_scheme, (void));
+extern void Clear_Memory ();
+extern void Setup_Memory ();
+extern void compiler_initialize ();
+\f
+forward void Start_Scheme ();
+forward void Enter_Interpreter ();
-int Saved_argc;
-CONST char ** Saved_argv;
+CONST char * scheme_program_name;
CONST char * OS_Name;
CONST char * OS_Variant;
struct obstack scratch_obstack;
+PTR initial_C_stack_pointer;
+
+/* If true, this is an executable created by dump-world. */
+Boolean scheme_dumped_p = false;
PTR
DEFUN (obstack_chunk_alloc, (size), unsigned int size)
if (result == 0)
{
fprintf (stderr, "\n%s: unable to allocate obstack chunk of %d bytes\n",
- (Saved_argv[0]), size);
+ scheme_program_name, size);
fflush (stderr);
Microcode_Termination (TERM_EXIT);
}
#define obstack_chunk_free free
-#ifndef ENTRY_HOOK
-#define ENTRY_HOOK()
+#ifndef INIT_FIXED_OBJECTS
+#define INIT_FIXED_OBJECTS() Fixed_Objects = (make_fixed_objects_vector ())
#endif
/* Declare the outermost critical section. */
static void
DEFUN (usage, (error_string), CONST char * error_string)
{
- fprintf (stderr, "%s: %s\n\n", (Saved_argv[0]), error_string);
+ fprintf (stderr, "%s: %s\n\n", scheme_program_name, error_string);
fflush (stderr);
- exit (1);
-}
-\f
-/* Command Line Parsing */
-
-static int
-DEFUN (string_compare_ci, (string1, string2),
- CONST char * string1 AND
- CONST char * string2)
-{
- CONST char * scan1 = string1;
- unsigned int length1 = (strlen (string1));
- CONST char * scan2 = string2;
- unsigned int length2 = (strlen (string2));
- unsigned int length = ((length1 < length2) ? length1 : length2);
- CONST char * end1 = (scan1 + length);
- CONST char * end2 = (scan2 + length);
- while ((scan1 < end1) && (scan2 < end2))
- {
- int c1 = (*scan1++);
- int c2 = (*scan2++);
- if (islower (c1))
- {
- if (! (islower (c2)))
- c1 = (toupper (c1));
- }
- else
- {
- if (islower (c2))
- c2 = (toupper (c2));
- }
- if (c1 != c2)
- return ((c1 < c2) ? (-1) : 1);
- }
- return
- ((length1 == length2)
- ? 0
- : ((length1 < length2) ? (-1) : 1));
-}
-
-static int
-DEFUN (find_option_argument, (name), CONST char * name)
-{
- CONST char ** scan = Saved_argv;
- CONST char ** end = (scan + Saved_argc);
- while (scan < end)
- if ((string_compare_ci (name, (*scan++))) == 0)
- return ((scan - Saved_argv) - 1);
- return (-1);
-}
-
-int
-DEFUN (boolean_option_argument, (name), CONST char * name)
-{
- return ((find_option_argument (name)) >= 0);
-}
-
-CONST char *
-DEFUN (string_option_argument, (name), CONST char * name)
-{
- int position = (find_option_argument (name));
- if (position == (Saved_argc - 1))
- {
- fprintf (stderr, "%s: %s option requires an argument name\n\n",
- (Saved_argv[0]), name);
- fflush (stderr);
- exit (1);
- }
- return ((position < 0) ? 0 : (Saved_argv [position + 1]));
-}
-
-long
-DEFUN (numeric_option_argument, (name, defval),
- CONST char * name AND
- long defval)
-{
- CONST char * option = (string_option_argument (name));
- return ((option == 0) ? defval : (atoi (option)));
-}
-\f
-/* Used to test whether it is a dumped executable version */
-
-extern Boolean scheme_dumped_p;
-Boolean scheme_dumped_p = false;
-
-int dumped_heap_size;
-int dumped_stack_size;
-int dumped_constant_size;
-
-static void
-DEFUN (find_image_parameters, (file_name, cold_load_p, supplied_p),
- CONST char ** file_name AND
- Boolean * cold_load_p AND
- Boolean * supplied_p)
-{
- Boolean found_p = false;
- (*supplied_p) = false;
- (*cold_load_p) = false;
- (*file_name) = DEFAULT_BAND_NAME;
- if (!scheme_dumped_p)
- {
- Heap_Size = HEAP_SIZE;
- Stack_Size = STACK_SIZE;
- Constant_Size = CONSTANT_SIZE;
- }
- else
- {
- dumped_heap_size = Heap_Size;
- dumped_stack_size = Stack_Size;
- dumped_constant_size = Constant_Size;
- }
- /* This does not set found_p because the image spec. can be
- overridden by the options below. It just sets different
- defaults. */
- if (boolean_option_argument ("-compiler"))
- {
- (*supplied_p) = true;
- (*file_name) = DEFAULT_COMPILER_BAND;
- Heap_Size = COMPILER_HEAP_SIZE;
- Stack_Size = COMPILER_STACK_SIZE;
- Constant_Size = COMPILER_CONSTANT_SIZE;
- }
- /* Exclusive image specs. */
- {
- CONST char * band_name = (string_option_argument ("-band"));
- if (band_name != 0)
- {
- if (found_p)
- usage ("Multiple image parameters specified!");
- found_p = true;
- (*supplied_p) = true;
- (*file_name) = band_name;
- }
- }
- {
- CONST char * fasl_name = (string_option_argument ("-fasl"));
- if (fasl_name != 0)
- {
- if (found_p)
- usage ("Multiple image parameters specified!");
- found_p = true;
- (*supplied_p) = true;
- (*cold_load_p) = true;
- (*file_name) = fasl_name;
- }
- }
- Heap_Size = (numeric_option_argument ("-heap", Heap_Size));
- Stack_Size = (numeric_option_argument ("-stack", Stack_Size));
- Constant_Size = (numeric_option_argument ("-constant", Constant_Size));
- if (scheme_dumped_p
- && ((Heap_Size != dumped_heap_size)
- || (Stack_Size != dumped_stack_size)
- || (Constant_Size != dumped_constant_size)))
- {
- fprintf (stderr, "%s warning: Allocation parameters ignored.\n",
- (Saved_argv[0]));
- fflush (stderr);
- Heap_Size = dumped_heap_size;
- Stack_Size = dumped_stack_size;
- Constant_Size = dumped_constant_size;
- }
+ termination_init_error ();
}
\f
/* Exit is done in a different way on some operating systems (eg. VMS) */
-EXIT_SCHEME_DECLARATIONS;
-
-forward void Start_Scheme ();
-forward void Enter_Interpreter ();
-extern void Clear_Memory ();
-extern void Setup_Memory ();
-PTR initial_C_stack_pointer;
+#ifndef main_type
+#define main_type void
+#endif
main_type
main (argc, argv)
int argc;
CONST char ** argv;
{
- Boolean cold_load_p, supplied_p;
- CONST char * file_name;
- extern void compiler_initialize ();
-
- INIT_EXIT_SCHEME ();
-
- Saved_argc = argc;
- Saved_argv = argv;
+ init_exit_scheme ();
+ scheme_program_name = (argv[0]);
initial_C_stack_pointer = (&argc);
obstack_init (&scratch_obstack);
-
- find_image_parameters (&file_name, &cold_load_p, &supplied_p);
-
+ read_command_line_options (argc, argv);
if (scheme_dumped_p)
- {
- OS_reset ();
- if (!supplied_p)
{
- printf ("Scheme Microcode Version %d.%d\n", VERSION, SUBVERSION);
- OS_initialize ();
- Enter_Interpreter ();
+ if (! ((Heap_Size == option_heap_size)
+ && (Stack_Size == option_stack_size)
+ && (Constant_Size == option_constant_size)))
+ {
+ fprintf (stderr, "%s: warning: ignoring allocation parameters.\n",
+ scheme_program_name);
+ fflush (stderr);
+ }
+ OS_reset ();
+ if (!option_band_specified)
+ {
+ printf ("Scheme Microcode Version %d.%d\n", VERSION, SUBVERSION);
+ OS_initialize ();
+ Enter_Interpreter ();
+ }
+ else
+ {
+ Clear_Memory ((BLOCKS_TO_BYTES (Heap_Size)),
+ (BLOCKS_TO_BYTES (Stack_Size)),
+ (BLOCKS_TO_BYTES (Constant_Size)));
+ /* We are reloading from scratch anyway. */
+ scheme_dumped_p = false;
+ if (option_fasl_file)
+ Start_Scheme (BOOT_FASLOAD, option_fasl_file);
+ else
+ Start_Scheme (BOOT_LOAD_BAND, option_band_file);
+ }
}
- else
+ else
{
- Clear_Memory ((BLOCKS_TO_BYTES (Heap_Size)),
+ Heap_Size = option_heap_size;
+ Stack_Size = option_stack_size;
+ Constant_Size = option_constant_size;
+ Setup_Memory ((BLOCKS_TO_BYTES (Heap_Size)),
(BLOCKS_TO_BYTES (Stack_Size)),
(BLOCKS_TO_BYTES (Constant_Size)));
- /* We are reloading from scratch anyway. */
- scheme_dumped_p = false;
- Start_Scheme ((cold_load_p ? BOOT_FASLOAD : BOOT_LOAD_BAND),
- file_name);
+ if (option_fasl_file)
+ {
+ compiler_initialize (1);
+ Start_Scheme (BOOT_FASLOAD, option_fasl_file);
+ }
+ else
+ {
+ compiler_initialize (0);
+ Start_Scheme (BOOT_LOAD_BAND, option_band_file);
+ }
}
- }
- else
- {
- Command_Line_Hook();
- Setup_Memory ((BLOCKS_TO_BYTES (Heap_Size)),
- (BLOCKS_TO_BYTES (Stack_Size)),
- (BLOCKS_TO_BYTES (Constant_Size)));
- compiler_initialize ((long) cold_load_p);
- Start_Scheme ((cold_load_p ? BOOT_FASLOAD : BOOT_LOAD_BAND),
- file_name);
- }
- exit (1);
+ termination_init_error ();
}
\f
-#define Default_Init_Fixed_Objects(Fixed_Objects) \
-{ \
- Fixed_Objects = (make_fixed_objects_vector ()); \
-}
-
SCHEME_OBJECT
make_fixed_objects_vector ()
{
Boolean I_Am_Master = (Start_Prim != BOOT_GET_WORK);
if (I_Am_Master)
{
- fprintf (stdout, "Scheme Microcode Version %d.%d\n", VERSION, SUBVERSION);
+ fprintf (stdout, "Scheme Microcode Version %d.%d\n",
+ VERSION, SUBVERSION);
fflush (stdout);
}
OS_initialize ();
{
Current_State_Point = SHARP_F;
Fluid_Bindings = EMPTY_LIST;
- Init_Fixed_Objects ();
+ INIT_FIXED_OBJECTS ();
}
/* The initial program to execute is one of
if ((Stack_Pointer <= Stack_Guard) || (Free > MemTop))
{
fprintf (stderr, "Configuration won't hold initial data.\n");
- Microcode_Termination (TERM_EXIT);
+ termination_init_error ();
}
+#ifdef ENTRY_HOOK
ENTRY_HOOK ();
- Enter_Interpreter();
- /*NOTREACHED*/
+#endif
+ Enter_Interpreter ();
}
void
-Enter_Interpreter()
+Enter_Interpreter ()
{
Interpret (scheme_dumped_p);
fprintf (stderr, "\nThe interpreter returned to top level!\n");
- fflush (stderr);
Microcode_Termination (TERM_EXIT);
- /*NOTREACHED*/
}
\f
/* Garbage collection debugging utilities. */
DEFINE_PRIMITIVE ("MICROCODE-TABLES-FILENAME", Prim_microcode_tables_filename, 0, 0, 0)
{
PRIMITIVE_HEADER (0);
- {
- CONST char * file_name = (string_option_argument ("-utabmd"));
- if (file_name == 0)
- file_name = (string_option_argument ("-utab"));
- if (file_name != 0)
- PRIMITIVE_RETURN (char_pointer_to_string (file_name));
- }
- {
- SCHEME_OBJECT result =
- (allocate_string ((strlen (SCHEME_SOURCES_PATH))
- + (strlen (UCODE_TABLES_FILENAME))));
- char * scan_result = ((char *) (STRING_LOC (result, 0)));
- {
- CONST char * scan = SCHEME_SOURCES_PATH;
- CONST char * end = (scan + (strlen (SCHEME_SOURCES_PATH)));
- while (scan < end)
- (*scan_result++) = (*scan++);
- }
- {
- CONST char * scan = UCODE_TABLES_FILENAME;
- CONST char * end = (scan + (strlen (UCODE_TABLES_FILENAME)));
- while (scan < end)
- (*scan_result++) = (*scan++);
- }
- PRIMITIVE_RETURN (result);
- }
+ PRIMITIVE_RETURN (char_pointer_to_string (option_utabmd_file));
+}
+
+static SCHEME_OBJECT
+DEFUN (argv_to_object, (argc, argv), int argc AND CONST char ** argv)
+{
+ SCHEME_OBJECT result = (allocate_marked_vector (TC_VECTOR, argc, 1));
+ CONST char ** scan = argv;
+ CONST char ** end = (scan + argc);
+ SCHEME_OBJECT * scan_result = (VECTOR_LOC (result, 0));
+ while (scan < end)
+ (*scan_result++) = (char_pointer_to_string (*scan++));
+ return (result);
}
DEFINE_PRIMITIVE ("GET-COMMAND-LINE", Prim_get_command_line, 0, 0, 0)
{
PRIMITIVE_HEADER (0);
- {
- SCHEME_OBJECT result = (allocate_marked_vector (TC_VECTOR, Saved_argc, 1));
- CONST char ** scan = Saved_argv;
- CONST char ** end = (scan + Saved_argc);
- SCHEME_OBJECT * scan_result = (VECTOR_LOC (result, 0));
- while (scan < end)
- (*scan_result++) = (char_pointer_to_string (*scan++));
- PRIMITIVE_RETURN (result);
- }
+ PRIMITIVE_RETURN (argv_to_object (option_saved_argc, option_saved_argv));
+}
+
+DEFINE_PRIMITIVE ("GET-UNUSED-COMMAND-LINE", Prim_get_unused_command_line, 0, 0, 0)
+{
+ PRIMITIVE_HEADER (0);
+ PRIMITIVE_RETURN (argv_to_object (option_unused_argc, option_unused_argv));
}
/* -*-C-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/Attic/config.h,v 9.56 1990/09/08 00:10:16 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/Attic/config.h,v 9.57 1990/11/13 08:44:20 cph Exp $
Copyright (c) 1987, 1988, 1989, 1990 Massachusetts Institute of Technology
#define ADDRESS_TO_DATUM(address) \
((SCHEME_OBJECT) (((unsigned long) (address)) & (~(HPPA_QUAD_BIT))))
-/* HPPA compiled binaries are large! */
-
-#ifdef HAS_COMPILER_SUPPORT
-#ifndef CONSTANT_SIZE
-#define CONSTANT_SIZE 600 /* Default Kcells for constant */
-#endif
-#endif
-
-#ifndef COMPILER_CONSTANT_SIZE
-#define COMPILER_CONSTANT_SIZE 1300
-#endif
-
#endif /* hp9000s800 */
#ifdef hp9000s500
#include <public.h>
#define HAS_FREXP
#define HAS_MODF
-#define STACK_SIZE 4 /* 4K objects */
#endif
#ifdef i386
((SCHEME_OBJECT) (((unsigned long) (address)) & (~(MIPS_DATA_BIT))))
/* MIPS compiled binaries are large! */
-
#ifdef HAS_COMPILER_SUPPORT
-#ifndef CONSTANT_SIZE
-#define CONSTANT_SIZE 700 /* Default Kcells for constant */
-#endif
+
+#ifndef DEFAULT_SMALL_CONSTANT
+#define DEFAULT_SMALL_CONSTANT 700
#endif
-#ifndef COMPILER_CONSTANT_SIZE
-#define COMPILER_CONSTANT_SIZE 1500
+#ifndef DEFAULT_LARGE_CONSTANT
+#define DEFAULT_LARGE_CONSTANT 1500
#endif
+#endif /* HAS_COMPILER_SUPPORT */
+
#endif /* mips */
\f
/* These (pdp10 and nu) haven't worked in a while.
#undef UNSIGNED_SHIFT_BUG
#undef Conditional_Bug
#endif
-
-/* Default "segment" sizes */
-
-#ifndef STACK_SIZE
-#ifndef USE_STACKLETS
-#define STACK_SIZE 100 /* Default Kcells for stack */
-#else
-#define STACK_SIZE 256 /* Default stacklet size */
-#endif
-#endif
-
-#ifndef CONSTANT_SIZE
-#define CONSTANT_SIZE 400 /* Default Kcells for constant */
-#endif
-
-#ifndef HEAP_SIZE
-#define HEAP_SIZE 250 /* Default Kcells for each heap */
-#endif
-
-#ifndef COMPILER_STACK_SIZE
-#define COMPILER_STACK_SIZE STACK_SIZE
-#endif
-
-#ifndef COMPILER_HEAP_SIZE
-#define COMPILER_HEAP_SIZE 1000
-#endif
-
-#ifndef COMPILER_CONSTANT_SIZE
-#define COMPILER_CONSTANT_SIZE 1000
-#endif
/* -*-C-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/Attic/default.h,v 9.34 1990/09/08 00:10:25 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/Attic/default.h,v 9.35 1990/11/13 08:44:27 cph Rel $
Copyright (c) 1988, 1989, 1990 Massachusetts Institute of Technology
#define Test_Pure_Space_Top(New_Top) ((New_Top) <= Constant_Top)
#endif
\f
-/* Used in boot.c */
-
-#ifndef main_type
-#define main_type void
-#endif
-
-#ifndef Command_Line_Hook
-#define Command_Line_Hook()
-#endif
-
-#ifndef EXIT_SCHEME_DECLARATIONS
-#define EXIT_SCHEME_DECLARATIONS
-#endif
-
-#ifndef INIT_EXIT_SCHEME
-#define INIT_EXIT_SCHEME()
-#endif
-
-#ifndef EXIT_SCHEME
-#define EXIT_SCHEME exit
-#endif
-
-/* Used in various places. */
-
-#ifndef Init_Fixed_Objects
-#define Init_Fixed_Objects() \
- Default_Init_Fixed_Objects(Fixed_Objects)
-#endif
-
-#ifndef Set_Fixed_Obj_Hook
-#define Set_Fixed_Obj_Hook(New_Vector) \
- Fixed_Objects = New_Vector
-#endif
-
/* Used in debug.c */
#ifndef Back_Trace_Entry_Hook
#define SITE_RETURN_DISPATCH_HOOK()
#endif
-#ifndef DOWNWARD_COERCE_FLONUM_P
-#define DOWNWARD_COERCE_FLONUM_P(number) 0
-#endif
-
#ifndef FASLOAD_RELOCATE_HOOK
#define FASLOAD_RELOCATE_HOOK(heap_low, heap_high, constant_low, constant_high)
#endif
/* -*-C-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/Attic/dmpwrld.c,v 9.32 1990/07/28 18:56:45 jinx Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/Attic/dmpwrld.c,v 9.33 1990/11/13 08:44:33 cph Exp $
Copyright (c) 1987, 1988, 1989, 1990 Massachusetts Institute of Technology
* fname,
path_buffer[FILE_NAME_LENGTH];
extern
- char ** Saved_Argv;
+ char * scheme_program_name;
PRIMITIVE_HEADER (1);
PRIMITIVE_CANONICALIZE_CONTEXT();
/* Dump! */
- unix_find_pathname ((Saved_argv[0]), path_buffer);
+ unix_find_pathname (scheme_program_name, path_buffer);
result = (unexec (fname,
path_buffer,
((unsigned) 0), /* default */
/* -*-C-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/extern.h,v 9.38 1990/10/03 15:14:36 jinx Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/extern.h,v 9.39 1990/11/13 08:44:37 cph Rel $
Copyright (c) 1987, 1988, 1989, 1990 Massachusetts Institute of Technology
extern SCHEME_OBJECT * Prev_Restore_History_Stacklet;
extern long Prev_Restore_History_Offset;
-extern int Saved_argc;
-extern CONST char ** Saved_argv;
+extern CONST char * scheme_program_name;
extern CONST char * OS_Name;
extern CONST char * OS_Variant;
extern struct obstack scratch_obstack;
extern SCHEME_OBJECT char_pointer_to_string ();
/* Random and OS utilities */
-extern int EXFUN (boolean_option_argument, (CONST char * name));
-extern CONST char * EXFUN (string_option_argument, (CONST char * name));
-extern long EXFUN (numeric_option_argument, (CONST char * name, long defval));
extern Boolean Restore_History ();
extern Boolean interpreter_applicable_p ();
extern void EXFUN
extern void EXFUN (Microcode_Termination, (int code));
extern void EXFUN (termination_normal, (void));
+extern void EXFUN (termination_init_error, (void));
extern void EXFUN (termination_end_of_computation, (void));
extern void EXFUN (termination_trap, (void));
extern void EXFUN (termination_no_error_handler, (void));
/* -*-C-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/hooks.c,v 9.39 1990/06/20 17:40:58 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/hooks.c,v 9.40 1990/11/13 08:44:43 cph Exp $
Copyright (c) 1988, 1989, 1990 Massachusetts Institute of Technology
PRIMITIVE_RETURN (SHARP_F);
}
+#ifndef SET_FIXED_OBJ_HOOK
+#define SET_FIXED_OBJ_HOOK(vector) Fixed_Objects = (vector)
+#endif
+
DEFINE_PRIMITIVE ("SET-FIXED-OBJECTS-VECTOR!", Prim_set_fixed_objects_vector, 1, 1, 0)
{
PRIMITIVE_HEADER (1);
((Valid_Fixed_Obj_Vector ())
? (Get_Fixed_Obj_Slot (Me_Myself))
: SHARP_F);
- Set_Fixed_Obj_Hook (vector);
+ SET_FIXED_OBJ_HOOK (vector);
Set_Fixed_Obj_Slot (Me_Myself, vector);
PRIMITIVE_RETURN (result);
}
/* -*-C-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/hppacach.h,v 1.1 1990/08/08 20:20:56 jinx Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/hppacach.h,v 1.2 1990/11/13 08:44:50 cph Exp $
Copyright (c) 1990 Massachusetts Institute of Technology
MIT in each case. */
#ifndef HPPACACHE_H /* Prevent multiple inclusion */
-
#define HPPACACHE_H
-#ifdef C_SCHEME
-#include "paths.h"
-#define CACHE_FILENAME_PATH SCHEME_SOURCES_PATH
+#ifdef MIT_SCHEME
+#include "option.h"
+#define CACHE_FILENAME "%s/%s.cache"
+#define CACHE_FILENAME_PATH "/usr/local/lib/mit-scheme"
#define MODELS_FILENAME "HPPAmodels"
#endif
/* -*-C-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/osscheme.h,v 1.1 1990/06/20 19:36:35 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/osscheme.h,v 1.2 1990/11/13 08:44:54 cph Rel $
Copyright (c) 1990 Massachusetts Institute of Technology
extern Tchannel EXFUN (arg_channel, (int arg_number));
extern Tchannel EXFUN (arg_channel_old, (int arg_number));
-extern int EXFUN (boolean_option_argument, (CONST char * name));
+extern int option_emacs_subprocess;
extern int EXFUN (executing_scheme_primitive_p, (void));
extern void EXFUN (termination_eof, (void));
extern void EXFUN (termination_normal, (void));
+extern void EXFUN (termination_init_error, (void));
extern void EXFUN (termination_signal, (CONST char * signal_name));
extern void EXFUN (termination_trap, (void));
-/* Perhaps this should be different. */
-#define termination_init_error termination_normal
extern void EXFUN (request_character_interrupt, (void));
extern void EXFUN (request_timer_interrupt, (void));
/* -*-C-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/term.c,v 1.3 1990/11/01 04:33:17 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/term.c,v 1.4 1990/11/13 08:44:58 cph Rel $
Copyright (c) 1990 Massachusetts Institute of Technology
extern void EXFUN (get_band_parameters, (long * heap_size, long * const_size));
extern void EXFUN (Reset_Memory, (void));
-#ifndef EXIT_HOOK
-#define EXIT_HOOK()
-#endif
-
#define BYTES_TO_BLOCKS(n) (((n) + 1023) / 1024)
#define MIN_HEAP_DELTA 50
+
+#ifndef EXIT_SCHEME
+#define EXIT_SCHEME exit
+#endif
+
+#ifdef EXIT_SCHEME_DECLARATIONS
+EXIT_SCHEME_DECLARATIONS;
+#endif
+
+void
+DEFUN_VOID (init_exit_scheme)
+{
+#ifdef INIT_EXIT_SCHEME
+ INIT_EXIT_SCHEME ();
+#endif
+}
\f
static void
DEFUN (attempt_termination_backout, (code), int code)
{
+ fflush (stderr);
if ((WITHIN_CRITICAL_SECTION_P ())
|| (code == TERM_HALT)
|| (! (Valid_Fixed_Obj_Vector ())))
}
}
}
-
+\f
static void
DEFUN (termination_prefix, (code), int code)
{
DEFUN (termination_suffix, (code, value, abnormal_p),
int code AND int value AND int abnormal_p)
{
+#ifdef EXIT_HOOK
+ EXIT_HOOK (code, value, abnormal_p);
+#endif
fflush (stdout);
Reset_Memory ();
- EXIT_HOOK ();
EXIT_SCHEME (value);
}
termination_suffix (TERM_HALT, 0, 0);
}
+void
+DEFUN_VOID (termination_init_error)
+{
+ termination_prefix (TERM_EXIT);
+ termination_suffix (TERM_EXIT, 1, 1);
+}
+
void
DEFUN_VOID (termination_end_of_computation)
{
termination_prefix (TERM_TRAP);
termination_suffix (TERM_TRAP, 1, 0);
}
-
+\f
void
DEFUN_VOID (termination_no_error_handler)
{
/* -*-C-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/unxutl/Attic/ymkfile,v 1.31 1990/11/08 11:14:11 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/unxutl/Attic/ymkfile,v 1.32 1990/11/13 08:45:37 cph Exp $
Copyright (c) 1989, 1990 Massachusetts Institute of Technology
lookup.c \
memmag.c \
obstack.c \
+option.c \
osscheme.c \
ostty.c \
prim.c \
lookprm.o \
lookup.o \
obstack.o \
+option.o \
osscheme.o \
ostty.o \
prim.o \
chmod g+s hppacache
./hppacache -dump
-hppacache : hppacache.c hppacache.h
- $(CC) -DC_SCHEME -o hppacache hppacache.c
+hppacache : hppacache.c hppacache.h option.h
+ $(CC) $(CFLAGS) -o hppacache hppacache.c
lint.out : $(SOURCES) $(SCHEME_SOURCES) $(CSRC) usrdef.c $(HEAD_FILES)
rm -f lint.out
char.o string.o : scheme.touch prims.h
tterm.o : scheme.touch prims.h osterm.h
-boot.o : scheme.touch prims.h version.h paths.h ostop.h
+boot.o : scheme.touch prims.h version.h option.h ostop.h
+option.o : ansidecl.h option.h
term.o : scheme.touch
compiler.o : config.h object.h sdata.h types.h errors.h const.h returns.h
-bchmmg.o bchgcl.o bchpur.o : scheme.touch prims.h bchgcc.h oscond.h $(GC_HEAD_FILES)
+bchmmg.o bchgcl.o bchpur.o : scheme.touch prims.h bchgcc.h option.h oscond.h $(GC_HEAD_FILES)
bchdmp.o : scheme.touch prims.h bchgcc.h oscond.h $(GC_HEAD_FILES) fasl.h dump.c
syntax.o : scheme.touch prims.h edwin.h syntax.h
uxsig.o : ossig.h osctty.h ostty.h uxtrap.h uxutil.h critsec.h
uxsock.o : uxsock.h osio.h uxio.h
uxterm.o : osterm.h uxterm.h osio.h uxio.h
-uxtop.o : ostop.h uxtop.h osctty.h uxutil.h errors.h
-uxtrap.o : scheme.touch uxtrap.h uxutil.h $(GC_HEAD_FILES)
+uxtop.o : ostop.h uxtop.h osctty.h uxutil.h errors.h option.h
+uxtrap.o : scheme.touch uxtrap.h uxutil.h option.h $(GC_HEAD_FILES)
uxtty.o : ostty.h osenv.h osio.h uxio.h osterm.h uxterm.h
uxutil.o : uxutil.h
pruxfs.o : osfs.h
/* -*-C-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/ux.h,v 1.13 1990/11/08 11:10:08 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/ux.h,v 1.14 1990/11/13 08:45:03 cph Exp $
Copyright (c) 1988, 1989, 1990 Massachusetts Institute of Technology
#include "dstack.h"
#include "osscheme.h"
-extern int parent_process_is_emacs;
-
extern void EXFUN (error_system_call, (int code, CONST char * name));
\f
/* Conditionalizations that are overridden by _POSIX. */
/* -*-C-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/uxsig.c,v 1.3 1990/08/27 20:08:39 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/uxsig.c,v 1.4 1990/11/13 08:45:09 cph Exp $
Copyright (c) 1990 Massachusetts Institute of Technology
DEFUN_STD_HANDLER (sighnd_terminate,
(termination_signal
- ((! (parent_process_is_emacs && (signo == SIGHUP)))
+ ((! (option_emacs_subprocess && (signo == SIGHUP)))
? (find_signal_name (signo))
: 0)))
\f
bind_handler (SIGUSR2, sighnd_renice);
#endif
bind_handler (SIGCHLD, sighnd_dead_subprocess);
- if ((isatty (STDIN_FILENO)) || parent_process_is_emacs)
+ if ((isatty (STDIN_FILENO)) || option_emacs_subprocess)
{
- if (!parent_process_is_emacs)
+ if (!option_emacs_subprocess)
bind_handler (SIGHUP, sighnd_save_then_terminate);
bind_handler (SIGQUIT, sighnd_interactive);
bind_handler (SIGPWR, sighnd_save_then_terminate);
#define INTERACTIVE_NEWLINE() \
{ \
- if (!parent_process_is_emacs) \
+ if (!option_emacs_subprocess) \
{ \
putc ('\n', stdout); \
fflush (stdout); \
static void
DEFUN (interactive_interrupt_handler, (scp), struct FULL_SIGCONTEXT * scp)
{
- if (!parent_process_is_emacs)
+ if (!option_emacs_subprocess)
{
fputs ((OS_tty_command_beep ()), stdout);
putc ('\n', stdout);
}
while (1)
{
- if (!parent_process_is_emacs)
+ if (!option_emacs_subprocess)
{
fprintf (stdout, "Interrupt option (? for help): ");
fflush (stdout);
termination_normal ();
return;
case '\f':
- if (!parent_process_is_emacs)
+ if (!option_emacs_subprocess)
{
fputs ((OS_tty_command_clear ()), stdout);
fflush (stdout);
return;
case 'H':
case 'h':
- if (!parent_process_is_emacs)
+ if (!option_emacs_subprocess)
print_interrupt_chars ();
break;
case 'I':
case 'i':
- if (!parent_process_is_emacs)
+ if (!option_emacs_subprocess)
{
fputs ("Ignored. Resuming Scheme.\n", stdout);
fflush (stdout);
}
return;
default:
- if (!parent_process_is_emacs)
+ if (!option_emacs_subprocess)
print_interactive_help ();
break;
}
/* -*-C-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/uxtop.c,v 1.6 1990/11/08 11:13:28 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/uxtop.c,v 1.7 1990/11/13 08:45:15 cph Rel $
Copyright (c) 1990 Massachusetts Institute of Technology
#include "osctty.h"
#include "uxutil.h"
#include "errors.h"
+#include "option.h"
extern void EXFUN (UX_initialize_channels, (void));
extern void EXFUN (UX_initialize_ctty, (int interactive));
extern CONST char * OS_Name;
extern CONST char * OS_Variant;
\f
-int parent_process_is_emacs;
static int interactive;
int
DEFUN_VOID (OS_under_emacs_p)
{
- return (parent_process_is_emacs);
+ return (option_emacs_subprocess);
}
void
dstack_initialize ();
transaction_initialize ();
initialize_interruptable_extent ();
- parent_process_is_emacs = (boolean_option_argument ("-emacs"));
{
interactive =
- ((isatty (STDIN_FILENO)) ||
- (isatty (STDOUT_FILENO)) ||
- (isatty (STDERR_FILENO)) ||
- (boolean_option_argument ("-interactive")));
+ (option_force_interactive
+ || (isatty (STDIN_FILENO))
+ || (isatty (STDOUT_FILENO))
+ || (isatty (STDERR_FILENO)));
/* If none of the stdio streams is a terminal, disassociate us
from the controlling terminal so that we're not affected by
keyboard interrupts or hangup signals. However, if we're
running under Emacs we don't want to do this, because we want
to receive a hangup signal if Emacs dies. */
- if ((!interactive) && (!parent_process_is_emacs))
+ if ((!interactive) && (!option_emacs_subprocess))
UX_setsid ();
/* The argument passed to `UX_ctty_initialize' says whether to
permit interrupt control, i.e. whether to attempt to setup the
OS_Name = SYSTEM_NAME;
OS_Variant = SYSTEM_VARIANT;
fprintf (stdout, "MIT Scheme running under %s\n", OS_Variant);
- if ((!parent_process_is_emacs) && (OS_ctty_interrupt_control ()))
+ if ((!option_emacs_subprocess) && (OS_ctty_interrupt_control ()))
{
fputs ("", stdout);
fprintf (stdout, "Type %s followed by `H' to obtain information about interrupts.\n",
fputs ("\nScheme has terminated abnormally!\n", stdout);
{
int dump_core =
- ((! (boolean_option_argument ("-nocore")))
+ ((!option_disable_core_dump)
&& (userio_confirm ("Would you like a core dump? [Y or N] "))
&& (userio_confirm ("Do you really want a core dump? [Y or N] ")));
putc ('\n', stdout);
/* -*-C-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/uxtrap.c,v 1.4 1990/08/09 19:52:20 jinx Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/uxtrap.c,v 1.5 1990/11/13 08:45:19 cph Exp $
Copyright (c) 1990 Massachusetts Institute of Technology
#include "ux.h"
#include "uxtrap.h"
#include "uxutil.h"
+#include "option.h"
extern CONST char * EXFUN (find_signal_name, (int signo));
extern void EXFUN (UX_dump_core, (void));
static void
DEFUN_VOID (trap_dump_core)
{
- if (boolean_option_argument ("-nocore"))
+ if (option_disable_core_dump)
{
fputs (">> Core dumps are disabled - Terminating normally.\n", stdout);
fflush (stdout);
/* -*-C-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/uxtty.c,v 1.3 1990/11/05 11:55:43 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/uxtty.c,v 1.4 1990/11/13 08:45:26 cph Rel $
Copyright (c) 1990 Massachusetts Institute of Technology
char termcap_buffer [TERMCAP_BUFFER_SIZE];
char * tbp = tgetstr_buffer;
CONST char * term;
- if ((isatty (STDOUT_FILENO)) &&
- (!parent_process_is_emacs) &&
- ((term = (getenv ("TERM"))) != 0) &&
- ((tgetent (termcap_buffer, term)) > 0))
+ if ((isatty (STDOUT_FILENO))
+ && (!option_emacs_subprocess)
+ && ((term = (getenv ("TERM"))) != 0)
+ && ((tgetent (termcap_buffer, term)) > 0))
{
tty_x_size = (tgetnum ("co"));
tty_y_size = (tgetnum ("li"));
/* -*-C-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/Attic/version.h,v 11.52 1990/11/08 11:14:54 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/Attic/version.h,v 11.53 1990/11/13 08:45:31 cph Exp $
Copyright (c) 1988, 1989, 1990 Massachusetts Institute of Technology
#define VERSION 11
#endif
#ifndef SUBVERSION
-#define SUBVERSION 52
+#define SUBVERSION 53
#endif
#ifndef UCODE_TABLES_FILENAME
/* -*-C-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/microcode/version.h,v 11.52 1990/11/08 11:14:54 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/microcode/version.h,v 11.53 1990/11/13 08:45:31 cph Exp $
Copyright (c) 1988, 1989, 1990 Massachusetts Institute of Technology
#define VERSION 11
#endif
#ifndef SUBVERSION
-#define SUBVERSION 52
+#define SUBVERSION 53
#endif
#ifndef UCODE_TABLES_FILENAME
projects / mit-scheme.git / commitdiff