Return to output.c CVS log

Up to [Research Unix] / researchv10no / cmd / f2c

Annotation of researchv10no/cmd/f2c/output.c, revision 1.1

1.1     ! root        1: /****************************************************************
        !             2: Copyright 1990, 1991, 1992, 1993 by AT&T Bell Laboratories and Bellcore.
        !             3: 
        !             4: Permission to use, copy, modify, and distribute this software
        !             5: and its documentation for any purpose and without fee is hereby
        !             6: granted, provided that the above copyright notice appear in all
        !             7: copies and that both that the copyright notice and this
        !             8: permission notice and warranty disclaimer appear in supporting
        !             9: documentation, and that the names of AT&T Bell Laboratories or
        !            10: Bellcore or any of their entities not be used in advertising or
        !            11: publicity pertaining to distribution of the software without
        !            12: specific, written prior permission.
        !            13: 
        !            14: AT&T and Bellcore disclaim all warranties with regard to this
        !            15: software, including all implied warranties of merchantability
        !            16: and fitness.  In no event shall AT&T or Bellcore be liable for
        !            17: any special, indirect or consequential damages or any damages
        !            18: whatsoever resulting from loss of use, data or profits, whether
        !            19: in an action of contract, negligence or other tortious action,
        !            20: arising out of or in connection with the use or performance of
        !            21: this software.
        !            22: ****************************************************************/
        !            23: 
        !            24: #include "defs.h"
        !            25: #include "names.h"
        !            26: #include "output.h"
        !            27: 
        !            28: #ifndef TRUE
        !            29: #define TRUE 1
        !            30: #endif
        !            31: #ifndef FALSE
        !            32: #define FALSE 0
        !            33: #endif
        !            34: 
        !            35: char _assoc_table[] = { 0, 0, 1, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1, 0 };
        !            36: 
        !            37: /* Opcode table -- This array is indexed by the OP_____ macros defined in
        !            38:    defines.h; these macros are expected to be adjacent integers, so that
        !            39:    this table is as small as possible. */
        !            40: 
        !            41: table_entry opcode_table[] = {
        !            42:                                { 0, 0, NULL },
        !            43:        /* OPPLUS 1 */          { BINARY_OP, 12, "%l + %r" },
        !            44:        /* OPMINUS 2 */         { BINARY_OP, 12, "%l - %r" },
        !            45:        /* OPSTAR 3 */          { BINARY_OP, 13, "%l * %r" },
        !            46:        /* OPSLASH 4 */         { BINARY_OP, 13, "%l / %r" },
        !            47:        /* OPPOWER 5 */         { BINARY_OP,  0, "power (%l, %r)" },
        !            48:        /* OPNEG 6 */           { UNARY_OP,  14, "-%l" },
        !            49:        /* OPOR 7 */            { BINARY_OP,  4, "%l || %r" },
        !            50:        /* OPAND 8 */           { BINARY_OP,  5, "%l && %r" },
        !            51:        /* OPEQV 9 */           { BINARY_OP,  9, "%l == %r" },
        !            52:        /* OPNEQV 10 */         { BINARY_OP,  9, "%l != %r" },
        !            53:        /* OPNOT 11 */          { UNARY_OP,  14, "! %l" },
        !            54:        /* OPCONCAT 12 */       { BINARY_OP,  0, "concat (%l, %r)" },
        !            55:        /* OPLT 13 */           { BINARY_OP, 10, "%l < %r" },
        !            56:        /* OPEQ 14 */           { BINARY_OP,  9, "%l == %r" },
        !            57:        /* OPGT 15 */           { BINARY_OP, 10, "%l > %r" },
        !            58:        /* OPLE 16 */           { BINARY_OP, 10, "%l <= %r" },
        !            59:        /* OPNE 17 */           { BINARY_OP,  9, "%l != %r" },
        !            60:        /* OPGE 18 */           { BINARY_OP, 10, "%l >= %r" },
        !            61:        /* OPCALL 19 */         { BINARY_OP, 15, SPECIAL_FMT },
        !            62:        /* OPCCALL 20 */        { BINARY_OP, 15, SPECIAL_FMT },
        !            63: 
        !            64: /* Left hand side of an assignment cannot have outermost parens */
        !            65: 
        !            66:        /* OPASSIGN 21 */       { BINARY_OP,  2, "%l = %r" },
        !            67:        /* OPPLUSEQ 22 */       { BINARY_OP,  2, "%l += %r" },
        !            68:        /* OPSTAREQ 23 */       { BINARY_OP,  2, "%l *= %r" },
        !            69:        /* OPCONV 24 */         { BINARY_OP, 14, "%l" },
        !            70:        /* OPLSHIFT 25 */       { BINARY_OP, 11, "%l << %r" },
        !            71:        /* OPMOD 26 */          { BINARY_OP, 13, "%l %% %r" },
        !            72:        /* OPCOMMA 27 */        { BINARY_OP,  1, "%l, %r" },
        !            73: 
        !            74: /* Don't want to nest the colon operator in parens */
        !            75: 
        !            76:        /* OPQUEST 28 */        { BINARY_OP, 3, "%l ? %r" },
        !            77:        /* OPCOLON 29 */        { BINARY_OP, 3, "%l : %r" },
        !            78:        /* OPABS 30 */          { UNARY_OP,  0, "abs(%l)" },
        !            79:        /* OPMIN 31 */          { BINARY_OP,   0, SPECIAL_FMT },
        !            80:        /* OPMAX 32 */          { BINARY_OP,   0, SPECIAL_FMT },
        !            81:        /* OPADDR 33 */         { UNARY_OP, 14, "&%l" },
        !            82: 
        !            83:        /* OPCOMMA_ARG 34 */    { BINARY_OP, 15, SPECIAL_FMT },
        !            84:        /* OPBITOR 35 */        { BINARY_OP,  6, "%l | %r" },
        !            85:        /* OPBITAND 36 */       { BINARY_OP,  8, "%l & %r" },
        !            86:        /* OPBITXOR 37 */       { BINARY_OP,  7, "%l ^ %r" },
        !            87:        /* OPBITNOT 38 */       { UNARY_OP,  14, "~ %l" },
        !            88:        /* OPRSHIFT 39 */       { BINARY_OP, 11, "%l >> %r" },
        !            89: 
        !            90: /* This isn't quite right -- it doesn't handle arrays, for instance */
        !            91: 
        !            92:        /* OPWHATSIN 40 */      { UNARY_OP,  14, "*%l" },
        !            93:        /* OPMINUSEQ 41 */      { BINARY_OP,  2, "%l -= %r" },
        !            94:        /* OPSLASHEQ 42 */      { BINARY_OP,  2, "%l /= %r" },
        !            95:        /* OPMODEQ 43 */        { BINARY_OP,  2, "%l %%= %r" },
        !            96:        /* OPLSHIFTEQ 44 */     { BINARY_OP,  2, "%l <<= %r" },
        !            97:        /* OPRSHIFTEQ 45 */     { BINARY_OP,  2, "%l >>= %r" },
        !            98:        /* OPBITANDEQ 46 */     { BINARY_OP,  2, "%l &= %r" },
        !            99:        /* OPBITXOREQ 47 */     { BINARY_OP,  2, "%l ^= %r" },
        !           100:        /* OPBITOREQ 48 */      { BINARY_OP,  2, "%l |= %r" },
        !           101:        /* OPPREINC 49 */       { UNARY_OP,  14, "++%l" },
        !           102:        /* OPPREDEC 50 */       { UNARY_OP,  14, "--%l" },
        !           103:        /* OPDOT 51 */          { BINARY_OP, 15, "%l.%r" },
        !           104:        /* OPARROW 52 */        { BINARY_OP, 15, "%l -> %r"},
        !           105:        /* OPNEG1 53 */         { UNARY_OP,  14, "-%l" },
        !           106:        /* OPDMIN 54 */         { BINARY_OP, 0, "dmin(%l,%r)" },
        !           107:        /* OPDMAX 55 */         { BINARY_OP, 0, "dmax(%l,%r)" },
        !           108:        /* OPASSIGNI 56 */      { BINARY_OP,  2, "%l = &%r" },
        !           109:        /* OPIDENTITY 57 */     { UNARY_OP, 15, "%l" },
        !           110:        /* OPCHARCAST 58 */     { UNARY_OP, 14, "(char *)&%l" },
        !           111:        /* OPDABS 59 */         { UNARY_OP, 0, "dabs(%l)" },
        !           112:        /* OPMIN2 60 */         { BINARY_OP,   0, "min(%l,%r)" },
        !           113:        /* OPMAX2 61 */         { BINARY_OP,   0, "max(%l,%r)" },
        !           114: 
        !           115: /* kludge to imitate (under forcedouble) f77's bizarre treatement of OPNEG... */
        !           116: 
        !           117:        /* OPNEG KLUDGE */      { UNARY_OP,  14, "-(doublereal)%l" }
        !           118: }; /* opcode_table */
        !           119: 
        !           120: #define OPNEG_KLUDGE (sizeof(opcode_table)/sizeof(table_entry) - 1)
        !           121: 
        !           122: static char opeqable[sizeof(opcode_table)/sizeof(table_entry)];
        !           123: 
        !           124: 
        !           125: static void output_prim ();
        !           126: static void output_unary (), output_binary (), output_arg_list ();
        !           127: static void output_list (), output_literal ();
        !           128: 
        !           129: 
        !           130: void expr_out (fp, e)
        !           131: FILE *fp;
        !           132: expptr e;
        !           133: {
        !           134:     if (e == (expptr) NULL)
        !           135:        return;
        !           136: 
        !           137:     switch (e -> tag) {
        !           138:        case TNAME:     out_name (fp, (struct Nameblock *) e);
        !           139:                        return;
        !           140: 
        !           141:        case TCONST:    out_const(fp, &e->constblock);
        !           142:                        goto end_out;
        !           143:        case TEXPR:
        !           144:                        break;
        !           145: 
        !           146:        case TADDR:     out_addr (fp, &(e -> addrblock));
        !           147:                        goto end_out;
        !           148: 
        !           149:        case TPRIM:     warn ("expr_out: got TPRIM");
        !           150:                        output_prim (fp, &(e -> primblock));
        !           151:                        return;
        !           152: 
        !           153:        case TLIST:     output_list (fp, &(e -> listblock));
        !           154:  end_out:              frexpr(e);
        !           155:                        return;
        !           156: 
        !           157:        case TIMPLDO:   err ("expr_out: got TIMPLDO");
        !           158:                        return;
        !           159: 
        !           160:        case TERROR:
        !           161:        default:
        !           162:                        erri ("expr_out: bad tag '%d'", e -> tag);
        !           163:     } /* switch */
        !           164: 
        !           165: /* Now we know that the tag is TEXPR */
        !           166: 
        !           167: /* Optimize on simple expressions, such as "a = a + b" ==> "a += b" */
        !           168: 
        !           169:     if (e -> exprblock.opcode == OPASSIGN && e -> exprblock.rightp &&
        !           170:        e -> exprblock.rightp -> tag == TEXPR) {
        !           171:        int opcode;
        !           172: 
        !           173:        opcode = e -> exprblock.rightp -> exprblock.opcode;
        !           174: 
        !           175:        if (opeqable[opcode]) {
        !           176:            expptr leftp, rightp;
        !           177: 
        !           178:            if ((leftp = e -> exprblock.leftp) &&
        !           179:                (rightp = e -> exprblock.rightp -> exprblock.leftp)) {
        !           180: 
        !           181:                if (same_ident (leftp, rightp)) {
        !           182:                    expptr temp = e -> exprblock.rightp;
        !           183: 
        !           184:                    e -> exprblock.opcode = op_assign(opcode);
        !           185: 
        !           186:                    e -> exprblock.rightp = temp -> exprblock.rightp;
        !           187:                    temp->exprblock.rightp = 0;
        !           188:                    frexpr(temp);
        !           189:                } /* if same_ident (leftp, rightp) */
        !           190:            } /* if leftp && rightp */
        !           191:        } /* if opcode == OPPLUS || */
        !           192:     } /* if e -> exprblock.opcode == OPASSIGN */
        !           193: 
        !           194: 
        !           195: /* Optimize on increment or decrement by 1 */
        !           196: 
        !           197:     {
        !           198:        int opcode = e -> exprblock.opcode;
        !           199:        expptr leftp = e -> exprblock.leftp;
        !           200:        expptr rightp = e -> exprblock.rightp;
        !           201: 
        !           202:        if (leftp && rightp && (leftp -> headblock.vstg == STGARG ||
        !           203:                ISINT (leftp -> headblock.vtype)) &&
        !           204:                (opcode == OPPLUSEQ || opcode == OPMINUSEQ) &&
        !           205:                ISINT (rightp -> headblock.vtype) &&
        !           206:                ISICON (e -> exprblock.rightp) &&
        !           207:                (ISONE (e -> exprblock.rightp) ||
        !           208:                e -> exprblock.rightp -> constblock.Const.ci == -1)) {
        !           209: 
        !           210: /* Allow for the '-1' constant value */
        !           211: 
        !           212:            if (!ISONE (e -> exprblock.rightp))
        !           213:                opcode = (opcode == OPPLUSEQ) ? OPMINUSEQ : OPPLUSEQ;
        !           214: 
        !           215: /* replace the existing opcode */
        !           216: 
        !           217:            if (opcode == OPPLUSEQ)
        !           218:                e -> exprblock.opcode = OPPREINC;
        !           219:            else
        !           220:                e -> exprblock.opcode = OPPREDEC;
        !           221: 
        !           222: /* Free up storage used by the right hand side */
        !           223: 
        !           224:            frexpr (e -> exprblock.rightp);
        !           225:            e->exprblock.rightp = 0;
        !           226:        } /* if opcode == OPPLUS */
        !           227:     } /* block */
        !           228: 
        !           229: 
        !           230:     if (is_unary_op (e -> exprblock.opcode))
        !           231:        output_unary (fp, &(e -> exprblock));
        !           232:     else if (is_binary_op (e -> exprblock.opcode))
        !           233:        output_binary (fp, &(e -> exprblock));
        !           234:     else
        !           235:        erri ("expr_out: bad opcode '%d'", (int) e -> exprblock.opcode);
        !           236: 
        !           237:     free((char *)e);
        !           238: 
        !           239: } /* expr_out */
        !           240: 
        !           241: 
        !           242: void out_and_free_statement (outfile, expr)
        !           243: FILE *outfile;
        !           244: expptr expr;
        !           245: {
        !           246:     if (expr)
        !           247:        expr_out (outfile, expr);
        !           248: 
        !           249:     nice_printf (outfile, ";\n");
        !           250: } /* out_and_free_statement */
        !           251: 
        !           252: 
        !           253: 
        !           254: int same_ident (left, right)
        !           255: expptr left, right;
        !           256: {
        !           257:     if (!left || !right)
        !           258:        return 0;
        !           259: 
        !           260:     if (left -> tag == TNAME && right -> tag == TNAME && left == right)
        !           261:        return 1;
        !           262: 
        !           263:     if (left -> tag == TADDR && right -> tag == TADDR &&
        !           264:            left -> addrblock.uname_tag == right -> addrblock.uname_tag)
        !           265:        switch (left -> addrblock.uname_tag) {
        !           266:            case UNAM_REF:
        !           267:            case UNAM_NAME:
        !           268: 
        !           269: /* Check for array subscripts */
        !           270: 
        !           271:                if (left -> addrblock.user.name -> vdim ||
        !           272:                        right -> addrblock.user.name -> vdim)
        !           273:                    if (left -> addrblock.user.name !=
        !           274:                            right -> addrblock.user.name ||
        !           275:                            !same_expr (left -> addrblock.memoffset,
        !           276:                            right -> addrblock.memoffset))
        !           277:                        return 0;
        !           278: 
        !           279:                return same_ident ((expptr) (left -> addrblock.user.name),
        !           280:                        (expptr) right -> addrblock.user.name);
        !           281:            case UNAM_IDENT:
        !           282:                return strcmp(left->addrblock.user.ident,
        !           283:                                right->addrblock.user.ident) == 0;
        !           284:            case UNAM_CHARP:
        !           285:                return strcmp(left->addrblock.user.Charp,
        !           286:                                right->addrblock.user.Charp) == 0;
        !           287:            default:
        !           288:                return 0;
        !           289:        } /* switch */
        !           290: 
        !           291:     if (left->tag == TEXPR && left->exprblock.opcode == OPWHATSIN
        !           292:        && right->tag == TEXPR && right->exprblock.opcode == OPWHATSIN)
        !           293:                return same_ident(left->exprblock.leftp,
        !           294:                                 right->exprblock.leftp);
        !           295: 
        !           296:     return 0;
        !           297: } /* same_ident */
        !           298: 
        !           299:  static int
        !           300: samefpconst(c1, c2, n)
        !           301:  register Constp c1, c2;
        !           302:  register int n;
        !           303: {
        !           304:        char *s1, *s2;
        !           305:        if (!c1->vstg && !c2->vstg)
        !           306:                return c1->Const.cd[n] == c2->Const.cd[n];
        !           307:        s1 = c1->vstg ? c1->Const.cds[n] : dtos(c1->Const.cd[n]);
        !           308:        s2 = c2->vstg ? c2->Const.cds[n] : dtos(c2->Const.cd[n]);
        !           309:        return !strcmp(s1, s2);
        !           310:        }
        !           311: 
        !           312:  static int
        !           313: sameconst(c1, c2)
        !           314:  register Constp c1, c2;
        !           315: {
        !           316:        switch(c1->vtype) {
        !           317:                case TYCOMPLEX:
        !           318:                case TYDCOMPLEX:
        !           319:                        if (!samefpconst(c1,c2,1))
        !           320:                                return 0;
        !           321:                case TYREAL:
        !           322:                case TYDREAL:
        !           323:                        return samefpconst(c1,c2,0);
        !           324:                case TYCHAR:
        !           325:                        return c1->Const.ccp1.blanks == c2->Const.ccp1.blanks
        !           326:                            &&     c1->vleng->constblock.Const.ci
        !           327:                                == c2->vleng->constblock.Const.ci
        !           328:                            && !memcmp(c1->Const.ccp, c2->Const.ccp,
        !           329:                                        (int)c1->vleng->constblock.Const.ci);
        !           330:                case TYSHORT:
        !           331:                case TYINT:
        !           332:                case TYLOGICAL:
        !           333:                        return c1->Const.ci == c2->Const.ci;
        !           334:                }
        !           335:        err("unexpected type in sameconst");
        !           336:        return 0;
        !           337:        }
        !           338: 
        !           339: /* same_expr -- Returns true only if   e1 and e2   match.  This is
        !           340:    somewhat pessimistic, but can afford to be because it's just used to
        !           341:    optimize on the assignment operators (+=, -=, etc). */
        !           342: 
        !           343: int same_expr (e1, e2)
        !           344: expptr e1, e2;
        !           345: {
        !           346:     if (!e1 || !e2)
        !           347:        return !e1 && !e2;
        !           348: 
        !           349:     if (e1 -> tag != e2 -> tag || e1 -> headblock.vtype != e2 -> headblock.vtype)
        !           350:        return 0;
        !           351: 
        !           352:     switch (e1 -> tag) {
        !           353:         case TEXPR:
        !           354:            if (e1 -> exprblock.opcode != e2 -> exprblock.opcode)
        !           355:                return 0;
        !           356: 
        !           357:            return same_expr (e1 -> exprblock.leftp, e2 -> exprblock.leftp) &&
        !           358:                   same_expr (e1 -> exprblock.rightp, e2 -> exprblock.rightp);
        !           359:        case TNAME:
        !           360:        case TADDR:
        !           361:            return same_ident (e1, e2);
        !           362:        case TCONST:
        !           363:            return sameconst(&e1->constblock, &e2->constblock);
        !           364:        default:
        !           365:            return 0;
        !           366:     } /* switch */
        !           367: } /* same_expr */
        !           368: 
        !           369: 
        !           370: 
        !           371: void out_name (fp, namep)
        !           372:  FILE *fp;
        !           373:  Namep namep;
        !           374: {
        !           375:     extern int usedefsforcommon;
        !           376:     Extsym *comm;
        !           377: 
        !           378:     if (namep == NULL)
        !           379:        return;
        !           380: 
        !           381: /* DON'T want to use oneof_stg() here; need to find the right common name
        !           382:    */
        !           383: 
        !           384:     if (namep->vstg == STGCOMMON && !namep->vcommequiv && !usedefsforcommon) {
        !           385:        comm = &extsymtab[namep->vardesc.varno];
        !           386:        extern_out(fp, comm);
        !           387:        nice_printf(fp, "%d.", comm->curno);
        !           388:     } /* if namep -> vstg == STGCOMMON */
        !           389: 
        !           390:     if (namep->vprocclass == PTHISPROC && namep->vtype != TYSUBR)
        !           391:        nice_printf(fp, xretslot[namep->vtype]->user.ident);
        !           392:     else
        !           393:        nice_printf (fp, "%s", namep->cvarname);
        !           394: } /* out_name */
        !           395: 
        !           396: 
        !           397: static char *Longfmt = "%ld";
        !           398: 
        !           399: #define cpd(n) cp->vstg ? cp->Const.cds[n] : dtos(cp->Const.cd[n])
        !           400: 
        !           401: void out_const(fp, cp)
        !           402:  FILE *fp;
        !           403:  register Constp cp;
        !           404: {
        !           405:     static char real_buf[50], imag_buf[50];
        !           406:     unsigned int k;
        !           407:     int type = cp->vtype;
        !           408: 
        !           409:     switch (type) {
        !           410:        case TYINT1:
        !           411:         case TYSHORT:
        !           412:            nice_printf (fp, "%ld", cp->Const.ci);      /* don't cast ci! */
        !           413:            break;
        !           414:        case TYLONG:
        !           415: #ifdef TYQUAD
        !           416:        case TYQUAD:
        !           417: #endif
        !           418:            nice_printf (fp, Longfmt, cp->Const.ci);    /* don't cast ci! */
        !           419:            break;
        !           420:        case TYREAL:
        !           421:            nice_printf(fp, "%s", flconst(real_buf, cpd(0)));
        !           422:            break;
        !           423:        case TYDREAL:
        !           424:            nice_printf(fp, "%s", cpd(0));
        !           425:            break;
        !           426:        case TYCOMPLEX:
        !           427:            nice_printf(fp, cm_fmt_string, flconst(real_buf, cpd(0)),
        !           428:                        flconst(imag_buf, cpd(1)));
        !           429:            break;
        !           430:        case TYDCOMPLEX:
        !           431:            nice_printf(fp, dcm_fmt_string, cpd(0), cpd(1));
        !           432:            break;
        !           433:        case TYLOGICAL1:
        !           434:        case TYLOGICAL2:
        !           435:        case TYLOGICAL:
        !           436:            nice_printf (fp, "%s", cp->Const.ci ? "TRUE_" : "FALSE_");
        !           437:            break;
        !           438:        case TYCHAR: {
        !           439:            char *c = cp->Const.ccp, *ce;
        !           440: 
        !           441:            if (c == NULL) {
        !           442:                nice_printf (fp, "\"\"");
        !           443:                break;
        !           444:            } /* if c == NULL */
        !           445: 
        !           446:            nice_printf (fp, "\"");
        !           447:            ce = c + cp->vleng->constblock.Const.ci;
        !           448:            while(c < ce) {
        !           449:                k = *(unsigned char *)c++;
        !           450:                nice_printf(fp, str_fmt[k], k);
        !           451:                }
        !           452:            for(k = cp->Const.ccp1.blanks; k > 0; k--)
        !           453:                nice_printf(fp, " ");
        !           454:            nice_printf (fp, "\"");
        !           455:            break;
        !           456:        } /* case TYCHAR */
        !           457:        default:
        !           458:            erri ("out_const:  bad type '%d'", (int) type);
        !           459:            break;
        !           460:     } /* switch */
        !           461: 
        !           462: } /* out_const */
        !           463: #undef cpd
        !           464: 
        !           465:  static void
        !           466: out_args(fp, ep) FILE *fp; expptr ep;
        !           467: {
        !           468:        chainp arglist;
        !           469: 
        !           470:        if(ep->tag != TLIST)
        !           471:                badtag("out_args", ep->tag);
        !           472:        for(arglist = ep->listblock.listp;;) {
        !           473:                expr_out(fp, (expptr)arglist->datap);
        !           474:                arglist->datap = 0;
        !           475:                if (!(arglist = arglist->nextp))
        !           476:                        break;
        !           477:                nice_printf(fp, ", ");
        !           478:                }
        !           479:        }
        !           480: 
        !           481: 
        !           482: /* out_addr -- this routine isn't local because it is called by the
        !           483:    system-generated identifier printing routines */
        !           484: 
        !           485: void out_addr (fp, addrp)
        !           486: FILE *fp;
        !           487: struct Addrblock *addrp;
        !           488: {
        !           489:        extern Extsym *extsymtab;
        !           490:        int was_array = 0;
        !           491:        char *s;
        !           492: 
        !           493: 
        !           494:        if (addrp == NULL)
        !           495:                return;
        !           496:        if (doin_setbound
        !           497:                        && addrp->vstg == STGARG
        !           498:                        && addrp->vtype != TYCHAR
        !           499:                        && ISICON(addrp->memoffset)
        !           500:                        && !addrp->memoffset->constblock.Const.ci)
        !           501:                nice_printf(fp, "*");
        !           502: 
        !           503:        switch (addrp -> uname_tag) {
        !           504:            case UNAM_REF:
        !           505:                nice_printf(fp, "%s_%s(", addrp->user.name->cvarname,
        !           506:                        addrp->cmplx_sub ? "subscr" : "ref");
        !           507:                out_args(fp, addrp->memoffset);
        !           508:                nice_printf(fp, ")");
        !           509:                return;
        !           510:            case UNAM_NAME:
        !           511:                out_name (fp, addrp -> user.name);
        !           512:                break;
        !           513:            case UNAM_IDENT:
        !           514:                if (*(s = addrp->user.ident) == ' ') {
        !           515:                        if (multitype)
        !           516:                                nice_printf(fp, "%s",
        !           517:                                        xretslot[addrp->vtype]->user.ident);
        !           518:                        else
        !           519:                                nice_printf(fp, "%s", s+1);
        !           520:                        }
        !           521:                else {
        !           522:                        nice_printf(fp, "%s", s);
        !           523:                        }
        !           524:                break;
        !           525:            case UNAM_CHARP:
        !           526:                nice_printf(fp, "%s", addrp->user.Charp);
        !           527:                break;
        !           528:            case UNAM_EXTERN:
        !           529:                extern_out (fp, &extsymtab[addrp -> memno]);
        !           530:                break;
        !           531:            case UNAM_CONST:
        !           532:                switch(addrp->vstg) {
        !           533:                        case STGCONST:
        !           534:                                out_const(fp, (Constp)addrp);
        !           535:                                break;
        !           536:                        case STGMEMNO:
        !           537:                                output_literal (fp, (int)addrp->memno,
        !           538:                                        (Constp)addrp);
        !           539:                                break;
        !           540:                        default:
        !           541:                        Fatal("unexpected vstg in out_addr");
        !           542:                        }
        !           543:                break;
        !           544:            case UNAM_UNKNOWN:
        !           545:            default:
        !           546:                nice_printf (fp, "Unknown Addrp");
        !           547:                break;
        !           548:        } /* switch */
        !           549: 
        !           550: /* It's okay to just throw in the brackets here because they have a
        !           551:    precedence level of 15, the highest value.  */
        !           552: 
        !           553:     if ((addrp->uname_tag == UNAM_NAME && addrp->user.name->vdim
        !           554:                        || addrp->ntempelt > 1 || addrp->isarray)
        !           555:        && addrp->vtype != TYCHAR) {
        !           556:        expptr offset;
        !           557: 
        !           558:        was_array = 1;
        !           559: 
        !           560:        offset = addrp -> memoffset;
        !           561:        addrp->memoffset = 0;
        !           562:        if (ONEOF(addrp->vstg, M(STGCOMMON)|M(STGEQUIV))
        !           563:                && addrp -> uname_tag == UNAM_NAME
        !           564:                && !addrp->skip_offset)
        !           565:            offset = mkexpr (OPMINUS, offset, mkintcon (
        !           566:                    addrp -> user.name -> voffset));
        !           567: 
        !           568:        nice_printf (fp, "[");
        !           569: 
        !           570:        offset = mkexpr (OPSLASH, offset,
        !           571:                ICON (typesize[addrp -> vtype] * (addrp -> Field ? 2 : 1)));
        !           572:        expr_out (fp, offset);
        !           573:        nice_printf (fp, "]");
        !           574:        }
        !           575: 
        !           576: /* Check for structure field reference */
        !           577: 
        !           578:     if (addrp -> Field && addrp -> uname_tag != UNAM_CONST &&
        !           579:            addrp -> uname_tag != UNAM_UNKNOWN) {
        !           580:        if (oneof_stg((addrp -> uname_tag == UNAM_NAME ? addrp -> user.name :
        !           581:                (Namep) NULL), addrp -> vstg, M(STGARG)|M(STGEQUIV))
        !           582:                && !was_array && (addrp->vclass != CLPROC || !multitype))
        !           583:            nice_printf (fp, "->%s", addrp -> Field);
        !           584:        else
        !           585:            nice_printf (fp, ".%s", addrp -> Field);
        !           586:     } /* if */
        !           587: 
        !           588: /* Check for character subscripting */
        !           589: 
        !           590:     if (addrp->vtype == TYCHAR &&
        !           591:            (addrp->vclass != CLPROC || addrp->uname_tag == UNAM_NAME
        !           592:                        && addrp->user.name->vprocclass == PTHISPROC) &&
        !           593:            addrp -> memoffset &&
        !           594:            (addrp -> uname_tag != UNAM_NAME ||
        !           595:             addrp -> user.name -> vtype == TYCHAR) &&
        !           596:            (!ISICON (addrp -> memoffset) ||
        !           597:             (addrp -> memoffset -> constblock.Const.ci))) {
        !           598: 
        !           599:        int use_paren = 0;
        !           600:        expptr e = addrp -> memoffset;
        !           601: 
        !           602:        if (!e)
        !           603:                return;
        !           604:        addrp->memoffset = 0;
        !           605: 
        !           606:        if (ONEOF(addrp->vstg, M(STGCOMMON)|M(STGEQUIV))
        !           607:         && addrp -> uname_tag == UNAM_NAME) {
        !           608:            e = mkexpr (OPMINUS, e, mkintcon (addrp -> user.name -> voffset));
        !           609: 
        !           610: /* mkexpr will simplify it to zero if possible */
        !           611:            if (e->tag == TCONST && e->constblock.Const.ci == 0)
        !           612:                return;
        !           613:        } /* if addrp -> vstg == STGCOMMON */
        !           614: 
        !           615: /* In the worst case, parentheses might be needed OUTSIDE the expression,
        !           616:    too.  But since I think this subscripting can only appear as a
        !           617:    parameter in a procedure call, I don't think outside parens will ever
        !           618:    be needed.  INSIDE parens are handled below */
        !           619: 
        !           620:        nice_printf (fp, " + ");
        !           621:        if (e -> tag == TEXPR) {
        !           622:            int arg_prec = op_precedence (e -> exprblock.opcode);
        !           623:            int prec = op_precedence (OPPLUS);
        !           624:            use_paren = arg_prec && (arg_prec < prec || (arg_prec == prec &&
        !           625:                    is_left_assoc (OPPLUS)));
        !           626:        } /* if e -> tag == TEXPR */
        !           627:        if (use_paren) nice_printf (fp, "(");
        !           628:        expr_out (fp, e);
        !           629:        if (use_paren) nice_printf (fp, ")");
        !           630:     } /* if */
        !           631: } /* out_addr */
        !           632: 
        !           633: 
        !           634: static void output_literal (fp, memno, cp)
        !           635:  FILE *fp;
        !           636:  int memno;
        !           637:  Constp cp;
        !           638: {
        !           639:     struct Literal *litp, *lastlit;
        !           640:     extern char *lit_name ();
        !           641: 
        !           642:     lastlit = litpool + nliterals;
        !           643: 
        !           644:     for (litp = litpool; litp < lastlit; litp++) {
        !           645:        if (litp -> litnum == memno)
        !           646:            break;
        !           647:     } /* for litp */
        !           648: 
        !           649:     if (litp >= lastlit)
        !           650:        out_const (fp, cp);
        !           651:     else {
        !           652:        nice_printf (fp, "%s", lit_name (litp));
        !           653:        litp->lituse++;
        !           654:        }
        !           655: } /* output_literal */
        !           656: 
        !           657: 
        !           658: static void output_prim (fp, primp)
        !           659: FILE *fp;
        !           660: struct Primblock *primp;
        !           661: {
        !           662:     if (primp == NULL)
        !           663:        return;
        !           664: 
        !           665:     out_name (fp, primp -> namep);
        !           666:     if (primp -> argsp)
        !           667:        output_arg_list (fp, primp -> argsp);
        !           668: 
        !           669:     if (primp -> fcharp != (expptr) NULL || primp -> lcharp != (expptr) NULL)
        !           670:        nice_printf (fp, "Sorry, no substrings yet");
        !           671: }
        !           672: 
        !           673: 
        !           674: 
        !           675: static void output_arg_list (fp, listp)
        !           676: FILE *fp;
        !           677: struct Listblock *listp;
        !           678: {
        !           679:     chainp arg_list;
        !           680: 
        !           681:     if (listp == (struct Listblock *) NULL || listp -> listp == (chainp) NULL)
        !           682:        return;
        !           683: 
        !           684:     nice_printf (fp, "(");
        !           685: 
        !           686:     for (arg_list = listp -> listp; arg_list; arg_list = arg_list -> nextp) {
        !           687:        expr_out (fp, (expptr) arg_list -> datap);
        !           688:        if (arg_list -> nextp != (chainp) NULL)
        !           689: 
        !           690: /* Might want to add a hook in here to accomodate the style setting which
        !           691:    wants spaces after commas */
        !           692: 
        !           693:            nice_printf (fp, ",");
        !           694:     } /* for arg_list */
        !           695: 
        !           696:     nice_printf (fp, ")");
        !           697: } /* output_arg_list */
        !           698: 
        !           699: 
        !           700: 
        !           701: static void output_unary (fp, e)
        !           702: FILE *fp;
        !           703: struct Exprblock *e;
        !           704: {
        !           705:     if (e == NULL)
        !           706:        return;
        !           707: 
        !           708:     switch (e -> opcode) {
        !           709:         case OPNEG:
        !           710:                if (e->vtype == TYREAL && forcedouble) {
        !           711:                        e->opcode = OPNEG_KLUDGE;
        !           712:                        output_binary(fp,e);
        !           713:                        e->opcode = OPNEG;
        !           714:                        break;
        !           715:                        }
        !           716:        case OPNEG1:
        !           717:        case OPNOT:
        !           718:        case OPABS:
        !           719:        case OPBITNOT:
        !           720:        case OPWHATSIN:
        !           721:        case OPPREINC:
        !           722:        case OPPREDEC:
        !           723:        case OPADDR:
        !           724:        case OPIDENTITY:
        !           725:        case OPCHARCAST:
        !           726:        case OPDABS:
        !           727:            output_binary (fp, e);
        !           728:            break;
        !           729:        case OPCALL:
        !           730:        case OPCCALL:
        !           731:            nice_printf (fp, "Sorry, no OPCALL yet");
        !           732:            break;
        !           733:        default:
        !           734:            erri ("output_unary: bad opcode", (int) e -> opcode);
        !           735:            break;
        !           736:     } /* switch */
        !           737: } /* output_unary */
        !           738: 
        !           739: 
        !           740:  static char *
        !           741: findconst(m)
        !           742:  register long m;
        !           743: {
        !           744:        register struct Literal *litp, *litpe;
        !           745: 
        !           746:        litp = litpool;
        !           747:        for(litpe = litp + nliterals; litp < litpe; litp++)
        !           748:                if (litp->litnum ==  m)
        !           749:                        return litp->cds[0];
        !           750:        Fatal("findconst failure!");
        !           751:        return 0;
        !           752:        }
        !           753: 
        !           754:  static int
        !           755: opconv_fudge(fp,e)
        !           756:  FILE *fp;
        !           757:  struct Exprblock *e;
        !           758: {
        !           759:        /* special handling for ichar and character*1 */
        !           760:        register expptr lp;
        !           761:        register union Expression *Offset;
        !           762:        register char *cp;
        !           763:        int lt;
        !           764:        char buf[8];
        !           765:        unsigned int k;
        !           766:        Namep np;
        !           767: 
        !           768:        if (!(lp = e->leftp))   /* possible with erroneous Fortran */
        !           769:                return 1;
        !           770:        lt = lp->headblock.vtype;
        !           771:        if (lt == TYCHAR) {
        !           772:                switch(lp->tag) {
        !           773:                        case TNAME:
        !           774:                                nice_printf(fp, "*");
        !           775:                                out_name(fp, (Namep)lp);
        !           776:                                return 1;
        !           777:                        case TCONST:
        !           778:  tconst:
        !           779:                                cp = lp->constblock.Const.ccp;
        !           780:  tconst1:
        !           781:                                k = *(unsigned char *)cp;
        !           782:                                sprintf(buf, chr_fmt[k], k);
        !           783:                                nice_printf(fp, "'%s'", buf);
        !           784:                                return 1;
        !           785:                        case TADDR:
        !           786:                                switch(lp->addrblock.vstg) {
        !           787:                                    case STGMEMNO:
        !           788:                                        if (halign && e->vtype != TYCHAR) {
        !           789:                                                nice_printf(fp, "*(%s *)",
        !           790:                                                        c_type_decl(e->vtype));
        !           791:                                                expr_out(fp, lp);
        !           792:                                                return 1;
        !           793:                                                }
        !           794:                                        cp = findconst(lp->addrblock.memno);
        !           795:                                        goto tconst1;
        !           796:                                    case STGCONST:
        !           797:                                        goto tconst;
        !           798:                                    }
        !           799:                                lp->addrblock.vtype = tyint;
        !           800:                                Offset = lp->addrblock.memoffset;
        !           801:                                switch(lp->addrblock.uname_tag) {
        !           802:                                  case UNAM_REF:
        !           803:                                        nice_printf(fp, "*");
        !           804:                                        return 0;
        !           805:                                  case UNAM_NAME:
        !           806:                                        np = lp->addrblock.user.name;
        !           807:                                        if (ONEOF(np->vstg,
        !           808:                                            M(STGCOMMON)|M(STGEQUIV)))
        !           809:                                                Offset = mkexpr(OPMINUS, Offset,
        !           810:                                                        ICON(np->voffset));
        !           811:                                        }
        !           812:                                lp->addrblock.memoffset = Offset ?
        !           813:                                        mkexpr(OPSTAR, Offset,
        !           814:                                                ICON(typesize[tyint]))
        !           815:                                        : ICON(0);
        !           816:                                lp->addrblock.isarray = 1;
        !           817:                                /* STGCOMMON or STGEQUIV would cause */
        !           818:                                /* voffset to be added in a second time */
        !           819:                                lp->addrblock.vstg = STGUNKNOWN;
        !           820:                                break;
        !           821:                        default:
        !           822:                                badtag("opconv_fudge", lp->tag);
        !           823:                        }
        !           824:                }
        !           825:        if (lt != e->vtype)
        !           826:                nice_printf(fp, "(%s) ",
        !           827:                        c_type_decl(e->vtype, 0));
        !           828:        return 0;
        !           829:        }
        !           830: 
        !           831: 
        !           832: static void output_binary (fp, e)
        !           833: FILE *fp;
        !           834: struct Exprblock *e;
        !           835: {
        !           836:     char *format;
        !           837:     extern table_entry opcode_table[];
        !           838:     int prec;
        !           839: 
        !           840:     if (e == NULL || e -> tag != TEXPR)
        !           841:        return;
        !           842: 
        !           843: /* Instead of writing a huge switch, I've incorporated the output format
        !           844:    into a table.  Things like "%l" and "%r" stand for the left and
        !           845:    right subexpressions.  This should allow both prefix and infix
        !           846:    functions to be specified (e.g. "(%l * %r", "z_div (%l, %r").  Of
        !           847:    course, I should REALLY think out the ramifications of writing out
        !           848:    straight text, as opposed to some intermediate format, which could
        !           849:    figure out and optimize on the the number of required blanks (we don't
        !           850:    want "x - (-y)" to become "x --y", for example).  Special cases (such as
        !           851:    incomplete implementations) could still be implemented as part of the
        !           852:    switch, they will just have some dummy value instead of the string
        !           853:    pattern.  Another difficulty is the fact that the complex functions
        !           854:    will differ from the integer and real ones */
        !           855: 
        !           856: /* Handle a special case.  We don't want to output "x + - 4", or "y - - 3"
        !           857: */
        !           858:     if ((e -> opcode == OPPLUS || e -> opcode == OPMINUS) &&
        !           859:            e -> rightp && e -> rightp -> tag == TCONST &&
        !           860:            isnegative_const (&(e -> rightp -> constblock)) &&
        !           861:            is_negatable (&(e -> rightp -> constblock))) {
        !           862: 
        !           863:        e -> opcode = (e -> opcode == OPPLUS) ? OPMINUS : OPPLUS;
        !           864:        negate_const (&(e -> rightp -> constblock));
        !           865:     } /* if e -> opcode == PLUS or MINUS */
        !           866: 
        !           867:     prec = op_precedence (e -> opcode);
        !           868:     format = op_format (e -> opcode);
        !           869: 
        !           870:     if (format != SPECIAL_FMT) {
        !           871:        while (*format) {
        !           872:            if (*format == '%') {
        !           873:                int arg_prec, use_paren = 0;
        !           874:                expptr lp, rp;
        !           875: 
        !           876:                switch (*(format + 1)) {
        !           877:                    case 'l':
        !           878:                        lp = e->leftp;
        !           879:                        if (lp && lp->tag == TEXPR) {
        !           880:                            arg_prec = op_precedence(lp->exprblock.opcode);
        !           881: 
        !           882:                            use_paren = arg_prec &&
        !           883:                                (arg_prec < prec || (arg_prec == prec &&
        !           884:                                    is_right_assoc (prec)));
        !           885:                        } /* if e -> leftp */
        !           886:                        if (e->opcode == OPCONV && opconv_fudge(fp,e))
        !           887:                                break;
        !           888:                        if (use_paren)
        !           889:                            nice_printf (fp, "(");
        !           890:                        expr_out(fp, lp);
        !           891:                        if (use_paren)
        !           892:                            nice_printf (fp, ")");
        !           893:                        break;
        !           894:                    case 'r':
        !           895:                        rp = e->rightp;
        !           896:                        if (rp && rp->tag == TEXPR) {
        !           897:                            arg_prec = op_precedence(rp->exprblock.opcode);
        !           898: 
        !           899:                            use_paren = arg_prec &&
        !           900:                                (arg_prec < prec || (arg_prec == prec &&
        !           901:                                    is_left_assoc (prec)));
        !           902:                            use_paren = use_paren ||
        !           903:                                (rp->exprblock.opcode == OPNEG
        !           904:                                && prec >= op_precedence(OPMINUS));
        !           905:                        } /* if e -> rightp */
        !           906:                        if (use_paren)
        !           907:                            nice_printf (fp, "(");
        !           908:                        expr_out(fp, rp);
        !           909:                        if (use_paren)
        !           910:                            nice_printf (fp, ")");
        !           911:                        break;
        !           912:                    case '\0':
        !           913:                    case '%':
        !           914:                        nice_printf (fp, "%%");
        !           915:                        break;
        !           916:                    default:
        !           917:                        erri ("output_binary: format err: '%%%c' illegal",
        !           918:                                (int) *(format + 1));
        !           919:                        break;
        !           920:                } /* switch */
        !           921:                format += 2;
        !           922:            } else
        !           923:                nice_printf (fp, "%c", *format++);
        !           924:        } /* while *format */
        !           925:     } else {
        !           926: 
        !           927: /* Handle Special cases of formatting */
        !           928: 
        !           929:        switch (e -> opcode) {
        !           930:                case OPCCALL:
        !           931:                case OPCALL:
        !           932:                        out_call (fp, (int) e -> opcode, e -> vtype,
        !           933:                                        e -> vleng, e -> leftp, e -> rightp);
        !           934:                        break;
        !           935: 
        !           936:                case OPCOMMA_ARG:
        !           937:                        doin_setbound = 1;
        !           938:                        nice_printf(fp, "(");
        !           939:                        expr_out(fp, e->leftp);
        !           940:                        nice_printf(fp, ", &");
        !           941:                        doin_setbound = 0;
        !           942:                        expr_out(fp, e->rightp);
        !           943:                        nice_printf(fp, ")");
        !           944:                        break;
        !           945: 
        !           946:                case OPADDR:
        !           947:                default:
        !           948:                        nice_printf (fp, "Sorry, can't format OPCODE '%d'",
        !           949:                                e -> opcode);
        !           950:                        break;
        !           951:                }
        !           952: 
        !           953:     } /* else */
        !           954: } /* output_binary */
        !           955: 
        !           956: 
        !           957: out_call (outfile, op, ftype, len, name, args)
        !           958: FILE *outfile;
        !           959: int op, ftype;
        !           960: expptr len, name, args;
        !           961: {
        !           962:     chainp arglist;            /* Pointer to any actual arguments */
        !           963:     chainp cp;                 /* Iterator over argument lists */
        !           964:     Addrp ret_val = (Addrp) NULL;
        !           965:                                /* Function return value buffer, if any is
        !           966:                                   required */
        !           967:     int byvalue;               /* True iff we're calling a C library
        !           968:                                   routine */
        !           969:     int done_once;             /* Used for writing commas to   outfile   */
        !           970:     int narg, t;
        !           971:     register expptr q;
        !           972:     long L;
        !           973:     Argtypes *at;
        !           974:     Atype *A, *Ac;
        !           975:     Namep np;
        !           976:     extern int forcereal;
        !           977: 
        !           978: /* Don't use addresses if we're calling a C function */
        !           979: 
        !           980:     byvalue = op == OPCCALL;
        !           981: 
        !           982:     if (args)
        !           983:        arglist = args -> listblock.listp;
        !           984:     else
        !           985:        arglist = CHNULL;
        !           986: 
        !           987: /* If this is a CHARACTER function, the first argument is the result */
        !           988: 
        !           989:     if (ftype == TYCHAR)
        !           990:        if (ISICON (len)) {
        !           991:            ret_val = (Addrp) (arglist -> datap);
        !           992:            arglist = arglist -> nextp;
        !           993:        } else {
        !           994:            err ("adjustable character function");
        !           995:            return;
        !           996:        } /* else */
        !           997: 
        !           998: /* If this is a COMPLEX function, the first argument is the result */
        !           999: 
        !          1000:     else if (ISCOMPLEX (ftype)) {
        !          1001:        ret_val = (Addrp) (arglist -> datap);
        !          1002:        arglist = arglist -> nextp;
        !          1003:     } /* if ISCOMPLEX */
        !          1004: 
        !          1005: /* Now we can actually start to write out the function invocation */
        !          1006: 
        !          1007:     if (ftype == TYREAL && forcereal)
        !          1008:        nice_printf(outfile, "(real)");
        !          1009:     if (name -> tag == TEXPR && name -> exprblock.opcode == OPWHATSIN) {
        !          1010:        nice_printf (outfile, "(");
        !          1011:        np = (Namep)name->exprblock.leftp; /*expr_out will free name */
        !          1012:        expr_out (outfile, name);
        !          1013:        nice_printf (outfile, ")");
        !          1014:        }
        !          1015:     else {
        !          1016:        np = (Namep)name;
        !          1017:        expr_out(outfile, name);
        !          1018:        }
        !          1019: 
        !          1020:     /* prepare to cast procedure parameters -- set A if we know how */
        !          1021: 
        !          1022:     A = Ac = 0;
        !          1023:     if (np->tag == TNAME && (at = np->arginfo)) {
        !          1024:        if (at->nargs > 0)
        !          1025:                A = at->atypes;
        !          1026:        if (Ansi && (at->defined || at->nargs > 0))
        !          1027:                Ac = at->atypes;
        !          1028:        }
        !          1029: 
        !          1030:     nice_printf(outfile, "(");
        !          1031: 
        !          1032:     if (ret_val) {
        !          1033:        if (ISCOMPLEX (ftype))
        !          1034:            nice_printf (outfile, "&");
        !          1035:        expr_out (outfile, (expptr) ret_val);
        !          1036:        if (Ac)
        !          1037:                Ac++;
        !          1038: 
        !          1039: /* The length of the result of a character function is the second argument */
        !          1040: /* It should be in place from putcall(), so we won't touch it explicitly */
        !          1041: 
        !          1042:     } /* if ret_val */
        !          1043:     done_once = ret_val ? TRUE : FALSE;
        !          1044: 
        !          1045: /* Now run through the named arguments */
        !          1046: 
        !          1047:     narg = -1;
        !          1048:     for (cp = arglist; cp; cp = cp -> nextp, done_once = TRUE) {
        !          1049: 
        !          1050:        if (done_once)
        !          1051:            nice_printf (outfile, ", ");
        !          1052:        narg++;
        !          1053: 
        !          1054:        if (!( q = (expptr)cp->datap) )
        !          1055:                continue;
        !          1056: 
        !          1057:        if (q->tag == TADDR) {
        !          1058:                if (q->addrblock.vtype > TYERROR) {
        !          1059:                        /* I/O block */
        !          1060:                        nice_printf(outfile, "&%s", q->addrblock.user.ident);
        !          1061:                        continue;
        !          1062:                        }
        !          1063:                if (!byvalue && q->addrblock.isarray
        !          1064:                && q->addrblock.vtype != TYCHAR
        !          1065:                && q->addrblock.memoffset->tag == TCONST) {
        !          1066: 
        !          1067:                        /* check for 0 offset -- after */
        !          1068:                        /* correcting for equivalence. */
        !          1069:                        L = q->addrblock.memoffset->constblock.Const.ci;
        !          1070:                        if (ONEOF(q->addrblock.vstg, M(STGCOMMON)|M(STGEQUIV))
        !          1071:                                        && q->addrblock.uname_tag == UNAM_NAME)
        !          1072:                                L -= q->addrblock.user.name->voffset;
        !          1073:                        if (L)
        !          1074:                                goto skip_deref;
        !          1075: 
        !          1076:                        if (Ac && narg < at->dnargs
        !          1077:                         && q->headblock.vtype != (t = Ac[narg].type)
        !          1078:                         && t > TYADDR && t < TYSUBR)
        !          1079:                                nice_printf(outfile, "(%s*)", typename[t]);
        !          1080: 
        !          1081:                        /* &x[0] == x */
        !          1082:                        /* This also prevents &sizeof(doublereal)[0] */
        !          1083: 
        !          1084:                        switch(q->addrblock.uname_tag) {
        !          1085:                            case UNAM_NAME:
        !          1086:                                out_name(outfile, q->addrblock.user.name);
        !          1087:                                continue;
        !          1088:                            case UNAM_IDENT:
        !          1089:                                nice_printf(outfile, "%s",
        !          1090:                                        q->addrblock.user.ident);
        !          1091:                                continue;
        !          1092:                            case UNAM_CHARP:
        !          1093:                                nice_printf(outfile, "%s",
        !          1094:                                        q->addrblock.user.Charp);
        !          1095:                                continue;
        !          1096:                            case UNAM_EXTERN:
        !          1097:                                extern_out(outfile,
        !          1098:                                        &extsymtab[q->addrblock.memno]);
        !          1099:                                continue;
        !          1100:                            }
        !          1101:                        }
        !          1102:                }
        !          1103: 
        !          1104: /* Skip over the dereferencing operator generated only for the
        !          1105:    intermediate file */
        !          1106:  skip_deref:
        !          1107:        if (q -> tag == TEXPR && q -> exprblock.opcode == OPWHATSIN)
        !          1108:            q = q -> exprblock.leftp;
        !          1109: 
        !          1110:        if (q->headblock.vclass == CLPROC) {
        !          1111:            if (Castargs && (q->tag != TNAME
        !          1112:                                || q->nameblock.vprocclass != PTHISPROC))
        !          1113:                {
        !          1114:                if (A && (t = A[narg].type) >= 200)
        !          1115:                        t %= 100;
        !          1116:                else {
        !          1117:                        t = q->headblock.vtype;
        !          1118:                        if (q->tag == TNAME && q->nameblock.vimpltype)
        !          1119:                                t = TYUNKNOWN;
        !          1120:                        }
        !          1121:                nice_printf(outfile, "(%s)", usedcasts[t] = casttypes[t]);
        !          1122:                }
        !          1123:            }
        !          1124:        else if (Ac && narg < at->dnargs
        !          1125:                && q->headblock.vtype != (t = Ac[narg].type)
        !          1126:                && t > TYADDR && t < TYSUBR)
        !          1127:                nice_printf(outfile, "(%s*)", typename[t]);
        !          1128: 
        !          1129:        if ((q -> tag == TADDR || q-> tag == TNAME) &&
        !          1130:                (byvalue || q -> headblock.vstg != STGREG)) {
        !          1131:            if (q -> headblock.vtype != TYCHAR)
        !          1132:              if (byvalue) {
        !          1133: 
        !          1134:                if (q -> tag == TADDR &&
        !          1135:                        q -> addrblock.uname_tag == UNAM_NAME &&
        !          1136:                        ! q -> addrblock.user.name -> vdim &&
        !          1137:                        oneof_stg(q -> addrblock.user.name, q -> addrblock.vstg,
        !          1138:                                        M(STGARG)|M(STGEQUIV)) &&
        !          1139:                        ! ISCOMPLEX(q->addrblock.user.name->vtype))
        !          1140:                    nice_printf (outfile, "*");
        !          1141:                else if (q -> tag == TNAME
        !          1142:                        && oneof_stg(&q->nameblock, q -> nameblock.vstg,
        !          1143:                                M(STGARG)|M(STGEQUIV))
        !          1144:                        && !(q -> nameblock.vdim))
        !          1145:                    nice_printf (outfile, "*");
        !          1146: 
        !          1147:              } else {
        !          1148:                expptr memoffset;
        !          1149: 
        !          1150:                if (q->tag == TADDR &&
        !          1151:                        !ONEOF (q -> addrblock.vstg, M(STGEXT)|M(STGLENG))
        !          1152:                        && (
        !          1153:                        ONEOF(q->addrblock.vstg,
        !          1154:                                M(STGCOMMON)|M(STGEQUIV)|M(STGMEMNO))
        !          1155:                        || ((memoffset = q->addrblock.memoffset)
        !          1156:                                && (!ISICON(memoffset)
        !          1157:                                || memoffset->constblock.Const.ci)))
        !          1158:                        || ONEOF(q->addrblock.vstg,
        !          1159:                                        M(STGINIT)|M(STGAUTO)|M(STGBSS))
        !          1160:                                && !q->addrblock.isarray)
        !          1161:                    nice_printf (outfile, "&");
        !          1162:                else if (q -> tag == TNAME
        !          1163:                        && !oneof_stg(&q->nameblock, q -> nameblock.vstg,
        !          1164:                                M(STGARG)|M(STGEXT)|M(STGEQUIV)))
        !          1165:                    nice_printf (outfile, "&");
        !          1166:            } /* else */
        !          1167: 
        !          1168:            expr_out (outfile, q);
        !          1169:        } /* if q -> tag == TADDR || q -> tag == TNAME */
        !          1170: 
        !          1171: /* Might be a Constant expression, e.g. string length, character constants */
        !          1172: 
        !          1173:        else if (q -> tag == TCONST) {
        !          1174:            if (tyioint == TYLONG)
        !          1175:                Longfmt = "%ldL";
        !          1176:            out_const(outfile, &q->constblock);
        !          1177:            Longfmt = "%ld";
        !          1178:            }
        !          1179: 
        !          1180: /* Must be some other kind of expression, or register var, or constant.
        !          1181:    In particular, this is likely to be a temporary variable assignment
        !          1182:    which was generated in p1put_call */
        !          1183: 
        !          1184:        else if (!ISCOMPLEX (q -> headblock.vtype) && !ISCHAR (q)){
        !          1185:            int use_paren = q -> tag == TEXPR &&
        !          1186:                    op_precedence (q -> exprblock.opcode) <=
        !          1187:                    op_precedence (OPCOMMA);
        !          1188: 
        !          1189:            if (use_paren) nice_printf (outfile, "(");
        !          1190:            expr_out (outfile, q);
        !          1191:            if (use_paren) nice_printf (outfile, ")");
        !          1192:        } /* if !ISCOMPLEX */
        !          1193:        else
        !          1194:            err ("out_call:  unknown parameter");
        !          1195: 
        !          1196:     } /* for (cp = arglist */
        !          1197: 
        !          1198:     if (arglist)
        !          1199:        frchain (&arglist);
        !          1200: 
        !          1201:     nice_printf (outfile, ")");
        !          1202: 
        !          1203: } /* out_call */
        !          1204: 
        !          1205: 
        !          1206:  char *
        !          1207: flconst(buf, x)
        !          1208:  char *buf, *x;
        !          1209: {
        !          1210:        sprintf(buf, fl_fmt_string, x);
        !          1211:        return buf;
        !          1212:        }
        !          1213: 
        !          1214:  char *
        !          1215: dtos(x)
        !          1216:  double x;
        !          1217: {
        !          1218:        static char buf[64];
        !          1219:        sprintf(buf, db_fmt_string, x);
        !          1220:        return buf;
        !          1221:        }
        !          1222: 
        !          1223: char tr_tab[Table_size];
        !          1224: 
        !          1225: /* out_init -- Initialize the data structures used by the routines in
        !          1226:    output.c.  These structures include the output format to be used for
        !          1227:    Float, Double, Complex, and Double Complex constants. */
        !          1228: 
        !          1229: void out_init ()
        !          1230: {
        !          1231:     extern int tab_size;
        !          1232:     register char *s;
        !          1233: 
        !          1234:     s = "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789_+-.";
        !          1235:     while(*s)
        !          1236:        tr_tab[*s++] = 3;
        !          1237:     tr_tab['>'] = 1;
        !          1238: 
        !          1239:        opeqable[OPPLUS] = 1;
        !          1240:        opeqable[OPMINUS] = 1;
        !          1241:        opeqable[OPSTAR] = 1;
        !          1242:        opeqable[OPSLASH] = 1;
        !          1243:        opeqable[OPMOD] = 1;
        !          1244:        opeqable[OPLSHIFT] = 1;
        !          1245:        opeqable[OPBITAND] = 1;
        !          1246:        opeqable[OPBITXOR] = 1;
        !          1247:        opeqable[OPBITOR ] = 1;
        !          1248: 
        !          1249: 
        !          1250: /* Set the output format for both types of floating point constants */
        !          1251: 
        !          1252:     if (fl_fmt_string == NULL || *fl_fmt_string == '\0')
        !          1253:        fl_fmt_string = Ansi == 1 ? "%sf" : "(float)%s";
        !          1254: 
        !          1255:     if (db_fmt_string == NULL || *db_fmt_string == '\0')
        !          1256:        db_fmt_string = "%.17g";
        !          1257: 
        !          1258: /* Set the output format for both types of complex constants.  They will
        !          1259:    have string parameters rather than float or double so that the decimal
        !          1260:    point may be added to the strings generated by the {db,fl}_fmt_string
        !          1261:    formats above */
        !          1262: 
        !          1263:     if (cm_fmt_string == NULL || *cm_fmt_string == '\0') {
        !          1264:        cm_fmt_string = "{%s,%s}";
        !          1265:     } /* if cm_fmt_string == NULL */
        !          1266: 
        !          1267:     if (dcm_fmt_string == NULL || *dcm_fmt_string == '\0') {
        !          1268:        dcm_fmt_string = "{%s,%s}";
        !          1269:     } /* if dcm_fmt_string == NULL */
        !          1270: 
        !          1271:     tab_size = 4;
        !          1272: } /* out_init */
        !          1273: 
        !          1274: 
        !          1275: void extern_out (fp, extsym)
        !          1276: FILE *fp;
        !          1277: Extsym *extsym;
        !          1278: {
        !          1279:     if (extsym == (Extsym *) NULL)
        !          1280:        return;
        !          1281: 
        !          1282:     nice_printf (fp, "%s", extsym->cextname);
        !          1283: 
        !          1284: } /* extern_out */
        !          1285: 
        !          1286: 
        !          1287: 
        !          1288: static void output_list (fp, listp)
        !          1289: FILE *fp;
        !          1290: struct Listblock *listp;
        !          1291: {
        !          1292:     int did_one = 0;
        !          1293:     chainp elts;
        !          1294: 
        !          1295:     nice_printf (fp, "(");
        !          1296:     if (listp)
        !          1297:        for (elts = listp -> listp; elts; elts = elts -> nextp) {
        !          1298:            if (elts -> datap) {
        !          1299:                if (did_one)
        !          1300:                    nice_printf (fp, ", ");
        !          1301:                expr_out (fp, (expptr) elts -> datap);
        !          1302:                did_one = 1;
        !          1303:            } /* if elts -> datap */
        !          1304:        } /* for elts */
        !          1305:     nice_printf (fp, ")");
        !          1306: } /* output_list */
        !          1307: 
        !          1308: 
        !          1309: void out_asgoto (outfile, expr)
        !          1310: FILE *outfile;
        !          1311: expptr expr;
        !          1312: {
        !          1313:     char *user_label();
        !          1314:     chainp value;
        !          1315:     Namep namep;
        !          1316:     int k;
        !          1317: 
        !          1318:     if (expr == (expptr) NULL) {
        !          1319:        err ("out_asgoto:  NULL variable expr");
        !          1320:        return;
        !          1321:     } /* if expr */
        !          1322: 
        !          1323:     nice_printf (outfile, Ansi ? "switch (" : "switch ((int)"); /*)*/
        !          1324:     expr_out (outfile, expr);
        !          1325:     nice_printf (outfile, ") {\n");
        !          1326:     next_tab (outfile);
        !          1327: 
        !          1328: /* The initial addrp value will be stored as a namep pointer */
        !          1329: 
        !          1330:     switch(expr->tag) {
        !          1331:        case TNAME:
        !          1332:                /* local variable */
        !          1333:                namep = &expr->nameblock;
        !          1334:                break;
        !          1335:        case TEXPR:
        !          1336:                if (expr->exprblock.opcode == OPWHATSIN
        !          1337:                 && expr->exprblock.leftp->tag == TNAME)
        !          1338:                        /* argument */
        !          1339:                        namep = &expr->exprblock.leftp->nameblock;
        !          1340:                else
        !          1341:                        goto bad;
        !          1342:                break;
        !          1343:        case TADDR:
        !          1344:                if (expr->addrblock.uname_tag == UNAM_NAME) {
        !          1345:                        /* initialized local variable */
        !          1346:                        namep = expr->addrblock.user.name;
        !          1347:                        break;
        !          1348:                        }
        !          1349:        default:
        !          1350:  bad:
        !          1351:                err("out_asgoto:  bad expr");
        !          1352:                return;
        !          1353:        }
        !          1354: 
        !          1355:     for(k = 0, value = namep -> varxptr.assigned_values; value;
        !          1356:            value = value->nextp, k++) {
        !          1357:        nice_printf (outfile, "case %d: goto %s;\n", k,
        !          1358:                user_label((long)value->datap));
        !          1359:     } /* for value */
        !          1360:     prev_tab (outfile);
        !          1361: 
        !          1362:     nice_printf (outfile, "}\n");
        !          1363: } /* out_asgoto */
        !          1364: 
        !          1365: void out_if (outfile, expr)
        !          1366: FILE *outfile;
        !          1367: expptr expr;
        !          1368: {
        !          1369:     nice_printf (outfile, "if (");
        !          1370:     expr_out (outfile, expr);
        !          1371:     nice_printf (outfile, ") {\n");
        !          1372:     next_tab (outfile);
        !          1373: } /* out_if */
        !          1374: 
        !          1375:  static void
        !          1376: output_rbrace(outfile, s)
        !          1377:  FILE *outfile;
        !          1378:  char *s;
        !          1379: {
        !          1380:        extern int last_was_label;
        !          1381:        register char *fmt;
        !          1382: 
        !          1383:        if (last_was_label) {
        !          1384:                last_was_label = 0;
        !          1385:                fmt = ";%s";
        !          1386:                }
        !          1387:        else
        !          1388:                fmt = "%s";
        !          1389:        nice_printf(outfile, fmt, s);
        !          1390:        }
        !          1391: 
        !          1392: void out_else (outfile)
        !          1393: FILE *outfile;
        !          1394: {
        !          1395:     prev_tab (outfile);
        !          1396:     output_rbrace(outfile, "} else {\n");
        !          1397:     next_tab (outfile);
        !          1398: } /* out_else */
        !          1399: 
        !          1400: void elif_out (outfile, expr)
        !          1401: FILE *outfile;
        !          1402: expptr expr;
        !          1403: {
        !          1404:     prev_tab (outfile);
        !          1405:     output_rbrace(outfile, "} else ");
        !          1406:     out_if (outfile, expr);
        !          1407: } /* elif_out */
        !          1408: 
        !          1409: void endif_out (outfile)
        !          1410: FILE *outfile;
        !          1411: {
        !          1412:     prev_tab (outfile);
        !          1413:     output_rbrace(outfile, "}\n");
        !          1414: } /* endif_out */
        !          1415: 
        !          1416: void end_else_out (outfile)
        !          1417: FILE *outfile;
        !          1418: {
        !          1419:     prev_tab (outfile);
        !          1420:     output_rbrace(outfile, "}\n");
        !          1421: } /* end_else_out */
        !          1422: 
        !          1423: 
        !          1424: 
        !          1425: void compgoto_out (outfile, index, labels)
        !          1426: FILE *outfile;
        !          1427: expptr index, labels;
        !          1428: {
        !          1429:     char *s1, *s2;
        !          1430: 
        !          1431:     if (index == ENULL)
        !          1432:        err ("compgoto_out:  null index for computed goto");
        !          1433:     else if (labels && labels -> tag != TLIST)
        !          1434:        erri ("compgoto_out:  expected label list, got tag '%d'",
        !          1435:                labels -> tag);
        !          1436:     else {
        !          1437:        extern char *user_label ();
        !          1438:        chainp elts;
        !          1439:        int i = 1;
        !          1440: 
        !          1441:        s2 = /*(*/ ") {\n"; /*}*/
        !          1442:        if (Ansi)
        !          1443:                s1 = "switch ("; /*)*/
        !          1444:        else if (index->tag == TNAME || index->tag == TEXPR
        !          1445:                                && index->exprblock.opcode == OPWHATSIN)
        !          1446:                s1 = "switch ((int)"; /*)*/
        !          1447:        else {
        !          1448:                s1 = "switch ((int)(";
        !          1449:                s2 = ")) {\n"; /*}*/
        !          1450:                }
        !          1451:        nice_printf(outfile, s1);
        !          1452:        expr_out (outfile, index);
        !          1453:        nice_printf (outfile, s2);
        !          1454:        next_tab (outfile);
        !          1455: 
        !          1456:        for (elts = labels -> listblock.listp; elts; elts = elts -> nextp, i++) {
        !          1457:            if (elts -> datap) {
        !          1458:                if (ISICON(((expptr) (elts -> datap))))
        !          1459:                    nice_printf (outfile, "case %d:  goto %s;\n", i,
        !          1460:                        user_label(((expptr)(elts->datap))->constblock.Const.ci));
        !          1461:                else
        !          1462:                    err ("compgoto_out:  bad label in label list");
        !          1463:            } /* if (elts -> datap) */
        !          1464:        } /* for elts */
        !          1465:        prev_tab (outfile);
        !          1466:        nice_printf (outfile, /*{*/ "}\n");
        !          1467:     } /* else */
        !          1468: } /* compgoto_out */
        !          1469: 
        !          1470: 
        !          1471: void out_for (outfile, init, test, inc)
        !          1472: FILE *outfile;
        !          1473: expptr init, test, inc;
        !          1474: {
        !          1475:     nice_printf (outfile, "for (");
        !          1476:     expr_out (outfile, init);
        !          1477:     nice_printf (outfile, "; ");
        !          1478:     expr_out (outfile, test);
        !          1479:     nice_printf (outfile, "; ");
        !          1480:     expr_out (outfile, inc);
        !          1481:     nice_printf (outfile, ") {\n");
        !          1482:     next_tab (outfile);
        !          1483: } /* out_for */
        !          1484: 
        !          1485: 
        !          1486: void out_end_for (outfile)
        !          1487: FILE *outfile;
        !          1488: {
        !          1489:     prev_tab (outfile);
        !          1490:     nice_printf (outfile, "}\n");
        !          1491: } /* out_end_for */

This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.