call.c

早期freebsd实现

					    putleaf(PCC_ICON,aryconst(ctype,i),0,PCCT_INT,0);
					    putop( PCC_CM , PCCT_INT );
					}
#					endif PC
					p1 = p1->chain->chain;
				    }
				}
			    }
			}
			break;
		case VAR:
			/*
			 * Value parameter
			 */
#			ifdef OBJ
			    q = rvalue(argv_node->list_node.list,
					p1->type , RREQ );
#			endif OBJ
#			ifdef PC
				/*
				 * structure arguments require lvalues,
				 * scalars use rvalue.
				 */
			    switch( classify( p1 -> type ) ) {
				case TFILE:
				case TARY:
				case TREC:
				case TSET:
				case TSTR:
				q = stkrval(argv_node->list_node.list,
						p1 -> type , (long) LREQ );
				    break;
				case TINT:
				case TSCAL:
				case TBOOL:
				case TCHAR:
				    precheck( p1 -> type , "_RANG4" , "_RSNG4" );
				q = stkrval(argv_node->list_node.list,
						p1 -> type , (long) RREQ );
				    postcheck(p1 -> type, nl+T4INT);
				    break;
				case TDOUBLE:
				q = stkrval(argv_node->list_node.list,
						p1 -> type , (long) RREQ );
				    sconv(p2type(q), PCCT_DOUBLE);
				    break;
				default:
				    q = rvalue(argv_node->list_node.list,
						p1 -> type , RREQ );
				    break;
			    }
#			endif PC
			if (q == NIL) {
				chk = FALSE;
				break;
			}
			if (incompat(q, p1->type,
				argv_node->list_node.list)) {
				cerror("Expression type clashed with type of value parameter %s of %s", p1->symbol, p->symbol);
				chk = FALSE;
				break;
			}
#			ifdef OBJ
			    if (isa(p1->type, "bcsi"))
				    rangechk(p1->type, q);
			    if (q->class != STR)
				    convert(q, p1->type);
#			endif OBJ
#			ifdef PC
			    switch( classify( p1 -> type ) ) {
				case TFILE:
				case TARY:
				case TREC:
				case TSET:
				case TSTR:
					putstrop( PCC_STARG
					    , p2type( p1 -> type )
					    , (int) lwidth( p1 -> type )
					    , align( p1 -> type ) );
			    }
#			endif PC
			break;
		case FFUNC:
			/*
			 * function parameter
			 */
			q = flvalue(argv_node->list_node.list, p1 );
			/*chk = (chk && fcompat(q, p1));*/
			if ((chk) && (fcompat(q, p1)))
			    chk = TRUE;
			else
			    chk = FALSE;
			break;
		case FPROC:
			/*
			 * procedure parameter
			 */
			q = flvalue(argv_node->list_node.list, p1 );
			/* chk = (chk && fcompat(q, p1)); */
			if ((chk) && (fcompat(q, p1)))
			    chk = TRUE;
			else chk = FALSE;
			break;
		default:
			panic("call");
	    }
#	    ifdef PC
		    /*
		     *	if this is the nth (>1) argument,
		     *	hang it on the left linear list of arguments
		     */
		if ( noarguments ) {
			noarguments = FALSE;
		} else {
			putop( PCC_CM , PCCT_INT );
		}
#	    endif PC
	    argv_node = argv_node->list_node.next;
	}
	if (argv_node != TR_NIL) {
		error("Too many arguments to %s", p->symbol);
		rvlist(argv_node);
		return (NLNIL);
	}
	if (chk == FALSE)
		return NLNIL;
#	ifdef OBJ
	    if ( p -> class == FFUNC || p -> class == FPROC ) {
		(void) put(2, PTR_RV | psbn << 8+INDX, (int)p->value[NL_OFFS]);
 		(void) put(2, O_LV | cbn << 8 + INDX ,
 			(int) savedispnp -> value[ NL_OFFS ] );
		(void) put(1, O_FCALL);
		(void) put(2, O_FRTN, roundup(width(p->type), (long) A_STACK));
	    } else {
		(void) put(2, O_CALL | psbn << 8, (long)p->value[NL_ENTLOC]);
	    }
#	endif OBJ
#	ifdef PC
		/*
		 *	for formal calls: add the hidden argument
		 *	which is the formal struct describing the
		 *	environment of the routine.
		 *	and the argument which is the address of the
		 *	space into which to save the display.
		 */
	    if ( p -> class == FFUNC || p -> class == FPROC ) {
		putRV((char *) 0 , cbn , tempdescrp -> value[ NL_OFFS ] ,
			tempdescrp -> extra_flags , PCCTM_PTR|PCCT_STRTY );
		if ( !noarguments ) {
		    putop( PCC_CM , PCCT_INT );
		}
		noarguments = FALSE;
 		putLV((char *) 0 , cbn , savedispnp -> value[ NL_OFFS ] ,
 			savedispnp -> extra_flags , PCCTM_PTR | PCCT_STRTY );
 		putop( PCC_CM , PCCT_INT );
	    }
		/*
		 *	do the actual call:
		 *	    either	... p( ... ) ...
		 *	    or		... ( t -> entryaddr )( ... ) ...
		 *	and maybe an assignment.
		 */
	    if ( porf == FUNC ) {
		switch ( p_type_class ) {
		    case TBOOL:
		    case TCHAR:
		    case TINT:
		    case TSCAL:
		    case TDOUBLE:
		    case TPTR:
			putop( ( noarguments ? PCCOM_UNARY PCC_CALL : PCC_CALL ) ,
				(int) p_type_p2type );
			if ( p -> class == FFUNC ) {
			    putop( PCC_ASSIGN , (int) p_type_p2type );
			}
			break;
		    default:
			putstrop( ( noarguments ? PCCOM_UNARY PCC_STCALL : PCC_STCALL ),
				(int) PCCM_ADDTYPE( p_type_p2type , PCCTM_PTR ) ,
				(int) p_type_width ,(int) p_type_align );
			putstrop(PCC_STASG, (int) PCCM_ADDTYPE(p_type_p2type, PCCTM_PTR),
				(int) lwidth(p -> type), align(p -> type));
			break;
		}
	    } else {
		putop( ( noarguments ? PCCOM_UNARY PCC_CALL : PCC_CALL ) , PCCT_INT );
	    }
		/*
		 *	( t=p , ... , FRTN( t ) ...
		 */
	    if ( p -> class == FFUNC || p -> class == FPROC ) {
		putop( PCC_COMOP , PCCT_INT );
		putleaf( PCC_ICON , 0 , 0 , PCCM_ADDTYPE( PCCTM_FTN | PCCT_INT , PCCTM_PTR ) ,
			"_FRTN" );
		putRV((char *) 0 , cbn , tempdescrp -> value[ NL_OFFS ] ,
			tempdescrp -> extra_flags , PCCTM_PTR | PCCT_STRTY );
 		putLV((char *) 0 , cbn , savedispnp -> value[ NL_OFFS ] ,
 			savedispnp -> extra_flags , PCCTM_PTR | PCCT_STRTY );
 		putop( PCC_CM , PCCT_INT );
		putop( PCC_CALL , PCCT_INT );
		putop( PCC_COMOP , PCCT_INT );
	    }
		/*
		 *	if required:
		 *	either	... , temp )
		 *	or	... , &temp )
		 */
	    if ( porf == FUNC && temptype != PCCT_UNDEF ) {
		if ( temptype != PCCT_STRTY ) {
		    putRV((char *) 0 , cbn , tempnlp -> value[ NL_OFFS ] ,
			    tempnlp -> extra_flags , (int) p_type_p2type );
		} else {
		    putLV((char *) 0 , cbn , tempnlp -> value[ NL_OFFS ] ,
			    tempnlp -> extra_flags , (int) p_type_p2type );
		}
		putop( PCC_COMOP , PCCT_INT );
	    }
	    if ( porf == PROC ) {
		putdot( filename , line );
	    }
#	endif PC
	return (p->type);
}

rvlist(al)
	register struct tnode *al;
{

	for (; al != TR_NIL; al = al->list_node.next)
		(void) rvalue( al->list_node.list, NLNIL , RREQ );
}

    /*
     *	check that two function/procedure namelist entries are compatible
     */
bool
fcompat( formal , actual )
    struct nl	*formal;
    struct nl	*actual;
{
    register struct nl	*f_chain;
    register struct nl	*a_chain;
    extern struct nl	*plist();
    bool compat = TRUE;

    if ( formal == NLNIL || actual == NLNIL ) {
	return FALSE;
    }
    for (a_chain = plist(actual), f_chain = plist(formal);
         f_chain != NLNIL;
	 f_chain = f_chain->chain, a_chain = a_chain->chain) {
	if (a_chain == NIL) {
	    error("%s %s declared on line %d has more arguments than",
		parnam(formal->class), formal->symbol,
		(char *) linenum(formal));
	    cerror("%s %s declared on line %d",
		parnam(actual->class), actual->symbol,
		(char *) linenum(actual));
	    return FALSE;
	}
	if ( a_chain -> class != f_chain -> class ) {
	    error("%s parameter %s of %s declared on line %d is not identical",
		parnam(f_chain->class), f_chain->symbol,
		formal->symbol, (char *) linenum(formal));
	    cerror("with %s parameter %s of %s declared on line %d",
		parnam(a_chain->class), a_chain->symbol,
		actual->symbol, (char *) linenum(actual));
	    compat = FALSE;
	} else if (a_chain->class == FFUNC || a_chain->class == FPROC) {
	    /*compat = (compat && fcompat(f_chain, a_chain));*/
	    if ((compat) && (fcompat(f_chain, a_chain)))
		compat = TRUE;
	    else compat = FALSE;
	}
	if ((a_chain->class != FPROC && f_chain->class != FPROC) &&
	    (a_chain->type != f_chain->type)) {
	    error("Type of %s parameter %s of %s declared on line %d is not identical",
		parnam(f_chain->class), f_chain->symbol,
		formal->symbol, (char *) linenum(formal));
	    cerror("to type of %s parameter %s of %s declared on line %d",
		parnam(a_chain->class), a_chain->symbol,
		actual->symbol, (char *) linenum(actual));
	    compat = FALSE;
	}
    }
    if (a_chain != NIL) {
	error("%s %s declared on line %d has fewer arguments than",
	    parnam(formal->class), formal->symbol,
	    (char *) linenum(formal));
	cerror("%s %s declared on line %d",
	    parnam(actual->class), actual->symbol,
	    (char *) linenum(actual));
	return FALSE;
    }
    return compat;
}

char *
parnam(nltype)
    int nltype;
{
    switch(nltype) {
	case REF:
	    return "var";
	case VAR:
	    return "value";
	case FUNC:
	case FFUNC:
	    return "function";
	case PROC:
	case FPROC:
	    return "procedure";
	default:
	    return "SNARK";
    }
}

struct nl *plist(p)
    struct nl *p;
{
    switch (p->class) {
	case FFUNC:
	case FPROC:
	    return p->ptr[ NL_FCHAIN ];
	case PROC:
	case FUNC:
	    return p->chain;
	default:
	    {
		panic("plist");
		return(NLNIL); /* this is here only so lint won't complain
				  panic actually aborts */
	    }

    }
}

linenum(p)
    struct nl *p;
{
    if (p->class == FUNC)
	return p->ptr[NL_FVAR]->value[NL_LINENO];
    return p->value[NL_LINENO];
}