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