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