# 2.11BSD#431 - /usr/src/ucb/PORT/pascal/src/call.c

##### Functions

    call              X
    fcompat           X
    linenum           X
    parnam            X
    plist             X
    rvlist            X

       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

linenum defined in line 655; used 8 times

- in line 572-575(2), 581-584(2), 596-599(2), 606-609(2)

parnam defined in line 615; used 9 times

- in line 571-574(2), 580-583(2), 595-598(2), 605-608(2)
- in /usr/src/ucb/PORT/pascal/src/0.h line 717

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

sccsid defined in line 8; never used

Last modified: 1985-07-27 Generated: 2016-12-26 | Generated by src2html V0.67 page hit count: 1797 |