int Iquote (int argc, lvar_t *argv) {
Tobj so, ao, qo;
char *s, *s1, *s2, *qs, *as;
char buf2[50];
int n, bufi;
if (
(Tgettype ((so = argv[0].o)) != T_STRING && !T_ISNUMBER (so)) ||
(argc > 1 && Tgettype ((qo = argv[1].o)) != T_STRING) ||
(argc > 2 && Tgettype ((ao = argv[2].o)) != T_STRING)
)
return L_FAILURE;
switch (Tgettype (so)) {
case T_STRING:
s = Tgetstring (so);
break;
case T_INTEGER:
sprintf (buf2, "%ld", Tgetinteger (so));
s = &buf2[0];
break;
case T_REAL:
sprintf (buf2, "%f", Tgetreal (so));
s = &buf2[0];
break;
}
if (argc > 1)
qs = Tgetstring (qo);
else
qs = "'\"";
if (argc > 2)
as = Tgetstring (ao);
else
as = NULL;
bufi = 0;
if ((n = strlen (s) + 3) * 2 > bufn)
growbufp (n * 2); /* the *2 is max for chars to quote */
if (as)
bufp[bufi++] = *as;
for (s1 = s; *s1; s1++) {
for (s2 = qs; *s2; s2++)
if (*s1 == *s2) {
bufp[bufi++] = '\\', bufp[bufi++] = *s1;
break;
}
if (!*s2) {
switch (*s1) {
case '\n': bufp[bufi++] = '\\', bufp[bufi++] = 'n'; break;
case '\r': bufp[bufi++] = '\\', bufp[bufi++] = 'r'; break;
default: bufp[bufi++] = *s1; break;
}
}
}
if (as)
bufp[bufi++] = *as;
bufp[bufi] = '\000';
rtno = Tstring (bufp);
return L_SUCCESS;
}
static Tobj arithop(num_tt * lnum, Ctype_t op, num_tt * rnum)
{
double d1, d2, d3;
if (!rnum && op != C_UMINUS)
return NULL;
if (lnum->type == C_INTEGER)
d1 = lnum->u.i;
else if (lnum->type == C_REAL)
d1 = lnum->u.d;
else if (!lnum->u.no)
return NULL;
else if (Tgettype(lnum->u.no) == T_INTEGER)
d1 = Tgetinteger(lnum->u.no);
else if (Tgettype(lnum->u.no) == T_REAL)
d1 = Tgetreal(lnum->u.no);
else
return NULL;
if (op == C_UMINUS) {
d3 = -d1;
goto result;
}
if (rnum->type == C_INTEGER)
d2 = rnum->u.i;
else if (rnum->type == C_REAL)
d2 = rnum->u.d;
else if (!rnum->u.no)
return NULL;
else if (Tgettype(rnum->u.no) == T_INTEGER)
d2 = Tgetinteger(rnum->u.no);
else if (Tgettype(rnum->u.no) == T_REAL)
d2 = Tgetreal(rnum->u.no);
else
return NULL;
switch (op) {
case C_PLUS:
d3 = d1 + d2;
break;
case C_MINUS:
d3 = d1 - d2;
break;
case C_MUL:
d3 = d1 * d2;
break;
case C_DIV:
d3 = d1 / d2;
break;
case C_MOD:
d3 = (long) d1 % (long) d2;
break;
}
result:
if (d3 == (double) (long) d3)
return Tinteger((long) d3);
return Treal(d3);
}
static int orderop(Tobj v1o, Ctype_t op, Tobj v2o)
{
Ctype_t t1, t2;
long i1, i2;
int r;
double d1, d2;
if (!v1o || !v2o) {
if ((v1o || v2o) && op == C_NE)
return TRUE;
return FALSE;
}
t1 = Tgettype(v1o), t2 = Tgettype(v2o);
if (t1 == T_STRING && t2 == T_STRING) {
r = Strcmp(Tgetstring(v1o), Tgetstring(v2o));
} else if (t1 == T_INTEGER && t2 == T_INTEGER) {
i1 = Tgetinteger(v1o), i2 = Tgetinteger(v2o);
r = (i1 == i2) ? 0 : ((i1 < i2) ? -1 : 1);
} else if (t1 == T_INTEGER && t2 == T_REAL) {
i1 = Tgetinteger(v1o), d2 = Tgetreal(v2o);
r = (i1 == d2) ? 0 : ((i1 < d2) ? -1 : 1);
} else if (t1 == T_REAL && t2 == T_INTEGER) {
d1 = Tgetreal(v1o), i2 = Tgetinteger(v2o);
r = (d1 == i2) ? 0 : ((d1 < i2) ? -1 : 1);
} else if (t1 == T_REAL && t2 == T_REAL) {
d1 = Tgetreal(v1o), d2 = Tgetreal(v2o);
r = (d1 == d2) ? 0 : ((d1 < d2) ? -1 : 1);
} else if (t1 == t2) {
if (op != C_EQ && op != C_NE)
return FALSE;
r = (v1o == v2o) ? 0 : 1;
} else {
return FALSE;
}
switch (op) {
case C_EQ:
return (r == 0) ? TRUE : FALSE;
case C_NE:
return (r != 0) ? TRUE : FALSE;
case C_LT:
return (r < 0) ? TRUE : FALSE;
case C_LE:
return (r <= 0) ? TRUE : FALSE;
case C_GT:
return (r > 0) ? TRUE : FALSE;
case C_GE:
return (r >= 0) ? TRUE : FALSE;
}
panic1(POS, "orderop", "bad op code");
return FALSE; /* NOT REACHED */
}
static void buildlist (txtnode_t *pnode) {
Tkvindex_t tkvi;
Tobj ko, vo;
int vtype;
txtnode_t *cnode;
pnode->u.f.t.n = ((Ttable_t *) pnode->vo)->n;
if (!(pnode->u.f.t.list = malloc (
max (pnode->u.f.t.n, 1) * sizeof (txtnode_t)
)))
panic (POS, "buildlist", "list malloc failed");
for (
cnode = &pnode->u.f.t.list[0], Tgetfirst (pnode->vo, &tkvi);
tkvi.kvp; Tgetnext (&tkvi)
) {
ko = tkvi.kvp->ko, vo = tkvi.kvp->vo;
vtype = Tgettype (vo);
if (vtype == T_CODE && TCgettype (vo, TCgetnext (
vo, TCgetnext (vo, TCgetnext (vo, TCgetfp (vo, 0)))
)) == C_INTERNAL) {
pnode->u.f.t.n--;
continue;
}
*cnode = defnode;
cnode->vo = vo;
cnode->ko = ko;
cnode->ttype = vtype;
cnode++;
}
qsort (
(char *) pnode->u.f.t.list, pnode->u.f.t.n, sizeof (txtnode_t), cmp
);
}
int Iconcat (int argc, lvar_t *argv) {
Tobj ao;
char buf2[50];
char *s;
int i, n, bufi;
for (bufi = 0, i = 0; i < argc; i++) {
ao = argv[i].o;
switch (Tgettype (argv[i].o)) {
case T_STRING:
if (bufi + (n = strlen (Tgetstring (ao)) + 1) > bufn)
growbufp (bufi + n);
for (s = Tgetstring (ao); *s; s++)
bufp[bufi++] = *s;
break;
case T_INTEGER:
if (bufi + 50 > bufn)
growbufp (bufi + 50);
sprintf (buf2, "%ld", Tgetinteger (ao));
for (s = buf2; *s; s++)
bufp[bufi++] = *s;
break;
case T_REAL:
if (bufi + 50 > bufn)
growbufp (bufi + 50);
sprintf (buf2, "%f", Tgetreal (ao));
for (s = buf2; *s; s++)
bufp[bufi++] = *s;
break;
}
}
bufp[bufi] = '\000';
rtno = Tstring (bufp);
return L_SUCCESS;
}
int Itablesize (int argc, lvar_t *argv) {
Tobj vo;
if (Tgettype ((vo = argv[0].o)) != T_TABLE)
return L_FAILURE;
rtno = Tinteger (((Ttable_t *) vo)->n);
return L_SUCCESS;
}
int Imonitor (int argc, lvar_t *argv) {
Tobj mo, io;
char *ms;
int ioi;
if (
Tgettype ((mo = argv[0].o)) != T_STRING ||
(Tgettype ((io = argv[1].o)) != T_INTEGER && Tgettype (io) != T_REAL)
)
return L_FAILURE;
ms = Tgetstring (mo), ioi = Tgetnumber (io);
if (ioi < 0 || ioi >= ion)
return L_FAILURE;
if (strcmp (ms, "on") == 0)
IOmonitor (ioi, inputfds);
else if (strcmp (ms, "off") == 0)
IOunmonitor (ioi, inputfds);
else
return L_FAILURE;
return L_SUCCESS;
}
static void eforinst(Tobj co, int ci)
{
volatile jmp_buf *opljbufp;
volatile jmp_buf pljbuf;
volatile Tobj tblo, c1o;
volatile Tkvindex_t tkvi;
volatile tnk_t tnk;
volatile long km, t;
volatile int ei1, ei2, si;
c1o = (volatile Tobj) co; /* protect argument from longjmp */
ei1 = TCgetfp(c1o, ci);
ei2 = TCgetnext(c1o, ei1);
si = TCgetnext(c1o, ei2);
if (getvar((Tobj) c1o, ei1, (tnk_t *) & tnk) == -1) {
err(ERRNOLHS, ERR3, c1o, ei1);
return;
}
if (tnk.type == TNK_O)
km = Mpushmark(tnk.u.tnko.ko);
if (!(tblo = (volatile Tobj) eeval((Tobj) c1o, ei2))) {
if (tnk.type == TNK_O)
Mpopmark(km);
err(ERRNORHS, ERR4, c1o, ei2);
return;
}
if (Tgettype(tblo) != T_TABLE) {
err(ERRNOTATABLE, ERR1, c1o, ei2);
return;
}
PUSHJMP(opljbufp, pljbufp1, pljbuf);
t = Tgettime(tblo);
for (Tgetfirst((Tobj) tblo, (Tkvindex_t *) & tkvi); tkvi.kvp;
Tgetnext((Tkvindex_t *) & tkvi)) {
setvar(tnk, tkvi.kvp->ko);
if (setjmp(*pljbufp1) != 0) {
if (pljtype == PLJ_CONTINUE)
continue;
else if (pljtype == PLJ_BREAK)
break;
}
eeval((Tobj) c1o, si);
if (t != Tgettime(tblo)) {
err(ERRTABLECHANGED, ERR1, c1o, ei2);
break;
}
}
POPJMP(opljbufp, pljbufp1);
if (tnk.type == TNK_O)
Mpopmark(km);
}
Tobj Eunit(Tobj co)
{
volatile jmp_buf *oeljbufp;
volatile int ownsinfoi;
volatile long m;
volatile Tobj lrtno;
jmp_buf eljbuf;
#if 0
if (running && !Eoktorun) {
err(ERRRECRUN, ERR2, NULL, 0);
return NULL;
}
#endif
Eoktorun = FALSE;
if (!co)
return NULL;
if (Tgettype(co) != T_CODE)
panic1(POS, "Eunit", "argument type is not T_CODE");
m = Mpushmark(co);
PUSHJMP(oeljbufp, eljbufp, eljbuf);
ownsinfoi = sinfoi++;
if (sinfoi == sinfon) {
sinfop =
Marraygrow(sinfop, (long) (sinfon + SINFOINCR) * SINFOSIZE);
sinfon += SINFOINCR;
}
sinfop[ownsinfoi].co = co;
sinfop[ownsinfoi].ci = TCgetfp(co, 0);
sinfop[ownsinfoi].fco = NULL;
sinfop[ownsinfoi].flvari = flvari;
sinfop[ownsinfoi].llvari = llvari;
running++;
if (setjmp(*eljbufp))
lrtno = NULL;
else
lrtno = eeval(co, TCgetfp(co, 0));
running--;
rtno = NULL;
flvari = sinfop[ownsinfoi].flvari;
llvari = sinfop[ownsinfoi].llvari;
sinfoi = ownsinfoi;
POPJMP(oeljbufp, eljbufp);
Mpopmark(m);
Erun = TRUE;
return lrtno;
}
int Iecho (int argc, lvar_t *argv) {
int i;
for (i = 0; i < argc; i++) {
switch (Tgettype (argv[i].o)) {
case T_STRING: printf ("%s", Tgetstring (argv[i].o)); break;
case T_INTEGER: printf ("%ld", Tgetinteger (argv[i].o)); break;
case T_REAL: printf ("%f", Tgetreal (argv[i].o)); break;
case T_TABLE: printf ("[\n"), Dtrace (argv[i].o, 4); break;
}
}
printf ("\n");
return L_SUCCESS;
}
static int cmp (const void *a, const void *b) {
int atype, btype;
txtnode_t *anode, *bnode;
double d1, d2;
d1 = 0.0, d2 = 0.0;
anode = (txtnode_t *) a, bnode = (txtnode_t *) b;
atype = Tgettype (anode->ko), btype = Tgettype (bnode->ko);
if (atype != btype)
return (atype - btype);
if (atype == T_STRING)
return strcmp (Tgetstring (anode->ko), Tgetstring (bnode->ko));
if (atype == T_INTEGER)
d1 = Tgetinteger (anode->ko), d2 = Tgetinteger (bnode->ko);
else if (atype == T_REAL)
d1 = Tgetreal (anode->ko), d2 = Tgetreal (bnode->ko);
if (d1 < d2)
return -1;
else if (d1 > d2)
return 1;
else
return 0; /* but this should never happen since keys are unique */
}
static void rebuildlist (txtnode_t *pnode) {
Tkvindex_t tkvi;
Tobj ko, vo;
int vtype;
txtnode_t *cnode;
txtnode_t *olist, *nlist;
txtnode_t tmpnode;
int on, nn, i, j, cmpval;
cmpval = 0;
olist = pnode->u.f.t.list;
on = pnode->u.f.t.n;
pnode->u.f.t.n = ((Ttable_t *) pnode->vo)->n;
if (!(pnode->u.f.t.list = malloc (
max (pnode->u.f.t.n, 1) * sizeof (txtnode_t)
)))
panic (POS, "rebuildlist", "list malloc failed");
for (
cnode = &pnode->u.f.t.list[0], Tgetfirst (pnode->vo, &tkvi);
tkvi.kvp; Tgetnext (&tkvi)
) {
ko = tkvi.kvp->ko, vo = tkvi.kvp->vo;
vtype = Tgettype (vo);
if (vtype == T_CODE && TCgettype (vo, TCgetnext (
vo, TCgetnext (vo, TCgetnext (vo, TCgetfp (vo, 0)))
)) == C_INTERNAL) {
pnode->u.f.t.n--;
continue;
}
*cnode = defnode;
cnode->vo = vo;
cnode->ko = ko;
cnode->ttype = vtype;
cnode++;
}
qsort ((char *) pnode->u.f.t.list, pnode->u.f.t.n, sizeof (txtnode_t), cmp);
nlist = pnode->u.f.t.list;
nn = pnode->u.f.t.n;
for (i = 0, j = 0; i < nn; i++) {
while (j < on && (cmpval = cmp (&olist[j], &nlist[i])) < 0)
j++;
if (j < on && cmpval == 0 && nlist[i].vo == olist[j].vo)
tmpnode = olist[j], olist[j] = nlist[i], nlist[i] = tmpnode, j++;
}
for (j = 0; j < on; j++)
unfillnode (&olist[j]);
free (olist);
}
char *Ssfull (Tobj ko, Tobj vo) {
sbufp[(sbufi = 0)] = '\000';
if (ko)
scalarstr (ko), appends (" = ");
switch (Tgettype (vo)) {
case T_STRING:
case T_INTEGER:
case T_REAL:
case T_CODE:
scalarstr (vo);
break;
}
appends (";");
return copysbuf ();
}
static void scalarstr (Tobj to) {
switch (Tgettype (to)) {
case T_INTEGER:
appendi (Tgetinteger (to));
break;
case T_REAL:
appendd (Tgetreal (to));
break;
case T_STRING:
appends ("\""), appends (Tgetstring (to)), appends ("\"");
break;
case T_CODE:
codestr (to, 0);
break;
}
}
/* LEFTY builtin */
int TXTmode (int argc, lvar_t *argv) {
char *s;
if (!argv[0].o || Tgettype (argv[0].o) != T_STRING)
return L_FAILURE;
s = Tgetstring (argv[0].o);
if (strcmp (s, "on") == 0) {
if (txtwi == -1)
viewon ();
} else if (strcmp (s, "off") == 0) {
if (txtwi != -1)
viewoff ();
else
txton = FALSE;
}
return L_SUCCESS;
}
int Iidlerun (int argc, lvar_t *argv) {
Tobj mo;
char *ms;
int mode;
if (Tgettype ((mo = argv[0].o)) != T_STRING)
return L_SUCCESS;
ms = Tgetstring (mo);
if (strcmp (ms, "on") == 0)
mode = 1;
else if (strcmp (ms, "off") == 0)
mode = 0;
else
return L_FAILURE;
idlerunmode = mode;
return L_SUCCESS;
}
int Ihtmlquote (int argc, lvar_t *argv) {
Tobj so;
char *s, *s1;
int n, bufi;
if (Tgettype ((so = argv[0].o)) != T_STRING)
return L_FAILURE;
s = Tgetstring (so);
bufi = 0;
if ((n = strlen (s) + 1) * 4 > bufn)
growbufp (n * 4); /* the *4 is max for chars to quote */
for (s1 = s; *s1; s1++) {
switch (*s1) {
case '%':
bufp[bufi++] = '%';
bufp[bufi++] = '2';
bufp[bufi++] = '5';
break;
case ';':
bufp[bufi++] = '%';
bufp[bufi++] = '3';
bufp[bufi++] = 'B';
break;
case '&':
bufp[bufi++] = '%';
bufp[bufi++] = '2';
bufp[bufi++] = '6';
break;
case '+':
bufp[bufi++] = '%';
bufp[bufi++] = '2';
bufp[bufi++] = 'B';
break;
case ' ':
bufp[bufi++] = '+';
break;
default:
bufp[bufi++] = *s1;
break;
}
}
bufp[bufi] = '\000';
rtno = Tstring (bufp);
return L_SUCCESS;
}
void Dtrace (Tobj to, int offset) {
dnode_t dnode;
char *s;
int i;
indent = offset - 2;
afternl = TRUE;
if (Tgettype (to) != T_TABLE) {
pr ((s = Ssfull (NULL, to))), free (s);
return;
}
seeni = 0;
dnode.vo = to;
dnode.path = "";
update (&dnode);
for (i = 0; i < seeni; i++)
free (seenp[i].path), seenp[i].path = NULL;
}
char *Sabstract (Tobj ko, Tobj vo) {
sbufp[(sbufi = 0)] = '\000';
scalarstr (ko), appends (" = ");
switch (Tgettype (vo)) {
case T_STRING:
case T_INTEGER:
case T_REAL:
scalarstr (vo);
break;
case T_CODE:
appends ("function (...) { ... }");
break;
case T_TABLE:
appends ("[ ... ]");
break;
}
appends (";");
return copysbuf ();
}
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 void update (dnode_t *pnode) {
Tkvindex_t tkvi;
dnode_t *list, *cnode;
seennode_t *seennode;
char *s;
long i, n;
indent += 2;
n = ((Ttable_t *) pnode->vo)->n;
if (!(list = malloc (n * sizeof (dnode_t))))
panic1 (POS, "update", "list malloc failed");
for (
cnode = &list[0], Tgetfirst (pnode->vo, &tkvi); tkvi.kvp;
cnode++, Tgetnext (&tkvi)
) {
cnode->ko = tkvi.kvp->ko;
cnode->vo = tkvi.kvp->vo;
cnode->ttype = Tgettype (cnode->vo);
}
qsort ((char *) list, n, sizeof (dnode_t), cmp);
for (i = 0, cnode = &list[0]; i < n; i++, cnode++) {
cnode->path = Spath (pnode->path, cnode->ko);
seennode = findseen (cnode);
if (seennode) {
pr ((s = Sseen (cnode->ko, seennode->path))), free (s);
} else {
add2seen (cnode);
if (cnode->ttype == T_TABLE) {
pr ((s = Stfull (cnode->ko))), free (s);
update (cnode);
pr ("];");
} else {
pr ((s = Ssfull (cnode->ko, cnode->vo))), free (s);
}
}
}
free (list);
indent -= 2;
}
static int boolop(Tobj vo)
{
long i;
double d;
if (!vo)
return FALSE;
switch (Tgettype(vo)) {
case T_INTEGER:
i = Tgetinteger(vo);
return (i == 0) ? FALSE : TRUE;
case T_REAL:
d = Tgetreal(vo);
return (d == 0.0) ? FALSE : TRUE;
case T_TABLE:
if (vo == null)
return FALSE;
return TRUE;
default:
return TRUE;
}
}
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 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;
}
int Isplit (int argc, lvar_t *argv) {
Tobj so, fo;
char *sp, *sp2, *s;
char fc, tc, qmode;
long rtnm, rtni;
int bufi, qflag;
if (
Tgettype ((so = argv[0].o)) != T_STRING ||
Tgettype ((fo = argv[1].o)) != T_STRING
)
return L_FAILURE;
qflag = (argc == 3) ? FALSE : TRUE;
sp = Tgetstring (so);
s = Tgetstring (fo);
if (s[0] == '\\' && s[1] == 'n')
fc = '\n';
else
fc = s[0];
rtno = Ttable (4);
rtnm = Mpushmark (rtno);
rtni = 0;
if (s[0] == 0) {
for (sp2 = sp; *sp2; sp2++) {
tc = *(sp2 + 1), *(sp2 + 1) = '\000';
Tinsi (rtno, rtni++, Tstring (sp2));
*(sp2 + 1) = tc;
}
} else if (qflag && (fc == ' ' || fc == ' ')) {
while (*sp == fc)
sp++;
while (*sp) {
bufi = 0;
qmode = 0;
for (sp2 = sp; *sp2; sp2++) {
if (bufi == bufn)
growbufp (bufn + BUFINCR);
if (*sp2 == '"' || *sp2 == '\'') {
if (qmode) {
if (qmode == *sp2)
qmode = 0;
else
bufp[bufi++] = *sp2;
} else
qmode = *sp2;
} else if (*sp2 == fc && !qmode)
break;
else
bufp[bufi++] = *sp2;
}
if (bufi == bufn)
growbufp (bufn + BUFINCR);
bufp[bufi] = 0;
Tinsi (rtno, rtni++, Tstring (bufp));
while (*sp2 == fc)
sp2++;
sp = sp2;
}
} else {
while (*sp) {
for (sp2 = sp; *sp2 && *sp2 != fc; sp2++)
;
tc = *sp2, *sp2 = '\000';
Tinsi (rtno, rtni++, Tstring (sp));
*sp2 = tc;
if (*sp2) {
sp2++;
if (!*sp2)
Tinsi (rtno, rtni++, Tstring (""));
}
sp = sp2;
}
}
Mpopmark (rtnm);
return L_SUCCESS;
}
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;
}