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