1b85afe43Sbostic /*-
2*41f4043dSbostic * Copyright (c) 1980, 1993
3*41f4043dSbostic * The Regents of the University of California. All rights reserved.
4b85afe43Sbostic *
5b85afe43Sbostic * %sccs.include.redist.c%
6295621b4Sdist */
7eb9f9eddSpeter
89d446337Sthien #ifndef lint
9*41f4043dSbostic static char sccsid[] = "@(#)call.c 8.1 (Berkeley) 06/06/93";
10b85afe43Sbostic #endif /* not lint */
11eb9f9eddSpeter
12eb9f9eddSpeter #include "whoami.h"
13eb9f9eddSpeter #include "0.h"
14eb9f9eddSpeter #include "tree.h"
15eb9f9eddSpeter #include "opcode.h"
16eb9f9eddSpeter #include "objfmt.h"
1771395e85Smckusick #include "align.h"
18eb9f9eddSpeter #ifdef PC
19eb9f9eddSpeter # include "pc.h"
20496b13afSralph # include <pcc.h>
21eb9f9eddSpeter #endif PC
22076ebb16Speter #include "tmps.h"
239d446337Sthien #include "tree_ty.h"
24eb9f9eddSpeter
25eb9f9eddSpeter /*
26eb9f9eddSpeter * Call generates code for calls to
27eb9f9eddSpeter * user defined procedures and functions
28eb9f9eddSpeter * and is called by proc and funccod.
29eb9f9eddSpeter * P is the result of the lookup
30eb9f9eddSpeter * of the procedure/function symbol,
31eb9f9eddSpeter * and porf is PROC or FUNC.
32eb9f9eddSpeter * Psbn is the block number of p.
33dc03343eSmckusic *
34dc03343eSmckusic * the idea here is that regular scalar functions are just called,
35dc03343eSmckusic * while structure functions and formal functions have their results
36dc03343eSmckusic * stored in a temporary after the call.
37dc03343eSmckusic * structure functions do this because they return pointers
38dc03343eSmckusic * to static results, so we copy the static
39dc03343eSmckusic * and return a pointer to the copy.
40dc03343eSmckusic * formal functions do this because we have to save the result
41dc03343eSmckusic * around a call to the runtime routine which restores the display,
42dc03343eSmckusic * so we can't just leave the result lying around in registers.
4310903c71Speter * formal calls save the address of the descriptor in a local
4410903c71Speter * temporary, so it can be addressed for the call which restores
4510903c71Speter * the display (FRTN).
46144ba7caSpeter * calls to formal parameters pass the formal as a hidden argument
47144ba7caSpeter * to a special entry point for the formal call.
48144ba7caSpeter * [this is somewhat dependent on the way arguments are addressed.]
49dc03343eSmckusic * so PROCs and scalar FUNCs look like
50dc03343eSmckusic * p(...args...)
51dc03343eSmckusic * structure FUNCs look like
52dc03343eSmckusic * (temp = p(...args...),&temp)
53dc03343eSmckusic * formal FPROCs look like
540ed313d2Smckusic * ( t=p,( t -> entryaddr )(...args...,t,s),FRTN(t,s))
55dc03343eSmckusic * formal scalar FFUNCs look like
560ed313d2Smckusic * ( t=p,temp=( t -> entryaddr )(...args...,t,s),FRTN(t,s),temp)
57dc03343eSmckusic * formal structure FFUNCs look like
580ed313d2Smckusic * (t=p,temp = ( t -> entryaddr )(...args...,t,s),FRTN(t,s),&temp)
59eb9f9eddSpeter */
60eb9f9eddSpeter struct nl *
call(p,argv_node,porf,psbn)619d446337Sthien call(p, argv_node, porf, psbn)
62eb9f9eddSpeter struct nl *p;
639d446337Sthien struct tnode *argv_node; /* list node */
649d446337Sthien int porf, psbn;
65eb9f9eddSpeter {
668dd571a1Smckusick register struct nl *p1, *q, *p2;
678dd571a1Smckusick register struct nl *ptype, *ctype;
689d446337Sthien struct tnode *rnode;
698dd571a1Smckusick int i, j, d;
70c09f2839Smckusic bool chk = TRUE;
710ed313d2Smckusic struct nl *savedispnp; /* temporary to hold saved display */
72eb9f9eddSpeter # ifdef PC
739d446337Sthien int p_type_class = classify( p -> type );
74dc03343eSmckusic long p_type_p2type = p2type( p -> type );
75dc03343eSmckusic bool noarguments;
76dc03343eSmckusic /*
77dc03343eSmckusic * these get used if temporaries and structures are used
78dc03343eSmckusic */
793a2b01bfSpeter struct nl *tempnlp;
80dc03343eSmckusic long temptype; /* type of the temporary */
81dc03343eSmckusic long p_type_width;
82dc03343eSmckusic long p_type_align;
83279fde76Speter char extname[ BUFSIZ ];
8410903c71Speter struct nl *tempdescrp;
85eb9f9eddSpeter # endif PC
86eb9f9eddSpeter
870ed313d2Smckusic if (p->class == FFUNC || p->class == FPROC) {
880ed313d2Smckusic /*
890ed313d2Smckusic * allocate space to save the display for formal calls
900ed313d2Smckusic */
919d446337Sthien savedispnp = tmpalloc( (long) sizeof display , NLNIL , NOREG );
920ed313d2Smckusic }
93eb9f9eddSpeter # ifdef OBJ
94144ba7caSpeter if (p->class == FFUNC || p->class == FPROC) {
959d446337Sthien (void) put(2, O_LV | cbn << 8 + INDX ,
960ed313d2Smckusic (int) savedispnp -> value[ NL_OFFS ] );
979d446337Sthien (void) put(2, PTR_RV | psbn << 8+INDX, (int)p->value[NL_OFFS]);
98144ba7caSpeter }
99144ba7caSpeter if (porf == FUNC) {
100eb9f9eddSpeter /*
101eb9f9eddSpeter * Push some space
102eb9f9eddSpeter * for the function return type
103eb9f9eddSpeter */
10471395e85Smckusick (void) put(2, O_PUSH,
10571395e85Smckusick -roundup(lwidth(p->type), (long) A_STACK));
106144ba7caSpeter }
107eb9f9eddSpeter # endif OBJ
108eb9f9eddSpeter # ifdef PC
109dc03343eSmckusic /*
11010903c71Speter * if this is a formal call,
11110903c71Speter * stash the address of the descriptor
11210903c71Speter * in a temporary so we can find it
11310903c71Speter * after the FCALL for the call to FRTN
11410903c71Speter */
11510903c71Speter if ( p -> class == FFUNC || p -> class == FPROC ) {
1169d446337Sthien tempdescrp = tmpalloc((long) (sizeof( struct formalrtn *)),
1179d446337Sthien NLNIL, REGOK );
1189d446337Sthien putRV((char *) 0 , cbn , tempdescrp -> value[ NL_OFFS ] ,
119496b13afSralph tempdescrp -> extra_flags , PCCTM_PTR|PCCT_STRTY );
1209d446337Sthien putRV((char *) 0 , psbn , p -> value[ NL_OFFS ] ,
121496b13afSralph p -> extra_flags , PCCTM_PTR|PCCT_STRTY );
122496b13afSralph putop( PCC_ASSIGN , PCCTM_PTR | PCCT_STRTY );
12310903c71Speter }
12410903c71Speter /*
125dc03343eSmckusic * if we have to store a temporary,
126dc03343eSmckusic * temptype will be its type,
127496b13afSralph * otherwise, it's PCCT_UNDEF.
128dc03343eSmckusic */
129496b13afSralph temptype = PCCT_UNDEF;
130eb9f9eddSpeter if ( porf == FUNC ) {
131dc03343eSmckusic p_type_width = width( p -> type );
132dc03343eSmckusic switch( p_type_class ) {
133eb9f9eddSpeter case TSTR:
134eb9f9eddSpeter case TSET:
135eb9f9eddSpeter case TREC:
136eb9f9eddSpeter case TFILE:
137eb9f9eddSpeter case TARY:
138496b13afSralph temptype = PCCT_STRTY;
139dc03343eSmckusic p_type_align = align( p -> type );
140dc03343eSmckusic break;
141dc03343eSmckusic default:
142dc03343eSmckusic if ( p -> class == FFUNC ) {
1439d446337Sthien temptype = p2type( p -> type );
144eb9f9eddSpeter }
145dc03343eSmckusic break;
146dc03343eSmckusic }
147496b13afSralph if ( temptype != PCCT_UNDEF ) {
1483a2b01bfSpeter tempnlp = tmpalloc(p_type_width, p -> type, NOREG);
149dc03343eSmckusic /*
150dc03343eSmckusic * temp
151dc03343eSmckusic * for (temp = ...
152dc03343eSmckusic */
1539d446337Sthien putRV((char *) 0 , cbn , tempnlp -> value[ NL_OFFS ] ,
1549d446337Sthien tempnlp -> extra_flags , (int) temptype );
155eb9f9eddSpeter }
156eb9f9eddSpeter }
1573ce3b4c4Speter switch ( p -> class ) {
1583ce3b4c4Speter case FUNC:
1593ce3b4c4Speter case PROC:
160dc03343eSmckusic /*
161dc03343eSmckusic * ... p( ...
162dc03343eSmckusic */
163199b2563Speter sextname( extname , p -> symbol , BLOCKNO(p -> nl_block) );
164496b13afSralph putleaf( PCC_ICON , 0 , 0 , p2type( p ) , extname );
1653ce3b4c4Speter break;
1663ce3b4c4Speter case FFUNC:
1673ce3b4c4Speter case FPROC:
16810903c71Speter
1693ce3b4c4Speter /*
17010903c71Speter * ... ( t -> entryaddr )( ...
1713ce3b4c4Speter */
1724c8e651fSpeter /* the descriptor */
1739d446337Sthien putRV((char *) 0 , cbn , tempdescrp -> value[ NL_OFFS ] ,
174496b13afSralph tempdescrp -> extra_flags , PCCTM_PTR | PCCT_STRTY );
1754c8e651fSpeter /* the entry address within the descriptor */
176144ba7caSpeter if ( FENTRYOFFSET != 0 ) {
177496b13afSralph putleaf( PCC_ICON , FENTRYOFFSET , 0 , PCCT_INT ,
1789d446337Sthien (char *) 0 );
179496b13afSralph putop( PCC_PLUS ,
180496b13afSralph PCCM_ADDTYPE(
181496b13afSralph PCCM_ADDTYPE( PCCM_ADDTYPE( p2type( p ) , PCCTM_FTN ) ,
182496b13afSralph PCCTM_PTR ) ,
183496b13afSralph PCCTM_PTR ) );
184144ba7caSpeter }
1854c8e651fSpeter /*
1864c8e651fSpeter * indirect to fetch the formal entry address
1874c8e651fSpeter * with the result type of the routine.
1884c8e651fSpeter */
1894c8e651fSpeter if (p -> class == FFUNC) {
190496b13afSralph putop( PCCOM_UNARY PCC_MUL ,
191496b13afSralph PCCM_ADDTYPE(PCCM_ADDTYPE(p2type(p -> type), PCCTM_FTN),
192496b13afSralph PCCTM_PTR));
1934c8e651fSpeter } else {
1944c8e651fSpeter /* procedures are int returning functions */
195496b13afSralph putop( PCCOM_UNARY PCC_MUL ,
196496b13afSralph PCCM_ADDTYPE(PCCM_ADDTYPE(PCCT_INT, PCCTM_FTN), PCCTM_PTR));
1974c8e651fSpeter }
1983ce3b4c4Speter break;
1993ce3b4c4Speter default:
2003ce3b4c4Speter panic("call class");
2013ce3b4c4Speter }
202dc03343eSmckusic noarguments = TRUE;
203eb9f9eddSpeter # endif PC
204eb9f9eddSpeter /*
205eb9f9eddSpeter * Loop and process each of
206eb9f9eddSpeter * arguments to the proc/func.
207dc03343eSmckusic * ... ( ... args ... ) ...
208eb9f9eddSpeter */
2098dd571a1Smckusick ptype = NIL;
2109d446337Sthien for (p1 = plist(p); p1 != NLNIL; p1 = p1->chain) {
2119d446337Sthien if (argv_node == TR_NIL) {
212eb9f9eddSpeter error("Not enough arguments to %s", p->symbol);
2139d446337Sthien return (NLNIL);
214eb9f9eddSpeter }
215eb9f9eddSpeter switch (p1->class) {
216eb9f9eddSpeter case REF:
217eb9f9eddSpeter /*
218eb9f9eddSpeter * Var parameter
219eb9f9eddSpeter */
2209d446337Sthien rnode = argv_node->list_node.list;
2219d446337Sthien if (rnode != TR_NIL && rnode->tag != T_VAR) {
222eb9f9eddSpeter error("Expression given (variable required) for var parameter %s of %s", p1->symbol, p->symbol);
2231c429f41Speter chk = FALSE;
224eb9f9eddSpeter break;
225eb9f9eddSpeter }
2269d446337Sthien q = lvalue( argv_node->list_node.list,
2279d446337Sthien MOD | ASGN , LREQ );
228c09f2839Smckusic if (q == NIL) {
229c09f2839Smckusic chk = FALSE;
230eb9f9eddSpeter break;
231c09f2839Smckusic }
2328dd571a1Smckusick p2 = p1->type;
23380f9e15bSmckusick if (p2 == NLNIL || p2->chain == NLNIL || p2->chain->class != CRANGE) {
2348dd571a1Smckusick if (q != p2) {
235eb9f9eddSpeter error("Parameter type not identical to type of var parameter %s of %s", p1->symbol, p->symbol);
2361c429f41Speter chk = FALSE;
2378dd571a1Smckusick }
238eb9f9eddSpeter break;
2398dd571a1Smckusick } else {
2408dd571a1Smckusick /* conformant array */
2418dd571a1Smckusick if (p1 == ptype) {
2428dd571a1Smckusick if (q != ctype) {
2438dd571a1Smckusick error("Conformant array parameters in the same specification must be the same type.");
2448dd571a1Smckusick goto conf_err;
2458dd571a1Smckusick }
2468dd571a1Smckusick } else {
2478dd571a1Smckusick if (classify(q) != TARY && classify(q) != TSTR) {
2488dd571a1Smckusick error("Array type required for var parameter %s of %s",p1->symbol,p->symbol);
2498dd571a1Smckusick goto conf_err;
2508dd571a1Smckusick }
2518dd571a1Smckusick /* check base type of array */
2528dd571a1Smckusick if (p2->type != q->type) {
2538dd571a1Smckusick error("Base type of array not identical to that of conformant array parameter %s of %s", p1->symbol, p->symbol);
2548dd571a1Smckusick goto conf_err;
2558dd571a1Smckusick }
2568dd571a1Smckusick if (p2->value[0] != q->value[0]) {
2578dd571a1Smckusick error("Subscript number mismatch on conformant array parameter %s of %s", p1->symbol, p->symbol);
2588dd571a1Smckusick /* Don't process array bounds & width */
2598dd571a1Smckusick conf_err: if (p1->chain->type->class == CRANGE) {
2608dd571a1Smckusick d = p1->value[0];
2618dd571a1Smckusick for (i = 1; i <= d; i++) {
2628dd571a1Smckusick /* for each subscript, pass by
2638dd571a1Smckusick * bounds and width
2648dd571a1Smckusick */
2658dd571a1Smckusick p1 = p1->chain->chain->chain;
2668dd571a1Smckusick }
2678dd571a1Smckusick }
2688dd571a1Smckusick ptype = ctype = NLNIL;
2698dd571a1Smckusick chk = FALSE;
2708dd571a1Smckusick break;
2718dd571a1Smckusick }
2728dd571a1Smckusick /*
2738dd571a1Smckusick * Save array type for all parameters with same
2748dd571a1Smckusick * specification.
2758dd571a1Smckusick */
2768dd571a1Smckusick ctype = q;
2778dd571a1Smckusick ptype = p2;
2788dd571a1Smckusick /*
2798dd571a1Smckusick * If at end of conformant array list,
2808dd571a1Smckusick * get bounds.
2818dd571a1Smckusick */
2828dd571a1Smckusick if (p1->chain->type->class == CRANGE) {
2838dd571a1Smckusick /* check each subscript, put on stack */
2848dd571a1Smckusick d = ptype->value[0];
2858dd571a1Smckusick q = ctype;
2868dd571a1Smckusick for (i = 1; i <= d; i++) {
2878dd571a1Smckusick p1 = p1->chain;
2888dd571a1Smckusick q = q->chain;
2898dd571a1Smckusick if (incompat(q, p1->type, TR_NIL)){
2908dd571a1Smckusick error("Subscript type not conformable with parameter %s of %s", p1->symbol, p->symbol);
2918dd571a1Smckusick chk = FALSE;
2928dd571a1Smckusick break;
2938dd571a1Smckusick }
2948dd571a1Smckusick /* Put lower and upper bound & width */
2958dd571a1Smckusick # ifdef OBJ
2968dd571a1Smckusick if (q->type->class == CRANGE) {
2978dd571a1Smckusick putcbnds(q->type);
2988dd571a1Smckusick } else {
2998dd571a1Smckusick put(2, width(p1->type) <= 2 ? O_CON2
3008dd571a1Smckusick : O_CON4, q->range[0]);
3018dd571a1Smckusick put(2, width(p1->type) <= 2 ? O_CON2
3028dd571a1Smckusick : O_CON4, q->range[1]);
3038dd571a1Smckusick put(2, width(p1->type) <= 2 ? O_CON2
3048dd571a1Smckusick : O_CON4, aryconst(ctype,i));
3058dd571a1Smckusick }
3068dd571a1Smckusick # endif OBJ
3078dd571a1Smckusick # ifdef PC
3088dd571a1Smckusick if (q->type->class == CRANGE) {
3098dd571a1Smckusick for (j = 1; j <= 3; j++) {
3108dd571a1Smckusick p2 = p->nptr[j];
3118dd571a1Smckusick putRV(p2->symbol, (p2->nl_block
3128dd571a1Smckusick & 037), p2->value[0],
3138dd571a1Smckusick p2->extra_flags,p2type(p2));
314496b13afSralph putop(PCC_CM, PCCT_INT);
3158dd571a1Smckusick }
3168dd571a1Smckusick } else {
317496b13afSralph putleaf(PCC_ICON, q->range[0], 0,PCCT_INT,0);
318496b13afSralph putop( PCC_CM , PCCT_INT );
319496b13afSralph putleaf(PCC_ICON, q->range[1], 0,PCCT_INT,0);
320496b13afSralph putop( PCC_CM , PCCT_INT );
321496b13afSralph putleaf(PCC_ICON,aryconst(ctype,i),0,PCCT_INT,0);
322496b13afSralph putop( PCC_CM , PCCT_INT );
3238dd571a1Smckusick }
3248dd571a1Smckusick # endif PC
3258dd571a1Smckusick p1 = p1->chain->chain;
3268dd571a1Smckusick }
3278dd571a1Smckusick }
3288dd571a1Smckusick }
329eb9f9eddSpeter }
330eb9f9eddSpeter break;
331eb9f9eddSpeter case VAR:
332eb9f9eddSpeter /*
333eb9f9eddSpeter * Value parameter
334eb9f9eddSpeter */
335eb9f9eddSpeter # ifdef OBJ
3369d446337Sthien q = rvalue(argv_node->list_node.list,
3379d446337Sthien p1->type , RREQ );
338eb9f9eddSpeter # endif OBJ
339eb9f9eddSpeter # ifdef PC
340eb9f9eddSpeter /*
341eb9f9eddSpeter * structure arguments require lvalues,
342eb9f9eddSpeter * scalars use rvalue.
343eb9f9eddSpeter */
344eb9f9eddSpeter switch( classify( p1 -> type ) ) {
345eb9f9eddSpeter case TFILE:
346eb9f9eddSpeter case TARY:
347eb9f9eddSpeter case TREC:
348eb9f9eddSpeter case TSET:
349eb9f9eddSpeter case TSTR:
3509d446337Sthien q = stkrval(argv_node->list_node.list,
3519d446337Sthien p1 -> type , (long) LREQ );
352eb9f9eddSpeter break;
353eb9f9eddSpeter case TINT:
354eb9f9eddSpeter case TSCAL:
355eb9f9eddSpeter case TBOOL:
356eb9f9eddSpeter case TCHAR:
357eb9f9eddSpeter precheck( p1 -> type , "_RANG4" , "_RSNG4" );
3589d446337Sthien q = stkrval(argv_node->list_node.list,
3599d446337Sthien p1 -> type , (long) RREQ );
36054b33800Speter postcheck(p1 -> type, nl+T4INT);
361a3c3381aSmckusick break;
362a3c3381aSmckusick case TDOUBLE:
3639d446337Sthien q = stkrval(argv_node->list_node.list,
3649d446337Sthien p1 -> type , (long) RREQ );
365496b13afSralph sconv(p2type(q), PCCT_DOUBLE);
366eb9f9eddSpeter break;
367eb9f9eddSpeter default:
3689d446337Sthien q = rvalue(argv_node->list_node.list,
3699d446337Sthien p1 -> type , RREQ );
370eb9f9eddSpeter break;
371eb9f9eddSpeter }
372eb9f9eddSpeter # endif PC
373c09f2839Smckusic if (q == NIL) {
374c09f2839Smckusic chk = FALSE;
375eb9f9eddSpeter break;
376c09f2839Smckusic }
3779d446337Sthien if (incompat(q, p1->type,
3789d446337Sthien argv_node->list_node.list)) {
379eb9f9eddSpeter cerror("Expression type clashed with type of value parameter %s of %s", p1->symbol, p->symbol);
3801c429f41Speter chk = FALSE;
381eb9f9eddSpeter break;
382eb9f9eddSpeter }
383eb9f9eddSpeter # ifdef OBJ
384eb9f9eddSpeter if (isa(p1->type, "bcsi"))
385eb9f9eddSpeter rangechk(p1->type, q);
386eb9f9eddSpeter if (q->class != STR)
387eb9f9eddSpeter convert(q, p1->type);
388eb9f9eddSpeter # endif OBJ
389eb9f9eddSpeter # ifdef PC
390eb9f9eddSpeter switch( classify( p1 -> type ) ) {
391eb9f9eddSpeter case TFILE:
392eb9f9eddSpeter case TARY:
393eb9f9eddSpeter case TREC:
394eb9f9eddSpeter case TSET:
395eb9f9eddSpeter case TSTR:
396496b13afSralph putstrop( PCC_STARG
397eb9f9eddSpeter , p2type( p1 -> type )
3989d446337Sthien , (int) lwidth( p1 -> type )
399eb9f9eddSpeter , align( p1 -> type ) );
400eb9f9eddSpeter }
401eb9f9eddSpeter # endif PC
402eb9f9eddSpeter break;
4033ce3b4c4Speter case FFUNC:
4043ce3b4c4Speter /*
4053ce3b4c4Speter * function parameter
4063ce3b4c4Speter */
4079d446337Sthien q = flvalue(argv_node->list_node.list, p1 );
4089d446337Sthien /*chk = (chk && fcompat(q, p1));*/
4099d446337Sthien if ((chk) && (fcompat(q, p1)))
4109d446337Sthien chk = TRUE;
4119d446337Sthien else
4129d446337Sthien chk = FALSE;
4133ce3b4c4Speter break;
4143ce3b4c4Speter case FPROC:
4153ce3b4c4Speter /*
4163ce3b4c4Speter * procedure parameter
4173ce3b4c4Speter */
4189d446337Sthien q = flvalue(argv_node->list_node.list, p1 );
4199d446337Sthien /* chk = (chk && fcompat(q, p1)); */
4209d446337Sthien if ((chk) && (fcompat(q, p1)))
4219d446337Sthien chk = TRUE;
4229d446337Sthien else chk = FALSE;
4233ce3b4c4Speter break;
424eb9f9eddSpeter default:
425eb9f9eddSpeter panic("call");
426eb9f9eddSpeter }
427eb9f9eddSpeter # ifdef PC
428eb9f9eddSpeter /*
429eb9f9eddSpeter * if this is the nth (>1) argument,
430eb9f9eddSpeter * hang it on the left linear list of arguments
431eb9f9eddSpeter */
432dc03343eSmckusic if ( noarguments ) {
433dc03343eSmckusic noarguments = FALSE;
434eb9f9eddSpeter } else {
435496b13afSralph putop( PCC_CM , PCCT_INT );
436eb9f9eddSpeter }
437eb9f9eddSpeter # endif PC
4389d446337Sthien argv_node = argv_node->list_node.next;
439eb9f9eddSpeter }
4409d446337Sthien if (argv_node != TR_NIL) {
441eb9f9eddSpeter error("Too many arguments to %s", p->symbol);
4429d446337Sthien rvlist(argv_node);
4439d446337Sthien return (NLNIL);
444eb9f9eddSpeter }
445c09f2839Smckusic if (chk == FALSE)
4469d446337Sthien return NLNIL;
4473ce3b4c4Speter # ifdef OBJ
4483ce3b4c4Speter if ( p -> class == FFUNC || p -> class == FPROC ) {
4499d446337Sthien (void) put(2, PTR_RV | psbn << 8+INDX, (int)p->value[NL_OFFS]);
4509d446337Sthien (void) put(2, O_LV | cbn << 8 + INDX ,
4510ed313d2Smckusic (int) savedispnp -> value[ NL_OFFS ] );
4529d446337Sthien (void) put(1, O_FCALL);
45371395e85Smckusick (void) put(2, O_FRTN, roundup(width(p->type), (long) A_STACK));
4543ce3b4c4Speter } else {
4559d446337Sthien (void) put(2, O_CALL | psbn << 8, (long)p->value[NL_ENTLOC]);
4563ce3b4c4Speter }
457eb9f9eddSpeter # endif OBJ
458eb9f9eddSpeter # ifdef PC
459dc03343eSmckusic /*
460144ba7caSpeter * for formal calls: add the hidden argument
461144ba7caSpeter * which is the formal struct describing the
462144ba7caSpeter * environment of the routine.
463144ba7caSpeter * and the argument which is the address of the
464144ba7caSpeter * space into which to save the display.
465144ba7caSpeter */
466144ba7caSpeter if ( p -> class == FFUNC || p -> class == FPROC ) {
4679d446337Sthien putRV((char *) 0 , cbn , tempdescrp -> value[ NL_OFFS ] ,
468496b13afSralph tempdescrp -> extra_flags , PCCTM_PTR|PCCT_STRTY );
469144ba7caSpeter if ( !noarguments ) {
470496b13afSralph putop( PCC_CM , PCCT_INT );
471144ba7caSpeter }
472144ba7caSpeter noarguments = FALSE;
4739d446337Sthien putLV((char *) 0 , cbn , savedispnp -> value[ NL_OFFS ] ,
474496b13afSralph savedispnp -> extra_flags , PCCTM_PTR | PCCT_STRTY );
475496b13afSralph putop( PCC_CM , PCCT_INT );
476144ba7caSpeter }
477144ba7caSpeter /*
478dc03343eSmckusic * do the actual call:
479dc03343eSmckusic * either ... p( ... ) ...
48010903c71Speter * or ... ( t -> entryaddr )( ... ) ...
481dc03343eSmckusic * and maybe an assignment.
482dc03343eSmckusic */
483eb9f9eddSpeter if ( porf == FUNC ) {
484dc03343eSmckusic switch ( p_type_class ) {
485eb9f9eddSpeter case TBOOL:
486eb9f9eddSpeter case TCHAR:
487eb9f9eddSpeter case TINT:
488eb9f9eddSpeter case TSCAL:
489eb9f9eddSpeter case TDOUBLE:
490eb9f9eddSpeter case TPTR:
491496b13afSralph putop( ( noarguments ? PCCOM_UNARY PCC_CALL : PCC_CALL ) ,
4929d446337Sthien (int) p_type_p2type );
493dc03343eSmckusic if ( p -> class == FFUNC ) {
494496b13afSralph putop( PCC_ASSIGN , (int) p_type_p2type );
4953ce3b4c4Speter }
496eb9f9eddSpeter break;
497eb9f9eddSpeter default:
498496b13afSralph putstrop( ( noarguments ? PCCOM_UNARY PCC_STCALL : PCC_STCALL ),
499496b13afSralph (int) PCCM_ADDTYPE( p_type_p2type , PCCTM_PTR ) ,
5009d446337Sthien (int) p_type_width ,(int) p_type_align );
501496b13afSralph putstrop(PCC_STASG, (int) PCCM_ADDTYPE(p_type_p2type, PCCTM_PTR),
5029d446337Sthien (int) lwidth(p -> type), align(p -> type));
503eb9f9eddSpeter break;
504eb9f9eddSpeter }
505eb9f9eddSpeter } else {
506496b13afSralph putop( ( noarguments ? PCCOM_UNARY PCC_CALL : PCC_CALL ) , PCCT_INT );
507ba9f1247Speter }
508dc03343eSmckusic /*
50910903c71Speter * ( t=p , ... , FRTN( t ) ...
510dc03343eSmckusic */
511715d7872Smckusic if ( p -> class == FFUNC || p -> class == FPROC ) {
512496b13afSralph putop( PCC_COMOP , PCCT_INT );
513496b13afSralph putleaf( PCC_ICON , 0 , 0 , PCCM_ADDTYPE( PCCTM_FTN | PCCT_INT , PCCTM_PTR ) ,
514dc03343eSmckusic "_FRTN" );
5159d446337Sthien putRV((char *) 0 , cbn , tempdescrp -> value[ NL_OFFS ] ,
516496b13afSralph tempdescrp -> extra_flags , PCCTM_PTR | PCCT_STRTY );
5179d446337Sthien putLV((char *) 0 , cbn , savedispnp -> value[ NL_OFFS ] ,
518496b13afSralph savedispnp -> extra_flags , PCCTM_PTR | PCCT_STRTY );
519496b13afSralph putop( PCC_CM , PCCT_INT );
520496b13afSralph putop( PCC_CALL , PCCT_INT );
521496b13afSralph putop( PCC_COMOP , PCCT_INT );
522ba9f1247Speter }
523dc03343eSmckusic /*
524dc03343eSmckusic * if required:
525dc03343eSmckusic * either ... , temp )
526dc03343eSmckusic * or ... , &temp )
527dc03343eSmckusic */
528496b13afSralph if ( porf == FUNC && temptype != PCCT_UNDEF ) {
529496b13afSralph if ( temptype != PCCT_STRTY ) {
5309d446337Sthien putRV((char *) 0 , cbn , tempnlp -> value[ NL_OFFS ] ,
5319d446337Sthien tempnlp -> extra_flags , (int) p_type_p2type );
532dc03343eSmckusic } else {
5339d446337Sthien putLV((char *) 0 , cbn , tempnlp -> value[ NL_OFFS ] ,
5349d446337Sthien tempnlp -> extra_flags , (int) p_type_p2type );
535dc03343eSmckusic }
536496b13afSralph putop( PCC_COMOP , PCCT_INT );
537dc03343eSmckusic }
538dc03343eSmckusic if ( porf == PROC ) {
539eb9f9eddSpeter putdot( filename , line );
540eb9f9eddSpeter }
541eb9f9eddSpeter # endif PC
542eb9f9eddSpeter return (p->type);
543eb9f9eddSpeter }
544eb9f9eddSpeter
rvlist(al)545eb9f9eddSpeter rvlist(al)
5469d446337Sthien register struct tnode *al;
547eb9f9eddSpeter {
548eb9f9eddSpeter
5499d446337Sthien for (; al != TR_NIL; al = al->list_node.next)
5509d446337Sthien (void) rvalue( al->list_node.list, NLNIL , RREQ );
551eb9f9eddSpeter }
552c09f2839Smckusic
553c09f2839Smckusic /*
554c09f2839Smckusic * check that two function/procedure namelist entries are compatible
555c09f2839Smckusic */
556c09f2839Smckusic bool
fcompat(formal,actual)557c09f2839Smckusic fcompat( formal , actual )
558c09f2839Smckusic struct nl *formal;
559c09f2839Smckusic struct nl *actual;
560c09f2839Smckusic {
561c09f2839Smckusic register struct nl *f_chain;
562c09f2839Smckusic register struct nl *a_chain;
5639d446337Sthien extern struct nl *plist();
564c09f2839Smckusic bool compat = TRUE;
565c09f2839Smckusic
5669d446337Sthien if ( formal == NLNIL || actual == NLNIL ) {
567c09f2839Smckusic return FALSE;
568c09f2839Smckusic }
569c09f2839Smckusic for (a_chain = plist(actual), f_chain = plist(formal);
5709d446337Sthien f_chain != NLNIL;
571c09f2839Smckusic f_chain = f_chain->chain, a_chain = a_chain->chain) {
572c09f2839Smckusic if (a_chain == NIL) {
573c09f2839Smckusic error("%s %s declared on line %d has more arguments than",
574c09f2839Smckusic parnam(formal->class), formal->symbol,
5759d446337Sthien (char *) linenum(formal));
576c09f2839Smckusic cerror("%s %s declared on line %d",
577c09f2839Smckusic parnam(actual->class), actual->symbol,
5789d446337Sthien (char *) linenum(actual));
579c09f2839Smckusic return FALSE;
580c09f2839Smckusic }
581c09f2839Smckusic if ( a_chain -> class != f_chain -> class ) {
582c09f2839Smckusic error("%s parameter %s of %s declared on line %d is not identical",
583c09f2839Smckusic parnam(f_chain->class), f_chain->symbol,
5849d446337Sthien formal->symbol, (char *) linenum(formal));
585c09f2839Smckusic cerror("with %s parameter %s of %s declared on line %d",
586c09f2839Smckusic parnam(a_chain->class), a_chain->symbol,
5879d446337Sthien actual->symbol, (char *) linenum(actual));
588c09f2839Smckusic compat = FALSE;
589c09f2839Smckusic } else if (a_chain->class == FFUNC || a_chain->class == FPROC) {
5909d446337Sthien /*compat = (compat && fcompat(f_chain, a_chain));*/
5919d446337Sthien if ((compat) && (fcompat(f_chain, a_chain)))
5929d446337Sthien compat = TRUE;
5939d446337Sthien else compat = FALSE;
594c09f2839Smckusic }
595c09f2839Smckusic if ((a_chain->class != FPROC && f_chain->class != FPROC) &&
596c09f2839Smckusic (a_chain->type != f_chain->type)) {
597c09f2839Smckusic error("Type of %s parameter %s of %s declared on line %d is not identical",
598c09f2839Smckusic parnam(f_chain->class), f_chain->symbol,
5999d446337Sthien formal->symbol, (char *) linenum(formal));
600c09f2839Smckusic cerror("to type of %s parameter %s of %s declared on line %d",
601c09f2839Smckusic parnam(a_chain->class), a_chain->symbol,
6029d446337Sthien actual->symbol, (char *) linenum(actual));
603c09f2839Smckusic compat = FALSE;
604c09f2839Smckusic }
605c09f2839Smckusic }
606c09f2839Smckusic if (a_chain != NIL) {
607c09f2839Smckusic error("%s %s declared on line %d has fewer arguments than",
608c09f2839Smckusic parnam(formal->class), formal->symbol,
6099d446337Sthien (char *) linenum(formal));
610c09f2839Smckusic cerror("%s %s declared on line %d",
611c09f2839Smckusic parnam(actual->class), actual->symbol,
6129d446337Sthien (char *) linenum(actual));
613c09f2839Smckusic return FALSE;
614c09f2839Smckusic }
615c09f2839Smckusic return compat;
616c09f2839Smckusic }
617c09f2839Smckusic
618c09f2839Smckusic char *
parnam(nltype)619c09f2839Smckusic parnam(nltype)
620c09f2839Smckusic int nltype;
621c09f2839Smckusic {
622c09f2839Smckusic switch(nltype) {
623c09f2839Smckusic case REF:
624c09f2839Smckusic return "var";
625c09f2839Smckusic case VAR:
626c09f2839Smckusic return "value";
627c09f2839Smckusic case FUNC:
628c09f2839Smckusic case FFUNC:
629c09f2839Smckusic return "function";
630c09f2839Smckusic case PROC:
631c09f2839Smckusic case FPROC:
632c09f2839Smckusic return "procedure";
633c09f2839Smckusic default:
634c09f2839Smckusic return "SNARK";
635c09f2839Smckusic }
636c09f2839Smckusic }
637c09f2839Smckusic
plist(p)6389d446337Sthien struct nl *plist(p)
639c09f2839Smckusic struct nl *p;
640c09f2839Smckusic {
641c09f2839Smckusic switch (p->class) {
642c09f2839Smckusic case FFUNC:
643c09f2839Smckusic case FPROC:
644c09f2839Smckusic return p->ptr[ NL_FCHAIN ];
645c09f2839Smckusic case PROC:
646c09f2839Smckusic case FUNC:
647c09f2839Smckusic return p->chain;
648c09f2839Smckusic default:
6499d446337Sthien {
650c09f2839Smckusic panic("plist");
6519d446337Sthien return(NLNIL); /* this is here only so lint won't complain
6529d446337Sthien panic actually aborts */
6539d446337Sthien }
6549d446337Sthien
655c09f2839Smckusic }
656c09f2839Smckusic }
657c09f2839Smckusic
658c09f2839Smckusic linenum(p)
659c09f2839Smckusic struct nl *p;
660c09f2839Smckusic {
661c09f2839Smckusic if (p->class == FUNC)
662c09f2839Smckusic return p->ptr[NL_FVAR]->value[NL_LINENO];
663c09f2839Smckusic return p->value[NL_LINENO];
664c09f2839Smckusic }
665