![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to func.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 func.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[] = "@(#)func.c 1.8 4/27/82";
4:
5: #include "whoami.h"
6: #ifdef OBJ
7: /*
8: * the rest of the file
9: */
10: #include "0.h"
11: #include "tree.h"
12: #include "opcode.h"
13:
14: /*
15: * Funccod generates code for
16: * built in function calls and calls
17: * call to generate calls to user
18: * defined functions and procedures.
19: */
20: funccod(r)
21: int *r;
22: {
23: struct nl *p;
24: register struct nl *p1;
25: struct nl *tempnlp;
26: register int *al;
27: register op;
28: int argc, *argv;
29: int tr[2], tr2[4];
30:
31: /*
32: * Verify that the given name
33: * is defined and the name of
34: * a function.
35: */
36: p = lookup(r[2]);
37: if (p == NIL) {
38: rvlist(r[3]);
39: return (NIL);
40: }
41: if (p->class != FUNC && p->class != FFUNC) {
42: error("%s is not a function", p->symbol);
43: rvlist(r[3]);
44: return (NIL);
45: }
46: argv = r[3];
47: /*
48: * Call handles user defined
49: * procedures and functions
50: */
51: if (bn != 0)
52: return (call(p, argv, FUNC, bn));
53: /*
54: * Count the arguments
55: */
56: argc = 0;
57: for (al = argv; al != NIL; al = al[2])
58: argc++;
59: /*
60: * Built-in functions have
61: * their interpreter opcode
62: * associated with them.
63: */
64: op = p->value[0] &~ NSTAND;
65: if (opt('s') && (p->value[0] & NSTAND)) {
66: standard();
67: error("%s is a nonstandard function", p->symbol);
68: }
69: switch (op) {
70: /*
71: * Parameterless functions
72: */
73: case O_CLCK:
74: case O_SCLCK:
75: case O_WCLCK:
76: case O_ARGC:
77: if (argc != 0) {
78: error("%s takes no arguments", p->symbol);
79: rvlist(argv);
80: return (NIL);
81: }
82: put(1, op);
83: return (nl+T4INT);
84: case O_EOF:
85: case O_EOLN:
86: if (argc == 0) {
87: argv = tr;
88: tr[1] = tr2;
89: tr2[0] = T_VAR;
90: tr2[2] = input->symbol;
91: tr2[1] = tr2[3] = NIL;
92: argc = 1;
93: } else if (argc != 1) {
94: error("%s takes either zero or one argument", p->symbol);
95: rvlist(argv);
96: return (NIL);
97: }
98: }
99: /*
100: * All other functions take
101: * exactly one argument.
102: */
103: if (argc != 1) {
104: error("%s takes exactly one argument", p->symbol);
105: rvlist(argv);
106: return (NIL);
107: }
108: /*
109: * Evaluate the argmument
110: */
111: if (op == O_EOF || op == O_EOLN)
112: p1 = stklval((int *) argv[1], NLNIL , LREQ );
113: else
114: p1 = stkrval((int *) argv[1], NLNIL , RREQ );
115: if (p1 == NIL)
116: return (NIL);
117: switch (op) {
118: case O_EXP:
119: case O_SIN:
120: case O_COS:
121: case O_ATAN:
122: case O_LN:
123: case O_SQRT:
124: case O_RANDOM:
125: case O_EXPO:
126: case O_UNDEF:
127: if (isa(p1, "i"))
128: convert( nl+T4INT , nl+TDOUBLE);
129: else if (isnta(p1, "d")) {
130: error("%s's argument must be integer or real, not %s", p->symbol, nameof(p1));
131: return (NIL);
132: }
133: put(1, op);
134: if (op == O_UNDEF)
135: return (nl+TBOOL);
136: else if (op == O_EXPO)
137: return (nl+T4INT);
138: else
139: return (nl+TDOUBLE);
140: case O_SEED:
141: if (isnta(p1, "i")) {
142: error("seed's argument must be an integer, not %s", nameof(p1));
143: return (NIL);
144: }
145: put(1, op);
146: return (nl+T4INT);
147: case O_ROUND:
148: case O_TRUNC:
149: if (isnta(p1, "d")) {
150: error("%s's argument must be a real, not %s", p->symbol, nameof(p1));
151: return (NIL);
152: }
153: put(1, op);
154: return (nl+T4INT);
155: case O_ABS2:
156: case O_SQR2:
157: if (isa(p1, "d")) {
158: put(1, op + O_ABS8-O_ABS2);
159: return (nl+TDOUBLE);
160: }
161: if (isa(p1, "i")) {
162: put(1, op + (width(p1) >> 2));
163: return (nl+T4INT);
164: }
165: error("%s's argument must be an integer or real, not %s", p->symbol, nameof(p1));
166: return (NIL);
167: case O_ORD2:
168: if (isa(p1, "bcis") || classify(p1) == TPTR) {
169: return (nl+T4INT);
170: }
171: error("ord's argument must be of scalar type or a pointer, not %s", nameof(p1));
172: return (NIL);
173: case O_SUCC2:
174: case O_PRED2:
175: if (isa(p1, "d")) {
176: error("%s is forbidden for reals", p->symbol);
177: return (NIL);
178: }
179: if ( isnta( p1 , "bcsi" ) ) {
180: error("%s's argument must be of scalar type, not %s", p->symbol, nameof(p1));
181: return NIL;
182: }
183: tempnlp = p1 -> class == TYPE ? p1 -> type : p1;
184: if (isa(p1, "i")) {
185: if (width(p1) <= 2) {
186: op += O_PRED24 - O_PRED2;
187: put(3, op, (int)tempnlp->range[0],
188: (int)tempnlp->range[1]);
189: } else {
190: op++;
191: put(3, op, tempnlp->range[0],
192: tempnlp->range[1]);
193: }
194: return nl + T4INT;
195: } else {
196: put(3, op, (int)tempnlp->range[0],
197: (int)tempnlp->range[1]);
198: return p1;
199: }
200: case O_ODD2:
201: if (isnta(p1, "i")) {
202: error("odd's argument must be an integer, not %s", nameof(p1));
203: return (NIL);
204: }
205: put(1, op + (width(p1) >> 2));
206: return (nl+TBOOL);
207: case O_CHR2:
208: if (isnta(p1, "i")) {
209: error("chr's argument must be an integer, not %s", nameof(p1));
210: return (NIL);
211: }
212: put(1, op + (width(p1) >> 2));
213: return (nl+TCHAR);
214: case O_CARD:
215: if (isnta(p1, "t")) {
216: error("Argument to card must be a set, not %s", nameof(p1));
217: return (NIL);
218: }
219: put(2, O_CARD, width(p1));
220: return (nl+T2INT);
221: case O_EOLN:
222: if (!text(p1)) {
223: error("Argument to eoln must be a text file, not %s", nameof(p1));
224: return (NIL);
225: }
226: put(1, op);
227: return (nl+TBOOL);
228: case O_EOF:
229: if (p1->class != FILET) {
230: error("Argument to eof must be file, not %s", nameof(p1));
231: return (NIL);
232: }
233: put(1, op);
234: return (nl+TBOOL);
235: case 0:
236: error("%s is an unimplemented 6000-3.4 extension", p->symbol);
237: default:
238: panic("func1");
239: }
240: }
241: #endif OBJ
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.