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