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