1 /********************************************************************
2 This file is part of the abs 0.907 distribution.  abs is a spreadsheet
3 with graphical user interface.
4 
5 Copyright (C) 1998-2001  Andr� Bertin (Andre.Bertin@ping.be)
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 if in the same spirit as version 2.
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 Concact: abs@pi.be
22          http://home.pi.be/bertin/abs.shtml
23 
24 *********************************************************************/
25 
26 
27 
28 
29 
30 
31 
32 
33 
34 
35 
36 
37 
38 
39 
40 
41 
42 
43 
44 
45 
46 
47 
48 
49 
50 
51 
52 
53 #include <stdio.h>
54 #include "interpret.h"
55 #include "y.tab.h"
56 #include "oper.h"
57 #include "symboltable.h"
58 #include "libfct.h"
59 #include "properties.h"
60 #include "project.h"
61 #include "io.h"
62 #include "abv.h"
63 
64 static nodeType ***argnode = NULL;
65 static obj **argu = NULL;
66 static obj **arguref = NULL;
67 static int *nargnode = NULL;
68 
69 static int routinedeep = -1;
70 static int initconst = 0;
71 
72 static int dobreak = 0;
73 
74 void
cb_Break()75 cb_Break ()
76 {
77   dobreak = 1;
78   fprintf (stderr, "Break!\n");
79   return;
80 }
81 
82 void
resetbreak()83 resetbreak ()
84 {
85   dobreak = 0;
86   return;
87 }
88 
89 
90 int
settype(nodeType * p)91 settype (nodeType * p)
92 {
93 
94   if (p != NULL)
95     {
96       int type = p->opr.oper.rec.i;
97 
98       if (type == NEW)
99 	{
100 	  symbol_settype (type, 1);
101 	}
102       else
103 	{
104 	  symbol_settype (type, 0);
105 	}
106     }
107   else
108     symbol_settype (VARIANT, 0);
109   return 0;
110 }
111 
112 static int scope = 1;
113 int
setscope(int a)114 setscope (int a)
115 {
116   scope = a;
117   return 0;
118 }
119 
120 int
setcstscope(nodeType * p)121 setcstscope (nodeType * p)
122 {
123 
124   if (p != NULL)
125     {
126       int sc = p->opr.oper.rec.i;
127 
128       if (sc == PRIVATE)
129 	{
130 	  scope = 4;
131 	}
132       else
133 	{
134 	  scope = 2;
135 	}
136     }
137   else
138     symbol_settype (VARIANT, 0);
139   return 0;
140 }
141 
142 
143 
144 static int Transmit = BYREF;
145 static int
settransmit(nodeType * p)146 settransmit (nodeType * p)
147 {
148 
149   if (p != NULL)
150     {
151       int mode = p->opr.oper.rec.i;
152 
153       if (mode == BYVAL)
154 	{
155 	  Transmit = BYVAL;
156 	}
157       else
158 	{
159 	  Transmit = BYREF;
160 	}
161     }
162   else
163     Transmit = BYREF;
164   return 0;
165 }
166 
167 static char *
setfilemode(nodeType * p)168 setfilemode (nodeType * p)
169 {
170   char *ret = "rw";
171   int mode = p->opr.oper.rec.i;
172 
173   if (mode == APPEND)
174     ret = "a+";
175   if (mode == BINARY)
176     ret = "r+b";
177   if (mode == INPUT)
178     ret = "r";
179   if (mode == OUTPUT)
180     ret = "w";
181   if (mode == RANDOM)
182     ret = "r+";
183 
184   return ret;
185 }
186 
187 
188 
189 
190 obj
exdecl(nodeType * p)191 exdecl (nodeType * p)
192 {
193   obj o;
194   if (dobreak)
195     return o;
196   if (!p)
197     return o;
198   switch (p->type)
199     {
200     case typeCon:
201       {
202 	return p->con.value;
203       }
204     case typeMember:
205       {
206 	o = p->member.member;
207 	if (o.type == MEMBER)
208 	  {
209 	    o.type = classname2classpos (o.label);
210 	    if (o.type == -1)
211 	      o.type = MEMBER;
212 	  }
213 	return o;
214 
215 
216 
217       }
218     case typeId:
219       {
220 	Idval *val;
221 	if (p->id.id.type == BUILTINFUNCTION)
222 	  {
223 	    o = check4property (p->id.id);
224 	    if (o.type != BUILTINFUNCTION)
225 	      return o;
226 	  }
227 	if (p->id.id.type == PROPERTY)
228 	  {
229 	    o = property2obj (p->id.id);
230 	    return o;
231 	  }
232 
233 	val = look (p->id.id.label, 1);
234 
235 	o.rec.s = (char *) val;
236 	o.type = p->id.id.type;
237 	o.label = p->id.id.label;
238 
239 	return o;
240       }
241     case typeOpr1:
242       switch (p->opr1.oper.rec.i)
243 	{
244 	case UMINUS:
245 	  return mkuminus (exdecl (p->opr1.op1));
246 
247 	}
248     case typeOpr2:
249       switch (p->opr2.oper.rec.i)
250 	{
251 	case '=':
252 	  {
253 	    obj o1 = exdecl (p->opr2.op2);
254 	    obj o0 = exdecl (p->opr2.op1);
255 	    o = mkassign (o0, o1);
256 	    freenocstobj (o1);
257 	    return o;
258 	  }
259 	case '+':
260 	  {
261 	    obj o1, o2, o3;
262 	    o1 = exdecl (p->opr2.op1);
263 	    o2 = exdecl (p->opr2.op2);
264 	    o3 = mksum (o1, o2);
265 	    freenocstobj (o1);
266 	    freenocstobj (o2);
267 	    return o3;
268 	  }
269 	case '-':
270 	  {
271 	    obj o1, o2, o3;
272 	    o1 = exdecl (p->opr2.op1);
273 	    o2 = exdecl (p->opr2.op2);
274 	    o3 = mkdiff (o1, o2);
275 	    freenocstobj (o1);
276 	    freenocstobj (o2);
277 	    return o3;
278 	  }
279 	case '*':
280 	  {
281 	    obj o1, o2, o3;
282 	    o1 = exdecl (p->opr2.op1);
283 	    o2 = exdecl (p->opr2.op2);
284 	    o3 = mkmult (o1, o2);
285 	    freenocstobj (o1);
286 	    freenocstobj (o2);
287 	    return o3;
288 	  }
289 	case '/':
290 	  {
291 	    obj o1, o2, o3;
292 	    o1 = exdecl (p->opr2.op1);
293 	    o2 = exdecl (p->opr2.op2);
294 	    o3 = mkdiv (o1, o2);
295 	    freenocstobj (o1);
296 	    freenocstobj (o2);
297 	    return o3;
298 	  }
299 	case MOD:
300 	  {
301 	    obj o1, o2, o3;
302 	    o1 = exdecl (p->opr2.op1);
303 	    o2 = exdecl (p->opr2.op2);
304 	    o3 = mkmod (o1, o2);
305 	    freenocstobj (o1);
306 	    freenocstobj (o2);
307 	    return o3;
308 	  }
309 	case '\\':
310 	  {
311 	    obj o1, o2, o3;
312 	    o1 = exdecl (p->opr2.op1);
313 	    o2 = exdecl (p->opr2.op2);
314 	    o3 = mkintdiv (o1, o2);
315 	    freenocstobj (o1);
316 	    freenocstobj (o2);
317 	    return o3;
318 	  }
319 	case '^':
320 	  {
321 	    obj o1, o2, o3;
322 	    o1 = exdecl (p->opr2.op1);
323 	    o2 = exdecl (p->opr2.op2);
324 	    o3 = mkpow (o1, o2);
325 	    freenocstobj (o1);
326 	    freenocstobj (o2);
327 	    return o3;
328 	  }
329 
330 	}
331 
332     case typeOpr:
333       switch (p->opr.oper.rec.i)
334 	{
335 	case NEWLINE:
336 	  {
337 	    int i;
338 	    int nops = p->opr.nops;
339 	    for (i = 0; i < nops; i++)
340 	      {
341 		exdecl (p->opr.op[i]);
342 	      }
343 	    return o;
344 	  }
345 	case IDLIST:
346 	  {
347 	    int nops = p->opr.nops;
348 	    Idval *val;
349 	    nodeType *pp;
350 	    if (nops == 5)
351 	      {
352 		exdecl (p->opr.op[0]);
353 		settype (p->opr.op[3]);
354 		pp = p->opr.op[1];
355 		val = look (pp->id.id.label, scope);
356 		symbol_settype (VARIANT, 0);
357 		if (initconst && p->opr.op[4] != NULL)
358 		  {
359 		    obj o;
360 		    o.rec.s = (char *) val;
361 		    pp = p->opr.op[4];
362 		    o1eqo2 (&o, exdecl (pp));
363 		    val->protect = 1;
364 		  }
365 	      }
366 	    else
367 	      {
368 		settype (p->opr.op[2]);
369 		pp = p->opr.op[0];
370 		val = look (pp->id.id.label, scope);
371 		symbol_settype (VARIANT, 0);
372 		if (initconst && p->opr.op[3] != NULL)
373 		  {
374 		    obj o;
375 		    o.rec.s = (char *) val;
376 		    pp = p->opr.op[3];
377 		    o1eqo2 (&o, exdecl (pp));
378 		    val->protect = 1;
379 		  }
380 
381 	      }
382 
383 
384 	    return o;
385 	  }
386 	case CONST:
387 	  {
388 	    int nops = p->opr.nops;
389 
390 	    initconst = 1;
391 	    if (nops == 2)
392 	      {
393 		nodeType *pp = p->opr.op[0];
394 		int sc = pp->opr.oper.rec.i;
395 		if (sc == PUBLIC)
396 		  setscope (2);
397 		else
398 		  setscope (4);
399 		exdecl (p->opr.op[1]);
400 	      }
401 	    else
402 	      {
403 		setscope (4);
404 		exdecl (p->opr.op[0]);
405 	      }
406 
407 	    setscope (1);
408 	    initconst = 0;
409 	    return o;
410 	  }
411 	case DIM:
412 	  {
413 
414 	    setscope (2);
415 	    exdecl (p->opr.op[0]);
416 	    setscope (1);
417 	    return o;
418 	  }
419 	case PUBLIC:
420 	  {
421 	    setscope (4);
422 	    exdecl (p->opr.op[0]);
423 	    setscope (1);
424 	    return o;
425 	  }
426 	case PRIVATE:
427 	  {
428 	    setscope (2);
429 	    exdecl (p->opr.op[0]);
430 	    setscope (1);
431 	    return o;
432 	  }
433 	case '.':
434 	  {
435 	    switch (p->opr.nops)
436 	      {
437 	      case 1:
438 		{
439 		}
440 	      case 2:
441 		{
442 		  return mkderef (exdecl (p->opr.op[0]), exdecl (p->opr.op[1]));
443 		}
444 	      }
445 	    return o;
446 
447 	  }
448 	}
449     }
450   return o;
451 }
452 
453 
454 static nodeType *selexpr[20];
455 static int caseelse[20];
456 static int nsel = -1;
457 
458 
459 obj
exint(nodeType * p)460 exint (nodeType * p)
461 {
462   obj o;
463 
464 
465 
466 
467   if (!p)
468     return o;
469   switch (p->type)
470     {
471     case typeCon:
472       {
473 	return p->con.value;
474       }
475     case typeMember:
476       {
477 	o = p->member.member;
478 	if (o.type == MEMBER)
479 	  {
480 	    o.type = classname2classpos (o.label);
481 	    if (o.type == -1)
482 	      o.type = MEMBER;
483 	  }
484 	return o;
485 
486 
487 
488       }
489     case typeId:
490       {
491 	Idval *val;
492 	if (p->id.id.type == BUILTINFUNCTION)
493 	  {
494 	    o = check4property (p->id.id);
495 	    if (o.type != BUILTINFUNCTION)
496 	      return o;
497 	  }
498 	if (p->id.id.type == PROPERTY)
499 	  {
500 	    o = property2obj (p->id.id);
501 	    return o;
502 	  }
503 
504 	val = look (p->id.id.label, scope);
505 
506 	o.rec.s = (char *) val;
507 	o.type = p->id.id.type;
508 	o.label = p->id.id.label;
509 
510 	return o;
511       }
512     case typeOpr1:
513 
514       switch (p->opr1.oper.rec.i)
515 	{
516 	case UMINUS:
517 	  return mkuminus (exint (p->opr1.op1));
518 
519 	}
520     case typeOpr2:
521 
522       switch (p->opr2.oper.rec.i)
523 	{
524 	case '=':
525 	  {
526 	    obj o1 = exint (p->opr2.op2);
527 	    obj o0 = exint (p->opr2.op1);
528 	    o = mkassign (o0, o1);
529 	    freenocstobj (o1);
530 	    return o;
531 	  }
532 	case '+':
533 	  {
534 	    obj o1, o2, o3;
535 	    o1 = exint (p->opr2.op1);
536 	    o2 = exint (p->opr2.op2);
537 	    o3 = mksum (o1, o2);
538 	    freenocstobj (o1);
539 	    freenocstobj (o2);
540 	    return o3;
541 	  }
542 	case '-':
543 	  {
544 	    obj o1, o2, o3;
545 	    o1 = exint (p->opr2.op1);
546 	    o2 = exint (p->opr2.op2);
547 	    o3 = mkdiff (o1, o2);
548 	    freenocstobj (o1);
549 	    freenocstobj (o2);
550 	    return o3;
551 	  }
552 	case '*':
553 	  {
554 	    obj o1, o2, o3;
555 	    o1 = exint (p->opr2.op1);
556 	    o2 = exint (p->opr2.op2);
557 	    o3 = mkmult (o1, o2);
558 	    freenocstobj (o1);
559 	    freenocstobj (o2);
560 	    return o3;
561 	  }
562 	case '/':
563 	  {
564 	    obj o1, o2, o3;
565 	    o1 = exint (p->opr2.op1);
566 	    o2 = exint (p->opr2.op2);
567 	    o3 = mkdiv (o1, o2);
568 	    freenocstobj (o1);
569 	    freenocstobj (o2);
570 	    return o3;
571 	  }
572 	case MOD:
573 	  {
574 	    obj o1, o2, o3;
575 	    o1 = exint (p->opr2.op1);
576 	    o2 = exint (p->opr2.op2);
577 	    o3 = mkmod (o1, o2);
578 	    freenocstobj (o1);
579 	    freenocstobj (o2);
580 	    return o3;
581 	  }
582 	case '\\':
583 	  {
584 	    obj o1, o2, o3;
585 	    o1 = exint (p->opr2.op1);
586 	    o2 = exint (p->opr2.op2);
587 	    o3 = mkintdiv (o1, o2);
588 	    freenocstobj (o1);
589 	    freenocstobj (o2);
590 	    return o3;
591 	  }
592 	case '^':
593 	  {
594 	    obj o1, o2, o3;
595 	    o1 = exint (p->opr2.op1);
596 	    o2 = exint (p->opr2.op2);
597 	    o3 = mkpow (o1, o2);
598 	    freenocstobj (o1);
599 	    freenocstobj (o2);
600 	    return o3;
601 	  }
602 
603 	}
604 
605     case typeOpr:
606 
607       switch (p->opr.oper.rec.i)
608 	{
609 	case WHILE:
610 	  {
611 	    while (obj2double (exint (p->opr.op[0])))
612 	      {
613 		exint (p->opr.op[1]);
614 	      }
615 	    return o;
616 	  }
617 	case UNTIL:
618 	  {
619 	    while (!obj2double (exint (p->opr.op[0])))
620 	      {
621 		exint (p->opr.op[1]);
622 	      }
623 	    return o;
624 	  }
625 	case LOOPWHILE:
626 	  {
627 	    do
628 	      {
629 		exint (p->opr.op[1]);
630 	      }
631 	    while (obj2double (exint (p->opr.op[0])));
632 	    return o;
633 	  }
634 	case LOOPUNTIL:
635 	  {
636 	    do
637 	      {
638 		exint (p->opr.op[1]);
639 	      }
640 	    while (!obj2double (exint (p->opr.op[0])));
641 	    return o;
642 	  }
643 	case SELECT:
644 	  {
645 	    nsel++;
646 	    if (nsel > 19)
647 	      {
648 		fprintf (stderr, "Select case inside other one limited to 20 levels!\n");
649 		nsel--;
650 		return o;
651 	      }
652 	    selexpr[nsel] = p->opr.op[0];
653 	    caseelse[nsel] = 1;
654 	    exint (p->opr.op[1]);
655 	    nsel--;
656 	    return o;
657 	  }
658 	case CASE:
659 	  {
660 	    switch (p->opr.nops)
661 	      {
662 	      case 2:
663 		if (objcmp (exint (selexpr[nsel]), exint (p->opr.op[0])))
664 		  {
665 		    exint (p->opr.op[1]);
666 		    caseelse[nsel] = 0;
667 		  }
668 		break;
669 	      case 3:
670 		exint (p->opr.op[0]);
671 		if (objcmp (exint (selexpr[nsel]), exint (p->opr.op[1])))
672 		  {
673 		    exint (p->opr.op[2]);
674 		    caseelse[nsel] = 0;
675 		  }
676 	      }
677 	    return o;
678 	  }
679 	case CASEELSE:
680 	  {
681 	    switch (p->opr.nops)
682 	      {
683 	      case 1:
684 		if (caseelse[nsel])
685 		  exint (p->opr.op[0]);
686 		break;
687 	      case 2:
688 		exint (p->opr.op[0]);
689 		if (caseelse[nsel])
690 		  exint (p->opr.op[1]);
691 	      }
692 	    return o;
693 	  }
694 
695 	case FOR:
696 	  {
697 	    int negstep = 0;
698 	    if (p->opr.nops > 5 && obj2double (exint (p->opr.op[3])) < 0)
699 	      negstep = 1;
700 	    else if (p->opr.nops < 6 && obj2double (exint (p->opr.op[1])) > obj2double (exint (p->opr.op[2])))
701 	      negstep = 1;
702 
703 	    o = mkassign (exint (p->opr.op[0]), (exint (p->opr.op[1])));
704 	    if (!negstep)
705 	      {
706 		while (obj2int (mkle (exint (p->opr.op[0]), (exint (p->opr.op[2])))))
707 		  {
708 		    if (p->opr.nops > 5)
709 		      {
710 			o = exint (p->opr.op[4]);
711 			mksumassign (exint (p->opr.op[0]), exint (p->opr.op[3]));
712 		      }
713 		    else
714 		      {
715 			o = exint (p->opr.op[3]);
716 			mkplusplus (exint (p->opr.op[0]));
717 		      }
718 		  }
719 	      }
720 	    else
721 
722 	      {
723 		while (obj2int (mkge (exint (p->opr.op[0]), (exint (p->opr.op[2])))))
724 		  {
725 		    if (p->opr.nops > 5)
726 		      {
727 			o = exint (p->opr.op[4]);
728 			mksumassign (exint (p->opr.op[0]), exint (p->opr.op[3]));
729 		      }
730 		    else
731 		      {
732 			o = exint (p->opr.op[3]);
733 			mkminusminus (exint (p->opr.op[0]));
734 		      }
735 		  }
736 	      }
737 	    return o;
738 	  };
739 	case EACH:
740 	  {
741 	    int start = 1;
742 	    int end = 0;
743 	    obj index;
744 	    obj collection = exint (p->opr.op[1]);
745 
746 	    end = obj2int ((arrayclass[collection.type].data[0].getfct) ());
747 
748 	    index.type = INTEGER;
749 	    for (index.rec.i = start; index.rec.i <= end; index.rec.i++)
750 	      {
751 		mkassign (exint (p->opr.op[0]),
752 		      (arrayclass[collection.type].fct[0].fct) (1, &index));
753 		o = exint (p->opr.op[2]);
754 	      }
755 	    return o;
756 	  };
757 
758 	case IF:
759 	  {
760 	    if (obj2double (exint (p->opr.op[0])))
761 	      o = exint (p->opr.op[1]);
762 	    else if (p->opr.nops > 2)
763 	      o = exint (p->opr.op[2]);
764 	    return o;
765 	  }
766 
767 	case IDLIST:
768 	  {
769 	    int nops = p->opr.nops;
770 	    Idval *val;
771 	    nodeType *pp;
772 
773 	    if (nops == 5)
774 	      {
775 		exint (p->opr.op[0]);
776 		settype (p->opr.op[3]);
777 		pp = p->opr.op[1];
778 		val = look (pp->id.id.label, scope);
779 		symbol_settype (VARIANT, 0);
780 		if (initconst && p->opr.op[4] != NULL)
781 		  {
782 		    obj o;
783 		    o.rec.s = (char *) val;
784 		    pp = p->opr.op[4];
785 		    o1eqo2 (&o, exint (pp));
786 		    val->protect = 1;
787 		  }
788 	      }
789 	    else
790 	      {
791 		settype (p->opr.op[2]);
792 		pp = p->opr.op[0];
793 		val = look (pp->id.id.label, scope);
794 		symbol_settype (VARIANT, 0);
795 		if (initconst && p->opr.op[3] != NULL)
796 		  {
797 		    obj o;
798 		    o.rec.s = (char *) val;
799 		    pp = p->opr.op[3];
800 		    o1eqo2 (&o, exint (pp));
801 		    val->protect = 1;
802 		  }
803 
804 
805 	      }
806 
807 
808 	    return o;
809 	  }
810 	case CONST:
811 	  {
812 	    int nops = p->opr.nops;
813 
814 	    initconst = 1;
815 	    setscope (2);
816 
817 	    exint (p->opr.op[nops - 1]);
818 	    setscope (1);
819 	    initconst = 0;
820 	    return o;
821 	  }
822 
823 	case DIM:
824 	  {
825 
826 	    setscope (2);
827 	    exint (p->opr.op[0]);
828 	    setscope (1);
829 	    return o;
830 	  }
831 	case STATIC:
832 	  {
833 	    setscope (3);
834 	    exint (p->opr.op[0]);
835 	    setscope (1);
836 	    return o;
837 
838 	  }
839 	case SUB:
840 	  {
841 	    argsub ();
842 	    if (p->opr.op[1] != NULL)
843 	      exint (p->opr.op[1]);
844 	    exint (p->opr.op[2]);
845 	    return o;
846 	  }
847 	case CALL:
848 	  {
849 	    argcall ();
850 	    exint (p->opr.op[1]);
851 	    switch ((p->opr.op[0])->id.id.type)
852 	      {
853 	      case IDENTIFIER:
854 		{
855 		  o = mkcall (exint (p->opr.op[0]));
856 		  argendcall ();
857 		  break;
858 		}
859 	      case BUILTINFUNCTION:
860 		{
861 		  o = mkcallbuiltin ((p->opr.op[0])->id.id);
862 		  argendcallbuiltin ();
863 		  break;
864 		}
865 	      }
866 	    return o;
867 	  }
868 	case WITH:
869 	  {
870 	    withenter (exint (p->opr.op[0]));
871 	    o = exint (p->opr.op[1]);
872 	    withend ();
873 	    return o;
874 	  }
875 	case ARG:
876 	  {
877 	    switch (p->opr.nops)
878 	      {
879 	      case 1:
880 		{
881 		  mkarg (p->opr.op[0]);
882 		  return o;
883 		}
884 	      case 2:
885 		{
886 		  o = exint (p->opr.op[0]);
887 		  mkarg (p->opr.op[1]);
888 		  return o;
889 		}
890 	      }
891 	    return o;
892 	  }
893 	case SUBARG:
894 	  {
895 	    switch (p->opr.nops)
896 	      {
897 	      case 3:
898 		{
899 		  settransmit (p->opr.op[0]);
900 		  settype (p->opr.op[2]);
901 		  setscope (2);
902 		  mkarg (p->opr.op[1]);
903 		  symbol_settype (VARIANT, 0);
904 		  setscope (1);
905 		  return o;
906 		}
907 	      case 4:
908 		{
909 		  o = exint (p->opr.op[0]);
910 		  settransmit (p->opr.op[1]);
911 		  settype (p->opr.op[3]);
912 		  setscope (2);
913 		  mkarg (p->opr.op[2]);
914 		  symbol_settype (VARIANT, 0);
915 		  setscope (1);
916 		  return o;
917 		}
918 	      }
919 	    return o;
920 	  }
921 	case BUILTINFUNCTION:
922 	  {
923 	    argcall ();
924 	    exint (p->opr.op[1]);
925 	    o = mkcallbuiltin ((p->opr.op[0])->id.id);
926 	    argendcallbuiltin ();
927 
928 	    return o;
929 	  }
930 	case NEWLINE:
931 	  {
932 	    int i;
933 	    int nops = p->opr.nops;
934 	    for (i = 0; i < nops; i++)
935 	      {
936 		exint (p->opr.op[i]);
937 	      }
938 	    return o;
939 	  }
940 
941 	case OPEN:
942 	  {
943 	    o.rec.i = io_open (obj2string (exint (p->opr.op[0])),
944 			       setfilemode (p->opr.op[1]),
945 			       obj2int (exint (p->opr.op[2])));
946 	    o.type = INTEGER;
947 	    return o;
948 	  };
949 	case CLOSE:
950 	  {
951 	    o.rec.i = io_close (obj2int (exint (p->opr.op[0])));
952 	    o.type = INTEGER;
953 	    return o;
954 	  };
955 	case SPC:
956 	  {
957 	    o.rec.i = obj2int (exint (p->opr.op[0]));
958 	    o.type = INTEGER;
959 	    return o;
960 	  };
961 	case TAB:
962 	  {
963 	    o.rec.i = -obj2int (exint (p->opr.op[0]));
964 	    o.type = INTEGER;
965 	    return o;
966 	  };
967 	case PRINT:
968 	  {
969 	    int tabspc = 0;
970 	    if (p->opr.op[1] != NULL)
971 	      tabspc = obj2int (exint (p->opr.op[1]));
972 	    argcall ();
973 	    exint (p->opr.op[2]);
974 	    o.rec.i = io_print (obj2int (exint (p->opr.op[0])),
975 				tabspc,
976 				nargnode[routinedeep],
977 				argu[routinedeep]);
978 	    argendcallbuiltin ();
979 	    o.type = INTEGER;
980 	    return o;
981 	  };
982 	case WRITE:
983 	  {
984 	    argcall ();
985 	    exint (p->opr.op[1]);
986 	    o.rec.i = io_write (obj2int (exint (p->opr.op[0])),
987 				nargnode[routinedeep],
988 				argu[routinedeep]);
989 	    argendcallbuiltin ();
990 	    o.type = INTEGER;
991 	    return o;
992 	  };
993 	case INPUT:
994 	  {
995 	    int i;
996 	    argcall ();
997 	    exint (p->opr.op[1]);
998 
999 	    for (i = 0; i < nargnode[routinedeep]; i++)
1000 	      {
1001 		argu[routinedeep][i] = io_input (obj2int (exint (p->opr.op[0])));
1002 	      }
1003 	    argsub ();
1004 	    return exint (p->opr.op[1]);
1005 	    argendcall ();
1006 	  };
1007 	case LT:
1008 	  {
1009 	    obj o1, o2, o3;
1010 	    o1 = exint (p->opr.op[0]);
1011 	    o2 = exint (p->opr.op[1]);
1012 	    o3 = mklt (o1, o2);
1013 	    freenocstobj (o1);
1014 	    freenocstobj (o2);
1015 	    return o3;
1016 	  }
1017 	case GT:
1018 	  {
1019 	    obj o1, o2, o3;
1020 	    o1 = exint (p->opr.op[0]);
1021 	    o2 = exint (p->opr.op[1]);
1022 	    o3 = mkgt (o1, o2);
1023 	    freenocstobj (o1);
1024 	    freenocstobj (o2);
1025 	    return o3;
1026 	  }
1027 	case GE:
1028 	  {
1029 	    obj o1, o2, o3;
1030 	    o1 = exint (p->opr.op[0]);
1031 	    o2 = exint (p->opr.op[1]);
1032 	    o3 = mkge (o1, o2);
1033 	    freenocstobj (o1);
1034 	    freenocstobj (o2);
1035 	    return o3;
1036 	  }
1037 	case LE:
1038 	  {
1039 	    obj o1, o2, o3;
1040 	    o1 = exint (p->opr.op[0]);
1041 	    o2 = exint (p->opr.op[1]);
1042 	    o3 = mkle (o1, o2);
1043 	    freenocstobj (o1);
1044 	    freenocstobj (o2);
1045 	    return o3;
1046 	  }
1047 	case NE:
1048 	  {
1049 	    obj o1, o2, o3;
1050 	    o1 = exint (p->opr.op[0]);
1051 	    o2 = exint (p->opr.op[1]);
1052 	    o3 = mkne (o1, o2);
1053 	    freenocstobj (o1);
1054 	    freenocstobj (o2);
1055 	    return o3;
1056 	  }
1057 	case EQ:
1058 	  {
1059 	    obj o1, o2, o3;
1060 	    o1 = exint (p->opr.op[0]);
1061 	    o2 = exint (p->opr.op[1]);
1062 	    o3 = mkeq (o1, o2);
1063 	    freenocstobj (o1);
1064 	    freenocstobj (o2);
1065 	    return o3;
1066 	  }
1067 	case OR:
1068 	  {
1069 	    obj o1, o2, o3;
1070 	    o1 = exint (p->opr.op[0]);
1071 	    o2 = exint (p->opr.op[1]);
1072 	    o3 = mkor (o1, o2);
1073 	    freenocstobj (o1);
1074 	    freenocstobj (o2);
1075 	    return o3;
1076 	  }
1077 	case AND:
1078 	  {
1079 	    obj o1, o2, o3;
1080 	    o1 = exint (p->opr.op[0]);
1081 	    o2 = exint (p->opr.op[1]);
1082 	    o3 = mkand (o1, o2);
1083 	    freenocstobj (o1);
1084 	    freenocstobj (o2);
1085 	    return o3;
1086 	  }
1087 	case XOR:
1088 	  {
1089 	    obj o1, o2, o3;
1090 	    o1 = exint (p->opr.op[0]);
1091 	    o2 = exint (p->opr.op[1]);
1092 	    o3 = mkxor (o1, o2);
1093 	    freenocstobj (o1);
1094 	    freenocstobj (o2);
1095 	    return o3;
1096 	  }
1097 	case '&':
1098 	  {
1099 	    obj o1, o2, o3;
1100 	    o1 = exint (p->opr.op[0]);
1101 	    o2 = exint (p->opr.op[1]);
1102 	    o3 = mkconcat (o1, o2);
1103 	    freenocstobj (o1);
1104 	    freenocstobj (o2);
1105 	    return o3;
1106 	  }
1107 	case NOT:
1108 	  {
1109 	    obj o1, o3;
1110 	    o1 = exint (p->opr.op[0]);
1111 	    o3 = mknot (o1);
1112 	    freenocstobj (o1);
1113 	    return o3;
1114 	  }
1115 
1116 	case BASEOBJECT:
1117 	  {
1118 	    return check_with ((p->opr.op[0])->id.id);
1119 	  }
1120 
1121 	case RETURNOBJECT:
1122 	  {
1123 	    o = exint (p->opr.op[0]);
1124 
1125 	    return mkderef (o, exint (p->opr.op[1]));
1126 	  };
1127 
1128 	case ALONEOBJ:
1129 	  {
1130 
1131 	    o = exint (p->opr.op[0]);
1132 	    o = mkcallalone (o);
1133 
1134 	    return o;
1135 	  }
1136 
1137 	case MEMBERFUNCTION:
1138 	  {
1139 
1140 	    exint (p->opr.op[1]);
1141 
1142 	    o = (exint (p->opr.op[0]));
1143 	    o.type = MEMBERFUNCTION;
1144 
1145 	    return o;
1146 	  }
1147 	case OBJMEMBERFCT:
1148 	  {
1149 	    obj base = exint (p->opr.op[0]);
1150 
1151 	    argcall ();
1152 	    o = exint (p->opr.op[1]);
1153 	    o = mkcallmember (base, o);
1154 	    argendcall ();
1155 	    return o;
1156 	  }
1157 	case FCTMEMBERFCT:
1158 	  {
1159 	    obj base = exint (p->opr.op[0]);
1160 
1161 	    argcall ();
1162 	    o = exint (p->opr.op[1]);
1163 	    o = mkcallmember (base, o);
1164 	    argendcall ();
1165 	    return o;
1166 	  }
1167 	case '.':
1168 	  {
1169 	    switch (p->opr.nops)
1170 	      {
1171 	      case 1:
1172 		{
1173 		}
1174 	      case 2:
1175 		{
1176 		  return mkderef (exint (p->opr.op[0]), exint (p->opr.op[1]));
1177 		}
1178 	      }
1179 	    return o;
1180 
1181 	  }
1182 	}
1183     }
1184   return o;
1185 }
1186 
1187 
1188 
1189 obj
mkcall(obj identifier)1190 mkcall (obj identifier)
1191 {
1192 
1193 
1194   if (identifier.type == IDENTIFIER)
1195     {
1196 
1197       gotolabel (identifier.label);
1198 
1199     }
1200   return id2val (identifier);
1201 }
1202 
1203 typedef enum
1204 {
1205   call, sub
1206 }
1207 Arg_use;
1208 static Arg_use arg_use;
1209 
1210 int
argsub()1211 argsub ()
1212 {
1213   arg_use = sub;
1214   return 0;
1215 }
1216 int
argcall()1217 argcall ()
1218 {
1219   arg_use = call;
1220   routinedeep++;
1221 
1222   argnode = (nodeType ***) absrealloc (argnode, sizeof (nodeType **) * (routinedeep + 1), "argcall:argnode ");
1223   argu = (obj **) absrealloc (argu, sizeof (obj *) * (routinedeep + 1), "argcall:argu    ");
1224   arguref = (obj **) absrealloc (arguref, sizeof (obj *) * (routinedeep + 1), "argcall:arguref ");
1225   nargnode = (int *) absrealloc (nargnode, sizeof (int) * (routinedeep + 1), "argcall:nargnode");
1226 
1227   argnode[routinedeep] = NULL;
1228   argu[routinedeep] = NULL;
1229   arguref[routinedeep] = NULL;
1230   nargnode[routinedeep] = 0;
1231 
1232 
1233   return 0;
1234 }
1235 
1236 int
argendcall()1237 argendcall ()
1238 {
1239   arg_use = sub;
1240 
1241   if (argnode[routinedeep] != NULL)
1242     absfree (argnode[routinedeep], "argendcall:argnode[routinedeep]");
1243   if (argu[routinedeep] != NULL)
1244     absfree (argu[routinedeep], "argendcall:argu   [routinedeep]");
1245   if (arguref[routinedeep] != NULL)
1246     absfree (arguref[routinedeep], "argendcall:arguref[routinedeep]");
1247 
1248   routinedeep--;
1249   if (routinedeep < 0)
1250     {
1251       absfree (argnode, "argendcall:argnode ");
1252       argnode = NULL;
1253       absfree (argu, "argendcall:argu    ");
1254       argu = NULL;
1255       absfree (arguref, "argendcall:arguref ");
1256       arguref = NULL;
1257       absfree (nargnode, "argendcall:nargnode");
1258       nargnode = NULL;
1259     }
1260   else
1261     {
1262       argnode = (nodeType ***) absrealloc (argnode, sizeof (nodeType **) * (routinedeep + 1), "argcall:argnode ");
1263       argu = (obj **) absrealloc (argu, sizeof (obj *) * (routinedeep + 1), "argcall:argu    ");
1264       arguref = (obj **) absrealloc (arguref, sizeof (obj *) * (routinedeep + 1), "argcall:arguref ");
1265       nargnode = (int *) absrealloc (nargnode, sizeof (int) * (routinedeep + 1), "argcall:nargnode");
1266     }
1267 
1268   return 0;
1269 }
1270 
1271 
1272 int
argendcallbuiltin()1273 argendcallbuiltin ()
1274 {
1275   argendcall ();
1276   arg_use = call;
1277   return 0;
1278 }
1279 
1280 obj
mkarg(nodeType * arg)1281 mkarg (nodeType * arg)
1282 {
1283   obj o, id;
1284   int i;
1285   int narg;
1286 
1287   if (arg_use == call)
1288     {
1289       narg = nargnode[routinedeep];
1290 
1291       argnode[routinedeep] = (nodeType **) absrealloc (argnode[routinedeep], sizeof (nodeType *) * (narg + 1), "mkarg:argnode");
1292       argu[routinedeep] = (obj *) absrealloc (argu[routinedeep], sizeof (obj) * (narg + 1), "mkarg:argu   ");
1293       arguref[routinedeep] = (obj *) absrealloc (arguref[routinedeep], sizeof (obj) * (narg + 1), "mkarg:arguref");
1294 
1295 
1296       argnode[routinedeep][narg] = arg;
1297       argu[routinedeep][narg] = id2val (exint (arg));
1298       arguref[routinedeep][narg] = exint (arg);
1299 
1300 
1301 
1302 
1303       nargnode[routinedeep]++;
1304 
1305     }
1306   else
1307     {
1308       nargnode[routinedeep]--;
1309       if (nargnode[routinedeep] >= 0)
1310 	{
1311 
1312 
1313 	  o = argu[routinedeep][0];
1314 	  id = arguref[routinedeep][0];
1315 	  for (i = 0; i < nargnode[routinedeep]; i++)
1316 	    {
1317 	      argu[routinedeep][i] = argu[routinedeep][i + 1];
1318 	      arguref[routinedeep][i] = arguref[routinedeep][i + 1];
1319 	    }
1320 
1321 
1322 	  if (id.type == IDENTIFIER && Transmit == BYREF)
1323 	    setrefid (id);
1324 	  else
1325 	    unsetrefid ();
1326 
1327 	  return mkassign (exint (arg), o);
1328 	}
1329     }
1330   return o;
1331 }
1332 
1333 
1334 
1335 obj
mkcallbuiltin(obj identifier)1336 mkcallbuiltin (obj identifier)
1337 {
1338   obj o;
1339   int narg;
1340   obj arg[10];
1341   int i;
1342 
1343 
1344 
1345   narg = nargnode[routinedeep];
1346 
1347   for (i = 0; i < nargnode[routinedeep]; i++)
1348     arg[i] = argu[routinedeep][i];
1349 
1350 
1351   if (identifier.type == BUILTINFUNCTION)
1352     {
1353 
1354       o = (arrayfct[identifier.rec.i].fct) (narg, arg);
1355     }
1356 
1357   return o;
1358 }
1359 
1360 obj
mkcallmember(base,identifier)1361 mkcallmember (base, identifier)
1362      obj base, identifier;
1363 {
1364   obj o;
1365   int narg;
1366   obj arg[10];
1367   int i, found;
1368 
1369 
1370 
1371 
1372 
1373   if (base.type == IDENTIFIER)
1374     base = id2val (base);
1375 
1376   narg = nargnode[routinedeep];
1377   for (i = 0; i < narg; i++)
1378     arg[i + 1] = argu[routinedeep][i];
1379   narg++;
1380   arg[0] = base;
1381 
1382 
1383   found = 0;
1384   i = 0;
1385   if (base.type > NUMBER_OF_CLASS || base.type < 0)
1386     {
1387       fprintf (stderr, "unknown class %s type %d\n", base.label, base.type);
1388       return o;
1389     }
1390   while (arrayclass[base.type].fct[i].name != NULL && found == 0)
1391     {
1392       if (strcasecmp (identifier.label, arrayclass[base.type].fct[i].name) == 0)
1393 	found = 1;
1394       i++;
1395     }
1396   i--;
1397 
1398   if (found)
1399     {
1400 
1401 
1402       o = (arrayclass[base.type].fct[i].fct) (narg, arg);
1403     }
1404   else
1405     {
1406       fprintf (stderr, "function %s is not member of type %d\n", identifier.label, base.type);
1407       printobj (base);
1408     }
1409   return o;
1410 }
1411 
1412 obj
mkcallalone(member)1413 mkcallalone (member)
1414      obj member;
1415 {
1416   obj o;
1417   int narg;
1418   obj arg[10];
1419   obj base;
1420   int i, found;
1421 
1422 
1423 
1424 
1425   if (member.type == MEMBER)
1426     base = *((obj *) member.rec.s);
1427   else
1428     return o;
1429 
1430   narg = 1;
1431   arg[0] = base;
1432 
1433 
1434   found = 0;
1435   i = 0;
1436   if (base.type > NUMBER_OF_CLASS || base.type < 0)
1437     {
1438       fprintf (stderr, "unknown class %s type %d\n", base.label, base.type);
1439       return o;
1440     }
1441 
1442   while (arrayclass[base.type].fct[i].name != NULL && found == 0)
1443     {
1444       if (strcasecmp (member.label, arrayclass[base.type].fct[i].name) == 0)
1445 	found = 1;
1446       i++;
1447     }
1448   i--;
1449 
1450   if (found)
1451     {
1452       o = (arrayclass[base.type].fct[i].fct) (narg, arg);
1453     }
1454   else
1455     fprintf (stderr, "function %s is not member of type %d\n", member.label, base.type);
1456   return o;
1457 }
1458