/* Copyright (c) 1979 Regents of the University of California */
static char sccsid
[] = "@(#)call.c 1.4.1.1 %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.
* so PROCs and scalar FUNCs look like
* structure FUNCs look like
* (temp = p(...args...),&temp)
* formal FPROCs look like
* ((FCALL( p ))(...args...),FRTN( p ))
* formal scalar FFUNCs look like
* (temp = (FCALL( p ))(...args...),FRTN( p ),temp)
* formal structure FFUNCs look like
* (temp = (FCALL( p ))(...args...),FRTN( p ),&temp)
call(p
, argv
, porf
, psbn
)
register struct nl
*p1
, *q
;
struct nl
*p_type_class
= classify( p
-> type
);
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
)
put(2, PTR_RV
| cbn
<< 8+INDX
, (int)p
->value
[NL_OFFS
]);
* for the function return type
put(2, O_PUSH
, leven(-lwidth(p
->type
)));
* 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
) {
tempoffset
= sizes
[ cbn
].om_off
-= p_type_width
;
putlbracket( ftnno
, -tempoffset
);
if ( tempoffset
< sizes
[cbn
].om_max
) {
sizes
[cbn
].om_max
= tempoffset
;
putRV( 0 , cbn
, tempoffset
, temptype
);
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
);
, ADDTYPE( ADDTYPE( p_p2type
, P2FTN
) , P2PTR
)
putRV( 0 , cbn
, p
-> value
[NL_OFFS
] , P2PTR
|P2STRTY
);
putop( P2CALL
, p_p2type
);
* Loop and process each of
* arguments to the proc/func.
* ... ( ... args ... ) ...
if ( p
-> class == FUNC
|| p
-> class == PROC
) {
for (p1
= p
->chain
; 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
, 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] , FFUNC
);
error("Function type not identical to type of function parameter %s of %s", p1
->symbol
, p
->symbol
);
q
= flvalue( (int *) argv
[1] , FPROC
);
error("Procedure parameter %s of %s cannot have a type", p1
->symbol
, p
->symbol
);
* 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
);
} else if ( p
-> class == FFUNC
|| p
-> class == FPROC
) {
* formal routines can only have by-value parameters.
* this will lose for integer actuals passed to real
* formals, and strings which people want blank padded.
for ( ; argv
!= NIL
; argv
= argv
[2] ) {
q
= rvalue(argv
[1], NIL
, RREQ
);
* structure arguments require lvalues,
p1
= rvalue( argv
[1] , NIL
, RREQ
);
switch( classify( p1
) ) {
if ( p1
-> class == STR
&& slenline
!= line
) {
( opt( 's' ) ? (standard()): (warning()) );
error("Implementation can't construct equal length strings");
q
= rvalue( argv
[1] , p1
, LREQ
);
if ( floatline
!= line
) {
( opt( 's' ) ? (standard()) : (warning()) );
error("Implementation can't coerice integer to real");
q
= rvalue( argv
[1] , p1
, RREQ
);
switch( classify( p1
) ) {
putstrop( P2STARG
, p2type( p1
) ,
lwidth( p1
) , align( p1
) );
* if this is the nth (>1) argument,
* hang it on the left linear list of arguments
putop( P2LISTOP
, P2INT
);
if ( p
-> class == FFUNC
|| p
-> class == FPROC
) {
put(2, PTR_RV
| cbn
<< 8+INDX
, (int)p
->value
[NL_OFFS
]);
put(2, O_FCALL
, (long)cnt
);
put(2, O_FRTN
, even(width(p
->type
)));
/* put(2, O_CALL | psbn << 8+INDX, (long)p->entloc); */
put(2, O_CALL
| psbn
<< 8, (long)p
->entloc
);
* either ... p( ... ) ...
* or ... ( ...() )( ... ) ...
* 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
);
if ( p
-> class == FFUNC
|| p
-> class == FPROC
) {
putleaf( P2ICON
, 0 , 0 , ADDTYPE( P2FTN
| P2INT
, P2PTR
) ,
putRV( 0 , cbn
, p
-> value
[ NL_OFFS
] , P2PTR
| P2STRTY
);
putop( P2COMOP
, P2INT
);
if ( porf
== FUNC
&& temptype
!= P2UNDEF
) {
if ( temptype
!= P2STRTY
) {
putRV( 0 , cbn
, tempoffset
, p_type_p2type
);
putLV( 0 , cbn
, tempoffset
, p_type_p2type
);
putop( P2COMOP
, P2INT
);
putdot( filename
, line
);
for (; al
!= NIL
; al
= al
[2])
rvalue( (int *) al
[1], NLNIL
, RREQ
);