1 /*-
2 * Copyright (c) 1980, 1993
3 * The Regents of the University of California. All rights reserved.
4 *
5 * %sccs.include.redist.c%
6 */
7
8 #ifndef lint
9 static char sccsid[] = "@(#)call.c 8.1 (Berkeley) 06/06/93";
10 #endif /* not lint */
11
12 #include "whoami.h"
13 #include "0.h"
14 #include "tree.h"
15 #include "opcode.h"
16 #include "objfmt.h"
17 #include "align.h"
18 #ifdef PC
19 # include "pc.h"
20 # include <pcc.h>
21 #endif PC
22 #include "tmps.h"
23 #include "tree_ty.h"
24
25 /*
26 * Call generates code for calls to
27 * user defined procedures and functions
28 * and is called by proc and funccod.
29 * P is the result of the lookup
30 * of the procedure/function symbol,
31 * and porf is PROC or FUNC.
32 * Psbn is the block number of p.
33 *
34 * the idea here is that regular scalar functions are just called,
35 * while structure functions and formal functions have their results
36 * stored in a temporary after the call.
37 * structure functions do this because they return pointers
38 * to static results, so we copy the static
39 * and return a pointer to the copy.
40 * formal functions do this because we have to save the result
41 * around a call to the runtime routine which restores the display,
42 * so we can't just leave the result lying around in registers.
43 * formal calls save the address of the descriptor in a local
44 * temporary, so it can be addressed for the call which restores
45 * the display (FRTN).
46 * calls to formal parameters pass the formal as a hidden argument
47 * to a special entry point for the formal call.
48 * [this is somewhat dependent on the way arguments are addressed.]
49 * so PROCs and scalar FUNCs look like
50 * p(...args...)
51 * structure FUNCs look like
52 * (temp = p(...args...),&temp)
53 * formal FPROCs look like
54 * ( t=p,( t -> entryaddr )(...args...,t,s),FRTN(t,s))
55 * formal scalar FFUNCs look like
56 * ( t=p,temp=( t -> entryaddr )(...args...,t,s),FRTN(t,s),temp)
57 * formal structure FFUNCs look like
58 * (t=p,temp = ( t -> entryaddr )(...args...,t,s),FRTN(t,s),&temp)
59 */
60 struct nl *
call(p,argv_node,porf,psbn)61 call(p, argv_node, porf, psbn)
62 struct nl *p;
63 struct tnode *argv_node; /* list node */
64 int porf, psbn;
65 {
66 register struct nl *p1, *q, *p2;
67 register struct nl *ptype, *ctype;
68 struct tnode *rnode;
69 int i, j, d;
70 bool chk = TRUE;
71 struct nl *savedispnp; /* temporary to hold saved display */
72 # ifdef PC
73 int p_type_class = classify( p -> type );
74 long p_type_p2type = p2type( p -> type );
75 bool noarguments;
76 /*
77 * these get used if temporaries and structures are used
78 */
79 struct nl *tempnlp;
80 long temptype; /* type of the temporary */
81 long p_type_width;
82 long p_type_align;
83 char extname[ BUFSIZ ];
84 struct nl *tempdescrp;
85 # endif PC
86
87 if (p->class == FFUNC || p->class == FPROC) {
88 /*
89 * allocate space to save the display for formal calls
90 */
91 savedispnp = tmpalloc( (long) sizeof display , NLNIL , NOREG );
92 }
93 # ifdef OBJ
94 if (p->class == FFUNC || p->class == FPROC) {
95 (void) put(2, O_LV | cbn << 8 + INDX ,
96 (int) savedispnp -> value[ NL_OFFS ] );
97 (void) put(2, PTR_RV | psbn << 8+INDX, (int)p->value[NL_OFFS]);
98 }
99 if (porf == FUNC) {
100 /*
101 * Push some space
102 * for the function return type
103 */
104 (void) put(2, O_PUSH,
105 -roundup(lwidth(p->type), (long) A_STACK));
106 }
107 # endif OBJ
108 # ifdef PC
109 /*
110 * if this is a formal call,
111 * stash the address of the descriptor
112 * in a temporary so we can find it
113 * after the FCALL for the call to FRTN
114 */
115 if ( p -> class == FFUNC || p -> class == FPROC ) {
116 tempdescrp = tmpalloc((long) (sizeof( struct formalrtn *)),
117 NLNIL, REGOK );
118 putRV((char *) 0 , cbn , tempdescrp -> value[ NL_OFFS ] ,
119 tempdescrp -> extra_flags , PCCTM_PTR|PCCT_STRTY );
120 putRV((char *) 0 , psbn , p -> value[ NL_OFFS ] ,
121 p -> extra_flags , PCCTM_PTR|PCCT_STRTY );
122 putop( PCC_ASSIGN , PCCTM_PTR | PCCT_STRTY );
123 }
124 /*
125 * if we have to store a temporary,
126 * temptype will be its type,
127 * otherwise, it's PCCT_UNDEF.
128 */
129 temptype = PCCT_UNDEF;
130 if ( porf == FUNC ) {
131 p_type_width = width( p -> type );
132 switch( p_type_class ) {
133 case TSTR:
134 case TSET:
135 case TREC:
136 case TFILE:
137 case TARY:
138 temptype = PCCT_STRTY;
139 p_type_align = align( p -> type );
140 break;
141 default:
142 if ( p -> class == FFUNC ) {
143 temptype = p2type( p -> type );
144 }
145 break;
146 }
147 if ( temptype != PCCT_UNDEF ) {
148 tempnlp = tmpalloc(p_type_width, p -> type, NOREG);
149 /*
150 * temp
151 * for (temp = ...
152 */
153 putRV((char *) 0 , cbn , tempnlp -> value[ NL_OFFS ] ,
154 tempnlp -> extra_flags , (int) temptype );
155 }
156 }
157 switch ( p -> class ) {
158 case FUNC:
159 case PROC:
160 /*
161 * ... p( ...
162 */
163 sextname( extname , p -> symbol , BLOCKNO(p -> nl_block) );
164 putleaf( PCC_ICON , 0 , 0 , p2type( p ) , extname );
165 break;
166 case FFUNC:
167 case FPROC:
168
169 /*
170 * ... ( t -> entryaddr )( ...
171 */
172 /* the descriptor */
173 putRV((char *) 0 , cbn , tempdescrp -> value[ NL_OFFS ] ,
174 tempdescrp -> extra_flags , PCCTM_PTR | PCCT_STRTY );
175 /* the entry address within the descriptor */
176 if ( FENTRYOFFSET != 0 ) {
177 putleaf( PCC_ICON , FENTRYOFFSET , 0 , PCCT_INT ,
178 (char *) 0 );
179 putop( PCC_PLUS ,
180 PCCM_ADDTYPE(
181 PCCM_ADDTYPE( PCCM_ADDTYPE( p2type( p ) , PCCTM_FTN ) ,
182 PCCTM_PTR ) ,
183 PCCTM_PTR ) );
184 }
185 /*
186 * indirect to fetch the formal entry address
187 * with the result type of the routine.
188 */
189 if (p -> class == FFUNC) {
190 putop( PCCOM_UNARY PCC_MUL ,
191 PCCM_ADDTYPE(PCCM_ADDTYPE(p2type(p -> type), PCCTM_FTN),
192 PCCTM_PTR));
193 } else {
194 /* procedures are int returning functions */
195 putop( PCCOM_UNARY PCC_MUL ,
196 PCCM_ADDTYPE(PCCM_ADDTYPE(PCCT_INT, PCCTM_FTN), PCCTM_PTR));
197 }
198 break;
199 default:
200 panic("call class");
201 }
202 noarguments = TRUE;
203 # endif PC
204 /*
205 * Loop and process each of
206 * arguments to the proc/func.
207 * ... ( ... args ... ) ...
208 */
209 ptype = NIL;
210 for (p1 = plist(p); p1 != NLNIL; p1 = p1->chain) {
211 if (argv_node == TR_NIL) {
212 error("Not enough arguments to %s", p->symbol);
213 return (NLNIL);
214 }
215 switch (p1->class) {
216 case REF:
217 /*
218 * Var parameter
219 */
220 rnode = argv_node->list_node.list;
221 if (rnode != TR_NIL && rnode->tag != T_VAR) {
222 error("Expression given (variable required) for var parameter %s of %s", p1->symbol, p->symbol);
223 chk = FALSE;
224 break;
225 }
226 q = lvalue( argv_node->list_node.list,
227 MOD | ASGN , LREQ );
228 if (q == NIL) {
229 chk = FALSE;
230 break;
231 }
232 p2 = p1->type;
233 if (p2 == NLNIL || p2->chain == NLNIL || p2->chain->class != CRANGE) {
234 if (q != p2) {
235 error("Parameter type not identical to type of var parameter %s of %s", p1->symbol, p->symbol);
236 chk = FALSE;
237 }
238 break;
239 } else {
240 /* conformant array */
241 if (p1 == ptype) {
242 if (q != ctype) {
243 error("Conformant array parameters in the same specification must be the same type.");
244 goto conf_err;
245 }
246 } else {
247 if (classify(q) != TARY && classify(q) != TSTR) {
248 error("Array type required for var parameter %s of %s",p1->symbol,p->symbol);
249 goto conf_err;
250 }
251 /* check base type of array */
252 if (p2->type != q->type) {
253 error("Base type of array not identical to that of conformant array parameter %s of %s", p1->symbol, p->symbol);
254 goto conf_err;
255 }
256 if (p2->value[0] != q->value[0]) {
257 error("Subscript number mismatch on conformant array parameter %s of %s", p1->symbol, p->symbol);
258 /* Don't process array bounds & width */
259 conf_err: if (p1->chain->type->class == CRANGE) {
260 d = p1->value[0];
261 for (i = 1; i <= d; i++) {
262 /* for each subscript, pass by
263 * bounds and width
264 */
265 p1 = p1->chain->chain->chain;
266 }
267 }
268 ptype = ctype = NLNIL;
269 chk = FALSE;
270 break;
271 }
272 /*
273 * Save array type for all parameters with same
274 * specification.
275 */
276 ctype = q;
277 ptype = p2;
278 /*
279 * If at end of conformant array list,
280 * get bounds.
281 */
282 if (p1->chain->type->class == CRANGE) {
283 /* check each subscript, put on stack */
284 d = ptype->value[0];
285 q = ctype;
286 for (i = 1; i <= d; i++) {
287 p1 = p1->chain;
288 q = q->chain;
289 if (incompat(q, p1->type, TR_NIL)){
290 error("Subscript type not conformable with parameter %s of %s", p1->symbol, p->symbol);
291 chk = FALSE;
292 break;
293 }
294 /* Put lower and upper bound & width */
295 # ifdef OBJ
296 if (q->type->class == CRANGE) {
297 putcbnds(q->type);
298 } else {
299 put(2, width(p1->type) <= 2 ? O_CON2
300 : O_CON4, q->range[0]);
301 put(2, width(p1->type) <= 2 ? O_CON2
302 : O_CON4, q->range[1]);
303 put(2, width(p1->type) <= 2 ? O_CON2
304 : O_CON4, aryconst(ctype,i));
305 }
306 # endif OBJ
307 # ifdef PC
308 if (q->type->class == CRANGE) {
309 for (j = 1; j <= 3; j++) {
310 p2 = p->nptr[j];
311 putRV(p2->symbol, (p2->nl_block
312 & 037), p2->value[0],
313 p2->extra_flags,p2type(p2));
314 putop(PCC_CM, PCCT_INT);
315 }
316 } else {
317 putleaf(PCC_ICON, q->range[0], 0,PCCT_INT,0);
318 putop( PCC_CM , PCCT_INT );
319 putleaf(PCC_ICON, q->range[1], 0,PCCT_INT,0);
320 putop( PCC_CM , PCCT_INT );
321 putleaf(PCC_ICON,aryconst(ctype,i),0,PCCT_INT,0);
322 putop( PCC_CM , PCCT_INT );
323 }
324 # endif PC
325 p1 = p1->chain->chain;
326 }
327 }
328 }
329 }
330 break;
331 case VAR:
332 /*
333 * Value parameter
334 */
335 # ifdef OBJ
336 q = rvalue(argv_node->list_node.list,
337 p1->type , RREQ );
338 # endif OBJ
339 # ifdef PC
340 /*
341 * structure arguments require lvalues,
342 * scalars use rvalue.
343 */
344 switch( classify( p1 -> type ) ) {
345 case TFILE:
346 case TARY:
347 case TREC:
348 case TSET:
349 case TSTR:
350 q = stkrval(argv_node->list_node.list,
351 p1 -> type , (long) LREQ );
352 break;
353 case TINT:
354 case TSCAL:
355 case TBOOL:
356 case TCHAR:
357 precheck( p1 -> type , "_RANG4" , "_RSNG4" );
358 q = stkrval(argv_node->list_node.list,
359 p1 -> type , (long) RREQ );
360 postcheck(p1 -> type, nl+T4INT);
361 break;
362 case TDOUBLE:
363 q = stkrval(argv_node->list_node.list,
364 p1 -> type , (long) RREQ );
365 sconv(p2type(q), PCCT_DOUBLE);
366 break;
367 default:
368 q = rvalue(argv_node->list_node.list,
369 p1 -> type , RREQ );
370 break;
371 }
372 # endif PC
373 if (q == NIL) {
374 chk = FALSE;
375 break;
376 }
377 if (incompat(q, p1->type,
378 argv_node->list_node.list)) {
379 cerror("Expression type clashed with type of value parameter %s of %s", p1->symbol, p->symbol);
380 chk = FALSE;
381 break;
382 }
383 # ifdef OBJ
384 if (isa(p1->type, "bcsi"))
385 rangechk(p1->type, q);
386 if (q->class != STR)
387 convert(q, p1->type);
388 # endif OBJ
389 # ifdef PC
390 switch( classify( p1 -> type ) ) {
391 case TFILE:
392 case TARY:
393 case TREC:
394 case TSET:
395 case TSTR:
396 putstrop( PCC_STARG
397 , p2type( p1 -> type )
398 , (int) lwidth( p1 -> type )
399 , align( p1 -> type ) );
400 }
401 # endif PC
402 break;
403 case FFUNC:
404 /*
405 * function parameter
406 */
407 q = flvalue(argv_node->list_node.list, p1 );
408 /*chk = (chk && fcompat(q, p1));*/
409 if ((chk) && (fcompat(q, p1)))
410 chk = TRUE;
411 else
412 chk = FALSE;
413 break;
414 case FPROC:
415 /*
416 * procedure parameter
417 */
418 q = flvalue(argv_node->list_node.list, p1 );
419 /* chk = (chk && fcompat(q, p1)); */
420 if ((chk) && (fcompat(q, p1)))
421 chk = TRUE;
422 else chk = FALSE;
423 break;
424 default:
425 panic("call");
426 }
427 # ifdef PC
428 /*
429 * if this is the nth (>1) argument,
430 * hang it on the left linear list of arguments
431 */
432 if ( noarguments ) {
433 noarguments = FALSE;
434 } else {
435 putop( PCC_CM , PCCT_INT );
436 }
437 # endif PC
438 argv_node = argv_node->list_node.next;
439 }
440 if (argv_node != TR_NIL) {
441 error("Too many arguments to %s", p->symbol);
442 rvlist(argv_node);
443 return (NLNIL);
444 }
445 if (chk == FALSE)
446 return NLNIL;
447 # ifdef OBJ
448 if ( p -> class == FFUNC || p -> class == FPROC ) {
449 (void) put(2, PTR_RV | psbn << 8+INDX, (int)p->value[NL_OFFS]);
450 (void) put(2, O_LV | cbn << 8 + INDX ,
451 (int) savedispnp -> value[ NL_OFFS ] );
452 (void) put(1, O_FCALL);
453 (void) put(2, O_FRTN, roundup(width(p->type), (long) A_STACK));
454 } else {
455 (void) put(2, O_CALL | psbn << 8, (long)p->value[NL_ENTLOC]);
456 }
457 # endif OBJ
458 # ifdef PC
459 /*
460 * for formal calls: add the hidden argument
461 * which is the formal struct describing the
462 * environment of the routine.
463 * and the argument which is the address of the
464 * space into which to save the display.
465 */
466 if ( p -> class == FFUNC || p -> class == FPROC ) {
467 putRV((char *) 0 , cbn , tempdescrp -> value[ NL_OFFS ] ,
468 tempdescrp -> extra_flags , PCCTM_PTR|PCCT_STRTY );
469 if ( !noarguments ) {
470 putop( PCC_CM , PCCT_INT );
471 }
472 noarguments = FALSE;
473 putLV((char *) 0 , cbn , savedispnp -> value[ NL_OFFS ] ,
474 savedispnp -> extra_flags , PCCTM_PTR | PCCT_STRTY );
475 putop( PCC_CM , PCCT_INT );
476 }
477 /*
478 * do the actual call:
479 * either ... p( ... ) ...
480 * or ... ( t -> entryaddr )( ... ) ...
481 * and maybe an assignment.
482 */
483 if ( porf == FUNC ) {
484 switch ( p_type_class ) {
485 case TBOOL:
486 case TCHAR:
487 case TINT:
488 case TSCAL:
489 case TDOUBLE:
490 case TPTR:
491 putop( ( noarguments ? PCCOM_UNARY PCC_CALL : PCC_CALL ) ,
492 (int) p_type_p2type );
493 if ( p -> class == FFUNC ) {
494 putop( PCC_ASSIGN , (int) p_type_p2type );
495 }
496 break;
497 default:
498 putstrop( ( noarguments ? PCCOM_UNARY PCC_STCALL : PCC_STCALL ),
499 (int) PCCM_ADDTYPE( p_type_p2type , PCCTM_PTR ) ,
500 (int) p_type_width ,(int) p_type_align );
501 putstrop(PCC_STASG, (int) PCCM_ADDTYPE(p_type_p2type, PCCTM_PTR),
502 (int) lwidth(p -> type), align(p -> type));
503 break;
504 }
505 } else {
506 putop( ( noarguments ? PCCOM_UNARY PCC_CALL : PCC_CALL ) , PCCT_INT );
507 }
508 /*
509 * ( t=p , ... , FRTN( t ) ...
510 */
511 if ( p -> class == FFUNC || p -> class == FPROC ) {
512 putop( PCC_COMOP , PCCT_INT );
513 putleaf( PCC_ICON , 0 , 0 , PCCM_ADDTYPE( PCCTM_FTN | PCCT_INT , PCCTM_PTR ) ,
514 "_FRTN" );
515 putRV((char *) 0 , cbn , tempdescrp -> value[ NL_OFFS ] ,
516 tempdescrp -> extra_flags , PCCTM_PTR | PCCT_STRTY );
517 putLV((char *) 0 , cbn , savedispnp -> value[ NL_OFFS ] ,
518 savedispnp -> extra_flags , PCCTM_PTR | PCCT_STRTY );
519 putop( PCC_CM , PCCT_INT );
520 putop( PCC_CALL , PCCT_INT );
521 putop( PCC_COMOP , PCCT_INT );
522 }
523 /*
524 * if required:
525 * either ... , temp )
526 * or ... , &temp )
527 */
528 if ( porf == FUNC && temptype != PCCT_UNDEF ) {
529 if ( temptype != PCCT_STRTY ) {
530 putRV((char *) 0 , cbn , tempnlp -> value[ NL_OFFS ] ,
531 tempnlp -> extra_flags , (int) p_type_p2type );
532 } else {
533 putLV((char *) 0 , cbn , tempnlp -> value[ NL_OFFS ] ,
534 tempnlp -> extra_flags , (int) p_type_p2type );
535 }
536 putop( PCC_COMOP , PCCT_INT );
537 }
538 if ( porf == PROC ) {
539 putdot( filename , line );
540 }
541 # endif PC
542 return (p->type);
543 }
544
rvlist(al)545 rvlist(al)
546 register struct tnode *al;
547 {
548
549 for (; al != TR_NIL; al = al->list_node.next)
550 (void) rvalue( al->list_node.list, NLNIL , RREQ );
551 }
552
553 /*
554 * check that two function/procedure namelist entries are compatible
555 */
556 bool
fcompat(formal,actual)557 fcompat( formal , actual )
558 struct nl *formal;
559 struct nl *actual;
560 {
561 register struct nl *f_chain;
562 register struct nl *a_chain;
563 extern struct nl *plist();
564 bool compat = TRUE;
565
566 if ( formal == NLNIL || actual == NLNIL ) {
567 return FALSE;
568 }
569 for (a_chain = plist(actual), f_chain = plist(formal);
570 f_chain != NLNIL;
571 f_chain = f_chain->chain, a_chain = a_chain->chain) {
572 if (a_chain == NIL) {
573 error("%s %s declared on line %d has more arguments than",
574 parnam(formal->class), formal->symbol,
575 (char *) linenum(formal));
576 cerror("%s %s declared on line %d",
577 parnam(actual->class), actual->symbol,
578 (char *) linenum(actual));
579 return FALSE;
580 }
581 if ( a_chain -> class != f_chain -> class ) {
582 error("%s parameter %s of %s declared on line %d is not identical",
583 parnam(f_chain->class), f_chain->symbol,
584 formal->symbol, (char *) linenum(formal));
585 cerror("with %s parameter %s of %s declared on line %d",
586 parnam(a_chain->class), a_chain->symbol,
587 actual->symbol, (char *) linenum(actual));
588 compat = FALSE;
589 } else if (a_chain->class == FFUNC || a_chain->class == FPROC) {
590 /*compat = (compat && fcompat(f_chain, a_chain));*/
591 if ((compat) && (fcompat(f_chain, a_chain)))
592 compat = TRUE;
593 else compat = FALSE;
594 }
595 if ((a_chain->class != FPROC && f_chain->class != FPROC) &&
596 (a_chain->type != f_chain->type)) {
597 error("Type of %s parameter %s of %s declared on line %d is not identical",
598 parnam(f_chain->class), f_chain->symbol,
599 formal->symbol, (char *) linenum(formal));
600 cerror("to type of %s parameter %s of %s declared on line %d",
601 parnam(a_chain->class), a_chain->symbol,
602 actual->symbol, (char *) linenum(actual));
603 compat = FALSE;
604 }
605 }
606 if (a_chain != NIL) {
607 error("%s %s declared on line %d has fewer arguments than",
608 parnam(formal->class), formal->symbol,
609 (char *) linenum(formal));
610 cerror("%s %s declared on line %d",
611 parnam(actual->class), actual->symbol,
612 (char *) linenum(actual));
613 return FALSE;
614 }
615 return compat;
616 }
617
618 char *
parnam(nltype)619 parnam(nltype)
620 int nltype;
621 {
622 switch(nltype) {
623 case REF:
624 return "var";
625 case VAR:
626 return "value";
627 case FUNC:
628 case FFUNC:
629 return "function";
630 case PROC:
631 case FPROC:
632 return "procedure";
633 default:
634 return "SNARK";
635 }
636 }
637
plist(p)638 struct nl *plist(p)
639 struct nl *p;
640 {
641 switch (p->class) {
642 case FFUNC:
643 case FPROC:
644 return p->ptr[ NL_FCHAIN ];
645 case PROC:
646 case FUNC:
647 return p->chain;
648 default:
649 {
650 panic("plist");
651 return(NLNIL); /* this is here only so lint won't complain
652 panic actually aborts */
653 }
654
655 }
656 }
657
658 linenum(p)
659 struct nl *p;
660 {
661 if (p->class == FUNC)
662 return p->ptr[NL_FVAR]->value[NL_LINENO];
663 return p->value[NL_LINENO];
664 }
665