1 /* $Id: intrins.c,v 1.4 2003/06/05 00:19:59 landrito Exp $
2
3 Handles datatyping of intrinsic functions.
4 */
5
6 /*
7
8
9 Copyright (c) 2001 by Robert K. Moniot.
10
11 Permission is hereby granted, free of charge, to any person
12 obtaining a copy of this software and associated documentation
13 files (the "Software"), to deal in the Software without
14 restriction, including without limitation the rights to use,
15 copy, modify, merge, publish, distribute, sublicense, and/or
16 sell copies of the Software, and to permit persons to whom the
17 Software is furnished to do so, subject to the following
18 conditions:
19
20 The above copyright notice and this permission notice shall be
21 included in all copies or substantial portions of the
22 Software.
23
24 THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY
25 KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE
26 WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR
27 PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR
28 COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
29 LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR
30 OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE
31 SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
32
33 Acknowledgement: the above permission notice is what is known
34 as the "MIT License."
35 */
36 #include <stdio.h>
37 #include <string.h>
38 #include "ftnchek.h"
39 #include "symtab.h"
40 #include "intrins.h"
41
42 /* Define positional flags to allow specifying more
43 than one allowed type of argument for generics.
44 */
45
46 #define I (1 << type_INTEGER)
47 #define R (1 << type_REAL)
48 #define D (1 << type_DP)
49 #define C (1 << type_COMPLEX)
50 #define Z (1 << type_DCOMPLEX)
51 #define L (1 << type_LOGICAL)
52 #define STR (1 << type_STRING)
53
54 /* Table below contains information from Table 5, pp. 15-22
55 to 15-25 of the standard. Note: num_args == -1 means 1 or 2 args,
56 num_args == -2 means 2 or more args. Value of arg_type is the OR
57 of all allowable types (I, R, etc. as defined above). Value of
58 result_type is type returned by function (type_INTEGER, etc.).
59 If result_type is type_GENERIC, function type is same as arg type.
60
61 If you add your own intrinsics to this list, the order is not
62 important and the table size adjusts automatically.
63 */
64
65 PRIVATE IntrinsInfo intrinsic[]={
66
67
68 /* Table contains: name, num_args, arg_type, result_type, flags.
69 Special num_args values are defined in symtab.h.
70
71 Flags: I_F77 if it is in Table 5 p. 15-24, I_NONF77 otherwise
72 I_NONF90 if it is not in Chap 13 of F90 standard
73 I_NONSTD = I_NONF77|I_NONF90 for convenience
74 I_MIXED_ARGS if arguments are not all of same type.
75 I_NONPURE if arg need not have defined value (LEN).
76 I_C_TO_R indicates complex -> real in generic cases
77 (ABS,IMAG,REAL).
78 I_SP_R indicates specific REAL result (REAL)
79 I_NOTARG if it is a generic with no specific meaning,
80 or if it is a type conversion, lexical relationship,
81 or min or max (cf. p. 15-3, sec. 15.3.2)
82 I_EXTRA indicates common nonstd function
83 I_VMS indicates VMS-specific function
84 I_UNIX indicates UNIX-specific function
85 */
86
87 #define I_NONSTD (I_NONF77|I_NONF90)
88
89 {"INT", 1, I|R|D|C|Z,type_INTEGER, I_F77|I_NOTARG},
90 {"IFIX", 1, R, type_INTEGER, I_F77|I_NOTARG},
91 {"IDINT", 1, D, type_INTEGER, I_F77|I_NOTARG},
92 {"REAL", 1, I|R|D|C|Z,type_GENERIC, I_F77|I_NOTARG|I_C_TO_R|I_SP_R},
93 {"FLOAT", 1, I, type_REAL, I_F77|I_NOTARG},
94 {"SNGL", 1, D, type_REAL, I_F77|I_NOTARG},
95 {"DBLE", 1, I|R|D|C|Z,type_DP, I_F77|I_NOTARG},
96 {"CMPLX", I_1or2, I|R|D|C|Z,type_COMPLEX, I_F77|I_NOTARG},
97 {"ICHAR", 1, STR, type_INTEGER, I_F77|I_NOTARG|I_ICHAR},
98 {"CHAR", 1, I, type_STRING, I_F77|I_NOTARG|I_CHAR},
99 {"AINT", 1, R|D, type_GENERIC, I_F77},
100 {"DINT", 1, D, type_DP, I_F77},
101 {"ANINT", 1, R|D, type_GENERIC, I_F77},
102 {"DNINT", 1, D, type_DP, I_F77},
103 {"NINT", 1, R|D, type_INTEGER, I_F77},
104 {"IDNINT", 1, D, type_INTEGER, I_F77},
105 {"ABS", 1, I|R|D|C|Z,type_GENERIC, I_F77|I_C_TO_R|I_ABS},
106 {"IABS", 1, I, type_INTEGER, I_F77|I_ABS},
107 {"DABS", 1, D, type_DP, I_F77},
108 {"CABS", 1, C, type_REAL, I_F77},
109 {"MOD", 2, I|R|D, type_GENERIC, I_F77|I_MOD},
110 {"AMOD", 2, R, type_REAL, I_F77},
111 {"DMOD", 2, D, type_DP, I_F77},
112 {"SIGN", 2, I|R|D, type_GENERIC, I_F77|I_SIGN},
113 {"ISIGN", 2, I, type_INTEGER, I_F77|I_SIGN},
114 {"DSIGN", 2, D, type_DP, I_F77},
115 {"DIM", 2, I|R|D, type_GENERIC, I_F77|I_DIM},
116 {"IDIM", 2, I, type_INTEGER, I_F77|I_DIM},
117 {"DDIM", 2, D, type_DP, I_F77},
118 {"DPROD", 2, R, type_DP, I_F77},
119 {"MAX", I_2up, I|R|D, type_GENERIC, I_F77|I_NOTARG|I_MAX},
120 {"MAX0", I_2up, I, type_INTEGER, I_F77|I_NOTARG|I_MAX},
121 {"AMAX1", I_2up, R, type_REAL, I_F77|I_NOTARG},
122 {"DMAX1", I_2up, D, type_DP, I_F77|I_NOTARG},
123 {"AMAX0", I_2up, I, type_REAL, I_F77|I_NOTARG},
124 {"MAX1", I_2up, R, type_INTEGER, I_F77|I_NOTARG},
125 {"MIN", I_2up, I|R|D, type_GENERIC, I_F77|I_NOTARG|I_MIN},
126 {"MIN0", I_2up, I, type_INTEGER, I_F77|I_NOTARG|I_MIN},
127 {"AMIN1", I_2up, R, type_REAL, I_F77|I_NOTARG},
128 {"DMIN1", I_2up, D, type_DP, I_F77|I_NOTARG},
129 {"AMIN0", I_2up, I, type_REAL, I_F77|I_NOTARG},
130 {"MIN1", I_2up, R, type_INTEGER, I_F77|I_NOTARG},
131 {"LEN", 1, STR, type_INTEGER, I_F77|I_LEN},
132 {"INDEX", 2, STR, type_INTEGER, I_F77|I_INDEX},
133 {"AIMAG", 1, C, type_REAL, I_F77},
134 {"CONJG", 1, C, type_COMPLEX, I_F77},
135 {"SQRT", 1, R|D|C|Z,type_GENERIC, I_F77},
136 {"DSQRT", 1, D, type_DP, I_F77},
137 {"CSQRT", 1, C, type_COMPLEX, I_F77},
138 {"EXP", 1, R|D|C|Z,type_GENERIC, I_F77},
139 {"DEXP", 1, D, type_DP, I_F77},
140 {"CEXP", 1, C, type_COMPLEX, I_F77},
141 {"LOG", 1, R|D|C|Z,type_GENERIC, I_F77|I_NOTARG},
142 {"ALOG", 1, R, type_REAL, I_F77},
143 {"DLOG", 1, D, type_DP, I_F77},
144 {"CLOG", 1, C, type_COMPLEX, I_F77},
145 {"LOG10", 1, R|D, type_GENERIC, I_F77|I_NOTARG},
146 {"ALOG10", 1, R, type_REAL, I_F77},
147 {"DLOG10", 1, D, type_DP, I_F77},
148 {"SIN", 1, R|D|C|Z,type_GENERIC, I_F77},
149 {"DSIN", 1, D, type_DP, I_F77},
150 {"CSIN", 1, C, type_COMPLEX, I_F77},
151 {"COS", 1, R|D|C|Z,type_GENERIC, I_F77},
152 {"DCOS", 1, D, type_DP, I_F77},
153 {"CCOS", 1, C, type_COMPLEX, I_F77},
154 {"TAN", 1, R|D, type_GENERIC, I_F77},
155 {"DTAN", 1, D, type_DP, I_F77},
156 {"ASIN", 1, R|D, type_GENERIC, I_F77},
157 {"DASIN", 1, D, type_DP, I_F77},
158 {"ACOS", 1, R|D, type_GENERIC, I_F77},
159 {"DACOS", 1, D, type_DP, I_F77},
160 {"ATAN", 1, R|D, type_GENERIC, I_F77},
161 {"DATAN", 1, D, type_DP, I_F77},
162 {"ATAN2", 2, R|D, type_GENERIC, I_F77},
163 {"DATAN2", 2, D, type_DP, I_F77},
164 {"SINH", 1, R|D, type_GENERIC, I_F77},
165 {"DSINH", 1, D, type_DP, I_F77},
166 {"COSH", 1, R|D, type_GENERIC, I_F77},
167 {"DCOSH", 1, D, type_DP, I_F77},
168 {"TANH", 1, R|D, type_GENERIC, I_F77},
169 {"DTANH", 1, D, type_DP, I_F77},
170 {"LGE", 2, STR, type_LOGICAL, I_F77|I_NOTARG},
171 {"LGT", 2, STR, type_LOGICAL, I_F77|I_NOTARG},
172 {"LLE", 2, STR, type_LOGICAL, I_F77|I_NOTARG},
173 {"LLT", 2, STR, type_LOGICAL, I_F77|I_NOTARG},
174 /* associated intrinsic statement to check association of
175 * pointers
176 */
177 {"ASSOCIATED", I_1or2, I|R|D|C|Z|L|STR,type_LOGICAL, I_NONF77|I_NONPURE},
178 /* allocated intrinsic statement to check allocation of
179 * pointers
180 */
181 {"ALLOCATED", 1, I|R|D|C|Z|L|STR,type_LOGICAL, I_NONF77|I_NONPURE},
182 /* DOUBLE COMPLEX intrinsics are included regardless
183 of -intrinsics option, since they are essential
184 to support of this datatype.
185 */
186 {"DCMPLX", I_1or2, I|R|D|C|Z,type_DCOMPLEX,I_NONSTD|I_NOTARG},
187 {"DCONJG", 1, Z, type_DCOMPLEX, I_NONSTD},
188 {"DIMAG", 1, Z, type_DP, I_NONSTD},
189 {"IMAG", 1, C|Z, type_GENERIC, I_NONSTD|I_NOTARG|I_C_TO_R},
190 {"DREAL", 1, Z, type_DP, I_NONSTD},
191 {"CDABS", 1, Z, type_DP, I_NONSTD},
192 {"ZABS", 1, Z, type_DP, I_NONSTD},
193 {"CDSQRT", 1, Z, type_DCOMPLEX, I_NONSTD},
194 {"ZSQRT", 1, Z, type_DCOMPLEX, I_NONSTD},
195 {"CDEXP", 1, Z, type_DCOMPLEX, I_NONSTD},
196 {"ZEXP", 1, Z, type_DCOMPLEX, I_NONSTD},
197 {"CDLOG", 1, Z, type_DCOMPLEX, I_NONSTD},
198 {"ZLOG", 1, Z, type_DCOMPLEX, I_NONSTD},
199 {"CDSIN", 1, Z, type_DCOMPLEX, I_NONSTD},
200 {"ZSIN", 1, Z, type_DCOMPLEX, I_NONSTD},
201 {"CDCOS", 1, Z, type_DCOMPLEX, I_NONSTD},
202 {"ZCOS", 1, Z, type_DCOMPLEX, I_NONSTD},
203
204 /* DFLOAT has been available in almost all Fortran
205 implementations for decades, but curiously, was
206 omitted from the Fortran 66 and Fortran 77
207 standards. A separate intrinsic is essential,
208 because DBLE(FLOAT()) will lose bits for integer
209 arguments larger than the REAL fraction size. If
210 we don't include it here, declaration file output
211 will incorrectly type it as REAL instead of DOUBLE
212 PRECISION. -- NHFB */
213
214 {"DFLOAT", 1, I, type_DP, I_NONSTD},
215
216 /* Quad precision intrinsics are included regardless
217 of -intrinsics option, since they are essential
218 to support of this datatype. (Actually most of
219 them are better handled by generics.)
220 */
221 {"IQINT", 1, R, type_INTEGER, I_NONSTD|I_NOTARG|I_QARG},
222 {"SNGLQ", 1, R, type_REAL, I_NONSTD|I_NOTARG|I_QARG},
223 {"QREAL", 1, C, type_QUAD, I_NONSTD|I_NOTARG|I_QARG|I_QUAD},
224 {"DBLEQ", 1, R, type_DP, I_NONSTD|I_NOTARG|I_QARG},
225 {"QFLOAT", 1, I, type_QUAD, I_NONSTD|I_NOTARG|I_QUAD},
226 {"QEXTD", 1, D, type_QUAD, I_NONSTD|I_NOTARG|I_QUAD},
227 {"QEXT", 1, I|R|D, type_QUAD, I_NONSTD|I_NOTARG|I_QUAD},
228 {"QCMPLX", I_1or2, I|R|D|C|Z,type_CQUAD, I_NONSTD|I_NOTARG|I_QUAD},
229 {"QINT", 1, R, type_QUAD, I_NONSTD|I_QARG|I_QUAD},
230 {"QNINT", 1, R, type_QUAD, I_NONSTD|I_QARG|I_QUAD},
231 {"IQNINT", 1, R, type_INTEGER, I_NONSTD|I_QARG},
232 {"QABS", 1, R, type_QUAD, I_NONSTD|I_QARG|I_QUAD},
233 {"CQABS", 1, C, type_QUAD, I_NONSTD|I_QARG|I_QUAD},
234 {"QMOD", 2, R, type_QUAD, I_NONSTD|I_QARG|I_QUAD},
235 {"QSIGN", 2, R, type_QUAD, I_NONSTD|I_QARG|I_QUAD},
236 {"QDIM", 2, R, type_QUAD, I_NONSTD|I_QARG|I_QUAD},
237 {"QPROD", 2, D, type_QUAD, I_NONSTD|I_QUAD},
238 {"QMAX1", I_2up, R, type_QUAD, I_NONSTD|I_NOTARG|I_QARG|I_QUAD},
239 {"QMIN1", I_2up, R, type_QUAD, I_NONSTD|I_NOTARG|I_QARG|I_QUAD},
240 {"QIMAG", 1, C, type_QUAD, I_NONSTD|I_QARG|I_QUAD},
241 {"QCONJG", 1, C, type_CQUAD, I_NONSTD|I_QARG|I_QUAD},
242 {"QSQRT", 1, R, type_QUAD, I_NONSTD|I_QARG|I_QUAD},
243 {"CQSQRT", 1, C, type_CQUAD, I_NONSTD|I_QARG|I_QUAD},
244 {"QEXP", 1, R, type_QUAD, I_NONSTD|I_QARG|I_QUAD},
245 {"CQEXP", 1, C, type_CQUAD, I_NONSTD|I_QARG|I_QUAD},
246 {"QLOG", 1, R, type_QUAD, I_NONSTD|I_QARG|I_QUAD},
247 {"CQLOG", 1, C, type_CQUAD, I_NONSTD|I_QARG|I_QUAD},
248 {"QLOG10", 1, R, type_QUAD, I_NONSTD|I_QARG|I_QUAD},
249 {"QSIN", 1, R, type_QUAD, I_NONSTD|I_QARG|I_QUAD},
250 {"CQSIN", 1, C, type_CQUAD, I_NONSTD|I_QARG|I_QUAD},
251 {"QCOS", 1, R, type_QUAD, I_NONSTD|I_QARG|I_QUAD},
252 {"CQCOS", 1, C, type_CQUAD, I_NONSTD|I_QARG|I_QUAD},
253 {"QTAN", 1, R, type_QUAD, I_NONSTD|I_QARG|I_QUAD},
254 {"QARSIN", 1, R, type_QUAD, I_NONSTD|I_QARG|I_QUAD},
255 {"QARCOS", 1, R, type_QUAD, I_NONSTD|I_QARG|I_QUAD},
256 {"QATAN", 1, R, type_QUAD, I_NONSTD|I_QARG|I_QUAD},
257 {"QATAN2", 2, R, type_QUAD, I_NONSTD|I_QARG|I_QUAD},
258 {"QSINH", 1, R, type_QUAD, I_NONSTD|I_QARG|I_QUAD},
259 {"QCOSH", 1, R, type_QUAD, I_NONSTD|I_QARG|I_QUAD},
260 {"QTANH", 1, R, type_QUAD, I_NONSTD|I_QARG|I_QUAD},
261
262 #ifdef EXTRA_INTRINSICS
263
264 /* Nonstandard but widely used intrinsics. These follow both
265 VMS and AIX defns, so they are probably de facto standard.
266 Not included: specifics covered by a generic.
267 N.B. Argument checking is not tight for these: some
268 take arrays, 0 or 1 arguments, etc. that are not
269 handled by check_intrins_args(). Remarks are placed by
270 these cases.
271 */
272
273
274 /* Bit test & Shift operations: these follow Mil. Std. 1753 */
275 {"BTEST", 2, I, type_LOGICAL, I_NONF77|I_EXTRA},
276 {"IAND", 2, I, type_INTEGER, I_NONF77|I_EXTRA},
277 {"IOR", 2, I, type_INTEGER, I_NONF77|I_EXTRA},
278 {"IBSET", 2, I, type_INTEGER, I_NONF77|I_EXTRA},
279 {"IBCLR", 2, I, type_INTEGER, I_NONF77|I_EXTRA},
280 {"IBITS", 3, I, type_INTEGER, I_NONF77|I_EXTRA},
281 {"IEOR", 2, I, type_INTEGER, I_NONF77|I_EXTRA},
282 {"ISHFT", 2, I, type_INTEGER, I_NONF77|I_EXTRA},
283 {"ISHFTC", 3, I, type_INTEGER, I_NONF77|I_EXTRA},
284 {"MVBITS", 5, I, type_SUBROUTINE,I_NONF77|I_EXTRA},
285 {"NOT", 1, I, type_INTEGER, I_NONF77|I_EXTRA},
286
287 /* Address-of function */
288 {"LOC", 1,I|R|D|C|Z|L|STR,type_INTEGER, I_NONSTD|I_EXTRA},
289
290 /* Utility routines */
291 {"EXIT", I_0or1, I, type_SUBROUTINE,I_NONSTD|I_EXTRA},
292 #endif
293
294 /* Unix only. These are a selected subset of the F77
295 library routines listed in the USENIX manual section 3F.
296 */
297 #ifdef UNIX_INTRINSICS
298 {"ABORT", 1, STR, type_SUBROUTINE,I_NONSTD|I_UNIX},
299 {"AND", 2, I, type_INTEGER, I_NONSTD|I_UNIX},
300 /* I, then STR not enforced in GETARG. */
301 {"GETARG", 2, I|STR, type_SUBROUTINE,I_MIXED_ARGS|I_NONSTD|I_UNIX},
302 {"GETENV", 2, STR, type_SUBROUTINE,I_NONSTD|I_UNIX},
303 {"GMTIME", 2, I, type_SUBROUTINE,I_NONSTD|I_UNIX},/*2nd arg array(9)*/
304 #ifdef IARGC_NO_ARG
305 {"IARGC", 0, 0, type_INTEGER, I_NONSTD|I_UNIX},
306 #else
307 #ifdef IARGC_ONE_ARG
308 {"IARGC", 1, I, type_INTEGER, I_NONSTD|I_UNIX},
309 #else /* default is to allow 0 or 1 */
310 {"IARGC", I_0or1, I, type_INTEGER, I_NONSTD|I_UNIX},
311 #endif
312 #endif
313 {"LSHIFT", 2, I, type_INTEGER, I_NONSTD|I_UNIX},
314 {"LTIME", 2, I, type_SUBROUTINE,I_NONSTD|I_UNIX},/*2nd arg array(9)*/
315 {"OR", 2, I, type_INTEGER, I_NONSTD|I_UNIX},
316 #ifdef RAND_NO_ARG /*RAND() form*/
317 {"IRAND", 0, 0, type_INTEGER, I_NONSTD|I_UNIX},
318 {"RAND", 0, 0, type_REAL, I_NONSTD|I_UNIX},
319 #else
320 #ifdef RAND_ONE_ARG /*RAND(ISEED) form*/
321 {"IRAND", 1, I, type_INTEGER, I_NONSTD|I_UNIX|I_NONPURE},
322 {"RAND", 1, I, type_REAL, I_NONSTD|I_UNIX|I_NONPURE},
323 #else /* Allow either form */
324 {"IRAND", I_0or1, I, type_INTEGER, I_NONSTD|I_UNIX|I_NONPURE},
325 {"RAND", I_0or1, I, type_REAL, I_NONSTD|I_UNIX|I_NONPURE},
326 #endif
327 #endif
328 {"RSHIFT", 2, I, type_INTEGER, I_NONSTD|I_UNIX},
329 {"SRAND", 1, I|R, type_SUBROUTINE,I_NONSTD|I_UNIX},/*AIX has this*/
330 {"SYSTEM", 1, STR, type_INTEGER, I_NONSTD|I_UNIX},
331 {"TIME", I_0or1, I, type_INTEGER, I_NONSTD|I_UNIX},
332 {"XOR", 2, I, type_INTEGER, I_NONSTD|I_UNIX},
333 #endif
334
335 #ifdef VMS_INTRINSICS /* VMS only */
336 {"DATE", 1, STR, type_SUBROUTINE,I_NONSTD|I_VMS},
337 {"ERRSNS", 5, I, type_SUBROUTINE,I_NONSTD|I_VMS},
338 {"IDATE", 3, I, type_SUBROUTINE,I_NONSTD|I_VMS},
339 {"RAN", 1, I, type_REAL, I_NONSTD|I_VMS|I_NONPURE},
340 {"SECNDS", 1, R, type_REAL, I_NONSTD|I_VMS},
341 {"SIZEOF", 1, I|R|D|C|Z|L|STR,type_INTEGER, I_NONSTD|I_VMS},
342 {"TIME", 1, STR, type_SUBROUTINE,I_NONSTD|I_VMS},
343 #endif
344
345 #undef I
346 #undef R
347 #undef D
348 #undef C
349 #undef Z
350 #undef L
351 #undef STR
352
353 };
354
355 #define NUM_INTRINSICS (sizeof(intrinsic)/sizeof(intrinsic[0]))
356
357
358 /* Definitions of routines start here */
359
360 PROTO( PRIVATE void set_intrinsic_numargs, ( const char *name, int choice ));
361 PROTO(PRIVATE unsigned long kwd_hash,( const char *s ));
362
363
364 #define EMPTY 255
365
366 PRIVATE unsigned char intrins_hashtab[INTRINS_HASHSZ];
367
368 /* init_intrins_hashtab:
369 Initializes the intrinsic hash table by clearing it to EMPTY
370 and then hashes all the intrinsic names into the table.
371 */
372
373 unsigned long
init_intrins_hashtab(VOID)374 init_intrins_hashtab(VOID)
375 {
376 unsigned i,h;
377 unsigned long hnum;
378 unsigned long numclashes=0;
379
380 for(h=0;h<INTRINS_HASHSZ;h++) {
381 intrins_hashtab[h] = EMPTY;
382 }
383 for(i=0; i < NUM_INTRINSICS; i++) {
384 hnum = kwd_hash(intrinsic[i].name);
385 while(h=hnum%INTRINS_HASHSZ, intrins_hashtab[h] != EMPTY) {
386 hnum = rehash(hnum);
387 numclashes++;
388 }
389 intrins_hashtab[h] = i;
390 }
391 return numclashes;
392 }
393
394
395 /* Function called by do_preps to alter intrinsic table for
396 user-selected options respecting RAND and IARGC.
397 */
398
399 #ifndef STANDARD_INTRINSICS
400 void
set_intrinsic_options(VOID)401 set_intrinsic_options(VOID)
402 {
403 int numargs;
404
405 /* numargs = 0 if only no_arg is set, and
406 1 if only one_arg is set. numargs =
407 I_0or1 if both are set. If neither
408 is set (-intrinsic=none),
409 return to compile-time default. */
410
411
412 /* Form a two-bit number */
413 switch( (intrinsic_rand_one_argument<<1) | intrinsic_rand_no_argument ) {
414 case 1:
415 numargs = 0; /* no_argument */
416 break;
417 case 2:
418 numargs = 1; /* one_argument */
419 break;
420 case 3:
421 numargs = I_0or1; /* both cases */
422 break;
423 default:
424 numargs= (DEF_INTRINSIC_RAND & 1?
425 (DEF_INTRINSIC_RAND & 2? I_0or1: 0)
426 :(DEF_INTRINSIC_RAND & 2? 1:I_0or1));
427 break;
428 }
429
430 set_intrinsic_numargs("RAND",numargs);
431 set_intrinsic_numargs("IRAND",numargs);
432
433 switch( (intrinsic_iargc_one_argument<<1) | intrinsic_iargc_no_argument ) {
434 case 1:
435 numargs = 0; /* no_argument */
436 break;
437 case 2:
438 numargs = 1; /* one_argument */
439 break;
440 case 3:
441 numargs = I_0or1; /* both cases */
442 break;
443 default:
444 numargs = (DEF_INTRINSIC_IARGC & 1?
445 (DEF_INTRINSIC_IARGC & 2? I_0or1: 0)
446 :(DEF_INTRINSIC_IARGC & 2? 1:I_0or1));
447 break;
448 }
449
450 set_intrinsic_numargs("IARGC",numargs);
451 }
452
453 #endif /* not STANDARD_INTRINSICS */
454
455
456
457 PRIVATE
458 #if HAVE_STDC
set_intrinsic_numargs(const char * name,int choice)459 void set_intrinsic_numargs(const char *name, int choice)
460 #else /* K&R style */
461 void set_intrinsic_numargs(name,choice)
462 char *name; /* Name of function to fix up */
463 int choice; /* 0 = none, 1 = one, I_0or1 = either */
464 #endif /* HAVE_STDC */
465 {
466 IntrinsInfo *defn;
467
468 defn = find_intrinsic(name);
469 if(defn != (IntrinsInfo *)NULL) {
470 defn->num_args = choice;
471 }
472 }
473
474
475 /* Function to look up an intrinsic function name in table.
476 If found, returns ptr to table entry, otherwise NULL.
477 */
478 IntrinsInfo *
479 #if HAVE_STDC
find_intrinsic(const char * s)480 find_intrinsic(const char *s)
481 /* given name */
482 #else /* K&R style */
483 find_intrinsic(s)
484 char *s; /* given name */
485 #endif /* HAVE_STDC */
486 {
487 unsigned i, h;
488 unsigned long hnum;
489
490 hnum = kwd_hash(s);
491 for(;;) {
492 h=hnum%INTRINS_HASHSZ;
493 if( (i=intrins_hashtab[h]) == EMPTY )
494 break; /* Not found */
495
496 /* Something found: see if a match */
497 if( strcmp(s,intrinsic[i].name) == 0
498 #ifndef STANDARD_INTRINSICS
499 &&
500 ((intrinsic[i].intrins_flags&(I_EXTRA|I_VMS|I_UNIX))==0 ||
501 ((intrinsic[i].intrins_flags&I_EXTRA) && intrinsic_set_extra) ||
502 ((intrinsic[i].intrins_flags&I_UNIX) && intrinsic_set_unix) ||
503 ((intrinsic[i].intrins_flags&I_VMS) && intrinsic_set_vms)
504 )
505 #endif
506 ) {
507
508 return &intrinsic[i];
509 }
510 else { /* No match: try next */
511 hnum = rehash(hnum);
512 }
513 }
514 /* Not an intrinsic function */
515 return (IntrinsInfo *)NULL;
516 }
517
518 /* kwd_hash: Same as hash() but always uses full length of keyword.
519 To keep the keyword table clash-free on any machine,
520 packs only 4 bytes per word even if long is bigger */
521
522 PRIVATE unsigned long
523 #if HAVE_STDC
kwd_hash(const char * s)524 kwd_hash(const char *s)
525 #else /* K&R style */
526 kwd_hash(s)
527 char *s;
528 #endif /* HAVE_STDC */
529 {
530 unsigned long sum = 0, wd;
531 int i = 0,j;
532
533 int n = strlen(s);
534
535 while (i < n) {
536 wd = 0;
537 for(j=1; j <= 4 && i < n; i++,j++) {
538 wd += (unsigned long)(s[i] & 0xff) << (4 - j) * 8;}
539
540 sum ^= wd;}
541 return sum;
542 }
543
544