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