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