1 /*
2 Copyright (C) 2004-2017,2018 John E. Davis
3
4 This file is part of the S-Lang Library.
5
6 The S-Lang Library is free software; you can redistribute it and/or
7 modify it under the terms of the GNU General Public License as
8 published by the Free Software Foundation; either version 2 of the
9 License, or (at your option) any later version.
10
11 The S-Lang Library is distributed in the hope that it will be useful,
12 but WITHOUT ANY WARRANTY; without even the implied warranty of
13 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
14 General Public License for more details.
15
16 You should have received a copy of the GNU General Public License
17 along with this library; if not, write to the Free Software
18 Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307,
19 USA.
20 */
21
22 #include "slinclud.h"
23
24 #include <math.h>
25 #include <limits.h>
26
27 #ifdef HAVE_LOCALE_H
28 # include <locale.h>
29 #endif
30
31 #if SLANG_HAS_FLOAT
32 # include <float.h>
33 # ifdef HAVE_FLOATINGPOINT_H
34 # include <floatingpoint.h>
35 # endif
36
37 # ifdef HAVE_IEEEFP_H
38 # include <ieeefp.h>
39 # endif
40
41 # ifdef HAVE_NAN_H
42 # include <nan.h>
43 # endif
44 #endif
45
46 #include <ctype.h>
47
48 #include "slang.h"
49 #include "_slang.h"
50
51 #if SLANG_HAS_FLOAT
52 double _pSLang_NaN;
53 double _pSLang_Inf;
54 #endif
55
56 /*
57 * This file defines binary and unary operations on all integer types.
58 * Supported types include:
59 *
60 * SLANG_CHAR_TYPE (char)
61 * SLANG_SHORT_TYPE (short)
62 * SLANG_INT_TYPE (int)
63 * SLANG_LONG_TYPE (long)
64 * SLANG_FLOAT_TYPE (float)
65 * SLANG_DOUBLE_TYPE (double)
66 *
67 * as well as unsigned types. The result-type of an arithmentic operation
68 * will depend upon the data types involved. I am going to distinguish
69 * between the boolean operations such as `and' and `or' from the arithmetic
70 * operations such as `plus'. Since the result of a boolean operation is
71 * either 1 or 0, a boolean result will be represented by SLANG_CHAR_TYPE.
72 * Ordinarily I would use an integer but for arrays it makes more sense to
73 * use a character data type.
74 *
75 * So, the following will be assumed (`+' is any arithmetic operator)
76 *
77 * char + char = int
78 * char|short + short = int
79 * char|short|int + int = int
80 * char|short|int|long + long = long
81 * char|short|int|long|float + float = float
82 * char|short|int|long|float|double + double = double
83 *
84 * In the actual implementation, a brute force approach is avoided. Such
85 * an approach would mean defining different functions for all possible
86 * combinations of types. Including the unsigned types, and not including
87 * the complex number type, there are 10 arithmetic types and 10*10=100
88 * different combinations of types. Clearly this would be too much.
89 *
90 * One approach would be to define binary functions only between operands of
91 * the same type and then convert types as appropriate. This would require
92 * just 6 such functions (int, uint, long, ulong, float, double).
93 * However, many conversion functions are going to be required, particularly
94 * since we are going to allow typecasting from one arithmetic to another.
95 * Since the bit pattern of signed and unsigned types are the same, and only
96 * the interpretation differs, there will be no functions to convert between
97 * signed and unsigned forms of a given type.
98 */
99
100 #ifdef HAVE_LONG_LONG
101 # define MAX_SLARITH_INT_TYPE SLANG_ULLONG_TYPE
102 #else
103 # define MAX_SLARITH_INT_TYPE SLANG_ULONG_TYPE
104 #endif
105
106 #define MAX_SLARITH_TYPE SLANG_LDOUBLE_TYPE
107
108 #define MAX_ARITHMETIC_TYPES (MAX_SLARITH_TYPE-SLANG_CHAR_TYPE+1)
109 #define TYPE_TO_TABLE_INDEX(t) ((t)-SLANG_CHAR_TYPE)
110 #define TABLE_INDEX_TO_TYPE(i) ((i)+SLANG_CHAR_TYPE)
111
112 #define IS_INTEGER_TYPE(t) \
113 (((t) >= SLANG_CHAR_TYPE) && ((t) <= MAX_SLARITH_INT_TYPE))
114
115 /* This table contains the types that have been implemented here */
116 SLtype _pSLarith_Arith_Types [MAX_ARITHMETIC_TYPES+1] =
117 {
118 SLANG_CHAR_TYPE,
119 SLANG_UCHAR_TYPE,
120 SLANG_SHORT_TYPE,
121 SLANG_USHORT_TYPE,
122 SLANG_INT_TYPE,
123 SLANG_UINT_TYPE,
124 SLANG_LONG_TYPE,
125 SLANG_ULONG_TYPE,
126 #ifdef HAVE_LONG_LONG
127 SLANG_LLONG_TYPE, SLANG_ULLONG_TYPE,
128 #endif
129 #ifdef SLANG_HAS_FLOAT
130 SLANG_FLOAT_TYPE,
131 SLANG_DOUBLE_TYPE,
132 # ifdef HAVE_LONG_DOUBLE
133 SLANG_LDOUBLE_TYPE,
134 # endif
135 #endif
136 0
137 };
138
139 static SLtype Alias_Map [MAX_ARITHMETIC_TYPES];
140
141 /* Here are a bunch of functions to convert from one type to another. To
142 * facilitate the process, macros will be used.
143 */
144
145 #define DEFUN_1(f,from_type,to_type) \
146 static void f (to_type *y, from_type *x, SLuindex_Type n) \
147 { \
148 SLuindex_Type i; \
149 for (i = 0; i < n; i++) y[i] = (to_type) x[i]; \
150 }
151
152 #define DEFUN_2(f,from_type,to_type,copy_fun) \
153 static VOID_STAR f (VOID_STAR xp, SLuindex_Type n) \
154 { \
155 from_type *x; \
156 to_type *y; \
157 x = (from_type *) xp; \
158 if (NULL == (y = (to_type *) _SLcalloc (n, sizeof (to_type)))) return NULL; \
159 copy_fun (y, x, n); \
160 return (VOID_STAR) y; \
161 }
162 typedef VOID_STAR (*Convert_Fun_Type)(VOID_STAR, SLuindex_Type);
163
164 #if SLANG_HAS_FLOAT
165 #define TO_DOUBLE_FUN(name,type) \
166 static double name (VOID_STAR x) { return (double) *(type *) x; }
167
168 typedef SLCONST struct
169 {
170 unsigned int sizeof_type;
171 double (*to_double_fun)(VOID_STAR);
172 }
173 To_Double_Fun_Table_Type;
174
175 #endif
176
177 /* Each element of the matrix determines how the row maps onto the column.
178 * That is, let the matrix be B_ij. Where the i,j indices refer to
179 * precedence of the type. Then,
180 * B_ij->copy_function copies type i to type j. Similarly,
181 * B_ij->convert_function mallocs a new array of type j and copies i to it.
182 *
183 * Since types are always converted to higher levels of precedence for binary
184 * operations, many of the elements are NULL.
185 *
186 * Is the idea clear?
187 */
188 typedef struct
189 {
190 FVOID_STAR copy_function;
191 Convert_Fun_Type convert_function;
192 }
193 Binary_Matrix_Type;
194
195 #include "slarith2.inc"
196
197 #if SLANG_HAS_FLOAT
198 SLang_To_Double_Fun_Type
SLarith_get_to_double_fun(SLtype type,unsigned int * sizeof_type)199 SLarith_get_to_double_fun (SLtype type, unsigned int *sizeof_type)
200 {
201 To_Double_Fun_Table_Type *t;
202
203 if ((type < SLANG_CHAR_TYPE) || (type > MAX_SLARITH_TYPE))
204 return NULL;
205
206 t = To_Double_Fun_Table + (type - SLANG_CHAR_TYPE);
207 if ((sizeof_type != NULL)
208 && (t->to_double_fun != NULL))
209 *sizeof_type = t->sizeof_type;
210
211 return t->to_double_fun;
212 }
213 #endif /* SLANG_HAS_FLOAT */
214
215 #define GENERIC_BINARY_FUNCTION int_int_bin_op
216 #define GENERIC_BIT_OPERATIONS
217 #define GENERIC_TYPE int
218 #define POW_FUNCTION(a,b) pow((double)(a),(double)(b))
219 #define POW_RESULT_TYPE double
220 #define ABS_FUNCTION abs
221 #define MOD_FUNCTION(a,b) ((a) % (b))
222 #define TRAP_DIV_ZERO 1
223 #define GENERIC_UNARY_FUNCTION int_unary_op
224 #define GENERIC_ARITH_UNARY_FUNCTION int_arith_unary_op
225 #define SIGN_FUNCTION(x) (((x) > 0) ? 1 : (((x) < 0) ? -1 : 0))
226 #if SLANG_OPTIMIZE_FOR_SPEED
227 # define SCALAR_BINARY_FUNCTION int_int_scalar_bin_op
228 #endif
229 #define PUSH_SCALAR_OBJ_FUN(x) SLclass_push_int_obj(SLANG_INT_TYPE,(x))
230 #define PUSH_POW_OBJ_FUN(x) SLclass_push_double_obj(SLANG_DOUBLE_TYPE, (x))
231 #define CMP_FUNCTION int_cmp_function
232 #include "slarith.inc"
233
234 #define GENERIC_BINARY_FUNCTION uint_uint_bin_op
235 #define GENERIC_BIT_OPERATIONS
236 #define GENERIC_TYPE unsigned int
237 #define GENERIC_TYPE_IS_UNSIGNED
238 #define POW_FUNCTION(a,b) pow((double)(a),(double)(b))
239 #define POW_RESULT_TYPE double
240 #define MOD_FUNCTION(a,b) ((a) % (b))
241 #define TRAP_DIV_ZERO 1
242 #define GENERIC_UNARY_FUNCTION uint_unary_op
243 #define GENERIC_ARITH_UNARY_FUNCTION uint_arith_unary_op
244 #define ABS_FUNCTION(a) (a)
245 #define SIGN_FUNCTION(x) (((x) > 0) ? 1 : 0)
246 #if SLANG_OPTIMIZE_FOR_SPEED
247 # define SCALAR_BINARY_FUNCTION uint_uint_scalar_bin_op
248 #endif
249 #define PUSH_SCALAR_OBJ_FUN(x) SLclass_push_int_obj(SLANG_UINT_TYPE,(int)(x))
250 #define PUSH_POW_OBJ_FUN(x) SLclass_push_double_obj(SLANG_DOUBLE_TYPE, (x))
251 #define CMP_FUNCTION uint_cmp_function
252 #define TO_BINARY_FUNCTION uint_to_binary
253 #include "slarith.inc"
254
255 #if LONG_IS_NOT_INT
256 #define GENERIC_BINARY_FUNCTION long_long_bin_op
257 #define GENERIC_BIT_OPERATIONS
258 #define GENERIC_TYPE long
259 #define POW_FUNCTION(a,b) pow((double)(a),(double)(b))
260 #define POW_RESULT_TYPE double
261 #define MOD_FUNCTION(a,b) ((a) % (b))
262 #define TRAP_DIV_ZERO 1
263 #define GENERIC_UNARY_FUNCTION long_unary_op
264 #define GENERIC_ARITH_UNARY_FUNCTION long_arith_unary_op
265 #define ABS_FUNCTION(a) (((a) >= 0) ? (a) : -(a))
266 #define SIGN_FUNCTION(x) (((x) > 0) ? 1 : (((x) < 0) ? -1 : 0))
267 #if SLANG_OPTIMIZE_FOR_SPEED
268 # define SCALAR_BINARY_FUNCTION long_long_scalar_bin_op
269 #endif
270 #define PUSH_SCALAR_OBJ_FUN(x) SLclass_push_long_obj(SLANG_LONG_TYPE,(x))
271 #define PUSH_POW_OBJ_FUN(x) SLclass_push_double_obj(SLANG_DOUBLE_TYPE, (x))
272 #define CMP_FUNCTION long_cmp_function
273 #include "slarith.inc"
274
275 #define GENERIC_BINARY_FUNCTION ulong_ulong_bin_op
276 #define GENERIC_BIT_OPERATIONS
277 #define GENERIC_TYPE unsigned long
278 #define GENERIC_TYPE_IS_UNSIGNED
279 #define POW_FUNCTION(a,b) pow((double)(a),(double)(b))
280 #define POW_RESULT_TYPE double
281 #define MOD_FUNCTION(a,b) ((a) % (b))
282 #define TRAP_DIV_ZERO 1
283 #define GENERIC_UNARY_FUNCTION ulong_unary_op
284 #define GENERIC_ARITH_UNARY_FUNCTION ulong_arith_unary_op
285 #define ABS_FUNCTION(a) (a)
286 #define SIGN_FUNCTION(x) (((x) > 0) ? 1 : 0)
287 #if SLANG_OPTIMIZE_FOR_SPEED
288 # define SCALAR_BINARY_FUNCTION ulong_ulong_scalar_bin_op
289 #endif
290 #define PUSH_SCALAR_OBJ_FUN(x) SLclass_push_long_obj(SLANG_ULONG_TYPE,(long)(x))
291 #define PUSH_POW_OBJ_FUN(x) SLclass_push_double_obj(SLANG_DOUBLE_TYPE, (x))
292 #define CMP_FUNCTION ulong_cmp_function
293 #define TO_BINARY_FUNCTION ulong_to_binary
294 #include "slarith.inc"
295 #else
296 #define long_long_bin_op int_int_bin_op
297 #define ulong_ulong_bin_op uint_uint_bin_op
298 #define long_unary_op int_unary_op
299 #define ulong_unary_op uint_unary_op
300 #define long_cmp_function int_cmp_function
301 #define ulong_cmp_function uint_cmp_function
302 #define ulong_to_binary uint_to_binary
303 #endif /* LONG_IS_NOT_INT */
304
305 #ifdef HAVE_LONG_LONG
306 # if LLONG_IS_NOT_LONG
307 # define GENERIC_BINARY_FUNCTION llong_llong_bin_op
308 # define GENERIC_BIT_OPERATIONS
309 # define GENERIC_TYPE long long
310 # define POW_FUNCTION(a,b) pow((double)(a),(double)(b))
311 # define POW_RESULT_TYPE double
312 # define MOD_FUNCTION(a,b) ((a) % (b))
313 # define TRAP_DIV_ZERO 1
314 # define GENERIC_UNARY_FUNCTION llong_unary_op
315 # define GENERIC_ARITH_UNARY_FUNCTION llong_arith_unary_op
316 # define ABS_FUNCTION(a) (((a) >= 0) ? (a) : -(a))
317 # define SIGN_FUNCTION(x) (((x) > 0) ? 1 : (((x) < 0) ? -1 : 0))
318 # if SLANG_OPTIMIZE_FOR_SPEED
319 # define SCALAR_BINARY_FUNCTION llong_llong_scalar_bin_op
320 # endif
321 # define PUSH_SCALAR_OBJ_FUN(x) SLclass_push_llong_obj(SLANG_LLONG_TYPE,(x))
322 # define PUSH_POW_OBJ_FUN(x) SLclass_push_double_obj(SLANG_DOUBLE_TYPE, (x))
323 # define CMP_FUNCTION llong_cmp_function
324 # include "slarith.inc"
325
326 # define GENERIC_BINARY_FUNCTION ullong_ullong_bin_op
327 # define GENERIC_BIT_OPERATIONS
328 # define GENERIC_TYPE unsigned long long
329 # define GENERIC_TYPE_IS_UNSIGNED
330 # define POW_FUNCTION(a,b) pow((double)(a),(double)(b))
331 # define POW_RESULT_TYPE double
332 # define MOD_FUNCTION(a,b) ((a) % (b))
333 # define TRAP_DIV_ZERO 1
334 # define GENERIC_UNARY_FUNCTION ullong_unary_op
335 # define GENERIC_ARITH_UNARY_FUNCTION ullong_arith_unary_op
336 # define ABS_FUNCTION(a) (a)
337 # define SIGN_FUNCTION(x) (((x) > 0) ? 1 : 0)
338 # if SLANG_OPTIMIZE_FOR_SPEED
339 # define SCALAR_BINARY_FUNCTION ullong_ullong_scalar_bin_op
340 # endif
341 # define PUSH_SCALAR_OBJ_FUN(x) SLclass_push_llong_obj(SLANG_ULLONG_TYPE,(long long)(x))
342 # define PUSH_POW_OBJ_FUN(x) SLclass_push_double_obj(SLANG_DOUBLE_TYPE, (x))
343 # define CMP_FUNCTION ullong_cmp_function
344 # define TO_BINARY_FUNCTION ullong_to_binary
345 # include "slarith.inc"
346 # else
347 # define llong_llong_bin_op long_long_bin_op
348 # define ullong_ullong_bin_op ulong_ulong_bin_op
349 # define llong_llong_scalar_bin_op long_long_scalar_bin_op
350 # define ullong_ullong_scalar_bin_op ulong_ulong_scalar_bin_op
351 # define ullong_to_binary ulong_to_binary
352 # endif /* LLONG_IS_NOT_LONG */
353 #endif /* HAVE_LONG_LONG */
354
355 #if SLANG_HAS_FLOAT
356 #define GENERIC_BINARY_FUNCTION float_float_bin_op
357 #define GENERIC_TYPE float
358 #define POW_FUNCTION(a,b) (float)pow((double)(a),(double)(b))
359 #define POW_RESULT_TYPE float
360 #define MOD_FUNCTION(a,b) (float)fmod((a),(b))
361 #define TRAP_DIV_ZERO 0
362 #define GENERIC_UNARY_FUNCTION float_unary_op
363 #define GENERIC_ARITH_UNARY_FUNCTION float_arith_unary_op
364 #define ABS_FUNCTION(a) (float)fabs((double) a)
365 #define SIGN_FUNCTION(x) (((x) > 0) ? 1 : (((x) < 0) ? -1 : 0))
366 #if SLANG_OPTIMIZE_FOR_SPEED
367 # define SCALAR_BINARY_FUNCTION float_float_scalar_bin_op
368 #endif
369 #define PUSH_SCALAR_OBJ_FUN(x) SLclass_push_float_obj(SLANG_FLOAT_TYPE,(x))
370 #define PUSH_POW_OBJ_FUN(x) SLclass_push_float_obj(SLANG_FLOAT_TYPE, (x))
371 #define CMP_FUNCTION float_cmp_function
372 #include "slarith.inc"
373
374 #define GENERIC_BINARY_FUNCTION double_double_bin_op
375 #define GENERIC_TYPE double
376 #define POW_FUNCTION(a,b) pow((double)(a),(double)(b))
377 #define POW_RESULT_TYPE double
378 #define MOD_FUNCTION(a,b) fmod((a),(b))
379 #define TRAP_DIV_ZERO 0
380 #define GENERIC_UNARY_FUNCTION double_unary_op
381 #define GENERIC_ARITH_UNARY_FUNCTION double_arith_unary_op
382 #define ABS_FUNCTION(a) fabs(a)
383 #define SIGN_FUNCTION(x) (((x) > 0) ? 1 : (((x) < 0) ? -1 : 0))
384 #if SLANG_OPTIMIZE_FOR_SPEED
385 # define SCALAR_BINARY_FUNCTION double_double_scalar_bin_op
386 #endif
387 #define PUSH_SCALAR_OBJ_FUN(x) SLclass_push_double_obj(SLANG_DOUBLE_TYPE,(x))
388 #define PUSH_POW_OBJ_FUN(x) SLclass_push_double_obj(SLANG_DOUBLE_TYPE, (x))
389 #define CMP_FUNCTION double_cmp_function
390 #include "slarith.inc"
391 #endif /* SLANG_HAS_FLOAT */
392
393 #define GENERIC_UNARY_FUNCTION char_unary_op
394 #define GENERIC_ARITH_UNARY_FUNCTION char_arith_unary_op
395 #define GENERIC_BINARY_FUNCTION char_char_arith_bin_op
396 #define JUST_BOOLEAN_BINARY_OPS
397 #define GENERIC_BIT_OPERATIONS
398 #define GENERIC_TYPE signed char
399 #define ABS_FUNCTION abs
400 #define SIGN_FUNCTION(x) (((x) > 0) ? 1 : (((x) < 0) ? -1 : 0))
401 #define CMP_FUNCTION char_cmp_function
402 #include "slarith.inc"
403
404 #define GENERIC_UNARY_FUNCTION uchar_unary_op
405 #define GENERIC_ARITH_UNARY_FUNCTION uchar_arith_unary_op
406 #define GENERIC_BIT_OPERATIONS
407 #define GENERIC_TYPE unsigned char
408 #define GENERIC_TYPE_IS_UNSIGNED
409 #define ABS_FUNCTION(x) (x)
410 #define SIGN_FUNCTION(x) (((x) > 0) ? 1 : 0)
411 #define CMP_FUNCTION uchar_cmp_function
412 #define TO_BINARY_FUNCTION uchar_to_binary
413 #include "slarith.inc"
414
415 #if SHORT_IS_NOT_INT
416 #define GENERIC_UNARY_FUNCTION short_unary_op
417 #define GENERIC_ARITH_UNARY_FUNCTION short_arith_unary_op
418 #define GENERIC_BIT_OPERATIONS
419 #define GENERIC_TYPE short
420 #define ABS_FUNCTION abs
421 #define SIGN_FUNCTION(x) (((x) > 0) ? 1 : (((x) < 0) ? -1 : 0))
422 #define CMP_FUNCTION short_cmp_function
423 #include "slarith.inc"
424
425 #define GENERIC_UNARY_FUNCTION ushort_unary_op
426 #define GENERIC_ARITH_UNARY_FUNCTION ushort_arith_unary_op
427 #define GENERIC_BIT_OPERATIONS
428 #define GENERIC_TYPE unsigned short
429 #define GENERIC_TYPE_IS_UNSIGNED
430 #define ABS_FUNCTION(x) (x)
431 #define SIGN_FUNCTION(x) (((x) > 0) ? 1 : 0)
432 #define CMP_FUNCTION ushort_cmp_function
433 #define TO_BINARY_FUNCTION ushort_to_binary
434 #include "slarith.inc"
435 #endif /* SHORT_IS_NOT_INT */
436
_pSLarith_get_precedence(SLtype type)437 int _pSLarith_get_precedence (SLtype type)
438 {
439 if ((type < SLANG_CHAR_TYPE) || (type > MAX_SLARITH_TYPE))
440 return -1;
441
442 type = Alias_Map[TYPE_TO_TABLE_INDEX(type)];
443 return type - SLANG_CHAR_TYPE;
444 }
445
_pSLarith_promote_type(SLtype t)446 SLtype _pSLarith_promote_type (SLtype t)
447 {
448 t = Alias_Map[TYPE_TO_TABLE_INDEX(t)];
449
450 switch (t)
451 {
452 case SLANG_INT_TYPE:
453 case SLANG_UINT_TYPE:
454 case SLANG_LONG_TYPE:
455 case SLANG_ULONG_TYPE:
456 #ifdef HAVE_LONG_LONG
457 case SLANG_LLONG_TYPE:
458 case SLANG_ULLONG_TYPE:
459 #endif
460 case SLANG_FLOAT_TYPE:
461 case SLANG_DOUBLE_TYPE:
462 break;
463
464 case SLANG_USHORT_TYPE:
465 #if SHORT_IS_INT
466 t = SLANG_UINT_TYPE;
467 break;
468 #endif
469 /* drop */
470 case SLANG_CHAR_TYPE:
471 case SLANG_UCHAR_TYPE:
472 case SLANG_SHORT_TYPE:
473 default:
474 t = SLANG_INT_TYPE;
475 }
476
477 return t;
478 }
479
promote_to_common_type(SLtype a,SLtype b)480 static SLtype promote_to_common_type (SLtype a, SLtype b)
481 {
482 SLtype a1;
483 a1 = _pSLarith_promote_type (a);
484 if (a == b)
485 return a1;
486 b = _pSLarith_promote_type (b);
487
488 return (a1 > b) ? a1 : b;
489 }
490
arith_bin_op_result(int op,SLtype a_type,SLtype b_type,SLtype * c_type)491 static int arith_bin_op_result (int op, SLtype a_type, SLtype b_type,
492 SLtype *c_type)
493 {
494 switch (op)
495 {
496 case SLANG_EQ:
497 case SLANG_NE:
498 case SLANG_GT:
499 case SLANG_GE:
500 case SLANG_LT:
501 case SLANG_LE:
502 case SLANG_OR:
503 case SLANG_AND:
504 *c_type = SLANG_CHAR_TYPE;
505 return 1;
506 #if SLANG_HAS_FLOAT
507 case SLANG_POW:
508 if (SLANG_FLOAT_TYPE == promote_to_common_type (a_type, b_type))
509 *c_type = SLANG_FLOAT_TYPE;
510 else
511 *c_type = SLANG_DOUBLE_TYPE;
512 return 1;
513 #endif
514 case SLANG_BAND:
515 case SLANG_BXOR:
516 case SLANG_BOR:
517 case SLANG_SHL:
518 case SLANG_SHR:
519 /* The bit-level operations are defined just for integer types */
520 if ((0 == IS_INTEGER_TYPE (a_type))
521 || (0 == IS_INTEGER_TYPE(b_type)))
522 return 0;
523 break;
524
525 default:
526 break;
527 }
528
529 *c_type = promote_to_common_type (a_type, b_type);
530 return 1;
531 }
532
533 typedef int (*Bin_Fun_Type) (int,
534 SLtype, VOID_STAR, SLuindex_Type,
535 SLtype, VOID_STAR, SLuindex_Type,
536 VOID_STAR);
537
538 /* This array of functions must be indexed by precedence after arithmetic
539 * promotions.
540 */
541 static Bin_Fun_Type Bin_Fun_Map [MAX_ARITHMETIC_TYPES] =
542 {
543 NULL, /* char */
544 NULL, /* uchar */
545 NULL, /* short */
546 NULL, /* ushort */
547 int_int_bin_op, /* int */
548 uint_uint_bin_op, /* uint */
549 long_long_bin_op, /* long */
550 ulong_ulong_bin_op, /* ulong */
551 #ifdef HAVE_LONG_LONG
552 llong_llong_bin_op, /* llong */
553 ullong_ullong_bin_op, /* ullong */
554 #else
555 NULL, NULL,
556 #endif
557 float_float_bin_op, /* float */
558 double_double_bin_op /* double */
559 };
560
arith_bin_op(int op,SLtype a_type,VOID_STAR ap,SLuindex_Type na,SLtype b_type,VOID_STAR bp,SLuindex_Type nb,VOID_STAR cp)561 static int arith_bin_op (int op,
562 SLtype a_type, VOID_STAR ap, SLuindex_Type na,
563 SLtype b_type, VOID_STAR bp, SLuindex_Type nb,
564 VOID_STAR cp)
565 {
566 Bin_Fun_Type binfun;
567 int c_indx;
568 SLtype c_type;
569
570 if ((a_type == b_type)
571 && ((a_type == SLANG_CHAR_TYPE) || (a_type == SLANG_UCHAR_TYPE)))
572 {
573 switch (op)
574 {
575 case SLANG_EQ:
576 case SLANG_NE:
577 case SLANG_AND:
578 case SLANG_OR:
579 return char_char_arith_bin_op (op, a_type, ap, na, b_type, bp, nb, cp);
580 }
581 }
582
583 c_type = promote_to_common_type (a_type, b_type);
584 c_indx = TYPE_TO_TABLE_INDEX(c_type);
585 binfun = Bin_Fun_Map[c_indx];
586
587 if ((c_type != a_type) || (c_type != b_type))
588 {
589 int ret;
590 int a_indx = TYPE_TO_TABLE_INDEX(a_type);
591 int b_indx = TYPE_TO_TABLE_INDEX(b_type);
592 Convert_Fun_Type af = Binary_Matrix[a_indx][c_indx].convert_function;
593 Convert_Fun_Type bf = Binary_Matrix[b_indx][c_indx].convert_function;
594
595 if ((af != NULL)
596 && (NULL == (ap = (VOID_STAR) (*af) (ap, na))))
597 return -1;
598
599 if ((bf != NULL)
600 && (NULL == (bp = (VOID_STAR) (*bf) (bp, nb))))
601 {
602 if (af != NULL) SLfree ((char *) ap);
603 return -1;
604 }
605
606 ret = (*binfun) (op, a_type, ap, na, b_type, bp, nb, cp);
607 if (af != NULL) SLfree ((char *) ap);
608 if (bf != NULL) SLfree ((char *) bp);
609 return ret;
610 }
611
612 return (*binfun) (op, a_type, ap, na, b_type, bp, nb, cp);
613 }
614
arith_unary_op_result(int op,SLtype a,SLtype * b)615 static int arith_unary_op_result (int op, SLtype a, SLtype *b)
616 {
617 (void) a;
618 switch (op)
619 {
620 default:
621 return 0;
622
623 case SLANG_SQR:
624 case SLANG_MUL2:
625 case SLANG_PLUSPLUS:
626 case SLANG_MINUSMINUS:
627 case SLANG_CHS:
628 case SLANG_ABS:
629 *b = a;
630 break;
631
632 case SLANG_BNOT:
633 if (0 == IS_INTEGER_TYPE(a))
634 return 0;
635 *b = a;
636 break;
637
638 case SLANG_SIGN:
639 *b = SLANG_INT_TYPE;
640 break;
641
642 case SLANG_NOT:
643 case SLANG_ISPOS:
644 case SLANG_ISNEG:
645 case SLANG_ISNONNEG:
646 *b = SLANG_CHAR_TYPE;
647 break;
648 }
649 return 1;
650 }
651
integer_pop(SLtype type,VOID_STAR ptr)652 static int integer_pop (SLtype type, VOID_STAR ptr)
653 {
654 SLang_Object_Type obj;
655 int i, j;
656 void (*f)(VOID_STAR, VOID_STAR, unsigned int);
657
658 if (-1 == SLang_pop (&obj))
659 return -1;
660
661 if (0 == IS_INTEGER_TYPE(obj.o_data_type))
662 {
663 _pSLclass_type_mismatch_error (type, obj.o_data_type);
664 SLang_free_object (&obj);
665 return -1;
666 }
667
668 i = TYPE_TO_TABLE_INDEX(type);
669 j = TYPE_TO_TABLE_INDEX(obj.o_data_type);
670 f = (void (*)(VOID_STAR, VOID_STAR, unsigned int))
671 Binary_Matrix[j][i].copy_function;
672
673 (*f) (ptr, (VOID_STAR)&obj.v, 1);
674
675 return 0;
676 }
677
integer_push(SLtype type,VOID_STAR ptr)678 static int integer_push (SLtype type, VOID_STAR ptr)
679 {
680 SLang_Object_Type obj;
681 int i;
682 void (*f)(VOID_STAR, VOID_STAR, unsigned int);
683
684 i = TYPE_TO_TABLE_INDEX(type);
685 f = (void (*)(VOID_STAR, VOID_STAR, unsigned int))
686 Binary_Matrix[i][i].copy_function;
687
688 obj.o_data_type = type;
689
690 (*f) ((VOID_STAR)&obj.v, ptr, 1);
691
692 return SLang_push (&obj);
693 }
694
SLang_pop_char(char * i)695 int SLang_pop_char (char *i)
696 {
697 return integer_pop (SLANG_CHAR_TYPE, (VOID_STAR) i);
698 }
699
SLang_pop_uchar(unsigned char * i)700 int SLang_pop_uchar (unsigned char *i)
701 {
702 return integer_pop (SLANG_UCHAR_TYPE, (VOID_STAR) i);
703 }
704
SLang_pop_short(short * i)705 int SLang_pop_short (short *i)
706 {
707 return integer_pop (_pSLANG_SHORT_TYPE, (VOID_STAR) i);
708 }
709
SLang_pop_ushort(unsigned short * i)710 int SLang_pop_ushort (unsigned short *i)
711 {
712 return integer_pop (_pSLANG_USHORT_TYPE, (VOID_STAR) i);
713 }
714
SLang_pop_long(long * i)715 int SLang_pop_long (long *i)
716 {
717 return integer_pop (_pSLANG_LONG_TYPE, (VOID_STAR) i);
718 }
719
SLang_pop_ulong(unsigned long * i)720 int SLang_pop_ulong (unsigned long *i)
721 {
722 return integer_pop (_pSLANG_ULONG_TYPE, (VOID_STAR) i);
723 }
724
725 #ifdef HAVE_LONG_LONG
726 #if LLONG_IS_NOT_LONG
llong_byte_code_destroy(SLtype unused,VOID_STAR ptr)727 static void llong_byte_code_destroy (SLtype unused, VOID_STAR ptr)
728 {
729 (void) unused;
730 SLfree (*(char **) ptr);
731 }
732 #endif
SLang_pop_long_long(long long * i)733 int SLang_pop_long_long (long long *i)
734 {
735 return integer_pop (_pSLANG_LLONG_TYPE, (VOID_STAR) i);
736 }
737
SLang_pop_ulong_long(unsigned long long * i)738 int SLang_pop_ulong_long (unsigned long long *i)
739 {
740 return integer_pop (_pSLANG_ULLONG_TYPE, (VOID_STAR) i);
741 }
742 #endif
743
SLang_pop_uint(unsigned int * i)744 int SLang_pop_uint (unsigned int *i)
745 {
746 return integer_pop (SLANG_UINT_TYPE, (VOID_STAR) i);
747 }
748
749 /* int _pSLang_pop_int16 (_pSLint16_Type *i) {return integer_pop (_pSLANG_INT16_TYPE, i);} */
750 /* int _pSLang_pop_uint16 (_pSLuint16_Type *i) {return integer_pop (_pSLANG_UINT16_TYPE, i);} */
751 /* int _pSLang_pop_int32 (_pSLint32_Type *i) {return integer_pop (_pSLANG_INT32_TYPE, i);} */
752 /* int _pSLang_pop_uint32 (_pSLuint32_Type *i) {return integer_pop (_pSLANG_UINT32_TYPE, i);} */
753 #if _pSLANG_INT64_TYPE
_pSLang_pop_int64(_pSLint64_Type * i)754 int _pSLang_pop_int64(_pSLint64_Type *i) {return integer_pop (_pSLANG_INT64_TYPE, i);}
_pSLang_pop_uint64(_pSLuint64_Type * i)755 int _pSLang_pop_uint64 (_pSLuint64_Type *i) {return integer_pop (_pSLANG_UINT64_TYPE, i);}
756 #endif
757
758 #define MK_PUSH_INTXX(fname_, ctype_, stype_, field_) \
759 int fname_ (ctype_ i) \
760 { \
761 SLang_Object_Type obj; \
762 obj.o_data_type = stype_; \
763 obj.v.field_ = i; \
764 return SLang_push (&obj); \
765 }
766
767 /* MK_PUSH_INTXX(_pSLang_push_int16, _pSLint16_Type, _pSLANG_INT16_TYPE, int16_val) */
768 /* MK_PUSH_INTXX(_pSLang_push_uint16, _pSLuint16_Type, _pSLANG_UINT16_TYPE, uint16_val) */
769 /* MK_PUSH_INTXX(_pSLang_push_int32, _pSLint32_Type, _pSLANG_INT32_TYPE, int32_val) */
770 /* MK_PUSH_INTXX(_pSLang_push_uint32, _pSLuint32_Type, _pSLANG_UINT32_TYPE, uint32_val) */
771 #if _pSLANG_INT64_TYPE
772 /* MK_PUSH_INTXX(_pSLang_push_int64, _pSLint64_Type, _pSLANG_INT64_TYPE, int64_val) */
773 /* MK_PUSH_INTXX(_pSLang_push_uint64, _pSLuint64_Type, _pSLANG_UINT64_TYPE, uint64_val) */
774 #endif
775
SLang_push_int(int i)776 int SLang_push_int (int i)
777 {
778 return SLclass_push_int_obj (SLANG_INT_TYPE, i);
779 }
SLang_push_uint(unsigned int i)780 int SLang_push_uint (unsigned int i)
781 {
782 return SLclass_push_int_obj (SLANG_UINT_TYPE, (int) i);
783 }
SLang_push_char(char i)784 int SLang_push_char (char i)
785 {
786 return SLclass_push_char_obj (SLANG_CHAR_TYPE, i);
787 }
788
SLang_push_uchar(unsigned char i)789 int SLang_push_uchar (unsigned char i)
790 {
791 return SLclass_push_char_obj (SLANG_UCHAR_TYPE, (char) i);
792 }
SLang_push_short(short i)793 int SLang_push_short (short i)
794 {
795 return SLclass_push_short_obj (_pSLANG_SHORT_TYPE, i);
796 }
SLang_push_ushort(unsigned short i)797 int SLang_push_ushort (unsigned short i)
798 {
799 return SLclass_push_short_obj (_pSLANG_USHORT_TYPE, (unsigned short) i);
800 }
SLang_push_long(long i)801 int SLang_push_long (long i)
802 {
803 return SLclass_push_long_obj (_pSLANG_LONG_TYPE, i);
804 }
SLang_push_ulong(unsigned long i)805 int SLang_push_ulong (unsigned long i)
806 {
807 return SLclass_push_long_obj (_pSLANG_ULONG_TYPE, (long) i);
808 }
809
810 #ifdef HAVE_LONG_LONG
SLang_push_long_long(long long i)811 int SLang_push_long_long (long long i)
812 {
813 return SLclass_push_llong_obj (_pSLANG_LLONG_TYPE, i);
814 }
SLang_push_ulong_long(unsigned long long i)815 int SLang_push_ulong_long (unsigned long long i)
816 {
817 return SLclass_push_llong_obj (_pSLANG_ULLONG_TYPE, (long long) i);
818 }
819 #endif
820
SLang_pop_strlen_type(SLstrlen_Type * ip)821 int SLang_pop_strlen_type (SLstrlen_Type *ip)
822 {
823 #if SLANG_STRLEN_TYPE == SLANG_UINT_TYPE
824 return SLang_pop_uint (ip);
825 #else
826 return SLang_pop_ulong (ip);
827 #endif
828 }
SLang_push_strlen_type(SLstrlen_Type i)829 int SLang_push_strlen_type (SLstrlen_Type i)
830 {
831 #if SLANG_STRLEN_TYPE == SLANG_UINT_TYPE
832 return SLang_push_uint (i);
833 #else
834 return SLang_push_ulong (i);
835 #endif
836 }
837
838 _INLINE_
_pSLarith_typecast(SLtype a_type,VOID_STAR ap,SLuindex_Type na,SLtype b_type,VOID_STAR bp)839 int _pSLarith_typecast (SLtype a_type, VOID_STAR ap, SLuindex_Type na,
840 SLtype b_type, VOID_STAR bp)
841 {
842 int i, j;
843
844 void (*copy)(VOID_STAR, VOID_STAR, SLuindex_Type);
845
846 i = TYPE_TO_TABLE_INDEX (a_type);
847 j = TYPE_TO_TABLE_INDEX (b_type);
848
849 copy = (void (*)(VOID_STAR, VOID_STAR, SLuindex_Type))
850 Binary_Matrix[i][j].copy_function;
851
852 (*copy) (bp, ap, na);
853 return 1;
854 }
855
856 #if SLANG_HAS_FLOAT
857
SLang_pop_double(double * x)858 int SLang_pop_double (double *x)
859 {
860 SLang_Object_Type obj;
861
862 if (0 != SLang_pop (&obj))
863 return -1;
864
865 switch (obj.o_data_type)
866 {
867 case SLANG_FLOAT_TYPE:
868 *x = (double) obj.v.float_val;
869 break;
870
871 case SLANG_DOUBLE_TYPE:
872 *x = obj.v.double_val;
873 break;
874
875 case SLANG_INT_TYPE:
876 *x = (double) obj.v.int_val;
877 break;
878
879 case SLANG_CHAR_TYPE: *x = (double) obj.v.char_val; break;
880 case SLANG_UCHAR_TYPE: *x = (double) obj.v.uchar_val; break;
881 case SLANG_SHORT_TYPE: *x = (double) obj.v.short_val; break;
882 case SLANG_USHORT_TYPE: *x = (double) obj.v.ushort_val; break;
883 case SLANG_UINT_TYPE: *x = (double) obj.v.uint_val; break;
884 case SLANG_LONG_TYPE: *x = (double) obj.v.long_val; break;
885 case SLANG_ULONG_TYPE: *x = (double) obj.v.ulong_val; break;
886 #ifdef HAVE_LONG_LONG
887 case SLANG_LLONG_TYPE: *x = (double) obj.v.llong_val; break;
888 case SLANG_ULLONG_TYPE: *x = (double) obj.v.ullong_val; break;
889 #endif
890 default:
891 _pSLclass_type_mismatch_error (SLANG_DOUBLE_TYPE, obj.o_data_type);
892 SLang_free_object (&obj);
893 return -1;
894 }
895 return 0;
896 }
897
SLang_push_double(double x)898 int SLang_push_double (double x)
899 {
900 return SLclass_push_double_obj (SLANG_DOUBLE_TYPE, x);
901 }
902
SLang_pop_float(float * x)903 int SLang_pop_float (float *x)
904 {
905 double d;
906
907 /* Pop it as a double and let the double function do all the typcasting */
908 if (-1 == SLang_pop_double (&d))
909 return -1;
910
911 *x = (float) d;
912 return 0;
913 }
914
SLang_push_float(float f)915 int SLang_push_float (float f)
916 {
917 return SLclass_push_float_obj (SLANG_FLOAT_TYPE, (double) f);
918 }
919
920 /* Double */
double_push(SLtype type,VOID_STAR ptr)921 static int double_push (SLtype type, VOID_STAR ptr)
922 {
923 #if SLANG_OPTIMIZE_FOR_SPEED
924 SLang_Object_Type obj;
925 obj.o_data_type = type;
926 obj.v.double_val = *(double *)ptr;
927 return SLang_push (&obj);
928 #else
929 return SLclass_push_double_obj (type, *(double *) ptr);
930 #endif
931 }
932
double_push_literal(SLtype type,VOID_STAR ptr)933 static int double_push_literal (SLtype type, VOID_STAR ptr)
934 {
935 return SLclass_push_double_obj (type, **(double **)ptr);
936 }
937
double_pop(SLtype unused,VOID_STAR ptr)938 static int double_pop (SLtype unused, VOID_STAR ptr)
939 {
940 (void) unused;
941 return SLang_pop_double ((double *) ptr);
942 }
943
double_byte_code_destroy(SLtype unused,VOID_STAR ptr)944 static void double_byte_code_destroy (SLtype unused, VOID_STAR ptr)
945 {
946 (void) unused;
947 SLfree (*(char **) ptr);
948 }
949
float_push(SLtype unused,VOID_STAR ptr)950 static int float_push (SLtype unused, VOID_STAR ptr)
951 {
952 (void) unused;
953 SLang_push_float (*(float *) ptr);
954 return 0;
955 }
956
float_pop(SLtype unused,VOID_STAR ptr)957 static int float_pop (SLtype unused, VOID_STAR ptr)
958 {
959 (void) unused;
960 return SLang_pop_float ((float *) ptr);
961 }
962
963 #endif /* SLANG_HAS_FLOAT */
964
965 #if SLANG_HAS_FLOAT
966 static char Double_Format[16] = "%g";
967 static char *Double_Format_Ptr = NULL;
968 static unsigned int Double_Format_Expon_Threshold = 6;
969
_pSLset_double_format(SLCONST char * fmt)970 void _pSLset_double_format (SLCONST char *fmt)
971 {
972 /* The only forms accepted by this function are:
973 * "%[+ ][width][.precision][efgS]"
974 */
975 SLCONST char *s = fmt;
976 int precision = 6;
977
978 if (*s++ != '%')
979 return;
980
981 /* 0 or more flags */
982 while ((*s == '#') || (*s == '0') || (*s == '-')
983 || (*s == ' ') || (*s == '+'))
984 s++;
985
986 /* field width */
987 while (isdigit ((unsigned char)*s)) s++;
988
989 /* precision */
990 if (*s == '.')
991 {
992 s++;
993 precision = 0;
994 while (isdigit ((unsigned char)*s))
995 {
996 precision = precision * 10 + (*s - '0');
997 s++;
998 }
999 if (precision < 0)
1000 precision = 6;
1001 }
1002
1003 if ((*s == 'e') || (*s == 'E')
1004 || (*s == 'f') || (*s == 'F')
1005 || (*s == 'g') || (*s == 'G'))
1006 {
1007 s++;
1008 if (*s != 0)
1009 return; /* more junk-- unacceptable */
1010
1011 if (strlen (fmt) >= sizeof (Double_Format))
1012 return;
1013
1014 strcpy (Double_Format, fmt);
1015 Double_Format_Ptr = Double_Format;
1016 return;
1017 }
1018
1019 if ((*s == 'S') || (*s == 's'))
1020 {
1021 s++;
1022 if (*s != 0)
1023 return;
1024
1025 Double_Format_Ptr = NULL;
1026 Double_Format_Expon_Threshold = precision;
1027 return;
1028 }
1029
1030 /* error */
1031 }
1032
_pSLget_double_format(void)1033 SLCONST char *_pSLget_double_format (void)
1034 {
1035 if (Double_Format_Ptr == NULL)
1036 return "%S";
1037
1038 return Double_Format_Ptr;
1039 }
1040
check_decimal(char * buf,unsigned int buflen,double x)1041 static void check_decimal (char *buf, unsigned int buflen, double x)
1042 {
1043 char *b, *bstart = buf, *bufmax = buf + buflen;
1044 unsigned int count = 0, expon;
1045 int has_point = 0;
1046 unsigned int expon_threshold = Double_Format_Expon_Threshold;
1047
1048 if (*bstart == '-')
1049 bstart++;
1050
1051 b = bstart;
1052 while (1)
1053 {
1054 char ch = *b;
1055 if (isdigit ((unsigned char)ch))
1056 {
1057 count++;
1058 b++;
1059 continue;
1060 }
1061 if (ch == 0)
1062 break; /* all digits */
1063
1064 if (ch != '.')
1065 return; /* something else */
1066
1067 /* We are at a decimal point. If expon > 1, then buf does not contain
1068 * an exponential formatted quantity.
1069 */
1070 if (count <= expon_threshold)
1071 return;
1072 /* We have something like: 1234567.123, which we want to
1073 * write as 1.234567123e+6
1074 */
1075 b += strlen(b);
1076 has_point = 1;
1077 break; /* handle below */
1078 }
1079
1080 /* We get here only when *b==0. */
1081
1082 if ((has_point == 0) && (count <= 6))
1083 {
1084 if (b + 3 >= bufmax)
1085 {
1086 sprintf (buf, "%e", x);
1087 return;
1088 }
1089 *b++ = '.';
1090 *b++ = '0';
1091 *b = 0;
1092 return;
1093 }
1094
1095 expon = count-1;
1096
1097 /* Now add on the exponent. First move the decimal point but drop trailing 0s */
1098 while ((count > 1) && (*(b-1) == '0'))
1099 {
1100 b--;
1101 count--;
1102 }
1103
1104 if (count > 1)
1105 {
1106 while (count > 1)
1107 {
1108 bstart[count] = bstart[count-1];
1109 count--;
1110 }
1111 bstart[count] = '.';
1112 if (has_point == 0)
1113 b++;
1114 }
1115
1116 if (EOF == SLsnprintf (b, bufmax-b, "e+%02d", expon))
1117 sprintf (buf, "%e", x);
1118 }
1119
massage_decimal_buffer(char * inbuf,char * buf,unsigned int buflen,unsigned int min_slen)1120 static int massage_decimal_buffer (char *inbuf, char *buf,
1121 unsigned int buflen, unsigned int min_slen)
1122 {
1123 char *s;
1124 unsigned int slen, count;
1125 char c;
1126
1127 slen = strlen(inbuf);
1128 if ((slen < min_slen) || (slen+1 > buflen))
1129 return 0;
1130
1131 s = inbuf + slen;
1132 s -= 2; /* skip last digit */
1133 c = *s;
1134 if ((c != '0') && (c != '9'))
1135 return 0;
1136 s--;
1137
1138 count = 0;
1139 while ((s > inbuf) && (*s == c))
1140 {
1141 count++;
1142 s--;
1143 }
1144
1145 if ((count < 4) || (0 == isdigit ((unsigned char)*s)))
1146 return 0;
1147
1148 if (c == '9')
1149 {
1150 /* e.g., 9.699999999999999 */
1151 slen = s-inbuf;
1152 memcpy (buf, inbuf, slen);
1153 buf[slen] = *s + 1; /* assumes ascii */
1154 buf[slen+1] = 0;
1155 }
1156 else
1157 {
1158 /* 9.300000000000001 */
1159 slen = (s+1)-inbuf;
1160 memcpy (buf, inbuf, slen);
1161 buf[slen] = 0;
1162 }
1163
1164 return 1;
1165 }
1166
massage_double_buffer(char * inbuf,double x)1167 static void massage_double_buffer (char *inbuf, double x)
1168 {
1169 char buf[1024];
1170
1171 if (massage_decimal_buffer (inbuf, buf, sizeof(buf), 16)
1172 && (atof(buf) == x))
1173 strcpy (inbuf, buf);
1174 }
1175
massage_float_buffer(char * inbuf,float x)1176 static void massage_float_buffer (char *inbuf, float x)
1177 {
1178 char buf[1024];
1179
1180 if (massage_decimal_buffer (inbuf, buf, sizeof(buf), 8)
1181 && ((float)atof(buf) == x))
1182 strcpy (inbuf, buf);
1183 }
1184
default_format_double(double x,char * buf,unsigned int buflen)1185 static void default_format_double (double x, char *buf, unsigned int buflen)
1186 {
1187 if (EOF == SLsnprintf (buf, buflen, "%.16g", x))
1188 {
1189 sprintf (buf, "%e", x);
1190 return;
1191 }
1192
1193 if (atof (buf) != x)
1194 {
1195 if (EOF == SLsnprintf (buf, buflen, "%.17g", x))
1196 {
1197 sprintf (buf, "%e", x);
1198 return;
1199 }
1200 }
1201 massage_double_buffer (buf,x);
1202 check_decimal (buf, buflen, x);
1203 }
1204
default_format_float(float x,char * buf,unsigned int buflen)1205 static void default_format_float (float x, char *buf, unsigned int buflen)
1206 {
1207 if (EOF == SLsnprintf (buf, buflen, "%.8g", x))
1208 {
1209 sprintf (buf, "%e", x);
1210 return;
1211 }
1212 if ((float) atof (buf) != x)
1213 {
1214 if (EOF == SLsnprintf (buf, buflen, "%.9g", x))
1215 {
1216 sprintf (buf, "%e", x);
1217 return;
1218 }
1219 }
1220 massage_float_buffer (buf, x);
1221 check_decimal (buf, buflen, x);
1222 }
1223 #endif
1224
1225 #if defined(__GNUC__)
1226 # pragma GCC diagnostic ignored "-Wformat-nonliteral"
1227 #endif
arith_string(SLtype type,VOID_STAR v)1228 static char *arith_string (SLtype type, VOID_STAR v)
1229 {
1230 char buf [1024];
1231 char *s;
1232
1233 s = buf;
1234
1235 switch (type)
1236 {
1237 default:
1238 s = (char *) SLclass_get_datatype_name (type);
1239 break;
1240
1241 case SLANG_CHAR_TYPE:
1242 sprintf (s, "%d", *(signed char *) v);
1243 break;
1244 case SLANG_UCHAR_TYPE:
1245 sprintf (s, "%u", *(unsigned char *) v);
1246 break;
1247 case SLANG_SHORT_TYPE:
1248 sprintf (s, "%d", *(short *) v);
1249 break;
1250 case SLANG_USHORT_TYPE:
1251 sprintf (s, "%u", *(unsigned short *) v);
1252 break;
1253 case SLANG_INT_TYPE:
1254 sprintf (s, "%d", *(int *) v);
1255 break;
1256 case SLANG_UINT_TYPE:
1257 sprintf (s, "%u", *(unsigned int *) v);
1258 break;
1259 case SLANG_LONG_TYPE:
1260 sprintf (s, "%ld", *(long *) v);
1261 break;
1262 case SLANG_ULONG_TYPE:
1263 sprintf (s, "%lu", *(unsigned long *) v);
1264 break;
1265 #ifdef HAVE_LONG_LONG
1266 case SLANG_LLONG_TYPE:
1267 sprintf (s, SLFMT_LLD, *(long long *) v);
1268 break;
1269 case SLANG_ULLONG_TYPE:
1270 sprintf (s, SLFMT_LLU, *(unsigned long long *) v);
1271 break;
1272 #endif
1273 #if SLANG_HAS_FLOAT
1274 case SLANG_FLOAT_TYPE:
1275 if (Double_Format_Ptr == NULL)
1276 default_format_float (*(float *)v, buf, sizeof(buf));
1277 else if (EOF == SLsnprintf (buf, sizeof (buf), Double_Format, *(float *) v))
1278 sprintf (s, "%e", *(float *) v);
1279 break;
1280 case SLANG_DOUBLE_TYPE:
1281 if (Double_Format_Ptr == NULL)
1282 default_format_double (*(double *)v, buf, sizeof(buf));
1283 else if (EOF == SLsnprintf (buf, sizeof (buf), Double_Format, *(double *) v))
1284 sprintf (s, "%e", *(double *) v);
1285 break;
1286 #endif
1287 }
1288
1289 return SLmake_string (s);
1290 }
1291 #if defined(__GNUC__)
1292 # pragma GCC diagnostic warning "-Wformat-nonliteral"
1293 #endif
1294
integer_to_bool(SLtype type,int * t)1295 static int integer_to_bool (SLtype type, int *t)
1296 {
1297 (void) type;
1298 return SLang_pop_integer (t);
1299 }
1300
1301 /* Note that integer literals are all stored in the byte-code as longs. This
1302 * is why it is necessary to use *(long*).
1303 */
push_int_literal(SLtype type,VOID_STAR ptr)1304 static int push_int_literal (SLtype type, VOID_STAR ptr)
1305 {
1306 return SLclass_push_int_obj (type, (int) *(long *) ptr);
1307 }
1308
push_char_literal(SLtype type,VOID_STAR ptr)1309 static int push_char_literal (SLtype type, VOID_STAR ptr)
1310 {
1311 return SLclass_push_char_obj (type, (char) *(long *) ptr);
1312 }
1313
1314 #if SHORT_IS_NOT_INT
push_short_literal(SLtype type,VOID_STAR ptr)1315 static int push_short_literal (SLtype type, VOID_STAR ptr)
1316 {
1317 return SLclass_push_short_obj (type, (short) *(long *) ptr);
1318 }
1319 #endif
1320
1321 #if LONG_IS_NOT_INT
push_long_literal(SLtype type,VOID_STAR ptr)1322 static int push_long_literal (SLtype type, VOID_STAR ptr)
1323 {
1324 return SLclass_push_long_obj (type, *(long *) ptr);
1325 }
1326 #endif
1327
1328 #ifdef HAVE_LONG_LONG
1329 #if LLONG_IS_NOT_LONG
push_llong_literal(SLtype type,VOID_STAR ptr)1330 static int push_llong_literal (SLtype type, VOID_STAR ptr)
1331 {
1332 return SLclass_push_llong_obj (type, **(long long **)ptr);
1333 }
1334 #endif
1335 #endif
1336 typedef struct
1337 {
1338 SLFUTURE_CONST char *name;
1339 SLtype data_type;
1340 unsigned int sizeof_type;
1341 int (*unary_fun)(int, SLtype, VOID_STAR, SLuindex_Type, VOID_STAR);
1342 int (*push_literal) (SLtype, VOID_STAR);
1343 void (*byte_code_destroy)(SLtype, VOID_STAR);
1344 int (*cmp_fun) (SLtype, VOID_STAR, VOID_STAR, int *);
1345 }
1346 Integer_Info_Type;
1347
1348 #ifdef HAVE_LONG_LONG
1349 # define NUM_INTEGER_TYPES 10
1350 #else
1351 # define NUM_INTEGER_TYPES 8
1352 #endif
1353 static Integer_Info_Type Integer_Types [NUM_INTEGER_TYPES] =
1354 {
1355 {"Char_Type", SLANG_CHAR_TYPE, sizeof (char), char_unary_op, push_char_literal, NULL, char_cmp_function},
1356 {"UChar_Type", SLANG_UCHAR_TYPE, sizeof (unsigned char), uchar_unary_op, push_char_literal, NULL, uchar_cmp_function},
1357 #if SHORT_IS_NOT_INT
1358 {"Short_Type", SLANG_SHORT_TYPE, sizeof (short), short_unary_op, push_short_literal, NULL, short_cmp_function},
1359 {"UShort_Type", SLANG_USHORT_TYPE, sizeof (unsigned short), ushort_unary_op, push_short_literal, NULL, ushort_cmp_function},
1360 #else
1361 {NULL, SLANG_SHORT_TYPE, 0, NULL, NULL, NULL, NULL},
1362 {NULL, SLANG_USHORT_TYPE, 0, NULL, NULL, NULL, NULL},
1363 #endif
1364
1365 {"Integer_Type", SLANG_INT_TYPE, sizeof (int), int_unary_op, push_int_literal, NULL, int_cmp_function},
1366 {"UInteger_Type", SLANG_UINT_TYPE, sizeof (unsigned int), uint_unary_op, push_int_literal, NULL, uint_cmp_function},
1367
1368 #if LONG_IS_NOT_INT
1369 {"Long_Type", SLANG_LONG_TYPE, sizeof (long), long_unary_op, push_long_literal, NULL, long_cmp_function},
1370 {"ULong_Type", SLANG_ULONG_TYPE, sizeof (unsigned long), ulong_unary_op, push_long_literal, NULL, ulong_cmp_function},
1371 #else
1372 {NULL, SLANG_LONG_TYPE, 0, NULL, NULL, NULL, NULL},
1373 {NULL, SLANG_ULONG_TYPE, 0, NULL, NULL, NULL, NULL},
1374 #endif
1375 #ifdef HAVE_LONG_LONG
1376 # if LLONG_IS_NOT_LONG
1377 {"LLong_Type", SLANG_LLONG_TYPE, sizeof (long long), llong_unary_op, push_llong_literal, llong_byte_code_destroy, llong_cmp_function},
1378 {"ULLong_Type", SLANG_ULLONG_TYPE, sizeof (unsigned long long), ullong_unary_op, push_llong_literal, llong_byte_code_destroy, ullong_cmp_function},
1379 # else
1380 {NULL, SLANG_LLONG_TYPE, 0, NULL, NULL, NULL, NULL},
1381 {NULL, SLANG_ULLONG_TYPE, 0, NULL, NULL, NULL, NULL},
1382 # endif
1383 #endif
1384 };
1385
_pSLformat_as_binary(unsigned int min_num_bits,int use_binary_prefix)1386 int _pSLformat_as_binary (unsigned int min_num_bits, int use_binary_prefix)
1387 {
1388 #ifdef HAVE_LONG_LONG
1389 char buf [2*8*SIZEOF_LONG_LONG];
1390 #else
1391 char buf [2*8*SIZEOF_LONG];
1392 #endif
1393 char *bufp;
1394 int ret;
1395 unsigned int buflen;
1396
1397 bufp = buf;
1398 buflen = sizeof(buf);
1399 if (use_binary_prefix)
1400 {
1401 *bufp++ = '0';
1402 *bufp++ = 'b';
1403 buflen -= 2;
1404 }
1405
1406 switch (SLang_peek_at_stack ())
1407 {
1408 default:
1409 case SLANG_INT_TYPE:
1410 case SLANG_UINT_TYPE:
1411 {
1412 unsigned int u;
1413 if (-1 == SLang_pop_uint (&u))
1414 return -1;
1415 ret = uint_to_binary (u, bufp, buflen, min_num_bits);
1416 }
1417 break;
1418
1419 case SLANG_CHAR_TYPE:
1420 case SLANG_UCHAR_TYPE:
1421 {
1422 unsigned char u;
1423 if (-1 == SLang_pop_uchar (&u))
1424 return -1;
1425 ret = uchar_to_binary (u, bufp, buflen, min_num_bits);
1426 }
1427 break;
1428
1429 case SLANG_SHORT_TYPE:
1430 case SLANG_USHORT_TYPE:
1431 {
1432 unsigned short u;
1433 if (-1 == SLang_pop_ushort (&u))
1434 return -1;
1435 ret = ushort_to_binary (u, bufp, buflen, min_num_bits);
1436 }
1437 break;
1438
1439 case SLANG_LONG_TYPE:
1440 case SLANG_ULONG_TYPE:
1441 {
1442 unsigned long u;
1443 if (-1 == SLang_pop_ulong (&u))
1444 return -1;
1445 ret = ulong_to_binary (u, bufp, buflen, min_num_bits);
1446 }
1447 break;
1448
1449 #ifdef HAVE_LONG_LONG
1450 case SLANG_LLONG_TYPE:
1451 case SLANG_ULLONG_TYPE:
1452 {
1453 unsigned long long u;
1454 if (-1 == SLang_pop_ulong_long (&u))
1455 return -1;
1456 ret = ullong_to_binary (u, bufp, buflen, min_num_bits);
1457 }
1458 break;
1459 #endif
1460 }
1461 if (ret == -1)
1462 {
1463 SLang_verror (SL_INTERNAL_ERROR, "Buffer is not large enough for the binary representations");
1464 return -1;
1465 }
1466
1467 (void) SLang_push_string (buf);
1468 return 0;
1469 }
1470
1471 #if 0
1472 static void to_binary_string_intrin (void)
1473 {
1474 unsigned int min_num_bits = 0;
1475
1476 if (SLang_Num_Function_Args == 2)
1477 {
1478 int n;
1479 if (-1 == SLang_pop_int (&n))
1480 return;
1481 if (n > 0)
1482 min_num_bits = (unsigned int) n;
1483 }
1484
1485 (void) _pSLformat_as_binary (min_num_bits, 0);
1486 }
1487 #endif
create_synonyms(void)1488 static int create_synonyms (void)
1489 {
1490 static SLFUTURE_CONST char *names[8] =
1491 {
1492 "Int16_Type", "UInt16_Type", "Int32_Type", "UInt32_Type",
1493 "Int64_Type", "UInt64_Type",
1494 "Float32_Type", "Float64_Type"
1495 };
1496 int types[8];
1497 unsigned int i;
1498
1499 memset ((char *) types, 0, sizeof (types));
1500 /* The assumption is that sizeof(unsigned X) == sizeof (X) */
1501 types[0] = _pSLANG_INT16_TYPE;
1502 types[1] = _pSLANG_UINT16_TYPE;
1503 types[2] = _pSLANG_INT32_TYPE;
1504 types[3] = _pSLANG_UINT32_TYPE;
1505 types[4] = _pSLANG_INT64_TYPE;
1506 types[5] = _pSLANG_UINT64_TYPE;
1507
1508 #if SLANG_HAS_FLOAT
1509
1510 #if SIZEOF_FLOAT == 4
1511 types[6] = SLANG_FLOAT_TYPE;
1512 #else
1513 # if SIZEOF_DOUBLE == 4
1514 types[6] = SLANG_DOUBLE_TYPE;
1515 # endif
1516 #endif
1517 #if SIZEOF_FLOAT == 8
1518 types[7] = SLANG_FLOAT_TYPE;
1519 #else
1520 # if SIZEOF_DOUBLE == 8
1521 types[7] = SLANG_DOUBLE_TYPE;
1522 # endif
1523 #endif
1524
1525 #endif
1526
1527 if ((-1 == SLclass_create_synonym ("Int_Type", SLANG_INT_TYPE))
1528 || (-1 == SLclass_create_synonym ("UInt_Type", SLANG_UINT_TYPE)))
1529 return -1;
1530
1531 for (i = 0; i < 8; i++)
1532 {
1533 if (types[i] == 0) continue;
1534
1535 if (-1 == SLclass_create_synonym (names[i], types[i]))
1536 return -1;
1537 }
1538
1539 for (i = 0; i < MAX_ARITHMETIC_TYPES; i++)
1540 {
1541 Alias_Map[i] = TABLE_INDEX_TO_TYPE(i);
1542 }
1543 #if SHORT_IS_INT
1544 Alias_Map [TYPE_TO_TABLE_INDEX(SLANG_SHORT_TYPE)] = SLANG_INT_TYPE;
1545 Alias_Map [TYPE_TO_TABLE_INDEX(SLANG_USHORT_TYPE)] = SLANG_UINT_TYPE;
1546 if ((-1 == SLclass_create_synonym ("Short_Type", SLANG_INT_TYPE))
1547 || (-1 == SLclass_create_synonym ("UShort_Type", SLANG_UINT_TYPE))
1548 || (-1 == _pSLclass_copy_class (SLANG_SHORT_TYPE, SLANG_INT_TYPE))
1549 || (-1 == _pSLclass_copy_class (SLANG_USHORT_TYPE, SLANG_UINT_TYPE)))
1550 return -1;
1551 #endif
1552 #if LONG_IS_INT
1553 Alias_Map [TYPE_TO_TABLE_INDEX(SLANG_LONG_TYPE)] = SLANG_INT_TYPE;
1554 Alias_Map [TYPE_TO_TABLE_INDEX(SLANG_ULONG_TYPE)] = SLANG_UINT_TYPE;
1555 if ((-1 == SLclass_create_synonym ("Long_Type", SLANG_INT_TYPE))
1556 || (-1 == SLclass_create_synonym ("ULong_Type", SLANG_UINT_TYPE))
1557 || (-1 == _pSLclass_copy_class (SLANG_LONG_TYPE, SLANG_INT_TYPE))
1558 || (-1 == _pSLclass_copy_class (SLANG_ULONG_TYPE, SLANG_UINT_TYPE)))
1559 return -1;
1560 #endif
1561 #if LLONG_IS_LONG
1562 Alias_Map [TYPE_TO_TABLE_INDEX(SLANG_LLONG_TYPE)] = _pSLANG_LONG_TYPE;
1563 Alias_Map [TYPE_TO_TABLE_INDEX(SLANG_ULLONG_TYPE)] = _pSLANG_ULONG_TYPE;
1564 if ((-1 == SLclass_create_synonym ("LLong_Type", _pSLANG_LONG_TYPE))
1565 || (-1 == SLclass_create_synonym ("ULLong_Type", _pSLANG_ULONG_TYPE))
1566 || (-1 == _pSLclass_copy_class (SLANG_LLONG_TYPE, _pSLANG_LONG_TYPE))
1567 || (-1 == _pSLclass_copy_class (SLANG_ULLONG_TYPE, _pSLANG_ULONG_TYPE)))
1568 return -1;
1569 #endif
1570
1571 return 0;
1572 }
1573
1574 static SLang_Arith_Unary_Type Unary_Table [] =
1575 {
1576 MAKE_ARITH_UNARY("abs", SLANG_ABS),
1577 MAKE_ARITH_UNARY("sign", SLANG_SIGN),
1578 MAKE_ARITH_UNARY("sqr", SLANG_SQR),
1579 MAKE_ARITH_UNARY("mul2", SLANG_MUL2),
1580 MAKE_ARITH_UNARY("chs", SLANG_CHS),
1581 MAKE_ARITH_UNARY("_ispos", SLANG_ISPOS),
1582 MAKE_ARITH_UNARY("_isneg", SLANG_ISNEG),
1583 MAKE_ARITH_UNARY("_isnonneg", SLANG_ISNONNEG),
1584 SLANG_END_ARITH_UNARY_TABLE
1585 };
1586
1587 static SLang_Arith_Binary_Type Binary_Table [] =
1588 {
1589 MAKE_ARITH_BINARY("_op_plus", SLANG_PLUS),
1590 MAKE_ARITH_BINARY("_op_minus", SLANG_MINUS),
1591 MAKE_ARITH_BINARY("_op_times", SLANG_TIMES),
1592 MAKE_ARITH_BINARY("_op_divide", SLANG_DIVIDE),
1593 MAKE_ARITH_BINARY("_op_eqs", SLANG_EQ),
1594 MAKE_ARITH_BINARY("_op_neqs", SLANG_NE),
1595 MAKE_ARITH_BINARY("_op_gt", SLANG_GT),
1596 MAKE_ARITH_BINARY("_op_ge", SLANG_GE),
1597 MAKE_ARITH_BINARY("_op_lt", SLANG_LT),
1598 MAKE_ARITH_BINARY("_op_le", SLANG_LE),
1599 MAKE_ARITH_BINARY("_op_pow", SLANG_POW),
1600 MAKE_ARITH_BINARY("_op_or", SLANG_OR),
1601 MAKE_ARITH_BINARY("_op_and", SLANG_AND),
1602 MAKE_ARITH_BINARY("_op_band", SLANG_BAND),
1603 MAKE_ARITH_BINARY("_op_bor", SLANG_BOR),
1604 MAKE_ARITH_BINARY("_op_xor", SLANG_BXOR),
1605 MAKE_ARITH_BINARY("_op_shl", SLANG_SHL),
1606 MAKE_ARITH_BINARY("_op_shr", SLANG_SHR),
1607 MAKE_ARITH_BINARY("_op_mod", SLANG_MOD),
1608 SLANG_END_ARITH_BINARY_TABLE
1609 };
1610
1611 static SLang_Intrin_Fun_Type Intrinsic_Table [] =
1612 {
1613 #if 0 /* need to think of a better name */
1614 MAKE_INTRINSIC_0("to_binary_string", to_binary_string_intrin, SLANG_VOID_TYPE),
1615 #endif
1616 SLANG_END_INTRIN_FUN_TABLE
1617 };
1618
1619 static SLang_IConstant_Type IConst_Table [] =
1620 {
1621 #if defined(SHRT_MIN) && defined(SHRT_MAX)
1622 MAKE_HCONSTANT_T("SHORT_MIN", SHRT_MIN, SLANG_SHORT_TYPE),
1623 MAKE_HCONSTANT_T("SHORT_MAX", SHRT_MAX, SLANG_SHORT_TYPE),
1624 #endif
1625 #if defined(USHRT_MAX)
1626 MAKE_HCONSTANT_T("USHORT_MAX", USHRT_MAX, SLANG_USHORT_TYPE),
1627 #endif
1628 #if defined(INT_MIN) && defined(INT_MAX)
1629 MAKE_ICONSTANT_T("INT_MIN", INT_MIN, SLANG_INT_TYPE),
1630 MAKE_ICONSTANT_T("INT_MAX", INT_MAX, SLANG_INT_TYPE),
1631 #endif
1632 #if defined(UINT_MAX)
1633 MAKE_ICONSTANT_T("UINT_MAX", UINT_MAX, SLANG_UINT_TYPE),
1634 #endif
1635 SLANG_END_ICONST_TABLE
1636 };
1637
1638 static SLang_LConstant_Type LConst_Table [] =
1639 {
1640 #if defined(LONG_MIN) && defined(LONG_MAX)
1641 MAKE_LCONSTANT_T("LONG_MIN", LONG_MIN, _pSLANG_LONG_TYPE),
1642 MAKE_LCONSTANT_T("LONG_MAX", LONG_MAX, _pSLANG_LONG_TYPE),
1643 #endif
1644 #if defined(ULONG_MAX)
1645 MAKE_LCONSTANT_T("ULONG_MAX", ULONG_MAX, _pSLANG_ULONG_TYPE),
1646 #endif
1647 SLANG_END_LCONST_TABLE
1648 };
1649
1650 #ifdef HAVE_LONG_LONG
1651 # ifndef LLONG_MAX
1652 # if (SIZEOF_LONG_LONG == 8)
1653 # define LLONG_MAX 9223372036854775807LL
1654 /* C90 does not have positive constants-- only negated negative ones. Hence,
1655 * LLONG_MIN is -9223372036854775808LL, but 9223372036854775808LL is too big.
1656 */
1657 # define LLONG_MIN (-LLONG_MAX - 1LL)
1658 # define ULLONG_MAX 18446744073709551615ULL
1659 # endif
1660 # endif
1661 static _pSLang_LLConstant_Type LLConst_Table[] =
1662 {
1663 #if defined(LLONG_MIN) && defined(LLONG_MAX)
1664 _pMAKE_LLCONSTANT_T("LLONG_MIN", LLONG_MIN, SLANG_LLONG_TYPE),
1665 _pMAKE_LLCONSTANT_T("LLONG_MAX", LLONG_MAX, SLANG_LLONG_TYPE),
1666 #endif
1667 #if defined(ULLONG_MAX)
1668 _pMAKE_LLCONSTANT_T("ULLONG_MAX", ULLONG_MAX, SLANG_ULLONG_TYPE),
1669 #endif
1670 _pSLANG_END_LLCONST_TABLE
1671 };
1672 #endif
1673
1674 static SLang_FConstant_Type FConst_Table [] =
1675 {
1676 #if defined(FLT_MIN) && defined(FLT_MAX)
1677 MAKE_FCONSTANT("FLOAT_MIN", FLT_MIN),
1678 MAKE_FCONSTANT("FLOAT_MAX", FLT_MAX),
1679 #endif
1680 #if defined(FLT_EPSILON)
1681 MAKE_FCONSTANT("FLOAT_EPSILON", FLT_EPSILON),
1682 #endif
1683 SLANG_END_FCONST_TABLE
1684 };
1685
1686 static SLang_DConstant_Type DConst_Table [] =
1687 {
1688 #if defined(DBL_MIN) && defined(DBL_MAX)
1689 MAKE_DCONSTANT("DOUBLE_MIN", DBL_MIN),
1690 MAKE_DCONSTANT("DOUBLE_MAX", DBL_MAX),
1691 #endif
1692 #if defined(DBL_EPSILON)
1693 MAKE_DCONSTANT("DOUBLE_EPSILON", DBL_EPSILON),
1694 #endif
1695 SLANG_END_DCONST_TABLE
1696 };
1697
compute_inf_an_nan(void)1698 static void compute_inf_an_nan (void)
1699 {
1700 #if SLANG_HAS_FLOAT
1701 volatile double nan_val, inf_val;
1702 # if SLANG_HAS_IEEE_FP
1703 volatile double big;
1704 unsigned int max_loops = 256;
1705
1706 big = 1e16;
1707 inf_val = 1.0;
1708
1709 while (max_loops)
1710 {
1711 max_loops--;
1712 big *= 1e16;
1713 if (inf_val == big)
1714 break;
1715 inf_val = big;
1716 }
1717 if (max_loops == 0)
1718 {
1719 inf_val = DBL_MAX;
1720 nan_val = DBL_MAX;
1721 }
1722 else nan_val = inf_val/inf_val;
1723 # else
1724 inf_val = DBL_MAX;
1725 nan_val = DBL_MAX;
1726 # endif
1727 _pSLang_NaN = nan_val;
1728 _pSLang_Inf = inf_val;
1729 #endif
1730 }
1731
_pSLarith_register_types(void)1732 int _pSLarith_register_types (void)
1733 {
1734 SLang_Class_Type *cl;
1735 SLtype a_type, b_type;
1736 int i, j;
1737
1738 #if defined(HAVE_SETLOCALE) && defined(LC_NUMERIC)
1739 /* make sure decimal point it used --- the parser requires it */
1740 (void) setlocale (LC_NUMERIC, "C");
1741 #endif
1742
1743 for (i = 0; i < NUM_INTEGER_TYPES; i++)
1744 {
1745 Integer_Info_Type *info;
1746
1747 info = Integer_Types + i;
1748
1749 _pSLang_set_arith_type (info->data_type, 1);
1750
1751 if (info->name == NULL)
1752 {
1753 /* This happens when the object is the same size as an integer
1754 * For this case, we really want to copy the integer class.
1755 * We will handle that when the synonym is created.
1756 */
1757 continue;
1758 }
1759
1760 if (NULL == (cl = SLclass_allocate_class (info->name)))
1761 return -1;
1762
1763 (void) SLclass_set_string_function (cl, arith_string);
1764 (void) SLclass_set_push_function (cl, integer_push);
1765 (void) SLclass_set_pop_function (cl, integer_pop);
1766 cl->cl_push_literal = info->push_literal;
1767 cl->cl_to_bool = integer_to_bool;
1768 cl->cl_byte_code_destroy = info->byte_code_destroy;
1769
1770 cl->cl_cmp = info->cmp_fun;
1771
1772 if (-1 == SLclass_register_class (cl, info->data_type, info->sizeof_type,
1773 SLANG_CLASS_TYPE_SCALAR))
1774 return -1;
1775 if (-1 == SLclass_add_unary_op (info->data_type, info->unary_fun, arith_unary_op_result))
1776 return -1;
1777 #if 0
1778 if (-1 == _pSLclass_add_arith_unary_op (info->data_type, info->arith_unary_fun, arith_unary_arith_op_result))
1779 return -1;
1780 #endif
1781 }
1782
1783 #if SLANG_HAS_FLOAT
1784 if (NULL == (cl = SLclass_allocate_class ("Double_Type")))
1785 return -1;
1786 (void) SLclass_set_push_function (cl, double_push);
1787 (void) SLclass_set_pop_function (cl, double_pop);
1788 (void) SLclass_set_string_function (cl, arith_string);
1789 cl->cl_byte_code_destroy = double_byte_code_destroy;
1790 cl->cl_push_literal = double_push_literal;
1791 cl->cl_cmp = double_cmp_function;
1792
1793 if (-1 == SLclass_register_class (cl, SLANG_DOUBLE_TYPE, sizeof (double),
1794 SLANG_CLASS_TYPE_SCALAR))
1795 return -1;
1796 if (-1 == SLclass_add_unary_op (SLANG_DOUBLE_TYPE, double_unary_op, arith_unary_op_result))
1797 return -1;
1798 #if 0
1799 if (-1 == _pSLclass_add_arith_unary_op (SLANG_DOUBLE_TYPE, double_arith_unary_op, arith_unary_op_result))
1800 return -1;
1801 #endif
1802 _pSLang_set_arith_type (SLANG_DOUBLE_TYPE, 2);
1803
1804 if (NULL == (cl = SLclass_allocate_class ("Float_Type")))
1805 return -1;
1806 (void) SLclass_set_string_function (cl, arith_string);
1807 (void) SLclass_set_push_function (cl, float_push);
1808 (void) SLclass_set_pop_function (cl, float_pop);
1809 cl->cl_cmp = float_cmp_function;
1810
1811 if (-1 == SLclass_register_class (cl, SLANG_FLOAT_TYPE, sizeof (float),
1812 SLANG_CLASS_TYPE_SCALAR))
1813 return -1;
1814 if (-1 == SLclass_add_unary_op (SLANG_FLOAT_TYPE, float_unary_op, arith_unary_op_result))
1815 return -1;
1816 #if 0
1817 if (-1 == _pSLclass_add_arith_unary_op (SLANG_FLOAT_TYPE, float_arith_unary_op, arith_unary_op_result))
1818 return -1;
1819 #endif
1820 _pSLang_set_arith_type (SLANG_FLOAT_TYPE, 2);
1821 #endif
1822
1823 if (-1 == create_synonyms ())
1824 return -1;
1825
1826 for (i = 0; i < MAX_ARITHMETIC_TYPES; i++)
1827 {
1828 a_type = _pSLarith_Arith_Types[i];
1829 #if 0
1830 if (Alias_Map[TYPE_TO_TABLE_INDEX(a_type)] != a_type)
1831 continue;
1832 #endif
1833 if (a_type == 0)
1834 continue;
1835
1836 for (j = 0; j < MAX_ARITHMETIC_TYPES; j++)
1837 {
1838 int implicit_ok;
1839
1840 b_type = _pSLarith_Arith_Types[j];
1841 if (b_type == 0)
1842 continue;
1843 /* Allow implicit typecast, except from int to float */
1844 implicit_ok = ((b_type >= SLANG_FLOAT_TYPE)
1845 || (a_type < SLANG_FLOAT_TYPE));
1846
1847 if (-1 == SLclass_add_binary_op (a_type, b_type, arith_bin_op, arith_bin_op_result))
1848 return -1;
1849
1850 if (a_type != b_type)
1851 if (-1 == SLclass_add_typecast (a_type, b_type, _pSLarith_typecast, implicit_ok))
1852 return -1;
1853 }
1854 }
1855
1856 if (-1 == SLadd_intrin_fun_table (Intrinsic_Table, NULL))
1857 return -1;
1858 if (-1 == _pSLadd_arith_unary_table (Unary_Table, NULL))
1859 return -1;
1860 if (-1 == _pSLadd_arith_binary_table (Binary_Table, NULL))
1861 return -1;
1862
1863 if ((-1 == SLadd_iconstant_table (IConst_Table, NULL))
1864 || (-1 == SLadd_lconstant_table (LConst_Table, NULL))
1865 #if SLANG_HAS_FLOAT
1866 || (-1 == SLadd_fconstant_table (FConst_Table, NULL))
1867 || (-1 == SLadd_dconstant_table (DConst_Table, NULL))
1868 #endif
1869 #ifdef HAVE_LONG_LONG
1870 || (-1 == _pSLadd_llconstant_table (LLConst_Table, NULL))
1871 #endif
1872 )
1873 return -1;
1874
1875 compute_inf_an_nan ();
1876
1877 return 0;
1878 }
1879
1880 #if SLANG_OPTIMIZE_FOR_SPEED
1881
promote_objs(SLang_Object_Type * a,SLang_Object_Type * b,SLang_Object_Type * c,SLang_Object_Type * d)1882 static void promote_objs (SLang_Object_Type *a, SLang_Object_Type *b,
1883 SLang_Object_Type *c, SLang_Object_Type *d)
1884 {
1885 SLtype ia, ib, ic, id;
1886 int i, j;
1887 void (*copy)(VOID_STAR, VOID_STAR, unsigned int);
1888
1889 ia = a->o_data_type;
1890 ib = b->o_data_type;
1891
1892 ic = _pSLarith_promote_type (ia);
1893
1894 if (ic == ib) id = ic; /* already promoted */
1895 else id = _pSLarith_promote_type (ib);
1896
1897 i = TYPE_TO_TABLE_INDEX(ic);
1898 j = TYPE_TO_TABLE_INDEX(id);
1899 if (i > j)
1900 {
1901 id = ic;
1902 j = i;
1903 }
1904
1905 c->o_data_type = d->o_data_type = id;
1906
1907 i = TYPE_TO_TABLE_INDEX(ia);
1908 copy = (void (*)(VOID_STAR, VOID_STAR, unsigned int))
1909 Binary_Matrix[i][j].copy_function;
1910 (*copy) ((VOID_STAR) &c->v, (VOID_STAR)&a->v, 1);
1911
1912 i = TYPE_TO_TABLE_INDEX(ib);
1913 copy = (void (*)(VOID_STAR, VOID_STAR, unsigned int))
1914 Binary_Matrix[i][j].copy_function;
1915 (*copy) ((VOID_STAR) &d->v, (VOID_STAR)&b->v, 1);
1916 }
1917
1918 /* Crazy return value: returns 1 if operation not supported by this function,
1919 * 0 if it is and was sucessful, or -1 if something went wrong
1920 */
_pSLarith_bin_op(SLang_Object_Type * oa,SLang_Object_Type * ob,int op)1921 int _pSLarith_bin_op (SLang_Object_Type *oa, SLang_Object_Type *ob, int op)
1922 {
1923 SLtype a_type, b_type;
1924 SLang_Object_Type obj_a, obj_b;
1925
1926 a_type = oa->o_data_type;
1927 b_type = ob->o_data_type;
1928
1929 if (a_type != b_type)
1930 {
1931 /* Handle common cases */
1932 #if SLANG_HAS_FLOAT
1933 if ((a_type == SLANG_INT_TYPE)
1934 && (b_type == SLANG_DOUBLE_TYPE))
1935 return double_double_scalar_bin_op (oa->v.int_val, ob->v.double_val, op);
1936
1937 if ((a_type == SLANG_DOUBLE_TYPE)
1938 && (b_type == SLANG_INT_TYPE))
1939 return double_double_scalar_bin_op (oa->v.double_val, ob->v.int_val, op);
1940 #endif
1941 /* Otherwise do it the hard way */
1942 promote_objs (oa, ob, &obj_a, &obj_b);
1943 oa = &obj_a;
1944 ob = &obj_b;
1945
1946 a_type = oa->o_data_type;
1947 /* b_type = ob->data_type; */
1948 }
1949
1950 switch (a_type)
1951 {
1952 case SLANG_CHAR_TYPE:
1953 return int_int_scalar_bin_op (oa->v.char_val, ob->v.char_val, op);
1954
1955 case SLANG_UCHAR_TYPE:
1956 return int_int_scalar_bin_op (oa->v.uchar_val, ob->v.uchar_val, op);
1957
1958 case SLANG_SHORT_TYPE:
1959 return int_int_scalar_bin_op (oa->v.short_val, ob->v.short_val, op);
1960
1961 case SLANG_USHORT_TYPE:
1962 # if SHORT_IS_INT
1963 return uint_uint_scalar_bin_op (oa->v.ushort_val, ob->v.ushort_val, op);
1964 # else
1965 return int_int_scalar_bin_op ((int)oa->v.ushort_val, (int)ob->v.ushort_val, op);
1966 # endif
1967
1968 #if LONG_IS_INT
1969 case SLANG_LONG_TYPE:
1970 #endif
1971 case SLANG_INT_TYPE:
1972 return int_int_scalar_bin_op (oa->v.int_val, ob->v.int_val, op);
1973
1974 #if LONG_IS_INT
1975 case SLANG_ULONG_TYPE:
1976 #endif
1977 case SLANG_UINT_TYPE:
1978 return uint_uint_scalar_bin_op (oa->v.uint_val, ob->v.uint_val, op);
1979
1980 #if LONG_IS_NOT_INT
1981 case SLANG_LONG_TYPE:
1982 return long_long_scalar_bin_op (oa->v.long_val, ob->v.long_val, op);
1983 case SLANG_ULONG_TYPE:
1984 return ulong_ulong_scalar_bin_op (oa->v.ulong_val, ob->v.ulong_val, op);
1985 #endif
1986 #ifdef HAVE_LONG_LONG
1987 case SLANG_LLONG_TYPE:
1988 return llong_llong_scalar_bin_op (oa->v.llong_val, ob->v.llong_val, op);
1989 case SLANG_ULLONG_TYPE:
1990 return ullong_ullong_scalar_bin_op (oa->v.ullong_val, ob->v.ullong_val, op);
1991 #endif
1992 #if SLANG_HAS_FLOAT
1993 case SLANG_FLOAT_TYPE:
1994 return float_float_scalar_bin_op (oa->v.float_val, ob->v.float_val, op);
1995 case SLANG_DOUBLE_TYPE:
1996 return double_double_scalar_bin_op (oa->v.double_val, ob->v.double_val, op);
1997 #endif
1998 }
1999
2000 return 1;
2001 }
2002 #endif
2003