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