void
NT_initialize_fov (SCHEME_OBJECT fov)
{
int ctr, in;
SCHEME_OBJECT iv, imv, prim;
static int interrupt_numbers[2] =
{
Global_GC_Level,
Global_1_Level,
};
static long interrupt_masks[2] =
{
0, /* No interrupts allowed */
(INT_Stack_Overflow | INT_Global_GC | INT_GC),
};
iv = (VECTOR_REF (fov, SYSTEM_INTERRUPT_VECTOR));
imv = (VECTOR_REF (fov, FIXOBJ_INTERRUPT_MASK_VECTOR));
prim = (make_primitive ("MICROCODE-POLL-INTERRUPT-HANDLER", 2));
for (ctr = 0; ctr < ((sizeof (interrupt_numbers)) / (sizeof (int))); ctr++)
{
in = interrupt_numbers[ctr];
VECTOR_SET (iv, in, prim);
VECTOR_SET (imv, in, (long_to_integer (interrupt_masks[ctr])));
}
return;
}
static SCM
env_ref (SCM env, int depth, int width)
{
while (depth--)
env = next_rib (env);
return VECTOR_REF (env, width + 1);
}
/*---------------------------------------------------------------------*/
obj_t
bgl_month_aname( int month ) {
static obj_t names = BNIL;
if( names == BNIL ) names = make_names( 12, "%b" );
return VECTOR_REF( names, month-1 );
}
/*---------------------------------------------------------------------*/
obj_t
bgl_day_aname( int day ) {
static obj_t names = BNIL;
if( names == BNIL ) names = make_names( 7, "%a" );
return VECTOR_REF( names, day-1 );
}
static int
try_lookup_rib (SCM x, SCM rib)
{
int idx = 0;
for (; idx < VECTOR_LENGTH (rib); idx++)
if (scm_is_eq (x, VECTOR_REF (rib, idx)))
return idx; /* bound */
return -1;
}
/* grow-stack! */
obj_t BGl_growzd2stackz12zc0zz__lalr_driverz00(obj_t BgL_vz00_1)
{
AN_OBJECT;
{ /* Lalr/driver.scm 49 */
{ /* Lalr/driver.scm 50 */
int BgL_lenz00_771;
BgL_lenz00_771 = VECTOR_LENGTH(BgL_vz00_1);
{ /* Lalr/driver.scm 50 */
obj_t BgL_v2z00_772;
{ /* Lalr/driver.scm 51 */
long BgL_arg1894z00_780;
BgL_arg1894z00_780 =
(
(long) (BgL_lenz00_771) +
BGl_za2stackzd2siza7ezd2incrementza2za7zz__lalr_driverz00);
BgL_v2z00_772 =
make_vector((int) (BgL_arg1894z00_780), BINT(((long) 0)));
}
{ /* Lalr/driver.scm 51 */
{
long BgL_iz00_774;
BgL_iz00_774 = ((long) 0);
BgL_zc3anonymousza31889ze3z83_775:
if ((BgL_iz00_774 < (long) (BgL_lenz00_771)))
{ /* Lalr/driver.scm 53 */
VECTOR_SET(BgL_v2z00_772,
(int) (BgL_iz00_774),
VECTOR_REF(BgL_vz00_1, (int) (BgL_iz00_774)));
{
long BgL_iz00_1611;
BgL_iz00_1611 = (BgL_iz00_774 + ((long) 1));
BgL_iz00_774 = BgL_iz00_1611;
goto BgL_zc3anonymousza31889ze3z83_775;
}
}
else
{ /* Lalr/driver.scm 53 */
return BgL_v2z00_772;
}
}
}
}
}
}
}
static void
attempt_termination_backout (int code)
{
outf_flush_error(); /* NOT flush_fatal */
if ((WITHIN_CRITICAL_SECTION_P ())
|| (code == TERM_HALT)
|| (! (VECTOR_P (fixed_objects))))
return;
{
SCHEME_OBJECT Term_Vector
= (VECTOR_REF (fixed_objects, Termination_Proc_Vector));
if ((! (VECTOR_P (Term_Vector)))
|| (((long) (VECTOR_LENGTH (Term_Vector))) <= code))
return;
{
SCHEME_OBJECT Handler = (VECTOR_REF (Term_Vector, code));
if (Handler == SHARP_F)
return;
Will_Push (CONTINUATION_SIZE
+ STACK_ENV_EXTRA_SLOTS
+ ((code == TERM_NO_ERROR_HANDLER) ? 5 : 4));
SET_RC (RC_HALT);
SET_EXP (LONG_TO_UNSIGNED_FIXNUM (code));
SAVE_CONT ();
if (code == TERM_NO_ERROR_HANDLER)
STACK_PUSH (LONG_TO_UNSIGNED_FIXNUM (death_blow));
PUSH_VAL (); /* Arg 3 */
PUSH_ENV (); /* Arg 2 */
PUSH_EXP (); /* Arg 1 */
STACK_PUSH (Handler); /* The handler function */
PUSH_APPLY_FRAME_HEADER ((code == TERM_NO_ERROR_HANDLER) ? 4 : 3);
Pushed ();
abort_to_interpreter (PRIM_NO_TRAP_APPLY);
}
}
}
static void
edwin_auto_save (void)
{
static SCHEME_OBJECT position;
static struct interpreter_state_s new_state;
position =
((VECTOR_P (fixed_objects))
? (VECTOR_REF (fixed_objects, FIXOBJ_EDWIN_AUTO_SAVE))
: EMPTY_LIST);
while (PAIR_P (position))
{
SCHEME_OBJECT entry = (PAIR_CAR (position));
position = (PAIR_CDR (position));
if ((PAIR_P (entry))
&& (GROUP_P (PAIR_CAR (entry)))
&& (STRING_P (PAIR_CDR (entry)))
&& ((GROUP_MODIFIED_P (PAIR_CAR (entry))) == SHARP_T))
{
SCHEME_OBJECT group = (PAIR_CAR (entry));
char * namestring = (STRING_POINTER (PAIR_CDR (entry)));
unsigned long length;
unsigned char * start = (GROUP_TEXT (group, (&length)));
unsigned char * end = (start + length);
unsigned char * gap_start = (start + (GROUP_GAP_START (group)));
unsigned char * gap_end = (start + (GROUP_GAP_END (group)));
if ((start < gap_start) || (gap_end < end))
{
bind_interpreter_state (&new_state);
if ((setjmp (interpreter_catch_env)) == 0)
{
Tchannel channel;
outf_error ("Auto-saving file \"%s\"\n", namestring);
outf_flush_error ();
channel = (OS_open_output_file (namestring));
if (start < gap_start)
OS_channel_write (channel, start, (gap_start - start));
if (gap_end < end)
OS_channel_write (channel, gap_end, (end - gap_end));
OS_channel_close (channel);
}
unbind_interpreter_state (&new_state);
}
}
}
}
/*---------------------------------------------------------------------*/
void
bglk_gtk_start( obj_t gtk_argv, int main_loop_p, char *argv0, char *name ) {
int argc;
char **argv;
int len_argv = VECTOR_LENGTH( gtk_argv );
char *peer_version = BSTRING_TO_STRING( biglook_peer_version );
if( !VECTORP( gtk_argv ) )
exit( 1 );
/* convert scheme vector to an char*[] for gtk_init */
argv = alloca( sizeof( char * ) * len_argv );
for( argc = 0; argc < len_argv; argc++ )
argv[ argc ] = BSTRING_TO_STRING( VECTOR_REF( gtk_argv, argc ));
//gnomelib_init( "biglook", peer_version );
gnome_program_init( "biglook", peer_version,
LIBGNOMEUI_MODULE,
argc, argv,
NULL);
gtk_init( &argc, &argv );
}
static void
delete_temp_files (void)
{
static SCHEME_OBJECT position;
static struct interpreter_state_s new_state;
position =
((VECTOR_P (fixed_objects))
? (VECTOR_REF (fixed_objects, FIXOBJ_FILES_TO_DELETE))
: EMPTY_LIST);
while (PAIR_P (position))
{
SCHEME_OBJECT entry = (PAIR_CAR (position));
position = (PAIR_CDR (position));
if (STRING_P (entry))
{
bind_interpreter_state (&new_state);
if ((setjmp (interpreter_catch_env)) == 0)
OS_file_remove (STRING_POINTER (entry));
unbind_interpreter_state (&new_state);
}
}
}
/*---------------------------------------------------------------------*/
static obj_t
bgl_bstring_to_symbol( obj_t name ) {
long hash_number;
obj_t bucket;
char *cname = BSTRING_TO_STRING( name );
hash_number = ____get_hash_power_number( cname, SYMBOL_HASH_TABLE_SIZE_SHIFT );
bucket = VECTOR_REF( ____bgl_get_symtab(), hash_number );
if( NULLP( bucket ) ) {
obj_t symbol = make_symbol( name );
obj_t pair = MAKE_PAIR( symbol, BNIL );
VECTOR_SET( ____bgl_get_symtab(), hash_number, pair );
return symbol;
} else {
obj_t run = bucket, back = bucket;
while( !NULLP( run ) &&
SYMBOL( CAR( run ) ).string &&
!bigloo_strcmp( SYMBOL( CAR( run ) ).string, name ) )
back = run, run = CDR( run );
if( !NULLP( run ) ) {
return CAR( run );
}
else {
obj_t symbol = make_symbol( name );
obj_t pair = MAKE_PAIR( symbol, BNIL );
SET_CDR( back, pair );
return symbol;
}
}
}
/* loose-alloc! */
BGL_EXPORTED_DEF obj_t BGl_loosezd2allocz12zc0zzcfa_loosez00(BgL_nodez00_bglt
BgL_nodez00_3)
{
AN_OBJECT;
{ /* Cfa/loose.scm 47 */
{ /* Cfa/loose.scm 47 */
obj_t BgL_method4684z00_1588;
{ /* Cfa/loose.scm 47 */
BgL_objectz00_bglt BgL_objz00_1589;
BgL_objz00_1589 = (BgL_objectz00_bglt) (BgL_nodez00_3);
{ /* Cfa/loose.scm 47 */
long BgL_objzd2classzd2numz00_1590;
BgL_objzd2classzd2numz00_1590 =
BGL_OBJECT_CLASS_NUM(BgL_objz00_1589);
{ /* Cfa/loose.scm 47 */
obj_t BgL_arg2643z00_1591;
BgL_arg2643z00_1591 =
PROCEDURE_REF(BGl_loosezd2allocz12zd2envz12zzcfa_loosez00,
(int) (((long) 1)));
{ /* Cfa/loose.scm 47 */
obj_t BgL_arrayz00_1593;
int BgL_offsetz00_1594;
BgL_arrayz00_1593 = BgL_arg2643z00_1591;
BgL_offsetz00_1594 = (int) (BgL_objzd2classzd2numz00_1590);
{ /* Cfa/loose.scm 47 */
long BgL_offsetz00_1595;
BgL_offsetz00_1595 =
((long) (BgL_offsetz00_1594) - OBJECT_TYPE);
{ /* Cfa/loose.scm 47 */
long BgL_modz00_1596;
{ /* Cfa/loose.scm 47 */
int BgL_arg2645z00_1597;
BgL_arg2645z00_1597 = (int) (((long) 16));
{ /* Cfa/loose.scm 47 */
long BgL_auxz00_1689;
BgL_auxz00_1689 = (long) (BgL_arg2645z00_1597);
BgL_modz00_1596 =
(BgL_offsetz00_1595 / BgL_auxz00_1689);
}
}
{ /* Cfa/loose.scm 47 */
long BgL_restz00_1598;
{ /* Cfa/loose.scm 47 */
int BgL_arg2644z00_1599;
BgL_arg2644z00_1599 = (int) (((long) 16));
{ /* Cfa/loose.scm 47 */
long BgL_auxz00_1693;
BgL_auxz00_1693 = (long) (BgL_arg2644z00_1599);
BgL_restz00_1598 =
(BgL_offsetz00_1595 % BgL_auxz00_1693);
}
}
{ /* Cfa/loose.scm 47 */
BgL_method4684z00_1588 =
VECTOR_REF(VECTOR_REF(BgL_arrayz00_1593,
(int) (BgL_modz00_1596)), (int) (BgL_restz00_1598));
}
}
}
}
}
}
}
}
return
PROCEDURE_ENTRY(BgL_method4684z00_1588) (BgL_method4684z00_1588,
(obj_t) (BgL_nodez00_3), BEOA);
}
}
}
/* set-one-kaptured! */
obj_t BGl_setzd2onezd2kapturedz12z12zzglobaliza7e_kaptureza7(BgL_localz00_bglt
BgL_localz00_2, obj_t BgL_lockingz00_3)
{
AN_OBJECT;
{ /* Globalize/kapture.scm 53 */
{ /* Globalize/kapture.scm 58 */
BgL_valuez00_bglt BgL_infoz00_929;
{
BgL_variablez00_bglt BgL_auxz00_1570;
BgL_auxz00_1570 = (BgL_variablez00_bglt) (BgL_localz00_2);
BgL_infoz00_929 =
(((BgL_variablez00_bglt) CREF(BgL_auxz00_1570))->BgL_valuez00);
}
{ /* Globalize/kapture.scm 58 */
obj_t BgL_kapturedz00_930;
{ /* Globalize/kapture.scm 59 */
BgL_sfunzf2ginfozf2_bglt BgL_obj3367z00_1441;
BgL_obj3367z00_1441 = (BgL_sfunzf2ginfozf2_bglt) (BgL_infoz00_929);
{
obj_t BgL_auxz00_1574;
{ /* Globalize/kapture.scm 59 */
BgL_objectz00_bglt BgL_auxz00_1575;
BgL_auxz00_1575 = (BgL_objectz00_bglt) (BgL_obj3367z00_1441);
BgL_auxz00_1574 = BGL_OBJECT_WIDENING(BgL_auxz00_1575);
}
BgL_kapturedz00_930 =
(((BgL_sfunzf2ginfozf2_bglt) CREF(BgL_auxz00_1574))->
BgL_kapturedz00);
}
}
{ /* Globalize/kapture.scm 59 */
{ /* Globalize/kapture.scm 61 */
bool_t BgL_testz00_1579;
if (PAIRP(BgL_kapturedz00_930))
{ /* Globalize/kapture.scm 61 */
BgL_testz00_1579 = ((bool_t) 1);
}
else
{ /* Globalize/kapture.scm 61 */
BgL_testz00_1579 = NULLP(BgL_kapturedz00_930);
}
if (BgL_testz00_1579)
{ /* Globalize/kapture.scm 61 */
{ /* Globalize/kapture.scm 64 */
obj_t BgL_v3646z00_932;
BgL_v3646z00_932 = create_vector((int) (((long) 3)));
VECTOR_SET(BgL_v3646z00_932,
(int) (((long) 2)), BgL_kapturedz00_930);
VECTOR_SET(BgL_v3646z00_932,
(int) (((long) 1)), BgL_lockingz00_3);
VECTOR_SET(BgL_v3646z00_932, (int) (((long) 0)), BTRUE);
return BgL_v3646z00_932;
}
}
else
{ /* Globalize/kapture.scm 61 */
if (BGl_iszd2azf3z21zz__objectz00(BgL_kapturedz00_930,
BGl_localz00zzast_varz00))
{ /* Globalize/kapture.scm 65 */
{ /* Globalize/kapture.scm 68 */
obj_t BgL_v3647z00_934;
BgL_v3647z00_934 = create_vector((int) (((long) 3)));
VECTOR_SET(BgL_v3647z00_934, (int) (((long) 2)), BNIL);
VECTOR_SET(BgL_v3647z00_934,
(int) (((long) 1)), BgL_lockingz00_3);
VECTOR_SET(BgL_v3647z00_934,
(int) (((long) 0)), BFALSE);
return BgL_v3647z00_934;
}
}
else
{ /* Globalize/kapture.scm 65 */
{ /* Globalize/kapture.scm 72 */
obj_t BgL_newzd2bodyzd2_935;
{ /* Globalize/kapture.scm 72 */
BgL_sfunzf2ginfozf2_bglt BgL_obj3370z00_1463;
BgL_obj3370z00_1463 =
(BgL_sfunzf2ginfozf2_bglt) (BgL_infoz00_929);
{
obj_t BgL_auxz00_1602;
{ /* Globalize/kapture.scm 72 */
BgL_objectz00_bglt BgL_auxz00_1603;
BgL_auxz00_1603 =
(BgL_objectz00_bglt) (BgL_obj3370z00_1463);
BgL_auxz00_1602 =
BGL_OBJECT_WIDENING(BgL_auxz00_1603);
}
BgL_newzd2bodyzd2_935 =
(((BgL_sfunzf2ginfozf2_bglt)
CREF(BgL_auxz00_1602))->BgL_newzd2bodyzd2);
}
}
{ /* Globalize/kapture.scm 74 */
BgL_sfunzf2ginfozf2_bglt BgL_obj3369z00_1464;
obj_t BgL_val3368z00_1465;
BgL_obj3369z00_1464 =
(BgL_sfunzf2ginfozf2_bglt) (BgL_infoz00_929);
BgL_val3368z00_1465 = (obj_t) (BgL_localz00_2);
{
obj_t BgL_auxz00_1609;
{ /* Globalize/kapture.scm 74 */
BgL_objectz00_bglt BgL_auxz00_1610;
BgL_auxz00_1610 =
(BgL_objectz00_bglt) (BgL_obj3369z00_1464);
BgL_auxz00_1609 =
BGL_OBJECT_WIDENING(BgL_auxz00_1610);
}
((((BgL_sfunzf2ginfozf2_bglt)
CREF(BgL_auxz00_1609))->BgL_kapturedz00) =
((obj_t) BgL_val3368z00_1465), BUNSPEC);
}
}
{ /* Globalize/kapture.scm 76 */
obj_t BgL_g3638z00_937;
{ /* Globalize/kapture.scm 77 */
obj_t BgL_auxz00_1621;
obj_t BgL_auxz00_1614;
{ /* Globalize/kapture.scm 78 */
BgL_sfunzf2ginfozf2_bglt BgL_obj3339z00_1467;
BgL_obj3339z00_1467 =
(BgL_sfunzf2ginfozf2_bglt) (BgL_infoz00_929);
{
obj_t BgL_auxz00_1623;
{ /* Globalize/kapture.scm 78 */
BgL_objectz00_bglt BgL_auxz00_1624;
BgL_auxz00_1624 =
(BgL_objectz00_bglt) (BgL_obj3339z00_1467);
BgL_auxz00_1623 =
BGL_OBJECT_WIDENING(BgL_auxz00_1624);
}
BgL_auxz00_1621 =
(((BgL_sfunzf2ginfozf2_bglt)
CREF(BgL_auxz00_1623))->BgL_cfunctionz00);
}
}
{ /* Globalize/kapture.scm 77 */
BgL_sfunzf2ginfozf2_bglt BgL_obj3336z00_1466;
BgL_obj3336z00_1466 =
(BgL_sfunzf2ginfozf2_bglt) (BgL_infoz00_929);
{
obj_t BgL_auxz00_1616;
{ /* Globalize/kapture.scm 77 */
BgL_objectz00_bglt BgL_auxz00_1617;
BgL_auxz00_1617 =
(BgL_objectz00_bglt) (BgL_obj3336z00_1466);
BgL_auxz00_1616 =
BGL_OBJECT_WIDENING(BgL_auxz00_1617);
}
BgL_auxz00_1614 =
(((BgL_sfunzf2ginfozf2_bglt)
CREF(BgL_auxz00_1616))->BgL_ctoza2za2);
}
}
BgL_g3638z00_937 =
bgl_append2(BgL_auxz00_1614, BgL_auxz00_1621);
}
{
obj_t BgL_kapturedz00_939;
obj_t BgL_ctoz00_940;
bool_t BgL_setterzf3zf3_941;
BgL_kapturedz00_939 = BNIL;
BgL_ctoz00_940 = BgL_g3638z00_937;
BgL_setterzf3zf3_941 = ((bool_t) 1);
BgL_zc3anonymousza33659ze3z83_942:
if (NULLP(BgL_ctoz00_940))
{ /* Globalize/kapture.scm 87 */
obj_t BgL_freez00_944;
BgL_freez00_944 =
BGl_getzd2freezd2varsz00zzglobaliza7e_freeza7(
(BgL_nodez00_bglt) (BgL_newzd2bodyzd2_935),
BgL_localz00_2);
{ /* Globalize/kapture.scm 87 */
obj_t BgL_fkapturedz00_945;
BgL_fkapturedz00_945 =
BGl_freezd2fromzd2zzglobaliza7e_freeza7
(BgL_kapturedz00_939, BgL_localz00_2);
{ /* Globalize/kapture.scm 88 */
obj_t BgL_kapturedz00_946;
{ /* Globalize/kapture.scm 89 */
obj_t BgL_arg3665z00_956;
BgL_arg3665z00_956 =
MAKE_PAIR(BgL_freez00_944,
BgL_fkapturedz00_945);
BgL_kapturedz00_946 =
BGl_unionz00zzglobaliza7e_kaptureza7
(BgL_arg3665z00_956);
}
{ /* Globalize/kapture.scm 89 */
if (BgL_setterzf3zf3_941)
{ /* Globalize/kapture.scm 96 */
{ /* Globalize/kapture.scm 99 */
BgL_sfunzf2ginfozf2_bglt
BgL_obj3369z00_1469;
obj_t BgL_val3368z00_1470;
BgL_obj3369z00_1469 =
(BgL_sfunzf2ginfozf2_bglt)
(BgL_infoz00_929);
BgL_val3368z00_1470 =
BgL_kapturedz00_946;
{
obj_t BgL_auxz00_1638;
{ /* Globalize/kapture.scm 99 */
BgL_objectz00_bglt
BgL_auxz00_1639;
BgL_auxz00_1639 =
(BgL_objectz00_bglt)
(BgL_obj3369z00_1469);
BgL_auxz00_1638 =
BGL_OBJECT_WIDENING
(BgL_auxz00_1639);
}
((((BgL_sfunzf2ginfozf2_bglt)
CREF(BgL_auxz00_1638))->
BgL_kapturedz00) =
((obj_t) BgL_val3368z00_1470),
BUNSPEC);
}
}
{
obj_t BgL_l3648z00_948;
{ /* Globalize/kapture.scm 101 */
bool_t BgL_auxz00_1643;
BgL_l3648z00_948 =
BgL_kapturedz00_946;
BgL_zc3anonymousza33661ze3z83_949:
if (PAIRP(BgL_l3648z00_948))
{ /* Globalize/kapture.scm 101 */
{ /* Globalize/kapture.scm 102 */
obj_t BgL_localz00_951;
BgL_localz00_951 =
CAR(BgL_l3648z00_948);
{ /* Globalize/kapture.scm 103 */
BgL_valuez00_bglt
BgL_arg3663z00_952;
{
BgL_variablez00_bglt
BgL_auxz00_1647;
BgL_auxz00_1647 =
(BgL_variablez00_bglt)
(BgL_localz00_951);
BgL_arg3663z00_952 =
(((BgL_variablez00_bglt) CREF(BgL_auxz00_1647))->BgL_valuez00);
}
{ /* Globalize/kapture.scm 102 */
BgL_svarzf2ginfozf2_bglt
BgL_obj3450z00_1474;
bool_t
BgL_val3449z00_1475;
BgL_obj3450z00_1474 =
(BgL_svarzf2ginfozf2_bglt)
(BgL_arg3663z00_952);
BgL_val3449z00_1475 =
((bool_t) 1);
{
obj_t BgL_auxz00_1651;
{ /* Globalize/kapture.scm 102 */
BgL_objectz00_bglt
BgL_auxz00_1652;
BgL_auxz00_1652 =
(BgL_objectz00_bglt)
(BgL_obj3450z00_1474);
BgL_auxz00_1651 =
BGL_OBJECT_WIDENING
(BgL_auxz00_1652);
}
((((BgL_svarzf2ginfozf2_bglt) CREF(BgL_auxz00_1651))->BgL_kapturedzf3zf3) = ((bool_t) BgL_val3449z00_1475), BUNSPEC);
}
}
}
}
{
obj_t BgL_l3648z00_1656;
BgL_l3648z00_1656 =
CDR(BgL_l3648z00_948);
BgL_l3648z00_948 =
BgL_l3648z00_1656;
goto
BgL_zc3anonymousza33661ze3z83_949;
}
}
else
{ /* Globalize/kapture.scm 101 */
BgL_auxz00_1643 =
((bool_t) 1);
}
BBOOL(BgL_auxz00_1643);
}
}
}
else
{ /* Globalize/kapture.scm 105 */
BgL_sfunzf2ginfozf2_bglt
BgL_obj3369z00_1477;
obj_t BgL_val3368z00_1478;
BgL_obj3369z00_1477 =
(BgL_sfunzf2ginfozf2_bglt)
(BgL_infoz00_929);
BgL_val3368z00_1478 = BFALSE;
{
obj_t BgL_auxz00_1660;
{ /* Globalize/kapture.scm 105 */
BgL_objectz00_bglt
BgL_auxz00_1661;
BgL_auxz00_1661 =
(BgL_objectz00_bglt)
(BgL_obj3369z00_1477);
BgL_auxz00_1660 =
BGL_OBJECT_WIDENING
(BgL_auxz00_1661);
}
((((BgL_sfunzf2ginfozf2_bglt)
CREF(BgL_auxz00_1660))->
BgL_kapturedz00) =
((obj_t) BgL_val3368z00_1478),
BUNSPEC);
}
}
{ /* Globalize/kapture.scm 106 */
obj_t BgL_v3650z00_955;
BgL_v3650z00_955 =
create_vector((int) (((long) 3)));
VECTOR_SET(BgL_v3650z00_955,
(int) (((long) 2)),
BgL_kapturedz00_946);
VECTOR_SET(BgL_v3650z00_955,
(int) (((long) 1)), BgL_lockingz00_3);
VECTOR_SET(BgL_v3650z00_955,
(int) (((long) 0)),
BBOOL(BgL_setterzf3zf3_941));
return BgL_v3650z00_955;
}
}
}
}
}
else
{ /* Globalize/kapture.scm 86 */
if (
(CAR(BgL_ctoz00_940) ==
(obj_t) (BgL_localz00_2)))
{ /* Globalize/kapture.scm 107 */
{
obj_t BgL_ctoz00_1678;
BgL_ctoz00_1678 = CDR(BgL_ctoz00_940);
BgL_ctoz00_940 = BgL_ctoz00_1678;
goto BgL_zc3anonymousza33659ze3z83_942;
}
}
else
{ /* Globalize/kapture.scm 113 */
bool_t BgL_testz00_1680;
{ /* Globalize/kapture.scm 113 */
BgL_sfunzf2ginfozf2_bglt
BgL_obj3323z00_1492;
{ /* Globalize/kapture.scm 113 */
BgL_valuez00_bglt BgL_auxz00_1681;
{ /* Globalize/kapture.scm 113 */
BgL_variablez00_bglt
BgL_obj1611z00_1491;
{ /* Globalize/kapture.scm 113 */
obj_t BgL_pairz00_1490;
BgL_pairz00_1490 = BgL_ctoz00_940;
BgL_obj1611z00_1491 =
(BgL_variablez00_bglt) (CAR
(BgL_pairz00_1490));
}
BgL_auxz00_1681 =
(((BgL_variablez00_bglt)
CREF(BgL_obj1611z00_1491))->
BgL_valuez00);
}
BgL_obj3323z00_1492 =
(BgL_sfunzf2ginfozf2_bglt)
(BgL_auxz00_1681);
}
{
obj_t BgL_auxz00_1686;
{ /* Globalize/kapture.scm 113 */
BgL_objectz00_bglt BgL_auxz00_1687;
BgL_auxz00_1687 =
(BgL_objectz00_bglt)
(BgL_obj3323z00_1492);
BgL_auxz00_1686 =
BGL_OBJECT_WIDENING
(BgL_auxz00_1687);
}
BgL_testz00_1680 =
(((BgL_sfunzf2ginfozf2_bglt)
CREF(BgL_auxz00_1686))->
BgL_gzf3zf3);
}
}
if (BgL_testz00_1680)
{ /* Globalize/kapture.scm 113 */
{ /* Globalize/kapture.scm 116 */
obj_t BgL_otherzd2kapturedzd2_960;
{ /* Globalize/kapture.scm 116 */
obj_t BgL_arg3679z00_971;
BgL_arg3679z00_971 =
CAR(BgL_ctoz00_940);
BgL_otherzd2kapturedzd2_960 =
BGl_setzd2onezd2kapturedz12z12zzglobaliza7e_kaptureza7
((BgL_localz00_bglt)
(BgL_arg3679z00_971),
BgL_lockingz00_3);
}
{ /* Globalize/kapture.scm 118 */
bool_t BgL_testz00_1694;
{ /* Globalize/kapture.scm 118 */
int BgL_kz00_1495;
BgL_kz00_1495 =
(int) (((long) 0));
BgL_testz00_1694 =
CBOOL(VECTOR_REF
(BgL_otherzd2kapturedzd2_960,
BgL_kz00_1495));
}
if (BgL_testz00_1694)
{ /* Globalize/kapture.scm 124 */
obj_t BgL_arg3670z00_962;
obj_t BgL_arg3671z00_963;
BgL_arg3670z00_962 =
MAKE_PAIR(VECTOR_REF
(BgL_otherzd2kapturedzd2_960,
(int) (((long) 2))),
BgL_kapturedz00_939);
BgL_arg3671z00_963 =
CDR(BgL_ctoz00_940);
{
obj_t BgL_ctoz00_1703;
obj_t BgL_kapturedz00_1702;
BgL_kapturedz00_1702 =
BgL_arg3670z00_962;
BgL_ctoz00_1703 =
BgL_arg3671z00_963;
BgL_ctoz00_940 =
BgL_ctoz00_1703;
BgL_kapturedz00_939 =
BgL_kapturedz00_1702;
goto
BgL_zc3anonymousza33659ze3z83_942;
}
}
else
{ /* Globalize/kapture.scm 119 */
obj_t BgL_arg3673z00_965;
obj_t BgL_arg3674z00_966;
bool_t BgL_arg3675z00_967;
BgL_arg3673z00_965 =
MAKE_PAIR(VECTOR_REF
(BgL_otherzd2kapturedzd2_960,
(int) (((long) 2))),
BgL_kapturedz00_939);
BgL_arg3674z00_966 =
CDR(BgL_ctoz00_940);
if (BgL_setterzf3zf3_941)
{ /* Globalize/kapture.scm 121 */
BgL_arg3675z00_967 =
(VECTOR_REF
(BgL_otherzd2kapturedzd2_960,
(int) (((long) 1))) ==
(obj_t) (BgL_localz00_2));
}
else
{ /* Globalize/kapture.scm 121 */
BgL_arg3675z00_967 =
((bool_t) 0);
}
{
bool_t BgL_setterzf3zf3_1715;
obj_t BgL_ctoz00_1714;
obj_t BgL_kapturedz00_1713;
BgL_kapturedz00_1713 =
BgL_arg3673z00_965;
BgL_ctoz00_1714 =
BgL_arg3674z00_966;
BgL_setterzf3zf3_1715 =
BgL_arg3675z00_967;
BgL_setterzf3zf3_941 =
BgL_setterzf3zf3_1715;
BgL_ctoz00_940 =
BgL_ctoz00_1714;
BgL_kapturedz00_939 =
BgL_kapturedz00_1713;
goto
BgL_zc3anonymousza33659ze3z83_942;
}
}
}
}
}
else
{ /* Globalize/kapture.scm 113 */
{
obj_t BgL_ctoz00_1716;
BgL_ctoz00_1716 = CDR(BgL_ctoz00_940);
BgL_ctoz00_940 = BgL_ctoz00_1716;
goto
BgL_zc3anonymousza33659ze3z83_942;
}
}
}
}
}
}
}
}
}
}
}
}
}
}
}
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);
}
/* make-ctype-accesses! */
BGL_EXPORTED_DEF obj_t
BGl_makezd2ctypezd2accessesz12z12zzforeign_accessz00(BgL_typez00_bglt
BgL_whatz00_1, BgL_typez00_bglt BgL_whoz00_2, obj_t BgL_locz00_3)
{
AN_OBJECT;
{ /* Foreign/access.scm 34 */
{ /* Foreign/access.scm 34 */
obj_t BgL_method1601z00_170;
{ /* Foreign/access.scm 34 */
BgL_objectz00_bglt BgL_objz00_171;
BgL_objz00_171 = (BgL_objectz00_bglt) (BgL_whatz00_1);
{ /* Foreign/access.scm 34 */
long BgL_objzd2classzd2numz00_172;
BgL_objzd2classzd2numz00_172 = BGL_OBJECT_CLASS_NUM(BgL_objz00_171);
{ /* Foreign/access.scm 34 */
obj_t BgL_arg2643z00_173;
BgL_arg2643z00_173 =
PROCEDURE_REF
(BGl_makezd2ctypezd2accessesz12zd2envzc0zzforeign_accessz00,
(int) (((long) 1)));
{ /* Foreign/access.scm 34 */
obj_t BgL_arrayz00_175;
int BgL_offsetz00_176;
BgL_arrayz00_175 = BgL_arg2643z00_173;
BgL_offsetz00_176 = (int) (BgL_objzd2classzd2numz00_172);
{ /* Foreign/access.scm 34 */
long BgL_offsetz00_177;
BgL_offsetz00_177 =
((long) (BgL_offsetz00_176) - OBJECT_TYPE);
{ /* Foreign/access.scm 34 */
long BgL_modz00_178;
{ /* Foreign/access.scm 34 */
int BgL_arg2645z00_179;
BgL_arg2645z00_179 = (int) (((long) 16));
{ /* Foreign/access.scm 34 */
long BgL_auxz00_225;
BgL_auxz00_225 = (long) (BgL_arg2645z00_179);
BgL_modz00_178 = (BgL_offsetz00_177 / BgL_auxz00_225);
}}
{ /* Foreign/access.scm 34 */
long BgL_restz00_180;
{ /* Foreign/access.scm 34 */
int BgL_arg2644z00_181;
BgL_arg2644z00_181 = (int) (((long) 16));
{ /* Foreign/access.scm 34 */
long BgL_auxz00_229;
BgL_auxz00_229 = (long) (BgL_arg2644z00_181);
BgL_restz00_180 =
(BgL_offsetz00_177 % BgL_auxz00_229);
}}
{ /* Foreign/access.scm 34 */
BgL_method1601z00_170 =
VECTOR_REF(VECTOR_REF(BgL_arrayz00_175,
(int) (BgL_modz00_178)), (int) (BgL_restz00_180));
}}}}}}}}
return
PROCEDURE_ENTRY(BgL_method1601z00_170) (BgL_method1601z00_170,
(obj_t) (BgL_whatz00_1), (obj_t) (BgL_whoz00_2), BgL_locz00_3, BEOA);
}
}
}
static SCM
eval (SCM x, SCM env)
{
SCM mx;
SCM proc = SCM_UNDEFINED, args = SCM_EOL;
unsigned int argc;
loop:
SCM_TICK;
mx = SCM_MEMOIZED_ARGS (x);
switch (SCM_I_INUM (SCM_CAR (x)))
{
case SCM_M_SEQ:
eval (CAR (mx), env);
x = CDR (mx);
goto loop;
case SCM_M_IF:
if (scm_is_true (EVAL1 (CAR (mx), env)))
x = CADR (mx);
else
x = CDDR (mx);
goto loop;
case SCM_M_LET:
{
SCM inits = CAR (mx);
SCM new_env;
int i;
new_env = make_env (VECTOR_LENGTH (inits), SCM_UNDEFINED, env);
for (i = 0; i < VECTOR_LENGTH (inits); i++)
env_set (new_env, 0, i, EVAL1 (VECTOR_REF (inits, i), env));
env = new_env;
x = CDR (mx);
goto loop;
}
case SCM_M_LAMBDA:
RETURN_BOOT_CLOSURE (mx, env);
case SCM_M_CAPTURE_ENV:
{
SCM locs = CAR (mx);
SCM new_env;
int i;
new_env = make_env (VECTOR_LENGTH (locs), SCM_BOOL_F, env);
for (i = 0; i < VECTOR_LENGTH (locs); i++)
{
SCM loc = VECTOR_REF (locs, i);
int depth, width;
depth = SCM_I_INUM (CAR (loc));
width = SCM_I_INUM (CDR (loc));
env_set (new_env, 0, i, env_ref (env, depth, width));
}
env = new_env;
x = CDR (mx);
goto loop;
}
case SCM_M_QUOTE:
return mx;
case SCM_M_CAPTURE_MODULE:
return eval (mx, scm_current_module ());
case SCM_M_APPLY:
/* Evaluate the procedure to be applied. */
proc = EVAL1 (CAR (mx), env);
/* Evaluate the argument holding the list of arguments */
args = EVAL1 (CADR (mx), env);
apply_proc:
/* Go here to tail-apply a procedure. PROC is the procedure and
* ARGS is the list of arguments. */
if (BOOT_CLOSURE_P (proc))
{
prepare_boot_closure_env_for_apply (proc, args, &x, &env);
goto loop;
}
else
return scm_apply_0 (proc, args);
case SCM_M_CALL:
/* Evaluate the procedure to be applied. */
proc = EVAL1 (CAR (mx), env);
argc = scm_ilength (CDR (mx));
mx = CDR (mx);
if (BOOT_CLOSURE_P (proc))
{
prepare_boot_closure_env_for_eval (proc, argc, mx, &x, &env);
goto loop;
}
else
{
SCM *argv;
unsigned int i;
argv = alloca (argc * sizeof (SCM));
for (i = 0; i < argc; i++, mx = CDR (mx))
argv[i] = EVAL1 (CAR (mx), env);
return scm_call_n (proc, argv, argc);
}
case SCM_M_CONT:
return scm_i_call_with_current_continuation (EVAL1 (mx, env));
case SCM_M_CALL_WITH_VALUES:
{
SCM producer;
SCM v;
producer = EVAL1 (CAR (mx), env);
/* `proc' is the consumer. */
proc = EVAL1 (CDR (mx), env);
v = scm_call_0 (producer);
if (SCM_VALUESP (v))
args = scm_struct_ref (v, SCM_INUM0);
else
args = scm_list_1 (v);
goto apply_proc;
}
case SCM_M_LEXICAL_REF:
{
SCM pos;
int depth, width;
pos = mx;
depth = SCM_I_INUM (CAR (pos));
width = SCM_I_INUM (CDR (pos));
return env_ref (env, depth, width);
}
case SCM_M_LEXICAL_SET:
{
SCM pos;
int depth, width;
SCM val = EVAL1 (CDR (mx), env);
pos = CAR (mx);
depth = SCM_I_INUM (CAR (pos));
width = SCM_I_INUM (CDR (pos));
env_set (env, depth, width, val);
return SCM_UNSPECIFIED;
}
case SCM_M_BOX_REF:
{
SCM box = mx;
return scm_variable_ref (EVAL1 (box, env));
}
case SCM_M_BOX_SET:
{
SCM box = CAR (mx), val = CDR (mx);
return scm_variable_set_x (EVAL1 (box, env), EVAL1 (val, env));
}
case SCM_M_RESOLVE:
if (SCM_VARIABLEP (mx))
return mx;
else
{
SCM var;
var = scm_sys_resolve_variable (mx, env_tail (env));
scm_set_cdr_x (x, var);
return var;
}
case SCM_M_CALL_WITH_PROMPT:
{
struct scm_vm *vp;
SCM k, handler, res;
scm_i_jmp_buf registers;
scm_t_ptrdiff saved_stack_depth;
k = EVAL1 (CAR (mx), env);
handler = EVAL1 (CDDR (mx), env);
vp = scm_the_vm ();
saved_stack_depth = vp->stack_top - vp->sp;
/* Push the prompt onto the dynamic stack. */
scm_dynstack_push_prompt (&SCM_I_CURRENT_THREAD->dynstack,
SCM_F_DYNSTACK_PROMPT_ESCAPE_ONLY,
k,
vp->stack_top - vp->fp,
saved_stack_depth,
vp->ip,
®isters);
if (SCM_I_SETJMP (registers))
{
/* The prompt exited nonlocally. */
scm_gc_after_nonlocal_exit ();
proc = handler;
args = scm_i_prompt_pop_abort_args_x (vp, saved_stack_depth);
goto apply_proc;
}
res = scm_call_0 (eval (CADR (mx), env));
scm_dynstack_pop (&SCM_I_CURRENT_THREAD->dynstack);
return res;
}
default:
abort ();
}
}
/* <anonymous:1896> */
obj_t BGl_zc3anonymousza31896ze3z83zz__lalr_driverz00(obj_t BgL_envz00_1579,
obj_t BgL_rgcz00_1582, obj_t BgL_inputzd2portzd2_1583,
obj_t BgL_iszd2eofzf3z21_1584)
{
AN_OBJECT;
{ /* Lalr/driver.scm 61 */
{ /* Lalr/driver.scm 69 */
obj_t BgL_actionzd2tablezd2_1580;
obj_t BgL_reductionzd2functionzd2_1581;
BgL_actionzd2tablezd2_1580 =
PROCEDURE_REF(BgL_envz00_1579, (int) (((long) 0)));
BgL_reductionzd2functionzd2_1581 =
PROCEDURE_REF(BgL_envz00_1579, (int) (((long) 1)));
{
obj_t BgL_rgcz00_782;
obj_t BgL_inputzd2portzd2_783;
obj_t BgL_iszd2eofzf3z21_784;
BgL_rgcz00_782 = BgL_rgcz00_1582;
BgL_inputzd2portzd2_783 = BgL_inputzd2portzd2_1583;
BgL_iszd2eofzf3z21_784 = BgL_iszd2eofzf3z21_1584;
{ /* Lalr/driver.scm 69 */
obj_t BgL_stackz00_787;
obj_t BgL_statez00_788;
obj_t BgL_inputz00_789;
obj_t BgL_inz00_790;
obj_t BgL_attrz00_791;
obj_t BgL_actsz00_792;
obj_t BgL_actz00_793;
bool_t BgL_eofzf3zf3_794;
bool_t BgL_debugz00_795;
BgL_stackz00_787 =
make_vector(
(int) (BGl_za2maxzd2stackzd2siza7eza2za7zz__lalr_driverz00),
BINT(((long) 0)));
BgL_statez00_788 = BFALSE;
BgL_inputz00_789 = BFALSE;
BgL_inz00_790 = BFALSE;
BgL_attrz00_791 = BFALSE;
BgL_actsz00_792 = BFALSE;
BgL_actz00_793 = BFALSE;
BgL_eofzf3zf3_794 = ((bool_t) 0);
{ /* Lalr/driver.scm 77 */
int BgL_arg1940z00_840;
BgL_arg1940z00_840 = bgl_debug();
BgL_debugz00_795 = ((long) (BgL_arg1940z00_840) >= ((long) 100));
}
{
obj_t BgL_spz00_797;
BgL_spz00_797 = BINT(((long) 0));
BgL_zc3anonymousza31897ze3z83_798:
BgL_statez00_788 =
VECTOR_REF(BgL_stackz00_787, CINT(BgL_spz00_797));
BgL_actsz00_792 =
VECTOR_REF(BgL_actionzd2tablezd2_1580, CINT(BgL_statez00_788));
if (NULLP(CDR(BgL_actsz00_792)))
{ /* Lalr/driver.scm 84 */
obj_t BgL_pairz00_1311;
BgL_pairz00_1311 = BgL_actsz00_792;
BgL_actz00_793 = CDR(CAR(BgL_pairz00_1311));
}
else
{ /* Lalr/driver.scm 83 */
if (CBOOL(BgL_inputz00_789))
{ /* Lalr/driver.scm 86 */
BFALSE;
}
else
{ /* Lalr/driver.scm 86 */
BgL_inputz00_789 =
PROCEDURE_ENTRY(BgL_rgcz00_782) (BgL_rgcz00_782,
BgL_inputzd2portzd2_783, BEOA);
}
if (CBOOL(BgL_inputz00_789))
{ /* Lalr/driver.scm 88 */
((bool_t) 0);
}
else
{ /* Lalr/driver.scm 88 */
bgl_system_failure(BGL_IO_PARSE_ERROR,
BGl_symbol2208z00zz__lalr_driverz00,
BGl_string2210z00zz__lalr_driverz00, BFALSE);
}
if (CBOOL(PROCEDURE_ENTRY(BgL_iszd2eofzf3z21_784)
(BgL_iszd2eofzf3z21_784, BgL_inputz00_789, BEOA)))
{ /* Lalr/driver.scm 94 */
BgL_inz00_790 = BGl_symbol2211z00zz__lalr_driverz00;
BgL_attrz00_791 = BFALSE;
BgL_eofzf3zf3_794 = ((bool_t) 1);
}
else
{ /* Lalr/driver.scm 94 */
if (PAIRP(BgL_inputz00_789))
{ /* Lalr/driver.scm 98 */
BgL_inz00_790 = CAR(BgL_inputz00_789);
BgL_attrz00_791 = CDR(BgL_inputz00_789);
}
else
{ /* Lalr/driver.scm 98 */
BgL_inz00_790 = BgL_inputz00_789;
BgL_attrz00_791 = BFALSE;
}
}
{ /* Lalr/driver.scm 105 */
obj_t BgL_xz00_1318;
obj_t BgL_lz00_1319;
BgL_xz00_1318 = BgL_inz00_790;
BgL_lz00_1319 = BgL_actsz00_792;
{ /* Lalr/driver.scm 105 */
obj_t BgL_yz00_1320;
BgL_yz00_1320 =
BGl_assqz00zz__r4_pairs_and_lists_6_3z00(BgL_xz00_1318,
BgL_lz00_1319);
if (CBOOL(BgL_yz00_1320))
{ /* Lalr/driver.scm 105 */
BgL_actz00_793 = CDR(BgL_yz00_1320);
}
else
{ /* Lalr/driver.scm 105 */
obj_t BgL_pairz00_1322;
BgL_pairz00_1322 = BgL_lz00_1319;
BgL_actz00_793 = CDR(CAR(BgL_pairz00_1322));
}
}
}
}
if (BgL_debugz00_795)
{ /* Lalr/driver.scm 107 */
{ /* Lalr/driver.scm 108 */
obj_t BgL_arg1903z00_804;
{ /* Lalr/driver.scm 108 */
obj_t BgL_res2190z00_1327;
{ /* Lalr/driver.scm 108 */
obj_t BgL_auxz00_1662;
BgL_auxz00_1662 = BGL_CURRENT_DYNAMIC_ENV();
BgL_res2190z00_1327 =
BGL_ENV_CURRENT_ERROR_PORT(BgL_auxz00_1662);
}
BgL_arg1903z00_804 = BgL_res2190z00_1327;
}
bgl_display_string(BGl_string2213z00zz__lalr_driverz00,
BgL_arg1903z00_804);
}
{ /* Lalr/driver.scm 109 */
obj_t BgL_arg1904z00_805;
{ /* Lalr/driver.scm 109 */
obj_t BgL_res2191z00_1331;
{ /* Lalr/driver.scm 109 */
obj_t BgL_auxz00_1666;
BgL_auxz00_1666 = BGL_CURRENT_DYNAMIC_ENV();
BgL_res2191z00_1331 =
BGL_ENV_CURRENT_ERROR_PORT(BgL_auxz00_1666);
}
BgL_arg1904z00_805 = BgL_res2191z00_1331;
}
{ /* Lalr/driver.scm 109 */
obj_t BgL_list1905z00_806;
BgL_list1905z00_806 = MAKE_PAIR(BgL_arg1904z00_805, BNIL);
BGl_writez00zz__r4_output_6_10_3z00(BgL_inz00_790,
BgL_list1905z00_806);
}
}
{ /* Lalr/driver.scm 110 */
obj_t BgL_arg1907z00_808;
{ /* Lalr/driver.scm 110 */
obj_t BgL_res2192z00_1333;
{ /* Lalr/driver.scm 110 */
obj_t BgL_auxz00_1671;
BgL_auxz00_1671 = BGL_CURRENT_DYNAMIC_ENV();
BgL_res2192z00_1333 =
BGL_ENV_CURRENT_ERROR_PORT(BgL_auxz00_1671);
}
BgL_arg1907z00_808 = BgL_res2192z00_1333;
}
bgl_display_string(BGl_string2214z00zz__lalr_driverz00,
BgL_arg1907z00_808);
}
{ /* Lalr/driver.scm 111 */
obj_t BgL_arg1908z00_809;
{ /* Lalr/driver.scm 111 */
obj_t BgL_res2193z00_1337;
{ /* Lalr/driver.scm 111 */
obj_t BgL_auxz00_1675;
BgL_auxz00_1675 = BGL_CURRENT_DYNAMIC_ENV();
BgL_res2193z00_1337 =
BGL_ENV_CURRENT_ERROR_PORT(BgL_auxz00_1675);
}
BgL_arg1908z00_809 = BgL_res2193z00_1337;
}
{ /* Lalr/driver.scm 111 */
obj_t BgL_list1909z00_810;
BgL_list1909z00_810 = MAKE_PAIR(BgL_arg1908z00_809, BNIL);
BGl_writez00zz__r4_output_6_10_3z00(BgL_statez00_788,
BgL_list1909z00_810);
}
}
{ /* Lalr/driver.scm 112 */
obj_t BgL_arg1911z00_812;
{ /* Lalr/driver.scm 112 */
obj_t BgL_res2194z00_1339;
{ /* Lalr/driver.scm 112 */
obj_t BgL_auxz00_1680;
BgL_auxz00_1680 = BGL_CURRENT_DYNAMIC_ENV();
BgL_res2194z00_1339 =
BGL_ENV_CURRENT_ERROR_PORT(BgL_auxz00_1680);
}
BgL_arg1911z00_812 = BgL_res2194z00_1339;
}
bgl_display_string(BGl_string2215z00zz__lalr_driverz00,
BgL_arg1911z00_812);
}
{ /* Lalr/driver.scm 113 */
obj_t BgL_arg1912z00_813;
{ /* Lalr/driver.scm 113 */
obj_t BgL_res2195z00_1343;
{ /* Lalr/driver.scm 113 */
obj_t BgL_auxz00_1684;
BgL_auxz00_1684 = BGL_CURRENT_DYNAMIC_ENV();
BgL_res2195z00_1343 =
BGL_ENV_CURRENT_ERROR_PORT(BgL_auxz00_1684);
}
BgL_arg1912z00_813 = BgL_res2195z00_1343;
}
{ /* Lalr/driver.scm 113 */
obj_t BgL_list1913z00_814;
BgL_list1913z00_814 = MAKE_PAIR(BgL_arg1912z00_813, BNIL);
BGl_writez00zz__r4_output_6_10_3z00(BgL_spz00_797,
BgL_list1913z00_814);
}
}
{ /* Lalr/driver.scm 114 */
obj_t BgL_arg1914z00_815;
{ /* Lalr/driver.scm 114 */
obj_t BgL_res2196z00_1345;
{ /* Lalr/driver.scm 114 */
obj_t BgL_auxz00_1689;
BgL_auxz00_1689 = BGL_CURRENT_DYNAMIC_ENV();
BgL_res2196z00_1345 =
BGL_ENV_CURRENT_ERROR_PORT(BgL_auxz00_1689);
}
BgL_arg1914z00_815 = BgL_res2196z00_1345;
}
bgl_display_char(((unsigned char) '\n'),
BgL_arg1914z00_815);
}}
else
{ /* Lalr/driver.scm 107 */
BFALSE;
}
if ((BgL_actz00_793 == BGl_symbol2216z00zz__lalr_driverz00))
{ /* Lalr/driver.scm 119 */
return VECTOR_REF(BgL_stackz00_787, (int) (((long) 1)));
}
else
{ /* Lalr/driver.scm 123 */
bool_t BgL_testz00_1697;
if ((BgL_actz00_793 == BGl_symbol2218z00zz__lalr_driverz00))
{ /* Lalr/driver.scm 123 */
BgL_testz00_1697 = ((bool_t) 1);
}
else
{ /* Lalr/driver.scm 123 */
BgL_testz00_1697 =
(BgL_actz00_793 == BGl_symbol2220z00zz__lalr_driverz00);
}
if (BgL_testz00_1697)
{ /* Lalr/driver.scm 124 */
obj_t BgL_msgz00_818;
{ /* Lalr/driver.scm 124 */
obj_t BgL_arg1919z00_820;
if (SYMBOLP(BgL_inz00_790))
{ /* Lalr/driver.scm 128 */
obj_t BgL_res2197z00_1352;
{ /* Lalr/driver.scm 128 */
obj_t BgL_symbolz00_1350;
BgL_symbolz00_1350 = BgL_inz00_790;
{ /* Lalr/driver.scm 128 */
obj_t BgL_arg2113z00_1351;
BgL_arg2113z00_1351 =
SYMBOL_TO_STRING(BgL_symbolz00_1350);
BgL_res2197z00_1352 =
BGl_stringzd2copyzd2zz__r4_strings_6_7z00
(BgL_arg2113z00_1351);
}
}
BgL_arg1919z00_820 = BgL_res2197z00_1352;
}
else
{ /* Lalr/driver.scm 127 */
if (CHARP(BgL_inz00_790))
{ /* Lalr/driver.scm 130 */
obj_t BgL_list1923z00_824;
BgL_list1923z00_824 =
MAKE_PAIR(BgL_inz00_790, BNIL);
{ /* Lalr/driver.scm 130 */
obj_t BgL_res2198z00_1360;
{ /* Lalr/driver.scm 130 */
obj_t BgL_arg2107z00_1357;
BgL_arg2107z00_1357 =
CAR(BgL_list1923z00_824);
BgL_res2198z00_1360 =
make_string(((long) 1),
CCHAR(BgL_arg2107z00_1357));
}
BgL_arg1919z00_820 = BgL_res2198z00_1360;
}}
else
{ /* Lalr/driver.scm 132 */
obj_t BgL_portz00_825;
{ /* Lalr/driver.scm 132 */
{ /* Ieee/port.scm 386 */
BgL_portz00_825 =
BGl_openzd2outputzd2stringz00zz__r4_ports_6_10_1z00
(BTRUE);
}
}
{ /* Lalr/driver.scm 133 */
obj_t BgL_list1924z00_826;
BgL_list1924z00_826 =
MAKE_PAIR(BgL_portz00_825, BNIL);
BGl_writez00zz__r4_output_6_10_3z00
(BgL_inz00_790, BgL_list1924z00_826);
}
BgL_arg1919z00_820 =
bgl_close_output_port(BgL_portz00_825);
}
}
BgL_msgz00_818 =
string_append_3(BGl_string2222z00zz__lalr_driverz00,
BgL_arg1919z00_820,
BGl_string2223z00zz__lalr_driverz00);
}
return
bgl_system_failure(BGL_IO_PARSE_ERROR,
BGl_string2209z00zz__lalr_driverz00, BgL_msgz00_818,
BgL_inputz00_789);
}
else
{ /* Lalr/driver.scm 123 */
if (((long) CINT(BgL_actz00_793) >= ((long) 0)))
{ /* Lalr/driver.scm 139 */
{ /* Lalr/driver.scm 140 */
bool_t BgL_testz00_1720;
{ /* Lalr/driver.scm 140 */
long BgL_arg1927z00_830;
{ /* Lalr/driver.scm 140 */
int BgL_arg1929z00_831;
BgL_arg1929z00_831 =
VECTOR_LENGTH(BgL_stackz00_787);
BgL_arg1927z00_830 =
((long) (BgL_arg1929z00_831) - ((long) 4));
}
BgL_testz00_1720 =
(
(long) CINT(BgL_spz00_797) >=
BgL_arg1927z00_830);
}
if (BgL_testz00_1720)
{ /* Lalr/driver.scm 140 */
BgL_stackz00_787 =
BGl_growzd2stackz12zc0zz__lalr_driverz00
(BgL_stackz00_787);
}
else
{ /* Lalr/driver.scm 140 */
BFALSE;
}
}
{ /* Lalr/driver.scm 142 */
long BgL_arg1931z00_833;
BgL_arg1931z00_833 =
((long) CINT(BgL_spz00_797) + ((long) 1));
VECTOR_SET(BgL_stackz00_787,
(int) (BgL_arg1931z00_833), BgL_attrz00_791);
}
{ /* Lalr/driver.scm 143 */
long BgL_arg1932z00_834;
BgL_arg1932z00_834 =
((long) CINT(BgL_spz00_797) + ((long) 2));
VECTOR_SET(BgL_stackz00_787,
(int) (BgL_arg1932z00_834), BgL_actz00_793);
}
if (BgL_eofzf3zf3_794)
{ /* Lalr/driver.scm 144 */
BFALSE;
}
else
{ /* Lalr/driver.scm 144 */
BgL_inputz00_789 = BFALSE;
}
{ /* Lalr/driver.scm 146 */
long BgL_arg1935z00_835;
BgL_arg1935z00_835 =
((long) CINT(BgL_spz00_797) + ((long) 2));
{
obj_t BgL_spz00_1738;
BgL_spz00_1738 = BINT(BgL_arg1935z00_835);
BgL_spz00_797 = BgL_spz00_1738;
goto BgL_zc3anonymousza31897ze3z83_798;
}
}
}
else
{ /* Lalr/driver.scm 150 */
obj_t BgL_arg1937z00_836;
{ /* Lalr/driver.scm 150 */
long BgL_arg1938z00_837;
BgL_arg1938z00_837 =
NEG((long) CINT(BgL_actz00_793));
BgL_arg1937z00_836 =
PROCEDURE_ENTRY(BgL_reductionzd2functionzd2_1581)
(BgL_reductionzd2functionzd2_1581,
BINT(BgL_arg1938z00_837), BgL_stackz00_787,
BgL_spz00_797, BEOA);
}
{
obj_t BgL_spz00_1745;
BgL_spz00_1745 = BgL_arg1937z00_836;
BgL_spz00_797 = BgL_spz00_1745;
goto BgL_zc3anonymousza31897ze3z83_798;
}
}
}
}
}
}
}
}
}
}
static SCM
next_rib (SCM env)
{
return VECTOR_REF (env, 0);
}
/* vector->tvector */
BGL_EXPORTED_DEF obj_t BGl_vectorzd2ze3tvectorz31zz__tvectorz00(obj_t
BgL_idz00_30, obj_t BgL_vz00_31)
{
AN_OBJECT;
{ /* Llib/tvector.scm 186 */
{ /* Llib/tvector.scm 187 */
obj_t BgL_descrz00_814;
if (PAIRP(BGl_za2tvectorzd2tableza2zd2zz__tvectorz00))
{ /* Llib/tvector.scm 187 */
obj_t BgL_cellz00_1428;
BgL_cellz00_1428 =
BGl_assqz00zz__r4_pairs_and_lists_6_3z00(BgL_idz00_30,
BGl_za2tvectorzd2tableza2zd2zz__tvectorz00);
if (PAIRP(BgL_cellz00_1428))
{ /* Llib/tvector.scm 187 */
BgL_descrz00_814 = CDR(BgL_cellz00_1428);
}
else
{ /* Llib/tvector.scm 187 */
BgL_descrz00_814 = BFALSE;
}
}
else
{ /* Llib/tvector.scm 187 */
BgL_descrz00_814 = BFALSE;
}
if (CBOOL(BgL_descrz00_814))
{ /* Llib/tvector.scm 190 */
obj_t BgL_allocatez00_815;
obj_t BgL_setz00_816;
BgL_allocatez00_815 =
STRUCT_REF(BgL_descrz00_814, (int) (((long) 1)));
BgL_setz00_816 = STRUCT_REF(BgL_descrz00_814, (int) (((long) 3)));
if (PROCEDUREP(BgL_setz00_816))
{ /* Llib/tvector.scm 196 */
int BgL_lenz00_818;
BgL_lenz00_818 = VECTOR_LENGTH(BgL_vz00_31);
{ /* Llib/tvector.scm 196 */
obj_t BgL_tvecz00_819;
BgL_tvecz00_819 =
PROCEDURE_ENTRY(BgL_allocatez00_815) (BgL_allocatez00_815,
BINT(BgL_lenz00_818), BEOA);
{ /* Llib/tvector.scm 197 */
{ /* Llib/tvector.scm 198 */
long BgL_g1825z00_820;
BgL_g1825z00_820 = ((long) (BgL_lenz00_818) - ((long) 1));
{
long BgL_iz00_822;
BgL_iz00_822 = BgL_g1825z00_820;
BgL_zc3anonymousza31911ze3z83_823:
if ((BgL_iz00_822 == ((long) -1)))
{ /* Llib/tvector.scm 199 */
return BgL_tvecz00_819;
}
else
{ /* Llib/tvector.scm 199 */
{ /* Llib/tvector.scm 202 */
obj_t BgL_arg1914z00_825;
BgL_arg1914z00_825 =
VECTOR_REF(BgL_vz00_31, (int) (BgL_iz00_822));
PROCEDURE_ENTRY(BgL_setz00_816) (BgL_setz00_816,
BgL_tvecz00_819, BINT(BgL_iz00_822),
BgL_arg1914z00_825, BEOA);
}
{
long BgL_iz00_1875;
BgL_iz00_1875 = (BgL_iz00_822 - ((long) 1));
BgL_iz00_822 = BgL_iz00_1875;
goto BgL_zc3anonymousza31911ze3z83_823;
}
}
}
}
}
}
}
else
{ /* Llib/tvector.scm 192 */
return
BGl_errorz00zz__errorz00(BGl_string2219z00zz__tvectorz00,
BGl_string2215z00zz__tvectorz00, BgL_idz00_30);
}
}
else
{ /* Llib/tvector.scm 188 */
return
BGl_errorz00zz__errorz00(BGl_string2219z00zz__tvectorz00,
BGl_string2216z00zz__tvectorz00, BgL_idz00_30);
}
}
}
}
void
Interpret (int pop_return_p)
{
long dispatch_code;
struct interpreter_state_s new_state;
/* Primitives jump back here for errors, requests to evaluate an
expression, apply a function, or handle an interrupt request. On
errors or interrupts they leave their arguments on the stack, the
primitive itself in GET_EXP. The code should do a primitive
backout in these cases, but not in others (apply, eval, etc.),
since the primitive itself will have left the state of the
interpreter ready for operation. */
bind_interpreter_state (&new_state);
dispatch_code = (setjmp (interpreter_catch_env));
preserve_signal_mask ();
fixup_float_environment ();
switch (dispatch_code)
{
case 0: /* first time */
if (pop_return_p)
goto pop_return; /* continue */
else
break; /* fall into eval */
case PRIM_APPLY:
PROCEED_AFTER_PRIMITIVE ();
goto internal_apply;
case PRIM_NO_TRAP_APPLY:
PROCEED_AFTER_PRIMITIVE ();
goto Apply_Non_Trapping;
case PRIM_APPLY_INTERRUPT:
PROCEED_AFTER_PRIMITIVE ();
PREPARE_APPLY_INTERRUPT ();
SIGNAL_INTERRUPT (PENDING_INTERRUPTS ());
case PRIM_APPLY_ERROR:
PROCEED_AFTER_PRIMITIVE ();
APPLICATION_ERROR (prim_apply_error_code);
case PRIM_DO_EXPRESSION:
SET_VAL (GET_EXP);
PROCEED_AFTER_PRIMITIVE ();
REDUCES_TO (GET_VAL);
case PRIM_NO_TRAP_EVAL:
SET_VAL (GET_EXP);
PROCEED_AFTER_PRIMITIVE ();
NEW_REDUCTION (GET_VAL, GET_ENV);
goto eval_non_trapping;
case PRIM_POP_RETURN:
PROCEED_AFTER_PRIMITIVE ();
goto pop_return;
case PRIM_RETURN_TO_C:
PROCEED_AFTER_PRIMITIVE ();
unbind_interpreter_state (interpreter_state);
return;
case PRIM_NO_TRAP_POP_RETURN:
PROCEED_AFTER_PRIMITIVE ();
goto pop_return_non_trapping;
case PRIM_INTERRUPT:
back_out_of_primitive ();
SIGNAL_INTERRUPT (PENDING_INTERRUPTS ());
case PRIM_ABORT_TO_C:
back_out_of_primitive ();
unbind_interpreter_state (interpreter_state);
return;
case ERR_ARG_1_WRONG_TYPE:
back_out_of_primitive ();
Do_Micro_Error (ERR_ARG_1_WRONG_TYPE, true);
goto internal_apply;
case ERR_ARG_2_WRONG_TYPE:
back_out_of_primitive ();
Do_Micro_Error (ERR_ARG_2_WRONG_TYPE, true);
goto internal_apply;
case ERR_ARG_3_WRONG_TYPE:
back_out_of_primitive ();
Do_Micro_Error (ERR_ARG_3_WRONG_TYPE, true);
goto internal_apply;
default:
back_out_of_primitive ();
Do_Micro_Error (dispatch_code, true);
goto internal_apply;
}
do_expression:
/* GET_EXP has an Scode item in it that should be evaluated and the
result left in GET_VAL.
A "break" after the code for any operation indicates that all
processing for this operation has been completed, and the next
step will be to pop a return code off the stack and proceed at
pop_return. This is sometimes called "executing the
continuation" since the return code can be considered the
continuation to be performed after the operation.
An operation can terminate with a REDUCES_TO or REDUCES_TO_NTH
macro. This indicates that the value of the current Scode item
is the value returned when the new expression is evaluated.
Therefore no new continuation is created and processing continues
at do_expression with the new expression in GET_EXP.
Finally, an operation can terminate with a DO_NTH_THEN macro.
This indicates that another expression must be evaluated and them
some additional processing will be performed before the value of
this S-Code item available. Thus a new continuation is created
and placed on the stack (using SAVE_CONT), the new expression is
placed in the GET_EXP, and processing continues at do_expression.
*/
/* Handling of Eval Trapping.
If we are handling traps and there is an Eval Trap set, turn off
all trapping and then go to internal_apply to call the user
supplied eval hook with the expression to be evaluated and the
environment. */
#ifdef COMPILE_STEPPER
if (trapping
&& (!WITHIN_CRITICAL_SECTION_P ())
&& ((FETCH_EVAL_TRAPPER ()) != SHARP_F))
{
trapping = false;
Will_Push (4);
PUSH_ENV ();
PUSH_EXP ();
STACK_PUSH (FETCH_EVAL_TRAPPER ());
PUSH_APPLY_FRAME_HEADER (2);
Pushed ();
goto Apply_Non_Trapping;
}
#endif /* COMPILE_STEPPER */
eval_non_trapping:
#ifdef EVAL_UCODE_HOOK
EVAL_UCODE_HOOK ();
#endif
switch (OBJECT_TYPE (GET_EXP))
{
case TC_BIG_FIXNUM: /* The self evaluating items */
case TC_BIG_FLONUM:
case TC_CHARACTER_STRING:
case TC_CHARACTER:
case TC_COMPILED_CODE_BLOCK:
case TC_COMPLEX:
case TC_CONTROL_POINT:
case TC_DELAYED:
case TC_ENTITY:
case TC_ENVIRONMENT:
case TC_EXTENDED_PROCEDURE:
case TC_FIXNUM:
case TC_HUNK3_A:
case TC_HUNK3_B:
case TC_INTERNED_SYMBOL:
case TC_LIST:
case TC_NON_MARKED_VECTOR:
case TC_NULL:
case TC_PRIMITIVE:
case TC_PROCEDURE:
case TC_QUAD:
case TC_RATNUM:
case TC_REFERENCE_TRAP:
case TC_RETURN_CODE:
case TC_UNINTERNED_SYMBOL:
case TC_CONSTANT:
case TC_VECTOR:
case TC_VECTOR_16B:
case TC_VECTOR_1B:
default:
SET_VAL (GET_EXP);
break;
case TC_ACCESS:
Will_Push (CONTINUATION_SIZE);
PUSH_NTH_THEN (RC_EXECUTE_ACCESS_FINISH, ACCESS_ENVIRONMENT);
case TC_ASSIGNMENT:
Will_Push (CONTINUATION_SIZE + 1);
PUSH_ENV ();
PUSH_NTH_THEN (RC_EXECUTE_ASSIGNMENT_FINISH, ASSIGN_VALUE);
case TC_BROKEN_HEART:
Microcode_Termination (TERM_BROKEN_HEART);
case TC_COMBINATION:
{
long length = ((VECTOR_LENGTH (GET_EXP)) - 1);
Will_Push (length + 2 + CONTINUATION_SIZE);
stack_pointer = (STACK_LOC (-length));
STACK_PUSH (MAKE_OBJECT (TC_MANIFEST_NM_VECTOR, length));
/* The finger: last argument number */
Pushed ();
if (length == 0)
{
PUSH_APPLY_FRAME_HEADER (0); /* Frame size */
DO_NTH_THEN (RC_COMB_APPLY_FUNCTION, COMB_FN_SLOT);
}
PUSH_ENV ();
DO_NTH_THEN (RC_COMB_SAVE_VALUE, (length + 1));
}
case TC_COMBINATION_1:
Will_Eventually_Push (CONTINUATION_SIZE + STACK_ENV_FIRST_ARG + 1);
PUSH_ENV ();
DO_NTH_THEN (RC_COMB_1_PROCEDURE, COMB_1_ARG_1);
case TC_COMBINATION_2:
Will_Eventually_Push (CONTINUATION_SIZE + STACK_ENV_FIRST_ARG + 2);
PUSH_ENV ();
DO_NTH_THEN (RC_COMB_2_FIRST_OPERAND, COMB_2_ARG_2);
case TC_COMMENT:
REDUCES_TO_NTH (COMMENT_EXPRESSION);
case TC_CONDITIONAL:
Will_Push (CONTINUATION_SIZE + 1);
PUSH_ENV ();
PUSH_NTH_THEN (RC_CONDITIONAL_DECIDE, COND_PREDICATE);
#ifdef CC_SUPPORT_P
case TC_COMPILED_ENTRY:
dispatch_code = (enter_compiled_expression ());
goto return_from_compiled_code;
#endif
case TC_DEFINITION:
Will_Push (CONTINUATION_SIZE + 1);
PUSH_ENV ();
PUSH_NTH_THEN (RC_EXECUTE_DEFINITION_FINISH, DEFINE_VALUE);
case TC_DELAY:
/* Deliberately omitted: EVAL_GC_CHECK (2); */
SET_VAL (MAKE_POINTER_OBJECT (TC_DELAYED, Free));
(Free[THUNK_ENVIRONMENT]) = GET_ENV;
(Free[THUNK_PROCEDURE]) = (MEMORY_REF (GET_EXP, DELAY_OBJECT));
Free += 2;
break;
case TC_DISJUNCTION:
Will_Push (CONTINUATION_SIZE + 1);
PUSH_ENV ();
PUSH_NTH_THEN (RC_DISJUNCTION_DECIDE, OR_PREDICATE);
case TC_EXTENDED_LAMBDA:
/* Deliberately omitted: EVAL_GC_CHECK (2); */
SET_VAL (MAKE_POINTER_OBJECT (TC_EXTENDED_PROCEDURE, Free));
(Free[PROCEDURE_LAMBDA_EXPR]) = GET_EXP;
(Free[PROCEDURE_ENVIRONMENT]) = GET_ENV;
Free += 2;
break;
case TC_IN_PACKAGE:
Will_Push (CONTINUATION_SIZE);
PUSH_NTH_THEN (RC_EXECUTE_IN_PACKAGE_CONTINUE, IN_PACKAGE_ENVIRONMENT);
case TC_LAMBDA:
case TC_LEXPR:
/* Deliberately omitted: EVAL_GC_CHECK (2); */
SET_VAL (MAKE_POINTER_OBJECT (TC_PROCEDURE, Free));
(Free[PROCEDURE_LAMBDA_EXPR]) = GET_EXP;
(Free[PROCEDURE_ENVIRONMENT]) = GET_ENV;
Free += 2;
break;
case TC_MANIFEST_NM_VECTOR:
EVAL_ERROR (ERR_EXECUTE_MANIFEST_VECTOR);
case TC_PCOMB0:
/* The argument to Will_Eventually_Push is determined by how
much will be on the stack if we back out of the primitive. */
Will_Eventually_Push (CONTINUATION_SIZE + STACK_ENV_FIRST_ARG);
Finished_Eventual_Pushing (CONTINUATION_SIZE + STACK_ENV_FIRST_ARG);
SET_EXP (OBJECT_NEW_TYPE (TC_PRIMITIVE, GET_EXP));
goto primitive_internal_apply;
case TC_PCOMB1:
Will_Eventually_Push (CONTINUATION_SIZE + STACK_ENV_FIRST_ARG + 1);
DO_NTH_THEN (RC_PCOMB1_APPLY, PCOMB1_ARG_SLOT);
case TC_PCOMB2:
Will_Eventually_Push (CONTINUATION_SIZE + STACK_ENV_FIRST_ARG + 2);
PUSH_ENV ();
DO_NTH_THEN (RC_PCOMB2_DO_1, PCOMB2_ARG_2_SLOT);
case TC_PCOMB3:
Will_Eventually_Push (CONTINUATION_SIZE + STACK_ENV_FIRST_ARG + 3);
PUSH_ENV ();
DO_NTH_THEN (RC_PCOMB3_DO_2, PCOMB3_ARG_3_SLOT);
case TC_SCODE_QUOTE:
SET_VAL (MEMORY_REF (GET_EXP, SCODE_QUOTE_OBJECT));
break;
case TC_SEQUENCE_2:
Will_Push (CONTINUATION_SIZE + 1);
PUSH_ENV ();
PUSH_NTH_THEN (RC_SEQ_2_DO_2, SEQUENCE_1);
case TC_SEQUENCE_3:
Will_Push (CONTINUATION_SIZE + 1);
PUSH_ENV ();
PUSH_NTH_THEN (RC_SEQ_3_DO_2, SEQUENCE_1);
case TC_SYNTAX_ERROR:
EVAL_ERROR (ERR_SYNTAX_ERROR);
case TC_THE_ENVIRONMENT:
SET_VAL (GET_ENV);
break;
case TC_VARIABLE:
{
SCHEME_OBJECT val = GET_VAL;
SCHEME_OBJECT name = (GET_VARIABLE_SYMBOL (GET_EXP));
long temp = (lookup_variable (GET_ENV, name, (&val)));
if (temp != PRIM_DONE)
{
/* Back out of the evaluation. */
if (temp == PRIM_INTERRUPT)
{
PREPARE_EVAL_REPEAT ();
SIGNAL_INTERRUPT (PENDING_INTERRUPTS ());
}
EVAL_ERROR (temp);
}
SET_VAL (val);
}
}
/* Now restore the continuation saved during an earlier part of the
EVAL cycle and continue as directed. */
pop_return:
#ifdef COMPILE_STEPPER
if (trapping
&& (!WITHIN_CRITICAL_SECTION_P ())
&& ((FETCH_RETURN_TRAPPER ()) != SHARP_F))
{
Will_Push (3);
trapping = false;
PUSH_VAL ();
STACK_PUSH (FETCH_RETURN_TRAPPER ());
PUSH_APPLY_FRAME_HEADER (1);
Pushed ();
goto Apply_Non_Trapping;
}
#endif /* COMPILE_STEPPER */
pop_return_non_trapping:
#ifdef POP_RETURN_UCODE_HOOK
POP_RETURN_UCODE_HOOK ();
#endif
RESTORE_CONT ();
#ifdef ENABLE_DEBUGGING_TOOLS
if (!RETURN_CODE_P (GET_RET))
{
PUSH_VAL (); /* For possible stack trace */
SAVE_CONT ();
Microcode_Termination (TERM_BAD_STACK);
}
#endif
/* Dispatch on the return code. A BREAK here will cause
a "goto pop_return" to occur, since this is the most
common occurrence.
*/
switch (OBJECT_DATUM (GET_RET))
{
case RC_COMB_1_PROCEDURE:
POP_ENV ();
PUSH_VAL (); /* Arg. 1 */
STACK_PUSH (SHARP_F); /* Operator */
PUSH_APPLY_FRAME_HEADER (1);
Finished_Eventual_Pushing (CONTINUATION_SIZE);
DO_ANOTHER_THEN (RC_COMB_APPLY_FUNCTION, COMB_1_FN);
case RC_COMB_2_FIRST_OPERAND:
POP_ENV ();
PUSH_VAL ();
PUSH_ENV ();
DO_ANOTHER_THEN (RC_COMB_2_PROCEDURE, COMB_2_ARG_1);
case RC_COMB_2_PROCEDURE:
POP_ENV ();
PUSH_VAL (); /* Arg 1, just calculated */
STACK_PUSH (SHARP_F); /* Function */
PUSH_APPLY_FRAME_HEADER (2);
Finished_Eventual_Pushing (CONTINUATION_SIZE);
DO_ANOTHER_THEN (RC_COMB_APPLY_FUNCTION, COMB_2_FN);
case RC_COMB_APPLY_FUNCTION:
END_SUBPROBLEM ();
goto internal_apply_val;
case RC_COMB_SAVE_VALUE:
{
long Arg_Number;
POP_ENV ();
Arg_Number = ((OBJECT_DATUM (STACK_REF (STACK_COMB_FINGER))) - 1);
(STACK_REF (STACK_COMB_FIRST_ARG + Arg_Number)) = GET_VAL;
(STACK_REF (STACK_COMB_FINGER))
= (MAKE_OBJECT (TC_MANIFEST_NM_VECTOR, Arg_Number));
/* DO NOT count on the type code being NMVector here, since
the stack parser may create them with #F here! */
if (Arg_Number > 0)
{
PUSH_ENV ();
DO_ANOTHER_THEN
(RC_COMB_SAVE_VALUE, ((COMB_ARG_1_SLOT - 1) + Arg_Number));
}
/* Frame Size */
STACK_PUSH (MEMORY_REF (GET_EXP, 0));
DO_ANOTHER_THEN (RC_COMB_APPLY_FUNCTION, COMB_FN_SLOT);
}
#ifdef CC_SUPPORT_P
#define DEFINE_COMPILER_RESTART(return_code, entry) \
case return_code: \
{ \
dispatch_code = (entry ()); \
goto return_from_compiled_code; \
}
DEFINE_COMPILER_RESTART
(RC_COMP_INTERRUPT_RESTART, comp_interrupt_restart);
DEFINE_COMPILER_RESTART
(RC_COMP_LOOKUP_TRAP_RESTART, comp_lookup_trap_restart);
DEFINE_COMPILER_RESTART
(RC_COMP_ASSIGNMENT_TRAP_RESTART, comp_assignment_trap_restart);
DEFINE_COMPILER_RESTART
(RC_COMP_OP_REF_TRAP_RESTART, comp_op_lookup_trap_restart);
DEFINE_COMPILER_RESTART
(RC_COMP_CACHE_REF_APPLY_RESTART, comp_cache_lookup_apply_restart);
DEFINE_COMPILER_RESTART
(RC_COMP_SAFE_REF_TRAP_RESTART, comp_safe_lookup_trap_restart);
DEFINE_COMPILER_RESTART
(RC_COMP_UNASSIGNED_TRAP_RESTART, comp_unassigned_p_trap_restart);
DEFINE_COMPILER_RESTART
(RC_COMP_LINK_CACHES_RESTART, comp_link_caches_restart);
DEFINE_COMPILER_RESTART
(RC_COMP_ERROR_RESTART, comp_error_restart);
case RC_REENTER_COMPILED_CODE:
dispatch_code = (return_to_compiled_code ());
goto return_from_compiled_code;
#endif
case RC_CONDITIONAL_DECIDE:
END_SUBPROBLEM ();
POP_ENV ();
REDUCES_TO_NTH
((GET_VAL == SHARP_F) ? COND_ALTERNATIVE : COND_CONSEQUENT);
case RC_DISJUNCTION_DECIDE:
/* Return predicate if it isn't #F; else do ALTERNATIVE */
END_SUBPROBLEM ();
POP_ENV ();
if (GET_VAL != SHARP_F)
goto pop_return;
REDUCES_TO_NTH (OR_ALTERNATIVE);
case RC_END_OF_COMPUTATION:
{
/* Signals bottom of stack */
interpreter_state_t previous_state;
previous_state = (interpreter_state -> previous_state);
if (previous_state == NULL_INTERPRETER_STATE)
{
termination_end_of_computation ();
/*NOTREACHED*/
}
else
{
dstack_position = interpreter_catch_dstack_position;
interpreter_state = previous_state;
return;
}
}
case RC_EVAL_ERROR:
/* Should be called RC_REDO_EVALUATION. */
POP_ENV ();
REDUCES_TO (GET_EXP);
case RC_EXECUTE_ACCESS_FINISH:
{
SCHEME_OBJECT val;
long code;
code = (lookup_variable (GET_VAL,
(MEMORY_REF (GET_EXP, ACCESS_NAME)),
(&val)));
if (code == PRIM_DONE)
SET_VAL (val);
else if (code == PRIM_INTERRUPT)
{
PREPARE_POP_RETURN_INTERRUPT (RC_EXECUTE_ACCESS_FINISH, GET_VAL);
SIGNAL_INTERRUPT (PENDING_INTERRUPTS ());
}
else
POP_RETURN_ERROR (code);
}
END_SUBPROBLEM ();
break;
case RC_EXECUTE_ASSIGNMENT_FINISH:
{
SCHEME_OBJECT variable = (MEMORY_REF (GET_EXP, ASSIGN_NAME));
SCHEME_OBJECT old_val;
long code;
POP_ENV ();
if (TC_VARIABLE == (OBJECT_TYPE (variable)))
code = (assign_variable (GET_ENV,
(GET_VARIABLE_SYMBOL (variable)),
GET_VAL,
(&old_val)));
else
code = ERR_BAD_FRAME;
if (code == PRIM_DONE)
SET_VAL (old_val);
else
{
PUSH_ENV ();
if (code == PRIM_INTERRUPT)
{
PREPARE_POP_RETURN_INTERRUPT
(RC_EXECUTE_ASSIGNMENT_FINISH, GET_VAL);
SIGNAL_INTERRUPT (PENDING_INTERRUPTS ());
}
else
POP_RETURN_ERROR (code);
}
}
END_SUBPROBLEM ();
break;
case RC_EXECUTE_DEFINITION_FINISH:
{
SCHEME_OBJECT name = (MEMORY_REF (GET_EXP, DEFINE_NAME));
SCHEME_OBJECT value = GET_VAL;
long result;
POP_ENV ();
result = (define_variable (GET_ENV, name, value));
if (result == PRIM_DONE)
{
END_SUBPROBLEM ();
SET_VAL (name);
break;
}
PUSH_ENV ();
if (result == PRIM_INTERRUPT)
{
PREPARE_POP_RETURN_INTERRUPT (RC_EXECUTE_DEFINITION_FINISH,
value);
SIGNAL_INTERRUPT (PENDING_INTERRUPTS ());
}
SET_VAL (value);
POP_RETURN_ERROR (result);
}
case RC_EXECUTE_IN_PACKAGE_CONTINUE:
if (ENVIRONMENT_P (GET_VAL))
{
END_SUBPROBLEM ();
SET_ENV (GET_VAL);
REDUCES_TO_NTH (IN_PACKAGE_EXPRESSION);
}
POP_RETURN_ERROR (ERR_BAD_FRAME);
case RC_HALT:
Microcode_Termination (TERM_TERM_HANDLER);
case RC_HARDWARE_TRAP:
{
/* This just reinvokes the handler */
SCHEME_OBJECT info = (STACK_REF (0));
SCHEME_OBJECT handler = SHARP_F;
SAVE_CONT ();
if (VECTOR_P (fixed_objects))
handler = (VECTOR_REF (fixed_objects, TRAP_HANDLER));
if (handler == SHARP_F)
{
outf_fatal ("There is no trap handler for recovery!\n");
termination_trap ();
/*NOTREACHED*/
}
Will_Push (STACK_ENV_EXTRA_SLOTS + 2);
STACK_PUSH (info);
STACK_PUSH (handler);
PUSH_APPLY_FRAME_HEADER (1);
Pushed ();
}
goto internal_apply;
/* internal_apply, the core of the application mechanism.
Branch here to perform a function application.
At this point the top of the stack contains an application
frame which consists of the following elements (see sdata.h):
- A header specifying the frame length.
- A procedure.
- The actual (evaluated) arguments.
No registers (except the stack pointer) are meaning full at
this point. Before interrupts or errors are processed, some
registers are cleared to avoid holding onto garbage if a
garbage collection occurs. */
case RC_INTERNAL_APPLY_VAL:
internal_apply_val:
(APPLY_FRAME_PROCEDURE ()) = GET_VAL;
case RC_INTERNAL_APPLY:
internal_apply:
#ifdef COMPILE_STEPPER
if (trapping
&& (!WITHIN_CRITICAL_SECTION_P ())
&& ((FETCH_APPLY_TRAPPER ()) != SHARP_F))
{
unsigned long frame_size = (APPLY_FRAME_SIZE ());
(* (STACK_LOC (0))) = (FETCH_APPLY_TRAPPER ());
PUSH_APPLY_FRAME_HEADER (frame_size);
trapping = false;
}
#endif /* COMPILE_STEPPER */
Apply_Non_Trapping:
if (PENDING_INTERRUPTS_P)
{
unsigned long interrupts = (PENDING_INTERRUPTS ());
PREPARE_APPLY_INTERRUPT ();
SIGNAL_INTERRUPT (interrupts);
}
perform_application:
#ifdef APPLY_UCODE_HOOK
APPLY_UCODE_HOOK ();
#endif
{
SCHEME_OBJECT Function = (APPLY_FRAME_PROCEDURE ());
apply_dispatch:
switch (OBJECT_TYPE (Function))
{
case TC_ENTITY:
{
unsigned long frame_size = (APPLY_FRAME_SIZE ());
SCHEME_OBJECT data = (MEMORY_REF (Function, ENTITY_DATA));
if ((VECTOR_P (data))
&& (frame_size < (VECTOR_LENGTH (data)))
&& ((VECTOR_REF (data, frame_size)) != SHARP_F)
&& ((VECTOR_REF (data, 0))
== (VECTOR_REF (fixed_objects, ARITY_DISPATCHER_TAG))))
{
Function = (VECTOR_REF (data, frame_size));
(APPLY_FRAME_PROCEDURE ()) = Function;
goto apply_dispatch;
}
(STACK_REF (0)) = (MEMORY_REF (Function, ENTITY_OPERATOR));
PUSH_APPLY_FRAME_HEADER (frame_size);
/* This must be done to prevent an infinite push loop by
an entity whose handler is the entity itself or some
other such loop. Of course, it will die if stack overflow
interrupts are disabled. */
STACK_CHECK (0);
goto internal_apply;
}
case TC_PROCEDURE:
{
unsigned long frame_size = (APPLY_FRAME_SIZE ());
Function = (MEMORY_REF (Function, PROCEDURE_LAMBDA_EXPR));
{
SCHEME_OBJECT formals
= (MEMORY_REF (Function, LAMBDA_FORMALS));
if ((frame_size != (VECTOR_LENGTH (formals)))
&& (((OBJECT_TYPE (Function)) != TC_LEXPR)
|| (frame_size < (VECTOR_LENGTH (formals)))))
APPLICATION_ERROR (ERR_WRONG_NUMBER_OF_ARGUMENTS);
}
if (GC_NEEDED_P (frame_size + 1))
{
PREPARE_APPLY_INTERRUPT ();
IMMEDIATE_GC (frame_size + 1);
}
{
SCHEME_OBJECT * end = (Free + 1 + frame_size);
SCHEME_OBJECT env
= (MAKE_POINTER_OBJECT (TC_ENVIRONMENT, Free));
(*Free++) = (MAKE_OBJECT (TC_MANIFEST_VECTOR, frame_size));
(void) STACK_POP ();
while (Free < end)
(*Free++) = (STACK_POP ());
SET_ENV (env);
REDUCES_TO (MEMORY_REF (Function, LAMBDA_SCODE));
}
}
case TC_CONTROL_POINT:
if ((APPLY_FRAME_SIZE ()) != 2)
APPLICATION_ERROR (ERR_WRONG_NUMBER_OF_ARGUMENTS);
SET_VAL (* (APPLY_FRAME_ARGS ()));
unpack_control_point (Function);
RESET_HISTORY ();
goto pop_return;
/* After checking the number of arguments, remove the
frame header since primitives do not expect it.
NOTE: This code must match the application code which
follows primitive_internal_apply. */
case TC_PRIMITIVE:
if (!IMPLEMENTED_PRIMITIVE_P (Function))
APPLICATION_ERROR (ERR_UNIMPLEMENTED_PRIMITIVE);
{
unsigned long n_args = (APPLY_FRAME_N_ARGS ());
/* Note that the first test below will fail for lexpr
primitives. */
if (n_args != (PRIMITIVE_ARITY (Function)))
{
if ((PRIMITIVE_ARITY (Function)) != LEXPR_PRIMITIVE_ARITY)
APPLICATION_ERROR (ERR_WRONG_NUMBER_OF_ARGUMENTS);
SET_LEXPR_ACTUALS (n_args);
}
stack_pointer = (APPLY_FRAME_ARGS ());
SET_EXP (Function);
APPLY_PRIMITIVE_FROM_INTERPRETER (Function);
POP_PRIMITIVE_FRAME (n_args);
goto pop_return;
}
case TC_EXTENDED_PROCEDURE:
{
SCHEME_OBJECT lambda;
SCHEME_OBJECT temp;
unsigned long nargs;
unsigned long nparams;
unsigned long formals;
unsigned long params;
unsigned long auxes;
long rest_flag;
long size;
long i;
SCHEME_OBJECT * scan;
nargs = (POP_APPLY_FRAME_HEADER ());
lambda = (MEMORY_REF (Function, PROCEDURE_LAMBDA_EXPR));
Function = (MEMORY_REF (lambda, ELAMBDA_NAMES));
nparams = ((VECTOR_LENGTH (Function)) - 1);
Function = (Get_Count_Elambda (lambda));
formals = (Elambda_Formals_Count (Function));
params = ((Elambda_Opts_Count (Function)) + formals);
rest_flag = (Elambda_Rest_Flag (Function));
auxes = (nparams - (params + rest_flag));
if ((nargs < formals) || (!rest_flag && (nargs > params)))
{
PUSH_APPLY_FRAME_HEADER (nargs);
APPLICATION_ERROR (ERR_WRONG_NUMBER_OF_ARGUMENTS);
}
/* size includes the procedure slot, but not the header. */
size = (params + rest_flag + auxes + 1);
if (GC_NEEDED_P
(size + 1
+ ((nargs > params)
? (2 * (nargs - params))
: 0)))
{
PUSH_APPLY_FRAME_HEADER (nargs);
PREPARE_APPLY_INTERRUPT ();
IMMEDIATE_GC
(size + 1
+ ((nargs > params)
? (2 * (nargs - params))
: 0));
}
scan = Free;
temp = (MAKE_POINTER_OBJECT (TC_ENVIRONMENT, scan));
(*scan++) = (MAKE_OBJECT (TC_MANIFEST_VECTOR, size));
if (nargs <= params)
{
for (i = (nargs + 1); (--i) >= 0; )
(*scan++) = (STACK_POP ());
for (i = (params - nargs); (--i) >= 0; )
(*scan++) = DEFAULT_OBJECT;
if (rest_flag)
(*scan++) = EMPTY_LIST;
for (i = auxes; (--i) >= 0; )
(*scan++) = UNASSIGNED_OBJECT;
}
else
{
/* rest_flag must be true. */
SCHEME_OBJECT list
= (MAKE_POINTER_OBJECT (TC_LIST, (scan + size)));
for (i = (params + 1); (--i) >= 0; )
(*scan++) = (STACK_POP ());
(*scan++) = list;
for (i = auxes; (--i) >= 0; )
(*scan++) = UNASSIGNED_OBJECT;
/* Now scan == OBJECT_ADDRESS (list) */
for (i = (nargs - params); (--i) >= 0; )
{
(*scan++) = (STACK_POP ());
(*scan) = MAKE_POINTER_OBJECT (TC_LIST, (scan + 1));
scan += 1;
}
(scan[-1]) = EMPTY_LIST;
}
Free = scan;
SET_ENV (temp);
REDUCES_TO (Get_Body_Elambda (lambda));
}
#ifdef CC_SUPPORT_P
case TC_COMPILED_ENTRY:
{
guarantee_cc_return (1 + (APPLY_FRAME_SIZE ()));
dispatch_code = (apply_compiled_procedure ());
return_from_compiled_code:
switch (dispatch_code)
{
case PRIM_DONE:
goto pop_return;
case PRIM_APPLY:
goto internal_apply;
case PRIM_INTERRUPT:
SIGNAL_INTERRUPT (PENDING_INTERRUPTS ());
case PRIM_APPLY_INTERRUPT:
PREPARE_APPLY_INTERRUPT ();
SIGNAL_INTERRUPT (PENDING_INTERRUPTS ());
case ERR_INAPPLICABLE_OBJECT:
case ERR_WRONG_NUMBER_OF_ARGUMENTS:
APPLICATION_ERROR (dispatch_code);
default:
Do_Micro_Error (dispatch_code, true);
goto internal_apply;
}
}
#endif
default:
APPLICATION_ERROR (ERR_INAPPLICABLE_OBJECT);
}
}
case RC_JOIN_STACKLETS:
unpack_control_point (GET_EXP);
break;
case RC_NORMAL_GC_DONE:
SET_VAL (GET_EXP);
/* Paranoia */
if (GC_NEEDED_P (gc_space_needed))
termination_gc_out_of_space ();
gc_space_needed = 0;
EXIT_CRITICAL_SECTION ({ SAVE_CONT (); });
break;
case RC_PCOMB1_APPLY:
END_SUBPROBLEM ();
PUSH_VAL (); /* Argument value */
Finished_Eventual_Pushing (CONTINUATION_SIZE + STACK_ENV_FIRST_ARG);
SET_EXP (MEMORY_REF (GET_EXP, PCOMB1_FN_SLOT));
primitive_internal_apply:
#ifdef COMPILE_STEPPER
if (trapping
&& (!WITHIN_CRITICAL_SECTION_P ())
&& ((FETCH_APPLY_TRAPPER ()) != SHARP_F))
{
Will_Push (3);
PUSH_EXP ();
STACK_PUSH (FETCH_APPLY_TRAPPER ());
PUSH_APPLY_FRAME_HEADER (1 + (PRIMITIVE_N_PARAMETERS (GET_EXP)));
Pushed ();
trapping = false;
goto Apply_Non_Trapping;
}
#endif /* COMPILE_STEPPER */
/* NOTE: This code must match the code in the TC_PRIMITIVE
case of internal_apply.
This code is simpler because:
1) The arity was checked at syntax time.
2) We don't have to deal with "lexpr" primitives.
3) We don't need to worry about unimplemented primitives because
unimplemented primitives will cause an error at invocation. */
{
SCHEME_OBJECT primitive = GET_EXP;
APPLY_PRIMITIVE_FROM_INTERPRETER (primitive);
POP_PRIMITIVE_FRAME (PRIMITIVE_ARITY (primitive));
break;
}
case RC_PCOMB2_APPLY:
END_SUBPROBLEM ();
PUSH_VAL (); /* Value of arg. 1 */
Finished_Eventual_Pushing (CONTINUATION_SIZE + STACK_ENV_FIRST_ARG);
SET_EXP (MEMORY_REF (GET_EXP, PCOMB2_FN_SLOT));
goto primitive_internal_apply;
case RC_PCOMB2_DO_1:
POP_ENV ();
PUSH_VAL (); /* Save value of arg. 2 */
DO_ANOTHER_THEN (RC_PCOMB2_APPLY, PCOMB2_ARG_1_SLOT);
case RC_PCOMB3_APPLY:
END_SUBPROBLEM ();
PUSH_VAL (); /* Save value of arg. 1 */
Finished_Eventual_Pushing (CONTINUATION_SIZE + STACK_ENV_FIRST_ARG);
SET_EXP (MEMORY_REF (GET_EXP, PCOMB3_FN_SLOT));
goto primitive_internal_apply;
case RC_PCOMB3_DO_1:
{
SCHEME_OBJECT Temp = (STACK_POP ()); /* Value of arg. 3 */
POP_ENV ();
STACK_PUSH (Temp); /* Save arg. 3 again */
PUSH_VAL (); /* Save arg. 2 */
DO_ANOTHER_THEN (RC_PCOMB3_APPLY, PCOMB3_ARG_1_SLOT);
}
case RC_PCOMB3_DO_2:
SET_ENV (STACK_REF (0));
PUSH_VAL (); /* Save value of arg. 3 */
DO_ANOTHER_THEN (RC_PCOMB3_DO_1, PCOMB3_ARG_2_SLOT);
case RC_POP_RETURN_ERROR:
case RC_RESTORE_VALUE:
SET_VAL (GET_EXP);
break;
/* The following two return codes are both used to restore a
saved history object. The difference is that the first does
not copy the history object while the second does. In both
cases, the GET_EXP contains the history object and the
next item to be popped off the stack contains the offset back
to the previous restore history return code. */
case RC_RESTORE_DONT_COPY_HISTORY:
{
prev_restore_history_offset = (OBJECT_DATUM (STACK_POP ()));
(void) STACK_POP ();
history_register = (OBJECT_ADDRESS (GET_EXP));
break;
}
case RC_RESTORE_HISTORY:
{
if (!restore_history (GET_EXP))
{
SAVE_CONT ();
Will_Push (CONTINUATION_SIZE);
SET_EXP (GET_VAL);
SET_RC (RC_RESTORE_VALUE);
SAVE_CONT ();
Pushed ();
IMMEDIATE_GC (HEAP_AVAILABLE);
}
prev_restore_history_offset = (OBJECT_DATUM (STACK_POP ()));
(void) STACK_POP ();
if (prev_restore_history_offset > 0)
(STACK_LOCATIVE_REFERENCE (STACK_BOTTOM,
(-prev_restore_history_offset)))
= (MAKE_RETURN_CODE (RC_RESTORE_HISTORY));
break;
}
case RC_RESTORE_INT_MASK:
SET_INTERRUPT_MASK (UNSIGNED_FIXNUM_TO_LONG (GET_EXP));
if (GC_NEEDED_P (0))
REQUEST_GC (0);
if (PENDING_INTERRUPTS_P)
{
SET_RC (RC_RESTORE_VALUE);
SET_EXP (GET_VAL);
SAVE_CONT ();
SIGNAL_INTERRUPT (PENDING_INTERRUPTS ());
}
break;
case RC_STACK_MARKER:
/* Frame consists of the return code followed by two objects.
The first object has already been popped into GET_EXP,
so just pop the second argument. */
stack_pointer = (STACK_LOCATIVE_OFFSET (stack_pointer, 1));
break;
case RC_SEQ_2_DO_2:
END_SUBPROBLEM ();
POP_ENV ();
REDUCES_TO_NTH (SEQUENCE_2);
case RC_SEQ_3_DO_2:
SET_ENV (STACK_REF (0));
DO_ANOTHER_THEN (RC_SEQ_3_DO_3, SEQUENCE_2);
case RC_SEQ_3_DO_3:
END_SUBPROBLEM ();
POP_ENV ();
REDUCES_TO_NTH (SEQUENCE_3);
case RC_SNAP_NEED_THUNK:
/* Don't snap thunk twice; evaluation of the thunk's body might
have snapped it already. */
if ((MEMORY_REF (GET_EXP, THUNK_SNAPPED)) == SHARP_T)
SET_VAL (MEMORY_REF (GET_EXP, THUNK_VALUE));
else
{
MEMORY_SET (GET_EXP, THUNK_SNAPPED, SHARP_T);
MEMORY_SET (GET_EXP, THUNK_VALUE, GET_VAL);
}
break;
default:
POP_RETURN_ERROR (ERR_INAPPLICABLE_CONTINUATION);
}