home *** CD-ROM | disk | FTP | other *** search
/ Programmer 7500 / MAX_PROGRAMMERS.iso / INFO / FORTRAN / F2C_SRC.ZIP / F2C / VAX.C < prev    next >
Encoding:
C/C++ Source or Header  |  1991-06-10  |  7.8 KB  |  326 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 "pccdefs.h"
  26. #include "output.h"
  27.  
  28. int regnum[] =  {
  29.     11, 10, 9, 8, 7, 6 };
  30.  
  31. /* Put out a constant integer */
  32.  
  33. prconi(fp, n)
  34. FILEP fp;
  35. ftnint n;
  36. {
  37.     fprintf(fp, "\t%ld\n", n);
  38. }
  39.  
  40.  
  41.  
  42. /* Put out a constant address */
  43.  
  44. prcona(fp, a)
  45. FILEP fp;
  46. ftnint a;
  47. {
  48.     fprintf(fp, "\tL%ld\n", a);
  49. }
  50.  
  51.  
  52.  
  53. prconr(fp, x, k)
  54.  FILEP fp;
  55.  int k;
  56.  Constp x;
  57. {
  58.     char *x0, *x1;
  59.     char cdsbuf0[64], cdsbuf1[64];
  60.  
  61.     if (k > 1) {
  62.         if (x->vstg) {
  63.             x0 = x->Const.cds[0];
  64.             x1 = x->Const.cds[1];
  65.             }
  66.         else {
  67.             x0 = cds(dtos(x->Const.cd[0]), cdsbuf0);
  68.             x1 = cds(dtos(x->Const.cd[1]), cdsbuf1);
  69.             }
  70.         fprintf(fp, "\t%s %s\n", x0, x1);
  71.         }
  72.     else
  73.         fprintf(fp, "\t%s\n", x->vstg ? x->Const.cds[0]
  74.                 : cds(dtos(x->Const.cd[0]), cdsbuf0));
  75. }
  76.  
  77.  
  78. char *memname(stg, mem)
  79.  int stg;
  80.  long mem;
  81. {
  82.     static char s[20];
  83.  
  84.     switch(stg)
  85.     {
  86.     case STGCOMMON:
  87.     case STGEXT:
  88.         sprintf(s, "_%s", extsymtab[mem].cextname);
  89.         break;
  90.  
  91.     case STGBSS:
  92.     case STGINIT:
  93.         sprintf(s, "v.%ld", mem);
  94.         break;
  95.  
  96.     case STGCONST:
  97.         sprintf(s, "L%ld", mem);
  98.         break;
  99.  
  100.     case STGEQUIV:
  101.         sprintf(s, "q.%ld", mem+eqvstart);
  102.         break;
  103.  
  104.     default:
  105.         badstg("memname", stg);
  106.     }
  107.     return(s);
  108. }
  109.  
  110. /* make_int_expr -- takes an arbitrary expression, and replaces all
  111.    occurrences of arguments with indirection */
  112.  
  113. expptr make_int_expr (e)
  114. expptr e;
  115. {
  116.     if (e != ENULL)
  117.     switch (e -> tag) {
  118.         case TADDR:
  119.             if (e -> addrblock.vstg == STGARG)
  120.             e = mkexpr (OPWHATSIN, e, ENULL);
  121.             break;
  122.         case TEXPR:
  123.             e -> exprblock.leftp = make_int_expr (e -> exprblock.leftp);
  124.             e -> exprblock.rightp = make_int_expr (e -> exprblock.rightp);
  125.             break;
  126.         default:
  127.             break;
  128.     } /* switch */
  129.  
  130.     return e;
  131. } /* make_int_expr */
  132.  
  133.  
  134.  
  135. /* prune_left_conv -- used in prolog() to strip type cast away from
  136.    left-hand side of parameter adjustments.  This is necessary to avoid
  137.    error messages from cktype() */
  138.  
  139. expptr prune_left_conv (e)
  140. expptr e;
  141. {
  142.     struct Exprblock *leftp;
  143.  
  144.     if (e && e -> tag == TEXPR && e -> exprblock.leftp &&
  145.         e -> exprblock.leftp -> tag == TEXPR) {
  146.     leftp = &(e -> exprblock.leftp -> exprblock);
  147.     if (leftp -> opcode == OPCONV) {
  148.         e -> exprblock.leftp = leftp -> leftp;
  149.         free ((charptr) leftp);
  150.     }
  151.     }
  152.  
  153.     return e;
  154. } /* prune_left_conv */
  155.  
  156.  
  157.  static int wrote_comment;
  158.  static FILE *comment_file;
  159.  
  160.  static void
  161. write_comment()
  162. {
  163.     if (!wrote_comment) {
  164.         wrote_comment = 1;
  165.         nice_printf (comment_file, "/* Parameter adjustments */\n");
  166.         }
  167.     }
  168.  
  169.  static int *
  170. count_args()
  171. {
  172.     register int *ac;
  173.     register chainp cp;
  174.     register struct Entrypoint *ep;
  175.     register Namep q;
  176.  
  177.     ac = (int *)ckalloc(nallargs*sizeof(int));
  178.  
  179.     for(ep = entries; ep; ep = ep->entnextp)
  180.         for(cp = ep->arglist; cp; cp = cp->nextp)
  181.             if (q = (Namep)cp->datap)
  182.                 ac[q->argno]++;
  183.     return ac;
  184.     }
  185.  
  186. prolog(outfile, p)
  187.  FILE *outfile;
  188.  register chainp p;
  189. {
  190.     int addif, addif0, i, nd, size;
  191.     int *ac;
  192.     register Namep q;
  193.     register struct Dimblock *dp;
  194.  
  195.     if(procclass == CLBLOCK)
  196.         return;
  197.     wrote_comment = 0;
  198.     comment_file = outfile;
  199.     ac = 0;
  200.  
  201. /* Compute the base addresses and offsets for the array parameters, and
  202.    assign these values to local variables */
  203.  
  204.     addif = addif0 = nentry > 1;
  205.     for(; p ; p = p->nextp)
  206.     {
  207.         q = (Namep) p->datap;
  208.         if(dp = q->vdim)    /* if this param is an array ... */
  209.         {
  210.         expptr Q, expr;
  211.  
  212.         /* See whether to protect the following with an if. */
  213.         /* This only happens when there are multiple entries. */
  214.  
  215.         nd = dp->ndim - 1;
  216.         if (addif0) {
  217.             if (!ac)
  218.                 ac = count_args();
  219.             if (ac[q->argno] == nentry)
  220.                 addif = 0;
  221.             else if (dp->basexpr
  222.                     || dp->baseoffset->constblock.Const.ci)
  223.                 addif = 1;
  224.             else for(addif = i = 0; i <= nd; i++)
  225.                 if (dp->dims[i].dimexpr
  226.                 && (i < nd || !q->vlastdim)) {
  227.                     addif = 1;
  228.                     break;
  229.                     }
  230.             if (addif) {
  231.                 write_comment();
  232.                 nice_printf(outfile, "if (%s) {\n", /*}*/
  233.                         q->cvarname);
  234.                 next_tab(outfile);
  235.                 }
  236.             }
  237.         for(i = 0 ; i <= nd; ++i)
  238.  
  239. /* Store the variable length of each dimension (which is fixed upon
  240.    runtime procedure entry) into a local variable */
  241.  
  242.             if ((Q = dp->dims[i].dimexpr)
  243.             && (i < nd || !q->vlastdim)) {
  244.             expr = (expptr)cpexpr(Q);
  245.             write_comment();
  246.             out_and_free_statement (outfile, mkexpr (OPASSIGN,
  247.                 fixtype(cpexpr(dp->dims[i].dimsize)), expr));
  248.             } /* if dp -> dims[i].dimexpr */
  249.  
  250. /* size   will equal the size of a single element, or -1 if the type is
  251.    variable length character type */
  252.  
  253.         size = typesize[ q->vtype ];
  254.         if(q->vtype == TYCHAR)
  255.             if( ISICON(q->vleng) )
  256.             size *= q->vleng->constblock.Const.ci;
  257.             else
  258.             size = -1;
  259.  
  260.         /* Fudge the argument pointers for arrays so subscripts
  261.          * are 0-based. Not done if array bounds are being checked.
  262.          */
  263.         if(dp->basexpr) {
  264.  
  265. /* Compute the base offset for this procedure */
  266.  
  267.             write_comment();
  268.             out_and_free_statement (outfile, mkexpr (OPASSIGN,
  269.                 cpexpr(fixtype(dp->baseoffset)),
  270.                 cpexpr(fixtype(dp->basexpr))));
  271.         } /* if dp -> basexpr */
  272.  
  273.         if(! checksubs) {
  274.             if(dp->basexpr) {
  275.             expptr tp;
  276.  
  277. /* If the base of this array has a variable adjustment ... */
  278.  
  279.             tp = (expptr) cpexpr (dp -> baseoffset);
  280.             if(size < 0 || q -> vtype == TYCHAR)
  281.                 tp = mkexpr (OPSTAR, tp, cpexpr (q -> vleng));
  282.  
  283.             write_comment();
  284.             tp = mkexpr (OPMINUSEQ,
  285.                 mkconv (TYADDR, (expptr)p->datap),
  286.                 mkconv(TYINT, fixtype
  287.                 (fixtype (tp))));
  288. /* Avoid type clash by removing the type conversion */
  289.             tp = prune_left_conv (tp);
  290.             out_and_free_statement (outfile, tp);
  291.             } else if(dp->baseoffset->constblock.Const.ci != 0) {
  292.  
  293. /* if the base of this array has a nonzero constant adjustment ... */
  294.  
  295.             expptr tp;
  296.  
  297.             write_comment();
  298.             if(size > 0 && q -> vtype != TYCHAR) {
  299.                 tp = prune_left_conv (mkexpr (OPMINUSEQ,
  300.                     mkconv (TYADDR, (expptr)p->datap),
  301.                     mkconv (TYINT, fixtype
  302.                     (cpexpr (dp->baseoffset)))));
  303.                 out_and_free_statement (outfile, tp);
  304.             } else {
  305.                 tp = prune_left_conv (mkexpr (OPMINUSEQ,
  306.                     mkconv (TYADDR, (expptr)p->datap),
  307.                     mkconv (TYINT, fixtype
  308.                     (mkexpr (OPSTAR, cpexpr (dp -> baseoffset),
  309.                     cpexpr (q -> vleng))))));
  310.                 out_and_free_statement (outfile, tp);
  311.             } /* else */
  312.             } /* if dp -> baseoffset -> const */
  313.         } /* if !checksubs */
  314.  
  315.         if (addif) {
  316.             nice_printf(outfile, /*{*/ "}\n");
  317.             prev_tab(outfile);
  318.             }
  319.         }
  320.     }
  321.     if (wrote_comment)
  322.         nice_printf (outfile, "\n/* Function Body */\n");
  323.     if (ac)
  324.         free((char *)ac);
  325. } /* prolog */
  326.