1: /* 2: * Copyright (c) 1980 Regents of the University of California. 3: * All rights reserved. The Berkeley software License Agreement 4: * specifies the terms and conditions for redistribution. 5: */ 6: 7: #ifndef lint 8: static char sccsid[] = "@(#)call.c 5.2 (Berkeley) 7/26/85"; 9: #endif not lint 10: 11: #include "whoami.h" 12: #include "0.h" 13: #include "tree.h" 14: #include "opcode.h" 15: #include "objfmt.h" 16: #ifdef PC 17: # include "pc.h" 18: # include <pcc.h> 19: #endif PC 20: #include "tmps.h" 21: #include "tree_ty.h" 22: 23: /* 24: * Call generates code for calls to 25: * user defined procedures and functions 26: * and is called by proc and funccod. 27: * P is the result of the lookup 28: * of the procedure/function symbol, 29: * and porf is PROC or FUNC. 30: * Psbn is the block number of p. 31: * 32: * the idea here is that regular scalar functions are just called, 33: * while structure functions and formal functions have their results 34: * stored in a temporary after the call. 35: * structure functions do this because they return pointers 36: * to static results, so we copy the static 37: * and return a pointer to the copy. 38: * formal functions do this because we have to save the result 39: * around a call to the runtime routine which restores the display, 40: * so we can't just leave the result lying around in registers. 41: * formal calls save the address of the descriptor in a local 42: * temporary, so it can be addressed for the call which restores 43: * the display (FRTN). 44: * calls to formal parameters pass the formal as a hidden argument 45: * to a special entry point for the formal call. 46: * [this is somewhat dependent on the way arguments are addressed.] 47: * so PROCs and scalar FUNCs look like 48: * p(...args...) 49: * structure FUNCs look like 50: * (temp = p(...args...),&temp) 51: * formal FPROCs look like 52: * ( t=p,( t -> entryaddr )(...args...,t,s),FRTN(t,s)) 53: * formal scalar FFUNCs look like 54: * ( t=p,temp=( t -> entryaddr )(...args...,t,s),FRTN(t,s),temp) 55: * formal structure FFUNCs look like 56: * (t=p,temp = ( t -> entryaddr )(...args...,t,s),FRTN(t,s),&temp) 57: */ 58: struct nl * 59: call(p, argv_node, porf, psbn) 60: struct nl *p; 61: struct tnode *argv_node; /* list node */ 62: int porf, psbn; 63: { 64: register struct nl *p1, *q, *p2; 65: register struct nl *ptype, *ctype; 66: struct tnode *rnode; 67: int i, j, d; 68: bool chk = TRUE; 69: struct nl *savedispnp; /* temporary to hold saved display */ 70: # ifdef PC 71: int p_type_class = classify( p -> type ); 72: long p_type_p2type = p2type( p -> type ); 73: bool noarguments; 74: /* 75: * these get used if temporaries and structures are used 76: */ 77: struct nl *tempnlp; 78: long temptype; /* type of the temporary */ 79: long p_type_width; 80: long p_type_align; 81: char extname[ BUFSIZ ]; 82: struct nl *tempdescrp; 83: # endif PC 84: 85: if (p->class == FFUNC || p->class == FPROC) { 86: /* 87: * allocate space to save the display for formal calls 88: */ 89: savedispnp = tmpalloc( (long) sizeof display , NLNIL , NOREG ); 90: } 91: # ifdef OBJ 92: if (p->class == FFUNC || p->class == FPROC) { 93: (void) put(2, O_LV | cbn << 8 + INDX , 94: (int) savedispnp -> value[ NL_OFFS ] ); 95: (void) put(2, PTR_RV | psbn << 8+INDX, (int)p->value[NL_OFFS]); 96: } 97: if (porf == FUNC) { 98: /* 99: * Push some space 100: * for the function return type 101: */ 102: (void) put(2, O_PUSH, leven(-lwidth(p->type))); 103: } 104: # endif OBJ 105: # ifdef PC 106: /* 107: * if this is a formal call, 108: * stash the address of the descriptor 109: * in a temporary so we can find it 110: * after the FCALL for the call to FRTN 111: */ 112: if ( p -> class == FFUNC || p -> class == FPROC ) { 113: tempdescrp = tmpalloc((long) (sizeof( struct formalrtn *)), 114: NLNIL, REGOK ); 115: putRV((char *) 0 , cbn , tempdescrp -> value[ NL_OFFS ] , 116: tempdescrp -> extra_flags , PCCTM_PTR|PCCT_STRTY ); 117: putRV((char *) 0 , psbn , p -> value[ NL_OFFS ] , 118: p -> extra_flags , PCCTM_PTR|PCCT_STRTY ); 119: putop( PCC_ASSIGN , PCCTM_PTR | PCCT_STRTY ); 120: } 121: /* 122: * if we have to store a temporary, 123: * temptype will be its type, 124: * otherwise, it's PCCT_UNDEF. 125: */ 126: temptype = PCCT_UNDEF; 127: if ( porf == FUNC ) { 128: p_type_width = width( p -> type ); 129: switch( p_type_class ) { 130: case TSTR: 131: case TSET: 132: case TREC: 133: case TFILE: 134: case TARY: 135: temptype = PCCT_STRTY; 136: p_type_align = align( p -> type ); 137: break; 138: default: 139: if ( p -> class == FFUNC ) { 140: temptype = p2type( p -> type ); 141: } 142: break; 143: } 144: if ( temptype != PCCT_UNDEF ) { 145: tempnlp = tmpalloc(p_type_width, p -> type, NOREG); 146: /* 147: * temp 148: * for (temp = ... 149: */ 150: putRV((char *) 0 , cbn , tempnlp -> value[ NL_OFFS ] , 151: tempnlp -> extra_flags , (int) temptype ); 152: } 153: } 154: switch ( p -> class ) { 155: case FUNC: 156: case PROC: 157: /* 158: * ... p( ... 159: */ 160: sextname( extname , p -> symbol , BLOCKNO(p -> nl_block) ); 161: putleaf( PCC_ICON , 0 , 0 , p2type( p ) , extname ); 162: break; 163: case FFUNC: 164: case FPROC: 165: 166: /* 167: * ... ( t -> entryaddr )( ... 168: */ 169: /* the descriptor */ 170: putRV((char *) 0 , cbn , tempdescrp -> value[ NL_OFFS ] , 171: tempdescrp -> extra_flags , PCCTM_PTR | PCCT_STRTY ); 172: /* the entry address within the descriptor */ 173: if ( FENTRYOFFSET != 0 ) { 174: putleaf( PCC_ICON , FENTRYOFFSET , 0 , PCCT_INT , 175: (char *) 0 ); 176: putop( PCC_PLUS , 177: PCCM_ADDTYPE( 178: PCCM_ADDTYPE( PCCM_ADDTYPE( p2type( p ) , PCCTM_FTN ) , 179: PCCTM_PTR ) , 180: PCCTM_PTR ) ); 181: } 182: /* 183: * indirect to fetch the formal entry address 184: * with the result type of the routine. 185: */ 186: if (p -> class == FFUNC) { 187: putop( PCCOM_UNARY PCC_MUL , 188: PCCM_ADDTYPE(PCCM_ADDTYPE(p2type(p -> type), PCCTM_FTN), 189: PCCTM_PTR)); 190: } else { 191: /* procedures are int returning functions */ 192: putop( PCCOM_UNARY PCC_MUL , 193: PCCM_ADDTYPE(PCCM_ADDTYPE(PCCT_INT, PCCTM_FTN), PCCTM_PTR)); 194: } 195: break; 196: default: 197: panic("call class"); 198: } 199: noarguments = TRUE; 200: # endif PC 201: /* 202: * Loop and process each of 203: * arguments to the proc/func. 204: * ... ( ... args ... ) ... 205: */ 206: ptype = NIL; 207: for (p1 = plist(p); p1 != NLNIL; p1 = p1->chain) { 208: if (argv_node == TR_NIL) { 209: error("Not enough arguments to %s", p->symbol); 210: return (NLNIL); 211: } 212: switch (p1->class) { 213: case REF: 214: /* 215: * Var parameter 216: */ 217: rnode = argv_node->list_node.list; 218: if (rnode != TR_NIL && rnode->tag != T_VAR) { 219: error("Expression given (variable required) for var parameter %s of %s", p1->symbol, p->symbol); 220: chk = FALSE; 221: break; 222: } 223: q = lvalue( argv_node->list_node.list, 224: MOD | ASGN , LREQ ); 225: if (q == NIL) { 226: chk = FALSE; 227: break; 228: } 229: p2 = p1->type; 230: if (p2 == NLNIL || p2->chain == NLNIL || p2->chain->class != CRANGE) { 231: if (q != p2) { 232: error("Parameter type not identical to type of var parameter %s of %s", p1->symbol, p->symbol); 233: chk = FALSE; 234: } 235: break; 236: } else { 237: /* conformant array */ 238: if (p1 == ptype) { 239: if (q != ctype) { 240: error("Conformant array parameters in the same specification must be the same type."); 241: goto conf_err; 242: } 243: } else { 244: if (classify(q) != TARY && classify(q) != TSTR) { 245: error("Array type required for var parameter %s of %s",p1->symbol,p->symbol); 246: goto conf_err; 247: } 248: /* check base type of array */ 249: if (p2->type != q->type) { 250: error("Base type of array not identical to that of conformant array parameter %s of %s", p1->symbol, p->symbol); 251: goto conf_err; 252: } 253: if (p2->value[0] != q->value[0]) { 254: error("Subscript number mismatch on conformant array parameter %s of %s", p1->symbol, p->symbol); 255: /* Don't process array bounds & width */ 256: conf_err: if (p1->chain->type->class == CRANGE) { 257: d = p1->value[0]; 258: for (i = 1; i <= d; i++) { 259: /* for each subscript, pass by 260: * bounds and width 261: */ 262: p1 = p1->chain->chain->chain; 263: } 264: } 265: ptype = ctype = NLNIL; 266: chk = FALSE; 267: break; 268: } 269: /* 270: * Save array type for all parameters with same 271: * specification. 272: */ 273: ctype = q; 274: ptype = p2; 275: /* 276: * If at end of conformant array list, 277: * get bounds. 278: */ 279: if (p1->chain->type->class == CRANGE) { 280: /* check each subscript, put on stack */ 281: d = ptype->value[0]; 282: q = ctype; 283: for (i = 1; i <= d; i++) { 284: p1 = p1->chain; 285: q = q->chain; 286: if (incompat(q, p1->type, TR_NIL)){ 287: error("Subscript type not conformable with parameter %s of %s", p1->symbol, p->symbol); 288: chk = FALSE; 289: break; 290: } 291: /* Put lower and upper bound & width */ 292: # ifdef OBJ 293: if (q->type->class == CRANGE) { 294: putcbnds(q->type); 295: } else { 296: put(2, width(p1->type) <= 2 ? O_CON2 297: : O_CON4, q->range[0]); 298: put(2, width(p1->type) <= 2 ? O_CON2 299: : O_CON4, q->range[1]); 300: put(2, width(p1->type) <= 2 ? O_CON2 301: : O_CON4, aryconst(ctype,i)); 302: } 303: # endif OBJ 304: # ifdef PC 305: if (q->type->class == CRANGE) { 306: for (j = 1; j <= 3; j++) { 307: p2 = p->nptr[j]; 308: putRV(p2->symbol, (p2->nl_block 309: & 037), p2->value[0], 310: p2->extra_flags,p2type(p2)); 311: putop(PCC_CM, PCCT_INT); 312: } 313: } else { 314: putleaf(PCC_ICON, q->range[0], 0,PCCT_INT,0); 315: putop( PCC_CM , PCCT_INT ); 316: putleaf(PCC_ICON, q->range[1], 0,PCCT_INT,0); 317: putop( PCC_CM , PCCT_INT ); 318: putleaf(PCC_ICON,aryconst(ctype,i),0,PCCT_INT,0); 319: putop( PCC_CM , PCCT_INT ); 320: } 321: # endif PC 322: p1 = p1->chain->chain; 323: } 324: } 325: } 326: } 327: break; 328: case VAR: 329: /* 330: * Value parameter 331: */ 332: # ifdef OBJ 333: q = rvalue(argv_node->list_node.list, 334: p1->type , RREQ ); 335: # endif OBJ 336: # ifdef PC 337: /* 338: * structure arguments require lvalues, 339: * scalars use rvalue. 340: */ 341: switch( classify( p1 -> type ) ) { 342: case TFILE: 343: case TARY: 344: case TREC: 345: case TSET: 346: case TSTR: 347: q = stkrval(argv_node->list_node.list, 348: p1 -> type , (long) LREQ ); 349: break; 350: case TINT: 351: case TSCAL: 352: case TBOOL: 353: case TCHAR: 354: precheck( p1 -> type , "_RANG4" , "_RSNG4" ); 355: q = stkrval(argv_node->list_node.list, 356: p1 -> type , (long) RREQ ); 357: postcheck(p1 -> type, nl+T4INT); 358: break; 359: case TDOUBLE: 360: q = stkrval(argv_node->list_node.list, 361: p1 -> type , (long) RREQ ); 362: sconv(p2type(q), PCCT_DOUBLE); 363: break; 364: default: 365: q = rvalue(argv_node->list_node.list, 366: p1 -> type , RREQ ); 367: break; 368: } 369: # endif PC 370: if (q == NIL) { 371: chk = FALSE; 372: break; 373: } 374: if (incompat(q, p1->type, 375: argv_node->list_node.list)) { 376: cerror("Expression type clashed with type of value parameter %s of %s", p1->symbol, p->symbol); 377: chk = FALSE; 378: break; 379: } 380: # ifdef OBJ 381: if (isa(p1->type, "bcsi")) 382: rangechk(p1->type, q); 383: if (q->class != STR) 384: convert(q, p1->type); 385: # endif OBJ 386: # ifdef PC 387: switch( classify( p1 -> type ) ) { 388: case TFILE: 389: case TARY: 390: case TREC: 391: case TSET: 392: case TSTR: 393: putstrop( PCC_STARG 394: , p2type( p1 -> type ) 395: , (int) lwidth( p1 -> type ) 396: , align( p1 -> type ) ); 397: } 398: # endif PC 399: break; 400: case FFUNC: 401: /* 402: * function parameter 403: */ 404: q = flvalue(argv_node->list_node.list, p1 ); 405: /*chk = (chk && fcompat(q, p1));*/ 406: if ((chk) && (fcompat(q, p1))) 407: chk = TRUE; 408: else 409: chk = FALSE; 410: break; 411: case FPROC: 412: /* 413: * procedure parameter 414: */ 415: q = flvalue(argv_node->list_node.list, p1 ); 416: /* chk = (chk && fcompat(q, p1)); */ 417: if ((chk) && (fcompat(q, p1))) 418: chk = TRUE; 419: else chk = FALSE; 420: break; 421: default: 422: panic("call"); 423: } 424: # ifdef PC 425: /* 426: * if this is the nth (>1) argument, 427: * hang it on the left linear list of arguments 428: */ 429: if ( noarguments ) { 430: noarguments = FALSE; 431: } else { 432: putop( PCC_CM , PCCT_INT ); 433: } 434: # endif PC 435: argv_node = argv_node->list_node.next; 436: } 437: if (argv_node != TR_NIL) { 438: error("Too many arguments to %s", p->symbol); 439: rvlist(argv_node); 440: return (NLNIL); 441: } 442: if (chk == FALSE) 443: return NLNIL; 444: # ifdef OBJ 445: if ( p -> class == FFUNC || p -> class == FPROC ) { 446: (void) put(2, PTR_RV | psbn << 8+INDX, (int)p->value[NL_OFFS]); 447: (void) put(2, O_LV | cbn << 8 + INDX , 448: (int) savedispnp -> value[ NL_OFFS ] ); 449: (void) put(1, O_FCALL); 450: (void) put(2, O_FRTN, even(width(p->type))); 451: } else { 452: (void) put(2, O_CALL | psbn << 8, (long)p->value[NL_ENTLOC]); 453: } 454: # endif OBJ 455: # ifdef PC 456: /* 457: * for formal calls: add the hidden argument 458: * which is the formal struct describing the 459: * environment of the routine. 460: * and the argument which is the address of the 461: * space into which to save the display. 462: */ 463: if ( p -> class == FFUNC || p -> class == FPROC ) { 464: putRV((char *) 0 , cbn , tempdescrp -> value[ NL_OFFS ] , 465: tempdescrp -> extra_flags , PCCTM_PTR|PCCT_STRTY ); 466: if ( !noarguments ) { 467: putop( PCC_CM , PCCT_INT ); 468: } 469: noarguments = FALSE; 470: putLV((char *) 0 , cbn , savedispnp -> value[ NL_OFFS ] , 471: savedispnp -> extra_flags , PCCTM_PTR | PCCT_STRTY ); 472: putop( PCC_CM , PCCT_INT ); 473: } 474: /* 475: * do the actual call: 476: * either ... p( ... ) ... 477: * or ... ( t -> entryaddr )( ... ) ... 478: * and maybe an assignment. 479: */ 480: if ( porf == FUNC ) { 481: switch ( p_type_class ) { 482: case TBOOL: 483: case TCHAR: 484: case TINT: 485: case TSCAL: 486: case TDOUBLE: 487: case TPTR: 488: putop( ( noarguments ? PCCOM_UNARY PCC_CALL : PCC_CALL ) , 489: (int) p_type_p2type ); 490: if ( p -> class == FFUNC ) { 491: putop( PCC_ASSIGN , (int) p_type_p2type ); 492: } 493: break; 494: default: 495: putstrop( ( noarguments ? PCCOM_UNARY PCC_STCALL : PCC_STCALL ), 496: (int) PCCM_ADDTYPE( p_type_p2type , PCCTM_PTR ) , 497: (int) p_type_width ,(int) p_type_align ); 498: putstrop(PCC_STASG, (int) PCCM_ADDTYPE(p_type_p2type, PCCTM_PTR), 499: (int) lwidth(p -> type), align(p -> type)); 500: break; 501: } 502: } else { 503: putop( ( noarguments ? PCCOM_UNARY PCC_CALL : PCC_CALL ) , PCCT_INT ); 504: } 505: /* 506: * ( t=p , ... , FRTN( t ) ... 507: */ 508: if ( p -> class == FFUNC || p -> class == FPROC ) { 509: putop( PCC_COMOP , PCCT_INT ); 510: putleaf( PCC_ICON , 0 , 0 , PCCM_ADDTYPE( PCCTM_FTN | PCCT_INT , PCCTM_PTR ) , 511: "_FRTN" ); 512: putRV((char *) 0 , cbn , tempdescrp -> value[ NL_OFFS ] , 513: tempdescrp -> extra_flags , PCCTM_PTR | PCCT_STRTY ); 514: putLV((char *) 0 , cbn , savedispnp -> value[ NL_OFFS ] , 515: savedispnp -> extra_flags , PCCTM_PTR | PCCT_STRTY ); 516: putop( PCC_CM , PCCT_INT ); 517: putop( PCC_CALL , PCCT_INT ); 518: putop( PCC_COMOP , PCCT_INT ); 519: } 520: /* 521: * if required: 522: * either ... , temp ) 523: * or ... , &temp ) 524: */ 525: if ( porf == FUNC && temptype != PCCT_UNDEF ) { 526: if ( temptype != PCCT_STRTY ) { 527: putRV((char *) 0 , cbn , tempnlp -> value[ NL_OFFS ] , 528: tempnlp -> extra_flags , (int) p_type_p2type ); 529: } else { 530: putLV((char *) 0 , cbn , tempnlp -> value[ NL_OFFS ] , 531: tempnlp -> extra_flags , (int) p_type_p2type ); 532: } 533: putop( PCC_COMOP , PCCT_INT ); 534: } 535: if ( porf == PROC ) { 536: putdot( filename , line ); 537: } 538: # endif PC 539: return (p->type); 540: } 541: 542: rvlist(al) 543: register struct tnode *al; 544: { 545: 546: for (; al != TR_NIL; al = al->list_node.next) 547: (void) rvalue( al->list_node.list, NLNIL , RREQ ); 548: } 549: 550: /* 551: * check that two function/procedure namelist entries are compatible 552: */ 553: bool 554: fcompat( formal , actual ) 555: struct nl *formal; 556: struct nl *actual; 557: { 558: register struct nl *f_chain; 559: register struct nl *a_chain; 560: extern struct nl *plist(); 561: bool compat = TRUE; 562: 563: if ( formal == NLNIL || actual == NLNIL ) { 564: return FALSE; 565: } 566: for (a_chain = plist(actual), f_chain = plist(formal); 567: f_chain != NLNIL; 568: f_chain = f_chain->chain, a_chain = a_chain->chain) { 569: if (a_chain == NIL) { 570: error("%s %s declared on line %d has more arguments than", 571: parnam(formal->class), formal->symbol, 572: (char *) linenum(formal)); 573: cerror("%s %s declared on line %d", 574: parnam(actual->class), actual->symbol, 575: (char *) linenum(actual)); 576: return FALSE; 577: } 578: if ( a_chain -> class != f_chain -> class ) { 579: error("%s parameter %s of %s declared on line %d is not identical", 580: parnam(f_chain->class), f_chain->symbol, 581: formal->symbol, (char *) linenum(formal)); 582: cerror("with %s parameter %s of %s declared on line %d", 583: parnam(a_chain->class), a_chain->symbol, 584: actual->symbol, (char *) linenum(actual)); 585: compat = FALSE; 586: } else if (a_chain->class == FFUNC || a_chain->class == FPROC) { 587: /*compat = (compat && fcompat(f_chain, a_chain));*/ 588: if ((compat) && (fcompat(f_chain, a_chain))) 589: compat = TRUE; 590: else compat = FALSE; 591: } 592: if ((a_chain->class != FPROC && f_chain->class != FPROC) && 593: (a_chain->type != f_chain->type)) { 594: error("Type of %s parameter %s of %s declared on line %d is not identical", 595: parnam(f_chain->class), f_chain->symbol, 596: formal->symbol, (char *) linenum(formal)); 597: cerror("to type of %s parameter %s of %s declared on line %d", 598: parnam(a_chain->class), a_chain->symbol, 599: actual->symbol, (char *) linenum(actual)); 600: compat = FALSE; 601: } 602: } 603: if (a_chain != NIL) { 604: error("%s %s declared on line %d has fewer arguments than", 605: parnam(formal->class), formal->symbol, 606: (char *) linenum(formal)); 607: cerror("%s %s declared on line %d", 608: parnam(actual->class), actual->symbol, 609: (char *) linenum(actual)); 610: return FALSE; 611: } 612: return compat; 613: } 614: 615: char * 616: parnam(nltype) 617: int nltype; 618: { 619: switch(nltype) { 620: case REF: 621: return "var"; 622: case VAR: 623: return "value"; 624: case FUNC: 625: case FFUNC: 626: return "function"; 627: case PROC: 628: case FPROC: 629: return "procedure"; 630: default: 631: return "SNARK"; 632: } 633: } 634: 635: struct nl *plist(p) 636: struct nl *p; 637: { 638: switch (p->class) { 639: case FFUNC: 640: case FPROC: 641: return p->ptr[ NL_FCHAIN ]; 642: case PROC: 643: case FUNC: 644: return p->chain; 645: default: 646: { 647: panic("plist"); 648: return(NLNIL); /* this is here only so lint won't complain 649: panic actually aborts */ 650: } 651: 652: } 653: } 654: 655: linenum(p) 656: struct nl *p; 657: { 658: if (p->class == FUNC) 659: return p->ptr[NL_FVAR]->value[NL_LINENO]; 660: return p->value[NL_LINENO]; 661: }
Defined functions
call
defined in line 58; used 5 times
- in /usr/src/ucb/PORT/pascal/src/0.h line 759
- in /usr/src/ucb/PORT/pascal/src/func.c line 61
- in /usr/src/ucb/PORT/pascal/src/pcfunc.c line 68
- in /usr/src/ucb/PORT/pascal/src/pcproc.c line 115
- in /usr/src/ucb/PORT/pascal/src/proc.c line 109
fcompat
defined in line 553; used 4 times
- in line 406, 417, 588
- in /usr/src/ucb/PORT/pascal/src/0.h line 726
plist
defined in line 635; used 5 times
- in line 207, 560, 566(2)
- in /usr/src/ucb/PORT/pascal/src/0.h line 736
rvlist
defined in line 542; used 16 times
- in line 439
- in /usr/src/ucb/PORT/pascal/src/func.c line 47-52(2), 88, 105, 115
- in /usr/src/ucb/PORT/pascal/src/pcfunc.c line 54-59(2), 102, 113, 134, 144
- in /usr/src/ucb/PORT/pascal/src/pcproc.c line 100-105(2)
- in /usr/src/ucb/PORT/pascal/src/proc.c line 94-99(2)
Defined variables
|
Last modified: 1985-07-27
Generated: 2016-12-26 |
Generated by src2html V0.67
page hit count: 3948 |
|