1 /* Copyright (c) 1979 Regents of the University of California */ 2 3 static char sccsid[] = "@(#)call.c 1.9 03/23/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 break; 175 } 176 q = lvalue( (int *) argv[1], MOD , LREQ ); 177 if (q == NIL) { 178 chk = FALSE; 179 break; 180 } 181 if (q != p1->type) { 182 error("Parameter type not identical to type of var parameter %s of %s", p1->symbol, p->symbol); 183 break; 184 } 185 break; 186 case VAR: 187 /* 188 * Value parameter 189 */ 190 # ifdef OBJ 191 q = rvalue(argv[1], p1->type , RREQ ); 192 # endif OBJ 193 # ifdef PC 194 /* 195 * structure arguments require lvalues, 196 * scalars use rvalue. 197 */ 198 switch( classify( p1 -> type ) ) { 199 case TFILE: 200 case TARY: 201 case TREC: 202 case TSET: 203 case TSTR: 204 q = rvalue( argv[1] , p1 -> type , LREQ ); 205 break; 206 case TINT: 207 case TSCAL: 208 case TBOOL: 209 case TCHAR: 210 precheck( p1 -> type , "_RANG4" , "_RSNG4" ); 211 q = rvalue( argv[1] , p1 -> type , RREQ ); 212 postcheck( p1 -> type ); 213 break; 214 default: 215 q = rvalue( argv[1] , p1 -> type , RREQ ); 216 if ( isa( p1 -> type , "d" ) 217 && isa( q , "i" ) ) { 218 putop( P2SCONV , P2DOUBLE ); 219 } 220 break; 221 } 222 # endif PC 223 if (q == NIL) { 224 chk = FALSE; 225 break; 226 } 227 if (incompat(q, p1->type, argv[1])) { 228 cerror("Expression type clashed with type of value parameter %s of %s", p1->symbol, p->symbol); 229 break; 230 } 231 # ifdef OBJ 232 if (isa(p1->type, "bcsi")) 233 rangechk(p1->type, q); 234 if (q->class != STR) 235 convert(q, p1->type); 236 # endif OBJ 237 # ifdef PC 238 switch( classify( p1 -> type ) ) { 239 case TFILE: 240 case TARY: 241 case TREC: 242 case TSET: 243 case TSTR: 244 putstrop( P2STARG 245 , p2type( p1 -> type ) 246 , lwidth( p1 -> type ) 247 , align( p1 -> type ) ); 248 } 249 # endif PC 250 break; 251 case FFUNC: 252 /* 253 * function parameter 254 */ 255 q = flvalue( (int *) argv[1] , p1 ); 256 chk = (chk && fcompat(q, p1)); 257 break; 258 case FPROC: 259 /* 260 * procedure parameter 261 */ 262 q = flvalue( (int *) argv[1] , p1 ); 263 chk = (chk && fcompat(q, p1)); 264 break; 265 default: 266 panic("call"); 267 } 268 # ifdef PC 269 /* 270 * if this is the nth (>1) argument, 271 * hang it on the left linear list of arguments 272 */ 273 if ( noarguments ) { 274 noarguments = FALSE; 275 } else { 276 putop( P2LISTOP , P2INT ); 277 } 278 # endif PC 279 argv = argv[2]; 280 } 281 if (argv != NIL) { 282 error("Too many arguments to %s", p->symbol); 283 rvlist(argv); 284 return (NIL); 285 } 286 if (chk == FALSE) 287 return NIL; 288 # ifdef OBJ 289 if ( p -> class == FFUNC || p -> class == FPROC ) { 290 put(2, PTR_RV | psbn << 8+INDX, (int)p->value[NL_OFFS]); 291 put(1, O_FCALL); 292 put(2, O_FRTN, even(width(p->type))); 293 } else { 294 put(2, O_CALL | psbn << 8, (long)p->entloc); 295 } 296 # endif OBJ 297 # ifdef PC 298 /* 299 * do the actual call: 300 * either ... p( ... ) ... 301 * or ... ( ...() )( ... ) ... 302 * and maybe an assignment. 303 */ 304 if ( porf == FUNC ) { 305 switch ( p_type_class ) { 306 case TBOOL: 307 case TCHAR: 308 case TINT: 309 case TSCAL: 310 case TDOUBLE: 311 case TPTR: 312 putop( ( noarguments ? P2UNARY P2CALL : P2CALL ) , 313 p_type_p2type ); 314 if ( p -> class == FFUNC ) { 315 putop( P2ASSIGN , p_type_p2type ); 316 } 317 break; 318 default: 319 putstrop( ( noarguments ? P2UNARY P2STCALL : P2STCALL ), 320 ADDTYPE( p_type_p2type , P2PTR ) , 321 p_type_width , p_type_align ); 322 putstrop( P2STASG , p_type_p2type , lwidth( p -> type ) 323 , align( p -> type ) ); 324 break; 325 } 326 } else { 327 putop( ( noarguments ? P2UNARY P2CALL : P2CALL ) , P2INT ); 328 } 329 /* 330 * ... , FRTN( p ) ... 331 */ 332 if ( p -> class == FFUNC || p -> class == FPROC ) { 333 putleaf( P2ICON , 0 , 0 , ADDTYPE( P2FTN | P2INT , P2PTR ) , 334 "_FRTN" ); 335 putRV( 0 , psbn , p -> value[ NL_OFFS ] , P2PTR | P2STRTY ); 336 putop( P2CALL , P2INT ); 337 putop( P2COMOP , P2INT ); 338 } 339 /* 340 * if required: 341 * either ... , temp ) 342 * or ... , &temp ) 343 */ 344 if ( porf == FUNC && temptype != P2UNDEF ) { 345 if ( temptype != P2STRTY ) { 346 putRV( 0 , cbn , tempoffset , p_type_p2type ); 347 } else { 348 putLV( 0 , cbn , tempoffset , p_type_p2type ); 349 } 350 putop( P2COMOP , P2INT ); 351 } 352 if ( porf == PROC ) { 353 putdot( filename , line ); 354 } 355 # endif PC 356 return (p->type); 357 } 358 359 rvlist(al) 360 register int *al; 361 { 362 363 for (; al != NIL; al = al[2]) 364 rvalue( (int *) al[1], NLNIL , RREQ ); 365 } 366 367 /* 368 * check that two function/procedure namelist entries are compatible 369 */ 370 bool 371 fcompat( formal , actual ) 372 struct nl *formal; 373 struct nl *actual; 374 { 375 register struct nl *f_chain; 376 register struct nl *a_chain; 377 bool compat = TRUE; 378 379 if ( formal == NIL || actual == NIL ) { 380 return FALSE; 381 } 382 for (a_chain = plist(actual), f_chain = plist(formal); 383 f_chain != NIL; 384 f_chain = f_chain->chain, a_chain = a_chain->chain) { 385 if (a_chain == NIL) { 386 error("%s %s declared on line %d has more arguments than", 387 parnam(formal->class), formal->symbol, 388 linenum(formal)); 389 cerror("%s %s declared on line %d", 390 parnam(actual->class), actual->symbol, 391 linenum(actual)); 392 return FALSE; 393 } 394 if ( a_chain -> class != f_chain -> class ) { 395 error("%s parameter %s of %s declared on line %d is not identical", 396 parnam(f_chain->class), f_chain->symbol, 397 formal->symbol, linenum(formal)); 398 cerror("with %s parameter %s of %s declared on line %d", 399 parnam(a_chain->class), a_chain->symbol, 400 actual->symbol, linenum(actual)); 401 compat = FALSE; 402 } else if (a_chain->class == FFUNC || a_chain->class == FPROC) { 403 compat = (compat && fcompat(f_chain, a_chain)); 404 } 405 if ((a_chain->class != FPROC && f_chain->class != FPROC) && 406 (a_chain->type != f_chain->type)) { 407 error("Type of %s parameter %s of %s declared on line %d is not identical", 408 parnam(f_chain->class), f_chain->symbol, 409 formal->symbol, linenum(formal)); 410 cerror("to type of %s parameter %s of %s declared on line %d", 411 parnam(a_chain->class), a_chain->symbol, 412 actual->symbol, linenum(actual)); 413 compat = FALSE; 414 } 415 } 416 if (a_chain != NIL) { 417 error("%s %s declared on line %d has fewer arguments than", 418 parnam(formal->class), formal->symbol, 419 linenum(formal)); 420 cerror("%s %s declared on line %d", 421 parnam(actual->class), actual->symbol, 422 linenum(actual)); 423 return FALSE; 424 } 425 return compat; 426 } 427 428 char * 429 parnam(nltype) 430 int nltype; 431 { 432 switch(nltype) { 433 case REF: 434 return "var"; 435 case VAR: 436 return "value"; 437 case FUNC: 438 case FFUNC: 439 return "function"; 440 case PROC: 441 case FPROC: 442 return "procedure"; 443 default: 444 return "SNARK"; 445 } 446 } 447 448 plist(p) 449 struct nl *p; 450 { 451 switch (p->class) { 452 case FFUNC: 453 case FPROC: 454 return p->ptr[ NL_FCHAIN ]; 455 case PROC: 456 case FUNC: 457 return p->chain; 458 default: 459 panic("plist"); 460 } 461 } 462 463 linenum(p) 464 struct nl *p; 465 { 466 if (p->class == FUNC) 467 return p->ptr[NL_FVAR]->value[NL_LINENO]; 468 return p->value[NL_LINENO]; 469 } 470