|
|
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.3 (Berkeley) 1/10/86"; ! 9: #endif not lint ! 10: ! 11: static char rcsid[] = "$Header: fortran.c,v 1.5 84/12/26 10:39:37 linton 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: ! 175: ! 176: Symbol eltype; ! 177: ! 178: switch (s->class) { ! 179: ! 180: case CONST: ! 181: ! 182: printf("parameter %s = ", symname(s)); ! 183: eval(s->symvalue.constval); ! 184: printval(s); ! 185: break; ! 186: ! 187: case REF: ! 188: printf(" (dummy argument) "); ! 189: ! 190: case VAR: ! 191: if (s->type->class == ARRAY && ! 192: (not istypename(s->type->type,"char")) ) { ! 193: char bounds[130], *p1, **p; ! 194: p1 = bounds; ! 195: p = &p1; ! 196: mksubs(p,s->type); ! 197: *p -= 1; ! 198: **p = '\0'; /* get rid of trailing ',' */ ! 199: printf(" %s %s[%s] ",typename(s), symname(s), bounds); ! 200: } else { ! 201: printf("%s %s", typename(s), symname(s)); ! 202: } ! 203: break; ! 204: ! 205: case FUNC: ! 206: if (not istypename(s->type, "void")) { ! 207: printf(" %s function ", typename(s) ); ! 208: } ! 209: else printf(" subroutine"); ! 210: printf(" %s ", symname(s)); ! 211: fortran_listparams(s); ! 212: break; ! 213: ! 214: case MODULE: ! 215: printf("source file \"%s.c\"", symname(s)); ! 216: break; ! 217: ! 218: case PROG: ! 219: printf("executable file \"%s\"", symname(s)); ! 220: break; ! 221: ! 222: default: ! 223: error("class %s in fortran_printdecl", classname(s)); ! 224: } ! 225: putchar('\n'); ! 226: } ! 227: ! 228: /* ! 229: * List the parameters of a procedure or function. ! 230: * No attempt is made to combine like types. ! 231: */ ! 232: ! 233: public fortran_listparams(s) ! 234: Symbol s; ! 235: { ! 236: register Symbol t; ! 237: ! 238: putchar('('); ! 239: for (t = s->chain; t != nil; t = t->chain) { ! 240: printf("%s", symname(t)); ! 241: if (t->chain != nil) { ! 242: printf(", "); ! 243: } ! 244: } ! 245: putchar(')'); ! 246: if (s->chain != nil) { ! 247: printf("\n"); ! 248: for (t = s->chain; t != nil; t = t->chain) { ! 249: if (t->class != REF) { ! 250: panic("unexpected class %d for parameter", t->class); ! 251: } ! 252: printdecl(t, 0); ! 253: } ! 254: } else { ! 255: putchar('\n'); ! 256: } ! 257: } ! 258: ! 259: /* ! 260: * Print out the value on the top of the expression stack ! 261: * in the format for the type of the given symbol. ! 262: */ ! 263: ! 264: public fortran_printval(s) ! 265: Symbol s; ! 266: { ! 267: register Symbol t; ! 268: register Address a; ! 269: register int i, len; ! 270: double d1, d2; ! 271: ! 272: switch (s->class) { ! 273: case CONST: ! 274: case TYPE: ! 275: case VAR: ! 276: case REF: ! 277: case FVAR: ! 278: case TAG: ! 279: fortran_printval(s->type); ! 280: break; ! 281: ! 282: case ARRAY: ! 283: t = rtype(s->type); ! 284: if (t->class == RANGE and istypename(t->type, "char")) { ! 285: len = size(s); ! 286: sp -= len; ! 287: printf("\"%.*s\"", len, sp); ! 288: } else { ! 289: fortran_printarray(s); ! 290: } ! 291: break; ! 292: ! 293: case RANGE: ! 294: if (isspecial(s)) { ! 295: switch (s->symvalue.rangev.lower) { ! 296: case sizeof(short): ! 297: if (istypename(s->type, "logical*2")) { ! 298: printlogical(pop(short)); ! 299: } ! 300: break; ! 301: ! 302: case sizeof(float): ! 303: if (istypename(s->type, "logical")) { ! 304: printlogical(pop(long)); ! 305: } else { ! 306: prtreal(pop(float)); ! 307: } ! 308: break; ! 309: ! 310: case sizeof(double): ! 311: if (istypename(s->type, "complex")) { ! 312: d2 = pop(float); ! 313: d1 = pop(float); ! 314: printf("("); ! 315: prtreal(d1); ! 316: printf(","); ! 317: prtreal(d2); ! 318: printf(")"); ! 319: } else { ! 320: prtreal(pop(double)); ! 321: } ! 322: break; ! 323: ! 324: case 2*sizeof(double): ! 325: d2 = pop(double); ! 326: d1 = pop(double); ! 327: printf("("); ! 328: prtreal(d1); ! 329: printf(","); ! 330: prtreal(d2); ! 331: printf(")"); ! 332: break; ! 333: ! 334: default: ! 335: panic("bad size \"%d\" for special", ! 336: s->symvalue.rangev.lower); ! 337: break; ! 338: } ! 339: } else { ! 340: printint(popsmall(s), s); ! 341: } ! 342: break; ! 343: ! 344: default: ! 345: if (ord(s->class) > ord(TYPEREF)) { ! 346: panic("printval: bad class %d", ord(s->class)); ! 347: } ! 348: error("don't know how to print a %s", fortran_classname(s)); ! 349: /* NOTREACHED */ ! 350: } ! 351: } ! 352: ! 353: /* ! 354: * Print out a logical ! 355: */ ! 356: ! 357: private printlogical(i) ! 358: Integer i; ! 359: { ! 360: if (i == 0) { ! 361: printf(".false."); ! 362: } else { ! 363: printf(".true."); ! 364: } ! 365: } ! 366: ! 367: /* ! 368: * Print out an int ! 369: */ ! 370: ! 371: private printint(i, t) ! 372: Integer i; ! 373: register Symbol t; ! 374: { ! 375: if ( (t->type == t_int) or istypename(t->type, "integer") or ! 376: istypename(t->type,"integer*2") ) { ! 377: printf("%ld", i); ! 378: } else if (istypename(t->type, "addr")) { ! 379: printf("0x%lx", i); ! 380: } else { ! 381: error("unknown type in fortran printint"); ! 382: } ! 383: } ! 384: ! 385: /* ! 386: * Print out a null-terminated string (pointer to char) ! 387: * starting at the given address. ! 388: */ ! 389: ! 390: private printstring(addr) ! 391: Address addr; ! 392: { ! 393: register Address a; ! 394: register Integer i, len; ! 395: register Boolean endofstring; ! 396: union { ! 397: char ch[sizeof(Word)]; ! 398: int word; ! 399: } u; ! 400: ! 401: putchar('"'); ! 402: a = addr; ! 403: endofstring = false; ! 404: while (not endofstring) { ! 405: dread(&u, a, sizeof(u)); ! 406: i = 0; ! 407: do { ! 408: if (u.ch[i] == '\0') { ! 409: endofstring = true; ! 410: } else { ! 411: printchar(u.ch[i]); ! 412: } ! 413: ++i; ! 414: } while (i < sizeof(Word) and not endofstring); ! 415: a += sizeof(Word); ! 416: } ! 417: putchar('"'); ! 418: } ! 419: /* ! 420: * Return the FORTRAN name for the particular class of a symbol. ! 421: */ ! 422: ! 423: public String fortran_classname(s) ! 424: Symbol s; ! 425: { ! 426: String str; ! 427: ! 428: switch (s->class) { ! 429: case REF: ! 430: str = "dummy argument"; ! 431: break; ! 432: ! 433: case CONST: ! 434: str = "parameter"; ! 435: break; ! 436: ! 437: default: ! 438: str = classname(s); ! 439: } ! 440: return str; ! 441: } ! 442: ! 443: /* reverses the indices from the expr_list; should be folded into buildaref ! 444: * and done as one recursive routine ! 445: */ ! 446: Node private rev_index(here,n) ! 447: register Node here,n; ! 448: { ! 449: ! 450: register Node i; ! 451: ! 452: if( here == nil or here == n) i=nil; ! 453: else if( here->value.arg[1] == n) i = here; ! 454: else i=rev_index(here->value.arg[1],n); ! 455: return i; ! 456: } ! 457: ! 458: public Node fortran_buildaref(a, slist) ! 459: Node a, slist; ! 460: { ! 461: register Symbol as; /* array of array of .. cursor */ ! 462: register Node en; /* Expr list cursor */ ! 463: Symbol etype; /* Type of subscript expr */ ! 464: Node esub, tree; /* Subscript expression ptr and tree to be built*/ ! 465: ! 466: tree=a; ! 467: ! 468: as = rtype(tree->nodetype); /* node->sym.type->array*/ ! 469: if ( not ( ! 470: (tree->nodetype->class == VAR or tree->nodetype->class == REF) ! 471: and as->class == ARRAY ! 472: ) ) { ! 473: beginerrmsg(); ! 474: prtree(stderr, a); ! 475: fprintf(stderr, " is not an array"); ! 476: /*fprintf(stderr, " a-> %x as %x ", tree->nodetype, as ); OUT*/ ! 477: enderrmsg(); ! 478: } else { ! 479: for (en = rev_index(slist,nil); en != nil and as->class == ARRAY; ! 480: en = rev_index(slist,en), as = as->type) { ! 481: esub = en->value.arg[0]; ! 482: etype = rtype(esub->nodetype); ! 483: assert(as->chain->class == RANGE); ! 484: if ( not compatible( t_int, etype) ) { ! 485: beginerrmsg(); ! 486: fprintf(stderr, "subscript "); ! 487: prtree(stderr, esub); ! 488: fprintf(stderr, " is type %s ",symname(etype->type) ); ! 489: enderrmsg(); ! 490: } ! 491: tree = build(O_INDEX, tree, esub); ! 492: tree->nodetype = as->type; ! 493: } ! 494: if (en != nil or ! 495: (as->class == ARRAY && (not istypename(as->type,"char"))) ) { ! 496: beginerrmsg(); ! 497: if (en != nil) { ! 498: fprintf(stderr, "too many subscripts for "); ! 499: } else { ! 500: fprintf(stderr, "not enough subscripts for "); ! 501: } ! 502: prtree(stderr, tree); ! 503: enderrmsg(); ! 504: } ! 505: } ! 506: return tree; ! 507: } ! 508: ! 509: /* ! 510: * Evaluate a subscript index. ! 511: */ ! 512: ! 513: public fortran_evalaref(s, base, i) ! 514: Symbol s; ! 515: Address base; ! 516: long i; ! 517: { ! 518: Symbol r, t; ! 519: long lb, ub; ! 520: ! 521: t = rtype(s); ! 522: r = t->chain; ! 523: if ( ! 524: r->symvalue.rangev.lowertype == R_ARG or ! 525: r->symvalue.rangev.lowertype == R_TEMP ! 526: ) { ! 527: if (not getbound( ! 528: s, r->symvalue.rangev.lower, r->symvalue.rangev.lowertype, &lb ! 529: )) { ! 530: error("dynamic bounds not currently available"); ! 531: } ! 532: } else { ! 533: lb = r->symvalue.rangev.lower; ! 534: } ! 535: if ( ! 536: r->symvalue.rangev.uppertype == R_ARG or ! 537: r->symvalue.rangev.uppertype == R_TEMP ! 538: ) { ! 539: if (not getbound( ! 540: s, r->symvalue.rangev.upper, r->symvalue.rangev.uppertype, &ub ! 541: )) { ! 542: error("dynamic bounds not currently available"); ! 543: } ! 544: } else { ! 545: ub = r->symvalue.rangev.upper; ! 546: } ! 547: ! 548: if (i < lb or i > ub) { ! 549: error("subscript out of range"); ! 550: } ! 551: push(long, base + (i - lb) * size(t->type)); ! 552: } ! 553: ! 554: private fortran_printarray(a) ! 555: Symbol a; ! 556: { ! 557: struct Bounds { int lb, val, ub} dim[MAXDIM]; ! 558: ! 559: Symbol sc,st,eltype; ! 560: char buf[50]; ! 561: char *subscr; ! 562: int i,ndim,elsize; ! 563: Stack *savesp; ! 564: Boolean done; ! 565: ! 566: st = a; ! 567: ! 568: savesp = sp; ! 569: sp -= size(a); ! 570: ndim=0; ! 571: ! 572: for(;;){ ! 573: sc = st->chain; ! 574: if(sc->symvalue.rangev.lowertype == R_ARG or ! 575: sc->symvalue.rangev.lowertype == R_TEMP) { ! 576: if( ! getbound(a,sc->symvalue.rangev.lower, ! 577: sc->symvalue.rangev.lowertype, &dim[ndim].lb) ) ! 578: error(" dynamic bounds not currently available"); ! 579: } ! 580: else dim[ndim].lb = sc->symvalue.rangev.lower; ! 581: ! 582: if(sc->symvalue.rangev.uppertype == R_ARG or ! 583: sc->symvalue.rangev.uppertype == R_TEMP) { ! 584: if( ! getbound(a,sc->symvalue.rangev.upper, ! 585: sc->symvalue.rangev.uppertype, &dim[ndim].ub) ) ! 586: error(" dynamic bounds not currently available"); ! 587: } ! 588: else dim[ndim].ub = sc->symvalue.rangev.upper; ! 589: ! 590: ndim ++; ! 591: if (st->type->class == ARRAY) st=st->type; ! 592: else break; ! 593: } ! 594: ! 595: if(istypename(st->type,"char")) { ! 596: eltype = st; ! 597: ndim--; ! 598: } ! 599: else eltype=st->type; ! 600: elsize=size(eltype); ! 601: sp += elsize; ! 602: /*printf("ndim %d elsize %lx in fortran_printarray\n",ndim,elsize);OUT*/ ! 603: ! 604: ndim--; ! 605: for (i=0;i<=ndim;i++){ ! 606: dim[i].val=dim[i].lb; ! 607: /*OUT printf(" %d %d %d \n",i,dim[i].lb,dim[i].ub); ! 608: fflush(stdout); OUT*/ ! 609: } ! 610: ! 611: ! 612: for(;;) { ! 613: buf[0]=','; ! 614: subscr = buf+1; ! 615: ! 616: for (i=ndim-1;i>=0;i--) { ! 617: ! 618: sprintf(subscr,"%d,",dim[i].val); ! 619: subscr += strlen(subscr); ! 620: } ! 621: *--subscr = '\0'; ! 622: ! 623: for(i=dim[ndim].lb;i<=dim[ndim].ub;i++) { ! 624: printf("[%d%s]\t",i,buf); ! 625: printval(eltype); ! 626: printf("\n"); ! 627: sp += 2*elsize; ! 628: } ! 629: dim[ndim].val=dim[ndim].ub; ! 630: ! 631: i=ndim-1; ! 632: if (i<0) break; ! 633: ! 634: done=false; ! 635: do { ! 636: dim[i].val++; ! 637: if(dim[i].val > dim[i].ub) { ! 638: dim[i].val = dim[i].lb; ! 639: if(--i<0) done=true; ! 640: } ! 641: else done=true; ! 642: } ! 643: while (not done); ! 644: if (i<0) break; ! 645: } ! 646: } ! 647: ! 648: /* ! 649: * Initialize typetable at beginning of a module. ! 650: */ ! 651: ! 652: public fortran_modinit (typetable) ! 653: Symbol typetable[]; ! 654: { ! 655: /* nothing for now */ ! 656: } ! 657: ! 658: public boolean fortran_hasmodules () ! 659: { ! 660: return false; ! 661: } ! 662: ! 663: public boolean fortran_passaddr (param, exprtype) ! 664: Symbol param, exprtype; ! 665: { ! 666: return false; ! 667: }
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.