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