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 "output.h"
00026 #include "iob.h"
00027
00028
00029 char *fl_fmt_string;
00030 char *db_fmt_string;
00031 char *cm_fmt_string;
00032 char *dcm_fmt_string;
00033
00034 chainp new_vars = CHNULL;
00035
00036
00037
00038 chainp used_builtins = CHNULL;
00039
00040
00041 chainp assigned_fmts = CHNULL;
00042 chainp allargs;
00043 chainp earlylabs;
00044 char main_alias[52];
00045 int tab_size = 4;
00046
00047
00048 FILEP infile;
00049 FILEP diagfile;
00050
00051 FILEP c_file;
00052 FILEP pass1_file;
00053 FILEP initfile;
00054 FILEP blkdfile;
00055
00056
00057 char *token;
00058 int maxtoklen, toklen;
00059 long err_lineno;
00060 long lineno;
00061
00062 char *infname;
00063 int needkwd;
00064 struct Labelblock *thislabel = NULL;
00065 int nerr;
00066 int nwarn;
00067
00068 flag saveall;
00069 flag substars;
00070 int parstate = OUTSIDE;
00071 flag headerdone = NO;
00072 int blklevel;
00073 int doin_setbound;
00074 int impltype[26];
00075 ftnint implleng[26];
00076 int implstg[26];
00077
00078 int tyint = TYLONG ;
00079 int tylogical = TYLONG;
00080 int tylog = TYLOGICAL;
00081 int typesize[NTYPES] = {
00082 1, SZADDR, 1, SZSHORT, SZLONG,
00083 #ifdef TYQUAD
00084 2*SZLONG,
00085 #endif
00086 SZLONG, 2*SZLONG,
00087 2*SZLONG, 4*SZLONG, 1, SZSHORT, SZLONG, 1, 1, 0,
00088 4*SZLONG + SZADDR,
00089 4*SZLONG + 2*SZADDR,
00090 4*SZLONG + 5*SZADDR,
00091 2*SZLONG + SZADDR,
00092 2*SZLONG,
00093 11*SZLONG + 15*SZADDR
00094 };
00095
00096 int typealign[NTYPES] = {
00097 1, ALIADDR, 1, ALISHORT, ALILONG,
00098 #ifdef TYQUAD
00099 ALIDOUBLE,
00100 #endif
00101 ALILONG, ALIDOUBLE,
00102 ALILONG, ALIDOUBLE, 1, ALISHORT, ALILONG, 1, 1, 1,
00103 ALILONG, ALILONG, ALILONG, ALILONG, ALILONG, ALILONG};
00104
00105 int type_choice[4] = { TYDREAL, TYSHORT, TYLONG, TYSHORT };
00106
00107 char *typename[] = {
00108 "<<unknown>>",
00109 "address",
00110 "integer1",
00111 "shortint",
00112 "integer",
00113 #ifdef TYQUAD
00114 "longint",
00115 #endif
00116 "real",
00117 "doublereal",
00118 "complex",
00119 "doublecomplex",
00120 "logical1",
00121 "shortlogical",
00122 "logical",
00123 "char"
00124 };
00125
00126 int type_pref[NTYPES] = { 0, 0, 3, 5, 7,
00127 #ifdef TYQUAD
00128 10,
00129 #endif
00130 8, 11, 9, 12, 1, 4, 6, 2 };
00131
00132 char *protorettypes[] = {
00133 "?", "??", "integer1", "shortint", "integer",
00134 #ifdef TYQUAD
00135 "longint",
00136 #endif
00137 "real", "doublereal",
00138 "C_f", "Z_f", "logical1", "shortlogical", "logical", "H_f", "int"
00139 };
00140
00141 char *casttypes[TYSUBR+1] = {
00142 "U_fp", "??bug??", "I1_fp",
00143 "J_fp", "I_fp",
00144 #ifdef TYQUAD
00145 "Q_fp",
00146 #endif
00147 "R_fp", "D_fp", "C_fp", "Z_fp",
00148 "L1_fp", "L2_fp", "L_fp", "H_fp", "S_fp"
00149 };
00150 char *usedcasts[TYSUBR+1];
00151
00152 char *dfltarg[] = {
00153 0, 0, "(integer1 *)0",
00154 "(shortint *)0", "(integer *)0",
00155 #ifdef TYQUAD
00156 "(longint *)0",
00157 #endif
00158 "(real *)0",
00159 "(doublereal *)0", "(complex *)0", "(doublecomplex *)0",
00160 "(logical1 *)0","(shortlogical *)0", "(logical *)0", "(char *)0"
00161 };
00162
00163 static char *dflt0proc[] = {
00164 0, 0, "(integer1 (*)())0",
00165 "(shortint (*)())0", "(integer (*)())0",
00166 #ifdef TYQUAD
00167 "(longint (*)())0",
00168 #endif
00169 "(real (*)())0",
00170 "(doublereal (*)())0", "(complex (*)())0", "(doublecomplex (*)())0",
00171 "(logical1 (*)())0", "(shortlogical (*)())0",
00172 "(logical (*)())0", "(char (*)())0", "(int (*)())0"
00173 };
00174
00175 char *dflt1proc[] = { "(U_fp)0", "(??bug??)0", "(I1_fp)0",
00176 "(J_fp)0", "(I_fp)0",
00177 #ifdef TYQUAD
00178 "(Q_fp)0",
00179 #endif
00180 "(R_fp)0", "(D_fp)0", "(C_fp)0", "(Z_fp)0",
00181 "(L1_fp)0","(L2_fp)0",
00182 "(L_fp)0", "(H_fp)0", "(S_fp)0"
00183 };
00184
00185 char **dfltproc = dflt0proc;
00186
00187 static char Bug[] = "bug";
00188
00189 char *ftn_types[] = { "external", "??", "integer*1",
00190 "integer*2", "integer",
00191 #ifdef TYQUAD
00192 "integer*8",
00193 #endif
00194 "real",
00195 "double precision", "complex", "double complex",
00196 "logical*1", "logical*2",
00197 "logical", "character", "subroutine",
00198 Bug,Bug,Bug,Bug,Bug,Bug,Bug,Bug,Bug, "ftnlen"
00199 };
00200
00201 int init_ac[TYSUBR+1] = { 0,0,0,0,0,0,0,
00202 #ifdef TYQUAD
00203 0,
00204 #endif
00205 1, 1, 0, 0, 0, 2};
00206
00207 int proctype = TYUNKNOWN;
00208 char *procname;
00209 int rtvlabel[NTYPES0];
00210 Addrp retslot;
00211
00212
00213 Addrp xretslot[NTYPES0];
00214 int cxslot = -1;
00215 int chslot = -1;
00216 int chlgslot = -1;
00217 int procclass = CLUNKNOWN;
00218 int nentry;
00219 int nallargs;
00220 int nallchargs;
00221 flag multitype;
00222 ftnint procleng;
00223 long lastiolabno;
00224 long lastlabno;
00225 int lastvarno;
00226 int lastargslot;
00227 int autonum[TYVOID];
00228 char *av_pfix[TYVOID] = {"??TYUNKNOWN??", "a","i1","s","i",
00229 #ifdef TYQUAD
00230 "i8",
00231 #endif
00232 "r","d","q","z","L1","L2","L","ch",
00233 "??TYSUBR??", "??TYERROR??","ci", "ici",
00234 "o", "cl", "al", "ioin" };
00235
00236 extern int maxctl;
00237 struct Ctlframe *ctls;
00238 struct Ctlframe *ctlstack;
00239 struct Ctlframe *lastctl;
00240
00241 Namep regnamep[MAXREGVAR];
00242 int highregvar;
00243 int nregvar;
00244
00245 extern int maxext;
00246 Extsym *extsymtab;
00247 Extsym *nextext;
00248 Extsym *lastext;
00249
00250 extern int maxequiv;
00251 struct Equivblock *eqvclass;
00252
00253 extern int maxhash;
00254 struct Hashentry *hashtab;
00255 struct Hashentry *lasthash;
00256
00257 extern int maxstno;
00258 struct Labelblock *labeltab;
00259 struct Labelblock *labtabend;
00260 struct Labelblock *highlabtab;
00261
00262 int maxdim = MAXDIM;
00263 struct Rplblock *rpllist = NULL;
00264 struct Chain *curdtp = NULL;
00265 flag toomanyinit;
00266 ftnint curdtelt;
00267 chainp templist[TYVOID];
00268 chainp holdtemps;
00269 int dorange = 0;
00270 struct Entrypoint *entries = NULL;
00271
00272 chainp chains = NULL;
00273
00274 flag inioctl;
00275 int iostmt;
00276 int nioctl;
00277 int nequiv = 0;
00278 int eqvstart = 0;
00279 int nintnames = 0;
00280 extern int maxlablist;
00281 struct Labelblock **labarray;
00282
00283 struct Literal *litpool;
00284 int nliterals;
00285
00286 char dflttype[26];
00287 char hextoi_tab[Table_size], Letters[Table_size];
00288 char *ei_first, *ei_next, *ei_last;
00289 char *wh_first, *wh_next, *wh_last;
00290
00291 #define ALLOCN(n,x) (struct x *) ckalloc((n)*sizeof(struct x))
00292
00293 void
00294 fileinit(Void)
00295 {
00296 register char *s;
00297 register int i, j;
00298
00299 lastiolabno = 100000;
00300 lastlabno = 0;
00301 lastvarno = 0;
00302 nliterals = 0;
00303 nerr = 0;
00304
00305 infile = stdin;
00306
00307 maxtoklen = 502;
00308 token = (char *)ckalloc(maxtoklen+2);
00309 memset(dflttype, tyreal, 26);
00310 memset(dflttype + 'i' - 'a', tyint, 6);
00311 memset(hextoi_tab, 16, sizeof(hextoi_tab));
00312 for(i = 0, s = "0123456789abcdef"; *s; i++, s++)
00313 hextoi(*s) = i;
00314 for(i = 10, s = "ABCDEF"; *s; i++, s++)
00315 hextoi(*s) = i;
00316 for(j = 0, s = "abcdefghijklmnopqrstuvwxyz"; i = *s++; j++)
00317 Letters[i] = Letters[i+'A'-'a'] = j;
00318
00319 ctls = ALLOCN(maxctl+1, Ctlframe);
00320 extsymtab = ALLOCN(maxext, Extsym);
00321 eqvclass = ALLOCN(maxequiv, Equivblock);
00322 hashtab = ALLOCN(maxhash, Hashentry);
00323 labeltab = ALLOCN(maxstno, Labelblock);
00324 litpool = ALLOCN(maxliterals, Literal);
00325 labarray = (struct Labelblock **)ckalloc(maxlablist*
00326 sizeof(struct Labelblock *));
00327 fmt_init();
00328 mem_init();
00329 np_init();
00330
00331 ctlstack = ctls++;
00332 lastctl = ctls + maxctl;
00333 nextext = extsymtab;
00334 lastext = extsymtab + maxext;
00335 lasthash = hashtab + maxhash;
00336 labtabend = labeltab + maxstno;
00337 highlabtab = labeltab;
00338 main_alias[0] = '\0';
00339 if (forcedouble)
00340 dfltproc[TYREAL] = dfltproc[TYDREAL];
00341
00342
00343
00344 out_init ();
00345 }
00346
00347 void
00348 hashclear(Void)
00349 {
00350 register struct Hashentry *hp;
00351 register Namep p;
00352 register struct Dimblock *q;
00353 register int i;
00354
00355 for(hp = hashtab ; hp < lasthash ; ++hp)
00356 if(p = hp->varp)
00357 {
00358 frexpr(p->vleng);
00359 if(q = p->vdim)
00360 {
00361 for(i = 0 ; i < q->ndim ; ++i)
00362 {
00363 frexpr(q->dims[i].dimsize);
00364 frexpr(q->dims[i].dimexpr);
00365 }
00366 frexpr(q->nelt);
00367 frexpr(q->baseoffset);
00368 frexpr(q->basexpr);
00369 free( (charptr) q);
00370 }
00371 if(p->vclass == CLNAMELIST)
00372 frchain( &(p->varxptr.namelist) );
00373 free( (charptr) p);
00374 hp->varp = NULL;
00375 }
00376 }
00377
00378 void
00379 procinit(Void)
00380 {
00381 register struct Labelblock *lp;
00382 struct Chain *cp;
00383 int i;
00384 struct memblock;
00385 extern struct memblock *curmemblock, *firstmemblock;
00386 extern char *mem_first, *mem_next, *mem_last, *mem0_last;
00387
00388 curmemblock = firstmemblock;
00389 mem_next = mem_first;
00390 mem_last = mem0_last;
00391 ei_next = ei_first = ei_last = 0;
00392 wh_next = wh_first = wh_last = 0;
00393 iob_list = 0;
00394 for(i = 0; i < 9; i++)
00395 io_structs[i] = 0;
00396
00397 parstate = OUTSIDE;
00398 headerdone = NO;
00399 blklevel = 1;
00400 saveall = NO;
00401 substars = NO;
00402 nwarn = 0;
00403 thislabel = NULL;
00404 needkwd = 0;
00405
00406 proctype = TYUNKNOWN;
00407 procname = "MAIN_";
00408 procclass = CLUNKNOWN;
00409 nentry = 0;
00410 nallargs = nallchargs = 0;
00411 multitype = NO;
00412 retslot = NULL;
00413 for(i = 0; i < NTYPES0; i++) {
00414 frexpr((expptr)xretslot[i]);
00415 xretslot[i] = 0;
00416 }
00417 cxslot = -1;
00418 chslot = -1;
00419 chlgslot = -1;
00420 procleng = 0;
00421 blklevel = 1;
00422 lastargslot = 0;
00423
00424 for(lp = labeltab ; lp < labtabend ; ++lp)
00425 lp->stateno = 0;
00426
00427 hashclear();
00428
00429
00430
00431
00432 frexchain(&new_vars);
00433 frexchain(&used_builtins);
00434 frchain(&assigned_fmts);
00435 frchain(&allargs);
00436 frchain(&earlylabs);
00437
00438 nintnames = 0;
00439 highlabtab = labeltab;
00440
00441 ctlstack = ctls - 1;
00442 for(i = TYADDR; i < TYVOID; i++) {
00443 for(cp = templist[i]; cp ; cp = cp->nextp)
00444 free( (charptr) (cp->datap) );
00445 frchain(templist + i);
00446 autonum[i] = 0;
00447 }
00448 holdtemps = NULL;
00449 dorange = 0;
00450 nregvar = 0;
00451 highregvar = 0;
00452 entries = NULL;
00453 rpllist = NULL;
00454 inioctl = NO;
00455 eqvstart += nequiv;
00456 nequiv = 0;
00457 dcomplex_seen = 0;
00458
00459 for(i = 0 ; i<NTYPES0 ; ++i)
00460 rtvlabel[i] = 0;
00461
00462 if(undeftype)
00463 setimpl(TYUNKNOWN, (ftnint) 0, 'a', 'z');
00464 else
00465 {
00466 setimpl(tyreal, (ftnint) 0, 'a', 'z');
00467 setimpl(tyint, (ftnint) 0, 'i', 'n');
00468 }
00469 setimpl(-STGBSS, (ftnint) 0, 'a', 'z');
00470 }
00471
00472
00473
00474 void
00475 #ifdef KR_headers
00476 setimpl(type, length, c1, c2)
00477 int type;
00478 ftnint length;
00479 int c1;
00480 int c2;
00481 #else
00482 setimpl(int type, ftnint length, int c1, int c2)
00483 #endif
00484 {
00485 int i;
00486 char buff[100];
00487
00488 if(c1==0 || c2==0)
00489 return;
00490
00491 if(c1 > c2) {
00492 sprintf(buff, "characters out of order in implicit:%c-%c", c1, c2);
00493 err(buff);
00494 }
00495 else {
00496 c1 = letter(c1);
00497 c2 = letter(c2);
00498 if(type < 0)
00499 for(i = c1 ; i<=c2 ; ++i)
00500 implstg[i] = - type;
00501 else {
00502 type = lengtype(type, length);
00503 if(type == TYCHAR) {
00504 if (length < 0) {
00505 err("length (*) in implicit");
00506 length = 1;
00507 }
00508 }
00509 else if (type != TYLONG)
00510 length = 0;
00511 for(i = c1 ; i<=c2 ; ++i) {
00512 impltype[i] = type;
00513 implleng[i] = length;
00514 }
00515 }
00516 }
00517 }