1 /* Copyright (c) 1979 Regents of the University of California */ 2 3 #ifndef lint 4 static char sccsid[] = "@(#)call.c 1.26 09/19/83"; 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 "pcops.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; 61 struct tnode *rnode; 62 bool chk = TRUE; 63 struct nl *savedispnp; /* temporary to hold saved display */ 64 # ifdef PC 65 int p_type_class = classify( p -> type ); 66 long p_type_p2type = p2type( p -> type ); 67 bool noarguments; 68 /* 69 * these get used if temporaries and structures are used 70 */ 71 struct nl *tempnlp; 72 long temptype; /* type of the temporary */ 73 long p_type_width; 74 long p_type_align; 75 char extname[ BUFSIZ ]; 76 struct nl *tempdescrp; 77 # endif PC 78 79 if (p->class == FFUNC || p->class == FPROC) { 80 /* 81 * allocate space to save the display for formal calls 82 */ 83 savedispnp = tmpalloc( (long) sizeof display , NLNIL , NOREG ); 84 } 85 # ifdef OBJ 86 if (p->class == FFUNC || p->class == FPROC) { 87 (void) put(2, O_LV | cbn << 8 + INDX , 88 (int) savedispnp -> value[ NL_OFFS ] ); 89 (void) put(2, PTR_RV | psbn << 8+INDX, (int)p->value[NL_OFFS]); 90 } 91 if (porf == FUNC) { 92 /* 93 * Push some space 94 * for the function return type 95 */ 96 (void) put(2, O_PUSH, leven(-lwidth(p->type))); 97 } 98 # endif OBJ 99 # ifdef PC 100 /* 101 * if this is a formal call, 102 * stash the address of the descriptor 103 * in a temporary so we can find it 104 * after the FCALL for the call to FRTN 105 */ 106 if ( p -> class == FFUNC || p -> class == FPROC ) { 107 tempdescrp = tmpalloc((long) (sizeof( struct formalrtn *)), 108 NLNIL, REGOK ); 109 putRV((char *) 0 , cbn , tempdescrp -> value[ NL_OFFS ] , 110 tempdescrp -> extra_flags , P2PTR|P2STRTY ); 111 putRV((char *) 0 , psbn , p -> value[ NL_OFFS ] , 112 p -> extra_flags , P2PTR|P2STRTY ); 113 putop( P2ASSIGN , P2PTR | P2STRTY ); 114 } 115 /* 116 * if we have to store a temporary, 117 * temptype will be its type, 118 * otherwise, it's P2UNDEF. 119 */ 120 temptype = P2UNDEF; 121 if ( porf == FUNC ) { 122 p_type_width = width( p -> type ); 123 switch( p_type_class ) { 124 case TSTR: 125 case TSET: 126 case TREC: 127 case TFILE: 128 case TARY: 129 temptype = P2STRTY; 130 p_type_align = align( p -> type ); 131 break; 132 default: 133 if ( p -> class == FFUNC ) { 134 temptype = p2type( p -> type ); 135 } 136 break; 137 } 138 if ( temptype != P2UNDEF ) { 139 tempnlp = tmpalloc(p_type_width, p -> type, NOREG); 140 /* 141 * temp 142 * for (temp = ... 143 */ 144 putRV((char *) 0 , cbn , tempnlp -> value[ NL_OFFS ] , 145 tempnlp -> extra_flags , (int) temptype ); 146 } 147 } 148 switch ( p -> class ) { 149 case FUNC: 150 case PROC: 151 /* 152 * ... p( ... 153 */ 154 sextname( extname , p -> symbol , BLOCKNO(p -> nl_block) ); 155 putleaf( P2ICON , 0 , 0 , p2type( p ) , extname ); 156 break; 157 case FFUNC: 158 case FPROC: 159 160 /* 161 * ... ( t -> entryaddr )( ... 162 */ 163 /* the descriptor */ 164 putRV((char *) 0 , cbn , tempdescrp -> value[ NL_OFFS ] , 165 tempdescrp -> extra_flags , P2PTR | P2STRTY ); 166 /* the entry address within the descriptor */ 167 if ( FENTRYOFFSET != 0 ) { 168 putleaf( P2ICON , FENTRYOFFSET , 0 , P2INT , 169 (char *) 0 ); 170 putop( P2PLUS , 171 ADDTYPE( 172 ADDTYPE( ADDTYPE( p2type( p ) , P2FTN ) , 173 P2PTR ) , 174 P2PTR ) ); 175 } 176 /* 177 * indirect to fetch the formal entry address 178 * with the result type of the routine. 179 */ 180 if (p -> class == FFUNC) { 181 putop( P2UNARY P2MUL , 182 ADDTYPE(ADDTYPE(p2type(p -> type), P2FTN), 183 P2PTR)); 184 } else { 185 /* procedures are int returning functions */ 186 putop( P2UNARY P2MUL , 187 ADDTYPE(ADDTYPE(P2INT, P2FTN), P2PTR)); 188 } 189 break; 190 default: 191 panic("call class"); 192 } 193 noarguments = TRUE; 194 # endif PC 195 /* 196 * Loop and process each of 197 * arguments to the proc/func. 198 * ... ( ... args ... ) ... 199 */ 200 for (p1 = plist(p); p1 != NLNIL; p1 = p1->chain) { 201 if (argv_node == TR_NIL) { 202 error("Not enough arguments to %s", p->symbol); 203 return (NLNIL); 204 } 205 switch (p1->class) { 206 case REF: 207 /* 208 * Var parameter 209 */ 210 rnode = argv_node->list_node.list; 211 if (rnode != TR_NIL && rnode->tag != T_VAR) { 212 error("Expression given (variable required) for var parameter %s of %s", p1->symbol, p->symbol); 213 chk = FALSE; 214 break; 215 } 216 q = lvalue( argv_node->list_node.list, 217 MOD | ASGN , LREQ ); 218 if (q == NIL) { 219 chk = FALSE; 220 break; 221 } 222 if (q != p1->type) { 223 error("Parameter type not identical to type of var parameter %s of %s", p1->symbol, p->symbol); 224 chk = FALSE; 225 break; 226 } 227 break; 228 case VAR: 229 /* 230 * Value parameter 231 */ 232 # ifdef OBJ 233 q = rvalue(argv_node->list_node.list, 234 p1->type , RREQ ); 235 # endif OBJ 236 # ifdef PC 237 /* 238 * structure arguments require lvalues, 239 * scalars use rvalue. 240 */ 241 switch( classify( p1 -> type ) ) { 242 case TFILE: 243 case TARY: 244 case TREC: 245 case TSET: 246 case TSTR: 247 q = stkrval(argv_node->list_node.list, 248 p1 -> type , (long) LREQ ); 249 break; 250 case TINT: 251 case TSCAL: 252 case TBOOL: 253 case TCHAR: 254 precheck( p1 -> type , "_RANG4" , "_RSNG4" ); 255 q = stkrval(argv_node->list_node.list, 256 p1 -> type , (long) RREQ ); 257 postcheck(p1 -> type, nl+T4INT); 258 break; 259 case TDOUBLE: 260 q = stkrval(argv_node->list_node.list, 261 p1 -> type , (long) RREQ ); 262 sconv(p2type(q), P2DOUBLE); 263 break; 264 default: 265 q = rvalue(argv_node->list_node.list, 266 p1 -> type , RREQ ); 267 break; 268 } 269 # endif PC 270 if (q == NIL) { 271 chk = FALSE; 272 break; 273 } 274 if (incompat(q, p1->type, 275 argv_node->list_node.list)) { 276 cerror("Expression type clashed with type of value parameter %s of %s", p1->symbol, p->symbol); 277 chk = FALSE; 278 break; 279 } 280 # ifdef OBJ 281 if (isa(p1->type, "bcsi")) 282 rangechk(p1->type, q); 283 if (q->class != STR) 284 convert(q, p1->type); 285 # endif OBJ 286 # ifdef PC 287 switch( classify( p1 -> type ) ) { 288 case TFILE: 289 case TARY: 290 case TREC: 291 case TSET: 292 case TSTR: 293 putstrop( P2STARG 294 , p2type( p1 -> type ) 295 , (int) lwidth( p1 -> type ) 296 , align( p1 -> type ) ); 297 } 298 # endif PC 299 break; 300 case FFUNC: 301 /* 302 * function parameter 303 */ 304 q = flvalue(argv_node->list_node.list, p1 ); 305 /*chk = (chk && fcompat(q, p1));*/ 306 if ((chk) && (fcompat(q, p1))) 307 chk = TRUE; 308 else 309 chk = FALSE; 310 break; 311 case FPROC: 312 /* 313 * procedure parameter 314 */ 315 q = flvalue(argv_node->list_node.list, p1 ); 316 /* chk = (chk && fcompat(q, p1)); */ 317 if ((chk) && (fcompat(q, p1))) 318 chk = TRUE; 319 else chk = FALSE; 320 break; 321 default: 322 panic("call"); 323 } 324 # ifdef PC 325 /* 326 * if this is the nth (>1) argument, 327 * hang it on the left linear list of arguments 328 */ 329 if ( noarguments ) { 330 noarguments = FALSE; 331 } else { 332 putop( P2LISTOP , P2INT ); 333 } 334 # endif PC 335 argv_node = argv_node->list_node.next; 336 } 337 if (argv_node != TR_NIL) { 338 error("Too many arguments to %s", p->symbol); 339 rvlist(argv_node); 340 return (NLNIL); 341 } 342 if (chk == FALSE) 343 return NLNIL; 344 # ifdef OBJ 345 if ( p -> class == FFUNC || p -> class == FPROC ) { 346 (void) put(2, PTR_RV | psbn << 8+INDX, (int)p->value[NL_OFFS]); 347 (void) put(2, O_LV | cbn << 8 + INDX , 348 (int) savedispnp -> value[ NL_OFFS ] ); 349 (void) put(1, O_FCALL); 350 (void) put(2, O_FRTN, even(width(p->type))); 351 } else { 352 (void) put(2, O_CALL | psbn << 8, (long)p->value[NL_ENTLOC]); 353 } 354 # endif OBJ 355 # ifdef PC 356 /* 357 * for formal calls: add the hidden argument 358 * which is the formal struct describing the 359 * environment of the routine. 360 * and the argument which is the address of the 361 * space into which to save the display. 362 */ 363 if ( p -> class == FFUNC || p -> class == FPROC ) { 364 putRV((char *) 0 , cbn , tempdescrp -> value[ NL_OFFS ] , 365 tempdescrp -> extra_flags , P2PTR|P2STRTY ); 366 if ( !noarguments ) { 367 putop( P2LISTOP , P2INT ); 368 } 369 noarguments = FALSE; 370 putLV((char *) 0 , cbn , savedispnp -> value[ NL_OFFS ] , 371 savedispnp -> extra_flags , P2PTR | P2STRTY ); 372 putop( P2LISTOP , P2INT ); 373 } 374 /* 375 * do the actual call: 376 * either ... p( ... ) ... 377 * or ... ( t -> entryaddr )( ... ) ... 378 * and maybe an assignment. 379 */ 380 if ( porf == FUNC ) { 381 switch ( p_type_class ) { 382 case TBOOL: 383 case TCHAR: 384 case TINT: 385 case TSCAL: 386 case TDOUBLE: 387 case TPTR: 388 putop( ( noarguments ? P2UNARY P2CALL : P2CALL ) , 389 (int) p_type_p2type ); 390 if ( p -> class == FFUNC ) { 391 putop( P2ASSIGN , (int) p_type_p2type ); 392 } 393 break; 394 default: 395 putstrop( ( noarguments ? P2UNARY P2STCALL : P2STCALL ), 396 (int) ADDTYPE( p_type_p2type , P2PTR ) , 397 (int) p_type_width ,(int) p_type_align ); 398 putstrop(P2STASG, (int) ADDTYPE(p_type_p2type, P2PTR), 399 (int) lwidth(p -> type), align(p -> type)); 400 break; 401 } 402 } else { 403 putop( ( noarguments ? P2UNARY P2CALL : P2CALL ) , P2INT ); 404 } 405 /* 406 * ( t=p , ... , FRTN( t ) ... 407 */ 408 if ( p -> class == FFUNC || p -> class == FPROC ) { 409 putop( P2COMOP , P2INT ); 410 putleaf( P2ICON , 0 , 0 , ADDTYPE( P2FTN | P2INT , P2PTR ) , 411 "_FRTN" ); 412 putRV((char *) 0 , cbn , tempdescrp -> value[ NL_OFFS ] , 413 tempdescrp -> extra_flags , P2PTR | P2STRTY ); 414 putLV((char *) 0 , cbn , savedispnp -> value[ NL_OFFS ] , 415 savedispnp -> extra_flags , P2PTR | P2STRTY ); 416 putop( P2LISTOP , P2INT ); 417 putop( P2CALL , P2INT ); 418 putop( P2COMOP , P2INT ); 419 } 420 /* 421 * if required: 422 * either ... , temp ) 423 * or ... , &temp ) 424 */ 425 if ( porf == FUNC && temptype != P2UNDEF ) { 426 if ( temptype != P2STRTY ) { 427 putRV((char *) 0 , cbn , tempnlp -> value[ NL_OFFS ] , 428 tempnlp -> extra_flags , (int) p_type_p2type ); 429 } else { 430 putLV((char *) 0 , cbn , tempnlp -> value[ NL_OFFS ] , 431 tempnlp -> extra_flags , (int) p_type_p2type ); 432 } 433 putop( P2COMOP , P2INT ); 434 } 435 if ( porf == PROC ) { 436 putdot( filename , line ); 437 } 438 # endif PC 439 return (p->type); 440 } 441 442 rvlist(al) 443 register struct tnode *al; 444 { 445 446 for (; al != TR_NIL; al = al->list_node.next) 447 (void) rvalue( al->list_node.list, NLNIL , RREQ ); 448 } 449 450 /* 451 * check that two function/procedure namelist entries are compatible 452 */ 453 bool 454 fcompat( formal , actual ) 455 struct nl *formal; 456 struct nl *actual; 457 { 458 register struct nl *f_chain; 459 register struct nl *a_chain; 460 extern struct nl *plist(); 461 bool compat = TRUE; 462 463 if ( formal == NLNIL || actual == NLNIL ) { 464 return FALSE; 465 } 466 for (a_chain = plist(actual), f_chain = plist(formal); 467 f_chain != NLNIL; 468 f_chain = f_chain->chain, a_chain = a_chain->chain) { 469 if (a_chain == NIL) { 470 error("%s %s declared on line %d has more arguments than", 471 parnam(formal->class), formal->symbol, 472 (char *) linenum(formal)); 473 cerror("%s %s declared on line %d", 474 parnam(actual->class), actual->symbol, 475 (char *) linenum(actual)); 476 return FALSE; 477 } 478 if ( a_chain -> class != f_chain -> class ) { 479 error("%s parameter %s of %s declared on line %d is not identical", 480 parnam(f_chain->class), f_chain->symbol, 481 formal->symbol, (char *) linenum(formal)); 482 cerror("with %s parameter %s of %s declared on line %d", 483 parnam(a_chain->class), a_chain->symbol, 484 actual->symbol, (char *) linenum(actual)); 485 compat = FALSE; 486 } else if (a_chain->class == FFUNC || a_chain->class == FPROC) { 487 /*compat = (compat && fcompat(f_chain, a_chain));*/ 488 if ((compat) && (fcompat(f_chain, a_chain))) 489 compat = TRUE; 490 else compat = FALSE; 491 } 492 if ((a_chain->class != FPROC && f_chain->class != FPROC) && 493 (a_chain->type != f_chain->type)) { 494 error("Type of %s parameter %s of %s declared on line %d is not identical", 495 parnam(f_chain->class), f_chain->symbol, 496 formal->symbol, (char *) linenum(formal)); 497 cerror("to type of %s parameter %s of %s declared on line %d", 498 parnam(a_chain->class), a_chain->symbol, 499 actual->symbol, (char *) linenum(actual)); 500 compat = FALSE; 501 } 502 } 503 if (a_chain != NIL) { 504 error("%s %s declared on line %d has fewer arguments than", 505 parnam(formal->class), formal->symbol, 506 (char *) linenum(formal)); 507 cerror("%s %s declared on line %d", 508 parnam(actual->class), actual->symbol, 509 (char *) linenum(actual)); 510 return FALSE; 511 } 512 return compat; 513 } 514 515 char * 516 parnam(nltype) 517 int nltype; 518 { 519 switch(nltype) { 520 case REF: 521 return "var"; 522 case VAR: 523 return "value"; 524 case FUNC: 525 case FFUNC: 526 return "function"; 527 case PROC: 528 case FPROC: 529 return "procedure"; 530 default: 531 return "SNARK"; 532 } 533 } 534 535 struct nl *plist(p) 536 struct nl *p; 537 { 538 switch (p->class) { 539 case FFUNC: 540 case FPROC: 541 return p->ptr[ NL_FCHAIN ]; 542 case PROC: 543 case FUNC: 544 return p->chain; 545 default: 546 { 547 panic("plist"); 548 return(NLNIL); /* this is here only so lint won't complain 549 panic actually aborts */ 550 } 551 552 } 553 } 554 555 linenum(p) 556 struct nl *p; 557 { 558 if (p->class == FUNC) 559 return p->ptr[NL_FVAR]->value[NL_LINENO]; 560 return p->value[NL_LINENO]; 561 } 562