4.3BSD - /usr/src/ucb/dbx/fortran.c

   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: }

Defined functions

Defined variables

Defined struct's

Defined macros