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