static int
_report_error(int err,
dident arg1, /* any arity */
dident module, /* arity 0 */
type mod_tag)
{
int res;
pword *old_tg = TG;
pword *tg = TG;
pword mod, goal;
Make_Struct(&goal, TG);
Push_Struct_Frame(d_.syserror); ++tg;
Make_Integer(tg, -err); ++tg;
Make_Struct(tg, TG); ++tg;
tg->val.did = module;
tg++->tag.all = mod_tag.all;
tg->val.did = module;
tg++->tag.all = mod_tag.all;
Push_Struct_Frame(d_.quotient); ++tg;
Make_Atom(tg, add_dict(arg1,0)); ++tg;
Make_Integer(tg, DidArity(arg1));
mod.val.did = d_.kernel_sepia;
mod.tag.kernel = ModuleTag(d_.kernel_sepia);
res = query_emulc(goal.val, goal.tag, mod.val, mod.tag);
TG = old_tg;
return res;
}
static Object P_Read_Bitmap_File (Object d, Object fn) {
Display *dpy;
Drawable dr = Get_Drawable (d, &dpy);
unsigned width, height;
int r, xhot, yhot;
Pixmap bitmap;
Object t, ret, x;
GC_Node2;
Disable_Interrupts;
r = XReadBitmapFile (dpy, dr, Get_Strsym (fn), &width, &height, &bitmap,
&xhot, &yhot);
Enable_Interrupts;
if (r != BitmapSuccess)
return Bits_To_Symbols ((unsigned long)r, 0, Bitmapstatus_Syms);
t = ret = P_Make_List (Make_Integer (5), Null);
GC_Link2 (ret, t);
x = Make_Pixmap (dpy, bitmap);
Car (t) = x;
t = Cdr (t);
Car (t) = Make_Integer (width);
t = Cdr (t);
Car (t) = Make_Integer (height);
t = Cdr (t);
Car (t) = Make_Integer (xhot);
t = Cdr (t);
Car (t) = Make_Integer (yhot);
GC_Unlink;
return ret;
}
static Object P_Query_Pointer (Object win) {
Object l, t, z;
Bool ret;
Window root, child;
int r_x, r_y, x, y;
unsigned int mask;
GC_Node3;
Check_Type (win, T_Window);
ret = XQueryPointer (WINDOW(win)->dpy, WINDOW(win)->win, &root, &child,
&r_x, &r_y, &x, &y, &mask);
t = l = P_Make_List (Make_Integer (8), Null);
GC_Link3 (l, t, win);
Car (t) = Make_Integer (x); t = Cdr (t);
Car (t) = Make_Integer (y); t = Cdr (t);
Car (t) = ret ? True : False; t = Cdr (t);
z = Make_Window (0, WINDOW(win)->dpy, root);
Car (t) = z; t = Cdr (t);
Car (t) = Make_Integer (r_x); t = Cdr (t);
Car (t) = Make_Integer (r_y); t = Cdr (t);
z = Make_Window (0, WINDOW(win)->dpy, child);
Car (t) = z; t = Cdr (t);
z = Bits_To_Symbols ((unsigned long)mask, 1, State_Syms);
Car (t) = z;
GC_Unlink;
return l;
}
int Winapi
ec_handle_events(long int *to_c)
{
int res;
pword * pw;
if (g_emu_.nesting_level > 1)
ec_panic("can't resume nested engine","ec_handle_events()");
if (ec_running())
return PRUNNING;
Make_Nil(&A[1]) /* don't care */
Make_Integer(&A[2], RESUME_SIMPLE);
res = restart_emulc();
if (res != PYIELD)
ec_panic("eclipse emulator did not yield properly","ec_handle_events()");
pw = &A[2];
Dereference_(pw)
if (IsInteger(pw->tag))
*to_c = pw->val.nint;
else
*to_c = 0;
pw = &A[1];
Dereference_(pw)
if (IsInteger(pw->tag))
return pw->val.nint;
else
return TYPE_ERROR;
}
int Winapi
ec_resume_async(void)
{
if (g_emu_.nesting_level > 1)
ec_panic("can't resume nested engine","ec_resume2()");
#ifdef _WIN32
if (!resume_thread) /* if we don't have a thread yet, make one */
{
resume_thread = ec_make_thread();
if (!resume_thread)
return SYS_ERROR;
}
else /* make sure the thread is not running */
{
if (ec_running())
return PRUNNING;
}
#endif
A[1] = _get_posted_goals();
Make_Integer(&A[2], RESUME_CONT);
#ifdef _WIN32
if (!ec_start_thread(resume_thread, restart_emulc_thread, NULL))
return SYS_ERROR;
#endif
return PSUCCEED;
}
int Winapi
ec_resume_long(long int *to_c)
{
int res;
pword * pw;
if (g_emu_.nesting_level > 1)
ec_panic("can't resume nested engine","ec_resume_long()");
if (ec_running())
return PRUNNING;
A[1] = _get_posted_goals();
Make_Integer(&A[2], RESUME_CONT);
res = restart_emulc();
if (res != PYIELD)
ec_panic("eclipse emulator did not yield properly","ec_resume_long()");
pw = &A[2];
Dereference_(pw)
if (IsInteger(pw->tag))
*to_c = pw->val.nint;
else
*to_c = 0;
pw = &A[1];
Dereference_(pw)
if (IsInteger(pw->tag))
return pw->val.nint;
else
return TYPE_ERROR;
}
int Winapi
ec_resume2(const pword term, ec_ref chp)
{
int res;
pword * pw;
pword tterm;
/* this assignment is needed to get around a compiler bug on Alpha Linux
that otherwise corrupts chp
*/
tterm = term;
if (g_emu_.nesting_level > 1)
ec_panic("can't resume nested engine","ec_resume2()");
if (ec_running())
return PRUNNING;
A[1] = tterm;
Make_Integer(&A[2], RESUME_CONT);
res = restart_emulc();
if (res != PYIELD)
ec_panic("eclipse emulator did not yield properly","ec_resume()");
if (chp)
ec_ref_set(chp,A[2]);
pw = &A[1];
Dereference_(pw)
if (IsInteger(pw->tag))
return pw->val.nint;
else
return TYPE_ERROR;
}
void Action_Hook (Widget w, XtPointer client_data, char *name, XEvent *ep,
char **argv, int *argc) {
ACTION *ap;
Object args, params, tail;
register int i;
GC_Node3;
for (ap = actions; ap; ap = ap->next) {
if (strcmp (ap->name, name))
continue;
args = params = tail = Null;
GC_Link3 (args, params, tail);
params = P_Make_List (Make_Integer (*argc), Null);
for (i = 0, tail = params; i < *argc; tail = Cdr (tail), i++) {
Object tmp;
tmp = Make_String (argv[i], strlen (argv[i]));
Car (tail) = tmp;
}
args = Cons (params, Null);
params = Get_Event_Args (ep);
args = Cons (Copy_List (params), args);
Destroy_Event_Args (params);
args = Cons (Make_Widget_Foreign (w), args);
(void)Funcall (Get_Function (ap->num), args, 0);
GC_Unlink;
}
}
static Object P_Query_Extension (Object d, Object name) {
int opcode, event, error;
Object ret, t;
GC_Node2;
Check_Type (d, T_Display);
if (!XQueryExtension (DISPLAY(d)->dpy, Get_Strsym (name), &opcode,
&event, &error))
return False;
t = ret = P_Make_List (Make_Integer (3), Null);
GC_Link2 (ret, t);
Car (t) = (opcode ? Make_Integer (opcode) : False); t = Cdr (t);
Car (t) = (event ? Make_Integer (event) : False); t = Cdr (t);
Car (t) = (error ? Make_Integer (error) : False);
GC_Unlink;
return ret;
}
Object P_Collect () {
register char *tmp;
register int msg = 0;
Object a[2];
if (!Interpreter_Initialized)
Fatal_Error ("heap too small (increase heap size)");
if (GC_In_Progress)
Fatal_Error ("GC while GC in progress");
Disable_Interrupts;
GC_In_Progress = 1;
Call_Before_GC ();
if (GC_Debug) {
printf ("."); (void)fflush (stdout);
} else if (Var_Is_True (V_Garbage_Collect_Notifyp)) {
msg++;
Format (Standard_Output_Port, "[Garbage collecting... ", 23, 0,
(Object *)0);
(void)fflush (stdout);
}
To = Free_Start;
Visit_GC_List (Global_GC_Obj, 0);
Visit_GC_List (GC_List, 0);
Visit_Wind (First_Wind, 0);
Hp = To;
tmp = Heap_Start; Heap_Start = Free_Start; Free_Start = tmp;
tmp = Heap_End; Heap_End = Free_End; Free_End = tmp;
if (!GC_Debug) {
if (msg) {
a[0] = Make_Integer ((Hp-Heap_Start) / 1024);
a[1] = Make_Integer ((Heap_End-Heap_Start) / 1024);
Format (Standard_Output_Port, "~sK of ~sK]~%", 13, 2, a);
}
}
Call_After_GC ();
GC_In_Progress = 0;
Enable_Interrupts;
return Void;
}
static Object P_Translate_Coordinates (Object src, Object x, Object y,
Object dst) {
int rx, ry;
Window child;
Object l, t, z;
GC_Node3;
Check_Type (src, T_Window);
Check_Type (dst, T_Window);
if (!XTranslateCoordinates (WINDOW(src)->dpy, WINDOW(src)->win,
WINDOW(dst)->win, Get_Integer (x), Get_Integer (y), &rx, &ry,
&child))
return False;
l = t = P_Make_List (Make_Integer (3), Null);
GC_Link3 (l, t, dst);
Car (t) = Make_Integer (rx); t = Cdr (t);
Car (t) = Make_Integer (ry), t = Cdr (t);
z = Make_Window (0, WINDOW(dst)->dpy, child);
Car (t) = z;
GC_Unlink;
return l;
}
char *Safe_Realloc (char *ptr, unsigned int size) {
char *ret;
Disable_Interrupts;
if ((ret = ptr ? realloc (ptr, size) : malloc (size)) == 0) {
if (Interpreter_Initialized)
Primitive_Error ("not enough memory to malloc ~s bytes",
Make_Integer (size));
else
Fatal_Error ("not enough memory to malloc %u bytes", size);
}
Enable_Interrupts;
return ret;
}
Object P_Command_Line_Args () {
Object ret, tail;
register int i;
GC_Node2;
ret = tail = P_Make_List (Make_Integer (Argc-First_Arg), Null);
GC_Link2 (ret, tail);
for (i = First_Arg; i < Argc; i++, tail = Cdr (tail)) {
Object a;
a = Make_String (Argv[i], strlen (Argv[i]));
Car (tail) = a;
}
GC_Unlink;
return ret;
}
int
ec_load_eco_from_stream(stream_id nst, int options, pword *module)
{
int res;
pword *clause, *query, *pw;
pword query_pw, kernel_pw;
pword top_module = *module;
int encoded = 0;
/* we are expecting an eco-encoded file, but we allow text as well */
res = _read_eco_header(nst);
encoded = (res == PSUCCEED);
StreamMode(nst) |= SNOMACROEXP; /* to avoid problems in text-eco files */
kernel_pw.val.did = d_.kernel_sepia;
kernel_pw.tag.kernel = ModuleTag(d_.kernel_sepia);
for(;;)
{
int recreate_module = 0;
pword exports_pw, language_pw;
pword *new_module = 0;
if (encoded) /* encoded dbformat */
{
int n;
word nread;
char *s = ec_getstring(nst, 4, &nread);
if (!(s))
return nread; /* error code */
if (nread < 4)
return (nread == 0) ? PSUCCEED : UNEXPECTED_EOF;
n = (unsigned char) *s++ << 24;
n |= (unsigned char) *s++ << 16;
n |= (unsigned char) *s++ << 8;
n |= (unsigned char) *s;
s = ec_getstring(nst, n, &nread);
if (!(s))
return nread; /* error code */
if (nread < n)
return UNEXPECTED_EOF;
clause = dbformat_to_term(s, module->val.did, module->tag);
if (!clause)
return NOT_DUMP_FILE;
}
else /* text format, call the parser */
{
res = ec_read_term(nst,
(GlobalFlags & VARIABLE_NAMES ? VARNAMES_PLEASE : 0),
&query_pw, 0, 0, module->val, module->tag);
if (res != PSUCCEED)
return (res == PEOF) ? PSUCCEED : NOT_DUMP_FILE;
clause = &query_pw;
}
Dereference_(clause);
if (!IsStructure(clause->tag) || !Query(clause->val.ptr->val.did))
return NOT_DUMP_FILE;
pw = query = clause->val.ptr + 1;
Dereference_(pw);
if (IsStructure(pw->tag)) /* look for special directives */
{
if (pw->val.ptr->val.did == d_.module1)
{
recreate_module = 1;
new_module = &pw->val.ptr[1];
Make_Nil(&exports_pw);
Make_Atom(&language_pw, d_eclipse_language_);
}
if (pw->val.ptr->val.did == d_module_interface)
{
recreate_module = 1;
new_module = &pw->val.ptr[1];
Make_Nil(&exports_pw);
Make_Atom(&language_pw, d_eclipse_language_);
}
else if (pw->val.ptr->val.did == d_module2)
{
recreate_module = 1;
new_module = &pw->val.ptr[1];
exports_pw = pw->val.ptr[2];
Make_Atom(&language_pw, d_eclipse_language_);
}
else if (pw->val.ptr->val.did == d_module3)
{
recreate_module = 1;
new_module = &pw->val.ptr[1];
exports_pw = pw->val.ptr[2];
language_pw = pw->val.ptr[3];
}
else if (pw->val.ptr->val.did == d_begin_module)
{
new_module = &pw->val.ptr[1];
query = &query_pw; /* don't execute anything */
Make_Atom(query, d_.true0);
}
else if (pw->val.ptr->val.did == d_.pragma)
{
query = &query_pw; /* ignore pragmas, replace with true */
Make_Atom(query, d_.true0);
}
}
else if (pw->val.did == d_.system || pw->val.did == d_.system_debug)
{
query = &query_pw; /* ignore pragmas, replace with true */
Make_Atom(query, d_.true0);
}
if (recreate_module) /* build translated module query */
{
pword *pgoal, *pcont;
query = &query_pw;
Make_Struct(query, TG);
/* If module changes, raise CODE_UNIT_LOADED event first */
if (module->val.did != top_module.val.did)
{
pcont = TG;
Push_Struct_Frame(d_.comma);
Make_Struct(&pcont[1], TG);
pgoal = TG;
Push_Struct_Frame(d_.syserror);
Make_Integer(&pgoal[1], CODE_UNIT_LOADED);
Make_Atom(&pgoal[2], d_.eof);
pgoal[3] = *module;
pgoal[4] = *module;
Make_Struct(&pcont[2], TG);
}
pcont = TG;
Push_Struct_Frame(d_.comma);
Make_Struct(&pcont[1], TG);
pgoal = TG;
Push_Struct_Frame(d_erase_module_);
pgoal[1] = *new_module;
Make_Struct(&pcont[2], TG);
pgoal = TG;
Push_Struct_Frame(d_create_module3_);
pgoal[1] = *new_module;
pgoal[2] = exports_pw;
pgoal[3] = language_pw;
res = query_emulc(query->val, query->tag, kernel_pw.val, kernel_pw.tag);
}
else
{
/* execute the query/directive */
res = query_emulc(query->val, query->tag, module->val, module->tag);
}
if (res != PSUCCEED)
{
pw = TG;
Push_Struct_Frame(d_.syserror);
Make_Integer(&pw[1], QUERY_FAILED);
pw[2] = *query;
pw[3] = *module;
pw[4] = *module;
query = &query_pw;
Make_Struct(query, pw);
(void) query_emulc(query->val, query->tag, kernel_pw.val, kernel_pw.tag);
}
if (new_module) /* change to new context module */
{
Dereference_(new_module);
*module = *new_module;
}
}
return PSUCCEED;
}
static Object General_Wait(Object ret, Object ruret,
int haspid, int pid, int options) {
#ifndef WIN32
int retpid, st, code;
char *status;
#ifdef WAIT_RUSAGE
struct rusage ru;
Object sec;
#endif
Object x;
GC_Node3;
x = Null;
Check_Result_Vector(ret, 5);
Check_Result_Vector(ruret, 2);
if (haspid) {
#ifdef HAVE_WAIT4
retpid = wait4(pid, &st, options, &ru);
#else
#ifdef HAVE_WAITPID
retpid = waitpid(pid, &st, options);
#endif
#endif
} else {
#ifdef HAVE_WAIT3
retpid = wait3(&st, options, &ru);
#else
retpid = wait(&st);
#endif
}
if (retpid == -1 && errno != ECHILD)
Raise_System_Error("~E");
GC_Link3(ret, ruret, x);
x = Make_Integer(retpid); VECTOR(ret)->data[0] = x;
if (retpid == 0 || retpid == -1) {
status = "none";
st = code = 0;
#ifdef WAIT_RUSAGE
memset((char *)&ru, 0, sizeof(ru));
#endif
} else if (WIFSTOPPED(st)) {
status = "stopped"; code = WSTOPSIG(st);
} else if (WIFSIGNALED(st)) {
status = "signaled"; code = WTERMSIG(st);
} else {
status = "exited"; code = WEXITSTATUS(st);
}
x = Intern(status); VECTOR(ret)->data[1] = x;
x = Make_Integer(code); VECTOR(ret)->data[2] = x;
VECTOR(ret)->data[3] = st & 0200 ? True : False;
#ifdef WAIT_RUSAGE
x = Cons(Null, Make_Unsigned_Long((unsigned long)ru.ru_utime.tv_usec
* 1000));
sec = Make_Unsigned_Long((unsigned long)ru.ru_utime.tv_sec);
Car(x) = sec;
VECTOR(ruret)->data[0] = x;
x = Cons(Null, Make_Unsigned_Long((unsigned long)ru.ru_stime.tv_usec
* 1000));
sec = Make_Unsigned_Long((unsigned long)ru.ru_stime.tv_sec);
Car(x) = sec;
VECTOR(ruret)->data[1] = x;
#endif
GC_Unlink;
#endif
return Void;
}
Object Parse_Number (Object port, char const *buf, int radix) {
char const *p;
int c, i;
int mdigit = 0, edigit = 0, expo = 0, neg = 0, point = 0;
int gotradix = 0, exact = 0, inexact = 0;
unsigned int max;
int maxdig;
Object ret;
for ( ; *buf == '#'; buf++) {
switch (*++buf) {
case 'b': case 'B':
if (gotradix++) return Null;
radix = 2;
break;
case 'o': case 'O':
if (gotradix++) return Null;
radix = 8;
break;
case 'd': case 'D':
if (gotradix++) return Null;
radix = 10;
break;
case 'x': case 'X':
if (gotradix++) return Null;
radix = 16;
break;
case 'e': case 'E':
if (exact++ || inexact) return Null;
break;
case 'i': case 'I':
if (inexact++ || exact) return Null;
break;
default:
return Null;
}
}
p = buf;
if (*p == '+' || (neg = *p == '-'))
p++;
for ( ; (c = *p); p++) {
if (c == '.') {
if (expo || point++)
return Null;
} else if (radix != 16 && (c == 'e' || c == 'E')) {
if (expo++)
return Null;
if (p[1] == '+' || p[1] == '-')
p++;
#ifdef HAVE_INDEX
} else if (radix == 16 && !index ("0123456789abcdefABCDEF", c)) {
#else
} else if (radix == 16 && !strchr ("0123456789abcdefABCDEF", c)) {
#endif
return Null;
} else if (radix < 16 && (c < '0' || c > '0' + radix-1)) {
return Null;
} else {
if (expo) edigit++; else mdigit++;
}
}
if (!mdigit || (expo && !edigit))
return Null;
if (point || expo) {
if (radix != 10) {
if (Nullp (port))
return Null;
Reader_Error (port, "reals must be given in decimal");
}
/* Lacking ratnums, there's nothing we can do if #e has been
* specified-- just return the inexact number.
*/
return Make_Flonum (atof (buf));
}
max = (neg ? -(unsigned int)INT_MIN : INT_MAX);
maxdig = max % radix;
max /= radix;
for (i = 0, p = buf; (c = *p); p++) {
if (c == '-' || c == '+') {
buf++;
continue;
}
if (radix == 16) {
if (isupper (c))
c = tolower (c);
if (c >= 'a')
c = '9' + c - 'a' + 1;
}
c -= '0';
if ((unsigned int)i > max || ((unsigned int)i == max && c > maxdig)) {
ret = Make_Bignum (buf, neg, radix);
return inexact ? Make_Flonum (Bignum_To_Double (ret)) : ret;
}
i *= radix; i += c;
}
if (neg)
i = -i;
return inexact ? Make_Flonum ((double)i) : Make_Integer (i);
}