00001 /****************************************************************
00002 Copyright 1990, 1991, 1993, 1994 by AT&T, Lucent Technologies and Bellcore.
00003 
00004 Permission to use, copy, modify, and distribute this software
00005 and its documentation for any purpose and without fee is hereby
00006 granted, provided that the above copyright notice appear in all
00007 copies and that both that the copyright notice and this
00008 permission notice and warranty disclaimer appear in supporting
00009 documentation, and that the names of AT&T, Bell Laboratories,
00010 Lucent or Bellcore or any of their entities not be used in
00011 advertising or publicity pertaining to distribution of the
00012 software without specific, written prior permission.
00013 
00014 AT&T, Lucent and Bellcore disclaim all warranties with regard to
00015 this software, including all implied warranties of
00016 merchantability and fitness.  In no event shall AT&T, Lucent or
00017 Bellcore be liable for any special, indirect or consequential
00018 damages or any damages whatsoever resulting from loss of use,
00019 data or profits, whether in an action of contract, negligence or
00020 other tortious action, arising out of or in connection with the
00021 use or performance of this software.
00022 ****************************************************************/
00023 
00024 #include "defs.h"
00025 #include "p1defs.h"
00026 #include "output.h"
00027 #include "names.h"
00028 
00029 
00030 static void p1_addr Argdcl((Addrp));
00031 static void p1_big_addr Argdcl((Addrp));
00032 static void p1_binary Argdcl((Exprp));
00033 static void p1_const Argdcl((Constp));
00034 static void p1_list Argdcl((struct Listblock*));
00035 static void p1_literal Argdcl((long int));
00036 static void p1_name Argdcl((Namep));
00037 static void p1_unary Argdcl((Exprp));
00038 static void p1putd Argdcl((int, long int));
00039 static void p1putdd Argdcl((int, int, int));
00040 static void p1putddd Argdcl((int, int, int, int));
00041 static void p1putdds Argdcl((int, int, int, char*));
00042 static void p1putds Argdcl((int, int, char*));
00043 static void p1putn Argdcl((int, int, char*));
00044 
00045 
00046 /* p1_comment -- save the text of a Fortran comment in the intermediate
00047    file.  Make sure that there are no spurious "/ *" or "* /" characters by
00048    mapping them onto "/+" and "+/".   str   is assumed to hold no newlines and be
00049    null terminated; it may be modified by this function. */
00050 
00051  void
00052 #ifdef KR_headers
00053 p1_comment(str)
00054         char *str;
00055 #else
00056 p1_comment(char *str)
00057 #endif
00058 {
00059     register unsigned char *pointer, *ustr;
00060 
00061     if (!str)
00062         return;
00063 
00064 /* Get rid of any open or close comment combinations that may be in the
00065    Fortran input */
00066 
00067         ustr = (unsigned char *)str;
00068         for(pointer = ustr; *pointer; pointer++)
00069                 if (*pointer == '*' && (pointer[1] == '/'
00070                                         || pointer > ustr && pointer[-1] == '/'))
00071                         *pointer = '+';
00072         /* trim trailing white space */
00073 #ifdef isascii
00074         while(--pointer >= ustr && (!isascii(*pointer) || isspace(*pointer)));
00075 #else
00076         while(--pointer >= ustr && isspace(*pointer));
00077 #endif
00078         pointer[1] = 0;
00079         p1puts (P1_COMMENT, str);
00080 } /* p1_comment */
00081 
00082 /* p1_name -- Writes the address of a hash table entry into the
00083    intermediate file */
00084 
00085  static void
00086 #ifdef KR_headers
00087 p1_name(namep)
00088         Namep namep;
00089 #else
00090 p1_name(Namep namep)
00091 #endif
00092 {
00093         p1putd (P1_NAME_POINTER, (long) namep);
00094         namep->visused = 1;
00095 } /* p1_name */
00096 
00097 
00098 
00099  void
00100 #ifdef KR_headers
00101 p1_expr(expr)
00102         expptr expr;
00103 #else
00104 p1_expr(expptr expr)
00105 #endif
00106 {
00107 /* An opcode of 0 means a null entry */
00108 
00109     if (expr == ENULL) {
00110         p1putdd (P1_EXPR, 0, TYUNKNOWN);        /* Should this be TYERROR? */
00111         return;
00112     } /* if (expr == ENULL) */
00113 
00114     switch (expr -> tag) {
00115         case TNAME:
00116                 p1_name ((Namep) expr);
00117                 return;
00118         case TCONST:
00119                 p1_const(&expr->constblock);
00120                 return;
00121         case TEXPR:
00122                 /* Fall through the switch */
00123                 break;
00124         case TADDR:
00125                 p1_addr (&(expr -> addrblock));
00126                 goto freeup;
00127         case TPRIM:
00128                 warn ("p1_expr:  got TPRIM");
00129                 return;
00130         case TLIST:
00131                 p1_list (&(expr->listblock));
00132                 frchain( &(expr->listblock.listp) );
00133                 return;
00134         case TERROR:
00135                 return;
00136         default:
00137                 erri ("p1_expr: bad tag '%d'", (int) (expr -> tag));
00138                 return;
00139         }
00140 
00141 /* Now we know that the tag is TEXPR */
00142 
00143     if (is_unary_op (expr -> exprblock.opcode))
00144         p1_unary (&(expr -> exprblock));
00145     else if (is_binary_op (expr -> exprblock.opcode))
00146         p1_binary (&(expr -> exprblock));
00147     else
00148         erri ("p1_expr:  bad opcode '%d'", (int) expr -> exprblock.opcode);
00149  freeup:
00150     free((char *)expr);
00151 
00152 } /* p1_expr */
00153 
00154 
00155 
00156  static void
00157 #ifdef KR_headers
00158 p1_const(cp)
00159         register Constp cp;
00160 #else
00161 p1_const(register Constp cp)
00162 #endif
00163 {
00164         int type = cp->vtype;
00165         expptr vleng = cp->vleng;
00166         union Constant *c = &cp->Const;
00167         char cdsbuf0[64], cdsbuf1[64];
00168         char *cds0, *cds1;
00169 
00170     switch (type) {
00171         case TYINT1:
00172         case TYSHORT:
00173         case TYLONG:
00174 #ifdef TYQUAD
00175         case TYQUAD:
00176 #endif
00177         case TYLOGICAL:
00178         case TYLOGICAL1:
00179         case TYLOGICAL2:
00180             fprintf(pass1_file, "%d: %d %ld\n", P1_CONST, type, c->ci);
00181             break;
00182         case TYREAL:
00183         case TYDREAL:
00184                 fprintf(pass1_file, "%d: %d %s\n", P1_CONST, type,
00185                         cp->vstg ? c->cds[0] : cds(dtos(c->cd[0]), cdsbuf0));
00186             break;
00187         case TYCOMPLEX:
00188         case TYDCOMPLEX:
00189                 if (cp->vstg) {
00190                         cds0 = c->cds[0];
00191                         cds1 = c->cds[1];
00192                         }
00193                 else {
00194                         cds0 = cds(dtos(c->cd[0]), cdsbuf0);
00195                         cds1 = cds(dtos(c->cd[1]), cdsbuf1);
00196                         }
00197                 fprintf(pass1_file, "%d: %d %s %s\n", P1_CONST, type,
00198                         cds0, cds1);
00199             break;
00200         case TYCHAR:
00201             if (vleng && !ISICON (vleng))
00202                 erri("p1_const:  bad vleng '%d'\n", (int) vleng);
00203             else
00204                 fprintf(pass1_file, "%d: %d %lx\n", P1_CONST, type,
00205                         cpexpr((expptr)cp));
00206             break;
00207         default:
00208             erri ("p1_const:  bad constant type '%d'", type);
00209             break;
00210     } /* switch */
00211 } /* p1_const */
00212 
00213 
00214  void
00215 #ifdef KR_headers
00216 p1_asgoto(addrp)
00217         Addrp addrp;
00218 #else
00219 p1_asgoto(Addrp addrp)
00220 #endif
00221 {
00222     p1put (P1_ASGOTO);
00223     p1_addr (addrp);
00224 } /* p1_asgoto */
00225 
00226 
00227  void
00228 #ifdef KR_headers
00229 p1_goto(stateno)
00230         ftnint stateno;
00231 #else
00232 p1_goto(ftnint stateno)
00233 #endif
00234 {
00235     p1putd (P1_GOTO, stateno);
00236 } /* p1_goto */
00237 
00238 
00239  static void
00240 #ifdef KR_headers
00241 p1_addr(addrp)
00242         register struct Addrblock *addrp;
00243 #else
00244 p1_addr(register struct Addrblock *addrp)
00245 #endif
00246 {
00247     int stg;
00248 
00249     if (addrp == (struct Addrblock *) NULL)
00250         return;
00251 
00252     stg = addrp -> vstg;
00253 
00254     if (ONEOF(stg, M(STGINIT)|M(STGREG))
00255         || ONEOF(stg, M(STGCOMMON)|M(STGEQUIV)) &&
00256                 (!ISICON(addrp->memoffset)
00257                 || (addrp->uname_tag == UNAM_NAME
00258                         ? addrp->memoffset->constblock.Const.ci
00259                                 != addrp->user.name->voffset
00260                         : addrp->memoffset->constblock.Const.ci))
00261         || ONEOF(stg, M(STGBSS)|M(STGINIT)|M(STGAUTO)|M(STGARG)) &&
00262                 (!ISICON(addrp->memoffset)
00263                         || addrp->memoffset->constblock.Const.ci)
00264         || addrp->Field || addrp->isarray || addrp->vstg == STGLENG)
00265         {
00266                 p1_big_addr (addrp);
00267                 return;
00268         }
00269 
00270 /* Write out a level of indirection for non-array arguments, which have
00271    addrp -> memoffset   set and are handled by   p1_big_addr().
00272    Lengths are passed by value, so don't check STGLENG
00273    28-Jun-89 (dmg)  Added the check for != TYCHAR
00274  */
00275 
00276     if (oneof_stg ( addrp -> uname_tag == UNAM_NAME ? addrp -> user.name : NULL,
00277             stg, M(STGARG)|M(STGEQUIV)) && addrp->vtype != TYCHAR) {
00278         p1putdd (P1_EXPR, OPWHATSIN, addrp -> vtype);
00279         p1_expr (ENULL);        /* Put dummy   vleng   */
00280     } /* if stg == STGARG */
00281 
00282     switch (addrp -> uname_tag) {
00283         case UNAM_NAME:
00284             p1_name (addrp -> user.name);
00285             break;
00286         case UNAM_IDENT:
00287             p1putdds(P1_IDENT, addrp->vtype, addrp->vstg,
00288                                 addrp->user.ident);
00289             break;
00290         case UNAM_CHARP:
00291                 p1putdds(P1_CHARP, addrp->vtype, addrp->vstg,
00292                                 addrp->user.Charp);
00293                 break;
00294         case UNAM_EXTERN:
00295             p1putd (P1_EXTERN, (long) addrp -> memno);
00296             if (addrp->vclass == CLPROC)
00297                 extsymtab[addrp->memno].extype = addrp->vtype;
00298             break;
00299         case UNAM_CONST:
00300             if (addrp -> memno != BAD_MEMNO)
00301                 p1_literal (addrp -> memno);
00302             else
00303                 p1_const((struct Constblock *)addrp);
00304             break;
00305         case UNAM_UNKNOWN:
00306         default:
00307             erri ("p1_addr:  unknown uname_tag '%d'", addrp -> uname_tag);
00308             break;
00309     } /* switch */
00310 } /* p1_addr */
00311 
00312 
00313  static void
00314 #ifdef KR_headers
00315 p1_list(listp)
00316         struct Listblock *listp;
00317 #else
00318 p1_list(struct Listblock *listp)
00319 #endif
00320 {
00321     chainp lis;
00322     int count = 0;
00323 
00324     if (listp == (struct Listblock *) NULL)
00325         return;
00326 
00327 /* Count the number of parameters in the list */
00328 
00329     for (lis = listp -> listp; lis; lis = lis -> nextp)
00330         count++;
00331 
00332     p1putddd (P1_LIST, listp -> tag, listp -> vtype, count);
00333 
00334     for (lis = listp -> listp; lis; lis = lis -> nextp)
00335         p1_expr ((expptr) lis -> datap);
00336 
00337 } /* p1_list */
00338 
00339 
00340  void
00341 #ifdef KR_headers
00342 p1_label(lab)
00343         long lab;
00344 #else
00345 p1_label(long lab)
00346 #endif
00347 {
00348         if (parstate < INDATA)
00349                 earlylabs = mkchain((char *)lab, earlylabs);
00350         else
00351                 p1putd (P1_LABEL, lab);
00352         }
00353 
00354 
00355 
00356  static void
00357 #ifdef KR_headers
00358 p1_literal(memno)
00359         long memno;
00360 #else
00361 p1_literal(long memno)
00362 #endif
00363 {
00364     p1putd (P1_LITERAL, memno);
00365 } /* p1_literal */
00366 
00367 
00368  void
00369 #ifdef KR_headers
00370 p1_if(expr)
00371         expptr expr;
00372 #else
00373 p1_if(expptr expr)
00374 #endif
00375 {
00376     p1put (P1_IF);
00377     p1_expr (expr);
00378 } /* p1_if */
00379 
00380 
00381 
00382 
00383  void
00384 #ifdef KR_headers
00385 p1_elif(expr)
00386         expptr expr;
00387 #else
00388 p1_elif(expptr expr)
00389 #endif
00390 {
00391     p1put (P1_ELIF);
00392     p1_expr (expr);
00393 } /* p1_elif */
00394 
00395 
00396 
00397 
00398  void
00399 p1_else(Void)
00400 {
00401     p1put (P1_ELSE);
00402 } /* p1_else */
00403 
00404 
00405 
00406 
00407  void
00408 p1_endif(Void)
00409 {
00410     p1put (P1_ENDIF);
00411 } /* p1_endif */
00412 
00413 
00414 
00415 
00416  void
00417 p1else_end(Void)
00418 {
00419     p1put (P1_ENDELSE);
00420 } /* p1else_end */
00421 
00422 
00423  static void
00424 #ifdef KR_headers
00425 p1_big_addr(addrp)
00426         Addrp addrp;
00427 #else
00428 p1_big_addr(Addrp addrp)
00429 #endif
00430 {
00431     if (addrp == (Addrp) NULL)
00432         return;
00433 
00434     p1putn (P1_ADDR, (int)sizeof(struct Addrblock), (char *) addrp);
00435     p1_expr (addrp -> vleng);
00436     p1_expr (addrp -> memoffset);
00437     if (addrp->uname_tag == UNAM_NAME)
00438         addrp->user.name->visused = 1;
00439 } /* p1_big_addr */
00440 
00441 
00442 
00443  static void
00444 #ifdef KR_headers
00445 p1_unary(e)
00446         struct Exprblock *e;
00447 #else
00448 p1_unary(struct Exprblock *e)
00449 #endif
00450 {
00451     if (e == (struct Exprblock *) NULL)
00452         return;
00453 
00454     p1putdd (P1_EXPR, (int) e -> opcode, e -> vtype);
00455     p1_expr (e -> vleng);
00456 
00457     switch (e -> opcode) {
00458         case OPNEG:
00459         case OPNEG1:
00460         case OPNOT:
00461         case OPABS:
00462         case OPBITNOT:
00463         case OPPREINC:
00464         case OPPREDEC:
00465         case OPADDR:
00466         case OPIDENTITY:
00467         case OPCHARCAST:
00468         case OPDABS:
00469             p1_expr(e -> leftp);
00470             break;
00471         default:
00472             erri ("p1_unary: bad opcode '%d'", (int) e -> opcode);
00473             break;
00474     } /* switch */
00475 
00476 } /* p1_unary */
00477 
00478 
00479  static void
00480 #ifdef KR_headers
00481 p1_binary(e)
00482         struct Exprblock *e;
00483 #else
00484 p1_binary(struct Exprblock *e)
00485 #endif
00486 {
00487     if (e == (struct Exprblock *) NULL)
00488         return;
00489 
00490     p1putdd (P1_EXPR, e -> opcode, e -> vtype);
00491     p1_expr (e -> vleng);
00492     p1_expr (e -> leftp);
00493     p1_expr (e -> rightp);
00494 } /* p1_binary */
00495 
00496 
00497  void
00498 #ifdef KR_headers
00499 p1_head(classKRH, name)
00500         int classKRH;
00501         char *name;
00502 #else
00503 p1_head(int classKRH, char *name)
00504 #endif
00505 {
00506     p1putds (P1_HEAD, classKRH, name ? name : "");
00507 } /* p1_head */
00508 
00509 
00510  void
00511 #ifdef KR_headers
00512 p1_subr_ret(retexp)
00513         expptr retexp;
00514 #else
00515 p1_subr_ret(expptr retexp)
00516 #endif
00517 {
00518 
00519     p1put (P1_SUBR_RET);
00520     p1_expr (cpexpr(retexp));
00521 } /* p1_subr_ret */
00522 
00523 
00524 
00525  void
00526 #ifdef KR_headers
00527 p1comp_goto(index, count, labels)
00528         expptr index;
00529         int count;
00530         struct Labelblock **labels;
00531 #else
00532 p1comp_goto(expptr index, int count, struct Labelblock **labels)
00533 #endif
00534 {
00535     struct Constblock c;
00536     int i;
00537     register struct Labelblock *L;
00538 
00539     p1put (P1_COMP_GOTO);
00540     p1_expr (index);
00541 
00542 /* Write out a P1_LIST directly, to avoid the overhead of allocating a
00543    list before it's needed HACK HACK HACK */
00544 
00545     p1putddd (P1_LIST, TLIST, TYUNKNOWN, count);
00546     c.vtype = TYLONG;
00547     c.vleng = 0;
00548 
00549     for (i = 0; i < count; i++) {
00550         L = labels[i];
00551         L->labused = 1;
00552         c.Const.ci = L->stateno;
00553         p1_const(&c);
00554     } /* for i = 0 */
00555 } /* p1comp_goto */
00556 
00557 
00558 
00559  void
00560 #ifdef KR_headers
00561 p1_for(init, test, inc)
00562         expptr init;
00563         expptr test;
00564         expptr inc;
00565 #else
00566 p1_for(expptr init, expptr test, expptr inc)
00567 #endif
00568 {
00569     p1put (P1_FOR);
00570     p1_expr (init);
00571     p1_expr (test);
00572     p1_expr (inc);
00573 } /* p1_for */
00574 
00575 
00576  void
00577 p1for_end(Void)
00578 {
00579     p1put (P1_ENDFOR);
00580 } /* p1for_end */
00581 
00582 
00583 
00584 
00585 /* ----------------------------------------------------------------------
00586    The intermediate file actually gets written ONLY by the routines below.
00587    To change the format of the file, you need only change these routines.
00588    ----------------------------------------------------------------------
00589 */
00590 
00591 
00592 /* p1puts -- Put a typed string into the Pass 1 intermediate file.  Assumes that
00593    str   contains no newlines and is null-terminated. */
00594 
00595  void
00596 #ifdef KR_headers
00597 p1puts(type, str)
00598         int type;
00599         char *str;
00600 #else
00601 p1puts(int type, char *str)
00602 #endif
00603 {
00604     fprintf (pass1_file, "%d: %s\n", type, str);
00605 } /* p1puts */
00606 
00607 
00608 /* p1putd -- Put a typed integer into the Pass 1 intermediate file. */
00609 
00610  static void
00611 #ifdef KR_headers
00612 p1putd(type, value)
00613         int type;
00614         long value;
00615 #else
00616 p1putd(int type, long value)
00617 #endif
00618 {
00619     fprintf (pass1_file, "%d: %ld\n", type, value);
00620 } /* p1_putd */
00621 
00622 
00623 /* p1putdd -- Put a typed pair of integers into the intermediate file. */
00624 
00625  static void
00626 #ifdef KR_headers
00627 p1putdd(type, v1, v2)
00628         int type;
00629         int v1;
00630         int v2;
00631 #else
00632 p1putdd(int type, int v1, int v2)
00633 #endif
00634 {
00635     fprintf (pass1_file, "%d: %d %d\n", type, v1, v2);
00636 } /* p1putdd */
00637 
00638 
00639 /* p1putddd -- Put a typed triple of integers into the intermediate file. */
00640 
00641  static void
00642 #ifdef KR_headers
00643 p1putddd(type, v1, v2, v3)
00644         int type;
00645         int v1;
00646         int v2;
00647         int v3;
00648 #else
00649 p1putddd(int type, int v1, int v2, int v3)
00650 #endif
00651 {
00652     fprintf (pass1_file, "%d: %d %d %d\n", type, v1, v2, v3);
00653 } /* p1putddd */
00654 
00655  union dL {
00656         double d;
00657         long L[2];
00658         };
00659 
00660  static void
00661 #ifdef KR_headers
00662 p1putn(type, count, str)
00663         int type;
00664         int count;
00665         char *str;
00666 #else
00667 p1putn(int type, int count, char *str)
00668 #endif
00669 {
00670     int i;
00671 
00672     fprintf (pass1_file, "%d: ", type);
00673 
00674     for (i = 0; i < count; i++)
00675         putc (str[i], pass1_file);
00676 
00677     putc ('\n', pass1_file);
00678 } /* p1putn */
00679 
00680 
00681 
00682 /* p1put -- Put a type marker into the intermediate file. */
00683 
00684  void
00685 #ifdef KR_headers
00686 p1put(type)
00687         int type;
00688 #else
00689 p1put(int type)
00690 #endif
00691 {
00692     fprintf (pass1_file, "%d:\n", type);
00693 } /* p1put */
00694 
00695 
00696 
00697  static void
00698 #ifdef KR_headers
00699 p1putds(type, i, str)
00700         int type;
00701         int i;
00702         char *str;
00703 #else
00704 p1putds(int type, int i, char *str)
00705 #endif
00706 {
00707     fprintf (pass1_file, "%d: %d %s\n", type, i, str);
00708 } /* p1putds */
00709 
00710 
00711  static void
00712 #ifdef KR_headers
00713 p1putdds(token, type, stg, str)
00714         int token;
00715         int type;
00716         int stg;
00717         char *str;
00718 #else
00719 p1putdds(int token, int type, int stg, char *str)
00720 #endif
00721 {
00722     fprintf (pass1_file, "%d: %d %d %s\n", token, type, stg, str);
00723 } /* p1putdds */