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