2.11BSD#431 - /usr/src/new/PORT/B/src/bsmall/b2exp.c

   1: /* Copyright (c) Stichting Mathematisch Centrum, Amsterdam, 1984. */
   2: /* $Header: b2exp.c,v 1.1 84/06/28 00:49:08 timo Exp $ */
   3: 
   4: /* B expression evaluation */
   5: #include "b.h"
   6: #include "b0con.h"
   7: #include "b1obj.h"
   8: #include "b1mem.h" /* for ptr */
   9: #include "b2env.h"
  10: #include "b2syn.h"
  11: #include "b2sem.h"
  12: #include "b2sou.h"
  13: 
  14: /*************************************************************/
  15: /*                                                           */
  16: /* The operand and operator stacks are modelled as compounds */
  17: /* whose first field is the top and whose second field is    */
  18: /* the remainder of the stack (i.e., linked lists).          */
  19: /* A cleaner and more efficient implementation of            */
  20: /* these heavily used stacks would be in order.              */
  21: /*                                                           */
  22: /*************************************************************/
  23: 
  24: /* nd = operand, tor = operator (function) */
  25: 
  26: value ndstack, torstack;
  27: #define Bot Vnil
  28: fun Bra, Ket;
  29: 
  30: Visible Procedure inittors() {
  31:     ndstack= torstack= Vnil;
  32:     Bra= mk_fun(-1, -1, Mon, (literal)Dummy, (txptr)Dummy, (txptr)Dummy, (value)Dummy, (bool)Dummy);
  33:     Ket= mk_fun( 0,  0, Dya, (literal)Dummy, (txptr)Dummy, (txptr)Dummy, (value)Dummy, (bool)Dummy);
  34: }
  35: 
  36: Hidden Procedure pop_stack(stack) value *stack; {
  37:     value oldstack= *stack;
  38:     *stack= *field(*stack, 1);
  39:     put_in_field(Vnil, &oldstack, 0); put_in_field(Vnil, &oldstack, 1);
  40:     release(oldstack);
  41: }
  42: 
  43: Hidden value popnd() {
  44:     value r;
  45:     if (ndstack == Vnil) syserr("operand stack underflow");
  46:     r= *field(ndstack, 0);
  47:     pop_stack(&ndstack);
  48:     return r;
  49: }
  50: 
  51: Hidden Procedure pushnd(nd) value nd; {
  52:     value s= ndstack;
  53:     ndstack= mk_compound(2);
  54:     put_in_field(nd, &ndstack, 0); put_in_field(s, &ndstack, 1);
  55: }
  56: 
  57: Hidden Procedure pushmontor(tor) value tor; {
  58:     value s= torstack;
  59:     torstack= mk_compound(2);
  60:     put_in_field(tor, &torstack, 0); put_in_field(s, &torstack, 1);
  61: }
  62: 
  63: Hidden Procedure pushdyator(tor2) value tor2; {
  64:     value tor1; funprd *t1, *t2= Funprd(tor2);
  65:     intlet L1, H1, L2= t2->L, H2= t2->H;
  66:  prio:  if (torstack == Vnil) syserr("operator stack underflow");
  67:     tor1= *field(torstack, 0); t1= Funprd(tor1),
  68:     L1= t1->L; H1= t1->H;
  69:     if (L2 > H1)
  70:         if (tor2 == Ket) {
  71:             if (tor1 != Bra)
  72:                 syserr("local operator stack underflow");
  73:             pop_stack(&torstack);
  74:         }
  75:         else pushmontor(tor2);
  76:     else if (L1 >= H2) {
  77:         value nd1= Vnil, nd2= popnd();
  78:         if (t1->adic == Dya) nd1= popnd();
  79:         pushnd(formula(nd1, tor1, nd2));
  80:         if (xeq) {
  81:             release(nd2);
  82:             release(nd1);
  83:         }
  84:         pop_stack(&torstack);
  85:         goto prio;
  86:     } else pprerr("priorities? use ( and ) to resolve", "");
  87: }
  88: 
  89: Forward value basexpr();
  90: Forward value text_dis();
  91: Forward value tl_dis();
  92: 
  93: Hidden value statabsel(t, k) value t, k; {
  94:     /* temporary, while no static type check */
  95:     return mk_elt();
  96: }
  97: 
  98: Visible value expr(q) txptr q; {
  99:     value c, v; txptr i, j; intlet len, k;
 100:     if ((len= 1+count(",", q)) == 1) return basexpr(q);
 101:     c= mk_compound(len);
 102:     k_Overfields {
 103:         if (Lastfield(k)) i= q;
 104:         else req(",", q, &i, &j);
 105:         v= basexpr(i);
 106:         put_in_field(v, &c, k);
 107:         if (!Lastfield(k)) tx= j;
 108:     }
 109:     return c;
 110: }
 111: 
 112: Hidden value basexpr(q) txptr q; {
 113:     value v= obasexpr(q);
 114:     Skipsp(tx);
 115:     if (tx < q && Char(tx) == ',')
 116:         parerr("no commas allowed in this context", "");
 117:     upto(q, "expression");
 118:     return v;
 119: }
 120: 
 121: Forward bool primary(), clocondis();
 122: 
 123: #define Pbot {pushnd(Bot); pushmontor(Bra);}
 124: #define Ipush if (!pushing) {Pbot; pushing= Yes;}
 125: #define Fpush if (pushing) {                                    \
 126:               pushnd(v); pushdyator(Ket); v= popnd();   \
 127:               if (popnd() != Bot) syserr(               \
 128:                   xeq ? "formula evaluation awry" : \
 129:                       "formula parsing awry");  \
 130:           }
 131: 
 132: Visible value obasexpr(q) txptr q; {
 133:     value v, t; bool pushing= No;
 134:  nxtnd: Skipsp(tx);
 135:     nothing(q, "expression");
 136:     t= tag();
 137:     if (primary(q, t, &v, Yes)) /* then t is released */;
 138:     else if (t != Vnil) {
 139:         value f;
 140:         if (is_monfun(t, &f)) {
 141:             release(t);
 142:             Ipush;
 143:             pushmontor(f);
 144:             goto nxtnd;
 145:         } else {
 146:             release(t);
 147:             error("target has not yet received a value");
 148:         }
 149:     } else if (Montormark(Char(tx))) {
 150:         Ipush;
 151:         pushmontor(montor());
 152:         goto nxtnd;
 153:     } else parerr("no expression where expected", "");
 154:     /* We are past an operand and look for an operator */
 155:     Skipsp(tx);
 156:     if (tx < q) {
 157:         txptr tx0= tx; bool lt, eq, gt;
 158:         if (Letter(Char(tx))) {
 159:             fun f;
 160:             t= tag();
 161:             if (is_dyafun(t, &f)) {
 162:                 release(t);
 163:                 Ipush;
 164:                 pushnd(v);
 165:                 pushdyator(f);
 166:                 goto nxtnd;
 167:             }
 168:             release(t);
 169:         } else if (relop(&lt, &eq, &gt));
 170:         else if (Dyatormark(Char(tx))) {
 171:             Ipush;
 172:             pushnd(v);
 173:             pushdyator(dyator());
 174:             goto nxtnd;
 175:         }
 176:         tx= tx0;
 177:     }
 178:     Fpush;
 179:     return v;
 180: }
 181: 
 182: Hidden bool clocondis(q, p) txptr q; value *p; {
 183:     txptr i, j;
 184:     Skipsp(tx);
 185:     nothing(q, "expression");
 186:     if (Char(tx) == '(') {
 187:         tx++; req(")", q, &i, &j);
 188:         *p= expr(i); tx= j;
 189:         return Yes;
 190:     }
 191:     if (Dig(Char(tx)) || Char(tx) == '.' || Char(tx) == 'E' &&
 192:        (Dig(Char(tx+1)) || Char(tx+1)=='+' || Char(tx+1)=='-')) {
 193:         *p= constant(q);
 194:         return Yes;
 195:     }
 196:     if (Char(tx) == '\'' || Char(tx) == '"') {
 197:         *p= text_dis(q);
 198:         return Yes;
 199:     }
 200:     if (Char(tx) == '{') {
 201:         *p= tl_dis(q);
 202:         return Yes;
 203:     }
 204:     return No;
 205: }
 206: 
 207: Hidden bool primary(q, t, p, tri) txptr q; value t, *p; bool tri; {
 208: /* If a tag has been seen, it is held in t.
 209:    Releasing t is a task of primary, but only if the call succeeds. */
 210:     fun f; value tt, relt= Vnil; value *aa= &t;
 211:     if (t != Vnil) /* tag */ {
 212:         if (xeq) {
 213:             tt= t;
 214:             aa= lookup(t);
 215:             if (aa == Pnil) {
 216:                 if (is_zerfun(t, &f)) {
 217:                     t= formula(Vnil, f, Vnil);
 218:                     aa= &t;
 219:                 } else return No;
 220:             } else if (Is_refinement(*aa)) {
 221:                 ref_et(*aa, Ret); t= resval; resval= Vnil;
 222:                 aa= &t;
 223:             } else if (Is_formal(*aa)) {
 224:                 t= eva_formal(*aa);
 225:                 aa= &t;
 226:             } else if (Is_shared(*aa)) {
 227:                 if (!in_env(prmnv->tab, t, &aa)) return No;
 228:                 if (Is_filed(*aa))
 229:                     if (!is_tloaded(t, &aa)) return No;
 230:                 t= Vnil;
 231:             } else if (Is_filed(*aa)) {
 232:                 if (!is_tloaded(t, &aa)) return No;
 233:                 t= Vnil;
 234:             } else t= Vnil;
 235:             release(tt);
 236:         }
 237:     } else if (clocondis(q, &t)) aa= &t;
 238:     else return No;
 239:     Skipsp(tx);
 240:     while (tx < q && Char(tx) == '[') {
 241:         txptr i, j; value s;
 242:         tx++; req("]", q, &i, &j);
 243:         s= expr(i); tx= j;
 244:         /* don't copy table for selection */
 245:         if (xeq) {
 246:             aa= adrassoc(*aa, s);
 247:             release(s);
 248:             relt= t;
 249:             if (aa == Pnil) error("key not in table");
 250:         } else {
 251:             t= statabsel(tt= t, s);
 252:             release(tt); release(s);
 253:         }
 254:         Skipsp(tx);
 255:     }
 256:     if (tri && tx < q && (Char(tx) == '@' || Char(tx) == '|')) {
 257:         intlet B, C;
 258:         if (xeq && !Is_text(*aa))
 259:             parerr("in t@p or t|p, t is not a text", "");
 260:         trimbc(q, xeq ? length(*aa) : 0, &B, &C);
 261:         if (xeq) {
 262:             relt= t;
 263:             t= trim(*aa, B, C);
 264:             aa= &t;
 265:         }
 266:     }
 267:     *p= t == Vnil || relt != Vnil ? copy(*aa) : t;
 268:     release(relt);
 269:     return Yes;
 270: }
 271: 
 272: Forward intlet trimi();
 273: 
 274: Visible Procedure trimbc(q, len, B, C) txptr q; intlet len, *B, *C; {
 275:     char bc; intlet N;
 276:     *B= *C= 0;
 277:     while (tx < q && (Char(tx) == '@' || Char(tx) == '|')) {
 278:         bc= Char(tx++);
 279:         N= trimi(q);
 280:         if (bc == '@') *B+= N-1;
 281:         else *C+= (len-*B-*C)-N;
 282:         if (*B < 0 || *C < 0 || *B+*C > len)
 283:             error("in t@p or t|p, p is out of bounds");
 284:         Skipsp(tx);
 285:     }
 286: }
 287: 
 288: Hidden intlet trimi(q) txptr q; {
 289:     value v, t; bool pushing= No;
 290:  nxtnd: Skipsp(tx);
 291:     nothing(q, "expression");
 292:     t= tag();
 293:     if (primary(q, t, &v, No)); /* then t is released */
 294:     else if (t != Vnil) {
 295:         value f;
 296:         if (is_monfun(t, &f)) {
 297:             release(t);
 298:             Ipush;
 299:             pushmontor(f);
 300:             goto nxtnd;
 301:         } else {
 302:             release(t);
 303:             error("target has not yet received a value");
 304:         }
 305:     } else if (Montormark(Char(tx))) {
 306:         Ipush;
 307:         pushmontor(montor());
 308:         goto nxtnd;
 309:     } else parerr("no expression where expected", "");
 310:     Fpush;
 311:     {int ii; intlet i= 0;
 312:         if (xeq) {
 313:             ii= intval(v);
 314:             if (ii < 0) error("in t@p or t|p, p is negative");
 315:             if (ii > Maxintlet)
 316:                 error("in t@p or t|p, p is excessive");
 317:             i= ii;
 318:         }
 319:         release(v);
 320:         return i;
 321:     }
 322: }
 323: 
 324: Visible value constant(q) txptr q; {
 325:     bool dig= No; txptr first= tx;
 326:     while (tx < q && Dig(Char(tx))) {
 327:         ++tx;
 328:         dig= Yes;
 329:     }
 330:     if (tx < q && Char(tx) == '.') {
 331:         tx++;
 332:         while (tx < q && Dig(Char(tx))) {
 333:             dig= Yes;
 334:             ++tx;
 335:         }
 336:         if (!dig) pprerr("point without digits", "");
 337:     }
 338:     if (tx < q && Char(tx) == 'E') {
 339:         tx++;
 340:         if (!(Dig(Char(tx))) && Keymark(Char(tx))) {
 341:             tx--;
 342:             goto done;
 343:         }
 344:         if (tx < q && (Char(tx) == '+' || Char(tx) == '-')) ++tx;
 345:         dig= No;
 346:         while (tx < q && Dig(Char(tx))) {
 347:             dig= Yes;
 348:             ++tx;
 349:         }
 350:         if (!dig) parerr("E not followed by exponent", "");
 351:     }
 352:  done:  return numconst(first, tx);
 353: }
 354: 
 355: char txdbuf[TXDBUFSIZE];
 356: txptr txdbufend= &txdbuf[TXDBUFSIZE];
 357: 
 358: Visible Procedure concat_to(v, s) value* v; string s; { /*TEMPORARY*/
 359:     value v1, v2;
 360:     if (*v == Vnil) *v= mk_text(s);
 361:     else {
 362:         *v= concat(v1= *v, v2= mk_text(s));
 363:         release(v1); release(v2);
 364:     }
 365: }
 366: 
 367: Hidden value text_dis(q) txptr q; {
 368:     char aq[2]; txptr tp= txdbuf; value t= Vnil, t1, t2;
 369:     aq[1]= '\0'; *aq= Char(tx++);
 370:  fbuf:  while (tx < q && Char(tx) != *aq) {
 371:         if (Char(tx) == '`') {
 372:             if (Char(tx+1) == '`') tx++;
 373:             else {
 374:                 *tp= '\0';
 375:                 concat_to(&t, txdbuf);
 376:                 t= concat(t1= t, t2= conversion(q));
 377:                 release(t1); release(t2);
 378:                 tp= txdbuf; goto fbuf;
 379:             }
 380:         }
 381:         *tp++= Char(tx++);
 382:         if (tp+1 >= txdbufend) {
 383:             *(txdbufend-1)= '\0';
 384:             concat_to(&t, txdbuf);
 385:             tp= txdbuf;
 386:         }
 387:     }
 388:     if (tx >= q) parerr("cannot find matching ", aq);
 389:     if (++tx < q && Char(tx) == *aq) {
 390:         *tp++= Char(tx++);
 391:         goto fbuf;
 392:     }
 393:     *tp= '\0';
 394:     concat_to(&t, txdbuf);
 395:     return t;
 396: }
 397: 
 398: Visible value conversion(q) txptr q; {
 399:     txptr f, t; value v, c;
 400:     thought('`');
 401:     req("`", q, &f, &t);
 402:     v= expr(f); c= Ifxeq(convert(v, Yes, Yes));
 403:     if (xeq) release(v);
 404:     tx= t; return c;
 405: }
 406: 
 407: Hidden value tl_dis(q) txptr q; {
 408:     txptr f, t, ff, tt;
 409:     intlet len, k;
 410:     thought('{');
 411:     Skipsp(tx);
 412:     if (Char(tx) == '}') {
 413:         tx++;
 414:         return Ifxeq(mk_elt());
 415:     }
 416:     req("}", q, &f, &t);
 417:     if (find("..", f, &ff, &tt)) {
 418:         value enu, lo, hi;
 419:         lo= basexpr(ff);
 420:         if (!xeq || Is_number(lo)) {
 421:             tx= tt; while (Char(tx) == '.') tx++;
 422:             hi= basexpr(f);
 423:             if (xeq) {
 424:                 value entries;
 425:                 if (!integral(lo))
 426:                   error("in {p..q}, p is a number but not an integer");
 427:                 if (!Is_number(hi))
 428:                   error("in {p..q}, p is a number but q is not");
 429:                 if (!integral(hi))
 430:                   error("in {p..q}, q is a number but not an integer");
 431:                 entries= diff(lo, hi);
 432:                 if (compare(entries, one)>0)
 433:                     error("in {p..q}, integer q < x < p");
 434:                 enu= mk_numrange(lo, hi);
 435:                 release(entries);
 436:             } else enu= mk_elt();
 437:             release(hi); release(lo);
 438:         } else if (Is_text(lo)) {
 439:             char a, z;
 440:             if (!character(lo))
 441:               error("in {p..q}, p is a text but not a character");
 442:             tx= tt; hi= basexpr(f);
 443:             if (!Is_text(hi))
 444:               error("in {p..q}, p is a text but q is not");
 445:             if (!character(hi))
 446:               error("in {p..q}, q is a text but not a character");
 447:             a= charval(lo); z= charval(hi);
 448:             if (z < a-1) error("in {p..q}, character q < x < p");
 449:             enu= mk_charrange(lo, hi);
 450:             release(lo); release(hi);
 451:         } else error("in {p..q}, p is neither a number nor a text");
 452:         tx= t; return enu;
 453:     }
 454:     len= 1+count(";", f);
 455:     Skipsp(tx);
 456:     if (Char(tx) == '[') {
 457:         value ta, ke, a;
 458:         ta= mk_elt();
 459:         k_Over_len {
 460:             Skipsp(tx);
 461:             need("[");
 462:             req("]", f, &ff, &tt);
 463:             ke= expr(ff); tx= tt;
 464:             need(":");
 465:             if (Last(k)) {ff= f; tt= t;}
 466:             else req(";", f, &ff, &tt);
 467:             a= basexpr(ff); tx= tt;
 468:             replace(a, &ta, ke);
 469:             release(ke); release(a);
 470:         }
 471:         return ta;
 472:     }
 473:     {value l, v;
 474:         l= mk_elt();
 475:         k_Over_len {
 476:             if (Last(k)) {ff= f; tt= t;}
 477:             else req(";", f, &ff, &tt);
 478:             v= basexpr(ff); tx= tt;
 479:             insert(v, &l);
 480:             release(v);
 481:         }
 482:         return l;
 483:     }
 484: }

Defined functions

Defined variables

Defined macros