void
soft_reset (void)
{
/* Called synchronously. */
struct trap_recovery_info trinfo;
SCHEME_OBJECT * new_stack_pointer
= ((SP_OK_P (stack_pointer)) ? stack_pointer : 0);
if (GET_PRIMITIVE != SHARP_F)
{
(trinfo . state) = STATE_PRIMITIVE;
(trinfo . pc_info_1) = GET_PRIMITIVE;
(trinfo . pc_info_2) = (ULONG_TO_FIXNUM (GET_LEXPR_ACTUALS));
(trinfo . extra_trap_info) = SHARP_F;
}
else
{
(trinfo . state) = STATE_UNKNOWN;
(trinfo . pc_info_1) = SHARP_F;
(trinfo . pc_info_2) = SHARP_F;
(trinfo . extra_trap_info) = SHARP_F;
}
if (!ADDRESS_IN_HEAP_P (Free))
Free = heap_alloc_limit; /* Let's hope this works. */
setup_trap_frame (0, 0, 0, (&trinfo), new_stack_pointer);
}
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);
}
return (arg_ulong_index_integer (arg, (1L << TYPE_CODE_LENGTH)));
}
static unsigned long
arg_datum (int arg)
{
return (arg_ulong_index_integer (arg, (1L << DATUM_LENGTH)));
}
/* Low level object manipulation */
DEFINE_PRIMITIVE ("PRIMITIVE-OBJECT-TYPE", Prim_prim_obj_type, 1, 1,
"Return the type code of OBJECT as an unsigned integer.")
{
PRIMITIVE_HEADER (1);
PRIMITIVE_RETURN (ULONG_TO_FIXNUM (OBJECT_TYPE (ARG_REF (1))));
}
DEFINE_PRIMITIVE ("PRIMITIVE-OBJECT-TYPE?", Prim_prim_obj_type_p, 2, 2,
"Return #T if TYPE-CODE is OBJECT's type code, else #F.")
{
PRIMITIVE_HEADER (2);
PRIMITIVE_RETURN
(BOOLEAN_TO_OBJECT ((OBJECT_TYPE (ARG_REF (2))) == (arg_type (1))));
}
DEFINE_PRIMITIVE ("PRIMITIVE-OBJECT-DATUM", Prim_prim_obj_datum, 1, 1,
"Return the datum part of OBJECT as an unsigned integer.")
{
PRIMITIVE_HEADER (1);
PRIMITIVE_RETURN (ulong_to_integer (OBJECT_DATUM (ARG_REF (1))));
static void
continue_from_trap (int signo, SIGINFO_T info, SIGCONTEXT_T * scp)
{
unsigned long pc = (SIGCONTEXT_PC (scp));
SCHEME_OBJECT primitive = GET_PRIMITIVE;
SCHEME_OBJECT * block_addr;
unsigned int index;
SCHEME_OBJECT * new_sp = 0;
struct trap_recovery_info recovery_info;
#ifdef PC_VALUE_MASK
pc &= PC_VALUE_MASK;
#endif
/* Choose new SP and encode location data. */
switch (classify_pc (pc, (&block_addr), (&index)))
{
case pcl_primitive:
new_sp = stack_pointer;
SET_RECOVERY_INFO
(STATE_PRIMITIVE, primitive, (ULONG_TO_FIXNUM (GET_LEXPR_ACTUALS)));
break;
case pcl_heap:
case pcl_constant:
#ifdef CC_SUPPORT_P
new_sp = ((SCHEME_OBJECT *) (SIGCONTEXT_SCHSP (scp)));
Free = ((SCHEME_OBJECT *) (SIGCONTEXT_RFREE (scp)));
SET_RECOVERY_INFO
(STATE_COMPILED_CODE,
(MAKE_CC_BLOCK (block_addr)),
(LONG_TO_UNSIGNED_FIXNUM (pc - ((unsigned long) block_addr))));
break;
#endif
case pcl_utility:
#ifdef CC_SUPPORT_P
new_sp = stack_pointer;
SET_RECOVERY_INFO (STATE_UTILITY, (ULONG_TO_FIXNUM (index)), UNSPECIFIC);
break;
#endif
case pcl_builtin:
#ifdef CC_SUPPORT_P
new_sp = ((SCHEME_OBJECT *) (SIGCONTEXT_SCHSP (scp)));
Free = ((SCHEME_OBJECT *) (SIGCONTEXT_RFREE (scp)));
SET_RECOVERY_INFO (STATE_BUILTIN, (ULONG_TO_FIXNUM (index)), UNSPECIFIC);
break;
#endif
case pcl_unknown:
new_sp = 0;
SET_RECOVERY_INFO
(STATE_UNKNOWN,
(LONG_TO_UNSIGNED_FIXNUM (pc)),
UNSPECIFIC);
break;
}
/* Sanity-check the new SP. */
if (! ((ADDRESS_IN_STACK_P (new_sp)) && (ALIGNED_P (new_sp))))
new_sp = 0;
/* Sanity-check Free. */
if ((new_sp != 0)
&& (ADDRESS_IN_HEAP_P (Free))
&& (ALIGNED_P (Free)))
{
if (FREE_OK_P (Free))
{
Free += FREE_PARANOIA_MARGIN;
if (!FREE_OK_P (Free))
Free = heap_alloc_limit;
}
}
else
Free = heap_alloc_limit;
/* Encode the registers. */
(recovery_info . extra_trap_info) =
(MAKE_POINTER_OBJECT (TC_NON_MARKED_VECTOR, Free));
(*Free++) =
(MAKE_OBJECT (TC_MANIFEST_NM_VECTOR, (2 + SIGCONTEXT_NREGS)));
(*Free++) = ((SCHEME_OBJECT) pc);
(*Free++) = ((SCHEME_OBJECT) (SIGCONTEXT_SP (scp)));
{
unsigned long * scan
= ((unsigned long *) (SIGCONTEXT_FIRST_REG (scp)));
unsigned long * end = (scan + SIGCONTEXT_NREGS);
while (scan < end)
(*Free++) = ((SCHEME_OBJECT) (*scan++));
}
setup_trap_frame (signo, info, scp, (&recovery_info), new_sp);
}