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