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