sources/f2c/misc.c

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