xref: /original-bsd/usr.bin/f77/pass1.tahoe/data.c (revision bdc0a208) 
1 /*-
2  * Copyright (c) 1980 The Regents of the University of California.
3  * All rights reserved.
4  *
5  * %sccs.include.proprietary.c%
6  */
7 
8 #ifndef lint
9 static char sccsid[] = "@(#)data.c	5.3 (Berkeley) 04/12/91";
10 #endif /* not lint */
11 
12 /*
13  * data.c
14  *
15  * Routines for handling DATA statements, f77 compiler, 4.2 BSD.
16  *
17  * University of Utah CS Dept modification history:
18  *
19  * Revision 3.1  84/10/13  01:09:50  donn
20  * Installed Jerry Berkman's version; added UofU comment header.
21  *
22  */
23 
24 #include "defs.h"
25 #include "data.h"
26 
27 
28 /*  global variables  */
29 
30 flag overlapflag;
31 
32 
33 
34 /*  local variables  */
35 
36 LOCAL char rstatus;
37 LOCAL ftnint rvalue;
38 LOCAL dovars *dvlist;
39 LOCAL int dataerror;
40 LOCAL vallist *grvals;
41 LOCAL int datafile;
42 LOCAL int chkfile;
43 LOCAL long base;
44 
45 
46 
47 /*  Copied from expr.c  */
48 
49 LOCAL letter(c)
50 register int c;
51 {
52 if( isupper(c) )
53 	c = tolower(c);
54 return(c - 'a');
55 }
56 
57 
58 
59 vexpr *
60 cpdvalue(dp)
61 vexpr *dp;
62 {
63   register dvalue *p;
64 
65   if (dp->tag != DVALUE)
66     badtag("cpdvalue", dp->tag);
67 
68   p = ALLOC(Dvalue);
69   p->tag = DVALUE;
70   p->status = dp->dvalue.status;
71   p->value = dp->dvalue.value;
72 
73   return ((vexpr *) p);
74 }
75 
76 
77 
78 frvexpr(vp)
79 register vexpr *vp;
80 {
81   if (vp != NULL)
82     {
83       if (vp->tag == DNAME)
84 	free(vp->dname.repr);
85       else if (vp->tag == DEXPR)
86 	{
87 	  frvexpr(vp->dexpr.left);
88 	  frvexpr(vp->dexpr.right);
89 	}
90 
91       free((char *) vp);
92     }
93 
94   return;
95 }
96 
97 
98 
99 frvlist(vp)
100 register vlist *vp;
101 {
102   register vlist *t;
103 
104   while (vp)
105     {
106       t = vp->next;
107       frvexpr(vp->val);
108       free((char *) vp);
109       vp = t;
110     }
111 
112   return;
113 }
114 
115 
116 
117 frelist(ep)
118 elist *ep;
119 {
120   register elist *p;
121   register elist *t;
122   register aelt *ap;
123   register dolist *dp;
124 
125   p = ep;
126 
127   while (p != NULL)
128     {
129       if (p->elt->tag == SIMPLE)
130 	{
131 	  ap = (aelt *) p->elt;
132 	  frvlist(ap->subs);
133 	  if (ap->range != NULL)
134 	    {
135 	      frvexpr(ap->range->low);
136 	      frvexpr(ap->range->high);
137 	      free((char *) ap->range);
138 	    }
139 	  free((char *) ap);
140 	}
141       else
142 	{
143 	  dp = (dolist *) p->elt;
144 	  frvexpr(dp->dovar);
145 	  frvexpr(dp->init);
146 	  frvexpr(dp->limit);
147 	  frvexpr(dp->step);
148 	  frelist(dp->elts);
149 	  free((char *) dp);
150 	}
151 
152       t = p;
153       p = p->next;
154       free((char *) t);
155     }
156 
157   return;
158 }
159 
160 
161 
162 frvallist(vp)
163 vallist *vp;
164 {
165   register vallist *p;
166   register vallist *t;
167 
168   p = vp;
169   while (p != NULL)
170     {
171       frexpr((tagptr) p->value);
172       t = p;
173       p = p->next;
174       free((char *) t);
175     }
176 
177   return;
178 }
179 
180 
181 
182 elist *revelist(ep)
183 register elist *ep;
184 {
185   register elist *next;
186   register elist *t;
187 
188   if (ep != NULL)
189     {
190       next = ep->next;
191       ep->next = NULL;
192 
193       while (next)
194 	{
195 	  t = next->next;
196 	  next->next = ep;
197 	  ep = next;
198 	  next = t;
199 	}
200     }
201 
202   return (ep);
203 }
204 
205 
206 
207 vlist *revvlist(vp)
208 vlist *vp;
209 {
210   register vlist *p;
211   register vlist *next;
212   register vlist *t;
213 
214   if (vp == NULL)
215     p = NULL;
216   else
217     {
218       p = vp;
219       next = p->next;
220       p->next = NULL;
221 
222       while (next)
223 	{
224 	  t = next->next;
225 	  next->next = p;
226 	  p = next;
227 	  next = t;
228 	}
229     }
230 
231   return (p);
232 }
233 
234 
235 
236 vallist *
237 revrvals(vp)
238 vallist *vp;
239 {
240   register vallist *p;
241   register vallist *next;
242   register vallist *t;
243 
244   if (vp == NULL)
245     p = NULL;
246   else
247     {
248       p = vp;
249       next = p->next;
250       p->next = NULL;
251       while (next)
252 	{
253 	  t = next->next;
254 	  next->next = p;
255 	  p = next;
256 	  next = t;
257 	}
258     }
259 
260   return (p);
261 }
262 
263 
264 
265 vlist *prepvexpr(tail, head)
266 vlist *tail;
267 vexpr *head;
268 {
269   register vlist *p;
270 
271   p = ALLOC(Vlist);
272   p->next = tail;
273   p->val = head;
274 
275   return (p);
276 }
277 
278 
279 
280 elist *preplval(tail, head)
281 elist *tail;
282 delt* head;
283 {
284   register elist *p;
285   p = ALLOC(Elist);
286   p->next = tail;
287   p->elt = head;
288 
289   return (p);
290 }
291 
292 
293 
294 delt *mkdlval(name, subs, range)
295 vexpr *name;
296 vlist *subs;
297 rpair *range;
298 {
299   static char *iscomm =" improper initialization for variable in COMMON";
300   register aelt *p;
301 
302   p = ALLOC(Aelt);
303   p->tag = SIMPLE;
304   p->var = mkname(name->dname.len, name->dname.repr);
305   if ((procclass != CLBLOCK) && (p->var->vstg == STGCOMMON))
306 	warn(iscomm);
307   p->subs = subs;
308   p->range = range;
309 
310   return ((delt *) p);
311 }
312 
313 
314 
315 delt *mkdatado(lvals, dovar, params)
316 elist *lvals;
317 vexpr *dovar;
318 vlist *params;
319 {
320   static char *toofew = "missing loop parameters";
321   static char *toomany = "too many loop parameters";
322 
323   register dolist *p;
324   register vlist *vp;
325   register int pcnt;
326   register dvalue *one;
327 
328   p = ALLOC(DoList);
329   p->tag = NESTED;
330   p->elts = revelist(lvals);
331   p->dovar = dovar;
332 
333   vp = params;
334   pcnt = 0;
335   while (vp)
336     {
337       pcnt++;
338       vp = vp->next;
339     }
340 
341   if (pcnt != 2 && pcnt != 3)
342     {
343       if (pcnt < 2)
344 	err(toofew);
345       else
346 	err(toomany);
347 
348       p->init = (vexpr *) ALLOC(Derror);
349       p->init->tag = DERROR;
350 
351       p->limit = (vexpr *) ALLOC(Derror);
352       p->limit->tag = DERROR;
353 
354       p->step = (vexpr *) ALLOC(Derror);
355       p->step->tag = DERROR;
356     }
357   else
358     {
359       vp = params;
360 
361       if (pcnt == 2)
362 	{
363 	  one = ALLOC(Dvalue);
364 	  one->tag = DVALUE;
365 	  one->status = NORMAL;
366 	  one->value = 1;
367 	  p->step = (vexpr *) one;
368 	}
369       else
370 	{
371 	  p->step = vp->val;
372 	  vp->val = NULL;
373 	  vp = vp->next;
374 	}
375 
376       p->limit = vp->val;
377       vp->val = NULL;
378       vp = vp->next;
379 
380       p->init = vp->val;
381       vp->val = NULL;
382     }
383 
384   frvlist(params);
385   return ((delt *) p);
386 }
387 
388 
389 
390 rpair *mkdrange(lb, ub)
391 vexpr *lb, *ub;
392 {
393   register rpair *p;
394 
395   p = ALLOC(Rpair);
396   p->low = lb;
397   p->high = ub;
398 
399   return (p);
400 }
401 
402 
403 
404 vallist *mkdrval(repl, val)
405 vexpr *repl;
406 expptr val;
407 {
408   static char *badtag = "bad tag in mkdrval";
409   static char *negrepl = "negative replicator";
410   static char *zerorepl = "zero replicator";
411   static char *toobig = "replicator too large";
412   static char *nonconst = "%s is not a constant";
413 
414   register vexpr *vp;
415   register vallist *p;
416   register int status;
417   register ftnint value;
418   register int copied;
419 
420   copied = 0;
421 
422   if (repl->tag == DNAME)
423     {
424       vp = evaldname(repl);
425       copied = 1;
426     }
427   else
428     vp = repl;
429 
430   p = ALLOC(ValList);
431   p->next = NULL;
432   p->value = (Constp) val;
433 
434   if (vp->tag == DVALUE)
435     {
436       status = vp->dvalue.status;
437       value = vp->dvalue.value;
438 
439       if ((status == NORMAL && value < 0) || status == MINLESS1)
440 	{
441 	  err(negrepl);
442 	  p->status = ERRVAL;
443 	}
444       else if (status == NORMAL)
445 	{
446 	  if (value == 0)
447 	    warn(zerorepl);
448 	  p->status = NORMAL;
449 	  p->repl = value;
450 	}
451       else if (status == MAXPLUS1)
452 	{
453 	  err(toobig);
454 	  p->status = ERRVAL;
455 	}
456       else
457 	p->status = ERRVAL;
458     }
459   else if (vp->tag == DNAME)
460     {
461       errnm(nonconst, vp->dname.len, vp->dname.repr);
462       p->status = ERRVAL;
463     }
464   else if (vp->tag == DERROR)
465     p->status = ERRVAL;
466   else
467     fatal(badtag);
468 
469   if (copied) frvexpr(vp);
470   return (p);
471 }
472 
473 
474 
475 /*  Evicon returns the value of the integer constant  */
476 /*  pointed to by token.                              */
477 
478 vexpr *evicon(len, token)
479 register int len;
480 register char *token;
481 {
482   static char *badconst = "bad integer constant";
483   static char *overflow = "integer constant too large";
484 
485   register int i;
486   register ftnint val;
487   register int digit;
488   register dvalue *p;
489 
490   if (len <= 0)
491     fatal(badconst);
492 
493   p = ALLOC(Dvalue);
494   p->tag = DVALUE;
495 
496   i = 0;
497   val = 0;
498   while (i < len)
499     {
500       if (val > MAXINT/10)
501 	{
502 	  err(overflow);
503 	  p->status = ERRVAL;
504 	  goto ret;
505 	}
506       val = 10*val;
507       digit = token[i++];
508       if (!isdigit(digit))
509 	fatal(badconst);
510       digit = digit - '0';
511       if (MAXINT - val >= digit)
512 	val = val + digit;
513       else
514 	if (i == len && MAXINT - val + 1 == digit)
515 	  {
516 	    p->status = MAXPLUS1;
517 	    goto ret;
518 	  }
519 	else
520 	  {
521 	    err(overflow);
522 	    p->status = ERRVAL;
523 	    goto ret;
524 	  }
525     }
526 
527   p->status = NORMAL;
528   p->value = val;
529 
530 ret:
531   return ((vexpr *) p);
532 }
533 
534 
535 
536 /*  Ivaltoicon converts a dvalue into a constant block.  */
537 
538 expptr ivaltoicon(vp)
539 register vexpr *vp;
540 {
541   static char *badtag = "bad tag in ivaltoicon";
542   static char *overflow = "integer constant too large";
543 
544   register int vs;
545   register expptr p;
546 
547   if (vp->tag == DERROR)
548     return(errnode());
549   else if (vp->tag != DVALUE)
550     fatal(badtag);
551 
552   vs = vp->dvalue.status;
553   if (vs == NORMAL)
554     p = mkintcon(vp->dvalue.value);
555   else if ((MAXINT + MININT == -1) && vs == MINLESS1)
556     p = mkintcon(MININT);
557   else if (vs == MAXPLUS1 || vs == MINLESS1)
558     {
559       err(overflow);
560       p = errnode();
561     }
562   else
563     p = errnode();
564 
565   return (p);
566 }
567 
568 
569 
570 /*  Mkdname stores an identifier as a dname  */
571 
572 vexpr *mkdname(len, str)
573 int len;
574 register char *str;
575 {
576   register dname *p;
577   register int i;
578   register char *s;
579 
580   s = (char *) ckalloc(len + 1);
581   i = len;
582   s[i] = '\0';
583 
584   while (--i >= 0)
585     s[i] = str[i];
586 
587   p = ALLOC(Dname);
588   p->tag = DNAME;
589   p->len = len;
590   p->repr = s;
591 
592   return ((vexpr *) p);
593 }
594 
595 
596 
597 /*  Getname gets the symbol table information associated with  */
598 /*  a name.  Getname differs from mkname in that it will not   */
599 /*  add the name to the symbol table if it is not already      */
600 /*  present.                                                   */
601 
602 Namep getname(l, s)
603 int l;
604 register char *s;
605 {
606   struct Hashentry *hp;
607   int hash;
608   register Namep q;
609   register int i;
610   char n[VL];
611 
612   hash = 0;
613   for (i = 0; i < l && *s != '\0'; ++i)
614     {
615       hash += *s;
616       n[i] = *s++;
617     }
618 
619   while (i < VL)
620     n[i++] = ' ';
621 
622   hash %= maxhash;
623   hp = hashtab + hash;
624 
625   while (q = hp->varp)
626     if (hash == hp->hashval
627 	&& eqn(VL, n, q->varname))
628       goto ret;
629     else if (++hp >= lasthash)
630       hp = hashtab;
631 
632 ret:
633   return (q);
634 }
635 
636 
637 
638 /*  Evparam returns the value of the constant named by name.  */
639 
640 expptr evparam(np)
641 register vexpr *np;
642 {
643   static char *badtag = "bad tag in evparam";
644   static char *undefined = "%s is undefined";
645   static char *nonconst = "%s is not constant";
646 
647   register struct Paramblock *tp;
648   register expptr p;
649   register int len;
650   register char *repr;
651 
652   if (np->tag != DNAME)
653     fatal(badtag);
654 
655   len = np->dname.len;
656   repr = np->dname.repr;
657 
658   tp = (struct Paramblock *) getname(len, repr);
659 
660   if (tp == NULL)
661     {
662       errnm(undefined, len, repr);
663       p = errnode();
664     }
665   else if (tp->vclass != CLPARAM || !ISCONST(tp->paramval))
666     {
667       if (tp->paramval->tag != TERROR)
668         errnm(nonconst, len, repr);
669       p = errnode();
670     }
671   else
672     p = (expptr) cpexpr(tp->paramval);
673 
674   return (p);
675 }
676 
677 
678 
679 vexpr *evaldname(dp)
680 vexpr *dp;
681 {
682   static char *undefined = "%s is undefined";
683   static char *nonconst = "%s is not a constant";
684   static char *nonint = "%s is not an integer";
685 
686   register dvalue *p;
687   register struct Paramblock *tp;
688   register int len;
689   register char *repr;
690 
691   p = ALLOC(Dvalue);
692   p->tag = DVALUE;
693 
694   len = dp->dname.len;
695   repr = dp->dname.repr;
696 
697   tp = (struct Paramblock *) getname(len, repr);
698 
699   if (tp == NULL)
700     {
701       errnm(undefined, len, repr);
702       p->status = ERRVAL;
703     }
704   else if (tp->vclass != CLPARAM || !ISCONST(tp->paramval))
705     {
706       if (tp->paramval->tag != TERROR)
707         errnm(nonconst, len, repr);
708       p->status = ERRVAL;
709     }
710   else if (!ISINT(tp->paramval->constblock.vtype))
711     {
712       errnm(nonint, len, repr);
713       p->status = ERRVAL;
714     }
715   else
716     {
717       if ((MAXINT + MININT == -1)
718 	  && tp->paramval->constblock.constant.ci == MININT)
719 	p->status = MINLESS1;
720       else
721 	{
722 	  p->status = NORMAL;
723           p->value = tp->paramval->constblock.constant.ci;
724 	}
725     }
726 
727   return ((vexpr *) p);
728 }
729 
730 
731 
732 vexpr *mkdexpr(op, l, r)
733 register int op;
734 register vexpr *l;
735 register vexpr *r;
736 {
737   static char *badop = "bad operator in mkdexpr";
738 
739   register vexpr *p;
740 
741   switch (op)
742     {
743     default:
744       fatal(badop);
745 
746     case OPNEG:
747     case OPPLUS:
748     case OPMINUS:
749     case OPSTAR:
750     case OPSLASH:
751     case OPPOWER:
752       break;
753     }
754 
755   if ((l != NULL && l->tag == DERROR) || r->tag == DERROR)
756     {
757       frvexpr(l);
758       frvexpr(r);
759       p = (vexpr *) ALLOC(Derror);
760       p->tag = DERROR;
761     }
762   else if (op == OPNEG && r->tag == DVALUE)
763     {
764       p = negival(r);
765       frvexpr(r);
766     }
767   else if (op != OPNEG && l->tag == DVALUE && r->tag == DVALUE)
768     {
769       switch (op)
770 	{
771 	case OPPLUS:
772 	  p = addivals(l, r);
773 	  break;
774 
775 	case OPMINUS:
776 	  p = subivals(l, r);
777 	  break;
778 
779 	case OPSTAR:
780 	  p = mulivals(l, r);
781 	  break;
782 
783 	case OPSLASH:
784 	  p = divivals(l, r);
785 	  break;
786 
787 	case OPPOWER:
788 	  p = powivals(l, r);
789 	  break;
790 	}
791 
792       frvexpr(l);
793       frvexpr(r);
794     }
795   else
796     {
797       p = (vexpr *) ALLOC(Dexpr);
798       p->tag = DEXPR;
799       p->dexpr.opcode = op;
800       p->dexpr.left = l;
801       p->dexpr.right = r;
802     }
803 
804   return (p);
805 }
806 
807 
808 
809 vexpr *addivals(l, r)
810 vexpr *l;
811 vexpr *r;
812 {
813   static char *badtag = "bad tag in addivals";
814   static char *overflow = "integer value too large";
815 
816   register int ls, rs;
817   register ftnint lv, rv;
818   register dvalue *p;
819   register ftnint k;
820 
821   if (l->tag != DVALUE || r->tag != DVALUE)
822     fatal(badtag);
823 
824   ls = l->dvalue.status;
825   lv = l->dvalue.value;
826   rs = r->dvalue.status;
827   rv = r->dvalue.value;
828 
829   p = ALLOC(Dvalue);
830   p->tag = DVALUE;
831 
832   if (ls == ERRVAL || rs == ERRVAL)
833     p->status = ERRVAL;
834 
835   else if (ls == NORMAL && rs == NORMAL)
836     {
837       addints(lv, rv);
838       if (rstatus == ERRVAL)
839 	err(overflow);
840       p->status = rstatus;
841       p->value = rvalue;
842     }
843 
844   else
845     {
846       if (rs == MAXPLUS1 || rs == MINLESS1)
847 	{
848 	  rs = ls;
849 	  rv = lv;
850 	  ls = r->dvalue.status;
851 	}
852 
853       if (rs == NORMAL && rv == 0)
854 	p->status = ls;
855       else if (ls == MAXPLUS1)
856 	{
857 	  if (rs == NORMAL && rv < 0)
858 	    {
859 	      p->status = NORMAL;
860 	      k = MAXINT + rv;
861 	      p->value = k + 1;
862 	    }
863 	  else if (rs == MINLESS1)
864 	    {
865 	      p->status = NORMAL;
866 	      p->value = 0;
867 	    }
868 	  else
869 	    {
870 	      err(overflow);
871 	      p->status = ERRVAL;
872 	    }
873 	}
874       else
875 	{
876 	  if (rs == NORMAL && rv > 0)
877 	    {
878 	      p->status = NORMAL;
879 	      k = ( -MAXINT ) + rv;
880 	      p->value = k - 1;
881 	    }
882 	  else if (rs == MAXPLUS1)
883 	    {
884 	      p->status = NORMAL;
885 	      p->value = 0;
886 	    }
887 	  else
888 	    {
889 	      err(overflow);
890 	      p->status = ERRVAL;
891 	    }
892 	}
893     }
894 
895   return ((vexpr *) p);
896 }
897 
898 
899 
900 vexpr *negival(vp)
901 vexpr *vp;
902 {
903   static char *badtag = "bad tag in negival";
904 
905   register int vs;
906   register dvalue *p;
907 
908   if (vp->tag != DVALUE)
909     fatal(badtag);
910 
911   vs = vp->dvalue.status;
912 
913   p = ALLOC(Dvalue);
914   p->tag = DVALUE;
915 
916   if (vs == ERRVAL)
917     p->status = ERRVAL;
918   else if (vs == NORMAL)
919     {
920       p->status = NORMAL;
921       p->value = -(vp->dvalue.value);
922     }
923   else if (vs == MAXPLUS1)
924     p->status = MINLESS1;
925   else
926     p->status = MAXPLUS1;
927 
928   return ((vexpr *) p);
929 }
930 
931 
932 
933 vexpr *subivals(l, r)
934 vexpr *l;
935 vexpr *r;
936 {
937   static char *badtag = "bad tag in subivals";
938 
939   register vexpr *p;
940   register vexpr *t;
941 
942   if (l->tag != DVALUE || r->tag != DVALUE)
943     fatal(badtag);
944 
945   t = negival(r);
946   p = addivals(l, t);
947   frvexpr(t);
948 
949   return (p);
950 }
951 
952 
953 
954 vexpr *mulivals(l, r)
955 vexpr *l;
956 vexpr *r;
957 {
958   static char *badtag = "bad tag in mulivals";
959   static char *overflow = "integer value too large";
960 
961   register int ls, rs;
962   register ftnint lv, rv;
963   register dvalue *p;
964 
965   if (l->tag != DVALUE || r->tag != DVALUE)
966     fatal(badtag);
967 
968   ls = l->dvalue.status;
969   lv = l->dvalue.value;
970   rs = r->dvalue.status;
971   rv = r->dvalue.value;
972 
973   p = ALLOC(Dvalue);
974   p->tag = DVALUE;
975 
976   if (ls == ERRVAL || rs == ERRVAL)
977     p->status = ERRVAL;
978 
979   else if (ls == NORMAL && rs == NORMAL)
980     {
981       mulints(lv, rv);
982       if (rstatus == ERRVAL)
983 	err(overflow);
984       p->status = rstatus;
985       p->value = rvalue;
986     }
987   else
988     {
989       if (rs == MAXPLUS1 || rs == MINLESS1)
990 	{
991 	  rs = ls;
992 	  rv = lv;
993 	  ls = r->dvalue.status;
994 	}
995 
996       if (rs == NORMAL && rv == 0)
997 	{
998 	  p->status = NORMAL;
999 	  p->value = 0;
1000 	}
1001       else if (rs == NORMAL && rv == 1)
1002 	p->status = ls;
1003       else if (rs == NORMAL && rv == -1)
1004 	if (ls == MAXPLUS1)
1005 	  p->status = MINLESS1;
1006 	else
1007 	  p->status = MAXPLUS1;
1008       else
1009 	{
1010 	  err(overflow);
1011 	  p->status = ERRVAL;
1012 	}
1013     }
1014 
1015   return ((vexpr *) p);
1016 }
1017 
1018 
1019 
1020 vexpr *divivals(l, r)
1021 vexpr *l;
1022 vexpr *r;
1023 {
1024   static char *badtag = "bad tag in divivals";
1025   static char *zerodivide = "division by zero";
1026 
1027   register int ls, rs;
1028   register ftnint lv, rv;
1029   register dvalue *p;
1030   register ftnint k;
1031   register int sign;
1032 
1033   if (l->tag != DVALUE && r->tag != DVALUE)
1034     fatal(badtag);
1035 
1036   ls = l->dvalue.status;
1037   lv = l->dvalue.value;
1038   rs = r->dvalue.status;
1039   rv = r->dvalue.value;
1040 
1041   p = ALLOC(Dvalue);
1042   p->tag = DVALUE;
1043 
1044   if (ls == ERRVAL || rs == ERRVAL)
1045     p->status = ERRVAL;
1046   else if (rs == NORMAL)
1047     {
1048       if (rv == 0)
1049 	{
1050 	  err(zerodivide);
1051 	  p->status = ERRVAL;
1052 	}
1053       else if (ls == NORMAL)
1054 	{
1055 	  p->status = NORMAL;
1056 	  p->value = lv / rv;
1057 	}
1058       else if (rv == 1)
1059 	p->status = ls;
1060       else if (rv == -1)
1061 	if (ls == MAXPLUS1)
1062 	  p->status = MINLESS1;
1063 	else
1064 	  p->status = MAXPLUS1;
1065       else
1066 	{
1067 	  p->status = NORMAL;
1068 
1069 	  if (ls == MAXPLUS1)
1070 	    sign = 1;
1071 	  else
1072 	    sign = -1;
1073 
1074 	  if (rv < 0)
1075 	    {
1076 	      rv = -rv;
1077 	      sign = -sign;
1078 	    }
1079 
1080 	  k = MAXINT - rv;
1081 	  p->value = sign * ((k + 1)/rv + 1);
1082 	}
1083     }
1084   else
1085     {
1086       p->status = NORMAL;
1087       if (ls == NORMAL)
1088 	p->value = 0;
1089       else if ((ls == MAXPLUS1 && rs == MAXPLUS1)
1090 		|| (ls == MINLESS1 && rs == MINLESS1))
1091 	p->value = 1;
1092       else
1093 	p->value = -1;
1094     }
1095 
1096   return ((vexpr *) p);
1097 }
1098 
1099 
1100 
1101 vexpr *powivals(l, r)
1102 vexpr *l;
1103 vexpr *r;
1104 {
1105   static char *badtag = "bad tag in powivals";
1106   static char *zerozero = "zero raised to the zero-th power";
1107   static char *zeroneg = "zero raised to a negative power";
1108   static char *overflow = "integer value too large";
1109 
1110   register int ls, rs;
1111   register ftnint lv, rv;
1112   register dvalue *p;
1113 
1114   if (l->tag != DVALUE || r->tag != DVALUE)
1115     fatal(badtag);
1116 
1117   ls = l->dvalue.status;
1118   lv = l->dvalue.value;
1119   rs = r->dvalue.status;
1120   rv = r->dvalue.value;
1121 
1122   p = ALLOC(Dvalue);
1123   p->tag = DVALUE;
1124 
1125   if (ls == ERRVAL || rs == ERRVAL)
1126     p->status = ERRVAL;
1127 
1128   else if (ls == NORMAL)
1129     {
1130       if (lv == 1)
1131 	{
1132 	  p->status = NORMAL;
1133 	  p->value = 1;
1134 	}
1135       else if (lv == 0)
1136 	{
1137 	  if (rs == MAXPLUS1 || (rs == NORMAL && rv > 0))
1138 	    {
1139 	      p->status = NORMAL;
1140 	      p->value = 0;
1141 	    }
1142 	  else if (rs == NORMAL && rv == 0)
1143 	    {
1144 	      warn(zerozero);
1145 	      p->status = NORMAL;
1146 	      p->value = 1;
1147 	    }
1148 	  else
1149 	    {
1150 	      err(zeroneg);
1151 	      p->status = ERRVAL;
1152 	    }
1153 	}
1154       else if (lv == -1)
1155 	{
1156 	  p->status = NORMAL;
1157 	  if (rs == NORMAL)
1158 	    {
1159 	      if (rv < 0) rv = -rv;
1160 	      if (rv % 2 == 0)
1161 		p->value = 1;
1162 	      else
1163 		p->value = -1;
1164 	    }
1165 	  else
1166 #	    if (MAXINT % 2 == 1)
1167 	      p->value = 1;
1168 #	    else
1169 	      p->value = -1;
1170 #	    endif
1171 	}
1172       else
1173 	{
1174 	  if (rs == NORMAL && rv > 0)
1175 	    {
1176 	      rstatus = NORMAL;
1177 	      rvalue = lv;
1178 	      while (--rv && rstatus == NORMAL)
1179 		mulints(rvalue, lv);
1180 	      if (rv == 0 && rstatus != ERRVAL)
1181 		{
1182 		  p->status = rstatus;
1183 		  p->value = rvalue;
1184 		}
1185 	      else
1186 		{
1187 		  err(overflow);
1188 		  p->status = ERRVAL;
1189 		}
1190 	    }
1191 	  else if (rs == MAXPLUS1)
1192 	    {
1193 	      err(overflow);
1194 	      p->status = ERRVAL;
1195 	    }
1196 	  else if (rs == NORMAL && rv == 0)
1197 	    {
1198 	      p->status = NORMAL;
1199 	      p->value = 1;
1200 	    }
1201 	  else
1202 	    {
1203 	      p->status = NORMAL;
1204 	      p->value = 0;
1205 	    }
1206 	}
1207     }
1208 
1209   else
1210     {
1211       if (rs == MAXPLUS1 || (rs == NORMAL && rv > 1))
1212 	{
1213 	  err(overflow);
1214 	  p->status = ERRVAL;
1215 	}
1216       else if (rs == NORMAL && rv == 1)
1217 	p->status = ls;
1218       else if (rs == NORMAL && rv == 0)
1219 	{
1220 	  p->status = NORMAL;
1221 	  p->value = 1;
1222 	}
1223       else
1224 	{
1225 	  p->status = NORMAL;
1226 	  p->value = 0;
1227 	}
1228     }
1229 
1230   return ((vexpr *) p);
1231 }
1232 
1233 
1234 
1235 /*  Addints adds two integer values.  */
1236 
1237 addints(i, j)
1238 register ftnint i, j;
1239 {
1240   register ftnint margin;
1241 
1242   if (i == 0)
1243     {
1244       rstatus = NORMAL;
1245       rvalue = j;
1246     }
1247   else if (i > 0)
1248     {
1249       margin = MAXINT - i;
1250       if (j <= margin)
1251 	{
1252 	  rstatus = NORMAL;
1253 	  rvalue = i + j;
1254 	}
1255       else if (j == margin + 1)
1256 	rstatus = MAXPLUS1;
1257       else
1258 	rstatus = ERRVAL;
1259     }
1260   else
1261     {
1262       margin = ( -MAXINT ) - i;
1263       if (j >= margin)
1264 	{
1265 	  rstatus = NORMAL;
1266 	  rvalue = i + j;
1267 	}
1268       else if (j == margin - 1)
1269 	rstatus = MINLESS1;
1270       else
1271 	rstatus = ERRVAL;
1272     }
1273 
1274    return;
1275 }
1276 
1277 
1278 
1279 /*  Mulints multiplies two integer values  */
1280 
1281 mulints(i, j)
1282 register ftnint i, j;
1283 {
1284   register ftnint sign;
1285   register ftnint margin;
1286 
1287   if (i == 0 || j == 0)
1288     {
1289       rstatus = NORMAL;
1290       rvalue = 0;
1291     }
1292   else
1293     {
1294       if ((i > 0 && j > 0) || (i < 0 && j < 0))
1295 	sign = 1;
1296       else
1297 	sign = -1;
1298 
1299       if (i < 0) i = -i;
1300       if (j < 0) j = -j;
1301 
1302       margin = MAXINT - i;
1303       margin = (margin + 1) / i;
1304 
1305       if (j <= margin)
1306 	{
1307 	  rstatus = NORMAL;
1308 	  rvalue = i * j * sign;
1309 	}
1310       else if (j - 1 == margin)
1311 	{
1312 	  margin = i*margin - 1;
1313 	  if (margin == MAXINT - i)
1314 	    if (sign > 0)
1315 	      rstatus = MAXPLUS1;
1316 	    else
1317 	      rstatus = MINLESS1;
1318 	  else
1319 	    {
1320 	      rstatus = NORMAL;
1321 	      rvalue = i * j * sign;
1322 	    }
1323 	}
1324       else
1325 	rstatus = ERRVAL;
1326     }
1327 
1328   return;
1329 }
1330 
1331 
1332 
1333 vexpr *
1334 evalvexpr(ep)
1335 vexpr *ep;
1336 {
1337   register vexpr *p;
1338   register vexpr *l, *r;
1339 
1340   switch (ep->tag)
1341     {
1342     case DVALUE:
1343       p = cpdvalue(ep);
1344       break;
1345 
1346     case DVAR:
1347       p = cpdvalue((vexpr *) ep->dvar.valp);
1348       break;
1349 
1350     case DNAME:
1351       p = evaldname(ep);
1352       break;
1353 
1354     case DEXPR:
1355       if (ep->dexpr.left == NULL)
1356 	l = NULL;
1357       else
1358 	l = evalvexpr(ep->dexpr.left);
1359 
1360       if (ep->dexpr.right == NULL)
1361 	r = NULL;
1362       else
1363 	r = evalvexpr(ep->dexpr.right);
1364 
1365       switch (ep->dexpr.opcode)
1366 	{
1367 	case OPNEG:
1368 	  p = negival(r);
1369 	  break;
1370 
1371 	case OPPLUS:
1372 	  p = addivals(l, r);
1373 	  break;
1374 
1375 	case OPMINUS:
1376 	  p = subivals(l, r);
1377 	  break;
1378 
1379 	case OPSTAR:
1380 	  p = mulivals(l, r);
1381 	  break;
1382 
1383 	case OPSLASH:
1384 	  p = divivals(l, r);
1385 	  break;
1386 
1387 	case OPPOWER:
1388 	  p = powivals(l, r);
1389 	  break;
1390 	}
1391 
1392       frvexpr(l);
1393       frvexpr(r);
1394       break;
1395 
1396     case DERROR:
1397       p = (vexpr *) ALLOC(Dvalue);
1398       p->tag = DVALUE;
1399       p->dvalue.status = ERRVAL;
1400       break;
1401     }
1402 
1403   return (p);
1404 }
1405 
1406 
1407 
1408 vexpr *
1409 refrigdname(vp)
1410 vexpr *vp;
1411 {
1412   register vexpr *p;
1413   register int len;
1414   register char *repr;
1415   register int found;
1416   register dovars *dvp;
1417 
1418   len = vp->dname.len;
1419   repr = vp->dname.repr;
1420 
1421   found = NO;
1422   dvp = dvlist;
1423   while (found == NO && dvp != NULL)
1424     {
1425       if (len == dvp->len && eqn(len, repr, dvp->repr))
1426 	found = YES;
1427       else
1428 	dvp = dvp->next;
1429     }
1430 
1431   if (found == YES)
1432     {
1433       p = (vexpr *) ALLOC(Dvar);
1434       p->tag = DVAR;
1435       p->dvar.valp = dvp->valp;
1436     }
1437   else
1438     {
1439       p = evaldname(vp);
1440       if (p->dvalue.status == ERRVAL)
1441 	dataerror = YES;
1442     }
1443 
1444   return (p);
1445 }
1446 
1447 
1448 
1449 refrigvexpr(vpp)
1450 vexpr **vpp;
1451 {
1452   register vexpr *vp;
1453 
1454   vp = *vpp;
1455 
1456   switch (vp->tag)
1457     {
1458     case DVALUE:
1459     case DVAR:
1460     case DERROR:
1461       break;
1462 
1463     case DEXPR:
1464       refrigvexpr( &(vp->dexpr.left) );
1465       refrigvexpr( &(vp->dexpr.right) );
1466       break;
1467 
1468     case DNAME:
1469       *(vpp) = refrigdname(vp);
1470       frvexpr(vp);
1471       break;
1472     }
1473 
1474   return;
1475 }
1476 
1477 
1478 
1479 int
1480 chkvar(np, sname)
1481 Namep np;
1482 char *sname;
1483 {
1484   static char *nonvar = "%s is not a variable";
1485   static char *arginit = "attempt to initialize a dummy argument: %s";
1486   static char *autoinit = "attempt to initialize an automatic variable: %s";
1487   static char *badclass = "bad class in chkvar";
1488 
1489   register int status;
1490   register struct Dimblock *dp;
1491   register int i;
1492 
1493   status = YES;
1494 
1495   if (np->vclass == CLUNKNOWN
1496       || (np->vclass == CLVAR && !np->vdcldone))
1497     vardcl(np);
1498 
1499   if (np->vstg == STGARG)
1500     {
1501       errstr(arginit, sname);
1502       dataerror = YES;
1503       status = NO;
1504     }
1505   else if (np->vclass != CLVAR)
1506     {
1507       errstr(nonvar, sname);
1508       dataerror = YES;
1509       status = NO;
1510     }
1511   else if (np->vstg == STGAUTO)
1512     {
1513       errstr(autoinit, sname);
1514       dataerror = YES;
1515       status = NO;
1516     }
1517   else if (np->vstg != STGBSS && np->vstg != STGINIT
1518 	    && np->vstg != STGCOMMON && np->vstg != STGEQUIV)
1519     {
1520       fatal(badclass);
1521     }
1522   else
1523     {
1524       switch (np->vtype)
1525 	{
1526 	case TYERROR:
1527 	  status = NO;
1528 	  dataerror = YES;
1529 	  break;
1530 
1531 	case TYSHORT:
1532 	case TYLONG:
1533 	case TYREAL:
1534 	case TYDREAL:
1535 	case TYCOMPLEX:
1536 	case TYDCOMPLEX:
1537 	case TYLOGICAL:
1538 	case TYCHAR:
1539 	  dp = np->vdim;
1540 	  if (dp != NULL)
1541 	    {
1542 	      if (dp->nelt == NULL || !ISICON(dp->nelt))
1543 	        {
1544 	          status = NO;
1545 	          dataerror = YES;
1546 	        }
1547 	    }
1548 	  break;
1549 
1550 	default:
1551 	  badtype("chkvar", np->vtype);
1552 	}
1553     }
1554 
1555   return (status);
1556 }
1557 
1558 
1559 
1560 refrigsubs(ap, sname)
1561 aelt *ap;
1562 char *sname;
1563 {
1564   static char *nonarray = "subscripts on a simple variable:  %s";
1565   static char *toofew = "not enough subscripts on %s";
1566   static char *toomany = "too many subscripts on %s";
1567 
1568   register vlist *subp;
1569   register int nsubs;
1570   register Namep np;
1571   register struct Dimblock *dp;
1572   register int i;
1573 
1574   np = ap->var;
1575   dp = np->vdim;
1576 
1577   if (ap->subs != NULL)
1578     {
1579       if (np->vdim == NULL)
1580 	{
1581 	  errstr(nonarray, sname);
1582 	  dataerror = YES;
1583 	}
1584       else
1585 	{
1586 	  nsubs = 0;
1587 	  subp = ap->subs;
1588 	  while (subp != NULL)
1589 	    {
1590 	      nsubs++;
1591 	      refrigvexpr( &(subp->val) );
1592 	      subp = subp->next;
1593 	    }
1594 
1595 	  if (dp->ndim != nsubs)
1596 	    {
1597 	      if (np->vdim->ndim > nsubs)
1598 		errstr(toofew, sname);
1599 	      else
1600 		errstr(toomany, sname);
1601 	      dataerror = YES;
1602 	    }
1603 	  else if (dp->baseoffset == NULL || !ISICON(dp->baseoffset))
1604 	    dataerror = YES;
1605 	  else
1606 	    {
1607 	      i = dp->ndim;
1608 	      while (i-- > 0)
1609 		{
1610 		  if (dp->dims[i].dimsize == NULL
1611 		      || !ISICON(dp->dims[i].dimsize))
1612 		    dataerror = YES;
1613 		}
1614 	    }
1615 	}
1616     }
1617 
1618   return;
1619 }
1620 
1621 
1622 
1623 refrigrange(ap, sname)
1624 aelt *ap;
1625 char *sname;
1626 {
1627   static char *nonstr = "substring of a noncharacter variable:  %s";
1628   static char *array = "substring applied to an array:  %s";
1629 
1630   register Namep np;
1631   register dvalue *t;
1632   register rpair *rp;
1633 
1634   if (ap->range != NULL)
1635     {
1636       np = ap->var;
1637       if (np->vtype != TYCHAR)
1638 	{
1639 	  errstr(nonstr, sname);
1640 	  dataerror = YES;
1641 	}
1642       else if (ap->subs == NULL && np->vdim != NULL)
1643 	{
1644 	  errstr(array, sname);
1645 	  dataerror = YES;
1646 	}
1647       else
1648 	{
1649 	  rp = ap->range;
1650 
1651 	  if (rp->low != NULL)
1652 	    refrigvexpr( &(rp->low) );
1653 	  else
1654 	    {
1655 	      t = ALLOC(Dvalue);
1656 	      t->tag = DVALUE;
1657 	      t->status = NORMAL;
1658 	      t->value = 1;
1659 	      rp->low = (vexpr *) t;
1660 	    }
1661 
1662 	  if (rp->high != NULL)
1663 	    refrigvexpr( &(rp->high) );
1664 	  else
1665 	    {
1666 	      if (!ISICON(np->vleng))
1667 		{
1668 		  rp->high = (vexpr *) ALLOC(Derror);
1669 		  rp->high->tag = DERROR;
1670 		}
1671 	      else
1672 		{
1673 		  t = ALLOC(Dvalue);
1674 		  t->tag = DVALUE;
1675 		  t->status = NORMAL;
1676 		  t->value = np->vleng->constblock.constant.ci;
1677 		  rp->high = (vexpr *) t;
1678 		}
1679 	    }
1680 	}
1681     }
1682 
1683   return;
1684 }
1685 
1686 
1687 
1688 refrigaelt(ap)
1689 aelt *ap;
1690 {
1691   register Namep np;
1692   register char *bp, *sp;
1693   register int len;
1694   char buff[VL+1];
1695 
1696   np = ap->var;
1697 
1698   len = 0;
1699   bp = buff;
1700   sp = np->varname;
1701   while (len < VL && *sp != ' ' && *sp != '\0')
1702     {
1703       *bp++ = *sp++;
1704       len++;
1705     }
1706   *bp = '\0';
1707 
1708   if (chkvar(np, buff))
1709     {
1710       refrigsubs(ap, buff);
1711       refrigrange(ap, buff);
1712     }
1713 
1714   return;
1715 }
1716 
1717 
1718 
1719 refrigdo(dp)
1720 dolist *dp;
1721 {
1722   static char *duplicates = "implied DO variable %s redefined";
1723   static char *nonvar = "%s is not a variable";
1724   static char *nonint = "%s is not integer";
1725 
1726   register int len;
1727   register char *repr;
1728   register int found;
1729   register dovars *dvp;
1730   register Namep np;
1731   register dovars *t;
1732 
1733   refrigvexpr( &(dp->init) );
1734   refrigvexpr( &(dp->limit) );
1735   refrigvexpr( &(dp->step) );
1736 
1737   len = dp->dovar->dname.len;
1738   repr = dp->dovar->dname.repr;
1739 
1740   found = NO;
1741   dvp = dvlist;
1742   while (found == NO && dvp != NULL)
1743     if (len == dvp->len && eqn(len, repr, dvp->repr))
1744       found = YES;
1745     else
1746       dvp = dvp->next;
1747 
1748   if (found == YES)
1749     {
1750       errnm(duplicates, len, repr);
1751       dataerror = YES;
1752     }
1753   else
1754     {
1755       np = getname(len, repr);
1756       if (np == NULL)
1757 	{
1758 	  if (!ISINT(impltype[letter(*repr)]))
1759 	    warnnm(nonint, len, repr);
1760 	}
1761       else
1762 	{
1763 	  if (np->vclass == CLUNKNOWN)
1764 	    vardcl(np);
1765 	  if (np->vclass != CLVAR)
1766 	    warnnm(nonvar, len, repr);
1767 	  else if (!ISINT(np->vtype))
1768 	    warnnm(nonint, len, repr);
1769 	}
1770     }
1771 
1772   t = ALLOC(DoVars);
1773   t->next = dvlist;
1774   t->len = len;
1775   t->repr = repr;
1776   t->valp = ALLOC(Dvalue);
1777   t->valp->tag = DVALUE;
1778   dp->dovar = (vexpr *) t->valp;
1779 
1780   dvlist = t;
1781 
1782   refriglvals(dp->elts);
1783 
1784   dvlist = t->next;
1785   free((char *) t);
1786 
1787   return;
1788 }
1789 
1790 
1791 
1792 refriglvals(lvals)
1793 elist *lvals;
1794 {
1795   register elist *top;
1796 
1797   top = lvals;
1798 
1799   while (top != NULL)
1800     {
1801       if (top->elt->tag == SIMPLE)
1802 	refrigaelt((aelt *) top->elt);
1803       else
1804 	refrigdo((dolist *) top->elt);
1805 
1806       top = top->next;
1807     }
1808 
1809   return;
1810 }
1811 
1812 
1813 
1814 /*  Refrig freezes name/value bindings in the DATA name list  */
1815 
1816 
1817 refrig(lvals)
1818 elist *lvals;
1819 {
1820   dvlist = NULL;
1821   refriglvals(lvals);
1822   return;
1823 }
1824 
1825 
1826 
1827 ftnint
1828 indexer(ap)
1829 aelt *ap;
1830 {
1831   static char *badvar = "bad variable in indexer";
1832   static char *boundserror = "subscript out of bounds";
1833 
1834   register ftnint index;
1835   register vlist *sp;
1836   register Namep np;
1837   register struct Dimblock *dp;
1838   register int i;
1839   register dvalue *vp;
1840   register ftnint size;
1841   ftnint sub[MAXDIM];
1842 
1843   sp = ap->subs;
1844   if (sp == NULL) return (0);
1845 
1846   np = ap->var;
1847   dp = np->vdim;
1848 
1849   if (dp == NULL)
1850     fatal(badvar);
1851 
1852   i = 0;
1853   while (sp != NULL)
1854     {
1855       vp = (dvalue *) evalvexpr(sp->val);
1856 
1857       if (vp->status == NORMAL)
1858 	sub[i++] = vp->value;
1859       else if ((MININT + MAXINT == -1) && vp->status == MINLESS1)
1860 	sub[i++] = MININT;
1861       else
1862 	{
1863 	  frvexpr((vexpr *) vp);
1864 	  return (-1);
1865 	}
1866 
1867       frvexpr((vexpr *) vp);
1868       sp = sp->next;
1869     }
1870 
1871   index = sub[--i];
1872   while (i-- > 0)
1873     {
1874       size = dp->dims[i].dimsize->constblock.constant.ci;
1875       index = sub[i] + index * size;
1876     }
1877 
1878   index -= dp->baseoffset->constblock.constant.ci;
1879 
1880   if (index < 0 || index >= dp->nelt->constblock.constant.ci)
1881     {
1882       err(boundserror);
1883       return (-1);
1884     }
1885 
1886   return (index);
1887 }
1888 
1889 
1890 
1891 savedata(lvals, rvals)
1892 elist *lvals;
1893 vallist *rvals;
1894 {
1895   static char *toomany = "more data values than data items";
1896 
1897   register elist *top;
1898 
1899   dataerror = NO;
1900   badvalue = NO;
1901 
1902   lvals = revelist(lvals);
1903   grvals = revrvals(rvals);
1904 
1905   refrig(lvals);
1906 
1907   if (!dataerror)
1908     outdata(lvals);
1909 
1910   frelist(lvals);
1911 
1912   while (grvals != NULL && dataerror == NO)
1913     {
1914       if (grvals->status != NORMAL)
1915 	dataerror = YES;
1916       else if (grvals->repl <= 0)
1917         grvals = grvals->next;
1918       else
1919 	{
1920 	  err(toomany);
1921 	  dataerror = YES;
1922 	}
1923     }
1924 
1925   frvallist(grvals);
1926 
1927   return;
1928 }
1929 
1930 
1931 
1932 setdfiles(np)
1933 register Namep np;
1934 {
1935   register struct Extsym *cp;
1936   register struct Equivblock *ep;
1937   register int stg;
1938   register int type;
1939   register ftnint typelen;
1940   register ftnint nelt;
1941   register ftnint varsize;
1942 
1943   stg = np->vstg;
1944 
1945   if (stg == STGBSS || stg == STGINIT)
1946     {
1947       datafile = vdatafile;
1948       chkfile = vchkfile;
1949       if (np->init == YES)
1950 	base = np->initoffset;
1951       else
1952 	{
1953 	  np->init = YES;
1954 	  np->initoffset = base = vdatahwm;
1955 	  if (np->vdim != NULL)
1956 	    nelt = np->vdim->nelt->constblock.constant.ci;
1957 	  else
1958 	    nelt = 1;
1959 	  type = np->vtype;
1960 	  if (type == TYCHAR)
1961 	    typelen = np->vleng->constblock.constant.ci;
1962 	  else if (type == TYLOGICAL)
1963 	    typelen = typesize[tylogical];
1964 	  else
1965 	    typelen = typesize[type];
1966 	  varsize = nelt * typelen;
1967 	  vdatahwm += varsize;
1968 	}
1969     }
1970   else if (stg == STGEQUIV)
1971     {
1972       datafile = vdatafile;
1973       chkfile = vchkfile;
1974       ep = &eqvclass[np->vardesc.varno];
1975       if (ep->init == YES)
1976 	base = ep->initoffset;
1977       else
1978 	{
1979 	  ep->init = YES;
1980 	  ep->initoffset = base = vdatahwm;
1981 	  vdatahwm += ep->eqvleng;
1982 	}
1983       base += np->voffset;
1984     }
1985   else if (stg == STGCOMMON)
1986     {
1987       datafile = cdatafile;
1988       chkfile = cchkfile;
1989       cp = &extsymtab[np->vardesc.varno];
1990       if (cp->init == YES)
1991 	base = cp->initoffset;
1992       else
1993 	{
1994 	  cp->init = YES;
1995 	  cp->initoffset = base = cdatahwm;
1996 	  cdatahwm += cp->maxleng;
1997 	}
1998       base += np->voffset;
1999     }
2000 
2001   return;
2002 }
2003 
2004 
2005 
2006 wrtdata(offset, repl, len, constant)
2007 long offset;
2008 ftnint repl;
2009 ftnint len;
2010 char *constant;
2011 {
2012   static char *badoffset = "bad offset in wrtdata";
2013   static char *toomuch = "too much data";
2014   static char *readerror = "read error on tmp file";
2015   static char *writeerror = "write error on tmp file";
2016   static char *seekerror = "seek error on tmp file";
2017 
2018   register ftnint k;
2019   long lastbyte;
2020   int bitpos;
2021   long chkoff;
2022   long lastoff;
2023   long chklen;
2024   long pos;
2025   int n;
2026   ftnint nbytes;
2027   int mask;
2028   register int i;
2029   char overlap;
2030   char allzero;
2031   char buff[BUFSIZ];
2032 
2033   if (offset < 0)
2034     fatal(badoffset);
2035 
2036   overlap = NO;
2037 
2038   k = repl * len;
2039   lastbyte = offset + k - 1;
2040   if (lastbyte < 0)
2041     {
2042       err(toomuch);
2043       dataerror = YES;
2044       return;
2045     }
2046 
2047   bitpos = offset % BYTESIZE;
2048   chkoff = offset/BYTESIZE;
2049   lastoff = lastbyte/BYTESIZE;
2050   chklen = lastoff - chkoff + 1;
2051 
2052   pos = lseek(chkfile, chkoff, 0);
2053   if (pos == -1)
2054     {
2055       err(seekerror);
2056       done(1);
2057     }
2058 
2059   while (k > 0)
2060     {
2061       if (chklen <= BUFSIZ)
2062 	n = chklen;
2063       else
2064 	{
2065 	  n = BUFSIZ;
2066 	  chklen -= BUFSIZ;
2067 	}
2068 
2069       nbytes = read(chkfile, buff, n);
2070       if (nbytes < 0)
2071 	{
2072 	  err(readerror);
2073 	  done(1);
2074 	}
2075 
2076       if (nbytes == 0)
2077 	buff[0] = '\0';
2078 
2079       if (nbytes < n)
2080 	buff[ n-1 ] = '\0';
2081 
2082       i = 0;
2083 
2084       if (bitpos > 0)
2085 	{
2086 	  while (k > 0 && bitpos < BYTESIZE)
2087 	    {
2088 	      mask = 1 << bitpos;
2089 
2090 	      if (mask & buff[0])
2091 		overlap = YES;
2092 	      else
2093 		buff[0] |= mask;
2094 
2095 	      k--;
2096 	      bitpos++;
2097 	    }
2098 
2099 	  if (bitpos == BYTESIZE)
2100 	    {
2101 	      bitpos = 0;
2102 	      i++;
2103 	    }
2104 	}
2105 
2106       while (i < nbytes && overlap == NO)
2107 	{
2108 	  if (buff[i] == 0 && k >= BYTESIZE)
2109 	    {
2110 	      buff[i++] = MAXBYTE;
2111 	      k -= BYTESIZE;
2112 	    }
2113 	  else if (k < BYTESIZE)
2114 	    {
2115 	      while (k-- > 0)
2116 		{
2117 		  mask = 1 << k;
2118 		  if (mask & buff[i])
2119 		    overlap = YES;
2120 		  else
2121 		    buff[i] |= mask;
2122 		}
2123 	      i++;
2124 	    }
2125 	  else
2126 	    {
2127 	      overlap = YES;
2128 	      buff[i++] = MAXBYTE;
2129 	      k -= BYTESIZE;
2130 	    }
2131 	}
2132 
2133       while (i < n)
2134 	{
2135 	  if (k >= BYTESIZE)
2136 	    {
2137 	      buff[i++] = MAXBYTE;
2138 	      k -= BYTESIZE;
2139 	    }
2140 	  else
2141 	    {
2142 	      while (k-- > 0)
2143 		{
2144 		  mask = 1 << k;
2145 		  buff[i] |= mask;
2146 		}
2147 	      i++;
2148 	    }
2149 	}
2150 
2151       pos = lseek(chkfile, -nbytes, 1);
2152       if (pos == -1)
2153 	{
2154 	  err(seekerror);
2155 	  done(1);
2156 	}
2157 
2158       nbytes = write(chkfile, buff, n);
2159       if (nbytes != n)
2160 	{
2161 	  err(writeerror);
2162 	  done(1);
2163 	}
2164     }
2165 
2166   if (overlap == NO)
2167     {
2168       allzero = YES;
2169       k = len;
2170 
2171       while (k > 0 && allzero != NO)
2172 	if (constant[--k] != 0) allzero = NO;
2173 
2174       if (allzero == YES)
2175 	return;
2176     }
2177 
2178   pos = lseek(datafile, offset, 0);
2179   if (pos == -1)
2180     {
2181       err(seekerror);
2182       done(1);
2183     }
2184 
2185   k = repl;
2186   while (k-- > 0)
2187     {
2188       nbytes = write(datafile, constant, len);
2189       if (nbytes != len)
2190 	{
2191 	  err(writeerror);
2192 	  done(1);
2193 	}
2194     }
2195 
2196   if (overlap) overlapflag = YES;
2197 
2198   return;
2199 }
2200 
2201 
2202 
2203 Constp
2204 getdatum()
2205 {
2206   static char *toofew = "more data items than data values";
2207 
2208   register vallist *t;
2209 
2210   while (grvals != NULL)
2211     {
2212       if (grvals->status != NORMAL)
2213 	{
2214 	  dataerror = YES;
2215 	  return (NULL);
2216 	}
2217       else if (grvals->repl > 0)
2218 	{
2219 	  grvals->repl--;
2220 	  return (grvals->value);
2221 	}
2222       else
2223 	{
2224 	  badvalue = 0;
2225 	  frexpr ((tagptr) grvals->value);
2226 	  t = grvals;
2227 	  grvals = t->next;
2228 	  free((char *) t);
2229 	}
2230     }
2231 
2232   err(toofew);
2233   dataerror = YES;
2234   return (NULL);
2235 }
2236 
2237 
2238 
2239 outdata(lvals)
2240 elist *lvals;
2241 {
2242   register elist *top;
2243 
2244   top = lvals;
2245 
2246   while (top != NULL && dataerror == NO)
2247     {
2248       if (top->elt->tag == SIMPLE)
2249 	outaelt((aelt *) top->elt);
2250       else
2251 	outdolist((dolist *) top->elt);
2252 
2253       top = top->next;
2254     }
2255 
2256   return;
2257 }
2258 
2259 
2260 
2261 outaelt(ap)
2262 aelt *ap;
2263 {
2264   static char *toofew = "more data items than data values";
2265   static char *boundserror = "substring expression out of bounds";
2266   static char *order = "substring expressions out of order";
2267 
2268   register Namep np;
2269   register long soffset;
2270   register dvalue *lwb;
2271   register dvalue *upb;
2272   register Constp constant;
2273   register int k;
2274   register vallist *t;
2275   register int type;
2276   register ftnint typelen;
2277   register ftnint repl;
2278 
2279   extern char *packbytes();
2280 
2281   np = ap->var;
2282   setdfiles(np);
2283 
2284   type = np->vtype;
2285 
2286   if (type == TYCHAR)
2287     typelen = np->vleng->constblock.constant.ci;
2288   else if (type == TYLOGICAL)
2289     typelen = typesize[tylogical];
2290   else
2291     typelen = typesize[type];
2292 
2293   if (ap->subs != NULL || np->vdim == NULL)
2294     {
2295       soffset = indexer(ap);
2296       if (soffset == -1)
2297 	{
2298 	  dataerror = YES;
2299 	  return;
2300 	}
2301 
2302       soffset = soffset * typelen;
2303 
2304       if (ap->range != NULL)
2305 	{
2306 	  lwb = (dvalue *) evalvexpr(ap->range->low);
2307 	  upb = (dvalue *) evalvexpr(ap->range->high);
2308 	  if (lwb->status == ERRVAL || upb->status == ERRVAL)
2309 	    {
2310 	      frvexpr((vexpr *) lwb);
2311 	      frvexpr((vexpr *) upb);
2312 	      dataerror = YES;
2313 	      return;
2314 	    }
2315 
2316 	  if (lwb->status != NORMAL ||
2317 	      lwb->value < 1 ||
2318 	      lwb->value > typelen ||
2319 	      upb->status != NORMAL ||
2320 	      upb->value < 1 ||
2321 	      upb->value > typelen)
2322 	    {
2323 	      err(boundserror);
2324 	      frvexpr((vexpr *) lwb);
2325 	      frvexpr((vexpr *) upb);
2326 	      dataerror = YES;
2327 	      return;
2328 	    }
2329 
2330 	  if (lwb->value > upb->value)
2331 	    {
2332 	      err(order);
2333 	      frvexpr((vexpr *) lwb);
2334 	      frvexpr((vexpr *) upb);
2335 	      dataerror = YES;
2336 	      return;
2337 	    }
2338 
2339 	  soffset = soffset + lwb->value - 1;
2340 	  typelen = upb->value - lwb->value + 1;
2341 	  frvexpr((vexpr *) lwb);
2342 	  frvexpr((vexpr *) upb);
2343 	}
2344 
2345       constant = getdatum();
2346       if (constant == NULL || !ISCONST(constant))
2347 	return;
2348 
2349       constant = (Constp) convconst(type, typelen, constant);
2350       if (constant == NULL || !ISCONST(constant))
2351 	{
2352 	  frexpr((tagptr) constant);
2353 	  return;
2354 	}
2355 
2356       if (type == TYCHAR)
2357 	wrtdata(base + soffset, 1, typelen, constant->constant.ccp);
2358       else
2359 	wrtdata(base + soffset, 1, typelen, packbytes(constant));
2360 
2361       frexpr((tagptr) constant);
2362     }
2363   else
2364     {
2365       soffset = 0;
2366       k = np->vdim->nelt->constblock.constant.ci;
2367       while (k > 0 && dataerror == NO)
2368 	{
2369 	  if (grvals == NULL)
2370 	    {
2371 	      err(toofew);
2372 	      dataerror = YES;
2373 	    }
2374 	  else if (grvals->status != NORMAL)
2375 	    dataerror = YES;
2376 	  else if (grvals-> repl <= 0)
2377 	    {
2378 	      badvalue = 0;
2379 	      frexpr((tagptr) grvals->value);
2380 	      t = grvals;
2381 	      grvals = t->next;
2382 	      free((char *) t);
2383 	    }
2384 	  else
2385 	    {
2386 	      constant = grvals->value;
2387 	      if (constant == NULL || !ISCONST(constant))
2388 		{
2389 		  dataerror = YES;
2390 		}
2391 	      else
2392 		{
2393 		  constant = (Constp) convconst(type, typelen, constant);
2394 		  if (constant == NULL || !ISCONST(constant))
2395 		    {
2396 		      dataerror = YES;
2397 		      frexpr((tagptr) constant);
2398 		    }
2399 		  else
2400 		    {
2401 		      if (k > grvals->repl)
2402 			repl = grvals->repl;
2403 		      else
2404 			repl = k;
2405 
2406 		      grvals->repl -= repl;
2407 		      k -= repl;
2408 
2409 		      if (type == TYCHAR)
2410 			wrtdata(base+soffset, repl, typelen,
2411 			    constant->constant.ccp);
2412 		      else
2413 			wrtdata(base+soffset, repl, typelen,
2414 			    packbytes(constant));
2415 
2416 		      soffset = soffset + repl * typelen;
2417 
2418 		      frexpr((tagptr) constant);
2419 		    }
2420 		}
2421 	    }
2422 	}
2423     }
2424 
2425   return;
2426 }
2427 
2428 
2429 
2430 outdolist(dp)
2431 dolist *dp;
2432 {
2433   static char *zerostep = "zero step in implied-DO";
2434   static char *order = "zero iteration count in implied-DO";
2435 
2436   register dvalue *e1, *e2, *e3;
2437   register int direction;
2438   register dvalue *dv;
2439   register int done;
2440   register int addin;
2441   register int ts;
2442   register ftnint tv;
2443 
2444   e1 = (dvalue *) evalvexpr(dp->init);
2445   e2 = (dvalue *) evalvexpr(dp->limit);
2446   e3 = (dvalue *) evalvexpr(dp->step);
2447 
2448   if (e1->status == ERRVAL ||
2449       e2->status == ERRVAL ||
2450       e3->status == ERRVAL)
2451     {
2452       dataerror = YES;
2453       goto ret;
2454     }
2455 
2456   if (e1->status == NORMAL)
2457     {
2458       if (e2->status == NORMAL)
2459 	{
2460 	  if (e1->value < e2->value)
2461 	    direction = 1;
2462 	  else if (e1->value > e2->value)
2463 	    direction = -1;
2464 	  else
2465 	    direction = 0;
2466 	}
2467       else if (e2->status == MAXPLUS1)
2468 	direction = 1;
2469       else
2470 	direction = -1;
2471     }
2472   else if (e1->status == MAXPLUS1)
2473     {
2474       if (e2->status == MAXPLUS1)
2475 	direction = 0;
2476       else
2477 	direction = -1;
2478     }
2479   else
2480     {
2481       if (e2->status == MINLESS1)
2482 	direction = 0;
2483       else
2484 	direction = 1;
2485     }
2486 
2487   if (e3->status == NORMAL && e3->value == 0)
2488     {
2489       err(zerostep);
2490       dataerror = YES;
2491       goto ret;
2492     }
2493   else if (e3->status == MAXPLUS1 ||
2494 	   (e3->status == NORMAL && e3->value > 0))
2495     {
2496       if (direction == -1)
2497 	{
2498 	  warn(order);
2499 	  goto ret;
2500 	}
2501     }
2502   else
2503     {
2504       if (direction == 1)
2505 	{
2506 	  warn(order);
2507 	  goto ret;
2508 	}
2509     }
2510 
2511   dv = (dvalue *) dp->dovar;
2512   dv->status = e1->status;
2513   dv->value = e1->value;
2514 
2515   done = NO;
2516   while (done == NO && dataerror == NO)
2517     {
2518       outdata(dp->elts);
2519 
2520       if (e3->status == NORMAL && dv->status == NORMAL)
2521 	{
2522 	  addints(e3->value, dv->value);
2523 	  dv->status = rstatus;
2524 	  dv->value = rvalue;
2525 	}
2526       else
2527 	{
2528 	  if (e3->status != NORMAL)
2529 	    {
2530 	      if (e3->status == MAXPLUS1)
2531 		addin = MAXPLUS1;
2532 	      else
2533 		addin = MINLESS1;
2534 	      ts = dv->status;
2535 	      tv = dv->value;
2536 	    }
2537 	  else
2538 	    {
2539 	      if (dv->status == MAXPLUS1)
2540 		addin = MAXPLUS1;
2541 	      else
2542 		addin = MINLESS1;
2543 	      ts = e3->status;
2544 	      tv = e3->value;
2545 	    }
2546 
2547 	  if (addin == MAXPLUS1)
2548 	    {
2549 	      if (ts == MAXPLUS1 || (ts == NORMAL && tv > 0))
2550 		dv->status = ERRVAL;
2551 	      else if (ts == NORMAL && tv == 0)
2552 		dv->status = MAXPLUS1;
2553 	      else if (ts == NORMAL)
2554 		{
2555 		  dv->status = NORMAL;
2556 		  dv->value = tv + MAXINT;
2557 		  dv->value++;
2558 		}
2559 	      else
2560 		{
2561 		  dv->status = NORMAL;
2562 		  dv->value = 0;
2563 		}
2564 	    }
2565 	  else
2566 	    {
2567 	      if (ts == MINLESS1 || (ts == NORMAL && tv < 0))
2568 		dv->status = ERRVAL;
2569 	      else if (ts == NORMAL && tv == 0)
2570 		dv->status = MINLESS1;
2571 	      else if (ts == NORMAL)
2572 		{
2573 		  dv->status = NORMAL;
2574 		  dv->value = tv - MAXINT;
2575 		  dv->value--;
2576 		}
2577 	      else
2578 		{
2579 		  dv->status = NORMAL;
2580 		  dv->value = 0;
2581 		}
2582 	    }
2583 	}
2584 
2585       if (dv->status == ERRVAL)
2586 	done = YES;
2587       else if (direction > 0)
2588 	{
2589 	  if (e2->status == NORMAL)
2590 	    {
2591 	      if (dv->status == MAXPLUS1 ||
2592 		  (dv->status == NORMAL && dv->value > e2->value))
2593 		done = YES;
2594 	    }
2595 	}
2596       else if (direction < 0)
2597 	{
2598 	  if (e2->status == NORMAL)
2599 	    {
2600 	      if (dv->status == MINLESS1 ||
2601 		  (dv->status == NORMAL && dv->value < e2->value))
2602 		done = YES;
2603 	    }
2604 	}
2605       else
2606 	done = YES;
2607     }
2608 
2609 ret:
2610   frvexpr((vexpr *) e1);
2611   frvexpr((vexpr *) e2);
2612   frvexpr((vexpr *) e3);
2613   return;
2614 }
2615