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