1 /* Copyright (c) 1979 Regents of the University of California */ 2 3 static char sccsid[] = "@(#)call.c 1.5 02/17/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, p->value[NL_OFFS]); 76 if (porf == FUNC) 77 /* 78 * Push some space 79 * for the function return type 80 */ 81 put2(O_PUSH, even(-width(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 = sizes[ cbn ].om_off -= p_type_width; 110 putlbracket( ftnno , -tempoffset ); 111 if ( tempoffset < sizes[cbn].om_max) { 112 sizes[cbn].om_max = tempoffset; 113 } 114 /* 115 * temp 116 * for (temp = ... 117 */ 118 putRV( 0 , cbn , tempoffset , temptype ); 119 } 120 } 121 switch ( p -> class ) { 122 case FUNC: 123 case PROC: 124 /* 125 * ... p( ... 126 */ 127 { 128 char extname[ BUFSIZ ]; 129 char *starthere; 130 int funcbn; 131 int i; 132 133 starthere = &extname[0]; 134 funcbn = p -> nl_block & 037; 135 for ( i = 1 ; i < funcbn ; i++ ) { 136 sprintf( starthere , EXTFORMAT , enclosing[ i ] ); 137 starthere += strlen( enclosing[ i ] ) + 1; 138 } 139 sprintf( starthere , EXTFORMAT , p -> symbol ); 140 starthere += strlen( p -> symbol ) + 1; 141 if ( starthere >= &extname[ BUFSIZ ] ) { 142 panic( "call namelength" ); 143 } 144 putleaf( P2ICON , 0 , 0 , p2type( p ) , extname ); 145 } 146 break; 147 case FFUNC: 148 case FPROC: 149 /* 150 * ... (FCALL( p ))( ... 151 */ 152 putleaf( P2ICON , 0 , 0 153 , ADDTYPE( ADDTYPE( p_p2type , P2FTN ) , P2PTR ) 154 , "_FCALL" ); 155 putRV( 0 , cbn , p -> value[NL_OFFS] , P2PTR|P2STRTY ); 156 putop( P2CALL , p_p2type ); 157 break; 158 default: 159 panic("call class"); 160 } 161 noarguments = TRUE; 162 # endif PC 163 /* 164 * Loop and process each of 165 * arguments to the proc/func. 166 * ... ( ... args ... ) ... 167 */ 168 if ( p -> class == FUNC || p -> class == PROC ) { 169 for (p1 = p->chain; p1 != NIL; p1 = p1->chain) { 170 if (argv == NIL) { 171 error("Not enough arguments to %s", p->symbol); 172 return (NIL); 173 } 174 switch (p1->class) { 175 case REF: 176 /* 177 * Var parameter 178 */ 179 r = argv[1]; 180 if (r != NIL && r[0] != T_VAR) { 181 error("Expression given (variable required) for var parameter %s of %s", p1->symbol, p->symbol); 182 break; 183 } 184 q = lvalue( (int *) argv[1], MOD , LREQ ); 185 if (q == NIL) 186 break; 187 if (q != p1->type) { 188 error("Parameter type not identical to type of var parameter %s of %s", p1->symbol, p->symbol); 189 break; 190 } 191 break; 192 case VAR: 193 /* 194 * Value parameter 195 */ 196 # ifdef OBJ 197 q = rvalue(argv[1], p1->type , RREQ ); 198 # endif OBJ 199 # ifdef PC 200 /* 201 * structure arguments require lvalues, 202 * scalars use rvalue. 203 */ 204 switch( classify( p1 -> type ) ) { 205 case TFILE: 206 case TARY: 207 case TREC: 208 case TSET: 209 case TSTR: 210 q = rvalue( argv[1] , p1 -> type , LREQ ); 211 break; 212 case TINT: 213 case TSCAL: 214 case TBOOL: 215 case TCHAR: 216 precheck( p1 -> type , "_RANG4" , "_RSNG4" ); 217 q = rvalue( argv[1] , p1 -> type , RREQ ); 218 postcheck( p1 -> type ); 219 break; 220 default: 221 q = rvalue( argv[1] , p1 -> type , RREQ ); 222 if ( isa( p1 -> type , "d" ) 223 && isa( q , "i" ) ) { 224 putop( P2SCONV , P2DOUBLE ); 225 } 226 break; 227 } 228 # endif PC 229 if (q == NIL) 230 break; 231 if (incompat(q, p1->type, argv[1])) { 232 cerror("Expression type clashed with type of value parameter %s of %s", p1->symbol, p->symbol); 233 break; 234 } 235 # ifdef OBJ 236 if (isa(p1->type, "bcsi")) 237 rangechk(p1->type, q); 238 if (q->class != STR) 239 convert(q, p1->type); 240 # endif OBJ 241 # ifdef PC 242 switch( classify( p1 -> type ) ) { 243 case TFILE: 244 case TARY: 245 case TREC: 246 case TSET: 247 case TSTR: 248 putstrop( P2STARG 249 , p2type( p1 -> type ) 250 , lwidth( p1 -> type ) 251 , align( p1 -> type ) ); 252 } 253 # endif PC 254 break; 255 case FFUNC: 256 /* 257 * function parameter 258 */ 259 q = flvalue( (int *) argv[1] , FFUNC ); 260 if (q == NIL) 261 break; 262 if (q != p1->type) { 263 error("Function type not identical to type of function parameter %s of %s", p1->symbol, p->symbol); 264 break; 265 } 266 break; 267 case FPROC: 268 /* 269 * procedure parameter 270 */ 271 q = flvalue( (int *) argv[1] , FPROC ); 272 if (q != NIL) { 273 error("Procedure parameter %s of %s cannot have a type", p1->symbol, p->symbol); 274 } 275 break; 276 default: 277 panic("call"); 278 } 279 # ifdef PC 280 /* 281 * if this is the nth (>1) argument, 282 * hang it on the left linear list of arguments 283 */ 284 if ( noarguments ) { 285 noarguments = FALSE; 286 } else { 287 putop( P2LISTOP , P2INT ); 288 } 289 # endif PC 290 argv = argv[2]; 291 } 292 if (argv != NIL) { 293 error("Too many arguments to %s", p->symbol); 294 rvlist(argv); 295 return (NIL); 296 } 297 } else if ( p -> class == FFUNC || p -> class == FPROC ) { 298 /* 299 * formal routines can only have by-value parameters. 300 * this will lose for integer actuals passed to real 301 * formals, and strings which people want blank padded. 302 */ 303 # ifdef OBJ 304 cnt = 0; 305 # endif OBJ 306 for ( ; argv != NIL ; argv = argv[2] ) { 307 # ifdef OBJ 308 q = rvalue(argv[1], NIL, RREQ ); 309 cnt += even(lwidth(q)); 310 # endif OBJ 311 # ifdef PC 312 /* 313 * structure arguments require lvalues, 314 * scalars use rvalue. 315 */ 316 codeoff(); 317 p1 = rvalue( argv[1] , NIL , RREQ ); 318 codeon(); 319 switch( classify( p1 ) ) { 320 case TSTR: 321 if ( p1 -> class == STR && slenline != line ) { 322 slenline = line; 323 ( opt( 's' ) ? (standard()): (warning()) ); 324 error("Implementation can't construct equal length strings"); 325 } 326 /* and fall through */ 327 case TFILE: 328 case TARY: 329 case TREC: 330 case TSET: 331 q = rvalue( argv[1] , p1 , LREQ ); 332 break; 333 case TINT: 334 if ( floatline != line ) { 335 floatline = line; 336 ( opt( 's' ) ? (standard()) : (warning()) ); 337 error("Implementation can't coerice integer to real"); 338 } 339 /* and fall through */ 340 case TSCAL: 341 case TBOOL: 342 case TCHAR: 343 default: 344 q = rvalue( argv[1] , p1 , RREQ ); 345 break; 346 } 347 switch( classify( p1 ) ) { 348 case TFILE: 349 case TARY: 350 case TREC: 351 case TSET: 352 case TSTR: 353 putstrop( P2STARG , p2type( p1 ) , 354 lwidth( p1 ) , align( p1 ) ); 355 } 356 /* 357 * if this is the nth (>1) argument, 358 * hang it on the left linear list of arguments 359 */ 360 if ( noarguments ) { 361 noarguments = FALSE; 362 } else { 363 putop( P2LISTOP , P2INT ); 364 } 365 # endif PC 366 } 367 } else { 368 panic("call class"); 369 } 370 # ifdef OBJ 371 if ( p -> class == FFUNC || p -> class == FPROC ) { 372 put(2, PTR_RV | cbn << 8+INDX, p->value[NL_OFFS]); 373 put(2, O_FCALL, cnt); 374 put(2, O_FRTN, even(lwidth(p->type))); 375 } else { 376 /* put(2, O_CALL | psbn << 8+INDX, p->entloc); */ 377 put(2, O_CALL | psbn << 8, p->entloc); 378 } 379 # endif OBJ 380 # ifdef PC 381 /* 382 * do the actual call: 383 * either ... p( ... ) ... 384 * or ... ( ...() )( ... ) ... 385 * and maybe an assignment. 386 */ 387 if ( porf == FUNC ) { 388 switch ( p_type_class ) { 389 case TBOOL: 390 case TCHAR: 391 case TINT: 392 case TSCAL: 393 case TDOUBLE: 394 case TPTR: 395 putop( ( noarguments ? P2UNARY P2CALL : P2CALL ) , 396 p_type_p2type ); 397 if ( p -> class == FFUNC ) { 398 putop( P2ASSIGN , p_type_p2type ); 399 } 400 break; 401 default: 402 putstrop( ( noarguments ? P2UNARY P2STCALL : P2STCALL ), 403 ADDTYPE( p_type_p2type , P2PTR ) , 404 p_type_width , p_type_align ); 405 putstrop( P2STASG , p_type_p2type , lwidth( p -> type ) 406 , align( p -> type ) ); 407 break; 408 } 409 } else { 410 putop( ( noarguments ? P2UNARY P2CALL : P2CALL ) , P2INT ); 411 } 412 /* 413 * ... , FRTN( p ) ... 414 */ 415 if ( p -> class == FFUNC || p -> class == FPROC ) { 416 putleaf( P2ICON , 0 , 0 , ADDTYPE( P2FTN | P2INT , P2PTR ) , 417 "_FRTN" ); 418 putRV( 0 , cbn , p -> value[ NL_OFFS ] , P2PTR | P2STRTY ); 419 putop( P2CALL , P2INT ); 420 putop( P2COMOP , P2INT ); 421 } 422 /* 423 * if required: 424 * either ... , temp ) 425 * or ... , &temp ) 426 */ 427 if ( porf == FUNC && temptype != P2UNDEF ) { 428 if ( temptype != P2STRTY ) { 429 putRV( 0 , cbn , tempoffset , p_type_p2type ); 430 } else { 431 putLV( 0 , cbn , tempoffset , p_type_p2type ); 432 } 433 putop( P2COMOP , P2INT ); 434 } 435 if ( porf == PROC ) { 436 putdot( filename , line ); 437 } 438 # endif PC 439 return (p->type); 440 } 441 442 rvlist(al) 443 register int *al; 444 { 445 446 for (; al != NIL; al = al[2]) 447 rvalue( (int *) al[1], NLNIL , RREQ ); 448 } 449