![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to pcfunc.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 pcfunc.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[] = "@(#)pcfunc.c 1.13 2/28/83";
4:
5: #include "whoami.h"
6: #ifdef PC
7: /*
8: * and to the end of the file
9: */
10: #include "0.h"
11: #include "tree.h"
12: #include "objfmt.h"
13: #include "opcode.h"
14: #include "pc.h"
15: #include "pcops.h"
16: #include "tmps.h"
17:
18: /*
19: * Funccod generates code for
20: * built in function calls and calls
21: * call to generate calls to user
22: * defined functions and procedures.
23: */
24: pcfunccod( r )
25: int *r;
26: {
27: struct nl *p;
28: register struct nl *p1;
29: register int *al;
30: register op;
31: int argc, *argv;
32: int tr[2], tr2[4];
33: char *funcname;
34: struct nl *tempnlp;
35: long temptype;
36: struct nl *rettype;
37:
38: /*
39: * Verify that the given name
40: * is defined and the name of
41: * a function.
42: */
43: p = lookup(r[2]);
44: if (p == NIL) {
45: rvlist(r[3]);
46: return (NIL);
47: }
48: if (p->class != FUNC && p->class != FFUNC) {
49: error("%s is not a function", p->symbol);
50: rvlist(r[3]);
51: return (NIL);
52: }
53: argv = r[3];
54: /*
55: * Call handles user defined
56: * procedures and functions
57: */
58: if (bn != 0)
59: return (call(p, argv, FUNC, bn));
60: /*
61: * Count the arguments
62: */
63: argc = 0;
64: for (al = argv; al != NIL; al = al[2])
65: argc++;
66: /*
67: * Built-in functions have
68: * their interpreter opcode
69: * associated with them.
70: */
71: op = p->value[0] &~ NSTAND;
72: if (opt('s') && (p->value[0] & NSTAND)) {
73: standard();
74: error("%s is a nonstandard function", p->symbol);
75: }
76: if ( op == O_ARGC ) {
77: putleaf( P2NAME , 0 , 0 , P2INT , "__argc" );
78: return nl + T4INT;
79: }
80: switch (op) {
81: /*
82: * Parameterless functions
83: */
84: case O_CLCK:
85: funcname = "_CLCK";
86: goto noargs;
87: case O_SCLCK:
88: funcname = "_SCLCK";
89: goto noargs;
90: noargs:
91: if (argc != 0) {
92: error("%s takes no arguments", p->symbol);
93: rvlist(argv);
94: return (NIL);
95: }
96: putleaf( P2ICON , 0 , 0
97: , ADDTYPE( P2FTN | P2INT , P2PTR )
98: , funcname );
99: putop( P2UNARY P2CALL , P2INT );
100: return (nl+T4INT);
101: case O_WCLCK:
102: if (argc != 0) {
103: error("%s takes no arguments", p->symbol);
104: rvlist(argv);
105: return (NIL);
106: }
107: putleaf( P2ICON , 0 , 0
108: , ADDTYPE( P2FTN | P2INT , P2PTR )
109: , "_time" );
110: putleaf( P2ICON , 0 , 0 , P2INT , 0 );
111: putop( P2CALL , P2INT );
112: return (nl+T4INT);
113: case O_EOF:
114: case O_EOLN:
115: if (argc == 0) {
116: argv = tr;
117: tr[1] = tr2;
118: tr2[0] = T_VAR;
119: tr2[2] = input->symbol;
120: tr2[1] = tr2[3] = NIL;
121: argc = 1;
122: } else if (argc != 1) {
123: error("%s takes either zero or one argument", p->symbol);
124: rvlist(argv);
125: return (NIL);
126: }
127: }
128: /*
129: * All other functions take
130: * exactly one argument.
131: */
132: if (argc != 1) {
133: error("%s takes exactly one argument", p->symbol);
134: rvlist(argv);
135: return (NIL);
136: }
137: /*
138: * find out the type of the argument
139: */
140: codeoff();
141: p1 = stkrval((int *) argv[1], NLNIL , RREQ );
142: codeon();
143: if (p1 == NIL)
144: return (NIL);
145: /*
146: * figure out the return type and the funtion name
147: */
148: switch (op) {
149: case O_EXP:
150: funcname = opt('t') ? "_EXP" : "_exp";
151: goto mathfunc;
152: case O_SIN:
153: funcname = opt('t') ? "_SIN" : "_sin";
154: goto mathfunc;
155: case O_COS:
156: funcname = opt('t') ? "_COS" : "_cos";
157: goto mathfunc;
158: case O_ATAN:
159: funcname = opt('t') ? "_ATAN" : "_atan";
160: goto mathfunc;
161: case O_LN:
162: funcname = opt('t') ? "_LN" : "_log";
163: goto mathfunc;
164: case O_SQRT:
165: funcname = opt('t') ? "_SQRT" : "_sqrt";
166: goto mathfunc;
167: case O_RANDOM:
168: funcname = "_RANDOM";
169: goto mathfunc;
170: mathfunc:
171: if (isnta(p1, "id")) {
172: error("%s's argument must be integer or real, not %s", p->symbol, nameof(p1));
173: return (NIL);
174: }
175: putleaf( P2ICON , 0 , 0
176: , ADDTYPE( P2FTN | P2DOUBLE , P2PTR ) , funcname );
177: p1 = stkrval( (int *) argv[1] , NLNIL , RREQ );
178: sconv(p2type(p1), P2DOUBLE);
179: putop( P2CALL , P2DOUBLE );
180: return nl + TDOUBLE;
181: case O_EXPO:
182: if (isnta( p1 , "id" ) ) {
183: error("%s's argument must be integer or real, not %s", p->symbol, nameof(p1));
184: return NIL;
185: }
186: putleaf( P2ICON , 0 , 0
187: , ADDTYPE( P2FTN | P2INT , P2PTR ) , "_EXPO" );
188: p1 = stkrval( (int *) argv[1] , NLNIL , RREQ );
189: sconv(p2type(p1), P2DOUBLE);
190: putop( P2CALL , P2INT );
191: return ( nl + T4INT );
192: case O_UNDEF:
193: if ( isnta( p1 , "id" ) ) {
194: error("%s's argument must be integer or real, not %s", p->symbol, nameof(p1));
195: return NIL;
196: }
197: p1 = stkrval( (int *) argv[1] , NLNIL , RREQ );
198: putleaf( P2ICON , 0 , 0 , P2CHAR , 0 );
199: putop( P2COMOP , P2CHAR );
200: return ( nl + TBOOL );
201: case O_SEED:
202: if (isnta(p1, "i")) {
203: error("seed's argument must be an integer, not %s", nameof(p1));
204: return (NIL);
205: }
206: putleaf( P2ICON , 0 , 0
207: , ADDTYPE( P2FTN | P2INT , P2PTR ) , "_SEED" );
208: p1 = stkrval( (int *) argv[1] , NLNIL , RREQ );
209: putop( P2CALL , P2INT );
210: return nl + T4INT;
211: case O_ROUND:
212: case O_TRUNC:
213: if ( isnta( p1 , "d" ) ) {
214: error("%s's argument must be a real, not %s", p->symbol, nameof(p1));
215: return (NIL);
216: }
217: putleaf( P2ICON , 0 , 0
218: , ADDTYPE( P2FTN | P2INT , P2PTR )
219: , op == O_ROUND ? "_ROUND" : "_TRUNC" );
220: p1 = stkrval( (int *) argv[1] , NLNIL , RREQ );
221: putop( P2CALL , P2INT );
222: return nl + T4INT;
223: case O_ABS2:
224: if ( isa( p1 , "d" ) ) {
225: putleaf( P2ICON , 0 , 0
226: , ADDTYPE( P2FTN | P2DOUBLE , P2PTR )
227: , "_fabs" );
228: p1 = stkrval( (int *) argv[1] , NLNIL , RREQ );
229: putop( P2CALL , P2DOUBLE );
230: return nl + TDOUBLE;
231: }
232: if ( isa( p1 , "i" ) ) {
233: putleaf( P2ICON , 0 , 0
234: , ADDTYPE( P2FTN | P2INT , P2PTR ) , "_abs" );
235: p1 = stkrval( (int *) argv[1] , NLNIL , RREQ );
236: putop( P2CALL , P2INT );
237: return nl + T4INT;
238: }
239: error("%s's argument must be an integer or real, not %s", p->symbol, nameof(p1));
240: return NIL;
241: case O_SQR2:
242: if ( isa( p1 , "d" ) ) {
243: temptype = P2DOUBLE;
244: rettype = nl + TDOUBLE;
245: tempnlp = tmpalloc(sizeof(double), rettype, REGOK);
246: } else if ( isa( p1 , "i" ) ) {
247: temptype = P2INT;
248: rettype = nl + T4INT;
249: tempnlp = tmpalloc(sizeof(long), rettype, REGOK);
250: } else {
251: error("%s's argument must be an integer or real, not %s", p->symbol, nameof(p1));
252: return NIL;
253: }
254: putRV( 0 , cbn , tempnlp -> value[ NL_OFFS ] ,
255: tempnlp -> extra_flags , temptype , 0 );
256: p1 = rvalue( (int *) argv[1] , NLNIL , RREQ );
257: sconv(p2type(p1), temptype);
258: putop( P2ASSIGN , temptype );
259: putRV( 0 , cbn , tempnlp -> value[ NL_OFFS ] ,
260: tempnlp -> extra_flags , temptype , 0 );
261: putRV( 0 , cbn , tempnlp -> value[ NL_OFFS ] ,
262: tempnlp -> extra_flags , temptype , 0 );
263: putop( P2MUL , temptype );
264: putop( P2COMOP , temptype );
265: return rettype;
266: case O_ORD2:
267: p1 = stkrval( (int *) argv[1] , NLNIL , RREQ );
268: if (isa(p1, "bcis")) {
269: return (nl+T4INT);
270: }
271: if (classify(p1) == TPTR) {
272: if (!opt('s')) {
273: return (nl+T4INT);
274: }
275: standard();
276: }
277: error("ord's argument must be of scalar type, not %s",
278: nameof(p1));
279: return (NIL);
280: case O_SUCC2:
281: case O_PRED2:
282: if (isa(p1, "d")) {
283: error("%s is forbidden for reals", p->symbol);
284: return (NIL);
285: }
286: if ( isnta( p1 , "bcsi" ) ) {
287: error("%s's argument must be of scalar type, not %s", p->symbol, nameof(p1));
288: return NIL;
289: }
290: if ( opt( 't' ) ) {
291: putleaf( P2ICON , 0 , 0
292: , ADDTYPE( P2FTN | P2INT , P2PTR )
293: , op == O_SUCC2 ? "_SUCC" : "_PRED" );
294: p1 = stkrval( (int *) argv[1] , NLNIL , RREQ );
295: tempnlp = p1 -> class == TYPE ? p1 -> type : p1;
296: putleaf( P2ICON, tempnlp -> range[0], 0, P2INT, 0 );
297: putop( P2LISTOP , P2INT );
298: putleaf( P2ICON, tempnlp -> range[1], 0, P2INT, 0 );
299: putop( P2LISTOP , P2INT );
300: putop( P2CALL , P2INT );
301: sconv(P2INT, p2type(p1));
302: } else {
303: p1 = stkrval( (int *) argv[1] , NLNIL , RREQ );
304: putleaf( P2ICON , 1 , 0 , P2INT , 0 );
305: putop( op == O_SUCC2 ? P2PLUS : P2MINUS , P2INT );
306: sconv(P2INT, p2type(p1));
307: }
308: if ( isa( p1 , "bcs" ) ) {
309: return p1;
310: } else {
311: return nl + T4INT;
312: }
313: case O_ODD2:
314: if (isnta(p1, "i")) {
315: error("odd's argument must be an integer, not %s", nameof(p1));
316: return (NIL);
317: }
318: p1 = stkrval( (int *) argv[1] , NLNIL , RREQ );
319: /*
320: * THIS IS MACHINE-DEPENDENT!!!
321: */
322: putleaf( P2ICON , 1 , 0 , P2INT , 0 );
323: putop( P2AND , P2INT );
324: sconv(P2INT, P2CHAR);
325: return nl + TBOOL;
326: case O_CHR2:
327: if (isnta(p1, "i")) {
328: error("chr's argument must be an integer, not %s", nameof(p1));
329: return (NIL);
330: }
331: if (opt('t')) {
332: putleaf( P2ICON , 0 , 0
333: , ADDTYPE( P2FTN | P2CHAR , P2PTR ) , "_CHR" );
334: p1 = stkrval( (int *) argv[1] , NLNIL , RREQ );
335: putop( P2CALL , P2CHAR );
336: } else {
337: p1 = stkrval( (int *) argv[1] , NLNIL , RREQ );
338: sconv(P2INT, P2CHAR);
339: }
340: return nl + TCHAR;
341: case O_CARD:
342: if (isnta(p1, "t")) {
343: error("Argument to card must be a set, not %s", nameof(p1));
344: return (NIL);
345: }
346: putleaf( P2ICON , 0 , 0
347: , ADDTYPE( P2FTN | P2INT , P2PTR ) , "_CARD" );
348: p1 = stkrval( (int *) argv[1] , NLNIL , LREQ );
349: putleaf( P2ICON , lwidth( p1 ) , 0 , P2INT , 0 );
350: putop( P2LISTOP , P2INT );
351: putop( P2CALL , P2INT );
352: return nl + T4INT;
353: case O_EOLN:
354: if (!text(p1)) {
355: error("Argument to eoln must be a text file, not %s", nameof(p1));
356: return (NIL);
357: }
358: putleaf( P2ICON , 0 , 0
359: , ADDTYPE( P2FTN | P2INT , P2PTR ) , "_TEOLN" );
360: p1 = stklval( (int *) argv[1] , NOFLAGS );
361: putop( P2CALL , P2INT );
362: sconv(P2INT, P2CHAR);
363: return nl + TBOOL;
364: case O_EOF:
365: if (p1->class != FILET) {
366: error("Argument to eof must be file, not %s", nameof(p1));
367: return (NIL);
368: }
369: putleaf( P2ICON , 0 , 0
370: , ADDTYPE( P2FTN | P2INT , P2PTR ) , "_TEOF" );
371: p1 = stklval( (int *) argv[1] , NOFLAGS );
372: putop( P2CALL , P2INT );
373: sconv(P2INT, P2CHAR);
374: return nl + TBOOL;
375: case 0:
376: error("%s is an unimplemented 6000-3.4 extension", p->symbol);
377: default:
378: panic("func1");
379: }
380: }
381: #endif PC
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.