From 6d2f271a45759bd792d299f04a424d3382ef4798 Mon Sep 17 00:00:00 2001 From: Keith Packard Date: Sun, 19 Nov 2017 21:07:00 -0800 Subject: [PATCH] altos/lisp: Add floats Signed-off-by: Keith Packard --- src/lisp/Makefile | 2 +- src/lisp/Makefile-inc | 1 + src/lisp/ao_lisp.h | 48 +++++++++++- src/lisp/ao_lisp_builtin.c | 119 ++++++++++++++++++++-------- src/lisp/ao_lisp_builtin.txt | 7 +- src/lisp/ao_lisp_cons.c | 13 +++ src/lisp/ao_lisp_const.lisp | 3 - src/lisp/ao_lisp_eval.c | 1 + src/lisp/ao_lisp_float.c | 148 +++++++++++++++++++++++++++++++++++ src/lisp/ao_lisp_mem.c | 1 + src/lisp/ao_lisp_poly.c | 4 + src/lisp/ao_lisp_read.c | 77 ++++++++++++++---- src/lisp/ao_lisp_read.h | 24 +++--- 13 files changed, 384 insertions(+), 64 deletions(-) create mode 100644 src/lisp/ao_lisp_float.c diff --git a/src/lisp/Makefile b/src/lisp/Makefile index 4563dad3..05f54550 100644 --- a/src/lisp/Makefile +++ b/src/lisp/Makefile @@ -19,6 +19,6 @@ OBJS=$(SRCS:.c=.o) CFLAGS=-DAO_LISP_MAKE_CONST -O0 -g -I. -Wall -Wextra -no-pie ao_lisp_make_const: $(OBJS) - $(CC) $(CFLAGS) -o $@ $(OBJS) + $(CC) $(CFLAGS) -o $@ $(OBJS) -lm $(OBJS): $(HDRS) diff --git a/src/lisp/Makefile-inc b/src/lisp/Makefile-inc index 6c8702fb..a097f1be 100644 --- a/src/lisp/Makefile-inc +++ b/src/lisp/Makefile-inc @@ -6,6 +6,7 @@ LISP_SRCS=\ ao_lisp_int.c \ ao_lisp_poly.c \ ao_lisp_bool.c \ + ao_lisp_float.c \ ao_lisp_builtin.c \ ao_lisp_read.c \ ao_lisp_frame.c \ diff --git a/src/lisp/ao_lisp.h b/src/lisp/ao_lisp.h index 08278fe7..cbbbe9a4 100644 --- a/src/lisp/ao_lisp.h +++ b/src/lisp/ao_lisp.h @@ -96,7 +96,8 @@ extern uint8_t ao_lisp_pool[AO_LISP_POOL + AO_LISP_POOL_EXTRA] __attribute__((a #define AO_LISP_STACK 8 #define AO_LISP_BOOL 9 #define AO_LISP_BIGINT 10 -#define AO_LISP_NUM_TYPE 11 +#define AO_LISP_FLOAT 11 +#define AO_LISP_NUM_TYPE 12 /* Leave two bits for types to use as they please */ #define AO_LISP_OTHER_TYPE_MASK 0x3f @@ -170,6 +171,13 @@ struct ao_lisp_bigint { uint32_t value; }; +struct ao_lisp_float { + uint8_t type; + uint8_t pad1; + uint16_t pad2; + float value; +}; + #if __BYTE_ORDER == __LITTLE_ENDIAN static inline uint32_t ao_lisp_int_bigint(int32_t i) { @@ -442,6 +450,22 @@ ao_lisp_poly_bool(ao_poly poly) { return ao_lisp_ref(poly); } + +static inline ao_poly +ao_lisp_float_poly(struct ao_lisp_float *f) +{ + return ao_lisp_poly(f, AO_LISP_OTHER); +} + +static inline struct ao_lisp_float * +ao_lisp_poly_float(ao_poly poly) +{ + return ao_lisp_ref(poly); +} + +float +ao_lisp_poly_number(ao_poly p); + /* memory functions */ extern int ao_lisp_collects[2]; @@ -524,6 +548,10 @@ extern const struct ao_lisp_type ao_lisp_cons_type; struct ao_lisp_cons * ao_lisp_cons_cons(ao_poly car, ao_poly cdr); +/* Return a cons or NULL for a proper list, else error */ +struct ao_lisp_cons * +ao_lisp_cons_cdr(struct ao_lisp_cons *cons); + ao_poly ao_lisp__cons(ao_poly car, ao_poly cdr); @@ -632,6 +660,24 @@ ao_lisp_eval(ao_poly p); ao_poly ao_lisp_set_cond(struct ao_lisp_cons *cons); +/* float */ +extern const struct ao_lisp_type ao_lisp_float_type; + +void +ao_lisp_float_write(ao_poly p); + +ao_poly +ao_lisp_float_get(float value); + +static inline uint8_t +ao_lisp_number_typep(uint8_t t) +{ + return ao_lisp_integer_typep(t) || (t == AO_LISP_FLOAT); +} + +float +ao_lisp_poly_number(ao_poly p); + /* builtin */ void ao_lisp_builtin_write(ao_poly b); diff --git a/src/lisp/ao_lisp_builtin.c b/src/lisp/ao_lisp_builtin.c index e5370f90..d4dc8a86 100644 --- a/src/lisp/ao_lisp_builtin.c +++ b/src/lisp/ao_lisp_builtin.c @@ -14,6 +14,7 @@ #include "ao_lisp.h" #include +#include static int builtin_size(void *addr) @@ -98,7 +99,7 @@ ao_lisp_check_argc(ao_poly name, struct ao_lisp_cons *cons, int min, int max) while (cons && argc <= max) { argc++; - cons = ao_lisp_poly_cons(cons->cdr); + cons = ao_lisp_cons_cdr(cons); } if (argc < min || argc > max) return ao_lisp_error(AO_LISP_INVALID, "%s: invalid arg count", ao_lisp_poly_atom(name)->name); @@ -113,7 +114,7 @@ ao_lisp_arg(struct ao_lisp_cons *cons, int argc) while (argc--) { if (!cons) return AO_LISP_NIL; - cons = ao_lisp_poly_cons(cons->cdr); + cons = ao_lisp_cons_cdr(cons); } return cons->car; } @@ -162,17 +163,17 @@ ao_lisp_do_cons(struct ao_lisp_cons *cons) ao_poly ao_lisp_do_last(struct ao_lisp_cons *cons) { - ao_poly l; + struct ao_lisp_cons *list; if (!ao_lisp_check_argc(_ao_lisp_atom_last, cons, 1, 1)) return AO_LISP_NIL; if (!ao_lisp_check_argt(_ao_lisp_atom_last, cons, 0, AO_LISP_CONS, 1)) return AO_LISP_NIL; - l = ao_lisp_arg(cons, 0); - while (l) { - struct ao_lisp_cons *list = ao_lisp_poly_cons(l); + for (list = ao_lisp_poly_cons(ao_lisp_arg(cons, 0)); + list; + list = ao_lisp_cons_cdr(list)) + { if (!list->cdr) return list->car; - l = list->cdr; } return AO_LISP_NIL; } @@ -253,7 +254,7 @@ ao_lisp_do_write(struct ao_lisp_cons *cons) while (cons) { val = cons->car; ao_lisp_poly_write(val); - cons = ao_lisp_poly_cons(cons->cdr); + cons = ao_lisp_cons_cdr(cons); if (cons) printf(" "); } @@ -268,39 +269,38 @@ ao_lisp_do_display(struct ao_lisp_cons *cons) while (cons) { val = cons->car; ao_lisp_poly_display(val); - cons = ao_lisp_poly_cons(cons->cdr); + cons = ao_lisp_cons_cdr(cons); } return _ao_lisp_bool_true; } ao_poly -ao_lisp_math(struct ao_lisp_cons *cons, enum ao_lisp_builtin_id op) +ao_lisp_math(struct ao_lisp_cons *orig_cons, enum ao_lisp_builtin_id op) { - struct ao_lisp_cons *orig_cons = cons; + struct ao_lisp_cons *cons = cons; ao_poly ret = AO_LISP_NIL; - while (cons) { + for (cons = orig_cons; cons; cons = ao_lisp_cons_cdr(cons)) { ao_poly car = cons->car; - ao_poly cdr; uint8_t rt = ao_lisp_poly_type(ret); uint8_t ct = ao_lisp_poly_type(car); if (cons == orig_cons) { ret = car; - if (cons->cdr == AO_LISP_NIL && ct == AO_LISP_INT) { + if (cons->cdr == AO_LISP_NIL) { switch (op) { case builtin_minus: - ret = ao_lisp_integer_poly(-ao_lisp_poly_integer(ret)); + if (ao_lisp_integer_typep(ct)) + ret = ao_lisp_integer_poly(-ao_lisp_poly_integer(ret)); + else if (ct == AO_LISP_FLOAT) + ret = ao_lisp_float_get(-ao_lisp_poly_number(ret)); break; case builtin_divide: - switch (ao_lisp_poly_integer(ret)) { - case 0: - return ao_lisp_error(AO_LISP_DIVIDE_BY_ZERO, "divide by zero"); - case 1: - break; - default: - ret = ao_lisp_int_poly(0); - break; + if (ao_lisp_integer_typep(ct) && ao_lisp_poly_integer(ret) == 1) + ; + else if (ao_lisp_number_typep(ct)) { + float v = ao_lisp_poly_number(ret); + ret = ao_lisp_float_get(1/v); } break; default: @@ -322,10 +322,54 @@ ao_lisp_math(struct ao_lisp_cons *cons, enum ao_lisp_builtin_id op) r *= c; break; case builtin_divide: + if (c != 0 && (r % c) == 0) + r /= c; + else { + ret = ao_lisp_float_get((float) r / (float) c); + continue; + } + break; + case builtin_quotient: + if (c == 0) + return ao_lisp_error(AO_LISP_DIVIDE_BY_ZERO, "quotient by zero"); + if (r % c != 0 && (c < 0) != (r < 0)) + r = r / c - 1; + else + r = r / c; + break; + case builtin_remainder: if (c == 0) - return ao_lisp_error(AO_LISP_DIVIDE_BY_ZERO, "divide by zero"); + return ao_lisp_error(AO_LISP_DIVIDE_BY_ZERO, "remainder by zero"); + r %= c; + break; + case builtin_modulo: + if (c == 0) + return ao_lisp_error(AO_LISP_DIVIDE_BY_ZERO, "modulo by zero"); + r %= c; + if ((r < 0) != (c < 0)) + r += c; + break; + default: + break; + } + ret = ao_lisp_integer_poly(r); + } else if (ao_lisp_number_typep(rt) && ao_lisp_number_typep(ct)) { + float r = ao_lisp_poly_number(ret); + float c = ao_lisp_poly_number(car); + switch(op) { + case builtin_plus: + r += c; + break; + case builtin_minus: + r -= c; + break; + case builtin_times: + r *= c; + break; + case builtin_divide: r /= c; break; +#if 0 case builtin_quotient: if (c == 0) return ao_lisp_error(AO_LISP_DIVIDE_BY_ZERO, "quotient by zero"); @@ -346,10 +390,11 @@ ao_lisp_math(struct ao_lisp_cons *cons, enum ao_lisp_builtin_id op) if ((r < 0) != (c < 0)) r += c; break; +#endif default: break; } - ret = ao_lisp_integer_poly(r); + ret = ao_lisp_float_get(r); } else if (rt == AO_LISP_STRING && ct == AO_LISP_STRING && op == builtin_plus) @@ -357,11 +402,6 @@ ao_lisp_math(struct ao_lisp_cons *cons, enum ao_lisp_builtin_id op) ao_lisp_poly_string(car))); else return ao_lisp_error(AO_LISP_INVALID, "invalid args"); - - cdr = cons->cdr; - if (cdr != AO_LISP_NIL && ao_lisp_poly_type(cdr) != AO_LISP_CONS) - return ao_lisp_error(AO_LISP_INVALID, "improper list"); - cons = ao_lisp_poly_cons(cdr); } return ret; } @@ -417,8 +457,7 @@ ao_lisp_compare(struct ao_lisp_cons *cons, enum ao_lisp_builtin_id op) return _ao_lisp_bool_true; left = cons->car; - cons = ao_lisp_poly_cons(cons->cdr); - while (cons) { + for (cons = ao_lisp_cons_cdr(cons); cons; cons = ao_lisp_cons_cdr(cons)) { ao_poly right = cons->car; if (op == builtin_equal) { @@ -477,7 +516,6 @@ ao_lisp_compare(struct ao_lisp_cons *cons, enum ao_lisp_builtin_id op) } } left = right; - cons = ao_lisp_poly_cons(cons->cdr); } return _ao_lisp_bool_true; } @@ -640,6 +678,20 @@ ao_lisp_do_pairp(struct ao_lisp_cons *cons) return ao_lisp_do_typep(AO_LISP_CONS, cons); } +ao_poly +ao_lisp_do_integerp(struct ao_lisp_cons *cons) +{ + if (!ao_lisp_check_argc(_ao_lisp_atom_led, cons, 1, 1)) + return AO_LISP_NIL; + switch (ao_lisp_poly_type(ao_lisp_arg(cons, 0))) { + case AO_LISP_INT: + case AO_LISP_BIGINT: + return _ao_lisp_bool_true; + default: + return _ao_lisp_bool_false; + } +} + ao_poly ao_lisp_do_numberp(struct ao_lisp_cons *cons) { @@ -648,6 +700,7 @@ ao_lisp_do_numberp(struct ao_lisp_cons *cons) switch (ao_lisp_poly_type(ao_lisp_arg(cons, 0))) { case AO_LISP_INT: case AO_LISP_BIGINT: + case AO_LISP_FLOAT: return _ao_lisp_bool_true; default: return _ao_lisp_bool_false; diff --git a/src/lisp/ao_lisp_builtin.txt b/src/lisp/ao_lisp_builtin.txt index c324ca67..2e11bdad 100644 --- a/src/lisp/ao_lisp_builtin.txt +++ b/src/lisp/ao_lisp_builtin.txt @@ -42,7 +42,8 @@ f_lambda nullp null? f_lambda not f_lambda listp list? f_lambda pairp pair? -f_lambda numberp number? integer? +f_lambda integerp integer? exact? exact-integer? +f_lambda numberp number? real? f_lambda booleanp boolean? f_lambda set_car set-car! f_lambda set_cdr set-cdr! @@ -58,3 +59,7 @@ f_lambda exit f_lambda current_jiffy current-jiffy f_lambda current_second current-second f_lambda jiffies_per_second jiffies-per-second +f_lambda finitep finite? +f_lambda infinitep infinite? +f_lambda inexactp inexact? +f_lambda sqrt diff --git a/src/lisp/ao_lisp_cons.c b/src/lisp/ao_lisp_cons.c index 9379597c..c70aa1ca 100644 --- a/src/lisp/ao_lisp_cons.c +++ b/src/lisp/ao_lisp_cons.c @@ -105,6 +105,19 @@ ao_lisp_cons_cons(ao_poly car, ao_poly cdr) return cons; } +struct ao_lisp_cons * +ao_lisp_cons_cdr(struct ao_lisp_cons *cons) +{ + ao_poly cdr = cons->cdr; + if (cdr == AO_LISP_NIL) + return NULL; + if (ao_lisp_poly_type(cdr) != AO_LISP_CONS) { + (void) ao_lisp_error(AO_LISP_INVALID, "improper list"); + return NULL; + } + return ao_lisp_poly_cons(cdr); +} + ao_poly ao_lisp__cons(ao_poly car, ao_poly cdr) { diff --git a/src/lisp/ao_lisp_const.lisp b/src/lisp/ao_lisp_const.lisp index 861a4fc8..9fb7634c 100644 --- a/src/lisp/ao_lisp_const.lisp +++ b/src/lisp/ao_lisp_const.lisp @@ -159,9 +159,6 @@ (odd? 3) (odd? -1) -(define exact? number?) -(defun inexact? (x) #f) - ; (if ) ; (if + * + * 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 + +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))); +} diff --git a/src/lisp/ao_lisp_mem.c b/src/lisp/ao_lisp_mem.c index f333073a..dc0008c4 100644 --- a/src/lisp/ao_lisp_mem.c +++ b/src/lisp/ao_lisp_mem.c @@ -459,6 +459,7 @@ static const struct ao_lisp_type *ao_lisp_types[AO_LISP_NUM_TYPE] = { [AO_LISP_STACK] = &ao_lisp_stack_type, [AO_LISP_BOOL] = &ao_lisp_bool_type, [AO_LISP_BIGINT] = &ao_lisp_bigint_type, + [AO_LISP_FLOAT] = &ao_lisp_float_type, }; static int diff --git a/src/lisp/ao_lisp_poly.c b/src/lisp/ao_lisp_poly.c index 94ecd042..e93e1192 100644 --- a/src/lisp/ao_lisp_poly.c +++ b/src/lisp/ao_lisp_poly.c @@ -60,6 +60,10 @@ static const struct ao_lisp_funcs ao_lisp_funcs[AO_LISP_NUM_TYPE] = { .write = ao_lisp_bigint_write, .display = ao_lisp_bigint_write, }, + [AO_LISP_FLOAT] = { + .write = ao_lisp_float_write, + .display = ao_lisp_float_write, + }, }; static const struct ao_lisp_funcs * diff --git a/src/lisp/ao_lisp_read.c b/src/lisp/ao_lisp_read.c index 5115f46e..c5a238cc 100644 --- a/src/lisp/ao_lisp_read.c +++ b/src/lisp/ao_lisp_read.c @@ -14,6 +14,7 @@ #include "ao_lisp.h" #include "ao_lisp_read.h" +#include static const uint16_t lex_classes[128] = { IGNORE, /* ^@ */ @@ -62,7 +63,7 @@ static const uint16_t lex_classes[128] = { PRINTABLE|SIGN, /* + */ PRINTABLE, /* , */ PRINTABLE|SIGN, /* - */ - PRINTABLE|SPECIAL, /* . */ + PRINTABLE|DOTC|FLOATC, /* . */ PRINTABLE, /* / */ PRINTABLE|DIGIT, /* 0 */ PRINTABLE|DIGIT, /* 1 */ @@ -85,7 +86,7 @@ static const uint16_t lex_classes[128] = { PRINTABLE, /* B */ PRINTABLE, /* C */ PRINTABLE, /* D */ - PRINTABLE, /* E */ + PRINTABLE|FLOATC, /* E */ PRINTABLE, /* F */ PRINTABLE, /* G */ PRINTABLE, /* H */ @@ -117,7 +118,7 @@ static const uint16_t lex_classes[128] = { PRINTABLE, /* b */ PRINTABLE, /* c */ PRINTABLE, /* d */ - PRINTABLE, /* e */ + PRINTABLE|FLOATC, /* e */ PRINTABLE, /* f */ PRINTABLE, /* g */ PRINTABLE, /* h */ @@ -140,7 +141,7 @@ static const uint16_t lex_classes[128] = { PRINTABLE, /* y */ PRINTABLE, /* z */ PRINTABLE, /* { */ - PRINTABLE|VBAR, /* | */ + PRINTABLE, /* | */ PRINTABLE, /* } */ PRINTABLE, /* ~ */ IGNORE, /* ^? */ @@ -247,16 +248,36 @@ lex_quoted(void) static char token_string[AO_LISP_TOKEN_MAX]; static int32_t token_int; static int token_len; +static float token_float; static inline void add_token(int c) { if (c && token_len < AO_LISP_TOKEN_MAX - 1) token_string[token_len++] = c; } +static inline void del_token(void) { + if (token_len > 0) + token_len--; +} + static inline void end_token(void) { token_string[token_len] = '\0'; } +struct namedfloat { + const char *name; + float value; +}; + +static const struct namedfloat namedfloats[] = { + { .name = "+inf.0", .value = INFINITY }, + { .name = "-inf.0", .value = -INFINITY }, + { .name = "+nan.0", .value = NAN }, + { .name = "-nan.0", .value = NAN }, +}; + +#define NUM_NAMED_FLOATS (sizeof namedfloats / sizeof namedfloats[0]) + static int _lex(void) { @@ -279,7 +300,7 @@ _lex(void) continue; } - if (lex_class & SPECIAL) { + if (lex_class & (SPECIAL|DOTC)) { add_token(c); end_token(); switch (c) { @@ -357,47 +378,72 @@ _lex(void) } } if (lex_class & PRINTABLE) { - int isnum; + int isfloat; int hasdigit; int isneg; + int isint; + int epos; - isnum = 1; + isfloat = 1; + isint = 1; hasdigit = 0; token_int = 0; isneg = 0; + epos = 0; for (;;) { if (!(lex_class & NUMBER)) { - isnum = 0; + isint = 0; + isfloat = 0; } else { - if (token_len != 0 && + if (!(lex_class & INTEGER)) + isint = 0; + if (token_len != epos && (lex_class & SIGN)) { - isnum = 0; + isint = 0; + isfloat = 0; } if (c == '-') isneg = 1; + if (c == '.' && epos != 0) + isfloat = 0; + if (c == 'e' || c == 'E') { + if (token_len == 0) + isfloat = 0; + else + epos = token_len + 1; + } if (lex_class & DIGIT) { hasdigit = 1; - if (isnum) + if (isint) token_int = token_int * 10 + c - '0'; } } add_token (c); c = lexc (); - if (lex_class & (NOTNAME)) { + if ((lex_class & (NOTNAME)) && (c != '.' || !isfloat)) { + unsigned int u; // if (lex_class & ENDOFFILE) // clearerr (f); lex_unget(c); end_token (); - if (isnum && hasdigit) { + if (isint && hasdigit) { if (isneg) token_int = -token_int; return NUM; } + if (isfloat && hasdigit) { + token_float = atof(token_string); + return FLOAT; + } + for (u = 0; u < NUM_NAMED_FLOATS; u++) + if (!strcmp(namedfloats[u].name, token_string)) { + token_float = namedfloats[u].value; + return FLOAT; + } return NAME; } } - } } } @@ -499,6 +545,9 @@ ao_lisp_read(void) case NUM: v = ao_lisp_integer_poly(token_int); break; + case FLOAT: + v = ao_lisp_float_get(token_float); + break; case BOOL: if (token_string[0] == 't') v = _ao_lisp_bool_true; diff --git a/src/lisp/ao_lisp_read.h b/src/lisp/ao_lisp_read.h index fc74a8e4..20c9c18a 100644 --- a/src/lisp/ao_lisp_read.h +++ b/src/lisp/ao_lisp_read.h @@ -26,28 +26,30 @@ # define QUOTE 4 # define STRING 5 # define NUM 6 -# define DOT 7 -# define BOOL 8 +# define FLOAT 7 +# define DOT 8 +# define BOOL 9 /* * character classes */ # define PRINTABLE 0x0001 /* \t \n ' ' - '~' */ -# define QUOTED 0x0002 /* \ anything */ -# define SPECIAL 0x0004 /* ( [ { ) ] } ' . */ +# define SPECIAL 0x0002 /* ( [ { ) ] } ' */ +# define DOTC 0x0004 /* . */ # define WHITE 0x0008 /* ' ' \t \n */ # define DIGIT 0x0010 /* [0-9] */ # define SIGN 0x0020 /* +- */ -# define ENDOFFILE 0x0040 /* end of file */ -# define COMMENT 0x0080 /* ; */ -# define IGNORE 0x0100 /* \0 - ' ' */ -# define BACKSLASH 0x0200 /* \ */ -# define VBAR 0x0400 /* | */ +# define FLOATC 0x0040 /* . e E */ +# define ENDOFFILE 0x0080 /* end of file */ +# define COMMENT 0x0100 /* ; */ +# define IGNORE 0x0200 /* \0 - ' ' */ +# define BACKSLASH 0x0400 /* \ */ # define STRINGC 0x0800 /* " */ # define POUND 0x1000 /* # */ -# define NOTNAME (STRINGC|VBAR|COMMENT|ENDOFFILE|WHITE|SPECIAL) -# define NUMBER (DIGIT|SIGN) +# define NOTNAME (STRINGC|COMMENT|ENDOFFILE|WHITE|SPECIAL) +# define INTEGER (DIGIT|SIGN) +# define NUMBER (INTEGER|FLOATC) #endif /* _AO_LISP_READ_H_ */ -- 2.30.2