00878 {
00879         register chainp cp, v0;
00880         ftnint dloc, k, loc;
00881 
00882         nice_printf(outfile, "\"");
00883         cp = (chainp)v->datap;
00884         loc = (ftnint)cp->datap;
00885         for(v0 = v;;) {
00886                 switch((int)cp->nextp->datap) {
00887                         case TYBLANK:
00888                                 k = (ftnint)cp->nextp->nextp->datap;
00889                                 loc += k;
00890                                 while(--k >= 0)
00891                                         nice_printf(outfile, " ");
00892                                 break;
00893                         case TYCHAR:
00894                                 k = (ftnint)cp->nextp->nextp->datap;
00895                                 nice_printf(outfile, str_fmt[k], k);
00896                                 loc++;
00897                                 break;
00898                         default:
00899                                 goto done;
00900                         }
00901                 v0 = v;
00902                 if (!(v = v->nextp) || !(cp = (chainp)v->datap))
00903                         break;
00904                 dloc = (ftnint)cp->datap;
00905                 if (loc != dloc)
00906                         break;
00907                 }
00908  done:
00909         nice_printf(outfile, "\"");
00910         *nloc = loc;
00911         return v0;
00912         }

00425 {
00426     char line[MAX_INIT_LINE + 1], *pointer;
00427     chainp vals, prev_val;
00428     char *newval;
00429 
00430     if (fgets (line, MAX_INIT_LINE, infile) == NULL) {
00431         err ("data_value:  error reading from intermediate file");
00432         return CHNULL;
00433     } /* if fgets */
00434 
00435 /* Get rid of the trailing newline */
00436 
00437     if (line[0])
00438         line[strlen (line) - 1] = '\0';
00439 
00440 #define iswhite(x) (isspace (x) || (x) == ',')
00441 
00442     pointer = line;
00443     prev_val = vals = CHNULL;
00444 
00445     while (*pointer) {
00446         register char *end_ptr, old_val;
00447 
00448 /* Move   pointer   to the start of the next word */
00449 
00450         while (*pointer && iswhite (*pointer))
00451             pointer++;
00452         if (*pointer == '\0')
00453             break;
00454 
00455 /* Move   end_ptr   to the end of the current word */
00456 
00457         for (end_ptr = pointer + 1; *end_ptr && !iswhite (*end_ptr);
00458                 end_ptr++)
00459             ;
00460 
00461         old_val = *end_ptr;
00462         *end_ptr = '\0';
00463 
00464 /* Add this value to the end of the list */
00465 
00466         if (ONEOF(type, MSKREAL|MSKCOMPLEX))
00467                 newval = cpstring(pointer);
00468         else
00469                 newval = (char *)atol(pointer);
00470         if (vals) {
00471             prev_val->nextp = mkchain(newval, CHNULL);
00472             prev_val = prev_val -> nextp;
00473         } else
00474             prev_val = vals = mkchain(newval, CHNULL);
00475         *end_ptr = old_val;
00476         pointer = end_ptr;
00477     } /* while *pointer */
00478 
00479     return mkchain((char *)offset, mkchain((char *)LONG_CAST type, vals));
00480 } /* data_value */

00086 {
00087     char varname[NAME_MAX], ovarname[NAME_MAX];
00088     ftnint offset;
00089     ftnint type;
00090     int vargroup;       /* 0 --> init, 1 --> equiv, 2 --> common */
00091     int did_one = 0;            /* True when one has been output */
00092     chainp values = CHNULL;     /* Actual data values */
00093     int keepit = 0;
00094     Namep np;
00095 
00096     ovarname[0] = '\0';
00097 
00098     while (rdname (infile, &vargroup, varname) && rdlong (infile, &offset)
00099             && rdlong (infile, &type)) {
00100         if (strcmp (varname, ovarname)) {
00101 
00102         /* If this is a new variable name, the old initialization has been
00103            completed */
00104 
00105                 wr_one_init(outfile, ovarname, &values, keepit);
00106 
00107                 strcpy (ovarname, varname);
00108                 values = CHNULL;
00109                 if (vargroup == 0) {
00110                         if (memno2info(atoi(varname+2), &np)) {
00111                                 if (((Addrp)np)->uname_tag != UNAM_NAME) {
00112                                         err("do_init_data: expected NAME");
00113                                         goto Keep;
00114                                         }
00115                                 np = ((Addrp)np)->user.name;
00116                                 }
00117                         if (!(keepit = np->visused) && !np->vimpldovar)
00118                                 warn1("local variable %s never used",
00119                                         np->fvarname);
00120                         }
00121                 else {
00122  Keep:
00123                         keepit = 1;
00124                         }
00125                 if (keepit && !did_one) {
00126                         nice_printf (outfile, "/* Initialized data */\n\n");
00127                         did_one = YES;
00128                         }
00129         } /* if strcmp */
00130 
00131         values = mkchain((char *)data_value(infile, offset, (int)type), values);
00132     } /* while */
00133 
00134 /* Write out the last declaration */
00135 
00136     wr_one_init (outfile, ovarname, &values, keepit);
00137 
00138     return did_one;
00139 } /* do_init_data */

00826 {
00827         register chainp cp, v0;
00828         ftnint dloc, k, loc;
00829         unsigned long uk;
00830         char buf[8], *comma;
00831 
00832         nice_printf(outfile, "{");
00833         cp = (chainp)v->datap;
00834         loc = (ftnint)cp->datap;
00835         comma = "";
00836         for(v0 = v;;) {
00837                 switch((int)cp->nextp->datap) {
00838                         case TYBLANK:
00839                                 k = (ftnint)cp->nextp->nextp->datap;
00840                                 loc += k;
00841                                 while(--k >= 0) {
00842                                         nice_printf(outfile, "%s' '", comma);
00843                                         comma = ", ";
00844                                         }
00845                                 break;
00846                         case TYCHAR:
00847                                 uk = (ftnint)cp->nextp->nextp->datap;
00848                                 sprintf(buf, chr_fmt[uk], uk);
00849                                 nice_printf(outfile, "%s'%s'", comma, buf);
00850                                 comma = ", ";
00851                                 loc++;
00852                                 break;
00853                         default:
00854                                 goto done;
00855                         }
00856                 v0 = v;
00857                 if (!(v = v->nextp) || !(cp = (chainp)v->datap))
00858                         break;
00859                 dloc = (ftnint)cp->datap;
00860                 if (loc != dloc)
00861                         break;
00862                 }
00863  done:
00864         nice_printf(outfile, "}");
00865         *nloc = loc;
00866         return v0;
00867         }

00922 {
00923         static char buf[24];
00924         if (L == 1 && type != TYCHAR)
00925                 return "";
00926         sprintf(buf, "[%ld]", L);
00927         return buf;
00928         }

00045 {
00046     FILE *sortfp;
00047     int status;
00048 
00049     fclose(*Infile);
00050     *Infile = 0;
00051 
00052     if (status = dsort(Inname, sortfname))
00053         fatali ("sort failed, status %d", status);
00054 
00055     scrub(Inname); /* optionally unlink Inname */
00056 
00057     if ((sortfp = fopen(sortfname, textread)) == NULL)
00058         Fatal("Couldn't open sorted initialization data");
00059 
00060     do_init_data(outfile, sortfp);
00061     fclose(sortfp);
00062     scrub(sortfname);
00063 
00064 /* Insert a blank line after any initialized data */
00065 
00066         nice_printf (outfile, "\n");
00067 
00068     if (debugflag && infname)
00069          /* don't back block data file up -- it won't be overwritten */
00070         backup(initfname, initbname);
00071 } /* list_init_data */

00667 {
00668     union Constant *Const;
00669     register char **L;
00670 
00671     if (type == TYCHAR) {
00672         char *str, *str_ptr;
00673         chainp v, prev;
00674         int b = 0, k, main_index = 0;
00675 
00676 /* Find the max length of init string, by finding the highest offset
00677    value stored in the list of initial values */
00678 
00679         for(k = 1, prev = CHNULL, v = values; v; prev = v, v = v->nextp)
00680             ;
00681         if (prev != CHNULL)
00682             k = ((int) (((chainp) prev->datap)->datap)) + 2;
00683                 /* + 2 above for null char at end */
00684         str = Alloc (k);
00685         for (str_ptr = str; values; str_ptr++) {
00686             int index = (int) (((chainp) values->datap)->datap);
00687 
00688             if (index < main_index)
00689                 overlapping();
00690             while (index > main_index++)
00691                 *str_ptr++ = ' ';
00692 
00693                 k = (int) (((chainp) values->datap)->nextp->nextp->datap);
00694                 if ((int)((chainp)values->datap)->nextp->datap == TYBLANK) {
00695                         b = k;
00696                         break;
00697                         }
00698                 *str_ptr = k;
00699                 values = values -> nextp;
00700         } /* for str_ptr */
00701         *str_ptr = '\0';
00702         Const = storage;
00703         Const -> ccp = str;
00704         Const -> ccp1.blanks = b;
00705         charlen = str_ptr - str;
00706     } else {
00707         int i = 0;
00708         chainp vals;
00709 
00710         vals = ((chainp)values->datap)->nextp->nextp;
00711         if (vals) {
00712                 L = (char **)storage;
00713                 do L[i++] = vals->datap;
00714                         while(vals = vals->nextp);
00715                 }
00716 
00717     } /* else */
00718 
00719 } /* make_one_const */

00785 {
00786     chainp this_var;
00787     extern chainp new_vars;
00788     extern struct Hashentry *hashtab, *lasthash;
00789     struct Hashentry *entry;
00790 
00791     for (this_var = new_vars; this_var; this_var = this_var -> nextp) {
00792         Addrp var = (Addrp) this_var->datap;
00793 
00794         if (var == (Addrp) NULL)
00795             Fatal("memno2info:  null variable");
00796         else if (var -> tag != TADDR)
00797             Fatal("memno2info:  bad tag");
00798         if (memno == var -> memno) {
00799             *info = (Namep) var;
00800             return 1;
00801         } /* if memno == var -> memno */
00802     } /* for this_var = new_vars */
00803 
00804     for (entry = hashtab; entry < lasthash; ++entry) {
00805         Namep var = entry -> varp;
00806 
00807         if (var && var -> vardesc.varno == memno && var -> vstg == STGINIT) {
00808             *info = (Namep) var;
00809             return 0;
00810         } /* if entry -> vardesc.varno == memno */
00811     } /* for entry = hashtab */
00812 
00813     Fatal("memno2info:  couldn't find memno");
00814     return 0;
00815 } /* memno2info */

00484 {
00485         extern char *filename0;
00486         static int warned = 0;
00487 
00488         if (warned)
00489                 return;
00490         warned = 1;
00491 
00492         fprintf(stderr, "Error");
00493         if (filename0)
00494                 fprintf(stderr, " in file %s", filename0);
00495         fprintf(stderr, ": overlapping initializations\n");
00496         nerr++;
00497         }

00762 {
00763     register int c;
00764 
00765     for (c = getc (infile); !feof (infile) && isspace (c); c = getc (infile))
00766         ;
00767 
00768     if (feof (infile))
00769         return NO;
00770 
00771     for (*n = 0; isdigit (c); c = getc (infile))
00772         *n = 10 * (*n) + c - '0';
00773     return YES;
00774 } /* rdlong */

00731 {
00732     register int i, c;
00733 
00734     c = getc (infile);
00735 
00736     if (feof (infile))
00737         return NO;
00738 
00739     *vargroupp = c - '0';
00740     for (i = 1;; i++) {
00741         if (i >= NAME_MAX)
00742                 Fatal("rdname: oversize name");
00743         c = getc (infile);
00744         if (feof (infile))
00745             return NO;
00746         if (c == '\t')
00747                 break;
00748         *name++ = c;
00749     }
00750     *name = 0;
00751     return YES;
00752 } /* rdname */

00554 {
00555     int size = typesize[type];
00556     long index, main_index = 0;
00557     int k;
00558 
00559     if (type == TYCHAR) {
00560         nice_printf(outfile, "\"");
00561         k = 0;
00562         if (Ansi != 1)
00563                 ch_ar_dim = -1;
00564         }
00565     else
00566         nice_printf (outfile, "{ ");
00567     while (values) {
00568         struct Constblock Const;
00569 
00570         index = ((long) ((chainp) values->datap)->datap) / size;
00571         while (index > main_index) {
00572 
00573 /* Fill with zeros.  The structure shorthand works because the compiler
00574    will expand the "0" in braces to fill the size of the entire structure
00575    */
00576 
00577             switch (type) {
00578                 case TYREAL:
00579                 case TYDREAL:
00580                     nice_printf (outfile, "0.0,");
00581                     break;
00582                 case TYCOMPLEX:
00583                 case TYDCOMPLEX:
00584                     nice_printf (outfile, "{0},");
00585                     break;
00586                 case TYCHAR:
00587                         nice_printf(outfile, " ");
00588                         break;
00589                 default:
00590                     nice_printf (outfile, "0,");
00591                     break;
00592             } /* switch */
00593             main_index++;
00594         } /* while index > main_index */
00595 
00596         if (index < main_index)
00597                 overlapping();
00598         else switch (type) {
00599             case TYCHAR:
00600                 { int this_char;
00601 
00602                 if (k == ch_ar_dim) {
00603                         nice_printf(outfile, "\" \"");
00604                         k = 0;
00605                         }
00606                 this_char = (int) ((chainp) values->datap)->
00607                                 nextp->nextp->datap;
00608                 if ((int)((chainp)values->datap)->nextp->datap == TYBLANK) {
00609                         main_index += this_char;
00610                         k += this_char;
00611                         while(--this_char >= 0)
00612                                 nice_printf(outfile, " ");
00613                         values = values -> nextp;
00614                         continue;
00615                         }
00616                 nice_printf(outfile, str_fmt[this_char], this_char);
00617                 k++;
00618                 } /* case TYCHAR */
00619                 break;
00620 
00621             case TYINT1:
00622             case TYSHORT:
00623             case TYLONG:
00624 #ifdef TYQUAD
00625             case TYQUAD:
00626 #endif
00627             case TYREAL:
00628             case TYDREAL:
00629             case TYLOGICAL:
00630             case TYLOGICAL1:
00631             case TYLOGICAL2:
00632             case TYCOMPLEX:
00633             case TYDCOMPLEX:
00634                 make_one_const(type, &Const.Const, values);
00635                 Const.vtype = type;
00636                 Const.vstg = ONEOF(type, MSKREAL|MSKCOMPLEX) != 0;
00637                 out_const(outfile, &Const);
00638                 break;
00639             default:
00640                 erri("wr_array_init: bad type '%d'", type);
00641                 break;
00642         } /* switch */
00643         values = values->nextp;
00644 
00645         main_index++;
00646         if (values && type != TYCHAR)
00647             nice_printf (outfile, ",");
00648     } /* while values */
00649 
00650     if (type == TYCHAR) {
00651         nice_printf(outfile, "\"");
00652         }
00653     else
00654         nice_printf (outfile, " }");
00655 } /* wr_array_init */

00152 {
00153         int i, nd;
00154         expptr e;
00155         ftnint j, rv;
00156 
00157         if (!dimp) {
00158                 nice_printf (outfile, extra1 ? "[%d+1]" : "[%d]", n);
00159                 return n + extra1;
00160                 }
00161         nice_printf(outfile, "[%d", n);
00162         nd = dimp->ndim;
00163         rv = n;
00164         for(i = 0; i < nd; i++) {
00165                 e = dimp->dims[i].dimsize;
00166                 if (ISCONST(e)) {
00167                         if (ISINT(e->constblock.vtype))
00168                                 j = e->constblock.Const.ci;
00169                         else if (ISREAL(e->constblock.vtype))
00170                                 j = (ftnint)e->constblock.Const.cd[0];
00171                         else
00172                                 goto non_const;
00173                         nice_printf(outfile, "*%ld", j);
00174                         rv *= j;
00175                         }
00176                 else {
00177  non_const:
00178                         err ("wr_char_len:  nonconstant array size");
00179                         }
00180                 }
00181         /* extra1 allows for stupid C compilers that complain about
00182          * too many initializers in
00183          *      char x[2] = "ab";
00184          */
00185         nice_printf(outfile, extra1 ? "+1]" : "]");
00186         return extra1 ? rv+1 : rv;
00187         }

00940 {
00941         struct Equivblock *eqv;
00942         int btype, curtype, dtype, filltype, filltype1, j, k, wasblank, xtype;
00943         static char Blank[] = "";
00944         register char *comma = Blank;
00945         register chainp cp, v;
00946         chainp sentinel, values, v1, vlast;
00947         ftnint L, L1, dL, dloc, loc, loc0;
00948         union Constant Const;
00949         char imag_buf[50], real_buf[50];
00950         int szshort = typesize[TYSHORT];
00951         static char typepref[] = {0, 0, TYINT1, TYSHORT, TYLONG,
00952 #ifdef TYQUAD
00953                                   TYQUAD,
00954 #endif
00955                                   TYREAL, TYDREAL, TYREAL, TYDREAL,
00956                                   TYLOGICAL1, TYLOGICAL2,
00957                                   TYLOGICAL, TYCHAR};
00958         static char basetype[] = {0, 0, TYCHAR, TYSHORT, TYLONG,
00959 #ifdef TYQUAD
00960                                   TYDREAL,
00961 #endif
00962                                   TYLONG, TYDREAL, TYLONG, TYDREAL,
00963                                   TYCHAR, TYSHORT,
00964                                   TYLONG, TYCHAR, 0 /* for TYBLANK */ };
00965         extern int htype;
00966         char *z;
00967 
00968         /* add sentinel */
00969         if (iscomm) {
00970                 L = extsymtab[memno].maxleng;
00971                 xtype = extsymtab[memno].extype;
00972                 }
00973         else {
00974                 eqv = &eqvclass[memno];
00975                 L = eqv->eqvtop - eqv->eqvbottom;
00976                 xtype = eqv->eqvtype;
00977                 }
00978 
00979         if (halign && typealign[typepref[xtype]] < typealign[htype])
00980                 xtype = htype;
00981         *Values = values = revchain(vlast = *Values);
00982 
00983         if (xtype != TYCHAR) {
00984 
00985                 /* unless the data include a value of the appropriate
00986                  * type, we add an extra element in an attempt
00987                  * to force correct alignment */
00988 
00989                 btype = basetype[xtype];
00990                 loc = 0;
00991                 for(v = *Values;;v = v->nextp) {
00992                         if (!v) {
00993                                 dtype = typepref[xtype];
00994                                 z = ISREAL(dtype) ? cpstring("0.") : (char *)0;
00995                                 k = typesize[dtype];
00996                                 if (j = L % k)
00997                                         L += k - j;
00998                                 v = mkchain((char *)L,
00999                                         mkchain((char *)LONG_CAST dtype,
01000                                                 mkchain(z, CHNULL)));
01001                                 vlast = vlast->nextp =
01002                                         mkchain((char *)v, CHNULL);
01003                                 L += k;
01004                                 break;
01005                                 }
01006                         cp = (chainp)v->datap;
01007                         if (basetype[(int)cp->nextp->datap] == btype)
01008                                 break;
01009                         dloc = (ftnint)cp->datap;
01010                         L1 = dloc - loc;
01011                         if (L1 > 0
01012                          && !(L1 % szshort)
01013                          && !(loc % szshort)
01014                          && btype <= type_choice[L1/szshort % 4]
01015                          && btype <= type_choice[loc/szshort % 4])
01016                                 break;
01017                         dtype = (int)cp->nextp->datap;
01018                         loc = dloc + dtype == TYBLANK
01019                                         ? (ftnint)cp->nextp->nextp->datap
01020                                         : typesize[dtype];
01021                         }
01022                 }
01023         sentinel = mkchain((char *)L, mkchain((char *)TYERROR,CHNULL));
01024         vlast->nextp = mkchain((char *)sentinel, CHNULL);
01025 
01026         /* use doublereal fillers only if there are doublereal values */
01027 
01028         k = TYLONG;
01029         for(v = values; v; v = v->nextp)
01030                 if (ONEOF((int)((chainp)v->datap)->nextp->datap,
01031                                 M(TYDREAL)|M(TYDCOMPLEX))) {
01032                         k = TYDREAL;
01033                         break;
01034                         }
01035         type_choice[0] = k;
01036 
01037         nice_printf(outfile, "%sstruct {\n", iscomm ? "" : "static ");
01038         next_tab(outfile);
01039         loc = loc0 = k = 0;
01040         curtype = -1;
01041         for(v = values; v; v = v->nextp) {
01042                 cp = (chainp)v->datap;
01043                 dloc = (ftnint)cp->datap;
01044                 L = dloc - loc;
01045                 if (L < 0) {
01046                         overlapping();
01047                         if ((int)cp->nextp->datap != TYERROR) {
01048                                 v1 = cp;
01049                                 frchain(&v1);
01050                                 v->datap = 0;
01051                                 }
01052                         continue;
01053                         }
01054                 dtype = (int)cp->nextp->datap;
01055                 if (dtype == TYBLANK) {
01056                         dtype = TYCHAR;
01057                         wasblank = 1;
01058                         }
01059                 else
01060                         wasblank = 0;
01061                 if (curtype != dtype || L > 0) {
01062                         if (curtype != -1) {
01063                                 L1 = (loc - loc0)/dL;
01064                                 nice_printf(outfile, "%s e_%d%s;\n",
01065                                         typename[curtype], ++k,
01066                                         Len(L1,curtype));
01067                                 }
01068                         curtype = dtype;
01069                         loc0 = dloc;
01070                         }
01071                 if (L > 0) {
01072                         if (xtype == TYCHAR)
01073                                 filltype = TYCHAR;
01074                         else {
01075                                 filltype = L % szshort ? TYCHAR
01076                                                 : type_choice[L/szshort % 4];
01077                                 filltype1 = loc % szshort ? TYCHAR
01078                                                 : type_choice[loc/szshort % 4];
01079                                 if (typesize[filltype] > typesize[filltype1])
01080                                         filltype = filltype1;
01081                                 }
01082                         L1 = L / typesize[filltype];
01083                         nice_printf(outfile, "%s fill_%d[%ld];\n",
01084                                 typename[filltype], ++k, L1);
01085                         loc = dloc;
01086                         }
01087                 if (wasblank) {
01088                         loc += (ftnint)cp->nextp->nextp->datap;
01089                         dL = 1;
01090                         }
01091                 else {
01092                         dL = typesize[dtype];
01093                         loc += dL;
01094                         }
01095                 }
01096         nice_printf(outfile, "} %s = { ", iscomm
01097                 ? extsymtab[memno].cextname
01098                 : equiv_name(eqvmemno, CNULL));
01099         loc = 0;
01100         for(v = values; ; v = v->nextp) {
01101                 cp = (chainp)v->datap;
01102                 if (!cp)
01103                         continue;
01104                 dtype = (int)cp->nextp->datap;
01105                 if (dtype == TYERROR)
01106                         break;
01107                 dloc = (ftnint)cp->datap;
01108                 if (dloc > loc) {
01109                         nice_printf(outfile, "%s{0}", comma);
01110                         comma = ", ";
01111                         loc = dloc;
01112                         }
01113                 if (comma != Blank)
01114                         nice_printf(outfile, ", ");
01115                 comma = ", ";
01116                 if (dtype == TYCHAR || dtype == TYBLANK) {
01117                         v =  Ansi == 1  ? Ado_string(outfile, v, &loc)
01118                                         :  do_string(outfile, v, &loc);
01119                         continue;
01120                         }
01121                 make_one_const(dtype, &Const, v);
01122                 switch(dtype) {
01123                         case TYLOGICAL:
01124                         case TYLOGICAL2:
01125                         case TYLOGICAL1:
01126                                 if (Const.ci < 0 || Const.ci > 1)
01127                                         errl(
01128                           "wr_equiv_init: unexpected logical value %ld",
01129                                                 Const.ci);
01130                                 nice_printf(outfile,
01131                                         Const.ci ? "TRUE_" : "FALSE_");
01132                                 break;
01133                         case TYINT1:
01134                         case TYSHORT:
01135                         case TYLONG:
01136 #ifdef TYQUAD
01137                         case TYQUAD:
01138 #endif
01139                                 nice_printf(outfile, "%ld", Const.ci);
01140                                 break;
01141                         case TYREAL:
01142                                 nice_printf(outfile, "%s",
01143                                         flconst(real_buf, Const.cds[0]));
01144                                 break;
01145                         case TYDREAL:
01146                                 nice_printf(outfile, "%s", Const.cds[0]);
01147                                 break;
01148                         case TYCOMPLEX:
01149                                 nice_printf(outfile, "%s, %s",
01150                                         flconst(real_buf, Const.cds[0]),
01151                                         flconst(imag_buf, Const.cds[1]));
01152                                 break;
01153                         case TYDCOMPLEX:
01154                                 nice_printf(outfile, "%s, %s",
01155                                         Const.cds[0], Const.cds[1]);
01156                                 break;
01157                         default:
01158                                 erri("unexpected type %d in wr_equiv_init",
01159                                         dtype);
01160                         }
01161                 loc += typesize[dtype];
01162                 }
01163         nice_printf(outfile, " };\n\n");
01164         prev_tab(outfile);
01165         frchain(&sentinel);
01166         }

00264 {
00265     static int memno;
00266     static union {
00267         Namep name;
00268         Addrp addr;
00269     } info;
00270     Namep namep;
00271     int is_addr, size, type;
00272     ftnint last, loc;
00273     int is_scalar = 0;
00274     char *array_comment = NULL, *name;
00275     chainp cp, values;
00276     extern char datachar[];
00277     static int e1[3] = {1, 0, 1};
00278     ftnint x;
00279     extern int hsize;
00280 
00281     if (!keepit)
00282         goto done;
00283     if (varname == NULL || varname[1] != '.')
00284         goto badvar;
00285 
00286 /* Get back to a meaningful representation; find the given   memno in one
00287    of the appropriate tables (user-generated variables in the hash table,
00288    system-generated variables in a separate list */
00289 
00290     memno = atoi(varname + 2);
00291     switch(varname[0]) {
00292         case 'q':
00293                 /* Must subtract eqvstart when the source file
00294                  * contains more than one procedure.
00295                  */
00296                 wr_equiv_init(outfile, eqvmemno = memno - eqvstart, Values, 0);
00297                 goto done;
00298         case 'Q':
00299                 /* COMMON initialization (BLOCK DATA) */
00300                 wr_equiv_init(outfile, memno, Values, 1);
00301                 goto done;
00302         case 'v':
00303                 break;
00304         default:
00305  badvar:
00306                 errstr("wr_one_init:  unknown variable name '%s'", varname);
00307                 goto done;
00308         }
00309 
00310     is_addr = memno2info (memno, &info.name);
00311     if (info.name == (Namep) NULL) {
00312         err ("wr_one_init -- unknown variable");
00313         return;
00314         }
00315     if (is_addr) {
00316         if (info.addr -> uname_tag != UNAM_NAME) {
00317             erri ("wr_one_init -- couldn't get name pointer; tag is %d",
00318                     info.addr -> uname_tag);
00319             namep = (Namep) NULL;
00320             nice_printf (outfile, " /* bad init data */");
00321         } else
00322             namep = info.addr -> user.name;
00323     } else
00324         namep = info.name;
00325 
00326         /* check for character initialization */
00327 
00328     *Values = values = revchain(*Values);
00329     type = info.name->vtype;
00330     if (type == TYCHAR) {
00331         for(last = 0; values; values = values->nextp) {
00332                 cp = (chainp)values->datap;
00333                 loc = (ftnint)cp->datap;
00334                 if (loc > last) {
00335                         write_char_init(outfile, Values, namep);
00336                         goto done;
00337                         }
00338                 last = (int)cp->nextp->datap == TYBLANK
00339                         ? loc + (int)cp->nextp->nextp->datap
00340                         : loc + 1;
00341                 }
00342         if (halign && info.name->tag == TNAME) {
00343                 nice_printf(outfile, "static struct { %s fill; char val",
00344                         halign);
00345                 x = wr_char_len(outfile, namep->vdim, ch_ar_dim =
00346                         info.name -> vleng -> constblock.Const.ci, 1);
00347                 if (x %= hsize)
00348                         nice_printf(outfile, "; char fill2[%ld]", hsize - x);
00349                 name = info.name->cvarname;
00350                 nice_printf(outfile, "; } %s_st = { 0,", name);
00351                 wr_output_values(outfile, namep, *Values);
00352                 nice_printf(outfile, " };\n");
00353                 ch_ar_dim = -1;
00354                 def_start(outfile, name, CNULL, name);
00355                 margin_printf(outfile, "_st.val\n");
00356                 goto done;
00357                 }
00358         }
00359     else {
00360         size = typesize[type];
00361         loc = 0;
00362         for(; values; values = values->nextp) {
00363                 if ((int)((chainp)values->datap)->nextp->datap == TYCHAR) {
00364                         write_char_init(outfile, Values, namep);
00365                         goto done;
00366                         }
00367                 last = ((long) ((chainp) values->datap)->datap) / size;
00368                 if (last - loc > 4) {
00369                         write_char_init(outfile, Values, namep);
00370                         goto done;
00371                         }
00372                 loc = last;
00373                 }
00374         }
00375     values = *Values;
00376 
00377     nice_printf (outfile, "static %s ", c_type_decl (type, 0));
00378 
00379     if (is_addr)
00380         write_nv_ident (outfile, info.addr);
00381     else
00382         out_name (outfile, info.name);
00383 
00384     if (namep)
00385         is_scalar = namep -> vdim == (struct Dimblock *) NULL;
00386 
00387     if (namep && !is_scalar)
00388         array_comment = type == TYCHAR
00389                 ? 0 : wr_ardecls(outfile, namep->vdim, 1L);
00390 
00391     if (type == TYCHAR)
00392         if (ISICON (info.name -> vleng))
00393 
00394 /* We'll make single strings one character longer, so that we can use the
00395    standard C initialization.  All this does is pad an extra zero onto the
00396    end of the string */
00397                 wr_char_len(outfile, namep->vdim, ch_ar_dim =
00398                         info.name -> vleng -> constblock.Const.ci, e1[Ansi]);
00399         else
00400                 err ("variable length character initialization");
00401 
00402     if (array_comment)
00403         nice_printf (outfile, "%s", array_comment);
00404 
00405     nice_printf (outfile, " = ");
00406     wr_output_values (outfile, namep, values);
00407     ch_ar_dim = -1;
00408     nice_printf (outfile, ";\n");
00409  done:
00410     frchain(Values);
00411 } /* wr_one_init */

00511 {
00512         int type = TYUNKNOWN;
00513         struct Constblock Const;
00514         static expptr Vlen;
00515 
00516         if (namep)
00517                 type = namep -> vtype;
00518 
00519 /* Handle array initializations away from scalars */
00520 
00521         if (namep && namep -> vdim)
00522                 wr_array_init (outfile, namep -> vtype, values);
00523 
00524         else if (values->nextp && type != TYCHAR)
00525                 overlapping();
00526 
00527         else {
00528                 make_one_const(type, &Const.Const, values);
00529                 Const.vtype = type;
00530                 Const.vstg = ONEOF(type, MSKREAL|MSKCOMPLEX) != 0;
00531                 if (type== TYCHAR) {
00532                         if (!Vlen)
00533                                 Vlen = ICON(0);
00534                         Const.vleng = Vlen;
00535                         Vlen->constblock.Const.ci = charlen;
00536                         out_const (outfile, &Const);
00537                         free (Const.Const.ccp);
00538                         }
00539                 else
00540                         out_const (outfile, &Const);
00541                 }
00542         }

00201 {
00202         struct Equivblock *eqv;
00203         long size;
00204         struct Dimblock *dimp;
00205         int i, nd, type;
00206         ftnint j;
00207         expptr ds;
00208 
00209         if (!namep)
00210                 return;
00211         if(nequiv >= maxequiv)
00212                 many("equivalences", 'q', maxequiv);
00213         eqv = &eqvclass[nequiv];
00214         eqv->eqvbottom = 0;
00215         type = namep->vtype;
00216         size = type == TYCHAR
00217                 ? namep->vleng->constblock.Const.ci
00218                 : typesize[type];
00219         if (dimp = namep->vdim)
00220                 for(i = 0, nd = dimp->ndim; i < nd; i++) {
00221                         ds = dimp->dims[i].dimsize;
00222                         if (ISCONST(ds)) {
00223                                 if (ISINT(ds->constblock.vtype))
00224                                         j = ds->constblock.Const.ci;
00225                                 else if (ISREAL(ds->constblock.vtype))
00226                                         j = (ftnint)ds->constblock.Const.cd[0];
00227                                 else
00228                                         goto non_const;
00229                                 size *= j;
00230                                 }
00231                         else {
00232  non_const:
00233                                 err("write_char_values: nonconstant array size");
00234                                 }
00235                         }
00236         *Values = revchain(*Values);
00237         eqv->eqvtop = size;
00238         eqvmemno = ++lastvarno;
00239         eqv->eqvtype = type;
00240         wr_equiv_init(outfile, nequiv, Values, 0);
00241         def_start(outfile, namep->cvarname, CNULL, "");
00242         if (type == TYCHAR)
00243                 margin_printf(outfile, "((char *)&equiv_%d)\n\n", eqvmemno);
00244         else
00245                 margin_printf(outfile, dimp
00246                         ? "((%s *)&equiv_%d)\n\n" : "(*(%s *)&equiv_%d)\n\n",
00247                         c_type_decl(type,0), eqvmemno);
00248         }