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