lang/fortran/comp/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 static char Bug[] = "bug";
 148
 149 char *ftn_types[] = { "external", "??",
 150         "integer*2", "integer", "real",
 151         "double precision", "complex", "double complex",
 152         "logical", "character", "subroutine",
 153         Bug,Bug,Bug,Bug,Bug,Bug,Bug,Bug,Bug, "ftnlen"
 154         };
 155
 156 int init_ac[TYSUBR+1] = { 0,0,0,0,0,0, 1, 1, 0, 2};
 157
 158 int proctype    = TYUNKNOWN;
 159 char *procname;
 160 int rtvlabel[NTYPES0];
 161 Addrp retslot;                  /* Holds automatic variable which was
 162                                    allocated the function return value
 163                                    */
 164 Addrp xretslot[NTYPES0];        /* for multiple entry points */
 165 int cxslot      = -1;
 166 int chslot      = -1;
 167 int chlgslot    = -1;
 168 int procclass   = CLUNKNOWN;
 169 int nentry;
 170 int nallargs;
 171 int nallchargs;
 172 flag multitype;
 173 ftnint procleng;
 174 long lastiolabno;
 175 int lastlabno;
 176 int lastvarno;
 177 int lastargslot;
 178 int autonum[TYVOID];
 179 char *av_pfix[TYVOID] = {"??TYUNKNOWN??", "a","s","i","r","d","q","z","L","ch",
 180                          "??TYSUBR??", "??TYERROR??","ci", "ici",
 181                          "o", "cl", "al", "ioin" };
 182
 183 extern int maxctl;
 184 struct Ctlframe *ctls;
 185 struct Ctlframe *ctlstack;
 186 struct Ctlframe *lastctl;
 187
 188 Namep regnamep[MAXREGVAR];
 189 int highregvar;
 190 int nregvar;
 191
 192 extern int maxext;
 193 Extsym *extsymtab;
 194 Extsym *nextext;
 195 Extsym *lastext;
 196
 197 extern int maxequiv;
 198 struct Equivblock *eqvclass;
 199
 200 extern int maxhash;
 201 struct Hashentry *hashtab;
 202 struct Hashentry *lasthash;
 203
 204 extern int maxstno;             /* Maximum number of statement labels */
 205 struct Labelblock *labeltab;
 206 struct Labelblock *labtabend;
 207 struct Labelblock *highlabtab;
 208
 209 int maxdim      = MAXDIM;
 210 struct Rplblock *rpllist        = NULL;
 211 struct Chain *curdtp    = NULL;
 212 flag toomanyinit;
 213 ftnint curdtelt;
 214 chainp templist[TYVOID];
 215 chainp holdtemps;
 216 int dorange     = 0;
 217 struct Entrypoint *entries      = NULL;
 218
 219 chainp chains   = NULL;
 220
 221 flag inioctl;
 222 int iostmt;
 223 int nioctl;
 224 int nequiv      = 0;
 225 int eqvstart    = 0;
 226 int nintnames   = 0;
 227
 228 struct Literal *litpool;
 229 int nliterals;
 230
 231 char dflttype[26];
 232 char hextoi_tab[Table_size], Letters[Table_size];
 233 char *ei_first, *ei_next, *ei_last;
 234 char *wh_first, *wh_next, *wh_last;
 235
 236 #define ALLOCN(n,x)     (struct x *) ckalloc((n)*sizeof(struct x))
 237
 238 fileinit()
 239 {
 240         register char *s;
 241         register int i, j;
 242         extern void fmt_init(), mem_init(), np_init();
 243
 244         lastiolabno = 100000;
 245         lastlabno = 0;
 246         lastvarno = 0;
 247         nliterals = 0;
 248         nerr = 0;
 249
 250         infile = stdin;
 251
 252         memset(dflttype, tyreal, 26);
 253         memset(dflttype + 'i' - 'a', tyint, 6);
 254         memset(hextoi_tab, 16, sizeof(hextoi_tab));
 255         for(i = 0, s = "0123456789abcdef"; *s; i++, s++)
 256                 hextoi(*s) = i;
 257         for(i = 10, s = "ABCDEF"; *s; i++, s++)
 258                 hextoi(*s) = i;
 259         for(j = 0, s = "abcdefghijklmnopqrstuvwxyz"; i = *s++; j++)
 260                 Letters[i] = Letters[i+'A'-'a'] = j;
 261
 262         ctls = ALLOCN(maxctl+1, Ctlframe);
 263         extsymtab = ALLOCN(maxext, Extsym);
 264         eqvclass = ALLOCN(maxequiv, Equivblock);
 265         hashtab = ALLOCN(maxhash, Hashentry);
 266         labeltab = ALLOCN(maxstno, Labelblock);
 267         litpool = ALLOCN(maxliterals, Literal);
 268         fmt_init();
 269         mem_init();
 270         np_init();
 271
 272         ctlstack = ctls++;
 273         lastctl = ctls + maxctl;
 274         nextext = extsymtab;
 275         lastext = extsymtab + maxext;
 276         lasthash = hashtab + maxhash;
 277         labtabend = labeltab + maxstno;
 278         highlabtab = labeltab;
 279         main_alias[0] = '\0';
 280         if (forcedouble)
 281                 dfltproc[TYREAL] = dfltproc[TYDREAL];
 282
 283 /* Initialize the routines for providing C output */
 284
 285         out_init ();
 286 }
 287
 288 hashclear()     /* clear hash table */
 289 {
 290         register struct Hashentry *hp;
 291         register Namep p;
 292         register struct Dimblock *q;
 293         register int i;
 294
 295         for(hp = hashtab ; hp < lasthash ; ++hp)
 296                 if(p = hp->varp)
 297                 {
 298                         frexpr(p->vleng);
 299                         if(q = p->vdim)
 300                         {
 301                                 for(i = 0 ; i < q->ndim ; ++i)
 302                                 {
 303                                         frexpr(q->dims[i].dimsize);
 304                                         frexpr(q->dims[i].dimexpr);
 305                                 }
 306                                 frexpr(q->nelt);
 307                                 frexpr(q->baseoffset);
 308                                 frexpr(q->basexpr);
 309                                 free( (charptr) q);
 310                         }
 311                         if(p->vclass == CLNAMELIST)
 312                                 frchain( &(p->varxptr.namelist) );
 313                         free( (charptr) p);
 314                         hp->varp = NULL;
 315                 }
 316         }
 317
 318 procinit()
 319 {
 320         register struct Labelblock *lp;
 321         struct Chain *cp;
 322         int i;
 323         extern struct memblock *curmemblock, *firstmemblock;
 324         extern char *mem_first, *mem_next, *mem_last, *mem0_last;
 325         extern void frexchain();
 326
 327         curmemblock = firstmemblock;
 328         mem_next = mem_first;
 329         mem_last = mem0_last;
 330         ei_next = ei_first = ei_last = 0;
 331         wh_next = wh_first = wh_last = 0;
 332         iob_list = 0;
 333         for(i = 0; i < 9; i++)
 334                 io_structs[i] = 0;
 335
 336         parstate = OUTSIDE;
 337         headerdone = NO;
 338         blklevel = 1;
 339         saveall = NO;
 340         substars = NO;
 341         nwarn = 0;
 342         thislabel = NULL;
 343         needkwd = 0;
 344
 345         proctype = TYUNKNOWN;
 346         procname = "MAIN_";
 347         procclass = CLUNKNOWN;
 348         nentry = 0;
 349         nallargs = nallchargs = 0;
 350         multitype = NO;
 351         retslot = NULL;
 352         for(i = 0; i < NTYPES0; i++) {
 353                 frexpr((expptr)xretslot[i]);
 354                 xretslot[i] = 0;
 355                 }
 356         cxslot = -1;
 357         chslot = -1;
 358         chlgslot = -1;
 359         procleng = 0;
 360         blklevel = 1;
 361         lastargslot = 0;
 362
 363         for(lp = labeltab ; lp < labtabend ; ++lp)
 364                 lp->stateno = 0;
 365
 366         hashclear();
 367
 368 /* Clear the list of newly generated identifiers from the previous
 369    function */
 370
 371         frexchain(&new_vars);
 372         frexchain(&used_builtins);
 373         frchain(&assigned_fmts);
 374         frchain(&allargs);
 375         frchain(&earlylabs);
 376
 377         nintnames = 0;
 378         highlabtab = labeltab;
 379
 380         ctlstack = ctls - 1;
 381         for(i = TYADDR; i < TYVOID; i++) {
 382                 for(cp = templist[i]; cp ; cp = cp->nextp)
 383                         free( (charptr) (cp->datap) );
 384                 frchain(templist + i);
 385                 autonum[i] = 0;
 386                 }
 387         holdtemps = NULL;
 388         dorange = 0;
 389         nregvar = 0;
 390         highregvar = 0;
 391         entries = NULL;
 392         rpllist = NULL;
 393         inioctl = NO;
 394         eqvstart += nequiv;
 395         nequiv = 0;
 396         dcomplex_seen = 0;
 397
 398         for(i = 0 ; i<NTYPES0 ; ++i)
 399                 rtvlabel[i] = 0;
 400
 401         if(undeftype)
 402                 setimpl(TYUNKNOWN, (ftnint) 0, 'a', 'z');
 403         else
 404         {
 405                 setimpl(tyreal, (ftnint) 0, 'a', 'z');
 406                 setimpl(tyint,  (ftnint) 0, 'i', 'n');
 407         }
 408         setimpl(-STGBSS, (ftnint) 0, 'a', 'z'); /* set class */
 409         setlog();
 410 }
 411
 412
 413
 414
 415 setimpl(type, length, c1, c2)
 416 int type;
 417 ftnint length;
 418 int c1, c2;
 419 {
 420         int i;
 421         char buff[100];
 422
 423         if(c1==0 || c2==0)
 424                 return;
 425
 426         if(c1 > c2) {
 427                 sprintf(buff, "characters out of order in implicit:%c-%c", c1, c2);
 428                 err(buff);
 429                 }
 430         else {
 431                 c1 = letter(c1);
 432                 c2 = letter(c2);
 433                 if(type < 0)
 434                         for(i = c1 ; i<=c2 ; ++i)
 435                                 implstg[i] = - type;
 436                 else {
 437                         type = lengtype(type, length);
 438                         if(type != TYCHAR)
 439                                 length = 0;
 440                         for(i = c1 ; i<=c2 ; ++i) {
 441                                 impltype[i] = type;
 442                                 implleng[i] = length;
 443                                 }
 444                         }
 445                 }
 446         }