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