e476984e8144999c790c873c9df748c00bba0e8d
* Copyright (c) 1980 Regents of the University of California.
* All rights reserved. The Berkeley software License Agreement
* specifies the terms and conditions for redistribution.
static char sccsid
[] = "@(#)call.c 5.3 (Berkeley) %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
, *p2
;
register struct nl
*ptype
, *ctype
;
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
-roundup(lwidth(p
->type
), (long) A_STACK
));
* 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
, 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.
p_type_width
= width( p
-> type
);
p_type_align
= align( p
-> type
);
if ( p
-> class == FFUNC
) {
temptype
= p2type( p
-> type
);
if ( temptype
!= PCCT_UNDEF
) {
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( PCC_ICON
, 0 , 0 , p2type( p
) , extname
);
* ... ( t -> entryaddr )( ...
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
,
PCCM_ADDTYPE( PCCM_ADDTYPE( p2type( p
) , PCCTM_FTN
) ,
* 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
),
/* procedures are int returning functions */
putop( PCCOM_UNARY PCC_MUL
,
PCCM_ADDTYPE(PCCM_ADDTYPE(PCCT_INT
, PCCTM_FTN
), PCCTM_PTR
));
* 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
,
if (p2
== NLNIL
|| p2
->chain
== NLNIL
|| p2
->chain
->class != CRANGE
) {
error("Parameter type not identical to type of var parameter %s of %s", p1
->symbol
, p
->symbol
);
error("Conformant array parameters in the same specification must be the same type.");
if (classify(q
) != TARY
&& classify(q
) != TSTR
) {
error("Array type required for var parameter %s of %s",p1
->symbol
,p
->symbol
);
/* 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
);
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
) {
for (i
= 1; i
<= d
; i
++) {
/* for each subscript, pass by
p1
= p1
->chain
->chain
->chain
;
* Save array type for all parameters with same
* If at end of conformant array list,
if (p1
->chain
->type
->class == CRANGE
) {
/* check each subscript, put on stack */
for (i
= 1; i
<= d
; i
++) {
if (incompat(q
, p1
->type
, TR_NIL
)){
error("Subscript type not conformable with parameter %s of %s", p1
->symbol
, p
->symbol
);
/* Put lower and upper bound & width */
if (q
->type
->class == CRANGE
) {
put(2, width(p1
->type
) <= 2 ? O_CON2
put(2, width(p1
->type
) <= 2 ? O_CON2
put(2, width(p1
->type
) <= 2 ? O_CON2
: O_CON4
, aryconst(ctype
,i
));
if (q
->type
->class == CRANGE
) {
for (j
= 1; j
<= 3; j
++) {
putRV(p2
->symbol
, (p2
->nl_block
p2
->extra_flags
,p2type(p2
));
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
);
putleaf(PCC_ICON
,aryconst(ctype
,i
),0,PCCT_INT
,0);
putop( PCC_CM
, PCCT_INT
);
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
), PCCT_DOUBLE
);
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( PCC_CM
, PCCT_INT
);
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
, roundup(width(p
->type
), (long) A_STACK
));
(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
, PCCTM_PTR
|PCCT_STRTY
);
putop( PCC_CM
, PCCT_INT
);
putLV((char *) 0 , cbn
, savedispnp
-> value
[ NL_OFFS
] ,
savedispnp
-> extra_flags
, PCCTM_PTR
| PCCT_STRTY
);
putop( PCC_CM
, PCCT_INT
);
* either ... p( ... ) ...
* or ... ( t -> entryaddr )( ... ) ...
* and maybe an assignment.
switch ( p_type_class
) {
putop( ( noarguments
? PCCOM_UNARY PCC_CALL
: PCC_CALL
) ,
if ( p
-> class == FFUNC
) {
putop( PCC_ASSIGN
, (int) p_type_p2type
);
putstrop( ( noarguments
? PCCOM_UNARY PCC_STCALL
: PCC_STCALL
),
(int) PCCM_ADDTYPE( p_type_p2type
, PCCTM_PTR
) ,
(int) p_type_width
,(int) p_type_align
);
putstrop(PCC_STASG
, (int) PCCM_ADDTYPE(p_type_p2type
, PCCTM_PTR
),
(int) lwidth(p
-> type
), align(p
-> type
));
putop( ( noarguments
? PCCOM_UNARY PCC_CALL
: PCC_CALL
) , PCCT_INT
);
* ( t=p , ... , FRTN( t ) ...
if ( p
-> class == FFUNC
|| p
-> class == FPROC
) {
putop( PCC_COMOP
, PCCT_INT
);
putleaf( PCC_ICON
, 0 , 0 , PCCM_ADDTYPE( PCCTM_FTN
| PCCT_INT
, PCCTM_PTR
) ,
putRV((char *) 0 , cbn
, tempdescrp
-> value
[ NL_OFFS
] ,
tempdescrp
-> extra_flags
, PCCTM_PTR
| PCCT_STRTY
);
putLV((char *) 0 , cbn
, savedispnp
-> value
[ NL_OFFS
] ,
savedispnp
-> extra_flags
, PCCTM_PTR
| PCCT_STRTY
);
putop( PCC_CM
, PCCT_INT
);
putop( PCC_CALL
, PCCT_INT
);
putop( PCC_COMOP
, PCCT_INT
);
if ( porf
== FUNC
&& temptype
!= PCCT_UNDEF
) {
if ( temptype
!= PCCT_STRTY
) {
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( PCC_COMOP
, PCCT_INT
);
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
];