1 /****************************************************************/
2 /* file eval.c
3
4 ARIBAS interpreter for Arithmetic
5 Copyright (C) 1996 O.Forster
6
7 This program is free software; you can redistribute it and/or modify
8 it under the terms of the GNU General Public License as published by
9 the Free Software Foundation; either version 2 of the License, or
10 (at your option) any later version.
11
12 This program is distributed in the hope that it will be useful,
13 but WITHOUT ANY WARRANTY; without even the implied warranty of
14 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
15 GNU General Public License for more details.
16
17 You should have received a copy of the GNU General Public License
18 along with this program; if not, write to the Free Software
19 Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
20
21 Address of the author
22
23 Otto Forster
24 Math. Institut der LMU
25 Theresienstr. 39
26 D-80333 Muenchen, Germany
27
28 Email forster@rz.mathematik.uni-muenchen.de
29 */
30 /****************************************************************/
31
32 /*
33 ** eval.c
34 ** evaluation functions
35 **
36 ** date of last change
37 ** 1995-03-20: sSYSTEMVAR
38 ** 1995-03-25: fRECORD
39 ** 1995-04-14: fixed bug in eval (case optional arguments)
40 ** 2002-06-08 bugfix in evalargs and evalvargs
41 */
42
43 #include "common.h"
44
45
46 #define STACKFAIL (stkcheck() < 512)
47
48
49 /******* prototypes of exported functions ************/
50 PUBLIC void inieval _((void));
51 PUBLIC truc eval _((truc *ptr));
52 PUBLIC truc ufunapply _((truc *fun, truc *arr, int n));
53 PUBLIC truc arreval _((truc *arr, int n));
54
55 /******* module global variable *********/
56 PRIVATE truc evalsym;
57
58 /******* prototypes of functions internal to this module *****/
59 PRIVATE truc eval0 _((truc *ptr, int flg));
60 PRIVATE int stkevargs _((truc *ptr));
61 PRIVATE void argvarspace _((truc *argptr, int n, truc *vptr, int m));
62 PRIVATE int evalargs _((truc *argptr, int n));
63 PRIVATE int evalvargs _((truc parms, truc *argptr, int n));
64 PRIVATE truc vsymaux _((truc *argptr, unsigned depth));
65 PRIVATE int lvarsini _((truc *arr, int n));
66
67 /* -------------------------------------------------------*/
inieval()68 PUBLIC void inieval()
69 {
70 evalsym = newselfsym("eval", sINTERNAL);
71 }
72 /* -------------------------------------------------------*/
73 /*
74 ** evaluates *ptr
75 */
eval(ptr)76 PUBLIC truc eval(ptr)
77 truc *ptr;
78 {
79 static struct symbol *sptr;
80 static truc *ptr1, *ptr2;
81 static truc obj;
82 static truc parms;
83 static int i, n;
84 static int chk;
85 static int flg;
86 /* static, damit bei Rekursion nur einmal Speicher reserviert wird */
87
88 funptr binfun;
89 int k;
90
91 if((flg = *FLAGPTR(ptr)) >= fSELFEVAL) {
92 return(*ptr);
93 }
94 else if(flg < fFUNEXPR)
95 return(eval0(ptr,flg));
96
97 /**** at this point flg >= fFUNEXPR && flg < fSELFEVAL *****/
98
99 if(STACKFAIL)
100 reset(err_rec);
101
102 if(INTERRUPT) {
103 setinterrupt(0);
104 reset(err_intr);
105 }
106
107 EVALpush(*ptr);
108 /********************/
109 tailnrec:
110 if(flg <= fSPECIALn) {
111 if(flg == fSPECIAL0)
112 binfun = (funptr)*SYMWBINDPTR(evalStkPtr);
113 else
114 binfun = (funptr)*SYMWBINDPTR(TAddress(evalStkPtr));
115 obj = binfun();
116 }
117 else if(flg <= fBUILTINn) {
118 binfun = (funptr)*SYMWBINDPTR(TAddress(evalStkPtr));
119 switch(flg) {
120 case fBUILTIN1:
121 obj = eval(ARG0PTR(evalStkPtr));
122 ARGpush(obj);
123 obj = binfun();
124 ARGpop();
125 break;
126 case fBUILTIN2:
127 obj = eval(ARG0PTR(evalStkPtr));
128 ARGpush(obj);
129 obj = eval(ARG1PTR(evalStkPtr));
130 ARGpush(obj);
131 obj = binfun();
132 ARGnpop(2);
133 break;
134 default: /* case fBUILTINn */
135 goto fnbineval;
136 }
137 }
138 else switch(flg) {
139 case fFUNCALL:
140 ptr = TAddress(evalStkPtr);
141 obj = eval0(ptr,*FLAGPTR(ptr));
142 sptr = symptr(obj);
143 flg = *FLAGPTR(sptr);
144 if(flg == sFUNCTION || flg == sVFUNCTION) {
145 ptr = Taddress(sptr->bind.t);
146 /* ptr zeigt auf die Funktions-Definition */
147 }
148 else if(flg == sFBINARY || flg == sSBINARY) {
149 k = *ARGCOUNTPTR(evalStkPtr);
150 chk = chknargs(obj,k);
151 if(chk == NARGS_FALSE) {
152 error(obj,err_args,voidsym);
153 obj = brkerr();
154 goto cleanup;
155 }
156 binfun = (funptr)sptr->bind.w;
157 if(k == 0 ||
158 ((flg==sSBINARY) && (chk==NARGS_VAR || k>=3))) {
159 obj = binfun();
160 }
161 else if(flg==sFBINARY && chk==NARGS_OK && k<=2) {
162 if(k == 1) {
163 obj = eval(ARG1PTR(evalStkPtr));
164 ARGpush(obj);
165 obj = binfun();
166 ARGpop();
167 }
168 else { /* k == 2 */
169 obj = eval(ARG1PTR(evalStkPtr));
170 ARGpush(obj);
171 obj = eval(ARGNPTR(evalStkPtr,2));
172 ARGpush(obj);
173 obj = binfun();
174 ARGnpop(2);
175 }
176 }
177 else if(flg == sFBINARY) {
178 goto fnbineval;
179 }
180 else { /* flg == sSBINARY && (k == 1 || k == 2) */
181 *evalStkPtr =
182 mkspecnode(obj,ARG1PTR(evalStkPtr),k);
183 obj = binfun();
184 }
185 goto cleanup;
186 }
187 else {
188 error(evalsym,err_ufunc,*ptr);
189 obj = brkerr();
190 goto cleanup;
191 }
192 n = *WORD2PTR(ptr);
193 /* number of formal function arguments */
194 i = *ARGCOUNTPTR(evalStkPtr);
195 /* number of actual function arguments */
196 if(n != i) {
197 if(i < n && n-i <= *FLG2PTR(ptr)) {
198 chk = 1;
199 }
200 else {
201 error(*TAddress(evalStkPtr),err_args,voidsym);
202 obj = brkerr();
203 break;
204 }
205 }
206 else
207 chk = 0;
208 SAVEpush(argStkPtr);
209
210 k = *VARCPTR(ptr);
211 if(chk) { /* provide default optional arguments */
212 ptr1 = VECTORPTR(PARMSPTR(ptr));
213 argvarspace(ptr1,n,VARSPTR(ptr),k);
214 ptr1 = SAVEtop() + 1;
215 ptr2 = ARG1PTR(evalStkPtr);
216 while(--i >= 0)
217 *ptr1++ = *ptr2++;
218 }
219 else {
220 argvarspace(ARG1PTR(evalStkPtr),n,VARSPTR(ptr),k);
221 }
222 *evalStkPtr = *(ptr + OFFS4body);
223
224 if(flg == sVFUNCTION) {
225 parms = *PARMSPTR(ptr);
226 ptr = SAVEtop() + 1;
227 n = evalvargs(parms,ptr,n);
228 }
229 else {
230 ptr = SAVEtop() + 1;
231 n = evalargs(ptr,n);
232 }
233 SAVEpush(basePtr);
234 basePtr = ptr;
235 if(n == aERROR || lvarsini(ptr+n,k) == aERROR)
236 obj = brkerr();
237 else {
238 obj = zero;
239 k = *FUNARGCPTR(evalStkPtr);
240 while(--k >= 0) {
241 obj = eval(ARGNPTR(evalStkPtr,k));
242 if(obj == breaksym) {
243 if(*brkmodePtr == retsym) {
244 obj = *brkbindPtr;
245 *brkbindPtr = zero;
246 }
247 break;
248 }
249 }
250 }
251 basePtr = SAVEretr();
252 argStkPtr = SAVEretr();
253 break;
254 case fWHILEXPR:
255 obj = Swhile();
256 break;
257 case fFOREXPR:
258 obj = Sfor();
259 break;
260 case fIFEXPR:
261 Sifaux();
262 flg = *FLAGPTR(evalStkPtr);
263 if(flg != fCOMPEXPR) {
264 obj = eval(evalStkPtr);
265 break;
266 }
267 /* else fall through */
268 case fCOMPEXPR:
269 obj = voidsym;
270 k = *FUNARGCPTR(evalStkPtr);
271 if(k == 0)
272 goto cleanup;
273 while(--k > 0) { /* evaluate k-1 expressions */
274 obj = eval(ARGNPTR(evalStkPtr,k));
275 if(obj == breaksym)
276 goto cleanup;
277 }
278 /* tail recursion elimination */
279 *evalStkPtr = *ARG0PTR(evalStkPtr);
280
281 flg = *FLAGPTR(evalStkPtr);
282 if(flg >= fSELFEVAL)
283 obj = *evalStkPtr;
284 else if(flg < fFUNEXPR)
285 obj = eval0(evalStkPtr,flg);
286 else
287 goto tailnrec;
288 break;
289 default:
290 error(evalsym,err_case,mkfixnum(flg));
291 obj = brkerr();
292 }
293 goto cleanup;
294 fnbineval:
295 SAVEpush(argStkPtr);
296 ptr = TAddress(evalStkPtr);
297 k = stkevargs(ptr+1);
298 obj = (k == aERROR ? brkerr() : ((funptr1)binfun)(k));
299 argStkPtr = SAVEretr();
300 cleanup:
301 EVALpop();
302 return(obj);
303 }
304 /*------------------------------------------------------------*/
305 /*
306 ** Wendet die benutzerdefinierte Funktion *fun auf die bereits
307 ** ausgewertete Argumentliste (arr,n) an.
308 ** Es wird vorausgesetzt, dass die Argumente der Funktion *fun
309 ** alle Wert-Parameter sind und die Anzahl gleich n ist.
310 */
ufunapply(fun,arr,n)311 PUBLIC truc ufunapply(fun,arr,n)
312 truc *fun;
313 truc *arr;
314 int n;
315 {
316 truc *fundefptr;
317 truc obj;
318 int k;
319
320 fundefptr = TAddress(fun);
321 SAVEpush(argStkPtr);
322 SAVEpush(basePtr);
323 basePtr = argStkPtr + 1;
324
325 k = *VARCPTR(fundefptr);
326 argvarspace(arr,n,VARSPTR(fundefptr),k);
327 EVALpush(*(fundefptr + OFFS4body));
328
329 if(lvarsini(basePtr+n,k) == aERROR)
330 obj = brkerr();
331 else { /* eval body, which is a compound statement */
332 obj = zero;
333 k = *FUNARGCPTR(evalStkPtr);
334 while(--k >= 0) {
335 obj = eval(ARGNPTR(evalStkPtr,k));
336 if(obj == breaksym) {
337 if(*brkmodePtr == retsym) {
338 obj = *brkbindPtr;
339 *brkbindPtr = zero;
340 }
341 break;
342 }
343 }
344 }
345 EVALpop();
346 basePtr = SAVEretr();
347 argStkPtr = SAVEretr();
348 return(obj);
349 }
350 /*------------------------------------------------------------*/
eval0(ptr,flg)351 PRIVATE truc eval0(ptr,flg)
352 truc *ptr;
353 int flg;
354 {
355 struct symbol *sptr;
356
357 if(flg == fSYMBOL) {
358 sptr = SYMPTR(ptr);
359
360 switch(*FLAGPTR(sptr)) {
361 case sCONSTANT:
362 case sSCONSTANT:
363 case sVARIABLE:
364 case sINTERNAL:
365 case sSYSTEMVAR:
366 return(sptr->bind.t);
367 case sUNBOUND:
368 error(evalsym,err_ubound,*ptr);
369 return(brkerr());
370 default:
371 return(*ptr);
372 }
373
374 }
375 else if(flg == fLSYMBOL) {
376 return(*LSYMBOLPTR(ptr));
377 }
378 else if(flg == fRSYMBOL) {
379 ptr = LSYMBOLPTR(ptr);
380 if((flg = *FLAGPTR(ptr)) == fSYMBOL)
381 return(eval(ptr));
382 else if(flg == fLRSYMBOL) {
383 return(*LRSYMBOLPTR(ptr));
384 }
385 else if(flg == fBUILTIN2 || flg == fSPECIAL2
386 || flg == fSPECIAL1) {
387 /* array access or record access or pointer reference */
388 return(eval(ptr));
389 }
390 else {
391 error(evalsym,err_case,mkfixnum(flg));
392 return(brkerr());
393 }
394 }
395 else if(flg == fLRSYMBOL) {
396 return(*LRSYMBOLPTR(ptr));
397 }
398 else if(flg == fTMPCONST) {
399 return(Lconsteval(ptr));
400 }
401 else
402 return(*ptr);
403 }
404 /*------------------------------------------------------------*/
405 /*
406 ** ptr[0] contains number of arguments,
407 ** ptr[1],...,ptr[n] are expressions for arguments
408 ** argStkPtr wird veraendert!
409 */
stkevargs(ptr)410 PRIVATE int stkevargs(ptr)
411 truc *ptr;
412 {
413 truc *argptr;
414 int i,n;
415
416 n = *WORD2PTR(ptr);
417 ptr++;
418 argptr = argStkPtr + 1;
419 argStkPtr += n;
420 if(argStkPtr >= saveStkPtr)
421 reset(err_astk);
422 for(i=0; i<n; i++) /* expressions for arguments */
423 argptr[i] = *ptr++;
424 for(i=0; i<n; i++) { /* evaluate arguments */
425 if((*argptr = eval(argptr)) == breaksym)
426 return(aERROR);
427 else
428 argptr++;
429 }
430 return(n);
431 }
432 /*------------------------------------------------------------*/
433 /*
434 ** schafft Platz fuer Argumente und lokale Variable einer
435 ** benutzerdefinierten Funktion
436 ** argStkPtr wird veraendert!
437 */
argvarspace(argptr,n,vptr,m)438 PRIVATE void argvarspace(argptr,n,vptr,m)
439 truc *argptr, *vptr;
440 int n, m;
441 {
442 truc *ptr1;
443 int i;
444
445 ptr1 = argStkPtr + 1;
446 argStkPtr += n + m;
447 if(argStkPtr >= saveStkPtr)
448 reset(err_astk);
449 for(i=0; i<n; i++) { /* expressions for arguments */
450 *ptr1++ = *argptr++;
451 }
452 if(!m)
453 return;
454 vptr = VECTORPTR(vptr);
455 for(i=0; i<m; i++) /* expressions for variable initialization */
456 *ptr1++ = *vptr++;
457 }
458 /*------------------------------------------------------------*/
evalargs(argptr,n)459 PRIVATE int evalargs(argptr,n)
460 truc *argptr;
461 int n;
462 {
463 int i, flg;
464 truc obj;
465
466 for(i=0; i<n; i++) {
467 if((flg = *FLAGPTR(argptr)) >= fBOOL) {
468 argptr++;
469 continue;
470 }
471 else if(flg < fFUNEXPR) {
472 *argptr = eval0(argptr,flg);
473 }
474 if(*FLAGPTR(argptr) < fRECORD) {
475 if((*argptr = eval(argptr)) == breaksym)
476 return(aERROR);
477 }
478 if((flg = *FLAGPTR(argptr)) >= fRECORD && flg <= fVECTLIKE1) {
479 *argptr = mkarrcopy(argptr);
480 }
481 argptr++;
482 }
483 return(n);
484 }
485 /*------------------------------------------------------------*/
evalvargs(parms,argptr,n)486 PRIVATE int evalvargs(parms,argptr,n)
487 truc parms;
488 truc *argptr;
489 int n;
490 {
491 int i, flg;
492 unsigned depth;
493 truc *ptr;
494
495 depth = basePtr - ArgStack;
496 WORKpush(parms);
497 for(i=0; i<n; i++) {
498 ptr = VECTORPTR(workStkPtr) + i;
499 if(*FLAGPTR(ptr) == fSPECIAL1) {
500 /* es handelt sich um einen Variable-Parameter */
501 if((*argptr = vsymaux(argptr,depth)) == breaksym) {
502 error(funcsym,err_vasym,voidsym);
503 n = aERROR;
504 goto cleanup;
505 }
506 else {
507 argptr++;
508 continue;
509 }
510 }
511 if((flg = *FLAGPTR(argptr)) >= fBOOL) {
512 argptr++;
513 continue;
514 }
515 else if(flg < fFUNEXPR) {
516 *argptr = eval0(argptr,flg);
517 }
518 if(*FLAGPTR(argptr) < fRECORD) {
519 if((*argptr = eval(argptr)) == breaksym) {
520 n = aERROR;
521 break;
522 }
523 }
524 if((flg = *FLAGPTR(argptr)) >= fRECORD && flg <= fVECTLIKE1) {
525 *argptr = mkarrcopy(argptr);
526 }
527 argptr++;
528 }
529 cleanup:
530 WORKpop();
531 return(n);
532 }
533 /*------------------------------------------------------------*/
vsymaux(argptr,depth)534 PRIVATE truc vsymaux(argptr,depth)
535 truc *argptr;
536 unsigned depth;
537 {
538 unsigned u;
539 truc *ptr;
540 truc sym, obj;
541
542 switch(*FLAGPTR(argptr)) {
543 case fSYMBOL:
544 return(*argptr);
545 case fLSYMBOL:
546 u = depth + *WORD2PTR(argptr);
547 return(mklocsym(fLRSYMBOL,u));
548 case fRSYMBOL:
549 return(*LSYMBOLPTR(argptr));
550 case fBUILTIN2: /* array access */
551 case fSPECIAL2: /* record access */
552 ptr = TAddress(argptr);
553 sym = *ptr;
554 ARGpush(ptr[1]);
555 ARGpush(ptr[2]);
556 if(sym == arr_sym || sym == subarrsym) {
557 argStkPtr[-1] = vsymaux(argStkPtr-1,depth);
558 argStkPtr[0] = eval(argStkPtr);
559 }
560 else if(sym == rec_sym) {
561 argStkPtr[-1] = vsymaux(argStkPtr-1,depth);
562 }
563 else {
564 ARGnpop(2);
565 break;
566 }
567 obj = mkbnode(sym);
568 ARGnpop(2);
569 return(obj);
570 }
571 return(brkerr());
572 }
573 /*------------------------------------------------------------*/
574 /*
575 ** Initialisierung der lokalen Variablen
576 */
lvarsini(arr,n)577 PRIVATE int lvarsini(arr,n)
578 truc *arr;
579 int n;
580 {
581 truc obj;
582
583 while(--n >= 0) {
584 if((obj = eval(arr)) == breaksym)
585 return(aERROR);
586 *arr++ = obj;
587 }
588 return(1);
589 }
590 /*------------------------------------------------------------*/
arreval(arr,n)591 PUBLIC truc arreval(arr,n)
592 truc *arr;
593 int n;
594 {
595 static truc res;
596
597 res = voidsym;
598 while(--n >= 0 && res != breaksym)
599 res = eval(arr++);
600 return(res);
601 }
602 /*********************************************************************/
603