Example #1
0
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;
}
Example #2
0
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;
}
Example #3
0
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;
}
Example #4
0
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;
}
Example #5
0
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;
}
Example #6
0
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;
}
Example #7
0
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;
}
Example #8
0
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;
    }
}
Example #9
0
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;
}
Example #10
0
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;
}
Example #11
0
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;
}
Example #12
0
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;
}
Example #13
0
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;
}
Example #14
0
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;
}
Example #15
0
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;
}
Example #16
0
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);
}