lang/fortran/comp/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         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 = 1;
 327                 }
 328         hash %= maxhash;
 329
 330 /* Add the name to the closed hash table */
 331
 332         hp = hashtab + hash;
 333
 334         while(q = hp->varp)
 335                 if( hash == hp->hashval && !strcmp(s0,q->fvarname) )
 336                         return(q);
 337                 else if(++hp >= lasthash)
 338                         hp = hashtab;
 339
 340         if(++nintnames >= maxhash-1)
 341                 many("names", 'n', maxhash);    /* Fatal error */
 342         hp->varp = q = ALLOC(Nameblock);
 343         hp->hashval = hash;
 344         q->tag = TNAME; /* TNAME means the tag type is NAME */
 345         c = s - s0;
 346         if (c > 7 && noextflag) {
 347                 sprintf(errbuf, "\"%.35s%s\" over 6 characters long", s0,
 348                         c > 36 ? "..." : "");
 349                 errext(errbuf);
 350                 }
 351         q->fvarname = strcpy(mem(c,0), s0);
 352         t = q->cvarname = mem(c + i + 1, 0);
 353         s = s0;
 354         /* add __ to the end of any name containing _ */
 355         while(*t = *s++)
 356                 t++;
 357         if (i) {
 358                 t[0] = t[1] = '_';
 359                 t[2] = 0;
 360                 }
 361         else if (in_vector(s0) >= 0) {
 362                 t[0] = '_';
 363                 t[1] = 0;
 364                 }
 365         return(q);
 366 }
 367
 368
 369 struct Labelblock *mklabel(l)
 370 ftnint l;
 371 {
 372         register struct Labelblock *lp;
 373
 374         if(l <= 0)
 375                 return(NULL);
 376
 377         for(lp = labeltab ; lp < highlabtab ; ++lp)
 378                 if(lp->stateno == l)
 379                         return(lp);
 380
 381         if(++highlabtab > labtabend)
 382                 many("statement labels", 's', maxstno);
 383
 384         lp->stateno = l;
 385         lp->labelno = newlabel();
 386         lp->blklevel = 0;
 387         lp->labused = NO;
 388         lp->fmtlabused = NO;
 389         lp->labdefined = NO;
 390         lp->labinacc = NO;
 391         lp->labtype = LABUNKNOWN;
 392         lp->fmtstring = 0;
 393         return(lp);
 394 }
 395
 396
 397 newlabel()
 398 {
 399         return( ++lastlabno );
 400 }
 401
 402
 403 /* this label appears in a branch context */
 404
 405 struct Labelblock *execlab(stateno)
 406 ftnint stateno;
 407 {
 408         register struct Labelblock *lp;
 409
 410         if(lp = mklabel(stateno))
 411         {
 412                 if(lp->labinacc)
 413                         warn1("illegal branch to inner block, statement label %s",
 414                             convic(stateno) );
 415                 else if(lp->labdefined == NO)
 416                         lp->blklevel = blklevel;
 417                 if(lp->labtype == LABFORMAT)
 418                         err("may not branch to a format");
 419                 else
 420                         lp->labtype = LABEXEC;
 421         }
 422         else
 423                 execerr("illegal label %s", convic(stateno));
 424
 425         return(lp);
 426 }
 427
 428
 429 /* find or put a name in the external symbol table */
 430
 431 Extsym *mkext(f,s)
 432 char *f, *s;
 433 {
 434         Extsym *p;
 435
 436         for(p = extsymtab ; p<nextext ; ++p)
 437                 if(!strcmp(s,p->cextname))
 438                         return( p );
 439
 440         if(nextext >= lastext)
 441                 many("external symbols", 'x', maxext);
 442
 443         nextext->fextname = strcpy(gmem(strlen(f)+1,0), f);
 444         nextext->cextname = f == s
 445                                 ? nextext->fextname
 446                                 : strcpy(gmem(strlen(s)+1,0), s);
 447         nextext->extstg = STGUNKNOWN;
 448         nextext->extp = 0;
 449         nextext->allextp = 0;
 450         nextext->extleng = 0;
 451         nextext->maxleng = 0;
 452         nextext->extinit = 0;
 453         nextext->curno = nextext->maxno = 0;
 454         return( nextext++ );
 455 }
 456
 457
 458 Addrp builtin(t, s, dbi)
 459 int t, dbi;
 460 char *s;
 461 {
 462         register Extsym *p;
 463         register Addrp q;
 464         extern chainp used_builtins;
 465
 466         p = mkext(s,s);
 467         if(p->extstg == STGUNKNOWN)
 468                 p->extstg = STGEXT;
 469         else if(p->extstg != STGEXT)
 470         {
 471                 errstr("improper use of builtin %s", s);
 472                 return(0);
 473         }
 474
 475         q = ALLOC(Addrblock);
 476         q->tag = TADDR;
 477         q->vtype = t;
 478         q->vclass = CLPROC;
 479         q->vstg = STGEXT;
 480         q->memno = p - extsymtab;
 481         q->dbl_builtin = dbi;
 482
 483 /* A NULL pointer here tells you to use   memno   to check the external
 484    symbol table */
 485
 486         q -> uname_tag = UNAM_EXTERN;
 487
 488 /* Add to the list of used builtins */
 489
 490         if (dbi >= 0)
 491                 add_extern_to_list (q, &used_builtins);
 492         return(q);
 493 }
 494
 495
 496
 497 add_extern_to_list (addr, list_store)
 498 Addrp addr;
 499 chainp *list_store;
 500 {
 501     chainp last = CHNULL;
 502     chainp list;
 503     int memno;
 504
 505     if (list_store == (chainp *) NULL || addr == (Addrp) NULL)
 506         return;
 507
 508     list = *list_store;
 509     memno = addr -> memno;
 510
 511     for (;list; last = list, list = list -> nextp) {
 512         Addrp this = (Addrp) (list -> datap);
 513
 514         if (this -> tag == TADDR && this -> uname_tag == UNAM_EXTERN &&
 515                 this -> memno == memno)
 516             return;
 517     } /* for */
 518
 519     if (*list_store == CHNULL)
 520         *list_store = mkchain((char *)cpexpr((expptr)addr), CHNULL);
 521     else
 522         last->nextp = mkchain((char *)cpexpr((expptr)addr), CHNULL);
 523
 524 } /* add_extern_to_list */
 525
 526
 527 frchain(p)
 528 register chainp *p;
 529 {
 530         register chainp q;
 531
 532         if(p==0 || *p==0)
 533                 return;
 534
 535         for(q = *p; q->nextp ; q = q->nextp)
 536                 ;
 537         q->nextp = chains;
 538         chains = *p;
 539         *p = 0;
 540 }
 541
 542  void
 543 frexchain(p)
 544  register chainp *p;
 545 {
 546         register chainp q, r;
 547
 548         if (q = *p) {
 549                 for(;;q = r) {
 550                         frexpr((expptr)q->datap);
 551                         if (!(r = q->nextp))
 552                                 break;
 553                         }
 554                 q->nextp = chains;
 555                 chains = *p;
 556                 *p = 0;
 557                 }
 558         }
 559
 560
 561 tagptr cpblock(n,p)
 562 register int n;
 563 register char * p;
 564 {
 565         register ptr q;
 566
 567         memcpy((char *)(q = ckalloc(n)), (char *)p, n);
 568         return( (tagptr) q);
 569 }
 570
 571
 572
 573 ftnint lmax(a, b)
 574 ftnint a, b;
 575 {
 576         return( a>b ? a : b);
 577 }
 578
 579 ftnint lmin(a, b)
 580 ftnint a, b;
 581 {
 582         return(a < b ? a : b);
 583 }
 584
 585
 586
 587
 588 maxtype(t1, t2)
 589 int t1, t2;
 590 {
 591         int t;
 592
 593         t = t1 >= t2 ? t1 : t2;
 594         if(t==TYCOMPLEX && (t1==TYDREAL || t2==TYDREAL) )
 595                 t = TYDCOMPLEX;
 596         return(t);
 597 }
 598
 599
 600
 601 /* return log base 2 of n if n a power of 2; otherwise -1 */
 602 log_2(n)
 603 ftnint n;
 604 {
 605         int k;
 606
 607         /* trick based on binary representation */
 608
 609         if(n<=0 || (n & (n-1))!=0)
 610                 return(-1);
 611
 612         for(k = 0 ;  n >>= 1  ; ++k)
 613                 ;
 614         return(k);
 615 }
 616
 617
 618
 619 frrpl()
 620 {
 621         struct Rplblock *rp;
 622
 623         while(rpllist)
 624         {
 625                 rp = rpllist->rplnextp;
 626                 free( (charptr) rpllist);
 627                 rpllist = rp;
 628         }
 629 }
 630
 631
 632
 633 /* Call a Fortran function with an arbitrary list of arguments */
 634
 635 int callk_kludge;
 636
 637 expptr callk(type, name, args)
 638 int type;
 639 char *name;
 640 chainp args;
 641 {
 642         register expptr p;
 643
 644         p = mkexpr(OPCALL,
 645                 (expptr)builtin(callk_kludge ? callk_kludge : type, name, 0),
 646                 (expptr)args);
 647         p->exprblock.vtype = type;
 648         return(p);
 649 }
 650
 651
 652
 653 expptr call4(type, name, arg1, arg2, arg3, arg4)
 654 int type;
 655 char *name;
 656 expptr arg1, arg2, arg3, arg4;
 657 {
 658         struct Listblock *args;
 659         args = mklist( mkchain((char *)arg1,
 660                         mkchain((char *)arg2,
 661                                 mkchain((char *)arg3,
 662                                         mkchain((char *)arg4, CHNULL)) ) ) );
 663         return( callk(type, name, (chainp)args) );
 664 }
 665
 666
 667
 668
 669 expptr call3(type, name, arg1, arg2, arg3)
 670 int type;
 671 char *name;
 672 expptr arg1, arg2, arg3;
 673 {
 674         struct Listblock *args;
 675         args = mklist( mkchain((char *)arg1,
 676                         mkchain((char *)arg2,
 677                                 mkchain((char *)arg3, CHNULL) ) ) );
 678         return( callk(type, name, (chainp)args) );
 679 }
 680
 681
 682
 683
 684
 685 expptr call2(type, name, arg1, arg2)
 686 int type;
 687 char *name;
 688 expptr arg1, arg2;
 689 {
 690         struct Listblock *args;
 691
 692         args = mklist( mkchain((char *)arg1, mkchain((char *)arg2, CHNULL) ) );
 693         return( callk(type,name, (chainp)args) );
 694 }
 695
 696
 697
 698
 699 expptr call1(type, name, arg)
 700 int type;
 701 char *name;
 702 expptr arg;
 703 {
 704         return( callk(type,name, (chainp)mklist(mkchain((char *)arg,CHNULL)) ));
 705 }
 706
 707
 708 expptr call0(type, name)
 709 int type;
 710 char *name;
 711 {
 712         return( callk(type, name, CHNULL) );
 713 }
 714
 715
 716
 717 struct Impldoblock *mkiodo(dospec, list)
 718 chainp dospec, list;
 719 {
 720         register struct Impldoblock *q;
 721
 722         q = ALLOC(Impldoblock);
 723         q->tag = TIMPLDO;
 724         q->impdospec = dospec;
 725         q->datalist = list;
 726         return(q);
 727 }
 728
 729
 730
 731
 732 /* ckalloc -- Allocate 1 memory unit of size   n,   checking for out of
 733    memory error */
 734
 735 ptr ckalloc(n)
 736 register int n;
 737 {
 738         register ptr p;
 739         if( p = (ptr)calloc(1, (unsigned) 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 TYSHORT:
 835         case TYLONG:
 836             retval = cp -> Const.ci < 0;
 837             break;
 838         case TYREAL:
 839         case TYDREAL:
 840                 retval = cp->vstg ? *cp->Const.cds[0] == '-'
 841                                   :  cp->Const.cd[0] < 0.0;
 842             break;
 843         default:
 844
 845             retval = 0;
 846             break;
 847     } /* switch */
 848
 849     return retval;
 850 } /* isnegative_const */
 851
 852 negate_const(cp)
 853  Constp cp;
 854 {
 855     if (cp == (struct Constblock *) NULL)
 856         return;
 857
 858     switch (cp -> vtype) {
 859         case TYSHORT:
 860         case TYLONG:
 861             cp -> Const.ci = - cp -> Const.ci;
 862             break;
 863         case TYCOMPLEX:
 864         case TYDCOMPLEX:
 865                 if (cp->vstg)
 866                     switch(*cp->Const.cds[1]) {
 867                         case '-':
 868                                 ++cp->Const.cds[1];
 869                                 break;
 870                         case '0':
 871                                 break;
 872                         default:
 873                                 --cp->Const.cds[1];
 874                         }
 875                 else
 876                         cp->Const.cd[1] = -cp->Const.cd[1];
 877                 /* no break */
 878         case TYREAL:
 879         case TYDREAL:
 880                 if (cp->vstg)
 881                     switch(*cp->Const.cds[0]) {
 882                         case '-':
 883                                 ++cp->Const.cds[0];
 884                                 break;
 885                         case '0':
 886                                 break;
 887                         default:
 888                                 --cp->Const.cds[0];
 889                         }
 890                 else
 891                         cp->Const.cd[0] = -cp->Const.cd[0];
 892             break;
 893         case TYCHAR:
 894         case TYLOGICAL:
 895             erri ("negate_const:  can't negate type '%d'", cp -> vtype);
 896             break;
 897         default:
 898             erri ("negate_const:  bad type '%d'",
 899                     cp -> vtype);
 900             break;
 901     } /* switch */
 902 } /* negate_const */
 903
 904 ffilecopy (infp, outfp)
 905 FILE *infp, *outfp;
 906 {
 907     while (!feof (infp)) {
 908         register c = getc (infp);
 909         if (!feof (infp))
 910         putc (c, outfp);
 911     } /* while */
 912 } /* ffilecopy */
 913
 914
 915 #define NOT_IN_VECTOR -1
 916
 917 /* in_vector -- verifies whether   str   is in c_keywords.
 918    If so, the index is returned else   NOT_IN_VECTOR   is returned.
 919    c_keywords must be in alphabetical order (as defined by strcmp).
 920 */
 921
 922 int in_vector(str)
 923 char *str;
 924 {
 925         extern int n_keywords;
 926         extern char *c_keywords[];
 927         register int n = n_keywords;
 928         register char **K = c_keywords;
 929         register int n1, t;
 930
 931         do {
 932                 n1 = n >> 1;
 933                 if (!(t = strcmp(str, K[n1])))
 934                         return K - c_keywords + n1;
 935                 if (t < 0)
 936                         n = n1;
 937                 else {
 938                         n -= ++n1;
 939                         K += n1;
 940                         }
 941                 }
 942                 while(n > 0);
 943
 944         return NOT_IN_VECTOR;
 945         } /* in_vector */
 946
 947
 948 int is_negatable (Const)
 949 Constp Const;
 950 {
 951     int retval = 0;
 952     if (Const != (Constp) NULL)
 953         switch (Const -> vtype) {
 954             case TYSHORT:
 955                 retval = Const -> Const.ci >= -BIGGEST_SHORT;
 956                 break;
 957             case TYLONG:
 958                 retval = Const -> Const.ci >= -BIGGEST_LONG;
 959                 break;
 960             case TYREAL:
 961             case TYDREAL:
 962             case TYCOMPLEX:
 963             case TYDCOMPLEX:
 964                 retval = 1;
 965                 break;
 966             case TYLOGICAL:
 967             case TYCHAR:
 968             case TYSUBR:
 969             default:
 970                 retval = 0;
 971                 break;
 972         } /* switch */
 973
 974     return retval;
 975 } /* is_negatable */
 976
 977 backup(fname, bname)
 978  char *fname, *bname;
 979 {
 980         FILE *b, *f;
 981         static char couldnt[] = "Couldn't open %.80s";
 982
 983         if (!(f = fopen(fname, binread))) {
 984                 warn1(couldnt, fname);
 985                 return;
 986                 }
 987         if (!(b = fopen(bname, binwrite))) {
 988                 warn1(couldnt, bname);
 989                 return;
 990                 }
 991         ffilecopy(f, b);
 992         fclose(f);
 993         fclose(b);
 994         }
 995
 996
 997 /* struct_eq -- returns YES if structures have the same field names and
 998    types, NO otherwise */
 999
1000 int struct_eq (s1, s2)
1001 chainp s1, s2;
1002 {
1003     struct Dimblock *d1, *d2;
1004     Constp cp1, cp2;
1005
1006     if (s1 == CHNULL && s2 == CHNULL)
1007         return YES;
1008     for(; s1 && s2; s1 = s1->nextp, s2 = s2->nextp) {
1009         register Namep v1 = (Namep) s1 -> datap;
1010         register Namep v2 = (Namep) s2 -> datap;
1011
1012         if (v1 == (Namep) NULL || v1 -> tag != TNAME ||
1013                 v2 == (Namep) NULL || v2 -> tag != TNAME)
1014             return NO;
1015
1016         if (v1->vtype != v2->vtype || v1->vclass != v2->vclass
1017                 || strcmp(v1->fvarname, v2->fvarname))
1018             return NO;
1019
1020         /* compare dimensions (needed for comparing COMMON blocks) */
1021
1022         if (d1 = v1->vdim) {
1023                 if (!(cp1 = (Constp)d1->nelt) || cp1->tag != TCONST)
1024                         return NO;
1025                 if (!(d2 = v2->vdim))
1026                         if (cp1->Const.ci == 1)
1027                                 continue;
1028                         else
1029                                 return NO;
1030                 if (!(cp2 = (Constp)d2->nelt) || cp2->tag != TCONST
1031                 ||  cp1->Const.ci != cp2->Const.ci)
1032                         return NO;
1033                 }
1034         else if ((d2 = v2->vdim) && (!(cp2 = (Constp)d2->nelt)
1035                                 || cp2->tag != TCONST
1036                                 || cp2->Const.ci != 1))
1037                 return NO;
1038     } /* while s1 != CHNULL && s2 != CHNULL */
1039
1040     return s1 == CHNULL && s2 == CHNULL;
1041 } /* struct_eq */