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