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