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