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