| 1 | /* Copyright (c) 1979 Regents of the University of California */ |
| 2 | |
| 3 | static char sccsid[] = "@(#)call.c 1.3 %G%"; |
| 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 | } |