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

fcompat defined in line 553; used 4 times
linenum defined in line 655; used 8 times
parnam defined in line 615; used 9 times
plist defined in line 635; used 5 times

Defined variables

sccsid defined in line 8; never used
Last modified: 1985-07-27
Generated: 2016-12-26
Generated by src2html V0.67
page hit count: 2663
Valid CSS Valid XHTML 1.0 Strict