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