home *** CD-ROM | disk | FTP | other *** search
/ Fresh Fish 8 / FreshFishVol8-CD2.bin / bbs / gnu / f2c-1993.04.28-src.lha / f2c-1993.04.28 / src / names.c < prev    next >
C/C++ Source or Header  |  1993-04-28  |  20KB  |  746 lines
  1. /****************************************************************
  2. Copyright 1990, 1992, 1993 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 "names.h"
  27. #include "iob.h"
  28.  
  29.  
  30. /* Names generated by the translator are guaranteed to be unique from the
  31.    Fortan names because Fortran does not allow underscores in identifiers,
  32.    and all of the system generated names do have underscores.  The various
  33.    naming conventions are outlined below:
  34.  
  35.     FORMAT        APPLICATION
  36.    ----------------------------------------------------------------------
  37.     io_#        temporaries generated by IO calls; these will
  38.             contain the device number (e.g. 5, 6, 0)
  39.     ret_val        function return value, required for complex and
  40.             character functions.
  41.     ret_val_len    length of the return value in character functions
  42.  
  43.     ssss_len    length of character argument "ssss"
  44.  
  45.     c_#        member of the literal pool, where # is an
  46.             arbitrary label assigned by the system
  47.     cs_#        short integer constant in the literal pool
  48.     t_#        expression temporary, # is the depth of arguments
  49.             on the stack.
  50.     L#        label "#", given by user in the Fortran program.
  51.             This is unique because Fortran labels are numeric
  52.     pad_#        label on an init field required for alignment
  53.     xxx_init    label on a common block union, if a block data
  54.             requires a separate declaration
  55. */
  56.  
  57. /* generate variable references */
  58.  
  59. char *c_type_decl (type, is_extern)
  60. int type, is_extern;
  61. {
  62.     static char buff[100];
  63.  
  64.     switch (type) {
  65.     case TYREAL:    if (!is_extern || !forcedouble)
  66.                 { strcpy (buff, "real");break; }
  67.     case TYDREAL:    strcpy (buff, "doublereal");    break;
  68.     case TYCOMPLEX:    if (is_extern)
  69.                 strcpy (buff, Ansi    ? "/* Complex */ VOID"
  70.                         : "/* Complex */ int");
  71.             else
  72.                 strcpy (buff, "complex");
  73.             break;
  74.     case TYDCOMPLEX:if (is_extern)
  75.                 strcpy (buff, Ansi    ? "/* Double Complex */ VOID"
  76.                         : "/* Double Complex */ int");
  77.             else
  78.                 strcpy (buff, "doublecomplex");
  79.             break;
  80.     case TYADDR:
  81.     case TYINT1:
  82.     case TYSHORT:
  83.     case TYLONG:
  84. #ifdef TYQUAD
  85.     case TYQUAD:
  86. #endif
  87.     case TYLOGICAL1:
  88.     case TYLOGICAL2:
  89.     case TYLOGICAL:    strcpy(buff, typename[type]);
  90.             break;
  91.     case TYCHAR:    if (is_extern)
  92.                 strcpy (buff, Ansi    ? "/* Character */ VOID"
  93.                         : "/* Character */ int");
  94.             else
  95.                 strcpy (buff, "char");
  96.             break;
  97.  
  98.         case TYUNKNOWN:    strcpy (buff, "UNKNOWN");
  99.  
  100. /* If a procedure's type is unknown, assume it's a subroutine */
  101.  
  102.             if (!is_extern)
  103.                 break;
  104.  
  105. /* Subroutines must return an INT, because they might return a label
  106.    value.  Even if one doesn't, the caller will EXPECT it to. */
  107.  
  108.     case TYSUBR:    strcpy (buff, "/* Subroutine */ int");
  109.                             break;
  110.     case TYERROR:    strcpy (buff, "ERROR");        break;
  111.     case TYVOID:    strcpy (buff, "void");        break;
  112.     case TYCILIST:    strcpy (buff, "cilist");    break;
  113.     case TYICILIST:    strcpy (buff, "icilist");    break;
  114.     case TYOLIST:    strcpy (buff, "olist");        break;
  115.     case TYCLLIST:    strcpy (buff, "cllist");    break;
  116.     case TYALIST:    strcpy (buff, "alist");        break;
  117.     case TYINLIST:    strcpy (buff, "inlist");    break;
  118.     case TYFTNLEN:    strcpy (buff, "ftnlen");    break;
  119.     default:    sprintf (buff, "BAD DECL '%d'", type);
  120.                             break;
  121.     } /* switch */
  122.  
  123.     return buff;
  124. } /* c_type_decl */
  125.  
  126.  
  127. char *new_func_length()
  128. { return "ret_val_len"; }
  129.  
  130. char *new_arg_length(arg)
  131.  Namep arg;
  132. {
  133.     static char buf[64];
  134.     sprintf (buf, "%s_len", arg->fvarname);
  135.  
  136.     return buf;
  137. } /* new_arg_length */
  138.  
  139.  
  140. /* declare_new_addr -- Add a new local variable to the function, given a
  141.    pointer to an Addrblock structure (which must have the uname_tag set)
  142.    This list of idents will be printed in reverse (i.e., chronological)
  143.    order */
  144.  
  145.  void
  146. declare_new_addr (addrp)
  147. struct Addrblock *addrp;
  148. {
  149.     extern chainp new_vars;
  150.  
  151.     new_vars = mkchain((char *)cpexpr((expptr)addrp), new_vars);
  152. } /* declare_new_addr */
  153.  
  154.  
  155. wr_nv_ident_help (outfile, addrp)
  156. FILE *outfile;
  157. struct Addrblock *addrp;
  158. {
  159.     int eltcount = 0;
  160.  
  161.     if (addrp == (struct Addrblock *) NULL)
  162.     return;
  163.  
  164.     if (addrp -> isarray) {
  165.     frexpr (addrp -> memoffset);
  166.     addrp -> memoffset = ICON(0);
  167.     eltcount = addrp -> ntempelt;
  168.     addrp -> ntempelt = 0;
  169.     addrp -> isarray = 0;
  170.     } /* if */
  171.     out_addr (outfile, addrp);
  172.     if (eltcount)
  173.     nice_printf (outfile, "[%d]", eltcount);
  174. } /* wr_nv_ident_help */
  175.  
  176. int nv_type_help (addrp)
  177. struct Addrblock *addrp;
  178. {
  179.     if (addrp == (struct Addrblock *) NULL)
  180.     return -1;
  181.  
  182.     return addrp -> vtype;
  183. } /* nv_type_help */
  184.  
  185.  
  186. /* lit_name -- returns a unique identifier for the given literal.  Make
  187.    the label useful, when possible.  For example:
  188.  
  189.     1 -> c_1        (constant 1)
  190.     2 -> c_2        (constant 2)
  191.     1000 -> c_1000        (constant 1000)
  192.     1000000 -> c_b<memno>    (big constant number)
  193.     1.2 -> c_1_2        (constant 1.2)
  194.     1.234345 -> c_b<memno>    (big constant number)
  195.     -1 -> c_n1        (constant -1)
  196.     -1.0 -> c_n1_0        (constant -1.0)
  197.     .true. -> c_true    (constant true)
  198.     .false. -> c_false    (constant false)
  199.     default -> c_b<memno>    (default label)
  200. */
  201.  
  202. char *lit_name (litp)
  203. struct Literal *litp;
  204. {
  205.     static char buf[CONST_IDENT_MAX];
  206.     ftnint val;
  207.  
  208.     if (litp == (struct Literal *) NULL)
  209.         return NULL;
  210.  
  211.     switch (litp -> littype) {
  212.     case TYINT1:
  213.         val = litp -> litval.litival;
  214.         if (val >= 256 || val < -255)
  215.             sprintf (buf, "c_b%d", litp -> litnum);
  216.         else if (val < 0)
  217.             sprintf (buf, "ci1_n%ld", -val);
  218.         else
  219.             sprintf(buf, "ci1__%ld", val);
  220.         case TYSHORT:
  221.         val = litp -> litval.litival;
  222.         if (val >= 32768 || val <= -32769)
  223.             sprintf (buf, "c_b%d", litp -> litnum);
  224.         else if (val < 0)
  225.             sprintf (buf, "cs_n%ld", -val);
  226.         else
  227.             sprintf (buf, "cs__%ld", val);
  228.         break;
  229.     case TYLONG:
  230. #ifdef TYQUAD
  231.     case TYQUAD:
  232. #endif
  233.         val = litp -> litval.litival;
  234.         if (val >= 100000 || val <= -10000)
  235.             sprintf (buf, "c_b%d", litp -> litnum);
  236.         else if (val < 0)
  237.             sprintf (buf, "c_n%ld", -val);
  238.         else
  239.             sprintf (buf, "c__%ld", val);
  240.         break;
  241.     case TYLOGICAL1:
  242.     case TYLOGICAL2:
  243.     case TYLOGICAL:
  244.         sprintf (buf, "c_%s", (litp -> litval.litival
  245.                     ? "true" : "false"));
  246.         break;
  247.     case TYREAL:
  248.     case TYDREAL:
  249.         /* Given a limit of 6 or 8 character on external names,    */
  250.         /* few f.p. values can be meaningfully encoded in the    */
  251.         /* constant name.  Just going with the default cb_#    */
  252.         /* seems to be the best course for floating-point    */
  253.         /* constants.    */
  254.     case TYCHAR:
  255.         /* Shouldn't be any of these */
  256.     case TYADDR:
  257.     case TYCOMPLEX:
  258.     case TYDCOMPLEX:
  259.     case TYSUBR:
  260.     default:
  261.         sprintf (buf, "c_b%d", litp -> litnum);
  262.     } /* switch */
  263.     return buf;
  264. } /* lit_name */
  265.  
  266.  
  267.  
  268.  char *
  269. comm_union_name(count)
  270.  int count;
  271. {
  272.     static char buf[12];
  273.  
  274.     sprintf(buf, "%d", count);
  275.     return buf;
  276.     }
  277.  
  278.  
  279.  
  280.  
  281. /* wr_globals -- after every function has been translated, we need to
  282.    output the global declarations, such as the static table of constant
  283.    values */
  284.  
  285. wr_globals (outfile)
  286. FILE *outfile;
  287. {
  288.     struct Literal *litp, *lastlit;
  289.     extern int hsize;
  290.     extern char *lit_name();
  291.     char *litname;
  292.     int did_one, t;
  293.     struct Constblock cb;
  294.     ftnint x, y;
  295.  
  296.     if (nliterals == 0)
  297.     return;
  298.  
  299.     lastlit = litpool + nliterals;
  300.     did_one = 0;
  301.     for (litp = litpool; litp < lastlit; litp++) {
  302.     if (!litp->lituse)
  303.         continue;
  304.     litname = lit_name(litp);
  305.     if (!did_on