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