home *** CD-ROM | disk | FTP | other *** search
/ Programmer 7500 / MAX_PROGRAMMERS.iso / INFO / FORTRAN / F2C_SRC.ZIP / F2C / INIT.C < prev    next >
Encoding:
C/C++ Source or Header  |  1991-06-10  |  10.5 KB  |  447 lines
  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.     }
  447.