![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to intr.c CVS log ![[TXT]](/cvsweb/icons/text.gif){kind=icon}
![[DIR]](/cvsweb/icons/dir.gif){kind=icon}
Up to [Research Unix] / researchv10dc / cmd / f2c|
Return to intr.c CVS log | Up to [Research Unix] / researchv10dc / cmd / f2c |
1.1 root 1: /****************************************************************
2: Copyright 1990, 1992 by AT&T Bell Laboratories and Bellcore.
3:
4: Permission to use, copy, modify, and distribute this software
5: and its documentation for any purpose and without fee is hereby
6: granted, provided that the above copyright notice appear in all
7: copies and that both that the copyright notice and this
8: permission notice and warranty disclaimer appear in supporting
9: documentation, and that the names of AT&T Bell Laboratories or
10: Bellcore or any of their entities not be used in advertising or
11: publicity pertaining to distribution of the software without
12: specific, written prior permission.
13:
14: AT&T and Bellcore disclaim all warranties with regard to this
15: software, including all implied warranties of merchantability
16: and fitness. In no event shall AT&T or Bellcore be liable for
17: any special, indirect or consequential damages or any damages
18: whatsoever resulting from loss of use, data or profits, whether
19: in an action of contract, negligence or other tortious action,
20: arising out of or in connection with the use or performance of
21: this software.
22: ****************************************************************/
23:
24: #include "defs.h"
25: #include "names.h"
26:
27: void cast_args ();
28:
29: union
30: {
31: int ijunk;
32: struct Intrpacked bits;
33: } packed;
34:
35: struct Intrbits
36: {
37: char intrgroup /* :3 */;
38: char intrstuff /* result type or number of generics */;
39: char intrno /* :7 */;
40: char dblcmplx;
41: char dblintrno; /* for -r8 */
42: };
43:
44: /* List of all intrinsic functions. */
45:
46: LOCAL struct Intrblock
47: {
48: char intrfname[8];
49: struct Intrbits intrval;
50: } intrtab[ ] =
51: {
52: "int", { INTRCONV, TYLONG },
53: "real", { INTRCONV, TYREAL, 1 },
54: /* 1 ==> real(TYDCOMPLEX) yields TYDREAL */
55: "dble", { INTRCONV, TYDREAL },
56: "cmplx", { INTRCONV, TYCOMPLEX },
57: "dcmplx", { INTRCONV, TYDCOMPLEX, 0, 1 },
58: "ifix", { INTRCONV, TYLONG },
59: "idint", { INTRCONV, TYLONG },
60: "float", { INTRCONV, TYREAL },
61: "dfloat", { INTRCONV, TYDREAL },
62: "sngl", { INTRCONV, TYREAL },
63: "ichar", { INTRCONV, TYLONG },
64: "iachar", { INTRCONV, TYLONG },
65: "char", { INTRCONV, TYCHAR },
66: "achar", { INTRCONV, TYCHAR },
67:
68: /* any MAX or MIN can be used with any types; the compiler will cast them
69: correctly. So rules against bad syntax in these expressions are not
70: enforced */
71:
72: "max", { INTRMAX, TYUNKNOWN },
73: "max0", { INTRMAX, TYLONG },
74: "amax0", { INTRMAX, TYREAL },
75: "max1", { INTRMAX, TYLONG },
76: "amax1", { INTRMAX, TYREAL },
77: "dmax1", { INTRMAX, TYDREAL },
78:
79: "and", { INTRBOOL, TYUNKNOWN, OPBITAND },
80: "or", { INTRBOOL, TYUNKNOWN, OPBITOR },
81: "xor", { INTRBOOL, TYUNKNOWN, OPBITXOR },
82: "not", { INTRBOOL, TYUNKNOWN, OPBITNOT },
83: "lshift", { INTRBOOL, TYUNKNOWN, OPLSHIFT },
84: "rshift", { INTRBOOL, TYUNKNOWN, OPRSHIFT },
85:
86: "min", { INTRMIN, TYUNKNOWN },
87: "min0", { INTRMIN, TYLONG },
88: "amin0", { INTRMIN, TYREAL },
89: "min1", { INTRMIN, TYLONG },
90: "amin1", { INTRMIN, TYREAL },
91: "dmin1", { INTRMIN, TYDREAL },
92:
93: "aint", { INTRGEN, 2, 0 },
94: "dint", { INTRSPEC, TYDREAL, 1 },
95:
96: "anint", { INTRGEN, 2, 2 },
97: "dnint", { INTRSPEC, TYDREAL, 3 },
98:
99: "nint", { INTRGEN, 4, 4 },
100: "idnint", { INTRGEN, 2, 6 },
101:
102: "abs", { INTRGEN, 6, 8 },
103: "iabs", { INTRGEN, 2, 9 },
104: "dabs", { INTRSPEC, TYDREAL, 11 },
105: "cabs", { INTRSPEC, TYREAL, 12, 0, 13 },
106: "zabs", { INTRSPEC, TYDREAL, 13, 1 },
107:
108: "mod", { INTRGEN, 4, 14 },
109: "amod", { INTRSPEC, TYREAL, 16, 0, 17 },
110: "dmod", { INTRSPEC, TYDREAL, 17 },
111:
112: "sign", { INTRGEN, 4, 18 },
113: "isign", { INTRGEN, 2, 19 },
114: "dsign", { INTRSPEC, TYDREAL, 21 },
115:
116: "dim", { INTRGEN, 4, 22 },
117: "idim", { INTRGEN, 2, 23 },
118: "ddim", { INTRSPEC, TYDREAL, 25 },
119:
120: "dprod", { INTRSPEC, TYDREAL, 26 },
121:
122: "len", { INTRSPEC, TYLONG, 27 },
123: "index", { INTRSPEC, TYLONG, 29 },
124:
125: "imag", { INTRGEN, 2, 31 },
126: "aimag", { INTRSPEC, TYREAL, 31, 0, 32 },
127: "dimag", { INTRSPEC, TYDREAL, 32 },
128:
129: "conjg", { INTRGEN, 2, 33 },
130: "dconjg", { INTRSPEC, TYDCOMPLEX, 34, 1 },
131:
132: "sqrt", { INTRGEN, 4, 35 },
133: "dsqrt", { INTRSPEC, TYDREAL, 36 },
134: "csqrt", { INTRSPEC, TYCOMPLEX, 37, 0, 38 },
135: "zsqrt", { INTRSPEC, TYDCOMPLEX, 38, 1 },
136:
137: "exp", { INTRGEN, 4, 39 },
138: "dexp", { INTRSPEC, TYDREAL, 40 },
139: "cexp", { INTRSPEC, TYCOMPLEX, 41, 0, 42 },
140: "zexp", { INTRSPEC, TYDCOMPLEX, 42, 1 },
141:
142: "log", { INTRGEN, 4, 43 },
143: "alog", { INTRSPEC, TYREAL, 43, 0, 44 },
144: "dlog", { INTRSPEC, TYDREAL, 44 },
145: "clog", { INTRSPEC, TYCOMPLEX, 45, 0, 46 },
146: "zlog", { INTRSPEC, TYDCOMPLEX, 46, 1 },
147:
148: "log10", { INTRGEN, 2, 47 },
149: "alog10", { INTRSPEC, TYREAL, 47, 0, 48 },
150: "dlog10", { INTRSPEC, TYDREAL, 48 },
151:
152: "sin", { INTRGEN, 4, 49 },
153: "dsin", { INTRSPEC, TYDREAL, 50 },
154: "csin", { INTRSPEC, TYCOMPLEX, 51, 0, 52 },
155: "zsin", { INTRSPEC, TYDCOMPLEX, 52, 1 },
156:
157: "cos", { INTRGEN, 4, 53 },
158: "dcos", { INTRSPEC, TYDREAL, 54 },
159: "ccos", { INTRSPEC, TYCOMPLEX, 55, 0, 56 },
160: "zcos", { INTRSPEC, TYDCOMPLEX, 56, 1 },
161:
162: "tan", { INTRGEN, 2, 57 },
163: "dtan", { INTRSPEC, TYDREAL, 58 },
164:
165: "asin", { INTRGEN, 2, 59 },
166: "dasin", { INTRSPEC, TYDREAL, 60 },
167:
168: "acos", { INTRGEN, 2, 61 },
169: "dacos", { INTRSPEC, TYDREAL, 62 },
170:
171: "atan", { INTRGEN, 2, 63 },
172: "datan", { INTRSPEC, TYDREAL, 64 },
173:
174: "atan2", { INTRGEN, 2, 65 },
175: "datan2", { INTRSPEC, TYDREAL, 66 },
176:
177: "sinh", { INTRGEN, 2, 67 },
178: "dsinh", { INTRSPEC, TYDREAL, 68 },
179:
180: "cosh", { INTRGEN, 2, 69 },
181: "dcosh", { INTRSPEC, TYDREAL, 70 },
182:
183: "tanh", { INTRGEN, 2, 71 },
184: "dtanh", { INTRSPEC, TYDREAL, 72 },
185:
186: "lge", { INTRSPEC, TYLOGICAL, 73},
187: "lgt", { INTRSPEC, TYLOGICAL, 75},
188: "lle", { INTRSPEC, TYLOGICAL, 77},
189: "llt", { INTRSPEC, TYLOGICAL, 79},
190:
191: #if 0
192: "epbase", { INTRCNST, 4, 0 },
193: "epprec", { INTRCNST, 4, 4 },
194: "epemin", { INTRCNST, 2, 8 },
195: "epemax", { INTRCNST, 2, 10 },
196: "eptiny", { INTRCNST, 2, 12 },
197: "ephuge", { INTRCNST, 4, 14 },
198: "epmrsp", { INTRCNST, 2, 18 },
199: #endif
200:
201: "fpexpn", { INTRGEN, 4, 81 },
202: "fpabsp", { INTRGEN, 2, 85 },
203: "fprrsp", { INTRGEN, 2, 87 },
204: "fpfrac", { INTRGEN, 2, 89 },
205: "fpmake", { INTRGEN, 2, 91 },
206: "fpscal", { INTRGEN, 2, 93 },
207:
208: "" };
209:
210:
211: LOCAL struct Specblock
212: {
213: char atype; /* Argument type; every arg must have
214: this type */
215: char rtype; /* Result type */
216: char nargs; /* Number of arguments */
217: char spxname[8]; /* Name of the function in Fortran */
218: char othername; /* index into callbyvalue table */
219: } spectab[ ] =
220: {
221: { TYREAL,TYREAL,1,"r_int" },
222: { TYDREAL,TYDREAL,1,"d_int" },
223:
224: { TYREAL,TYREAL,1,"r_nint" },
225: { TYDREAL,TYDREAL,1,"d_nint" },
226:
227: { TYREAL,TYSHORT,1,"h_nint" },
228: { TYREAL,TYLONG,1,"i_nint" },
229:
230: { TYDREAL,TYSHORT,1,"h_dnnt" },
231: { TYDREAL,TYLONG,1,"i_dnnt" },
232:
233: { TYREAL,TYREAL,1,"r_abs" },
234: { TYSHORT,TYSHORT,1,"h_abs" },
235: { TYLONG,TYLONG,1,"i_abs" },
236: { TYDREAL,TYDREAL,1,"d_abs" },
237: { TYCOMPLEX,TYREAL,1,"c_abs" },
238: { TYDCOMPLEX,TYDREAL,1,"z_abs" },
239:
240: { TYSHORT,TYSHORT,2,"h_mod" },
241: { TYLONG,TYLONG,2,"i_mod" },
242: { TYREAL,TYREAL,2,"r_mod" },
243: { TYDREAL,TYDREAL,2,"d_mod" },
244:
245: { TYREAL,TYREAL,2,"r_sign" },
246: { TYSHORT,TYSHORT,2,"h_sign" },
247: { TYLONG,TYLONG,2,"i_sign" },
248: { TYDREAL,TYDREAL,2,"d_sign" },
249:
250: { TYREAL,TYREAL,2,"r_dim" },
251: { TYSHORT,TYSHORT,2,"h_dim" },
252: { TYLONG,TYLONG,2,"i_dim" },
253: { TYDREAL,TYDREAL,2,"d_dim" },
254:
255: { TYREAL,TYDREAL,2,"d_prod" },
256:
257: { TYCHAR,TYSHORT,1,"h_len" },
258: { TYCHAR,TYLONG,1,"i_len" },
259:
260: { TYCHAR,TYSHORT,2,"h_indx" },
261: { TYCHAR,TYLONG,2,"i_indx" },
262:
263: { TYCOMPLEX,TYREAL,1,"r_imag" },
264: { TYDCOMPLEX,TYDREAL,1,"d_imag" },
265: { TYCOMPLEX,TYCOMPLEX,1,"r_cnjg" },
266: { TYDCOMPLEX,TYDCOMPLEX,1,"d_cnjg" },
267:
268: { TYREAL,TYREAL,1,"r_sqrt", 1 },
269: { TYDREAL,TYDREAL,1,"d_sqrt", 1 },
270: { TYCOMPLEX,TYCOMPLEX,1,"c_sqrt" },
271: { TYDCOMPLEX,TYDCOMPLEX,1,"z_sqrt" },
272:
273: { TYREAL,TYREAL,1,"r_exp", 2 },
274: { TYDREAL,TYDREAL,1,"d_exp", 2 },
275: { TYCOMPLEX,TYCOMPLEX,1,"c_exp" },
276: { TYDCOMPLEX,TYDCOMPLEX,1,"z_exp" },
277:
278: { TYREAL,TYREAL,1,"r_log", 3 },
279: { TYDREAL,TYDREAL,1,"d_log", 3 },
280: { TYCOMPLEX,TYCOMPLEX,1,"c_log" },
281: { TYDCOMPLEX,TYDCOMPLEX,1,"z_log" },
282:
283: { TYREAL,TYREAL,1,"r_lg10" },
284: { TYDREAL,TYDREAL,1,"d_lg10" },
285:
286: { TYREAL,TYREAL,1,"r_sin", 4 },
287: { TYDREAL,TYDREAL,1,"d_sin", 4 },
288: { TYCOMPLEX,TYCOMPLEX,1,"c_sin" },
289: { TYDCOMPLEX,TYDCOMPLEX,1,"z_sin" },
290:
291: { TYREAL,TYREAL,1,"r_cos", 5 },
292: { TYDREAL,TYDREAL,1,"d_cos", 5 },
293: { TYCOMPLEX,TYCOMPLEX,1,"c_cos" },
294: { TYDCOMPLEX,TYDCOMPLEX,1,"z_cos" },
295:
296: { TYREAL,TYREAL,1,"r_tan", 6 },
297: { TYDREAL,TYDREAL,1,"d_tan", 6 },
298:
299: { TYREAL,TYREAL,1,"r_asin", 7 },
300: { TYDREAL,TYDREAL,1,"d_asin", 7 },
301:
302: { TYREAL,TYREAL,1,"r_acos", 8 },
303: { TYDREAL,TYDREAL,1,"d_acos", 8 },
304:
305: { TYREAL,TYREAL,1,"r_atan", 9 },
306: { TYDREAL,TYDREAL,1,"d_atan", 9 },
307:
308: { TYREAL,TYREAL,2,"r_atn2", 10 },
309: { TYDREAL,TYDREAL,2,"d_atn2", 10 },
310:
311: { TYREAL,TYREAL,1,"r_sinh", 11 },
312: { TYDREAL,TYDREAL,1,"d_sinh", 11 },
313:
314: { TYREAL,TYREAL,1,"r_cosh", 12 },
315: { TYDREAL,TYDREAL,1,"d_cosh", 12 },
316:
317: { TYREAL,TYREAL,1,"r_tanh", 13 },
318: { TYDREAL,TYDREAL,1,"d_tanh", 13 },
319:
320: { TYCHAR,TYLOGICAL,2,"hl_ge" },
321: { TYCHAR,TYLOGICAL,2,"l_ge" },
322:
323: { TYCHAR,TYLOGICAL,2,"hl_gt" },
324: { TYCHAR,TYLOGICAL,2,"l_gt" },
325:
326: { TYCHAR,TYLOGICAL,2,"hl_le" },
327: { TYCHAR,TYLOGICAL,2,"l_le" },
328:
329: { TYCHAR,TYLOGICAL,2,"hl_lt" },
330: { TYCHAR,TYLOGICAL,2,"l_lt" },
331:
332: { TYREAL,TYSHORT,1,"hr_expn" },
333: { TYREAL,TYLONG,1,"ir_expn" },
334: { TYDREAL,TYSHORT,1,"hd_expn" },
335: { TYDREAL,TYLONG,1,"id_expn" },
336:
337: { TYREAL,TYREAL,1,"r_absp" },
338: { TYDREAL,TYDREAL,1,"d_absp" },
339:
340: { TYREAL,TYDREAL,1,"r_rrsp" },
341: { TYDREAL,TYDREAL,1,"d_rrsp" },
342:
343: { TYREAL,TYREAL,1,"r_frac" },
344: { TYDREAL,TYDREAL,1,"d_frac" },
345:
346: { TYREAL,TYREAL,2,"r_make" },
347: { TYDREAL,TYDREAL,2,"d_make" },
348:
349: { TYREAL,TYREAL,2,"r_scal" },
350: { TYDREAL,TYDREAL,2,"d_scal" },
351: { 0 }
352: } ;
353:
354: #if 0
355: LOCAL struct Incstblock
356: {
357: char atype;
358: char rtype;
359: char constno;
360: } consttab[ ] =
361: {
362: { TYSHORT, TYLONG, 0 },
363: { TYLONG, TYLONG, 1 },
364: { TYREAL, TYLONG, 2 },
365: { TYDREAL, TYLONG, 3 },
366:
367: { TYSHORT, TYLONG, 4 },
368: { TYLONG, TYLONG, 5 },
369: { TYREAL, TYLONG, 6 },
370: { TYDREAL, TYLONG, 7 },
371:
372: { TYREAL, TYLONG, 8 },
373: { TYDREAL, TYLONG, 9 },
374:
375: { TYREAL, TYLONG, 10 },
376: { TYDREAL, TYLONG, 11 },
377:
378: { TYREAL, TYREAL, 0 },
379: { TYDREAL, TYDREAL, 1 },
380:
381: { TYSHORT, TYLONG, 12 },
382: { TYLONG, TYLONG, 13 },
383: { TYREAL, TYREAL, 2 },
384: { TYDREAL, TYDREAL, 3 },
385:
386: { TYREAL, TYREAL, 4 },
387: { TYDREAL, TYDREAL, 5 }
388: };
389: #endif
390:
391: char *callbyvalue[ ] =
392: {0,
393: "sqrt",
394: "exp",
395: "log",
396: "sin",
397: "cos",
398: "tan",
399: "asin",
400: "acos",
401: "atan",
402: "atan2",
403: "sinh",
404: "cosh",
405: "tanh"
406: };
407:
408: void
409: r8fix() /* adjust tables for -r8 */
410: {
411: register struct Intrblock *I;
412: register struct Specblock *S;
413:
414: for(I = intrtab; I->intrfname[0]; I++)
415: if (I->intrval.intrgroup != INTRGEN)
416: switch(I->intrval.intrstuff) {
417: case TYREAL:
418: I->intrval.intrstuff = TYDREAL;
419: I->intrval.intrno = I->intrval.dblintrno;
420: break;
421: case TYCOMPLEX:
422: I->intrval.intrstuff = TYDCOMPLEX;
423: I->intrval.intrno = I->intrval.dblintrno;
424: I->intrval.dblcmplx = 1;
425: }
426:
427: for(S = spectab; S->atype; S++)
428: switch(S->atype) {
429: case TYCOMPLEX:
430: S->atype = TYDCOMPLEX;
431: if (S->rtype == TYREAL)
432: S->rtype = TYDREAL;
433: else if (S->rtype == TYCOMPLEX)
434: S->rtype = TYDCOMPLEX;
435: switch(S->spxname[0]) {
436: case 'r':
437: S->spxname[0] = 'd';
438: break;
439: case 'c':
440: S->spxname[0] = 'z';
441: break;
442: default:
443: Fatal("r8fix bug");
444: }
445: break;
446: case TYREAL:
447: S->atype = TYDREAL;
448: switch(S->rtype) {
449: case TYREAL:
450: S->rtype = TYDREAL;
451: if (S->spxname[0] != 'r')
452: Fatal("r8fix bug");
453: S->spxname[0] = 'd';
454: case TYDREAL: /* d_prod */
455: break;
456:
457: case TYSHORT:
458: if (!strcmp(S->spxname, "hr_expn"))
459: S->spxname[1] = 'd';
460: else if (!strcmp(S->spxname, "h_nint"))
461: strcpy(S->spxname, "h_dnnt");
462: else Fatal("r8fix bug");
463: break;
464:
465: case TYLONG:
466: if (!strcmp(S->spxname, "ir_expn"))
467: S->spxname[1] = 'd';
468: else if (!strcmp(S->spxname, "i_nint"))
469: strcpy(S->spxname, "i_dnnt");
470: else Fatal("r8fix bug");
471: break;
472:
473: default:
474: Fatal("r8fix bug");
475: }
476: }
477: }
478:
479: expptr intrcall(np, argsp, nargs)
480: Namep np;
481: struct Listblock *argsp;
482: int nargs;
483: {
484: int i, rettype;
485: Addrp ap;
486: register struct Specblock *sp;
487: register struct Chain *cp;
488: expptr Inline(), mkcxcon(), mkrealcon();
489: expptr q, ep;
490: int mtype;
491: int op;
492: int f1field, f2field, f3field;
493:
494: packed.ijunk = np->vardesc.varno;
495: f1field = packed.bits.f1;
496: f2field = packed.bits.f2;
497: f3field = packed.bits.f3;
498: if(nargs == 0)
499: goto badnargs;
500:
501: mtype = 0;
502: for(cp = argsp->listp ; cp ; cp = cp->nextp)
503: {
504: ep = (expptr)cp->datap;
505: if( ISCONST(ep) && ep->headblock.vtype==TYSHORT )
506: cp->datap = (char *) mkconv(tyint, ep);
507: mtype = maxtype(mtype, ep->headblock.vtype);
508: }
509:
510: switch(f1field)
511: {
512: case INTRBOOL:
513: op = f3field;
514: if( ! ONEOF(mtype, MSKINT|MSKLOGICAL) )
515: goto badtype;
516: if(op == OPBITNOT)
517: {
518: if(nargs != 1)
519: goto badnargs;
520: q = mkexpr(OPBITNOT, (expptr)argsp->listp->datap, ENULL);
521: }
522: else
523: {
524: if(nargs != 2)
525: goto badnargs;
526: q = mkexpr(op, (expptr)argsp->listp->datap,
527: (expptr)argsp->listp->nextp->datap);
528: }
529: frchain( &(argsp->listp) );
530: free( (charptr) argsp);
531: return(q);
532:
533: case INTRCONV:
534: rettype = f2field;
535: switch(rettype) {
536: case TYLONG:
537: rettype = tyint;
538: break;
539: case TYLOGICAL:
540: rettype = tylog;
541: }
542: if( ISCOMPLEX(rettype) && nargs==2)
543: {
544: expptr qr, qi;
545: qr = (expptr) argsp->listp->datap;
546: qi = (expptr) argsp->listp->nextp->datap;
547: if(ISCONST(qr) && ISCONST(qi))
548: q = mkcxcon(qr,qi);
549: else q = mkexpr(OPCONV,mkconv(rettype-2,qr),
550: mkconv(rettype-2,qi));
551: }
552: else if(nargs == 1) {
553: if (f3field && ((Exprp)argsp->listp->datap)->vtype
554: == TYDCOMPLEX)
555: rettype = TYDREAL;
556: q = mkconv(rettype+100, (expptr)argsp->listp->datap);
557: if (q->tag == TADDR)
558: q->addrblock.parenused = 1;
559: }
560: else goto badnargs;
561:
562: q->headblock.vtype = rettype;
563: frchain(&(argsp->listp));
564: free( (charptr) argsp);
565: return(q);
566:
567:
568: #if 0
569: case INTRCNST:
570:
571: /* Machine-dependent f77 stuff that f2c omits:
572:
573: intcon contains
574: radix for short int
575: radix for long int
576: radix for single precision
577: radix for double precision
578: precision for short int
579: precision for long int
580: precision for single precision
581: precision for double precision
582: emin for single precision
583: emin for double precision
584: emax for single precision
585: emax for double prcision
586: largest short int
587: largest long int
588:
589: realcon contains
590: tiny for single precision
591: tiny for double precision
592: huge for single precision
593: huge for double precision
594: mrsp (epsilon) for single precision
595: mrsp (epsilon) for double precision
596: */
597: { register struct Incstblock *cstp;
598: extern ftnint intcon[14];
599: extern double realcon[6];
600:
601: cstp = consttab + f3field;
602: for(i=0 ; i<f2field ; ++i)
603: if(cstp->atype == mtype)
604: goto foundconst;
605: else
606: ++cstp;
607: goto badtype;
608:
609: foundconst:
610: switch(cstp->rtype)
611: {
612: case TYLONG:
613: return(mkintcon(intcon[cstp->constno]));
614:
615: case TYREAL:
616: case TYDREAL:
617: return(mkrealcon(cstp->rtype,
618: realcon[cstp->constno]) );
619:
620: default:
621: Fatal("impossible intrinsic constant");
622: }
623: }
624: #endif
625:
626: case INTRGEN:
627: sp = spectab + f3field;
628: if(no66flag)
629: if(sp->atype == mtype)
630: goto specfunct;
631: else err66("generic function");
632:
633: for(i=0; i<f2field ; ++i)
634: if(sp->atype == mtype)
635: goto specfunct;
636: else
637: ++sp;
638: warn1 ("bad argument type to intrinsic %s", np->fvarname);
639:
640: /* Made this a warning rather than an error so things like "log (5) ==>
641: log (5.0)" can be accommodated. When none of these cases matches, the
642: argument is cast up to the first type in the spectab list; this first
643: type is assumed to be the "smallest" type, e.g. REAL before DREAL
644: before COMPLEX, before DCOMPLEX */
645:
646: sp = spectab + f3field;
647: mtype = sp -> atype;
648: goto specfunct;
649:
650: case INTRSPEC:
651: sp = spectab + f3field;
652: specfunct:
653: if(tyint==TYLONG && ONEOF(sp->rtype,M(TYSHORT)|M(TYLOGICAL))
654: && (sp+1)->atype==sp->atype)
655: ++sp;
656:
657: if(nargs != sp->nargs)
658: goto badnargs;
659: if(mtype != sp->atype)
660: goto badtype;
661:
662: /* NOTE!! I moved fixargs (YES) into the ELSE branch so that constants in
663: the inline expression wouldn't get put into the constant table */
664:
665: fixargs (NO, argsp);
666: cast_args (mtype, argsp -> listp);
667:
668: if(q = Inline((int)(sp-spectab), mtype, argsp->listp))
669: {
670: frchain( &(argsp->listp) );
671: free( (charptr) argsp);
672: } else {
673:
674: if(sp->othername) {
675: /* C library routines that return double... */
676: /* sp->rtype might be TYREAL */
677: ap = builtin(sp->rtype,
678: callbyvalue[sp->othername], 1);
679: q = fixexpr((Exprp)
680: mkexpr(OPCCALL, (expptr)ap, (expptr)argsp) );
681: } else {
682: fixargs(YES, argsp);
683: ap = builtin(sp->rtype, sp->spxname, 0);
684: q = fixexpr((Exprp)
685: mkexpr(OPCALL, (expptr)ap, (expptr)argsp) );
686: } /* else */
687: } /* else */
688: return(q);
689:
690: case INTRMIN:
691: case INTRMAX:
692: if(nargs < 2)
693: goto badnargs;
694: if( ! ONEOF(mtype, MSKINT|MSKREAL) )
695: goto badtype;
696: argsp->vtype = mtype;
697: q = mkexpr( (f1field==INTRMIN ? OPMIN : OPMAX), (expptr)argsp, ENULL);
698:
699: q->headblock.vtype = mtype;
700: rettype = f2field;
701: if(rettype == TYLONG)
702: rettype = tyint;
703: else if(rettype == TYUNKNOWN)
704: rettype = mtype;
705: return( mkconv(rettype, q) );
706:
707: default:
708: fatali("intrcall: bad intrgroup %d", f1field);
709: }
710: badnargs:
711: errstr("bad number of arguments to intrinsic %s", np->fvarname);
712: goto bad;
713:
714: badtype:
715: errstr("bad argument type to intrinsic %s", np->fvarname);
716:
717: bad:
718: return( errnode() );
719: }
720:
721:
722:
723:
724: intrfunct(s)
725: char *s;
726: {
727: register struct Intrblock *p;
728:
729: for(p = intrtab; p->intrval.intrgroup!=INTREND ; ++p)
730: {
731: if( !strcmp(s, p->intrfname) )
732: {
733: packed.bits.f1 = p->intrval.intrgroup;
734: packed.bits.f2 = p->intrval.intrstuff;
735: packed.bits.f3 = p->intrval.intrno;
736: packed.bits.f4 = p->intrval.dblcmplx;
737: return(packed.ijunk);
738: }
739: }
740:
741: return(0);
742: }
743:
744:
745:
746:
747:
748: Addrp intraddr(np)
749: Namep np;
750: {
751: Addrp q;
752: register struct Specblock *sp;
753: int f3field;
754:
755: if(np->vclass!=CLPROC || np->vprocclass!=PINTRINSIC)
756: fatalstr("intraddr: %s is not intrinsic", np->fvarname);
757: packed.ijunk = np->vardesc.varno;
758: f3field = packed.bits.f3;
759:
760: switch(packed.bits.f1)
761: {
762: case INTRGEN:
763: /* imag, log, and log10 arent specific functions */
764: if(f3field==31 || f3field==43 || f3field==47)
765: goto bad;
766:
767: case INTRSPEC:
768: sp = spectab + f3field;
769: if (tyint == TYLONG
770: && (sp->rtype == TYSHORT || sp->rtype == TYLOGICAL))
771: ++sp;
772: q = builtin(sp->rtype, sp->spxname,
773: sp->othername ? 1 : 0);
774: return(q);
775:
776: case INTRCONV:
777: case INTRMIN:
778: case INTRMAX:
779: case INTRBOOL:
780: case INTRCNST:
781: bad:
782: errstr("cannot pass %s as actual", np->fvarname);
783: return((Addrp)errnode());
784: }
785: fatali("intraddr: impossible f1=%d\n", (int) packed.bits.f1);
786: /* NOT REACHED */ return 0;
787: }
788:
789:
790:
791: void cast_args (maxtype, args)
792: int maxtype;
793: chainp args;
794: {
795: for (; args; args = args -> nextp) {
796: expptr e = (expptr) args->datap;
797: if (e -> headblock.vtype != maxtype)
798: if (e -> tag == TCONST)
799: args->datap = (char *) mkconv(maxtype, e);
800: else {
801: Addrp temp = mktmp(maxtype, ENULL);
802:
803: puteq(cpexpr((expptr)temp), e);
804: args->datap = (char *)temp;
805: } /* else */
806: } /* for */
807: } /* cast_args */
808:
809:
810:
811: expptr Inline(fno, type, args)
812: int fno;
813: int type;
814: struct Chain *args;
815: {
816: register expptr q, t, t1;
817:
818: switch(fno)
819: {
820: case 8: /* real abs */
821: case 9: /* short int abs */
822: case 10: /* long int abs */
823: case 11: /* double precision abs */
824: if( addressable(q = (expptr) args->datap) )
825: {
826: t = q;
827: q = NULL;
828: }
829: else
830: t = (expptr) mktmp(type,ENULL);
831: t1 = mkexpr(type == TYREAL && forcedouble ? OPDABS : OPABS,
832: cpexpr(t), ENULL);
833: if(q)
834: t1 = mkexpr(OPCOMMA, mkexpr(OPASSIGN, cpexpr(t),q), t1);
835: frexpr(t);
836: return(t1);
837:
838: case 26: /* dprod */
839: q = mkexpr(OPSTAR, mkconv(TYDREAL,(expptr)args->datap),
840: (expptr)args->nextp->datap);
841: return(q);
842:
843: case 27: /* len of character string */
844: q = (expptr) cpexpr(((tagptr)args->datap)->headblock.vleng);
845: frexpr((expptr)args->datap);
846: return(q);
847:
848: case 14: /* half-integer mod */
849: case 15: /* mod */
850: return mkexpr(OPMOD, (expptr) args->datap,
851: (expptr) args->nextp->datap);
852: }
853: return(NULL);
854: }
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.