00001
00002
00003
00004
00005
00006
00007
00008
00009
00010
00011
00012
00013
00014
00015
00016
00017
00018
00019
00020
00021
00022
00023
00024 #include "defs.h"
00025 #include "names.h"
00026 #include "output.h"
00027 #include "p1defs.h"
00028
00029
00030
00031
00032
00033 #undef roundup
00034 #define roundup(a,b) ( b * ( (a+b-1)/b) )
00035
00036 #define EXNULL (union Expression *)0
00037
00038 static void dobss Argdcl((void));
00039 static void docomleng Argdcl((void));
00040 static void docommon Argdcl((void));
00041 static void doentry Argdcl((struct Entrypoint*));
00042 static void epicode Argdcl((void));
00043 static int nextarg Argdcl((int));
00044 static void retval Argdcl((int));
00045
00046 static char Blank[] = BLANKCOMMON;
00047
00048 static char *postfix[] = { "g", "h", "i",
00049 #ifdef TYQUAD
00050 "j",
00051 #endif
00052 "r", "d", "c", "z", "g", "h", "i" };
00053
00054 chainp new_procs;
00055 int prev_proc, proc_argchanges, proc_protochanges;
00056
00057 void
00058 #ifdef KR_headers
00059 changedtype(q)
00060 Namep q;
00061 #else
00062 changedtype(Namep q)
00063 #endif
00064 {
00065 char buf[200];
00066 int qtype, type1;
00067 register Extsym *e;
00068 Argtypes *at;
00069
00070 if (q->vtypewarned)
00071 return;
00072 q->vtypewarned = 1;
00073 qtype = q->vtype;
00074 e = &extsymtab[q->vardesc.varno];
00075 if (!(at = e->arginfo)) {
00076 if (!e->exused)
00077 return;
00078 }
00079 else if (at->changes & 2 && qtype != TYUNKNOWN && !at->defined)
00080 proc_protochanges++;
00081 type1 = e->extype;
00082 if (type1 == TYUNKNOWN)
00083 return;
00084 if (qtype == TYUNKNOWN)
00085
00086
00087
00088
00089
00090
00091
00092 return;
00093 sprintf(buf, "%.90s: inconsistent declarations:\n\
00094 here %s%s, previously %s%s.", q->fvarname, ftn_types[qtype],
00095 qtype == TYSUBR ? "" : " function",
00096 ftn_types[type1], type1 == TYSUBR ? "" : " function");
00097 warn(buf);
00098 }
00099
00100 void
00101 #ifdef KR_headers
00102 unamstring(q, s)
00103 register Addrp q;
00104 register char *s;
00105 #else
00106 unamstring(register Addrp q, register char *s)
00107 #endif
00108 {
00109 register int k;
00110 register char *t;
00111
00112 k = strlen(s);
00113 if (k < IDENT_LEN) {
00114 q->uname_tag = UNAM_IDENT;
00115 t = q->user.ident;
00116 }
00117 else {
00118 q->uname_tag = UNAM_CHARP;
00119 q->user.Charp = t = mem(k+1, 0);
00120 }
00121 strcpy(t, s);
00122 }
00123
00124 static void
00125 fix_entry_returns(Void)
00126 {
00127 Addrp a;
00128 int i;
00129 struct Entrypoint *e;
00130 Namep np;
00131
00132 e = entries = (struct Entrypoint *)revchain((chainp)entries);
00133 allargs = revchain(allargs);
00134 if (!multitype)
00135 return;
00136
00137
00138
00139 for(i = TYINT1; i <= TYLOGICAL; i++)
00140 if (a = xretslot[i])
00141 sprintf(a->user.ident, "(*ret_val).%s",
00142 postfix[i-TYINT1]);
00143
00144 do {
00145 np = e->enamep;
00146 switch(np->vtype) {
00147 case TYINT1:
00148 case TYSHORT:
00149 case TYLONG:
00150 #ifdef TYQUAD
00151 case TYQUAD:
00152 #endif
00153 case TYREAL:
00154 case TYDREAL:
00155 case TYCOMPLEX:
00156 case TYDCOMPLEX:
00157 case TYLOGICAL1:
00158 case TYLOGICAL2:
00159 case TYLOGICAL:
00160 np->vstg = STGARG;
00161 }
00162 }
00163 while(e = e->entnextp);
00164 }
00165
00166 static void
00167 #ifdef KR_headers
00168 putentries(outfile)
00169 FILE *outfile;
00170 #else
00171 putentries(FILE *outfile)
00172 #endif
00173
00174 {
00175 char base[MAXNAMELEN+4];
00176 struct Entrypoint *e;
00177 Namep *A, *Ae, *Ae1, **Alp, *a, **a1, np;
00178 chainp args, lengths;
00179 int i, k, mt, nL, t, type;
00180 extern char *dfltarg[], **dfltproc;
00181
00182 e = entries;
00183 if (!e->enamep)
00184 return;
00185 nL = (nallargs + nallchargs) * sizeof(Namep *);
00186 A = (Namep *)ckalloc(nL + nallargs*sizeof(Namep **));
00187 Ae = A + nallargs;
00188 Alp = (Namep **)(Ae1 = Ae + nallchargs);
00189 i = k = 0;
00190 for(a1 = Alp, args = allargs; args; a1++, args = args->nextp) {
00191 np = (Namep)args->datap;
00192 if (np->vtype == TYCHAR && np->vclass != CLPROC)
00193 *a1 = &Ae[i++];
00194 }
00195
00196 mt = multitype;
00197 multitype = 0;
00198 sprintf(base, "%s0_", e->enamep->cvarname);
00199 do {
00200 np = e->enamep;
00201 lengths = length_comp(e, 0);
00202 proctype = type = np->vtype;
00203 if (protofile)
00204 protowrite(protofile, type, np->cvarname, e, lengths);
00205 nice_printf(outfile, "\n%s ", c_type_decl(type, 1));
00206 nice_printf(outfile, "%s", np->cvarname);
00207 if (!Ansi) {
00208 listargs(outfile, e, 0, lengths);
00209 nice_printf(outfile, "\n");
00210 }
00211 list_arg_types(outfile, e, lengths, 0, "\n");
00212 nice_printf(outfile, "{\n");
00213 frchain(&lengths);
00214 next_tab(outfile);
00215 if (mt)
00216 nice_printf(outfile,
00217 "Multitype ret_val;\n%s(%d, &ret_val",
00218 base, k);
00219 else if (ISCOMPLEX(type))
00220 nice_printf(outfile, "%s(%d,%s", base, k,
00221 xretslot[type]->user.ident);
00222 else if (type == TYCHAR)
00223 nice_printf(outfile,
00224 "%s(%d, ret_val, ret_val_len", base, k);
00225 else
00226 nice_printf(outfile, "return %s(%d", base, k);
00227 k++;
00228 memset((char *)A, 0, nL);
00229 for(args = e->arglist; args; args = args->nextp) {
00230 np = (Namep)args->datap;
00231 A[np->argno] = np;
00232 if (np->vtype == TYCHAR && np->vclass != CLPROC)
00233 *Alp[np->argno] = np;
00234 }
00235 args = allargs;
00236 for(a = A; a < Ae; a++, args = args->nextp) {
00237 t = ((Namep)args->datap)->vtype;
00238 nice_printf(outfile, ", %s", (np = *a)
00239 ? np->cvarname
00240 : ((Namep)args->datap)->vclass == CLPROC
00241 ? dfltproc[((Namep)args->datap)->vimpltype
00242 ? (Castargs ? TYUNKNOWN : TYSUBR)
00243 : t == TYREAL && forcedouble && !Castargs
00244 ? TYDREAL : t]
00245 : dfltarg[((Namep)args->datap)->vtype]);
00246 }
00247 for(; a < Ae1; a++)
00248 if (np = *a)
00249 nice_printf(outfile, ", %s",
00250 new_arg_length(np));
00251 else
00252 nice_printf(outfile, ", (ftnint)0");
00253 nice_printf(outfile, ");\n");
00254 if (mt) {
00255 if (type == TYCOMPLEX)
00256 nice_printf(outfile,
00257 "r_v->r = ret_val.c.r; r_v->i = ret_val.c.i;\n");
00258 else if (type == TYDCOMPLEX)
00259 nice_printf(outfile,
00260 "r_v->r = ret_val.z.r; r_v->i = ret_val.z.i;\n");
00261 else if (type <= TYLOGICAL)
00262 nice_printf(outfile, "return ret_val.%s;\n",
00263 postfix[type-TYINT1]);
00264 }
00265 nice_printf(outfile, "}\n");
00266 prev_tab(outfile);
00267 }
00268 while(e = e->entnextp);
00269 free((char *)A);
00270 }
00271
00272 static void
00273 #ifdef KR_headers
00274 entry_goto(outfile)
00275 FILE *outfile;
00276 #else
00277 entry_goto(FILE *outfile)
00278 #endif
00279 {
00280 struct Entrypoint *e = entries;
00281 int k = 0;
00282
00283 nice_printf(outfile, "switch(n__) {\n");
00284 next_tab(outfile);
00285 while(e = e->entnextp)
00286 nice_printf(outfile, "case %d: goto %s;\n", ++k,
00287 user_label((long)(extsymtab - e->entryname - 1)));
00288 nice_printf(outfile, "}\n\n");
00289 prev_tab(outfile);
00290 }
00291
00292
00293
00294 void
00295 newproc(Void)
00296 {
00297 if(parstate != OUTSIDE)
00298 {
00299 execerr("missing end statement", CNULL);
00300 endproc();
00301 }
00302
00303 parstate = INSIDE;
00304 procclass = CLMAIN;
00305 }
00306
00307 static void
00308 zap_changes(Void)
00309 {
00310 register chainp cp;
00311 register Argtypes *at;
00312
00313
00314
00315
00316 if (prev_proc && proc_argchanges)
00317 proc_protochanges++;
00318 prev_proc = proc_argchanges = 0;
00319 for(cp = new_procs; cp; cp = cp->nextp)
00320 if (at = ((Namep)cp->datap)->arginfo)
00321 at->changes &= ~1;
00322 frchain(&new_procs);
00323 }
00324
00325
00326
00327 void
00328 endproc(Void)
00329 {
00330 struct Labelblock *lp;
00331 Extsym *ext;
00332
00333 if(parstate < INDATA)
00334 enddcl();
00335 if(ctlstack >= ctls)
00336 err("DO loop or BLOCK IF not closed");
00337 for(lp = labeltab ; lp < labtabend ; ++lp)
00338 if(lp->stateno!=0 && lp->labdefined==NO)
00339 errstr("missing statement label %s",
00340 convic(lp->stateno) );
00341
00342
00343
00344 for (ext = extsymtab; ext < nextext; ext++)
00345 if (ext -> extstg == STGCOMMON && ext -> extp) {
00346 extern int usedefsforcommon;
00347
00348
00349
00350 copy_data (ext -> extp);
00351 if (usedefsforcommon) {
00352 wr_abbrevs (c_file, 1, ext -> extp);
00353 ext -> used_here = 1;
00354 }
00355 else
00356 ext -> extp = CHNULL;
00357
00358 }
00359
00360 if (nentry > 1)
00361 fix_entry_returns();
00362 epicode();
00363 donmlist();
00364 dobss();
00365 start_formatting ();
00366 if (nentry > 1)
00367 putentries(c_file);
00368
00369 zap_changes();
00370 procinit();
00371 }
00372
00373
00374
00375
00376
00377 void
00378 enddcl(Void)
00379 {
00380 register struct Entrypoint *ep;
00381 struct Entrypoint *ep0;
00382 chainp cp;
00383 extern char *err_proc;
00384 static char comblks[] = "common blocks";
00385
00386 err_proc = comblks;
00387 docommon();
00388
00389
00390
00391
00392
00393 err_proc = "equivalences";
00394 doequiv();
00395
00396 err_proc = comblks;
00397 docomleng();
00398
00399
00400
00401
00402 err_proc = "entries";
00403 if (ep = ep0 = (struct Entrypoint *)revchain((chainp)entries)) {
00404
00405 do doentry(ep);
00406 while(ep = ep->entnextp);
00407 entries = (struct Entrypoint *)revchain((chainp)ep0);
00408 }
00409
00410 err_proc = 0;
00411 parstate = INEXEC;
00412 p1put(P1_PROCODE);
00413 freetemps();
00414 if (earlylabs) {
00415 for(cp = earlylabs = revchain(earlylabs); cp; cp = cp->nextp)
00416 p1_label((long)cp->datap);
00417 frchain(&earlylabs);
00418 }
00419 p1_line_number(lineno);
00420
00421 }
00422
00423
00424
00425
00426
00427 void
00428 #ifdef KR_headers
00429 startproc(progname, classKRH)
00430 Extsym *progname;
00431 int classKRH;
00432 #else
00433 startproc(Extsym *progname, int classKRH)
00434 #endif
00435 {
00436 register struct Entrypoint *p;
00437
00438 p = ALLOC(Entrypoint);
00439 if(classKRH == CLMAIN) {
00440 puthead(CNULL, CLMAIN);
00441 if (progname)
00442 strcpy (main_alias, progname->cextname);
00443 } else {
00444 if (progname) {
00445
00446
00447
00448
00449 entrypt(CLPROC, TYSUBR, (ftnint)0, progname, (chainp)0);
00450 endproc();
00451 newproc();
00452 }
00453 puthead(CNULL, CLBLOCK);
00454 }
00455 if(classKRH == CLMAIN)
00456 newentry( mkname(" MAIN"), 0 )->extinit = 1;
00457 p->entryname = progname;
00458 entries = p;
00459
00460 procclass = classKRH;
00461 fprintf(diagfile, " %s", (classKRH==CLMAIN ? "MAIN" : "BLOCK DATA") );
00462 if(progname) {
00463 fprintf(diagfile, " %s", progname->fextname);
00464 procname = progname->cextname;
00465 }
00466 fprintf(diagfile, ":\n");
00467 fflush(diagfile);
00468 }
00469
00470
00471
00472 Extsym *
00473 #ifdef KR_headers
00474 newentry(v, substmsg)
00475 register Namep v;
00476 int substmsg;
00477 #else
00478 newentry(register Namep v, int substmsg)
00479 #endif
00480 {
00481 register Extsym *p;
00482 char buf[128], badname[64];
00483 static int nbad = 0;
00484 static char already[] = "external name already used";
00485
00486 p = mkext(v->fvarname, addunder(v->cvarname));
00487
00488 if(p->extinit || ! ONEOF(p->extstg, M(STGUNKNOWN)|M(STGEXT)) )
00489 {
00490 sprintf(badname, "%s_bad%d", v->fvarname, ++nbad);
00491 if (substmsg) {
00492 sprintf(buf,"%s\n\tsubstituting \"%s\"",
00493 already, badname);
00494 dclerr(buf, v);
00495 }
00496 else
00497 dclerr(already, v);
00498 p = mkext(v->fvarname, badname);
00499 }
00500 v->vstg = STGAUTO;
00501 v->vprocclass = PTHISPROC;
00502 v->vclass = CLPROC;
00503 if (p->extstg == STGEXT)
00504 prev_proc = 1;
00505 else
00506 p->extstg = STGEXT;
00507 p->extinit = YES;
00508 v->vardesc.varno = p - extsymtab;
00509 return(p);
00510 }
00511
00512 void
00513 #ifdef KR_headers
00514 entrypt(classKRH, type, length, entry, args)
00515 int classKRH;
00516 int type;
00517 ftnint length;
00518 Extsym *entry;
00519 chainp args;
00520 #else
00521 entrypt(int classKRH, int type, ftnint length, Extsym *entry, chainp args)
00522 #endif
00523 {
00524 register Namep q;
00525 register struct Entrypoint *p;
00526
00527 if(classKRH != CLENTRY)
00528 puthead( procname = entry->cextname, classKRH);
00529 else
00530 fprintf(diagfile, " entry ");
00531 fprintf(diagfile, " %s:\n", entry->fextname);
00532 fflush(diagfile);
00533 q = mkname(entry->fextname);
00534 if (type == TYSUBR)
00535 q->vstg = STGEXT;
00536
00537 type = lengtype(type, length);
00538 if(classKRH == CLPROC)
00539 {
00540 procclass = CLPROC;
00541 proctype = type;
00542 procleng = type == TYCHAR ? length : 0;
00543 }
00544
00545 p = ALLOC(Entrypoint);
00546
00547 p->entnextp = entries;
00548 entries = p;
00549
00550 p->entryname = entry;
00551 p->arglist = revchain(args);
00552 p->enamep = q;
00553
00554 if(classKRH == CLENTRY)
00555 {
00556 classKRH = CLPROC;
00557 if(proctype == TYSUBR)
00558 type = TYSUBR;
00559 }
00560
00561 q->vclass = classKRH;
00562 q->vprocclass = 0;
00563 settype(q, type, length);
00564 q->vprocclass = PTHISPROC;
00565
00566 if(parstate >= INDATA)
00567 doentry(p);
00568 }
00569
00570
00571
00572
00573
00574
00575
00576 LOCAL void
00577 epicode(Void)
00578 {
00579 extern int lastwasbranch;
00580
00581 if(procclass==CLPROC)
00582 {
00583 if(proctype==TYSUBR)
00584 {
00585
00586
00587
00588
00589 if ((substars || Ansi) && lastwasbranch != YES)
00590 p1_subr_ret (ICON(0));
00591 }
00592 else if (!multitype && lastwasbranch != YES)
00593 retval(proctype);
00594 }
00595 else if (procclass == CLMAIN && Ansi && lastwasbranch != YES)
00596 p1_subr_ret (ICON(0));
00597 lastwasbranch = NO;
00598 }
00599
00600
00601
00602
00603 LOCAL void
00604 #ifdef KR_headers
00605 retval(t)
00606 register int t;
00607 #else
00608 retval(register int t)
00609 #endif
00610 {
00611 register Addrp p;
00612
00613 switch(t)
00614 {
00615 case TYCHAR:
00616 case TYCOMPLEX:
00617 case TYDCOMPLEX:
00618 break;
00619
00620 case TYLOGICAL:
00621 t = tylogical;
00622 case TYINT1:
00623 case TYADDR:
00624 case TYSHORT:
00625 case TYLONG:
00626 #ifdef TYQUAD
00627 case TYQUAD:
00628 #endif
00629 case TYREAL:
00630 case TYDREAL:
00631 case TYLOGICAL1:
00632 case TYLOGICAL2:
00633 p = (Addrp) cpexpr((expptr)retslot);
00634 p->vtype = t;
00635 p1_subr_ret (mkconv (t, fixtype((expptr)p)));
00636 break;
00637
00638 default:
00639 badtype("retval", t);
00640 }
00641 }
00642
00643
00644
00645
00646 void
00647 #ifdef KR_headers
00648 procode(outfile)
00649 FILE *outfile;
00650 #else
00651 procode(FILE *outfile)
00652 #endif
00653 {
00654 prolog(outfile, allargs);
00655
00656 if (nentry > 1)
00657 entry_goto(outfile);
00658 }
00659
00660 static void
00661 #ifdef KR_headers
00662 bad_dimtype(q) Namep q;
00663 #else
00664 bad_dimtype(Namep q)
00665 #endif
00666 {
00667 errstr("bad dimension type for %.70s", q->fvarname);
00668 }
00669
00670
00671
00672
00673
00674
00675
00676
00677
00678 static void
00679 #ifdef KR_headers
00680 dim_finish(v)
00681 Namep v;
00682 #else
00683 dim_finish(Namep v)
00684 #endif
00685 {
00686 register struct Dimblock *p;
00687 register expptr q;
00688 register int i, nd;
00689
00690 p = v->vdim;
00691 v->vdimfinish = 0;
00692 nd = p->ndim;
00693 doin_setbound = 1;
00694 for(i = 0; i < nd; i++)
00695 if (q = p->dims[i].dimexpr) {
00696 q = p->dims[i].dimexpr = make_int_expr(putx(fixtype(q)));
00697 if (!ONEOF(q->headblock.vtype, MSKINT|MSKREAL))
00698 bad_dimtype(v);
00699 }
00700 if (q = p->basexpr)
00701 p->basexpr = make_int_expr(putx(fixtype(q)));
00702 doin_setbound = 0;
00703 }
00704
00705 static void
00706 #ifdef KR_headers
00707 duparg(q)
00708 Namep q;
00709 #else
00710 duparg(Namep q)
00711 #endif
00712 { errstr("duplicate argument %.80s", q->fvarname); }
00713
00714
00715
00716
00717
00718
00719 LOCAL void
00720 #ifdef KR_headers
00721 doentry(ep)
00722 struct Entrypoint *ep;
00723 #else
00724 doentry(struct Entrypoint *ep)
00725 #endif
00726 {
00727 register int type;
00728 register Namep np;
00729 chainp p, p1;
00730 register Namep q;
00731 Addrp rs;
00732 int it, k;
00733 extern char dflttype[26];
00734 Extsym *entryname = ep->entryname;
00735
00736 if (++nentry > 1)
00737 p1_label((long)(extsymtab - entryname - 1));
00738
00739
00740
00741
00742 if(procclass == CLMAIN || procclass == CLBLOCK)
00743 return;
00744
00745
00746
00747
00748 impldcl( np = mkname(entryname->fextname) );
00749 type = np->vtype;
00750 proc_argchanges = prev_proc && type != entryname->extype;
00751 entryname->extseen = 1;
00752 if(proctype == TYUNKNOWN)
00753 if( (proctype = type) == TYCHAR)
00754 procleng = np->vleng ? np->vleng->constblock.Const.ci
00755 : (ftnint) (-1);
00756
00757 if(proctype == TYCHAR)
00758 {
00759 if(type != TYCHAR)
00760 err("noncharacter entry of character function");
00761
00762
00763
00764
00765 else if( (np->vleng ? np->vleng->constblock.Const.ci :
00766 (ftnint) (-1)) != procleng)
00767 err("mismatched character entry lengths");
00768 }
00769 else if(type == TYCHAR)
00770 err("character entry of noncharacter function");
00771 else if(type != proctype)
00772 multitype = YES;
00773 if(rtvlabel[type] == 0)
00774 rtvlabel[type] = (int)newlabel();
00775 ep->typelabel = rtvlabel[type];
00776
00777 if(type == TYCHAR)
00778 {
00779 if(chslot < 0)
00780 {
00781 chslot = nextarg(TYADDR);
00782 chlgslot = nextarg(TYLENG);
00783 }
00784 np->vstg = STGARG;
00785
00786
00787
00788
00789
00790 if(procleng < 0) {
00791 np->vleng = (expptr) mkarg(TYLENG, chlgslot);
00792 np->vleng->addrblock.uname_tag = UNAM_IDENT;
00793 strcpy (np -> vleng -> addrblock.user.ident,
00794 new_func_length());
00795 }
00796 if (!xretslot[TYCHAR]) {
00797 xretslot[TYCHAR] = rs =
00798 autovar(0, type, ISCONST(np->vleng)
00799 ? np->vleng : ICON(0), "");
00800 strcpy(rs->user.ident, "ret_val");
00801 }
00802 }
00803
00804
00805
00806
00807 else if( ISCOMPLEX(type) ) {
00808 if (!xretslot[type])
00809 xretslot[type] =
00810 autovar(0, type, EXNULL, " ret_val");
00811
00812 np->vstg = STGARG;
00813 if(cxslot < 0)
00814 cxslot = nextarg(TYADDR);
00815 }
00816 else if (type != TYSUBR) {
00817 if (type == TYUNKNOWN) {
00818 dclerr("untyped function", np);
00819 proctype = type = np->vtype =
00820 dflttype[letter(np->fvarname[0])];
00821 }
00822 if (!xretslot[type])
00823 xretslot[type] = retslot =
00824 autovar(1, type, EXNULL, " ret_val");
00825
00826 np->vstg = STGAUTO;
00827 }
00828
00829 for(p = ep->arglist ; p ; p = p->nextp)
00830 if(! (( q = (Namep) (p->datap) )->vknownarg) ) {
00831 q->vknownarg = 1;
00832 q->vardesc.varno = nextarg(TYADDR);
00833 allargs = mkchain((char *)q, allargs);
00834 q->argno = nallargs++;
00835 }
00836 else if (nentry == 1)
00837 duparg(q);
00838 else for(p1 = ep->arglist ; p1 != p; p1 = p1->nextp)
00839 if ((Namep)p1->datap == q)
00840 duparg(q);
00841
00842 k = 0;
00843 for(p = ep->arglist ; p ; p = p->nextp) {
00844 if(! (( q = (Namep) (p->datap) )->vdcldone) )
00845 {
00846 impldcl(q);
00847 q->vdcldone = YES;
00848 if(q->vtype == TYCHAR)
00849 {
00850
00851
00852
00853
00854 ++nallchargs;
00855 if (q->vclass == CLPROC)
00856 nallchargs--;
00857 else if (q->vleng == NULL) {
00858
00859 q->vleng = (expptr)
00860 mkarg(TYLENG, nextarg(TYLENG) );
00861 unamstring((Addrp)q->vleng,
00862 new_arg_length(q));
00863 }
00864 }
00865 }
00866 if (q->vdimfinish)
00867 dim_finish(q);
00868 if (q->vtype == TYCHAR && q->vclass != CLPROC)
00869 k++;
00870 }
00871
00872 if (entryname->extype != type)
00873 changedtype(np);
00874
00875
00876
00877 it = infertypes;
00878 if (entryname->exproto)
00879 infertypes = 1;
00880 save_argtypes(ep->arglist, &entryname->arginfo, &np->arginfo,
00881 0, np->fvarname, STGEXT, k, np->vtype, 2);
00882 infertypes = it;
00883 }
00884
00885
00886
00887 LOCAL int
00888 #ifdef KR_headers
00889 nextarg(type)
00890 int type;
00891 #else
00892 nextarg(int type)
00893 #endif
00894 {
00895 type = type;
00896 return(lastargslot++);
00897 }
00898
00899 LOCAL void
00900 #ifdef KR_headers
00901 dim_check(q)
00902 Namep q;
00903 #else
00904 dim_check(Namep q)
00905 #endif
00906 {
00907 register struct Dimblock *vdim = q->vdim;
00908 register expptr nelt;
00909
00910 if(!(nelt = vdim->nelt) || !ISCONST(nelt))
00911 dclerr("adjustable dimension on non-argument", q);
00912 else if (!ONEOF(nelt->headblock.vtype, MSKINT|MSKREAL))
00913 bad_dimtype(q);
00914 else if (ISINT(nelt->headblock.vtype)
00915 && nelt->constblock.Const.ci <= 0
00916 || nelt->constblock.Const.cd[0] <= 0)
00917 dclerr("nonpositive dimension", q);
00918 }
00919
00920 LOCAL void
00921 dobss(Void)
00922 {
00923 register struct Hashentry *p;
00924 register Namep q;
00925 int qstg, qclass, qtype;
00926 Extsym *e;
00927
00928 for(p = hashtab ; p<lasthash ; ++p)
00929 if(q = p->varp)
00930 {
00931 qstg = q->vstg;
00932 qtype = q->vtype;
00933 qclass = q->vclass;
00934
00935 if( (qclass==CLUNKNOWN && qstg!=STGARG) ||
00936 (qclass==CLVAR && qstg==STGUNKNOWN) ) {
00937 if (!(q->vis_assigned | q->vimpldovar))
00938 warn1("local variable %s never used",
00939 q->fvarname);
00940 }
00941 else if(qclass==CLVAR && qstg==STGBSS)
00942 { ; }
00943
00944
00945
00946 else if(qclass==CLPROC && q->vprocclass==PEXTERNAL
00947 && qstg!=STGARG) {
00948 e = mkext(q->fvarname,addunder(q->cvarname));
00949 e->extstg = STGEXT;
00950 q->vardesc.varno = e - extsymtab;
00951 if (e->extype != qtype)
00952 changedtype(q);
00953 }
00954 if(qclass==CLVAR) {
00955 if (qstg != STGARG && q->vdim)
00956 dim_check(q);
00957 }
00958 }
00959
00960 }
00961
00962
00963 void
00964 donmlist(Void)
00965 {
00966 register struct Hashentry *p;
00967 register Namep q;
00968
00969 for(p=hashtab; p<lasthash; ++p)
00970 if( (q = p->varp) && q->vclass==CLNAMELIST)
00971 namelist(q);
00972 }
00973
00974
00975
00976
00977 ftnint
00978 #ifdef KR_headers
00979 iarrlen(q)
00980 register Namep q;
00981 #else
00982 iarrlen(register Namep q)
00983 #endif
00984 {
00985 ftnint leng;
00986
00987 leng = typesize[q->vtype];
00988 if(leng <= 0)
00989 return(-1);
00990 if(q->vdim)
00991 if( ISICON(q->vdim->nelt) )
00992 leng *= q->vdim->nelt->constblock.Const.ci;
00993 else return(-1);
00994 if(q->vleng)
00995 if( ISICON(q->vleng) )
00996 leng *= q->vleng->constblock.Const.ci;
00997 else return(-1);
00998 return(leng);
00999 }
01000
01001 void
01002 #ifdef KR_headers
01003 namelist(np)
01004 Namep np;
01005 #else
01006 namelist(Namep np)
01007 #endif
01008 {
01009 register chainp q;
01010 register Namep v;
01011 int y;
01012
01013 if (!np->visused)
01014 return;
01015 y = 0;
01016
01017 for(q = np->varxptr.namelist ; q ; q = q->nextp)
01018 {
01019 vardcl( v = (Namep) (q->datap) );
01020 if( !ONEOF(v->vstg, MSKSTATIC) )
01021 dclerr("may not appear in namelist", v);
01022 else {
01023 v->vnamelist = 1;
01024 v->visused = 1;
01025 v->vsave = 1;
01026 y = 1;
01027 }
01028 np->visused = y;
01029 }
01030 }
01031
01032
01033
01034
01035 LOCAL void
01036 docommon(Void)
01037 {
01038 register Extsym *extptr;
01039 register chainp q, q1;
01040 struct Dimblock *t;
01041 expptr neltp;
01042 register Namep comvar;
01043 ftnint size;
01044 int i, k, pref, type;
01045 extern int type_pref[];
01046
01047 for(extptr = extsymtab ; extptr<nextext ; ++extptr)
01048 if (extptr->extstg == STGCOMMON && (q = extptr->extp)) {
01049
01050
01051
01052 q = extptr->extp = revchain(q);
01053 pref = 1;
01054 for(k = TYCHAR; q ; q = q->nextp)
01055 {
01056 comvar = (Namep) (q->datap);
01057
01058 if(comvar->vdcldone == NO)
01059 vardcl(comvar);
01060 type = comvar->vtype;
01061 if (pref < type_pref[type])
01062 pref = type_pref[k = type];
01063 if(extptr->extleng % typealign[type] != 0) {
01064 dclerr("common alignment", comvar);
01065 --nerr;
01066 #if 0
01067 extptr->extleng = roundup(extptr->extleng, typealign[type]);
01068 #endif
01069 }
01070
01071
01072
01073 comvar->voffset = extptr->extleng;
01074 comvar->vardesc.varno = extptr - extsymtab;
01075 if(type == TYCHAR)
01076 if (comvar->vleng)
01077 size = comvar->vleng->constblock.Const.ci;
01078 else {
01079 dclerr("character*(*) in common", comvar);
01080 size = 1;
01081 }
01082 else
01083 size = typesize[type];
01084 if(t = comvar->vdim)
01085 if( (neltp = t->nelt) && ISCONST(neltp) )
01086 size *= neltp->constblock.Const.ci;
01087 else
01088 dclerr("adjustable array in common", comvar);
01089
01090
01091
01092 extptr->extleng += size;
01093 }
01094
01095 extptr->extype = k;
01096
01097
01098
01099 q1 = extptr->extp;
01100 for (q = extptr->allextp, i = 0; q; i++, q = q->nextp)
01101 if (struct_eq((chainp)q->datap, q1))
01102 break;
01103 if (q)
01104 extptr->curno = extptr->maxno - i;
01105 else {
01106 extptr->curno = ++extptr->maxno;
01107 extptr->allextp = mkchain((char *)extptr->extp,
01108 extptr->allextp);
01109 }
01110 }
01111
01112
01113
01114
01115 }
01116
01117
01118
01119
01120
01121 void
01122 #ifdef KR_headers
01123 copy_data(list)
01124 chainp list;
01125 #else
01126 copy_data(chainp list)
01127 #endif
01128 {
01129 for (; list; list = list -> nextp) {
01130 Namep namep = ALLOC (Nameblock);
01131 int size, nd, i;
01132 struct Dimblock *dp;
01133
01134 cpn(sizeof(struct Nameblock), list->datap, (char *)namep);
01135 namep->fvarname = strcpy(gmem(strlen(namep->fvarname)+1,0),
01136 namep->fvarname);
01137 namep->cvarname = strcmp(namep->fvarname, namep->cvarname)
01138 ? strcpy(gmem(strlen(namep->cvarname)+1,0), namep->cvarname)
01139 : namep->fvarname;
01140 if (namep -> vleng)
01141 namep -> vleng = (expptr) cpexpr (namep -> vleng);
01142 if (namep -> vdim) {
01143 nd = namep -> vdim -> ndim;
01144 size = sizeof(int) + (3 + 2 * nd) * sizeof (expptr);
01145 dp = (struct Dimblock *) ckalloc (size);
01146 cpn(size, (char *)namep->vdim, (char *)dp);
01147 namep -> vdim = dp;
01148 dp->nelt = (expptr)cpexpr(dp->nelt);
01149 for (i = 0; i < nd; i++) {
01150 dp -> dims[i].dimsize = (expptr) cpexpr (dp -> dims[i].dimsize);
01151 }
01152 }
01153 list -> datap = (char *) namep;
01154 }
01155 }
01156
01157
01158
01159 LOCAL void
01160 docomleng(Void)
01161 {
01162 register Extsym *p;
01163
01164 for(p = extsymtab ; p < nextext ; ++p)
01165 if(p->extstg == STGCOMMON)
01166 {
01167 if(p->maxleng!=0 && p->extleng!=0 && p->maxleng!=p->extleng
01168 && strcmp(Blank, p->cextname) )
01169 warn1("incompatible lengths for common block %.60s",
01170 p->fextname);
01171 if(p->maxleng < p->extleng)
01172 p->maxleng = p->extleng;
01173 p->extleng = 0;
01174 }
01175 }
01176
01177
01178
01179
01180 void
01181 #ifdef KR_headers
01182 frtemp(p)
01183 Addrp p;
01184 #else
01185 frtemp(Addrp p)
01186 #endif
01187 {
01188
01189 holdtemps = mkchain((char *)p, holdtemps);
01190 }
01191
01192 void
01193 freetemps(Void)
01194 {
01195 register chainp p, p1;
01196 register Addrp q;
01197 register int t;
01198
01199 p1 = holdtemps;
01200 while(p = p1) {
01201 q = (Addrp)p->datap;
01202 t = q->vtype;
01203 if (t == TYCHAR && q->varleng != 0) {
01204
01205 frexpr(q->vleng);
01206 q->vleng = ICON(q->varleng);
01207 }
01208 p1 = p->nextp;
01209 p->nextp = templist[t];
01210 templist[t] = p;
01211 }
01212 holdtemps = 0;
01213 }
01214
01215
01216
01217 Addrp
01218 #ifdef KR_headers
01219 autovar(nelt0, t, lengp, name)
01220 register int nelt0;
01221 register int t;
01222 expptr lengp;
01223 char *name;
01224 #else
01225 autovar(register int nelt0, register int t, expptr lengp, char *name)
01226 #endif
01227 {
01228 ftnint leng;
01229 register Addrp q;
01230 register int nelt = nelt0 > 0 ? nelt0 : 1;
01231 extern char *av_pfix[];
01232
01233 if(t == TYCHAR)
01234 if( ISICON(lengp) )
01235 leng = lengp->constblock.Const.ci;
01236 else {
01237 Fatal("automatic variable of nonconstant length");
01238 }
01239 else
01240 leng = typesize[t];
01241
01242 q = ALLOC(Addrblock);
01243 q->tag = TADDR;
01244 q->vtype = t;
01245 if(t == TYCHAR)
01246 {
01247 q->vleng = ICON(leng);
01248 q->varleng = leng;
01249 }
01250 q->vstg = STGAUTO;
01251 q->ntempelt = nelt;
01252 q->isarray = (nelt > 1);
01253 q->memoffset = ICON(0);
01254
01255
01256 if (*name == ' ')
01257 unamstring(q, name);
01258 else {
01259 q->uname_tag = UNAM_IDENT;
01260 temp_name(av_pfix[t], ++autonum[t], q->user.ident);
01261 }
01262 if (nelt0 > 0)
01263 declare_new_addr (q);
01264 return(q);
01265 }
01266
01267
01268
01269
01270
01271 Addrp
01272 #ifdef KR_headers
01273 mktmpn(nelt, type, lengp)
01274 int nelt;
01275 register int type;
01276 expptr lengp;
01277 #else
01278 mktmpn(int nelt, register int type, expptr lengp)
01279 #endif
01280 {
01281 ftnint leng;
01282 chainp p, oldp;
01283 register Addrp q;
01284 extern int krparens;
01285
01286 if(type==TYUNKNOWN || type==TYERROR)
01287 badtype("mktmpn", type);
01288
01289 if(type==TYCHAR)
01290 if(lengp && ISICON(lengp) )
01291 leng = lengp->constblock.Const.ci;
01292 else {
01293 err("adjustable length");
01294 return( (Addrp) errnode() );
01295 }
01296 else if (type > TYCHAR || type < TYADDR) {
01297 erri("mktmpn: unexpected type %d", type);
01298 exit(1);
01299 }
01300
01301
01302
01303
01304 if (krparens == 2 && ONEOF(type,M(TYREAL)|M(TYCOMPLEX)))
01305 type++;
01306 for(oldp=CHNULL, p=templist[type]; p ; oldp=p, p=p->nextp)
01307 {
01308 q = (Addrp) (p->datap);
01309 if(q->ntempelt==nelt &&
01310 (type!=TYCHAR || q->vleng->constblock.Const.ci==leng) )
01311 {
01312 if(oldp)
01313 oldp->nextp = p->nextp;
01314 else
01315 templist[type] = p->nextp;
01316 free( (charptr) p);
01317 return(q);
01318 }
01319 }
01320 q = autovar(nelt, type, lengp, "");
01321 return(q);
01322 }
01323
01324
01325
01326
01327
01328
01329
01330 Addrp
01331 #ifdef KR_headers
01332 mktmp(type, lengp)
01333 int type;
01334 expptr lengp;
01335 #else
01336 mktmp(int type, expptr lengp)
01337 #endif
01338 {
01339 Addrp rv;
01340
01341
01342 rv = mktmpn(1,type,lengp);
01343 frtemp((Addrp)cpexpr((expptr)rv));
01344 return rv;
01345 }
01346
01347
01348 Addrp
01349 #ifdef KR_headers
01350 mktmp0(type, lengp)
01351 int type;
01352 expptr lengp;
01353 #else
01354 mktmp0(int type, expptr lengp)
01355 #endif
01356 {
01357 Addrp rv;
01358
01359
01360 rv = mktmpn(1,type,lengp);
01361 rv->istemp = YES;
01362 return rv;
01363 }
01364
01365
01366
01367
01368
01369
01370 Extsym *
01371 #ifdef KR_headers
01372 comblock(s)
01373 register char *s;
01374 #else
01375 comblock(register char *s)
01376 #endif
01377 {
01378 Extsym *p;
01379 register char *t;
01380 register int c, i;
01381 char cbuf[256], *s0;
01382
01383
01384
01385 if(*s == 0)
01386 p = mkext1(s0 = Blank, Blank);
01387 else {
01388 s0 = s;
01389 t = cbuf;
01390 for(i = 0; c = *t = *s++; t++)
01391 if (c == '_')
01392 i = 1;
01393 if (i)
01394 *t++ = '_';
01395 t[0] = '_';
01396 t[1] = 0;
01397 p = mkext1(s0,cbuf);
01398 }
01399 if(p->extstg == STGUNKNOWN)
01400 p->extstg = STGCOMMON;
01401 else if(p->extstg != STGCOMMON)
01402 {
01403 errstr("%.52s cannot be a common block: it is a subprogram.",
01404 s0);
01405 return(0);
01406 }
01407
01408 return( p );
01409 }
01410
01411
01412
01413
01414 void
01415 #ifdef KR_headers
01416 incomm(c, v)
01417 Extsym *c;
01418 Namep v;
01419 #else
01420 incomm(Extsym *c, Namep v)
01421 #endif
01422 {
01423 if (!c)
01424 return;
01425 if(v->vstg != STGUNKNOWN && !v->vimplstg)
01426 dclerr(v->vstg == STGARG
01427 ? "dummy arguments cannot be in common"
01428 : "incompatible common declaration", v);
01429 else
01430 {
01431 v->vstg = STGCOMMON;
01432 c->extp = mkchain((char *)v, c->extp);
01433 }
01434 }
01435
01436
01437
01438
01439
01440
01441
01442
01443
01444 void
01445 #ifdef KR_headers
01446 settype(v, type, length)
01447 register Namep v;
01448 register int type;
01449 register ftnint length;
01450 #else
01451 settype(register Namep v, register int type, register ftnint length)
01452 #endif
01453 {
01454 int type1;
01455
01456 if(type == TYUNKNOWN)
01457 return;
01458
01459 if(type==TYSUBR && v->vtype!=TYUNKNOWN && v->vstg==STGARG)
01460 {
01461 v->vtype = TYSUBR;
01462 frexpr(v->vleng);
01463 v->vleng = 0;
01464 v->vimpltype = 0;
01465 }
01466 else if(type < 0)
01467 {
01468 if(v->vstg == STGUNKNOWN)
01469 v->vstg = - type;
01470 else if(v->vstg != -type)
01471 dclerr("incompatible storage declarations", v);
01472 }
01473 else if(v->vtype == TYUNKNOWN
01474 || v->vtype != type
01475 && (v->vimpltype || v->vinftype || v->vinfproc))
01476 {
01477 if( (v->vtype = lengtype(type, length))==TYCHAR )
01478 if (length>=0)
01479 v->vleng = ICON(length);
01480 else if (parstate >= INDATA)
01481 v->vleng = ICON(1);
01482 v->vimpltype = 0;
01483 v->vinftype = 0;
01484 v->vinfproc = 0;
01485
01486 if (v->vclass == CLPROC) {
01487 if (v->vstg == STGEXT
01488 && (type1 = extsymtab[v->vardesc.varno].extype)
01489 && type1 != v->vtype)
01490 changedtype(v);
01491 else if (v->vprocclass == PTHISPROC
01492 && (parstate >= INDATA
01493 || procclass == CLMAIN)
01494 && !xretslot[type]) {
01495 xretslot[type] = autovar(ONEOF(type,
01496 MSKCOMPLEX|MSKCHAR) ? 0 : 1, type,
01497 v->vleng, " ret_val");
01498 if (procclass == CLMAIN)
01499 errstr(
01500 "illegal use of %.60s (main program name)",
01501 v->fvarname);
01502
01503
01504
01505 }
01506 }
01507 }
01508 else if(v->vtype!=type) {
01509 incompat:
01510 dclerr("incompatible type declarations", v);
01511 }
01512 else if (type==TYCHAR)
01513 if (v->vleng && v->vleng->constblock.Const.ci != length)
01514 goto incompat;
01515 else if (parstate >= INDATA)
01516 v->vleng = ICON(1);
01517 }
01518
01519
01520
01521
01522
01523
01524
01525
01526 int
01527 #ifdef KR_headers
01528 lengtype(type, len)
01529 register int type;
01530 ftnint len;
01531 #else
01532 lengtype(register int type, ftnint len)
01533 #endif
01534 {
01535 register int length = (int)len;
01536 switch(type)
01537 {
01538 case TYREAL:
01539 if(length == typesize[TYDREAL])
01540 return(TYDREAL);
01541 if(length == typesize[TYREAL])
01542 goto ret;
01543 break;
01544
01545 case TYCOMPLEX:
01546 if(length == typesize[TYDCOMPLEX])
01547 return(TYDCOMPLEX);
01548 if(length == typesize[TYCOMPLEX])
01549 goto ret;
01550 break;
01551
01552 case TYINT1:
01553 case TYSHORT:
01554 case TYDREAL:
01555 case TYDCOMPLEX:
01556 case TYCHAR:
01557 case TYLOGICAL1:
01558 case TYLOGICAL2:
01559 case TYUNKNOWN:
01560 case TYSUBR:
01561 case TYERROR:
01562 #ifdef TYQUAD
01563 case TYQUAD:
01564 #endif
01565 goto ret;
01566
01567 case TYLOGICAL:
01568 switch(length) {
01569 case 0: return tylog;
01570 case 1: return TYLOGICAL1;
01571 case 2: return TYLOGICAL2;
01572 case 4: goto ret;
01573 }
01574 #if 0
01575 if(length == typesize[TYLOGICAL])
01576 goto ret;
01577 #endif
01578 break;
01579
01580 case TYLONG:
01581 if(length == 0)
01582 return(tyint);
01583 if (length == 1)
01584 return TYINT1;
01585 if(length == typesize[TYSHORT])
01586 return(TYSHORT);
01587 #ifdef TYQUAD
01588 if(length == typesize[TYQUAD] && use_tyquad)
01589 return(TYQUAD);
01590 #endif
01591 if(length == typesize[TYLONG])
01592 goto ret;
01593 break;
01594 default:
01595 badtype("lengtype", type);
01596 }
01597
01598 if(len != 0)
01599 err("incompatible type-length combination");
01600
01601 ret:
01602 return(type);
01603 }
01604
01605
01606
01607
01608
01609
01610
01611 void
01612 #ifdef KR_headers
01613 setintr(v)
01614 register Namep v;
01615 #else
01616 setintr(register Namep v)
01617 #endif
01618 {
01619 int k;
01620
01621 if(k = intrfunct(v->fvarname)) {
01622 if ((*(struct Intrpacked *)&k).f4)
01623 if (noextflag)
01624 goto unknown;
01625 else
01626 dcomplex_seen++;
01627 v->vardesc.varno = k;
01628 }
01629 else {
01630 unknown:
01631 dclerr("unknown intrinsic function", v);
01632 return;
01633 }
01634 if(v->vstg == STGUNKNOWN)
01635 v->vstg = STGINTR;
01636 else if(v->vstg!=STGINTR)
01637 dclerr("incompatible use of intrinsic function", v);
01638 if(v->vclass==CLUNKNOWN)
01639 v->vclass = CLPROC;
01640 if(v->vprocclass == PUNKNOWN)
01641 v->vprocclass = PINTRINSIC;
01642 else if(v->vprocclass != PINTRINSIC)
01643 dclerr("invalid intrinsic declaration", v);
01644 }
01645
01646
01647
01648
01649
01650
01651 void
01652 #ifdef KR_headers
01653 setext(v)
01654 register Namep v;
01655 #else
01656 setext(register Namep v)
01657 #endif
01658 {
01659 if(v->vclass == CLUNKNOWN)
01660 v->vclass = CLPROC;
01661 else if(v->vclass != CLPROC)
01662 dclerr("invalid external declaration", v);
01663
01664 if(v->vprocclass == PUNKNOWN)
01665 v->vprocclass = PEXTERNAL;
01666 else if(v->vprocclass != PEXTERNAL)
01667 dclerr("invalid external declaration", v);
01668 }
01669
01670
01671
01672
01673
01674
01675 void
01676 #ifdef KR_headers
01677 setbound(v, nd, dims)
01678 register Namep v;
01679 int nd;
01680 struct Dims *dims;
01681 #else
01682 setbound(register Namep v, int nd, struct Dims *dims)
01683 #endif
01684 {
01685 register expptr q, t;
01686 register struct Dimblock *p;
01687 int i;
01688 extern chainp new_vars;
01689 char buf[256];
01690
01691 if(v->vclass == CLUNKNOWN)
01692 v->vclass = CLVAR;
01693 else if(v->vclass != CLVAR)
01694 {
01695 dclerr("only variables may be arrays", v);
01696 return;
01697 }
01698
01699 v->vdim = p = (struct Dimblock *)
01700 ckalloc( sizeof(int) + (3+2*nd)*sizeof(expptr) );
01701 p->ndim = nd--;
01702 p->nelt = ICON(1);
01703 doin_setbound = 1;
01704
01705 if (noextflag)
01706 for(i = 0; i <= nd; i++)
01707 if (((q = dims[i].lb) && !ISINT(q->headblock.vtype))
01708 || ((q = dims[i].ub) && !ISINT(q->headblock.vtype))) {
01709 sprintf(buf, "dimension %d of %s is not an integer.",
01710 i+1, v->fvarname);
01711 errext(buf);
01712 break;
01713 }
01714
01715 for(i = 0; i <= nd; i++) {
01716 if (((q = dims[i].lb) && !ISINT(q->headblock.vtype)))
01717 dims[i].lb = mkconv(TYINT, q);
01718 if (((q = dims[i].ub) && !ISINT(q->headblock.vtype)))
01719 dims[i].ub = mkconv(TYINT, q);
01720 }
01721
01722 for(i = 0; i <= nd; ++i)
01723 {
01724 if( (q = dims[i].ub) == NULL)
01725 {
01726 if(i == nd)
01727 {
01728 frexpr(p->nelt);
01729 p->nelt = NULL;
01730 }
01731 else
01732 err("only last bound may be asterisk");
01733 p->dims[i].dimsize = ICON(1);
01734 p->dims[i].dimexpr = NULL;
01735 }
01736 else
01737 {
01738
01739 if(dims[i].lb)
01740 {
01741 q = mkexpr(OPMINUS, q, cpexpr(dims[i].lb));
01742 q = mkexpr(OPPLUS, q, ICON(1) );
01743 }
01744 if( ISCONST(q) )
01745 {
01746 p->dims[i].dimsize = q;
01747 p->dims[i].dimexpr = (expptr) PNULL;
01748 }
01749 else {
01750 sprintf(buf, " %s_dim%d", v->fvarname, i+1);
01751 p->dims[i].dimsize = (expptr)
01752 autovar(1, tyint, EXNULL, buf);
01753 p->dims[i].dimexpr = q;
01754 if (i == nd)
01755 v->vlastdim = new_vars;
01756 v->vdimfinish = 1;
01757 }
01758 if(p->nelt)
01759 p->nelt = mkexpr(OPSTAR, p->nelt,
01760 cpexpr(p->dims[i].dimsize) );
01761 }
01762 }
01763
01764 q = dims[nd].lb;
01765 if(q == NULL)
01766 q = ICON(1);
01767
01768 for(i = nd-1 ; i>=0 ; --i)
01769 {
01770 t = dims[i].lb;
01771 if(t == NULL)
01772 t = ICON(1);
01773 if(p->dims[i].dimsize)
01774 q = mkexpr(OPPLUS, t,
01775 mkexpr(OPSTAR, cpexpr(p->dims[i].dimsize), q));
01776 }
01777
01778 if( ISCONST(q) )
01779 {
01780 p->baseoffset = q;
01781 p->basexpr = NULL;
01782 }
01783 else
01784 {
01785 sprintf(buf, " %s_offset", v->fvarname);
01786 p->baseoffset = (expptr) autovar(1, tyint, EXNULL, buf);
01787 p->basexpr = q;
01788 v->vdimfinish = 1;
01789 }
01790 doin_setbound = 0;
01791 }
01792
01793
01794 void
01795 #ifdef KR_headers
01796 wr_abbrevs(outfile, function_head, vars)
01797 FILE *outfile;
01798 int function_head;
01799 chainp vars;
01800 #else
01801 wr_abbrevs(FILE *outfile, int function_head, chainp vars)
01802 #endif
01803 {
01804 for (; vars; vars = vars -> nextp) {
01805 Namep name = (Namep) vars -> datap;
01806 if (!name->visused)
01807 continue;
01808
01809 if (function_head)
01810 nice_printf (outfile, "#define ");
01811 else
01812 nice_printf (outfile, "#undef ");
01813 out_name (outfile, name);
01814
01815 if (function_head) {
01816 Extsym *comm = &extsymtab[name -> vardesc.varno];
01817
01818 nice_printf (outfile, " (");
01819 extern_out (outfile, comm);
01820 nice_printf (outfile, "%d.", comm->curno);
01821 nice_printf (outfile, "%s)", name->cvarname);
01822 }
01823 nice_printf (outfile, "\n");
01824 }
01825 }