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); }