sources/f2c/init.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 #include "output.h"
  26 #include "iob.h"
  27
  28 /* State required for the C output */
  29 char *fl_fmt_string;            /* Float format string */
  30 char *db_fmt_string;            /* Double format string */
  31 char *cm_fmt_string;            /* Complex format string */
  32 char *dcm_fmt_string;           /* Double complex format string */
  33
  34 chainp new_vars = CHNULL;       /* List of newly created locals in this
  35                                    function.  These may have identifiers
  36                                    which have underscores and more than VL
  37                                    characters */
  38 chainp used_builtins = CHNULL;  /* List of builtins used by this function.
  39                                    These are all Addrps with UNAM_EXTERN
  40                                    */
  41 chainp assigned_fmts = CHNULL;  /* assigned formats */
  42 chainp allargs;                 /* union of args in all entry points */
  43 chainp earlylabs;               /* labels seen before enddcl() */
  44 char main_alias[52];            /* PROGRAM name, if any is given */
  45 int tab_size = 4;
  46
  47
  48 FILEP infile;
  49 FILEP diagfile;
  50
  51 FILEP c_file;
  52 FILEP pass1_file;
  53 FILEP initfile;
  54 FILEP blkdfile;
  55
  56
  57 char token[MAXTOKENLEN];
  58 int toklen;
  59 long lineno;                    /* Current line in the input file, NOT the
  60                                    Fortran statement label number */
  61 char *infname;
  62 int needkwd;
  63 struct Labelblock *thislabel    = NULL;
  64 int nerr;
  65 int nwarn;
  66
  67 flag saveall;
  68 flag substars;
  69 int parstate    = OUTSIDE;
  70 flag headerdone = NO;
  71 int blklevel;
  72 int doin_setbound;
  73 int impltype[26];
  74 ftnint implleng[26];
  75 int implstg[26];
  76
  77 int tyint       = TYLONG ;
  78 int tylogical   = TYLONG;
  79 int typesize[NTYPES] = {
  80         1, SZADDR, SZSHORT, SZLONG, SZLONG, 2*SZLONG,
  81             2*SZLONG, 4*SZLONG, SZLONG, 1, 1, 0,
  82                 4*SZLONG + SZADDR,      /* sizeof(cilist) */
  83                 4*SZLONG + 2*SZADDR,    /* sizeof(icilist) */
  84                 4*SZLONG + 5*SZADDR,    /* sizeof(olist) */
  85                 2*SZLONG + SZADDR,      /* sizeof(cllist) */
  86                 2*SZLONG,               /* sizeof(alist) */
  87                 11*SZLONG + 15*SZADDR   /* sizeof(inlist) */
  88                 };
  89
  90 int typealign[NTYPES] = {
  91         1, ALIADDR, ALISHORT, ALILONG, ALILONG, ALIDOUBLE,
  92         ALILONG, ALIDOUBLE, ALILONG, 1, 1, 1,
  93         ALILONG, ALILONG, ALILONG, ALILONG, ALILONG, ALILONG};
  94
  95 int type_choice[4] = { TYDREAL, TYSHORT, TYLONG,  TYSHORT };
  96
  97 char *typename[] = {
  98         "<<unknown>>",
  99         "address",
 100         "shortint",
 101         "integer",
 102         "real",
 103         "doublereal",
 104         "complex",
 105         "doublecomplex",
 106         "logical",
 107         "char"  /* character */
 108         };
 109
 110 int type_pref[NTYPES] = { 0, 0, 2, 4, 5, 7, 6, 8, 3, 1 };
 111
 112 char *protorettypes[] = {
 113         "?", "??", "shortint", "integer", "real", "doublereal",
 114         "C_f", "Z_f", "logical", "H_f", "int"
 115         };
 116
 117 char *casttypes[TYSUBR+1] = {
 118         "U_fp", "??bug??",
 119         "J_fp", "I_fp", "R_fp",
 120         "D_fp", "C_fp", "Z_fp",
 121         "L_fp", "H_fp", "S_fp"
 122         };
 123 char *usedcasts[TYSUBR+1];
 124
 125 char *dfltarg[] = {
 126         0, 0,
 127         "(shortint *)0", "(integer *)0", "(real *)0",
 128         "(doublereal *)0", "(complex *)0", "(doublecomplex *)0",
 129         "(logical *)0", "(char *)0"
 130         };
 131
 132 static char *dflt0proc[] = {
 133         0, 0,
 134         "(shortint (*)())0", "(integer (*)())0", "(real (*)())0",
 135         "(doublereal (*)())0", "(complex (*)())0", "(doublecomplex (*)())0",
 136         "(logical (*)())0", "(char (*)())0", "(int (*)())0"
 137         };
 138
 139 char *dflt1proc[] = { "(U_fp)0", "(??bug??)0",
 140         "(J_fp)0", "(I_fp)0", "(R_fp)0",
 141         "(D_fp)0", "(C_fp)0", "(Z_fp)0",
 142         "(L_fp)0", "(H_fp)0", "(S_fp)0"
 143         };
 144
 145 char **dfltproc = dflt0proc;
 146
 147 char *ftn_types[] = { "external", "??",
 148         "integer*2", "integer", "real",
 149         "double precision", "complex", "double complex",
 150         "logical", "character", "subroutine"
 151         };
 152
 153 int proctype    = TYUNKNOWN;
 154 char *procname;
 155 int rtvlabel[NTYPES0];
 156 Addrp retslot;                  /* Holds automatic variable which was
 157                                    allocated the function return value
 158                                    */
 159 Addrp xretslot[NTYPES0];        /* for multiple entry points */
 160 int cxslot      = -1;
 161 int chslot      = -1;
 162 int chlgslot    = -1;
 163 int procclass   = CLUNKNOWN;
 164 int nentry;
 165 int nallargs;
 166 int nallchargs;
 167 flag multitype;
 168 ftnint procleng;
 169 long lastiolabno;
 170 int lastlabno;
 171 int lastvarno;
 172 int lastargslot;
 173 int autonum[TYVOID];
 174 char *av_pfix[TYVOID] = {"??TYUNKNOWN??", "a","s","i","r","d","q","z","L","ch",
 175                          "??TYSUBR??", "??TYERROR??","ci", "ici",
 176                          "o", "cl", "al", "ioin" };
 177
 178 extern int maxctl;
 179 struct Ctlframe *ctls;
 180 struct Ctlframe *ctlstack;
 181 struct Ctlframe *lastctl;
 182
 183 Namep regnamep[MAXREGVAR];
 184 int highregvar;
 185 int nregvar;
 186
 187 extern int maxext;
 188 Extsym *extsymtab;
 189 Extsym *nextext;
 190 Extsym *lastext;
 191
 192 extern int maxequiv;
 193 struct Equivblock *eqvclass;
 194
 195 extern int maxhash;
 196 struct Hashentry *hashtab;
 197 struct Hashentry *lasthash;
 198
 199 extern int maxstno;             /* Maximum number of statement labels */
 200 struct Labelblock *labeltab;
 201 struct Labelblock *labtabend;
 202 struct Labelblock *highlabtab;
 203
 204 int maxdim      = MAXDIM;
 205 struct Rplblock *rpllist        = NULL;
 206 struct Chain *curdtp    = NULL;
 207 flag toomanyinit;
 208 ftnint curdtelt;
 209 chainp templist[TYVOID];
 210 chainp holdtemps;
 211 int dorange     = 0;
 212 struct Entrypoint *entries      = NULL;
 213
 214 chainp chains   = NULL;
 215
 216 flag inioctl;
 217 int iostmt;
 218 int nioctl;
 219 int nequiv      = 0;
 220 int eqvstart    = 0;
 221 int nintnames   = 0;
 222
 223 struct Literal litpool[MAXLITERALS];
 224 int nliterals;
 225
 226 char dflttype[26];
 227 char hextoi_tab[256], Letters[256];
 228 char *wh_first, *wh_next, *wh_last;
 229
 230 #define ALLOCN(n,x)     (struct x *) ckalloc((n)*sizeof(struct x))
 231
 232 fileinit()
 233 {
 234         register char *s;
 235         register int i, j;
 236
 237         lastiolabno = 100000;
 238         lastlabno = 0;
 239         lastvarno = 0;
 240         nliterals = 0;
 241         nerr = 0;
 242
 243         infile = stdin;
 244
 245         memset(dflttype, tyreal, 26);
 246         memset(dflttype + 'i' - 'a', tyint, 6);
 247         memset(hextoi_tab, 16, sizeof(hextoi_tab));
 248         for(i = 0, s = "0123456789abcdef"; *s; i++, s++)
 249                 hextoi(*s) = i;
 250         for(i = 10, s = "ABCDEF"; *s; i++, s++)
 251                 hextoi(*s) = i;
 252         for(j = 0, s = "abcdefghijklmnopqrstuvwxyz"; i = *s++; j++)
 253                 Letters[i] = Letters[i+'A'-'a'] = j;
 254
 255         ctls = ALLOCN(maxctl+1, Ctlframe);
 256         extsymtab = ALLOCN(maxext, Extsym);
 257         eqvclass = ALLOCN(maxequiv, Equivblock);
 258         hashtab = ALLOCN(maxhash, Hashentry);
 259         labeltab = ALLOCN(maxstno, Labelblock);
 260
 261         ctlstack = ctls++;
 262         lastctl = ctls + maxctl;
 263         nextext = extsymtab;
 264         lastext = extsymtab + maxext;
 265         lasthash = hashtab + maxhash;
 266         labtabend = labeltab + maxstno;
 267         highlabtab = labeltab;
 268         main_alias[0] = '\0';
 269         if (forcedouble)
 270                 dfltproc[TYREAL] = dfltproc[TYDREAL];
 271
 272 /* Initialize the routines for providing C output */
 273
 274         out_init ();
 275 }
 276
 277 hashclear()     /* clear hash table */
 278 {
 279         register struct Hashentry *hp;
 280         register Namep p;
 281         register struct Dimblock *q;
 282         register int i;
 283
 284         for(hp = hashtab ; hp < lasthash ; ++hp)
 285                 if(p = hp->varp)
 286                 {
 287                         frexpr(p->vleng);
 288                         if(q = p->vdim)
 289                         {
 290                                 for(i = 0 ; i < q->ndim ; ++i)
 291                                 {
 292                                         frexpr(q->dims[i].dimsize);
 293                                         frexpr(q->dims[i].dimexpr);
 294                                 }
 295                                 frexpr(q->nelt);
 296                                 frexpr(q->baseoffset);
 297                                 frexpr(q->basexpr);
 298                                 free( (charptr) q);
 299                         }
 300                         if(p->vclass == CLNAMELIST)
 301                                 frchain( &(p->varxptr.namelist) );
 302                         free( (charptr) p);
 303                         hp->varp = NULL;
 304                 }
 305         }
 306
 307 procinit()
 308 {
 309         register struct Labelblock *lp;
 310         struct Chain *cp;
 311         int i;
 312         extern struct memblock *curmemblock, *firstmemblock;
 313         extern char *mem_first, *mem_next, *mem_last, *mem0_last;
 314         extern void frexchain();
 315
 316         curmemblock = firstmemblock;
 317         mem_next = mem_first;
 318         mem_last = mem0_last;
 319         wh_next = wh_first = wh_last = 0;
 320         iob_list = 0;
 321         for(i = 0; i < 9; i++)
 322                 io_structs[i] = 0;
 323
 324         parstate = OUTSIDE;
 325         headerdone = NO;
 326         blklevel = 1;
 327         saveall = NO;
 328         substars = NO;
 329         nwarn = 0;
 330         thislabel = NULL;
 331         needkwd = 0;
 332
 333         proctype = TYUNKNOWN;
 334         procname = "MAIN_";
 335         procclass = CLUNKNOWN;
 336         nentry = 0;
 337         nallargs = nallchargs = 0;
 338         multitype = NO;
 339         retslot = NULL;
 340         for(i = 0; i < NTYPES0; i++) {
 341                 frexpr((expptr)xretslot[i]);
 342                 xretslot[i] = 0;
 343                 }
 344         cxslot = -1;
 345         chslot = -1;
 346         chlgslot = -1;
 347         procleng = 0;
 348         blklevel = 1;
 349         lastargslot = 0;
 350
 351         for(lp = labeltab ; lp < labtabend ; ++lp)
 352                 lp->stateno = 0;
 353
 354         hashclear();
 355
 356 /* Clear the list of newly generated identifiers from the previous
 357    function */
 358
 359         frexchain(&new_vars);
 360         frexchain(&used_builtins);
 361         frchain(&assigned_fmts);
 362         frchain(&allargs);
 363         frchain(&earlylabs);
 364
 365         nintnames = 0;
 366         highlabtab = labeltab;
 367
 368         ctlstack = ctls - 1;
 369         for(i = TYADDR; i < TYVOID; i++) {
 370                 for(cp = templist[i]; cp ; cp = cp->nextp)
 371                         free( (charptr) (cp->datap) );
 372                 frchain(templist + i);
 373                 autonum[i] = 0;
 374                 }
 375         holdtemps = NULL;
 376         dorange = 0;
 377         nregvar = 0;
 378         highregvar = 0;
 379         entries = NULL;
 380         rpllist = NULL;
 381         inioctl = NO;
 382         eqvstart += nequiv;
 383         nequiv = 0;
 384         dcomplex_seen = 0;
 385
 386         for(i = 0 ; i<NTYPES0 ; ++i)
 387                 rtvlabel[i] = 0;
 388
 389         if(undeftype)
 390                 setimpl(TYUNKNOWN, (ftnint) 0, 'a', 'z');
 391         else
 392         {
 393                 setimpl(tyreal, (ftnint) 0, 'a', 'z');
 394                 setimpl(tyint,  (ftnint) 0, 'i', 'n');
 395         }
 396         setimpl(-STGBSS, (ftnint) 0, 'a', 'z'); /* set class */
 397         setlog();
 398 }
 399
 400
 401
 402
 403 setimpl(type, length, c1, c2)
 404 int type;
 405 ftnint length;
 406 int c1, c2;
 407 {
 408         int i;
 409         char buff[100];
 410
 411         if(c1==0 || c2==0)
 412                 return;
 413
 414         if(c1 > c2) {
 415                 sprintf(buff, "characters out of order in implicit:%c-%c", c1, c2);
 416                 err(buff);
 417                 }
 418         else {
 419                 c1 = letter(c1);
 420                 c2 = letter(c2);
 421                 if(type < 0)
 422                         for(i = c1 ; i<=c2 ; ++i)
 423                                 implstg[i] = - type;
 424                 else {
 425                         type = lengtype(type, length);
 426                         if(type != TYCHAR)
 427                                 length = 0;
 428                         for(i = c1 ; i<=c2 ; ++i) {
 429                                 impltype[i] = type;
 430                                 implleng[i] = length;
 431                                 }
 432                         }
 433                 }
 434         }