1 /* Copyright (c) 1979 Regents of the University of California */ 2 3 static char sccsid[] = "@(#)call.c 1.7 03/11/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 56 # ifdef OBJ 57 int cnt; 58 # endif OBJ 59 # ifdef PC 60 long p_p2type = p2type( p ); 61 long p_type_p2type = p2type( p -> type ); 62 bool noarguments; 63 long calltype; /* type of the call */ 64 /* 65 * these get used if temporaries and structures are used 66 */ 67 long tempoffset; 68 long temptype; /* type of the temporary */ 69 long p_type_width; 70 long p_type_align; 71 # endif PC 72 73 # ifdef OBJ 74 if (p->class == FFUNC || p->class == FPROC) 75 put(2, PTR_RV | cbn << 8+INDX, (int)p->value[NL_OFFS]); 76 if (porf == FUNC) 77 /* 78 * Push some space 79 * for the function return type 80 */ 81 put(2, O_PUSH, leven(-lwidth(p->type))); 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 tempoffset = tmpalloc(p_type_width, p -> type, NOREG); 110 /* 111 * temp 112 * for (temp = ... 113 */ 114 putRV( 0 , cbn , tempoffset , temptype ); 115 } 116 } 117 switch ( p -> class ) { 118 case FUNC: 119 case PROC: 120 /* 121 * ... p( ... 122 */ 123 { 124 char extname[ BUFSIZ ]; 125 char *starthere; 126 int funcbn; 127 int i; 128 129 starthere = &extname[0]; 130 funcbn = p -> nl_block & 037; 131 for ( i = 1 ; i < funcbn ; i++ ) { 132 sprintf( starthere , EXTFORMAT , enclosing[ i ] ); 133 starthere += strlen( enclosing[ i ] ) + 1; 134 } 135 sprintf( starthere , EXTFORMAT , p -> symbol ); 136 starthere += strlen( p -> symbol ) + 1; 137 if ( starthere >= &extname[ BUFSIZ ] ) { 138 panic( "call namelength" ); 139 } 140 putleaf( P2ICON , 0 , 0 , p2type( p ) , extname ); 141 } 142 break; 143 case FFUNC: 144 case FPROC: 145 /* 146 * ... (FCALL( p ))( ... 147 */ 148 putleaf( P2ICON , 0 , 0 149 , ADDTYPE( ADDTYPE( p_p2type , P2FTN ) , P2PTR ) 150 , "_FCALL" ); 151 putRV( 0 , cbn , p -> value[NL_OFFS] , P2PTR|P2STRTY ); 152 putop( P2CALL , p_p2type ); 153 break; 154 default: 155 panic("call class"); 156 } 157 noarguments = TRUE; 158 # endif PC 159 /* 160 * Loop and process each of 161 * arguments to the proc/func. 162 * ... ( ... args ... ) ... 163 */ 164 if ( p -> class == FUNC || p -> class == PROC ) { 165 for (p1 = p->chain; p1 != NIL; p1 = p1->chain) { 166 if (argv == NIL) { 167 error("Not enough arguments to %s", p->symbol); 168 return (NIL); 169 } 170 switch (p1->class) { 171 case REF: 172 /* 173 * Var parameter 174 */ 175 r = argv[1]; 176 if (r != NIL && r[0] != T_VAR) { 177 error("Expression given (variable required) for var parameter %s of %s", p1->symbol, p->symbol); 178 break; 179 } 180 q = lvalue( (int *) argv[1], MOD , LREQ ); 181 if (q == NIL) 182 break; 183 if (q != p1->type) { 184 error("Parameter type not identical to type of var parameter %s of %s", p1->symbol, p->symbol); 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 break; 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] , FFUNC ); 256 if (q == NIL) 257 break; 258 if (q != p1->type) { 259 error("Function type not identical to type of function parameter %s of %s", p1->symbol, p->symbol); 260 break; 261 } 262 break; 263 case FPROC: 264 /* 265 * procedure parameter 266 */ 267 q = flvalue( (int *) argv[1] , FPROC ); 268 if (q != NIL) { 269 error("Procedure parameter %s of %s cannot have a type", p1->symbol, p->symbol); 270 } 271 break; 272 default: 273 panic("call"); 274 } 275 # ifdef PC 276 /* 277 * if this is the nth (>1) argument, 278 * hang it on the left linear list of arguments 279 */ 280 if ( noarguments ) { 281 noarguments = FALSE; 282 } else { 283 putop( P2LISTOP , P2INT ); 284 } 285 # endif PC 286 argv = argv[2]; 287 } 288 if (argv != NIL) { 289 error("Too many arguments to %s", p->symbol); 290 rvlist(argv); 291 return (NIL); 292 } 293 } else if ( p -> class == FFUNC || p -> class == FPROC ) { 294 /* 295 * formal routines can only have by-value parameters. 296 * this will lose for integer actuals passed to real 297 * formals, and strings which people want blank padded. 298 */ 299 # ifdef OBJ 300 cnt = 0; 301 # endif OBJ 302 for ( ; argv != NIL ; argv = argv[2] ) { 303 # ifdef OBJ 304 q = rvalue(argv[1], NIL, RREQ ); 305 cnt += leven(lwidth(q)); 306 # endif OBJ 307 # ifdef PC 308 /* 309 * structure arguments require lvalues, 310 * scalars use rvalue. 311 */ 312 codeoff(); 313 p1 = rvalue( argv[1] , NIL , RREQ ); 314 codeon(); 315 switch( classify( p1 ) ) { 316 case TSTR: 317 if ( p1 -> class == STR && slenline != line ) { 318 slenline = line; 319 ( opt( 's' ) ? (standard()): (warning()) ); 320 error("Implementation can't construct equal length strings"); 321 } 322 /* and fall through */ 323 case TFILE: 324 case TARY: 325 case TREC: 326 case TSET: 327 q = rvalue( argv[1] , p1 , LREQ ); 328 break; 329 case TINT: 330 if ( floatline != line ) { 331 floatline = line; 332 ( opt( 's' ) ? (standard()) : (warning()) ); 333 error("Implementation can't coerice integer to real"); 334 } 335 /* and fall through */ 336 case TSCAL: 337 case TBOOL: 338 case TCHAR: 339 default: 340 q = rvalue( argv[1] , p1 , RREQ ); 341 break; 342 } 343 switch( classify( p1 ) ) { 344 case TFILE: 345 case TARY: 346 case TREC: 347 case TSET: 348 case TSTR: 349 putstrop( P2STARG , p2type( p1 ) , 350 lwidth( p1 ) , align( p1 ) ); 351 } 352 /* 353 * if this is the nth (>1) argument, 354 * hang it on the left linear list of arguments 355 */ 356 if ( noarguments ) { 357 noarguments = FALSE; 358 } else { 359 putop( P2LISTOP , P2INT ); 360 } 361 # endif PC 362 } 363 } else { 364 panic("call class"); 365 } 366 # ifdef OBJ 367 if ( p -> class == FFUNC || p -> class == FPROC ) { 368 put(2, PTR_RV | cbn << 8+INDX, (int)p->value[NL_OFFS]); 369 put(2, O_FCALL, (long)cnt); 370 put(2, O_FRTN, even(width(p->type))); 371 } else { 372 /* put(2, O_CALL | psbn << 8+INDX, (long)p->entloc); */ 373 put(2, O_CALL | psbn << 8, (long)p->entloc); 374 } 375 # endif OBJ 376 # ifdef PC 377 /* 378 * do the actual call: 379 * either ... p( ... ) ... 380 * or ... ( ...() )( ... ) ... 381 * and maybe an assignment. 382 */ 383 if ( porf == FUNC ) { 384 switch ( p_type_class ) { 385 case TBOOL: 386 case TCHAR: 387 case TINT: 388 case TSCAL: 389 case TDOUBLE: 390 case TPTR: 391 putop( ( noarguments ? P2UNARY P2CALL : P2CALL ) , 392 p_type_p2type ); 393 if ( p -> class == FFUNC ) { 394 putop( P2ASSIGN , p_type_p2type ); 395 } 396 break; 397 default: 398 putstrop( ( noarguments ? P2UNARY P2STCALL : P2STCALL ), 399 ADDTYPE( p_type_p2type , P2PTR ) , 400 p_type_width , p_type_align ); 401 putstrop( P2STASG , p_type_p2type , lwidth( p -> type ) 402 , align( p -> type ) ); 403 break; 404 } 405 } else { 406 putop( ( noarguments ? P2UNARY P2CALL : P2CALL ) , P2INT ); 407 } 408 /* 409 * ... , FRTN( p ) ... 410 */ 411 if ( p -> class == FFUNC || p -> class == FPROC ) { 412 putleaf( P2ICON , 0 , 0 , ADDTYPE( P2FTN | P2INT , P2PTR ) , 413 "_FRTN" ); 414 putRV( 0 , cbn , p -> value[ NL_OFFS ] , P2PTR | P2STRTY ); 415 putop( P2CALL , P2INT ); 416 putop( P2COMOP , P2INT ); 417 } 418 /* 419 * if required: 420 * either ... , temp ) 421 * or ... , &temp ) 422 */ 423 if ( porf == FUNC && temptype != P2UNDEF ) { 424 if ( temptype != P2STRTY ) { 425 putRV( 0 , cbn , tempoffset , p_type_p2type ); 426 } else { 427 putLV( 0 , cbn , tempoffset , p_type_p2type ); 428 } 429 putop( P2COMOP , P2INT ); 430 } 431 if ( porf == PROC ) { 432 putdot( filename , line ); 433 } 434 # endif PC 435 return (p->type); 436 } 437 438 rvlist(al) 439 register int *al; 440 { 441 442 for (; al != NIL; al = al[2]) 443 rvalue( (int *) al[1], NLNIL , RREQ ); 444 } 445