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