/* Copyright (c) 1979 Regents of the University of California */
static char sccsid
[] = "@(#)call.c 1.26 %G%";
* 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
* 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
* 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)
call(p
, argv_node
, porf
, psbn
)
struct tnode
*argv_node
; /* list node */
register struct nl
*p1
, *q
;
struct nl
*savedispnp
; /* temporary to hold saved display */
int p_type_class
= classify( p
-> type
);
long p_type_p2type
= p2type( p
-> type
);
* these get used if temporaries and structures are used
long temptype
; /* type of the temporary */
if (p
->class == FFUNC
|| p
->class == FPROC
) {
* allocate space to save the display for formal calls
savedispnp
= tmpalloc( (long) sizeof display
, NLNIL
, NOREG
);
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
]);
* for the function return type
(void) put(2, O_PUSH
, leven(-lwidth(p
->type
)));
* 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
*)),
putRV((char *) 0 , cbn
, tempdescrp
-> value
[ NL_OFFS
] ,
tempdescrp
-> extra_flags
, P2PTR
|P2STRTY
);
putRV((char *) 0 , psbn
, p
-> value
[ NL_OFFS
] ,
p
-> extra_flags
, P2PTR
|P2STRTY
);
putop( P2ASSIGN
, P2PTR
| P2STRTY
);
* if we have to store a temporary,
* temptype will be its type,
* otherwise, it's P2UNDEF.
p_type_width
= width( p
-> type
);
p_type_align
= align( p
-> type
);
if ( p
-> class == FFUNC
) {
temptype
= p2type( p
-> type
);
if ( temptype
!= P2UNDEF
) {
tempnlp
= tmpalloc(p_type_width
, p
-> type
, NOREG
);
putRV((char *) 0 , cbn
, tempnlp
-> value
[ NL_OFFS
] ,
tempnlp
-> extra_flags
, (int) temptype
);
sextname( extname
, p
-> symbol
, BLOCKNO(p
-> nl_block
) );
putleaf( P2ICON
, 0 , 0 , p2type( p
) , extname
);
* ... ( t -> entryaddr )( ...
putRV((char *) 0 , cbn
, tempdescrp
-> value
[ NL_OFFS
] ,
tempdescrp
-> extra_flags
, P2PTR
| P2STRTY
);
/* the entry address within the descriptor */
if ( FENTRYOFFSET
!= 0 ) {
putleaf( P2ICON
, FENTRYOFFSET
, 0 , P2INT
,
ADDTYPE( ADDTYPE( p2type( p
) , P2FTN
) ,
* indirect to fetch the formal entry address
* with the result type of the routine.
if (p
-> class == FFUNC
) {
ADDTYPE(ADDTYPE(p2type(p
-> type
), P2FTN
),
/* procedures are int returning functions */
ADDTYPE(ADDTYPE(P2INT
, P2FTN
), P2PTR
));
* Loop and process each of
* arguments to the proc/func.
* ... ( ... args ... ) ...
for (p1
= plist(p
); p1
!= NLNIL
; p1
= p1
->chain
) {
if (argv_node
== TR_NIL
) {
error("Not enough arguments to %s", p
->symbol
);
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
);
q
= lvalue( argv_node
->list_node
.list
,
error("Parameter type not identical to type of var parameter %s of %s", p1
->symbol
, p
->symbol
);
q
= rvalue(argv_node
->list_node
.list
,
* structure arguments require lvalues,
switch( classify( p1
-> type
) ) {
q
= stkrval(argv_node
->list_node
.list
,
p1
-> type
, (long) LREQ
);
precheck( p1
-> type
, "_RANG4" , "_RSNG4" );
q
= stkrval(argv_node
->list_node
.list
,
p1
-> type
, (long) RREQ
);
postcheck(p1
-> type
, nl
+T4INT
);
q
= stkrval(argv_node
->list_node
.list
,
p1
-> type
, (long) RREQ
);
sconv(p2type(q
), P2DOUBLE
);
q
= rvalue(argv_node
->list_node
.list
,
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
);
if (isa(p1
->type
, "bcsi"))
switch( classify( p1
-> type
) ) {
, (int) lwidth( p1
-> type
)
q
= flvalue(argv_node
->list_node
.list
, p1
);
/*chk = (chk && fcompat(q, p1));*/
if ((chk
) && (fcompat(q
, p1
)))
q
= flvalue(argv_node
->list_node
.list
, p1
);
/* chk = (chk && fcompat(q, p1)); */
if ((chk
) && (fcompat(q
, p1
)))
* if this is the nth (>1) argument,
* hang it on the left linear list of arguments
putop( P2LISTOP
, P2INT
);
argv_node
= argv_node
->list_node
.next
;
if (argv_node
!= TR_NIL
) {
error("Too many arguments to %s", p
->symbol
);
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(2, O_FRTN
, even(width(p
->type
)));
(void) put(2, O_CALL
| psbn
<< 8, (long)p
->value
[NL_ENTLOC
]);
* 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
, P2PTR
|P2STRTY
);
putop( P2LISTOP
, P2INT
);
putLV((char *) 0 , cbn
, savedispnp
-> value
[ NL_OFFS
] ,
savedispnp
-> extra_flags
, P2PTR
| P2STRTY
);
putop( P2LISTOP
, P2INT
);
* either ... p( ... ) ...
* or ... ( t -> entryaddr )( ... ) ...
* and maybe an assignment.
switch ( p_type_class
) {
putop( ( noarguments
? P2UNARY P2CALL
: P2CALL
) ,
if ( p
-> class == FFUNC
) {
putop( P2ASSIGN
, (int) p_type_p2type
);
putstrop( ( noarguments
? P2UNARY P2STCALL
: P2STCALL
),
(int) ADDTYPE( p_type_p2type
, P2PTR
) ,
(int) p_type_width
,(int) p_type_align
);
putstrop(P2STASG
, (int) ADDTYPE(p_type_p2type
, P2PTR
),
(int) lwidth(p
-> type
), align(p
-> type
));
putop( ( noarguments
? P2UNARY P2CALL
: P2CALL
) , P2INT
);
* ( t=p , ... , FRTN( t ) ...
if ( p
-> class == FFUNC
|| p
-> class == FPROC
) {
putop( P2COMOP
, P2INT
);
putleaf( P2ICON
, 0 , 0 , ADDTYPE( P2FTN
| P2INT
, P2PTR
) ,
putRV((char *) 0 , cbn
, tempdescrp
-> value
[ NL_OFFS
] ,
tempdescrp
-> extra_flags
, P2PTR
| P2STRTY
);
putLV((char *) 0 , cbn
, savedispnp
-> value
[ NL_OFFS
] ,
savedispnp
-> extra_flags
, P2PTR
| P2STRTY
);
putop( P2LISTOP
, P2INT
);
putop( P2COMOP
, P2INT
);
if ( porf
== FUNC
&& temptype
!= P2UNDEF
) {
if ( temptype
!= P2STRTY
) {
putRV((char *) 0 , cbn
, tempnlp
-> value
[ NL_OFFS
] ,
tempnlp
-> extra_flags
, (int) p_type_p2type
);
putLV((char *) 0 , cbn
, tempnlp
-> value
[ NL_OFFS
] ,
tempnlp
-> extra_flags
, (int) p_type_p2type
);
putop( P2COMOP
, P2INT
);
putdot( filename
, line
);
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
fcompat( formal
, actual
)
register struct nl
*f_chain
;
register struct nl
*a_chain
;
extern struct nl
*plist();
if ( formal
== NLNIL
|| actual
== NLNIL
) {
for (a_chain
= plist(actual
), f_chain
= plist(formal
);
f_chain
= f_chain
->chain
, a_chain
= a_chain
->chain
) {
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
));
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
));
} else if (a_chain
->class == FFUNC
|| a_chain
->class == FPROC
) {
/*compat = (compat && fcompat(f_chain, a_chain));*/
if ((compat
) && (fcompat(f_chain
, a_chain
)))
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
));
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 p
->ptr
[ NL_FCHAIN
];
return(NLNIL
); /* this is here only so lint won't complain
return p
->ptr
[NL_FVAR
]->value
[NL_LINENO
];
return p
->value
[NL_LINENO
];