```   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

basexpr defined in line 112; used 8 times
clocondis defined in line 182; used 2 times
concat_to defined in line 358; used 7 times
constant defined in line 324; used 2 times
conversion defined in line 398; used 2 times
inittors defined in line 30; used 1 times
obasexpr defined in line 132; used 6 times
pop_stack defined in line 36; used 3 times
popnd defined in line 43; used 4 times
primary defined in line 207; used 3 times
pushdyator defined in line 63; used 3 times
pushmontor defined in line 57; used 6 times
pushnd defined in line 51; used 5 times
statabsel defined in line 93; used 1 times
text_dis defined in line 367; used 2 times
tl_dis defined in line 407; used 2 times
trimbc defined in line 274; used 2 times
trimi defined in line 288; used 2 times

#### Defined variables

txdbuf defined in line 355; used 7 times
txdbufend defined in line 356; used 2 times

#### Defined macros

Bot defined in line 27; used 2 times
Fpush defined in line 125; used 2 times
Ipush defined in line 124; used 6 times
Pbot defined in line 123; used 1 times
 Last modified: 1985-08-27 Generated: 2016-12-26 Generated by src2html V0.67 page hit count: 1996