Return to p1output.c CVS log

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

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

1.1     ! root        1: /****************************************************************
        !             2: Copyright 1990, 1991, 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 "p1defs.h"
        !            26: #include "output.h"
        !            27: #include "names.h"
        !            28: 
        !            29: 
        !            30: static void p1_addr(), p1_big_addr(), p1_binary(), p1_const(), p1_list(),
        !            31:        p1_literal(), p1_name(), p1_unary(), p1putn();
        !            32: static void p1putd (/* int, int */);
        !            33: static void p1putds (/* int, int, char * */);
        !            34: static void p1putdds (/* int, int, int, char * */);
        !            35: static void p1putdd (/* int, int, int */);
        !            36: static void p1putddd (/* int, int, int, int */);
        !            37: 
        !            38: 
        !            39: /* p1_comment -- save the text of a Fortran comment in the intermediate
        !            40:    file.  Make sure that there are no spurious "/ *" or "* /" characters by
        !            41:    mapping them onto "/+" and "+/".   str   is assumed to hold no newlines and be
        !            42:    null terminated; it may be modified by this function. */
        !            43: 
        !            44: void p1_comment (str)
        !            45: char *str;
        !            46: {
        !            47:     register unsigned char *pointer, *ustr;
        !            48: 
        !            49:     if (!str)
        !            50:        return;
        !            51: 
        !            52: /* Get rid of any open or close comment combinations that may be in the
        !            53:    Fortran input */
        !            54: 
        !            55:        ustr = (unsigned char *)str;
        !            56:        for(pointer = ustr; *pointer; pointer++)
        !            57:                if (*pointer == '*' && (pointer[1] == '/'
        !            58:                                        || pointer > ustr && pointer[-1] == '/'))
        !            59:                        *pointer = '+';
        !            60:        /* trim trailing white space */
        !            61: #ifdef isascii
        !            62:        while(--pointer >= ustr && (!isascii(*pointer) || isspace(*pointer)));
        !            63: #else
        !            64:        while(--pointer >= ustr && isspace(*pointer));
        !            65: #endif
        !            66:        pointer[1] = 0;
        !            67:        p1puts (P1_COMMENT, str);
        !            68: } /* p1_comment */
        !            69: 
        !            70: void p1_line_number (line_number)
        !            71: long line_number;
        !            72: {
        !            73: 
        !            74:     p1putd (P1_SET_LINE, line_number);
        !            75: } /* p1_line_number */
        !            76: 
        !            77: /* p1_name -- Writes the address of a hash table entry into the
        !            78:    intermediate file */
        !            79: 
        !            80: static void p1_name (namep)
        !            81: Namep namep;
        !            82: {
        !            83:        p1putd (P1_NAME_POINTER, (long) namep);
        !            84:        namep->visused = 1;
        !            85: } /* p1_name */
        !            86: 
        !            87: 
        !            88: 
        !            89: void p1_expr (expr)
        !            90: expptr expr;
        !            91: {
        !            92: /* An opcode of 0 means a null entry */
        !            93: 
        !            94:     if (expr == ENULL) {
        !            95:        p1putdd (P1_EXPR, 0, TYUNKNOWN);        /* Should this be TYERROR? */
        !            96:        return;
        !            97:     } /* if (expr == ENULL) */
        !            98: 
        !            99:     switch (expr -> tag) {
        !           100:         case TNAME:
        !           101:                p1_name ((Namep) expr);
        !           102:                return;
        !           103:        case TCONST:
        !           104:                p1_const(&expr->constblock);
        !           105:                return;
        !           106:        case TEXPR:
        !           107:                /* Fall through the switch */
        !           108:                break;
        !           109:        case TADDR:
        !           110:                p1_addr (&(expr -> addrblock));
        !           111:                goto freeup;
        !           112:        case TPRIM:
        !           113:                warn ("p1_expr:  got TPRIM");
        !           114:                return;
        !           115:        case TLIST:
        !           116:                p1_list (&(expr->listblock));
        !           117:                frchain( &(expr->listblock.listp) );
        !           118:                return;
        !           119:        case TERROR:
        !           120:                return;
        !           121:        default:
        !           122:                erri ("p1_expr: bad tag '%d'", (int) (expr -> tag));
        !           123:                return;
        !           124:        }
        !           125: 
        !           126: /* Now we know that the tag is TEXPR */
        !           127: 
        !           128:     if (is_unary_op (expr -> exprblock.opcode))
        !           129:        p1_unary (&(expr -> exprblock));
        !           130:     else if (is_binary_op (expr -> exprblock.opcode))
        !           131:        p1_binary (&(expr -> exprblock));
        !           132:     else
        !           133:        erri ("p1_expr:  bad opcode '%d'", (int) expr -> exprblock.opcode);
        !           134:  freeup:
        !           135:     free((char *)expr);
        !           136: 
        !           137: } /* p1_expr */
        !           138: 
        !           139: 
        !           140: 
        !           141: static void p1_const(cp)
        !           142:  register Constp cp;
        !           143: {
        !           144:        int type = cp->vtype;
        !           145:        expptr vleng = cp->vleng;
        !           146:        union Constant *c = &cp->Const;
        !           147:        char cdsbuf0[64], cdsbuf1[64];
        !           148:        char *cds0, *cds1;
        !           149: 
        !           150:     switch (type) {
        !           151:        case TYINT1:
        !           152:         case TYSHORT:
        !           153:        case TYLONG:
        !           154: #ifdef TYQUAD
        !           155:        case TYQUAD:
        !           156: #endif
        !           157:        case TYLOGICAL:
        !           158:        case TYLOGICAL1:
        !           159:        case TYLOGICAL2:
        !           160:            fprintf(pass1_file, "%d: %d %ld\n", P1_CONST, type, c->ci);
        !           161:            break;
        !           162:        case TYREAL:
        !           163:        case TYDREAL:
        !           164:                fprintf(pass1_file, "%d: %d %s\n", P1_CONST, type,
        !           165:                        cp->vstg ? c->cds[0] : cds(dtos(c->cd[0]), cdsbuf0));
        !           166:            break;
        !           167:        case TYCOMPLEX:
        !           168:        case TYDCOMPLEX:
        !           169:                if (cp->vstg) {
        !           170:                        cds0 = c->cds[0];
        !           171:                        cds1 = c->cds[1];
        !           172:                        }
        !           173:                else {
        !           174:                        cds0 = cds(dtos(c->cd[0]), cdsbuf0);
        !           175:                        cds1 = cds(dtos(c->cd[1]), cdsbuf1);
        !           176:                        }
        !           177:                fprintf(pass1_file, "%d: %d %s %s\n", P1_CONST, type,
        !           178:                        cds0, cds1);
        !           179:            break;
        !           180:        case TYCHAR:
        !           181:            if (vleng && !ISICON (vleng))
        !           182:                erri("p1_const:  bad vleng '%d'\n", (int) vleng);
        !           183:            else
        !           184:                fprintf(pass1_file, "%d: %d %lx\n", P1_CONST, type,
        !           185:                        cpexpr((expptr)cp));
        !           186:            break;
        !           187:        default:
        !           188:            erri ("p1_const:  bad constant type '%d'", type);
        !           189:            break;
        !           190:     } /* switch */
        !           191: } /* p1_const */
        !           192: 
        !           193: 
        !           194: void p1_asgoto (addrp)
        !           195: Addrp addrp;
        !           196: {
        !           197:     p1put (P1_ASGOTO);
        !           198:     p1_addr (addrp);
        !           199: } /* p1_asgoto */
        !           200: 
        !           201: 
        !           202: void p1_goto (stateno)
        !           203: ftnint stateno;
        !           204: {
        !           205:     p1putd (P1_GOTO, stateno);
        !           206: } /* p1_goto */
        !           207: 
        !           208: 
        !           209: static void p1_addr (addrp)
        !           210:  register struct Addrblock *addrp;
        !           211: {
        !           212:     int stg;
        !           213: 
        !           214:     if (addrp == (struct Addrblock *) NULL)
        !           215:        return;
        !           216: 
        !           217:     stg = addrp -> vstg;
        !           218: 
        !           219:     if (ONEOF(stg, M(STGINIT)|M(STGREG))
        !           220:        || ONEOF(stg, M(STGCOMMON)|M(STGEQUIV)) &&
        !           221:                (!ISICON(addrp->memoffset)
        !           222:                || (addrp->uname_tag == UNAM_NAME
        !           223:                        ? addrp->memoffset->constblock.Const.ci
        !           224:                                != addrp->user.name->voffset
        !           225:                        : addrp->memoffset->constblock.Const.ci))
        !           226:        || ONEOF(stg, M(STGBSS)|M(STGINIT)|M(STGAUTO)|M(STGARG)) &&
        !           227:                (!ISICON(addrp->memoffset)
        !           228:                        || addrp->memoffset->constblock.Const.ci)
        !           229:        || addrp->Field || addrp->isarray || addrp->vstg == STGLENG)
        !           230:        {
        !           231:                p1_big_addr (addrp);
        !           232:                return;
        !           233:        }
        !           234: 
        !           235: /* Write out a level of indirection for non-array arguments, which have
        !           236:    addrp -> memoffset   set and are handled by   p1_big_addr().
        !           237:    Lengths are passed by value, so don't check STGLENG
        !           238:    28-Jun-89 (dmg)  Added the check for != TYCHAR
        !           239:  */
        !           240: 
        !           241:     if (oneof_stg ( addrp -> uname_tag == UNAM_NAME ? addrp -> user.name : NULL,
        !           242:            stg, M(STGARG)|M(STGEQUIV)) && addrp->vtype != TYCHAR) {
        !           243:        p1putdd (P1_EXPR, OPWHATSIN, addrp -> vtype);
        !           244:        p1_expr (ENULL);        /* Put dummy   vleng   */
        !           245:     } /* if stg == STGARG */
        !           246: 
        !           247:     switch (addrp -> uname_tag) {
        !           248:         case UNAM_NAME:
        !           249:            p1_name (addrp -> user.name);
        !           250:            break;
        !           251:        case UNAM_IDENT:
        !           252:            p1putdds(P1_IDENT, addrp->vtype, addrp->vstg,
        !           253:                                addrp->user.ident);
        !           254:            break;
        !           255:        case UNAM_CHARP:
        !           256:                p1putdds(P1_CHARP, addrp->vtype, addrp->vstg,
        !           257:                                addrp->user.Charp);
        !           258:                break;
        !           259:        case UNAM_EXTERN:
        !           260:            p1putd (P1_EXTERN, (long) addrp -> memno);
        !           261:            if (addrp->vclass == CLPROC)
        !           262:                extsymtab[addrp->memno].extype = addrp->vtype;
        !           263:            break;
        !           264:        case UNAM_CONST:
        !           265:            if (addrp -> memno != BAD_MEMNO)
        !           266:                p1_literal (addrp -> memno);
        !           267:            else
        !           268:                p1_const((struct Constblock *)addrp);
        !           269:            break;
        !           270:        case UNAM_UNKNOWN:
        !           271:        default:
        !           272:            erri ("p1_addr:  unknown uname_tag '%d'", addrp -> uname_tag);
        !           273:            break;
        !           274:     } /* switch */
        !           275: } /* p1_addr */
        !           276: 
        !           277: 
        !           278: static void p1_list (listp)
        !           279: struct Listblock *listp;
        !           280: {
        !           281:     chainp lis;
        !           282:     int count = 0;
        !           283: 
        !           284:     if (listp == (struct Listblock *) NULL)
        !           285:        return;
        !           286: 
        !           287: /* Count the number of parameters in the list */
        !           288: 
        !           289:     for (lis = listp -> listp; lis; lis = lis -> nextp)
        !           290:        count++;
        !           291: 
        !           292:     p1putddd (P1_LIST, listp -> tag, listp -> vtype, count);
        !           293: 
        !           294:     for (lis = listp -> listp; lis; lis = lis -> nextp)
        !           295:        p1_expr ((expptr) lis -> datap);
        !           296: 
        !           297: } /* p1_list */
        !           298: 
        !           299: 
        !           300: void p1_label (lab)
        !           301: long lab;
        !           302: {
        !           303:        if (parstate < INDATA)
        !           304:                earlylabs = mkchain((char *)lab, earlylabs);
        !           305:        else
        !           306:                p1putd (P1_LABEL, lab);
        !           307:        }
        !           308: 
        !           309: 
        !           310: 
        !           311: static void p1_literal (memno)
        !           312: long memno;
        !           313: {
        !           314:     p1putd (P1_LITERAL, memno);
        !           315: } /* p1_literal */
        !           316: 
        !           317: 
        !           318: void p1_if (expr)
        !           319: expptr expr;
        !           320: {
        !           321:     p1put (P1_IF);
        !           322:     p1_expr (expr);
        !           323: } /* p1_if */
        !           324: 
        !           325: 
        !           326: 
        !           327: 
        !           328: void p1_elif (expr)
        !           329: expptr expr;
        !           330: {
        !           331:     p1put (P1_ELIF);
        !           332:     p1_expr (expr);
        !           333: } /* p1_elif */
        !           334: 
        !           335: 
        !           336: 
        !           337: 
        !           338: void p1_else ()
        !           339: {
        !           340:     p1put (P1_ELSE);
        !           341: } /* p1_else */
        !           342: 
        !           343: 
        !           344: 
        !           345: 
        !           346: void p1_endif ()
        !           347: {
        !           348:     p1put (P1_ENDIF);
        !           349: } /* p1_endif */
        !           350: 
        !           351: 
        !           352: 
        !           353: 
        !           354: void p1else_end ()
        !           355: {
        !           356:     p1put (P1_ENDELSE);
        !           357: } /* p1else_end */
        !           358: 
        !           359: 
        !           360: static void p1_big_addr (addrp)
        !           361: Addrp addrp;
        !           362: {
        !           363:     if (addrp == (Addrp) NULL)
        !           364:        return;
        !           365: 
        !           366:     p1putn (P1_ADDR, (int)sizeof(struct Addrblock), (char *) addrp);
        !           367:     p1_expr (addrp -> vleng);
        !           368:     p1_expr (addrp -> memoffset);
        !           369:     if (addrp->uname_tag == UNAM_NAME)
        !           370:        addrp->user.name->visused = 1;
        !           371: } /* p1_big_addr */
        !           372: 
        !           373: 
        !           374: 
        !           375: static void p1_unary (e)
        !           376: struct Exprblock *e;
        !           377: {
        !           378:     if (e == (struct Exprblock *) NULL)
        !           379:        return;
        !           380: 
        !           381:     p1putdd (P1_EXPR, (int) e -> opcode, e -> vtype);
        !           382:     p1_expr (e -> vleng);
        !           383: 
        !           384:     switch (e -> opcode) {
        !           385:         case OPNEG:
        !           386:        case OPNEG1:
        !           387:        case OPNOT:
        !           388:        case OPABS:
        !           389:        case OPBITNOT:
        !           390:        case OPPREINC:
        !           391:        case OPPREDEC:
        !           392:        case OPADDR:
        !           393:        case OPIDENTITY:
        !           394:        case OPCHARCAST:
        !           395:        case OPDABS:
        !           396:            p1_expr(e -> leftp);
        !           397:            break;
        !           398:        default:
        !           399:            erri ("p1_unary: bad opcode '%d'", (int) e -> opcode);
        !           400:            break;
        !           401:     } /* switch */
        !           402: 
        !           403: } /* p1_unary */
        !           404: 
        !           405: 
        !           406: static void p1_binary (e)
        !           407: struct Exprblock *e;
        !           408: {
        !           409:     if (e == (struct Exprblock *) NULL)
        !           410:        return;
        !           411: 
        !           412:     p1putdd (P1_EXPR, e -> opcode, e -> vtype);
        !           413:     p1_expr (e -> vleng);
        !           414:     p1_expr (e -> leftp);
        !           415:     p1_expr (e -> rightp);
        !           416: } /* p1_binary */
        !           417: 
        !           418: 
        !           419: void p1_head (class, name)
        !           420: int class;
        !           421: char *name;
        !           422: {
        !           423:     p1putds (P1_HEAD, class, name ? name : "");
        !           424: } /* p1_head */
        !           425: 
        !           426: 
        !           427: void p1_subr_ret (retexp)
        !           428: expptr retexp;
        !           429: {
        !           430: 
        !           431:     p1put (P1_SUBR_RET);
        !           432:     p1_expr (cpexpr(retexp));
        !           433: } /* p1_subr_ret */
        !           434: 
        !           435: 
        !           436: 
        !           437: void p1comp_goto (index, count, labels)
        !           438: expptr index;
        !           439: int count;
        !           440: struct Labelblock *labels[];
        !           441: {
        !           442:     struct Constblock c;
        !           443:     int i;
        !           444:     register struct Labelblock *L;
        !           445: 
        !           446:     p1put (P1_COMP_GOTO);
        !           447:     p1_expr (index);
        !           448: 
        !           449: /* Write out a P1_LIST directly, to avoid the overhead of allocating a
        !           450:    list before it's needed HACK HACK HACK */
        !           451: 
        !           452:     p1putddd (P1_LIST, TLIST, TYUNKNOWN, count);
        !           453:     c.vtype = TYLONG;
        !           454:     c.vleng = 0;
        !           455: 
        !           456:     for (i = 0; i < count; i++) {
        !           457:        L = labels[i];
        !           458:        L->labused = 1;
        !           459:        c.Const.ci = L->stateno;
        !           460:        p1_const(&c);
        !           461:     } /* for i = 0 */
        !           462: } /* p1comp_goto */
        !           463: 
        !           464: 
        !           465: 
        !           466: void p1_for (init, test, inc)
        !           467: expptr init, test, inc;
        !           468: {
        !           469:     p1put (P1_FOR);
        !           470:     p1_expr (init);
        !           471:     p1_expr (test);
        !           472:     p1_expr (inc);
        !           473: } /* p1_for */
        !           474: 
        !           475: 
        !           476: void p1for_end ()
        !           477: {
        !           478:     p1put (P1_ENDFOR);
        !           479: } /* p1for_end */
        !           480: 
        !           481: 
        !           482: 
        !           483: 
        !           484: /* ----------------------------------------------------------------------
        !           485:    The intermediate file actually gets written ONLY by the routines below.
        !           486:    To change the format of the file, you need only change these routines.
        !           487:    ----------------------------------------------------------------------
        !           488: */
        !           489: 
        !           490: 
        !           491: /* p1puts -- Put a typed string into the Pass 1 intermediate file.  Assumes that
        !           492:    str   contains no newlines and is null-terminated. */
        !           493: 
        !           494: void p1puts (type, str)
        !           495: int type;
        !           496: char *str;
        !           497: {
        !           498:     fprintf (pass1_file, "%d: %s\n", type, str);
        !           499: } /* p1puts */
        !           500: 
        !           501: 
        !           502: /* p1putd -- Put a typed integer into the Pass 1 intermediate file. */
        !           503: 
        !           504: static void p1putd (type, value)
        !           505: int type;
        !           506: long value;
        !           507: {
        !           508:     fprintf (pass1_file, "%d: %ld\n", type, value);
        !           509: } /* p1_putd */
        !           510: 
        !           511: 
        !           512: /* p1putdd -- Put a typed pair of integers into the intermediate file. */
        !           513: 
        !           514: static void p1putdd (type, v1, v2)
        !           515: int type, v1, v2;
        !           516: {
        !           517:     fprintf (pass1_file, "%d: %d %d\n", type, v1, v2);
        !           518: } /* p1putdd */
        !           519: 
        !           520: 
        !           521: /* p1putddd -- Put a typed triple of integers into the intermediate file. */
        !           522: 
        !           523: static void p1putddd (type, v1, v2, v3)
        !           524: int type, v1, v2, v3;
        !           525: {
        !           526:     fprintf (pass1_file, "%d: %d %d %d\n", type, v1, v2, v3);
        !           527: } /* p1putddd */
        !           528: 
        !           529:  union dL {
        !           530:        double d;
        !           531:        long L[2];
        !           532:        };
        !           533: 
        !           534: static void p1putn (type, count, str)
        !           535: int type, count;
        !           536: char *str;
        !           537: {
        !           538:     int i;
        !           539: 
        !           540:     fprintf (pass1_file, "%d: ", type);
        !           541: 
        !           542:     for (i = 0; i < count; i++)
        !           543:        putc (str[i], pass1_file);
        !           544: 
        !           545:     putc ('\n', pass1_file);
        !           546: } /* p1putn */
        !           547: 
        !           548: 
        !           549: 
        !           550: /* p1put -- Put a type marker into the intermediate file. */
        !           551: 
        !           552: void p1put(type)
        !           553: int type;
        !           554: {
        !           555:     fprintf (pass1_file, "%d:\n", type);
        !           556: } /* p1put */
        !           557: 
        !           558: 
        !           559: 
        !           560: static void p1putds (type, i, str)
        !           561: int type;
        !           562: int i;
        !           563: char *str;
        !           564: {
        !           565:     fprintf (pass1_file, "%d: %d %s\n", type, i, str);
        !           566: } /* p1putds */
        !           567: 
        !           568: 
        !           569: static void p1putdds (token, type, stg, str)
        !           570: int token, type, stg;
        !           571: char *str;
        !           572: {
        !           573:     fprintf (pass1_file, "%d: %d %d %s\n", token, type, stg, str);
        !           574: } /* p1putdds */

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