00001 /****************************************************************
00002 Copyright 1990, 1992 - 1996 by AT&T, Lucent Technologies and Bellcore.
00003 
00004 Permission to use, copy, modify, and distribute this software
00005 and its documentation for any purpose and without fee is hereby
00006 granted, provided that the above copyright notice appear in all
00007 copies and that both that the copyright notice and this
00008 permission notice and warranty disclaimer appear in supporting
00009 documentation, and that the names of AT&T, Bell Laboratories,
00010 Lucent or Bellcore or any of their entities not be used in
00011 advertising or publicity pertaining to distribution of the
00012 software without specific, written prior permission.
00013 
00014 AT&T, Lucent and Bellcore disclaim all warranties with regard to
00015 this software, including all implied warranties of
00016 merchantability and fitness.  In no event shall AT&T, Lucent or
00017 Bellcore be liable for any special, indirect or consequential
00018 damages or any damages whatsoever resulting from loss of use,
00019 data or profits, whether in an action of contract, negligence or
00020 other tortious action, arising out of or in connection with the
00021 use or performance of this software.
00022 ****************************************************************/
00023 
00024 #include "defs.h"
00025 #include "output.h"
00026 #include "iob.h"
00027 
00028 /* State required for the C output */
00029 char *fl_fmt_string;            /* Float format string */
00030 char *db_fmt_string;            /* Double format string */
00031 char *cm_fmt_string;            /* Complex format string */
00032 char *dcm_fmt_string;           /* Double complex format string */
00033 
00034 chainp new_vars = CHNULL;       /* List of newly created locals in this
00035                                    function.  These may have identifiers
00036                                    which have underscores and more than VL
00037                                    characters */
00038 chainp used_builtins = CHNULL;  /* List of builtins used by this function.
00039                                    These are all Addrps with UNAM_EXTERN
00040                                    */
00041 chainp assigned_fmts = CHNULL;  /* assigned formats */
00042 chainp allargs;                 /* union of args in all entry points */
00043 chainp earlylabs;               /* labels seen before enddcl() */
00044 char main_alias[52];            /* PROGRAM name, if any is given */
00045 int tab_size = 4;
00046 
00047 
00048 FILEP infile;
00049 FILEP diagfile;
00050 
00051 FILEP c_file;
00052 FILEP pass1_file;
00053 FILEP initfile;
00054 FILEP blkdfile;
00055 
00056 
00057 char *token;
00058 int maxtoklen, toklen;
00059 long err_lineno;
00060 long lineno;                    /* Current line in the input file, NOT the
00061                                    Fortran statement label number */
00062 char *infname;
00063 int needkwd;
00064 struct Labelblock *thislabel    = NULL;
00065 int nerr;
00066 int nwarn;
00067 
00068 flag saveall;
00069 flag substars;
00070 int parstate    = OUTSIDE;
00071 flag headerdone = NO;
00072 int blklevel;
00073 int doin_setbound;
00074 int impltype[26];
00075 ftnint implleng[26];
00076 int implstg[26];
00077 
00078 int tyint       = TYLONG ;
00079 int tylogical   = TYLONG;
00080 int tylog       = TYLOGICAL;
00081 int typesize[NTYPES] = {
00082         1, SZADDR, 1, SZSHORT, SZLONG,
00083 #ifdef TYQUAD
00084                 2*SZLONG,
00085 #endif
00086                 SZLONG, 2*SZLONG,
00087                 2*SZLONG, 4*SZLONG, 1, SZSHORT, SZLONG, 1, 1, 0,
00088                 4*SZLONG + SZADDR,      /* sizeof(cilist) */
00089                 4*SZLONG + 2*SZADDR,    /* sizeof(icilist) */
00090                 4*SZLONG + 5*SZADDR,    /* sizeof(olist) */
00091                 2*SZLONG + SZADDR,      /* sizeof(cllist) */
00092                 2*SZLONG,               /* sizeof(alist) */
00093                 11*SZLONG + 15*SZADDR   /* sizeof(inlist) */
00094                 };
00095 
00096 int typealign[NTYPES] = {
00097         1, ALIADDR, 1, ALISHORT, ALILONG,
00098 #ifdef TYQUAD
00099         ALIDOUBLE,
00100 #endif
00101         ALILONG, ALIDOUBLE,
00102         ALILONG, ALIDOUBLE, 1, ALISHORT, ALILONG, 1, 1, 1,
00103         ALILONG, ALILONG, ALILONG, ALILONG, ALILONG, ALILONG};
00104 
00105 int type_choice[4] = { TYDREAL, TYSHORT, TYLONG,  TYSHORT };
00106 
00107 char *typename[] = {
00108         "<<unknown>>",
00109         "address",
00110         "integer1",
00111         "shortint",
00112         "integer",
00113 #ifdef TYQUAD
00114         "longint",
00115 #endif
00116         "real",
00117         "doublereal",
00118         "complex",
00119         "doublecomplex",
00120         "logical1",
00121         "shortlogical",
00122         "logical",
00123         "char"  /* character */
00124         };
00125 
00126 int type_pref[NTYPES] = { 0, 0, 3, 5, 7,
00127 #ifdef TYQUAD
00128                          10,
00129 #endif
00130                                 8, 11, 9, 12, 1, 4, 6, 2 };
00131 
00132 char *protorettypes[] = {
00133         "?", "??", "integer1", "shortint", "integer",
00134 #ifdef TYQUAD
00135         "longint",
00136 #endif
00137         "real", "doublereal",
00138         "C_f", "Z_f", "logical1", "shortlogical", "logical", "H_f", "int"
00139         };
00140 
00141 char *casttypes[TYSUBR+1] = {
00142         "U_fp", "??bug??", "I1_fp",
00143         "J_fp", "I_fp",
00144 #ifdef TYQUAD
00145         "Q_fp",
00146 #endif
00147         "R_fp", "D_fp", "C_fp", "Z_fp",
00148         "L1_fp", "L2_fp", "L_fp", "H_fp", "S_fp"
00149         };
00150 char *usedcasts[TYSUBR+1];
00151 
00152 char *dfltarg[] = {
00153         0, 0, "(integer1 *)0",
00154         "(shortint *)0", "(integer *)0",
00155 #ifdef TYQUAD
00156         "(longint *)0",
00157 #endif
00158         "(real *)0",
00159         "(doublereal *)0", "(complex *)0", "(doublecomplex *)0",
00160         "(logical1 *)0","(shortlogical *)0", "(logical *)0", "(char *)0"
00161         };
00162 
00163 static char *dflt0proc[] = {
00164         0, 0, "(integer1 (*)())0",
00165         "(shortint (*)())0", "(integer (*)())0",
00166 #ifdef TYQUAD
00167         "(longint (*)())0",
00168 #endif
00169         "(real (*)())0",
00170         "(doublereal (*)())0", "(complex (*)())0", "(doublecomplex (*)())0",
00171         "(logical1 (*)())0", "(shortlogical (*)())0",
00172         "(logical (*)())0", "(char (*)())0", "(int (*)())0"
00173         };
00174 
00175 char *dflt1proc[] = { "(U_fp)0", "(??bug??)0", "(I1_fp)0",
00176         "(J_fp)0", "(I_fp)0",
00177 #ifdef TYQUAD
00178         "(Q_fp)0",
00179 #endif
00180         "(R_fp)0", "(D_fp)0", "(C_fp)0", "(Z_fp)0",
00181         "(L1_fp)0","(L2_fp)0",
00182         "(L_fp)0", "(H_fp)0", "(S_fp)0"
00183         };
00184 
00185 char **dfltproc = dflt0proc;
00186 
00187 static char Bug[] = "bug";
00188 
00189 char *ftn_types[] = { "external", "??", "integer*1",
00190         "integer*2", "integer",
00191 #ifdef TYQUAD
00192         "integer*8",
00193 #endif
00194         "real",
00195         "double precision", "complex", "double complex",
00196         "logical*1", "logical*2",
00197         "logical", "character", "subroutine",
00198         Bug,Bug,Bug,Bug,Bug,Bug,Bug,Bug,Bug, "ftnlen"
00199         };
00200 
00201 int init_ac[TYSUBR+1] = { 0,0,0,0,0,0,0,
00202 #ifdef TYQUAD
00203                           0,
00204 #endif
00205                           1, 1, 0, 0, 0, 2};
00206 
00207 int proctype    = TYUNKNOWN;
00208 char *procname;
00209 int rtvlabel[NTYPES0];
00210 Addrp retslot;                  /* Holds automatic variable which was
00211                                    allocated the function return value
00212                                    */
00213 Addrp xretslot[NTYPES0];        /* for multiple entry points */
00214 int cxslot      = -1;
00215 int chslot      = -1;
00216 int chlgslot    = -1;
00217 int procclass   = CLUNKNOWN;
00218 int nentry;
00219 int nallargs;
00220 int nallchargs;
00221 flag multitype;
00222 ftnint procleng;
00223 long lastiolabno;
00224 long lastlabno;
00225 int lastvarno;
00226 int lastargslot;
00227 int autonum[TYVOID];
00228 char *av_pfix[TYVOID] = {"??TYUNKNOWN??", "a","i1","s","i",
00229 #ifdef TYQUAD
00230                          "i8",
00231 #endif
00232                         "r","d","q","z","L1","L2","L","ch",
00233                          "??TYSUBR??", "??TYERROR??","ci", "ici",
00234                          "o", "cl", "al", "ioin" };
00235 
00236 extern int maxctl;
00237 struct Ctlframe *ctls;
00238 struct Ctlframe *ctlstack;
00239 struct Ctlframe *lastctl;
00240 
00241 Namep regnamep[MAXREGVAR];
00242 int highregvar;
00243 int nregvar;
00244 
00245 extern int maxext;
00246 Extsym *extsymtab;
00247 Extsym *nextext;
00248 Extsym *lastext;
00249 
00250 extern int maxequiv;
00251 struct Equivblock *eqvclass;
00252 
00253 extern int maxhash;
00254 struct Hashentry *hashtab;
00255 struct Hashentry *lasthash;
00256 
00257 extern int maxstno;             /* Maximum number of statement labels */
00258 struct Labelblock *labeltab;
00259 struct Labelblock *labtabend;
00260 struct Labelblock *highlabtab;
00261 
00262 int maxdim      = MAXDIM;
00263 struct Rplblock *rpllist        = NULL;
00264 struct Chain *curdtp    = NULL;
00265 flag toomanyinit;
00266 ftnint curdtelt;
00267 chainp templist[TYVOID];
00268 chainp holdtemps;
00269 int dorange     = 0;
00270 struct Entrypoint *entries      = NULL;
00271 
00272 chainp chains   = NULL;
00273 
00274 flag inioctl;
00275 int iostmt;
00276 int nioctl;
00277 int nequiv      = 0;
00278 int eqvstart    = 0;
00279 int nintnames   = 0;
00280 extern int maxlablist;
00281 struct Labelblock **labarray;
00282 
00283 struct Literal *litpool;
00284 int nliterals;
00285 
00286 char dflttype[26];
00287 char hextoi_tab[Table_size], Letters[Table_size];
00288 char *ei_first, *ei_next, *ei_last;
00289 char *wh_first, *wh_next, *wh_last;
00290 
00291 #define ALLOCN(n,x)     (struct x *) ckalloc((n)*sizeof(struct x))
00292 
00293  void
00294 fileinit(Void)
00295 {
00296         register char *s;
00297         register int i, j;
00298 
00299         lastiolabno = 100000;
00300         lastlabno = 0;
00301         lastvarno = 0;
00302         nliterals = 0;
00303         nerr = 0;
00304 
00305         infile = stdin;
00306 
00307         maxtoklen = 502;
00308         token = (char *)ckalloc(maxtoklen+2);
00309         memset(dflttype, tyreal, 26);
00310         memset(dflttype + 'i' - 'a', tyint, 6);
00311         memset(hextoi_tab, 16, sizeof(hextoi_tab));
00312         for(i = 0, s = "0123456789abcdef"; *s; i++, s++)
00313                 hextoi(*s) = i;
00314         for(i = 10, s = "ABCDEF"; *s; i++, s++)
00315                 hextoi(*s) = i;
00316         for(j = 0, s = "abcdefghijklmnopqrstuvwxyz"; i = *s++; j++)
00317                 Letters[i] = Letters[i+'A'-'a'] = j;
00318 
00319         ctls = ALLOCN(maxctl+1, Ctlframe);
00320         extsymtab = ALLOCN(maxext, Extsym);
00321         eqvclass = ALLOCN(maxequiv, Equivblock);
00322         hashtab = ALLOCN(maxhash, Hashentry);
00323         labeltab = ALLOCN(maxstno, Labelblock);
00324         litpool = ALLOCN(maxliterals, Literal);
00325         labarray = (struct Labelblock **)ckalloc(maxlablist*
00326                                         sizeof(struct Labelblock *));
00327         fmt_init();
00328         mem_init();
00329         np_init();
00330 
00331         ctlstack = ctls++;
00332         lastctl = ctls + maxctl;
00333         nextext = extsymtab;
00334         lastext = extsymtab + maxext;
00335         lasthash = hashtab + maxhash;
00336         labtabend = labeltab + maxstno;
00337         highlabtab = labeltab;
00338         main_alias[0] = '\0';
00339         if (forcedouble)
00340                 dfltproc[TYREAL] = dfltproc[TYDREAL];
00341 
00342 /* Initialize the routines for providing C output */
00343 
00344         out_init ();
00345 }
00346 
00347  void
00348 hashclear(Void) /* clear hash table */
00349 {
00350         register struct Hashentry *hp;
00351         register Namep p;
00352         register struct Dimblock *q;
00353         register int i;
00354 
00355         for(hp = hashtab ; hp < lasthash ; ++hp)
00356                 if(p = hp->varp)
00357                 {
00358                         frexpr(p->vleng);
00359                         if(q = p->vdim)
00360                         {
00361                                 for(i = 0 ; i < q->ndim ; ++i)
00362                                 {
00363                                         frexpr(q->dims[i].dimsize);
00364                                         frexpr(q->dims[i].dimexpr);
00365                                 }
00366                                 frexpr(q->nelt);
00367                                 frexpr(q->baseoffset);
00368                                 frexpr(q->basexpr);
00369                                 free( (charptr) q);
00370                         }
00371                         if(p->vclass == CLNAMELIST)
00372                                 frchain( &(p->varxptr.namelist) );
00373                         free( (charptr) p);
00374                         hp->varp = NULL;
00375                 }
00376         }
00377 
00378  void
00379 procinit(Void)
00380 {
00381         register struct Labelblock *lp;
00382         struct Chain *cp;
00383         int i;
00384         struct memblock;
00385         extern struct memblock *curmemblock, *firstmemblock;
00386         extern char *mem_first, *mem_next, *mem_last, *mem0_last;
00387 
00388         curmemblock = firstmemblock;
00389         mem_next = mem_first;
00390         mem_last = mem0_last;
00391         ei_next = ei_first = ei_last = 0;
00392         wh_next = wh_first = wh_last = 0;
00393         iob_list = 0;
00394         for(i = 0; i < 9; i++)
00395                 io_structs[i] = 0;
00396 
00397         parstate = OUTSIDE;
00398         headerdone = NO;
00399         blklevel = 1;
00400         saveall = NO;
00401         substars = NO;
00402         nwarn = 0;
00403         thislabel = NULL;
00404         needkwd = 0;
00405 
00406         proctype = TYUNKNOWN;
00407         procname = "MAIN_";
00408         procclass = CLUNKNOWN;
00409         nentry = 0;
00410         nallargs = nallchargs = 0;
00411         multitype = NO;
00412         retslot = NULL;
00413         for(i = 0; i < NTYPES0; i++) {
00414                 frexpr((expptr)xretslot[i]);
00415                 xretslot[i] = 0;
00416                 }
00417         cxslot = -1;
00418         chslot = -1;
00419         chlgslot = -1;
00420         procleng = 0;
00421         blklevel = 1;
00422         lastargslot = 0;
00423 
00424         for(lp = labeltab ; lp < labtabend ; ++lp)
00425                 lp->stateno = 0;
00426 
00427         hashclear();
00428 
00429 /* Clear the list of newly generated identifiers from the previous
00430    function */
00431 
00432         frexchain(&new_vars);
00433         frexchain(&used_builtins);
00434         frchain(&assigned_fmts);
00435         frchain(&allargs);
00436         frchain(&earlylabs);
00437 
00438         nintnames = 0;
00439         highlabtab = labeltab;
00440 
00441         ctlstack = ctls - 1;
00442         for(i = TYADDR; i < TYVOID; i++) {
00443                 for(cp = templist[i]; cp ; cp = cp->nextp)
00444                         free( (charptr) (cp->datap) );
00445                 frchain(templist + i);
00446                 autonum[i] = 0;
00447                 }
00448         holdtemps = NULL;
00449         dorange = 0;
00450         nregvar = 0;
00451         highregvar = 0;
00452         entries = NULL;
00453         rpllist = NULL;
00454         inioctl = NO;
00455         eqvstart += nequiv;
00456         nequiv = 0;
00457         dcomplex_seen = 0;
00458 
00459         for(i = 0 ; i<NTYPES0 ; ++i)
00460                 rtvlabel[i] = 0;
00461 
00462         if(undeftype)
00463                 setimpl(TYUNKNOWN, (ftnint) 0, 'a', 'z');
00464         else
00465         {
00466                 setimpl(tyreal, (ftnint) 0, 'a', 'z');
00467                 setimpl(tyint,  (ftnint) 0, 'i', 'n');
00468         }
00469         setimpl(-STGBSS, (ftnint) 0, 'a', 'z'); /* set class */
00470 }
00471 
00472 
00473 
00474  void
00475 #ifdef KR_headers
00476 setimpl(type, length, c1, c2)
00477         int type;
00478         ftnint length;
00479         int c1;
00480         int c2;
00481 #else
00482 setimpl(int type, ftnint length, int c1, int c2)
00483 #endif
00484 {
00485         int i;
00486         char buff[100];
00487 
00488         if(c1==0 || c2==0)
00489                 return;
00490 
00491         if(c1 > c2) {
00492                 sprintf(buff, "characters out of order in implicit:%c-%c", c1, c2);
00493                 err(buff);
00494                 }
00495         else {
00496                 c1 = letter(c1);
00497                 c2 = letter(c2);
00498                 if(type < 0)
00499                         for(i = c1 ; i<=c2 ; ++i)
00500                                 implstg[i] = - type;
00501                 else {
00502                         type = lengtype(type, length);
00503                         if(type == TYCHAR) {
00504                                 if (length < 0) {
00505                                         err("length (*) in implicit");
00506                                         length = 1;
00507                                         }
00508                                 }
00509                         else if (type != TYLONG)
00510                                 length = 0;
00511                         for(i = c1 ; i<=c2 ; ++i) {
00512                                 impltype[i] = type;
00513                                 implleng[i] = length;
00514                                 }
00515                         }
00516                 }
00517         }