1 /****************************************************************
2 Copyright 1990 by AT&T Bell Laboratories and Bellcore.
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.
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
22 ****************************************************************/
26 int oneof_stg (name, stg, mask)
30 if (stg == STGCOMMON && name) {
31 if ((mask & M(STGEQUIV)))
32 return name->vcommequiv;
33 if ((mask & M(STGCOMMON)))
34 return !name->vcommequiv;
36 return ONEOF(stg, mask);
40 /* op_assign -- given a binary opcode, return the associated assignment
43 int op_assign (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;
60 erri ("op_assign: bad opcode '%d'", opcode);
69 Alloc(n) /* error-checking version of malloc */
70 /* ckalloc initializes memory to 0; Alloc does not */
73 extern char *malloc();
79 sprintf(errbuf, "malloc(%d) failure!", n);
112 cmpstr(a, b, la, lb) /* compare two strings */
113 register char *a, *b;
116 register char *aend, *bend;
159 /* hookup -- Same as LISP NCONC, that is a destructive append of two lists */
162 register chainp x, y;
169 for(p = x ; p->nextp ; p = p->nextp)
177 struct Listblock *mklist(p)
180 register struct Listblock *q;
182 q = ALLOC(Listblock);
198 chains = chains->nextp;
210 register chainp next;
212 register chainp p, prev = 0;
223 /* addunder -- turn a cvarname into an external name */
224 /* The cvarname may already end in _ (to avoid C keywords); */
225 /* if not, it has room for appending an _. */
248 /* copyn -- return a new copy of the input Fortran-string */
254 register char *p, *q;
256 p = q = (char *) Alloc(n);
264 /* copys -- return a new copy of the input C-string */
269 return( copyn( strlen(s)+1 , s) );
274 /* convci -- Convert Fortran-string to integer; assumes that input is a
275 legal number, with no trailing blanks */
284 sum = 10*sum + (*s++ - '0');
288 /* convic - Convert Integer constant to string */
309 /* mkname -- add a new identifier to the environment, including the closed
310 hash table. There is a BAD assumption that strlen (s) < VL */
315 struct Hashentry *hp;
317 register int c, hash, i;
331 /* Add the name to the closed hash table */
336 if( hash == hp->hashval && !strcmp(s0,q->fvarname) )
338 else if(++hp >= lasthash)
341 if(++nintnames >= maxhash-1)
342 many("names", 'n', maxhash); /* Fatal error */
343 hp->varp = q = ALLOC(Nameblock);
345 q->tag = TNAME; /* TNAME means the tag type is NAME */
347 if (c > 7 && noextflag) {
348 sprintf(errbuf, "\"%.35s%s\" over 6 characters long", s0,
349 c > 36 ? "..." : "");
352 q->fvarname = strcpy(mem(c,0), s0);
353 t = q->cvarname = mem(c + i + 1, 0);
355 /* add __ to the end of any name containing _ */
362 else if (in_vector(s0) >= 0) {
370 struct Labelblock *mklabel(l)
373 register struct Labelblock *lp;
378 for(lp = labeltab ; lp < highlabtab ; ++lp)
382 if(++highlabtab > labtabend)
383 many("statement labels", 's', maxstno);
386 lp->labelno = newlabel();
392 lp->labtype = LABUNKNOWN;
400 return( ++lastlabno );
404 /* this label appears in a branch context */
406 struct Labelblock *execlab(stateno)
409 register struct Labelblock *lp;
411 if(lp = mklabel(stateno))
414 warn1("illegal branch to inner block, statement label %s",
416 else if(lp->labdefined == NO)
417 lp->blklevel = blklevel;
418 if(lp->labtype == LABFORMAT)
419 err("may not branch to a format");
421 lp->labtype = LABEXEC;
424 execerr("illegal label %s", convic(stateno));
430 /* find or put a name in the external symbol table */
437 for(p = extsymtab ; p<nextext ; ++p)
438 if(!strcmp(s,p->cextname))
441 if(nextext >= lastext)
442 many("external symbols", 'x', maxext);
444 nextext->fextname = strcpy(gmem(strlen(f)+1,0), f);
445 nextext->cextname = f == s
447 : strcpy(gmem(strlen(s)+1,0), s);
448 nextext->extstg = STGUNKNOWN;
450 nextext->allextp = 0;
451 nextext->extleng = 0;
452 nextext->maxleng = 0;
453 nextext->extinit = 0;
454 nextext->curno = nextext->maxno = 0;
459 Addrp builtin(t, s, dbi)
465 extern chainp used_builtins;
468 if(p->extstg == STGUNKNOWN)
470 else if(p->extstg != STGEXT)
472 errstr("improper use of builtin %s", s);
476 q = ALLOC(Addrblock);
481 q->memno = p - extsymtab;
482 q->dbl_builtin = dbi;
484 /* A NULL pointer here tells you to use memno to check the external
487 q -> uname_tag = UNAM_EXTERN;
489 /* Add to the list of used builtins */
492 add_extern_to_list (q, &used_builtins);
498 add_extern_to_list (addr, list_store)
502 chainp last = CHNULL;
506 if (list_store == (chainp *) NULL || addr == (Addrp) NULL)
510 memno = addr -> memno;
512 for (;list; last = list, list = list -> nextp) {
513 Addrp this = (Addrp) (list -> datap);
515 if (this -> tag == TADDR && this -> uname_tag == UNAM_EXTERN &&
516 this -> memno == memno)
520 if (*list_store == CHNULL)
521 *list_store = mkchain((char *)cpexpr((expptr)addr), CHNULL);
523 last->nextp = mkchain((char *)cpexpr((expptr)addr), CHNULL);
525 } /* add_extern_to_list */
536 for(q = *p; q->nextp ; q = q->nextp)
547 register chainp q, r;
551 frexpr((expptr)q->datap);
568 memcpy((char *)(q = ckalloc(n)), (char *)p, n);
577 return( a>b ? a : b);
584 return( a>b ? a : b);
590 return(a < b ? a : b);
602 if(t==TYCOMPLEX && (t1==TYDREAL || t2==TYDREAL) )
609 /* return log base 2 of n if n a power of 2; otherwise -1 */
615 /* trick based on binary representation */
617 if(n<=0 || (n & (n-1))!=0)
620 for(k = 0 ; n >>= 1 ; ++k)
633 rp = rpllist->rplnextp;
634 free( (charptr) rpllist);
641 /* Call a Fortran function with an arbitrary list of arguments */
645 expptr callk(type, name, args)
653 (expptr)builtin(callk_kludge ? callk_kludge : type, name, 0),
655 p->exprblock.vtype = type;
661 expptr call4(type, name, arg1, arg2, arg3, arg4)
664 expptr arg1, arg2, arg3, arg4;
666 struct Listblock *args;
667 args = mklist( mkchain((char *)arg1,
668 mkchain((char *)arg2,
669 mkchain((char *)arg3,
670 mkchain((char *)arg4, CHNULL)) ) ) );
671 return( callk(type, name, (chainp)args) );
677 expptr call3(type, name, arg1, arg2, arg3)
680 expptr arg1, arg2, arg3;
682 struct Listblock *args;
683 args = mklist( mkchain((char *)arg1,
684 mkchain((char *)arg2,
685 mkchain((char *)arg3, CHNULL) ) ) );
686 return( callk(type, name, (chainp)args) );
693 expptr call2(type, name, arg1, arg2)
698 struct Listblock *args;
700 args = mklist( mkchain((char *)arg1, mkchain((char *)arg2, CHNULL) ) );
701 return( callk(type,name, (chainp)args) );
707 expptr call1(type, name, arg)
712 return( callk(type,name, (chainp)mklist(mkchain((char *)arg,CHNULL)) ));
716 expptr call0(type, name)
720 return( callk(type, name, CHNULL) );
725 struct Impldoblock *mkiodo(dospec, list)
728 register struct Impldoblock *q;
730 q = ALLOC(Impldoblock);
732 q->impdospec = dospec;
740 /* ckalloc -- Allocate 1 memory unit of size n, checking for out of
748 if( p = (ptr)calloc(1, (unsigned) n) )
750 fprintf(stderr, "failing to get %d bytes\n",n);
751 Fatal("out of memory");
752 /* NOT REACHED */ return 0;
763 switch(p->exprblock.opcode)
766 return( isaddr(p->exprblock.rightp) );
779 return( isaddr(p->exprblock.leftp) );
790 if(p->headblock.vleng && !ISCONST(p->headblock.vleng))
799 if(ONEOF(p->addrblock.vstg,MSKSTATIC) &&
800 ISCONST(p->addrblock.memoffset))
810 /* addressable -- return True iff it is a constant value, or can be
811 referenced by constant values */
822 return( addressable(p->addrblock.memoffset) );
830 /* isnegative_const -- returns true if the constant is negative. Returns
831 false for imaginary and nonnumeric constants */
833 int isnegative_const (cp)
834 struct Constblock *cp;
841 switch (cp -> vtype) {
844 retval = cp -> Const.ci < 0;
848 retval = cp->vstg ? *cp->Const.cds[0] == '-'
849 : cp->Const.cd[0] < 0.0;
858 } /* isnegative_const */
863 if (cp == (struct Constblock *) NULL)
866 switch (cp -> vtype) {
869 cp -> Const.ci = - cp -> Const.ci;
874 switch(*cp->Const.cds[1]) {
884 cp->Const.cd[1] = -cp->Const.cd[1];
889 switch(*cp->Const.cds[0]) {
899 cp->Const.cd[0] = -cp->Const.cd[0];
903 erri ("negate_const: can't negate type '%d'", cp -> vtype);
906 erri ("negate_const: bad type '%d'",
912 ffilecopy (infp, outfp)
915 while (!feof (infp)) {
916 register c = getc (infp);
923 #define NOT_IN_VECTOR -1
925 /* in_vector -- verifies whether str is in c_keywords.
926 If so, the index is returned else NOT_IN_VECTOR is returned.
927 c_keywords must be in alphabetical order (as defined by strcmp).
933 extern int n_keywords;
934 extern char *c_keywords[];
935 register int n = n_keywords;
936 register char **K = c_keywords;
942 if (!(t = strcmp(str, K[n1])))
943 return K - c_keywords + n1;
953 return NOT_IN_VECTOR;
957 int is_negatable (Const)
961 if (Const != (Constp) NULL)
962 switch (Const -> vtype) {
964 retval = Const -> Const.ci >= -BIGGEST_SHORT;
967 retval = Const -> Const.ci >= -BIGGEST_LONG;
990 static char couldnt[] = "Couldn't open %.80s";
992 if (!(f = fopen(fname, binread))) {
993 warn1(couldnt, fname);
996 if (!(b = fopen(bname, binwrite))) {
997 warn1(couldnt, bname);
1006 /* struct_eq -- returns YES if structures have the same field names and
1007 types, NO otherwise */
1009 int struct_eq (s1, s2)
1012 struct Dimblock *d1, *d2;
1015 if (s1 == CHNULL && s2 == CHNULL)
1017 for(; s1 && s2; s1 = s1->nextp, s2 = s2->nextp) {
1018 register Namep v1 = (Namep) s1 -> datap;
1019 register Namep v2 = (Namep) s2 -> datap;
1021 if (v1 == (Namep) NULL || v1 -> tag != TNAME ||
1022 v2 == (Namep) NULL || v2 -> tag != TNAME)
1025 if (v1->vtype != v2->vtype || v1->vclass != v2->vclass
1026 || strcmp(v1->fvarname, v2->fvarname))
1029 /* compare dimensions (needed for comparing COMMON blocks) */
1031 if (d1 = v1->vdim) {
1032 if (!(cp1 = (Constp)d1->nelt) || cp1->tag != TCONST)
1034 if (!(d2 = v2->vdim))
1035 if (cp1->Const.ci == 1)
1039 if (!(cp2 = (Constp)d2->nelt) || cp2->tag != TCONST
1040 || cp1->Const.ci != cp2->Const.ci)
1043 else if ((d2 = v2->vdim) && (!(cp2 = (Constp)d2->nelt)
1044 || cp2->tag != TCONST
1045 || cp2->Const.ci != 1))
1047 } /* while s1 != CHNULL && s2 != CHNULL */
1049 return s1 == CHNULL && s2 == CHNULL;