lang/fortran/comp/vax.c

   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 */