![[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] / 40BSD / cmd / pi|
Return to call.c CVS log | Up to [CSRG BSD Unix] / 40BSD / cmd / pi |
1.1 root 1: /* Copyright (c) 1979 Regents of the University of California */
2:
3: static char sccsid[] = "@(#)call.c 1.3 10/2/80";
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:
15: bool slenflag = 0;
16: bool floatflag = 0;
17:
18: /*
19: * Call generates code for calls to
20: * user defined procedures and functions
21: * and is called by proc and funccod.
22: * P is the result of the lookup
23: * of the procedure/function symbol,
24: * and porf is PROC or FUNC.
25: * Psbn is the block number of p.
26: */
27: struct nl *
28: call(p, argv, porf, psbn)
29: struct nl *p;
30: int *argv, porf, psbn;
31: {
32: register struct nl *p1, *q;
33: int *r;
34:
35: # ifdef OBJ
36: int cnt;
37: # endif OBJ
38: # ifdef PC
39: long temp;
40: int firsttime;
41: int rettype;
42: # endif PC
43:
44: # ifdef OBJ
45: if (p->class == FFUNC || p->class == FPROC)
46: put(2, PTR_RV | cbn << 8+INDX, p->value[NL_OFFS]);
47: if (porf == FUNC)
48: /*
49: * Push some space
50: * for the function return type
51: */
52: put2(O_PUSH, even(-width(p->type)));
53: # endif OBJ
54: # ifdef PC
55: if ( porf == FUNC ) {
56: switch( classify( p -> type ) ) {
57: case TSTR:
58: case TSET:
59: case TREC:
60: case TFILE:
61: case TARY:
62: temp = sizes[ cbn ].om_off -= width( p -> type );
63: putlbracket( ftnno , -sizes[cbn].om_off );
64: if (sizes[cbn].om_off < sizes[cbn].om_max) {
65: sizes[cbn].om_max = sizes[cbn].om_off;
66: }
67: putRV( 0 , cbn , temp , P2STRTY );
68: }
69: }
70: switch ( p -> class ) {
71: case FUNC:
72: case PROC:
73: {
74: char extname[ BUFSIZ ];
75: char *starthere;
76: int funcbn;
77: int i;
78:
79: starthere = &extname[0];
80: funcbn = p -> nl_block & 037;
81: for ( i = 1 ; i < funcbn ; i++ ) {
82: sprintf( starthere , EXTFORMAT , enclosing[ i ] );
83: starthere += strlen( enclosing[ i ] ) + 1;
84: }
85: sprintf( starthere , EXTFORMAT , p -> symbol );
86: starthere += strlen( p -> symbol ) + 1;
87: if ( starthere >= &extname[ BUFSIZ ] ) {
88: panic( "call namelength" );
89: }
90: putleaf( P2ICON , 0 , 0 , p2type( p ) , extname );
91: }
92: break;
93: case FFUNC:
94: case FPROC:
95: /*
96: * start one of these:
97: * FRTN( frtn , ( *FCALL( frtn ) )(...args...) )
98: */
99: putleaf( P2ICON , 0 , 0 , p2type( p ) , "_FRTN" );
100: putRV( 0 , cbn , p -> value[NL_OFFS] , P2PTR|P2STRTY );
101: putleaf( P2ICON , 0 , 0
102: , ADDTYPE( P2PTR , ADDTYPE( P2FTN , p2type( p ) ) )
103: , "_FCALL" );
104: putRV( 0 , cbn , p -> value[NL_OFFS] , P2PTR|P2STRTY );
105: putop( P2CALL , p2type( p ) );
106: break;
107: default:
108: panic("call class");
109: }
110: firsttime = TRUE;
111: # endif PC
112: /*
113: * Loop and process each of
114: * arguments to the proc/func.
115: */
116: if ( p -> class == FUNC || p -> class == PROC ) {
117: for (p1 = p->chain; p1 != NIL; p1 = p1->chain) {
118: if (argv == NIL) {
119: error("Not enough arguments to %s", p->symbol);
120: return (NIL);
121: }
122: switch (p1->class) {
123: case REF:
124: /*
125: * Var parameter
126: */
127: r = argv[1];
128: if (r != NIL && r[0] != T_VAR) {
129: error("Expression given (variable required) for var parameter %s of %s", p1->symbol, p->symbol);
130: break;
131: }
132: q = lvalue( (int *) argv[1], MOD , LREQ );
133: if (q == NIL)
134: break;
135: if (q != p1->type) {
136: error("Parameter type not identical to type of var parameter %s of %s", p1->symbol, p->symbol);
137: break;
138: }
139: break;
140: case VAR:
141: /*
142: * Value parameter
143: */
144: # ifdef OBJ
145: q = rvalue(argv[1], p1->type , RREQ );
146: # endif OBJ
147: # ifdef PC
148: /*
149: * structure arguments require lvalues,
150: * scalars use rvalue.
151: */
152: switch( classify( p1 -> type ) ) {
153: case TFILE:
154: case TARY:
155: case TREC:
156: case TSET:
157: case TSTR:
158: q = rvalue( argv[1] , p1 -> type , LREQ );
159: break;
160: case TINT:
161: case TSCAL:
162: case TBOOL:
163: case TCHAR:
164: precheck( p1 -> type , "_RANG4" , "_RSNG4" );
165: q = rvalue( argv[1] , p1 -> type , RREQ );
166: postcheck( p1 -> type );
167: break;
168: default:
169: q = rvalue( argv[1] , p1 -> type , RREQ );
170: if ( isa( p1 -> type , "d" )
171: && isa( q , "i" ) ) {
172: putop( P2SCONV , P2DOUBLE );
173: }
174: break;
175: }
176: # endif PC
177: if (q == NIL)
178: break;
179: if (incompat(q, p1->type, argv[1])) {
180: cerror("Expression type clashed with type of value parameter %s of %s", p1->symbol, p->symbol);
181: break;
182: }
183: # ifdef OBJ
184: if (isa(p1->type, "bcsi"))
185: rangechk(p1->type, q);
186: if (q->class != STR)
187: convert(q, p1->type);
188: # endif OBJ
189: # ifdef PC
190: switch( classify( p1 -> type ) ) {
191: case TFILE:
192: case TARY:
193: case TREC:
194: case TSET:
195: case TSTR:
196: putstrop( P2STARG
197: , p2type( p1 -> type )
198: , lwidth( p1 -> type )
199: , align( p1 -> type ) );
200: }
201: # endif PC
202: break;
203: case FFUNC:
204: /*
205: * function parameter
206: */
207: q = flvalue( (int *) argv[1] , FFUNC );
208: if (q == NIL)
209: break;
210: if (q != p1->type) {
211: error("Function type not identical to type of function parameter %s of %s", p1->symbol, p->symbol);
212: break;
213: }
214: break;
215: case FPROC:
216: /*
217: * procedure parameter
218: */
219: q = flvalue( (int *) argv[1] , FPROC );
220: if (q != NIL) {
221: error("Procedure parameter %s of %s cannot have a type", p1->symbol, p->symbol);
222: }
223: break;
224: default:
225: panic("call");
226: }
227: # ifdef PC
228: /*
229: * if this is the nth (>1) argument,
230: * hang it on the left linear list of arguments
231: */
232: if ( firsttime ) {
233: firsttime = FALSE;
234: } else {
235: putop( P2LISTOP , P2INT );
236: }
237: # endif PC
238: argv = argv[2];
239: }
240: if (argv != NIL) {
241: error("Too many arguments to %s", p->symbol);
242: rvlist(argv);
243: return (NIL);
244: }
245: } else if ( p -> class == FFUNC || p -> class == FPROC ) {
246: /*
247: * formal routines can only have by-value parameters.
248: * this will lose for integer actuals passed to real
249: * formals, and strings which people want blank padded.
250: */
251: # ifdef OBJ
252: cnt = 0;
253: # endif OBJ
254: for ( ; argv != NIL ; argv = argv[2] ) {
255: # ifdef OBJ
256: q = rvalue(argv[1], NIL, RREQ );
257: cnt += even(lwidth(q));
258: # endif OBJ
259: # ifdef PC
260: /*
261: * structure arguments require lvalues,
262: * scalars use rvalue.
263: */
264: codeoff();
265: p1 = rvalue( argv[1] , NIL , RREQ );
266: codeon();
267: switch( classify( p1 ) ) {
268: case TSTR:
269: if ( p1 -> class == STR && slenflag == 0 ) {
270: if ( opt( 's' ) ) {
271: standard();
272: } else {
273: warning();
274: }
275: error("Implementation can't construct equal length strings");
276: slenflag++;
277: }
278: /* and fall through */
279: case TFILE:
280: case TARY:
281: case TREC:
282: case TSET:
283: q = rvalue( argv[1] , p1 , LREQ );
284: break;
285: case TINT:
286: if ( floatflag == 0 ) {
287: if ( opt( 's' ) ) {
288: standard();
289: } else {
290: warning();
291: }
292: error("Implementation can't coerice integer to real");
293: floatflag++;
294: }
295: /* and fall through */
296: case TSCAL:
297: case TBOOL:
298: case TCHAR:
299: default:
300: q = rvalue( argv[1] , p1 , RREQ );
301: break;
302: }
303: switch( classify( p1 ) ) {
304: case TFILE:
305: case TARY:
306: case TREC:
307: case TSET:
308: case TSTR:
309: putstrop( P2STARG , p2type( p1 ) ,
310: lwidth( p1 ) , align( p1 ) );
311: }
312: /*
313: * if this is the nth (>1) argument,
314: * hang it on the left linear list of arguments
315: */
316: if ( firsttime ) {
317: firsttime = FALSE;
318: } else {
319: putop( P2LISTOP , P2INT );
320: }
321: # endif PC
322: }
323: } else {
324: panic("call class");
325: }
326: # ifdef OBJ
327: if ( p -> class == FFUNC || p -> class == FPROC ) {
328: put(2, PTR_RV | cbn << 8+INDX, p->value[NL_OFFS]);
329: put(2, O_FCALL, cnt);
330: put(2, O_FRTN, even(lwidth(p->type)));
331: } else {
332: put2(O_CALL | psbn << 8+INDX, p->entloc);
333: }
334: # endif OBJ
335: # ifdef PC
336: if ( porf == FUNC ) {
337: rettype = p2type( p -> type );
338: switch ( classify( p -> type ) ) {
339: case TBOOL:
340: case TCHAR:
341: case TINT:
342: case TSCAL:
343: case TDOUBLE:
344: case TPTR:
345: if ( firsttime ) {
346: putop( P2UNARY P2CALL , rettype );
347: } else {
348: putop( P2CALL , rettype );
349: }
350: if (p -> class == FFUNC || p -> class == FPROC ) {
351: putop( P2LISTOP , P2INT );
352: putop( P2CALL , rettype );
353: }
354: break;
355: default:
356: if ( firsttime ) {
357: putstrop( P2UNARY P2STCALL
358: , ADDTYPE( rettype , P2PTR )
359: , lwidth( p -> type )
360: , align( p -> type ) );
361: } else {
362: putstrop( P2STCALL
363: , ADDTYPE( rettype , P2PTR )
364: , lwidth( p -> type )
365: , align( p -> type ) );
366: }
367: if (p -> class == FFUNC || p -> class == FPROC ) {
368: putop( P2LISTOP , P2INT );
369: putop( P2CALL , ADDTYPE( rettype , P2PTR ) );
370: }
371: putstrop( P2STASG , rettype , lwidth( p -> type )
372: , align( p -> type ) );
373: putLV( 0 , cbn , temp , rettype );
374: putop( P2COMOP , P2INT );
375: break;
376: }
377: } else {
378: if ( firsttime ) {
379: putop( P2UNARY P2CALL , P2INT );
380: } else {
381: putop( P2CALL , P2INT );
382: }
383: if (p -> class == FFUNC || p -> class == FPROC ) {
384: putop( P2LISTOP , P2INT );
385: putop( P2CALL , P2INT );
386: }
387: putdot( filename , line );
388: }
389: # endif PC
390: return (p->type);
391: }
392:
393: rvlist(al)
394: register int *al;
395: {
396:
397: for (; al != NIL; al = al[2])
398: rvalue( (int *) al[1], NLNIL , RREQ );
399: }
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.