Return to format.c CVS log

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

Annotation of researchv10no/cmd/f2c/format.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: /* Format.c -- this file takes an intermediate file (generated by pass 1
        !            25:    of the translator) and some state information about the contents of that
        !            26:    file, and generates C program text. */
        !            27: 
        !            28: #include "defs.h"
        !            29: #include "p1defs.h"
        !            30: #include "format.h"
        !            31: #include "output.h"
        !            32: #include "names.h"
        !            33: #include "iob.h"
        !            34: 
        !            35: int c_output_line_length = DEF_C_LINE_LENGTH;
        !            36: 
        !            37: int last_was_label;    /* Boolean used to generate semicolons
        !            38:                                   when a label terminates a block */
        !            39: static char this_proc_name[52];        /* Name of the current procedure.  This is
        !            40:                                   probably too simplistic to handle
        !            41:                                   multiple entry points */
        !            42: 
        !            43: static int p1getd(), p1gets(), p1getf(), get_p1_token();
        !            44: static int p1get_const(), p1getn();
        !            45: static expptr do_format(), do_p1_name_pointer(), do_p1_const();
        !            46: static expptr do_p1_expr(), do_p1_ident(), do_p1_charp(), do_p1_extern();
        !            47: static expptr do_p1_head(), do_p1_list(), do_p1_literal();
        !            48: static void do_p1_label(), do_p1_asgoto(), do_p1_goto();
        !            49: static void do_p1_if(), do_p1_else(), do_p1_elif(), do_p1_endif();
        !            50: static void do_p1_endelse(), do_p1_subr_ret(), do_p1_comp_goto();
        !            51: static void do_p1_for(), do_p1_end_for(), do_p1_fortran();
        !            52: static void do_p1_1while(), do_p1_2while(), do_p1_elseifstart();
        !            53: static void do_p1_comment(), do_p1_set_line();
        !            54: static expptr do_p1_addr();
        !            55: static void proto();
        !            56: void list_arg_types();
        !            57: chainp length_comp();
        !            58: void listargs();
        !            59: extern chainp assigned_fmts;
        !            60: static char filename[P1_FILENAME_MAX];
        !            61: extern int gflag;
        !            62: int gflag1;
        !            63: extern char *parens;
        !            64: 
        !            65: start_formatting ()
        !            66: {
        !            67:     FILE *infile;
        !            68:     static int wrote_one = 0;
        !            69:     extern int usedefsforcommon;
        !            70:     extern char *p1_file, *p1_bakfile;
        !            71: 
        !            72:     this_proc_name[0] = '\0';
        !            73:     last_was_label = 0;
        !            74:     ei_next = ei_first;
        !            75:     wh_next = wh_first;
        !            76: 
        !            77:     (void) fclose (pass1_file);
        !            78:     if ((infile = fopen (p1_file, binread)) == NULL)
        !            79:        Fatal("start_formatting:  couldn't open the intermediate file\n");
        !            80: 
        !            81:     if (wrote_one)
        !            82:        nice_printf (c_file, "\n");
        !            83: 
        !            84:     while (!feof (infile)) {
        !            85:        expptr this_expr;
        !            86: 
        !            87:        this_expr = do_format (infile, c_file);
        !            88:        if (this_expr) {
        !            89:            out_and_free_statement (c_file, this_expr);
        !            90:        } /* if this_expr */
        !            91:     } /* while !feof infile */
        !            92: 
        !            93:     (void) fclose (infile);
        !            94: 
        !            95:     if (last_was_label)
        !            96:        nice_printf (c_file, ";\n");
        !            97: 
        !            98:     prev_tab (c_file);
        !            99:     gflag1 = 0;
        !           100:     if (this_proc_name[0])
        !           101:        nice_printf (c_file, "} /* %s */\n", this_proc_name);
        !           102: 
        !           103: 
        !           104: /* Write the #undefs for common variable reference */
        !           105: 
        !           106:     if (usedefsforcommon) {
        !           107:        Extsym *ext;
        !           108:        int did_one = 0;
        !           109: 
        !           110:        for (ext = extsymtab; ext < nextext; ext++)
        !           111:            if (ext -> extstg == STGCOMMON && ext -> used_here) {
        !           112:                ext -> used_here = 0;
        !           113:                if (!did_one)
        !           114:                    nice_printf (c_file, "\n");
        !           115:                wr_abbrevs(c_file, 0, ext->extp);
        !           116:                did_one = 1;
        !           117:                ext -> extp = CHNULL;
        !           118:            } /* if */
        !           119: 
        !           120:        if (did_one)
        !           121:            nice_printf (c_file, "\n");
        !           122:     } /* if usedefsforcommon */
        !           123: 
        !           124:     other_undefs(c_file);
        !           125: 
        !           126:     wrote_one = 1;
        !           127: 
        !           128: /* For debugging only */
        !           129: 
        !           130:     if (debugflag && (pass1_file = fopen (p1_bakfile, binwrite)))
        !           131:        if (infile = fopen (p1_file, binread)) {
        !           132:            ffilecopy (infile, pass1_file);
        !           133:            fclose (infile);
        !           134:            fclose (pass1_file);
        !           135:        } /* if infile */
        !           136: 
        !           137: /* End of "debugging only" */
        !           138: 
        !           139:     scrub(p1_file);    /* optionally unlink */
        !           140: 
        !           141:     if ((pass1_file = fopen (p1_file, binwrite)) == NULL)
        !           142:        err ("start_formatting:  couldn't reopen the pass1 file");
        !           143: 
        !           144: } /* start_formatting */
        !           145: 
        !           146: 
        !           147:  static void
        !           148: put_semi(outfile)
        !           149:  FILE *outfile;
        !           150: {
        !           151:        nice_printf (outfile, ";\n");
        !           152:        last_was_label = 0;
        !           153:        }
        !           154: 
        !           155: #define SEM_CHECK(x) if (last_was_label) put_semi(x)
        !           156: 
        !           157: /* do_format -- takes an input stream (a file in pass1 format) and writes
        !           158:    the appropriate C code to   outfile   when possible.  When reading an
        !           159:    expression, the expression tree is returned instead. */
        !           160: 
        !           161: static expptr do_format (infile, outfile)
        !           162: FILE *infile, *outfile;
        !           163: {
        !           164:     int token_type, was_c_token;
        !           165:     expptr retval = ENULL;
        !           166: 
        !           167:     token_type = get_p1_token (infile);
        !           168:     was_c_token = 1;
        !           169:     switch (token_type) {
        !           170:        case P1_COMMENT:
        !           171:            do_p1_comment (infile, outfile);
        !           172:            was_c_token = 0;
        !           173:            break;
        !           174:        case P1_SET_LINE:
        !           175:            do_p1_set_line (infile);
        !           176:            was_c_token = 0;
        !           177:            break;
        !           178:        case P1_FILENAME:
        !           179:            p1gets(infile, filename, P1_FILENAME_MAX);
        !           180:            was_c_token = 0;
        !           181:            break;
        !           182:        case P1_NAME_POINTER:
        !           183:            retval = do_p1_name_pointer (infile);
        !           184:            break;
        !           185:        case P1_CONST:
        !           186:            retval = do_p1_const (infile);
        !           187:            break;
        !           188:        case P1_EXPR:
        !           189:            retval = do_p1_expr (infile, outfile);
        !           190:            break;
        !           191:        case P1_IDENT:
        !           192:            retval = do_p1_ident(infile);
        !           193:            break;
        !           194:        case P1_CHARP:
        !           195:                retval = do_p1_charp(infile);
        !           196:                break;
        !           197:        case P1_EXTERN:
        !           198:            retval = do_p1_extern (infile);
        !           199:            break;
        !           200:        case P1_HEAD:
        !           201:            gflag1 = 0;
        !           202:            retval = do_p1_head (infile, outfile);
        !           203:            gflag1 = gflag;
        !           204:            break;
        !           205:        case P1_LIST:
        !           206:            retval = do_p1_list (infile, outfile);
        !           207:            break;
        !           208:        case P1_LITERAL:
        !           209:            retval = do_p1_literal (infile);
        !           210:            break;
        !           211:        case P1_LABEL:
        !           212:            do_p1_label (infile, outfile);
        !           213:            /* last_was_label = 1; -- now set in do_p1_label */
        !           214:            was_c_token = 0;
        !           215:            break;
        !           216:        case P1_ASGOTO:
        !           217:            do_p1_asgoto (infile, outfile);
        !           218:            break;
        !           219:        case P1_GOTO:
        !           220:            do_p1_goto (infile, outfile);
        !           221:            break;
        !           222:        case P1_IF:
        !           223:            do_p1_if (infile, outfile);
        !           224:            break;
        !           225:        case P1_ELSE:
        !           226:            SEM_CHECK(outfile);
        !           227:            do_p1_else (outfile);
        !           228:            break;
        !           229:        case P1_ELIF:
        !           230:            SEM_CHECK(outfile);
        !           231:            do_p1_elif (infile, outfile);
        !           232:            break;
        !           233:        case P1_ENDIF:
        !           234:            SEM_CHECK(outfile);
        !           235:            do_p1_endif (outfile);
        !           236:            break;
        !           237:        case P1_ENDELSE:
        !           238:            SEM_CHECK(outfile);
        !           239:            do_p1_endelse (outfile);
        !           240:            break;
        !           241:        case P1_ADDR:
        !           242:            retval = do_p1_addr (infile, outfile);
        !           243:            break;
        !           244:        case P1_SUBR_RET:
        !           245:            do_p1_subr_ret (infile, outfile);
        !           246:            break;
        !           247:        case P1_COMP_GOTO:
        !           248:            do_p1_comp_goto (infile, outfile);
        !           249:            break;
        !           250:        case P1_FOR:
        !           251:            do_p1_for (infile, outfile);
        !           252:            break;
        !           253:        case P1_ENDFOR:
        !           254:            SEM_CHECK(outfile);
        !           255:            do_p1_end_for (outfile);
        !           256:            break;
        !           257:        case P1_WHILE1START:
        !           258:                do_p1_1while(outfile);
        !           259:                break;
        !           260:        case P1_WHILE2START:
        !           261:                do_p1_2while(infile, outfile);
        !           262:                break;
        !           263:        case P1_PROCODE:
        !           264:                procode(outfile);
        !           265:                break;
        !           266:        case P1_ELSEIFSTART:
        !           267:                SEM_CHECK(outfile);
        !           268:                do_p1_elseifstart(outfile);
        !           269:                break;
        !           270:        case P1_FORTRAN:
        !           271:                do_p1_fortran(infile, outfile);
        !           272:                /* no break; */
        !           273:        case P1_EOF:
        !           274:            was_c_token = 0;
        !           275:            break;
        !           276:        case P1_UNKNOWN:
        !           277:            Fatal("do_format:  Unknown token type in intermediate file");
        !           278:            break;
        !           279:        default:
        !           280:            Fatal("do_format:  Bad token type in intermediate file");
        !           281:            break;
        !           282:    } /* switch */
        !           283: 
        !           284:     if (was_c_token)
        !           285:        last_was_label = 0;
        !           286:     return retval;
        !           287: } /* do_format */
        !           288: 
        !           289: 
        !           290:  static void
        !           291: do_p1_comment (infile, outfile)
        !           292: FILE *infile, *outfile;
        !           293: {
        !           294:     extern int c_output_line_length, in_comment;
        !           295: 
        !           296:     char storage[COMMENT_BUFFER_SIZE + 1];
        !           297:     int length;
        !           298: 
        !           299:     if (!p1gets(infile, storage, COMMENT_BUFFER_SIZE + 1))
        !           300:        return;
        !           301: 
        !           302:     length = strlen (storage);
        !           303: 
        !           304:     gflag1 = 0;
        !           305:     in_comment = 1;
        !           306:     if (length > c_output_line_length - 6)
        !           307:        margin_printf (outfile, "/*%s*/\n", storage);
        !           308:     else
        !           309:        margin_printf (outfile, length ? "/* %s */\n" : "\n", storage);
        !           310:     in_comment = 0;
        !           311:     gflag1 = gflag;
        !           312: } /* do_p1_comment */
        !           313: 
        !           314:  static void
        !           315: do_p1_set_line (infile)
        !           316: FILE *infile;
        !           317: {
        !           318:     int status;
        !           319:     long new_line_number = -1;
        !           320: 
        !           321:     status = p1getd (infile, &new_line_number);
        !           322: 
        !           323:     if (status == EOF)
        !           324:        err ("do_p1_set_line:  Missing line number at end of file\n");
        !           325:     else if (status == 0 || new_line_number == -1)
        !           326:        errl("do_p1_set_line:  Illegal line number in intermediate file: %ld\n",
        !           327:                new_line_number);
        !           328:     else {
        !           329:        lineno = new_line_number;
        !           330:        }
        !           331: } /* do_p1_set_line */
        !           332: 
        !           333: 
        !           334: static expptr do_p1_name_pointer (infile)
        !           335: FILE *infile;
        !           336: {
        !           337:     Namep namep = (Namep) NULL;
        !           338:     int status;
        !           339: 
        !           340:     status = p1getd (infile, (long *) &namep);
        !           341: 
        !           342:     if (status == EOF)
        !           343:        err ("do_p1_name_pointer:  Missing pointer at end of file\n");
        !           344:     else if (status == 0 || namep == (Namep) NULL)
        !           345:        erri ("do_p1_name_pointer:  Illegal name pointer in p1 file: '%x'\n",
        !           346:                (int) namep);
        !           347: 
        !           348:     return (expptr) namep;
        !           349: } /* do_p1_name_pointer */
        !           350: 
        !           351: 
        !           352: 
        !           353: static expptr do_p1_const (infile)
        !           354: FILE *infile;
        !           355: {
        !           356:     struct Constblock *c = (struct Constblock *) NULL;
        !           357:     long type = -1;
        !           358:     int status;
        !           359: 
        !           360:     status = p1getd (infile, &type);
        !           361: 
        !           362:     if (status == EOF)
        !           363:        err ("do_p1_const:  Missing constant type at end of file\n");
        !           364:     else if (status == 0)
        !           365:        errl("do_p1_const:  Illegal constant type in p1 file: %ld\n", type);
        !           366:     else {
        !           367:        status = p1get_const (infile, (int)type, &c);
        !           368: 
        !           369:        if (status == EOF) {
        !           370:            err ("do_p1_const:  Missing constant value at end of file\n");
        !           371:            c = (struct Constblock *) NULL;
        !           372:        } else if (status == 0) {
        !           373:            err ("do_p1_const:  Illegal constant value in p1 file\n");
        !           374:            c = (struct Constblock *) NULL;
        !           375:        } /* else */
        !           376:     } /* else */
        !           377:     return (expptr) c;
        !           378: } /* do_p1_const */
        !           379: 
        !           380: 
        !           381: static expptr do_p1_literal (infile)
        !           382: FILE *infile;
        !           383: {
        !           384:     int status;
        !           385:     long memno;
        !           386:     Addrp addrp;
        !           387: 
        !           388:     status = p1getd (infile, &memno);
        !           389: 
        !           390:     if (status == EOF)
        !           391:        err ("do_p1_literal:  Missing memno at end of file");
        !           392:     else if (status == 0)
        !           393:        err ("do_p1_literal:  Missing memno in p1 file");
        !           394:     else {
        !           395:        struct Literal *litp, *lastlit;
        !           396: 
        !           397:        addrp = ALLOC (Addrblock);
        !           398:        addrp -> tag = TADDR;
        !           399:        addrp -> vtype = TYUNKNOWN;
        !           400:        addrp -> Field = NULL;
        !           401: 
        !           402:        lastlit = litpool + nliterals;
        !           403:        for (litp = litpool; litp < lastlit; litp++)
        !           404:            if (litp -> litnum == memno) {
        !           405:                addrp -> vtype = litp -> littype;
        !           406:                *((union Constant *) &(addrp -> user)) =
        !           407:                        *((union Constant *) &(litp -> litval));
        !           408:                break;
        !           409:            } /* if litp -> litnum == memno */
        !           410: 
        !           411:        addrp -> memno = memno;
        !           412:        addrp -> vstg = STGMEMNO;
        !           413:        addrp -> uname_tag = UNAM_CONST;
        !           414:     } /* else */
        !           415: 
        !           416:     return (expptr) addrp;
        !           417: } /* do_p1_literal */
        !           418: 
        !           419: 
        !           420: static void do_p1_label (infile, outfile)
        !           421: FILE *infile, *outfile;
        !           422: {
        !           423:     int status;
        !           424:     ftnint stateno;
        !           425:     char *user_label ();
        !           426:     struct Labelblock *L;
        !           427:     char *fmt;
        !           428: 
        !           429:     status = p1getd (infile, &stateno);
        !           430: 
        !           431:     if (status == EOF)
        !           432:        err ("do_p1_label:  Missing label at end of file");
        !           433:     else if (status == 0)
        !           434:        err ("do_p1_label:  Missing label in p1 file ");
        !           435:     else if (stateno < 0) {    /* entry */
        !           436:        margin_printf(outfile, "\n%s:\n", user_label(stateno));
        !           437:        last_was_label = 1;
        !           438:        }
        !           439:     else {
        !           440:        L = labeltab + stateno;
        !           441:        if (L->labused) {
        !           442:                fmt = "%s:\n";
        !           443:                last_was_label = 1;
        !           444:                }
        !           445:        else
        !           446:                fmt = "/* %s: */\n";
        !           447:        margin_printf(outfile, fmt, user_label(L->stateno));
        !           448:     } /* else */
        !           449: } /* do_p1_label */
        !           450: 
        !           451: 
        !           452: 
        !           453: static void do_p1_asgoto (infile, outfile)
        !           454: FILE *infile, *outfile;
        !           455: {
        !           456:     expptr expr;
        !           457: 
        !           458:     expr = do_format (infile, outfile);
        !           459:     out_asgoto (outfile, expr);
        !           460: 
        !           461: } /* do_p1_asgoto */
        !           462: 
        !           463: 
        !           464: static void do_p1_goto (infile, outfile)
        !           465: FILE *infile, *outfile;
        !           466: {
        !           467:     int status;
        !           468:     long stateno;
        !           469:     char *user_label ();
        !           470: 
        !           471:     status = p1getd (infile, &stateno);
        !           472: 
        !           473:     if (status == EOF)
        !           474:        err ("do_p1_goto:  Missing goto label at end of file");
        !           475:     else if (status == 0)
        !           476:        err ("do_p1_goto:  Missing goto label in p1 file");
        !           477:     else {
        !           478:        nice_printf (outfile, "goto %s;\n", user_label (stateno));
        !           479:     } /* else */
        !           480: } /* do_p1_goto */
        !           481: 
        !           482: 
        !           483: static void do_p1_if (infile, outfile)
        !           484: FILE *infile, *outfile;
        !           485: {
        !           486:     expptr cond;
        !           487: 
        !           488:     do {
        !           489:         cond = do_format (infile, outfile);
        !           490:     } while (cond == ENULL);
        !           491: 
        !           492:     out_if (outfile, cond);
        !           493: } /* do_p1_if */
        !           494: 
        !           495: 
        !           496: static void do_p1_else (outfile)
        !           497: FILE *outfile;
        !           498: {
        !           499:     out_else (outfile);
        !           500: } /* do_p1_else */
        !           501: 
        !           502: 
        !           503: static void do_p1_elif (infile, outfile)
        !           504: FILE *infile, *outfile;
        !           505: {
        !           506:     expptr cond;
        !           507: 
        !           508:     do {
        !           509:         cond = do_format (infile, outfile);
        !           510:     } while (cond == ENULL);
        !           511: 
        !           512:     elif_out (outfile, cond);
        !           513: } /* do_p1_elif */
        !           514: 
        !           515: static void do_p1_endif (outfile)
        !           516: FILE *outfile;
        !           517: {
        !           518:     endif_out (outfile);
        !           519: } /* do_p1_endif */
        !           520: 
        !           521: 
        !           522: static void do_p1_endelse (outfile)
        !           523: FILE *outfile;
        !           524: {
        !           525:     end_else_out (outfile);
        !           526: } /* do_p1_endelse */
        !           527: 
        !           528: 
        !           529: static expptr do_p1_addr (infile, outfile)
        !           530: FILE *infile, *outfile;
        !           531: {
        !           532:     Addrp addrp = (Addrp) NULL;
        !           533:     int status;
        !           534: 
        !           535:     status = p1getn (infile, (int)sizeof(struct Addrblock), (char **) &addrp);
        !           536: 
        !           537:     if (status == EOF)
        !           538:        err ("do_p1_addr:  Missing Addrp at end of file");
        !           539:     else if (status == 0)
        !           540:        err ("do_p1_addr:  Missing Addrp in p1 file");
        !           541:     else if (addrp == (Addrp) NULL)
        !           542:        err ("do_p1_addr:  Null addrp in p1 file");
        !           543:     else if (addrp -> tag != TADDR)
        !           544:        erri ("do_p1_addr: bad tag in p1 file '%d'", addrp -> tag);
        !           545:     else {
        !           546:        addrp -> vleng = do_format (infile, outfile);
        !           547:        addrp -> memoffset = do_format (infile, outfile);
        !           548:     }
        !           549: 
        !           550:     return (expptr) addrp;
        !           551: } /* do_p1_addr */
        !           552: 
        !           553: 
        !           554: 
        !           555: static void do_p1_subr_ret (infile, outfile)
        !           556: FILE *infile, *outfile;
        !           557: {
        !           558:     expptr retval;
        !           559: 
        !           560:     nice_printf (outfile, "return ");
        !           561:     retval = do_format (infile, outfile);
        !           562:     if (!multitype)
        !           563:        if (retval)
        !           564:                expr_out (outfile, retval);
        !           565: 
        !           566:     nice_printf (outfile, ";\n");
        !           567: } /* do_p1_subr_ret */
        !           568: 
        !           569: 
        !           570: 
        !           571: static void do_p1_comp_goto (infile, outfile)
        !           572: FILE *infile, *outfile;
        !           573: {
        !           574:     expptr index;
        !           575:     expptr labels;
        !           576: 
        !           577:     index = do_format (infile, outfile);
        !           578: 
        !           579:     if (index == ENULL) {
        !           580:        err ("do_p1_comp_goto:  no expression for computed goto");
        !           581:        return;
        !           582:     } /* if index == ENULL */
        !           583: 
        !           584:     labels = do_format (infile, outfile);
        !           585: 
        !           586:     if (labels && labels -> tag != TLIST)
        !           587:        erri ("do_p1_comp_goto:  expected list, got tag '%d'", labels -> tag);
        !           588:     else
        !           589:        compgoto_out (outfile, index, labels);
        !           590: } /* do_p1_comp_goto */
        !           591: 
        !           592: 
        !           593: static void do_p1_for (infile, outfile)
        !           594: FILE *infile, *outfile;
        !           595: {
        !           596:     expptr init, test, inc;
        !           597: 
        !           598:     init = do_format (infile, outfile);
        !           599:     test = do_format (infile, outfile);
        !           600:     inc = do_format (infile, outfile);
        !           601: 
        !           602:     out_for (outfile, init, test, inc);
        !           603: } /* do_p1_for */
        !           604: 
        !           605: static void do_p1_end_for (outfile)
        !           606: FILE *outfile;
        !           607: {
        !           608:     out_end_for (outfile);
        !           609: } /* do_p1_end_for */
        !           610: 
        !           611: 
        !           612:  static void
        !           613: do_p1_fortran(infile, outfile)
        !           614:  FILE *infile, *outfile;
        !           615: {
        !           616:        char buf[P1_STMTBUFSIZE];
        !           617:        if (!p1gets(infile, buf, P1_STMTBUFSIZE))
        !           618:                return;
        !           619:        /* bypass nice_printf nonsense */
        !           620:        fprintf(outfile, "/*< %s >*/\n", buf+1);        /* + 1 to skip by '$' */
        !           621:        }
        !           622: 
        !           623: 
        !           624: static expptr do_p1_expr (infile, outfile)
        !           625: FILE *infile, *outfile;
        !           626: {
        !           627:     int status;
        !           628:     long opcode, type;
        !           629:     struct Exprblock *result = (struct Exprblock *) NULL;
        !           630: 
        !           631:     status = p1getd (infile, &opcode);
        !           632: 
        !           633:     if (status == EOF)
        !           634:        err ("do_p1_expr:  Missing expr opcode at end of file");
        !           635:     else if (status == 0)
        !           636:        err ("do_p1_expr:  Missing expr opcode in p1 file");
        !           637:     else {
        !           638: 
        !           639:        status = p1getd (infile, &type);
        !           640: 
        !           641:        if (status == EOF)
        !           642:            err ("do_p1_expr:  Missing expr type at end of file");
        !           643:        else if (status == 0)
        !           644:            err ("do_p1_expr:  Missing expr type in p1 file");
        !           645:        else if (opcode == 0)
        !           646:            return ENULL;
        !           647:        else {
        !           648:            result = ALLOC (Exprblock);
        !           649: 
        !           650:            result -> tag = TEXPR;
        !           651:            result -> vtype = type;
        !           652:            result -> opcode = opcode;
        !           653:            result -> vleng = do_format (infile, outfile);
        !           654: 
        !           655:            if (is_unary_op (opcode))
        !           656:                result -> leftp = do_format (infile, outfile);
        !           657:            else if (is_binary_op (opcode)) {
        !           658:                result -> leftp = do_format (infile, outfile);
        !           659:                result -> rightp = do_format (infile, outfile);
        !           660:            } else
        !           661:                errl("do_p1_expr:  Illegal opcode %ld", opcode);
        !           662:        } /* else */
        !           663:     } /* else */
        !           664: 
        !           665:     return (expptr) result;
        !           666: } /* do_p1_expr */
        !           667: 
        !           668: 
        !           669: static expptr do_p1_ident(infile)
        !           670: FILE *infile;
        !           671: {
        !           672:        Addrp addrp;
        !           673:        int status;
        !           674:        long vtype, vstg;
        !           675: 
        !           676:        addrp = ALLOC (Addrblock);
        !           677:        addrp -> tag = TADDR;
        !           678: 
        !           679:        status = p1getd (infile, &vtype);
        !           680:        if (status == EOF)
        !           681:            err ("do_p1_ident:  Missing identifier type at end of file\n");
        !           682:        else if (status == 0 || vtype < 0 || vtype >= NTYPES)
        !           683:            errl("do_p1_ident:  Bad type in intermediate file: %ld\n", vtype);
        !           684:        else
        !           685:            addrp -> vtype = vtype;
        !           686: 
        !           687:        status = p1getd (infile, &vstg);
        !           688:        if (status == EOF)
        !           689:            err ("do_p1_ident:  Missing identifier storage at end of file\n");
        !           690:        else if (status == 0 || vstg < 0 || vstg > STGNULL)
        !           691:            errl("do_p1_ident:  Bad storage in intermediate file: %ld\n", vtype);
        !           692:        else
        !           693:            addrp -> vstg = vstg;
        !           694: 
        !           695:        status = p1gets(infile, addrp->user.ident, IDENT_LEN);
        !           696: 
        !           697:        if (status == EOF)
        !           698:            err ("do_p1_ident:  Missing ident string at end of file");
        !           699:        else if (status == 0)
        !           700:            err ("do_p1_ident:  Missing ident string in intermediate file");
        !           701:        addrp->uname_tag = UNAM_IDENT;
        !           702:        return (expptr) addrp;
        !           703: } /* do_p1_ident */
        !           704: 
        !           705: static expptr do_p1_charp(infile)
        !           706: FILE *infile;
        !           707: {
        !           708:        Addrp addrp;
        !           709:        int status;
        !           710:        long vtype, vstg;
        !           711:        char buf[64];
        !           712: 
        !           713:        addrp = ALLOC (Addrblock);
        !           714:        addrp -> tag = TADDR;
        !           715: 
        !           716:        status = p1getd (infile, &vtype);
        !           717:        if (status == EOF)
        !           718:            err ("do_p1_ident:  Missing identifier type at end of file\n");
        !           719:        else if (status == 0 || vtype < 0 || vtype >= NTYPES)
        !           720:            errl("do_p1_ident:  Bad type in intermediate file: %ld\n", vtype);
        !           721:        else
        !           722:            addrp -> vtype = vtype;
        !           723: 
        !           724:        status = p1getd (infile, &vstg);
        !           725:        if (status == EOF)
        !           726:            err ("do_p1_ident:  Missing identifier storage at end of file\n");
        !           727:        else if (status == 0 || vstg < 0 || vstg > STGNULL)
        !           728:            errl("do_p1_ident:  Bad storage in intermediate file: %ld\n", vtype);
        !           729:        else
        !           730:            addrp -> vstg = vstg;
        !           731: 
        !           732:        status = p1gets(infile, buf, (int)sizeof(buf));
        !           733: 
        !           734:        if (status == EOF)
        !           735:            err ("do_p1_ident:  Missing charp ident string at end of file");
        !           736:        else if (status == 0)
        !           737:            err ("do_p1_ident:  Missing charp ident string in intermediate file");
        !           738:        addrp->uname_tag = UNAM_CHARP;
        !           739:        addrp->user.Charp = strcpy(mem(strlen(buf)+1,0), buf);
        !           740:        return (expptr) addrp;
        !           741: }
        !           742: 
        !           743: 
        !           744: static expptr do_p1_extern (infile)
        !           745: FILE *infile;
        !           746: {
        !           747:     Addrp addrp;
        !           748: 
        !           749:     addrp = ALLOC (Addrblock);
        !           750:     if (addrp) {
        !           751:        int status;
        !           752: 
        !           753:        addrp->tag = TADDR;
        !           754:        addrp->vstg = STGEXT;
        !           755:        addrp->uname_tag = UNAM_EXTERN;
        !           756:        status = p1getd (infile, &(addrp -> memno));
        !           757:        if (status == EOF)
        !           758:            err ("do_p1_extern:  Missing memno at end of file");
        !           759:        else if (status == 0)
        !           760:            err ("do_p1_extern:  Missing memno in intermediate file");
        !           761:        if (addrp->vtype = extsymtab[addrp->memno].extype)
        !           762:                addrp->vclass = CLPROC;
        !           763:     } /* if addrp */
        !           764: 
        !           765:     return (expptr) addrp;
        !           766: } /* do_p1_extern */
        !           767: 
        !           768: 
        !           769: 
        !           770: static expptr do_p1_head (infile, outfile)
        !           771: FILE *infile, *outfile;
        !           772: {
        !           773:     int status;
        !           774:     int add_n_;
        !           775:     long class;
        !           776:     char storage[256];
        !           777: 
        !           778:     status = p1getd (infile, &class);
        !           779:     if (status == EOF)
        !           780:        err ("do_p1_head:  missing header class at end of file");
        !           781:     else if (status == 0)
        !           782:        err ("do_p1_head:  missing header class in p1 file");
        !           783:     else {
        !           784:        status = p1gets (infile, storage, (int)sizeof(storage));
        !           785:        if (status == EOF || status == 0)
        !           786:            storage[0] = '\0';
        !           787:     } /* else */
        !           788: 
        !           789:     if (class == CLPROC || class == CLMAIN) {
        !           790:        chainp lengths;
        !           791: 
        !           792:        add_n_ = nentry > 1;
        !           793:        lengths = length_comp(entries, add_n_);
        !           794: 
        !           795:        if (!add_n_ && protofile && class != CLMAIN)
        !           796:                protowrite(protofile, proctype, storage, entries, lengths);
        !           797: 
        !           798:        if (class == CLMAIN)
        !           799:            nice_printf (outfile, "/* Main program */ ");
        !           800:        else
        !           801:            nice_printf(outfile, "%s ", multitype ? "VOID"
        !           802:                        : c_type_decl(proctype, 1));
        !           803: 
        !           804:        nice_printf(outfile, add_n_ ? "%s0_" : "%s", storage);
        !           805:        if (!Ansi) {
        !           806:                listargs(outfile, entries, add_n_, lengths);
        !           807:                nice_printf (outfile, "\n");
        !           808:                }
        !           809:        list_arg_types (outfile, entries, lengths, add_n_, "\n");
        !           810:        nice_printf (outfile, "{\n");
        !           811:        frchain(&lengths);
        !           812:        next_tab (outfile);
        !           813:        strcpy(this_proc_name, storage);
        !           814:        list_decls (outfile);
        !           815: 
        !           816:     } else if (class == CLBLOCK)
        !           817:         next_tab (outfile);
        !           818:     else
        !           819:        errl("do_p1_head: got class %ld", class);
        !           820: 
        !           821:     return NULL;
        !           822: } /* do_p1_head */
        !           823: 
        !           824: 
        !           825: static expptr do_p1_list (infile, outfile)
        !           826: FILE *infile, *outfile;
        !           827: {
        !           828:     long tag, type, count;
        !           829:     int status;
        !           830:     expptr result;
        !           831: 
        !           832:     status = p1getd (infile, &tag);
        !           833:     if (status == EOF)
        !           834:        err ("do_p1_list:  missing list tag at end of file");
        !           835:     else if (status == 0)
        !           836:        err ("do_p1_list:  missing list tag in p1 file");
        !           837:     else {
        !           838:        status = p1getd (infile, &type);
        !           839:        if (status == EOF)
        !           840:            err ("do_p1_list:  missing list type at end of file");
        !           841:        else if (status == 0)
        !           842:            err ("do_p1_list:  missing list type in p1 file");
        !           843:        else {
        !           844:            status = p1getd (infile, &count);
        !           845:            if (status == EOF)
        !           846:                err ("do_p1_list:  missing count at end of file");
        !           847:            else if (status == 0)
        !           848:                err ("do_p1_list:  missing count in p1 file");
        !           849:        } /* else */
        !           850:     } /* else */
        !           851: 
        !           852:     result = (expptr) ALLOC (Listblock);
        !           853:     if (result) {
        !           854:        chainp pointer;
        !           855: 
        !           856:        result -> tag = tag;
        !           857:        result -> listblock.vtype = type;
        !           858: 
        !           859: /* Assume there will be enough data */
        !           860: 
        !           861:        if (count--) {
        !           862:            pointer = result->listblock.listp =
        !           863:                mkchain((char *)do_format(infile, outfile), CHNULL);
        !           864:            while (count--) {
        !           865:                pointer -> nextp =
        !           866:                        mkchain((char *)do_format(infile, outfile), CHNULL);
        !           867:                pointer = pointer -> nextp;
        !           868:            } /* while (count--) */
        !           869:        } /* if (count) */
        !           870:     } /* if (result) */
        !           871: 
        !           872:     return result;
        !           873: } /* do_p1_list */
        !           874: 
        !           875: 
        !           876: chainp length_comp(e, add_n)   /* get lengths of characters args */
        !           877:  struct Entrypoint *e;
        !           878:  int add_n;
        !           879: {
        !           880:        chainp lengths;
        !           881:        chainp args, args1;
        !           882:        Namep arg, np;
        !           883:        int nchargs;
        !           884:        Argtypes *at;
        !           885:        Atype *a;
        !           886:        extern int init_ac[TYSUBR+1];
        !           887: 
        !           888:        if (!e)
        !           889:                return 0;       /* possible only with errors */
        !           890:        args = args1 = add_n ? allargs : e->arglist;
        !           891:        nchargs = 0;
        !           892:        for (lengths = NULL; args; args = args -> nextp)
        !           893:                if (arg = (Namep)args->datap) {
        !           894:                        if (arg->vclass == CLUNKNOWN)
        !           895:                                arg->vclass = CLVAR;
        !           896:                        if (arg->vtype == TYCHAR && arg->vclass != CLPROC) {
        !           897:                                lengths = mkchain((char *)arg, lengths);
        !           898:                                nchargs++;
        !           899:                                }
        !           900:                        }
        !           901:        if (!add_n && (np = e->enamep)) {
        !           902:                /* one last check -- by now we know all we ever will
        !           903:                 * about external args...
        !           904:                 */
        !           905:                save_argtypes(e->arglist, &e->entryname->arginfo,
        !           906:                        &np->arginfo, 0, np->fvarname, STGEXT, nchargs,
        !           907:                        np->vtype, 1);
        !           908:                at = e->entryname->arginfo;
        !           909:                a = at->atypes + init_ac[np->vtype];
        !           910:                for(; args1; a++, args1 = args1->nextp) {
        !           911:                        frchain(&a->cp);
        !           912:                        if (arg = (Namep)args1->datap)
        !           913:                            switch(arg->vclass) {
        !           914:                                case CLPROC:
        !           915:                                        if (arg->vimpltype
        !           916:                                        && a->type >= 300)
        !           917:                                                a->type = TYUNKNOWN + 200;
        !           918:                                        break;
        !           919:                                case CLUNKNOWN:
        !           920:                                        a->type %= 100;
        !           921:                                }
        !           922:                        }
        !           923:                }
        !           924:        return revchain(lengths);
        !           925:        }
        !           926: 
        !           927: void listargs(outfile, entryp, add_n_, lengths)
        !           928:  FILE *outfile;
        !           929:  struct Entrypoint *entryp;
        !           930:  int add_n_;
        !           931:  chainp lengths;
        !           932: {
        !           933:        chainp args;
        !           934:        char *s;
        !           935:        Namep arg;
        !           936:        int did_one = 0;
        !           937: 
        !           938:        nice_printf (outfile, "(");
        !           939: 
        !           940:        if (add_n_) {
        !           941:                nice_printf(outfile, "n__");
        !           942:                did_one = 1;
        !           943:                args = allargs;
        !           944:                }
        !           945:        else {
        !           946:                if (!entryp)
        !           947:                        return; /* possible only with errors */
        !           948:                args = entryp->arglist;
        !           949:                }
        !           950: 
        !           951:        if (multitype)
        !           952:                {
        !           953:                nice_printf(outfile, ", ret_val");
        !           954:                did_one = 1;
        !           955:                args = allargs;
        !           956:                }
        !           957:        else if (ONEOF(proctype, MSKCOMPLEX|MSKCHAR))
        !           958:                {
        !           959:                s = xretslot[proctype]->user.ident;
        !           960:                nice_printf(outfile, did_one ? ", %s" : "%s",
        !           961:                        *s == '(' /*)*/ ? "r_v" : s);
        !           962:                did_one = 1;
        !           963:                if (proctype == TYCHAR)
        !           964:                        nice_printf (outfile, ", ret_val_len");
        !           965:                }
        !           966:        for (; args; args = args -> nextp)
        !           967:                if (arg = (Namep)args->datap) {
        !           968:                        nice_printf (outfile, "%s", did_one ? ", " : "");
        !           969:                        out_name (outfile, arg);
        !           970:                        did_one = 1;
        !           971:                        }
        !           972: 
        !           973:        for (args = lengths; args; args = args -> nextp)
        !           974:                nice_printf(outfile, ", %s",
        !           975:                        new_arg_length((Namep)args->datap));
        !           976:        nice_printf (outfile, ")");
        !           977: } /* listargs */
        !           978: 
        !           979: 
        !           980: void list_arg_types(outfile, entryp, lengths, add_n_, finalnl)
        !           981: FILE *outfile;
        !           982: struct Entrypoint *entryp;
        !           983: chainp lengths;
        !           984: int add_n_;
        !           985: char *finalnl;
        !           986: {
        !           987:     chainp args;
        !           988:     int last_type = -1, last_class = -1;
        !           989:     int did_one = 0, done_one, is_ext;
        !           990:     char *s, *sep = "", *sep1;
        !           991: 
        !           992:     if (outfile == (FILE *) NULL) {
        !           993:        err ("list_arg_types:  null output file");
        !           994:        return;
        !           995:     } else if (entryp == (struct Entrypoint *) NULL) {
        !           996:        err ("list_arg_types:  null procedure entry pointer");
        !           997:        return;
        !           998:     } /* else */
        !           999: 
        !          1000:     if (Ansi) {
        !          1001:        done_one = 0;
        !          1002:        sep1 = ", ";
        !          1003:        nice_printf(outfile, "(" /*)*/);
        !          1004:        }
        !          1005:     else {
        !          1006:        done_one = 1;
        !          1007:        sep1 = ";\n";
        !          1008:        }
        !          1009:     args = entryp->arglist;
        !          1010:     if (add_n_) {
        !          1011:        nice_printf(outfile, "int n__");
        !          1012:        did_one = done_one;
        !          1013:        sep = sep1;
        !          1014:        args = allargs;
        !          1015:        }
        !          1016:     if (multitype) {
        !          1017:        nice_printf(outfile, "%sMultitype *ret_val", sep);
        !          1018:        did_one = done_one;
        !          1019:        sep = sep1;
        !          1020:        }
        !          1021:     else if (ONEOF (proctype, MSKCOMPLEX|MSKCHAR)) {
        !          1022:        s = xretslot[proctype]->user.ident;
        !          1023:        nice_printf(outfile, "%s%s *%s", sep, c_type_decl(proctype, 0),
        !          1024:                        *s == '(' /*)*/ ? "r_v" : s);
        !          1025:        did_one = done_one;
        !          1026:        sep = sep1;
        !          1027:        if (proctype == TYCHAR)
        !          1028:            nice_printf (outfile, "%sftnlen ret_val_len", sep);
        !          1029:     } /* if ONEOF proctype */
        !          1030:     for (; args; args = args -> nextp) {
        !          1031:        Namep arg = (Namep) args->datap;
        !          1032: 
        !          1033: /* Scalars are passed by reference, and arrays will have their lower bound
        !          1034:    adjusted, so nearly everything is printed with a star in front.  The
        !          1035:    exception is character lengths, which are passed by value. */
        !          1036: 
        !          1037:        if (arg) {
        !          1038:            int type = arg -> vtype, class = arg -> vclass;
        !          1039: 
        !          1040:            if (class == CLPROC)
        !          1041:                if (arg->vimpltype)
        !          1042:                        type = Castargs ? TYUNKNOWN : TYSUBR;
        !          1043:                else if (type == TYREAL && forcedouble && !Castargs)
        !          1044:                        type = TYDREAL;
        !          1045: 
        !          1046:            if (type == last_type && class == last_class && did_one)
        !          1047:                nice_printf (outfile, ", ");
        !          1048:            else
        !          1049:                if ((is_ext = class == CLPROC) && Castargs)
        !          1050:                        nice_printf(outfile, "%s%s ", sep,
        !          1051:                                usedcasts[type] = casttypes[type]);
        !          1052:                else
        !          1053:                        nice_printf(outfile, "%s%s ", sep,
        !          1054:                                c_type_decl(type, is_ext));
        !          1055:            if (class == CLPROC)
        !          1056:                if (Castargs)
        !          1057:                        out_name(outfile, arg);
        !          1058:                else {
        !          1059:                        nice_printf(outfile, "(*");
        !          1060:                        out_name(outfile, arg);
        !          1061:                        nice_printf(outfile, ") %s", parens);
        !          1062:                        }
        !          1063:            else {
        !          1064:                nice_printf (outfile, "*");
        !          1065:                out_name (outfile, arg);
        !          1066:                }
        !          1067: 
        !          1068:            last_type = type;
        !          1069:            last_class = class;
        !          1070:            did_one = done_one;
        !          1071:            sep = sep1;
        !          1072:        } /* if (arg) */
        !          1073:     } /* for args = entryp -> arglist */
        !          1074: 
        !          1075:     for (args = lengths; args; args = args -> nextp)
        !          1076:        nice_printf(outfile, "%sftnlen %s", sep,
        !          1077:                        new_arg_length((Namep)args->datap));
        !          1078:     if (did_one)
        !          1079:        nice_printf (outfile, ";\n");
        !          1080:     else if (Ansi)
        !          1081:        nice_printf(outfile,
        !          1082:                /*((*/ sep != sep1 && Ansi == 1 ? "void)%s" : ")%s",
        !          1083:                finalnl);
        !          1084: } /* list_arg_types */
        !          1085: 
        !          1086:  static void
        !          1087: write_formats(outfile)
        !          1088:  FILE *outfile;
        !          1089: {
        !          1090:        register struct Labelblock *lp;
        !          1091:        int first = 1;
        !          1092:        char *fs;
        !          1093: 
        !          1094:        for(lp = labeltab ; lp < highlabtab ; ++lp)
        !          1095:                if (lp->fmtlabused) {
        !          1096:                        if (first) {
        !          1097:                                first = 0;
        !          1098:                                nice_printf(outfile, "/* Format strings */\n");
        !          1099:                                }
        !          1100:                        nice_printf(outfile, "static char fmt_%ld[] = \"",
        !          1101:                                lp->stateno);
        !          1102:                        if (!(fs = lp->fmtstring))
        !          1103:                                fs = "";
        !          1104:                        nice_printf(outfile, "%s\";\n", fs);
        !          1105:                        }
        !          1106:        if (!first)
        !          1107:                nice_printf(outfile, "\n");
        !          1108:        }
        !          1109: 
        !          1110:  static void
        !          1111: write_ioblocks(outfile)
        !          1112:  FILE *outfile;
        !          1113: {
        !          1114:        register iob_data *L;
        !          1115:        register char *f, **s, *sep;
        !          1116: 
        !          1117:        nice_printf(outfile, "/* Fortran I/O blocks */\n");
        !          1118:        L = iob_list = (iob_data *)revchain((chainp)iob_list);
        !          1119:        do {
        !          1120:                nice_printf(outfile, "static %s %s = { ",
        !          1121:                        L->type, L->name);
        !          1122:                sep = 0;
        !          1123:                for(s = L->fields; f = *s; s++) {
        !          1124:                        if (sep)
        !          1125:                                nice_printf(outfile, sep);
        !          1126:                        sep = ", ";
        !          1127:                        if (*f == '"') {        /* kludge */
        !          1128:                                nice_printf(outfile, "\"");
        !          1129:                                nice_printf(outfile, "%s\"", f+1);
        !          1130:                                }
        !          1131:                        else
        !          1132:                                nice_printf(outfile, "%s", f);
        !          1133:                        }
        !          1134:                nice_printf(outfile, " };\n");
        !          1135:                }
        !          1136:                while(L = L->next);
        !          1137:        nice_printf(outfile, "\n\n");
        !          1138:        }
        !          1139: 
        !          1140:  static void
        !          1141: write_assigned_fmts(outfile)
        !          1142:  FILE *outfile;
        !          1143: {
        !          1144:        register chainp cp;
        !          1145:        Namep np;
        !          1146:        int did_one = 0;
        !          1147: 
        !          1148:        cp = assigned_fmts = revchain(assigned_fmts);
        !          1149:        nice_printf(outfile, "/* Assigned format variables */\nchar ");
        !          1150:        do {
        !          1151:                np = (Namep)cp->datap;
        !          1152:                if (did_one)
        !          1153:                        nice_printf(outfile, ", ");
        !          1154:                did_one = 1;
        !          1155:                nice_printf(outfile, "*%s_fmt", np->fvarname);
        !          1156:                }
        !          1157:                while(cp = cp->nextp);
        !          1158:        nice_printf(outfile, ";\n\n");
        !          1159:        }
        !          1160: 
        !          1161:  static char *
        !          1162: to_upper(s)
        !          1163:  register char *s;
        !          1164: {
        !          1165:        static char buf[64];
        !          1166:        register char *t = buf;
        !          1167:        register int c;
        !          1168:        while(*t++ = (c = *s++) >= 'a' && c <= 'z' ? c + 'A' - 'a' : c);
        !          1169:        return buf;
        !          1170:        }
        !          1171: 
        !          1172: 
        !          1173: /* This routine creates static structures representing a namelist.
        !          1174:    Declarations of the namelist and related structures are:
        !          1175: 
        !          1176:        struct Vardesc {
        !          1177:                char *name;
        !          1178:                char *addr;
        !          1179:                ftnlen *dims;   /* laid out as struct dimensions below *//*
        !          1180:                int  type;
        !          1181:                };
        !          1182:        typedef struct Vardesc Vardesc;
        !          1183: 
        !          1184:        struct Namelist {
        !          1185:                char *name;
        !          1186:                Vardesc **vars;
        !          1187:                int nvars;
        !          1188:                };
        !          1189: 
        !          1190:        struct dimensions
        !          1191:                {
        !          1192:                ftnlen numberofdimensions;
        !          1193:                ftnlen numberofelements
        !          1194:                ftnlen baseoffset;
        !          1195:                ftnlen span[numberofdimensions-1];
        !          1196:                };
        !          1197: 
        !          1198:    If dims is not null, then the corner element of the array is at
        !          1199:    addr.  However,  the element with subscripts (i1,...,in) is at
        !          1200:    addr + sizeoftype * (i1+span[0]*(i2+span[1]*...) - dimp->baseoffset)
        !          1201: */
        !          1202: 
        !          1203:  static void
        !          1204: write_namelists(nmch, outfile)
        !          1205:  chainp nmch;
        !          1206:  FILE *outfile;
        !          1207: {
        !          1208:        Namep var;
        !          1209:        struct Hashentry *entry;
        !          1210:        struct Dimblock *dimp;
        !          1211:        int i, nd, type;
        !          1212:        char *comma, *name;
        !          1213:        register chainp q;
        !          1214:        register Namep v;
        !          1215:        extern int typeconv[];
        !          1216: 
        !          1217:        nice_printf(outfile, "/* Namelist stuff */\n\n");
        !          1218:        for (entry = hashtab; entry < lasthash; ++entry) {
        !          1219:                if (!(v = entry->varp) || !v->vnamelist)
        !          1220:                        continue;
        !          1221:                type = v->vtype;
        !          1222:                name = v->cvarname;
        !          1223:                if (dimp = v->vdim) {
        !          1224:                        nd = dimp->ndim;
        !          1225:                        nice_printf(outfile,
        !          1226:                                "static ftnlen %s_dims[] = { %d, %ld, %ld",
        !          1227:                                name, nd,
        !          1228:                                dimp->nelt->constblock.Const.ci,
        !          1229:                                dimp->baseoffset->constblock.Const.ci);
        !          1230:                        for(i = 0, --nd; i < nd; i++)
        !          1231:                                nice_printf(outfile, ", %ld",
        !          1232:                                  dimp->dims[i].dimsize->constblock.Const.ci);
        !          1233:                        nice_printf(outfile, " };\n");
        !          1234:                        }
        !          1235:                nice_printf(outfile, "static Vardesc %s_dv = { \"%s\", %s",
        !          1236:                        name, to_upper(v->fvarname),
        !          1237:                        type == TYCHAR ? ""
        !          1238:                                : (dimp || oneof_stg(v,v->vstg,
        !          1239:                                        M(STGEQUIV)|M(STGCOMMON)))
        !          1240:                                ? "(char *)" : "(char *)&");
        !          1241:                out_name(outfile, v);
        !          1242:                nice_printf(outfile, dimp ? ", %s_dims" : ", (ftnlen *)0", name);
        !          1243:                nice_printf(outfile, ", %ld };\n",
        !          1244:                        type != TYCHAR  ? (long)typeconv[type]
        !          1245:                                        : -v->vleng->constblock.Const.ci);
        !          1246:                }
        !          1247: 
        !          1248:        do {
        !          1249:                var = (Namep)nmch->datap;
        !          1250:                name = var->cvarname;
        !          1251:                nice_printf(outfile, "\nstatic Vardesc *%s_vl[] = ", name);
        !          1252:                comma = "{";
        !          1253:                i = 0;
        !          1254:                for(q = var->varxptr.namelist ; q ; q = q->nextp) {
        !          1255:                        v = (Namep)q->datap;
        !          1256:                        if (!v->vnamelist)
        !          1257:                                continue;
        !          1258:                        i++;
        !          1259:                        nice_printf(outfile, "%s &%s_dv", comma, v->cvarname);
        !          1260:                        comma = ",";
        !          1261:                        }
        !          1262:                nice_printf(outfile, " };\n");
        !          1263:                nice_printf(outfile,
        !          1264:                        "static Namelist %s = { \"%s\", %s_vl, %d };\n",
        !          1265:                        name, to_upper(var->fvarname), name, i);
        !          1266:                }
        !          1267:                while(nmch = nmch->nextp);
        !          1268:        nice_printf(outfile, "\n");
        !          1269:        }
        !          1270: 
        !          1271: /* fixextype tries to infer from usage in previous procedures
        !          1272:    the type of an external procedure declared
        !          1273:    external and passed as an argument but never typed or invoked.
        !          1274:  */
        !          1275: 
        !          1276:  static int
        !          1277: fixexttype(var)
        !          1278:  Namep var;
        !          1279: {
        !          1280:        Extsym *e;
        !          1281:        int type, type1;
        !          1282:        extern void changedtype();
        !          1283: 
        !          1284:        type = var->vtype;
        !          1285:        e = &extsymtab[var->vardesc.varno];
        !          1286:        if ((type1 = e->extype) && type == TYUNKNOWN)
        !          1287:                return var->vtype = type1;
        !          1288:        if (var->visused) {
        !          1289:                if (e->exused && type != type1)
        !          1290:                        changedtype(var);
        !          1291:                e->exused = 1;
        !          1292:                e->extype = type;
        !          1293:                }
        !          1294:        return type;
        !          1295:        }
        !          1296: 
        !          1297:  static void
        !          1298: ref_defs(outfile, refdefs) FILE *outfile; chainp refdefs;
        !          1299: {
        !          1300:        chainp cp;
        !          1301:        int eb, i, j, n;
        !          1302:        struct Dimblock *dimp;
        !          1303:        long L;
        !          1304:        expptr b, vl;
        !          1305:        Namep var;
        !          1306:        char *amp, *comma;
        !          1307: 
        !          1308:        ind_printf(0, outfile, "\n");
        !          1309:        for(cp = refdefs = revchain(refdefs); cp; cp = cp->nextp) {
        !          1310:                var = (Namep)cp->datap;
        !          1311:                cp->datap = 0;
        !          1312:                amp = "_subscr";
        !          1313:                if (!(eb = var->vsubscrused)) {
        !          1314:                        var->vrefused = 0;
        !          1315:                        if (!ISCOMPLEX(var->vtype))
        !          1316:                                amp = "_ref";
        !          1317:                        }
        !          1318:                def_start(outfile, var->cvarname, amp, CNULL);
        !          1319:                dimp = var->vdim;
        !          1320:                vl = 0;
        !          1321:                comma = "(";
        !          1322:                amp = "";
        !          1323:                if (var->vtype == TYCHAR) {
        !          1324:                        amp = "&";
        !          1325:                        vl = var->vleng;
        !          1326:                        if (ISCONST(vl) && vl->constblock.Const.ci == 1)
        !          1327:                                vl = 0;
        !          1328:                        nice_printf(outfile, "%sa_0", comma);
        !          1329:                        comma = ",";
        !          1330:                        }
        !          1331:                n = dimp->ndim;
        !          1332:                for(i = 1; i <= n; i++, comma = ",")
        !          1333:                        nice_printf(outfile, "%sa_%d", comma, i);
        !          1334:                nice_printf(outfile, ") %s", amp);
        !          1335:                if (var->vsubscrused)
        !          1336:                        var->vsubscrused = 0;
        !          1337:                else if (!ISCOMPLEX(var->vtype)) {
        !          1338:                        out_name(outfile, var);
        !          1339:                        nice_printf(outfile, "[%s", vl ? "(" : "");
        !          1340:                        }
        !          1341:                for(j = 2; j < n; j++)
        !          1342:                        nice_printf(outfile, "(");
        !          1343:                while(--i > 1) {
        !          1344:                        nice_printf(outfile, "(a_%d)%s*", i, i == n ? "" : ")");
        !          1345:                        expr_out(outfile, cpexpr(dimp->dims[i-2].dimsize));
        !          1346:                        nice_printf(outfile, " + ");
        !          1347:                        }
        !          1348:                nice_printf(outfile, "a_1");
        !          1349:                if (var->vtype == TYCHAR) {
        !          1350:                        if (vl) {
        !          1351:                                nice_printf(outfile, ")*");
        !          1352:                                expr_out(outfile, cpexpr(vl));
        !          1353:                                }
        !          1354:                        nice_printf(outfile, " + a_0");
        !          1355:                        }
        !          1356:                if (var->vstg != STGARG && (b = dimp->baseoffset)) {
        !          1357:                        b = cpexpr(b);
        !          1358:                        if (var->vtype == TYCHAR)
        !          1359:                                b = mkexpr(OPSTAR, cpexpr(var->vleng), b);
        !          1360:                        nice_printf(outfile, " - ");
        !          1361:                        expr_out(outfile, b);
        !          1362:                        }
        !          1363:                if (ISCOMPLEX(var->vtype)) {
        !          1364:                        ind_printf(0, outfile, "\n");
        !          1365:                        def_start(outfile, var->cvarname, "_ref", CNULL);
        !          1366:                        comma = "(";
        !          1367:                        for(i = 1; i <= n; i++, comma = ",")
        !          1368:                                nice_printf(outfile, "%sa_%d", comma, i);
        !          1369:                        nice_printf(outfile, ") %s[%s_subscr",
        !          1370:                                var->cvarname, var->cvarname);
        !          1371:                        comma = "(";
        !          1372:                        for(i = 1; i <= n; i++, comma = ",")
        !          1373:                                nice_printf(outfile, "%sa_%d", comma, i);
        !          1374:                        nice_printf(outfile, ")");
        !          1375:                        }
        !          1376:                ind_printf(0, outfile, "]\n" + eb);
        !          1377:                }
        !          1378:        nice_printf(outfile, "\n");
        !          1379:        frchain(refdefs);
        !          1380:        }
        !          1381: 
        !          1382: list_decls (outfile)
        !          1383: FILE *outfile;
        !          1384: {
        !          1385:     extern chainp used_builtins;
        !          1386:     extern struct Hashentry *hashtab;
        !          1387:     extern ftnint wr_char_len();
        !          1388:     struct Hashentry *entry;
        !          1389:     int write_header = 1;
        !          1390:     int last_class = -1, last_stg = -1;
        !          1391:     Namep var;
        !          1392:     int Alias, Define, did_one, last_type, type;
        !          1393:     extern int def_equivs, useauto;
        !          1394:     extern chainp new_vars;    /* Compiler-generated locals */
        !          1395:     chainp namelists = 0, refdefs = 0;
        !          1396:     char *ctype;
        !          1397:     int useauto1 = useauto && !saveall;
        !          1398:     long x;
        !          1399:     extern int hsize;
        !          1400: 
        !          1401: /* First write out the statically initialized data */
        !          1402: 
        !          1403:     if (initfile)
        !          1404:        list_init_data(&initfile, initfname, outfile);
        !          1405: 
        !          1406: /* Next come formats */
        !          1407:     write_formats(outfile);
        !          1408: 
        !          1409: /* Now write out the system-generated identifiers */
        !          1410: 
        !          1411:     if (new_vars || nequiv) {
        !          1412:        chainp args, next_var, this_var;
        !          1413:        chainp nv[TYVOID], nv1[TYVOID];
        !          1414:        int i, j;
        !          1415:        Addrp Var;
        !          1416:        Namep arg;
        !          1417: 
        !          1418:        /* zap unused dimension variables */
        !          1419: 
        !          1420:        for(args = allargs; args; args = args->nextp) {
        !          1421:                arg = (Namep)args->datap;
        !          1422:                if (this_var = arg->vlastdim) {
        !          1423:                        frexpr((tagptr)this_var->datap);
        !          1424:                        this_var->datap = 0;
        !          1425:                        }
        !          1426:                }
        !          1427: 
        !          1428:        /* sort new_vars by type, skipping entries just zapped */
        !          1429: 
        !          1430:        for(i = TYADDR; i < TYVOID; i++)
        !          1431:                nv[i] = 0;
        !          1432:        for(this_var = new_vars; this_var; this_var = next_var) {
        !          1433:                next_var = this_var->nextp;
        !          1434:                if (Var = (Addrp)this_var->datap) {
        !          1435:                        if (!(this_var->nextp = nv[j = Var->vtype]))
        !          1436:                                nv1[j] = this_var;
        !          1437:                        nv[j] = this_var;
        !          1438:                        }
        !          1439:                else {
        !          1440:                        this_var->nextp = 0;
        !          1441:                        frchain(&this_var);
        !          1442:                        }
        !          1443:                }
        !          1444:        new_vars = 0;
        !          1445:        for(i = TYVOID; --i >= TYADDR;)
        !          1446:                if (this_var = nv[i]) {
        !          1447:                        nv1[i]->nextp = new_vars;
        !          1448:                        new_vars = this_var;
        !          1449:                        }
        !          1450: 
        !          1451:        /* write the declarations */
        !          1452: 
        !          1453:        did_one = 0;
        !          1454:        last_type = -1;
        !          1455: 
        !          1456:        for (this_var = new_vars; this_var; this_var = this_var -> nextp) {
        !          1457:            Var = (Addrp) this_var->datap;
        !          1458: 
        !          1459:            if (Var == (Addrp) NULL)
        !          1460:                err ("list_decls:  null variable");
        !          1461:            else if (Var -> tag != TADDR)
        !          1462:                erri ("list_decls:  bad tag on new variable '%d'",
        !          1463:                        Var -> tag);
        !          1464: 
        !          1465:            type = nv_type (Var);
        !          1466:            if (Var->vstg == STGINIT
        !          1467:            ||  Var->uname_tag == UNAM_IDENT
        !          1468:                        && *Var->user.ident == ' '
        !          1469:                        && multitype)
        !          1470:                continue;
        !          1471:            if (!did_one)
        !          1472:                nice_printf (outfile, "/* System generated locals */\n");
        !          1473: 
        !          1474:            if (last_type == type && did_one)
        !          1475:                nice_printf (outfile, ", ");
        !          1476:            else {
        !          1477:                if (did_one)
        !          1478:                    nice_printf (outfile, ";\n");
        !          1479:                nice_printf (outfile, "%s ",
        !          1480:                        c_type_decl (type, Var -> vclass == CLPROC));
        !          1481:            } /* else */
        !          1482: 
        !          1483: /* Character type is really a string type.  Put out a '*' for parameters
        !          1484:    with unknown length and functions returning character */
        !          1485: 
        !          1486:            if (Var -> vtype == TYCHAR && (!ISICON ((Var -> vleng))
        !          1487:                    || Var -> vclass == CLPROC))
        !          1488:                nice_printf (outfile, "*");
        !          1489: 
        !          1490:            write_nv_ident(outfile, (Addrp)this_var->datap);
        !          1491:            if (Var -> vtype == TYCHAR && Var->vclass != CLPROC &&
        !          1492:                    ISICON((Var -> vleng))
        !          1493:                        && (i = Var->vleng->constblock.Const.ci) > 0)
        !          1494:                nice_printf (outfile, "[%d]", i);
        !          1495: 
        !          1496:            did_one = 1;
        !          1497:            last_type = nv_type (Var);
        !          1498:        } /* for this_var */
        !          1499: 
        !          1500: /* Handle the uninitialized equivalences */
        !          1501: 
        !          1502:        do_uninit_equivs (outfile, &did_one);
        !          1503: 
        !          1504:        if (did_one)
        !          1505:            nice_printf (outfile, ";\n\n");
        !          1506:     } /* if new_vars */
        !          1507: 
        !          1508: /* Write out builtin declarations */
        !          1509: 
        !          1510:     if (used_builtins) {
        !          1511:        chainp cp;
        !          1512:        Extsym *es;
        !          1513: 
        !          1514:        last_type = -1;
        !          1515:        did_one = 0;
        !          1516: 
        !          1517:        nice_printf (outfile, "/* Builtin functions */");
        !          1518: 
        !          1519:        for (cp = used_builtins; cp; cp = cp -> nextp) {
        !          1520:            Addrp e = (Addrp)cp->datap;
        !          1521: 
        !          1522:            switch(type = e->vtype) {
        !          1523:                case TYDREAL:
        !          1524:                case TYREAL:
        !          1525:                        /* if (forcedouble || e->dbl_builtin) */
        !          1526:                        /* libF77 currently assumes everything double */
        !          1527:                        type = TYDREAL;
        !          1528:                        ctype = "double";
        !          1529:                        break;
        !          1530:                case TYCOMPLEX:
        !          1531:                case TYDCOMPLEX:
        !          1532:                        type = TYVOID;
        !          1533:                        /* no break */
        !          1534:                default:
        !          1535:                        ctype = c_type_decl(type, 0);
        !          1536:                }
        !          1537: 
        !          1538:            if (did_one && last_type == type)
        !          1539:                nice_printf(outfile, ", ");
        !          1540:            else
        !          1541:                nice_printf(outfile, "%s\n%s ", did_one ? ";" : "", ctype);
        !          1542: 
        !          1543:            extern_out(outfile, es = &extsymtab[e -> memno]);
        !          1544:            proto(outfile, es->arginfo, es->fextname);
        !          1545:            last_type = type;
        !          1546:            did_one = 1;
        !          1547:        } /* for cp = used_builtins */
        !          1548: 
        !          1549:        nice_printf (outfile, ";\n\n");
        !          1550:     } /* if used_builtins */
        !          1551: 
        !          1552:     last_type = -1;
        !          1553:     for (entry = hashtab; entry < lasthash; ++entry) {
        !          1554:        var = entry -> varp;
        !          1555: 
        !          1556:        if (var) {
        !          1557:            int procclass = var -> vprocclass;
        !          1558:            char *comment = NULL;
        !          1559:            int stg = var -> vstg;
        !          1560:            int class = var -> vclass;
        !          1561:            type = var -> vtype;
        !          1562: 
        !          1563:            if (var->vrefused)
        !          1564:                refdefs = mkchain((char *)var, refdefs);
        !          1565:            if (var->vsubscrused)
        !          1566:                if (ISCOMPLEX(var->vtype))
        !          1567:                        var->vsubscrused = 0;
        !          1568:                else
        !          1569:                        refdefs = mkchain((char *)var, refdefs);
        !          1570:            if (ONEOF(stg, M(STGARG)|M(STGLENG)|M(STGINIT)))
        !          1571:                continue;
        !          1572: 
        !          1573:            if (useauto1 && stg == STGBSS && !var->vsave)
        !          1574:                stg = STGAUTO;
        !          1575: 
        !          1576:            switch (class) {
        !          1577:                case CLVAR:
        !          1578:                    break;
        !          1579:                case CLPROC:
        !          1580:                    switch(procclass) {
        !          1581:                        case PTHISPROC:
        !          1582:                                extsymtab[var->vardesc.varno].extype = type;
        !          1583:                                continue;
        !          1584:                        case PSTFUNCT:
        !          1585:                        case PINTRINSIC:
        !          1586:                                continue;
        !          1587:                        case PUNKNOWN:
        !          1588:                                err ("list_decls:  unknown procedure class");
        !          1589:                                continue;
        !          1590:                        case PEXTERNAL:
        !          1591:                                if (stg == STGUNKNOWN) {
        !          1592:                                        warn1(
        !          1593:                                        "%.64s declared EXTERNAL but never used.",
        !          1594:                                                var->fvarname);
        !          1595:                                        /* to retain names declared EXTERNAL */
        !          1596:                                        /* but not referenced, change
        !          1597:                                        /* "continue" to "stg = STGEXT" */
        !          1598:                                        continue;
        !          1599:                                        }
        !          1600:                                else
        !          1601:                                        type = fixexttype(var);
        !          1602:                        }
        !          1603:                    break;
        !          1604:                case CLUNKNOWN:
        !          1605:                        /* declared but never used */
        !          1606:                        continue;
        !          1607:                case CLPARAM:
        !          1608:                        continue;
        !          1609:                case CLNAMELIST:
        !          1610:                        if (var->visused)
        !          1611:                                namelists = mkchain((char *)var, namelists);
        !          1612:                        continue;
        !          1613:                default:
        !          1614:                    erri("list_decls:  can't handle class '%d' yet",
        !          1615:                            class);
        !          1616:                    Fatal(var->fvarname);
        !          1617:                    continue;
        !          1618:            } /* switch */
        !          1619: 
        !          1620:            /* Might be equivalenced to a common.  If not, don't process */
        !          1621:            if (stg == STGCOMMON && !var->vcommequiv)
        !          1622:                continue;
        !          1623: 
        !          1624: /* Only write the header if system-generated locals, builtins, or
        !          1625:    uninitialized equivs were already output */
        !          1626: 
        !          1627:            if (write_header == 1 && (new_vars || nequiv || used_builtins)
        !          1628:                    && oneof_stg ( var, stg,
        !          1629:                    M(STGBSS)|M(STGEXT)|M(STGAUTO)|M(STGCOMMON)|M(STGEQUIV))) {
        !          1630:                nice_printf (outfile, "/* Local variables */\n");
        !          1631:                write_header = 2;
        !          1632:                }
        !          1633: 
        !          1634: 
        !          1635:            Alias = oneof_stg(var, stg, M(STGEQUIV)|M(STGCOMMON));
        !          1636:            if (Define = (Alias && def_equivs)) {
        !          1637:                if (!write_header)
        !          1638:                        nice_printf(outfile, ";\n");
        !          1639:                def_start(outfile, var->cvarname, CNULL, "(");
        !          1640:                goto Alias1;
        !          1641:                }
        !          1642:            else if (type == last_type && class == last_class &&
        !          1643:                    stg == last_stg && !write_header)
        !          1644:                nice_printf (outfile, ", ");
        !          1645:            else {
        !          1646:                if (!write_header && ONEOF(stg, M(STGBSS)|
        !          1647:                    M(STGEXT)|M(STGAUTO)|M(STGEQUIV)|M(STGCOMMON)))
        !          1648:                    nice_printf (outfile, ";\n");
        !          1649: 
        !          1650:                switch (stg) {
        !          1651:                    case STGARG:
        !          1652:                    case STGLENG:
        !          1653:                        /* Part of the argument list, don't write them out
        !          1654:                           again */
        !          1655:                        continue;           /* Go back to top of the loop */
        !          1656:                    case STGBSS:
        !          1657:                    case STGEQUIV:
        !          1658:                    case STGCOMMON:
        !          1659:                        nice_printf (outfile, "static ");
        !          1660:                        break;
        !          1661:                    case STGEXT:
        !          1662:                        nice_printf (outfile, "extern ");
        !          1663:                        break;
        !          1664:                    case STGAUTO:
        !          1665:                        break;
        !          1666:                    case STGINIT:
        !          1667:                    case STGUNKNOWN:
        !          1668:                        /* Don't want to touch the initialized data, that will
        !          1669:                           be handled elsewhere.  Unknown data have
        !          1670:                           already been complained about, so skip them */
        !          1671:                        continue;
        !          1672:                    default:
        !          1673:                        erri("list_decls:  can't handle storage class %d",
        !          1674:                                stg);
        !          1675:                        continue;
        !          1676:                } /* switch */
        !          1677: 
        !          1678:                if (type == TYCHAR && halign && class != CLPROC
        !          1679:                && ISICON(var->vleng)) {
        !          1680:                        nice_printf(outfile, "struct { %s fill; char val",
        !          1681:                                halign);
        !          1682:                        x = wr_char_len(outfile, var->vdim,
        !          1683:                                var->vleng->constblock.Const.ci, 1);
        !          1684:                        if (x %= hsize)
        !          1685:                                nice_printf(outfile, "; char fill2[%ld]",
        !          1686:                                        hsize - x);
        !          1687:                        nice_printf(outfile, "; } %s_st;\n", var->cvarname);
        !          1688:                        def_start(outfile, var->cvarname, CNULL, var->cvarname);
        !          1689:                        ind_printf(0, outfile, "_st.val\n");
        !          1690:                        last_type = -1;
        !          1691:                        write_header = 2;
        !          1692:                        continue;
        !          1693:                        }
        !          1694:                nice_printf(outfile, "%s ",
        !          1695:                        c_type_decl(type, class == CLPROC));
        !          1696:            } /* else */
        !          1697: 
        !          1698: /* Character type is really a string type.  Put out a '*' for variable
        !          1699:    length strings, and also for equivalences */
        !          1700: 
        !          1701:            if (type == TYCHAR && class != CLPROC
        !          1702:                    && (!var->vleng || !ISICON (var -> vleng))
        !          1703:            || oneof_stg(var, stg, M(STGEQUIV)|M(STGCOMMON)))
        !          1704:                nice_printf (outfile, "*%s", var->cvarname);
        !          1705:            else {
        !          1706:                nice_printf (outfile, "%s", var->cvarname);
        !          1707:                if (class == CLPROC) {
        !          1708:                        Argtypes *at;
        !          1709:                        if (!(at = var->arginfo)
        !          1710:                         && var->vprocclass == PEXTERNAL)
        !          1711:                                at = extsymtab[var->vardesc.varno].arginfo;
        !          1712:                        proto(outfile, at, var->fvarname);
        !          1713:                        }
        !          1714:                else if (type == TYCHAR && ISICON ((var -> vleng)))
        !          1715:                        wr_char_len(outfile, var->vdim,
        !          1716:                                (int)var->vleng->constblock.Const.ci, 0);
        !          1717:                else if (var -> vdim &&
        !          1718:                    !oneof_stg (var, stg, M(STGEQUIV)|M(STGCOMMON)))
        !          1719:                        comment = wr_ardecls(outfile, var->vdim, 1L);
        !          1720:                }
        !          1721: 
        !          1722:            if (comment)
        !          1723:                nice_printf (outfile, "%s", comment);
        !          1724:  Alias1:
        !          1725:            if (Alias) {
        !          1726:                char *amp, *lp, *name, *rp;
        !          1727:                char *equiv_name ();
        !          1728:                ftnint voff = var -> voffset;
        !          1729:                int et0, expr_type, k;
        !          1730:                Extsym *E;
        !          1731:                struct Equivblock *eb;
        !          1732:                char buf[16];
        !          1733: 
        !          1734: /* We DON'T want to use oneof_stg here, because we need to distinguish
        !          1735:    between them */
        !          1736: 
        !          1737:                if (stg == STGEQUIV) {
        !          1738:                        name = equiv_name(k = var->vardesc.varno, CNULL);
        !          1739:                        eb = eqvclass + k;
        !          1740:                        if (eb->eqvinit) {
        !          1741:                                amp = "&";
        !          1742:                                et0 = TYERROR;
        !          1743:                                }
        !          1744:                        else {
        !          1745:                                amp = "";
        !          1746:                                et0 = eb->eqvtype;
        !          1747:                                }
        !          1748:                        expr_type = et0;
        !          1749:                    }
        !          1750:                else {
        !          1751:                        E = &extsymtab[var->vardesc.varno];
        !          1752:                        sprintf(name = buf, "%s%d", E->cextname, E->curno);
        !          1753:                        expr_type = type;
        !          1754:                        et0 = -1;
        !          1755:                        amp = "&";
        !          1756:                } /* else */
        !          1757: 
        !          1758:                if (!Define)
        !          1759:                        nice_printf (outfile, " = ");
        !          1760:                if (voff) {
        !          1761:                        k = typesize[type];
        !          1762:                        switch((int)(voff % k)) {
        !          1763:                                case 0:
        !          1764:                                        voff /= k;
        !          1765:                                        expr_type = type;
        !          1766:                                        break;
        !          1767:                                case SZSHORT:
        !          1768:                                case SZSHORT+SZLONG:
        !          1769:                                        expr_type = TYSHORT;
        !          1770:                                        voff /= SZSHORT;
        !          1771:                                        break;
        !          1772:                                case SZLONG:
        !          1773:                                        expr_type = TYLONG;
        !          1774:                                        voff /= SZLONG;
        !          1775:                                        break;
        !          1776:                                default:
        !          1777:                                        expr_type = TYCHAR;
        !          1778:                                }
        !          1779:                        }
        !          1780: 
        !          1781:                if (expr_type == type) {
        !          1782:                        lp = rp = "";
        !          1783:                        if (et0 == -1 && !voff)
        !          1784:                                goto cast;
        !          1785:                        }
        !          1786:                else {
        !          1787:                        lp = "(";
        !          1788:                        rp = ")";
        !          1789:  cast:
        !          1790:                        nice_printf(outfile, "(%s *)", c_type_decl(type, 0));
        !          1791:                        }
        !          1792: 
        !          1793: /* Now worry about computing the offset */
        !          1794: 
        !          1795:                if (voff) {
        !          1796:                    if (expr_type == et0)
        !          1797:                        nice_printf (outfile, "%s%s + %ld%s",
        !          1798:                                lp, name, voff, rp);
        !          1799:                    else
        !          1800:                        nice_printf(outfile, "%s(%s *)%s%s + %ld%s", lp,
        !          1801:                                c_type_decl (expr_type, 0), amp,
        !          1802:                                name, voff, rp);
        !          1803:                } else
        !          1804:                    nice_printf(outfile, "%s%s", amp, name);
        !          1805: /* Always put these at the end of the line */
        !          1806:                last_type = last_class = last_stg = -1;
        !          1807:                write_header = 0;
        !          1808:                if (Define) {
        !          1809:                        ind_printf(0, outfile, ")\n");
        !          1810:                        write_header = 2;
        !          1811:                        }
        !          1812:                continue;
        !          1813:                }
        !          1814:            write_header = 0;
        !          1815:            last_type = type;
        !          1816:            last_class = class;
        !          1817:            last_stg = stg;
        !          1818:        } /* if (var) */
        !          1819:     } /* for (entry = hashtab */
        !          1820: 
        !          1821:     if (!write_header)
        !          1822:        nice_printf (outfile, ";\n\n");
        !          1823:     else if (write_header == 2)
        !          1824:        nice_printf(outfile, "\n");
        !          1825: 
        !          1826: /* Next, namelists, which may reference equivs */
        !          1827: 
        !          1828:     if (namelists) {
        !          1829:        write_namelists(namelists = revchain(namelists), outfile);
        !          1830:        frchain(&namelists);
        !          1831:        }
        !          1832: 
        !          1833: /* Finally, ioblocks (which may reference equivs and namelists) */
        !          1834:     if (iob_list)
        !          1835:        write_ioblocks(outfile);
        !          1836:     if (assigned_fmts)
        !          1837:        write_assigned_fmts(outfile);
        !          1838: 
        !          1839:     if (refdefs)
        !          1840:        ref_defs(outfile, refdefs);
        !          1841: 
        !          1842: } /* list_decls */
        !          1843: 
        !          1844: do_uninit_equivs (outfile, did_one)
        !          1845: FILE *outfile;
        !          1846: int *did_one;
        !          1847: {
        !          1848:     extern int nequiv;
        !          1849:     struct Equivblock *eqv, *lasteqv = eqvclass + nequiv;
        !          1850:     int k, last_type = -1, t;
        !          1851: 
        !          1852:     for (eqv = eqvclass; eqv < lasteqv; eqv++)
        !          1853:        if (!eqv -> eqvinit && eqv -> eqvtop != eqv -> eqvbottom) {
        !          1854:            if (!*did_one)
        !          1855:                nice_printf (outfile, "/* System generated locals */\n");
        !          1856:            t = eqv->eqvtype;
        !          1857:            if (last_type == t)
        !          1858:                nice_printf (outfile, ", ");
        !          1859:            else {
        !          1860:                if (*did_one)
        !          1861:                    nice_printf (outfile, ";\n");
        !          1862:                nice_printf (outfile, "static %s ", c_type_decl(t, 0));
        !          1863:                k = typesize[t];
        !          1864:            } /* else */
        !          1865:            nice_printf(outfile, "%s", equiv_name((int)(eqv - eqvclass), CNULL));
        !          1866:            nice_printf(outfile, "[%ld]",
        !          1867:                (eqv->eqvtop - eqv->eqvbottom + k - 1) / k);
        !          1868:            last_type = t;
        !          1869:            *did_one = 1;
        !          1870:        } /* if !eqv -> eqvinit */
        !          1871: } /* do_uninit_equivs */
        !          1872: 
        !          1873: 
        !          1874: /* wr_ardecls -- Writes the brackets and size for an array
        !          1875:    declaration.  Because of the inner workings of the compiler,
        !          1876:    multi-dimensional arrays get mapped directly into a one-dimensional
        !          1877:    array, so we have to compute the size of the array here.  When the
        !          1878:    dimension is greater than 1, a string comment about the original size
        !          1879:    is returned */
        !          1880: 
        !          1881: char *wr_ardecls(outfile, dimp, size)
        !          1882: FILE *outfile;
        !          1883: struct Dimblock *dimp;
        !          1884: long size;
        !          1885: {
        !          1886:     int i, k;
        !          1887:     static char buf[1000];
        !          1888: 
        !          1889:     if (dimp == (struct Dimblock *) NULL)
        !          1890:        return NULL;
        !          1891: 
        !          1892:     sprintf(buf, "\t/* was "); /* would like to say  k = sprintf(...), but */
        !          1893:     k = strlen(buf);           /* BSD doesn't return char transmitted count */
        !          1894: 
        !          1895:     for (i = 0; i < dimp -> ndim; i++) {
        !          1896:        expptr this_size = dimp -> dims[i].dimsize;
        !          1897: 
        !          1898:        if (!ISICON (this_size))
        !          1899:            err ("wr_ardecls:  nonconstant array size");
        !          1900:        else {
        !          1901:            size *= this_size -> constblock.Const.ci;
        !          1902:            sprintf(buf+k, "[%ld]", this_size -> constblock.Const.ci);
        !          1903:            k += strlen(buf+k); /* BSD prevents combining this with prev stmt */
        !          1904:        } /* else */
        !          1905:     } /* for i = 0 */
        !          1906: 
        !          1907:     nice_printf (outfile, "[%ld]", size);
        !          1908:     strcat(buf+k, " */");
        !          1909: 
        !          1910:     return (i > 1) ? buf : NULL;
        !          1911: } /* wr_ardecls */
        !          1912: 
        !          1913: 
        !          1914: 
        !          1915: /* ----------------------------------------------------------------------
        !          1916: 
        !          1917:        The following routines read from the p1 intermediate file.  If
        !          1918:    that format changes, only these routines need be changed
        !          1919: 
        !          1920:    ---------------------------------------------------------------------- */
        !          1921: 
        !          1922: static int get_p1_token (infile)
        !          1923: FILE *infile;
        !          1924: {
        !          1925:     int token = P1_UNKNOWN;
        !          1926: 
        !          1927: /* NOT PORTABLE!! */
        !          1928: 
        !          1929:     if (fscanf (infile, "%d", &token) == EOF)
        !          1930:        return P1_EOF;
        !          1931: 
        !          1932: /* Skip over the ": " */
        !          1933: 
        !          1934:     if (getc (infile) != '\n')
        !          1935:        getc (infile);
        !          1936: 
        !          1937:     return token;
        !          1938: } /* get_p1_token */
        !          1939: 
        !          1940: 
        !          1941: 
        !          1942: /* Returns a (null terminated) string from the input file */
        !          1943: 
        !          1944: static int p1gets (fp, str, size)
        !          1945: FILE *fp;
        !          1946: char *str;
        !          1947: int size;
        !          1948: {
        !          1949:     char *fgets ();
        !          1950:     char c;
        !          1951: 
        !          1952:     if (str == NULL)
        !          1953:        return 0;
        !          1954: 
        !          1955:     if ((c = getc (fp)) != ' ')
        !          1956:        ungetc (c, fp);
        !          1957: 
        !          1958:     if (fgets (str, size, fp)) {
        !          1959:        int length;
        !          1960: 
        !          1961:        str[size - 1] = '\0';
        !          1962:        length = strlen (str);
        !          1963: 
        !          1964: /* Get rid of the newline */
        !          1965: 
        !          1966:        if (str[length - 1] == '\n')
        !          1967:            str[length - 1] = '\0';
        !          1968:        return 1;
        !          1969: 
        !          1970:     } else if (feof (fp))
        !          1971:        return EOF;
        !          1972:     else
        !          1973:        return 0;
        !          1974: } /* p1gets */
        !          1975: 
        !          1976: 
        !          1977: static int p1get_const (infile, type, resultp)
        !          1978: FILE *infile;
        !          1979: int type;
        !          1980: struct Constblock **resultp;
        !          1981: {
        !          1982:     int status;
        !          1983:     struct Constblock *result;
        !          1984: 
        !          1985:        if (type != TYCHAR) {
        !          1986:                *resultp = result = ALLOC(Constblock);
        !          1987:                result -> tag = TCONST;
        !          1988:                result -> vtype = type;
        !          1989:                }
        !          1990: 
        !          1991:     switch (type) {
        !          1992:        case TYINT1:
        !          1993:         case TYSHORT:
        !          1994:        case TYLONG:
        !          1995:        case TYLOGICAL:
        !          1996: #ifdef TYQUAD
        !          1997:        case TYQUAD:
        !          1998: #endif
        !          1999:        case TYLOGICAL1:
        !          2000:        case TYLOGICAL2:
        !          2001:            status = p1getd (infile, &(result -> Const.ci));
        !          2002:            break;
        !          2003:        case TYREAL:
        !          2004:        case TYDREAL:
        !          2005:            status = p1getf(infile, &result->Const.cds[0]);
        !          2006:            result->vstg = 1;
        !          2007:            break;
        !          2008:        case TYCOMPLEX:
        !          2009:        case TYDCOMPLEX:
        !          2010:            status = p1getf(infile, &result->Const.cds[0]);
        !          2011:            if (status && status != EOF)
        !          2012:                status = p1getf(infile, &result->Const.cds[1]);
        !          2013:            result->vstg = 1;
        !          2014:            break;
        !          2015:        case TYCHAR:
        !          2016:            status = fscanf(infile, "%lx", resultp);
        !          2017:            break;
        !          2018:        default:
        !          2019:            erri ("p1get_const:  bad constant type '%d'", type);
        !          2020:            status = 0;
        !          2021:            break;
        !          2022:     } /* switch */
        !          2023: 
        !          2024:     return status;
        !          2025: } /* p1get_const */
        !          2026: 
        !          2027: static int p1getd (infile, result)
        !          2028: FILE *infile;
        !          2029: long *result;
        !          2030: {
        !          2031:     return fscanf (infile, "%ld", result);
        !          2032: } /* p1getd */
        !          2033: 
        !          2034:  static int
        !          2035: p1getf(infile, result)
        !          2036:  FILE *infile;
        !          2037:  char **result;
        !          2038: {
        !          2039: 
        !          2040:        char buf[1324];
        !          2041:        register int k;
        !          2042: 
        !          2043:        k = fscanf (infile, "%s", buf);
        !          2044:        if (k < 1)
        !          2045:                k = EOF;
        !          2046:        else
        !          2047:                strcpy(*result = mem(strlen(buf)+1,0), buf);
        !          2048:        return k;
        !          2049: }
        !          2050: 
        !          2051: static int p1getn (infile, count, result)
        !          2052: FILE *infile;
        !          2053: int count;
        !          2054: char **result;
        !          2055: {
        !          2056: 
        !          2057:     char *bufptr;
        !          2058:     extern ptr ckalloc ();
        !          2059: 
        !          2060:     bufptr = (char *) ckalloc (count);
        !          2061: 
        !          2062:     if (result)
        !          2063:        *result = bufptr;
        !          2064: 
        !          2065:     for (; !feof (infile) && count > 0; count--)
        !          2066:        *bufptr++ = getc (infile);
        !          2067: 
        !          2068:     return feof (infile) ? EOF : 1;
        !          2069: } /* p1getn */
        !          2070: 
        !          2071:  static void
        !          2072: proto(outfile, at, fname)
        !          2073:  FILE *outfile;
        !          2074:  Argtypes *at;
        !          2075:  char *fname;
        !          2076: {
        !          2077:        int i, j, k, n;
        !          2078:        char *comma;
        !          2079:        Atype *atypes;
        !          2080:        Namep np;
        !          2081:        chainp cp;
        !          2082:        extern void bad_atypes();
        !          2083: 
        !          2084:        if (at) {
        !          2085:                /* Correct types that we learn on the fly, e.g.
        !          2086:                        subroutine gotcha(foo)
        !          2087:                        external foo
        !          2088:                        call zap(...,foo,...)
        !          2089:                        call foo(...)
        !          2090:                */
        !          2091:                atypes = at->atypes;
        !          2092:                n = at->defined ? at->dnargs : at->nargs;
        !          2093:                for(i = 0; i++ < n; atypes++) {
        !          2094:                        if (!(cp = atypes->cp))
        !          2095:                                continue;
        !          2096:                        j = atypes->type;
        !          2097:                        do {
        !          2098:                                np = (Namep)cp->datap;
        !          2099:                                k = np->vtype;
        !          2100:                                if (np->vclass == CLPROC) {
        !          2101:                                        if (!np->vimpltype && k)
        !          2102:                                                k += 200;
        !          2103:                                        else {
        !          2104:                                                if (j >= 300)
        !          2105:                                                        j = TYUNKNOWN + 200;
        !          2106:                                                continue;
        !          2107:                                                }
        !          2108:                                        }
        !          2109:                                if (j == k)
        !          2110:                                        continue;
        !          2111:                                if (j >= 300
        !          2112:                                ||  j == 200 && k >= 200)
        !          2113:                                        j = k;
        !          2114:                                else {
        !          2115:                                        if (at->nargs >= 0)
        !          2116:                                           bad_atypes(at,fname,i,j,k,""," and");
        !          2117:                                        goto break2;
        !          2118:                                        }
        !          2119:                                }
        !          2120:                                while(cp = cp->nextp);
        !          2121:                        atypes->type = j;
        !          2122:                        frchain(&atypes->cp);
        !          2123:                        }
        !          2124:                }
        !          2125:  break2:
        !          2126:        if (parens) {
        !          2127:                nice_printf(outfile, parens);
        !          2128:                return;
        !          2129:                }
        !          2130: 
        !          2131:        if (!at || (n = at-> defined ? at->dnargs : at->nargs) < 0) {
        !          2132:                nice_printf(outfile, Ansi == 1 ? "()" : "(...)");
        !          2133:                return;
        !          2134:                }
        !          2135: 
        !          2136:        if (n == 0) {
        !          2137:                nice_printf(outfile, Ansi == 1 ? "(void)" : "()");
        !          2138:                return;
        !          2139:                }
        !          2140: 
        !          2141:        atypes = at->atypes;
        !          2142:        nice_printf(outfile, "(");
        !          2143:        comma = "";
        !          2144:        for(; --n >= 0; atypes++) {
        !          2145:                k = atypes->type;
        !          2146:                if (k == TYADDR)
        !          2147:                        nice_printf(outfile, "%schar **", comma);
        !          2148:                else if (k >= 200) {
        !          2149:                        k -= 200;
        !          2150:                        nice_printf(outfile, "%s%s", comma,
        !          2151:                                usedcasts[k] = casttypes[k]);
        !          2152:                        }
        !          2153:                else if (k >= 100)
        !          2154:                        nice_printf(outfile,
        !          2155:                                        k == TYCHAR + 100 ? "%s%s *" : "%s%s",
        !          2156:                                        comma, c_type_decl(k-100, 0));
        !          2157:                else
        !          2158:                        nice_printf(outfile, "%s%s *", comma,
        !          2159:                                        c_type_decl(k, 0));
        !          2160:                comma = ", ";
        !          2161:                }
        !          2162:        nice_printf(outfile, ")");
        !          2163:        }
        !          2164: 
        !          2165:  void
        !          2166: protowrite(protofile, type, name, e, lengths)
        !          2167:  FILE *protofile;
        !          2168:  char *name;
        !          2169:  struct Entrypoint *e;
        !          2170:  chainp lengths;
        !          2171: {
        !          2172:        extern char used_rets[];
        !          2173:        int asave;
        !          2174: 
        !          2175:        if (!(asave = Ansi))
        !          2176:                Castargs = Ansi = 1;
        !          2177:        nice_printf(protofile, "extern %s %s", protorettypes[type], name);
        !          2178:        list_arg_types(protofile, e, lengths, 0, ";\n");
        !          2179:        used_rets[type] = 1;
        !          2180:        if (!(Ansi = asave))
        !          2181:                Castargs = 0;
        !          2182:        }
        !          2183: 
        !          2184:  static void
        !          2185: do_p1_1while(outfile)
        !          2186:  FILE *outfile;
        !          2187: {
        !          2188:        if (*wh_next) {
        !          2189:                nice_printf(outfile,
        !          2190:                        "for(;;) { /* while(complicated condition) */\n" /*}*/ );
        !          2191:                next_tab(outfile);
        !          2192:                }
        !          2193:        else
        !          2194:                nice_printf(outfile, "while(" /*)*/ );
        !          2195:        }
        !          2196: 
        !          2197:  static void
        !          2198: do_p1_2while(infile, outfile)
        !          2199:  FILE *infile, *outfile;
        !          2200: {
        !          2201:        expptr test;
        !          2202: 
        !          2203:        test = do_format(infile, outfile);
        !          2204:        if (*wh_next)
        !          2205:                nice_printf(outfile, "if (!(");
        !          2206:        expr_out(outfile, test);
        !          2207:        if (*wh_next++)
        !          2208:                nice_printf(outfile, "))\n\tbreak;\n");
        !          2209:        else {
        !          2210:                nice_printf(outfile, /*(*/ ") {\n");
        !          2211:                next_tab(outfile);
        !          2212:                }
        !          2213:        }
        !          2214: 
        !          2215:  static void
        !          2216: do_p1_elseifstart(outfile)
        !          2217:  FILE *outfile;
        !          2218: {
        !          2219:        if (*ei_next++) {
        !          2220:                prev_tab(outfile);
        !          2221:                nice_printf(outfile, /*{*/
        !          2222:                        "} else /* if(complicated condition) */ {\n" /*}*/ );
        !          2223:                next_tab(outfile);
        !          2224:                }
        !          2225:        }

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