|
|
1.1 ! root 1: /* ! 2: * Copyright (c) 1983 Regents of the University of California. ! 3: * All rights reserved. The Berkeley software License Agreement ! 4: * specifies the terms and conditions for redistribution. ! 5: */ ! 6: ! 7: #ifndef lint ! 8: static char sccsid[] = "@(#)fortran.c 5.4 (Berkeley) 1/12/88"; ! 9: #endif not lint ! 10: ! 11: static char rcsid[] = "$Header: fortran.c,v 1.3 87/03/25 20:00:03 donn Exp $"; ! 12: ! 13: /* ! 14: * FORTRAN dependent symbol routines. ! 15: */ ! 16: ! 17: #include "defs.h" ! 18: #include "symbols.h" ! 19: #include "printsym.h" ! 20: #include "languages.h" ! 21: #include "fortran.h" ! 22: #include "tree.h" ! 23: #include "eval.h" ! 24: #include "operators.h" ! 25: #include "mappings.h" ! 26: #include "process.h" ! 27: #include "runtime.h" ! 28: #include "machine.h" ! 29: ! 30: #define isspecial(range) ( \ ! 31: range->symvalue.rangev.upper == 0 and range->symvalue.rangev.lower > 0 \ ! 32: ) ! 33: ! 34: #define isrange(t, name) (t->class == RANGE and istypename(t->type, name)) ! 35: ! 36: #define MAXDIM 20 ! 37: ! 38: private Language fort; ! 39: ! 40: /* ! 41: * Initialize FORTRAN language information. ! 42: */ ! 43: ! 44: public fortran_init() ! 45: { ! 46: fort = language_define("fortran", ".f"); ! 47: language_setop(fort, L_PRINTDECL, fortran_printdecl); ! 48: language_setop(fort, L_PRINTVAL, fortran_printval); ! 49: language_setop(fort, L_TYPEMATCH, fortran_typematch); ! 50: language_setop(fort, L_BUILDAREF, fortran_buildaref); ! 51: language_setop(fort, L_EVALAREF, fortran_evalaref); ! 52: language_setop(fort, L_MODINIT, fortran_modinit); ! 53: language_setop(fort, L_HASMODULES, fortran_hasmodules); ! 54: language_setop(fort, L_PASSADDR, fortran_passaddr); ! 55: } ! 56: ! 57: /* ! 58: * Test if two types are compatible. ! 59: * ! 60: * Integers and reals are not compatible since they cannot always be mixed. ! 61: */ ! 62: ! 63: public Boolean fortran_typematch(type1, type2) ! 64: Symbol type1, type2; ! 65: { ! 66: ! 67: /* only does integer for now; may need to add others ! 68: */ ! 69: ! 70: Boolean b; ! 71: register Symbol t1, t2, tmp; ! 72: ! 73: t1 = rtype(type1); ! 74: t2 = rtype(type2); ! 75: if(t1 == nil or t1->type == nil or t2 == nil or t2->type == nil ) b = false; ! 76: else { b = (Boolean) ( ! 77: (t1 == t2) or ! 78: (t1->type == t_int and (istypename(t2->type, "integer") or ! 79: istypename(t2->type, "integer*2")) ) or ! 80: (t2->type == t_int and (istypename(t1->type, "integer") or ! 81: istypename(t1->type, "integer*2")) ) ! 82: ); ! 83: } ! 84: /*OUT fprintf(stderr," %d compat %s %s \n", b, ! 85: (t1 == nil or t1->type == nil ) ? "nil" : symname(t1->type), ! 86: (t2 == nil or t2->type == nil ) ? "nil" : symname(t2->type) );*/ ! 87: return b; ! 88: } ! 89: ! 90: private String typename(s) ! 91: Symbol s; ! 92: { ! 93: int ub; ! 94: static char buf[20]; ! 95: char *pbuf; ! 96: Symbol st,sc; ! 97: ! 98: if(s->type->class == TYPE) return(symname(s->type)); ! 99: ! 100: for(st = s->type; st->type->class != TYPE; st = st->type); ! 101: ! 102: pbuf=buf; ! 103: ! 104: if(istypename(st->type,"char")) { ! 105: sprintf(pbuf,"character*"); ! 106: pbuf += strlen(pbuf); ! 107: sc = st->chain; ! 108: if(sc->symvalue.rangev.uppertype == R_ARG or ! 109: sc->symvalue.rangev.uppertype == R_TEMP) { ! 110: if( ! getbound(s,sc->symvalue.rangev.upper, ! 111: sc->symvalue.rangev.uppertype, &ub) ) ! 112: sprintf(pbuf,"(*)"); ! 113: else ! 114: sprintf(pbuf,"%d",ub); ! 115: } ! 116: else sprintf(pbuf,"%d",sc->symvalue.rangev.upper); ! 117: } ! 118: else { ! 119: sprintf(pbuf,"%s ",symname(st->type)); ! 120: } ! 121: return(buf); ! 122: } ! 123: ! 124: private Symbol mksubs(pbuf,st) ! 125: Symbol st; ! 126: char **pbuf; ! 127: { ! 128: int lb, ub; ! 129: Symbol r, eltype; ! 130: ! 131: if(st->class != ARRAY or (istypename(st->type, "char")) ) return; ! 132: else { ! 133: mksubs(pbuf,st->type); ! 134: assert( (r = st->chain)->class == RANGE); ! 135: ! 136: if(r->symvalue.rangev.lowertype == R_ARG or ! 137: r->symvalue.rangev.lowertype == R_TEMP) { ! 138: if( ! getbound(st,r->symvalue.rangev.lower, ! 139: r->symvalue.rangev.lowertype, &lb) ) ! 140: sprintf(*pbuf,"?:"); ! 141: else ! 142: sprintf(*pbuf,"%d:",lb); ! 143: } ! 144: else { ! 145: lb = r->symvalue.rangev.lower; ! 146: sprintf(*pbuf,"%d:",lb); ! 147: } ! 148: *pbuf += strlen(*pbuf); ! 149: ! 150: if(r->symvalue.rangev.uppertype == R_ARG or ! 151: r->symvalue.rangev.uppertype == R_TEMP) { ! 152: if( ! getbound(st,r->symvalue.rangev.upper, ! 153: r->symvalue.rangev.uppertype, &ub) ) ! 154: sprintf(*pbuf,"?,"); ! 155: else ! 156: sprintf(*pbuf,"%d,",ub); ! 157: } ! 158: else { ! 159: ub = r->symvalue.rangev.upper; ! 160: sprintf(*pbuf,"%d,",ub); ! 161: } ! 162: *pbuf += strlen(*pbuf); ! 163: ! 164: } ! 165: } ! 166: ! 167: /* ! 168: * Print out the declaration of a FORTRAN variable. ! 169: */ ! 170: ! 171: public fortran_printdecl(s) ! 172: Symbol s; ! 173: { ! 174: Symbol eltype; ! 175: ! 176: switch (s->class) { ! 177: case CONST: ! 178: printf("parameter %s = ", symname(s)); ! 179: eval(s->symvalue.constval); ! 180: printval(s); ! 181: break; ! 182: ! 183: case REF: ! 184: printf(" (dummy argument) "); ! 185: ! 186: case VAR: ! 187: if (s->type->class == ARRAY && ! 188: (not istypename(s->type->type,"char")) ) { ! 189: char bounds[130], *p1, **p; ! 190: p1 = bounds; ! 191: p = &p1; ! 192: mksubs(p,s->type); ! 193: *p -= 1; ! 194: **p = '\0'; /* get rid of trailing ',' */ ! 195: printf(" %s %s[%s] ",typename(s), symname(s), bounds); ! 196: } else { ! 197: printf("%s %s", typename(s), symname(s)); ! 198: } ! 199: break; ! 200: ! 201: case FUNC: ! 202: if (not istypename(s->type, "void")) { ! 203: printf(" %s function ", typename(s) ); ! 204: } ! 205: else printf(" subroutine"); ! 206: printf(" %s ", symname(s)); ! 207: fortran_listparams(s); ! 208: break; ! 209: ! 210: case MODULE: ! 211: printf("source file \"%s.c\"", symname(s)); ! 212: break; ! 213: ! 214: case PROG: ! 215: printf("executable file \"%s\"", symname(s)); ! 216: break; ! 217: ! 218: default: ! 219: error("class %s in fortran_printdecl", classname(s)); ! 220: } ! 221: putchar('\n'); ! 222: } ! 223: ! 224: /* ! 225: * List the parameters of a procedure or function. ! 226: * No attempt is made to combine like types. ! 227: */ ! 228: ! 229: public fortran_listparams(s) ! 230: Symbol s; ! 231: { ! 232: register Symbol t; ! 233: ! 234: putchar('('); ! 235: for (t = s->chain; t != nil; t = t->chain) { ! 236: printf("%s", symname(t)); ! 237: if (t->chain != nil) { ! 238: printf(", "); ! 239: } ! 240: } ! 241: putchar(')'); ! 242: if (s->chain != nil) { ! 243: printf("\n"); ! 244: for (t = s->chain; t != nil; t = t->chain) { ! 245: if (t->class != REF) { ! 246: panic("unexpected class %d for parameter", t->class); ! 247: } ! 248: printdecl(t, 0); ! 249: } ! 250: } else { ! 251: putchar('\n'); ! 252: } ! 253: } ! 254: ! 255: /* ! 256: * Print out the value on the top of the expression stack ! 257: * in the format for the type of the given symbol. ! 258: */ ! 259: ! 260: public fortran_printval(s) ! 261: Symbol s; ! 262: { ! 263: register Symbol t; ! 264: register Address a; ! 265: register int i, len; ! 266: double d1, d2; ! 267: ! 268: switch (s->class) { ! 269: case CONST: ! 270: case TYPE: ! 271: case VAR: ! 272: case REF: ! 273: case FVAR: ! 274: case TAG: ! 275: fortran_printval(s->type); ! 276: break; ! 277: ! 278: case ARRAY: ! 279: t = rtype(s->type); ! 280: if (t->class == RANGE and istypename(t->type, "char")) { ! 281: len = size(s); ! 282: sp -= len; ! 283: printf("\"%.*s\"", len, sp); ! 284: } else { ! 285: fortran_printarray(s); ! 286: } ! 287: break; ! 288: ! 289: case RANGE: ! 290: if (isspecial(s)) { ! 291: switch (s->symvalue.rangev.lower) { ! 292: case sizeof(short): ! 293: if (istypename(s->type, "logical*2")) { ! 294: printlogical(pop(short)); ! 295: } ! 296: break; ! 297: ! 298: case sizeof(float): ! 299: if (istypename(s->type, "logical")) { ! 300: printlogical(pop(long)); ! 301: } else { ! 302: prtreal(pop(float)); ! 303: } ! 304: break; ! 305: ! 306: case sizeof(double): ! 307: if (istypename(s->type,"complex")) { ! 308: d2 = pop(float); ! 309: d1 = pop(float); ! 310: printf("("); ! 311: prtreal(d1); ! 312: printf(","); ! 313: prtreal(d2); ! 314: printf(")"); ! 315: } else { ! 316: prtreal(pop(double)); ! 317: } ! 318: break; ! 319: ! 320: case 2*sizeof(double): ! 321: d2 = pop(double); ! 322: d1 = pop(double); ! 323: printf("("); ! 324: prtreal(d1); ! 325: printf(","); ! 326: prtreal(d2); ! 327: printf(")"); ! 328: break; ! 329: ! 330: default: ! 331: panic("bad size \"%d\" for special", ! 332: s->symvalue.rangev.lower); ! 333: break; ! 334: } ! 335: } else { ! 336: printint(popsmall(s), s); ! 337: } ! 338: break; ! 339: ! 340: default: ! 341: if (ord(s->class) > ord(TYPEREF)) { ! 342: panic("printval: bad class %d", ord(s->class)); ! 343: } ! 344: error("don't know how to print a %s", fortran_classname(s)); ! 345: /* NOTREACHED */ ! 346: } ! 347: } ! 348: ! 349: /* ! 350: * Print out a logical ! 351: */ ! 352: ! 353: private printlogical (i) ! 354: integer i; ! 355: { ! 356: if (i == 0) { ! 357: printf(".false."); ! 358: } else { ! 359: printf(".true."); ! 360: } ! 361: } ! 362: ! 363: /* ! 364: * Print out an int ! 365: */ ! 366: ! 367: private printint(i, t) ! 368: Integer i; ! 369: register Symbol t; ! 370: { ! 371: if (t->type == t_int or istypename(t->type, "integer") or ! 372: istypename(t->type,"integer*2") ! 373: ) { ! 374: printf("%ld", i); ! 375: } else if (istypename(t->type, "addr")) { ! 376: printf("0x%lx", i); ! 377: } else { ! 378: error("unknown type in fortran printint"); ! 379: } ! 380: } ! 381: ! 382: /* ! 383: * Print out a null-terminated string (pointer to char) ! 384: * starting at the given address. ! 385: */ ! 386: ! 387: private printstring(addr) ! 388: Address addr; ! 389: { ! 390: register Address a; ! 391: register Integer i, len; ! 392: register Boolean endofstring; ! 393: union { ! 394: char ch[sizeof(Word)]; ! 395: int word; ! 396: } u; ! 397: ! 398: putchar('"'); ! 399: a = addr; ! 400: endofstring = false; ! 401: while (not endofstring) { ! 402: dread(&u, a, sizeof(u)); ! 403: i = 0; ! 404: do { ! 405: if (u.ch[i] == '\0') { ! 406: endofstring = true; ! 407: } else { ! 408: printchar(u.ch[i]); ! 409: } ! 410: ++i; ! 411: } while (i < sizeof(Word) and not endofstring); ! 412: a += sizeof(Word); ! 413: } ! 414: putchar('"'); ! 415: } ! 416: /* ! 417: * Return the FORTRAN name for the particular class of a symbol. ! 418: */ ! 419: ! 420: public String fortran_classname(s) ! 421: Symbol s; ! 422: { ! 423: String str; ! 424: ! 425: switch (s->class) { ! 426: case REF: ! 427: str = "dummy argument"; ! 428: break; ! 429: ! 430: case CONST: ! 431: str = "parameter"; ! 432: break; ! 433: ! 434: default: ! 435: str = classname(s); ! 436: } ! 437: return str; ! 438: } ! 439: ! 440: /* reverses the indices from the expr_list; should be folded into buildaref ! 441: * and done as one recursive routine ! 442: */ ! 443: Node private rev_index(here,n) ! 444: register Node here,n; ! 445: { ! 446: ! 447: register Node i; ! 448: ! 449: if( here == nil or here == n) i=nil; ! 450: else if( here->value.arg[1] == n) i = here; ! 451: else i=rev_index(here->value.arg[1],n); ! 452: return i; ! 453: } ! 454: ! 455: public Node fortran_buildaref(a, slist) ! 456: Node a, slist; ! 457: { ! 458: register Symbol as; /* array of array of .. cursor */ ! 459: register Node en; /* Expr list cursor */ ! 460: Symbol etype; /* Type of subscript expr */ ! 461: Node esub, tree; /* Subscript expression ptr and tree to be built*/ ! 462: ! 463: tree=a; ! 464: ! 465: as = rtype(tree->nodetype); /* node->sym.type->array*/ ! 466: if ( not ( ! 467: (tree->nodetype->class == VAR or tree->nodetype->class == REF) ! 468: and as->class == ARRAY ! 469: ) ) { ! 470: beginerrmsg(); ! 471: prtree(stderr, a); ! 472: fprintf(stderr, " is not an array"); ! 473: /*fprintf(stderr, " a-> %x as %x ", tree->nodetype, as ); OUT*/ ! 474: enderrmsg(); ! 475: } else { ! 476: for (en = rev_index(slist,nil); en != nil and as->class == ARRAY; ! 477: en = rev_index(slist,en), as = as->type) { ! 478: esub = en->value.arg[0]; ! 479: etype = rtype(esub->nodetype); ! 480: assert(as->chain->class == RANGE); ! 481: if ( not compatible( t_int, etype) ) { ! 482: beginerrmsg(); ! 483: fprintf(stderr, "subscript "); ! 484: prtree(stderr, esub); ! 485: fprintf(stderr, " is type %s ",symname(etype->type) ); ! 486: enderrmsg(); ! 487: } ! 488: tree = build(O_INDEX, tree, esub); ! 489: tree->nodetype = as->type; ! 490: } ! 491: if (en != nil or ! 492: (as->class == ARRAY && (not istypename(as->type,"char"))) ) { ! 493: beginerrmsg(); ! 494: if (en != nil) { ! 495: fprintf(stderr, "too many subscripts for "); ! 496: } else { ! 497: fprintf(stderr, "not enough subscripts for "); ! 498: } ! 499: prtree(stderr, tree); ! 500: enderrmsg(); ! 501: } ! 502: } ! 503: return tree; ! 504: } ! 505: ! 506: /* ! 507: * Evaluate a subscript index. ! 508: */ ! 509: ! 510: public fortran_evalaref(s, base, i) ! 511: Symbol s; ! 512: Address base; ! 513: long i; ! 514: { ! 515: Symbol r, t; ! 516: long lb, ub; ! 517: ! 518: t = rtype(s); ! 519: r = t->chain; ! 520: if ( ! 521: r->symvalue.rangev.lowertype == R_ARG or ! 522: r->symvalue.rangev.lowertype == R_TEMP ! 523: ) { ! 524: if (not getbound( ! 525: s, r->symvalue.rangev.lower, r->symvalue.rangev.lowertype, &lb ! 526: )) { ! 527: error("dynamic bounds not currently available"); ! 528: } ! 529: } else { ! 530: lb = r->symvalue.rangev.lower; ! 531: } ! 532: if ( ! 533: r->symvalue.rangev.uppertype == R_ARG or ! 534: r->symvalue.rangev.uppertype == R_TEMP ! 535: ) { ! 536: if (not getbound( ! 537: s, r->symvalue.rangev.upper, r->symvalue.rangev.uppertype, &ub ! 538: )) { ! 539: error("dynamic bounds not currently available"); ! 540: } ! 541: } else { ! 542: ub = r->symvalue.rangev.upper; ! 543: } ! 544: ! 545: if (i < lb or i > ub) { ! 546: error("subscript out of range"); ! 547: } ! 548: push(long, base + (i - lb) * size(t->type)); ! 549: } ! 550: ! 551: private fortran_printarray(a) ! 552: Symbol a; ! 553: { ! 554: struct Bounds { int lb, val, ub} dim[MAXDIM]; ! 555: ! 556: Symbol sc,st,eltype; ! 557: char buf[50]; ! 558: char *subscr; ! 559: int i,ndim,elsize; ! 560: Stack *savesp; ! 561: Boolean done; ! 562: ! 563: st = a; ! 564: ! 565: savesp = sp; ! 566: sp -= size(a); ! 567: ndim=0; ! 568: ! 569: for(;;){ ! 570: sc = st->chain; ! 571: if(sc->symvalue.rangev.lowertype == R_ARG or ! 572: sc->symvalue.rangev.lowertype == R_TEMP) { ! 573: if( ! getbound(a,sc->symvalue.rangev.lower, ! 574: sc->symvalue.rangev.lowertype, &dim[ndim].lb) ) ! 575: error(" dynamic bounds not currently available"); ! 576: } ! 577: else dim[ndim].lb = sc->symvalue.rangev.lower; ! 578: ! 579: if(sc->symvalue.rangev.uppertype == R_ARG or ! 580: sc->symvalue.rangev.uppertype == R_TEMP) { ! 581: if( ! getbound(a,sc->symvalue.rangev.upper, ! 582: sc->symvalue.rangev.uppertype, &dim[ndim].ub) ) ! 583: error(" dynamic bounds not currently available"); ! 584: } ! 585: else dim[ndim].ub = sc->symvalue.rangev.upper; ! 586: ! 587: ndim ++; ! 588: if (st->type->class == ARRAY) st=st->type; ! 589: else break; ! 590: } ! 591: ! 592: if(istypename(st->type,"char")) { ! 593: eltype = st; ! 594: ndim--; ! 595: } ! 596: else eltype=st->type; ! 597: elsize=size(eltype); ! 598: sp += elsize; ! 599: /*printf("ndim %d elsize %lx in fortran_printarray\n",ndim,elsize);OUT*/ ! 600: ! 601: ndim--; ! 602: for (i=0;i<=ndim;i++){ ! 603: dim[i].val=dim[i].lb; ! 604: /*OUT printf(" %d %d %d \n",i,dim[i].lb,dim[i].ub); ! 605: fflush(stdout); OUT*/ ! 606: } ! 607: ! 608: ! 609: for(;;) { ! 610: buf[0]=','; ! 611: subscr = buf+1; ! 612: ! 613: for (i=ndim-1;i>=0;i--) { ! 614: ! 615: sprintf(subscr,"%d,",dim[i].val); ! 616: subscr += strlen(subscr); ! 617: } ! 618: *--subscr = '\0'; ! 619: ! 620: for(i=dim[ndim].lb;i<=dim[ndim].ub;i++) { ! 621: printf("[%d%s]\t",i,buf); ! 622: printval(eltype); ! 623: printf("\n"); ! 624: sp += 2*elsize; ! 625: } ! 626: dim[ndim].val=dim[ndim].ub; ! 627: ! 628: i=ndim-1; ! 629: if (i<0) break; ! 630: ! 631: done=false; ! 632: do { ! 633: dim[i].val++; ! 634: if(dim[i].val > dim[i].ub) { ! 635: dim[i].val = dim[i].lb; ! 636: if(--i<0) done=true; ! 637: } ! 638: else done=true; ! 639: } ! 640: while (not done); ! 641: if (i<0) break; ! 642: } ! 643: } ! 644: ! 645: /* ! 646: * Initialize typetable at beginning of a module. ! 647: */ ! 648: ! 649: public fortran_modinit (typetable) ! 650: Symbol typetable[]; ! 651: { ! 652: /* nothing for now */ ! 653: } ! 654: ! 655: public boolean fortran_hasmodules () ! 656: { ! 657: return false; ! 658: } ! 659: ! 660: public boolean fortran_passaddr (param, exprtype) ! 661: Symbol param, exprtype; ! 662: { ! 663: return false; ! 664: }
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.