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