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