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