static void setvar(tnk_t tnk, Tobj vo)
{
switch (tnk.type) {
case TNK_LI:
Mresetmark(lvarp[flvari + tnk.u.li].m,
(lvarp[flvari + tnk.u.li].o = vo));
break;
case TNK_O:
Tinso(tnk.u.tnko.to, tnk.u.tnko.ko, vo);
break;
default:
switch (tnk.u.tnks.kt) {
case C_STRING:
Tinss(tnk.u.tnks.to,
TCgetstring(tnk.u.tnks.co, tnk.u.tnks.vi), vo);
break;
case C_INTEGER:
Tinsi(tnk.u.tnks.to,
TCgetinteger(tnk.u.tnks.co, tnk.u.tnks.vi), vo);
break;
case C_REAL:
Tinsr(tnk.u.tnks.to, TCgetreal(tnk.u.tnks.co, tnk.u.tnks.vi),
vo);
break;
}
break;
}
}
/* shortcut: this function executes a piece of code that corresponds to
<internal func name> = function () internal "<internal func name>";
*/
Tobj Efunction(Tobj co, char *ifnam)
{
Tobj v1o;
int fi;
fi = TCgetnext(co, TCgetfp(co, TCgetfp(co, 0)));
v1o = Tcode(TCgetaddr(co, fi), fi,
(int) TCgetinteger(co, TCgetfp(co, fi)));
Tinss(root, ifnam, v1o);
return v1o;
}
static Tobj getval(Tobj co, int ci)
{
Tobj cvo, cko, cto;
Ctype_t ct, vt;
int vi, ni, nn;
if ((ct = TCgettype(co, ci)) == C_LVAR) {
nn = (int) TCgetinteger(co, (ni = TCgetnext(co, TCgetfp(co, ci))));
cto = cvo = lvarp[flvari + nn].o;
if (!cto)
return NULL;
vi = TCgetnext(co, ni);
} else if (ct == C_GVAR) {
cto = root;
vi = TCgetfp(co, ci);
} else if (ct == C_PVAR)
return TCgetobject(co, ci);
else
return NULL;
while (vi != C_NULL) {
if (Tgettype(cto) != T_TABLE)
return NULL;
if ((vt = TCgettype(co, vi)) == C_STRING) {
if (!(cvo = Tfinds(cto, TCgetstring(co, vi))))
return NULL;
} else if (vt == C_INTEGER) {
if (!(cvo = Tfindi(cto, TCgetinteger(co, vi))))
return NULL;
} else if (vt == C_REAL) {
if (!(cvo = Tfindr(cto, TCgetreal(co, vi))))
return NULL;
} else {
if (!(cko = eeval(co, vi)) || !(cvo = Tfindo(cto, cko)))
return NULL;
}
cto = cvo;
vi = TCgetnext(co, vi);
}
return cvo;
}
static int getvar(Tobj co, int ci, tnk_t * tnkp)
{
Tobj cvo, cko, cto;
Ctype_t ct, vt;
long m;
int vi, ovi, nn, ni;
if ((ct = TCgettype(co, ci)) == C_LVAR) {
nn = (int) TCgetinteger(co, (ni = TCgetnext(co, TCgetfp(co, ci))));
cvo = cto = lvarp[flvari + nn].o;
vi = TCgetnext(co, ni);
if (vi != C_NULL && (!cvo || Tgettype(cvo) != T_TABLE))
Mresetmark(lvarp[flvari + nn].m,
(lvarp[flvari + nn].o = cvo = cto = Ttable(0)));
} else if (ct == C_GVAR) { /* else it's a global variable */
cvo = root;
vi = TCgetfp(co, ci);
} else {
return -1;
}
ovi = -1;
while (vi != C_NULL) {
cto = cvo;
if ((vt = TCgettype(co, vi)) == C_STRING) {
cvo = Tfinds(cto, TCgetstring(co, vi));
} else if (vt == C_INTEGER) {
cvo = Tfindi(cto, TCgetinteger(co, vi));
} else if (vt == C_REAL) {
cvo = Tfindr(cto, TCgetreal(co, vi));
} else {
if (!(cko = eeval(co, vi)) || !(T_ISSTRING(cko) ||
T_ISNUMBER(cko)))
return -1;
cvo = Tfindo(cto, cko);
}
ovi = vi, vi = TCgetnext(co, vi);
if (vi != C_NULL && (!cvo || Tgettype(cvo) != T_TABLE)) {
if (vt == C_STRING)
Tinss(cto, TCgetstring(co, ovi), (cvo = Ttable(0)));
else if (vt == C_INTEGER)
Tinsi(cto, TCgetinteger(co, ovi), (cvo = Ttable(0)));
else if (vt == C_REAL)
Tinsr(cto, TCgetreal(co, ovi), (cvo = Ttable(0)));
else
m = Mpushmark(cko), Tinso(cto, cko, (cvo = Ttable(0))),
Mpopmark(m);
}
}
if (ct == C_LVAR && ovi == -1) {
tnkp->type = TNK_LI;
tnkp->u.li = nn;
} else {
switch (vt) {
case C_STRING:
case C_INTEGER:
case C_REAL:
tnkp->type = TNK_S;
tnkp->u.tnks.kt = vt;
tnkp->u.tnks.to = cto;
tnkp->u.tnks.co = co;
tnkp->u.tnks.vi = ovi;
break;
default:
tnkp->type = TNK_O;
tnkp->u.tnko.to = cto;
tnkp->u.tnko.ko = cko;
break;
}
}
return 0;
}
static Tobj efcall(Tobj co, int ci)
{
volatile jmp_buf *opljbufp1, *opljbufp2;
volatile long m;
volatile int bi, ownsinfoi, li, ln;
jmp_buf pljbuf;
Tobj fdo, vo, lrtno;
int i, fci, ai, di, di1, fid;
ownsinfoi = sinfoi++;
if (sinfoi == sinfon) {
sinfop =
Marraygrow(sinfop, (long) (sinfon + SINFOINCR) * SINFOSIZE);
sinfon += SINFOINCR;
}
sinfop[ownsinfoi].co = co;
sinfop[ownsinfoi].ci = ci;
sinfop[ownsinfoi].fco = NULL;
sinfop[ownsinfoi].flvari = flvari;
sinfop[ownsinfoi].llvari = llvari;
fci = TCgetfp(co, ci);
if (!(fdo = getval(co, fci)) || Tgettype(fdo) != T_CODE) {
err(ERRNOSUCHFUNC, ERR2, co, fci);
sinfoi = ownsinfoi;
return NULL;
}
m = Mpushmark((Tobj) fdo);
ai = TCgetfp(co, TCgetnext(co, fci));
ln = (int) TCgetinteger(fdo, (li = TCgetnext(fdo, TCgetfp(fdo, 0))));
di = TCgetnext(fdo, li);
bi = TCgetnext(fdo, di);
if (bi != C_NULL && TCgettype(fdo, bi) == C_INTERNAL) {
for (i = 0; ai != C_NULL; ai = TCgetnext(co, ai), i++) {
if (!(vo = eeval(co, ai))) {
err(ERRBADARG, ERR2, co, ai);
Mpopmark(m);
llvari = sinfop[ownsinfoi].llvari;
sinfoi = ownsinfoi;
return NULL;
}
if (llvari + 1 > lvarn) {
lvarp = Marraygrow(lvarp, (long) (llvari + 1) * LVARSIZE);
lvarn = llvari + 1;
}
lvarp[llvari].m = Mpushmark((lvarp[llvari].o = vo));
llvari++;
}
fid = (int) TCgetinteger(fdo, TCgetfp(fdo, bi));
if (Ifuncs[fid].min > i || Ifuncs[fid].max < i) {
err(ERRARGMIS, ERR2, co, ci);
Mpopmark(m);
llvari = sinfop[ownsinfoi].llvari;
sinfoi = ownsinfoi;
return NULL;
}
flvari = sinfop[ownsinfoi].llvari;
sinfop[ownsinfoi].fco = fdo;
sinfop[ownsinfoi].fci = bi;
if (fid < 0 || fid >= Ifuncn)
panic1(POS, "efcall", "no such internal function: %d", fid);
rtno = Ttrue;
if ((*Ifuncs[fid].func) (i, &lvarp[flvari]) == L_FAILURE) {
rtno = NULL;
err(ERRIFUNCERR, ERR2, co, ci);
}
} else {
if (llvari + ln > lvarn) {
lvarp = Marraygrow(lvarp, (long) (llvari + ln) * LVARSIZE);
lvarn = llvari + ln;
}
di1 = TCgetfp(fdo, di);
for (i = 0; i < ln && di1 != C_NULL && ai != C_NULL;
i++, ai = TCgetnext(co, ai)) {
if (!(vo = eeval(co, ai))) {
err(ERRBADARG, ERR2, co, ai);
Mpopmark(m);
llvari = sinfop[ownsinfoi].llvari;
sinfoi = ownsinfoi;
return NULL;
}
lvarp[llvari].m = Mpushmark((lvarp[llvari].o = vo));
llvari++;
di1 = TCgetnext(fdo, di1);
}
if (di1 != C_NULL || ai != C_NULL) {
err(ERRARGMIS, ERR2, co, ci);
Mpopmark(m);
llvari = sinfop[ownsinfoi].llvari;
sinfoi = ownsinfoi;
return NULL;
}
for (; i < ln; i++, llvari++)
lvarp[llvari].m = Mpushmark((lvarp[llvari].o = NULL));
flvari = sinfop[ownsinfoi].llvari;
PUSHJMP(opljbufp2, pljbufp2, pljbuf);
opljbufp1 = (volatile jmp_buf *) pljbufp1;
if (setjmp(*pljbufp2)) {
;
} else {
sinfop[ownsinfoi].fco = fdo;
for (; bi != C_NULL; bi = TCgetnext(fdo, bi)) {
sinfop[ownsinfoi].fci = bi;
if (TCgettype(fdo, bi) != C_DECL)
eeval((Tobj) fdo, bi);
}
}
POPJMP(opljbufp2, pljbufp2);
pljbufp1 = (jmp_buf *) opljbufp1;
}
flvari = sinfop[ownsinfoi].flvari;
llvari = sinfop[ownsinfoi].llvari;
sinfoi = ownsinfoi;
Mpopmark(m);
lrtno = rtno, rtno = NULL;
errdo = TRUE;
return lrtno;
}
static Tobj eeval(Tobj co, int ci)
{
Tobj v1o, v2o, v3o;
Ttype_t ttype;
Ctype_t ctype;
tnk_t tnk;
num_tt lnum, rnum;
long m1, m2;
int i1, i2, res;
tailrec:
errdo = TRUE;
v1o = NULL;
ctype = TCgettype(co, ci);
switch (ctype) {
case C_ASSIGN:
i1 = TCgetfp(co, ci);
if ((v1o = eeval(co, TCgetnext(co, i1))) == NULL) {
err(ERRNORHS, ERR4, co, TCgetnext(co, i1));
return NULL;
}
m1 = Mpushmark(v1o);
res = getvar(co, i1, &tnk);
Mpopmark(m1);
if (res == -1) {
err(ERRNOLHS, ERR3, co, i1);
return NULL;
}
setvar(tnk, v1o);
return v1o;
case C_OR:
case C_AND:
case C_NOT:
i1 = TCgetfp(co, ci);
if ((v1o = eeval(co, i1)) == NULL)
err(ERRNORHS, ERR4, co, i1);
switch (ctype) {
case C_OR:
if (boolop(v1o) == TRUE)
return Ttrue;
if ((v1o = eeval(co, TCgetnext(co, i1))) == NULL)
err(ERRNORHS, ERR4, co, TCgetnext(co, i1));
return (boolop(v1o) == TRUE) ? Ttrue : Tfalse;
case C_AND:
if (boolop(v1o) == FALSE)
return Tfalse;
if ((v1o = eeval(co, TCgetnext(co, i1))) == NULL)
err(ERRNORHS, ERR4, co, TCgetnext(co, i1));
return (boolop(v1o) == FALSE) ? Tfalse : Ttrue;
case C_NOT:
return (boolop(v1o) == TRUE) ? Tfalse : Ttrue;
}
/* NOT REACHED */
return Tfalse;
case C_EQ:
case C_NE:
case C_LT:
case C_LE:
case C_GT:
case C_GE:
i1 = TCgetfp(co, ci);
if ((v1o = eeval(co, i1)) == NULL)
err(ERRNORHS, ERR4, co, i1);
else
m1 = Mpushmark(v1o);
if ((v2o = eeval(co, TCgetnext(co, i1))) == NULL)
err(ERRNORHS, ERR4, co, TCgetnext(co, i1));
if (v1o)
Mpopmark(m1);
return (orderop(v1o, ctype, v2o) == TRUE) ? Ttrue : Tfalse;
case C_PLUS:
case C_MINUS:
case C_MUL:
case C_DIV:
case C_MOD:
case C_UMINUS:
i1 = TCgetfp(co, ci);
if ((lnum.type = TCgettype(co, i1)) == C_INTEGER)
lnum.u.i = TCgetinteger(co, i1);
else if (lnum.type == C_REAL)
lnum.u.d = TCgetreal(co, i1);
else if ((lnum.u.no = eeval(co, i1)) == NULL) {
err(ERRNORHS, ERR4, co, i1);
return NULL;
}
if (ctype == C_UMINUS) {
if (!(v1o = arithop(&lnum, ctype, NULL)))
err(ERRNORHS, ERR4, co, ci);
return v1o;
}
if (lnum.type != C_INTEGER && lnum.type != C_REAL)
m1 = Mpushmark(lnum.u.no);
i1 = TCgetnext(co, i1);
if ((rnum.type = TCgettype(co, i1)) == C_INTEGER)
rnum.u.i = TCgetinteger(co, i1);
else if (rnum.type == C_REAL)
rnum.u.d = TCgetreal(co, i1);
else if ((rnum.u.no = eeval(co, i1)) == NULL)
err(ERRNORHS, ERR4, co, i1);
if (lnum.type != C_INTEGER && lnum.type != C_REAL)
Mpopmark(m1);
if (!(v1o = arithop(&lnum, ctype, &rnum)))
err(ERRNORHS, ERR4, co, ci);
return v1o;
case C_PEXPR:
ci = TCgetfp(co, ci);
goto tailrec;
case C_FCALL:
return efcall(co, ci);
case C_INTEGER:
return Tinteger(TCgetinteger(co, ci));
case C_REAL:
return Treal(TCgetreal(co, ci));
case C_STRING:
return Tstring(TCgetstring(co, ci));
case C_GVAR:
case C_LVAR:
case C_PVAR:
return getval(co, ci);
case C_FUNCTION:
return Tcode(TCgetaddr(co, ci), ci,
(int) TCgetinteger(co, TCgetfp(co, ci)));
case C_TCONS:
v1o = Ttable(0);
m1 = Mpushmark(v1o);
for (i1 = TCgetfp(co, ci); i1 != C_NULL;
i1 = TCgetnext(co, TCgetnext(co, i1))) {
if (!(v3o = eeval(co, TCgetnext(co, i1)))) {
err(ERRNORHS, ERR4, co, TCgetnext(co, i1));
continue;
}
m2 = Mpushmark(v3o);
if (!(v2o = eeval(co, i1))) {
err(ERRNOLHS, ERR3, co, i1);
Mpopmark(m2);
continue;
}
ttype = Tgettype(v2o);
if (ttype == T_INTEGER || ttype == T_REAL || ttype == T_STRING)
Tinso(v1o, v2o, v3o);
else
err(ERRNOLHS, ERR1, co, i1);
}
Mpopmark(m1);
return v1o;
case C_STMT:
for (i1 = TCgetfp(co, ci); i1 != C_NULL;)
if ((i2 = TCgetnext(co, i1)) != C_NULL) {
eeval(co, i1);
i1 = i2;
} else {
ci = i1;
goto tailrec;
}
/* NOT REACHED */
break;
case C_IF:
i1 = TCgetfp(co, ci);
if (!(v1o = eeval(co, i1)))
err(ERRNORHS, ERR5, co, i1);
if (boolop(v1o) == TRUE) {
ci = TCgetnext(co, i1);
goto tailrec;
} else if ((ci = TCgetnext(co, TCgetnext(co, i1))) != C_NULL)
goto tailrec;
break;
case C_WHILE:
ewhilest(co, ci);
break;
case C_FOR:
eforst(co, ci);
break;
case C_FORIN:
eforinst(co, ci);
break;
case C_BREAK:
pljtype = PLJ_BREAK;
longjmp(*pljbufp1, 1);
/* NOT REACHED */
break;
case C_CONTINUE:
pljtype = PLJ_CONTINUE;
longjmp(*pljbufp1, 1);
/* NOT REACHED */
break;
case C_RETURN:
if ((i1 = TCgetfp(co, ci)) != C_NULL)
rtno = eeval(co, i1);
pljtype = PLJ_RETURN;
longjmp(*pljbufp2, 1);
/* NOT REACHED */
break;
default:
panic1(POS, "eeval", "unknown program token type %d", ctype);
}
return v1o;
}
static void codestr (Tobj co, int ci) {
int ct, ct1;
int ci1, ci2;
if (highci == ci)
appends (" >> ");
switch ((ct = TCgettype (co, ci))) {
case C_ASSIGN:
codestr (co, (ci1 = TCgetfp (co, ci)));
appends (" = ");
codestr (co, TCgetnext (co, ci1));
break;
case C_OR:
case C_AND:
case C_EQ:
case C_NE:
case C_LT:
case C_LE:
case C_GT:
case C_GE:
case C_PLUS:
case C_MINUS:
case C_MUL:
case C_DIV:
case C_MOD:
codestr (co, (ci1 = TCgetfp (co, ci)));
switch (ct) {
case C_OR: appends (" | "); break;
case C_AND: appends (" & "); break;
case C_EQ: appends (" == "); break;
case C_NE: appends (" ~= "); break;
case C_LT: appends (" < "); break;
case C_LE: appends (" <= "); break;
case C_GT: appends (" > "); break;
case C_GE: appends (" >= "); break;
case C_PLUS: appends (" + "); break;
case C_MINUS: appends (" - "); break;
case C_MUL: appends (" * "); break;
case C_DIV: appends (" / "); break;
case C_MOD: appends (" % "); break;
}
codestr (co, TCgetnext (co, ci1));
break;
case C_NOT:
appends ("~");
codestr (co, TCgetfp (co, ci));
break;
case C_UMINUS:
appends ("-");
codestr (co, TCgetfp (co, ci));
break;
case C_PEXPR:
appends ("(");
codestr (co, TCgetfp (co, ci));
appends (")");
break;
case C_FCALL:
codestr (co, (ci1 = TCgetfp (co, ci)));
appends (" (");
codestr (co, TCgetnext (co, ci1));
appends (")");
break;
case C_INTEGER:
appendi (TCgetinteger (co, ci));
break;
case C_REAL:
appendd (TCgetreal (co, ci));
break;
case C_STRING:
appends ("\""), appends (TCgetstring (co, ci)), appends ("\"");
break;
case C_GVAR:
case C_LVAR:
ci1 = TCgetfp (co, ci);
appends (TCgetstring (co, ci1));
if (ct == C_LVAR)
ci1 = TCgetnext (co, ci1);
for (
ci1 = TCgetnext (co, ci1); ci1 != C_NULL;
ci1 = TCgetnext (co, ci1)
) {
switch (TCgettype (co, ci1)) {
case C_STRING:
appends ("."), appends (TCgetstring (co, ci1));
break;
case C_INTEGER:
appends ("[");
appendi (TCgetinteger (co, ci1));
appends ("]");
break;
case C_REAL:
appends ("[");
appendd (TCgetreal (co, ci1));
appends ("]");
break;
default:
appends ("[");
codestr (co, ci1);
appends ("]");
}
}
break;
case C_PVAR:
appends ("<var>");
break;
case C_FUNCTION:
ci1 = TCgetnext (co, TCgetnext (co, TCgetfp (co, ci)));
appends ("function (");
codestr (co, ci1);
ci1 = TCgetnext (co, ci1);
if (TCgettype (co, ci1) == C_INTERNAL) {
appends (") internal \"");
appends (Ifuncs[TCgetinteger (co, TCgetfp (co, ci1))].name);
appends ("\"");
} else {
appends (") {");
INDINC (2);
for (; ci1 != C_NULL; ci1 = TCgetnext (co, ci1)) {
appendnl ();
if (TCgettype (co, ci1) == C_DECL)
appends ("local "), codestr (co, ci1), appends (";");
else
codestr (co, ci1);
}
INDDEC (2);
appendnl ();
appends ("}");
}
break;
case C_TCONS:
appends ("[");
INDINC (2);
ci1 = TCgetfp (co, ci);
while (ci1 != C_NULL) {
appendnl ();
codestr (co, ci1);
appends (" = ");
ci1 = TCgetnext (co, ci1);
codestr (co, ci1);
appends (";");
ci1 = TCgetnext (co, ci1);
}
INDDEC (2);
appendnl ();
appends ("]");
break;
case C_DECL:
ci1 = TCgetfp (co, ci);
while (ci1 != C_NULL) {
appends (TCgetstring (co, ci1));
ci1 = TCgetnext (co, ci1);
if (ci1 != C_NULL)
appends (", ");
}
break;
case C_STMT:
ci1 = TCgetfp (co, ci);
if (ci1 == C_NULL) {
appends (";");
break;
}
if (TCgetnext (co, ci1) == C_NULL) {
codestr (co, ci1);
ct1 = TCgettype (co, ci1);
if (!C_ISSTMT (ct1))
appends (";");
} else {
appends (" {");
INDINC (2);
for (; ci1 != C_NULL; ci1 = TCgetnext (co, ci1)) {
appendnl ();
codestr (co, ci1);
}
INDDEC (2);
appendnl ();
appends ("}");
}
break;
case C_IF:
ci1 = TCgetfp (co, ci);
appends ("if (");
codestr (co, ci1);
appends (")");
ci1 = TCgetnext (co, ci1);
ci2 = TCgetfp (co, ci1);
if (ci2 == C_NULL || TCgetnext (co, ci2) == C_NULL) {
INDINC (2);
appendnl ();
codestr (co, ci1);
INDDEC (2);
} else {
codestr (co, ci1);
}
ci1 = TCgetnext (co, ci1);
if (ci1 == C_NULL)
break;
if (ci2 == C_NULL || TCgetnext (co, ci2) == C_NULL) {
appendnl ();
appends ("else");
} else {
appends (" else");
}
ci2 = TCgetfp (co, ci1);
if (ci2 == C_NULL || TCgetnext (co, ci2) == C_NULL) {
INDINC (2);
appendnl ();
codestr (co, ci1);
INDDEC (2);
} else {
codestr (co, ci1);
}
break;
case C_WHILE:
ci1 = TCgetfp (co, ci);
appends ("while (");
codestr (co, ci1);
ci1 = TCgetnext (co, ci1);
ci2 = TCgetfp (co, ci1);
if (ci2 == C_NULL || TCgetnext (co, ci2) == C_NULL) {
appends (")");
INDINC (2);
appendnl ();
codestr (co, ci1);
INDDEC (2);
} else {
appends (")");
codestr (co, ci1);
}
break;
case C_FOR:
ci1 = TCgetfp (co, ci);
appends ("for (");
codestr (co, ci1);
appends ("; ");
ci1 = TCgetnext (co, ci1);
codestr (co, ci1);
appends ("; ");
ci1 = TCgetnext (co, ci1);
codestr (co, ci1);
ci1 = TCgetnext (co, ci1);
ci2 = TCgetfp (co, ci1);
if (ci2 == C_NULL || TCgetnext (co, ci2) == C_NULL) {
appends (")");
INDINC (2);
appendnl ();
codestr (co, ci1);
INDDEC (2);
} else {
appends (")");
codestr (co, ci1);
}
break;
case C_FORIN:
ci1 = TCgetfp (co, ci);
appends ("for (");
codestr (co, ci1);
appends (" in ");
ci1 = TCgetnext (co, ci1);
codestr (co, ci1);
ci1 = TCgetnext (co, ci1);
ci2 = TCgetfp (co, ci1);
if (ci2 == C_NULL || TCgetnext (co, ci2) == C_NULL) {
appends (")");
INDINC (2);
appendnl ();
codestr (co, ci1);
INDDEC (2);
} else {
appends (")");
codestr (co, ci1);
}
break;
case C_BREAK:
appends ("break;");
break;
case C_CONTINUE:
appends ("continue;");
break;
case C_RETURN:
ci1 = TCgetfp (co, ci);
appends ("return");
if (ci1 != C_NULL) {
appends (" ");
codestr (co, ci1);
}
appends (";");
break;
case C_ARGS:
ci1 = TCgetfp (co, ci);
while (ci1 != C_NULL) {
codestr (co, ci1);
ci1 = TCgetnext (co, ci1);
if (ci1 != C_NULL)
appends (", ");
}
break;
default:
panic1 (POS, "codestr", "bad object type: %d", ct);
}
}