1 /*
2     $Id: floatobj.c 2593 2021-04-18 13:00:11Z soci $
3 
4     This program is free software; you can redistribute it and/or modify
5     it under the terms of the GNU General Public License as published by
6     the Free Software Foundation; either version 2 of the License, or
7     (at your option) any later version.
8 
9     This program is distributed in the hope that it will be useful,
10     but WITHOUT ANY WARRANTY; without even the implied warranty of
11     MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
12     GNU General Public License for more details.
13 
14     You should have received a copy of the GNU General Public License along
15     with this program; if not, write to the Free Software Foundation, Inc.,
16     51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
17 
18 */
19 #include "floatobj.h"
20 #include <string.h>
21 #include "math.h"
22 #include "error.h"
23 #include "eval.h"
24 #include "variables.h"
25 #include "arguments.h"
26 
27 #include "boolobj.h"
28 #include "codeobj.h"
29 #include "strobj.h"
30 #include "bytesobj.h"
31 #include "intobj.h"
32 #include "bitsobj.h"
33 #include "operobj.h"
34 #include "typeobj.h"
35 #include "noneobj.h"
36 #include "errorobj.h"
37 #include "addressobj.h"
38 #include "functionobj.h"
39 
40 static Type obj;
41 
42 Type *const FLOAT_OBJ = &obj;
43 
float_from_obj(Obj * v1,linepos_t epoint)44 MUST_CHECK Obj *float_from_obj(Obj *v1, linepos_t epoint) {
45     switch (v1->obj->type) {
46     case T_NONE:
47     case T_ERROR:
48     case T_FLOAT: return val_reference(v1);
49     case T_CODE: return float_from_code(Code(v1), epoint);
50     case T_STR: return float_from_str(Str(v1), epoint);
51     case T_BOOL: return float_from_bool(Bool(v1));
52     case T_BYTES: return float_from_bytes(Bytes(v1), epoint);
53     case T_INT: return float_from_int(Int(v1), epoint);
54     case T_BITS: return float_from_bits(Bits(v1), epoint);
55     case T_ADDRESS: return float_from_address(Address(v1), epoint);
56     default: break;
57     }
58     return new_error_conv(v1, FLOAT_OBJ, epoint);
59 }
60 
convert(oper_t op)61 static MUST_CHECK Obj *convert(oper_t op) {
62     return float_from_obj(op->v2, op->epoint2);
63 }
64 
same(const Obj * o1,const Obj * o2)65 static FAST_CALL bool same(const Obj *o1, const Obj *o2) {
66     return o1->obj == o2->obj && Float(o1)->real == Float(o2)->real;
67 }
68 
truth(Obj * o1,Truth_types UNUSED (type),linepos_t UNUSED (epoint))69 static MUST_CHECK Obj *truth(Obj *o1, Truth_types UNUSED(type), linepos_t UNUSED(epoint)) {
70     return truth_reference(Float(o1)->real != 0.0);
71 }
72 
hash(Obj * o1,int * hs,linepos_t UNUSED (epoint))73 static MUST_CHECK Obj *hash(Obj *o1, int *hs, linepos_t UNUSED(epoint)) {
74     double integer, r = Float(o1)->real;
75     int expo;
76     unsigned int h, h1, h2;
77     bool neg = (r < 0.0);
78     if (neg) r = -r;
79 
80     r = modf(frexp(r, &expo) * 2147483648.0, &integer) * 2147483648.0;
81     h1 = (unsigned int)floor(integer);
82     h2 = (unsigned int)floor(r);
83     if (neg) {
84         h1 = ~h1 + 1U;
85         h2 = ~h2 + 1U;
86     }
87     h = (expo < 0) ? ~((unsigned int)-expo) + 1U : (unsigned int)expo;
88     h ^= h1 ^ h2;
89     *hs = h & ((~0U) >> 1);
90     return NULL;
91 }
92 
repr(Obj * o1,linepos_t UNUSED (epoint),size_t maxsize)93 static MUST_CHECK Obj *repr(Obj *o1, linepos_t UNUSED(epoint), size_t maxsize) {
94     Str *v;
95     char line[100];
96     int i = 0;
97     size_t len = (size_t)sprintf(line, "%.10g", Float(o1)->real);
98     while (line[i] != 0 && line[i]!='.' && line[i]!='e' && line[i]!='n' && line[i]!='i') i++;
99     if (line[i] == 0) {line[i++] = '.';line[i++] = '0';len += 2;}
100     if (len > maxsize) return NULL;
101     v = new_str2(len);
102     if (v == NULL) return NULL;
103     v->chars = len;
104     memcpy(v->data, line, len);
105     return Obj(v);
106 }
107 
ival(Obj * o1,ival_t * iv,unsigned int bits,linepos_t epoint)108 static MUST_CHECK Error *ival(Obj *o1, ival_t *iv, unsigned int bits, linepos_t epoint) {
109     double real = floor(Float(o1)->real);
110     Error *v;
111     if (-real >= (double)(~((~(uval_t)0) >> 1)) + 1.0 || real >= (double)((~(uval_t)0) >> 1) + 1.0) {
112         *iv = 0;
113         v = new_error(ERROR_____CANT_IVAL, epoint);
114         v->u.intconv.bits = bits;
115         v->u.intconv.val = val_reference(o1);
116         return v;
117     }
118     *iv = (ival_t)real;
119     if ((((*iv >= 0) ? *iv : (~*iv)) >> (bits - 1)) != 0) {
120         v = new_error(ERROR_____CANT_IVAL, epoint);
121         v->u.intconv.bits = bits;
122         v->u.intconv.val = val_reference(o1);
123         return v;
124     }
125     if (diagnostics.float_round && real != Float(o1)->real) err_msg2(ERROR___FLOAT_ROUND, NULL, epoint);
126     return NULL;
127 }
128 
uval(Obj * o1,uval_t * uv,unsigned int bits,linepos_t epoint)129 static MUST_CHECK Error *uval(Obj *o1, uval_t *uv, unsigned int bits, linepos_t epoint) {
130     double real = floor(Float(o1)->real);
131     Error *v;
132     if (real <= -1.0 || real >= (double)(~(uval_t)0) + 1.0) {
133         v = new_error(real < 0.0 ? ERROR______NOT_UVAL : ERROR_____CANT_UVAL, epoint);
134         v->u.intconv.bits = bits;
135         v->u.intconv.val = val_reference(o1);
136         return v;
137     }
138     *uv = (uval_t)real;
139     if (bits < 8 * sizeof *uv && (*uv >> bits) != 0) {
140         v = new_error(ERROR_____CANT_UVAL, epoint);
141         v->u.intconv.bits = bits;
142         v->u.intconv.val = val_reference(o1);
143         return v;
144     }
145     if (diagnostics.float_round && real != Float(o1)->real) err_msg2(ERROR___FLOAT_ROUND, NULL, epoint);
146     return NULL;
147 }
148 
sign(Obj * o1,linepos_t UNUSED (epoint))149 static MUST_CHECK Obj *sign(Obj *o1, linepos_t UNUSED(epoint)) {
150     double v1 = Float(o1)->real;
151     return val_reference(v1 < 0.0 ? minus1_value : int_value[(v1 > 0.0) ? 1 : 0]);
152 }
153 
function(oper_t op)154 static MUST_CHECK Obj *function(oper_t op) {
155     Float *v1 = Float(op->v2);
156     double r = v1->real;
157     switch (Function(op->v1)->func) {
158     case F_ABS: if (r >= 0.0) return val_reference(Obj(v1)); r = -r; break;
159     case F_TRUNC: r = trunc(r); break;
160     case F_ROUND: r = round(r); break;
161     case F_FLOOR: r = floor(r); break;
162     case F_CEIL: r = ceil(r); break;
163     default: break;
164     }
165     if (op->inplace == Obj(v1)) {
166         v1->real = r;
167         return val_reference(Obj(v1));
168     }
169     return new_float(r);
170 }
171 
float_from_double_inplace(double d,oper_t op)172 static MUST_CHECK Obj *float_from_double_inplace(double d, oper_t op) {
173     if (d == HUGE_VAL || d == -HUGE_VAL || d != d) {
174         return Obj(new_error(ERROR_NUMERIC_OVERF, op->epoint3));
175     }
176     if (op->inplace == op->v1) {
177         Float(op->v1)->real = d;
178         return val_reference(op->v1);
179     }
180     if (op->inplace == op->v2) {
181         Float(op->v2)->real = d;
182         return val_reference(op->v2);
183     }
184     return new_float(d);
185 }
186 
calc1(oper_t op)187 static MUST_CHECK Obj *calc1(oper_t op) {
188     Float *v1 = Float(op->v1);
189     double real = v1->real;
190     switch (op->op) {
191     case O_BANK:
192     case O_HIGHER:
193     case O_LOWER:
194     case O_HWORD:
195     case O_WORD:
196     case O_BSWORD:
197         {
198             uint32_t r;
199             bool neg = (real < 0.0);
200             real = floor(real);
201             if (diagnostics.float_round && real != v1->real) err_msg2(ERROR___FLOAT_ROUND, NULL, op->epoint3);
202             if (neg) real = -real;
203             if (real >= 4294967296.0) real = fmod(real, 4294967296.0);
204             r = (uint32_t)real;
205             return bits_calc1(op->op, neg ? ~r + 1U : r);
206         }
207     case O_INV:
208         return float_from_double_inplace(-0.5 / ((double)((uint32_t)1 << (8 * sizeof(uint32_t) - 1))) - real, op);
209     case O_NEG:
210         return float_from_double_inplace(-real, op);
211     case O_POS:
212         return val_reference(op->v1);
213     case O_STRING:
214         {
215             Obj *o = repr(op->v1, op->epoint, SIZE_MAX);
216             return (o != NULL) ? o : new_error_mem(op->epoint3);
217         }
218     case O_LNOT:
219         if (diagnostics.strict_bool) err_msg_bool_oper(op);
220         return truth_reference(real == 0.0);
221     default: break;
222     }
223     return obj_oper_error(op);
224 }
225 
almost_equal(oper_t op,double a,double b)226 static bool almost_equal(oper_t op, double a, double b) {
227     double aa = fabs(a);
228     double ab = fabs(b);
229     if (fabs(a - b) <= (aa > ab ? ab : aa) * 0.0000000005) {
230         if (diagnostics.float_compare) {
231             if (op->epoint3->line != 0) err_msg2(ERROR_FLOAT_COMPARE, operators[op->op].name, op->epoint3);
232         }
233         return true;
234     }
235     return false;
236 }
237 
bitoper(oper_t op)238 static MUST_CHECK Obj *bitoper(oper_t op) {
239     uint64_t v, v1, v2;
240     bool neg, neg1, neg2;
241     int e, e1, e2;
242     double r, r1, r2;
243 
244     r1 = frexp(Float(op->v1)->real, &e1);
245     neg1 = (r1 < 0.0);
246     if (neg1) r1 = -r1;
247 
248     r2 = frexp(Float(op->v2)->real, &e2);
249     neg2 = (r2 < 0.0);
250     if (neg2) r2 = -r2;
251 
252     if (e1 > e2) {
253         e = e1 - 63;
254         e2 = 63 - (e1 - e2);
255         e1 = 63;
256     } else {
257         e = e2 - 63;
258         e1 = 63 - (e2 - e1);
259         e2 = 63;
260     }
261     v1 = (uint64_t)ldexp(r1, e1);
262     v2 = (uint64_t)ldexp(r2, e2);
263 
264     switch (op->op) {
265     case O_AND:
266         if (neg1) {
267             if (neg2) {
268                 v = ~((~v1 + 1U) & (~v2 + 1U));
269             } else {
270                 v = (~v1 + 1U) & v2;
271             }
272         } else if (neg2) {
273             v = v1 & (~v2 + 1U);
274         } else {
275             v = v1 & v2;
276         }
277         neg = neg1 && neg2;
278         break;
279     case O_OR:
280         if (neg1) {
281             if (neg2) {
282                 v = ~((~v1 + 1U) | (~v2 + 1U));
283             } else {
284                 v = ~((~v1 + 1U) | v2);
285             }
286         } else if (neg2) {
287             v = ~(v1 | (~v2 + 1U));
288         } else {
289             v = v1 | v2;
290         }
291         neg = neg1 || neg2;
292         break;
293     default:
294         if (neg1) {
295             if (neg2) {
296                 v = (~v1 + 1U) ^ (~v2 + 1U);
297             } else {
298                 v = ~((~v1 + 1U) ^ v2);
299             }
300         } else if (neg2) {
301             v = ~(v1 ^ (~v2 + 1U));
302         } else {
303             v = v1 ^ v2;
304         }
305         neg = neg1 != neg2;
306         break;
307     }
308     r = ldexp((double)v, e);
309     return float_from_double_inplace(neg ? -r : r, op);
310 }
311 
calc2_double(oper_t op)312 static MUST_CHECK Obj *calc2_double(oper_t op) {
313     double r, v1 = Float(op->v1)->real, v2 = Float(op->v2)->real;
314     switch (op->op) {
315     case O_CMP: return val_reference((v1 == v2 || almost_equal(op, v1, v2)) ? int_value[0] : (v1 < v2) ? minus1_value : int_value[1]);
316     case O_EQ: return truth_reference(v1 == v2 || almost_equal(op, v1, v2));
317     case O_NE: return truth_reference(v1 != v2 && !almost_equal(op, v1, v2));
318     case O_MIN: return truth_reference(v1 < v2);
319     case O_LT: return truth_reference(v1 < v2 && !almost_equal(op, v1, v2));
320     case O_LE: return truth_reference(v1 <= v2 || almost_equal(op, v1, v2));
321     case O_MAX: return truth_reference(v1 > v2);
322     case O_GT: return truth_reference(v1 > v2 && !almost_equal(op, v1, v2));
323     case O_GE: return truth_reference(v1 >= v2 || almost_equal(op, v1, v2));
324     case O_ADD: return float_from_double_inplace(v1 + v2, op);
325     case O_SUB: return float_from_double_inplace(v1 - v2, op);
326     case O_MUL: return float_from_double_inplace(v1 * v2, op);
327     case O_DIV:
328         if (v2 == 0.0) {
329             return new_error_obj(ERROR_DIVISION_BY_Z, op->v2, op->epoint3);
330         }
331         return float_from_double_inplace(v1 / v2, op);
332     case O_MOD:
333         if (v2 == 0.0) {
334             return new_error_obj(ERROR_DIVISION_BY_Z, op->v2, op->epoint3);
335         }
336         r = fmod(v1, v2);
337         if (r != 0.0 && ((v2 < 0.0) != (r < 0))) r += v2;
338         return float_from_double_inplace(r, op);
339     case O_AND:
340     case O_OR:
341     case O_XOR: return bitoper(op);
342     case O_LSHIFT: return float_from_double_inplace(v1 * pow(2.0, v2), op);
343     case O_RSHIFT: return float_from_double_inplace(v1 * pow(2.0, -v2), op);
344     case O_EXP:
345         if (v1 == 0.0) {
346             if (v2 < 0.0) {
347                 return new_error_obj(ERROR_ZERO_NEGPOWER, op->v2, op->epoint3);
348             }
349             return new_float((v2 == 0.0) ? 1.0 : 0.0);
350         }
351         if (v1 < 0.0 && floor(v2) != v2) {
352             return Obj(new_error(ERROR_NEGFRAC_POWER, op->epoint3));
353         }
354         return float_from_double_inplace(pow(v1, v2), op);
355     default: break;
356     }
357     return obj_oper_error(op);
358 }
359 
float_from_double(double d,linepos_t epoint)360 MUST_CHECK Obj *float_from_double(double d, linepos_t epoint) {
361     if (d == HUGE_VAL || d == -HUGE_VAL || d != d) {
362         return Obj(new_error(ERROR_NUMERIC_OVERF, epoint));
363     }
364     return new_float(d);
365 }
366 
calc2(oper_t op)367 static MUST_CHECK Obj *calc2(oper_t op) {
368     Obj *err, *val;
369     Obj *v2 = op->v2;
370     if (op->op == O_LAND) {
371         if (diagnostics.strict_bool) err_msg_bool_oper(op);
372         return val_reference((Float(op->v1)->real != 0.0) ? v2 : op->v1);
373     }
374     if (op->op == O_LOR) {
375         if (diagnostics.strict_bool) err_msg_bool_oper(op);
376         return val_reference((Float(op->v1)->real != 0.0) ? op->v1 : v2);
377     }
378     switch (v2->obj->type) {
379     case T_FLOAT: return calc2_double(op);
380     case T_BOOL:
381         if (diagnostics.strict_bool) err_msg_bool_oper(op);
382         /* fall through */
383     case T_INT:
384     case T_BITS:
385     case T_STR:
386     case T_BYTES:
387         if (op->op == O_LSHIFT || op->op == O_RSHIFT) {
388             ival_t shift;
389             err = Obj(v2->obj->ival(v2, &shift, 8 * sizeof shift, op->epoint2));
390             if (err != NULL) return err;
391             if (shift == 0) return val_reference(op->v1);
392             if (op->op == O_RSHIFT) shift = -shift;
393             return float_from_double_inplace(ldexp(Float(op->v1)->real, shift), op);
394         }
395         err = float_from_obj(v2, op->epoint2);
396         if (err->obj != FLOAT_OBJ) return err;
397         op->v2 = err;
398         op->inplace = (err->refcount == 1) ? err : NULL;
399         val = calc2_double(op);
400         if (val->obj == ERROR_OBJ) error_obj_update(Error(val), err, v2);
401         val_destroy(err);
402         return val;
403     default:
404         if (op->op != O_MEMBER && op->op != O_X) {
405             return v2->obj->rcalc2(op);
406         }
407         if (v2 == none_value || v2->obj == ERROR_OBJ) return val_reference(v2);
408     }
409     return obj_oper_error(op);
410 }
411 
rcalc2(oper_t op)412 static MUST_CHECK Obj *rcalc2(oper_t op) {
413     Obj *err, *val;
414     Obj *v1 = op->v1;
415     switch (v1->obj->type) {
416     case T_BOOL:
417         if (diagnostics.strict_bool) err_msg_bool_oper(op);
418         /* fall through */
419     case T_INT:
420     case T_BITS:
421         err = float_from_obj(v1, op->epoint);
422         if (err->obj != FLOAT_OBJ) return err;
423         op->v1 = err;
424         op->inplace = (err->refcount == 1) ? err : NULL;
425         val = calc2_double(op);
426         if (val->obj == ERROR_OBJ) error_obj_update(Error(val), err, v1);
427         val_destroy(err);
428         return val;
429     default: break;
430     }
431     return obj_oper_error(op);
432 }
433 
floatobj_init(void)434 void floatobj_init(void) {
435     new_type(&obj, T_FLOAT, "float", sizeof(Float));
436     obj.convert = convert;
437     obj.same = same;
438     obj.truth = truth;
439     obj.hash = hash;
440     obj.repr = repr;
441     obj.ival = ival;
442     obj.uval = uval;
443     obj.uval2 = uval;
444     obj.iaddress = ival;
445     obj.uaddress = uval;
446     obj.sign = sign;
447     obj.function = function;
448     obj.calc1 = calc1;
449     obj.calc2 = calc2;
450     obj.rcalc2 = rcalc2;
451 }
452 
453 static Float pi_value = { { &obj, 2 }, M_PI };
454 
floatobj_names(void)455 void floatobj_names(void) {
456     new_builtin("float", val_reference(Obj(FLOAT_OBJ)));
457     new_builtin("pi", &pi_value.v);
458 }
459 
floatobj_destroy(void)460 void floatobj_destroy(void) {
461 #ifdef DEBUG
462     if (pi_value.v.refcount != 1) fprintf(stderr, "pi %" PRIuSIZE "\n", pi_value.v.refcount - 1);
463 #endif
464 }
465