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