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