1 /* Copyright (c) 1979 Regents of the University of California */ 2 3 static char sccsid[] = "@(#)call.c 1.3 10/03/80"; 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 bool slenflag = 0; 16 bool floatflag = 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 struct nl * 28 call(p, argv, porf, psbn) 29 struct nl *p; 30 int *argv, porf, psbn; 31 { 32 register struct nl *p1, *q; 33 int *r; 34 35 # ifdef OBJ 36 int cnt; 37 # endif OBJ 38 # ifdef PC 39 long temp; 40 int firsttime; 41 int rettype; 42 # endif PC 43 44 # ifdef OBJ 45 if (p->class == FFUNC || p->class == FPROC) 46 put(2, PTR_RV | cbn << 8+INDX, p->value[NL_OFFS]); 47 if (porf == FUNC) 48 /* 49 * Push some space 50 * for the function return type 51 */ 52 put2(O_PUSH, even(-width(p->type))); 53 # endif OBJ 54 # ifdef PC 55 if ( porf == FUNC ) { 56 switch( classify( p -> type ) ) { 57 case TSTR: 58 case TSET: 59 case TREC: 60 case TFILE: 61 case TARY: 62 temp = sizes[ cbn ].om_off -= width( p -> type ); 63 putlbracket( ftnno , -sizes[cbn].om_off ); 64 if (sizes[cbn].om_off < sizes[cbn].om_max) { 65 sizes[cbn].om_max = sizes[cbn].om_off; 66 } 67 putRV( 0 , cbn , temp , P2STRTY ); 68 } 69 } 70 switch ( p -> class ) { 71 case FUNC: 72 case PROC: 73 { 74 char extname[ BUFSIZ ]; 75 char *starthere; 76 int funcbn; 77 int i; 78 79 starthere = &extname[0]; 80 funcbn = p -> nl_block & 037; 81 for ( i = 1 ; i < funcbn ; i++ ) { 82 sprintf( starthere , EXTFORMAT , enclosing[ i ] ); 83 starthere += strlen( enclosing[ i ] ) + 1; 84 } 85 sprintf( starthere , EXTFORMAT , p -> symbol ); 86 starthere += strlen( p -> symbol ) + 1; 87 if ( starthere >= &extname[ BUFSIZ ] ) { 88 panic( "call namelength" ); 89 } 90 putleaf( P2ICON , 0 , 0 , p2type( p ) , extname ); 91 } 92 break; 93 case FFUNC: 94 case FPROC: 95 /* 96 * start one of these: 97 * FRTN( frtn , ( *FCALL( frtn ) )(...args...) ) 98 */ 99 putleaf( P2ICON , 0 , 0 , p2type( p ) , "_FRTN" ); 100 putRV( 0 , cbn , p -> value[NL_OFFS] , P2PTR|P2STRTY ); 101 putleaf( P2ICON , 0 , 0 102 , ADDTYPE( P2PTR , ADDTYPE( P2FTN , p2type( p ) ) ) 103 , "_FCALL" ); 104 putRV( 0 , cbn , p -> value[NL_OFFS] , P2PTR|P2STRTY ); 105 putop( P2CALL , p2type( p ) ); 106 break; 107 default: 108 panic("call class"); 109 } 110 firsttime = TRUE; 111 # endif PC 112 /* 113 * Loop and process each of 114 * arguments to the proc/func. 115 */ 116 if ( p -> class == FUNC || p -> class == PROC ) { 117 for (p1 = p->chain; p1 != NIL; p1 = p1->chain) { 118 if (argv == NIL) { 119 error("Not enough arguments to %s", p->symbol); 120 return (NIL); 121 } 122 switch (p1->class) { 123 case REF: 124 /* 125 * Var parameter 126 */ 127 r = argv[1]; 128 if (r != NIL && r[0] != T_VAR) { 129 error("Expression given (variable required) for var parameter %s of %s", p1->symbol, p->symbol); 130 break; 131 } 132 q = lvalue( (int *) argv[1], MOD , LREQ ); 133 if (q == NIL) 134 break; 135 if (q != p1->type) { 136 error("Parameter type not identical to type of var parameter %s of %s", p1->symbol, p->symbol); 137 break; 138 } 139 break; 140 case VAR: 141 /* 142 * Value parameter 143 */ 144 # ifdef OBJ 145 q = rvalue(argv[1], p1->type , RREQ ); 146 # endif OBJ 147 # ifdef PC 148 /* 149 * structure arguments require lvalues, 150 * scalars use rvalue. 151 */ 152 switch( classify( p1 -> type ) ) { 153 case TFILE: 154 case TARY: 155 case TREC: 156 case TSET: 157 case TSTR: 158 q = rvalue( argv[1] , p1 -> type , LREQ ); 159 break; 160 case TINT: 161 case TSCAL: 162 case TBOOL: 163 case TCHAR: 164 precheck( p1 -> type , "_RANG4" , "_RSNG4" ); 165 q = rvalue( argv[1] , p1 -> type , RREQ ); 166 postcheck( p1 -> type ); 167 break; 168 default: 169 q = rvalue( argv[1] , p1 -> type , RREQ ); 170 if ( isa( p1 -> type , "d" ) 171 && isa( q , "i" ) ) { 172 putop( P2SCONV , P2DOUBLE ); 173 } 174 break; 175 } 176 # endif PC 177 if (q == NIL) 178 break; 179 if (incompat(q, p1->type, argv[1])) { 180 cerror("Expression type clashed with type of value parameter %s of %s", p1->symbol, p->symbol); 181 break; 182 } 183 # ifdef OBJ 184 if (isa(p1->type, "bcsi")) 185 rangechk(p1->type, q); 186 if (q->class != STR) 187 convert(q, p1->type); 188 # endif OBJ 189 # ifdef PC 190 switch( classify( p1 -> type ) ) { 191 case TFILE: 192 case TARY: 193 case TREC: 194 case TSET: 195 case TSTR: 196 putstrop( P2STARG 197 , p2type( p1 -> type ) 198 , lwidth( p1 -> type ) 199 , align( p1 -> type ) ); 200 } 201 # endif PC 202 break; 203 case FFUNC: 204 /* 205 * function parameter 206 */ 207 q = flvalue( (int *) argv[1] , FFUNC ); 208 if (q == NIL) 209 break; 210 if (q != p1->type) { 211 error("Function type not identical to type of function parameter %s of %s", p1->symbol, p->symbol); 212 break; 213 } 214 break; 215 case FPROC: 216 /* 217 * procedure parameter 218 */ 219 q = flvalue( (int *) argv[1] , FPROC ); 220 if (q != NIL) { 221 error("Procedure parameter %s of %s cannot have a type", p1->symbol, p->symbol); 222 } 223 break; 224 default: 225 panic("call"); 226 } 227 # ifdef PC 228 /* 229 * if this is the nth (>1) argument, 230 * hang it on the left linear list of arguments 231 */ 232 if ( firsttime ) { 233 firsttime = FALSE; 234 } else { 235 putop( P2LISTOP , P2INT ); 236 } 237 # endif PC 238 argv = argv[2]; 239 } 240 if (argv != NIL) { 241 error("Too many arguments to %s", p->symbol); 242 rvlist(argv); 243 return (NIL); 244 } 245 } else if ( p -> class == FFUNC || p -> class == FPROC ) { 246 /* 247 * formal routines can only have by-value parameters. 248 * this will lose for integer actuals passed to real 249 * formals, and strings which people want blank padded. 250 */ 251 # ifdef OBJ 252 cnt = 0; 253 # endif OBJ 254 for ( ; argv != NIL ; argv = argv[2] ) { 255 # ifdef OBJ 256 q = rvalue(argv[1], NIL, RREQ ); 257 cnt += even(lwidth(q)); 258 # endif OBJ 259 # ifdef PC 260 /* 261 * structure arguments require lvalues, 262 * scalars use rvalue. 263 */ 264 codeoff(); 265 p1 = rvalue( argv[1] , NIL , RREQ ); 266 codeon(); 267 switch( classify( p1 ) ) { 268 case TSTR: 269 if ( p1 -> class == STR && slenflag == 0 ) { 270 if ( opt( 's' ) ) { 271 standard(); 272 } else { 273 warning(); 274 } 275 error("Implementation can't construct equal length strings"); 276 slenflag++; 277 } 278 /* and fall through */ 279 case TFILE: 280 case TARY: 281 case TREC: 282 case TSET: 283 q = rvalue( argv[1] , p1 , LREQ ); 284 break; 285 case TINT: 286 if ( floatflag == 0 ) { 287 if ( opt( 's' ) ) { 288 standard(); 289 } else { 290 warning(); 291 } 292 error("Implementation can't coerice integer to real"); 293 floatflag++; 294 } 295 /* and fall through */ 296 case TSCAL: 297 case TBOOL: 298 case TCHAR: 299 default: 300 q = rvalue( argv[1] , p1 , RREQ ); 301 break; 302 } 303 switch( classify( p1 ) ) { 304 case TFILE: 305 case TARY: 306 case TREC: 307 case TSET: 308 case TSTR: 309 putstrop( P2STARG , p2type( p1 ) , 310 lwidth( p1 ) , align( p1 ) ); 311 } 312 /* 313 * if this is the nth (>1) argument, 314 * hang it on the left linear list of arguments 315 */ 316 if ( firsttime ) { 317 firsttime = FALSE; 318 } else { 319 putop( P2LISTOP , P2INT ); 320 } 321 # endif PC 322 } 323 } else { 324 panic("call class"); 325 } 326 # ifdef OBJ 327 if ( p -> class == FFUNC || p -> class == FPROC ) { 328 put(2, PTR_RV | cbn << 8+INDX, p->value[NL_OFFS]); 329 put(2, O_FCALL, cnt); 330 put(2, O_FRTN, even(lwidth(p->type))); 331 } else { 332 put2(O_CALL | psbn << 8+INDX, p->entloc); 333 } 334 # endif OBJ 335 # ifdef PC 336 if ( porf == FUNC ) { 337 rettype = p2type( p -> type ); 338 switch ( classify( p -> type ) ) { 339 case TBOOL: 340 case TCHAR: 341 case TINT: 342 case TSCAL: 343 case TDOUBLE: 344 case TPTR: 345 if ( firsttime ) { 346 putop( P2UNARY P2CALL , rettype ); 347 } else { 348 putop( P2CALL , rettype ); 349 } 350 if (p -> class == FFUNC || p -> class == FPROC ) { 351 putop( P2LISTOP , P2INT ); 352 putop( P2CALL , rettype ); 353 } 354 break; 355 default: 356 if ( firsttime ) { 357 putstrop( P2UNARY P2STCALL 358 , ADDTYPE( rettype , P2PTR ) 359 , lwidth( p -> type ) 360 , align( p -> type ) ); 361 } else { 362 putstrop( P2STCALL 363 , ADDTYPE( rettype , P2PTR ) 364 , lwidth( p -> type ) 365 , align( p -> type ) ); 366 } 367 if (p -> class == FFUNC || p -> class == FPROC ) { 368 putop( P2LISTOP , P2INT ); 369 putop( P2CALL , ADDTYPE( rettype , P2PTR ) ); 370 } 371 putstrop( P2STASG , rettype , lwidth( p -> type ) 372 , align( p -> type ) ); 373 putLV( 0 , cbn , temp , rettype ); 374 putop( P2COMOP , P2INT ); 375 break; 376 } 377 } else { 378 if ( firsttime ) { 379 putop( P2UNARY P2CALL , P2INT ); 380 } else { 381 putop( P2CALL , P2INT ); 382 } 383 if (p -> class == FFUNC || p -> class == FPROC ) { 384 putop( P2LISTOP , P2INT ); 385 putop( P2CALL , P2INT ); 386 } 387 putdot( filename , line ); 388 } 389 # endif PC 390 return (p->type); 391 } 392 393 rvlist(al) 394 register int *al; 395 { 396 397 for (; al != NIL; al = al[2]) 398 rvalue( (int *) al[1], NLNIL , RREQ ); 399 } 400