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