projects / unix-history / blame
? search:
summary | tags | clone url | shortlog | log | commit | commitdiff | tree
blob | blame (incremental) | history | HEAD
BSD 4_3_Tahoe release
[unix-history] / usr / src / usr.bin / f77 / f77.tahoe / f77pass1 / data.c
CommitLineData
099b7138
KM		 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
95f51977 8static char sccsid[] = "@(#)data.c 5.1 (Berkeley) 6/7/85";
099b7138
KM		 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
29flag overlapflag;
30
31
32
33/* local variables */
34
35LOCAL char rstatus;
36LOCAL ftnint rvalue;
37LOCAL dovars *dvlist;
38LOCAL int dataerror;
39LOCAL vallist *grvals;
40LOCAL int datafile;
41LOCAL int chkfile;
42LOCAL long base;
43
44\f
45
46/* Copied from expr.c */
47
48LOCAL letter(c)
49register int c;
50{
51if( isupper(c) )
52 c = tolower(c);
53return(c - 'a');
54}
55
56\f
57
58vexpr *
59cpdvalue(dp)
60vexpr *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\f
76
77frvexpr(vp)
78register 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\f
97
98frvlist(vp)
99register 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\f
115
116frelist(ep)
117elist *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\f
160
161frvallist(vp)
162vallist *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\f
180
181elist *revelist(ep)
182register 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\f
205
206vlist *revvlist(vp)
207vlist *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\f
234
235vallist *
236revrvals(vp)
237vallist *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\f
263
264vlist *prepvexpr(tail, head)
265vlist *tail;
266vexpr *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\f
278
279elist *preplval(tail, head)
280elist *tail;
281delt* 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\f
292
293delt *mkdlval(name, subs, range)
294vexpr *name;
295vlist *subs;
296rpair *range;
297{
ca67e7b4 298 static char *iscomm =" improper initialization for variable in COMMON";
099b7138
KM		 299 register aelt *p;
300
301 p = ALLOC(Aelt);
302 p->tag = SIMPLE;
303 p->var = mkname(name->dname.len, name->dname.repr);
ca67e7b4
C		 304 if ((procclass != CLBLOCK) && (p->var->vstg == STGCOMMON))
305 warn(iscomm);
099b7138
KM		 306 p->subs = subs;
307 p->range = range;
308
309 return ((delt *) p);
310}
311
312\f
313
314delt *mkdatado(lvals, dovar, params)
315elist *lvals;
316vexpr *dovar;
317vlist *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\f
388
389rpair *mkdrange(lb, ub)
390vexpr *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\f
402
403vallist *mkdrval(repl, val)
404vexpr *repl;
405expptr 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\f
473
474/* Evicon returns the value of the integer constant */
475/* pointed to by token. */
476
477vexpr *evicon(len, token)
478register int len;
479register 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
529ret:
530 return ((vexpr *) p);
531}
532
533\f
534
535/* Ivaltoicon converts a dvalue into a constant block. */
536
537expptr ivaltoicon(vp)
538register 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\f
568
569/* Mkdname stores an identifier as a dname */
570
571vexpr *mkdname(len, str)
572int len;
573register 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\f
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
601Namep getname(l, s)
602int l;
603register 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
631ret:
632 return (q);
633}
634
635\f
636
637/* Evparam returns the value of the constant named by name. */
638
639expptr evparam(np)
640register 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\f
677
678vexpr *evaldname(dp)
679vexpr *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\f
730
731vexpr *mkdexpr(op, l, r)
732register int op;
733register vexpr *l;
734register 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\f
807
808vexpr *addivals(l, r)
809vexpr *l;
810vexpr *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\f
898
899vexpr *negival(vp)
900vexpr *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\f
931
932vexpr *subivals(l, r)
933vexpr *l;
934vexpr *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\f
952
953vexpr *mulivals(l, r)
954vexpr *l;
955vexpr *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\f
1018
1019vexpr *divivals(l, r)
1020vexpr *l;
1021vexpr *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\f
1099
1100vexpr *powivals(l, r)
1101vexpr *l;
1102vexpr *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\f
1233
1234/* Addints adds two integer values. */
1235
1236addints(i, j)
1237register 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\f
1277
1278/* Mulints multiplies two integer values */
1279
1280mulints(i, j)
1281register 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\f
1331
1332vexpr *
1333evalvexpr(ep)
1334vexpr *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\f
1406
1407vexpr *
1408refrigdname(vp)
1409vexpr *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\f
1447
1448refrigvexpr(vpp)
1449vexpr **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\f
1477
1478int
1479chkvar(np, sname)
1480Namep np;
1481char *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\f
1558
1559refrigsubs(ap, sname)
1560aelt *ap;
1561char *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\f
1621
1622refrigrange(ap, sname)
1623aelt *ap;
1624char *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\f
1686
1687refrigaelt(ap)
1688aelt *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\f
1717
1718refrigdo(dp)
1719dolist *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\f
1790
1791refriglvals(lvals)
1792elist *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\f
1812
1813/* Refrig freezes name/value bindings in the DATA name list */
1814
1815
1816refrig(lvals)
1817elist *lvals;
1818{
1819 dvlist = NULL;
1820 refriglvals(lvals);
1821 return;
1822}
1823
1824\f
1825
1826ftnint
1827indexer(ap)
1828aelt *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\f
1889
1890savedata(lvals, rvals)
1891elist *lvals;
1892vallist *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\f
1930
1931setdfiles(np)
1932register 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\f
2004
2005wrtdata(offset, repl, len, const)
2006long offset;
2007ftnint repl;
2008ftnint len;
2009char *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\f
2201
2202Constp
2203getdatum()
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\f
2237
2238outdata(lvals)
2239elist *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\f
2259
2260outaelt(ap)
2261aelt *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\f
2426
2427outdolist(dp)
2428dolist *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
2606ret:
2607 frvexpr((vexpr *) e1);
2608 frvexpr((vexpr *) e2);
2609 frvexpr((vexpr *) e3);
2610 return;
2611}
Continuous source code history from original PDP-7 UNIX to FreeBSD 2, the first fully unencumbered FreeBSD release.