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