/* -*-C-*- $Id: boot.c,v 9.105 2001/07/31 03:10:57 cph Exp $ Copyright (c) 1988-2001 Massachusetts Institute of Technology This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program; if not, write to the Free Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. */ /* This file contains `main' and associated startup code. */ #include "scheme.h" #include "prims.h" #include "version.h" #include "option.h" #ifndef islower #include #endif #include "ostop.h" #include "ostty.h" extern PTR EXFUN (malloc, (unsigned int size)); extern void EXFUN (free, (PTR ptr)); extern void EXFUN (init_exit_scheme, (void)); extern void EXFUN (Clear_Memory, (int, int, int)); extern void EXFUN (Setup_Memory, (int, int, int)); extern void EXFUN (compiler_initialize, (long fasl_p)); extern SCHEME_OBJECT EXFUN (make_primitive, (char *, int)); extern void EXFUN (OS_announcement, (void)); extern SCHEME_OBJECT EXFUN (char_pointer_to_symbol, (unsigned char *)); static void EXFUN (Start_Scheme, (int, CONST char *)); static void EXFUN (Enter_Interpreter, (void)); CONST char * scheme_program_name; CONST char * OS_Name; CONST char * OS_Variant; struct obstack scratch_obstack; PTR initial_C_stack_pointer; static char * reload_saved_string; static unsigned int reload_saved_string_length; /* If true, this is an executable created by dump-world. */ Boolean scheme_dumped_p = false; PTR DEFUN (obstack_chunk_alloc, (size), unsigned int size) { PTR result = (malloc (size)); if (result == 0) { outf_fatal ("\n%s: unable to allocate obstack chunk of %d bytes\n", scheme_program_name, size); Microcode_Termination (TERM_EXIT); } return (result); } #define obstack_chunk_free free #ifndef INIT_FIXED_OBJECTS #define INIT_FIXED_OBJECTS initialize_fixed_objects_vector #endif /* Declare the outermost critical section. */ DECLARE_CRITICAL_SECTION (); #define BLOCKS_TO_BYTES(n) ((n) * 1024) /* Exit is done in a different way on some operating systems (eg. VMS) */ #ifndef main_name #define main_name main #endif #define FILE_READABLE(filename) ((access ((filename), 4)) >= 0) int DEFUN (main_name, (argc, argv), int argc AND CONST char ** argv) { init_exit_scheme (); scheme_program_name = (argv[0]); initial_C_stack_pointer = ((PTR) (&argc)); #ifdef __WIN32__ { extern void NT_initialize_win32_system_utilities(); NT_initialize_win32_system_utilities (); } #endif #ifdef PREALLOCATE_HEAP_MEMORY PREALLOCATE_HEAP_MEMORY (); #endif #ifdef __OS2__ { extern void OS2_initialize_early (void); OS2_initialize_early (); } #endif obstack_init (&scratch_obstack); dstack_initialize (); transaction_initialize (); reload_saved_string = 0; reload_saved_string_length = 0; read_command_line_options (argc, argv); if (scheme_dumped_p) { extern SCHEME_OBJECT compiler_utilities; extern void EXFUN (compiler_reset, (SCHEME_OBJECT)); if (! ((Heap_Size == ((long) option_heap_size)) && (Stack_Size == ((long) option_stack_size)) && (Constant_Size == ((long) option_constant_size)))) { outf_error ("%s: warning: ignoring allocation parameters.\n", scheme_program_name); outf_flush_error (); } OS_reset (); compiler_reset (compiler_utilities); if (!option_band_specified) { outf_console ("Scheme Microcode Version %d.%d\n", SCHEME_VERSION, SCHEME_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 { extern void EXFUN (initialize_primitives, (void)); 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))); #ifdef EMPTY_LIST_VALUE /* EMPTY_LIST_VALUE is defined if it is teh true value for '() and EMPTY_LIST is a location used to store '() or #F */ if (option_empty_list_eq_false) EMPTY_LIST = SHARP_F; else EMPTY_LIST = EMPTY_LIST_VALUE; #endif initialize_primitives (); if (! option_fasl_file) { compiler_initialize (0); Start_Scheme (BOOT_LOAD_BAND, option_band_file); } #ifdef NATIVE_CODE_IS_C else if (! (FILE_READABLE (option_fasl_file))) { compiler_initialize (1); Start_Scheme (BOOT_EXECUTE, option_fasl_file); } #endif /* NATIVE_CODE_IS_C */ else { compiler_initialize (1); Start_Scheme (BOOT_FASLOAD, option_fasl_file); } } termination_init_error (); return (0); } static SCHEME_OBJECT DEFUN (names_to_vector, (length, names), unsigned int length AND unsigned char ** names) { SCHEME_OBJECT v = (allocate_marked_vector (TC_VECTOR, length, 1)); unsigned int i; for (i = 0; (i < length); i += 1) { VECTOR_SET (v, i, (char_pointer_to_symbol (names [i]))); } return (v); } static SCHEME_OBJECT DEFUN_VOID (fixed_objects_syscall_names) { unsigned int length; unsigned char ** names; extern void EXFUN (OS_syscall_names, (unsigned int *, unsigned char ***)); OS_syscall_names ((&length), (&names)); return (names_to_vector (length, names)); } static SCHEME_OBJECT DEFUN_VOID (fixed_objects_syserr_names) { unsigned int length; unsigned char ** names; extern void EXFUN (OS_syserr_names, (unsigned int *, unsigned char ***)); OS_syserr_names ((&length), (&names)); return (names_to_vector (length, names)); } void DEFUN_VOID (initialize_fixed_objects_vector) { extern SCHEME_OBJECT EXFUN (initialize_history, (void)); extern SCHEME_OBJECT EXFUN (initialize_interrupt_handler_vector, (void)); extern SCHEME_OBJECT EXFUN (initialize_interrupt_mask_vector, (void)); /* Create the fixed objects vector, with 4 extra slots for expansion and debugging. */ fast SCHEME_OBJECT fixed_objects_vector = (make_vector ((NFixed_Objects + 4), SHARP_F, false)); Fixed_Objects = fixed_objects_vector; FAST_VECTOR_SET (fixed_objects_vector, Me_Myself, fixed_objects_vector); FAST_VECTOR_SET (fixed_objects_vector, Non_Object, (MAKE_OBJECT (TC_CONSTANT, 2))); FAST_VECTOR_SET (fixed_objects_vector, System_Interrupt_Vector, (initialize_interrupt_handler_vector ())); FAST_VECTOR_SET (fixed_objects_vector, FIXOBJ_INTERRUPT_MASK_VECTOR, (initialize_interrupt_mask_vector ())); /* Error vector is not needed at boot time */ FAST_VECTOR_SET (fixed_objects_vector, System_Error_Vector, SHARP_F); FAST_VECTOR_SET (fixed_objects_vector, OBArray, (make_vector (OBARRAY_SIZE, EMPTY_LIST, false))); FAST_VECTOR_SET (fixed_objects_vector, Dummy_History, (initialize_history ())); FAST_VECTOR_SET (fixed_objects_vector, State_Space_Tag, SHARP_T); FAST_VECTOR_SET (fixed_objects_vector, Bignum_One, (long_to_bignum (1))); FAST_VECTOR_SET (fixed_objects_vector, FIXOBJ_EDWIN_AUTO_SAVE, EMPTY_LIST); FAST_VECTOR_SET (fixed_objects_vector, FIXOBJ_FILES_TO_DELETE, EMPTY_LIST); FAST_VECTOR_SET (fixed_objects_vector, FIXOBJ_SYSTEM_CALL_NAMES, (fixed_objects_syscall_names ())); FAST_VECTOR_SET (fixed_objects_vector, FIXOBJ_SYSTEM_CALL_ERRORS, (fixed_objects_syserr_names ())); (*Free++) = EMPTY_LIST; (*Free++) = EMPTY_LIST; FAST_VECTOR_SET (fixed_objects_vector, The_Work_Queue, (MAKE_POINTER_OBJECT (TC_LIST, (Free - 2)))); FAST_VECTOR_SET (fixed_objects_vector, Utilities_Vector, (make_vector (0, SHARP_F, false))); FAST_VECTOR_SET (fixed_objects_vector, GENERIC_TRAMPOLINE_ZERO_P, (make_primitive ("INTEGER-ZERO?", 1))); FAST_VECTOR_SET (fixed_objects_vector, GENERIC_TRAMPOLINE_POSITIVE_P, (make_primitive ("INTEGER-POSITIVE?", 1))); FAST_VECTOR_SET (fixed_objects_vector, GENERIC_TRAMPOLINE_NEGATIVE_P, (make_primitive ("INTEGER-NEGATIVE?", 1))); FAST_VECTOR_SET (fixed_objects_vector, GENERIC_TRAMPOLINE_SUCCESSOR, (make_primitive ("INTEGER-ADD-1", 1))); FAST_VECTOR_SET (fixed_objects_vector, GENERIC_TRAMPOLINE_PREDECESSOR, (make_primitive ("INTEGER-SUBTRACT-1", 1))); FAST_VECTOR_SET (fixed_objects_vector, GENERIC_TRAMPOLINE_EQUAL_P, (make_primitive ("INTEGER-EQUAL?", 2))); FAST_VECTOR_SET (fixed_objects_vector, GENERIC_TRAMPOLINE_LESS_P, (make_primitive ("INTEGER-LESS?", 2))); FAST_VECTOR_SET (fixed_objects_vector, GENERIC_TRAMPOLINE_GREATER_P, (make_primitive ("INTEGER-GREATER?", 2))); FAST_VECTOR_SET (fixed_objects_vector, GENERIC_TRAMPOLINE_ADD, (make_primitive ("INTEGER-ADD", 2))); FAST_VECTOR_SET (fixed_objects_vector, GENERIC_TRAMPOLINE_SUBTRACT, (make_primitive ("INTEGER-SUBTRACT", 2))); FAST_VECTOR_SET (fixed_objects_vector, GENERIC_TRAMPOLINE_MULTIPLY, (make_primitive ("INTEGER-MULTIPLY", 2))); FAST_VECTOR_SET (fixed_objects_vector, GENERIC_TRAMPOLINE_DIVIDE, SHARP_F); FAST_VECTOR_SET (fixed_objects_vector, GENERIC_TRAMPOLINE_QUOTIENT, SHARP_F); FAST_VECTOR_SET (fixed_objects_vector, GENERIC_TRAMPOLINE_REMAINDER, SHARP_F); FAST_VECTOR_SET (fixed_objects_vector, GENERIC_TRAMPOLINE_MODULO, SHARP_F); FAST_VECTOR_SET (fixed_objects_vector, ARITY_DISPATCHER_TAG, char_pointer_to_symbol("#[(microcode)arity-dispatcher-tag]")); #ifdef __WIN32__ { extern void EXFUN (NT_initialize_fov, (SCHEME_OBJECT)); NT_initialize_fov (fixed_objects_vector); } #endif } /* Boot Scheme */ #ifndef ENTRY_HOOK # define ENTRY_HOOK() do { } while (0) #endif static void DEFUN (Start_Scheme, (Start_Prim, File_Name), int Start_Prim AND CONST char * File_Name) { SCHEME_OBJECT FName; SCHEME_OBJECT expr = SHARP_F; SCHEME_OBJECT * inner_arg; SCHEME_OBJECT prim; /* fast long i; */ /* Parallel processor test */ Boolean I_Am_Master = (Start_Prim != BOOT_GET_WORK); OS_initialize (); if (I_Am_Master) { outf_console ("Scheme Microcode Version %d.%d\n", SCHEME_VERSION, SCHEME_SUBVERSION); outf_console ("MIT Scheme running under %s\n", OS_Variant); OS_announcement (); outf_flush_console (); } if (I_Am_Master) { Current_State_Point = SHARP_F; Fluid_Bindings = EMPTY_LIST; INIT_FIXED_OBJECTS (); } /* The initial program to execute is one of (SCODE-EVAL (BINARY-FASLOAD ) SYSTEM-GLOBAL-ENVIRONMENT), (LOAD-BAND ), or ((GET-WORK)) (SCODE-EVAL (INITIALIZE-C-COMPILED-BLOCK ) GLOBAL-ENV) depending on the value of Start_Prim. */ switch (Start_Prim) { case BOOT_FASLOAD: /* (SCODE-EVAL (BINARY-FASLOAD ) GLOBAL-ENV) */ FName = (char_pointer_to_string ((unsigned char *) File_Name)); prim = (make_primitive ("BINARY-FASLOAD", 1)); inner_arg = Free; *Free++ = prim; *Free++ = FName; prim = (make_primitive ("SCODE-EVAL", 2)); expr = MAKE_POINTER_OBJECT (TC_PCOMB2, Free); *Free++ = prim; *Free++ = MAKE_POINTER_OBJECT (TC_PCOMB1, inner_arg); *Free++ = THE_GLOBAL_ENV; break; case BOOT_LOAD_BAND: /* (LOAD-BAND ) */ FName = (char_pointer_to_string ((unsigned char *) File_Name)); prim = (make_primitive ("LOAD-BAND", 1)); inner_arg = Free; *Free++ = prim; *Free++ = FName; expr = MAKE_POINTER_OBJECT (TC_PCOMB1, inner_arg); break; case BOOT_GET_WORK: /* ((GET-WORK)) */ prim = (make_primitive ("GET-WORK", 0)); inner_arg = Free; *Free++ = prim; *Free++ = SHARP_F; expr = MAKE_POINTER_OBJECT (TC_COMBINATION, Free); *Free++ = MAKE_OBJECT (TC_MANIFEST_VECTOR, 1); *Free++ = MAKE_POINTER_OBJECT (TC_PCOMB1, inner_arg); break; case BOOT_EXECUTE: /* (SCODE-EVAL (INITIALIZE-C-COMPILED-BLOCK ) GLOBAL-ENV) */ FName = (char_pointer_to_string ((unsigned char *) File_Name)); prim = (make_primitive ("INITIALIZE-C-COMPILED-BLOCK", 1)); inner_arg = Free; *Free++ = prim; *Free++ = FName; prim = (make_primitive ("SCODE-EVAL", 2)); expr = (MAKE_POINTER_OBJECT (TC_PCOMB2, Free)); *Free++ = prim; *Free++ = (MAKE_POINTER_OBJECT (TC_PCOMB1, inner_arg)); *Free++ = THE_GLOBAL_ENV; break; default: outf_fatal ("Unknown boot time option: %d\n", Start_Prim); Microcode_Termination (TERM_BAD_PRIMITIVE); /*NOTREACHED*/ } /* Setup registers */ INITIALIZE_INTERRUPTS (); SET_INTERRUPT_MASK (0); Env = THE_GLOBAL_ENV; Trapping = false; Return_Hook_Address = NULL; /* Give the interpreter something to chew on, and ... */ Will_Push (CONTINUATION_SIZE); Store_Return (RC_END_OF_COMPUTATION); Store_Expression (SHARP_F); Save_Cont (); Pushed (); Store_Expression (expr); /* Go to it! */ if ((Stack_Pointer <= Stack_Guard) || (Free > MemTop)) { outf_fatal ("Configuration won't hold initial data.\n"); termination_init_error (); } ENTRY_HOOK (); Enter_Interpreter (); } #ifdef __WIN32__ extern void EXFUN (win32_enter_interpreter, (void (*) (void))); # define HOOK_ENTER_INTERPRETER win32_enter_interpreter #else # ifdef __OS2__ extern void EXFUN (OS2_enter_interpreter, (void (*) (void))); # define HOOK_ENTER_INTERPRETER OS2_enter_interpreter # else # define HOOK_ENTER_INTERPRETER(func) func () # endif #endif static void DEFUN_VOID (Do_Enter_Interpreter) { Interpret (scheme_dumped_p); outf_fatal ("\nThe interpreter returned to top level!\n"); Microcode_Termination (TERM_EXIT); } static void DEFUN_VOID (Enter_Interpreter) { HOOK_ENTER_INTERPRETER (Do_Enter_Interpreter); } /* This must be used with care, and only synchronously. */ extern SCHEME_OBJECT EXFUN (Re_Enter_Interpreter, (void)); SCHEME_OBJECT DEFUN_VOID (Re_Enter_Interpreter) { Interpret (true); return Val; } /* Garbage collection debugging utilities. */ extern SCHEME_OBJECT *deadly_free, *deadly_scan; extern unsigned long gc_counter; extern void EXFUN (gc_death, (long code, char *, SCHEME_OBJECT *, SCHEME_OBJECT *)); extern void EXFUN (stack_death, (CONST char *)); extern char gc_death_message_buffer[]; SCHEME_OBJECT *deadly_free, *deadly_scan; unsigned long gc_counter = 0; char gc_death_message_buffer[100]; void DEFUN (gc_death, (code, message, scan, free), long code AND char * message AND SCHEME_OBJECT * scan AND SCHEME_OBJECT * free) { outf_fatal ("\n%s.\n", message); outf_fatal ("scan = 0x%lx; free = 0x%lx\n", scan, free); deadly_scan = scan; deadly_free = free; Microcode_Termination (code); /*NOTREACHED*/ } void DEFUN (stack_death, (name), CONST char * name) { outf_fatal ("\n%s: The stack has overflowed and overwritten adjacent memory.\n", name); outf_fatal ("This was probably caused by a runaway recursion.\n"); Microcode_Termination (TERM_STACK_OVERFLOW); /*NOTREACHED*/ } /* Utility primitives. */ #define IDENTITY_LENGTH 20 /* Plenty of room */ #define ID_RELEASE 0 /* System release (string) */ #define ID_MICRO_VERSION 1 /* Microcode version (fixnum) */ #define ID_MICRO_MOD 2 /* Microcode modification (fixnum) */ #define ID_PRINTER_WIDTH 3 /* TTY width (# chars) */ #define ID_PRINTER_LENGTH 4 /* TTY height (# chars) */ #define ID_NEW_LINE_CHARACTER 5 /* #\Newline */ #define ID_FLONUM_PRECISION 6 /* Flonum mantissa (# bits) */ #define ID_FLONUM_EPSILON 7 /* Flonum epsilon (flonum) */ #define ID_OS_NAME 8 /* OS name (string) */ #define ID_OS_VARIANT 9 /* OS variant (string) */ #define ID_STACK_TYPE 10 /* Scheme stack type (string) */ #ifdef USE_STACKLETS #define STACK_TYPE_STRING "stacklets" #else #define STACK_TYPE_STRING "standard" #endif DEFINE_PRIMITIVE ("MICROCODE-IDENTIFY", Prim_microcode_identify, 0, 0, 0) { fast SCHEME_OBJECT Result; PRIMITIVE_HEADER (0); Result = (make_vector (IDENTITY_LENGTH, SHARP_F, true)); FAST_VECTOR_SET (Result, ID_RELEASE, (char_pointer_to_string ((unsigned char *) SCHEME_RELEASE))); FAST_VECTOR_SET (Result, ID_MICRO_VERSION, (LONG_TO_UNSIGNED_FIXNUM (SCHEME_VERSION))); FAST_VECTOR_SET (Result, ID_MICRO_MOD, (LONG_TO_UNSIGNED_FIXNUM (SCHEME_SUBVERSION))); FAST_VECTOR_SET (Result, ID_PRINTER_WIDTH, (LONG_TO_UNSIGNED_FIXNUM (OS_tty_x_size ()))); FAST_VECTOR_SET (Result, ID_PRINTER_LENGTH, (LONG_TO_UNSIGNED_FIXNUM (OS_tty_y_size ()))); FAST_VECTOR_SET (Result, ID_NEW_LINE_CHARACTER, (ASCII_TO_CHAR ('\n'))); FAST_VECTOR_SET (Result, ID_FLONUM_PRECISION, (LONG_TO_UNSIGNED_FIXNUM (DBL_MANT_DIG))); FAST_VECTOR_SET (Result, ID_FLONUM_EPSILON, (double_to_flonum ((double) DBL_EPSILON))); FAST_VECTOR_SET (Result, ID_OS_NAME, (char_pointer_to_string ((unsigned char *) OS_Name))); FAST_VECTOR_SET (Result, ID_OS_VARIANT, (char_pointer_to_string ((unsigned char *) OS_Variant))); FAST_VECTOR_SET (Result, ID_STACK_TYPE, (char_pointer_to_string ((unsigned char *) STACK_TYPE_STRING))); PRIMITIVE_RETURN (Result); } DEFINE_PRIMITIVE ("MICROCODE-SYSTEM-CALL-NAMES", Prim_microcode_syscall_names, 0, 0, 0) { PRIMITIVE_HEADER (0); PRIMITIVE_RETURN (fixed_objects_syscall_names ()); } DEFINE_PRIMITIVE ("MICROCODE-SYSTEM-ERROR-NAMES", Prim_microcode_syserr_names, 0, 0, 0) { PRIMITIVE_HEADER (0); PRIMITIVE_RETURN (fixed_objects_syserr_names ()); } DEFINE_PRIMITIVE ("MICROCODE-TABLES-FILENAME", Prim_microcode_tables_filename, 0, 0, 0) { PRIMITIVE_HEADER (0); PRIMITIVE_RETURN (char_pointer_to_string ((unsigned char *) option_utabmd_file)); } DEFINE_PRIMITIVE ("MICROCODE-LIBRARY-PATH", Prim_microcode_library_path, 0, 0, 0) { PRIMITIVE_HEADER (0); { CONST char ** scan = option_library_path; CONST char ** end = option_library_path; while (1) if ((*end++) == 0) { end -= 1; break; } { SCHEME_OBJECT result = (allocate_marked_vector (TC_VECTOR, (end - scan), 1)); SCHEME_OBJECT * scan_result = (VECTOR_LOC (result, 0)); while (scan < end) (*scan_result++) = (char_pointer_to_string ((unsigned char *) *scan++)); PRIMITIVE_RETURN (result); } } } 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 ((unsigned char *) *scan++)); return (result); } DEFINE_PRIMITIVE ("GET-COMMAND-LINE", Prim_get_command_line, 0, 0, 0) { PRIMITIVE_HEADER (0); 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); if (option_unused_argv == 0) PRIMITIVE_RETURN (SHARP_F); { SCHEME_OBJECT result = (argv_to_object (option_unused_argc, option_unused_argv)); option_unused_argv = 0; PRIMITIVE_RETURN (result); } } DEFINE_PRIMITIVE ("RELOAD-SAVE-STRING", Prim_reload_save_string, 1, 1, 0) { PRIMITIVE_HEADER (1); if (reload_saved_string != 0) { free (reload_saved_string); reload_saved_string = 0; } if ((ARG_REF (1)) != SHARP_F) { CHECK_ARG (1, STRING_P); { unsigned int length = (STRING_LENGTH (ARG_REF (1))); reload_saved_string = (malloc (length)); if (reload_saved_string == 0) error_external_return (); reload_saved_string_length = length; { char * scan = ((char *) (STRING_LOC ((ARG_REF (1)), 0))); char * end = (scan + length); char * scan_result = reload_saved_string; while (scan < end) (*scan_result++) = (*scan++); } } } PRIMITIVE_RETURN (UNSPECIFIC); } DEFINE_PRIMITIVE ("RELOAD-RETRIEVE-STRING", Prim_reload_retrieve_string, 0, 0, 0) { PRIMITIVE_HEADER (0); if (reload_saved_string == 0) PRIMITIVE_RETURN (SHARP_F); { SCHEME_OBJECT result = (memory_to_string (reload_saved_string_length, ((unsigned char *) reload_saved_string))); free (reload_saved_string); reload_saved_string = 0; PRIMITIVE_RETURN (result); } }