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) 01/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 } 665