diff options
Diffstat (limited to 'src/lisp/ao_lisp_float.c')
| -rw-r--r-- | src/lisp/ao_lisp_float.c | 148 |
1 files changed, 148 insertions, 0 deletions
diff --git a/src/lisp/ao_lisp_float.c b/src/lisp/ao_lisp_float.c new file mode 100644 index 00000000..0aa6f2ea --- /dev/null +++ b/src/lisp/ao_lisp_float.c @@ -0,0 +1,148 @@ +/* + * Copyright © 2017 Keith Packard <keithp@keithp.com> + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation, either version 2 of the License, or + * (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, but + * WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + * General Public License for more details. + */ + +#include "ao_lisp.h" +#include <math.h> + +static void float_mark(void *addr) +{ + (void) addr; +} + +static int float_size(void *addr) +{ + if (!addr) + return 0; + return sizeof (struct ao_lisp_float); +} + +static void float_move(void *addr) +{ + (void) addr; +} + +const struct ao_lisp_type ao_lisp_float_type = { + .mark = float_mark, + .size = float_size, + .move = float_move, + .name = "float", +}; + +void +ao_lisp_float_write(ao_poly p) +{ + struct ao_lisp_float *f = ao_lisp_poly_float(p); + float v = f->value; + + if (isnanf(v)) + printf("+nan.0"); + else if (isinff(v)) { + if (v < 0) + printf("-"); + else + printf("+"); + printf("inf.0"); + } else + printf ("%g", f->value); +} + +float +ao_lisp_poly_number(ao_poly p) +{ + switch (ao_lisp_poly_base_type(p)) { + case AO_LISP_INT: + return ao_lisp_poly_int(p); + case AO_LISP_OTHER: + switch (ao_lisp_other_type(ao_lisp_poly_other(p))) { + case AO_LISP_BIGINT: + return ao_lisp_bigint_int(ao_lisp_poly_bigint(p)->value); + case AO_LISP_FLOAT: + return ao_lisp_poly_float(p)->value; + } + } + return NAN; +} + +ao_poly +ao_lisp_float_get(float value) +{ + struct ao_lisp_float *f; + + f = ao_lisp_alloc(sizeof (struct ao_lisp_float)); + f->type = AO_LISP_FLOAT; + f->value = value; + return ao_lisp_float_poly(f); +} + +ao_poly +ao_lisp_do_inexactp(struct ao_lisp_cons *cons) +{ + if (!ao_lisp_check_argc(_ao_lisp_atom_led, cons, 1, 1)) + return AO_LISP_NIL; + if (ao_lisp_poly_type(ao_lisp_arg(cons, 0)) == AO_LISP_FLOAT) + return _ao_lisp_bool_true; + return _ao_lisp_bool_false; +} + +ao_poly +ao_lisp_do_finitep(struct ao_lisp_cons *cons) +{ + ao_poly value; + float f; + + if (!ao_lisp_check_argc(_ao_lisp_atom_led, cons, 1, 1)) + return AO_LISP_NIL; + value = ao_lisp_arg(cons, 0); + switch (ao_lisp_poly_type(value)) { + case AO_LISP_INT: + case AO_LISP_BIGINT: + return _ao_lisp_bool_true; + case AO_LISP_FLOAT: + f = ao_lisp_poly_float(value)->value; + if (!isnan(f) && !isinf(f)) + return _ao_lisp_bool_true; + } + return _ao_lisp_bool_false; +} + +ao_poly +ao_lisp_do_infinitep(struct ao_lisp_cons *cons) +{ + ao_poly value; + float f; + + if (!ao_lisp_check_argc(_ao_lisp_atom_led, cons, 1, 1)) + return AO_LISP_NIL; + value = ao_lisp_arg(cons, 0); + switch (ao_lisp_poly_type(value)) { + case AO_LISP_FLOAT: + f = ao_lisp_poly_float(value)->value; + if (isinf(f)) + return _ao_lisp_bool_true; + } + return _ao_lisp_bool_false; +} + +ao_poly +ao_lisp_do_sqrt(struct ao_lisp_cons *cons) +{ + ao_poly value; + + if (!ao_lisp_check_argc(_ao_lisp_atom_sqrt, cons, 1, 1)) + return AO_LISP_NIL; + value = ao_lisp_arg(cons, 0); + if (!ao_lisp_number_typep(ao_lisp_poly_type(value))) + return ao_lisp_error(AO_LISP_INVALID, "%s: non-numeric", ao_lisp_poly_atom(_ao_lisp_atom_sqrt)->name); + return ao_lisp_float_get(sqrtf(ao_lisp_poly_number(value))); +} |