4.3BSD/usr/contrib/B/src/bsmall/b2exp.c
/* Copyright (c) Stichting Mathematisch Centrum, Amsterdam, 1984. */
/* $Header: b2exp.c,v 1.1 84/06/28 00:49:08 timo Exp $ */
/* B expression evaluation */
#include "b.h"
#include "b0con.h"
#include "b1obj.h"
#include "b1mem.h" /* for ptr */
#include "b2env.h"
#include "b2syn.h"
#include "b2sem.h"
#include "b2sou.h"
/*************************************************************/
/* */
/* The operand and operator stacks are modelled as compounds */
/* whose first field is the top and whose second field is */
/* the remainder of the stack (i.e., linked lists). */
/* A cleaner and more efficient implementation of */
/* these heavily used stacks would be in order. */
/* */
/*************************************************************/
/* nd = operand, tor = operator (function) */
value ndstack, torstack;
#define Bot Vnil
fun Bra, Ket;
Visible Procedure inittors() {
ndstack= torstack= Vnil;
Bra= mk_fun(-1, -1, Mon, (literal)Dummy, (txptr)Dummy, (txptr)Dummy, (value)Dummy, (bool)Dummy);
Ket= mk_fun( 0, 0, Dya, (literal)Dummy, (txptr)Dummy, (txptr)Dummy, (value)Dummy, (bool)Dummy);
}
Hidden Procedure pop_stack(stack) value *stack; {
value oldstack= *stack;
*stack= *field(*stack, 1);
put_in_field(Vnil, &oldstack, 0); put_in_field(Vnil, &oldstack, 1);
release(oldstack);
}
Hidden value popnd() {
value r;
if (ndstack == Vnil) syserr("operand stack underflow");
r= *field(ndstack, 0);
pop_stack(&ndstack);
return r;
}
Hidden Procedure pushnd(nd) value nd; {
value s= ndstack;
ndstack= mk_compound(2);
put_in_field(nd, &ndstack, 0); put_in_field(s, &ndstack, 1);
}
Hidden Procedure pushmontor(tor) value tor; {
value s= torstack;
torstack= mk_compound(2);
put_in_field(tor, &torstack, 0); put_in_field(s, &torstack, 1);
}
Hidden Procedure pushdyator(tor2) value tor2; {
value tor1; funprd *t1, *t2= Funprd(tor2);
intlet L1, H1, L2= t2->L, H2= t2->H;
prio: if (torstack == Vnil) syserr("operator stack underflow");
tor1= *field(torstack, 0); t1= Funprd(tor1),
L1= t1->L; H1= t1->H;
if (L2 > H1)
if (tor2 == Ket) {
if (tor1 != Bra)
syserr("local operator stack underflow");
pop_stack(&torstack);
}
else pushmontor(tor2);
else if (L1 >= H2) {
value nd1= Vnil, nd2= popnd();
if (t1->adic == Dya) nd1= popnd();
pushnd(formula(nd1, tor1, nd2));
if (xeq) {
release(nd2);
release(nd1);
}
pop_stack(&torstack);
goto prio;
} else pprerr("priorities? use ( and ) to resolve", "");
}
Forward value basexpr();
Forward value text_dis();
Forward value tl_dis();
Hidden value statabsel(t, k) value t, k; {
/* temporary, while no static type check */
return mk_elt();
}
Visible value expr(q) txptr q; {
value c, v; txptr i, j; intlet len, k;
if ((len= 1+count(",", q)) == 1) return basexpr(q);
c= mk_compound(len);
k_Overfields {
if (Lastfield(k)) i= q;
else req(",", q, &i, &j);
v= basexpr(i);
put_in_field(v, &c, k);
if (!Lastfield(k)) tx= j;
}
return c;
}
Hidden value basexpr(q) txptr q; {
value v= obasexpr(q);
Skipsp(tx);
if (tx < q && Char(tx) == ',')
parerr("no commas allowed in this context", "");
upto(q, "expression");
return v;
}
Forward bool primary(), clocondis();
#define Pbot {pushnd(Bot); pushmontor(Bra);}
#define Ipush if (!pushing) {Pbot; pushing= Yes;}
#define Fpush if (pushing) { \
pushnd(v); pushdyator(Ket); v= popnd(); \
if (popnd() != Bot) syserr( \
xeq ? "formula evaluation awry" : \
"formula parsing awry"); \
}
Visible value obasexpr(q) txptr q; {
value v, t; bool pushing= No;
nxtnd: Skipsp(tx);
nothing(q, "expression");
t= tag();
if (primary(q, t, &v, Yes)) /* then t is released */;
else if (t != Vnil) {
value f;
if (is_monfun(t, &f)) {
release(t);
Ipush;
pushmontor(f);
goto nxtnd;
} else {
release(t);
error("target has not yet received a value");
}
} else if (Montormark(Char(tx))) {
Ipush;
pushmontor(montor());
goto nxtnd;
} else parerr("no expression where expected", "");
/* We are past an operand and look for an operator */
Skipsp(tx);
if (tx < q) {
txptr tx0= tx; bool lt, eq, gt;
if (Letter(Char(tx))) {
fun f;
t= tag();
if (is_dyafun(t, &f)) {
release(t);
Ipush;
pushnd(v);
pushdyator(f);
goto nxtnd;
}
release(t);
} else if (relop(<, &eq, >));
else if (Dyatormark(Char(tx))) {
Ipush;
pushnd(v);
pushdyator(dyator());
goto nxtnd;
}
tx= tx0;
}
Fpush;
return v;
}
Hidden bool clocondis(q, p) txptr q; value *p; {
txptr i, j;
Skipsp(tx);
nothing(q, "expression");
if (Char(tx) == '(') {
tx++; req(")", q, &i, &j);
*p= expr(i); tx= j;
return Yes;
}
if (Dig(Char(tx)) || Char(tx) == '.' || Char(tx) == 'E' &&
(Dig(Char(tx+1)) || Char(tx+1)=='+' || Char(tx+1)=='-')) {
*p= constant(q);
return Yes;
}
if (Char(tx) == '\'' || Char(tx) == '"') {
*p= text_dis(q);
return Yes;
}
if (Char(tx) == '{') {
*p= tl_dis(q);
return Yes;
}
return No;
}
Hidden bool primary(q, t, p, tri) txptr q; value t, *p; bool tri; {
/* If a tag has been seen, it is held in t.
Releasing t is a task of primary, but only if the call succeeds. */
fun f; value tt, relt= Vnil; value *aa= &t;
if (t != Vnil) /* tag */ {
if (xeq) {
tt= t;
aa= lookup(t);
if (aa == Pnil) {
if (is_zerfun(t, &f)) {
t= formula(Vnil, f, Vnil);
aa= &t;
} else return No;
} else if (Is_refinement(*aa)) {
ref_et(*aa, Ret); t= resval; resval= Vnil;
aa= &t;
} else if (Is_formal(*aa)) {
t= eva_formal(*aa);
aa= &t;
} else if (Is_shared(*aa)) {
if (!in_env(prmnv->tab, t, &aa)) return No;
if (Is_filed(*aa))
if (!is_tloaded(t, &aa)) return No;
t= Vnil;
} else if (Is_filed(*aa)) {
if (!is_tloaded(t, &aa)) return No;
t= Vnil;
} else t= Vnil;
release(tt);
}
} else if (clocondis(q, &t)) aa= &t;
else return No;
Skipsp(tx);
while (tx < q && Char(tx) == '[') {
txptr i, j; value s;
tx++; req("]", q, &i, &j);
s= expr(i); tx= j;
/* don't copy table for selection */
if (xeq) {
aa= adrassoc(*aa, s);
release(s);
relt= t;
if (aa == Pnil) error("key not in table");
} else {
t= statabsel(tt= t, s);
release(tt); release(s);
}
Skipsp(tx);
}
if (tri && tx < q && (Char(tx) == '@' || Char(tx) == '|')) {
intlet B, C;
if (xeq && !Is_text(*aa))
parerr("in t@p or t|p, t is not a text", "");
trimbc(q, xeq ? length(*aa) : 0, &B, &C);
if (xeq) {
relt= t;
t= trim(*aa, B, C);
aa= &t;
}
}
*p= t == Vnil || relt != Vnil ? copy(*aa) : t;
release(relt);
return Yes;
}
Forward intlet trimi();
Visible Procedure trimbc(q, len, B, C) txptr q; intlet len, *B, *C; {
char bc; intlet N;
*B= *C= 0;
while (tx < q && (Char(tx) == '@' || Char(tx) == '|')) {
bc= Char(tx++);
N= trimi(q);
if (bc == '@') *B+= N-1;
else *C+= (len-*B-*C)-N;
if (*B < 0 || *C < 0 || *B+*C > len)
error("in t@p or t|p, p is out of bounds");
Skipsp(tx);
}
}
Hidden intlet trimi(q) txptr q; {
value v, t; bool pushing= No;
nxtnd: Skipsp(tx);
nothing(q, "expression");
t= tag();
if (primary(q, t, &v, No)); /* then t is released */
else if (t != Vnil) {
value f;
if (is_monfun(t, &f)) {
release(t);
Ipush;
pushmontor(f);
goto nxtnd;
} else {
release(t);
error("target has not yet received a value");
}
} else if (Montormark(Char(tx))) {
Ipush;
pushmontor(montor());
goto nxtnd;
} else parerr("no expression where expected", "");
Fpush;
{int ii; intlet i= 0;
if (xeq) {
ii= intval(v);
if (ii < 0) error("in t@p or t|p, p is negative");
if (ii > Maxintlet)
error("in t@p or t|p, p is excessive");
i= ii;
}
release(v);
return i;
}
}
Visible value constant(q) txptr q; {
bool dig= No; txptr first= tx;
while (tx < q && Dig(Char(tx))) {
++tx;
dig= Yes;
}
if (tx < q && Char(tx) == '.') {
tx++;
while (tx < q && Dig(Char(tx))) {
dig= Yes;
++tx;
}
if (!dig) pprerr("point without digits", "");
}
if (tx < q && Char(tx) == 'E') {
tx++;
if (!(Dig(Char(tx))) && Keymark(Char(tx))) {
tx--;
goto done;
}
if (tx < q && (Char(tx) == '+' || Char(tx) == '-')) ++tx;
dig= No;
while (tx < q && Dig(Char(tx))) {
dig= Yes;
++tx;
}
if (!dig) parerr("E not followed by exponent", "");
}
done: return numconst(first, tx);
}
char txdbuf[TXDBUFSIZE];
txptr txdbufend= &txdbuf[TXDBUFSIZE];
Visible Procedure concat_to(v, s) value* v; string s; { /*TEMPORARY*/
value v1, v2;
if (*v == Vnil) *v= mk_text(s);
else {
*v= concat(v1= *v, v2= mk_text(s));
release(v1); release(v2);
}
}
Hidden value text_dis(q) txptr q; {
char aq[2]; txptr tp= txdbuf; value t= Vnil, t1, t2;
aq[1]= '\0'; *aq= Char(tx++);
fbuf: while (tx < q && Char(tx) != *aq) {
if (Char(tx) == '`') {
if (Char(tx+1) == '`') tx++;
else {
*tp= '\0';
concat_to(&t, txdbuf);
t= concat(t1= t, t2= conversion(q));
release(t1); release(t2);
tp= txdbuf; goto fbuf;
}
}
*tp++= Char(tx++);
if (tp+1 >= txdbufend) {
*(txdbufend-1)= '\0';
concat_to(&t, txdbuf);
tp= txdbuf;
}
}
if (tx >= q) parerr("cannot find matching ", aq);
if (++tx < q && Char(tx) == *aq) {
*tp++= Char(tx++);
goto fbuf;
}
*tp= '\0';
concat_to(&t, txdbuf);
return t;
}
Visible value conversion(q) txptr q; {
txptr f, t; value v, c;
thought('`');
req("`", q, &f, &t);
v= expr(f); c= Ifxeq(convert(v, Yes, Yes));
if (xeq) release(v);
tx= t; return c;
}
Hidden value tl_dis(q) txptr q; {
txptr f, t, ff, tt;
intlet len, k;
thought('{');
Skipsp(tx);
if (Char(tx) == '}') {
tx++;
return Ifxeq(mk_elt());
}
req("}", q, &f, &t);
if (find("..", f, &ff, &tt)) {
value enu, lo, hi;
lo= basexpr(ff);
if (!xeq || Is_number(lo)) {
tx= tt; while (Char(tx) == '.') tx++;
hi= basexpr(f);
if (xeq) {
value entries;
if (!integral(lo))
error("in {p..q}, p is a number but not an integer");
if (!Is_number(hi))
error("in {p..q}, p is a number but q is not");
if (!integral(hi))
error("in {p..q}, q is a number but not an integer");
entries= diff(lo, hi);
if (compare(entries, one)>0)
error("in {p..q}, integer q < x < p");
enu= mk_numrange(lo, hi);
release(entries);
} else enu= mk_elt();
release(hi); release(lo);
} else if (Is_text(lo)) {
char a, z;
if (!character(lo))
error("in {p..q}, p is a text but not a character");
tx= tt; hi= basexpr(f);
if (!Is_text(hi))
error("in {p..q}, p is a text but q is not");
if (!character(hi))
error("in {p..q}, q is a text but not a character");
a= charval(lo); z= charval(hi);
if (z < a-1) error("in {p..q}, character q < x < p");
enu= mk_charrange(lo, hi);
release(lo); release(hi);
} else error("in {p..q}, p is neither a number nor a text");
tx= t; return enu;
}
len= 1+count(";", f);
Skipsp(tx);
if (Char(tx) == '[') {
value ta, ke, a;
ta= mk_elt();
k_Over_len {
Skipsp(tx);
need("[");
req("]", f, &ff, &tt);
ke= expr(ff); tx= tt;
need(":");
if (Last(k)) {ff= f; tt= t;}
else req(";", f, &ff, &tt);
a= basexpr(ff); tx= tt;
replace(a, &ta, ke);
release(ke); release(a);
}
return ta;
}
{value l, v;
l= mk_elt();
k_Over_len {
if (Last(k)) {ff= f; tt= t;}
else req(";", f, &ff, &tt);
v= basexpr(ff); tx= tt;
insert(v, &l);
release(v);
}
return l;
}
}