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