home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 10 Tools / 10-Tools.zip / f2csrc.zip / f2csrc / src / init.c < prev    next >
C/C++ Source or Header  |  1994-02-25  |  12KB  |  516 lines
  1. /****************************************************************
  2. Copyright 1990, 1992, 1993, 1994 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+2];
  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 tylog    = TYLOGICAL;
  80. int typesize[NTYPES] = {
  81.     1, SZADDR, 1, SZSHORT, SZLONG,
  82. #ifdef TYQUAD
  83.         2*SZLONG,
  84. #endif
  85.         SZLONG, 2*SZLONG,
  86.         2*SZLONG, 4*SZLONG, 1, SZSHORT, SZLONG, 1, 1, 0,
  87.         4*SZLONG + SZADDR,    /* sizeof(cilist) */
  88.         4*SZLONG + 2*SZADDR,    /* sizeof(icilist) */
  89.         4*SZLONG + 5*SZADDR,    /* sizeof(olist) */
  90.         2*SZLONG + SZADDR,    /* sizeof(cllist) */
  91.         2*SZLONG,        /* sizeof(alist) */
  92.         11*SZLONG + 15*SZADDR    /* sizeof(inlist) */
  93.         };
  94.  
  95. int typealign[NTYPES] = {
  96.     1, ALIADDR, 1, ALISHORT, ALILONG,
  97. #ifdef TYQUAD
  98.     ALIDOUBLE,
  99. #endif
  100.     ALILONG, ALIDOUBLE,
  101.     ALILONG, ALIDOUBLE, 1, ALISHORT, ALILONG, 1, 1, 1,
  102.     ALILONG, ALILONG, ALILONG, ALILONG, ALILONG, ALILONG};
  103.  
  104. int type_choice[4] = { TYDREAL, TYSHORT, TYLONG,  TYSHORT };
  105.  
  106. char *typename[] = {
  107.     "<<unknown>>",
  108.     "address",
  109.     "integer1",
  110.     "shortint",
  111.     "integer",
  112. #ifdef TYQUAD
  113.     "longint",
  114. #endif
  115.     "real",
  116.     "doublereal",
  117.     "complex",
  118.     "doublecomplex",
  119.     "logical1",
  120.     "shortlogical",
  121.     "logical",
  122.     "char"    /* character */
  123.     };
  124.  
  125. int type_pref[NTYPES] = { 0, 0, 3, 5, 7,
  126. #ifdef TYQUAD
  127.              10,
  128. #endif
  129.                 8, 11, 9, 12, 1, 4, 6, 2 };
  130.  
  131. char *protorettypes[] = {
  132.     "?", "??", "integer1", "shortint", "integer",
  133. #ifdef TYQUAD
  134.     "longint",
  135. #endif
  136.     "real", "doublereal",
  137.     "C_f", "Z_f", "logical1", "shortlogical", "logical", "H_f", "int"
  138.     };
  139.  
  140. char *casttypes[TYSUBR+1] = {
  141.     "U_fp", "??bug??", "I1_fp",
  142.     "J_fp", "I_fp",
  143. #ifdef TYQUAD
  144.     "Q_fp",
  145. #endif
  146.     "R_fp", "D_fp", "C_fp", "Z_fp",
  147.     "L1_fp", "L2_fp", "L_fp", "H_fp", "S_fp"
  148.     };
  149. char *usedcasts[TYSUBR+1];
  150.  
  151. char *dfltarg[] = {
  152.     0, 0, "(integer1 *)0",
  153.     "(shortint *)0", "(integer *)0",
  154. #ifdef TYQUAD
  155.     "(longint *)0",
  156. #endif
  157.     "(real *)0",
  158.     "(doublereal *)0", "(complex *)0", "(doublecomplex *)0",
  159.     "(logical1 *)0","(shortlogical *)0)", "(logical *)0", "(char *)0"
  160.     };
  161.  
  162. static char *dflt0proc[] = {
  163.     0, 0, "(integer1 (*)())0",
  164.     "(shortint (*)())0", "(integer (*)())0",
  165. #ifdef TYQUAD
  166.     "(longint (*)())0",
  167. #endif
  168.     "(real (*)())0",
  169.     "(doublereal (*)())0", "(complex (*)())0", "(doublecomplex (*)())0",
  170.     "(logical1 (*)())0", "(shortlogical (*)())0",
  171.     "(logical (*)())0", "(char (*)())0", "(int (*)())0"
  172.     };
  173.  
  174. char *dflt1proc[] = { "(U_fp)0", "(??bug??)0", "(I1_fp)0",
  175.     "(J_fp)0", "(I_fp)0",
  176. #ifdef TYQUAD
  177.     "(Q_fp)0",
  178. #endif
  179.     "(R_fp)0", "(D_fp)0", "(C_fp)0", "(Z_fp)0",
  180.     "(L1_fp)0","(L2_fp)0",
  181.     "(L_fp)0", "(H_fp)0", "(S_fp)0"
  182.     };
  183.  
  184. char **dfltproc = dflt0proc;
  185.  
  186. static char Bug[] = "bug";
  187.  
  188. char *ftn_types[] = { "external", "??", "integer*1",
  189.     "integer*2", "integer",
  190. #ifdef TYQUAD
  191.     "integer*8",
  192. #endif
  193.     "real",
  194.     "double precision", "complex", "double complex",
  195.     "logical*1", "logical*2",
  196.     "logical", "character", "subroutine",
  197.     Bug,Bug,Bug,Bug,Bug,Bug,Bug,Bug,Bug, "ftnlen"
  198.     };
  199.  
  200. int init_ac[TYSUBR+1] = { 0,0,0,0,0,0,0,
  201. #ifdef TYQUAD
  202.               0,
  203. #endif
  204.               1, 1, 0, 0, 0, 2};
  205.  
  206. int proctype    = TYUNKNOWN;
  207. char *procname;
  208. int rtvlabel[NTYPES0];
  209. Addrp retslot;            /* Holds automatic variable which was
  210.                    allocated the function return value
  211.                    */
  212. Addrp xretslot[NTYPES0];    /* for multiple entry points */
  213. int cxslot    = -1;
  214. int chslot    = -1;
  215. int chlgslot    = -1;
  216. int procclass    = CLUNKNOWN;
  217. int nentry;
  218. int nallargs;
  219. int nallchargs;
  220. flag multitype;
  221. ftnint procleng;
  222. long lastiolabno;
  223. int lastlabno;
  224. int lastvarno;
  225. int lastargslot;
  226. int autonum[TYVOID];
  227. char *av_pfix[TYVOID] = {"??TYUNKNOWN??", "a","i1","s","i",
  228. #ifdef TYQUAD
  229.              "i8",
  230. #endif
  231.             "r","d","q","z","L1","L2","L","ch",
  232.              "??TYSUBR??", "??TYERROR??","ci", "ici",
  233.              "o", "cl", "al", "ioin" };
  234.  
  235. extern int maxctl;
  236. struct Ctlframe *ctls;
  237. struct Ctlframe *ctlstack;
  238. struct Ctlframe *lastctl;
  239.  
  240. Namep regnamep[MAXREGVAR];
  241. int highregvar;
  242. int nregvar;
  243.  
  244. extern int maxext;
  245. Extsym *extsymtab;
  246. Extsym *nextext;
  247. Extsym *lastext;
  248.  
  249. extern int maxequiv;
  250. struct Equivblock *eqvclass;
  251.  
  252. extern int maxhash;
  253. struct Hashentry *hashtab;
  254. struct Hashentry *lasthash;
  255.  
  256. extern int maxstno;        /* Maximum number of statement labels */
  257. struct Labelblock *labeltab;
  258. struct Labelblock *labtabend;
  259. struct Labelblock *highlabtab;
  260.  
  261. int maxdim    = MAXDIM;
  262. struct Rplblock *rpllist    = NULL;
  263. struct Chain *curdtp    = NULL;
  264. flag toomanyinit;
  265. ftnint curdtelt;
  266. chainp templist[TYVOID];
  267. chainp holdtemps;
  268. int dorange    = 0;
  269. struct Entrypoint *entries    = NULL;
  270.  
  271. chainp chains    = NULL;
  272.  
  273. flag inioctl;
  274. int iostmt;
  275. int nioctl;
  276. int nequiv    = 0;
  277. int eqvstart    = 0;
  278. int nintnames    = 0;
  279. extern int maxlablist;
  280. struct Labelblock **labarray;
  281.  
  282. struct Literal *litpool;
  283. int nliterals;
  284.  
  285. char dflttype[26];
  286. char hextoi_tab[Table_size], Letters[Table_size];
  287. char *ei_first, *ei_next, *ei_last;
  288. char *wh_first, *wh_next, *wh_last;
  289.  
  290. #define ALLOCN(n,x)    (struct x *) ckalloc((n)*sizeof(struct x))
  291.  
  292.  void
  293. fileinit(Void)
  294. {
  295.     register char *s;
  296.     register int i, j;
  297.  
  298.     lastiolabno = 100000;
  299.     lastlabno = 0;
  300.     lastvarno = 0;
  301.     nliterals = 0;
  302.     nerr = 0;
  303.  
  304.     infile = stdin;
  305.  
  306.     memset(dflttype, tyreal, 26);
  307.     memset(dflttype + 'i' - 'a', tyint, 6);
  308.     memset(hextoi_tab, 16, sizeof(hextoi_tab));
  309.     for(i = 0, s = "0123456789abcdef"; *s; i++, s++)
  310.         hextoi(*s) = i;
  311.     for(i = 10, s = "ABCDEF"; *s; i++, s++)
  312.         hextoi(*s) = i;
  313.     for(j = 0, s = "abcdefghijklmnopqrstuvwxyz"; i = *s++; j++)
  314.         Letters[i] = Letters[i+'A'-'a'] = j;
  315.  
  316.     ctls = ALLOCN(maxctl+1, Ctlframe);
  317.     extsymtab = ALLOCN(maxext, Extsym);
  318.     eqvclass = ALLOCN(maxequiv, Equivblock);
  319.     hashtab = ALLOCN(maxhash, Hashentry);
  320.     labeltab = ALLOCN(maxstno, Labelblock);
  321.     litpool = ALLOCN(maxliterals, Literal);
  322.     labarray = (struct Labelblock **)ckalloc(maxlablist*
  323.                     sizeof(struct Labelblock *));
  324.     fmt_init();
  325.     mem_init();
  326.     np_init();
  327.  
  328.     ctlstack = ctls++;
  329.     lastctl = ctls + maxctl;
  330.     nextext = extsymtab;
  331.     lastext = extsymtab + maxext;
  332.     lasthash = hashtab + maxhash;
  333.     labtabend = labeltab + maxstno;
  334.     highlabtab = labeltab;
  335.     main_alias[0] = '\0';
  336.     if (forcedouble)
  337.         dfltproc[TYREAL] = dfltproc[TYDREAL];
  338.  
  339. /* Initialize the routines for providing C output */
  340.  
  341.     out_init ();
  342. }
  343.  
  344.  void
  345. hashclear(Void)    /* clear hash table */
  346. {
  347.     register struct Hashentry *hp;
  348.     register Namep p;
  349.     register struct Dimblock *q;
  350.     register int i;
  351.  
  352.     for(hp = hashtab ; hp < lasthash ; ++hp)
  353.         if(p = hp->varp)
  354.         {
  355.             frexpr(p->vleng);
  356.             if(q = p->vdim)
  357.             {
  358.                 for(i = 0 ; i < q->ndim ; ++i)
  359.                 {
  360.                     frexpr(q->dims[i].dimsize);
  361.                     frexpr(q->dims[i].dimexpr);
  362.                 }
  363.                 frexpr(q->nelt);
  364.                 frexpr(q->baseoffset);
  365.                 frexpr(q->basexpr);
  366.                 free( (charptr) q);
  367.             }
  368.             if(p->vclass == CLNAMELIST)
  369.                 frchain( &(p->varxptr.namelist) );
  370.             free( (charptr) p);
  371.             hp->varp = NULL;
  372.         }
  373.     }
  374.  
  375.  void
  376. procinit(Void)
  377. {
  378.     register struct Labelblock *lp;
  379.     struct Chain *cp;
  380.     int i;
  381.     struct memblock;
  382.     extern struct memblock *curmemblock, *firstmemblock;
  383.     extern char *mem_first, *mem_next, *mem_last, *mem0_last;
  384.  
  385.     curmemblock = firstmemblock;
  386.     mem_next = mem_first;
  387.     mem_last = mem0_last;
  388.     ei_next = ei_first = ei_last = 0;
  389.     wh_next = wh_first = wh_last = 0;
  390.     iob_list = 0;
  391.     for(i = 0; i < 9; i++)
  392.         io_structs[i] = 0;
  393.  
  394.     parstate = OUTSIDE;
  395.     headerdone = NO;
  396.     blklevel = 1;
  397.     saveall = NO;
  398.     substars = NO;
  399.     nwarn = 0;
  400.     thislabel = NULL;
  401.     needkwd = 0;
  402.  
  403.     proctype = TYUNKNOWN;
  404.     procname = "MAIN_";
  405.     procclass = CLUNKNOWN;
  406.     nentry = 0;
  407.     nallargs = nallchargs = 0;
  408.     multitype = NO;
  409.     retslot = NULL;
  410.     for(i = 0; i < NTYPES0; i++) {
  411.         frexpr((expptr)xretslot[i]);
  412.         xretslot[i] = 0;
  413.         }
  414.     cxslot = -1;
  415.     chslot = -1;
  416.     chlgslot = -1;
  417.     procleng = 0;
  418.     blklevel = 1;
  419.     lastargslot = 0;
  420.  
  421.     for(lp = labeltab ; lp < labtabend ; ++lp)
  422.         lp->stateno = 0;
  423.  
  424.     hashclear();
  425.  
  426. /* Clear the list of newly generated identifiers from the previous
  427.    function */
  428.  
  429.     frexchain(&new_vars);
  430.     frexchain(&used_builtins);
  431.     frchain(&assigned_fmts);
  432.     frchain(&allargs);
  433.     frchain(&earlylabs);
  434.  
  435.     nintnames = 0;
  436.     highlabtab = labeltab;
  437.  
  438.     ctlstack = ctls - 1;
  439.     for(i = TYADDR; i < TYVOID; i++) {
  440.         for(cp = templist[i]; cp ; cp = cp->nextp)
  441.             free( (charptr) (cp->datap) );
  442.         frchain(templist + i);
  443.         autonum[i] = 0;
  444.         }
  445.     holdtemps = NULL;
  446.     dorange = 0;
  447.     nregvar = 0;
  448.     highregvar = 0;
  449.     entries = NULL;
  450.     rpllist = NULL;
  451.     inioctl = NO;
  452.     eqvstart += nequiv;
  453.     nequiv = 0;
  454.     dcomplex_seen = 0;
  455.  
  456.     for(i = 0 ; i<NTYPES0 ; ++i)
  457.         rtvlabel[i] = 0;
  458.  
  459.     if(undeftype)
  460.         setimpl(TYUNKNOWN, (ftnint) 0, 'a', 'z');
  461.     else
  462.     {
  463.         setimpl(tyreal, (ftnint) 0, 'a', 'z');
  464.         setimpl(tyint,  (ftnint) 0, 'i', 'n');
  465.     }
  466.     setimpl(-STGBSS, (ftnint) 0, 'a', 'z');    /* set class */
  467.     setlog();
  468. }
  469.  
  470.  
  471.  
  472.  void
  473. #ifdef KR_headers
  474. setimpl(type, length, c1, c2)
  475.     int type;
  476.     ftnint length;
  477.     int c1;
  478.     int c2;
  479. #else
  480. setimpl(int type, ftnint length, int c1, int c2)
  481. #endif
  482. {
  483.     int i;
  484.     char buff[100];
  485.  
  486.     if(c1==0 || c2==0)
  487.         return;
  488.  
  489.     if(c1 > c2) {
  490.         sprintf(buff, "characters out of order in implicit:%c-%c", c1, c2);
  491.         err(buff);
  492.         }
  493.     else {
  494.         c1 = letter(c1);
  495.         c2 = letter(c2);
  496.         if(type < 0)
  497.             for(i = c1 ; i<=c2 ; ++i)
  498.                 implstg[i] = - type;
  499.         else {
  500.             type = lengtype(type, length);
  501.             if(type == TYCHAR) {
  502.                 if (length < 0) {
  503.                     err("length (*) in implicit");
  504.                     length = 1;
  505.                     }
  506.                 }
  507.             else if (type != TYLONG)
  508.                 length = 0;
  509.             for(i = c1 ; i<=c2 ; ++i) {
  510.                 impltype[i] = type;
  511.                 implleng[i] = length;
  512.                 }
  513.             }
  514.         }
  515.     }
  516.