aboutsummaryrefslogtreecommitdiff
path: root/unix/f2c/src/misc.c
diff options
context:
space:
mode:
Diffstat (limited to 'unix/f2c/src/misc.c')
-rw-r--r--unix/f2c/src/misc.c1398
1 files changed, 1398 insertions, 0 deletions
diff --git a/unix/f2c/src/misc.c b/unix/f2c/src/misc.c
new file mode 100644
index 00000000..bdb9bcb3
--- /dev/null
+++ b/unix/f2c/src/misc.c
@@ -0,0 +1,1398 @@
+/****************************************************************
+Copyright 1990, 1992-1995, 2000-2001 by AT&T, Lucent Technologies and Bellcore.
+
+Permission to use, copy, modify, and distribute this software
+and its documentation for any purpose and without fee is hereby
+granted, provided that the above copyright notice appear in all
+copies and that both that the copyright notice and this
+permission notice and warranty disclaimer appear in supporting
+documentation, and that the names of AT&T, Bell Laboratories,
+Lucent or Bellcore or any of their entities not be used in
+advertising or publicity pertaining to distribution of the
+software without specific, written prior permission.
+
+AT&T, Lucent and Bellcore disclaim all warranties with regard to
+this software, including all implied warranties of
+merchantability and fitness. In no event shall AT&T, Lucent or
+Bellcore be liable for any special, indirect or consequential
+damages or any damages whatsoever resulting from loss of use,
+data or profits, whether in an action of contract, negligence or
+other tortious action, arising out of or in connection with the
+use or performance of this software.
+****************************************************************/
+
+#include "defs.h"
+#include "limits.h"
+
+ int
+#ifdef KR_headers
+oneof_stg(name, stg, mask)
+ Namep name;
+ int stg;
+ int mask;
+#else
+oneof_stg(Namep name, int stg, int mask)
+#endif
+{
+ if (stg == STGCOMMON && name) {
+ if ((mask & M(STGEQUIV)))
+ return name->vcommequiv;
+ if ((mask & M(STGCOMMON)))
+ return !name->vcommequiv;
+ }
+ return ONEOF(stg, mask);
+ }
+
+
+/* op_assign -- given a binary opcode, return the associated assignment
+ operator */
+
+ int
+#ifdef KR_headers
+op_assign(opcode)
+ int opcode;
+#else
+op_assign(int opcode)
+#endif
+{
+ int retval = -1;
+
+ switch (opcode) {
+ case OPPLUS: retval = OPPLUSEQ; break;
+ case OPMINUS: retval = OPMINUSEQ; break;
+ case OPSTAR: retval = OPSTAREQ; break;
+ case OPSLASH: retval = OPSLASHEQ; break;
+ case OPMOD: retval = OPMODEQ; break;
+ case OPLSHIFT: retval = OPLSHIFTEQ; break;
+ case OPRSHIFT: retval = OPRSHIFTEQ; break;
+ case OPBITAND: retval = OPBITANDEQ; break;
+ case OPBITXOR: retval = OPBITXOREQ; break;
+ case OPBITOR: retval = OPBITOREQ; break;
+ default:
+ erri ("op_assign: bad opcode '%d'", opcode);
+ break;
+ } /* switch */
+
+ return retval;
+} /* op_assign */
+
+
+ char *
+#ifdef KR_headers
+Alloc(n)
+ int n;
+#else
+Alloc(int n)
+#endif
+ /* error-checking version of malloc */
+ /* ckalloc initializes memory to 0; Alloc does not */
+{
+ char errbuf[32];
+ register char *rv;
+
+ rv = (char*)malloc(n);
+ if (!rv) {
+ sprintf(errbuf, "malloc(%d) failure!", n);
+ Fatal(errbuf);
+ }
+ return rv;
+ }
+
+ void
+#ifdef KR_headers
+cpn(n, a, b)
+ register int n;
+ register char *a;
+ register char *b;
+#else
+cpn(register int n, register char *a, register char *b)
+#endif
+{
+ while(--n >= 0)
+ *b++ = *a++;
+}
+
+
+ int
+#ifdef KR_headers
+eqn(n, a, b)
+ register int n;
+ register char *a;
+ register char *b;
+#else
+eqn(register int n, register char *a, register char *b)
+#endif
+{
+ while(--n >= 0)
+ if(*a++ != *b++)
+ return(NO);
+ return(YES);
+}
+
+
+
+
+
+
+ int
+#ifdef KR_headers
+cmpstr(a, b, la, lb)
+ register char *a;
+ register char *b;
+ ftnint la;
+ ftnint lb;
+#else
+cmpstr(register char *a, register char *b, ftnint la, ftnint lb)
+#endif
+ /* compare two strings */
+{
+ register char *aend, *bend;
+ aend = a + la;
+ bend = b + lb;
+
+
+ if(la <= lb)
+ {
+ while(a < aend)
+ if(*a != *b)
+ return( *a - *b );
+ else
+ {
+ ++a;
+ ++b;
+ }
+
+ while(b < bend)
+ if(*b != ' ')
+ return(' ' - *b);
+ else
+ ++b;
+ }
+
+ else
+ {
+ while(b < bend)
+ if(*a != *b)
+ return( *a - *b );
+ else
+ {
+ ++a;
+ ++b;
+ }
+ while(a < aend)
+ if(*a != ' ')
+ return(*a - ' ');
+ else
+ ++a;
+ }
+ return(0);
+}
+
+
+/* hookup -- Same as LISP NCONC, that is a destructive append of two lists */
+
+ chainp
+#ifdef KR_headers
+hookup(x, y)
+ register chainp x;
+ register chainp y;
+#else
+hookup(register chainp x, register chainp y)
+#endif
+{
+ register chainp p;
+
+ if(x == NULL)
+ return(y);
+
+ for(p = x ; p->nextp ; p = p->nextp)
+ ;
+ p->nextp = y;
+ return(x);
+}
+
+
+
+ struct Listblock *
+#ifdef KR_headers
+mklist(p)
+ chainp p;
+#else
+mklist(chainp p)
+#endif
+{
+ register struct Listblock *q;
+
+ q = ALLOC(Listblock);
+ q->tag = TLIST;
+ q->listp = p;
+ return(q);
+}
+
+
+ chainp
+#ifdef KR_headers
+mkchain(p, q)
+ register char * p;
+ register chainp q;
+#else
+mkchain(register char * p, register chainp q)
+#endif
+{
+ register chainp r;
+
+ if(chains)
+ {
+ r = chains;
+ chains = chains->nextp;
+ }
+ else
+ r = ALLOC(Chain);
+
+ r->datap = p;
+ r->nextp = q;
+ return(r);
+}
+
+ chainp
+#ifdef KR_headers
+revchain(next)
+ register chainp next;
+#else
+revchain(register chainp next)
+#endif
+{
+ register chainp p, prev = 0;
+
+ while(p = next) {
+ next = p->nextp;
+ p->nextp = prev;
+ prev = p;
+ }
+ return prev;
+ }
+
+
+/* addunder -- turn a cvarname into an external name */
+/* The cvarname may already end in _ (to avoid C keywords); */
+/* if not, it has room for appending an _. */
+
+ char *
+#ifdef KR_headers
+addunder(s)
+ register char *s;
+#else
+addunder(register char *s)
+#endif
+{
+ register int c, i, j;
+ char *s0 = s;
+
+ i = j = 0;
+ while(c = *s++)
+ if (c == '_')
+ i++, j++;
+ else
+ i = 0;
+ if (!i) {
+ *s-- = 0;
+ *s = '_';
+ }
+ else if (j == 2)
+ s[-2] = 0;
+ return( s0 );
+ }
+
+
+/* copyn -- return a new copy of the input Fortran-string */
+
+ char *
+#ifdef KR_headers
+copyn(n, s)
+ register int n;
+ register char *s;
+#else
+copyn(register int n, register char *s)
+#endif
+{
+ register char *p, *q;
+
+ p = q = (char *) Alloc(n);
+ while(--n >= 0)
+ *q++ = *s++;
+ return(p);
+}
+
+
+
+/* copys -- return a new copy of the input C-string */
+
+ char *
+#ifdef KR_headers
+copys(s)
+ char *s;
+#else
+copys(char *s)
+#endif
+{
+ return( copyn( strlen(s)+1 , s) );
+}
+
+
+
+/* convci -- Convert Fortran-string to integer; assumes that input is a
+ legal number, with no trailing blanks */
+
+ ftnint
+#ifdef KR_headers
+convci(n, s)
+ register int n;
+ register char *s;
+#else
+convci(register int n, register char *s)
+#endif
+{
+ ftnint sum, t;
+ char buff[100], *s0;
+ int n0;
+
+ s0 = s;
+ n0 = n;
+ sum = 0;
+ while(n-- > 0) {
+ /* sum = 10*sum + (*s++ - '0'); */
+ t = *s++ - '0';
+ if (sum > LONG_MAX/10) {
+ ovfl:
+ if (n0 > 60)
+ n0 = 60;
+ sprintf(buff, "integer constant %.*s truncated.",
+ n0, s0);
+ err(buff);
+ return LONG_MAX;
+ }
+ sum *= 10;
+ if (sum > LONG_MAX - t)
+ goto ovfl;
+ sum += t;
+ }
+ return(sum);
+ }
+
+/* convic - Convert Integer constant to string */
+
+ char *
+#ifdef KR_headers
+convic(n)
+ ftnint n;
+#else
+convic(ftnint n)
+#endif
+{
+ static char s[20];
+ register char *t;
+
+ s[19] = '\0';
+ t = s+19;
+
+ do {
+ *--t = '0' + n%10;
+ n /= 10;
+ } while(n > 0);
+
+ return(t);
+}
+
+
+
+/* mkname -- add a new identifier to the environment, including the closed
+ hash table. */
+
+ Namep
+#ifdef KR_headers
+mkname(s)
+ register char *s;
+#else
+mkname(register char *s)
+#endif
+{
+ struct Hashentry *hp;
+ register Namep q;
+ register int c, hash, i;
+ register char *t;
+ char *s0;
+ char errbuf[64];
+
+ hash = i = 0;
+ s0 = s;
+ while(c = *s++) {
+ hash += c;
+ if (c == '_')
+ i = 2;
+ }
+ if (!i && in_vector(s0,c_keywords,n_keywords) >= 0)
+ i = 2;
+ hash %= maxhash;
+
+/* Add the name to the closed hash table */
+
+ hp = hashtab + hash;
+
+ while(q = hp->varp)
+ if( hash == hp->hashval && !strcmp(s0,q->fvarname) )
+ return(q);
+ else if(++hp >= lasthash)
+ hp = hashtab;
+
+ if(++nintnames >= maxhash-1)
+ many("names", 'n', maxhash); /* Fatal error */
+ hp->varp = q = ALLOC(Nameblock);
+ hp->hashval = hash;
+ q->tag = TNAME; /* TNAME means the tag type is NAME */
+ c = s - s0;
+ if (c > 7 && noextflag) {
+ sprintf(errbuf, "\"%.35s%s\" over 6 characters long", s0,
+ c > 36 ? "..." : "");
+ errext(errbuf);
+ }
+ q->fvarname = strcpy(mem(c,0), s0);
+ t = q->cvarname = mem(c + i + 1, 0);
+ s = s0;
+ /* add __ to the end of any name containing _ and to any C keyword */
+ while(*t = *s++)
+ t++;
+ if (i) {
+ do *t++ = '_';
+ while(--i > 0);
+ *t = 0;
+ }
+ return(q);
+}
+
+
+ struct Labelblock *
+#ifdef KR_headers
+mklabel(l)
+ ftnint l;
+#else
+mklabel(ftnint l)
+#endif
+{
+ register struct Labelblock *lp;
+
+ if(l <= 0)
+ return(NULL);
+
+ for(lp = labeltab ; lp < highlabtab ; ++lp)
+ if(lp->stateno == l)
+ return(lp);
+
+ if(++highlabtab > labtabend)
+ many("statement labels", 's', maxstno);
+
+ lp->stateno = l;
+ lp->labelno = (int)newlabel();
+ lp->blklevel = 0;
+ lp->labused = NO;
+ lp->fmtlabused = NO;
+ lp->labdefined = NO;
+ lp->labinacc = NO;
+ lp->labtype = LABUNKNOWN;
+ lp->fmtstring = 0;
+ return(lp);
+}
+
+ long
+newlabel(Void)
+{
+ return ++lastlabno;
+}
+
+
+/* this label appears in a branch context */
+
+ struct Labelblock *
+#ifdef KR_headers
+execlab(stateno)
+ ftnint stateno;
+#else
+execlab(ftnint stateno)
+#endif
+{
+ register struct Labelblock *lp;
+
+ if(lp = mklabel(stateno))
+ {
+ if(lp->labinacc)
+ warn1("illegal branch to inner block, statement label %s",
+ convic(stateno) );
+ else if(lp->labdefined == NO)
+ lp->blklevel = blklevel;
+ if(lp->labtype == LABFORMAT)
+ err("may not branch to a format");
+ else
+ lp->labtype = LABEXEC;
+ }
+ else
+ execerr("illegal label %s", convic(stateno));
+
+ return(lp);
+}
+
+
+/* find or put a name in the external symbol table */
+
+ Extsym *
+#ifdef KR_headers
+mkext1(f, s)
+ char *f;
+ char *s;
+#else
+mkext1(char *f, char *s)
+#endif
+{
+ Extsym *p;
+
+ for(p = extsymtab ; p<nextext ; ++p)
+ if(!strcmp(s,p->cextname))
+ return( p );
+
+ if(nextext >= lastext)
+ many("external symbols", 'x', maxext);
+
+ nextext->fextname = strcpy(gmem(strlen(f)+1,0), f);
+ nextext->cextname = f == s
+ ? nextext->fextname
+ : strcpy(gmem(strlen(s)+1,0), s);
+ nextext->extstg = STGUNKNOWN;
+ nextext->extp = 0;
+ nextext->allextp = 0;
+ nextext->extleng = 0;
+ nextext->maxleng = 0;
+ nextext->extinit = 0;
+ nextext->curno = nextext->maxno = 0;
+ return( nextext++ );
+}
+
+
+ Extsym *
+#ifdef KR_headers
+mkext(f, s)
+ char *f;
+ char *s;
+#else
+mkext(char *f, char *s)
+#endif
+{
+ Extsym *e = mkext1(f, s);
+ if (e->extstg == STGCOMMON)
+ errstr("%.52s cannot be a subprogram: it is a common block.",f);
+ return e;
+ }
+
+ Addrp
+#ifdef KR_headers
+builtin(t, s, dbi)
+ int t;
+ char *s;
+ int dbi;
+#else
+builtin(int t, char *s, int dbi)
+#endif
+{
+ register Extsym *p;
+ register Addrp q;
+ extern chainp used_builtins;
+
+ p = mkext(s,s);
+ if(p->extstg == STGUNKNOWN)
+ p->extstg = STGEXT;
+ else if(p->extstg != STGEXT)
+ {
+ errstr("improper use of builtin %s", s);
+ return(0);
+ }
+
+ q = ALLOC(Addrblock);
+ q->tag = TADDR;
+ q->vtype = t;
+ q->vclass = CLPROC;
+ q->vstg = STGEXT;
+ q->memno = p - extsymtab;
+ q->dbl_builtin = dbi;
+
+/* A NULL pointer here tells you to use memno to check the external
+ symbol table */
+
+ q -> uname_tag = UNAM_EXTERN;
+
+/* Add to the list of used builtins */
+
+ if (dbi >= 0)
+ add_extern_to_list (q, &used_builtins);
+ return(q);
+}
+
+
+ void
+#ifdef KR_headers
+add_extern_to_list(addr, list_store)
+ Addrp addr;
+ chainp *list_store;
+#else
+add_extern_to_list(Addrp addr, chainp *list_store)
+#endif
+{
+ chainp last = CHNULL;
+ chainp list;
+ int memno;
+
+ if (list_store == (chainp *) NULL || addr == (Addrp) NULL)
+ return;
+
+ list = *list_store;
+ memno = addr -> memno;
+
+ for (;list; last = list, list = list -> nextp) {
+ Addrp This = (Addrp) (list -> datap);
+
+ if (This -> tag == TADDR && This -> uname_tag == UNAM_EXTERN &&
+ This -> memno == memno)
+ return;
+ } /* for */
+
+ if (*list_store == CHNULL)
+ *list_store = mkchain((char *)cpexpr((expptr)addr), CHNULL);
+ else
+ last->nextp = mkchain((char *)cpexpr((expptr)addr), CHNULL);
+
+} /* add_extern_to_list */
+
+
+ void
+#ifdef KR_headers
+frchain(p)
+ register chainp *p;
+#else
+frchain(register chainp *p)
+#endif
+{
+ register chainp q;
+
+ if(p==0 || *p==0)
+ return;
+
+ for(q = *p; q->nextp ; q = q->nextp)
+ ;
+ q->nextp = chains;
+ chains = *p;
+ *p = 0;
+}
+
+ void
+#ifdef KR_headers
+frexchain(p)
+ register chainp *p;
+#else
+frexchain(register chainp *p)
+#endif
+{
+ register chainp q, r;
+
+ if (q = *p) {
+ for(;;q = r) {
+ frexpr((expptr)q->datap);
+ if (!(r = q->nextp))
+ break;
+ }
+ q->nextp = chains;
+ chains = *p;
+ *p = 0;
+ }
+ }
+
+
+ tagptr
+#ifdef KR_headers
+cpblock(n, p)
+ register int n;
+ register char *p;
+#else
+cpblock(register int n, register char *p)
+#endif
+{
+ register ptr q;
+
+ memcpy((char *)(q = ckalloc(n)), (char *)p, n);
+ return( (tagptr) q);
+}
+
+
+
+ ftnint
+#ifdef KR_headers
+lmax(a, b)
+ ftnint a;
+ ftnint b;
+#else
+lmax(ftnint a, ftnint b)
+#endif
+{
+ return( a>b ? a : b);
+}
+
+ ftnint
+#ifdef KR_headers
+lmin(a, b)
+ ftnint a;
+ ftnint b;
+#else
+lmin(ftnint a, ftnint b)
+#endif
+{
+ return(a < b ? a : b);
+}
+
+
+
+ int
+#ifdef KR_headers
+maxtype(t1, t2)
+ int t1;
+ int t2;
+#else
+maxtype(int t1, int t2)
+#endif
+{
+ int t;
+
+ t = t1 >= t2 ? t1 : t2;
+ if(t==TYCOMPLEX && (t1==TYDREAL || t2==TYDREAL) )
+ t = TYDCOMPLEX;
+ return(t);
+}
+
+
+
+/* return log base 2 of n if n a power of 2; otherwise -1 */
+ int
+#ifdef KR_headers
+log_2(n)
+ ftnint n;
+#else
+log_2(ftnint n)
+#endif
+{
+ int k;
+
+ /* trick based on binary representation */
+
+ if(n<=0 || (n & (n-1))!=0)
+ return(-1);
+
+ for(k = 0 ; n >>= 1 ; ++k)
+ ;
+ return(k);
+}
+
+
+ void
+frrpl(Void)
+{
+ struct Rplblock *rp;
+
+ while(rpllist)
+ {
+ rp = rpllist->rplnextp;
+ free( (charptr) rpllist);
+ rpllist = rp;
+ }
+}
+
+
+
+/* Call a Fortran function with an arbitrary list of arguments */
+
+int callk_kludge;
+
+ expptr
+#ifdef KR_headers
+callk(type, name, args)
+ int type;
+ char *name;
+ chainp args;
+#else
+callk(int type, char *name, chainp args)
+#endif
+{
+ register expptr p;
+
+ p = mkexpr(OPCALL,
+ (expptr)builtin(callk_kludge ? callk_kludge : type, name, 0),
+ (expptr)args);
+ p->exprblock.vtype = type;
+ return(p);
+}
+
+
+
+ expptr
+#ifdef KR_headers
+call4(type, name, arg1, arg2, arg3, arg4)
+ int type;
+ char *name;
+ expptr arg1;
+ expptr arg2;
+ expptr arg3;
+ expptr arg4;
+#else
+call4(int type, char *name, expptr arg1, expptr arg2, expptr arg3, expptr arg4)
+#endif
+{
+ struct Listblock *args;
+ args = mklist( mkchain((char *)arg1,
+ mkchain((char *)arg2,
+ mkchain((char *)arg3,
+ mkchain((char *)arg4, CHNULL)) ) ) );
+ return( callk(type, name, (chainp)args) );
+}
+
+
+
+
+ expptr
+#ifdef KR_headers
+call3(type, name, arg1, arg2, arg3)
+ int type;
+ char *name;
+ expptr arg1;
+ expptr arg2;
+ expptr arg3;
+#else
+call3(int type, char *name, expptr arg1, expptr arg2, expptr arg3)
+#endif
+{
+ struct Listblock *args;
+ args = mklist( mkchain((char *)arg1,
+ mkchain((char *)arg2,
+ mkchain((char *)arg3, CHNULL) ) ) );
+ return( callk(type, name, (chainp)args) );
+}
+
+
+
+
+
+ expptr
+#ifdef KR_headers
+call2(type, name, arg1, arg2)
+ int type;
+ char *name;
+ expptr arg1;
+ expptr arg2;
+#else
+call2(int type, char *name, expptr arg1, expptr arg2)
+#endif
+{
+ struct Listblock *args;
+
+ args = mklist( mkchain((char *)arg1, mkchain((char *)arg2, CHNULL) ) );
+ return( callk(type,name, (chainp)args) );
+}
+
+
+
+
+ expptr
+#ifdef KR_headers
+call1(type, name, arg)
+ int type;
+ char *name;
+ expptr arg;
+#else
+call1(int type, char *name, expptr arg)
+#endif
+{
+ return( callk(type,name, (chainp)mklist(mkchain((char *)arg,CHNULL)) ));
+}
+
+
+ expptr
+#ifdef KR_headers
+call0(type, name)
+ int type;
+ char *name;
+#else
+call0(int type, char *name)
+#endif
+{
+ return( callk(type, name, CHNULL) );
+}
+
+
+
+ struct Impldoblock *
+#ifdef KR_headers
+mkiodo(dospec, list)
+ chainp dospec;
+ chainp list;
+#else
+mkiodo(chainp dospec, chainp list)
+#endif
+{
+ register struct Impldoblock *q;
+
+ q = ALLOC(Impldoblock);
+ q->tag = TIMPLDO;
+ q->impdospec = dospec;
+ q->datalist = list;
+ return(q);
+}
+
+
+
+
+/* ckalloc -- Allocate 1 memory unit of size n, checking for out of
+ memory error */
+
+ ptr
+#ifdef KR_headers
+ckalloc(n)
+ register int n;
+#else
+ckalloc(register int n)
+#endif
+{
+ register ptr p;
+ p = (ptr)calloc(1, (unsigned) n);
+ if (p || !n)
+ return(p);
+ fprintf(stderr, "failing to get %d bytes\n",n);
+ Fatal("out of memory");
+ /* NOT REACHED */ return 0;
+}
+
+
+ int
+#ifdef KR_headers
+isaddr(p)
+ register expptr p;
+#else
+isaddr(register expptr p)
+#endif
+{
+ if(p->tag == TADDR)
+ return(YES);
+ if(p->tag == TEXPR)
+ switch(p->exprblock.opcode)
+ {
+ case OPCOMMA:
+ return( isaddr(p->exprblock.rightp) );
+
+ case OPASSIGN:
+ case OPASSIGNI:
+ case OPPLUSEQ:
+ case OPMINUSEQ:
+ case OPSLASHEQ:
+ case OPMODEQ:
+ case OPLSHIFTEQ:
+ case OPRSHIFTEQ:
+ case OPBITANDEQ:
+ case OPBITXOREQ:
+ case OPBITOREQ:
+ return( isaddr(p->exprblock.leftp) );
+ }
+ return(NO);
+}
+
+
+
+ int
+#ifdef KR_headers
+isstatic(p)
+ register expptr p;
+#else
+isstatic(register expptr p)
+#endif
+{
+ extern int useauto;
+ if(p->headblock.vleng && !ISCONST(p->headblock.vleng))
+ return(NO);
+
+ switch(p->tag)
+ {
+ case TCONST:
+ return(YES);
+
+ case TADDR:
+ if(ONEOF(p->addrblock.vstg,MSKSTATIC) &&
+ ISCONST(p->addrblock.memoffset) && !useauto)
+ return(YES);
+
+ default:
+ return(NO);
+ }
+}
+
+
+
+/* addressable -- return True iff it is a constant value, or can be
+ referenced by constant values */
+
+ int
+#ifdef KR_headers
+addressable(p) expptr p;
+#else
+addressable(expptr p)
+#endif
+{
+ if (p)
+ switch(p->tag) {
+ case TCONST:
+ return(YES);
+
+ case TADDR:
+ return( addressable(p->addrblock.memoffset) );
+ }
+ return(NO);
+ }
+
+
+/* isnegative_const -- returns true if the constant is negative. Returns
+ false for imaginary and nonnumeric constants */
+
+ int
+#ifdef KR_headers
+isnegative_const(cp)
+ struct Constblock *cp;
+#else
+isnegative_const(struct Constblock *cp)
+#endif
+{
+ int retval;
+
+ if (cp == NULL)
+ return 0;
+
+ switch (cp -> vtype) {
+ case TYINT1:
+ case TYSHORT:
+ case TYLONG:
+#ifdef TYQUAD
+ case TYQUAD:
+#endif
+ retval = cp -> Const.ci < 0;
+ break;
+ case TYREAL:
+ case TYDREAL:
+ retval = cp->vstg ? *cp->Const.cds[0] == '-'
+ : cp->Const.cd[0] < 0.0;
+ break;
+ default:
+
+ retval = 0;
+ break;
+ } /* switch */
+
+ return retval;
+} /* isnegative_const */
+
+ void
+#ifdef KR_headers
+negate_const(cp)
+ Constp cp;
+#else
+negate_const(Constp cp)
+#endif
+{
+ if (cp == (struct Constblock *) NULL)
+ return;
+
+ switch (cp -> vtype) {
+ case TYINT1:
+ case TYSHORT:
+ case TYLONG:
+#ifdef TYQUAD
+ case TYQUAD:
+#endif
+ cp -> Const.ci = - cp -> Const.ci;
+ break;
+ case TYCOMPLEX:
+ case TYDCOMPLEX:
+ if (cp->vstg)
+ switch(*cp->Const.cds[1]) {
+ case '-':
+ ++cp->Const.cds[1];
+ break;
+ case '0':
+ break;
+ default:
+ --cp->Const.cds[1];
+ }
+ else
+ cp->Const.cd[1] = -cp->Const.cd[1];
+ /* no break */
+ case TYREAL:
+ case TYDREAL:
+ if (cp->vstg)
+ switch(*cp->Const.cds[0]) {
+ case '-':
+ ++cp->Const.cds[0];
+ break;
+ case '0':
+ break;
+ default:
+ --cp->Const.cds[0];
+ }
+ else
+ cp->Const.cd[0] = -cp->Const.cd[0];
+ break;
+ case TYCHAR:
+ case TYLOGICAL1:
+ case TYLOGICAL2:
+ case TYLOGICAL:
+ erri ("negate_const: can't negate type '%d'", cp -> vtype);
+ break;
+ default:
+ erri ("negate_const: bad type '%d'",
+ cp -> vtype);
+ break;
+ } /* switch */
+} /* negate_const */
+
+ void
+#ifdef KR_headers
+ffilecopy(infp, outfp) FILE *infp, *outfp;
+#else
+ffilecopy(FILE *infp, FILE *outfp)
+#endif
+{
+ int c;
+ while (!feof(infp)) {
+ c = getc(infp);
+ if (!feof(infp))
+ putc(c, outfp);
+ }
+ }
+
+
+/* in_vector -- verifies whether str is in c_keywords.
+ If so, the index is returned else -1 is returned.
+ c_keywords must be in alphabetical order (as defined by strcmp).
+*/
+
+ int
+#ifdef KR_headers
+in_vector(str, keywds, n)
+ char *str;
+ char **keywds;
+ register int n;
+#else
+in_vector(char *str, char **keywds, register int n)
+#endif
+{
+ register char **K = keywds;
+ register int n1, t;
+
+ do {
+ n1 = n >> 1;
+ if (!(t = strcmp(str, K[n1])))
+ return K - keywds + n1;
+ if (t < 0)
+ n = n1;
+ else {
+ n -= ++n1;
+ K += n1;
+ }
+ }
+ while(n > 0);
+
+ return -1;
+ } /* in_vector */
+
+
+ int
+#ifdef KR_headers
+is_negatable(Const)
+ Constp Const;
+#else
+is_negatable(Constp Const)
+#endif
+{
+ int retval = 0;
+ if (Const != (Constp) NULL)
+ switch (Const -> vtype) {
+ case TYINT1:
+ retval = Const -> Const.ci >= -BIGGEST_CHAR;
+ break;
+ case TYSHORT:
+ retval = Const -> Const.ci >= -BIGGEST_SHORT;
+ break;
+ case TYLONG:
+#ifdef TYQUAD
+ case TYQUAD:
+#endif
+ retval = Const -> Const.ci >= -BIGGEST_LONG;
+ break;
+ case TYREAL:
+ case TYDREAL:
+ case TYCOMPLEX:
+ case TYDCOMPLEX:
+ retval = 1;
+ break;
+ case TYLOGICAL1:
+ case TYLOGICAL2:
+ case TYLOGICAL:
+ case TYCHAR:
+ case TYSUBR:
+ default:
+ retval = 0;
+ break;
+ } /* switch */
+
+ return retval;
+} /* is_negatable */
+
+ void
+#ifdef KR_headers
+backup(fname, bname)
+ char *fname;
+ char *bname;
+#else
+backup(char *fname, char *bname)
+#endif
+{
+ FILE *b, *f;
+ static char couldnt[] = "Couldn't open %.80s";
+
+ if (!(f = fopen(fname, binread))) {
+ warn1(couldnt, fname);
+ return;
+ }
+ if (!(b = fopen(bname, binwrite))) {
+ warn1(couldnt, bname);
+ return;
+ }
+ ffilecopy(f, b);
+ fclose(f);
+ fclose(b);
+ }
+
+
+/* struct_eq -- returns YES if structures have the same field names and
+ types, NO otherwise */
+
+ int
+#ifdef KR_headers
+struct_eq(s1, s2)
+ chainp s1;
+ chainp s2;
+#else
+struct_eq(chainp s1, chainp s2)
+#endif
+{
+ struct Dimblock *d1, *d2;
+ Constp cp1, cp2;
+
+ if (s1 == CHNULL && s2 == CHNULL)
+ return YES;
+ for(; s1 && s2; s1 = s1->nextp, s2 = s2->nextp) {
+ register Namep v1 = (Namep) s1 -> datap;
+ register Namep v2 = (Namep) s2 -> datap;
+
+ if (v1 == (Namep) NULL || v1 -> tag != TNAME ||
+ v2 == (Namep) NULL || v2 -> tag != TNAME)
+ return NO;
+
+ if (v1->vtype != v2->vtype || v1->vclass != v2->vclass
+ || strcmp(v1->fvarname, v2->fvarname))
+ return NO;
+
+ /* compare dimensions (needed for comparing COMMON blocks) */
+
+ if (d1 = v1->vdim) {
+ if (!(cp1 = (Constp)d1->nelt) || cp1->tag != TCONST
+ || !(d2 = v2->vdim)
+ || !(cp2 = (Constp)d2->nelt) || cp2->tag != TCONST
+ || cp1->Const.ci != cp2->Const.ci)
+ return NO;
+ }
+ else if (v2->vdim)
+ return NO;
+ } /* while s1 != CHNULL && s2 != CHNULL */
+
+ return s1 == CHNULL && s2 == CHNULL;
+} /* struct_eq */
+
+ static int
+#ifdef KR_headers
+int_trunc(n0, s0) int n0; char *s0;
+#else
+int_trunc(int n0, char *s0)
+#endif
+{
+ char buff[100];
+
+ if (n0 > 60)
+ n0 = 60;
+ sprintf(buff, "integer constant %.*s truncated.", n0, s0);
+ err(buff);
+ return 1;
+ }
+
+ tagptr
+#ifdef KR_headers
+mkintqcon(n, s) int n; char *s;
+#else
+mkintqcon(int n, char *s)
+#endif
+{
+#ifdef NO_LONG_LONG
+ return mkintcon(convci(n, s));
+#else
+#ifndef LLONG_MAX
+#ifdef LONGLONG_MAX
+#define LLONG_MAX LONGLONG_MAX
+#else
+#define LLONG_MAX 0x7fffffffffffffffLL
+#endif
+#endif
+ Constp p;
+ Llong sum, t;
+ char *s0;
+ int n0, warned = 0;
+
+ s0 = s;
+ n0 = n;
+ sum = 0;
+ while(n-- > 0) {
+ /* sum = 10*sum + (*s++ - '0'); */
+ t = *s++ - '0';
+ if (sum > LLONG_MAX/10) {
+ ovfl:
+ warned = int_trunc(n0,s0);
+ sum = LLONG_MAX;
+ break;
+ }
+ sum *= 10;
+ if (sum > LLONG_MAX - t)
+ goto ovfl;
+ sum += t;
+ }
+ p = mkconst(tyint);
+ if (sum > LONG_MAX) {
+ if (allow_i8c) {
+ p->vtype = TYQUAD;
+ p->Const.cq = sum;
+ }
+ else {
+ p->Const.ci = LONG_MAX;
+ if (!warned)
+ int_trunc(n0,s0);
+ }
+ }
+ else
+ p->Const.ci = (ftnint) sum;
+ return (tagptr)p;
+#endif
+ }
generated by cgit (git 2.34.1) at 2025-09-20 09:49:04 -0400