static void continue_prepare(struct compile_and_run_frame *frame)
{
value closure;
struct global_state *gcopy;
if (mprepare_load_next_start(&frame->ps))
return;
mprepare_vars(&frame->ps);
gcopy = copy_global_state(frame->ps.ccontext->gstate);
GCPRO1(gcopy);
closure = compile_code(frame->ps.ccontext->gstate, frame->f->body);
GCPOP(1);
if (closure)
{
GCPRO1(closure);
if (debug_lvl > 1)
output_value(muderr, prt_examine, closure);
frame->state = running;
if (frame->dontrun)
{
/* Just leave the closure itself as the result */
stack_reserve(sizeof(value));
stack_push(closure);
}
else
push_closure(closure, 0);
GCPOP(1);
return;
}
global_set(frame->ps.ccontext->gstate, gcopy);
runtime_error(error_compile_error);
}
fncode new_fncode(struct global_state *gstate, location l, int toplevel, i8 nargs)
/* Returns: A new function code structure (in which code for functions
may be generated).
*/
{
block_t afnmemory = new_block();
fncode newp = allocate(afnmemory, sizeof *newp);
newp->l = l;
newp->toplevel = toplevel;
newp->fnmemory = afnmemory;
newp->instructions = NULL;
newp->last_ins = &newp->instructions;
newp->current_depth = newp->max_depth = 0;
newp->loopcount = 0;
newp->nargs = nargs;
newp->next_label = NULL;
newp->blks = NULL;
PUSH_LIST(newp->cstpro);
newp->cstpro.cl = &newp->csts;
init_list(&newp->csts);
newp->gstate = gstate;
GCPRO1(newp->gstate); /* Safe as new_fncode/delete_fncode called
in LIFO order */
return newp;
}
static struct closure *compile_code(struct global_state *gstate, clist b)
{
struct code *cc;
u8 nb_locals;
fncode top;
location topl;
struct string *afilename;
/* Code strings must be allocated before code (immutability restriction) */
afilename = make_filename(lexloc.filename);
GCPRO1(afilename);
erred = FALSE;
env_reset();
topl.filename = NULL;
topl.lineno = 0;
top = new_fncode(gstate, topl, TRUE, 0);
env_push(NULL, top); /* Environment must not be totally empty */
generate_clist(b, FALSE, top);
ins0(OPmreturn, top);
env_pop(&nb_locals);
cc = generate_fncode(top, nb_locals, NULL, NULL, afilename, 0);
delete_fncode(top);
GCPOP(1);
if (erred) return NULL;
else return alloc_closure0(cc);
}
static value make_list(constant loc, cstlist csts, int has_tail, bool save_location, fncode fn)
{
struct list *l;
if (has_tail && csts != NULL)
{
l = csts->cst ? make_constant(csts->cst, FALSE, fn) : NULL;
csts = csts->next;
}
else
l = NULL;
GCPRO1(l);
/* Remember that csts is in reverse order ... */
while (csts)
{
value tmp = make_constant(csts->cst, save_location, fn);
l = alloc_list(tmp, l);
SET_READONLY(l); SET_IMMUTABLE(l);
csts = csts->next;
}
if (save_location)
{
value vloc = make_location(&loc->loc);
l = alloc_list(vloc, l);
SET_READONLY(l); SET_IMMUTABLE(l);
}
GCPOP(1);
return l;
}
void
lock_file (Lisp_Object fn)
{
register Lisp_Object attack, orig_fn, encoded_fn;
register char *lfname, *locker;
lock_info_type lock_info;
struct gcpro gcpro1;
/* Don't do locking while dumping Emacs.
Uncompressing wtmp files uses call-process, which does not work
in an uninitialized Emacs. */
if (! NILP (Vpurify_flag))
return;
orig_fn = fn;
GCPRO1 (fn);
fn = Fexpand_file_name (fn, Qnil);
encoded_fn = ENCODE_FILE (fn);
/* Create the name of the lock-file for file fn */
MAKE_LOCK_NAME (lfname, encoded_fn);
/* See if this file is visited and has changed on disk since it was
visited. */
{
register Lisp_Object subject_buf;
subject_buf = get_truename_buffer (orig_fn);
if (!NILP (subject_buf)
&& NILP (Fverify_visited_file_modtime (subject_buf))
&& !NILP (Ffile_exists_p (fn)))
call1 (intern ("ask-user-about-supersession-threat"), fn);
}
UNGCPRO;
/* Try to lock the lock. */
if (lock_if_free (&lock_info, lfname) <= 0)
/* Return now if we have locked it, or if lock creation failed */
return;
/* Else consider breaking the lock */
locker = (char *) alloca (strlen (lock_info.user) + strlen (lock_info.host)
+ LOCK_PID_MAX + 9);
sprintf (locker, "%s@%s (pid %lu)", lock_info.user, lock_info.host,
lock_info.pid);
FREE_LOCK_INFO (lock_info);
attack = call2 (intern ("ask-user-about-lock"), fn, build_string (locker));
if (!NILP (attack))
/* User says take the lock */
{
lock_file_1 (lfname, 1);
return;
}
/* User says ignore the lock */
}
struct global_state *new_global_state(struct machine_specification *machine)
/* Returns: A new global state for a motlle interpreter for machine
*/
{
struct global_state *gstate;
GCPRO1(machine);
gstate = (struct global_state *)allocate_record(type_vector, 5);
GCPRO1(gstate);
gstate->modules = alloc_table(DEF_TABLE_SIZE);
gstate->mvars = alloc_vector(GLOBAL_SIZE);
gstate->global = alloc_table(GLOBAL_SIZE);
gstate->environment = alloc_env(GLOBAL_SIZE);
gstate->machine = machine;
GCPOP(2);
return gstate;
}
static void pcst(struct oport *f, instruction *i, char *insname)
{
value cst = RINSCST(i);
GCPRO1(cst);
pprintf(f, insname);
GCPOP(1);
_print_value(f, prt_examine, cst, 0);
pprintf(f, "\n");
}
static Lisp_Object
read_file_name (Lisp_Object default_filename, Lisp_Object mustmatch,
Lisp_Object initial, Lisp_Object predicate)
{
struct gcpro gcpro1;
GCPRO1 (default_filename);
RETURN_UNGCPRO (CALLN (Ffuncall, intern ("read-file-name"),
callint_message, Qnil, default_filename,
mustmatch, initial, predicate));
}
static Lisp_Object
build_syscolor_cons (int index1, int index2)
{
Lisp_Object color1, color2;
struct gcpro gcpro1;
GCPRO1 (color1);
color1 = build_syscolor_string (index1);
color2 = build_syscolor_string (index2);
RETURN_UNGCPRO (Fcons (color1, color2));
}
static Lisp_Object
gtk_canonicalize_device_connection (Lisp_Object connection, Error_behavior errb)
{
struct gcpro gcpro1;
GCPRO1 (connection);
connection = build_string("gtk");
RETURN_UNGCPRO (connection);
}
static u16 global_add1(struct global_state *gstate,
struct string *name, mtype type, value val)
{
struct symbol *pos;
ivalue old_size, aindex;
GCCHECK(val);
GCPRO2(gstate, name);
old_size = vector_len(gstate->environment->values);
aindex = env_add_entry(gstate->environment, val);
if (vector_len(gstate->environment->values) != old_size) /* Increase mvars too */
{
uvalue newsize = vector_len(gstate->environment->values);
struct vector *new_mvars, *new_names, *new_types;
new_mvars = alloc_vector(newsize);
GCPRO1(new_mvars);
new_names = alloc_vector(newsize);
GCPRO1(new_names);
new_types = alloc_vector(newsize);
GCPOP(2);
memcpy(new_mvars->data, gstate->mvars->data,
gstate->mvars->o.size - sizeof(struct obj));
gstate->mvars = new_mvars;
memcpy(new_names->data, gstate->names->data,
gstate->names->o.size - sizeof(struct obj));
gstate->names = new_names;
memcpy(new_types->data, gstate->types->data,
gstate->types->o.size - sizeof(struct obj));
gstate->types = new_types;
}
GCPOP(2);
gstate->mvars->data[aindex] = makeint(var_normal);
gstate->names->data[aindex] = name;
gstate->types->data[aindex] = makeint(type);
pos = table_add_fast(gstate->global, name, makeint(aindex));
SET_READONLY(pos); /* index of global vars never changes */
return aindex;
}
struct vector *copy_vector(struct vector *v)
{
struct vector *newp;
uvalue size = vector_len(v);
GCPRO1(v);
newp = alloc_vector(size);
memcpy(newp->data, v->data, size * sizeof(*v->data));
GCPOP(1);
return newp;
}
struct string *copy_string(struct string *s)
{
struct string *newp;
uvalue size = string_len(s);
GCPRO1(s);
newp = alloc_string_n(size);
memcpy(newp->str, s->str, size * sizeof(*s->str));
GCPOP(1);
return newp;
}
/*
* DEV can be either a printer or devmode
*/
static Lisp_Object
print_dialog_worker (Lisp_Object dev, DWORD flags)
{
Lisp_Devmode *ldm = decode_devmode (dev);
PRINTDLGW pd;
memset (&pd, 0, sizeof (pd));
pd.lStructSize = sizeof (pd);
pd.hwndOwner = mswindows_get_selected_frame_hwnd ();
pd.hDevMode = devmode_to_hglobal (ldm);
pd.Flags = flags | PD_USEDEVMODECOPIESANDCOLLATE;
pd.nMinPage = 0;
pd.nMaxPage = 0xFFFF;
if (!qxePrintDlg (&pd))
{
global_free_2_maybe (pd.hDevNames, pd.hDevMode);
return Qnil;
}
handle_devmode_changes (ldm, pd.hDevNames, pd.hDevMode);
/* Finally, build the resulting plist */
{
Lisp_Object result = Qnil;
struct gcpro gcpro1;
GCPRO1 (result);
/* Do consing in reverse order.
Number of copies */
result = Fcons (Qcopies, Fcons (make_fixnum (pd.nCopies), result));
/* Page range */
if (pd.Flags & PD_PAGENUMS)
{
result = Fcons (Qto_page, Fcons (make_fixnum (pd.nToPage), result));
result = Fcons (Qfrom_page, Fcons (make_fixnum (pd.nFromPage), result));
result = Fcons (Qselected_page_button, Fcons (Qpages, result));
}
else if (pd.Flags & PD_SELECTION)
result = Fcons (Qselected_page_button, Fcons (Qselection, result));
else
result = Fcons (Qselected_page_button, Fcons (Qall, result));
/* Device name */
result = Fcons (Qname, Fcons (ldm->printer_name, result));
UNGCPRO;
global_free_2_maybe (pd.hDevNames, pd.hDevMode);
return result;
}
}
static value make_symbol(cstpair p, fncode fn)
{
struct symbol *sym;
struct string *s = alloc_string(p->cst1->u.string);
GCPRO1(s);
SET_IMMUTABLE(s); SET_READONLY(s);
sym = alloc_symbol(s, make_constant(p->cst2, FALSE, fn));
SET_IMMUTABLE(sym); SET_READONLY(sym);
GCPOP(1);
return sym;
}
struct closure *alloc_closure0(struct code *code)
{
struct closure *newp;
GCCHECK(code);
GCPRO1(code);
newp = (struct closure *)allocate_record(type_function, 1);
GCPOP(1);
newp->code = code;
SET_READONLY(newp);
return newp;
}
static value make_symbol(cstpair p)
{
struct symbol *sym;
struct string *s = alloc_string_length(p->cst1->u.string.str,
p->cst1->u.string.len);
GCPRO1(s);
s->o.flags |= OBJ_READONLY | OBJ_IMMUTABLE;
sym = alloc_symbol(s, make_constant(p->cst2));
sym->o.flags |= OBJ_READONLY | OBJ_IMMUTABLE;
UNGCPRO();
return sym;
}
void
eq_worker_work_finished(Lisp_Object job)
{
Lisp_Object wfev = Qnil;
struct gcpro gcpro1;
GCPRO1(wfev);
wfev = make_empty_event();
XEVENT(wfev)->event_type = work_finished_event;
XEVENT(wfev)->event.work_finished.job = job;
eq_enqueue(asyneq, wfev);
UNGCPRO;
return;
}
static value make_table(cstlist csts, fncode fn)
{
struct table *t = alloc_table(DEF_TABLE_SIZE);
GCPRO1(t);
for (; csts; csts = csts->next)
table_set(t, csts->cst->u.constpair->cst1->u.string,
make_constant(csts->cst->u.constpair->cst2, FALSE, fn), NULL);
table_foreach(t, protect_symbol);
SET_READONLY(t);
GCPOP(1);
return t;
}
CC compile_and_run(block_t region,
struct global_state *gstate,
const char *nicename, u8 *noreload,
bool dontrun)
{
struct compile_and_run_frame *frame;
struct compile_context *ccontext;
GCPRO1(gstate);
frame = push_frame(compile_and_run_action, sizeof(struct compile_and_run_frame));
ccontext = (struct compile_context *)allocate_record(type_vector, 2);
frame->dontrun = dontrun;
frame->ps.ccontext = ccontext;
ccontext->gstate = gstate;
/* no evaluation_state yet */
GCPOP(1);
frame->state = init;
if (!region)
region = new_block();
frame->parser_block = region;
/* Set filename */
lexloc.filename = bstrdup(region, nicename);
normal_lexing();
if ((frame->f = parse(frame->parser_block)))
{
if (noreload)
{
if (frame->f->name &&
module_status(frame->ps.ccontext->gstate, frame->f->name) != module_unloaded)
{
free_block(frame->parser_block);
*noreload = TRUE;
FA_POP(&fp, &sp);
return;
}
*noreload = FALSE;
}
if (mprepare(&frame->ps, frame->parser_block, frame->f))
{
frame->state = preparing;
continue_prepare(frame);
return;
}
}
runtime_error(error_compile_error);
}
static void make_global_state(int argc, const char **argv)
{
struct machine_specification *this_machine =
(struct machine_specification *)allocate_record(type_vector, 4);
struct extptr *tms;
GCPRO1(this_machine);
tms = alloc_extptr(&this_machine_specification);
GCPOP(1);
this_machine->c_machine_specification = tms;
globals = new_global_state(this_machine);
staticpro((value *)&globals);
runtime_setup(globals, argc, argv);
}
struct closure *unsafe_alloc_and_push_closure(u8 nb_variables)
{
/* This could (should?) be optimised to avoid the need for
GCPRO1/stack_reserve/GCPOP */
struct closure *newp = (struct closure *)unsafe_allocate_record(type_function, nb_variables + 1);
SET_READONLY(newp);
GCPRO1(newp);
stack_reserve(sizeof(value));
GCPOP(1);
stack_push(newp);
return newp;
}
struct global_state *copy_global_state(struct global_state *gstate)
/* Returns: A copy of global state gstate, which includes copying
global variable and module state
*/
{
struct global_state *newp;
value tmp;
GCPRO1(gstate);
newp = (struct global_state *)allocate_record(type_vector, 8);
GCPRO1(newp);
tmp = copy_table(gstate->modules); newp->modules = tmp;
tmp = copy_vector(gstate->mvars); newp->mvars = tmp;
tmp = copy_vector(gstate->types); newp->types = tmp;
tmp = copy_vector(gstate->names); newp->names = tmp;
tmp = copy_table(gstate->global); newp->global = tmp;
tmp = copy_table(gstate->gsymbols); newp->gsymbols = tmp;
tmp = copy_env(gstate->environment); newp->environment = tmp;
newp->machine = gstate->machine;
GCPOP(2);
return newp;
}
void
eq_worker_eaten_myself(eq_worker_t eqw)
{
Lisp_Object emev = Qnil;
struct gcpro gcpro1;
GCPRO1(emev);
emev = make_empty_event();
XEVENT(emev)->event_type = eaten_myself_event;
XEVENT(emev)->event.eaten_myself.worker = eqw;
eq_enqueue(asyneq, emev);
UNGCPRO;
return;
}
static value make_table(cstlist csts)
{
struct table *t = alloc_table(DEF_TABLE_SIZE);
GCPRO1(t);
for (; csts; csts = csts->next)
table_set_len(t,
csts->cst->u.constpair->cst1->u.string.str,
csts->cst->u.constpair->cst1->u.string.len,
make_constant(csts->cst->u.constpair->cst2));
table_foreach(t, NULL, protect_symbol);
immutable_table(t);
UNGCPRO();
return t;
}
static value make_gsymbol(const char *name, fncode fn)
{
struct table *gsymbols = (fn ? fnglobals(fn) : globals)->gsymbols;
struct symbol *gsym;
if (!table_lookup(gsymbols, name, &gsym))
{
struct string *s;
GCPRO1(gsymbols);
s = alloc_string(name);
SET_READONLY(s);
GCPOP(1);
gsym = table_add_fast(gsymbols, s, makeint(table_entries(gsymbols)));
}
return gsym;
}
u16 global_lookup(struct global_state *gstate, const char *name)
/* Returns: the index for global variable name in environment.
If name doesn't exist yet, it is created with a variable
whose value is NULL.
*/
{
struct symbol *pos;
struct string *tname;
if (table_lookup(gstate->global, name, &pos))
return (u16)intval(pos->data);
GCPRO1(gstate);
tname = alloc_string(name);
GCPOP(1);
return global_add(gstate, tname, NULL);
}
static void write_string(struct oport *p, prt_level level, struct string *print)
{
uvalue l = string_len(print);
if (level == prt_display)
pswrite(p, print, 0, l);
else
{
unsigned char *str = (unsigned char *)alloca(l + 1);
unsigned char *endstr;
memcpy((char *)str, print->str, l + 1);
GCPRO1(p);
/* The NULL byte at the end doesn't count */
endstr = str + l;
pputc('"', p);
while (str < endstr)
{
unsigned char *pos = str;
while (pos < endstr && writable(*pos)) pos++;
opwrite(p, (char *)str, pos - str);
if (pos < endstr) /* We stopped for a \ */
{
pputc('\\', p);
switch (*pos)
{
case '\\': case '"': pputc(*pos, p); break;
case '\n': pputc('n', p); break;
case '\r': pputc('r', p); break;
case '\t': pputc('t', p); break;
case '\f': pputc('f', p); break;
default: pprintf(p, "%o", *pos); break;
}
str = pos + 1;
}
else str = pos;
}
pputc('"', p);
GCPOP(1);
}
}
static void
single_keymap_panes (Lisp_Object keymap, Lisp_Object pane_name,
Lisp_Object prefix, int maxdepth)
{
struct skp skp;
struct gcpro gcpro1;
skp.pending_maps = Qnil;
skp.maxdepth = maxdepth;
skp.notbuttons = 0;
if (maxdepth <= 0)
return;
push_menu_pane (pane_name, prefix);
if (!have_boxes ())
{
/* Remember index for first item in this pane so we can go back
and add a prefix when (if) we see the first button. After
that, notbuttons is set to 0, to mark that we have seen a
button and all non button items need a prefix. */
skp.notbuttons = menu_items_used;
}
GCPRO1 (skp.pending_maps);
map_keymap_canonical (keymap, single_menu_item, Qnil, &skp);
UNGCPRO;
/* Process now any submenus which want to be panes at this level. */
while (CONSP (skp.pending_maps))
{
Lisp_Object elt, eltcdr, string;
elt = XCAR (skp.pending_maps);
eltcdr = XCDR (elt);
string = XCAR (eltcdr);
/* We no longer discard the @ from the beginning of the string here.
Instead, we do this in *menu_show. */
single_keymap_panes (Fcar (elt), string, XCDR (eltcdr), maxdepth - 1);
skp.pending_maps = XCDR (skp.pending_maps);
}
}
static value make_quote(constant c, bool save_location, fncode fn)
{
struct list *l;
value quote;
l = alloc_list(make_constant(c->u.constant, save_location, fn), NULL);
SET_READONLY(l); SET_IMMUTABLE(l);
GCPRO1(l);
quote = make_gsymbol("quote", fn);
l = alloc_list(quote, l);
SET_READONLY(l); SET_IMMUTABLE(l);
if (save_location)
{
value loc = make_location(&c->loc);
l = alloc_list(loc, l);
SET_READONLY(l); SET_IMMUTABLE(l);
}
GCPOP(1);
return l;
}