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