int equal_p(object o1, object o2) {
if (eqv_p(o1,o2)) return 1;
if (PAIR_P(o1)) {
return PAIR_P(o2)&&equal_p(CAR(o1),CAR(o2))&&equal_p(CDR(o1),CDR(o2));
} else if (VECTOR_P(o1)) {
if (VECTOR_P(o2)) {
long max = VECTOR_LENGTH(o1);
if (max == VECTOR_LENGTH(o2)) {
object *e1 = VECTOR_ELEMENTS(o1), *e2 = VECTOR_ELEMENTS(o2);
long i;
for (i=0; i<max; i++)
if (!equal_p(e1[i],e2[i]))
return 0;
return 1;
}
}
} else if (STRING_P(o1)) {
if (STRING_P(o2)) {
long max = STRING_LENGTH(o1);
if (max == STRING_LENGTH(o2)) {
char *p1 = STRING_VALUE(o1);
char *p2 = STRING_VALUE(o2);
while (*p1 && *p2) {
if (*p1++ != *p2++) return 0;
}
return (*p1 == *p2);
}
}
}
return 0;
}
/**
* Adds an entry to a plugin data store.
*
* @param type[in] The store type.
* @param pluginID[in] The plugin identifier.
* @param storeptr[in,out] A pointer to the store. The store will be initialized if necessary.
* @param data[in] The data entry to add.
* @param classid[in] The entry class identifier.
* @param autofree[in] Whether the entry should be automatically freed when removed.
*/
void hplugins_addToHPData(enum HPluginDataTypes type, uint32 pluginID, struct hplugin_data_store **storeptr, void *data, uint32 classid, bool autofree)
{
struct hplugin_data_store *store;
struct hplugin_data_entry *entry;
int i;
nullpo_retv(storeptr);
if (!HPM->data_store_validate(type, storeptr, true)) {
/* woo it failed! */
ShowError("HPM:addToHPData:%s: failed, type %u (%u|%u)\n", HPM->pid2name(pluginID), type, pluginID, classid);
return;
}
store = *storeptr;
/* duplicate check */
ARR_FIND(0, VECTOR_LENGTH(store->entries), i, VECTOR_INDEX(store->entries, i)->pluginID == pluginID && VECTOR_INDEX(store->entries, i)->classid == classid);
if (i != VECTOR_LENGTH(store->entries)) {
ShowError("HPM:addToHPData:%s: error! attempting to insert duplicate struct of id %u and classid %u\n", HPM->pid2name(pluginID), pluginID, classid);
return;
}
/* hplugin_data_entry is always same size, probably better to use the ERS (with reasonable chunk size e.g. 10/25/50) */
CREATE(entry, struct hplugin_data_entry, 1);
/* input */
entry->pluginID = pluginID;
entry->classid = classid;
entry->flag.free = autofree ? 1 : 0;
entry->data = data;
VECTOR_ENSURE(store->entries, 1, 1);
VECTOR_PUSH(store->entries, entry);
}
/**
* Imports a shared symbol.
*
* @param name The symbol name.
* @param pID The requesting plugin ID.
* @return The symbol value.
* @retval NULL if the symbol wasn't found.
*/
void *hplugin_import_symbol(char *name, unsigned int pID)
{
int i;
ARR_FIND(0, VECTOR_LENGTH(HPM->symbols), i, strcmp(VECTOR_INDEX(HPM->symbols, i)->name, name) == 0);
if (i != VECTOR_LENGTH(HPM->symbols))
return VECTOR_INDEX(HPM->symbols, i)->ptr;
ShowError("HPM:get_symbol:%s: '"CL_WHITE"%s"CL_RESET"' not found!\n",HPM->pid2name(pID),name);
return NULL;
}
bool hplugins_addpacket(unsigned short cmd, unsigned short length, void (*receive) (int fd), unsigned int point, unsigned int pluginID)
{
struct HPluginPacket *packet;
int i;
if (point >= hpPHP_MAX) {
ShowError("HPM->addPacket:%s: unknown point '%u' specified for packet 0x%04x (len %d)\n",HPM->pid2name(pluginID),point,cmd,length);
return false;
}
for (i = 0; i < VECTOR_LENGTH(HPM->packets[point]); i++) {
if (VECTOR_INDEX(HPM->packets[point], i).cmd == cmd ) {
ShowError("HPM->addPacket:%s: can't add packet 0x%04x, already in use by '%s'!",
HPM->pid2name(pluginID), cmd, HPM->pid2name(VECTOR_INDEX(HPM->packets[point], i).pluginID));
return false;
}
}
VECTOR_ENSURE(HPM->packets[point], 1, 1);
VECTOR_PUSHZEROED(HPM->packets[point]);
packet = &VECTOR_LAST(HPM->packets[point]);
packet->pluginID = pluginID;
packet->cmd = cmd;
packet->len = length;
packet->receive = receive;
return true;
}
static void Player_collides_with_debris(player_t *pl, object_t *obj)
{
player_t *kp = NULL;
double cost;
char msg[MSG_LEN];
cost = collision_cost(obj->mass, VECTOR_LENGTH(obj->vel));
if (!Player_uses_emergency_shield(pl))
Player_add_fuel(pl, -cost);
if (pl->fuel.sum == 0.0
|| (obj->type == OBJ_WRECKAGE
&& options.wreckageCollisionMayKill
&& !BIT(pl->used, HAS_SHIELD)
&& !Player_has_armor(pl))) {
Player_set_state(pl, PL_STATE_KILLED);
sprintf(msg, "%s succumbed to an explosion.", pl->name);
if (obj->id != NO_ID) {
kp = Player_by_id(obj->id);
sprintf(msg + strlen(msg) - 1, " from %s.", kp->name);
if (obj->id == pl->id)
sprintf(msg + strlen(msg), " How strange!");
}
Set_message(msg);
Handle_Scoring(SCORE_EXPLOSION,kp,pl,NULL,NULL);
obj->life = 0.0;
return;
}
if (obj->type == OBJ_WRECKAGE
&& options.wreckageCollisionMayKill
&& !BIT(pl->used, HAS_SHIELD)
&& Player_has_armor(pl))
Player_hit_armor(pl);
}
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;
}
/**
* Executes an event on all loaded plugins.
*
* @param type The event type to trigger.
*/
void hplugin_trigger_event(enum hp_event_types type)
{
int i;
for (i = 0; i < VECTOR_LENGTH(HPM->plugins); i++) {
struct hplugin *plugin = VECTOR_INDEX(HPM->plugins, i);
if (plugin->hpi->event[type] != NULL)
plugin->hpi->event[type]();
}
}
/**
* Adds a plugin-defined command-line argument.
*
* @param pluginID the current plugin's ID.
* @param name the command line argument's name, including the leading '--'.
* @param has_param whether the command line argument expects to be followed by a value.
* @param func the triggered function.
* @param help the help string to be displayed by '--help', if any.
* @return the success status.
*/
bool hpm_add_arg(unsigned int pluginID, char *name, bool has_param, CmdlineExecFunc func, const char *help)
{
int i;
if (!name || strlen(name) < 3 || name[0] != '-' || name[1] != '-') {
ShowError("HPM:add_arg:%s invalid argument name: arguments must begin with '--' (from %s)\n", name, HPM->pid2name(pluginID));
return false;
}
ARR_FIND(0, VECTOR_LENGTH(cmdline->args_data), i, strcmp(VECTOR_INDEX(cmdline->args_data, i).name, name) == 0);
if (i != VECTOR_LENGTH(cmdline->args_data)) {
ShowError("HPM:add_arg:%s duplicate! (from %s)\n",name,HPM->pid2name(pluginID));
return false;
}
return cmdline->arg_add(pluginID, name, '\0', func, help, has_param ? CMDLINE_OPT_PARAM : CMDLINE_OPT_NORMAL);
}
/**
* Retrieves an entry from a plugin data store.
*
* @param type[in] The store type.
* @param pluginID[in] The plugin identifier.
* @param store[in] The store.
* @param classid[in] The entry class identifier.
*
* @return The retrieved entry, or NULL.
*/
void *hplugins_getFromHPData(enum HPluginDataTypes type, uint32 pluginID, struct hplugin_data_store *store, uint32 classid)
{
int i;
if (!HPM->data_store_validate(type, &store, false)) {
/* woo it failed! */
ShowError("HPM:getFromHPData:%s: failed, type %u (%u|%u)\n", HPM->pid2name(pluginID), type, pluginID, classid);
return NULL;
}
if (!store)
return NULL;
ARR_FIND(0, VECTOR_LENGTH(store->entries), i, VECTOR_INDEX(store->entries, i)->pluginID == pluginID && VECTOR_INDEX(store->entries, i)->classid == classid);
if (i != VECTOR_LENGTH(store->entries))
return VECTOR_INDEX(store->entries, i)->data;
return NULL;
}
/**
* Checks whether a plugin is currently loaded
*
* @param filename The plugin filename.
* @retval true if the plugin exists and is currently loaded.
* @retval false otherwise.
*/
bool hplugin_exists(const char *filename)
{
int i;
for (i = 0; i < VECTOR_LENGTH(HPM->plugins); i++) {
if (strcmpi(VECTOR_INDEX(HPM->plugins, i)->filename,filename) == 0)
return true;
}
return false;
}
/**
* Initializes the data structure for a new plugin and registers it.
*
* @return A (retained) pointer to the initialized data.
*/
struct hplugin *hplugin_create(void)
{
struct hplugin *plugin = NULL;
CREATE(plugin, struct hplugin, 1);
plugin->idx = (int)VECTOR_LENGTH(HPM->plugins);
plugin->filename = NULL;
VECTOR_ENSURE(HPM->plugins, 1, 1);
VECTOR_PUSH(HPM->plugins, plugin);
return plugin;
}
SCHEME_OBJECT *
faslhdr_utilities_end (fasl_header_t * h)
{
if (((__FASLHDR_UTILITIES_END (h)) == 0)
&& (VECTOR_P (FASLHDR_UTILITIES_VECTOR (h))))
(__FASLHDR_UTILITIES_END (h))
= (VECTOR_LOC ((FASLHDR_UTILITIES_VECTOR (h)),
(VECTOR_LENGTH (FASLHDR_UTILITIES_VECTOR (h)))));
return (__FASLHDR_UTILITIES_END (h));
}
/**
* Creates a new console command entry.
*
* @param name The command name.
* @param func The command callback.
*/
void console_parse_create(char *name, CParseFunc func)
{
int i;
char *tok;
char sublist[CP_CMD_LENGTH * 5];
struct CParseEntry *cmd;
safestrncpy(sublist, name, CP_CMD_LENGTH * 5);
tok = strtok(sublist,":");
ARR_FIND(0, VECTOR_LENGTH(console->input->command_list), i, strcmpi(tok, VECTOR_INDEX(console->input->command_list, i)->cmd) == 0);
if (i == VECTOR_LENGTH(console->input->command_list)) {
CREATE(cmd, struct CParseEntry, 1);
safestrncpy(cmd->cmd, tok, CP_CMD_LENGTH);
cmd->type = CPET_UNKNOWN;
VECTOR_ENSURE(console->input->commands, 1, 1);
VECTOR_PUSH(console->input->commands, cmd);
VECTOR_ENSURE(console->input->command_list, 1, 1);
VECTOR_PUSH(console->input->command_list, cmd);
}
/**
* Removes an entry from a plugin data store.
*
* @param type[in] The store type.
* @param pluginID[in] The plugin identifier.
* @param store[in] The store.
* @param classid[in] The entry class identifier.
*/
void hplugins_removeFromHPData(enum HPluginDataTypes type, uint32 pluginID, struct hplugin_data_store *store, uint32 classid)
{
struct hplugin_data_entry *entry;
int i;
if (!HPM->data_store_validate(type, &store, false)) {
/* woo it failed! */
ShowError("HPM:removeFromHPData:%s: failed, type %u (%u|%u)\n", HPM->pid2name(pluginID), type, pluginID, classid);
return;
}
if (!store)
return;
ARR_FIND(0, VECTOR_LENGTH(store->entries), i, VECTOR_INDEX(store->entries, i)->pluginID == pluginID && VECTOR_INDEX(store->entries, i)->classid == classid);
if (i == VECTOR_LENGTH(store->entries))
return;
entry = VECTOR_INDEX(store->entries, i);
VECTOR_ERASE(store->entries, i); // Erase and compact
aFree(entry->data); // when it's removed we delete it regardless of autofree
aFree(entry);
}
/* 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;
}
}
}
}
}
}
}
/**
* Adds a configuration listener for a plugin.
*
* @param pluginID The plugin identifier.
* @param type The configuration type to listen for.
* @param name The configuration entry name.
* @param func The callback function.
* @retval true if the listener was added successfully.
* @retval false in case of error.
*/
bool hplugins_addconf(unsigned int pluginID, enum HPluginConfType type, char *name, void (*parse_func) (const char *key, const char *val), int (*return_func) (const char *key))
{
struct HPConfListenStorage *conf;
int i;
if (parse_func == NULL) {
ShowError("HPM->addConf:%s: missing setter function for config '%s'\n",HPM->pid2name(pluginID),name);
return false;
}
if (type == HPCT_BATTLE && return_func == NULL) {
ShowError("HPM->addConf:%s: missing getter function for config '%s'\n",HPM->pid2name(pluginID),name);
return false;
}
if (type >= HPCT_MAX) {
ShowError("HPM->addConf:%s: unknown point '%u' specified for config '%s'\n",HPM->pid2name(pluginID),type,name);
return false;
}
ARR_FIND(0, VECTOR_LENGTH(HPM->config_listeners[type]), i, strcmpi(name, VECTOR_INDEX(HPM->config_listeners[type], i).key) == 0);
if (i != VECTOR_LENGTH(HPM->config_listeners[type])) {
ShowError("HPM->addConf:%s: duplicate '%s', already in use by '%s'!",
HPM->pid2name(pluginID), name, HPM->pid2name(VECTOR_INDEX(HPM->config_listeners[type], i).pluginID));
return false;
}
VECTOR_ENSURE(HPM->config_listeners[type], 1, 1);
VECTOR_PUSHZEROED(HPM->config_listeners[type]);
conf = &VECTOR_LAST(HPM->config_listeners[type]);
conf->pluginID = pluginID;
safestrncpy(conf->key, name, HPM_ADDCONF_LENGTH);
conf->parse_func = parse_func;
conf->return_func = return_func;
return true;
}
/**
* Saves changed achievements for a character.
* @param[in] char_id character identifier.
* @param[out] cp pointer to loaded achievements.
* @param[in] p pointer to map-sent character achievements.
* @return number of achievements saved.
*/
static int inter_achievement_tosql(int char_id, struct char_achievements *cp, const struct char_achievements *p)
{
StringBuf buf;
int i = 0, rows = 0;
nullpo_ret(cp);
nullpo_ret(p);
Assert_ret(char_id > 0);
StrBuf->Init(&buf);
StrBuf->Printf(&buf, "REPLACE INTO `%s` (`char_id`, `ach_id`, `completed_at`, `rewarded_at`", char_achievement_db);
for (i = 0; i < MAX_ACHIEVEMENT_OBJECTIVES; i++)
StrBuf->Printf(&buf, ", `obj_%d`", i);
StrBuf->AppendStr(&buf, ") VALUES ");
for (i = 0; i < VECTOR_LENGTH(*p); i++) {
int j = 0;
bool save = false;
struct achievement *pa = &VECTOR_INDEX(*p, i), *cpa = NULL;
ARR_FIND(0, VECTOR_LENGTH(*cp), j, ((cpa = &VECTOR_INDEX(*cp, j)) && cpa->id == pa->id));
if (j == VECTOR_LENGTH(*cp))
save = true;
else if (memcmp(cpa, pa, sizeof(struct achievement)) != 0)
save = true;
if (save) {
StrBuf->Printf(&buf, "%s('%d', '%d', '%"PRId64"', '%"PRId64"'", rows ?", ":"", char_id, pa->id, (int64)pa->completed_at, (int64)pa->rewarded_at);
for (j = 0; j < MAX_ACHIEVEMENT_OBJECTIVES; j++)
StrBuf->Printf(&buf, ", '%d'", pa->objective[j]);
StrBuf->AppendStr(&buf, ")");
rows++;
}
}
if (rows > 0 && SQL_ERROR == SQL->QueryStr(inter->sql_handle, StrBuf->Value(&buf))) {
Sql_ShowDebug(inter->sql_handle);
StrBuf->Destroy(&buf); // Destroy the buffer.
return 0;
}
// Destroy the buffer.
StrBuf->Destroy(&buf);
if (rows) {
ShowInfo("achievements saved for char %d (total: %d, saved: %d)\n", char_id, VECTOR_LENGTH(*p), rows);
/* Sync with inter-db acheivements. */
VECTOR_CLEAR(*cp);
VECTOR_ENSURE(*cp, VECTOR_LENGTH(*p), 1);
VECTOR_PUSHARRAY(*cp, VECTOR_DATA(*p), VECTOR_LENGTH(*p));
}
return rows;
}
/*---------------------------------------------------------------------*/
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 Player_collides_with_asteroid(player_t *pl, wireobject_t *ast)
{
double v = VECTOR_LENGTH(ast->vel);
double cost = collision_cost(ast->mass, v);
ast->life += ASTEROID_FUEL_HIT(ED_PL_CRASH, ast->wire_size);
if (ast->life < 0.0)
ast->life = 0.0;
if (ast->life == 0.0) {
Handle_Scoring(SCORE_ASTEROID_KILL,pl,NULL,ast,NULL);
}
if (!Player_uses_emergency_shield(pl))
Player_add_fuel(pl, -cost);
if (options.asteroidCollisionMayKill
&& (pl->fuel.sum == 0.0
|| (!BIT(pl->used, HAS_SHIELD)
&& !Player_has_armor(pl)))) {
Player_set_state(pl, PL_STATE_KILLED);
if (pl->velocity > v)
/* player moves faster than asteroid */
Set_message_f("%s smashed into an asteroid.", pl->name);
else
Set_message_f("%s was hit by an asteroid.", pl->name);
Handle_Scoring(SCORE_ASTEROID_DEATH,NULL,pl,NULL,NULL);
if (Player_is_tank(pl)) {
player_t *owner_pl = Player_by_id(pl->lock.pl_id);
Handle_Scoring(SCORE_ASTEROID_KILL,owner_pl,NULL,ast,NULL);
}
return;
}
if (options.asteroidCollisionMayKill
&& !BIT(pl->used, HAS_SHIELD)
&& Player_has_armor(pl))
Player_hit_armor(pl);
}
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);
}
}
}
/* 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);
}
}
}
}
static void AsteroidCollision(void)
{
int j, radius, obj_count;
object_t *ast;
object_t *obj = NULL, **obj_list;
list_t list;
list_iter_t iter;
double damage = 0.0;
bool sound = false;
list = Asteroid_get_list();
if (!list)
return;
for (iter = List_begin(list); iter != List_end(list); LI_FORWARD(iter)) {
ast = (object_t *)LI_DATA(iter);
assert(ast->type == OBJ_ASTEROID);
if (ast->life <= 0.0)
continue;
assert(World_contains_clpos(ast->pos));
if (NumObjs >= options.cellGetObjectsThreshold)
Cell_get_objects(ast->pos, ast->pl_radius / BLOCK_SZ + 1,
300, &obj_list, &obj_count);
else {
obj_list = Obj;
obj_count = NumObjs;
}
for (j = 0; j < obj_count; j++) {
obj = obj_list[j];
assert(obj != NULL);
/* asteroids don't hit these objects */
if ((obj->type == OBJ_ITEM
|| obj->type == OBJ_DEBRIS
|| obj->type == OBJ_SPARK
|| obj->type == OBJ_WRECKAGE)
&& obj->id == NO_ID
&& !BIT(obj->obj_status, FROMCANNON))
continue;
/* don't collide while still overlapping after breaking */
if (obj->type == OBJ_ASTEROID && ast->fuse > 0)
continue;
/* don't collide with self */
if (obj == ast)
continue;
/* don't collide with phased balls */
if (obj->type == OBJ_BALL
&& obj->id != NO_ID
&& Player_is_phasing(Player_by_id(obj->id)))
continue;
radius = (ast->pl_radius + obj->pl_radius) * CLICK;
if (!in_range(OBJ_PTR(ast), obj, (double)radius))
continue;
switch (obj->type) {
case OBJ_BALL:
Obj_repel(ast, obj, radius);
if (options.treasureCollisionDestroys)
obj->life = 0.0;
damage = ED_BALL_HIT;
sound = true;
break;
case OBJ_ASTEROID:
obj->life -= ASTEROID_FUEL_HIT(
collision_cost(ast->mass, VECTOR_LENGTH(ast->vel)),
WIRE_PTR(obj)->wire_size);
damage = -collision_cost(obj->mass, VECTOR_LENGTH(obj->vel));
Delta_mv_elastic(ast, obj);
/* avoid doing collision twice */
obj->fuse = timeStep;
sound = true;
break;
case OBJ_SPARK:
obj->life = 0.0;
Delta_mv(ast, obj);
damage = 0.0;
break;
case OBJ_DEBRIS:
case OBJ_WRECKAGE:
obj->life = 0.0;
damage = -collision_cost(obj->mass, VECTOR_LENGTH(obj->vel));
Delta_mv(ast, obj);
break;
case OBJ_MINE:
if (!BIT(obj->obj_status, CONFUSED))
obj->life = 0.0;
break;
case OBJ_SHOT:
case OBJ_CANNON_SHOT:
obj->life = 0.0;
Delta_mv(ast, obj);
damage = ED_SHOT_HIT;
sound = true;
break;
case OBJ_SMART_SHOT:
case OBJ_TORPEDO:
case OBJ_HEAT_SHOT:
obj->life = 0.0;
Delta_mv(ast, obj);
damage = Missile_hit_drain(MISSILE_PTR(obj));
sound = true;
break;
case OBJ_PULSE:
obj->life = 0;
damage = ED_LASER_HIT;
sound = true;
break;
default:
Delta_mv(ast, obj);
damage = 0.0;
break;
}
if (ast->life > 0.0) {
/* kps - this is some strange sort of hack - fix it*/
/*if (ast->life <= ast->fuselife) {*/
ast->life += ASTEROID_FUEL_HIT(damage,
WIRE_PTR(ast)->wire_size);
/*}*/
if (sound)
sound_play_sensors(ast->pos, ASTEROID_HIT_SOUND);
if (ast->life < 0.0)
ast->life = 0.0;
if (ast->life == 0.0) {
if ((obj->id != NO_ID
|| (obj->type == OBJ_BALL
&& BALL_PTR(obj)->ball_owner != NO_ID))) {
int owner_id = ((obj->type == OBJ_BALL)
? BALL_PTR(obj)->ball_owner
: obj->id);
player_t *pl = Player_by_id(owner_id);
Handle_Scoring(SCORE_ASTEROID_KILL,pl,NULL,ast,NULL);
}
/* break; */
}
}
}
}
}
/**
* Loads console commands list
**/
void console_load_defaults(void)
{
/**
* Defines a main category.
*
* Categories can't be used as commands!
* E.G.
* - sql update skip
* 'sql' is the main category
* CP_DEF_C(category)
**/
#define CP_DEF_C(x) { #x , CPET_CATEGORY, NULL , NULL, NULL }
/**
* Defines a sub-category.
*
* Sub-categories can't be used as commands!
* E.G.
* - sql update skip
* 'update' is a sub-category
* CP_DEF_C2(command, category)
**/
#define CP_DEF_C2(x,y) { #x , CPET_CATEGORY, NULL , #y, NULL }
/**
* Defines a command that is inside a category or sub-category
* CP_DEF_S(command, category/sub-category)
**/
#define CP_DEF_S(x,y) { #x, CPET_FUNCTION, CPCMD_C_A(x,y), #y, NULL }
/**
* Defines a command that is _not_ inside any category
* CP_DEF_S(command)
**/
#define CP_DEF(x) { #x , CPET_FUNCTION, CPCMD_A(x), NULL, NULL }
struct {
char *name;
int type;
CParseFunc func;
char *connect;
struct CParseEntry *self;
} default_list[] = {
CP_DEF(help),
/**
* Server related commands
**/
CP_DEF_C(server),
CP_DEF_S(ers_report,server),
CP_DEF_S(mem_report,server),
CP_DEF_S(malloc_usage,server),
CP_DEF_S(exit,server),
/**
* Sql related commands
**/
CP_DEF_C(sql),
CP_DEF_C2(update,sql),
CP_DEF_S(skip,update),
};
int len = ARRAYLENGTH(default_list);
struct CParseEntry *cmd;
int i;
VECTOR_ENSURE(console->input->commands, len, 1);
for(i = 0; i < len; i++) {
CREATE(cmd, struct CParseEntry, 1);
safestrncpy(cmd->cmd, default_list[i].name, CP_CMD_LENGTH);
cmd->type = default_list[i].type;
switch (cmd->type) {
case CPET_FUNCTION:
cmd->u.func = default_list[i].func;
break;
case CPET_CATEGORY:
VECTOR_INIT(cmd->u.children);
break;
case CPET_UNKNOWN:
break;
}
VECTOR_PUSH(console->input->commands, cmd);
default_list[i].self = cmd;
if (!default_list[i].connect) {
VECTOR_ENSURE(console->input->command_list, 1, 1);
VECTOR_PUSH(console->input->command_list, cmd);
}
}
for (i = 0; i < len; i++) {
int k;
if (!default_list[i].connect)
continue;
ARR_FIND(0, VECTOR_LENGTH(console->input->commands), k, strcmpi(default_list[i].connect, VECTOR_INDEX(console->input->commands, k)->cmd) == 0);
if (k != VECTOR_LENGTH(console->input->commands)) {
struct CParseEntry *parent = VECTOR_INDEX(console->input->commands, k);
Assert_retb(parent->type == CPET_CATEGORY);
cmd = default_list[i].self;
VECTOR_ENSURE(parent->u.children, 1, 1);
VECTOR_PUSH(parent->u.children, cmd);
}
}
#undef CP_DEF_C
#undef CP_DEF_C2
#undef CP_DEF_S
#undef CP_DEF
}
/* <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;
}
}
}
}
}
}
}
}
}
}
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);
}
static SCM
memoize (SCM exp, SCM env)
{
if (!SCM_EXPANDED_P (exp))
abort ();
switch (SCM_EXPANDED_TYPE (exp))
{
case SCM_EXPANDED_VOID:
return MAKMEMO_QUOTE (SCM_UNSPECIFIED);
case SCM_EXPANDED_CONST:
return MAKMEMO_QUOTE (REF (exp, CONST, EXP));
case SCM_EXPANDED_PRIMITIVE_REF:
if (scm_is_eq (scm_current_module (), scm_the_root_module ()))
return maybe_makmemo_capture_module
(MAKMEMO_BOX_REF (MAKMEMO_TOP_BOX (SCM_EXPANDED_TOPLEVEL_REF,
REF (exp, PRIMITIVE_REF, NAME))),
env);
else
return MAKMEMO_BOX_REF (MAKMEMO_MOD_BOX (SCM_EXPANDED_MODULE_REF,
list_of_guile,
REF (exp, PRIMITIVE_REF, NAME),
SCM_BOOL_F));
case SCM_EXPANDED_LEXICAL_REF:
return MAKMEMO_LEX_REF (lookup (REF (exp, LEXICAL_REF, GENSYM), env));
case SCM_EXPANDED_LEXICAL_SET:
return MAKMEMO_LEX_SET (lookup (REF (exp, LEXICAL_SET, GENSYM), env),
memoize (REF (exp, LEXICAL_SET, EXP), env));
case SCM_EXPANDED_MODULE_REF:
return MAKMEMO_BOX_REF (MAKMEMO_MOD_BOX
(SCM_EXPANDED_MODULE_REF,
REF (exp, MODULE_REF, MOD),
REF (exp, MODULE_REF, NAME),
REF (exp, MODULE_REF, PUBLIC)));
case SCM_EXPANDED_MODULE_SET:
return MAKMEMO_BOX_SET (MAKMEMO_MOD_BOX
(SCM_EXPANDED_MODULE_SET,
REF (exp, MODULE_SET, MOD),
REF (exp, MODULE_SET, NAME),
REF (exp, MODULE_SET, PUBLIC)),
memoize (REF (exp, MODULE_SET, EXP), env));
case SCM_EXPANDED_TOPLEVEL_REF:
return maybe_makmemo_capture_module
(MAKMEMO_BOX_REF (MAKMEMO_TOP_BOX (SCM_EXPANDED_TOPLEVEL_REF,
REF (exp, TOPLEVEL_REF, NAME))),
env);
case SCM_EXPANDED_TOPLEVEL_SET:
return maybe_makmemo_capture_module
(MAKMEMO_BOX_SET (MAKMEMO_TOP_BOX (SCM_EXPANDED_TOPLEVEL_SET,
REF (exp, TOPLEVEL_SET, NAME)),
memoize (REF (exp, TOPLEVEL_SET, EXP),
capture_env (env))),
env);
case SCM_EXPANDED_TOPLEVEL_DEFINE:
return maybe_makmemo_capture_module
(MAKMEMO_BOX_SET (MAKMEMO_TOP_BOX (SCM_EXPANDED_TOPLEVEL_DEFINE,
REF (exp, TOPLEVEL_DEFINE, NAME)),
memoize (REF (exp, TOPLEVEL_DEFINE, EXP),
capture_env (env))),
env);
case SCM_EXPANDED_CONDITIONAL:
return MAKMEMO_IF (memoize (REF (exp, CONDITIONAL, TEST), env),
memoize (REF (exp, CONDITIONAL, CONSEQUENT), env),
memoize (REF (exp, CONDITIONAL, ALTERNATE), env));
case SCM_EXPANDED_CALL:
{
SCM proc, args;
proc = REF (exp, CALL, PROC);
args = memoize_exps (REF (exp, CALL, ARGS), env);
return MAKMEMO_CALL (memoize (proc, env), args);
}
case SCM_EXPANDED_PRIMCALL:
{
SCM name, args;
int nargs;
name = REF (exp, PRIMCALL, NAME);
args = memoize_exps (REF (exp, PRIMCALL, ARGS), env);
nargs = scm_ilength (args);
if (nargs == 3
&& scm_is_eq (name, scm_from_latin1_symbol ("call-with-prompt")))
return MAKMEMO_CALL_WITH_PROMPT (CAR (args),
CADR (args),
CADDR (args));
else if (nargs == 2
&& scm_is_eq (name, scm_from_latin1_symbol ("apply")))
return MAKMEMO_APPLY (CAR (args), CADR (args));
else if (nargs == 1
&& scm_is_eq (name,
scm_from_latin1_symbol
("call-with-current-continuation")))
return MAKMEMO_CONT (CAR (args));
else if (nargs == 2
&& scm_is_eq (name,
scm_from_latin1_symbol ("call-with-values")))
return MAKMEMO_CALL_WITH_VALUES (CAR (args), CADR (args));
else if (nargs == 1
&& scm_is_eq (name,
scm_from_latin1_symbol ("variable-ref")))
return MAKMEMO_BOX_REF (CAR (args));
else if (nargs == 2
&& scm_is_eq (name,
scm_from_latin1_symbol ("variable-set!")))
return MAKMEMO_BOX_SET (CAR (args), CADR (args));
else if (nargs == 2
&& scm_is_eq (name, scm_from_latin1_symbol ("wind")))
return MAKMEMO_CALL (MAKMEMO_QUOTE (wind), args);
else if (nargs == 0
&& scm_is_eq (name, scm_from_latin1_symbol ("unwind")))
return MAKMEMO_CALL (MAKMEMO_QUOTE (unwind), SCM_EOL);
else if (nargs == 2
&& scm_is_eq (name, scm_from_latin1_symbol ("push-fluid")))
return MAKMEMO_CALL (MAKMEMO_QUOTE (push_fluid), args);
else if (nargs == 0
&& scm_is_eq (name, scm_from_latin1_symbol ("pop-fluid")))
return MAKMEMO_CALL (MAKMEMO_QUOTE (pop_fluid), SCM_EOL);
else if (nargs == 1
&& scm_is_eq (name,
scm_from_latin1_symbol ("push-dynamic-state")))
return MAKMEMO_CALL (MAKMEMO_QUOTE (push_dynamic_state), args);
else if (nargs == 0
&& scm_is_eq (name,
scm_from_latin1_symbol ("pop-dynamic-state")))
return MAKMEMO_CALL (MAKMEMO_QUOTE (pop_dynamic_state), SCM_EOL);
else if (scm_is_eq (scm_current_module (), scm_the_root_module ()))
return MAKMEMO_CALL (maybe_makmemo_capture_module
(MAKMEMO_BOX_REF
(MAKMEMO_TOP_BOX (SCM_EXPANDED_TOPLEVEL_REF,
name)),
env),
args);
else
return MAKMEMO_CALL (MAKMEMO_BOX_REF
(MAKMEMO_MOD_BOX (SCM_EXPANDED_MODULE_REF,
list_of_guile,
name,
SCM_BOOL_F)),
args);
}
case SCM_EXPANDED_SEQ:
return MAKMEMO_SEQ (memoize (REF (exp, SEQ, HEAD), env),
memoize (REF (exp, SEQ, TAIL), env));
case SCM_EXPANDED_LAMBDA:
/* The body will be a lambda-case. */
{
SCM meta, body, proc, new_env;
meta = REF (exp, LAMBDA, META);
body = REF (exp, LAMBDA, BODY);
new_env = push_flat_link (capture_env (env));
proc = memoize (body, new_env);
SCM_SETCAR (SCM_CDR (SCM_MEMOIZED_ARGS (proc)), meta);
return maybe_makmemo_capture_module (capture_flat_env (proc, new_env),
env);
}
case SCM_EXPANDED_LAMBDA_CASE:
{
SCM req, rest, opt, kw, inits, vars, body, alt;
SCM unbound, arity, rib, new_env;
int nreq, nopt, ninits;
req = REF (exp, LAMBDA_CASE, REQ);
rest = scm_not (scm_not (REF (exp, LAMBDA_CASE, REST)));
opt = REF (exp, LAMBDA_CASE, OPT);
kw = REF (exp, LAMBDA_CASE, KW);
inits = REF (exp, LAMBDA_CASE, INITS);
vars = REF (exp, LAMBDA_CASE, GENSYMS);
body = REF (exp, LAMBDA_CASE, BODY);
alt = REF (exp, LAMBDA_CASE, ALTERNATE);
nreq = scm_ilength (req);
nopt = scm_is_pair (opt) ? scm_ilength (opt) : 0;
ninits = scm_ilength (inits);
/* This relies on assignment conversion turning inits into a
sequence of CONST expressions whose values are a unique
"unbound" token. */
unbound = ninits ? REF (CAR (inits), CONST, EXP) : SCM_BOOL_F;
rib = scm_vector (vars);
new_env = push_nested_link (rib, env);
if (scm_is_true (kw))
{
/* (aok? (kw name sym) ...) -> (aok? (kw . index) ...) */
SCM aok = CAR (kw), indices = SCM_EOL;
for (kw = CDR (kw); scm_is_pair (kw); kw = CDR (kw))
{
SCM k;
int idx;
k = CAR (CAR (kw));
idx = lookup_rib (CADDR (CAR (kw)), rib);
indices = scm_acons (k, SCM_I_MAKINUM (idx), indices);
}
kw = scm_cons (aok, scm_reverse_x (indices, SCM_UNDEFINED));
}
if (scm_is_false (alt) && scm_is_false (kw) && scm_is_false (opt))
{
if (scm_is_false (rest))
arity = FIXED_ARITY (nreq);
else
arity = REST_ARITY (nreq, SCM_BOOL_T);
}
else if (scm_is_true (alt))
arity = FULL_ARITY (nreq, rest, nopt, kw, ninits, unbound,
SCM_MEMOIZED_ARGS (memoize (alt, env)));
else
arity = FULL_ARITY (nreq, rest, nopt, kw, ninits, unbound,
SCM_BOOL_F);
return MAKMEMO_LAMBDA (memoize (body, new_env), arity,
SCM_EOL /* meta, filled in later */);
}
case SCM_EXPANDED_LET:
{
SCM vars, exps, body, varsv, inits, new_env;
int i;
vars = REF (exp, LET, GENSYMS);
exps = REF (exp, LET, VALS);
body = REF (exp, LET, BODY);
varsv = scm_vector (vars);
inits = scm_c_make_vector (VECTOR_LENGTH (varsv),
SCM_BOOL_F);
new_env = push_nested_link (varsv, capture_env (env));
for (i = 0; scm_is_pair (exps); exps = CDR (exps), i++)
VECTOR_SET (inits, i, memoize (CAR (exps), env));
return maybe_makmemo_capture_module
(MAKMEMO_LET (inits, memoize (body, new_env)), env);
}
default:
abort ();
}
}
void garbage_collect(long min_space) {
char *p;
object **gcp;
object *op;
long i, max, count;
int old_interrupt;
if (*will_gc_hook) (*will_gc_hook)();
old_interrupt = enable_interrupts(0);
/* switch heap space */
gc_count++;
/* printf("[GC]\n"); */
heap += heap_size;
if (heap >= max_heap)
heap = min_memory;
heap_pointer = heap;
heap_end = heap + heap_size;
/* migrate objects */
count = gc_root_stack_pointer - gc_root_stack_begin;
migrate_object(gc_root_stack_buffer);
if (FORWARDED_P(gc_root_stack_buffer)) gc_root_stack_buffer = FORWARDED_POINTER(gc_root_stack_buffer);
gc_root_stack_begin = (object **)BUFFER_DATA(gc_root_stack_buffer);
gc_root_stack_end = gc_root_stack_begin + GC_ROOT_STACK_MAX;
gc_root_stack_pointer = gc_root_stack_begin + count;
gcp = gc_root_stack_begin;
for (i=0; i<count; i++)
migrate_object(*gcp[i]);
for (op = sp; op < stack_top; op++)
migrate_object(*op);
/* eliminate forwarding pointers */
gcp = gc_root_stack_begin;
for (i=0; i<count; i++) {
object o = *gcp[i];
if (FORWARDED_P(o))
*gcp[i] = FORWARDED_POINTER(o);
}
for (op = sp; op < stack_top; op++) {
object o = *op;
if (FORWARDED_P(o))
*op = FORWARDED_POINTER(o);
}
p = heap;
while (p < heap_pointer) {
object *q, obj, o;
obj = (object)p;
switch (POINTER_TYPE(obj)) {
case PAIR_TYPE:
o = CAR(obj); if (FORWARDED_P(o)) CAR(obj) = FORWARDED_POINTER(o);
o = CDR(obj); if (FORWARDED_P(o)) CDR(obj) = FORWARDED_POINTER(o);
break;
case WEAK_TYPE:
if (FORWARDED_P(WEAK_VALUE(obj))) {
WEAK_BOUND(obj) = 1;
} else {
WEAK_BOUND(obj) = 0;
migrate_object(WEAK_VALUE(obj));
}
o = WEAK_VALUE(obj); if (FORWARDED_P(o)) WEAK_VALUE(obj) = FORWARDED_POINTER(o);
break;
case SYMBOL_TYPE:
o = SYMBOL_VALUE(obj); if (FORWARDED_P(o)) SYMBOL_VALUE(obj) = FORWARDED_POINTER(o);
break;
case VECTOR_TYPE:
max = VECTOR_LENGTH(obj);
q = VECTOR_ELEMENTS(obj);
for (i=0; i<max; i++) {
o = q[i]; if (FORWARDED_P(o)) q[i] = FORWARDED_POINTER(o);
}
o = VECTOR_TAG(obj); if (FORWARDED_P(o)) VECTOR_TAG(obj) = FORWARDED_POINTER(o);
break;
case PROCEDURE_TYPE:
o = PROC_MODULE(obj); if (FORWARDED_P(o)) PROC_MODULE(obj) = FORWARDED_POINTER(o);
break;
case FRAME_TYPE:
o = FRAME_PREVIOUS(obj); if (FORWARDED_P(o)) FRAME_PREVIOUS(obj) = FORWARDED_POINTER(o);
o = FRAME_ENV(obj); if (FORWARDED_P(o)) FRAME_ENV(obj) = FORWARDED_POINTER(o);
max = (POINTER_LENGTH(obj) - sizeof(struct frame_heap_structure))/sizeof(long);
q = FRAME_ELEMENTS(obj);
for (i=0; i<max; i++) {
o = q[i]; if (FORWARDED_P(o)) q[i] = FORWARDED_POINTER(o);
}
break;
case CLOSURE_TYPE:
o = CLOSURE_PROC(obj); if (FORWARDED_P(o)) CLOSURE_PROC(obj) = FORWARDED_POINTER(o);
o = CLOSURE_ENV(obj); if (FORWARDED_P(o)) CLOSURE_ENV(obj) = FORWARDED_POINTER(o);
break;
case CONTINUATION_TYPE:
o = CONTINUATION_FRAME(obj); if (FORWARDED_P(o)) CONTINUATION_FRAME(obj) = FORWARDED_POINTER(o);
max = CONTINUATION_STACKSIZE(obj);
q = CONTINUATION_STACK(obj);
for (i=0; i<max; i++) {
o = q[i]; if (FORWARDED_P(o)) q[i] = FORWARDED_POINTER(o);
}
break;
case SYMBOLTABLE_TYPE:
o = SYMBOLTABLE_MAPPINGS(obj); if (FORWARDED_P(o)) SYMBOLTABLE_MAPPINGS(obj) = FORWARDED_POINTER(o);
break;
case PORT_TYPE:
o = PORT_BUFFER(obj); if (FORWARDED_P(o)) PORT_BUFFER(obj) = FORWARDED_POINTER(o);
break;
default:
fatal_error("Unknown pointer type: heap.c#garbage_collect(): %p\n", obj);
return;
}
p += POINTER_LENGTH(obj);
}
/* finalization of ports */
close_stale_ports();
fix_runtime_pointers();
/* Finish up */
enable_interrupts(old_interrupt);
i = heap_size - (heap_pointer - heap);
if (i < min_space)
fatal_error("out of heap space: %d\n", i);
if (*did_gc_hook) (*did_gc_hook)();
}
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 ();
}
}
