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