From 435a91ae3889cd361b543f4555a78488905e0bbb Mon Sep 17 00:00:00 2001 From: Keith Packard Date: Thu, 16 Nov 2017 22:13:46 -0800 Subject: [PATCH] altos/lisp: Lots more scheme bits * Arithmetic functions and tests * append, reverse and list-tail * set-car! and set-cdr! Signed-off-by: Keith Packard --- src/lisp/ao_lisp.h | 2 +- src/lisp/ao_lisp_builtin.c | 105 ++++++++++++++++++++++++--- src/lisp/ao_lisp_builtin.txt | 8 ++- src/lisp/ao_lisp_const.lisp | 136 +++++++++++++++++++++++++++++++++++ 4 files changed, 240 insertions(+), 11 deletions(-) diff --git a/src/lisp/ao_lisp.h b/src/lisp/ao_lisp.h index 9a48a445..341996c0 100644 --- a/src/lisp/ao_lisp.h +++ b/src/lisp/ao_lisp.h @@ -136,7 +136,7 @@ ao_lisp_is_const(ao_poly poly) { #define AO_LISP_IS_CONST(a) (ao_lisp_const <= ((uint8_t *) (a)) && ((uint8_t *) (a)) < ao_lisp_const + AO_LISP_POOL_CONST) #define AO_LISP_IS_POOL(a) (ao_lisp_pool <= ((uint8_t *) (a)) && ((uint8_t *) (a)) < ao_lisp_pool + AO_LISP_POOL) -#define AO_LISP_IS_INT(p) (ao_lisp_base_type(p) == AO_LISP_INT); +#define AO_LISP_IS_INT(p) (ao_lisp_poly_base_type(p) == AO_LISP_INT) void * ao_lisp_ref(ao_poly poly); diff --git a/src/lisp/ao_lisp_builtin.c b/src/lisp/ao_lisp_builtin.c index d89404dc..2c5608e7 100644 --- a/src/lisp/ao_lisp_builtin.c +++ b/src/lisp/ao_lisp_builtin.c @@ -277,6 +277,7 @@ ao_lisp_do_patom(struct ao_lisp_cons *cons) ao_poly ao_lisp_math(struct ao_lisp_cons *cons, enum ao_lisp_builtin_id op) { + struct ao_lisp_cons *orig_cons = cons; ao_poly ret = AO_LISP_NIL; while (cons) { @@ -284,12 +285,29 @@ ao_lisp_math(struct ao_lisp_cons *cons, enum ao_lisp_builtin_id op) uint8_t rt = ao_lisp_poly_type(ret); uint8_t ct = ao_lisp_poly_type(car); - cons = ao_lisp_poly_cons(cons->cdr); - - if (rt == AO_LISP_NIL) + if (cons == orig_cons) { ret = car; - - else if (rt == AO_LISP_INT && ct == AO_LISP_INT) { + if (cons->cdr == AO_LISP_NIL && ct == AO_LISP_INT) { + switch (op) { + case builtin_minus: + ret = ao_lisp_int_poly(-ao_lisp_poly_int(ret)); + break; + case builtin_divide: + switch (ao_lisp_poly_int(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; + } + break; + default: + break; + } + } + } else if (rt == AO_LISP_INT && ct == AO_LISP_INT) { int r = ao_lisp_poly_int(ret); int c = ao_lisp_poly_int(car); @@ -308,11 +326,26 @@ ao_lisp_math(struct ao_lisp_cons *cons, enum ao_lisp_builtin_id op) return ao_lisp_error(AO_LISP_DIVIDE_BY_ZERO, "divide by zero"); r /= c; break; - case builtin_mod: + case builtin_quotient: if (c == 0) - return ao_lisp_error(AO_LISP_DIVIDE_BY_ZERO, "mod by zero"); + 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, "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; } @@ -324,6 +357,8 @@ 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"); + + cons = ao_lisp_poly_cons(cons->cdr); } return ret; } @@ -353,9 +388,21 @@ ao_lisp_do_divide(struct ao_lisp_cons *cons) } ao_poly -ao_lisp_do_mod(struct ao_lisp_cons *cons) +ao_lisp_do_quotient(struct ao_lisp_cons *cons) +{ + return ao_lisp_math(cons, builtin_quotient); +} + +ao_poly +ao_lisp_do_modulo(struct ao_lisp_cons *cons) { - return ao_lisp_math(cons, builtin_mod); + return ao_lisp_math(cons, builtin_modulo); +} + +ao_poly +ao_lisp_do_remainder(struct ao_lisp_cons *cons) +{ + return ao_lisp_math(cons, builtin_remainder); } ao_poly @@ -593,5 +640,45 @@ ao_lisp_do_pairp(struct ao_lisp_cons *cons) return _ao_lisp_bool_false; } +ao_poly +ao_lisp_do_numberp(struct ao_lisp_cons *cons) +{ + if (!ao_lisp_check_argc(_ao_lisp_atom_led, cons, 1, 1)) + return AO_LISP_NIL; + if (AO_LISP_IS_INT(ao_lisp_arg(cons, 0))) + return _ao_lisp_bool_true; + return _ao_lisp_bool_false; +} + +ao_poly +ao_lisp_do_booleanp(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_BOOL) + return _ao_lisp_bool_true; + return _ao_lisp_bool_false; +} + +ao_poly +ao_lisp_do_set_car(struct ao_lisp_cons *cons) +{ + if (!ao_lisp_check_argc(_ao_lisp_atom_led, cons, 2, 2)) + return AO_LISP_NIL; + if (!ao_lisp_check_argt(_ao_lisp_atom_led, cons, 0, AO_LISP_CONS, 0)) + return AO_LISP_NIL; + return ao_lisp_poly_cons(ao_lisp_arg(cons, 0))->car = ao_lisp_arg(cons, 1); +} + +ao_poly +ao_lisp_do_set_cdr(struct ao_lisp_cons *cons) +{ + if (!ao_lisp_check_argc(_ao_lisp_atom_led, cons, 2, 2)) + return AO_LISP_NIL; + if (!ao_lisp_check_argt(_ao_lisp_atom_led, cons, 0, AO_LISP_CONS, 0)) + return AO_LISP_NIL; + return ao_lisp_poly_cons(ao_lisp_arg(cons, 0))->cdr = ao_lisp_arg(cons, 1); +} + #define AO_LISP_BUILTIN_FUNCS #include "ao_lisp_builtin.h" diff --git a/src/lisp/ao_lisp_builtin.txt b/src/lisp/ao_lisp_builtin.txt index 2b891dba..b27985ff 100644 --- a/src/lisp/ao_lisp_builtin.txt +++ b/src/lisp/ao_lisp_builtin.txt @@ -21,7 +21,9 @@ lexpr plus + lexpr minus - lexpr times * lexpr divide / -lexpr mod % +lexpr modulo modulo % +lexpr remainder +lexpr quotient lexpr equal = eq? eqv? lexpr less < lexpr greater > @@ -40,3 +42,7 @@ lambda nullp null? lambda not lambda listp list? lambda pairp pair? +lambda numberp number? integer? +lambda booleanp boolean? +lambda set_car set-car! +lambda set_cdr set-cdr! diff --git a/src/lisp/ao_lisp_const.lisp b/src/lisp/ao_lisp_const.lisp index 37307a68..3ba6aaf5 100644 --- a/src/lisp/ao_lisp_const.lisp +++ b/src/lisp/ao_lisp_const.lisp @@ -69,6 +69,93 @@ (defun 1+ (x) (+ x 1)) (defun 1- (x) (- x 1)) +(define zero? (macro (value rest) + (list + eq? + value + 0) + ) + ) + +(zero? 1) +(zero? 0) +(zero? "hello") + +(define positive? (macro (value rest) + (list + > + value + 0) + ) + ) + +(positive? 12) +(positive? -12) + +(define negative? (macro (value rest) + (list + < + value + 0) + ) + ) + +(negative? 12) +(negative? -12) + +(defun abs (x) (cond ((>= x 0) x) + (else (- x))) + ) + +(abs 12) +(abs -12) + +(define max (lexpr (first rest) + (while (not (null? rest)) + (cond ((< first (car rest)) + (set! first (car rest))) + ) + (set! rest (cdr rest)) + ) + first) + ) + +(max 1 2 3) +(max 3 2 1) + +(define min (lexpr (first rest) + (while (not (null? rest)) + (cond ((> first (car rest)) + (set! first (car rest))) + ) + (set! rest (cdr rest)) + ) + first) + ) + +(min 1 2 3) +(min 3 2 1) + +(defun even? (x) (zero? (% x 2))) + +(even? 2) +(even? -2) +(even? 3) +(even? -1) + +(defun odd? (x) (not (even? x))) + +(odd? 2) +(odd? -2) +(odd? 3) +(odd? -1) + +(define exact? number?) +(defun inexact? (x) #f) + + ; (if ) + ; (if string (lexpr (arg opt) +; (let ((base (if (null? opt) 10 (car opt))) + ; +; + -- 2.30.2