/* 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; } }