1 /* Copyright (c) 1979 Regents of the University of California */ 2 3 static char sccsid[] = "@(#)call.c 1.23 04/06/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 putRV( 0 , cbn , tempdescrp -> value[ NL_OFFS ] , 163 tempdescrp -> extra_flags , P2PTR | P2STRTY ); 164 if ( FENTRYOFFSET != 0 ) { 165 putleaf( P2ICON , FENTRYOFFSET , 0 , P2INT , 0 ); 166 putop( P2PLUS , 167 ADDTYPE( 168 ADDTYPE( ADDTYPE( p2type( p ) , P2FTN ) , 169 P2PTR ) , 170 P2PTR ) ); 171 } 172 putop( P2UNARY P2MUL , 173 ADDTYPE( ADDTYPE( p2type( p ) , P2FTN ) , P2PTR ) ); 174 break; 175 default: 176 panic("call class"); 177 } 178 noarguments = TRUE; 179 # endif PC 180 /* 181 * Loop and process each of 182 * arguments to the proc/func. 183 * ... ( ... args ... ) ... 184 */ 185 for (p1 = plist(p); p1 != NIL; p1 = p1->chain) { 186 if (argv == NIL) { 187 error("Not enough arguments to %s", p->symbol); 188 return (NIL); 189 } 190 switch (p1->class) { 191 case REF: 192 /* 193 * Var parameter 194 */ 195 r = argv[1]; 196 if (r != NIL && r[0] != T_VAR) { 197 error("Expression given (variable required) for var parameter %s of %s", p1->symbol, p->symbol); 198 chk = FALSE; 199 break; 200 } 201 q = lvalue( (int *) argv[1], MOD | ASGN , LREQ ); 202 if (q == NIL) { 203 chk = FALSE; 204 break; 205 } 206 if (q != p1->type) { 207 error("Parameter type not identical to type of var parameter %s of %s", p1->symbol, p->symbol); 208 chk = FALSE; 209 break; 210 } 211 break; 212 case VAR: 213 /* 214 * Value parameter 215 */ 216 # ifdef OBJ 217 q = rvalue(argv[1], p1->type , RREQ ); 218 # endif OBJ 219 # ifdef PC 220 /* 221 * structure arguments require lvalues, 222 * scalars use rvalue. 223 */ 224 switch( classify( p1 -> type ) ) { 225 case TFILE: 226 case TARY: 227 case TREC: 228 case TSET: 229 case TSTR: 230 q = stkrval( argv[1] , p1 -> type , LREQ ); 231 break; 232 case TINT: 233 case TSCAL: 234 case TBOOL: 235 case TCHAR: 236 precheck( p1 -> type , "_RANG4" , "_RSNG4" ); 237 q = stkrval( argv[1] , p1 -> type , RREQ ); 238 postcheck(p1 -> type, nl+T4INT); 239 break; 240 case TDOUBLE: 241 q = stkrval( argv[1] , p1 -> type , RREQ ); 242 sconv(p2type(q), P2DOUBLE); 243 break; 244 default: 245 q = rvalue( argv[1] , p1 -> type , RREQ ); 246 break; 247 } 248 # endif PC 249 if (q == NIL) { 250 chk = FALSE; 251 break; 252 } 253 if (incompat(q, p1->type, argv[1])) { 254 cerror("Expression type clashed with type of value parameter %s of %s", p1->symbol, p->symbol); 255 chk = FALSE; 256 break; 257 } 258 # ifdef OBJ 259 if (isa(p1->type, "bcsi")) 260 rangechk(p1->type, q); 261 if (q->class != STR) 262 convert(q, p1->type); 263 # endif OBJ 264 # ifdef PC 265 switch( classify( p1 -> type ) ) { 266 case TFILE: 267 case TARY: 268 case TREC: 269 case TSET: 270 case TSTR: 271 putstrop( P2STARG 272 , p2type( p1 -> type ) 273 , lwidth( p1 -> type ) 274 , align( p1 -> type ) ); 275 } 276 # endif PC 277 break; 278 case FFUNC: 279 /* 280 * function parameter 281 */ 282 q = flvalue( (int *) argv[1] , p1 ); 283 chk = (chk && fcompat(q, p1)); 284 break; 285 case FPROC: 286 /* 287 * procedure parameter 288 */ 289 q = flvalue( (int *) argv[1] , p1 ); 290 chk = (chk && fcompat(q, p1)); 291 break; 292 default: 293 panic("call"); 294 } 295 # ifdef PC 296 /* 297 * if this is the nth (>1) argument, 298 * hang it on the left linear list of arguments 299 */ 300 if ( noarguments ) { 301 noarguments = FALSE; 302 } else { 303 putop( P2LISTOP , P2INT ); 304 } 305 # endif PC 306 argv = argv[2]; 307 } 308 if (argv != NIL) { 309 error("Too many arguments to %s", p->symbol); 310 rvlist(argv); 311 return (NIL); 312 } 313 if (chk == FALSE) 314 return NIL; 315 # ifdef OBJ 316 if ( p -> class == FFUNC || p -> class == FPROC ) { 317 put(2, PTR_RV | psbn << 8+INDX, (int)p->value[NL_OFFS]); 318 put(2, O_LV | cbn << 8 + INDX , 319 (int) savedispnp -> value[ NL_OFFS ] ); 320 put(1, O_FCALL); 321 put(2, O_FRTN, even(width(p->type))); 322 } else { 323 put(2, O_CALL | psbn << 8, (long)p->value[NL_ENTLOC]); 324 } 325 # endif OBJ 326 # ifdef PC 327 /* 328 * for formal calls: add the hidden argument 329 * which is the formal struct describing the 330 * environment of the routine. 331 * and the argument which is the address of the 332 * space into which to save the display. 333 */ 334 if ( p -> class == FFUNC || p -> class == FPROC ) { 335 putRV( 0 , cbn , tempdescrp -> value[ NL_OFFS ] , 336 tempdescrp -> extra_flags , P2PTR|P2STRTY ); 337 if ( !noarguments ) { 338 putop( P2LISTOP , P2INT ); 339 } 340 noarguments = FALSE; 341 putLV( 0 , cbn , savedispnp -> value[ NL_OFFS ] , 342 savedispnp -> extra_flags , P2PTR | P2STRTY ); 343 putop( P2LISTOP , P2INT ); 344 } 345 /* 346 * do the actual call: 347 * either ... p( ... ) ... 348 * or ... ( t -> entryaddr )( ... ) ... 349 * and maybe an assignment. 350 */ 351 if ( porf == FUNC ) { 352 switch ( p_type_class ) { 353 case TBOOL: 354 case TCHAR: 355 case TINT: 356 case TSCAL: 357 case TDOUBLE: 358 case TPTR: 359 putop( ( noarguments ? P2UNARY P2CALL : P2CALL ) , 360 p_type_p2type ); 361 if ( p -> class == FFUNC ) { 362 putop( P2ASSIGN , p_type_p2type ); 363 } 364 break; 365 default: 366 putstrop( ( noarguments ? P2UNARY P2STCALL : P2STCALL ), 367 ADDTYPE( p_type_p2type , P2PTR ) , 368 p_type_width , p_type_align ); 369 putstrop(P2STASG, ADDTYPE(p_type_p2type, P2PTR), 370 lwidth(p -> type), align(p -> type)); 371 break; 372 } 373 } else { 374 putop( ( noarguments ? P2UNARY P2CALL : P2CALL ) , P2INT ); 375 } 376 /* 377 * ( t=p , ... , FRTN( t ) ... 378 */ 379 if ( p -> class == FFUNC || p -> class == FPROC ) { 380 putop( P2COMOP , P2INT ); 381 putleaf( P2ICON , 0 , 0 , ADDTYPE( P2FTN | P2INT , P2PTR ) , 382 "_FRTN" ); 383 putRV( 0 , cbn , tempdescrp -> value[ NL_OFFS ] , 384 tempdescrp -> extra_flags , P2PTR | P2STRTY ); 385 putLV( 0 , cbn , savedispnp -> value[ NL_OFFS ] , 386 savedispnp -> extra_flags , P2PTR | P2STRTY ); 387 putop( P2LISTOP , P2INT ); 388 putop( P2CALL , P2INT ); 389 putop( P2COMOP , P2INT ); 390 } 391 /* 392 * if required: 393 * either ... , temp ) 394 * or ... , &temp ) 395 */ 396 if ( porf == FUNC && temptype != P2UNDEF ) { 397 if ( temptype != P2STRTY ) { 398 putRV( 0 , cbn , tempnlp -> value[ NL_OFFS ] , 399 tempnlp -> extra_flags , p_type_p2type ); 400 } else { 401 putLV( 0 , cbn , tempnlp -> value[ NL_OFFS ] , 402 tempnlp -> extra_flags , p_type_p2type ); 403 } 404 putop( P2COMOP , P2INT ); 405 } 406 if ( porf == PROC ) { 407 putdot( filename , line ); 408 } 409 # endif PC 410 return (p->type); 411 } 412 413 rvlist(al) 414 register int *al; 415 { 416 417 for (; al != NIL; al = al[2]) 418 rvalue( (int *) al[1], NLNIL , RREQ ); 419 } 420 421 /* 422 * check that two function/procedure namelist entries are compatible 423 */ 424 bool 425 fcompat( formal , actual ) 426 struct nl *formal; 427 struct nl *actual; 428 { 429 register struct nl *f_chain; 430 register struct nl *a_chain; 431 bool compat = TRUE; 432 433 if ( formal == NIL || actual == NIL ) { 434 return FALSE; 435 } 436 for (a_chain = plist(actual), f_chain = plist(formal); 437 f_chain != NIL; 438 f_chain = f_chain->chain, a_chain = a_chain->chain) { 439 if (a_chain == NIL) { 440 error("%s %s declared on line %d has more arguments than", 441 parnam(formal->class), formal->symbol, 442 linenum(formal)); 443 cerror("%s %s declared on line %d", 444 parnam(actual->class), actual->symbol, 445 linenum(actual)); 446 return FALSE; 447 } 448 if ( a_chain -> class != f_chain -> class ) { 449 error("%s parameter %s of %s declared on line %d is not identical", 450 parnam(f_chain->class), f_chain->symbol, 451 formal->symbol, linenum(formal)); 452 cerror("with %s parameter %s of %s declared on line %d", 453 parnam(a_chain->class), a_chain->symbol, 454 actual->symbol, linenum(actual)); 455 compat = FALSE; 456 } else if (a_chain->class == FFUNC || a_chain->class == FPROC) { 457 compat = (compat && fcompat(f_chain, a_chain)); 458 } 459 if ((a_chain->class != FPROC && f_chain->class != FPROC) && 460 (a_chain->type != f_chain->type)) { 461 error("Type of %s parameter %s of %s declared on line %d is not identical", 462 parnam(f_chain->class), f_chain->symbol, 463 formal->symbol, linenum(formal)); 464 cerror("to type of %s parameter %s of %s declared on line %d", 465 parnam(a_chain->class), a_chain->symbol, 466 actual->symbol, linenum(actual)); 467 compat = FALSE; 468 } 469 } 470 if (a_chain != NIL) { 471 error("%s %s declared on line %d has fewer arguments than", 472 parnam(formal->class), formal->symbol, 473 linenum(formal)); 474 cerror("%s %s declared on line %d", 475 parnam(actual->class), actual->symbol, 476 linenum(actual)); 477 return FALSE; 478 } 479 return compat; 480 } 481 482 char * 483 parnam(nltype) 484 int nltype; 485 { 486 switch(nltype) { 487 case REF: 488 return "var"; 489 case VAR: 490 return "value"; 491 case FUNC: 492 case FFUNC: 493 return "function"; 494 case PROC: 495 case FPROC: 496 return "procedure"; 497 default: 498 return "SNARK"; 499 } 500 } 501 502 plist(p) 503 struct nl *p; 504 { 505 switch (p->class) { 506 case FFUNC: 507 case FPROC: 508 return p->ptr[ NL_FCHAIN ]; 509 case PROC: 510 case FUNC: 511 return p->chain; 512 default: 513 panic("plist"); 514 } 515 } 516 517 linenum(p) 518 struct nl *p; 519 { 520 if (p->class == FUNC) 521 return p->ptr[NL_FVAR]->value[NL_LINENO]; 522 return p->value[NL_LINENO]; 523 } 524