01630 {
01631     char *s1, *s2;
01632 
01633     if (index == ENULL)
01634         err ("compgoto_out:  null index for computed goto");
01635     else if (labels && labels -> tag != TLIST)
01636         erri ("compgoto_out:  expected label list, got tag '%d'",
01637                 labels -> tag);
01638     else {
01639         chainp elts;
01640         int i = 1;
01641 
01642         s2 = /*(*/ ") {\n"; /*}*/
01643         if (Ansi)
01644                 s1 = "switch ("; /*)*/
01645         else if (index->tag == TNAME || index->tag == TEXPR
01646                                 && index->exprblock.opcode == OPWHATSIN)
01647                 s1 = "switch ((int)"; /*)*/
01648         else {
01649                 s1 = "switch ((int)(";
01650                 s2 = ")) {\n"; /*}*/
01651                 }
01652         nice_printf(outfile, s1);
01653         expr_out (outfile, index);
01654         nice_printf (outfile, s2);
01655         next_tab (outfile);
01656 
01657         for (elts = labels -> listblock.listp; elts; elts = elts -> nextp, i++) {
01658             if (elts -> datap) {
01659                 if (ISICON(((expptr) (elts -> datap))))
01660                     nice_printf (outfile, "case %d:  goto %s;\n", i,
01661                         user_label(((expptr)(elts->datap))->constblock.Const.ci));
01662                 else
01663                     err ("compgoto_out:  bad label in label list");
01664             } /* if (elts -> datap) */
01665         } /* for elts */
01666         prev_tab (outfile);
01667         nice_printf (outfile, /*{*/ "}\n");
01668     } /* else */
01669 } /* compgoto_out */

01365 {
01366         static char buf[64];
01367 #ifdef USE_DTOA
01368         g_fmt(buf, x);
01369 #else
01370         sprintf(buf, db_fmt_string, x);
01371 #endif
01372         return strcpy(mem(strlen(buf)+1,0), buf);
01373         }

01589 {
01590     prev_tab (outfile);
01591     output_rbrace(outfile, "} else ");
01592     out_if (outfile, expr);
01593 } /* elif_out */

01614 {
01615     prev_tab (outfile);
01616     output_rbrace(outfile, "}\n");
01617 } /* end_else_out */

01602 {
01603     prev_tab (outfile);
01604     output_rbrace(outfile, "}\n");
01605 } /* endif_out */

00149 {
00150     if (e == (expptr) NULL)
00151         return;
00152 
00153     switch (e -> tag) {
00154         case TNAME:     out_name (fp, (struct Nameblock *) e);
00155                         return;
00156 
00157         case TCONST:    out_const(fp, &e->constblock);
00158                         goto end_out;
00159         case TEXPR:
00160                         break;
00161 
00162         case TADDR:     out_addr (fp, &(e -> addrblock));
00163                         goto end_out;
00164 
00165         case TPRIM:     if (!nerr)
00166                                 warn ("expr_out: got TPRIM");
00167                         output_prim (fp, &(e -> primblock));
00168                         return;
00169 
00170         case TLIST:     output_list (fp, &(e -> listblock));
00171  end_out:               frexpr(e);
00172                         return;
00173 
00174         case TIMPLDO:   err ("expr_out: got TIMPLDO");
00175                         return;
00176 
00177         case TERROR:
00178         default:
00179                         erri ("expr_out: bad tag '%d'", e -> tag);
00180     } /* switch */
00181 
00182 /* Now we know that the tag is TEXPR */
00183 
00184 /* Optimize on simple expressions, such as "a = a + b" ==> "a += b" */
00185 
00186     if (e -> exprblock.opcode == OPASSIGN && e -> exprblock.rightp &&
00187         e -> exprblock.rightp -> tag == TEXPR) {
00188         int opcode;
00189 
00190         opcode = e -> exprblock.rightp -> exprblock.opcode;
00191 
00192         if (opeqable[opcode]) {
00193             expptr leftp, rightp;
00194 
00195             if ((leftp = e -> exprblock.leftp) &&
00196                 (rightp = e -> exprblock.rightp -> exprblock.leftp)) {
00197 
00198                 if (same_ident (leftp, rightp)) {
00199                     expptr temp = e -> exprblock.rightp;
00200 
00201                     e -> exprblock.opcode = op_assign(opcode);
00202 
00203                     e -> exprblock.rightp = temp -> exprblock.rightp;
00204                     temp->exprblock.rightp = 0;
00205                     frexpr(temp);
00206                 } /* if same_ident (leftp, rightp) */
00207             } /* if leftp && rightp */
00208         } /* if opcode == OPPLUS || */
00209     } /* if e -> exprblock.opcode == OPASSIGN */
00210 
00211 
00212 /* Optimize on increment or decrement by 1 */
00213 
00214     {
00215         int opcode = e -> exprblock.opcode;
00216         expptr leftp = e -> exprblock.leftp;
00217         expptr rightp = e -> exprblock.rightp;
00218 
00219         if (leftp && rightp && (leftp -> headblock.vstg == STGARG ||
00220                 ISINT (leftp -> headblock.vtype)) &&
00221                 (opcode == OPPLUSEQ || opcode == OPMINUSEQ) &&
00222                 ISINT (rightp -> headblock.vtype) &&
00223                 ISICON (e -> exprblock.rightp) &&
00224                 (ISONE (e -> exprblock.rightp) ||
00225                 e -> exprblock.rightp -> constblock.Const.ci == -1)) {
00226 
00227 /* Allow for the '-1' constant value */
00228 
00229             if (!ISONE (e -> exprblock.rightp))
00230                 opcode = (opcode == OPPLUSEQ) ? OPMINUSEQ : OPPLUSEQ;
00231 
00232 /* replace the existing opcode */
00233 
00234             if (opcode == OPPLUSEQ)
00235                 e -> exprblock.opcode = OPPREINC;
00236             else
00237                 e -> exprblock.opcode = OPPREDEC;
00238 
00239 /* Free up storage used by the right hand side */
00240 
00241             frexpr (e -> exprblock.rightp);
00242             e->exprblock.rightp = 0;
00243         } /* if opcode == OPPLUS */
00244     } /* block */
00245 
00246 
00247     if (is_unary_op (e -> exprblock.opcode))
00248         output_unary (fp, &(e -> exprblock));
00249     else if (is_binary_op (e -> exprblock.opcode))
00250         output_binary (fp, &(e -> exprblock));
00251     else
00252         erri ("expr_out: bad opcode '%d'", (int) e -> exprblock.opcode);
00253 
00254     free((char *)e);
00255 
00256 } /* expr_out */

01436 {
01437     if (extsym == (Extsym *) NULL)
01438         return;
01439 
01440     nice_printf (fp, "%s", extsym->cextname);
01441 
01442 } /* extern_out */

00831 {
00832         register struct Literal *litp, *litpe;
00833 
00834         litp = litpool;
00835         for(litpe = litp + nliterals; litp < litpe; litp++)
00836                 if (litp->litnum ==  m)
00837                         return litp->cds[0];
00838         Fatal("findconst failure!");
00839         return 0;
00840         }

01353 {
01354         sprintf(buf, fl_fmt_string, x);
01355         return buf;
01356         }

00850 {
00851         /* special handling for conversions, ichar and character*1 */
00852         register expptr lp;
00853         register union Expression *Offset;
00854         register char *cp;
00855         int lt;
00856         char buf[8], *s;
00857         unsigned int k;
00858         Namep np;
00859         Addrp ap;
00860 
00861         if (!(lp = e->leftp))   /* possible with erroneous Fortran */
00862                 return 1;
00863         lt = lp->headblock.vtype;
00864         if (lt == TYCHAR) {
00865                 switch(lp->tag) {
00866                         case TNAME:
00867                                 nice_printf(fp, "*(unsigned char *)");
00868                                 out_name(fp, (Namep)lp);
00869                                 return 1;
00870                         case TCONST:
00871  tconst:
00872                                 cp = lp->constblock.Const.ccp;
00873  tconst1:
00874                                 k = *(unsigned char *)cp;
00875                                 if (k < 128) { /* ASCII character */
00876                                         sprintf(buf, chr_fmt[k], k);
00877                                         nice_printf(fp, "'%s'", buf);
00878                                         }
00879                                 else
00880                                         nice_printf(fp, "%d", k);
00881                                 return 1;
00882                         case TADDR:
00883                                 switch(lp->addrblock.vstg) {
00884                                     case STGMEMNO:
00885                                         if (halign && e->vtype != TYCHAR) {
00886                                                 nice_printf(fp, "*(%s *)",
00887                                                     c_type_decl(e->vtype,0));
00888                                                 expr_out(fp, lp);
00889                                                 return 1;
00890                                                 }
00891                                         cp = findconst(lp->addrblock.memno);
00892                                         goto tconst1;
00893                                     case STGCONST:
00894                                         goto tconst;
00895                                     }
00896                                 lp->addrblock.vtype = tyint;
00897                                 Offset = lp->addrblock.memoffset;
00898                                 switch(lp->addrblock.uname_tag) {
00899                                   case UNAM_REF:
00900                                         nice_printf(fp, "*(unsigned char *)");
00901                                         return 0;
00902                                   case UNAM_NAME:
00903                                         np = lp->addrblock.user.name;
00904                                         if (ONEOF(np->vstg,
00905                                             M(STGCOMMON)|M(STGEQUIV)))
00906                                                 Offset = mkexpr(OPMINUS, Offset,
00907                                                         ICON(np->voffset));
00908                                         }
00909                                 lp->addrblock.memoffset = Offset ?
00910                                         mkexpr(OPSTAR, Offset,
00911                                                 ICON(typesize[tyint]))
00912                                         : ICON(0);
00913                                 lp->addrblock.isarray = 1;
00914                                 /* STGCOMMON or STGEQUIV would cause */
00915                                 /* voffset to be added in a second time */
00916                                 lp->addrblock.vstg = STGUNKNOWN;
00917                                 nice_printf(fp, "*(unsigned char *)&");
00918                                 return 0;
00919                         default:
00920                                 badtag("opconv_fudge", lp->tag);
00921                         }
00922                 }
00923         if (lt != e->vtype) {
00924                 s = c_type_decl(e->vtype, 0);
00925                 if (ISCOMPLEX(lt)) {
00926                         np = (Namep)e->leftp;
00927                         switch(np->tag) {
00928                           case TNAME:
00929                                 nice_printf(fp, "(%s) %s.r", s,
00930                                         np->cvarname);
00931                                 return 1;
00932                           case TADDR:
00933                                 ap = (Addrp)np;
00934                                 switch(ap->uname_tag) {
00935                                   case UNAM_IDENT:
00936                                         nice_printf(fp, "(%s) %s.r", s,
00937                                                 ap->user.ident);
00938                                         return 1;
00939                                   case UNAM_NAME:
00940                                         nice_printf(fp, "(%s) ", s);
00941                                         out_addr(fp, ap);
00942                                         nice_printf(fp, ".r");
00943                                         return 1;
00944                                   }
00945                           default:
00946                                 fatali("Unexpected tag %d in opconv_fudge",
00947                                         np->tag);
00948                           }
00949                         }
00950                 nice_printf(fp, "(%s) ", s);
00951                 }
00952         return 0;
00953         }

00553 {
00554         extern Extsym *extsymtab;
00555         int was_array = 0;
00556         char *s;
00557 
00558 
00559         if (addrp == NULL)
00560                 return;
00561         if (doin_setbound
00562                         && addrp->vstg == STGARG
00563                         && addrp->vtype != TYCHAR
00564                         && ISICON(addrp->memoffset)
00565                         && !addrp->memoffset->constblock.Const.ci)
00566                 nice_printf(fp, "*");
00567 
00568         switch (addrp -> uname_tag) {
00569             case UNAM_REF:
00570                 nice_printf(fp, "%s_%s(", addrp->user.name->cvarname,
00571                         addrp->cmplx_sub ? "subscr" : "ref");
00572                 out_args(fp, addrp->memoffset);
00573                 nice_printf(fp, ")");
00574                 return;
00575             case UNAM_NAME:
00576                 out_name (fp, addrp -> user.name);
00577                 break;
00578             case UNAM_IDENT:
00579                 if (*(s = addrp->user.ident) == ' ') {
00580                         if (multitype)
00581                                 nice_printf(fp, "%s",
00582                                         xretslot[addrp->vtype]->user.ident);
00583                         else
00584                                 nice_printf(fp, "%s", s+1);
00585                         }
00586                 else {
00587                         nice_printf(fp, "%s", s);
00588                         }
00589                 break;
00590             case UNAM_CHARP:
00591                 nice_printf(fp, "%s", addrp->user.Charp);
00592                 break;
00593             case UNAM_EXTERN:
00594                 extern_out (fp, &extsymtab[addrp -> memno]);
00595                 break;
00596             case UNAM_CONST:
00597                 switch(addrp->vstg) {
00598                         case STGCONST:
00599                                 out_const(fp, (Constp)addrp);
00600                                 break;
00601                         case STGMEMNO:
00602                                 output_literal (fp, addrp->memno,
00603                                         (Constp)addrp);
00604                                 break;
00605                         default:
00606                         Fatal("unexpected vstg in out_addr");
00607                         }
00608                 break;
00609             case UNAM_UNKNOWN:
00610             default:
00611                 nice_printf (fp, "Unknown Addrp");
00612                 break;
00613         } /* switch */
00614 
00615 /* It's okay to just throw in the brackets here because they have a
00616    precedence level of 15, the highest value.  */
00617 
00618     if ((addrp->uname_tag == UNAM_NAME && addrp->user.name->vdim
00619                         || addrp->ntempelt > 1 || addrp->isarray)
00620         && addrp->vtype != TYCHAR) {
00621         expptr offset;
00622 
00623         was_array = 1;
00624 
00625         offset = addrp -> memoffset;
00626         addrp->memoffset = 0;
00627         if (ONEOF(addrp->vstg, M(STGCOMMON)|M(STGEQUIV))
00628                 && addrp -> uname_tag == UNAM_NAME
00629                 && !addrp->skip_offset)
00630             offset = mkexpr (OPMINUS, offset, mkintcon (
00631                     addrp -> user.name -> voffset));
00632 
00633         nice_printf (fp, "[");
00634 
00635         offset = mkexpr (OPSLASH, offset,
00636                 ICON (typesize[addrp -> vtype] * (addrp -> Field ? 2 : 1)));
00637         expr_out (fp, offset);
00638         nice_printf (fp, "]");
00639         }
00640 
00641 /* Check for structure field reference */
00642 
00643     if (addrp -> Field && addrp -> uname_tag != UNAM_CONST &&
00644             addrp -> uname_tag != UNAM_UNKNOWN) {
00645         if (oneof_stg((addrp -> uname_tag == UNAM_NAME ? addrp -> user.name :
00646                 (Namep) NULL), addrp -> vstg, M(STGARG)|M(STGEQUIV))
00647                 && !was_array && (addrp->vclass != CLPROC || !multitype))
00648             nice_printf (fp, "->%s", addrp -> Field);
00649         else
00650             nice_printf (fp, ".%s", addrp -> Field);
00651     } /* if */
00652 
00653 /* Check for character subscripting */
00654 
00655     if (addrp->vtype == TYCHAR &&
00656             (addrp->vclass != CLPROC || addrp->uname_tag == UNAM_NAME
00657                         && addrp->user.name->vprocclass == PTHISPROC) &&
00658             addrp -> memoffset &&
00659             (addrp -> uname_tag != UNAM_NAME ||
00660              addrp -> user.name -> vtype == TYCHAR) &&
00661             (!ISICON (addrp -> memoffset) ||
00662              (addrp -> memoffset -> constblock.Const.ci))) {
00663 
00664         int use_paren = 0;
00665         expptr e = addrp -> memoffset;
00666 
00667         if (!e)
00668                 return;
00669         addrp->memoffset = 0;
00670 
00671         if (ONEOF(addrp->vstg, M(STGCOMMON)|M(STGEQUIV))
00672          && addrp -> uname_tag == UNAM_NAME) {
00673             e = mkexpr (OPMINUS, e, mkintcon (addrp -> user.name -> voffset));
00674 
00675 /* mkexpr will simplify it to zero if possible */
00676             if (e->tag == TCONST && e->constblock.Const.ci == 0)
00677                 return;
00678         } /* if addrp -> vstg == STGCOMMON */
00679 
00680 /* In the worst case, parentheses might be needed OUTSIDE the expression,
00681    too.  But since I think this subscripting can only appear as a
00682    parameter in a procedure call, I don't think outside parens will ever
00683    be needed.  INSIDE parens are handled below */
00684 
00685         nice_printf (fp, " + ");
00686         if (e -> tag == TEXPR) {
00687             int arg_prec = op_precedence (e -> exprblock.opcode);
00688             int prec = op_precedence (OPPLUS);
00689             use_paren = arg_prec && (arg_prec < prec || (arg_prec == prec &&
00690                     is_left_assoc (OPPLUS)));
00691         } /* if e -> tag == TEXPR */
00692         if (use_paren) nice_printf (fp, "(");
00693         expr_out (fp, e);
00694         if (use_paren) nice_printf (fp, ")");
00695     } /* if */
00696 } /* out_addr */

00267 {
00268     if (expr)
00269         expr_out (outfile, expr);
00270 
00271     nice_printf (outfile, ";\n");
00272 } /* out_and_free_statement */

00527 {
00528         chainp arglist;
00529 
00530         if(ep->tag != TLIST)
00531                 badtag("out_args", ep->tag);
00532         for(arglist = ep->listblock.listp;;) {
00533                 expr_out(fp, (expptr)arglist->datap);
00534                 arglist->datap = 0;
00535                 if (!(arglist = arglist->nextp))
00536                         break;
00537                 nice_printf(fp, ", ");
00538                 }
00539         }

01480 {
01481     chainp value;
01482     Namep namep;
01483     int k;
01484 
01485     if (expr == (expptr) NULL) {
01486         err ("out_asgoto:  NULL variable expr");
01487         return;
01488     } /* if expr */
01489 
01490     nice_printf (outfile, Ansi ? "switch (" : "switch ((int)"); /*)*/
01491     expr_out (outfile, expr);
01492     nice_printf (outfile, ") {\n");
01493     next_tab (outfile);
01494 
01495 /* The initial addrp value will be stored as a namep pointer */
01496 
01497     switch(expr->tag) {
01498         case TNAME:
01499                 /* local variable */
01500                 namep = &expr->nameblock;
01501                 break;
01502         case TEXPR:
01503                 if (expr->exprblock.opcode == OPWHATSIN
01504                  && expr->exprblock.leftp->tag == TNAME)
01505                         /* argument */
01506                         namep = &expr->exprblock.leftp->nameblock;
01507                 else
01508                         goto bad;
01509                 break;
01510         case TADDR:
01511                 if (expr->addrblock.uname_tag == UNAM_NAME) {
01512                         /* initialized local variable */
01513                         namep = expr->addrblock.user.name;
01514                         break;
01515                         }
01516         default:
01517  bad:
01518                 err("out_asgoto:  bad expr");
01519                 return;
01520         }
01521 
01522     for(k = 0, value = namep -> varxptr.assigned_values; value;
01523             value = value->nextp, k++) {
01524         nice_printf (outfile, "case %d: goto %s;\n", k,
01525                 user_label((long)value->datap));
01526     } /* for value */
01527     prev_tab (outfile);
01528 
01529     nice_printf (outfile, "}\n");
01530 } /* out_asgoto */

01097 {
01098     chainp arglist;             /* Pointer to any actual arguments */
01099     chainp cp;                  /* Iterator over argument lists */
01100     Addrp ret_val = (Addrp) NULL;
01101                                 /* Function return value buffer, if any is
01102                                    required */
01103     int byvalue;                /* True iff we're calling a C library
01104                                    routine */
01105     int done_once;              /* Used for writing commas to   outfile   */
01106     int narg, t;
01107     register expptr q;
01108     long L;
01109     Argtypes *at;
01110     Atype *A, *Ac;
01111     Namep np;
01112     extern int forcereal;
01113 
01114 /* Don't use addresses if we're calling a C function */
01115 
01116     byvalue = op == OPCCALL;
01117 
01118     if (args)
01119         arglist = args -> listblock.listp;
01120     else
01121         arglist = CHNULL;
01122 
01123 /* If this is a CHARACTER function, the first argument is the result */
01124 
01125     if (ftype == TYCHAR)
01126         if (ISICON (len)) {
01127             ret_val = (Addrp) (arglist -> datap);
01128             arglist = arglist -> nextp;
01129         } else {
01130             err ("adjustable character function");
01131             return;
01132         } /* else */
01133 
01134 /* If this is a COMPLEX function, the first argument is the result */
01135 
01136     else if (ISCOMPLEX (ftype)) {
01137         ret_val = (Addrp) (arglist -> datap);
01138         arglist = arglist -> nextp;
01139     } /* if ISCOMPLEX */
01140 
01141     /* prepare to cast procedure parameters -- set A if we know how */
01142     np = name->tag == TEXPR && name->exprblock.opcode == OPWHATSIN
01143         ? (Namep)name->exprblock.leftp : (Namep)name;
01144 
01145     A = Ac = 0;
01146     if (np->tag == TNAME && (at = np->arginfo)) {
01147         if (at->nargs > 0)
01148                 A = at->atypes;
01149         if (Ansi && (at->defined || at->nargs > 0))
01150                 Ac = at->atypes;
01151         }
01152 
01153 /* Now we can actually start to write out the function invocation */
01154 
01155     if (ftype == TYREAL && forcereal)
01156         nice_printf(outfile, "(real)");
01157     if (name -> tag == TEXPR && name -> exprblock.opcode == OPWHATSIN) {
01158         nice_printf (outfile, "(");
01159         expr_out (outfile, name);
01160         nice_printf (outfile, ")");
01161         }
01162     else
01163         expr_out(outfile, name);
01164 
01165     nice_printf(outfile, "(");
01166 
01167     if (ret_val) {
01168         if (ISCOMPLEX (ftype))
01169             nice_printf (outfile, "&");
01170         expr_out (outfile, (expptr) ret_val);
01171         if (Ac)
01172                 Ac++;
01173 
01174 /* The length of the result of a character function is the second argument */
01175 /* It should be in place from putcall(), so we won't touch it explicitly */
01176 
01177     } /* if ret_val */
01178     done_once = ret_val ? TRUE : FALSE;
01179 
01180 /* Now run through the named arguments */
01181 
01182     narg = -1;
01183     for (cp = arglist; cp; cp = cp -> nextp, done_once = TRUE) {
01184 
01185         if (done_once)
01186             nice_printf (outfile, ", ");
01187         narg++;
01188 
01189         if (!( q = (expptr)cp->datap) )
01190                 continue;
01191 
01192         if (q->tag == TADDR) {
01193                 if (q->addrblock.vtype > TYERROR) {
01194                         /* I/O block */
01195                         nice_printf(outfile, "&%s", q->addrblock.user.ident);
01196                         continue;
01197                         }
01198                 if (!byvalue && q->addrblock.isarray
01199                 && q->addrblock.vtype != TYCHAR
01200                 && q->addrblock.memoffset->tag == TCONST) {
01201 
01202                         /* check for 0 offset -- after */
01203                         /* correcting for equivalence. */
01204                         L = q->addrblock.memoffset->constblock.Const.ci;
01205                         if (ONEOF(q->addrblock.vstg, M(STGCOMMON)|M(STGEQUIV))
01206                                         && q->addrblock.uname_tag == UNAM_NAME)
01207                                 L -= q->addrblock.user.name->voffset;
01208                         if (L)
01209                                 goto skip_deref;
01210 
01211                         if (Ac && narg < at->dnargs
01212                          && q->headblock.vtype != (t = Ac[narg].type)
01213                          && t > TYADDR && t < TYSUBR)
01214                                 nice_printf(outfile, "(%s*)", typename[t]);
01215 
01216                         /* &x[0] == x */
01217                         /* This also prevents &sizeof(doublereal)[0] */
01218 
01219                         switch(q->addrblock.uname_tag) {
01220                             case UNAM_NAME:
01221                                 out_name(outfile, q->addrblock.user.name);
01222                                 continue;
01223                             case UNAM_IDENT:
01224                                 nice_printf(outfile, "%s",
01225                                         q->addrblock.user.ident);
01226                                 continue;
01227                             case UNAM_CHARP:
01228                                 nice_printf(outfile, "%s",
01229                                         q->addrblock.user.Charp);
01230                                 continue;
01231                             case UNAM_EXTERN:
01232                                 extern_out(outfile,
01233                                         &extsymtab[q->addrblock.memno]);
01234                                 continue;
01235                             }
01236                         }
01237                 }
01238 
01239 /* Skip over the dereferencing operator generated only for the
01240    intermediate file */
01241  skip_deref:
01242         if (q -> tag == TEXPR && q -> exprblock.opcode == OPWHATSIN)
01243             q = q -> exprblock.leftp;
01244 
01245         if (q->headblock.vclass == CLPROC) {
01246             if (Castargs && (q->tag != TNAME
01247                                 || q->nameblock.vprocclass != PTHISPROC)
01248                          && (q->tag != TADDR
01249                                 || q->addrblock.uname_tag != UNAM_NAME
01250                                 || q->addrblock.user.name->vprocclass
01251                                                                 != PTHISPROC))
01252                 {
01253                 if (A && (t = A[narg].type) >= 200)
01254                         t %= 100;
01255                 else {
01256                         t = q->headblock.vtype;
01257                         if (q->tag == TNAME && q->nameblock.vimpltype)
01258                                 t = TYUNKNOWN;
01259                         }
01260                 nice_printf(outfile, "(%s)", usedcasts[t] = casttypes[t]);
01261                 }
01262             }
01263         else if (Ac && narg < at->dnargs
01264                 && q->headblock.vtype != (t = Ac[narg].type)
01265                 && t > TYADDR && t < TYSUBR)
01266                 nice_printf(outfile, "(%s*)", typename[t]);
01267 
01268         if ((q -> tag == TADDR || q-> tag == TNAME) &&
01269                 (byvalue || q -> headblock.vstg != STGREG)) {
01270             if (q -> headblock.vtype != TYCHAR)
01271               if (byvalue) {
01272 
01273                 if (q -> tag == TADDR &&
01274                         q -> addrblock.uname_tag == UNAM_NAME &&
01275                         ! q -> addrblock.user.name -> vdim &&
01276                         oneof_stg(q -> addrblock.user.name, q -> addrblock.vstg,
01277                                         M(STGARG)|M(STGEQUIV)) &&
01278                         ! ISCOMPLEX(q->addrblock.user.name->vtype))
01279                     nice_printf (outfile, "*");
01280                 else if (q -> tag == TNAME
01281                         && oneof_stg(&q->nameblock, q -> nameblock.vstg,
01282                                 M(STGARG)|M(STGEQUIV))
01283                         && !(q -> nameblock.vdim))
01284                     nice_printf (outfile, "*");
01285 
01286               } else {
01287                 expptr memoffset;
01288 
01289                 if (q->tag == TADDR &&
01290                         !ONEOF (q -> addrblock.vstg, M(STGEXT)|M(STGLENG))
01291                         && (
01292                         ONEOF(q->addrblock.vstg,
01293                                 M(STGCOMMON)|M(STGEQUIV)|M(STGMEMNO))
01294                         || ((memoffset = q->addrblock.memoffset)
01295                                 && (!ISICON(memoffset)
01296                                 || memoffset->constblock.Const.ci)))
01297                         || ONEOF(q->addrblock.vstg,
01298                                         M(STGINIT)|M(STGAUTO)|M(STGBSS))
01299                                 && !q->addrblock.isarray)
01300                     nice_printf (outfile, "&");
01301                 else if (q -> tag == TNAME
01302                         && !oneof_stg(&q->nameblock, q -> nameblock.vstg,
01303                                 M(STGARG)|M(STGEXT)|M(STGEQUIV)))
01304                     nice_printf (outfile, "&");
01305             } /* else */
01306 
01307             expr_out (outfile, q);
01308         } /* if q -> tag == TADDR || q -> tag == TNAME */
01309 
01310 /* Might be a Constant expression, e.g. string length, character constants */
01311 
01312         else if (q -> tag == TCONST) {
01313             if (tyioint == TYLONG)
01314                 Longfmt = "%ldL";
01315             out_const(outfile, &q->constblock);
01316             Longfmt = "%ld";
01317             }
01318 
01319 /* Must be some other kind of expression, or register var, or constant.
01320    In particular, this is likely to be a temporary variable assignment
01321    which was generated in p1put_call */
01322 
01323         else if (!ISCOMPLEX (q -> headblock.vtype) && !ISCHAR (q)){
01324             int use_paren = q -> tag == TEXPR &&
01325                     op_precedence (q -> exprblock.opcode) <=
01326                     op_precedence (OPCOMMA);
01327 
01328             if (use_paren) nice_printf (outfile, "(");
01329             expr_out (outfile, q);
01330             if (use_paren) nice_printf (outfile, ")");
01331         } /* if !ISCOMPLEX */
01332         else
01333             err ("out_call:  unknown parameter");
01334 
01335     } /* for (cp = arglist */
01336 
01337     if (arglist)
01338         frchain (&arglist);
01339 
01340     nice_printf (outfile, ")");
01341 
01342 } /* out_call */

00458 {
00459     static char real_buf[50], imag_buf[50];
00460     unsigned int k;
00461     int type = cp->vtype;
00462 
00463     switch (type) {
00464         case TYINT1:
00465         case TYSHORT:
00466             nice_printf (fp, "%ld", cp->Const.ci);      /* don't cast ci! */
00467             break;
00468         case TYLONG:
00469 #ifdef TYQUAD
00470         case TYQUAD:
00471 #endif
00472             nice_printf (fp, Longfmt, cp->Const.ci);    /* don't cast ci! */
00473             break;
00474         case TYREAL:
00475             nice_printf(fp, "%s", flconst(real_buf, cpd(0)));
00476             break;
00477         case TYDREAL:
00478             nice_printf(fp, "%s", cpd(0));
00479             break;
00480         case TYCOMPLEX:
00481             nice_printf(fp, cm_fmt_string, flconst(real_buf, cpd(0)),
00482                         flconst(imag_buf, cpd(1)));
00483             break;
00484         case TYDCOMPLEX:
00485             nice_printf(fp, dcm_fmt_string, cpd(0), cpd(1));
00486             break;
00487         case TYLOGICAL1:
00488         case TYLOGICAL2:
00489         case TYLOGICAL:
00490             nice_printf (fp, "%s", cp->Const.ci ? "TRUE_" : "FALSE_");
00491             break;
00492         case TYCHAR: {
00493             char *c = cp->Const.ccp, *ce;
00494 
00495             if (c == NULL) {
00496                 nice_printf (fp, "\"\"");
00497                 break;
00498             } /* if c == NULL */
00499 
00500             nice_printf (fp, "\"");
00501             ce = c + cp->vleng->constblock.Const.ci;
00502             while(c < ce) {
00503                 k = *(unsigned char *)c++;
00504                 nice_printf(fp, str_fmt[k], k);
00505                 }
00506             for(k = cp->Const.ccp1.blanks; k > 0; k--)
00507                 nice_printf(fp, " ");
00508             nice_printf (fp, "\"");
00509             break;
00510         } /* case TYCHAR */
00511         default:
00512             erri ("out_const:  bad type '%d'", (int) type);
00513             break;
00514     } /* switch */
00515 
00516 } /* out_const */

01575 {
01576     prev_tab (outfile);
01577     output_rbrace(outfile, "} else {\n");
01578     next_tab (outfile);
01579 } /* out_else */

01701 {
01702     prev_tab (outfile);
01703     nice_printf (outfile, "}\n");
01704 } /* out_end_for */

01682 {
01683     nice_printf (outfile, "for (");
01684     expr_out (outfile, init);
01685     nice_printf (outfile, "; ");
01686     expr_out (outfile, test);
01687     nice_printf (outfile, "; ");
01688     expr_out (outfile, inc);
01689     nice_printf (outfile, ") {\n");
01690     next_tab (outfile);
01691 } /* out_for */

01540 {
01541     nice_printf (outfile, "if (");
01542     expr_out (outfile, expr);
01543     nice_printf (outfile, ") {\n");
01544     next_tab (outfile);
01545 } /* out_if */

01383 {
01384     extern int tab_size;
01385     register char *s;
01386 
01387     s = "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789_+-.";
01388     while(*s)
01389         tr_tab[*s++] = 3;
01390     tr_tab['>'] = 1;
01391 
01392         opeqable[OPPLUS] = 1;
01393         opeqable[OPMINUS] = 1;
01394         opeqable[OPSTAR] = 1;
01395         opeqable[OPSLASH] = 1;
01396         opeqable[OPMOD] = 1;
01397         opeqable[OPLSHIFT] = 1;
01398         opeqable[OPBITAND] = 1;
01399         opeqable[OPBITXOR] = 1;
01400         opeqable[OPBITOR ] = 1;
01401 
01402 
01403 /* Set the output format for both types of floating point constants */
01404 
01405     if (fl_fmt_string == NULL || *fl_fmt_string == '\0')
01406         fl_fmt_string = Ansi == 1 ? "%sf" : "(float)%s";
01407 
01408     if (db_fmt_string == NULL || *db_fmt_string == '\0')
01409         db_fmt_string = "%.17g";
01410 
01411 /* Set the output format for both types of complex constants.  They will
01412    have string parameters rather than float or double so that the decimal
01413    point may be added to the strings generated by the {db,fl}_fmt_string
01414    formats above */
01415 
01416     if (cm_fmt_string == NULL || *cm_fmt_string == '\0') {
01417         cm_fmt_string = "{%s,%s}";
01418     } /* if cm_fmt_string == NULL */
01419 
01420     if (dcm_fmt_string == NULL || *dcm_fmt_string == '\0') {
01421         dcm_fmt_string = "{%s,%s}";
01422     } /* if dcm_fmt_string == NULL */
01423 
01424     tab_size = 4;
01425 } /* out_init */

00423 {
00424     extern int usedefsforcommon;
00425     Extsym *comm;
00426 
00427     if (namep == NULL)
00428         return;
00429 
00430 /* DON'T want to use oneof_stg() here; need to find the right common name
00431    */
00432 
00433     if (namep->vstg == STGCOMMON && !namep->vcommequiv && !usedefsforcommon) {
00434         comm = &extsymtab[namep->vardesc.varno];
00435         extern_out(fp, comm);
00436         nice_printf(fp, "%d.", comm->curno);
00437     } /* if namep -> vstg == STGCOMMON */
00438 
00439     if (namep->vprocclass == PTHISPROC && namep->vtype != TYSUBR)
00440         nice_printf(fp, xretslot[namep->vtype]->user.ident);
00441     else
00442         nice_printf (fp, "%s", namep->cvarname);
00443 } /* out_name */

00757 {
00758     chainp arg_list;
00759 
00760     if (listp == (struct Listblock *) NULL || listp -> listp == (chainp) NULL)
00761         return;
00762 
00763     nice_printf (fp, "(");
00764 
00765     for (arg_list = listp -> listp; arg_list; arg_list = arg_list -> nextp) {
00766         expr_out (fp, (expptr) arg_list -> datap);
00767         if (arg_list -> nextp != (chainp) NULL)
00768 
00769 /* Might want to add a hook in here to accomodate the style setting which
00770    wants spaces after commas */
00771 
00772             nice_printf (fp, ",");
00773     } /* for arg_list */
00774 
00775     nice_printf (fp, ")");
00776 } /* output_arg_list */

00964 {
00965     char *format;
00966     extern table_entry opcode_table[];
00967     int prec;
00968 
00969     if (e == NULL || e -> tag != TEXPR)
00970         return;
00971 
00972 /* Instead of writing a huge switch, I've incorporated the output format
00973    into a table.  Things like "%l" and "%r" stand for the left and
00974    right subexpressions.  This should allow both prefix and infix
00975    functions to be specified (e.g. "(%l * %r", "z_div (%l, %r").  Of
00976    course, I should REALLY think out the ramifications of writing out
00977    straight text, as opposed to some intermediate format, which could
00978    figure out and optimize on the the number of required blanks (we don't
00979    want "x - (-y)" to become "x --y", for example).  Special cases (such as
00980    incomplete implementations) could still be implemented as part of the
00981    switch, they will just have some dummy value instead of the string
00982    pattern.  Another difficulty is the fact that the complex functions
00983    will differ from the integer and real ones */
00984 
00985 /* Handle a special case.  We don't want to output "x + - 4", or "y - - 3"
00986 */
00987     if ((e -> opcode == OPPLUS || e -> opcode == OPMINUS) &&
00988             e -> rightp && e -> rightp -> tag == TCONST &&
00989             isnegative_const (&(e -> rightp -> constblock)) &&
00990             is_negatable (&(e -> rightp -> constblock))) {
00991 
00992         e -> opcode = (e -> opcode == OPPLUS) ? OPMINUS : OPPLUS;
00993         negate_const (&(e -> rightp -> constblock));
00994     } /* if e -> opcode == PLUS or MINUS */
00995 
00996     prec = op_precedence (e -> opcode);
00997     format = op_format (e -> opcode);
00998 
00999     if (format != SPECIAL_FMT) {
01000         while (*format) {
01001             if (*format == '%') {
01002                 int arg_prec, use_paren = 0;
01003                 expptr lp, rp;
01004 
01005                 switch (*(format + 1)) {
01006                     case 'l':
01007                         lp = e->leftp;
01008                         if (lp && lp->tag == TEXPR) {
01009                             arg_prec = op_precedence(lp->exprblock.opcode);
01010 
01011                             use_paren = arg_prec &&
01012                                 (arg_prec < prec || (arg_prec == prec &&
01013                                     is_right_assoc (prec)));
01014                         } /* if e -> leftp */
01015                         if (e->opcode == OPCONV && opconv_fudge(fp,e))
01016                                 break;
01017                         if (use_paren)
01018                             nice_printf (fp, "(");
01019                         expr_out(fp, lp);
01020                         if (use_paren)
01021                             nice_printf (fp, ")");
01022                         break;
01023                     case 'r':
01024                         rp = e->rightp;
01025                         if (rp && rp->tag == TEXPR) {
01026                             arg_prec = op_precedence(rp->exprblock.opcode);
01027 
01028                             use_paren = arg_prec &&
01029                                 (arg_prec < prec || (arg_prec == prec &&
01030                                     is_left_assoc (prec)));
01031                             use_paren = use_paren ||
01032                                 (rp->exprblock.opcode == OPNEG
01033                                 && prec >= op_precedence(OPMINUS));
01034                         } /* if e -> rightp */
01035                         if (use_paren)
01036                             nice_printf (fp, "(");
01037                         expr_out(fp, rp);
01038                         if (use_paren)
01039                             nice_printf (fp, ")");
01040                         break;
01041                     case '\0':
01042                     case '%':
01043                         nice_printf (fp, "%%");
01044                         break;
01045                     default:
01046                         erri ("output_binary: format err: '%%%c' illegal",
01047                                 (int) *(format + 1));
01048                         break;
01049                 } /* switch */
01050                 format += 2;
01051             } else
01052                 nice_printf (fp, "%c", *format++);
01053         } /* while *format */
01054     } else {
01055 
01056 /* Handle Special cases of formatting */
01057 
01058         switch (e -> opcode) {
01059                 case OPCCALL:
01060                 case OPCALL:
01061                         out_call (fp, (int) e -> opcode, e -> vtype,
01062                                         e -> vleng, e -> leftp, e -> rightp);
01063                         break;
01064 
01065                 case OPCOMMA_ARG:
01066                         doin_setbound = 1;
01067                         nice_printf(fp, "(");
01068                         expr_out(fp, e->leftp);
01069                         nice_printf(fp, ", &");
01070                         doin_setbound = 0;
01071                         expr_out(fp, e->rightp);
01072                         nice_printf(fp, ")");
01073                         break;
01074 
01075                 case OPADDR:
01076                 default:
01077                         nice_printf (fp, "Sorry, can't format OPCODE '%d'",
01078                                 e -> opcode);
01079                         break;
01080                 }
01081 
01082     } /* else */
01083 } /* output_binary */

01454 {
01455     int did_one = 0;
01456     chainp elts;
01457 
01458     nice_printf (fp, "(");
01459     if (listp)
01460         for (elts = listp -> listp; elts; elts = elts -> nextp) {
01461             if (elts -> datap) {
01462                 if (did_one)
01463                     nice_printf (fp, ", ");
01464                 expr_out (fp, (expptr) elts -> datap);
01465                 did_one = 1;
01466             } /* if elts -> datap */
01467         } /* for elts */
01468     nice_printf (fp, ")");
01469 } /* output_list */

00708 {
00709     struct Literal *litp, *lastlit;
00710 
00711     lastlit = litpool + nliterals;
00712 
00713     for (litp = litpool; litp < lastlit; litp++) {
00714         if (litp -> litnum == memno)
00715             break;
00716     } /* for litp */
00717 
00718     if (litp >= lastlit)
00719         out_const (fp, cp);
00720     else {
00721         nice_printf (fp, "%s", lit_name (litp));
00722         litp->lituse++;
00723         }
00724 } /* output_literal */

00735 {
00736     if (primp == NULL)
00737         return;
00738 
00739     out_name (fp, primp -> namep);
00740     if (primp -> argsp)
00741         output_arg_list (fp, primp -> argsp);
00742 
00743     if (primp -> fcharp != (expptr) NULL || primp -> lcharp != (expptr) NULL)
00744         nice_printf (fp, "Sorry, no substrings yet");
00745 }

01555 {
01556         extern int last_was_label;
01557         register char *fmt;
01558 
01559         if (last_was_label) {
01560                 last_was_label = 0;
01561                 fmt = ";%s";
01562                 }
01563         else
01564                 fmt = "%s";
01565         nice_printf(outfile, fmt, s);
01566         }

00788 {
00789     if (e == NULL)
00790         return;
00791 
00792     switch (e -> opcode) {
00793         case OPNEG:
00794                 if (e->vtype == TYREAL && dneg) {
00795                         e->opcode = OPNEG_KLUDGE;
00796                         output_binary(fp,e);
00797                         e->opcode = OPNEG;
00798                         break;
00799                         }
00800         case OPNEG1:
00801         case OPNOT:
00802         case OPABS:
00803         case OPBITNOT:
00804         case OPWHATSIN:
00805         case OPPREINC:
00806         case OPPREDEC:
00807         case OPADDR:
00808         case OPIDENTITY:
00809         case OPCHARCAST:
00810         case OPDABS:
00811             output_binary (fp, e);
00812             break;
00813         case OPCALL:
00814         case OPCCALL:
00815             nice_printf (fp, "Sorry, no OPCALL yet");
00816             break;
00817         default:
00818             erri ("output_unary: bad opcode", (int) e -> opcode);
00819             break;
00820     } /* switch */
00821 } /* output_unary */

00389 {
00390     if (!e1 || !e2)
00391         return !e1 && !e2;
00392 
00393     if (e1 -> tag != e2 -> tag || e1 -> headblock.vtype != e2 -> headblock.vtype)
00394         return 0;
00395 
00396     switch (e1 -> tag) {
00397         case TEXPR:
00398             if (e1 -> exprblock.opcode != e2 -> exprblock.opcode)
00399                 return 0;
00400 
00401             return same_expr (e1 -> exprblock.leftp, e2 -> exprblock.leftp) &&
00402                    same_expr (e1 -> exprblock.rightp, e2 -> exprblock.rightp);
00403         case TNAME:
00404         case TADDR:
00405             return same_ident (e1, e2);
00406         case TCONST:
00407             return sameconst(&e1->constblock, &e2->constblock);
00408         default:
00409             return 0;
00410     } /* switch */
00411 } /* same_expr */

00284 {
00285     if (!left || !right)
00286         return 0;
00287 
00288     if (left -> tag == TNAME && right -> tag == TNAME && left == right)
00289         return 1;
00290 
00291     if (left -> tag == TADDR && right -> tag == TADDR &&
00292             left -> addrblock.uname_tag == right -> addrblock.uname_tag)
00293         switch (left -> addrblock.uname_tag) {
00294             case UNAM_REF:
00295             case UNAM_NAME:
00296 
00297 /* Check for array subscripts */
00298 
00299                 if (left -> addrblock.user.name -> vdim ||
00300                         right -> addrblock.user.name -> vdim)
00301                     if (left -> addrblock.user.name !=
00302                             right -> addrblock.user.name ||
00303                             !same_expr (left -> addrblock.memoffset,
00304                             right -> addrblock.memoffset))
00305                         return 0;
00306 
00307                 return same_ident ((expptr) (left -> addrblock.user.name),
00308                         (expptr) right -> addrblock.user.name);
00309             case UNAM_IDENT:
00310                 return strcmp(left->addrblock.user.ident,
00311                                 right->addrblock.user.ident) == 0;
00312             case UNAM_CHARP:
00313                 return strcmp(left->addrblock.user.Charp,
00314                                 right->addrblock.user.Charp) == 0;
00315             default:
00316                 return 0;
00317         } /* switch */
00318 
00319     if (left->tag == TEXPR && left->exprblock.opcode == OPWHATSIN
00320         && right->tag == TEXPR && right->exprblock.opcode == OPWHATSIN)
00321                 return same_ident(left->exprblock.leftp,
00322                                  right->exprblock.leftp);
00323 
00324     return 0;
00325 } /* same_ident */

00353 {
00354         switch(c1->vtype) {
00355                 case TYCOMPLEX:
00356                 case TYDCOMPLEX:
00357                         if (!samefpconst(c1,c2,1))
00358                                 return 0;
00359                 case TYREAL:
00360                 case TYDREAL:
00361                         return samefpconst(c1,c2,0);
00362                 case TYCHAR:
00363                         return c1->Const.ccp1.blanks == c2->Const.ccp1.blanks
00364                             &&     c1->vleng->constblock.Const.ci
00365                                 == c2->vleng->constblock.Const.ci
00366                             && !memcmp(c1->Const.ccp, c2->Const.ccp,
00367                                         (int)c1->vleng->constblock.Const.ci);
00368                 case TYSHORT:
00369                 case TYINT:
00370                 case TYLOGICAL:
00371                         return c1->Const.ci == c2->Const.ci;
00372                 }
00373         err("unexpected type in sameconst");
00374         return 0;
00375         }

00336 {
00337         char *s1, *s2;
00338         if (!c1->vstg && !c2->vstg)
00339                 return c1->Const.cd[n] == c2->Const.cd[n];
00340         s1 = c1->vstg ? c1->Const.cds[n] : dtos(c1->Const.cd[n]);
00341         s2 = c2->vstg ? c2->Const.cds[n] : dtos(c2->Const.cd[n]);
00342         return !strcmp(s1, s2);
00343         }