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