![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to misc.c CVS log ![[TXT]](/cvsweb/icons/text.gif){kind=icon}
![[DIR]](/cvsweb/icons/dir.gif){kind=icon}
Up to [Research Unix] / researchv10no / cmd / f2c|
Return to misc.c CVS log | Up to [Research Unix] / researchv10no / cmd / f2c |
1.1 root 1: /****************************************************************
2: Copyright 1990, 1992, 1993 by AT&T Bell Laboratories and Bellcore.
3:
4: Permission to use, copy, modify, and distribute this software
5: and its documentation for any purpose and without fee is hereby
6: granted, provided that the above copyright notice appear in all
7: copies and that both that the copyright notice and this
8: permission notice and warranty disclaimer appear in supporting
9: documentation, and that the names of AT&T Bell Laboratories or
10: Bellcore or any of their entities not be used in advertising or
11: publicity pertaining to distribution of the software without
12: specific, written prior permission.
13:
14: AT&T and Bellcore disclaim all warranties with regard to this
15: software, including all implied warranties of merchantability
16: and fitness. In no event shall AT&T or Bellcore be liable for
17: any special, indirect or consequential damages or any damages
18: whatsoever resulting from loss of use, data or profits, whether
19: in an action of contract, negligence or other tortious action,
20: arising out of or in connection with the use or performance of
21: this software.
22: ****************************************************************/
23:
24: #include "defs.h"
25:
26: int oneof_stg (name, stg, mask)
27: Namep name;
28: int stg, mask;
29: {
30: if (stg == STGCOMMON && name) {
31: if ((mask & M(STGEQUIV)))
32: return name->vcommequiv;
33: if ((mask & M(STGCOMMON)))
34: return !name->vcommequiv;
35: }
36: return ONEOF(stg, mask);
37: }
38:
39:
40: /* op_assign -- given a binary opcode, return the associated assignment
41: operator */
42:
43: int op_assign (opcode)
44: int opcode;
45: {
46: int retval = -1;
47:
48: switch (opcode) {
49: case OPPLUS: retval = OPPLUSEQ; break;
50: case OPMINUS: retval = OPMINUSEQ; break;
51: case OPSTAR: retval = OPSTAREQ; break;
52: case OPSLASH: retval = OPSLASHEQ; break;
53: case OPMOD: retval = OPMODEQ; break;
54: case OPLSHIFT: retval = OPLSHIFTEQ; break;
55: case OPRSHIFT: retval = OPRSHIFTEQ; break;
56: case OPBITAND: retval = OPBITANDEQ; break;
57: case OPBITXOR: retval = OPBITXOREQ; break;
58: case OPBITOR: retval = OPBITOREQ; break;
59: default:
60: erri ("op_assign: bad opcode '%d'", opcode);
61: break;
62: } /* switch */
63:
64: return retval;
65: } /* op_assign */
66:
67:
68: char *
69: Alloc(n) /* error-checking version of malloc */
70: /* ckalloc initializes memory to 0; Alloc does not */
71: int n;
72: {
73: char errbuf[32];
74: register char *rv;
75:
76: rv = malloc(n);
77: if (!rv) {
78: sprintf(errbuf, "malloc(%d) failure!", n);
79: Fatal(errbuf);
80: }
81: return rv;
82: }
83:
84:
85: cpn(n, a, b)
86: register int n;
87: register char *a, *b;
88: {
89: while(--n >= 0)
90: *b++ = *a++;
91: }
92:
93:
94:
95: eqn(n, a, b)
96: register int n;
97: register char *a, *b;
98: {
99: while(--n >= 0)
100: if(*a++ != *b++)
101: return(NO);
102: return(YES);
103: }
104:
105:
106:
107:
108:
109:
110:
111: cmpstr(a, b, la, lb) /* compare two strings */
112: register char *a, *b;
113: ftnint la, lb;
114: {
115: register char *aend, *bend;
116: aend = a + la;
117: bend = b + lb;
118:
119:
120: if(la <= lb)
121: {
122: while(a < aend)
123: if(*a != *b)
124: return( *a - *b );
125: else
126: {
127: ++a;
128: ++b;
129: }
130:
131: while(b < bend)
132: if(*b != ' ')
133: return(' ' - *b);
134: else
135: ++b;
136: }
137:
138: else
139: {
140: while(b < bend)
141: if(*a != *b)
142: return( *a - *b );
143: else
144: {
145: ++a;
146: ++b;
147: }
148: while(a < aend)
149: if(*a != ' ')
150: return(*a - ' ');
151: else
152: ++a;
153: }
154: return(0);
155: }
156:
157:
158: /* hookup -- Same as LISP NCONC, that is a destructive append of two lists */
159:
160: chainp hookup(x,y)
161: register chainp x, y;
162: {
163: register chainp p;
164:
165: if(x == NULL)
166: return(y);
167:
168: for(p = x ; p->nextp ; p = p->nextp)
169: ;
170: p->nextp = y;
171: return(x);
172: }
173:
174:
175:
176: struct Listblock *mklist(p)
177: chainp p;
178: {
179: register struct Listblock *q;
180:
181: q = ALLOC(Listblock);
182: q->tag = TLIST;
183: q->listp = p;
184: return(q);
185: }
186:
187:
188: chainp mkchain(p,q)
189: register char * p;
190: register chainp q;
191: {
192: register chainp r;
193:
194: if(chains)
195: {
196: r = chains;
197: chains = chains->nextp;
198: }
199: else
200: r = ALLOC(Chain);
201:
202: r->datap = p;
203: r->nextp = q;
204: return(r);
205: }
206:
207: chainp
208: revchain(next)
209: register chainp next;
210: {
211: register chainp p, prev = 0;
212:
213: while(p = next) {
214: next = p->nextp;
215: p->nextp = prev;
216: prev = p;
217: }
218: return prev;
219: }
220:
221:
222: /* addunder -- turn a cvarname into an external name */
223: /* The cvarname may already end in _ (to avoid C keywords); */
224: /* if not, it has room for appending an _. */
225:
226: char *
227: addunder(s)
228: register char *s;
229: {
230: register int c, i;
231: char *s0 = s;
232:
233: i = 0;
234: while(c = *s++)
235: if (c == '_')
236: i++;
237: else
238: i = 0;
239: if (!i) {
240: *s-- = 0;
241: *s = '_';
242: }
243: return( s0 );
244: }
245:
246:
247: /* copyn -- return a new copy of the input Fortran-string */
248:
249: char *copyn(n, s)
250: register int n;
251: register char *s;
252: {
253: register char *p, *q;
254:
255: p = q = (char *) Alloc(n);
256: while(--n >= 0)
257: *q++ = *s++;
258: return(p);
259: }
260:
261:
262:
263: /* copys -- return a new copy of the input C-string */
264:
265: char *copys(s)
266: char *s;
267: {
268: return( copyn( strlen(s)+1 , s) );
269: }
270:
271:
272:
273: /* convci -- Convert Fortran-string to integer; assumes that input is a
274: legal number, with no trailing blanks */
275:
276: ftnint convci(n, s)
277: register int n;
278: register char *s;
279: {
280: ftnint sum;
281: sum = 0;
282: while(n-- > 0)
283: sum = 10*sum + (*s++ - '0');
284: return(sum);
285: }
286:
287: /* convic - Convert Integer constant to string */
288:
289: char *convic(n)
290: ftnint n;
291: {
292: static char s[20];
293: register char *t;
294:
295: s[19] = '\0';
296: t = s+19;
297:
298: do {
299: *--t = '0' + n%10;
300: n /= 10;
301: } while(n > 0);
302:
303: return(t);
304: }
305:
306:
307:
308: /* mkname -- add a new identifier to the environment, including the closed
309: hash table. */
310:
311: Namep mkname(s)
312: register char *s;
313: {
314: struct Hashentry *hp;
315: register Namep q;
316: register int c, hash, i;
317: register char *t;
318: char *s0;
319: char errbuf[64];
320:
321: hash = i = 0;
322: s0 = s;
323: while(c = *s++) {
324: hash += c;
325: if (c == '_')
326: i = 2;
327: }
328: if (!i && in_vector(s0,c_keywords,n_keywords) >= 0)
329: i = 1;
330: hash %= maxhash;
331:
332: /* Add the name to the closed hash table */
333:
334: hp = hashtab + hash;
335:
336: while(q = hp->varp)
337: if( hash == hp->hashval && !strcmp(s0,q->fvarname) )
338: return(q);
339: else if(++hp >= lasthash)
340: hp = hashtab;
341:
342: if(++nintnames >= maxhash-1)
343: many("names", 'n', maxhash); /* Fatal error */
344: hp->varp = q = ALLOC(Nameblock);
345: hp->hashval = hash;
346: q->tag = TNAME; /* TNAME means the tag type is NAME */
347: c = s - s0;
348: if (c > 7 && noextflag) {
349: sprintf(errbuf, "\"%.35s%s\" over 6 characters long", s0,
350: c > 36 ? "..." : "");
351: errext(errbuf);
352: }
353: q->fvarname = strcpy(mem(c,0), s0);
354: t = q->cvarname = mem(c + i + 1, 0);
355: s = s0;
356: /* add __ to the end of any name containing _ and to any C keyword */
357: while(*t = *s++)
358: t++;
359: if (i) {
360: do *t++ = '_';
361: while(--i > 0);
362: *t = 0;
363: }
364: return(q);
365: }
366:
367:
368: struct Labelblock *mklabel(l)
369: ftnint l;
370: {
371: register struct Labelblock *lp;
372:
373: if(l <= 0)
374: return(NULL);
375:
376: for(lp = labeltab ; lp < highlabtab ; ++lp)
377: if(lp->stateno == l)
378: return(lp);
379:
380: if(++highlabtab > labtabend)
381: many("statement labels", 's', maxstno);
382:
383: lp->stateno = l;
384: lp->labelno = newlabel();
385: lp->blklevel = 0;
386: lp->labused = NO;
387: lp->fmtlabused = NO;
388: lp->labdefined = NO;
389: lp->labinacc = NO;
390: lp->labtype = LABUNKNOWN;
391: lp->fmtstring = 0;
392: return(lp);
393: }
394:
395:
396: newlabel()
397: {
398: return( ++lastlabno );
399: }
400:
401:
402: /* this label appears in a branch context */
403:
404: struct Labelblock *execlab(stateno)
405: ftnint stateno;
406: {
407: register struct Labelblock *lp;
408:
409: if(lp = mklabel(stateno))
410: {
411: if(lp->labinacc)
412: warn1("illegal branch to inner block, statement label %s",
413: convic(stateno) );
414: else if(lp->labdefined == NO)
415: lp->blklevel = blklevel;
416: if(lp->labtype == LABFORMAT)
417: err("may not branch to a format");
418: else
419: lp->labtype = LABEXEC;
420: }
421: else
422: execerr("illegal label %s", convic(stateno));
423:
424: return(lp);
425: }
426:
427:
428: /* find or put a name in the external symbol table */
429:
430: Extsym *mkext(f,s)
431: char *f, *s;
432: {
433: Extsym *p;
434:
435: for(p = extsymtab ; p<nextext ; ++p)
436: if(!strcmp(s,p->cextname))
437: return( p );
438:
439: if(nextext >= lastext)
440: many("external symbols", 'x', maxext);
441:
442: nextext->fextname = strcpy(gmem(strlen(f)+1,0), f);
443: nextext->cextname = f == s
444: ? nextext->fextname
445: : strcpy(gmem(strlen(s)+1,0), s);
446: nextext->extstg = STGUNKNOWN;
447: nextext->extp = 0;
448: nextext->allextp = 0;
449: nextext->extleng = 0;
450: nextext->maxleng = 0;
451: nextext->extinit = 0;
452: nextext->curno = nextext->maxno = 0;
453: return( nextext++ );
454: }
455:
456:
457: Addrp builtin(t, s, dbi)
458: int t, dbi;
459: char *s;
460: {
461: register Extsym *p;
462: register Addrp q;
463: extern chainp used_builtins;
464:
465: p = mkext(s,s);
466: if(p->extstg == STGUNKNOWN)
467: p->extstg = STGEXT;
468: else if(p->extstg != STGEXT)
469: {
470: errstr("improper use of builtin %s", s);
471: return(0);
472: }
473:
474: q = ALLOC(Addrblock);
475: q->tag = TADDR;
476: q->vtype = t;
477: q->vclass = CLPROC;
478: q->vstg = STGEXT;
479: q->memno = p - extsymtab;
480: q->dbl_builtin = dbi;
481:
482: /* A NULL pointer here tells you to use memno to check the external
483: symbol table */
484:
485: q -> uname_tag = UNAM_EXTERN;
486:
487: /* Add to the list of used builtins */
488:
489: if (dbi >= 0)
490: add_extern_to_list (q, &used_builtins);
491: return(q);
492: }
493:
494:
495:
496: add_extern_to_list (addr, list_store)
497: Addrp addr;
498: chainp *list_store;
499: {
500: chainp last = CHNULL;
501: chainp list;
502: int memno;
503:
504: if (list_store == (chainp *) NULL || addr == (Addrp) NULL)
505: return;
506:
507: list = *list_store;
508: memno = addr -> memno;
509:
510: for (;list; last = list, list = list -> nextp) {
511: Addrp this = (Addrp) (list -> datap);
512:
513: if (this -> tag == TADDR && this -> uname_tag == UNAM_EXTERN &&
514: this -> memno == memno)
515: return;
516: } /* for */
517:
518: if (*list_store == CHNULL)
519: *list_store = mkchain((char *)cpexpr((expptr)addr), CHNULL);
520: else
521: last->nextp = mkchain((char *)cpexpr((expptr)addr), CHNULL);
522:
523: } /* add_extern_to_list */
524:
525:
526: frchain(p)
527: register chainp *p;
528: {
529: register chainp q;
530:
531: if(p==0 || *p==0)
532: return;
533:
534: for(q = *p; q->nextp ; q = q->nextp)
535: ;
536: q->nextp = chains;
537: chains = *p;
538: *p = 0;
539: }
540:
541: void
542: frexchain(p)
543: register chainp *p;
544: {
545: register chainp q, r;
546:
547: if (q = *p) {
548: for(;;q = r) {
549: frexpr((expptr)q->datap);
550: if (!(r = q->nextp))
551: break;
552: }
553: q->nextp = chains;
554: chains = *p;
555: *p = 0;
556: }
557: }
558:
559:
560: tagptr cpblock(n,p)
561: register int n;
562: register char * p;
563: {
564: register ptr q;
565:
566: memcpy((char *)(q = ckalloc(n)), (char *)p, n);
567: return( (tagptr) q);
568: }
569:
570:
571:
572: ftnint lmax(a, b)
573: ftnint a, b;
574: {
575: return( a>b ? a : b);
576: }
577:
578: ftnint lmin(a, b)
579: ftnint a, b;
580: {
581: return(a < b ? a : b);
582: }
583:
584:
585:
586:
587: maxtype(t1, t2)
588: int t1, t2;
589: {
590: int t;
591:
592: t = t1 >= t2 ? t1 : t2;
593: if(t==TYCOMPLEX && (t1==TYDREAL || t2==TYDREAL) )
594: t = TYDCOMPLEX;
595: return(t);
596: }
597:
598:
599:
600: /* return log base 2 of n if n a power of 2; otherwise -1 */
601: log_2(n)
602: ftnint n;
603: {
604: int k;
605:
606: /* trick based on binary representation */
607:
608: if(n<=0 || (n & (n-1))!=0)
609: return(-1);
610:
611: for(k = 0 ; n >>= 1 ; ++k)
612: ;
613: return(k);
614: }
615:
616:
617:
618: frrpl()
619: {
620: struct Rplblock *rp;
621:
622: while(rpllist)
623: {
624: rp = rpllist->rplnextp;
625: free( (charptr) rpllist);
626: rpllist = rp;
627: }
628: }
629:
630:
631:
632: /* Call a Fortran function with an arbitrary list of arguments */
633:
634: int callk_kludge;
635:
636: expptr callk(type, name, args)
637: int type;
638: char *name;
639: chainp args;
640: {
641: register expptr p;
642:
643: p = mkexpr(OPCALL,
644: (expptr)builtin(callk_kludge ? callk_kludge : type, name, 0),
645: (expptr)args);
646: p->exprblock.vtype = type;
647: return(p);
648: }
649:
650:
651:
652: expptr call4(type, name, arg1, arg2, arg3, arg4)
653: int type;
654: char *name;
655: expptr arg1, arg2, arg3, arg4;
656: {
657: struct Listblock *args;
658: args = mklist( mkchain((char *)arg1,
659: mkchain((char *)arg2,
660: mkchain((char *)arg3,
661: mkchain((char *)arg4, CHNULL)) ) ) );
662: return( callk(type, name, (chainp)args) );
663: }
664:
665:
666:
667:
668: expptr call3(type, name, arg1, arg2, arg3)
669: int type;
670: char *name;
671: expptr arg1, arg2, arg3;
672: {
673: struct Listblock *args;
674: args = mklist( mkchain((char *)arg1,
675: mkchain((char *)arg2,
676: mkchain((char *)arg3, CHNULL) ) ) );
677: return( callk(type, name, (chainp)args) );
678: }
679:
680:
681:
682:
683:
684: expptr call2(type, name, arg1, arg2)
685: int type;
686: char *name;
687: expptr arg1, arg2;
688: {
689: struct Listblock *args;
690:
691: args = mklist( mkchain((char *)arg1, mkchain((char *)arg2, CHNULL) ) );
692: return( callk(type,name, (chainp)args) );
693: }
694:
695:
696:
697:
698: expptr call1(type, name, arg)
699: int type;
700: char *name;
701: expptr arg;
702: {
703: return( callk(type,name, (chainp)mklist(mkchain((char *)arg,CHNULL)) ));
704: }
705:
706:
707: expptr call0(type, name)
708: int type;
709: char *name;
710: {
711: return( callk(type, name, CHNULL) );
712: }
713:
714:
715:
716: struct Impldoblock *mkiodo(dospec, list)
717: chainp dospec, list;
718: {
719: register struct Impldoblock *q;
720:
721: q = ALLOC(Impldoblock);
722: q->tag = TIMPLDO;
723: q->impdospec = dospec;
724: q->datalist = list;
725: return(q);
726: }
727:
728:
729:
730:
731: /* ckalloc -- Allocate 1 memory unit of size n, checking for out of
732: memory error */
733:
734: ptr ckalloc(n)
735: register int n;
736: {
737: register ptr p;
738: p = (ptr)calloc(1, (unsigned) n);
739: if (p || !n)
740: return(p);
741: fprintf(stderr, "failing to get %d bytes\n",n);
742: Fatal("out of memory");
743: /* NOT REACHED */ return 0;
744: }
745:
746:
747:
748: isaddr(p)
749: register expptr p;
750: {
751: if(p->tag == TADDR)
752: return(YES);
753: if(p->tag == TEXPR)
754: switch(p->exprblock.opcode)
755: {
756: case OPCOMMA:
757: return( isaddr(p->exprblock.rightp) );
758:
759: case OPASSIGN:
760: case OPASSIGNI:
761: case OPPLUSEQ:
762: case OPMINUSEQ:
763: case OPSLASHEQ:
764: case OPMODEQ:
765: case OPLSHIFTEQ:
766: case OPRSHIFTEQ:
767: case OPBITANDEQ:
768: case OPBITXOREQ:
769: case OPBITOREQ:
770: return( isaddr(p->exprblock.leftp) );
771: }
772: return(NO);
773: }
774:
775:
776:
777:
778: isstatic(p)
779: register expptr p;
780: {
781: extern int useauto;
782: if(p->headblock.vleng && !ISCONST(p->headblock.vleng))
783: return(NO);
784:
785: switch(p->tag)
786: {
787: case TCONST:
788: return(YES);
789:
790: case TADDR:
791: if(ONEOF(p->addrblock.vstg,MSKSTATIC) &&
792: ISCONST(p->addrblock.memoffset) && !useauto)
793: return(YES);
794:
795: default:
796: return(NO);
797: }
798: }
799:
800:
801:
802: /* addressable -- return True iff it is a constant value, or can be
803: referenced by constant values */
804:
805: addressable(p)
806: register expptr p;
807: {
808: switch(p->tag)
809: {
810: case TCONST:
811: return(YES);
812:
813: case TADDR:
814: return( addressable(p->addrblock.memoffset) );
815:
816: default:
817: return(NO);
818: }
819: }
820:
821:
822: /* isnegative_const -- returns true if the constant is negative. Returns
823: false for imaginary and nonnumeric constants */
824:
825: int isnegative_const (cp)
826: struct Constblock *cp;
827: {
828: int retval;
829:
830: if (cp == NULL)
831: return 0;
832:
833: switch (cp -> vtype) {
834: case TYINT1:
835: case TYSHORT:
836: case TYLONG:
837: #ifdef TYQUAD
838: case TYQUAD:
839: #endif
840: retval = cp -> Const.ci < 0;
841: break;
842: case TYREAL:
843: case TYDREAL:
844: retval = cp->vstg ? *cp->Const.cds[0] == '-'
845: : cp->Const.cd[0] < 0.0;
846: break;
847: default:
848:
849: retval = 0;
850: break;
851: } /* switch */
852:
853: return retval;
854: } /* isnegative_const */
855:
856: negate_const(cp)
857: Constp cp;
858: {
859: if (cp == (struct Constblock *) NULL)
860: return;
861:
862: switch (cp -> vtype) {
863: case TYINT1:
864: case TYSHORT:
865: case TYLONG:
866: #ifdef TYQUAD
867: case TYQUAD:
868: #endif
869: cp -> Const.ci = - cp -> Const.ci;
870: break;
871: case TYCOMPLEX:
872: case TYDCOMPLEX:
873: if (cp->vstg)
874: switch(*cp->Const.cds[1]) {
875: case '-':
876: ++cp->Const.cds[1];
877: break;
878: case '0':
879: break;
880: default:
881: --cp->Const.cds[1];
882: }
883: else
884: cp->Const.cd[1] = -cp->Const.cd[1];
885: /* no break */
886: case TYREAL:
887: case TYDREAL:
888: if (cp->vstg)
889: switch(*cp->Const.cds[0]) {
890: case '-':
891: ++cp->Const.cds[0];
892: break;
893: case '0':
894: break;
895: default:
896: --cp->Const.cds[0];
897: }
898: else
899: cp->Const.cd[0] = -cp->Const.cd[0];
900: break;
901: case TYCHAR:
902: case TYLOGICAL1:
903: case TYLOGICAL2:
904: case TYLOGICAL:
905: erri ("negate_const: can't negate type '%d'", cp -> vtype);
906: break;
907: default:
908: erri ("negate_const: bad type '%d'",
909: cp -> vtype);
910: break;
911: } /* switch */
912: } /* negate_const */
913:
914: ffilecopy (infp, outfp)
915: FILE *infp, *outfp;
916: {
917: while (!feof (infp)) {
918: register c = getc (infp);
919: if (!feof (infp))
920: putc (c, outfp);
921: } /* while */
922: } /* ffilecopy */
923:
924:
925: /* in_vector -- verifies whether str is in c_keywords.
926: If so, the index is returned else -1 is returned.
927: c_keywords must be in alphabetical order (as defined by strcmp).
928: */
929:
930: int in_vector(str, keywds, n)
931: char *str; char **keywds; register int n;
932: {
933: register char **K = keywds;
934: register int n1, t;
935:
936: do {
937: n1 = n >> 1;
938: if (!(t = strcmp(str, K[n1])))
939: return K - keywds + n1;
940: if (t < 0)
941: n = n1;
942: else {
943: n -= ++n1;
944: K += n1;
945: }
946: }
947: while(n > 0);
948:
949: return -1;
950: } /* in_vector */
951:
952:
953: int is_negatable (Const)
954: Constp Const;
955: {
956: int retval = 0;
957: if (Const != (Constp) NULL)
958: switch (Const -> vtype) {
959: case TYINT1:
960: retval = Const -> Const.ci >= -BIGGEST_CHAR;
961: break;
962: case TYSHORT:
963: retval = Const -> Const.ci >= -BIGGEST_SHORT;
964: break;
965: case TYLONG:
966: #ifdef TYQUAD
967: case TYQUAD:
968: #endif
969: retval = Const -> Const.ci >= -BIGGEST_LONG;
970: break;
971: case TYREAL:
972: case TYDREAL:
973: case TYCOMPLEX:
974: case TYDCOMPLEX:
975: retval = 1;
976: break;
977: case TYLOGICAL1:
978: case TYLOGICAL2:
979: case TYLOGICAL:
980: case TYCHAR:
981: case TYSUBR:
982: default:
983: retval = 0;
984: break;
985: } /* switch */
986:
987: return retval;
988: } /* is_negatable */
989:
990: backup(fname, bname)
991: char *fname, *bname;
992: {
993: FILE *b, *f;
994: static char couldnt[] = "Couldn't open %.80s";
995:
996: if (!(f = fopen(fname, binread))) {
997: warn1(couldnt, fname);
998: return;
999: }
1000: if (!(b = fopen(bname, binwrite))) {
1001: warn1(couldnt, bname);
1002: return;
1003: }
1004: ffilecopy(f, b);
1005: fclose(f);
1006: fclose(b);
1007: }
1008:
1009:
1010: /* struct_eq -- returns YES if structures have the same field names and
1011: types, NO otherwise */
1012:
1013: int struct_eq (s1, s2)
1014: chainp s1, s2;
1015: {
1016: struct Dimblock *d1, *d2;
1017: Constp cp1, cp2;
1018:
1019: if (s1 == CHNULL && s2 == CHNULL)
1020: return YES;
1021: for(; s1 && s2; s1 = s1->nextp, s2 = s2->nextp) {
1022: register Namep v1 = (Namep) s1 -> datap;
1023: register Namep v2 = (Namep) s2 -> datap;
1024:
1025: if (v1 == (Namep) NULL || v1 -> tag != TNAME ||
1026: v2 == (Namep) NULL || v2 -> tag != TNAME)
1027: return NO;
1028:
1029: if (v1->vtype != v2->vtype || v1->vclass != v2->vclass
1030: || strcmp(v1->fvarname, v2->fvarname))
1031: return NO;
1032:
1033: /* compare dimensions (needed for comparing COMMON blocks) */
1034:
1035: if (d1 = v1->vdim) {
1036: if (!(cp1 = (Constp)d1->nelt) || cp1->tag != TCONST)
1037: return NO;
1038: if (!(d2 = v2->vdim))
1039: if (cp1->Const.ci == 1)
1040: continue;
1041: else
1042: return NO;
1043: if (!(cp2 = (Constp)d2->nelt) || cp2->tag != TCONST
1044: || cp1->Const.ci != cp2->Const.ci)
1045: return NO;
1046: }
1047: else if ((d2 = v2->vdim) && (!(cp2 = (Constp)d2->nelt)
1048: || cp2->tag != TCONST
1049: || cp2->Const.ci != 1))
1050: return NO;
1051: } /* while s1 != CHNULL && s2 != CHNULL */
1052:
1053: return s1 == CHNULL && s2 == CHNULL;
1054: } /* struct_eq */
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.