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