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)
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 \
#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
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) {
{
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];
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);
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);
#include "ao_lisp.h"
#include <limits.h>
+#include <math.h>
static int
builtin_size(void *addr)
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);
while (argc--) {
if (!cons)
return AO_LISP_NIL;
- cons = ao_lisp_poly_cons(cons->cdr);
+ cons = ao_lisp_cons_cdr(cons);
}
return cons->car;
}
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;
}
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(" ");
}
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:
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");
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)
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;
}
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) {
}
}
left = right;
- cons = ao_lisp_poly_cons(cons->cdr);
}
return _ao_lisp_bool_true;
}
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)
{
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;
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!
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
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)
{
(odd? 3)
(odd? -1)
-(define exact? number?)
-(defun inexact? (x) #f)
-
; (if <condition> <if-true>)
; (if <condition> <if-true> <if-false)
case AO_LISP_BOOL:
case AO_LISP_INT:
case AO_LISP_BIGINT:
+ case AO_LISP_FLOAT:
case AO_LISP_STRING:
case AO_LISP_BUILTIN:
case AO_LISP_LAMBDA:
--- /dev/null
+/*
+ * 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)));
+}
[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
.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 *
#include "ao_lisp.h"
#include "ao_lisp_read.h"
+#include <math.h>
static const uint16_t lex_classes[128] = {
IGNORE, /* ^@ */
PRINTABLE|SIGN, /* + */
PRINTABLE, /* , */
PRINTABLE|SIGN, /* - */
- PRINTABLE|SPECIAL, /* . */
+ PRINTABLE|DOTC|FLOATC, /* . */
PRINTABLE, /* / */
PRINTABLE|DIGIT, /* 0 */
PRINTABLE|DIGIT, /* 1 */
PRINTABLE, /* B */
PRINTABLE, /* C */
PRINTABLE, /* D */
- PRINTABLE, /* E */
+ PRINTABLE|FLOATC, /* E */
PRINTABLE, /* F */
PRINTABLE, /* G */
PRINTABLE, /* H */
PRINTABLE, /* b */
PRINTABLE, /* c */
PRINTABLE, /* d */
- PRINTABLE, /* e */
+ PRINTABLE|FLOATC, /* e */
PRINTABLE, /* f */
PRINTABLE, /* g */
PRINTABLE, /* h */
PRINTABLE, /* y */
PRINTABLE, /* z */
PRINTABLE, /* { */
- PRINTABLE|VBAR, /* | */
+ PRINTABLE, /* | */
PRINTABLE, /* } */
PRINTABLE, /* ~ */
IGNORE, /* ^? */
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)
{
continue;
}
- if (lex_class & SPECIAL) {
+ if (lex_class & (SPECIAL|DOTC)) {
add_token(c);
end_token();
switch (c) {
}
}
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;
}
}
-
}
}
}
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;
# 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_ */
projects / fw / altos / commitdiff