static SCHEME_OBJECT
find_signal_code_name (int signo, SIGINFO_T info, SIGCONTEXT_T * scp)
{
unsigned long code = 0;
const char * name = 0;
if (SIGINFO_VALID_P (info))
{
code = (SIGINFO_CODE (info));
SPECIAL_SIGNAL_CODE_NAMES ();
if (name == 0)
{
struct ux_sig_code_desc * entry = (& (ux_signal_codes[0]));
while ((entry -> signo) != 0)
if ((((entry -> signo) < 0) || ((entry -> signo) == signo))
&& (((entry -> code_mask) & code) == (entry -> code_value)))
{
name = (entry -> name);
break;
}
else
entry += 1;
}
}
return
(cons ((ulong_to_integer (code)),
((name == 0)
? SHARP_F
: (char_pointer_to_string (name)))));
}
static SCHEME_OBJECT
cp2s (void * cp)
{
if (cp == 0)
return (SHARP_F);
else
{
SCHEME_OBJECT s = (char_pointer_to_string (cp));
free (cp);
return (s);
}
}
SCHEME_OBJECT
make_microcode_identification_vector (void)
{
SCHEME_OBJECT v = (make_vector (IDENTITY_LENGTH, SHARP_F, true));
VECTOR_SET (v, ID_RELEASE, SHARP_F);
VECTOR_SET (v, ID_MICRO_VERSION, (char_pointer_to_string (PACKAGE_VERSION)));
VECTOR_SET (v, ID_PRINTER_WIDTH, (ULONG_TO_FIXNUM (OS_tty_x_size ())));
VECTOR_SET (v, ID_PRINTER_LENGTH, (ULONG_TO_FIXNUM (OS_tty_y_size ())));
VECTOR_SET (v, ID_NEW_LINE_CHARACTER, (ASCII_TO_CHAR ('\n')));
VECTOR_SET (v, ID_FLONUM_PRECISION, (ULONG_TO_FIXNUM (DBL_MANT_DIG)));
VECTOR_SET (v, ID_FLONUM_EPSILON, (double_to_flonum ((double) DBL_EPSILON)));
VECTOR_SET (v, ID_OS_NAME, (char_pointer_to_string (OS_Name)));
VECTOR_SET (v, ID_OS_VARIANT, (char_pointer_to_string (OS_Variant)));
VECTOR_SET (v, ID_STACK_TYPE, (char_pointer_to_string ("standard")));
VECTOR_SET (v, ID_MACHINE_TYPE, (char_pointer_to_string (MACHINE_TYPE)));
{
const char * name = (cc_arch_name ());
if (name != 0)
VECTOR_SET (v, ID_CC_ARCH, (char_pointer_to_string (name)));
}
return (v);
}
static void
start_scheme (void)
{
SCHEME_OBJECT expr;
if (!option_batch_mode && !option_show_version && !option_show_help)
{
outf_console ("MIT/GNU Scheme running under %s\n", OS_Variant);
OS_announcement ();
outf_console ("\n");
outf_flush_console ();
}
initialize_fixed_objects_vector ();
if (option_fasl_file != 0)
{
#ifdef CC_IS_C
/* (SCODE-EVAL (INITIALIZE-C-COMPILED-BLOCK <file>) GLOBAL-ENV) */
SCHEME_OBJECT prim1 = (make_primitive ("INITIALIZE-C-COMPILED-BLOCK", 1));
#else
/* (SCODE-EVAL (BINARY-FASLOAD <file>) GLOBAL-ENV) */
SCHEME_OBJECT prim1 = (make_primitive ("BINARY-FASLOAD", 1));
#endif
SCHEME_OBJECT fn_object = (char_pointer_to_string (option_fasl_file));
SCHEME_OBJECT prim2 = (make_primitive ("SCODE-EVAL", 2));
SCHEME_OBJECT * inner_arg = Free;
(*Free++) = prim1;
(*Free++) = fn_object;
expr = (MAKE_POINTER_OBJECT (TC_PCOMB2, Free));
(*Free++) = prim2;
(*Free++) = (MAKE_POINTER_OBJECT (TC_PCOMB1, inner_arg));
(*Free++) = THE_GLOBAL_ENV;
}
else
{
/* (LOAD-BAND <file>) */
SCHEME_OBJECT prim = (make_primitive ("LOAD-BAND", 1));
SCHEME_OBJECT fn_object = (char_pointer_to_string (option_band_file));
expr = (MAKE_POINTER_OBJECT (TC_PCOMB1, Free));
(*Free++) = prim;
(*Free++) = fn_object;
}
/* Setup registers */
INITIALIZE_INTERRUPTS (0);
SET_ENV (THE_GLOBAL_ENV);
trapping = false;
/* Give the interpreter something to chew on, and ... */
Will_Push (CONTINUATION_SIZE);
SET_RC (RC_END_OF_COMPUTATION);
SET_EXP (SHARP_F);
SAVE_CONT ();
Pushed ();
SET_EXP (expr);
/* Go to it! */
if (! ((SP_OK_P (stack_pointer)) && (Free <= heap_alloc_limit)))
{
outf_fatal ("Configuration won't hold initial data.\n");
termination_init_error ();
}
ENTRY_HOOK ();
Enter_Interpreter ();
}
static void
setup_trap_frame (int signo,
SIGINFO_T info,
SIGCONTEXT_T * scp,
struct trap_recovery_info * trinfo,
SCHEME_OBJECT * new_stack_pointer)
{
unsigned long saved_mask = GET_INT_MASK;
SCHEME_OBJECT handler;
SCHEME_OBJECT signal_name;
SET_INTERRUPT_MASK (0); /* To prevent GC for now. */
handler
= ((VECTOR_P (fixed_objects))
? (VECTOR_REF (fixed_objects, TRAP_HANDLER))
: SHARP_F);
if (!INTERPRETER_APPLICABLE_P (handler))
{
fprintf (stderr, "There is no trap handler for recovery!\n");
fflush (stderr);
termination_trap ();
}
signal_name =
((signo != 0)
? (char_pointer_to_string (find_signal_name (signo)))
: SHARP_F);
if (!FREE_OK_P (Free))
REQUEST_GC (0);
if (new_stack_pointer != 0)
stack_pointer = new_stack_pointer;
else
{
INITIALIZE_STACK ();
Will_Push (CONTINUATION_SIZE);
SET_RC (RC_END_OF_COMPUTATION);
SET_EXP (SHARP_F);
SAVE_CONT ();
Pushed ();
}
Will_Push (7 + CONTINUATION_SIZE);
STACK_PUSH (trinfo -> extra_trap_info);
STACK_PUSH (trinfo -> pc_info_2);
STACK_PUSH (trinfo -> pc_info_1);
STACK_PUSH (trinfo -> state);
STACK_PUSH (BOOLEAN_TO_OBJECT (new_stack_pointer != 0));
STACK_PUSH (find_signal_code_name (signo, info, scp));
STACK_PUSH (signal_name);
SET_RC (RC_HARDWARE_TRAP);
SET_EXP (long_to_integer (signo));
SAVE_CONT ();
Pushed ();
if ((new_stack_pointer != 0)
/* This may want to do it in other cases, but this may be enough. */
&& ((trinfo -> state) == STATE_COMPILED_CODE))
stop_history ();
history_register = (make_dummy_history ());
Will_Push (STACK_ENV_EXTRA_SLOTS + 2);
STACK_PUSH (signal_name);
STACK_PUSH (handler);
PUSH_APPLY_FRAME_HEADER (1);
Pushed ();
SET_INTERRUPT_MASK (saved_mask);
abort_to_interpreter (PRIM_APPLY);
}
