1 /* Copyright (c) 1979 Regents of the University of California */ 2 3 #ifndef lint 4 static char sccsid[] = "@(#)call.c 2.2 03/20/85"; 5 #endif 6 7 #include "whoami.h" 8 #include "0.h" 9 #include "tree.h" 10 #include "opcode.h" 11 #include "objfmt.h" 12 #ifdef PC 13 # include "pc.h" 14 # include <pcc.h> 15 #endif PC 16 #include "tmps.h" 17 #include "tree_ty.h" 18 19 /* 20 * Call generates code for calls to 21 * user defined procedures and functions 22 * and is called by proc and funccod. 23 * P is the result of the lookup 24 * of the procedure/function symbol, 25 * and porf is PROC or FUNC. 26 * Psbn is the block number of p. 27 * 28 * the idea here is that regular scalar functions are just called, 29 * while structure functions and formal functions have their results 30 * stored in a temporary after the call. 31 * structure functions do this because they return pointers 32 * to static results, so we copy the static 33 * and return a pointer to the copy. 34 * formal functions do this because we have to save the result 35 * around a call to the runtime routine which restores the display, 36 * so we can't just leave the result lying around in registers. 37 * formal calls save the address of the descriptor in a local 38 * temporary, so it can be addressed for the call which restores 39 * the display (FRTN). 40 * calls to formal parameters pass the formal as a hidden argument 41 * to a special entry point for the formal call. 42 * [this is somewhat dependent on the way arguments are addressed.] 43 * so PROCs and scalar FUNCs look like 44 * p(...args...) 45 * structure FUNCs look like 46 * (temp = p(...args...),&temp) 47 * formal FPROCs look like 48 * ( t=p,( t -> entryaddr )(...args...,t,s),FRTN(t,s)) 49 * formal scalar FFUNCs look like 50 * ( t=p,temp=( t -> entryaddr )(...args...,t,s),FRTN(t,s),temp) 51 * formal structure FFUNCs look like 52 * (t=p,temp = ( t -> entryaddr )(...args...,t,s),FRTN(t,s),&temp) 53 */ 54 struct nl * 55 call(p, argv_node, porf, psbn) 56 struct nl *p; 57 struct tnode *argv_node; /* list node */ 58 int porf, psbn; 59 { 60 register struct nl *p1, *q, *p2; 61 register struct nl *ptype, *ctype; 62 struct tnode *rnode; 63 int i, j, d; 64 bool chk = TRUE; 65 struct nl *savedispnp; /* temporary to hold saved display */ 66 # ifdef PC 67 int p_type_class = classify( p -> type ); 68 long p_type_p2type = p2type( p -> type ); 69 bool noarguments; 70 /* 71 * these get used if temporaries and structures are used 72 */ 73 struct nl *tempnlp; 74 long temptype; /* type of the temporary */ 75 long p_type_width; 76 long p_type_align; 77 char extname[ BUFSIZ ]; 78 struct nl *tempdescrp; 79 # endif PC 80 81 if (p->class == FFUNC || p->class == FPROC) { 82 /* 83 * allocate space to save the display for formal calls 84 */ 85 savedispnp = tmpalloc( (long) sizeof display , NLNIL , NOREG ); 86 } 87 # ifdef OBJ 88 if (p->class == FFUNC || p->class == FPROC) { 89 (void) put(2, O_LV | cbn << 8 + INDX , 90 (int) savedispnp -> value[ NL_OFFS ] ); 91 (void) put(2, PTR_RV | psbn << 8+INDX, (int)p->value[NL_OFFS]); 92 } 93 if (porf == FUNC) { 94 /* 95 * Push some space 96 * for the function return type 97 */ 98 (void) put(2, O_PUSH, leven(-lwidth(p->type))); 99 } 100 # endif OBJ 101 # ifdef PC 102 /* 103 * if this is a formal call, 104 * stash the address of the descriptor 105 * in a temporary so we can find it 106 * after the FCALL for the call to FRTN 107 */ 108 if ( p -> class == FFUNC || p -> class == FPROC ) { 109 tempdescrp = tmpalloc((long) (sizeof( struct formalrtn *)), 110 NLNIL, REGOK ); 111 putRV((char *) 0 , cbn , tempdescrp -> value[ NL_OFFS ] , 112 tempdescrp -> extra_flags , PCCTM_PTR|PCCT_STRTY ); 113 putRV((char *) 0 , psbn , p -> value[ NL_OFFS ] , 114 p -> extra_flags , PCCTM_PTR|PCCT_STRTY ); 115 putop( PCC_ASSIGN , PCCTM_PTR | PCCT_STRTY ); 116 } 117 /* 118 * if we have to store a temporary, 119 * temptype will be its type, 120 * otherwise, it's PCCT_UNDEF. 121 */ 122 temptype = PCCT_UNDEF; 123 if ( porf == FUNC ) { 124 p_type_width = width( p -> type ); 125 switch( p_type_class ) { 126 case TSTR: 127 case TSET: 128 case TREC: 129 case TFILE: 130 case TARY: 131 temptype = PCCT_STRTY; 132 p_type_align = align( p -> type ); 133 break; 134 default: 135 if ( p -> class == FFUNC ) { 136 temptype = p2type( p -> type ); 137 } 138 break; 139 } 140 if ( temptype != PCCT_UNDEF ) { 141 tempnlp = tmpalloc(p_type_width, p -> type, NOREG); 142 /* 143 * temp 144 * for (temp = ... 145 */ 146 putRV((char *) 0 , cbn , tempnlp -> value[ NL_OFFS ] , 147 tempnlp -> extra_flags , (int) temptype ); 148 } 149 } 150 switch ( p -> class ) { 151 case FUNC: 152 case PROC: 153 /* 154 * ... p( ... 155 */ 156 sextname( extname , p -> symbol , BLOCKNO(p -> nl_block) ); 157 putleaf( PCC_ICON , 0 , 0 , p2type( p ) , extname ); 158 break; 159 case FFUNC: 160 case FPROC: 161 162 /* 163 * ... ( t -> entryaddr )( ... 164 */ 165 /* the descriptor */ 166 putRV((char *) 0 , cbn , tempdescrp -> value[ NL_OFFS ] , 167 tempdescrp -> extra_flags , PCCTM_PTR | PCCT_STRTY ); 168 /* the entry address within the descriptor */ 169 if ( FENTRYOFFSET != 0 ) { 170 putleaf( PCC_ICON , FENTRYOFFSET , 0 , PCCT_INT , 171 (char *) 0 ); 172 putop( PCC_PLUS , 173 PCCM_ADDTYPE( 174 PCCM_ADDTYPE( PCCM_ADDTYPE( p2type( p ) , PCCTM_FTN ) , 175 PCCTM_PTR ) , 176 PCCTM_PTR ) ); 177 } 178 /* 179 * indirect to fetch the formal entry address 180 * with the result type of the routine. 181 */ 182 if (p -> class == FFUNC) { 183 putop( PCCOM_UNARY PCC_MUL , 184 PCCM_ADDTYPE(PCCM_ADDTYPE(p2type(p -> type), PCCTM_FTN), 185 PCCTM_PTR)); 186 } else { 187 /* procedures are int returning functions */ 188 putop( PCCOM_UNARY PCC_MUL , 189 PCCM_ADDTYPE(PCCM_ADDTYPE(PCCT_INT, PCCTM_FTN), PCCTM_PTR)); 190 } 191 break; 192 default: 193 panic("call class"); 194 } 195 noarguments = TRUE; 196 # endif PC 197 /* 198 * Loop and process each of 199 * arguments to the proc/func. 200 * ... ( ... args ... ) ... 201 */ 202 ptype = NIL; 203 for (p1 = plist(p); p1 != NLNIL; p1 = p1->chain) { 204 if (argv_node == TR_NIL) { 205 error("Not enough arguments to %s", p->symbol); 206 return (NLNIL); 207 } 208 switch (p1->class) { 209 case REF: 210 /* 211 * Var parameter 212 */ 213 rnode = argv_node->list_node.list; 214 if (rnode != TR_NIL && rnode->tag != T_VAR) { 215 error("Expression given (variable required) for var parameter %s of %s", p1->symbol, p->symbol); 216 chk = FALSE; 217 break; 218 } 219 q = lvalue( argv_node->list_node.list, 220 MOD | ASGN , LREQ ); 221 if (q == NIL) { 222 chk = FALSE; 223 break; 224 } 225 p2 = p1->type; 226 if (p2->chain->class != CRANGE) { 227 if (q != p2) { 228 error("Parameter type not identical to type of var parameter %s of %s", p1->symbol, p->symbol); 229 chk = FALSE; 230 } 231 break; 232 } else { 233 /* conformant array */ 234 if (p1 == ptype) { 235 if (q != ctype) { 236 error("Conformant array parameters in the same specification must be the same type."); 237 goto conf_err; 238 } 239 } else { 240 if (classify(q) != TARY && classify(q) != TSTR) { 241 error("Array type required for var parameter %s of %s",p1->symbol,p->symbol); 242 goto conf_err; 243 } 244 /* check base type of array */ 245 if (p2->type != q->type) { 246 error("Base type of array not identical to that of conformant array parameter %s of %s", p1->symbol, p->symbol); 247 goto conf_err; 248 } 249 if (p2->value[0] != q->value[0]) { 250 error("Subscript number mismatch on conformant array parameter %s of %s", p1->symbol, p->symbol); 251 /* Don't process array bounds & width */ 252 conf_err: if (p1->chain->type->class == CRANGE) { 253 d = p1->value[0]; 254 for (i = 1; i <= d; i++) { 255 /* for each subscript, pass by 256 * bounds and width 257 */ 258 p1 = p1->chain->chain->chain; 259 } 260 } 261 ptype = ctype = NLNIL; 262 chk = FALSE; 263 break; 264 } 265 /* 266 * Save array type for all parameters with same 267 * specification. 268 */ 269 ctype = q; 270 ptype = p2; 271 /* 272 * If at end of conformant array list, 273 * get bounds. 274 */ 275 if (p1->chain->type->class == CRANGE) { 276 /* check each subscript, put on stack */ 277 d = ptype->value[0]; 278 q = ctype; 279 for (i = 1; i <= d; i++) { 280 p1 = p1->chain; 281 q = q->chain; 282 if (incompat(q, p1->type, TR_NIL)){ 283 error("Subscript type not conformable with parameter %s of %s", p1->symbol, p->symbol); 284 chk = FALSE; 285 break; 286 } 287 /* Put lower and upper bound & width */ 288 # ifdef OBJ 289 if (q->type->class == CRANGE) { 290 putcbnds(q->type); 291 } else { 292 put(2, width(p1->type) <= 2 ? O_CON2 293 : O_CON4, q->range[0]); 294 put(2, width(p1->type) <= 2 ? O_CON2 295 : O_CON4, q->range[1]); 296 put(2, width(p1->type) <= 2 ? O_CON2 297 : O_CON4, aryconst(ctype,i)); 298 } 299 # endif OBJ 300 # ifdef PC 301 if (q->type->class == CRANGE) { 302 for (j = 1; j <= 3; j++) { 303 p2 = p->nptr[j]; 304 putRV(p2->symbol, (p2->nl_block 305 & 037), p2->value[0], 306 p2->extra_flags,p2type(p2)); 307 putop(PCC_CM, PCCT_INT); 308 } 309 } else { 310 putleaf(PCC_ICON, q->range[0], 0,PCCT_INT,0); 311 putop( PCC_CM , PCCT_INT ); 312 putleaf(PCC_ICON, q->range[1], 0,PCCT_INT,0); 313 putop( PCC_CM , PCCT_INT ); 314 putleaf(PCC_ICON,aryconst(ctype,i),0,PCCT_INT,0); 315 putop( PCC_CM , PCCT_INT ); 316 } 317 # endif PC 318 p1 = p1->chain->chain; 319 } 320 } 321 } 322 } 323 break; 324 case VAR: 325 /* 326 * Value parameter 327 */ 328 # ifdef OBJ 329 q = rvalue(argv_node->list_node.list, 330 p1->type , RREQ ); 331 # endif OBJ 332 # ifdef PC 333 /* 334 * structure arguments require lvalues, 335 * scalars use rvalue. 336 */ 337 switch( classify( p1 -> type ) ) { 338 case TFILE: 339 case TARY: 340 case TREC: 341 case TSET: 342 case TSTR: 343 q = stkrval(argv_node->list_node.list, 344 p1 -> type , (long) LREQ ); 345 break; 346 case TINT: 347 case TSCAL: 348 case TBOOL: 349 case TCHAR: 350 precheck( p1 -> type , "_RANG4" , "_RSNG4" ); 351 q = stkrval(argv_node->list_node.list, 352 p1 -> type , (long) RREQ ); 353 postcheck(p1 -> type, nl+T4INT); 354 break; 355 case TDOUBLE: 356 q = stkrval(argv_node->list_node.list, 357 p1 -> type , (long) RREQ ); 358 sconv(p2type(q), PCCT_DOUBLE); 359 break; 360 default: 361 q = rvalue(argv_node->list_node.list, 362 p1 -> type , RREQ ); 363 break; 364 } 365 # endif PC 366 if (q == NIL) { 367 chk = FALSE; 368 break; 369 } 370 if (incompat(q, p1->type, 371 argv_node->list_node.list)) { 372 cerror("Expression type clashed with type of value parameter %s of %s", p1->symbol, p->symbol); 373 chk = FALSE; 374 break; 375 } 376 # ifdef OBJ 377 if (isa(p1->type, "bcsi")) 378 rangechk(p1->type, q); 379 if (q->class != STR) 380 convert(q, p1->type); 381 # endif OBJ 382 # ifdef PC 383 switch( classify( p1 -> type ) ) { 384 case TFILE: 385 case TARY: 386 case TREC: 387 case TSET: 388 case TSTR: 389 putstrop( PCC_STARG 390 , p2type( p1 -> type ) 391 , (int) lwidth( p1 -> type ) 392 , align( p1 -> type ) ); 393 } 394 # endif PC 395 break; 396 case FFUNC: 397 /* 398 * function parameter 399 */ 400 q = flvalue(argv_node->list_node.list, p1 ); 401 /*chk = (chk && fcompat(q, p1));*/ 402 if ((chk) && (fcompat(q, p1))) 403 chk = TRUE; 404 else 405 chk = FALSE; 406 break; 407 case FPROC: 408 /* 409 * procedure parameter 410 */ 411 q = flvalue(argv_node->list_node.list, p1 ); 412 /* chk = (chk && fcompat(q, p1)); */ 413 if ((chk) && (fcompat(q, p1))) 414 chk = TRUE; 415 else chk = FALSE; 416 break; 417 default: 418 panic("call"); 419 } 420 # ifdef PC 421 /* 422 * if this is the nth (>1) argument, 423 * hang it on the left linear list of arguments 424 */ 425 if ( noarguments ) { 426 noarguments = FALSE; 427 } else { 428 putop( PCC_CM , PCCT_INT ); 429 } 430 # endif PC 431 argv_node = argv_node->list_node.next; 432 } 433 if (argv_node != TR_NIL) { 434 error("Too many arguments to %s", p->symbol); 435 rvlist(argv_node); 436 return (NLNIL); 437 } 438 if (chk == FALSE) 439 return NLNIL; 440 # ifdef OBJ 441 if ( p -> class == FFUNC || p -> class == FPROC ) { 442 (void) put(2, PTR_RV | psbn << 8+INDX, (int)p->value[NL_OFFS]); 443 (void) put(2, O_LV | cbn << 8 + INDX , 444 (int) savedispnp -> value[ NL_OFFS ] ); 445 (void) put(1, O_FCALL); 446 (void) put(2, O_FRTN, even(width(p->type))); 447 } else { 448 (void) put(2, O_CALL | psbn << 8, (long)p->value[NL_ENTLOC]); 449 } 450 # endif OBJ 451 # ifdef PC 452 /* 453 * for formal calls: add the hidden argument 454 * which is the formal struct describing the 455 * environment of the routine. 456 * and the argument which is the address of the 457 * space into which to save the display. 458 */ 459 if ( p -> class == FFUNC || p -> class == FPROC ) { 460 putRV((char *) 0 , cbn , tempdescrp -> value[ NL_OFFS ] , 461 tempdescrp -> extra_flags , PCCTM_PTR|PCCT_STRTY ); 462 if ( !noarguments ) { 463 putop( PCC_CM , PCCT_INT ); 464 } 465 noarguments = FALSE; 466 putLV((char *) 0 , cbn , savedispnp -> value[ NL_OFFS ] , 467 savedispnp -> extra_flags , PCCTM_PTR | PCCT_STRTY ); 468 putop( PCC_CM , PCCT_INT ); 469 } 470 /* 471 * do the actual call: 472 * either ... p( ... ) ... 473 * or ... ( t -> entryaddr )( ... ) ... 474 * and maybe an assignment. 475 */ 476 if ( porf == FUNC ) { 477 switch ( p_type_class ) { 478 case TBOOL: 479 case TCHAR: 480 case TINT: 481 case TSCAL: 482 case TDOUBLE: 483 case TPTR: 484 putop( ( noarguments ? PCCOM_UNARY PCC_CALL : PCC_CALL ) , 485 (int) p_type_p2type ); 486 if ( p -> class == FFUNC ) { 487 putop( PCC_ASSIGN , (int) p_type_p2type ); 488 } 489 break; 490 default: 491 putstrop( ( noarguments ? PCCOM_UNARY PCC_STCALL : PCC_STCALL ), 492 (int) PCCM_ADDTYPE( p_type_p2type , PCCTM_PTR ) , 493 (int) p_type_width ,(int) p_type_align ); 494 putstrop(PCC_STASG, (int) PCCM_ADDTYPE(p_type_p2type, PCCTM_PTR), 495 (int) lwidth(p -> type), align(p -> type)); 496 break; 497 } 498 } else { 499 putop( ( noarguments ? PCCOM_UNARY PCC_CALL : PCC_CALL ) , PCCT_INT ); 500 } 501 /* 502 * ( t=p , ... , FRTN( t ) ... 503 */ 504 if ( p -> class == FFUNC || p -> class == FPROC ) { 505 putop( PCC_COMOP , PCCT_INT ); 506 putleaf( PCC_ICON , 0 , 0 , PCCM_ADDTYPE( PCCTM_FTN | PCCT_INT , PCCTM_PTR ) , 507 "_FRTN" ); 508 putRV((char *) 0 , cbn , tempdescrp -> value[ NL_OFFS ] , 509 tempdescrp -> extra_flags , PCCTM_PTR | PCCT_STRTY ); 510 putLV((char *) 0 , cbn , savedispnp -> value[ NL_OFFS ] , 511 savedispnp -> extra_flags , PCCTM_PTR | PCCT_STRTY ); 512 putop( PCC_CM , PCCT_INT ); 513 putop( PCC_CALL , PCCT_INT ); 514 putop( PCC_COMOP , PCCT_INT ); 515 } 516 /* 517 * if required: 518 * either ... , temp ) 519 * or ... , &temp ) 520 */ 521 if ( porf == FUNC && temptype != PCCT_UNDEF ) { 522 if ( temptype != PCCT_STRTY ) { 523 putRV((char *) 0 , cbn , tempnlp -> value[ NL_OFFS ] , 524 tempnlp -> extra_flags , (int) p_type_p2type ); 525 } else { 526 putLV((char *) 0 , cbn , tempnlp -> value[ NL_OFFS ] , 527 tempnlp -> extra_flags , (int) p_type_p2type ); 528 } 529 putop( PCC_COMOP , PCCT_INT ); 530 } 531 if ( porf == PROC ) { 532 putdot( filename , line ); 533 } 534 # endif PC 535 return (p->type); 536 } 537 538 rvlist(al) 539 register struct tnode *al; 540 { 541 542 for (; al != TR_NIL; al = al->list_node.next) 543 (void) rvalue( al->list_node.list, NLNIL , RREQ ); 544 } 545 546 /* 547 * check that two function/procedure namelist entries are compatible 548 */ 549 bool 550 fcompat( formal , actual ) 551 struct nl *formal; 552 struct nl *actual; 553 { 554 register struct nl *f_chain; 555 register struct nl *a_chain; 556 extern struct nl *plist(); 557 bool compat = TRUE; 558 559 if ( formal == NLNIL || actual == NLNIL ) { 560 return FALSE; 561 } 562 for (a_chain = plist(actual), f_chain = plist(formal); 563 f_chain != NLNIL; 564 f_chain = f_chain->chain, a_chain = a_chain->chain) { 565 if (a_chain == NIL) { 566 error("%s %s declared on line %d has more arguments than", 567 parnam(formal->class), formal->symbol, 568 (char *) linenum(formal)); 569 cerror("%s %s declared on line %d", 570 parnam(actual->class), actual->symbol, 571 (char *) linenum(actual)); 572 return FALSE; 573 } 574 if ( a_chain -> class != f_chain -> class ) { 575 error("%s parameter %s of %s declared on line %d is not identical", 576 parnam(f_chain->class), f_chain->symbol, 577 formal->symbol, (char *) linenum(formal)); 578 cerror("with %s parameter %s of %s declared on line %d", 579 parnam(a_chain->class), a_chain->symbol, 580 actual->symbol, (char *) linenum(actual)); 581 compat = FALSE; 582 } else if (a_chain->class == FFUNC || a_chain->class == FPROC) { 583 /*compat = (compat && fcompat(f_chain, a_chain));*/ 584 if ((compat) && (fcompat(f_chain, a_chain))) 585 compat = TRUE; 586 else compat = FALSE; 587 } 588 if ((a_chain->class != FPROC && f_chain->class != FPROC) && 589 (a_chain->type != f_chain->type)) { 590 error("Type of %s parameter %s of %s declared on line %d is not identical", 591 parnam(f_chain->class), f_chain->symbol, 592 formal->symbol, (char *) linenum(formal)); 593 cerror("to type of %s parameter %s of %s declared on line %d", 594 parnam(a_chain->class), a_chain->symbol, 595 actual->symbol, (char *) linenum(actual)); 596 compat = FALSE; 597 } 598 } 599 if (a_chain != NIL) { 600 error("%s %s declared on line %d has fewer arguments than", 601 parnam(formal->class), formal->symbol, 602 (char *) linenum(formal)); 603 cerror("%s %s declared on line %d", 604 parnam(actual->class), actual->symbol, 605 (char *) linenum(actual)); 606 return FALSE; 607 } 608 return compat; 609 } 610 611 char * 612 parnam(nltype) 613 int nltype; 614 { 615 switch(nltype) { 616 case REF: 617 return "var"; 618 case VAR: 619 return "value"; 620 case FUNC: 621 case FFUNC: 622 return "function"; 623 case PROC: 624 case FPROC: 625 return "procedure"; 626 default: 627 return "SNARK"; 628 } 629 } 630 631 struct nl *plist(p) 632 struct nl *p; 633 { 634 switch (p->class) { 635 case FFUNC: 636 case FPROC: 637 return p->ptr[ NL_FCHAIN ]; 638 case PROC: 639 case FUNC: 640 return p->chain; 641 default: 642 { 643 panic("plist"); 644 return(NLNIL); /* this is here only so lint won't complain 645 panic actually aborts */ 646 } 647 648 } 649 } 650 651 linenum(p) 652 struct nl *p; 653 { 654 if (p->class == FUNC) 655 return p->ptr[NL_FVAR]->value[NL_LINENO]; 656 return p->value[NL_LINENO]; 657 } 658