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 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
mkdatado(lvals,dovar,params)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
mkdrange(lb,ub)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
mkdrval(repl,val)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
evicon(len,token)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
ivaltoicon(vp)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
mkdname(len,str)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
getname(l,s)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
evparam(np)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
evaldname(dp)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
mkdexpr(op,l,r)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
addivals(l,r)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
negival(vp)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
subivals(l,r)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
mulivals(l,r)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
divivals(l,r)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
powivals(l,r)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
addints(i,j)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
mulints(i,j)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 *
evalvexpr(ep)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 *
refrigdname(vp)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
refrigvexpr(vpp)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
chkvar(np,sname)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
refrigsubs(ap,sname)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
refrigrange(ap,sname)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
refrigaelt(ap)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
refrigdo(dp)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
refriglvals(lvals)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
refrig(lvals)1814 refrig(lvals)
1815 elist *lvals;
1816 {
1817 dvlist = NULL;
1818 refriglvals(lvals);
1819 return;
1820 }
1821
1822
1823
1824 ftnint
indexer(ap)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
savedata(lvals,rvals)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
setdfiles(np)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
wrtdata(offset,repl,len,constant)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
getdatum()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
outdata(lvals)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
outaelt(ap)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
outdolist(dp)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