void CacheList::preload_cache_object(int type)
{
if (type<0xffff)
{
if (!figures[type]->get_cflag(CFLAG_NEED_CACHE_IN)) // see if it's already marked
{
figures[type]->set_cflag(CFLAG_NEED_CACHE_IN,1);
void *cache_fun=figures[type]->get_fun(OFUN_GET_CACHE_LIST);
if (cache_fun)
{
LSpace *sp = LSpace::Current;
LSpace::Current = &LSpace::Perm;
void *call_with=NULL;
push_onto_list(LNumber::Create(type),call_with);
void *CacheList = ((LSymbol *)cache_fun)->EvalFunction(call_with);
PtrRef r1(CacheList);
if (CacheList && lcar(CacheList))
{
void *obj_list=lcar(CacheList);
while (obj_list)
{
int t=lnumber_value(CAR(obj_list));
if (t<0 || t>=total_objects)
lbreak("Get cache list returned a bad object number %d\n",t);
else
preload_cache_object(t);
obj_list=CDR(obj_list);
}
}
if (CacheList && lcdr(CacheList))
{
void *id_list=lcar(lcdr(CacheList));
while (id_list)
{
int id=lnumber_value(CAR(id_list));
if (id<0 || id>=total)
lbreak("Get cache list returned a bad id number %d\n",id);
else if (list[id].last_access<0)
list[id].last_access=-2;
else list[id].last_access=2;
id_list=CDR(id_list);
}
}
LSpace::Current=sp;
}
}
}
}
int CacheList::reg_object(char const *filename, LObject *object, int type,
int rm_dups) {
// See if we got a object with a filename included. Otherwise,
// it's a string.
if (item_type(object) == L_CONS_CELL) {
filename = lstring_value(lcar(object));
object = lcdr(object);
}
return reg(filename, lstring_value(object), type, rm_dups);
}
static lref_t execute_fast_op(lref_t fop, lref_t env)
{
lref_t retval = NIL;
lref_t sym;
lref_t binding;
lref_t fn;
lref_t args;
size_t argc;
lref_t argv[ARG_BUF_LEN];
lref_t after;
lref_t tag;
lref_t cell;
lref_t escape_retval;
jmp_buf *jmpbuf;
STACK_CHECK(&fop);
_process_interrupts();
fstack_enter_eval_frame(&fop, fop, env);
while(!NULLP(fop)) {
switch(fop->header.opcode)
{
case FOP_LITERAL:
retval = fop->as.fast_op.arg1;
fop = fop->as.fast_op.next;
break;
case FOP_GLOBAL_REF:
sym = fop->as.fast_op.arg1;
binding = SYMBOL_VCELL(sym);
if (UNBOUND_MARKER_P(binding))
vmerror_unbound(sym);
retval = binding;
fop = fop->as.fast_op.next;
break;
case FOP_GLOBAL_SET:
sym = fop->as.fast_op.arg1;
binding = SYMBOL_VCELL(sym);
if (UNBOUND_MARKER_P(binding))
vmerror_unbound(sym);
SET_SYMBOL_VCELL(sym, retval);
fop = fop->as.fast_op.next;
break;
case FOP_APPLY_GLOBAL:
sym = fop->as.fast_op.arg1;
fn = SYMBOL_VCELL(sym);
if (UNBOUND_MARKER_P(fn))
vmerror_unbound(sym);
argc = 0;
args = fop->as.fast_op.arg2;
while (CONSP(args)) {
if (argc >= ARG_BUF_LEN) {
vmerror_unsupported(_T("too many actual arguments"));
break;
}
argv[argc] = execute_fast_op(CAR(args), env);
args = CDR(args);
argc++;
}
if (!NULLP(args))
vmerror_arg_out_of_range(fop->as.fast_op.arg2,
_T("bad formal argument list"));
fop = apply(fn, argc, argv, &env, &retval);
break;
case FOP_APPLY:
argc = 0;
fn = execute_fast_op(fop->as.fast_op.arg1, env);
args = fop->as.fast_op.arg2;
while (CONSP(args)) {
if (argc >= ARG_BUF_LEN) {
vmerror_unsupported(_T("too many actual arguments"));
break;
}
argv[argc] = execute_fast_op(CAR(args), env);
args = CDR(args);
argc++;
}
if (!NULLP(args))
vmerror_arg_out_of_range(fop->as.fast_op.arg2,
_T("bad formal argument list"));
fop = apply(fn, argc, argv, &env, &retval);
break;
case FOP_IF_TRUE:
if (TRUEP(retval))
fop = fop->as.fast_op.arg1;
else
fop = fop->as.fast_op.arg2;
break;
case FOP_RETVAL:
fop = fop->as.fast_op.next;
break;
case FOP_SEQUENCE:
retval = execute_fast_op(fop->as.fast_op.arg1, env);
fop = fop->as.fast_op.arg2;
break;
case FOP_THROW:
tag = execute_fast_op(fop->as.fast_op.arg1, env);
escape_retval = execute_fast_op(fop->as.fast_op.arg2, env);
dscwritef(DF_SHOW_THROWS, (_T("; DEBUG: throw ~a, retval = ~a\n"), tag, escape_retval));
CURRENT_TIB()->escape_frame = find_matching_escape(CURRENT_TIB()->frame, tag);
CURRENT_TIB()->escape_value = escape_retval;
if (CURRENT_TIB()->escape_frame == NULL) {
/* If we don't find a matching catch for the throw, we have a
* problem and need to invoke a trap. */
vmtrap(TRAP_UNCAUGHT_THROW,
(enum vmt_options_t)(VMT_MANDATORY_TRAP | VMT_HANDLER_MUST_ESCAPE),
2, tag, escape_retval);
}
unwind_stack_for_throw();
fop = fop->as.fast_op.next;
break;
case FOP_CATCH:
tag = execute_fast_op(fop->as.fast_op.arg1, env);
jmpbuf = fstack_enter_catch_frame(tag, CURRENT_TIB()->frame);
dscwritef(DF_SHOW_THROWS, (_T("; DEBUG: setjmp tag: ~a, frame: ~c&, jmpbuf: ~c&\n"), tag, CURRENT_TIB()->frame, jmpbuf));
if (setjmp(*jmpbuf) == 0) {
retval = execute_fast_op(fop->as.fast_op.arg2, env);
} else {
dscwritef(DF_SHOW_THROWS, (_T("; DEBUG: catch, retval = ~a\n"), CURRENT_TIB()->escape_value));
retval = CURRENT_TIB()->escape_value;
CURRENT_TIB()->escape_value = NIL;
}
fstack_leave_frame();
fop = fop->as.fast_op.next;
break;
case FOP_WITH_UNWIND_FN:
fstack_enter_unwind_frame(execute_fast_op(fop->as.fast_op.arg1, env));
retval = execute_fast_op(fop->as.fast_op.arg2, env);
after = CURRENT_TIB()->frame[FOFS_UNWIND_AFTER];
fstack_leave_frame();
apply1(after, 0, NULL);
fop = fop->as.fast_op.next;
break;
case FOP_CLOSURE:
retval = lclosurecons(env,
lcons(lcar(fop->as.fast_op.arg1),
fop->as.fast_op.arg2),
lcdr(fop->as.fast_op.arg1));
fop = fop->as.fast_op.next;
break;
case FOP_CAR:
retval = lcar(retval);
fop = fop->as.fast_op.next;
break;
case FOP_CDR:
retval = lcdr(retval);
fop = fop->as.fast_op.next;
break;
case FOP_NOT:
retval = boolcons(!TRUEP(retval));
fop = fop->as.fast_op.next;
break;
case FOP_NULLP:
retval = boolcons(NULLP(retval));
fop = fop->as.fast_op.next;
break;
case FOP_EQP:
retval = boolcons(EQ(execute_fast_op(fop->as.fast_op.arg1, env),
execute_fast_op(fop->as.fast_op.arg2, env)));
fop = fop->as.fast_op.next;
break;
case FOP_GET_ENV:
retval = env;
fop = fop->as.fast_op.next;
break;
case FOP_GLOBAL_DEF: // three args, third was genv, but currently unused
retval = lidefine_global(fop->as.fast_op.arg1, fop->as.fast_op.arg2);
fop = fop->as.fast_op.next;
break;
case FOP_GET_FSP:
retval = fixcons((fixnum_t)CURRENT_TIB()->fsp);
fop = fop->as.fast_op.next;
break;
case FOP_GET_FRAME:
retval = fixcons((fixnum_t)CURRENT_TIB()->frame);
fop = fop->as.fast_op.next;
break;
case FOP_GET_HFRAMES:
retval = CURRENT_TIB()->handler_frames;
fop = fop->as.fast_op.next;
break;
case FOP_SET_HFRAMES:
CURRENT_TIB()->handler_frames = execute_fast_op(fop->as.fast_op.arg1, env);
fop = fop->as.fast_op.next;
break;
case FOP_GLOBAL_PRESERVE_FRAME:
sym = fop->as.fast_op.arg1;
binding = SYMBOL_VCELL(sym);
if (UNBOUND_MARKER_P(binding))
vmerror_unbound(sym);
SET_SYMBOL_VCELL(sym, fixcons((fixnum_t)CURRENT_TIB()->frame));
retval = execute_fast_op(fop->as.fast_op.arg2, env);
fop = fop->as.fast_op.next;
break;
case FOP_STACK_BOUNDARY:
sym = execute_fast_op(fop->as.fast_op.arg1, env);
fstack_enter_boundary_frame(sym);
retval = execute_fast_op(fop->as.fast_op.arg2, env);
fstack_leave_frame();
fop = fop->as.fast_op.next;
break;
case FOP_FAST_ENQUEUE_CELL:
retval = execute_fast_op(fop->as.fast_op.arg2, env);
cell = execute_fast_op(fop->as.fast_op.arg1, env);
SET_CDR(CAR(retval), cell);
SET_CAR(retval, cell);
fop = fop->as.fast_op.next;
break;
case FOP_WHILE_TRUE:
while(TRUEP(execute_fast_op(fop->as.fast_op.arg1, env))) {
retval = execute_fast_op(fop->as.fast_op.arg2, env);
}
fop = fop->as.fast_op.next;
break;
case FOP_LOCAL_REF_BY_INDEX:
retval = lenvlookup_by_index(FIXNM(fop->as.fast_op.arg1),
FIXNM(fop->as.fast_op.arg2),
env);
fop = fop->as.fast_op.next;
break;
case FOP_LOCAL_REF_RESTARG:
retval = lenvlookup_restarg_by_index(FIXNM(fop->as.fast_op.arg1),
FIXNM(fop->as.fast_op.arg2),
env);
fop = fop->as.fast_op.next;
break;
case FOP_LOCAL_SET_BY_INDEX:
lenvlookup_set_by_index(FIXNM(fop->as.fast_op.arg1),
FIXNM(fop->as.fast_op.arg2),
env,
retval);
fop = fop->as.fast_op.next;
break;
default:
panic("Unsupported fast-op");
}
}
fstack_leave_frame();
return retval;
}
int menu(void *args, JCFont *font) // reurns -1 on esc
{
main_menu();
char *title=NULL;
if (!NILP(CAR(args)))
title=lstring_value(CAR(args));
Cell *def=lcar(lcdr(lcdr(args)));
args=CAR(CDR(args));
int options=list_length(args);
int mh=(font->height()+1)*options+10,maxw=0;
Cell *c=(Cell *)args;
for (;!NILP(c);c=CDR(c))
{
if (strlen(men_str(CAR(c)))>maxw)
maxw=strlen(men_str(CAR(c)));
}
int mw=(font->width())*maxw+20;
int mx=screen->width()/2-mw/2,
my=screen->height()/2-mh/2;
screen->add_dirty(mx,my,mx+mw-1,my+mh-1);
if (title)
{
int tl=strlen(title)*font->width();
int tx=screen->width()/2-tl/2;
dark_wiget(tx-2,my-font->height()-4,tx+tl+2,my-2,eh->medium_color(),eh->dark_color(),180);
font->put_string(screen,tx+1,my-font->height()-2,title,eh->bright_color());
}
dark_wiget(mx,my,mx+mw-1,my+mh-1,eh->medium_color(),eh->dark_color(),200);
int y=my+5;
for (c=(Cell *)args;!NILP(c);c=CDR(c))
{
char *ms=men_str(CAR(c));
font->put_string(screen,mx+10+1,y+1,ms,eh->black());
font->put_string(screen,mx+10,y,ms,eh->bright_color());
y+=font->height()+1;
}
eh->flush_screen();
event ev;
int choice=0,done=0;
int bh=font->height()+3;
image *save=new image(mw-2,bh);
int color=128,cdir=50;
time_marker *last_color_time=NULL;
if (!NILP(def))
choice=lnumber_value(def);
do
{
eh->flush_screen();
if (eh->event_waiting())
{
eh->get_event(ev);
if (ev.type==EV_KEY)
{
switch (ev.key)
{
case JK_ESC :
{ choice=-1; done=1; } break;
case JK_ENTER :
{ done=1; } break;
case JK_DOWN :
{ if (choice<options-1)
choice++;
else choice=0;
} break;
case JK_UP :
{
if (choice>0)
choice--;
else choice=options-1;
} break;
}
} else if (ev.type==EV_MOUSE_BUTTON && ev.mouse_button)
{
if (ev.mouse_move.x>mx && ev.mouse_move.x<mx+mw && ev.mouse_move.y>my &&
ev.mouse_move.y<my+mh)
{
int msel=(ev.mouse_move.y-my)/(font->height()+1);
if (msel>=options) msel=options-1;
if (msel==choice) // clicked on already selected item, return it
done=1;
else choice=msel; // selects an item
}
}
}
time_marker cur_time;
if (!last_color_time || (int)(cur_time.diff_time(last_color_time)*1000)>120)
{
if (last_color_time)
delete last_color_time;
last_color_time=new time_marker;
int by1=(font->height()+1)*choice+my+5-2;
int by2=by1+bh-1;
screen->put_part(save,0,0,mx+1,by1,mx+mw-2,by2);
tint_area(mx+1,by1,mx+mw-2,by2,63,63,63,color);
char *cur=men_str(nth(choice,args));
font->put_string(screen,mx+10+1,by1+3,cur,eh->black());
font->put_string(screen,mx+10,by1+2,cur,eh->bright_color());
screen->rectangle(mx+1,by1,mx+mw-2,by2,eh->bright_color());
color+=cdir;
if (color<12 || color>256)
{
cdir=-cdir;
color+=cdir;
}
eh->flush_screen();
save->put_image(screen,mx+1,by1);
} else milli_wait(10);
} while (!done);
if (last_color_time)
delete last_color_time;
delete save;
the_game->draw(the_game->state==SCENE_STATE);
if (choice!=-1)
{
void *val=nth(choice,args);
if (item_type(val)==L_CONS_CELL) // is there another value that the user want us to return?
return lnumber_value(lcdr(val));
}
return choice;
}
lref_t debug_print_object(lref_t obj, lref_t port, bool machine_readable)
{
_TCHAR buf[STACK_STRBUF_LEN];
if (DEBUG_FLAG(DF_PRINT_ADDRESSES))
scwritef("#@~c&=", port, obj);
lref_t tmp;
size_t ii;
lref_t slots;
const _TCHAR *fast_op_name;
switch (TYPE(obj))
{
case TC_NIL:
WRITE_TEXT_CONSTANT(port, _T("()"));
break;
case TC_BOOLEAN:
if (TRUEP(obj))
WRITE_TEXT_CONSTANT(port, _T("#t"));
else
WRITE_TEXT_CONSTANT(port, _T("#f"));
break;
case TC_CONS:
write_char(port, _T('('));
debug_print_object(lcar(obj), port, machine_readable);
for (tmp = lcdr(obj); CONSP(tmp); tmp = lcdr(tmp))
{
write_char(port, _T(' '));
debug_print_object(lcar(tmp), port, machine_readable);
}
if (!NULLP(tmp))
{
WRITE_TEXT_CONSTANT(port, _T(" . "));
debug_print_object(tmp, port, machine_readable);
}
write_char(port, _T(')'));
break;
case TC_FIXNUM:
_sntprintf(buf, STACK_STRBUF_LEN, _T("%" SCAN_PRIiFIXNUM), FIXNM(obj));
write_text(port, buf, _tcslen(buf));
break;
case TC_FLONUM:
debug_print_flonum(obj, port, machine_readable);
break;
case TC_CHARACTER:
if (machine_readable)
{
if (CHARV(obj) < CHARNAMECOUNT)
scwritef(_T("#\\~cs"), port, charnames[(size_t) CHARV(obj)]);
else if (CHARV(obj) >= CHAREXTENDED - 1)
scwritef(_T("#\\<~cd>"), port, (int) CHARV(obj));
else
scwritef(_T("#\\~cc"), port, (int) CHARV(obj));
}
else
scwritef(_T("~cc"), port, (int) CHARV(obj));
break;
case TC_SYMBOL:
if (NULLP(SYMBOL_HOME(obj)))
{
if (DEBUG_FLAG(DF_PRINT_FOR_DIFF))
scwritef("#:<uninterned-symbol>", port);
else
scwritef("#:~a@~c&", port, SYMBOL_PNAME(obj), obj);
}
else if (SYMBOL_HOME(obj) == interp.control_fields[VMCTRL_PACKAGE_KEYWORD])
scwritef(":~a", port, SYMBOL_PNAME(obj));
else
{
/* With only a minimal c-level package implementation, we
* just assume every symbol is private. */
scwritef("~a::~a", port, SYMBOL_HOME(obj)->as.package.name, SYMBOL_PNAME(obj));
}
break;
case TC_VECTOR:
WRITE_TEXT_CONSTANT(port, _T("["));
for (ii = 0; ii < obj->as.vector.dim; ii++)
{
debug_print_object(obj->as.vector.data[ii], port, true);
if (ii + 1 < obj->as.vector.dim)
write_char(port, _T(' '));
}
write_char(port, _T(']'));
break;
case TC_STRUCTURE:
WRITE_TEXT_CONSTANT(port, _T("#S("));
debug_print_object(CAR(STRUCTURE_LAYOUT(obj)), port, true);
for (ii = 0, slots = CAR(CDR(STRUCTURE_LAYOUT(obj)));
ii < STRUCTURE_DIM(obj); ii++, slots = CDR(slots))
{
WRITE_TEXT_CONSTANT(port, _T(" "));
debug_print_object(CAR(CAR(slots)), port, true);
WRITE_TEXT_CONSTANT(port, _T(" "));
debug_print_object(STRUCTURE_ELEM(obj, ii), port, true);
}
WRITE_TEXT_CONSTANT(port, _T(")"));
break;
case TC_STRING:
debug_print_string(obj, port, machine_readable);
break;
case TC_HASH:
debug_print_hash(obj, port, machine_readable);
break;
case TC_PACKAGE:
scwritef("~u ~a", port, (lref_t) obj, obj->as.package.name);
break;
case TC_SUBR:
scwritef("~u,~cd:~a", port, (lref_t) obj, SUBR_TYPE(obj), SUBR_NAME(obj));
break;
case TC_CLOSURE:
if (DEBUG_FLAG(DF_PRINT_CLOSURE_CODE))
scwritef("~u\n\tcode:~s\n\tenv:~s\n\tp-list:~s", port,
(lref_t) obj, CLOSURE_CODE(obj), CLOSURE_ENV(obj),
CLOSURE_PROPERTY_LIST(obj));
else
scwritef("~u", port, (lref_t) obj);
break;
case TC_VALUES_TUPLE:
scwritef("~u ~s", port, (lref_t) obj, obj->as.values_tuple.values);
break;
case TC_MACRO:
if (DEBUG_FLAG(DF_PRINT_CLOSURE_CODE))
scwritef("~u ~s", port, (lref_t) obj, obj->as.macro.transformer);
else
scwritef("~u", port, (lref_t) obj);
break;
case TC_END_OF_FILE:
scwritef("~u", port, (lref_t) obj);
break;
case TC_PORT:
scwritef(_T("~u~cs~cs~cs ~cs ~s"), port,
obj,
PORT_INPUTP(obj) ? " (input)" : "",
PORT_OUTPUTP(obj) ? " (output)" : "",
BINARY_PORTP(obj) ? " (binary)" : "",
PORT_CLASS(obj)->name,
PORT_PINFO(obj)->port_name);
break;
case TC_FAST_OP:
fast_op_name = fast_op_opcode_name(obj->header.opcode);
if (fast_op_name)
scwritef("#<FOP@~c&:~cs ~s ~s => ~s>", port, (lref_t) obj,
fast_op_name,
obj->as.fast_op.arg1,
obj->as.fast_op.arg2,
obj->as.fast_op.next);
else
scwritef("#<FOP@~c&:~cd ~s ~s => ~s>", port, (lref_t) obj,
obj->header.opcode,
obj->as.fast_op.arg1,
obj->as.fast_op.arg2,
obj->as.fast_op.next);
break;
case TC_FASL_READER:
scwritef(_T("~u~s"), port,
obj,
FASL_READER_PORT(obj));
break;
case TC_UNBOUND_MARKER:
scwritef("#<UNBOUND-MARKER>", port);
break;
case TC_FREE_CELL:
scwritef("#<FREE CELL -- Forget a call to gc_mark? ~c&>", port, obj);
break;
default:
scwritef("#<INVALID OBJECT - UNKNOWN TYPE ~c&>", port, obj);
}
return port;
}
void load_tiles(Cell *file_list)
{
bFILE *fp;
spec_directory *sd;
spec_entry *spe;
int num;
Cell *fl;
int old_fsize=nforetiles,
old_bsize=nbacktiles;
for (fl=file_list; !NILP(fl); fl=lcdr(fl))
{
fp=open_file(lstring_value(lcar(fl)),"rb");
if (fp->open_failure())
{
printf("Warning : open %s for reading\n",lstring_value(lcar(fl)));
delete fp;
}
else
{
sd=new spec_directory(fp);
delete fp;
int i;
for (i=0; i<sd->total; i++)
{
spe=sd->entries[i];
switch (spe->type)
{
case SPEC_BACKTILE :
if (!sscanf(spe->name,"%d",&num))
printf("Warning : background tile %s has no number\n",spe->name);
else if (nbacktiles<=num) nbacktiles=num+1;
break;
case SPEC_FORETILE :
if (!sscanf(spe->name,"%d",&num))
printf("Warning : foreground tile %s has no number\n",spe->name);
else if (nforetiles<=num) nforetiles=num+1;
break;
}
}
delete sd;
}
}
// enlarge the arrays if needed.
if (nbacktiles>old_bsize)
{
backtiles=(int *)realloc(backtiles,sizeof(int)*nbacktiles);
memset(backtiles+old_bsize,-1,(nbacktiles-old_bsize)*sizeof(int));
}
if (nforetiles>old_fsize)
{
foretiles=(int *)realloc(foretiles,sizeof(int)*nforetiles);
memset(foretiles+old_fsize,-1,(nforetiles-old_fsize)*sizeof(int));
}
// now load them up
for (fl=file_list; !NILP(fl); fl=lcdr(fl))
{
char const *fn=lstring_value(lcar(fl));
fp=open_file(fn,"rb");
if (!fp->open_failure())
{
sd=new spec_directory(fp);
delete fp;
int i;
for (i=0; i<sd->total; i++)
{
spe=sd->entries[i];
switch (spe->type)
{
case SPEC_BACKTILE :
if (sscanf(spe->name,"%d",&num))
{
if (backtiles[num]>=0)
{
dprintf("Warning : background tile %d redefined\n",num);
cache.unreg(backtiles[num]);
}
backtiles[num]=cache.reg(fn,spe->name,SPEC_BACKTILE);
}
break;
case SPEC_FORETILE :
if (sscanf(spe->name,"%d",&num))
{
if (foretiles[num]>=0)
{
dprintf("Warning : foreground tile %d redefined\n",num);
cache.unreg(foretiles[num]);
}
foretiles[num]=cache.reg(fn,spe->name,SPEC_FORETILE);
}
break;
}
}
delete sd;
} else delete fp;
}
}
