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