![[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] / 42BSD / ucb / pascal / src|
Return to call.c CVS log | Up to [CSRG BSD Unix] / 42BSD / ucb / pascal / src |
1.1 root 1: /* Copyright (c) 1979 Regents of the University of California */
2:
3: static char sccsid[] = "@(#)call.c 1.24 6/3/83";
4:
5: #include "whoami.h"
6: #include "0.h"
7: #include "tree.h"
8: #include "opcode.h"
9: #include "objfmt.h"
10: #ifdef PC
11: # include "pc.h"
12: # include "pcops.h"
13: #endif PC
14: #include "tmps.h"
15:
16: /*
17: * Call generates code for calls to
18: * user defined procedures and functions
19: * and is called by proc and funccod.
20: * P is the result of the lookup
21: * of the procedure/function symbol,
22: * and porf is PROC or FUNC.
23: * Psbn is the block number of p.
24: *
25: * the idea here is that regular scalar functions are just called,
26: * while structure functions and formal functions have their results
27: * stored in a temporary after the call.
28: * structure functions do this because they return pointers
29: * to static results, so we copy the static
30: * and return a pointer to the copy.
31: * formal functions do this because we have to save the result
32: * around a call to the runtime routine which restores the display,
33: * so we can't just leave the result lying around in registers.
34: * formal calls save the address of the descriptor in a local
35: * temporary, so it can be addressed for the call which restores
36: * the display (FRTN).
37: * calls to formal parameters pass the formal as a hidden argument
38: * to a special entry point for the formal call.
39: * [this is somewhat dependent on the way arguments are addressed.]
40: * so PROCs and scalar FUNCs look like
41: * p(...args...)
42: * structure FUNCs look like
43: * (temp = p(...args...),&temp)
44: * formal FPROCs look like
45: * ( t=p,( t -> entryaddr )(...args...,t,s),FRTN(t,s))
46: * formal scalar FFUNCs look like
47: * ( t=p,temp=( t -> entryaddr )(...args...,t,s),FRTN(t,s),temp)
48: * formal structure FFUNCs look like
49: * (t=p,temp = ( t -> entryaddr )(...args...,t,s),FRTN(t,s),&temp)
50: */
51: struct nl *
52: call(p, argv, porf, psbn)
53: struct nl *p;
54: int *argv, porf, psbn;
55: {
56: register struct nl *p1, *q;
57: int *r;
58: struct nl *p_type_class = classify( p -> type );
59: bool chk = TRUE;
60: struct nl *savedispnp; /* temporary to hold saved display */
61: # ifdef PC
62: long p_p2type = p2type( p );
63: long p_type_p2type = p2type( p -> type );
64: bool noarguments;
65: long calltype; /* type of the call */
66: /*
67: * these get used if temporaries and structures are used
68: */
69: struct nl *tempnlp;
70: long temptype; /* type of the temporary */
71: long p_type_width;
72: long p_type_align;
73: char extname[ BUFSIZ ];
74: struct nl *tempdescrp;
75: # endif PC
76:
77: if (p->class == FFUNC || p->class == FPROC) {
78: /*
79: * allocate space to save the display for formal calls
80: */
81: savedispnp = tmpalloc( sizeof display , NIL , NOREG );
82: }
83: # ifdef OBJ
84: if (p->class == FFUNC || p->class == FPROC) {
85: put(2, O_LV | cbn << 8 + INDX ,
86: (int) savedispnp -> value[ NL_OFFS ] );
87: put(2, PTR_RV | psbn << 8+INDX, (int)p->value[NL_OFFS]);
88: }
89: if (porf == FUNC) {
90: /*
91: * Push some space
92: * for the function return type
93: */
94: put(2, O_PUSH, leven(-lwidth(p->type)));
95: }
96: # endif OBJ
97: # ifdef PC
98: /*
99: * if this is a formal call,
100: * stash the address of the descriptor
101: * in a temporary so we can find it
102: * after the FCALL for the call to FRTN
103: */
104: if ( p -> class == FFUNC || p -> class == FPROC ) {
105: tempdescrp = tmpalloc(sizeof( struct formalrtn *) , NIL ,
106: REGOK );
107: putRV( 0 , cbn , tempdescrp -> value[ NL_OFFS ] ,
108: tempdescrp -> extra_flags , P2PTR|P2STRTY );
109: putRV( 0 , psbn , p -> value[ NL_OFFS ] ,
110: p -> extra_flags , P2PTR|P2STRTY );
111: putop( P2ASSIGN , P2PTR | P2STRTY );
112: }
113: /*
114: * if we have to store a temporary,
115: * temptype will be its type,
116: * otherwise, it's P2UNDEF.
117: */
118: temptype = P2UNDEF;
119: calltype = P2INT;
120: if ( porf == FUNC ) {
121: p_type_width = width( p -> type );
122: switch( p_type_class ) {
123: case TSTR:
124: case TSET:
125: case TREC:
126: case TFILE:
127: case TARY:
128: calltype = temptype = P2STRTY;
129: p_type_align = align( p -> type );
130: break;
131: default:
132: if ( p -> class == FFUNC ) {
133: calltype = temptype = p2type( p -> type );
134: }
135: break;
136: }
137: if ( temptype != P2UNDEF ) {
138: tempnlp = tmpalloc(p_type_width, p -> type, NOREG);
139: /*
140: * temp
141: * for (temp = ...
142: */
143: putRV( 0 , cbn , tempnlp -> value[ NL_OFFS ] ,
144: tempnlp -> extra_flags , temptype );
145: }
146: }
147: switch ( p -> class ) {
148: case FUNC:
149: case PROC:
150: /*
151: * ... p( ...
152: */
153: sextname( extname , p -> symbol , BLOCKNO(p -> nl_block) );
154: putleaf( P2ICON , 0 , 0 , p2type( p ) , extname );
155: break;
156: case FFUNC:
157: case FPROC:
158:
159: /*
160: * ... ( t -> entryaddr )( ...
161: */
162: /* the descriptor */
163: putRV( 0 , cbn , tempdescrp -> value[ NL_OFFS ] ,
164: tempdescrp -> extra_flags , P2PTR | P2STRTY );
165: /* the entry address within the descriptor */
166: if ( FENTRYOFFSET != 0 ) {
167: putleaf( P2ICON , FENTRYOFFSET , 0 , P2INT , 0 );
168: putop( P2PLUS ,
169: ADDTYPE(
170: ADDTYPE( ADDTYPE( p2type( p ) , P2FTN ) ,
171: P2PTR ) ,
172: P2PTR ) );
173: }
174: /*
175: * indirect to fetch the formal entry address
176: * with the result type of the routine.
177: */
178: if (p -> class == FFUNC) {
179: putop( P2UNARY P2MUL ,
180: ADDTYPE(ADDTYPE(p2type(p -> type), P2FTN),
181: P2PTR));
182: } else {
183: /* procedures are int returning functions */
184: putop( P2UNARY P2MUL ,
185: ADDTYPE(ADDTYPE(P2INT, P2FTN), P2PTR));
186: }
187: break;
188: default:
189: panic("call class");
190: }
191: noarguments = TRUE;
192: # endif PC
193: /*
194: * Loop and process each of
195: * arguments to the proc/func.
196: * ... ( ... args ... ) ...
197: */
198: for (p1 = plist(p); p1 != NIL; p1 = p1->chain) {
199: if (argv == NIL) {
200: error("Not enough arguments to %s", p->symbol);
201: return (NIL);
202: }
203: switch (p1->class) {
204: case REF:
205: /*
206: * Var parameter
207: */
208: r = argv[1];
209: if (r != NIL && r[0] != T_VAR) {
210: error("Expression given (variable required) for var parameter %s of %s", p1->symbol, p->symbol);
211: chk = FALSE;
212: break;
213: }
214: q = lvalue( (int *) argv[1], MOD | ASGN , LREQ );
215: if (q == NIL) {
216: chk = FALSE;
217: break;
218: }
219: if (q != p1->type) {
220: error("Parameter type not identical to type of var parameter %s of %s", p1->symbol, p->symbol);
221: chk = FALSE;
222: break;
223: }
224: break;
225: case VAR:
226: /*
227: * Value parameter
228: */
229: # ifdef OBJ
230: q = rvalue(argv[1], p1->type , RREQ );
231: # endif OBJ
232: # ifdef PC
233: /*
234: * structure arguments require lvalues,
235: * scalars use rvalue.
236: */
237: switch( classify( p1 -> type ) ) {
238: case TFILE:
239: case TARY:
240: case TREC:
241: case TSET:
242: case TSTR:
243: q = stkrval( argv[1] , p1 -> type , LREQ );
244: break;
245: case TINT:
246: case TSCAL:
247: case TBOOL:
248: case TCHAR:
249: precheck( p1 -> type , "_RANG4" , "_RSNG4" );
250: q = stkrval( argv[1] , p1 -> type , RREQ );
251: postcheck(p1 -> type, nl+T4INT);
252: break;
253: case TDOUBLE:
254: q = stkrval( argv[1] , p1 -> type , RREQ );
255: sconv(p2type(q), P2DOUBLE);
256: break;
257: default:
258: q = rvalue( argv[1] , p1 -> type , RREQ );
259: break;
260: }
261: # endif PC
262: if (q == NIL) {
263: chk = FALSE;
264: break;
265: }
266: if (incompat(q, p1->type, argv[1])) {
267: cerror("Expression type clashed with type of value parameter %s of %s", p1->symbol, p->symbol);
268: chk = FALSE;
269: break;
270: }
271: # ifdef OBJ
272: if (isa(p1->type, "bcsi"))
273: rangechk(p1->type, q);
274: if (q->class != STR)
275: convert(q, p1->type);
276: # endif OBJ
277: # ifdef PC
278: switch( classify( p1 -> type ) ) {
279: case TFILE:
280: case TARY:
281: case TREC:
282: case TSET:
283: case TSTR:
284: putstrop( P2STARG
285: , p2type( p1 -> type )
286: , lwidth( p1 -> type )
287: , align( p1 -> type ) );
288: }
289: # endif PC
290: break;
291: case FFUNC:
292: /*
293: * function parameter
294: */
295: q = flvalue( (int *) argv[1] , p1 );
296: chk = (chk && fcompat(q, p1));
297: break;
298: case FPROC:
299: /*
300: * procedure parameter
301: */
302: q = flvalue( (int *) argv[1] , p1 );
303: chk = (chk && fcompat(q, p1));
304: break;
305: default:
306: panic("call");
307: }
308: # ifdef PC
309: /*
310: * if this is the nth (>1) argument,
311: * hang it on the left linear list of arguments
312: */
313: if ( noarguments ) {
314: noarguments = FALSE;
315: } else {
316: putop( P2LISTOP , P2INT );
317: }
318: # endif PC
319: argv = argv[2];
320: }
321: if (argv != NIL) {
322: error("Too many arguments to %s", p->symbol);
323: rvlist(argv);
324: return (NIL);
325: }
326: if (chk == FALSE)
327: return NIL;
328: # ifdef OBJ
329: if ( p -> class == FFUNC || p -> class == FPROC ) {
330: put(2, PTR_RV | psbn << 8+INDX, (int)p->value[NL_OFFS]);
331: put(2, O_LV | cbn << 8 + INDX ,
332: (int) savedispnp -> value[ NL_OFFS ] );
333: put(1, O_FCALL);
334: put(2, O_FRTN, even(width(p->type)));
335: } else {
336: put(2, O_CALL | psbn << 8, (long)p->value[NL_ENTLOC]);
337: }
338: # endif OBJ
339: # ifdef PC
340: /*
341: * for formal calls: add the hidden argument
342: * which is the formal struct describing the
343: * environment of the routine.
344: * and the argument which is the address of the
345: * space into which to save the display.
346: */
347: if ( p -> class == FFUNC || p -> class == FPROC ) {
348: putRV( 0 , cbn , tempdescrp -> value[ NL_OFFS ] ,
349: tempdescrp -> extra_flags , P2PTR|P2STRTY );
350: if ( !noarguments ) {
351: putop( P2LISTOP , P2INT );
352: }
353: noarguments = FALSE;
354: putLV( 0 , cbn , savedispnp -> value[ NL_OFFS ] ,
355: savedispnp -> extra_flags , P2PTR | P2STRTY );
356: putop( P2LISTOP , P2INT );
357: }
358: /*
359: * do the actual call:
360: * either ... p( ... ) ...
361: * or ... ( t -> entryaddr )( ... ) ...
362: * and maybe an assignment.
363: */
364: if ( porf == FUNC ) {
365: switch ( p_type_class ) {
366: case TBOOL:
367: case TCHAR:
368: case TINT:
369: case TSCAL:
370: case TDOUBLE:
371: case TPTR:
372: putop( ( noarguments ? P2UNARY P2CALL : P2CALL ) ,
373: p_type_p2type );
374: if ( p -> class == FFUNC ) {
375: putop( P2ASSIGN , p_type_p2type );
376: }
377: break;
378: default:
379: putstrop( ( noarguments ? P2UNARY P2STCALL : P2STCALL ),
380: ADDTYPE( p_type_p2type , P2PTR ) ,
381: p_type_width , p_type_align );
382: putstrop(P2STASG, ADDTYPE(p_type_p2type, P2PTR),
383: lwidth(p -> type), align(p -> type));
384: break;
385: }
386: } else {
387: putop( ( noarguments ? P2UNARY P2CALL : P2CALL ) , P2INT );
388: }
389: /*
390: * ( t=p , ... , FRTN( t ) ...
391: */
392: if ( p -> class == FFUNC || p -> class == FPROC ) {
393: putop( P2COMOP , P2INT );
394: putleaf( P2ICON , 0 , 0 , ADDTYPE( P2FTN | P2INT , P2PTR ) ,
395: "_FRTN" );
396: putRV( 0 , cbn , tempdescrp -> value[ NL_OFFS ] ,
397: tempdescrp -> extra_flags , P2PTR | P2STRTY );
398: putLV( 0 , cbn , savedispnp -> value[ NL_OFFS ] ,
399: savedispnp -> extra_flags , P2PTR | P2STRTY );
400: putop( P2LISTOP , P2INT );
401: putop( P2CALL , P2INT );
402: putop( P2COMOP , P2INT );
403: }
404: /*
405: * if required:
406: * either ... , temp )
407: * or ... , &temp )
408: */
409: if ( porf == FUNC && temptype != P2UNDEF ) {
410: if ( temptype != P2STRTY ) {
411: putRV( 0 , cbn , tempnlp -> value[ NL_OFFS ] ,
412: tempnlp -> extra_flags , p_type_p2type );
413: } else {
414: putLV( 0 , cbn , tempnlp -> value[ NL_OFFS ] ,
415: tempnlp -> extra_flags , p_type_p2type );
416: }
417: putop( P2COMOP , P2INT );
418: }
419: if ( porf == PROC ) {
420: putdot( filename , line );
421: }
422: # endif PC
423: return (p->type);
424: }
425:
426: rvlist(al)
427: register int *al;
428: {
429:
430: for (; al != NIL; al = al[2])
431: rvalue( (int *) al[1], NLNIL , RREQ );
432: }
433:
434: /*
435: * check that two function/procedure namelist entries are compatible
436: */
437: bool
438: fcompat( formal , actual )
439: struct nl *formal;
440: struct nl *actual;
441: {
442: register struct nl *f_chain;
443: register struct nl *a_chain;
444: bool compat = TRUE;
445:
446: if ( formal == NIL || actual == NIL ) {
447: return FALSE;
448: }
449: for (a_chain = plist(actual), f_chain = plist(formal);
450: f_chain != NIL;
451: f_chain = f_chain->chain, a_chain = a_chain->chain) {
452: if (a_chain == NIL) {
453: error("%s %s declared on line %d has more arguments than",
454: parnam(formal->class), formal->symbol,
455: linenum(formal));
456: cerror("%s %s declared on line %d",
457: parnam(actual->class), actual->symbol,
458: linenum(actual));
459: return FALSE;
460: }
461: if ( a_chain -> class != f_chain -> class ) {
462: error("%s parameter %s of %s declared on line %d is not identical",
463: parnam(f_chain->class), f_chain->symbol,
464: formal->symbol, linenum(formal));
465: cerror("with %s parameter %s of %s declared on line %d",
466: parnam(a_chain->class), a_chain->symbol,
467: actual->symbol, linenum(actual));
468: compat = FALSE;
469: } else if (a_chain->class == FFUNC || a_chain->class == FPROC) {
470: compat = (compat && fcompat(f_chain, a_chain));
471: }
472: if ((a_chain->class != FPROC && f_chain->class != FPROC) &&
473: (a_chain->type != f_chain->type)) {
474: error("Type of %s parameter %s of %s declared on line %d is not identical",
475: parnam(f_chain->class), f_chain->symbol,
476: formal->symbol, linenum(formal));
477: cerror("to type of %s parameter %s of %s declared on line %d",
478: parnam(a_chain->class), a_chain->symbol,
479: actual->symbol, linenum(actual));
480: compat = FALSE;
481: }
482: }
483: if (a_chain != NIL) {
484: error("%s %s declared on line %d has fewer arguments than",
485: parnam(formal->class), formal->symbol,
486: linenum(formal));
487: cerror("%s %s declared on line %d",
488: parnam(actual->class), actual->symbol,
489: linenum(actual));
490: return FALSE;
491: }
492: return compat;
493: }
494:
495: char *
496: parnam(nltype)
497: int nltype;
498: {
499: switch(nltype) {
500: case REF:
501: return "var";
502: case VAR:
503: return "value";
504: case FUNC:
505: case FFUNC:
506: return "function";
507: case PROC:
508: case FPROC:
509: return "procedure";
510: default:
511: return "SNARK";
512: }
513: }
514:
515: plist(p)
516: struct nl *p;
517: {
518: switch (p->class) {
519: case FFUNC:
520: case FPROC:
521: return p->ptr[ NL_FCHAIN ];
522: case PROC:
523: case FUNC:
524: return p->chain;
525: default:
526: panic("plist");
527: }
528: }
529:
530: linenum(p)
531: struct nl *p;
532: {
533: if (p->class == FUNC)
534: return p->ptr[NL_FVAR]->value[NL_LINENO];
535: return p->value[NL_LINENO];
536: }
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.