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