/* Copyright (c) 1979 Regents of the University of California */
static char sccsid
[] = "@(#)call.c 1.18 %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
, porf
, psbn
)
register struct nl
*p1
, *q
;
struct nl
*p_type_class
= classify( p
-> type
);
struct nl
*savedispnp
; /* temporary to hold saved display */
long p_p2type
= p2type( p
);
long p_type_p2type
= p2type( p
-> type
);
long calltype
; /* type of the call */
* 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( sizeof display
, NIL
, NOREG
);
if (p
->class == FFUNC
|| p
->class == FPROC
) {
put(2, O_LV
| cbn
<< 8 + INDX
,
(int) savedispnp
-> value
[ NL_OFFS
] );
put(2, PTR_RV
| psbn
<< 8+INDX
, (int)p
->value
[NL_OFFS
]);
* for the function return type
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(sizeof( struct formalrtn
*) , NIL
,
putRV( 0 , cbn
, tempdescrp
-> value
[ NL_OFFS
] ,
tempdescrp
-> extra_flags
, P2PTR
|P2STRTY
);
putRV( 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
);
calltype
= temptype
= P2STRTY
;
p_type_align
= align( p
-> type
);
if ( p
-> class == FFUNC
) {
calltype
= temptype
= p2type( p
-> type
);
if ( temptype
!= P2UNDEF
) {
tempnlp
= tmpalloc(p_type_width
, p
-> type
, NOREG
);
putRV( 0 , cbn
, tempnlp
-> value
[ NL_OFFS
] ,
tempnlp
-> extra_flags
, temptype
);
sextname( extname
, p
-> symbol
, BLOCKNO(p
-> nl_block
) );
putleaf( P2ICON
, 0 , 0 , p2type( p
) , extname
);
* ... ( t -> entryaddr )( ...
putRV( 0 , cbn
, tempdescrp
-> value
[ NL_OFFS
] ,
tempdescrp
-> extra_flags
, P2PTR
| P2STRTY
);
if ( FENTRYOFFSET
!= 0 ) {
putleaf( P2ICON
, FENTRYOFFSET
, 0 , P2INT
, 0 );
ADDTYPE( ADDTYPE( p2type( p
) , P2FTN
) ,
ADDTYPE( ADDTYPE( p2type( p
) , P2FTN
) , P2PTR
) );
* Loop and process each of
* arguments to the proc/func.
* ... ( ... args ... ) ...
for (p1
= plist(p
); p1
!= NIL
; p1
= p1
->chain
) {
error("Not enough arguments to %s", p
->symbol
);
if (r
!= NIL
&& r
[0] != T_VAR
) {
error("Expression given (variable required) for var parameter %s of %s", p1
->symbol
, p
->symbol
);
q
= lvalue( (int *) argv
[1], MOD
| ASGN
, LREQ
);
error("Parameter type not identical to type of var parameter %s of %s", p1
->symbol
, p
->symbol
);
q
= rvalue(argv
[1], p1
->type
, RREQ
);
* structure arguments require lvalues,
switch( classify( p1
-> type
) ) {
q
= rvalue( argv
[1] , p1
-> type
, LREQ
);
precheck( p1
-> type
, "_RANG4" , "_RSNG4" );
q
= rvalue( argv
[1] , p1
-> type
, RREQ
);
q
= rvalue( argv
[1] , p1
-> type
, RREQ
);
if ( isa( p1
-> type
, "d" )
putop( P2SCONV
, P2DOUBLE
);
if (incompat(q
, p1
->type
, argv
[1])) {
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
) ) {
q
= flvalue( (int *) argv
[1] , p1
);
chk
= (chk
&& fcompat(q
, p1
));
q
= flvalue( (int *) argv
[1] , p1
);
chk
= (chk
&& fcompat(q
, p1
));
* if this is the nth (>1) argument,
* hang it on the left linear list of arguments
putop( P2LISTOP
, P2INT
);
error("Too many arguments to %s", p
->symbol
);
if ( p
-> class == FFUNC
|| p
-> class == FPROC
) {
put(2, PTR_RV
| psbn
<< 8+INDX
, (int)p
->value
[NL_OFFS
]);
put(2, O_LV
| cbn
<< 8 + INDX
,
(int) savedispnp
-> value
[ NL_OFFS
] );
put(2, O_FRTN
, even(width(p
->type
)));
put(2, O_CALL
| psbn
<< 8, (long)p
->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( 0 , cbn
, tempdescrp
-> value
[ NL_OFFS
] ,
tempdescrp
-> extra_flags
, P2PTR
|P2STRTY
);
putop( P2LISTOP
, P2INT
);
putLV( 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
, p_type_p2type
);
putstrop( ( noarguments
? P2UNARY P2STCALL
: P2STCALL
),
ADDTYPE( p_type_p2type
, P2PTR
) ,
p_type_width
, p_type_align
);
putstrop( P2STASG
, p_type_p2type
, lwidth( 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( 0 , cbn
, tempdescrp
-> value
[ NL_OFFS
] ,
tempdescrp
-> extra_flags
, P2PTR
| P2STRTY
);
putLV( 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( 0 , cbn
, tempnlp
-> value
[ NL_OFFS
] ,
tempnlp
-> extra_flags
, p_type_p2type
);
putLV( 0 , cbn
, tempnlp
-> value
[ NL_OFFS
] ,
tempnlp
-> extra_flags
, p_type_p2type
);
putop( P2COMOP
, P2INT
);
putdot( filename
, line
);
for (; al
!= NIL
; al
= al
[2])
rvalue( (int *) al
[1], NLNIL
, RREQ
);
* check that two function/procedure namelist entries are compatible
fcompat( formal
, actual
)
register struct nl
*f_chain
;
register struct nl
*a_chain
;
if ( formal
== NIL
|| actual
== NIL
) {
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
,
cerror("%s %s declared on line %d",
parnam(actual
->class), actual
->symbol
,
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
, linenum(formal
));
cerror("with %s parameter %s of %s declared on line %d",
parnam(a_chain
->class), a_chain
->symbol
,
actual
->symbol
, linenum(actual
));
} else if (a_chain
->class == FFUNC
|| a_chain
->class == FPROC
) {
compat
= (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
, linenum(formal
));
cerror("to type of %s parameter %s of %s declared on line %d",
parnam(a_chain
->class), a_chain
->symbol
,
actual
->symbol
, linenum(actual
));
error("%s %s declared on line %d has fewer arguments than",
parnam(formal
->class), formal
->symbol
,
cerror("%s %s declared on line %d",
parnam(actual
->class), actual
->symbol
,
return p
->ptr
[ NL_FCHAIN
];
return p
->ptr
[NL_FVAR
]->value
[NL_LINENO
];
return p
->value
[NL_LINENO
];