Commit | Line | Data |
---|---|---|
6e015276 BJ |
1 | #include "defs" |
2 | ||
3 | extern ftnint intcon[14]; | |
4 | extern double realcon[6]; | |
5 | ||
6 | union | |
7 | { | |
8 | int ijunk; | |
9 | struct Intrpacked bits; | |
10 | } packed; | |
11 | ||
12 | struct Intrbits | |
13 | { | |
14 | int intrgroup /* :3 */; | |
15 | int intrstuff /* result type or number of generics */; | |
16 | int intrno /* :7 */; | |
17 | }; | |
18 | ||
19 | LOCAL struct Intrblock | |
20 | { | |
21 | char intrfname[VL]; | |
22 | struct Intrbits intrval; | |
23 | } intrtab[ ] = | |
24 | { | |
25 | "int", { INTRCONV, TYLONG }, | |
26 | "real", { INTRCONV, TYREAL }, | |
27 | "dble", { INTRCONV, TYDREAL }, | |
28 | "cmplx", { INTRCONV, TYCOMPLEX }, | |
29 | "dcmplx", { INTRCONV, TYDCOMPLEX }, | |
30 | "ifix", { INTRCONV, TYLONG }, | |
31 | "idint", { INTRCONV, TYLONG }, | |
32 | "float", { INTRCONV, TYREAL }, | |
33 | "dfloat", { INTRCONV, TYDREAL }, | |
34 | "sngl", { INTRCONV, TYREAL }, | |
35 | "ichar", { INTRCONV, TYLONG }, | |
36 | "iachar", { INTRCONV, TYLONG }, | |
37 | "char", { INTRCONV, TYCHAR }, | |
38 | "achar", { INTRCONV, TYCHAR }, | |
39 | ||
40 | "max", { INTRMAX, TYUNKNOWN }, | |
41 | "max0", { INTRMAX, TYLONG }, | |
42 | "amax0", { INTRMAX, TYREAL }, | |
43 | "max1", { INTRMAX, TYLONG }, | |
44 | "amax1", { INTRMAX, TYREAL }, | |
45 | "dmax1", { INTRMAX, TYDREAL }, | |
46 | ||
47 | "and", { INTRBOOL, TYUNKNOWN, OPBITAND }, | |
48 | "or", { INTRBOOL, TYUNKNOWN, OPBITOR }, | |
49 | "xor", { INTRBOOL, TYUNKNOWN, OPBITXOR }, | |
50 | "not", { INTRBOOL, TYUNKNOWN, OPBITNOT }, | |
51 | "lshift", { INTRBOOL, TYUNKNOWN, OPLSHIFT }, | |
52 | "rshift", { INTRBOOL, TYUNKNOWN, OPRSHIFT }, | |
53 | ||
54 | "min", { INTRMIN, TYUNKNOWN }, | |
55 | "min0", { INTRMIN, TYLONG }, | |
56 | "amin0", { INTRMIN, TYREAL }, | |
57 | "min1", { INTRMIN, TYLONG }, | |
58 | "amin1", { INTRMIN, TYREAL }, | |
59 | "dmin1", { INTRMIN, TYDREAL }, | |
60 | ||
61 | "aint", { INTRGEN, 2, 0 }, | |
62 | "dint", { INTRSPEC, TYDREAL, 1 }, | |
63 | ||
64 | "anint", { INTRGEN, 2, 2 }, | |
65 | "dnint", { INTRSPEC, TYDREAL, 3 }, | |
66 | ||
67 | "nint", { INTRGEN, 4, 4 }, | |
68 | "idnint", { INTRGEN, 2, 6 }, | |
69 | ||
70 | "abs", { INTRGEN, 6, 8 }, | |
71 | "iabs", { INTRGEN, 2, 9 }, | |
72 | "dabs", { INTRSPEC, TYDREAL, 11 }, | |
73 | "cabs", { INTRSPEC, TYREAL, 12 }, | |
74 | "zabs", { INTRSPEC, TYDREAL, 13 }, | |
75 | ||
76 | "mod", { INTRGEN, 4, 14 }, | |
77 | "amod", { INTRSPEC, TYREAL, 16 }, | |
78 | "dmod", { INTRSPEC, TYDREAL, 17 }, | |
79 | ||
80 | "sign", { INTRGEN, 4, 18 }, | |
81 | "isign", { INTRGEN, 2, 19 }, | |
82 | "dsign", { INTRSPEC, TYDREAL, 21 }, | |
83 | ||
84 | "dim", { INTRGEN, 4, 22 }, | |
85 | "idim", { INTRGEN, 2, 23 }, | |
86 | "ddim", { INTRSPEC, TYDREAL, 25 }, | |
87 | ||
88 | "dprod", { INTRSPEC, TYDREAL, 26 }, | |
89 | ||
90 | "len", { INTRSPEC, TYLONG, 27 }, | |
91 | "index", { INTRSPEC, TYLONG, 29 }, | |
92 | ||
93 | "imag", { INTRGEN, 2, 31 }, | |
94 | "aimag", { INTRSPEC, TYREAL, 31 }, | |
95 | "dimag", { INTRSPEC, TYDREAL, 32 }, | |
96 | ||
97 | "conjg", { INTRGEN, 2, 33 }, | |
98 | "dconjg", { INTRSPEC, TYDCOMPLEX, 34 }, | |
99 | ||
100 | "sqrt", { INTRGEN, 4, 35 }, | |
101 | "dsqrt", { INTRSPEC, TYDREAL, 36 }, | |
102 | "csqrt", { INTRSPEC, TYCOMPLEX, 37 }, | |
103 | "zsqrt", { INTRSPEC, TYDCOMPLEX, 38 }, | |
104 | ||
105 | "exp", { INTRGEN, 4, 39 }, | |
106 | "dexp", { INTRSPEC, TYDREAL, 40 }, | |
107 | "cexp", { INTRSPEC, TYCOMPLEX, 41 }, | |
108 | "zexp", { INTRSPEC, TYDCOMPLEX, 42 }, | |
109 | ||
110 | "log", { INTRGEN, 4, 43 }, | |
111 | "alog", { INTRSPEC, TYREAL, 43 }, | |
112 | "dlog", { INTRSPEC, TYDREAL, 44 }, | |
113 | "clog", { INTRSPEC, TYCOMPLEX, 45 }, | |
114 | "zlog", { INTRSPEC, TYDCOMPLEX, 46 }, | |
115 | ||
116 | "log10", { INTRGEN, 2, 47 }, | |
117 | "alog10", { INTRSPEC, TYREAL, 47 }, | |
118 | "dlog10", { INTRSPEC, TYDREAL, 48 }, | |
119 | ||
120 | "sin", { INTRGEN, 4, 49 }, | |
121 | "dsin", { INTRSPEC, TYDREAL, 50 }, | |
122 | "csin", { INTRSPEC, TYCOMPLEX, 51 }, | |
123 | "zsin", { INTRSPEC, TYDCOMPLEX, 52 }, | |
124 | ||
125 | "cos", { INTRGEN, 4, 53 }, | |
126 | "dcos", { INTRSPEC, TYDREAL, 54 }, | |
127 | "ccos", { INTRSPEC, TYCOMPLEX, 55 }, | |
128 | "zcos", { INTRSPEC, TYDCOMPLEX, 56 }, | |
129 | ||
130 | "tan", { INTRGEN, 2, 57 }, | |
131 | "dtan", { INTRSPEC, TYDREAL, 58 }, | |
132 | ||
133 | "asin", { INTRGEN, 2, 59 }, | |
134 | "dasin", { INTRSPEC, TYDREAL, 60 }, | |
135 | ||
136 | "acos", { INTRGEN, 2, 61 }, | |
137 | "dacos", { INTRSPEC, TYDREAL, 62 }, | |
138 | ||
139 | "atan", { INTRGEN, 2, 63 }, | |
140 | "datan", { INTRSPEC, TYDREAL, 64 }, | |
141 | ||
142 | "atan2", { INTRGEN, 2, 65 }, | |
143 | "datan2", { INTRSPEC, TYDREAL, 66 }, | |
144 | ||
145 | "sinh", { INTRGEN, 2, 67 }, | |
146 | "dsinh", { INTRSPEC, TYDREAL, 68 }, | |
147 | ||
148 | "cosh", { INTRGEN, 2, 69 }, | |
149 | "dcosh", { INTRSPEC, TYDREAL, 70 }, | |
150 | ||
151 | "tanh", { INTRGEN, 2, 71 }, | |
152 | "dtanh", { INTRSPEC, TYDREAL, 72 }, | |
153 | ||
154 | "lge", { INTRSPEC, TYLOGICAL, 73}, | |
155 | "lgt", { INTRSPEC, TYLOGICAL, 75}, | |
156 | "lle", { INTRSPEC, TYLOGICAL, 77}, | |
157 | "llt", { INTRSPEC, TYLOGICAL, 79}, | |
158 | ||
159 | "epbase", { INTRCNST, 4, 0 }, | |
160 | "epprec", { INTRCNST, 4, 4 }, | |
161 | "epemin", { INTRCNST, 2, 8 }, | |
162 | "epemax", { INTRCNST, 2, 10 }, | |
163 | "eptiny", { INTRCNST, 2, 12 }, | |
164 | "ephuge", { INTRCNST, 4, 14 }, | |
165 | "epmrsp", { INTRCNST, 2, 18 }, | |
166 | ||
167 | "fpexpn", { INTRGEN, 4, 81 }, | |
168 | "fpabsp", { INTRGEN, 2, 85 }, | |
169 | "fprrsp", { INTRGEN, 2, 87 }, | |
170 | "fpfrac", { INTRGEN, 2, 89 }, | |
171 | "fpmake", { INTRGEN, 2, 91 }, | |
172 | "fpscal", { INTRGEN, 2, 93 }, | |
173 | ||
174 | "" }; | |
175 | \f | |
176 | ||
177 | LOCAL struct Specblock | |
178 | { | |
179 | char atype; | |
180 | char rtype; | |
181 | char nargs; | |
182 | char spxname[XL]; | |
183 | char othername; /* index into callbyvalue table */ | |
184 | } spectab[ ] = | |
185 | { | |
186 | { TYREAL,TYREAL,1,"r_int" }, | |
187 | { TYDREAL,TYDREAL,1,"d_int" }, | |
188 | ||
189 | { TYREAL,TYREAL,1,"r_nint" }, | |
190 | { TYDREAL,TYDREAL,1,"d_nint" }, | |
191 | ||
192 | { TYREAL,TYSHORT,1,"h_nint" }, | |
193 | { TYREAL,TYLONG,1,"i_nint" }, | |
194 | ||
195 | { TYDREAL,TYSHORT,1,"h_dnnt" }, | |
196 | { TYDREAL,TYLONG,1,"i_dnnt" }, | |
197 | ||
198 | { TYREAL,TYREAL,1,"r_abs" }, | |
199 | { TYSHORT,TYSHORT,1,"h_abs" }, | |
200 | { TYLONG,TYLONG,1,"i_abs" }, | |
201 | { TYDREAL,TYDREAL,1,"d_abs" }, | |
202 | { TYCOMPLEX,TYREAL,1,"c_abs" }, | |
203 | { TYDCOMPLEX,TYDREAL,1,"z_abs" }, | |
204 | ||
205 | { TYSHORT,TYSHORT,2,"h_mod" }, | |
206 | { TYLONG,TYLONG,2,"i_mod" }, | |
207 | { TYREAL,TYREAL,2,"r_mod" }, | |
208 | { TYDREAL,TYDREAL,2,"d_mod" }, | |
209 | ||
210 | { TYREAL,TYREAL,2,"r_sign" }, | |
211 | { TYSHORT,TYSHORT,2,"h_sign" }, | |
212 | { TYLONG,TYLONG,2,"i_sign" }, | |
213 | { TYDREAL,TYDREAL,2,"d_sign" }, | |
214 | ||
215 | { TYREAL,TYREAL,2,"r_dim" }, | |
216 | { TYSHORT,TYSHORT,2,"h_dim" }, | |
217 | { TYLONG,TYLONG,2,"i_dim" }, | |
218 | { TYDREAL,TYDREAL,2,"d_dim" }, | |
219 | ||
220 | { TYREAL,TYDREAL,2,"d_prod" }, | |
221 | ||
222 | { TYCHAR,TYSHORT,1,"h_len" }, | |
223 | { TYCHAR,TYLONG,1,"i_len" }, | |
224 | ||
225 | { TYCHAR,TYSHORT,2,"h_indx" }, | |
226 | { TYCHAR,TYLONG,2,"i_indx" }, | |
227 | ||
228 | { TYCOMPLEX,TYREAL,1,"r_imag" }, | |
229 | { TYDCOMPLEX,TYDREAL,1,"d_imag" }, | |
230 | { TYCOMPLEX,TYCOMPLEX,1,"r_cnjg" }, | |
231 | { TYDCOMPLEX,TYDCOMPLEX,1,"d_cnjg" }, | |
232 | ||
233 | { TYREAL,TYREAL,1,"r_sqrt", 1 }, | |
234 | { TYDREAL,TYDREAL,1,"d_sqrt", 1 }, | |
235 | { TYCOMPLEX,TYCOMPLEX,1,"c_sqrt" }, | |
236 | { TYDCOMPLEX,TYDCOMPLEX,1,"z_sqrt" }, | |
237 | ||
238 | { TYREAL,TYREAL,1,"r_exp", 2 }, | |
239 | { TYDREAL,TYDREAL,1,"d_exp", 2 }, | |
240 | { TYCOMPLEX,TYCOMPLEX,1,"c_exp" }, | |
241 | { TYDCOMPLEX,TYDCOMPLEX,1,"z_exp" }, | |
242 | ||
243 | { TYREAL,TYREAL,1,"r_log", 3 }, | |
244 | { TYDREAL,TYDREAL,1,"d_log", 3 }, | |
245 | { TYCOMPLEX,TYCOMPLEX,1,"c_log" }, | |
246 | { TYDCOMPLEX,TYDCOMPLEX,1,"z_log" }, | |
247 | ||
248 | { TYREAL,TYREAL,1,"r_lg10" }, | |
249 | { TYDREAL,TYDREAL,1,"d_lg10" }, | |
250 | ||
251 | { TYREAL,TYREAL,1,"r_sin", 4 }, | |
252 | { TYDREAL,TYDREAL,1,"d_sin", 4 }, | |
253 | { TYCOMPLEX,TYCOMPLEX,1,"c_sin" }, | |
254 | { TYDCOMPLEX,TYDCOMPLEX,1,"z_sin" }, | |
255 | ||
256 | { TYREAL,TYREAL,1,"r_cos", 5 }, | |
257 | { TYDREAL,TYDREAL,1,"d_cos", 5 }, | |
258 | { TYCOMPLEX,TYCOMPLEX,1,"c_cos" }, | |
259 | { TYDCOMPLEX,TYDCOMPLEX,1,"z_cos" }, | |
260 | ||
261 | { TYREAL,TYREAL,1,"r_tan", 6 }, | |
262 | { TYDREAL,TYDREAL,1,"d_tan", 6 }, | |
263 | ||
264 | { TYREAL,TYREAL,1,"r_asin", 7 }, | |
265 | { TYDREAL,TYDREAL,1,"d_asin", 7 }, | |
266 | ||
267 | { TYREAL,TYREAL,1,"r_acos", 8 }, | |
268 | { TYDREAL,TYDREAL,1,"d_acos", 8 }, | |
269 | ||
270 | { TYREAL,TYREAL,1,"r_atan", 9 }, | |
271 | { TYDREAL,TYDREAL,1,"d_atan", 9 }, | |
272 | ||
273 | { TYREAL,TYREAL,2,"r_atn2", 10 }, | |
274 | { TYDREAL,TYDREAL,2,"d_atn2", 10 }, | |
275 | ||
276 | { TYREAL,TYREAL,1,"r_sinh", 11 }, | |
277 | { TYDREAL,TYDREAL,1,"d_sinh", 11 }, | |
278 | ||
279 | { TYREAL,TYREAL,1,"r_cosh", 12 }, | |
280 | { TYDREAL,TYDREAL,1,"d_cosh", 12 }, | |
281 | ||
282 | { TYREAL,TYREAL,1,"r_tanh", 13 }, | |
283 | { TYDREAL,TYDREAL,1,"d_tanh", 13 }, | |
284 | ||
285 | { TYCHAR,TYLOGICAL,2,"hl_ge" }, | |
286 | { TYCHAR,TYLOGICAL,2,"l_ge" }, | |
287 | ||
288 | { TYCHAR,TYLOGICAL,2,"hl_gt" }, | |
289 | { TYCHAR,TYLOGICAL,2,"l_gt" }, | |
290 | ||
291 | { TYCHAR,TYLOGICAL,2,"hl_le" }, | |
292 | { TYCHAR,TYLOGICAL,2,"l_le" }, | |
293 | ||
294 | { TYCHAR,TYLOGICAL,2,"hl_lt" }, | |
295 | { TYCHAR,TYLOGICAL,2,"l_lt" }, | |
296 | ||
297 | { TYREAL,TYSHORT,1,"hr_expn" }, | |
298 | { TYREAL,TYLONG,1,"ir_expn" }, | |
299 | { TYDREAL,TYSHORT,1,"hd_expn" }, | |
300 | { TYDREAL,TYLONG,1,"id_expn" }, | |
301 | ||
302 | { TYREAL,TYREAL,1,"r_absp" }, | |
303 | { TYDREAL,TYDREAL,1,"d_absp" }, | |
304 | ||
305 | { TYREAL,TYDREAL,1,"r_rrsp" }, | |
306 | { TYDREAL,TYDREAL,1,"d_rrsp" }, | |
307 | ||
308 | { TYREAL,TYREAL,1,"r_frac" }, | |
309 | { TYDREAL,TYDREAL,1,"d_frac" }, | |
310 | ||
311 | { TYREAL,TYREAL,2,"r_make" }, | |
312 | { TYDREAL,TYDREAL,2,"d_make" }, | |
313 | ||
314 | { TYREAL,TYREAL,2,"r_scal" }, | |
315 | { TYDREAL,TYDREAL,2,"d_scal" } | |
316 | } ; | |
317 | \f | |
318 | LOCAL struct Incstblock | |
319 | { | |
320 | char atype; | |
321 | char rtype; | |
322 | char constno; | |
323 | } consttab[ ] = | |
324 | { | |
325 | { TYSHORT, TYLONG, 0 }, | |
326 | { TYLONG, TYLONG, 1 }, | |
327 | { TYREAL, TYLONG, 2 }, | |
328 | { TYDREAL, TYLONG, 3 }, | |
329 | ||
330 | { TYSHORT, TYLONG, 4 }, | |
331 | { TYLONG, TYLONG, 5 }, | |
332 | { TYREAL, TYLONG, 6 }, | |
333 | { TYDREAL, TYLONG, 7 }, | |
334 | ||
335 | { TYREAL, TYLONG, 8 }, | |
336 | { TYDREAL, TYLONG, 9 }, | |
337 | ||
338 | { TYREAL, TYLONG, 10 }, | |
339 | { TYDREAL, TYLONG, 11 }, | |
340 | ||
341 | { TYREAL, TYREAL, 0 }, | |
342 | { TYDREAL, TYDREAL, 1 }, | |
343 | ||
344 | { TYSHORT, TYLONG, 12 }, | |
345 | { TYLONG, TYLONG, 13 }, | |
346 | { TYREAL, TYREAL, 2 }, | |
347 | { TYDREAL, TYDREAL, 3 }, | |
348 | ||
349 | { TYREAL, TYREAL, 4 }, | |
350 | { TYDREAL, TYDREAL, 5 } | |
351 | }; | |
352 | ||
353 | /* For each machine, two arrays must be initialized. | |
354 | intcon contains | |
355 | radix for short int | |
356 | radix for long int | |
357 | radix for single precision | |
358 | radix for double precision | |
359 | precision for short int | |
360 | precision for long int | |
361 | precision for single precision | |
362 | precision for double precision | |
363 | emin for single precision | |
364 | emin for double precision | |
365 | emax for single precision | |
366 | emax for double prcision | |
367 | largest short int | |
368 | largest long int | |
369 | ||
370 | realcon contains | |
371 | tiny for single precision | |
372 | tiny for double precision | |
373 | huge for single precision | |
374 | huge for double precision | |
375 | mrsp (epsilon) for single precision | |
376 | mrsp (epsilon) for double precision | |
377 | ||
378 | the realcons should probably be filled in in binary if TARGET==HERE | |
379 | */ | |
380 | \f | |
381 | char callbyvalue[ ][XL] = | |
382 | { | |
383 | "sqrt", | |
384 | "exp", | |
385 | "log", | |
386 | "sin", | |
387 | "cos", | |
388 | "tan", | |
389 | "asin", | |
390 | "acos", | |
391 | "atan", | |
392 | "atan2", | |
393 | "sinh", | |
394 | "cosh", | |
395 | "tanh" | |
396 | }; | |
397 | \f | |
398 | expptr intrcall(np, argsp, nargs) | |
399 | Namep np; | |
400 | struct Listblock *argsp; | |
401 | int nargs; | |
402 | { | |
403 | int i, rettype; | |
404 | Addrp ap; | |
405 | register struct Specblock *sp; | |
406 | register struct Chain *cp; | |
407 | expptr inline(), mkcxcon(), mkrealcon(); | |
408 | register struct Incstblock *cstp; | |
409 | expptr q, ep; | |
410 | int mtype; | |
411 | int op; | |
412 | int f1field, f2field, f3field; | |
413 | ||
414 | packed.ijunk = np->vardesc.varno; | |
415 | f1field = packed.bits.f1; | |
416 | f2field = packed.bits.f2; | |
417 | f3field = packed.bits.f3; | |
418 | if(nargs == 0) | |
419 | goto badnargs; | |
420 | ||
421 | mtype = 0; | |
422 | for(cp = argsp->listp ; cp ; cp = cp->nextp) | |
423 | { | |
424 | /* TEMPORARY */ ep = (expptr) (cp->datap); | |
425 | /* TEMPORARY */ if( ISCONST(ep) && ep->headblock.vtype==TYSHORT ) | |
426 | /* TEMPORARY */ cp->datap = (tagptr) mkconv(tyint, ep); | |
427 | mtype = maxtype(mtype, ep->headblock.vtype); | |
428 | } | |
429 | ||
430 | switch(f1field) | |
431 | { | |
432 | case INTRBOOL: | |
433 | op = f3field; | |
434 | if( ! ONEOF(mtype, MSKINT|MSKLOGICAL) ) | |
435 | goto badtype; | |
436 | if(op == OPBITNOT) | |
437 | { | |
438 | if(nargs != 1) | |
439 | goto badnargs; | |
440 | q = mkexpr(OPBITNOT, argsp->listp->datap, ENULL); | |
441 | } | |
442 | else | |
443 | { | |
444 | if(nargs != 2) | |
445 | goto badnargs; | |
446 | q = mkexpr(op, argsp->listp->datap, | |
447 | argsp->listp->nextp->datap); | |
448 | } | |
449 | frchain( &(argsp->listp) ); | |
450 | free( (charptr) argsp); | |
451 | return(q); | |
452 | ||
453 | case INTRCONV: | |
454 | rettype = f2field; | |
455 | if(rettype == TYLONG) | |
456 | rettype = tyint; | |
457 | if( ISCOMPLEX(rettype) && nargs==2) | |
458 | { | |
459 | expptr qr, qi; | |
460 | qr = (expptr) (argsp->listp->datap); | |
461 | qi = (expptr) (argsp->listp->nextp->datap); | |
462 | if(ISCONST(qr) && ISCONST(qi)) | |
463 | q = mkcxcon(qr,qi); | |
464 | else q = mkexpr(OPCONV,mkconv(rettype-2,qr), | |
465 | mkconv(rettype-2,qi)); | |
466 | } | |
467 | else if(nargs == 1) | |
468 | q = mkconv(rettype, argsp->listp->datap); | |
469 | else goto badnargs; | |
470 | ||
471 | q->headblock.vtype = rettype; | |
472 | frchain(&(argsp->listp)); | |
473 | free( (charptr) argsp); | |
474 | return(q); | |
475 | ||
476 | ||
477 | case INTRCNST: | |
478 | cstp = consttab + f3field; | |
479 | for(i=0 ; i<f2field ; ++i) | |
480 | if(cstp->atype == mtype) | |
481 | goto foundconst; | |
482 | else | |
483 | ++cstp; | |
484 | goto badtype; | |
485 | ||
486 | foundconst: | |
487 | switch(cstp->rtype) | |
488 | { | |
489 | case TYLONG: | |
490 | return(mkintcon(intcon[cstp->constno])); | |
491 | ||
492 | case TYREAL: | |
493 | case TYDREAL: | |
494 | return(mkrealcon(cstp->rtype, | |
495 | realcon[cstp->constno]) ); | |
496 | ||
497 | default: | |
498 | fatal("impossible intrinsic constant"); | |
499 | } | |
500 | ||
501 | case INTRGEN: | |
502 | sp = spectab + f3field; | |
503 | if(no66flag) | |
504 | if(sp->atype == mtype) | |
505 | goto specfunct; | |
506 | else err66("generic function"); | |
507 | ||
508 | for(i=0; i<f2field ; ++i) | |
509 | if(sp->atype == mtype) | |
510 | goto specfunct; | |
511 | else | |
512 | ++sp; | |
513 | goto badtype; | |
514 | ||
515 | case INTRSPEC: | |
516 | sp = spectab + f3field; | |
517 | specfunct: | |
518 | if(tyint==TYLONG && ONEOF(sp->rtype,M(TYSHORT)|M(TYLOGICAL)) | |
519 | && (sp+1)->atype==sp->atype) | |
520 | ++sp; | |
521 | ||
522 | if(nargs != sp->nargs) | |
523 | goto badnargs; | |
524 | if(mtype != sp->atype) | |
525 | goto badtype; | |
526 | fixargs(YES, argsp); | |
527 | if(q = inline(sp-spectab, mtype, argsp->listp)) | |
528 | { | |
529 | frchain( &(argsp->listp) ); | |
530 | free( (charptr) argsp); | |
531 | } | |
532 | else if(sp->othername) | |
533 | { | |
534 | ap = builtin(sp->rtype, | |
535 | varstr(XL, callbyvalue[sp->othername-1]) ); | |
536 | q = fixexpr( mkexpr(OPCCALL, ap, argsp) ); | |
537 | } | |
538 | else | |
539 | { | |
540 | ap = builtin(sp->rtype, varstr(XL, sp->spxname) ); | |
541 | q = fixexpr( mkexpr(OPCALL, ap, argsp) ); | |
542 | } | |
543 | return(q); | |
544 | ||
545 | case INTRMIN: | |
546 | case INTRMAX: | |
547 | if(nargs < 2) | |
548 | goto badnargs; | |
549 | if( ! ONEOF(mtype, MSKINT|MSKREAL) ) | |
550 | goto badtype; | |
551 | argsp->vtype = mtype; | |
552 | q = mkexpr( (f1field==INTRMIN ? OPMIN : OPMAX), argsp, ENULL); | |
553 | ||
554 | q->headblock.vtype = mtype; | |
555 | rettype = f2field; | |
556 | if(rettype == TYLONG) | |
557 | rettype = tyint; | |
558 | else if(rettype == TYUNKNOWN) | |
559 | rettype = mtype; | |
560 | return( mkconv(rettype, q) ); | |
561 | ||
562 | default: | |
563 | fatali("intrcall: bad intrgroup %d", f1field); | |
564 | } | |
565 | badnargs: | |
566 | errstr("bad number of arguments to intrinsic %s", | |
567 | varstr(VL,np->varname) ); | |
568 | goto bad; | |
569 | ||
570 | badtype: | |
571 | errstr("bad argument type to intrinsic %s", varstr(VL, np->varname) ); | |
572 | ||
573 | bad: | |
574 | return( errnode() ); | |
575 | } | |
576 | ||
577 | ||
578 | ||
579 | ||
580 | intrfunct(s) | |
581 | char s[VL]; | |
582 | { | |
583 | register struct Intrblock *p; | |
584 | char nm[VL]; | |
585 | register int i; | |
586 | ||
587 | for(i = 0 ; i<VL ; ++s) | |
588 | nm[i++] = (*s==' ' ? '\0' : *s); | |
589 | ||
590 | for(p = intrtab; p->intrval.intrgroup!=INTREND ; ++p) | |
591 | { | |
592 | if( eqn(VL, nm, p->intrfname) ) | |
593 | { | |
594 | packed.bits.f1 = p->intrval.intrgroup; | |
595 | packed.bits.f2 = p->intrval.intrstuff; | |
596 | packed.bits.f3 = p->intrval.intrno; | |
597 | return(packed.ijunk); | |
598 | } | |
599 | } | |
600 | ||
601 | return(0); | |
602 | } | |
603 | ||
604 | ||
605 | ||
606 | ||
607 | ||
608 | Addrp intraddr(np) | |
609 | Namep np; | |
610 | { | |
611 | Addrp q; | |
612 | register struct Specblock *sp; | |
613 | int f3field; | |
614 | ||
615 | if(np->vclass!=CLPROC || np->vprocclass!=PINTRINSIC) | |
616 | fatalstr("intraddr: %s is not intrinsic", varstr(VL,np->varname)); | |
617 | packed.ijunk = np->vardesc.varno; | |
618 | f3field = packed.bits.f3; | |
619 | ||
620 | switch(packed.bits.f1) | |
621 | { | |
622 | case INTRGEN: | |
623 | /* imag, log, and log10 arent specific functions */ | |
624 | if(f3field==31 || f3field==43 || f3field==47) | |
625 | goto bad; | |
626 | ||
627 | case INTRSPEC: | |
628 | sp = spectab + f3field; | |
629 | if(tyint==TYLONG && sp->rtype==TYSHORT) | |
630 | ++sp; | |
631 | q = builtin(sp->rtype, varstr(XL,sp->spxname) ); | |
632 | return(q); | |
633 | ||
634 | case INTRCONV: | |
635 | case INTRMIN: | |
636 | case INTRMAX: | |
637 | case INTRBOOL: | |
638 | case INTRCNST: | |
639 | bad: | |
640 | errstr("cannot pass %s as actual", | |
641 | varstr(VL,np->varname)); | |
642 | return( errnode() ); | |
643 | } | |
644 | fatali("intraddr: impossible f1=%d\n", (int) packed.bits.f1); | |
645 | /* NOTREACHED */ | |
646 | } | |
647 | ||
648 | ||
649 | ||
650 | ||
651 | ||
652 | expptr inline(fno, type, args) | |
653 | int fno; | |
654 | int type; | |
655 | struct Chain *args; | |
656 | { | |
657 | register expptr q, t, t1; | |
658 | ||
659 | switch(fno) | |
660 | { | |
661 | case 8: /* real abs */ | |
662 | case 9: /* short int abs */ | |
663 | case 10: /* long int abs */ | |
664 | case 11: /* double precision abs */ | |
665 | if( addressable(q = (expptr) (args->datap)) ) | |
666 | { | |
667 | t = q; | |
668 | q = NULL; | |
669 | } | |
670 | else | |
671 | t = (expptr) mktemp(type,PNULL); | |
672 | t1 = mkexpr(OPQUEST, | |
673 | mkexpr(OPLE, mkconv(type,ICON(0)), cpexpr(t)), | |
674 | mkexpr(OPCOLON, cpexpr(t), | |
675 | mkexpr(OPNEG, cpexpr(t), ENULL) )); | |
676 | if(q) | |
677 | t1 = mkexpr(OPCOMMA, mkexpr(OPASSIGN, cpexpr(t),q), t1); | |
678 | frexpr(t); | |
679 | return(t1); | |
680 | ||
681 | case 26: /* dprod */ | |
682 | q = mkexpr(OPSTAR, mkconv(TYDREAL,args->datap), args->nextp->datap); | |
683 | return(q); | |
684 | ||
685 | case 27: /* len of character string */ | |
686 | q = (expptr) cpexpr(args->datap->headblock.vleng); | |
687 | frexpr(args->datap); | |
688 | return(q); | |
689 | ||
690 | case 14: /* half-integer mod */ | |
691 | case 15: /* mod */ | |
692 | return( mkexpr(OPMOD, (expptr) (args->datap), | |
693 | (expptr) (args->nextp->datap) )); | |
694 | } | |
695 | return(NULL); | |
696 | } |