call.c

早期freebsd实现

/*-
 * Copyright (c) 1980, 1993
 *	The Regents of the University of California.  All rights reserved.
 *
 * Redistribution and use in source and binary forms, with or without
 * modification, are permitted provided that the following conditions
 * are met:
 * 1. Redistributions of source code must retain the above copyright
 *    notice, this list of conditions and the following disclaimer.
 * 2. Redistributions in binary form must reproduce the above copyright
 *    notice, this list of conditions and the following disclaimer in the
 *    documentation and/or other materials provided with the distribution.
 * 3. All advertising materials mentioning features or use of this software
 *    must display the following acknowledgement:
 *	This product includes software developed by the University of
 *	California, Berkeley and its contributors.
 * 4. Neither the name of the University nor the names of its contributors
 *    may be used to endorse or promote products derived from this software
 *    without specific prior written permission.
 *
 * THIS SOFTWARE IS PROVIDED BY THE REGENTS AND CONTRIBUTORS ``AS IS'' AND
 * ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
 * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
 * ARE DISCLAIMED.  IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE
 * FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
 * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
 * OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
 * HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
 * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
 * OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
 * SUCH DAMAGE.
 */

#ifndef lint
static char sccsid[] = "@(#)call.c	8.1 (Berkeley) 6/6/93";
#endif /* not lint */

#include "whoami.h"
#include "0.h"
#include "tree.h"
#include "opcode.h"
#include "objfmt.h"
#include "align.h"
#ifdef PC
#   include "pc.h"
#   include <pcc.h>
#endif PC
#include "tmps.h"
#include "tree_ty.h"

/*
 * 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.
 *
 *	the idea here is that regular scalar functions are just called,
 *	while structure functions and formal functions have their results
 *	stored in a temporary after the call.
 *	structure functions do this because they return pointers
 *	to static results, so we copy the static
 *	and return a pointer to the copy.
 *	formal functions do this because we have to save the result
 *	around a call to the runtime routine which restores the display,
 *	so we can't just leave the result lying around in registers.
 *	formal calls save the address of the descriptor in a local
 *	temporary, so it can be addressed for the call which restores
 *	the display (FRTN).
 *	calls to formal parameters pass the formal as a hidden argument 
 *	to a special entry point for the formal call.
 *	[this is somewhat dependent on the way arguments are addressed.]
 *	so PROCs and scalar FUNCs look like
 *		p(...args...)
 *	structure FUNCs look like
 *		(temp = p(...args...),&temp)
 *	formal FPROCs look like
 *		( t=p,( t -> entryaddr )(...args...,t,s),FRTN(t,s))
 *	formal scalar FFUNCs look like
 *		( t=p,temp=( t -> entryaddr )(...args...,t,s),FRTN(t,s),temp)
 *	formal structure FFUNCs look like
 *		(t=p,temp = ( t -> entryaddr )(...args...,t,s),FRTN(t,s),&temp)
 */
struct nl *
call(p, argv_node, porf, psbn)
	struct nl *p;
	struct tnode	*argv_node;	/* list node */
	int porf, psbn;
{
	register struct nl *p1, *q, *p2;
	register struct nl *ptype, *ctype;
	struct tnode *rnode;
	int i, j, d;
	bool chk = TRUE;
 	struct nl	*savedispnp;	/* temporary to hold saved display */
#	ifdef PC
	    int		p_type_class = classify( p -> type );
	    long	p_type_p2type = p2type( p -> type );
	    bool	noarguments;
		/*
		 *	these get used if temporaries and structures are used
		 */
	    struct nl	*tempnlp;
	    long	temptype;	/* type of the temporary */
	    long	p_type_width;
	    long	p_type_align;
	    char	extname[ BUFSIZ ];
	    struct nl	*tempdescrp;
#	endif PC

         if (p->class == FFUNC || p->class == FPROC) {
 	    /*
 	     * allocate space to save the display for formal calls
 	     */
	    savedispnp = tmpalloc( (long) sizeof display , NLNIL , NOREG );
 	}
#	ifdef OBJ
	    if (p->class == FFUNC || p->class == FPROC) {
 		(void) put(2, O_LV | cbn << 8 + INDX ,
 			(int) savedispnp -> value[ NL_OFFS ] );
		(void) put(2, PTR_RV | psbn << 8+INDX, (int)p->value[NL_OFFS]);
	    }
	    if (porf == FUNC) {
		    /*
		     * Push some space
		     * for the function return type
		     */
		    (void) put(2, O_PUSH,
			-roundup(lwidth(p->type), (long) A_STACK));
	    }
#	endif OBJ
#	ifdef PC
		/*
		 *	if this is a formal call,
		 *	stash the address of the descriptor
		 *	in a temporary so we can find it
		 *	after the FCALL for the call to FRTN
		 */
	    if ( p -> class == FFUNC || p -> class == FPROC ) {
		tempdescrp = tmpalloc((long) (sizeof( struct formalrtn *)),
					NLNIL, REGOK );
		putRV((char *) 0 , cbn , tempdescrp -> value[ NL_OFFS ] ,
			tempdescrp -> extra_flags , PCCTM_PTR|PCCT_STRTY );
		putRV((char *) 0 , psbn , p -> value[ NL_OFFS ] ,
			p -> extra_flags , PCCTM_PTR|PCCT_STRTY );
		putop( PCC_ASSIGN , PCCTM_PTR | PCCT_STRTY );
	    }
		/*
		 *	if we have to store a temporary,
		 *	temptype will be its type,
		 *	otherwise, it's PCCT_UNDEF.
		 */
	    temptype = PCCT_UNDEF;
	    if ( porf == FUNC ) {
		p_type_width = width( p -> type );
		switch( p_type_class ) {
		    case TSTR:
		    case TSET:
		    case TREC:
		    case TFILE:
		    case TARY:
			temptype = PCCT_STRTY;
			p_type_align = align( p -> type );
			break;
		    default:
			if ( p -> class == FFUNC ) {
			    temptype = p2type( p -> type );
			}
			break;
		}
		if ( temptype != PCCT_UNDEF ) {
		    tempnlp = tmpalloc(p_type_width, p -> type, NOREG);
			/*
			 *	temp
			 *	for (temp = ...
			 */
		    putRV((char *) 0 , cbn , tempnlp -> value[ NL_OFFS ] ,
			    tempnlp -> extra_flags , (int) temptype );
		}
	    }
	    switch ( p -> class ) {
		case FUNC:
		case PROC:
			/*
			 *	... p( ...
			 */
		    sextname( extname , p -> symbol , BLOCKNO(p -> nl_block) );
		    putleaf( PCC_ICON , 0 , 0 , p2type( p ) , extname );
		    break;
		case FFUNC:
		case FPROC:

			    /*
			     *	... ( t -> entryaddr )( ...
			     */
			    /* 	the descriptor */
			putRV((char *) 0 , cbn , tempdescrp -> value[ NL_OFFS ] ,
				tempdescrp -> extra_flags , PCCTM_PTR | PCCT_STRTY );
			    /*	the entry address within the descriptor */
			if ( FENTRYOFFSET != 0 ) {
			    putleaf( PCC_ICON , FENTRYOFFSET , 0 , PCCT_INT , 
						(char *) 0 );
			    putop( PCC_PLUS , 
				PCCM_ADDTYPE(
				    PCCM_ADDTYPE( PCCM_ADDTYPE( p2type( p ) , PCCTM_FTN ) ,
					    PCCTM_PTR ) ,
					PCCTM_PTR ) );
			}
			    /*
			     *	indirect to fetch the formal entry address
			     *	with the result type of the routine.
			     */
			if (p -> class == FFUNC) {
			    putop( PCCOM_UNARY PCC_MUL ,
				PCCM_ADDTYPE(PCCM_ADDTYPE(p2type(p -> type), PCCTM_FTN),
					PCCTM_PTR));
			} else {
				/* procedures are int returning functions */
			    putop( PCCOM_UNARY PCC_MUL ,
				PCCM_ADDTYPE(PCCM_ADDTYPE(PCCT_INT, PCCTM_FTN), PCCTM_PTR));
			}
			break;
		default:
			panic("call class");
	    }
	    noarguments = TRUE;
#	endif PC
	/*
	 * Loop and process each of
	 * arguments to the proc/func.
	 *	... ( ... args ... ) ...
	 */
	ptype = NIL;
	for (p1 = plist(p); p1 != NLNIL; p1 = p1->chain) {
	    if (argv_node == TR_NIL) {
		    error("Not enough arguments to %s", p->symbol);
		    return (NLNIL);
	    }
	    switch (p1->class) {
		case REF:
			/*
			 * Var parameter
			 */
			rnode = argv_node->list_node.list;
			if (rnode != TR_NIL && rnode->tag != T_VAR) {
				error("Expression given (variable required) for var parameter %s of %s", p1->symbol, p->symbol);
				chk = FALSE;
				break;
			}
			q = lvalue( argv_node->list_node.list,
					MOD | ASGN , LREQ );
			if (q == NIL) {
				chk = FALSE;
				break;
			}
			p2 = p1->type;
			if (p2 == NLNIL || p2->chain == NLNIL || p2->chain->class != CRANGE) {
			    if (q != p2) {
				error("Parameter type not identical to type of var parameter %s of %s", p1->symbol, p->symbol);
				chk = FALSE;
			    }
			    break;
			} else {
			    /* conformant array */
			    if (p1 == ptype) {
				if (q != ctype) {
				    error("Conformant array parameters in the same specification must be the same type.");
				    goto conf_err;
				}
			    } else {
				if (classify(q) != TARY && classify(q) != TSTR) {
				    error("Array type required for var parameter %s of %s",p1->symbol,p->symbol);
				    goto conf_err;
				}
				/* check base type of array */
				if (p2->type != q->type) {
				    error("Base type of array not identical to that of conformant array parameter %s of %s", p1->symbol, p->symbol);
				    goto conf_err;
				}
				if (p2->value[0] != q->value[0]) {
				    error("Subscript number mismatch on conformant array parameter %s of %s", p1->symbol, p->symbol);
				    /* Don't process array bounds & width */
conf_err:			    if (p1->chain->type->class == CRANGE) {
					d = p1->value[0];
					for (i = 1; i <= d; i++) {
					    /* for each subscript, pass by
					     * bounds and width
					     */
					    p1 = p1->chain->chain->chain;
					}
				    }
				    ptype = ctype = NLNIL;
				    chk = FALSE;
				    break;
				}
				/*
				 * Save array type for all parameters with same
				 * specification.
				 */
				ctype = q;
				ptype = p2;
				/*
				 * If at end of conformant array list,
				 * get bounds.
				 */
				if (p1->chain->type->class == CRANGE) {
				    /* check each subscript, put on stack */
				    d = ptype->value[0];
				    q = ctype;
				    for (i = 1; i <= d; i++) {
					p1 = p1->chain;
					q = q->chain;
					if (incompat(q, p1->type, TR_NIL)){
					    error("Subscript type not conformable with parameter %s of %s", p1->symbol, p->symbol);
					    chk = FALSE;
					    break;
					}
					/* Put lower and upper bound & width */
#					ifdef OBJ
					if (q->type->class == CRANGE) {
					    putcbnds(q->type);
					} else {
					    put(2, width(p1->type) <= 2 ? O_CON2
						: O_CON4, q->range[0]);
					    put(2, width(p1->type) <= 2 ? O_CON2
						: O_CON4, q->range[1]);
					    put(2, width(p1->type) <= 2 ? O_CON2
						: O_CON4, aryconst(ctype,i));
					}
#					endif OBJ
#					ifdef PC
					if (q->type->class == CRANGE) {
					    for (j = 1; j <= 3; j++) {
						p2 = p->nptr[j];
						putRV(p2->symbol, (p2->nl_block
						    & 037), p2->value[0],
						    p2->extra_flags,p2type(p2));
						putop(PCC_CM, PCCT_INT);
					    }
					} else {
					    putleaf(PCC_ICON, q->range[0], 0,PCCT_INT,0);
					    putop( PCC_CM , PCCT_INT );
					    putleaf(PCC_ICON, q->range[1], 0,PCCT_INT,0);
					    putop( PCC_CM , PCCT_INT );