xref: /csrg-svn/usr.bin/pascal/src/call.c (revision 745)

/* Copyright (c) 1979 Regents of the University of California */

static	char sccsid[] = "@(#)call.c 1.1 08/27/80";

#include "whoami.h"
#include "0.h"
#include "tree.h"
#include "opcode.h"
#include "objfmt.h"
#ifdef PC
#   include "pc.h"
#   include "pcops.h"
#endif PC

/*
 * Call generates code for calls to
 * user defined procedures and functions
 * and is called by proc and funccod.
 * P is the result of the lookup
 * of the procedure/function symbol,
 * and porf is PROC or FUNC.
 * Psbn is the block number of p.
 */
struct nl *
call(p, argv, porf, psbn)
	struct nl *p;
	int *argv, porf, psbn;
{
	register struct nl *p1, *q;
	int *r;

#	ifdef PC
	    long	temp;
	    int		firsttime;
	    int		rettype;
#	endif PC

#	ifdef OBJ
	    if (porf == FUNC)
		    /*
		     * Push some space
		     * for the function return type
		     */
		    put2(O_PUSH, even(-width(p->type)));
#	endif OBJ
#	ifdef PC
	    if ( porf == FUNC ) {
		switch( classify( p -> type ) ) {
		    case TSTR:
		    case TSET:
		    case TREC:
		    case TFILE:
		    case TARY:
			temp = sizes[ cbn ].om_off -= width( p -> type );
			putlbracket( ftnno , -sizes[cbn].om_off );
			if (sizes[cbn].om_off < sizes[cbn].om_max) {
				sizes[cbn].om_max = sizes[cbn].om_off;
			}
			putRV( 0 , cbn , temp , P2STRTY );
		}
	    }
	    {
		char	extname[ BUFSIZ ];
		char	*starthere;
		int	funcbn;
		int	i;

		starthere = &extname[0];
		funcbn = p -> nl_block & 037;
		for ( i = 1 ; i < funcbn ; i++ ) {
		    sprintf( starthere , EXTFORMAT , enclosing[ i ] );
		    starthere += strlen( enclosing[ i ] ) + 1;
		}
		sprintf( starthere , EXTFORMAT , p -> symbol );
		starthere += strlen( p -> symbol ) + 1;
		if ( starthere >= &extname[ BUFSIZ ] ) {
		    panic( "call namelength" );
		}
		putleaf( P2ICON , 0 , 0 , p2type( p ) , extname );
	    }
	    firsttime = TRUE;
#	endif PC
	/*
	 * Loop and process each of
	 * arguments to the proc/func.
	 */
	for (p1 = p->chain; p1 != NIL; p1 = p1->chain) {
	    if (argv == NIL) {
		    error("Not enough arguments to %s", p->symbol);
		    return (NIL);
	    }
	    switch (p1->class) {
		case REF:
			/*
			 * Var parameter
			 */
			r = argv[1];
			if (r != NIL && r[0] != T_VAR) {
				error("Expression given (variable required) for var parameter %s of %s", p1->symbol, p->symbol);
				break;
			}
			q = lvalue( (int *) argv[1], MOD , LREQ );
			if (q == NIL)
				break;
			if (q != p1->type) {
				error("Parameter type not identical to type of var parameter %s of %s", p1->symbol, p->symbol);
				break;
			}
			break;
		case VAR:
			/*
			 * Value parameter
			 */
#			ifdef OBJ
			    q = rvalue(argv[1], 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 = rvalue( argv[1] , p1 -> type , LREQ );
				    break;
				case TINT:
				case TSCAL:
				case TBOOL:
				case TCHAR:
				    precheck( p1 -> type , "_RANG4" , "_RSNG4" );
				    q = rvalue( argv[1] , p1 -> type , RREQ );
				    postcheck( p1 -> type );
				    break;
					/*
					 * and fall through
					 */
				default:
				    q = rvalue( argv[1] , p1 -> type , RREQ );
				    break;
			    }
#			endif PC
			if (q == NIL)
				break;
			if (incompat(q, p1->type, argv[1])) {
				cerror("Expression type clashed with type of value parameter %s of %s", p1->symbol, p->symbol);
				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( P2STARG
					    , p2type( p1 -> type )
					    , lwidth( p1 -> type )
					    , align( p1 -> type ) );
			    }
#			endif PC
			break;
		default:
			panic("call");
	    }
#	    ifdef PC
		    /*
		     *	if this is the nth (>1) argument,
		     *	hang it on the left linear list of arguments
		     */
		if ( firsttime ) {
			firsttime = FALSE;
		} else {
			putop( P2LISTOP , P2INT );
		}
#	    endif PC
	    argv = argv[2];
	}
	if (argv != NIL) {
		error("Too many arguments to %s", p->symbol);
		rvlist(argv);
		return (NIL);
	}
#	ifdef OBJ
	    put2(O_CALL | psbn << 8+INDX, p->entloc);
	    put2(O_POP, p->value[NL_OFFS]-DPOFF2);
#	endif OBJ
#	ifdef PC
	    if ( porf == FUNC ) {
		rettype = p2type( p -> type );
		switch ( classify( p -> type ) ) {
		    case TBOOL:
		    case TCHAR:
		    case TINT:
		    case TSCAL:
		    case TDOUBLE:
		    case TPTR:
			if ( p -> chain == NIL ) {
				putop( P2UNARY P2CALL , rettype );
			} else {
				putop( P2CALL , rettype );
			}
			break;
		    default:
			if ( p -> chain == NIL ) {
				putstrop( P2UNARY P2STCALL
					, ADDTYPE( rettype , P2PTR )
					, lwidth( p -> type )
					, align( p -> type ) );
			} else {
				putstrop( P2STCALL
					, ADDTYPE( rettype , P2PTR )
					, lwidth( p -> type )
					, align( p -> type ) );
			}
			putstrop( P2STASG , rettype , lwidth( p -> type )
				, align( p -> type ) );
			putLV( 0 , cbn , temp , rettype );
			putop( P2COMOP , P2INT );
			break;
		}
	    } else {
		if ( p -> chain == NIL ) {
			putop( P2UNARY P2CALL , P2INT );
		} else {
			putop( P2CALL , P2INT );
		}
		putdot( filename , line );
	    }
#	endif PC
	return (p->type);
}

rvlist(al)
	register int *al;
{

	for (; al != NIL; al = al[2])
		rvalue( (int *) al[1], NLNIL , RREQ );
}