1 /****************************************************************/
2 /* file control.c
3
4 ARIBAS interpreter for Arithmetic
5 Copyright (C) 1996-2002 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@mathematik.uni-muenchen.de
29 */
30 /****************************************************************/
31 #define TYPEIDENT
32 /*
33 ** control.c
34 ** function definition, logical and control functions
35 **
36 ** date of last change
37 ** 1995-02-22: lpbrksym
38 ** 1995-03-15: const
39 ** 1995-03-20: changed make_unbound
40 ** 1995-03-31: pointer
41 ** 1997-04-22: type symbol, reorg (newintsym), changed Sfor
42 ** 1997-08-18: removed bug (discovered by M.Zimmer, Leipzig) in Sfor
43 ** 1998-01-17: small change in Sfor (regarding toolong)
44 ** 1998-10-07: continue statement
45 ** 1999-06-21: make_unbound(user)
46 ** 2002-03-27: small change in Lvalassign, new function is_lval()
47 ** 2002-04-04: simultaneous assignment (x1,...,xn) := (val1,...,valn)
48 ** 2002-04-27: gmtime
49 ** 2003-02-28: case fGF2NINT in nulltest()
50 ** 2004-06-20: function type_ident
51 ** 2004-10-30: for-loop can now do more than 2**32 iterations
52 */
53
54 #include "common.h"
55
56 PUBLIC void inicont _((void));
57 PUBLIC int is_lval _((truc *ptr));
58 PUBLIC int Lvaladdr _((truc *ptr, trucptr *pvptr));
59 PUBLIC truc Lvalassign _((truc *ptr, truc obj));
60 PUBLIC truc Swhile _((void));
61 PUBLIC truc Sfor _((void));
62 PUBLIC void Sifaux _((void));
63 PUBLIC truc Sexit _((void));
64 PUBLIC truc brkerr _((void));
65
66 PUBLIC truc Lconsteval _((truc *ptr));
67 PUBLIC int Lconstini _((truc consts));
68 PUBLIC truc unbindsym _((truc *ptr));
69 PUBLIC truc unbinduser _((void));
70
71 PUBLIC truc boolsym;
72 PUBLIC truc truesym, falsesym, true, false, nil;
73 PUBLIC truc equalsym, nequalsym;
74 PUBLIC truc exitsym, exitfun, lpbrksym, lpbrkfun, lpcontsym, lpcontfun;
75 PUBLIC truc whilesym, dosym, ifsym, thensym, elsifsym, elsesym;
76 PUBLIC truc forsym, tosym, bysym;
77 PUBLIC truc constsym, varsym, var_sym, inivarsym, typesym;
78 PUBLIC truc not_sym, notsym;
79 PUBLIC truc voidsym, nullsym;
80 PUBLIC truc breaksym, contsym, contnsym, errsym;
81 PUBLIC truc retsym, ret_sym;
82 PUBLIC truc assignsym;
83 PUBLIC truc arisym, usersym;
84 PUBLIC truc symbsym;
85
86 PUBLIC truc funcsym, procsym;
87 PUBLIC truc extrnsym;
88 PUBLIC truc beginsym, endsym;
89
90 PUBLIC truc *brkbindPtr, *brkmodePtr;
91 /*--------------------------------------------------*/
92 PRIVATE truc symbolssym;
93 PRIVATE truc timersym, gmtimsym;
94 PRIVATE truc mkunbdsym;
95 PRIVATE truc andsym, orsym;
96
97 PRIVATE truc *constbindPtr;
98
99 PRIVATE truc Fequal _((void));
100 PRIVATE truc Fnequal _((void));
101 PRIVATE int equal _((truc *ptr1, truc *ptr2));
102 PRIVATE truc Fnot _((void));
103 PRIVATE truc Sand _((void));
104 PRIVATE truc Sor _((void));
105 PRIVATE int nulltest _((truc obj));
106 PRIVATE truc Sinivars _((void));
107 PRIVATE truc Svarparm _((void));
108 PRIVATE truc Sassign _((void));
109 PRIVATE int symbaddr _((truc *ptr, trucptr *pvptr));
110 PRIVATE int increment _((word2 *x, int n, int *signptr,
111 word2 *inc, int inclen, int s));
112 PRIVATE truc Freturn _((void));
113 PRIVATE truc Slpbreak _((void));
114 PRIVATE truc Slpcont _((void));
115 PRIVATE truc Stimer _((void));
116 PRIVATE truc Fgmtime _((int argn));
117 PRIVATE truc Smkunbound _((void));
118 PRIVATE truc Fsymbols _((void));
119 PRIVATE int symbcmp _((truc *ptr1, truc *ptr2));
120
121 #ifdef TYPEIDENT
122 PRIVATE truc typeidsym;
123 PRIVATE truc Ftypeident _((void));
124 PRIVATE int typevalue _((truc symb));
125 #endif
126 /*----------------------------------------------------------------------*/
inicont()127 PUBLIC void inicont()
128 {
129 truc temp;
130 truc and_sym, or_sym, const_sym;
131 variant v;
132
133 v.pp.b0 = fBOOL;
134 v.pp.b1 = 0;
135 v.pp.ww = 1;
136 true = v.xx;
137 v.pp.ww = 0;
138 false = v.xx;
139
140 boolsym = newsym("boolean", sTYPESPEC, false);
141
142 voidsym = newselfsym("", sINTERNAL);
143 nullsym = newselfsym("", sINTERNAL);
144 contsym = newselfsym("cont", sINTERNAL);
145 contnsym = newselfsym("contn",sINTERNAL);
146 errsym = newselfsym("error",sINTERNAL);
147
148 exitsym = newsym("exit", sPARSAUX, nullsym);
149 temp = newintsym("exit",sSBINARY, (wtruc)Sexit);
150 exitfun = mk0fun(temp);
151 lpbrksym = newsym("break", sPARSAUX, nullsym);
152 temp = newintsym("break",sSBINARY, (wtruc)Slpbreak);
153 lpbrkfun = mk0fun(temp);
154 lpcontsym = newsym("continue", sPARSAUX, nullsym);
155 temp = newintsym("continue",sSBINARY, (wtruc)Slpcont);
156 lpcontfun = mk0fun(temp);
157
158 breaksym = newsym("$break", sINTERNVAR, voidsym);
159 brkbindPtr = SYMBINDPTR(&breaksym);
160 brkmodePtr = (truc *)SYMCCPTR(&breaksym);
161 *brkmodePtr = breaksym;
162
163 equalsym = newintsym("=", sFBINARY, (wtruc)Fequal);
164 nequalsym = newintsym("/=", sFBINARY, (wtruc)Fnequal);
165
166 assignsym = newintsym(":= ", sSBINARY, (wtruc)Sassign);
167
168 funcsym = newsym("function", sPARSAUX, nullsym);
169 procsym = newsym("procedure",sPARSAUX, nullsym);
170 extrnsym = newsym("external", sDELIM, nullsym);
171 varsym = newsym("var", sPARSAUX, nullsym);
172 var_sym = newintsym("_var", sSBINARY,(wtruc)Svarparm);
173 inivarsym = newintsym("var", sSBINARY,(wtruc)Sinivars);
174 constsym = newsym("const", sPARSAUX, nullsym);
175 const_sym = newsym("$const", sINTERNVAR, voidsym);
176 constbindPtr = SYMBINDPTR(&const_sym);
177 typesym = newsym("type", sPARSAUX, nullsym);
178
179 whilesym = newsym("while", sPARSAUX, nullsym);
180 forsym = newsym("for", sPARSAUX, nullsym);
181 ifsym = newsym("if", sPARSAUX, nullsym);
182 tosym = newsym("to", sDELIM, nullsym);
183 bysym = newsym("by", sDELIM, nullsym);
184 dosym = newsym("do", sDELIM, nullsym);
185 thensym = newsym("then", sDELIM, nullsym);
186 elsifsym = newsym("elsif", sDELIM, nullsym);
187 elsesym = newsym("else", sDELIM, nullsym);
188 beginsym = newsym("begin", sDELIM, nullsym);
189 endsym = newsym("end", sDELIM, nullsym);
190
191 not_sym = newintsym("not",sFBINARY, (wtruc)Fnot);
192 notsym = newsym("not", sPARSAUX, not_sym);
193
194 ret_sym = newintsym("return",sFBINARY, (wtruc)Freturn);
195 retsym = newsym("return", sPARSAUX, ret_sym);
196
197 and_sym = newintsym("and",sSBINARY, (wtruc)Sand);
198 andsym = newsym("and", sINFIX, and_sym);
199 SYMcc1(andsym) = ANDTOK;
200
201 or_sym = newintsym("or", sSBINARY, (wtruc)Sor);
202 orsym = newsym("or", sINFIX, or_sym);
203 SYMcc1(orsym) = ORTOK;
204
205 truesym = newsym("true", sSCONSTANT, true);
206 falsesym = newsym("false", sSCONSTANT, false);
207
208 nil = newreflsym("nil", sSCONSTANT);
209 arisym = newreflsym("aribas", sSYSSYMBOL);
210 usersym = newreflsym("user", sSYSSYMBOL);
211 #ifdef DEVEL
212 symbsym = newreflsym("symbol", sTYPESPEC);
213 #else
214 symbsym = nullsym;
215 #endif
216 timersym = newsymsig("timer", sSBINARY, (wtruc)Stimer, s_0);
217 gmtimsym = newsymsig("gmtime",sFBINARY, (wtruc)Fgmtime,s_01);
218 mkunbdsym = newsymsig("make_unbound", sSBINARY,
219 (wtruc)Smkunbound, s_bV);
220 symbolssym = newsymsig("symbols", sFBINARY, (wtruc)Fsymbols, s_1);
221 #ifdef TYPEIDENT
222 typeidsym = newsymsig("type_ident", sFBINARY, (wtruc)Ftypeident, s_1);
223 #endif
224 }
225 /*----------------------------------------------------------------------*/
Fequal()226 PRIVATE truc Fequal()
227 {
228 return(equal(argStkPtr-1,argStkPtr) ? true : false);
229 }
230 /*----------------------------------------------------------*/
Fnequal()231 PRIVATE truc Fnequal()
232 {
233 return(equal(argStkPtr-1,argStkPtr) ? false : true);
234 }
235 /*----------------------------------------------------------*/
equal(ptr1,ptr2)236 PRIVATE int equal(ptr1,ptr2)
237 truc *ptr1, *ptr2;
238 {
239 char *cpt1, *cpt2;
240 unsigned n, i;
241 int flg, flg2;
242
243 if(*ptr1 == *ptr2)
244 return(1);
245
246 flg = *FLAGPTR(ptr1);
247 flg2 = *FLAGPTR(ptr2);
248
249 if(flg >= fFIXNUM && flg2 >= fFIXNUM) {
250 if(flg2 > flg)
251 flg = flg2;
252 return(cmpnums(ptr1,ptr2,flg) ? 0 : 1);
253 }
254 else if(flg != flg2) {
255 if(*ptr2 != nil && *ptr1 != nil)
256 return(0);
257 else if(*ptr2 == nil) {
258 if(flg == fPOINTER && *PTARGETPTR(ptr1) == nil)
259 return(1);
260 }
261 else { /* *ptr1 == nil */
262 if(flg2 == fPOINTER && *PTARGETPTR(ptr2) == nil)
263 return(1);
264 }
265 return(0);
266 }
267 else switch(flg) { /* here flg == flg2 */
268 case fGF2NINT:
269 return(cmpnums(ptr1,ptr2,flg) ? 0 : 1);
270 case fSTRING:
271 case fBYTESTRING:
272 n = *STRLENPTR(ptr1);
273 if(n != *STRLENPTR(ptr2))
274 return(0);
275 cpt1 = STRINGPTR(ptr1);
276 cpt2 = STRINGPTR(ptr2);
277 for(i=0; i<n; i++)
278 if(*cpt1++ != *cpt2++)
279 return(0);
280 return(1);
281 case fVECTOR:
282 case fTUPLE:
283 case fRECORD:
284 n = *VECLENPTR(ptr1);
285 if(n != *VECLENPTR(ptr2))
286 return(0);
287 ptr1 = VECTORPTR(ptr1);
288 ptr2 = VECTORPTR(ptr2);
289 if(flg == fRECORD)
290 n++;
291 for(i=0; i<n; i++)
292 if(!equal(ptr1++,ptr2++))
293 return(0);
294 return(1);
295 case fPOINTER:
296 return(*PTARGETPTR(ptr1) == *PTARGETPTR(ptr2));
297 default:
298 return(0);
299 }
300 }
301 /*----------------------------------------------------------*/
Fnot()302 PRIVATE truc Fnot()
303 {
304 int val;
305
306 val = nulltest(*argStkPtr);
307 if(val > 0)
308 return(false);
309 else if(!val)
310 return(true);
311 else {
312 error(notsym,err_bool,*argStkPtr);
313 return(brkerr());
314 }
315 }
316 /*-----------------------------------------------------------*/
Sand()317 PRIVATE truc Sand()
318 {
319 truc obj;
320 int val;
321
322 obj = eval(ARG0PTR(evalStkPtr));
323 val = nulltest(obj);
324 if(!val)
325 return(false);
326 else if(val > 0) {
327 obj = eval(ARG1PTR(evalStkPtr));
328 val = nulltest(obj);
329 if(!val)
330 return(false);
331 else if(val > 0)
332 return(true);
333 }
334 error(andsym,err_bool,obj);
335 return(brkerr());
336 }
337 /*-----------------------------------------------------------*/
Sor()338 PRIVATE truc Sor()
339 {
340 truc obj;
341 int val;
342
343 obj = eval(ARG0PTR(evalStkPtr));
344 val = nulltest(obj);
345 if(val > 0)
346 return(true);
347 else if(!val) {
348 obj = eval(ARG1PTR(evalStkPtr));
349 val = nulltest(obj);
350 if(val > 0)
351 return(true);
352 else if(!val)
353 return(false);
354 }
355 error(orsym,err_bool,obj);
356 return(brkerr());
357 }
358 /*-----------------------------------------------------------*/
359 /*
360 ** returns 0 if obj represents false, 1 if true
361 ** returns aERROR in case of error
362 */
nulltest(obj)363 PRIVATE int nulltest(obj)
364 truc obj;
365 {
366 variant v;
367
368 v.xx = obj;
369 switch(v.pp.b0) { /* flag */
370 case fBOOL:
371 case fFIXNUM:
372 case fCHARACTER:
373 return(v.pp.ww ? 1 : 0);
374 case fBIGNUM: /* bignum is not zero */
375 return(1);
376 case fGF2NINT:
377 return (obj == gf2nzero ? 0 : 1);
378 default:
379 return(aERROR);
380 }
381 }
382 /*----------------------------------------------------------*/
Sinivars()383 PRIVATE truc Sinivars()
384 {
385 struct symbol *sptr;
386 truc *ptr;
387 truc obj;
388 int i,n;
389
390 ptr = TAddress(evalStkPtr);
391 WORKpush(ptr[1]); /* list of variables */
392 ARGpush(ptr[2]); /* list of initial values */
393 ptr = TAddress(argStkPtr);
394 n = *WORD2PTR(ptr); /* number of variables */
395 for(i=1; i<=n; i++) {
396 ptr = TAddress(argStkPtr) + i;
397 obj = eval(ptr);
398 ptr = TAddress(workStkPtr) + i;
399 sptr = SYMPTR(ptr);
400 *FLAGPTR(sptr) = sVARIABLE;
401 sptr->bind.t = obj;
402 }
403 ARGpop();
404 WORKpop();
405 return(varsym);
406 }
407 /*-----------------------------------------------------------*/
408 /*
409 ** Initialisierung der lokalen Konstanten (nach dem
410 ** Lesen der const-Deklaration)
411 ** Werte werden an das Symbol const_sym als fTUPLE gebunden
412 */
Lconstini(consts)413 PUBLIC int Lconstini(consts)
414 truc consts;
415 {
416 truc *ptr;
417 truc obj;
418 unsigned i, n;
419 int res = 0;
420
421 if(consts == voidsym) {
422 *constbindPtr = voidsym;
423 return(0);
424 }
425 ptr = Taddress(consts);
426 *constbindPtr = ptr[2];
427 ptr = TAddress(constbindPtr);
428 n = *WORD2PTR(ptr);
429 for(i=1; i<=n; i++) {
430 obj = eval(++ptr);
431 if(obj == breaksym) {
432 res = aERROR;
433 break;
434 }
435 else
436 res = i;
437 ptr = TAddress(constbindPtr) + i;
438 /* ptr must be evaluated again, since gc may have occurred */
439 *ptr = obj;
440 }
441 return(res);
442 }
443 /*-----------------------------------------------------------*/
444 /*
445 ** bestimmt den Wert einer lokalen Konstanten
446 ** (waehrend des Compilierens einer benutzerdefinierten Funktion)
447 */
Lconsteval(ptr)448 PUBLIC truc Lconsteval(ptr)
449 truc *ptr;
450 {
451 truc *vec;
452 unsigned n,len;
453
454 n = *WORD2PTR(ptr);
455 if(*FLAGPTR(constbindPtr) == fTUPLE) {
456 len = *VECLENPTR(constbindPtr);
457 if(n < len) {
458 vec = VECTORPTR(constbindPtr);
459 return(vec[n]);
460 }
461 }
462 error(constsym,err_case,mkfixnum(n));
463 return(zero);
464 }
465 /*-----------------------------------------------------------*/
Svarparm()466 PRIVATE truc Svarparm()
467 {
468 truc obj;
469
470 obj = eval(ARG0PTR(evalStkPtr));
471 return(obj);
472 }
473 /*-----------------------------------------------------------*/
Sassign()474 PRIVATE truc Sassign()
475 {
476 truc obj;
477 int flg;
478
479 obj = eval(ARG1PTR(evalStkPtr));
480 flg = Tflag(obj);
481 if(flg <= fVECTLIKE1 && flg >= fRECORD) {
482 WORKpush(obj);
483 if(flg < fCONSTLIT) { /* fRECORD or fVECTOR */
484 obj = mkarrcopy(workStkPtr);
485 }
486 else { /* flg == fSTRING || flg == fBYTESTRING */
487 obj = mkcopy(workStkPtr);
488 }
489 WORKpop();
490 }
491 return(Lvalassign(ARG0PTR(evalStkPtr),obj));
492 }
493 /*-----------------------------------------------------------*/
494 /*
495 ** Moegliche lvals sind entweder Symbole mit den flags
496 ** fSYMBOL (globales Symbol)
497 ** fLSYMBOL (lokales Symbol)
498 ** fRSYMBOL (Referenz auf Symbol [global oder lokal] bei var-Parametern)
499 ** sowie Array-Elemente, Sub-Arrays, Record-Felder, Pointer-Referenzen
500 **
501 ** In *pvptr wird entweder ein Pointer auf die bind-Zelle eines Symbols
502 ** abgelegt (Rueckgebewert vBOUND oder vUNBOUND)
503 ** oder ein Pointer ptr auf eine Funktion zur Beschreibung des lvals:
504 ** Rueckgabewert vARRELE:
505 ** ptr[0] = arr_sym, ptr[1] = Array, ptr[2] = Index
506 ** vSUBARRAY:
507 ** ptr[0] = subarrsym, ptr[1] = Array, ptr[2] = Paar mit Subarray-Grenzen
508 ** vRECFIELD:
509 ** ptr[0] = rec_sym, ptr[1] = Record, ptr[2] = field
510 ** vPOINTREF:
511 ** ptr[0] = derefsym, ptr[1] = Pointer
512 ** vVECTOR:
513 ** ptr[0] = vectorsym, ptr[1] = len, ptr[2] = ele0, ptr[3] = ele1, ..
514 ** Die Argumente in ptr[1] bzw. ptr[2] sind jeweils unausgewertet.
515 */
Lvaladdr(ptr,pvptr)516 PUBLIC int Lvaladdr(ptr,pvptr)
517 truc *ptr;
518 trucptr *pvptr;
519 {
520 int flag;
521
522 flag = *FLAGPTR(ptr);
523 if(flag == fLSYMBOL) {
524 *pvptr = LSYMBOLPTR(ptr);
525 return(vBOUND);
526 }
527 else if(flag == fSYMBOL) {
528 return(symbaddr(ptr,pvptr));
529 }
530 else if(flag == fRSYMBOL) {
531 ptr = LSYMBOLPTR(ptr);
532 if((flag = *FLAGPTR(ptr)) == fSYMBOL)
533 return(symbaddr(ptr,pvptr));
534 else if(flag == fLRSYMBOL) {
535 *pvptr = LRSYMBOLPTR(ptr);
536 return(vBOUND);
537 }
538 /* else fall through */
539 }
540 if(flag >= fSPECIAL1 && flag <= fBUILTINn) {
541 /* array access or record access or pointer reference or vector*/
542 *pvptr = ptr = TAddress(ptr);
543 if(*ptr == arr_sym) {
544 return(vARRELE);
545 }
546 else if(*ptr == subarrsym) {
547 return(vSUBARRAY);
548 }
549 else if(*ptr == rec_sym) {
550 return(vRECFIELD);
551 }
552 else if(*ptr == derefsym) {
553 return(vPOINTREF);
554 }
555 else if(*ptr == vectorsym) {
556 return(vVECTOR);
557 }
558 }
559 /* else aERROR */
560 *pvptr = NULL;
561 return(aERROR);
562 }
563 /*-----------------------------------------------------------*/
564 /*
565 ** stripped down version of Lvaladdr
566 */
is_lval(ptr)567 PUBLIC int is_lval(ptr)
568 truc *ptr;
569 {
570 struct symbol *sptr;
571 int flag;
572
573 flag = *FLAGPTR(ptr);
574 if(flag == fLSYMBOL) {
575 return(vBOUND);
576 }
577 else if(flag == fSYMBOL) {
578 goto symbol;
579 }
580 else if(flag == fRSYMBOL) {
581 ptr = LSYMBOLPTR(ptr);
582 if((flag = *FLAGPTR(ptr)) == fSYMBOL)
583 goto symbol;
584 else if(flag == fLRSYMBOL) {
585 return(vBOUND);
586 }
587 /* else fall through */
588 }
589 if(flag == fBUILTIN2 || flag == fSPECIAL2 || flag == fSPECIAL1) {
590 /* array access or record access or pointer reference */
591 ptr = TAddress(ptr);
592 if(*ptr == arr_sym) {
593 return(vARRELE);
594 }
595 else if(*ptr == subarrsym) {
596 return(vSUBARRAY);
597 }
598 else if(*ptr == rec_sym) {
599 return(vRECFIELD);
600 }
601 else if(*ptr == derefsym) {
602 return(vPOINTREF);
603 }
604 /* else fall through */
605 }
606 /* else aERROR */
607 return(aERROR);
608 symbol:
609 sptr = SYMPTR(ptr);
610 switch(*FLAGPTR(sptr)) {
611 case sUNBOUND:
612 return(vUNBOUND);
613 case sVARIABLE:
614 return(vBOUND);
615 case sCONSTANT:
616 case sSCONSTANT:
617 return(vCONST);
618 default:
619 break;
620 }
621 return(aERROR);
622 }
623 /*-----------------------------------------------------------*/
624 /*
625 ** Legt in *pvptr die Adresse, in der der Wert des Symbols
626 ** gespeichert ist, falls es sich um eine Variable oder ein
627 ** ungebundenes Symbol handelt
628 ** Return-Wert:
629 ** vBOUND, falls Bindung vorhanden,
630 ** vUNBOUND, falls noch ungebunden,
631 ** vCONST, falls Konstante
632 ** aERROR falls keine Variable
633 */
symbaddr(ptr,pvptr)634 PRIVATE int symbaddr(ptr,pvptr)
635 truc *ptr;
636 trucptr *pvptr;
637 {
638 struct symbol *sptr;
639
640 sptr = SYMPTR(ptr);
641 switch(*FLAGPTR(sptr)) {
642 case sUNBOUND:
643 *FLAGPTR(sptr) = sVARIABLE;
644 *pvptr = &(sptr->bind.t);
645 return(vUNBOUND);
646 case sVARIABLE:
647 *pvptr = &(sptr->bind.t);
648 return(vBOUND);
649 case sCONSTANT:
650 case sSCONSTANT:
651 *pvptr = NULL;
652 return(vCONST);
653 default:
654 *pvptr = NULL;
655 return(aERROR);
656 }
657 }
658 /*-----------------------------------------------------------*/
Lvalassign(ptr,obj)659 PUBLIC truc Lvalassign(ptr,obj)
660 truc *ptr;
661 truc obj;
662 {
663 truc *vptr;
664 truc *ptr1, *work0ptr;
665 truc ele;
666 int flg, ret, len, k;
667
668 if(obj == nil)
669 return(Pdispose(ptr));
670 ret = Lvaladdr(ptr,&vptr);
671 if(ret == vBOUND || ret == vUNBOUND) {
672 flg = *FLAGPTR(vptr);
673 switch(flg) {
674 case fRECORD:
675 return(fullrecassign(vptr,obj));
676 case fPOINTER:
677 default:
678 /******* type check unvollstaendig **********/
679 return(*vptr = obj);
680 }
681 }
682 /* else */
683 WORKpush(obj);
684 switch(ret) {
685 case vARRELE:
686 case vSUBARRAY:
687 ARGpush(vptr[1]);
688 ARGpush(vptr[2]);
689 argStkPtr[-1] = eval(argStkPtr-1);
690 argStkPtr[0] = eval(argStkPtr);
691 if(ret == vARRELE)
692 obj = arrassign(argStkPtr-1,*workStkPtr);
693 else
694 obj = subarrassign(argStkPtr-1,*workStkPtr);
695 ARGnpop(2);
696 break;
697 case vRECFIELD:
698 ARGpush(vptr[1]);
699 *argStkPtr = eval(argStkPtr);
700 obj = recfassign(argStkPtr,vptr[2],*workStkPtr);
701 /* vptr[2] = field */
702 ARGpop();
703 break;
704 case vPOINTREF:
705 ARGpush(vptr[1]);
706 *argStkPtr = eval(argStkPtr);
707 flg = *FLAGPTR(argStkPtr);
708 if(flg == fPOINTER) {
709 ptr1 = TAddress(argStkPtr);
710 if(ptr1[2] == nil) {
711 error(assignsym,err_nil,voidsym);
712 obj = brkerr();
713 }
714 else {
715 obj = fullrecassign(ptr1+2,*workStkPtr);
716 }
717 }
718 else {
719 obj = brkerr();
720 }
721 ARGpop();
722 break;
723 case vVECTOR:
724 if(*FLAGPTR(workStkPtr) != fVECTOR) {
725 error(assignsym,err_vect,obj);
726 goto errexit;
727 }
728 len = *WORD2PTR(vptr+1);
729 if(len != *VECLENPTR(workStkPtr)) {
730 error(assignsym,"vectors must have same length",mkfixnum(len));
731 goto errexit;
732 }
733 work0ptr = workStkPtr;
734 for(k=0; k<len; k++)
735 WORKpush(vptr[k+2]);
736 for(k=0; k<len; k++) {
737 ele = *(VECTORPTR(work0ptr)+k);
738 ele = Lvalassign(work0ptr+k+1,ele);
739 if(ele == breaksym)
740 goto errexit;
741 }
742 workStkPtr = work0ptr;
743 break;
744 case vCONST:
745 error(assignsym,err_sym2,*ptr);
746 goto errexit;
747 default:
748 error(assignsym,err_vsym,*ptr);
749 errexit:
750 obj = brkerr();
751 } /* end switch */
752 WORKpop();
753 return(obj);
754 }
755 /*-----------------------------------------------------------*/
Swhile()756 PUBLIC truc Swhile()
757 {
758 truc *ptr, *arr;
759 truc res;
760 int val;
761 int i, n;
762
763 res = eval(ARG0PTR(evalStkPtr)); /* boolean expression */
764 val = nulltest(res);
765 if(val <= 0)
766 return(voidsym);
767
768 ptr = TAddress(evalStkPtr);
769 n = *WORD2PTR(ptr);
770 ARGpush(ptr[1]); /* boolean expression */
771 arr = workStkPtr + 1;
772 for(i=2; i<=n; i++) {
773 WORKpush(ptr[i]);
774 }
775 while(val > 0) {
776 for(res=voidsym, ptr=arr, i=0; ++i<n && res != breaksym; )
777 res = eval(ptr++);
778 if((res == breaksym) && (*brkmodePtr != lpcontsym)) {
779 if(*brkmodePtr == lpbrksym)
780 res = voidsym;
781 goto cleanup;
782 }
783 res = eval(argStkPtr);
784 val = nulltest(res);
785 }
786 res = voidsym;
787 cleanup:
788 workStkPtr = arr - 1;
789 ARGpop();
790 return(res);
791 }
792 /*-----------------------------------------------------------*/
Sfor()793 PUBLIC truc Sfor()
794 {
795 struct fornode *fptr;
796 struct symbol *sptr;
797 truc *runvar;
798 truc *ptr, *arr;
799 truc *argptr0, *saveptr0;
800 truc obj;
801 truc res = voidsym;
802
803 word2 *x, *y, *lauf, *inc, *zaehler;
804 word4 anz;
805 int flg;
806 int i, n, n0, m, slen, bodylen, inclen, zlen, rlen;
807 int sign, sign1;
808 int toolong = 0;
809
810 fptr = (struct fornode *)TAddress(evalStkPtr);
811 bodylen = fptr->len - 4;
812 ptr = &(fptr->runvar);
813 if((flg = *FLAGPTR(ptr)) == fSYMBOL) {
814 sptr = SYMPTR(ptr);
815 *FLAGPTR(sptr) = sVARIABLE;
816 runvar = &(sptr->bind.t);
817 }
818 else if(flg == fLSYMBOL) {
819 runvar = LSYMBOLPTR(ptr);
820 }
821 else {
822 error(forsym,err_case,mkfixnum(flg));
823 return(brkerr());
824 }
825 argptr0 = argStkPtr;
826 saveptr0 = saveStkPtr;
827 arr = workStkPtr + 1;
828 ARGpush(fptr->inc);
829 ARGpush(fptr->end);
830 ARGpush(fptr->start);
831 ptr = &(fptr->body0);
832 for(i=0; i<bodylen; i++)
833 WORKpush(*ptr++);
834 argStkPtr[-2] = eval(argStkPtr-2); /* inc */
835 argStkPtr[-1] = eval(argStkPtr-1); /* end */
836 argStkPtr[0] = eval(argStkPtr); /* start */
837 if(chkints(forsym,argStkPtr-2,3) == aERROR) {
838 res = brkerr();
839 goto cleanup;
840 }
841 /* Berechnung der Anzahl der Iterationen */
842 argStkPtr[-1] = addints(argStkPtr-1,-1); /* end - start */
843 n = bigref(argStkPtr-1,&x,&sign);
844 inclen = bigref(argStkPtr-2,&y,&sign1);
845 if(n == 0)
846 anz = 1;
847 else if(sign1 != sign) {
848 goto cleanup; /* leere for-Schleife */
849 }
850 else if(inclen == 0) {
851 error(forsym,err_div,voidsym);
852 goto cleanup;
853 }
854 else {
855 n = divbig(x,n,y,inclen,AriBuf,&rlen,AriScratch);
856 if(n > 2) {
857 toolong = 1;
858 }
859 else {
860 anz = big2long(AriBuf,n);
861 if(anz < 0xFFFFFFFF) {
862 anz++;
863 }
864 else {
865 toolong = 1;
866 }
867 }
868 if(toolong) {
869 zaehler = (word2*)SAVEspace(n/2+2);
870 if(zaehler) {
871 cpyarr(AriBuf,n,zaehler);
872 zlen = incarr(zaehler,n,1);
873 }
874 else {
875 error(forsym,err_savstk,voidsym);
876 goto cleanup;
877 }
878 }
879 }
880 n0 = bigref(argStkPtr,&x,&sign); /* start */
881 m = (n0 < inclen ? inclen : n0) + 3;
882 slen = (m + inclen)/2 + 2; /* unit of SaveStack is word4 */
883 lauf = (word2 *)SAVEspace(slen);
884 if(lauf) {
885 cpyarr(x,n0,lauf);
886 inc = lauf + m;
887 cpyarr(y,inclen,inc);
888 }
889 else {
890 error(forsym,err_savstk,voidsym);
891 goto cleanup;
892 }
893 if(!toolong) {
894 while(anz) {
895 *runvar = mkint(sign,lauf,n0);
896 obj = arreval(arr,bodylen);
897 if((obj == breaksym) && (*brkmodePtr != lpcontsym)) {
898 if(*brkmodePtr != lpbrksym)
899 res = obj;
900 /* else res = voidsym; */
901 break;
902 }
903 n0 = increment(lauf,n0,&sign,inc,inclen,sign1);
904 anz--;
905 }
906 }
907 else {
908 while(zlen) {
909 *runvar = mkint(sign,lauf,n0);
910 obj = arreval(arr,bodylen);
911 if((obj == breaksym) && (*brkmodePtr != lpcontsym)) {
912 if(*brkmodePtr != lpbrksym)
913 res = obj;
914 /* else res = voidsym; */
915 break;
916 }
917 n0 = increment(lauf,n0,&sign,inc,inclen,sign1);
918 zlen = decarr(zaehler,zlen,1);
919 }
920 }
921 cleanup:
922 saveStkPtr = saveptr0;
923 argStkPtr = argptr0;
924 workStkPtr = arr - 1;
925 return(res);
926 }
927 /*-----------------------------------------------------------*/
increment(x,n,signptr,inc,inclen,s)928 PRIVATE int increment(x,n,signptr,inc,inclen,s)
929 word2 *x, *inc;
930 int n, inclen;
931 int *signptr;
932 int s;
933 {
934 int cmp;
935
936 if(*signptr == s)
937 return(addarr(x,n,inc,inclen));
938 /* else */
939 cmp = cmparr(x,n,inc,inclen);
940 if(cmp > 0)
941 return(subarr(x,n,inc,inclen));
942 else if(cmp < 0) {
943 *signptr = s;
944 return(sub1arr(x,n,inc,inclen));
945 }
946 else {
947 *signptr = 0;
948 return(0);
949 }
950 }
951 /*-----------------------------------------------------------*/
952 /*
953 ** Bestimmt in einem if-elsif-...-else-Ausdruck durch Auswertung
954 ** der Bedingungen, welcher Zweig ausgewertet werden muss
955 ** und legt diesen in *evalStkPtr ab
956 */
Sifaux()957 PUBLIC void Sifaux()
958 {
959 truc *ptr;
960 int val;
961 int i, n;
962
963 ptr = TAddress(evalStkPtr);
964 n = *WORD2PTR(ptr);
965 for(i=1; i<n; i+=2) {
966 val = nulltest(eval(ptr+i));
967 if(val > 0) {
968 *evalStkPtr = *ARGNPTR(evalStkPtr,i);
969 return;
970 }
971 else if(val == 0) {
972 ptr = TAddress(evalStkPtr);
973 /* this may have been changed */
974 }
975 else { /* val == aERROR */
976 *evalStkPtr = brkerr();
977 return;
978 }
979 }
980 *evalStkPtr = *ARGNPTR(evalStkPtr,n-1); /* else statement */
981 return;
982 }
983 /*-----------------------------------------------------------*/
Freturn()984 PRIVATE truc Freturn()
985 {
986 if((*brkbindPtr = *argStkPtr) == breaksym)
987 *brkmodePtr = errsym;
988 else {
989 *brkmodePtr = retsym;
990 }
991 return(breaksym);
992 }
993 /*-----------------------------------------------------------*/
Sexit()994 PUBLIC truc Sexit()
995 {
996 *brkmodePtr = exitsym;
997 return(breaksym);
998 }
999 /*-----------------------------------------------------------*/
Slpbreak()1000 PRIVATE truc Slpbreak()
1001 {
1002 *brkmodePtr = lpbrksym;
1003 return(breaksym);
1004 }
1005 /*-----------------------------------------------------------*/
Slpcont()1006 PRIVATE truc Slpcont()
1007 {
1008 *brkmodePtr = lpcontsym;
1009 return(breaksym);
1010 }
1011 /*-----------------------------------------------------------*/
brkerr()1012 PUBLIC truc brkerr()
1013 {
1014 *brkmodePtr = errsym;
1015 return(breaksym);
1016 }
1017 /*-----------------------------------------------------------*/
Stimer()1018 PRIVATE truc Stimer()
1019 {
1020 return mkinum(timer());
1021 }
1022 /*----------------------------------------------------------*/
Fgmtime(argn)1023 PRIVATE truc Fgmtime(argn)
1024 int argn;
1025 {
1026 int tim[6];
1027 long secs;
1028 char *str;
1029 word4 x,y;
1030
1031 secs = datetime(tim);
1032
1033 if(argn == 1 && *argStkPtr == zero) {
1034 return mkinum(secs);
1035 }
1036 /* else */
1037 x = tim[0] + 1900;
1038 y = tim[1] + 1;
1039 str = OutBuf;
1040 str += s2form(str,"~04D:~02D:", (wtruc)x,(wtruc)y);
1041 x = tim[2];
1042 y = tim[3];
1043 str += s2form(str,"~02D:~02D:",(wtruc)x,(wtruc)y);
1044 x = tim[4];
1045 y = tim[5];
1046 s2form(str,"~02D:~02D",(wtruc)x,(wtruc)y);
1047
1048 return mkstr(OutBuf);
1049 }
1050 /*----------------------------------------------------------*/
Smkunbound()1051 PRIVATE truc Smkunbound()
1052 {
1053 truc *ptr;
1054 int flg;
1055
1056 ptr = ARG0PTR(evalStkPtr);
1057 if((flg = *FLAGPTR(ptr)) != fSYMBOL) {
1058 /** arrays of symbols? **/
1059 error(mkunbdsym,err_gsym,(flg==fLSYMBOL ? voidsym : *ptr));
1060 return(false);
1061 }
1062 else if(*ptr == usersym) {
1063 return(unbinduser());
1064 }
1065 else if(*SYMFLAGPTR(ptr) >= sFBINARY) {
1066 error(mkunbdsym,err_bltin,*ptr);
1067 return(false);
1068 }
1069 else
1070 return(unbindsym(ptr));
1071 }
1072 /*----------------------------------------------------------*/
1073 /*
1074 ** unbind all user defined symbols
1075 */
unbinduser()1076 PUBLIC truc unbinduser()
1077 {
1078 truc *ptr;
1079 truc obj;
1080 int flg;
1081 int i = 0;
1082
1083 while((ptr = nextsymptr(i++))) {
1084 obj = symbobj(ptr);
1085 if(!inpack(obj,usersym))
1086 continue;
1087 flg = *FLAGPTR(ptr);
1088 if(flg >= sVARIABLE && flg < sINTERNAL) {
1089 unbindsym(ptr);
1090 }
1091 else
1092 continue;
1093 }
1094 return(true);
1095 }
1096 /*----------------------------------------------------------*/
1097 /*
1098 ** unbinds symbol *ptr
1099 ** (used also by globtypedef [file parser.c] in case of error)
1100 ** ! if *ptr is not a symbol, this may have bad consequences !
1101 */
unbindsym(ptr)1102 PUBLIC truc unbindsym(ptr)
1103 truc *ptr;
1104 {
1105 struct symbol *sptr;
1106
1107 sptr = SYMPTR(ptr);
1108 sptr->bind.t = zero;
1109 *FLAGPTR(sptr) = sUNBOUND;
1110 return(true);
1111 }
1112 /*----------------------------------------------------------*/
Fsymbols()1113 PRIVATE truc Fsymbols()
1114 {
1115 truc *arr, *ptr;
1116 truc vec, pack, obj;
1117 int flg;
1118 int i = 0;
1119 int count = 0;
1120
1121 pack = *argStkPtr;
1122 /***
1123 if(pack != usersym && pack != arisym)
1124 pack = usersym;
1125 ***/
1126 arr = workStkPtr + 1;
1127 while((ptr = nextsymptr(i++))) {
1128 obj = symbobj(ptr);
1129 if(!inpack(obj,pack))
1130 continue;
1131 flg = *FLAGPTR(ptr);
1132 if(flg >= sVARIABLE && flg < sINTERNAL) {
1133 WORKpush(obj);
1134 count++;
1135 }
1136 else
1137 continue;
1138 }
1139 sortarr(arr,count,symbcmp);
1140 vec = mkvect0(count);
1141 ptr = VECTOR(vec);
1142 while(--count >= 0)
1143 *ptr++ = WORKretr();
1144 return(vec);
1145 }
1146 /*----------------------------------------------------------*/
symbcmp(ptr1,ptr2)1147 PRIVATE int symbcmp(ptr1,ptr2)
1148 truc *ptr1, *ptr2;
1149 {
1150 return(strcmp(SYMNAMEPTR(ptr2),SYMNAMEPTR(ptr1)));
1151 }
1152 /*----------------------------------------------------------*/
Ftypeident()1153 PRIVATE truc Ftypeident()
1154 {
1155 int flag, flg1, val;
1156 truc obj, symb;
1157
1158 flag = *FLAGPTR(argStkPtr);
1159
1160 if(flag==1) {
1161 flg1 = *SYMFLAGPTR(argStkPtr);
1162 switch(flg1) {
1163 case sFUNCTION:
1164 case sVFUNCTION:
1165 case sFBINARY:
1166 case sSBINARY:
1167 symb = funcsym;
1168 break;
1169 case sTYPEDEF:
1170 *argStkPtr = *SYMBINDPTR(argStkPtr);
1171 flag = *FLAGPTR(argStkPtr);
1172 goto weiter;
1173 case sPARSAUX:
1174 symb = *argStkPtr;
1175 if(symb == funcsym || symb == procsym)
1176 symb = funcsym;
1177 else
1178 symb = voidsym;
1179 break;
1180 case sTYPESPEC:
1181 symb = *argStkPtr;
1182 break;
1183 case sSCONSTANT:
1184 symb = *argStkPtr;
1185 if(symb == nil)
1186 symb = pointrsym;
1187 break;
1188 default:
1189 symb = voidsym;
1190 break;
1191 }
1192 goto ausgang;
1193 }
1194 weiter:
1195 switch(flag) {
1196 case fBOOL:
1197 symb = boolsym;
1198 break;
1199 case fFIXNUM:
1200 case fBIGNUM:
1201 symb = integsym;
1202 break;
1203 case fGF2NINT:
1204 symb = gf2nintsym;
1205 break;
1206 case fCHARACTER:
1207 symb = charsym;
1208 break;
1209 case fSTRING:
1210 symb = stringsym;
1211 break;
1212 case fBYTESTRING:
1213 symb = bstringsym;
1214 break;
1215 case fVECTOR:
1216 symb = arraysym;
1217 break;
1218 case fSTREAM:
1219 symb = filesym;
1220 break;
1221 case fSTACK:
1222 symb = stacksym;
1223 break;
1224 case fRECORD:
1225 symb = recordsym;
1226 break;
1227 case fPOINTER:
1228 symb = pointrsym;
1229 break;
1230 case fBUILTIN1:
1231 obj = *OPNODEPTR(argStkPtr);
1232 if(obj == mkrecsym) {
1233 symb = recordsym;
1234 break;
1235 }
1236 /* else fall through */
1237 default:
1238 if ((flag & fFLTOBJ) == fFLTOBJ)
1239 symb = realsym;
1240 else
1241 symb = errsym;
1242 break;
1243 }
1244 ausgang:
1245 val = typevalue(symb);
1246 return mkinum(val);
1247 }
1248 /*----------------------------------------------------------*/
typevalue(symb)1249 PRIVATE int typevalue(symb)
1250 truc symb;
1251 {
1252 int val;
1253
1254 if(symb == boolsym) {
1255 val = 1;
1256 }
1257 else if(symb == integsym) {
1258 val = 2;
1259 }
1260 else if(symb == gf2nintsym) {
1261 val = 3;
1262 }
1263 else if(symb == realsym) {
1264 val = 4;
1265 }
1266 else if(symb == charsym) {
1267 val = 10;
1268 }
1269 else if(symb == stringsym) {
1270 val = 11;
1271 }
1272 else if(symb == bstringsym) {
1273 val = 12;
1274 }
1275 else if(symb == arraysym) {
1276 val = 20;
1277 }
1278 else if(symb == recordsym) {
1279 val = 21;
1280 }
1281 else if(symb == pointrsym) {
1282 val = 22;
1283 }
1284 else if(symb == stacksym) {
1285 val = 23;
1286 }
1287 else if(symb == filesym) {
1288 val = 30;
1289 }
1290 else if(symb == funcsym) {
1291 val = 40;
1292 }
1293 else if(symb == voidsym) {
1294 val = 0;
1295 }
1296 else
1297 val = -1;
1298 return val;
1299 }
1300 /*********************************************************************/
1301