Commit | Line | Data |
---|---|---|
3964952e PK |
1 | /* Copyright (c) 1979 Regents of the University of California */ |
2 | ||
c4e911b6 | 3 | static char sccsid[] = "@(#)pcfunc.c 1.2 %G%"; |
3964952e PK |
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 | bool cardempty = FALSE; | |
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 | long tempoff; | |
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 | } | |
c4e911b6 | 48 | if (p->class != FUNC && p->class != FFUNC) { |
3964952e PK |
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 = "_exp"; | |
151 | goto mathfunc; | |
152 | case O_SIN: | |
153 | funcname = "_sin"; | |
154 | goto mathfunc; | |
155 | case O_COS: | |
156 | funcname = "_cos"; | |
157 | goto mathfunc; | |
158 | case O_ATAN: | |
159 | funcname = "_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 | if ( isa( p1 , "i" ) ) { | |
179 | putop( P2SCONV , P2DOUBLE ); | |
180 | } | |
181 | putop( P2CALL , P2DOUBLE ); | |
182 | return nl + TDOUBLE; | |
183 | case O_EXPO: | |
184 | if (isnta( p1 , "id" ) ) { | |
185 | error("%s's argument must be integer or real, not %s", p->symbol, nameof(p1)); | |
186 | return NIL; | |
187 | } | |
188 | putleaf( P2ICON , 0 , 0 | |
189 | , ADDTYPE( P2FTN | P2INT , P2PTR ) , "_EXPO" ); | |
190 | p1 = stkrval( (int *) argv[1] , NLNIL , RREQ ); | |
191 | if ( isa( p1 , "i" ) ) { | |
192 | putop( P2SCONV , P2DOUBLE ); | |
193 | } | |
194 | putop( P2CALL , P2INT ); | |
195 | return ( nl + T4INT ); | |
196 | case O_UNDEF: | |
197 | if ( isnta( p1 , "id" ) ) { | |
198 | error("%s's argument must be integer or real, not %s", p->symbol, nameof(p1)); | |
199 | return NIL; | |
200 | } | |
201 | p1 = stkrval( (int *) argv[1] , NLNIL , RREQ ); | |
202 | putleaf( P2ICON , 0 , 0 , P2INT , 0 ); | |
203 | putop( P2COMOP , P2INT ); | |
204 | return ( nl + TBOOL ); | |
205 | case O_SEED: | |
206 | if (isnta(p1, "i")) { | |
207 | error("seed's argument must be an integer, not %s", nameof(p1)); | |
208 | return (NIL); | |
209 | } | |
210 | putleaf( P2ICON , 0 , 0 | |
211 | , ADDTYPE( P2FTN | P2INT , P2PTR ) , "_SEED" ); | |
212 | p1 = stkrval( (int *) argv[1] , NLNIL , RREQ ); | |
213 | putop( P2CALL , P2INT ); | |
214 | return nl + T4INT; | |
215 | case O_ROUND: | |
216 | case O_TRUNC: | |
217 | if ( isnta( p1 , "d" ) ) { | |
218 | error("%s's argument must be a real, not %s", p->symbol, nameof(p1)); | |
219 | return (NIL); | |
220 | } | |
221 | putleaf( P2ICON , 0 , 0 | |
222 | , ADDTYPE( P2FTN | P2INT , P2PTR ) | |
223 | , op == O_ROUND ? "_ROUND" : "_TRUNC" ); | |
224 | p1 = stkrval( (int *) argv[1] , NLNIL , RREQ ); | |
225 | putop( P2CALL , P2INT ); | |
226 | return nl + T4INT; | |
227 | case O_ABS2: | |
228 | if ( isa( p1 , "d" ) ) { | |
229 | putleaf( P2ICON , 0 , 0 | |
230 | , ADDTYPE( P2FTN | P2DOUBLE , P2PTR ) | |
231 | , "_fabs" ); | |
232 | p1 = stkrval( (int *) argv[1] , NLNIL , RREQ ); | |
233 | putop( P2CALL , P2DOUBLE ); | |
234 | return nl + TDOUBLE; | |
235 | } | |
236 | if ( isa( p1 , "i" ) ) { | |
237 | putleaf( P2ICON , 0 , 0 | |
238 | , ADDTYPE( P2FTN | P2INT , P2PTR ) , "_abs" ); | |
239 | p1 = stkrval( (int *) argv[1] , NLNIL , RREQ ); | |
240 | putop( P2CALL , P2INT ); | |
241 | return nl + T4INT; | |
242 | } | |
243 | error("%s's argument must be an integer or real, not %s", p->symbol, nameof(p1)); | |
244 | return NIL; | |
245 | case O_SQR2: | |
246 | if ( isa( p1 , "d" ) ) { | |
247 | temptype = P2DOUBLE; | |
248 | rettype = nl + TDOUBLE; | |
249 | sizes[ cbn ].om_off -= sizeof( double ); | |
250 | } else if ( isa( p1 , "i" ) ) { | |
251 | temptype = P2INT; | |
252 | rettype = nl + T4INT; | |
253 | sizes[ cbn ].om_off -= sizeof( long ); | |
254 | } else { | |
255 | error("%s's argument must be an integer or real, not %s", p->symbol, nameof(p1)); | |
256 | return NIL; | |
257 | } | |
258 | tempoff = sizes[ cbn ].om_off; | |
259 | if ( tempoff < sizes[ cbn ].om_max ) { | |
260 | sizes[ cbn ].om_max = tempoff; | |
261 | } | |
262 | putlbracket( ftnno , -tempoff ); | |
263 | putRV( 0 , cbn , tempoff , temptype , 0 ); | |
264 | p1 = rvalue( (int *) argv[1] , NLNIL , RREQ ); | |
265 | putop( P2ASSIGN , temptype ); | |
266 | putRV( 0 , cbn , tempoff , temptype , 0 ); | |
267 | putRV( 0 , cbn , tempoff , temptype , 0 ); | |
268 | putop( P2MUL , temptype ); | |
269 | putop( P2COMOP , temptype ); | |
270 | return rettype; | |
271 | case O_ORD2: | |
272 | p1 = stkrval( (int *) argv[1] , NLNIL , RREQ ); | |
273 | if (isa(p1, "bcis") || classify(p1) == TPTR) { | |
274 | return (nl+T4INT); | |
275 | } | |
276 | error("ord's argument must be of scalar type or a pointer, not %s", nameof(p1)); | |
277 | return (NIL); | |
278 | case O_SUCC2: | |
279 | case O_PRED2: | |
280 | if (isa(p1, "d")) { | |
281 | error("%s is forbidden for reals", p->symbol); | |
282 | return (NIL); | |
283 | } | |
284 | if ( isnta( p1 , "bcsi" ) ) { | |
285 | error("%s's argument must be of scalar type, not %s", p->symbol, nameof(p1)); | |
286 | return NIL; | |
287 | } | |
288 | if ( opt( 't' ) ) { | |
289 | putleaf( P2ICON , 0 , 0 | |
290 | , ADDTYPE( P2FTN | P2INT , P2PTR ) | |
291 | , op == O_SUCC2 ? "_SUCC" : "_PRED" ); | |
292 | p1 = stkrval( (int *) argv[1] , NLNIL , RREQ ); | |
293 | putleaf( P2ICON , p1 -> range[0] , 0 , P2INT , 0 ); | |
294 | putop( P2LISTOP , P2INT ); | |
295 | putleaf( P2ICON , p1 -> range[1] , 0 , P2INT , 0 ); | |
296 | putop( P2LISTOP , P2INT ); | |
297 | putop( P2CALL , P2INT ); | |
298 | } else { | |
299 | p1 = rvalue( argv[1] , NIL , RREQ ); | |
300 | putleaf( P2ICON , 1 , 0 , P2INT , 0 ); | |
301 | putop( op == O_SUCC2 ? P2PLUS : P2MINUS , P2INT ); | |
302 | } | |
303 | if ( isa( p1 , "bcs" ) ) { | |
304 | return p1; | |
305 | } else { | |
306 | return nl + T4INT; | |
307 | } | |
308 | case O_ODD2: | |
309 | if (isnta(p1, "i")) { | |
310 | error("odd's argument must be an integer, not %s", nameof(p1)); | |
311 | return (NIL); | |
312 | } | |
313 | p1 = rvalue( (int *) argv[1] , NLNIL , RREQ ); | |
314 | putleaf( P2ICON , 1 , 0 , P2INT , 0 ); | |
315 | putop( P2AND , P2INT ); | |
316 | return nl + TBOOL; | |
317 | case O_CHR2: | |
318 | if (isnta(p1, "i")) { | |
319 | error("chr's argument must be an integer, not %s", nameof(p1)); | |
320 | return (NIL); | |
321 | } | |
322 | if (opt('t')) { | |
323 | putleaf( P2ICON , 0 , 0 | |
324 | , ADDTYPE( P2FTN | P2CHAR , P2PTR ) , "_CHR" ); | |
325 | p1 = stkrval( (int *) argv[1] , NLNIL , RREQ ); | |
326 | putop( P2CALL , P2CHAR ); | |
327 | } else { | |
328 | p1 = stkrval( (int *) argv[1] , NLNIL , RREQ ); | |
329 | } | |
330 | return nl + TCHAR; | |
331 | case O_CARD: | |
332 | if ( p1 != nl + TSET ) { | |
333 | if (isnta(p1, "t")) { | |
334 | error("Argument to card must be a set, not %s", nameof(p1)); | |
335 | return (NIL); | |
336 | } | |
337 | putleaf( P2ICON , 0 , 0 | |
338 | , ADDTYPE( P2FTN | P2INT , P2PTR ) , "_CARD" ); | |
339 | p1 = stkrval( (int *) argv[1] , NLNIL , LREQ ); | |
340 | putleaf( P2ICON , lwidth( p1 ) , 0 , P2INT , 0 ); | |
341 | putop( P2LISTOP , P2INT ); | |
342 | putop( P2CALL , P2INT ); | |
343 | } else { | |
344 | if ( !cardempty ) { | |
345 | warning(); | |
346 | error("Cardinality of the empty set is 0." ); | |
347 | cardempty = TRUE; | |
348 | } | |
349 | putleaf( P2ICON , 0 , 0 , P2INT , 0 ); | |
350 | } | |
351 | return nl + T2INT; | |
352 | case O_EOLN: | |
353 | if (!text(p1)) { | |
354 | error("Argument to eoln must be a text file, not %s", nameof(p1)); | |
355 | return (NIL); | |
356 | } | |
357 | putleaf( P2ICON , 0 , 0 | |
358 | , ADDTYPE( P2FTN | P2INT , P2PTR ) , "_TEOLN" ); | |
359 | p1 = stklval( (int *) argv[1] , NOFLAGS ); | |
360 | putop( P2CALL , P2INT ); | |
361 | return nl + TBOOL; | |
362 | case O_EOF: | |
363 | if (p1->class != FILET) { | |
364 | error("Argument to eof must be file, not %s", nameof(p1)); | |
365 | return (NIL); | |
366 | } | |
367 | putleaf( P2ICON , 0 , 0 | |
368 | , ADDTYPE( P2FTN | P2INT , P2PTR ) , "_TEOF" ); | |
369 | p1 = stklval( (int *) argv[1] , NOFLAGS ); | |
370 | putop( P2CALL , P2INT ); | |
371 | return nl + TBOOL; | |
372 | case 0: | |
373 | error("%s is an unimplemented 6000-3.4 extension", p->symbol); | |
374 | default: | |
375 | panic("func1"); | |
376 | } | |
377 | } | |
378 | #endif PC |