From e3d8ad6de7d2dfabe45a285b27f465ba68844f05 Mon Sep 17 00:00:00 2001 From: Keith Packard Date: Sun, 30 Oct 2016 19:08:14 -0700 Subject: altos/nucleo-32: Add basic support for STM32F042 Nucleo-32 board This hooks up the LED, USB and the USART. Signed-off-by: Keith Packard --- src/nucleao-32/Makefile | 71 +++++++++++++++++++++++++++++++++++ src/nucleao-32/ao_nucleo.c | 63 +++++++++++++++++++++++++++++++ src/nucleao-32/ao_pins.h | 56 +++++++++++++++++++++++++++ src/nucleao-32/flash-loader/Makefile | 8 ++++ src/nucleao-32/flash-loader/ao_pins.h | 37 ++++++++++++++++++ 5 files changed, 235 insertions(+) create mode 100644 src/nucleao-32/Makefile create mode 100644 src/nucleao-32/ao_nucleo.c create mode 100644 src/nucleao-32/ao_pins.h create mode 100644 src/nucleao-32/flash-loader/Makefile create mode 100644 src/nucleao-32/flash-loader/ao_pins.h (limited to 'src/nucleao-32') diff --git a/src/nucleao-32/Makefile b/src/nucleao-32/Makefile new file mode 100644 index 00000000..a160fd2f --- /dev/null +++ b/src/nucleao-32/Makefile @@ -0,0 +1,71 @@ +# +# AltOS build +# +# + +include ../stmf0/Makefile.defs + +INC = \ + ao.h \ + ao_arch.h \ + ao_arch_funcs.h \ + ao_boot.h \ + ao_pins.h \ + ao_product.h \ + ao_task.h \ + stm32f0.h \ + Makefile + +ALTOS_SRC = \ + ao_boot_chain.c \ + ao_interrupt.c \ + ao_product.c \ + ao_romconfig.c \ + ao_cmd.c \ + ao_config.c \ + ao_task.c \ + ao_led.c \ + ao_dma_stm.c \ + ao_stdio.c \ + ao_panic.c \ + ao_timer.c \ + ao_mutex.c \ + ao_usb_stm.c \ + ao_serial_stm.c \ + ao_exti_stm.c + +PRODUCT=Nucleo-32 +PRODUCT_DEF=-DNUCLEO +IDPRODUCT=0x000a + +CFLAGS = $(PRODUCT_DEF) $(STMF0_CFLAGS) -Os -g + +PROGNAME=nucleo-32 +PROG=$(PROGNAME)-$(VERSION).elf +HEX=$(PROGNAME)-$(VERSION).ihx + +SRC=$(ALTOS_SRC) ao_nucleo.c +OBJ=$(SRC:.c=.o) + +all: $(PROG) $(HEX) + +$(PROG): Makefile $(OBJ) altos.ld + $(call quiet,CC) $(LDFLAGS) $(CFLAGS) -o $(PROG) $(OBJ) $(LIBS) + +$(OBJ): $(INC) + +ao_product.h: ao-make-product.5c ../Version + $(call quiet,NICKLE,$<) $< -m altusmetrum.org -i $(IDPRODUCT) -p $(PRODUCT) -v $(VERSION) > $@ + +load: $(PROG) + stm-load $(PROG) + +distclean: clean + +clean: + rm -f *.o $(PROGNAME)-*.elf $(PROGNAME)-*.ihx + rm -f ao_product.h + +install: + +uninstall: diff --git a/src/nucleao-32/ao_nucleo.c b/src/nucleao-32/ao_nucleo.c new file mode 100644 index 00000000..cda889c6 --- /dev/null +++ b/src/nucleao-32/ao_nucleo.c @@ -0,0 +1,63 @@ +/* + * Copyright © 2016 Keith Packard + * + * 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 + +static uint16_t blink_delay, blink_running; + +static void blink(void) { + blink_running = 1; + while (blink_delay) { + ao_led_on(AO_LED_GREEN); + ao_delay(blink_delay); + ao_led_off(AO_LED_GREEN); + ao_delay(blink_delay); + } + blink_running = 0; + ao_wakeup(&blink_running); + ao_exit(); +} + +struct ao_task blink_task; + +static void blink_cmd() { + ao_cmd_decimal(); + blink_delay = ao_cmd_lex_i; + if (blink_delay && !blink_running) + ao_add_task(&blink_task, blink, "blink"); + if (!blink_delay) + while (blink_running) + ao_sleep(&blink_running); +} + +static const struct ao_cmds blink_cmds[] = { + { blink_cmd, "b \0Blink the green LED" }, + { 0, 0 } +}; + +void main(void) +{ + ao_led_init(LEDS_AVAILABLE); + ao_clock_init(); + ao_task_init(); + ao_timer_init(); + ao_dma_init(); + ao_usb_init(); + ao_serial_init(); + ao_cmd_init(); + ao_cmd_register(blink_cmds); + ao_start_scheduler(); +} + + diff --git a/src/nucleao-32/ao_pins.h b/src/nucleao-32/ao_pins.h new file mode 100644 index 00000000..76200176 --- /dev/null +++ b/src/nucleao-32/ao_pins.h @@ -0,0 +1,56 @@ +/* + * Copyright © 2016 Keith Packard + * + * 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. + * + * You should have received a copy of the GNU General Public License along + * with this program; if not, write to the Free Software Foundation, Inc., + * 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA. + */ + +#ifndef _AO_PINS_H_ +#define _AO_PINS_H_ + +#define LED_PORT_ENABLE STM_RCC_AHBENR_IOPBEN +#define LED_PORT (&stm_gpiob) +#define LED_PIN_GREEN 3 +#define AO_LED_GREEN (1 << LED_PIN_GREEN) +#define AO_LED_PANIC AO_LED_GREEN + +#define LEDS_AVAILABLE (AO_LED_GREEN) + +#define AO_POWER_MANAGEMENT 0 + +/* 48MHz clock based on USB */ +#define AO_HSI48 1 + +/* HCLK = 48MHz */ +#define AO_AHB_PRESCALER 1 +#define AO_RCC_CFGR_HPRE_DIV STM_RCC_CFGR_HPRE_DIV_1 + +/* APB = 48MHz */ +#define AO_APB_PRESCALER 1 +#define AO_RCC_CFGR_PPRE_DIV STM_RCC_CFGR_PPRE_DIV_1 + +#define HAS_USB 1 +#define AO_USB_DIRECTIO 0 +#define AO_PA11_PA12_RMP 0 +#define HAS_BEEP 0 + +#define IS_FLASH_LOADER 0 + +#define HAS_SERIAL_2 1 +#define SERIAL_2_PA2_PA15 1 +#define USE_SERIAL_2_FLOW 0 +#define USE_SERIAL_2_STDIN 1 +#define DELAY_SERIAL_2_STDIN 0 + +#endif /* _AO_PINS_H_ */ diff --git a/src/nucleao-32/flash-loader/Makefile b/src/nucleao-32/flash-loader/Makefile new file mode 100644 index 00000000..2392e998 --- /dev/null +++ b/src/nucleao-32/flash-loader/Makefile @@ -0,0 +1,8 @@ +# +# AltOS flash loader build +# +# + +TOPDIR=../.. +HARDWARE=nucleo-32 +include $(TOPDIR)/stmf0/Makefile-flash.defs diff --git a/src/nucleao-32/flash-loader/ao_pins.h b/src/nucleao-32/flash-loader/ao_pins.h new file mode 100644 index 00000000..8bdbdb1a --- /dev/null +++ b/src/nucleao-32/flash-loader/ao_pins.h @@ -0,0 +1,37 @@ +/* + * Copyright © 2016 Keith Packard + * + * 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. + * + * You should have received a copy of the GNU General Public License along + * with this program; if not, write to the Free Software Foundation, Inc., + * 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA. + */ + +#ifndef _AO_PINS_H_ +#define _AO_PINS_H_ + +#include + +/* Pin D3, which is PB0 */ + +#define AO_BOOT_PIN 1 +#define AO_BOOT_APPLICATION_GPIO stm_gpiob +#define AO_BOOT_APPLICATION_PIN 0 +#define AO_BOOT_APPLICATION_VALUE 1 +#define AO_BOOT_APPLICATION_MODE AO_EXTI_MODE_PULL_UP + +/* USB */ +#define HAS_USB 1 +#define AO_USB_DIRECTIO 0 +#define AO_PA11_PA12_RMP 0 + +#endif /* _AO_PINS_H_ */ -- cgit v1.2.3 From d2408e72d1e0d3459918601712b09860ab17e200 Mon Sep 17 00:00:00 2001 From: Keith Packard Date: Tue, 1 Nov 2016 21:14:45 -0700 Subject: altos/lisp: Change lisp objects to use ao_poly everywhere. Add const This makes all lisp objects use 16-bit ints for references so we can hold more stuff in small amounts of memory. Also adds a separate constant pool of lisp objects for builtins, initial atoms and constant lisp code. Now builds (and runs!) on the nucleo-32 boards. Signed-off-by: Keith Packard --- src/lisp/.gitignore | 2 + src/lisp/Makefile | 32 +++++ src/lisp/ao_lisp.h | 238 ++++++++++++++++++++++----------- src/lisp/ao_lisp_atom.c | 43 +++--- src/lisp/ao_lisp_builtin.c | 189 +++++++++++++++++++++++++- src/lisp/ao_lisp_cons.c | 19 +-- src/lisp/ao_lisp_const.lisp | 1 + src/lisp/ao_lisp_eval.c | 57 ++++++-- src/lisp/ao_lisp_int.c | 3 +- src/lisp/ao_lisp_make_const.c | 90 +++++++++++++ src/lisp/ao_lisp_mem.c | 41 ++++-- src/lisp/ao_lisp_poly.c | 89 +----------- src/lisp/ao_lisp_prim.c | 40 +++--- src/lisp/ao_lisp_read.c | 31 +++-- src/lisp/ao_lisp_rep.c | 40 ++++++ src/lisp/ao_lisp_string.c | 6 +- src/nucleao-32/.gitignore | 2 + src/nucleao-32/Makefile | 11 ++ src/nucleao-32/ao_nucleo.c | 7 + src/nucleao-32/flash-loader/.gitignore | 2 + src/test/Makefile | 8 +- src/test/ao_lisp_test.c | 40 +++--- 22 files changed, 714 insertions(+), 277 deletions(-) create mode 100644 src/lisp/.gitignore create mode 100644 src/lisp/Makefile create mode 100644 src/lisp/ao_lisp_const.lisp create mode 100644 src/lisp/ao_lisp_make_const.c create mode 100644 src/lisp/ao_lisp_rep.c create mode 100644 src/nucleao-32/.gitignore create mode 100644 src/nucleao-32/flash-loader/.gitignore (limited to 'src/nucleao-32') diff --git a/src/lisp/.gitignore b/src/lisp/.gitignore new file mode 100644 index 00000000..76a555ea --- /dev/null +++ b/src/lisp/.gitignore @@ -0,0 +1,2 @@ +ao_lisp_make_const +ao_lisp_const.h diff --git a/src/lisp/Makefile b/src/lisp/Makefile new file mode 100644 index 00000000..e8c3c02c --- /dev/null +++ b/src/lisp/Makefile @@ -0,0 +1,32 @@ +all: ao_lisp_const.h + +clean: + rm -f ao_lisp_const.h $(OBJS) ao_lisp_make_const + +ao_lisp_const.h: ao_lisp_const.lisp ao_lisp_make_const + ./ao_lisp_make_const < ao_lisp_const.lisp > $@ + +SRCS=\ + ao_lisp_make_const.c\ + ao_lisp_mem.c \ + ao_lisp_cons.c \ + ao_lisp_string.c \ + ao_lisp_atom.c \ + ao_lisp_int.c \ + ao_lisp_poly.c \ + ao_lisp_prim.c \ + ao_lisp_builtin.c \ + ao_lisp_read.c + +OBJS=$(SRCS:.c=.o) + +CFLAGS=-DAO_LISP_MAKE_CONST -O0 -g + +HDRS=\ + ao_lisp.h \ + ao_lisp_read.h + +ao_lisp_make_const: $(OBJS) + $(CC) $(CFLAGS) -o $@ $(OBJS) + +$(OBJS): $(HDRS) diff --git a/src/lisp/ao_lisp.h b/src/lisp/ao_lisp.h index 6667dcc2..4fac861b 100644 --- a/src/lisp/ao_lisp.h +++ b/src/lisp/ao_lisp.h @@ -15,78 +15,158 @@ #ifndef _AO_LISP_H_ #define _AO_LISP_H_ +#if !defined(AO_LISP_TEST) && !defined(AO_LISP_MAKE_CONST) +#include +#define AO_LISP_ALTOS 1 +#endif + #include #include #include +#ifdef AO_LISP_MAKE_CONST +#define AO_LISP_POOL_CONST 16384 +extern uint8_t ao_lisp_const[AO_LISP_POOL_CONST]; +#else +#include "ao_lisp_const.h" +#endif + +/* Primitive types */ +#define AO_LISP_CONS 0 +#define AO_LISP_INT 1 +#define AO_LISP_STRING 2 +#define AO_LISP_OTHER 3 -# define AO_LISP_CONS 0 -# define AO_LISP_INT 1 -# define AO_LISP_STRING 2 -# define AO_LISP_OTHER 3 +#define AO_LISP_TYPE_MASK 0x0003 +#define AO_LISP_TYPE_SHIFT 2 +#define AO_LISP_REF_MASK 0x7ffc +#define AO_LISP_CONST 0x8000 -# define AO_LISP_ATOM 4 -# define AO_LISP_BUILTIN 5 +/* These have a type value at the start of the struct */ +#define AO_LISP_ATOM 4 +#define AO_LISP_BUILTIN 5 +#define AO_LISP_NUM_TYPE 6 -# define AO_LISP_NIL 0 +#define AO_LISP_NIL 0 #define AO_LISP_POOL 1024 -#define AO_LISP_ROOT 16 -static inline void *ao_lisp_set_ref(void *addr) { - return (void *) ((intptr_t)addr | 1); +extern uint8_t ao_lisp_pool[AO_LISP_POOL]; +extern uint16_t ao_lisp_top; + +#define AO_LISP_OOM 0x01 +#define AO_LISP_DIVIDE_BY_ZERO 0x02 +#define AO_LISP_INVALID 0x04 + +extern uint8_t ao_lisp_exception; + +typedef uint16_t ao_poly; + +static inline void * +ao_lisp_ref(ao_poly poly) { + if (poly == AO_LISP_NIL) + return NULL; + if (poly & AO_LISP_CONST) + return (void *) ((ao_lisp_const - 4) + (poly & AO_LISP_REF_MASK)); + else + return (void *) ((ao_lisp_pool - 4) + (poly & AO_LISP_REF_MASK)); } -static inline void *ao_lisp_clear_ref(void *addr) { - return (void *) ((intptr_t)addr & ~1); +static inline ao_poly +ao_lisp_poly(const void *addr, ao_poly type) { + const uint8_t *a = addr; + if (addr == NULL) + return AO_LISP_NIL; + if (ao_lisp_pool <= a && a < ao_lisp_pool + AO_LISP_POOL) + return (a - (ao_lisp_pool - 4)) | type; + else if (ao_lisp_const <= a && a <= ao_lisp_const + AO_LISP_POOL_CONST) + return AO_LISP_CONST | (a - (ao_lisp_const - 4)) | type; + else { + ao_lisp_exception |= AO_LISP_INVALID; + return AO_LISP_NIL; + } } -extern uint8_t ao_lisp_pool[AO_LISP_POOL]; +#define AO_LISP_POLY(addr, type) (((ao_lisp_pool <= ((uint8_t *) (a)) && \ + ((uint8_t *) (a)) < ao_lisp_pool + AO_LISP_POOL) ? \ + ((uint8_t *) (a) - (ao_lisp_pool - 4)) : \ + (((uint8_t *) (a) - (ao_lisp_const - 4)) | AO_LISP_POOL_CONST)) | \ + (type)) -struct ao_lisp_mem_type { +struct ao_lisp_type { void (*mark)(void *addr); int (*size)(void *addr); void (*move)(void *addr); }; -typedef intptr_t ao_lisp_poly; - struct ao_lisp_cons { - ao_lisp_poly car; - struct ao_lisp_cons *cdr; + ao_poly car; + ao_poly cdr; }; struct ao_lisp_atom { - uint8_t type; - ao_lisp_poly val; - struct ao_lisp_atom *next; - char name[]; + uint8_t type; + uint8_t pad[1]; + ao_poly val; + ao_poly next; + char name[]; }; -#define AO_LISP_ATOM_CONST ((struct ao_lisp_atom *) (intptr_t) 1) - -extern const struct ao_lisp_atom *ao_lisp_builtins[]; +#define AO_LISP_LAMBDA 0 +#define AO_LISP_NLAMBDA 1 +#define AO_LISP_MACRO 2 +#define AO_LISP_LEXPR 3 struct ao_lisp_builtin { - uint8_t type; - ao_lisp_poly (*func)(struct ao_lisp_cons *cons); - char name[]; + uint8_t type; + uint8_t args; + uint16_t func; }; +enum ao_lisp_builtin_id { + builtin_car, + builtin_cdr, + builtin_cons, + builtin_quote, + builtin_print, + builtin_plus, + builtin_minus, + builtin_times, + builtin_divide, + builtin_mod, + builtin_last +}; + +typedef ao_poly (*ao_lisp_func_t)(struct ao_lisp_cons *cons); + +extern ao_lisp_func_t ao_lisp_builtins[]; + +static inline ao_lisp_func_t +ao_lisp_func(struct ao_lisp_builtin *b) +{ + return ao_lisp_builtins[b->func]; +} + static inline void * -ao_lisp_poly_other(ao_lisp_poly poly) { - return (void *) (poly - AO_LISP_OTHER); +ao_lisp_poly_other(ao_poly poly) { + return ao_lisp_ref(poly); } -static const inline ao_lisp_poly +static inline ao_poly ao_lisp_other_poly(const void *other) { - return (ao_lisp_poly) other + AO_LISP_OTHER; + return ao_lisp_poly(other, AO_LISP_OTHER); +} + +static inline int +ao_lisp_mem_round(int size) +{ + return (size + 3) & ~3; } -#define AO_LISP_OTHER_POLY(other) ((ao_lisp_poly)(other) + AO_LISP_OTHER) +#define AO_LISP_OTHER_POLY(other) ((ao_poly)(other) + AO_LISP_OTHER) -static inline int ao_lisp_poly_type(ao_lisp_poly poly) { +static inline int ao_lisp_poly_type(ao_poly poly) { int type = poly & 3; if (type == AO_LISP_OTHER) return *((uint8_t *) ao_lisp_poly_other(poly)); @@ -94,75 +174,75 @@ static inline int ao_lisp_poly_type(ao_lisp_poly poly) { } static inline struct ao_lisp_cons * -ao_lisp_poly_cons(ao_lisp_poly poly) +ao_lisp_poly_cons(ao_poly poly) { - return (struct ao_lisp_cons *) (poly - AO_LISP_CONS); + return ao_lisp_ref(poly); } -static inline ao_lisp_poly +static inline ao_poly ao_lisp_cons_poly(struct ao_lisp_cons *cons) { - return (ao_lisp_poly) cons + AO_LISP_CONS; + return ao_lisp_poly(cons, AO_LISP_CONS); } static inline int -ao_lisp_poly_int(ao_lisp_poly poly) +ao_lisp_poly_int(ao_poly poly) { - return (int) (poly >> 2); + return (int) poly >> AO_LISP_TYPE_SHIFT; } -static inline ao_lisp_poly +static inline ao_poly ao_lisp_int_poly(int i) { - return ((ao_lisp_poly) i << 2) + AO_LISP_INT; + return ((ao_poly) i << 2) + AO_LISP_INT; } static inline char * -ao_lisp_poly_string(ao_lisp_poly poly) +ao_lisp_poly_string(ao_poly poly) { - return (char *) (poly - AO_LISP_STRING); + return ao_lisp_ref(poly); } -static inline ao_lisp_poly -ao_lisp_string_poly(char *s) { - return (ao_lisp_poly) s + AO_LISP_STRING; +static inline ao_poly +ao_lisp_string_poly(char *s) +{ + return ao_lisp_poly(s, AO_LISP_STRING); } static inline struct ao_lisp_atom * -ao_lisp_poly_atom(ao_lisp_poly poly) +ao_lisp_poly_atom(ao_poly poly) { - return (struct ao_lisp_atom *) (poly - AO_LISP_OTHER); + return ao_lisp_ref(poly); } -static inline ao_lisp_poly +static inline ao_poly ao_lisp_atom_poly(struct ao_lisp_atom *a) { - return (ao_lisp_poly) a + AO_LISP_OTHER; + return ao_lisp_poly(a, AO_LISP_OTHER); } static inline struct ao_lisp_builtin * -ao_lisp_poly_builtin(ao_lisp_poly poly) +ao_lisp_poly_builtin(ao_poly poly) { - return (struct ao_lisp_builtin *) (poly - AO_LISP_OTHER); + return ao_lisp_ref(poly); } -static inline ao_lisp_poly +static inline ao_poly ao_lisp_builtin_poly(struct ao_lisp_builtin *b) { - return (ao_lisp_poly) b + AO_LISP_OTHER; + return ao_lisp_poly(b, AO_LISP_OTHER); } /* memory functions */ - void -ao_lisp_mark(const struct ao_lisp_mem_type *type, void *addr); +ao_lisp_mark(const struct ao_lisp_type *type, void *addr); /* returns 1 if the object was already marked */ int ao_lisp_mark_memory(void *addr, int size); void * -ao_lisp_move(const struct ao_lisp_mem_type *type, void *addr); +ao_lisp_move(const struct ao_lisp_type *type, void *addr); /* returns NULL if the object was already moved */ void * @@ -172,22 +252,22 @@ void * ao_lisp_alloc(int size); int -ao_lisp_root_add(const struct ao_lisp_mem_type *type, void *addr); +ao_lisp_root_add(const struct ao_lisp_type *type, void *addr); void ao_lisp_root_clear(void *addr); /* cons */ -extern const struct ao_lisp_mem_type ao_lisp_cons_type; +extern const struct ao_lisp_type ao_lisp_cons_type; struct ao_lisp_cons * -ao_lisp_cons(ao_lisp_poly car, struct ao_lisp_cons *cdr); +ao_lisp_cons_cons(ao_poly car, struct ao_lisp_cons *cdr); void -ao_lisp_cons_print(struct ao_lisp_cons *cons); +ao_lisp_cons_print(ao_poly); /* string */ -extern const struct ao_lisp_mem_type ao_lisp_string_type; +extern const struct ao_lisp_type ao_lisp_string_type; char * ao_lisp_string_new(int len); @@ -199,44 +279,50 @@ char * ao_lisp_string_cat(char *a, char *b); void -ao_lisp_string_print(char *s); +ao_lisp_string_print(ao_poly s); /* atom */ -extern const struct ao_lisp_mem_type ao_lisp_atom_type; +extern const struct ao_lisp_type ao_lisp_atom_type; + +extern struct ao_lisp_atom *ao_lisp_atoms; void ao_lisp_atom_init(void); void -ao_lisp_atom_print(struct ao_lisp_atom *atom); +ao_lisp_atom_print(ao_poly a); struct ao_lisp_atom * ao_lisp_atom_intern(char *name); /* int */ void -ao_lisp_int_print(int i); +ao_lisp_int_print(ao_poly i); /* prim */ -ao_lisp_poly -ao_lisp_poly_print(ao_lisp_poly p); +ao_poly +ao_lisp_poly_print(ao_poly p); void -ao_lisp_poly_mark(ao_lisp_poly p); +ao_lisp_poly_mark(ao_poly p); -ao_lisp_poly -ao_lisp_poly_move(ao_lisp_poly p); +ao_poly +ao_lisp_poly_move(ao_poly p); /* eval */ -ao_lisp_poly -ao_lisp_eval(ao_lisp_poly p); +ao_poly +ao_lisp_eval(ao_poly p); /* builtin */ void -ao_lisp_builtin_print(struct ao_lisp_builtin *b); +ao_lisp_builtin_print(ao_poly b); /* read */ -ao_lisp_poly +ao_poly ao_lisp_read(void); +/* rep */ +ao_poly +ao_lisp_read_eval_print(void); + #endif /* _AO_LISP_H_ */ diff --git a/src/lisp/ao_lisp_atom.c b/src/lisp/ao_lisp_atom.c index 65282142..aaa84b8d 100644 --- a/src/lisp/ao_lisp_atom.c +++ b/src/lisp/ao_lisp_atom.c @@ -34,12 +34,9 @@ static void atom_mark(void *addr) { struct ao_lisp_atom *atom = addr; - if (atom->next == AO_LISP_ATOM_CONST) - return; - for (;;) { ao_lisp_poly_mark(atom->val); - atom = atom->next; + atom = ao_lisp_poly_atom(atom->next); if (!atom) break; if (ao_lisp_mark_memory(atom, atom_size(atom))) @@ -51,49 +48,50 @@ static void atom_move(void *addr) { struct ao_lisp_atom *atom = addr; - if (atom->next == AO_LISP_ATOM_CONST) - return; - for (;;) { struct ao_lisp_atom *next; atom->val = ao_lisp_poly_move(atom->val); - next = ao_lisp_move_memory(atom->next, atom_size(atom->next)); + next = ao_lisp_poly_atom(atom->next); + next = ao_lisp_move_memory(next, atom_size(next)); if (!next) break; - atom->next = next; + atom->next = ao_lisp_atom_poly(next); atom = next; } } -const struct ao_lisp_mem_type ao_lisp_atom_type = { +const struct ao_lisp_type ao_lisp_atom_type = { .mark = atom_mark, .size = atom_size, .move = atom_move, }; -struct ao_lisp_atom *atoms; +struct ao_lisp_atom *ao_lisp_atoms; struct ao_lisp_atom * ao_lisp_atom_intern(char *name) { struct ao_lisp_atom *atom; - int b; +// int b; - for (atom = atoms; atom; atom = atom->next) { + for (atom = ao_lisp_atoms; atom; atom = ao_lisp_poly_atom(atom->next)) { + if (!strcmp(atom->name, name)) + return atom; + } +#ifdef ao_builtin_atoms + for (atom = ao_lisp_poly_atom(ao_builtin_atoms); atom; atom = ao_lisp_poly_atom(atom->next)) { if (!strcmp(atom->name, name)) return atom; } - for (b = 0; ao_lisp_builtins[b]; b++) - if (!strcmp(ao_lisp_builtins[b]->name, name)) - return (struct ao_lisp_atom *) ao_lisp_builtins[b]; - if (!atoms) - ao_lisp_root_add(&ao_lisp_atom_type, (void **) &atoms); +#endif + if (!ao_lisp_atoms) + ao_lisp_root_add(&ao_lisp_atom_type, (void **) &ao_lisp_atoms); atom = ao_lisp_alloc(name_size(name)); if (atom) { atom->type = AO_LISP_ATOM; - atom->next = atoms; - atoms = atom; + atom->next = ao_lisp_atom_poly(ao_lisp_atoms); + ao_lisp_atoms = atom; strcpy(atom->name, name); atom->val = AO_LISP_NIL; } @@ -101,7 +99,8 @@ ao_lisp_atom_intern(char *name) } void -ao_lisp_atom_print(struct ao_lisp_atom *a) +ao_lisp_atom_print(ao_poly a) { - fputs(a->name, stdout); + struct ao_lisp_atom *atom = ao_lisp_poly_atom(a); + printf("%s", atom->name); } diff --git a/src/lisp/ao_lisp_builtin.c b/src/lisp/ao_lisp_builtin.c index 3752a2c8..e6d55797 100644 --- a/src/lisp/ao_lisp_builtin.c +++ b/src/lisp/ao_lisp_builtin.c @@ -15,7 +15,192 @@ #include "ao_lisp.h" void -ao_lisp_builtin_print(struct ao_lisp_builtin *b) +ao_lisp_builtin_print(ao_poly b) { - printf("[builtin %s]", b->name); + (void) b; + printf("[builtin]"); } + +enum math_op { math_plus, math_minus, math_times, math_divide, math_mod }; + +ao_poly +ao_lisp_car(struct ao_lisp_cons *cons) +{ + if (!cons) { + ao_lisp_exception |= AO_LISP_INVALID; + return AO_LISP_NIL; + } + if (!cons->car) { + ao_lisp_exception |= AO_LISP_INVALID; + return AO_LISP_NIL; + } + if (ao_lisp_poly_type(cons->car) != AO_LISP_CONS) { + ao_lisp_exception |= AO_LISP_INVALID; + return AO_LISP_NIL; + } + return ao_lisp_poly_cons(cons->car)->car; +} + +ao_poly +ao_lisp_cdr(struct ao_lisp_cons *cons) +{ + if (!cons) { + ao_lisp_exception |= AO_LISP_INVALID; + return AO_LISP_NIL; + } + if (!cons->car) { + ao_lisp_exception |= AO_LISP_INVALID; + return AO_LISP_NIL; + } + if (ao_lisp_poly_type(cons->car) != AO_LISP_CONS) { + ao_lisp_exception |= AO_LISP_INVALID; + return AO_LISP_NIL; + } + return ao_lisp_poly_cons(cons->car)->cdr; +} + +ao_poly +ao_lisp_cons(struct ao_lisp_cons *cons) +{ + ao_poly car, cdr; + if (!cons) { + ao_lisp_exception |= AO_LISP_INVALID; + return AO_LISP_NIL; + } + car = cons->car; + cdr = cons->cdr; + if (!car || !cdr) { + ao_lisp_exception |= AO_LISP_INVALID; + return AO_LISP_NIL; + } + cdr = ao_lisp_poly_cons(cdr)->car; + if (ao_lisp_poly_type(cdr) != AO_LISP_CONS) { + ao_lisp_exception |= AO_LISP_INVALID; + return AO_LISP_NIL; + } + return ao_lisp_cons_poly(ao_lisp_cons_cons(car, ao_lisp_poly_cons(cdr))); +} + +ao_poly +ao_lisp_quote(struct ao_lisp_cons *cons) +{ + if (!cons) { + ao_lisp_exception |= AO_LISP_INVALID; + return AO_LISP_NIL; + } + return cons->car; +} + +ao_poly +ao_lisp_print(struct ao_lisp_cons *cons) +{ + ao_poly val = AO_LISP_NIL; + while (cons) { + val = cons->car; + ao_lisp_poly_print(val); + cons = ao_lisp_poly_cons(cons->cdr); + } + return val; +} + +ao_poly +ao_lisp_math(struct ao_lisp_cons *cons, enum math_op op) +{ + ao_poly ret = AO_LISP_NIL; + + while (cons) { + ao_poly car = cons->car; + 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) + ret = car; + + else if (rt == AO_LISP_INT && ct == AO_LISP_INT) { + int r = ao_lisp_poly_int(ret); + int c = ao_lisp_poly_int(car); + + switch(op) { + case math_plus: + r += c; + break; + case math_minus: + r -= c; + break; + case math_times: + r *= c; + break; + case math_divide: + if (c == 0) { + ao_lisp_exception |= AO_LISP_DIVIDE_BY_ZERO; + return AO_LISP_NIL; + } + r /= c; + break; + case math_mod: + if (c == 0) { + ao_lisp_exception |= AO_LISP_DIVIDE_BY_ZERO; + return AO_LISP_NIL; + } + r %= c; + break; + } + ret = ao_lisp_int_poly(r); + } + + else if (rt == AO_LISP_STRING && ct == AO_LISP_STRING && op == math_plus) + ret = ao_lisp_string_poly(ao_lisp_string_cat(ao_lisp_poly_string(ret), + ao_lisp_poly_string(car))); + else { + ao_lisp_exception |= AO_LISP_INVALID; + return AO_LISP_NIL; + } + } + return ret; +} + +ao_poly +ao_lisp_plus(struct ao_lisp_cons *cons) +{ + return ao_lisp_math(cons, math_plus); +} + +ao_poly +ao_lisp_minus(struct ao_lisp_cons *cons) +{ + return ao_lisp_math(cons, math_minus); +} + +ao_poly +ao_lisp_times(struct ao_lisp_cons *cons) +{ + return ao_lisp_math(cons, math_times); +} + +ao_poly +ao_lisp_divide(struct ao_lisp_cons *cons) +{ + return ao_lisp_math(cons, math_divide); +} + +ao_poly +ao_lisp_mod(struct ao_lisp_cons *cons) +{ + return ao_lisp_math(cons, math_mod); +} + +ao_lisp_func_t ao_lisp_builtins[] = { + [builtin_car] = ao_lisp_car, + [builtin_cdr] = ao_lisp_cdr, + [builtin_cons] = ao_lisp_cons, + [builtin_quote] = ao_lisp_quote, + [builtin_print] = ao_lisp_print, + [builtin_plus] = ao_lisp_plus, + [builtin_minus] = ao_lisp_minus, + [builtin_times] = ao_lisp_times, + [builtin_divide] = ao_lisp_divide, + [builtin_mod] = ao_lisp_mod +}; + diff --git a/src/lisp/ao_lisp_cons.c b/src/lisp/ao_lisp_cons.c index 60cbb2f3..65908e30 100644 --- a/src/lisp/ao_lisp_cons.c +++ b/src/lisp/ao_lisp_cons.c @@ -20,7 +20,7 @@ static void cons_mark(void *addr) for (;;) { ao_lisp_poly_mark(cons->car); - cons = cons->cdr; + cons = ao_lisp_poly_cons(cons->cdr); if (!cons) break; if (ao_lisp_mark_memory(cons, sizeof (struct ao_lisp_cons))) @@ -42,42 +42,43 @@ static void cons_move(void *addr) struct ao_lisp_cons *cdr; cons->car = ao_lisp_poly_move(cons->car); - cdr = ao_lisp_move_memory(cons->cdr, sizeof (struct ao_lisp_cons)); + cdr = ao_lisp_poly_cons(cons->cdr); + cdr = ao_lisp_move_memory(cdr, sizeof (struct ao_lisp_cons)); if (!cdr) break; - cons->cdr = cdr; + cons->cdr = ao_lisp_cons_poly(cdr); cons = cdr; } } -const struct ao_lisp_mem_type ao_lisp_cons_type = { +const struct ao_lisp_type ao_lisp_cons_type = { .mark = cons_mark, .size = cons_size, .move = cons_move, }; struct ao_lisp_cons * -ao_lisp_cons(ao_lisp_poly car, struct ao_lisp_cons *cdr) +ao_lisp_cons_cons(ao_poly car, struct ao_lisp_cons *cdr) { struct ao_lisp_cons *cons = ao_lisp_alloc(sizeof (struct ao_lisp_cons)); if (!cons) return NULL; cons->car = car; - cons->cdr = cdr; + cons->cdr = ao_lisp_cons_poly(cdr); return cons; } void -ao_lisp_cons_print(struct ao_lisp_cons *cons) +ao_lisp_cons_print(ao_poly c) { + struct ao_lisp_cons *cons = ao_lisp_poly_cons(c); int first = 1; printf("("); while (cons) { if (!first) printf(" "); - fflush(stdout); ao_lisp_poly_print(cons->car); - cons = cons->cdr; + cons = ao_lisp_poly_cons(cons->cdr); first = 0; } printf(")"); diff --git a/src/lisp/ao_lisp_const.lisp b/src/lisp/ao_lisp_const.lisp new file mode 100644 index 00000000..aa356d45 --- /dev/null +++ b/src/lisp/ao_lisp_const.lisp @@ -0,0 +1 @@ +cadr (lambda (l) (car (cdr l))) diff --git a/src/lisp/ao_lisp_eval.c b/src/lisp/ao_lisp_eval.c index 23908e64..b13d4681 100644 --- a/src/lisp/ao_lisp_eval.c +++ b/src/lisp/ao_lisp_eval.c @@ -40,8 +40,8 @@ static uint8_t been_here; #define DBG_POLY(a) #endif -ao_lisp_poly -ao_lisp_eval(ao_lisp_poly v) +ao_poly +ao_lisp_eval(ao_poly v) { struct ao_lisp_cons *formal; int cons = 0; @@ -59,6 +59,7 @@ ao_lisp_eval(ao_lisp_poly v) formals_tail = 0; for (;;) { + restart: /* Build stack frames for each list */ while (ao_lisp_poly_type(v) == AO_LISP_CONS) { if (v == AO_LISP_NIL) @@ -68,8 +69,8 @@ ao_lisp_eval(ao_lisp_poly v) if (cons++) { struct ao_lisp_cons *frame; - frame = ao_lisp_cons(ao_lisp_cons_poly(actuals), formals); - stack = ao_lisp_cons(ao_lisp_cons_poly(frame), stack); + frame = ao_lisp_cons_cons(ao_lisp_cons_poly(actuals), formals); + stack = ao_lisp_cons_cons(ao_lisp_cons_poly(frame), stack); } actuals = ao_lisp_poly_cons(v); formals = NULL; @@ -83,6 +84,8 @@ ao_lisp_eval(ao_lisp_poly v) /* Evaluate primitive types */ + DBG ("actual: "); DBG_POLY(v); DBG("\n"); + switch (ao_lisp_poly_type(v)) { case AO_LISP_INT: case AO_LISP_STRING: @@ -92,16 +95,42 @@ ao_lisp_eval(ao_lisp_poly v) break; } + if (!cons) + break; + for (;;) { DBG("add formal: "); DBG_POLY(v); DBG("\n"); - formal = ao_lisp_cons(v, NULL); + if (formals == NULL) { + if (ao_lisp_poly_type(v) == AO_LISP_BUILTIN) { + struct ao_lisp_builtin *b = ao_lisp_poly_builtin(v); + switch (b->args) { + case AO_LISP_NLAMBDA: + v = ao_lisp_func(b)(ao_lisp_poly_cons(actuals->cdr)); + goto done_eval; + + case AO_LISP_MACRO: + v = ao_lisp_func(b)(ao_lisp_poly_cons(actuals->cdr)); + if (ao_lisp_poly_type(v) != AO_LISP_CONS) { + ao_lisp_exception |= AO_LISP_INVALID; + return AO_LISP_NIL; + } + + /* Reset frame to the new list */ + actuals = ao_lisp_poly_cons(v); + v = actuals->car; + goto restart; + } + } + } + + formal = ao_lisp_cons_cons(v, NULL); if (formals_tail) - formals_tail->cdr = formal; + formals_tail->cdr = ao_lisp_cons_poly(formal); else formals = formal; formals_tail = formal; - actuals = actuals->cdr; + actuals = ao_lisp_poly_cons(actuals->cdr); DBG("formals: "); DBG_CONS(formals); @@ -113,7 +142,6 @@ ao_lisp_eval(ao_lisp_poly v) /* Process all of the arguments */ if (actuals) { v = actuals->car; - DBG ("actual: "); DBG_POLY(v); DBG("\n"); break; } @@ -123,7 +151,7 @@ ao_lisp_eval(ao_lisp_poly v) if (ao_lisp_poly_type(v) == AO_LISP_BUILTIN) { struct ao_lisp_builtin *b = ao_lisp_poly_builtin(v); - v = b->func(formals->cdr); + v = ao_lisp_func(b) (ao_lisp_poly_cons(formals->cdr)); DBG ("eval: "); DBG_CONS(formals); @@ -131,22 +159,23 @@ ao_lisp_eval(ao_lisp_poly v) DBG_POLY(v); DBG ("\n"); } else { - DBG ("invalid eval\n"); + ao_lisp_exception |= AO_LISP_INVALID; + return AO_LISP_NIL; } - + done_eval: if (--cons) { struct ao_lisp_cons *frame; /* Pop the previous frame off the stack */ frame = ao_lisp_poly_cons(stack->car); actuals = ao_lisp_poly_cons(frame->car); - formals = frame->cdr; + formals = ao_lisp_poly_cons(frame->cdr); /* Recompute the tail of the formals list */ - for (formal = formals; formal->cdr != NULL; formal = formal->cdr); + for (formal = formals; formal->cdr != AO_LISP_NIL; formal = ao_lisp_poly_cons(formal->cdr)); formals_tail = formal; - stack = stack->cdr; + stack = ao_lisp_poly_cons(stack->cdr); DBG("stack pop: stack"); DBG_CONS(stack); DBG("\n"); DBG("stack pop: actuals"); DBG_CONS(actuals); DBG("\n"); DBG("stack pop: formals"); DBG_CONS(formals); DBG("\n"); diff --git a/src/lisp/ao_lisp_int.c b/src/lisp/ao_lisp_int.c index 6ee3096d..77f65e95 100644 --- a/src/lisp/ao_lisp_int.c +++ b/src/lisp/ao_lisp_int.c @@ -15,7 +15,8 @@ #include "ao_lisp.h" void -ao_lisp_int_print(int i) +ao_lisp_int_print(ao_poly p) { + int i = ao_lisp_poly_int(p); printf("%d", i); } diff --git a/src/lisp/ao_lisp_make_const.c b/src/lisp/ao_lisp_make_const.c new file mode 100644 index 00000000..21e000bf --- /dev/null +++ b/src/lisp/ao_lisp_make_const.c @@ -0,0 +1,90 @@ +/* + * Copyright © 2016 Keith Packard + * + * 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 struct ao_lisp_builtin * +ao_lisp_make_builtin(enum ao_lisp_builtin_id func, int args) { + struct ao_lisp_builtin *b = ao_lisp_alloc(sizeof (struct ao_lisp_builtin)); + + b->type = AO_LISP_BUILTIN; + b->func = func; + b->args = args; + return b; +} + +struct builtin_func { + char *name; + int args; + int func; +}; + +struct builtin_func funcs[] = { + "car", AO_LISP_LEXPR, builtin_car, + "cdr", AO_LISP_LEXPR, builtin_cdr, + "cons", AO_LISP_LEXPR, builtin_cons, + "quote", AO_LISP_NLAMBDA,builtin_quote, + "print", AO_LISP_LEXPR, builtin_print, + "+", AO_LISP_LEXPR, builtin_plus, + "-", AO_LISP_LEXPR, builtin_minus, + "*", AO_LISP_LEXPR, builtin_times, + "/", AO_LISP_LEXPR, builtin_divide, + "%", AO_LISP_LEXPR, builtin_mod +}; + +#define N_FUNC (sizeof funcs / sizeof funcs[0]) + +int +main(int argc, char **argv) +{ + int f, o; + ao_poly atom, val; + + for (f = 0; f < N_FUNC; f++) { + struct ao_lisp_builtin *b = ao_lisp_make_builtin(funcs[f].func, funcs[f].args); + struct ao_lisp_atom *a = ao_lisp_atom_intern(funcs[f].name); + a->val = ao_lisp_builtin_poly(b); + } + + for (;;) { + atom = ao_lisp_read(); + if (!atom) + break; + val = ao_lisp_read(); + if (!val) + break; + if (ao_lisp_poly_type(atom) != AO_LISP_ATOM) { + fprintf(stderr, "input must be atom val pairs\n"); + exit(1); + } + ao_lisp_poly_atom(atom)->val = val; + } + + printf("/* constant objects, all referenced from atoms */\n\n"); + printf("#define AO_LISP_POOL_CONST %d\n", ao_lisp_top); + printf("extern const uint8_t ao_lisp_const[AO_LISP_POOL_CONST] __attribute__((aligned(4)));\n"); + printf("#define ao_builtin_atoms 0x%04x\n", ao_lisp_atom_poly(ao_lisp_atoms)); + printf("#ifdef AO_LISP_CONST_BITS\n"); + printf("const uint8_t ao_lisp_const[] = {"); + for (o = 0; o < ao_lisp_top; o++) { + if ((o & 0xf) == 0) + printf("\n\t"); + else + printf(" "); + printf("0x%02x,", ao_lisp_const[o]); + } + printf("\n};\n"); + printf("#endif /* AO_LISP_CONST_BITS */\n"); +} diff --git a/src/lisp/ao_lisp_mem.c b/src/lisp/ao_lisp_mem.c index d008519b..7295d150 100644 --- a/src/lisp/ao_lisp_mem.c +++ b/src/lisp/ao_lisp_mem.c @@ -12,23 +12,34 @@ * General Public License for more details. */ +#define AO_LISP_CONST_BITS + #include "ao_lisp.h" #include -uint8_t ao_lisp_pool[AO_LISP_POOL]; +uint8_t ao_lisp_pool[AO_LISP_POOL] __attribute__((aligned(4))); + +#ifdef AO_LISP_MAKE_CONST +#include +uint8_t ao_lisp_const[AO_LISP_POOL_CONST] __attribute__((aligned(4))); +#endif + +uint8_t ao_lisp_exception; struct ao_lisp_root { void **addr; - const struct ao_lisp_mem_type *type; + const struct ao_lisp_type *type; }; +#define AO_LISP_ROOT 16 + static struct ao_lisp_root ao_lisp_root[AO_LISP_ROOT]; static uint8_t ao_lisp_busy[AO_LISP_POOL / 32]; static uint8_t ao_lisp_moving[AO_LISP_POOL / 32]; -static uint16_t ao_lisp_top; +uint16_t ao_lisp_top; static inline void mark(uint8_t *tag, int offset) { int byte = offset >> 5; @@ -59,9 +70,13 @@ static int mark_object(uint8_t *tag, void *addr, int size) { int base; int bound; + if (!addr) return 1; + if ((uint8_t *) addr < ao_lisp_pool || ao_lisp_pool + AO_LISP_POOL <= (uint8_t*) addr) + return 1; + base = (uint8_t *) addr - ao_lisp_pool; bound = base + size; @@ -150,7 +165,7 @@ collect(void) void -ao_lisp_mark(const struct ao_lisp_mem_type *type, void *addr) +ao_lisp_mark(const struct ao_lisp_type *type, void *addr) { if (mark_object(ao_lisp_busy, addr, type->size(addr))) return; @@ -175,7 +190,7 @@ check_move(void *addr, int size) } void * -ao_lisp_move(const struct ao_lisp_mem_type *type, void *addr) +ao_lisp_move(const struct ao_lisp_type *type, void *addr) { int size = type->size(addr); @@ -206,19 +221,29 @@ ao_lisp_alloc(int size) { void *addr; - size = (size + 3) & ~3; + size = ao_lisp_mem_round(size); +#ifdef AO_LISP_MAKE_CONST + if (ao_lisp_top + size > AO_LISP_POOL_CONST) { + fprintf(stderr, "Too much constant data, increase AO_LISP_POOL_CONST\n"); + exit(1); + } + addr = ao_lisp_const + ao_lisp_top; +#else if (ao_lisp_top + size > AO_LISP_POOL) { collect(); - if (ao_lisp_top + size > AO_LISP_POOL) + if (ao_lisp_top + size > AO_LISP_POOL) { + ao_lisp_exception |= AO_LISP_OOM; return NULL; + } } addr = ao_lisp_pool + ao_lisp_top; +#endif ao_lisp_top += size; return addr; } int -ao_lisp_root_add(const struct ao_lisp_mem_type *type, void *addr) +ao_lisp_root_add(const struct ao_lisp_type *type, void *addr) { int i; for (i = 0; i < AO_LISP_ROOT; i++) { diff --git a/src/lisp/ao_lisp_poly.c b/src/lisp/ao_lisp_poly.c index 1855d945..c6ca0a97 100644 --- a/src/lisp/ao_lisp_poly.c +++ b/src/lisp/ao_lisp_poly.c @@ -14,91 +14,7 @@ #include "ao_lisp.h" -enum math_op { math_plus, math_minus, math_times, math_divide, math_mod }; - -ao_lisp_poly -ao_lisp_math(struct ao_lisp_cons *cons, enum math_op op) -{ - ao_lisp_poly ret = AO_LISP_NIL; - - while (cons) { - ao_lisp_poly car = cons->car; - uint8_t rt = ao_lisp_poly_type(ret); - uint8_t ct = ao_lisp_poly_type(car); - - cons = cons->cdr; - - if (rt == AO_LISP_NIL) - ret = car; - - else if (rt == AO_LISP_INT && ct == AO_LISP_INT) { - int r = ao_lisp_poly_int(ret); - int c = ao_lisp_poly_int(car); - - switch(op) { - case math_plus: - r += c; - break; - case math_minus: - r -= c; - break; - case math_times: - r *= c; - break; - case math_divide: - if (c == 0) - return AO_LISP_NIL; - r /= c; - break; - case math_mod: - if (c == 0) - return AO_LISP_NIL; - r %= c; - break; - } - ret = ao_lisp_int_poly(r); - } - - else if (rt == AO_LISP_STRING && ct == AO_LISP_STRING && op == math_plus) - ret = ao_lisp_string_poly(ao_lisp_string_cat(ao_lisp_poly_string(ret), - ao_lisp_poly_string(car))); - else { - /* XXX exception */ - return AO_LISP_NIL; - } - } - return ret; -} - -ao_lisp_poly -ao_lisp_plus(struct ao_lisp_cons *cons) -{ - return ao_lisp_math(cons, math_plus); -} - -ao_lisp_poly -ao_lisp_minus(struct ao_lisp_cons *cons) -{ - return ao_lisp_math(cons, math_minus); -} - -ao_lisp_poly -ao_lisp_times(struct ao_lisp_cons *cons) -{ - return ao_lisp_math(cons, math_times); -} - -ao_lisp_poly -ao_lisp_divide(struct ao_lisp_cons *cons) -{ - return ao_lisp_math(cons, math_divide); -} - -ao_lisp_poly -ao_lisp_mod(struct ao_lisp_cons *cons) -{ - return ao_lisp_math(cons, math_mod); -} +/* static const struct ao_lisp_builtin builtin_plus = { .type = AO_LISP_BUILTIN, @@ -113,7 +29,6 @@ static const struct ao_lisp_atom atom_plus = { .name = "plus" }; -/* static const struct ao_lisp_builtin builtin_minus = { .type = AO_LISP_BUILTIN, .func = ao_lisp_minus @@ -124,9 +39,9 @@ static const struct ao_lisp_builtin builtin_times = { .func = ao_lisp_times }; -*/ const struct ao_lisp_atom const *ao_lisp_builtins[] = { &atom_plus, 0 }; +*/ diff --git a/src/lisp/ao_lisp_prim.c b/src/lisp/ao_lisp_prim.c index ccfd2be4..38dcb961 100644 --- a/src/lisp/ao_lisp_prim.c +++ b/src/lisp/ao_lisp_prim.c @@ -14,31 +14,25 @@ #include "ao_lisp.h" -ao_lisp_poly -ao_lisp_poly_print(ao_lisp_poly p) +static void (*const ao_lisp_print_funcs[AO_LISP_NUM_TYPE])(ao_poly) = { + [AO_LISP_CONS] = ao_lisp_cons_print, + [AO_LISP_STRING] = ao_lisp_string_print, + [AO_LISP_INT] = ao_lisp_int_print, + [AO_LISP_ATOM] = ao_lisp_atom_print, + [AO_LISP_BUILTIN] = ao_lisp_builtin_print +}; + +ao_poly +ao_lisp_poly_print(ao_poly p) { - switch (ao_lisp_poly_type(p)) { - case AO_LISP_CONS: - ao_lisp_cons_print(ao_lisp_poly_cons(p)); - break; - case AO_LISP_STRING: - ao_lisp_string_print(ao_lisp_poly_string(p)); - break; - case AO_LISP_INT: - ao_lisp_int_print(ao_lisp_poly_int(p)); - break; - case AO_LISP_ATOM: - ao_lisp_atom_print(ao_lisp_poly_atom(p)); - break; - case AO_LISP_BUILTIN: - ao_lisp_builtin_print(ao_lisp_poly_builtin(p)); - break; - } - return AO_LISP_NIL; + void (*print)(ao_poly) = ao_lisp_print_funcs[ao_lisp_poly_type(p)]; + if (print) + print(p); + return p; } void -ao_lisp_poly_mark(ao_lisp_poly p) +ao_lisp_poly_mark(ao_poly p) { switch (ao_lisp_poly_type(p)) { case AO_LISP_CONS: @@ -53,8 +47,8 @@ ao_lisp_poly_mark(ao_lisp_poly p) } } -ao_lisp_poly -ao_lisp_poly_move(ao_lisp_poly p) +ao_poly +ao_lisp_poly_move(ao_poly p) { switch (ao_lisp_poly_type(p)) { case AO_LISP_CONS: diff --git a/src/lisp/ao_lisp_read.c b/src/lisp/ao_lisp_read.c index ccb4ba3a..ea98b976 100644 --- a/src/lisp/ao_lisp_read.c +++ b/src/lisp/ao_lisp_read.c @@ -155,8 +155,21 @@ lex_get() if (lex_unget_c) { c = lex_unget_c; lex_unget_c = 0; - } else + } else { +#if AO_LISP_ALTOS + static uint8_t at_eol; + + if (at_eol) { + ao_cmd_readline(); + at_eol = 0; + } + c = ao_cmd_lex(); + if (c == '\n') + at_eol = 1; +#else c = getchar(); +#endif + } return c; } @@ -362,13 +375,13 @@ static struct ao_lisp_cons *read_cons; static struct ao_lisp_cons *read_cons_tail; static struct ao_lisp_cons *read_stack; -static ao_lisp_poly +static ao_poly read_item(void) { struct ao_lisp_atom *atom; char *string; int cons; - ao_lisp_poly v; + ao_poly v; if (!been_here) { ao_lisp_root_add(&ao_lisp_cons_type, &read_cons); @@ -381,7 +394,7 @@ read_item(void) for (;;) { while (parse_token == OPEN) { if (cons++) - read_stack = ao_lisp_cons(ao_lisp_cons_poly(read_cons), read_stack); + read_stack = ao_lisp_cons_cons(ao_lisp_cons_poly(read_cons), read_stack); read_cons = NULL; read_cons_tail = NULL; parse_token = lex(); @@ -416,10 +429,10 @@ read_item(void) v = AO_LISP_NIL; if (--cons) { read_cons = ao_lisp_poly_cons(read_stack->car); - read_stack = read_stack->cdr; + read_stack = ao_lisp_poly_cons(read_stack->cdr); for (read_cons_tail = read_cons; read_cons_tail && read_cons_tail->cdr; - read_cons_tail = read_cons_tail->cdr) + read_cons_tail = ao_lisp_poly_cons(read_cons_tail->cdr)) ; } break; @@ -428,9 +441,9 @@ read_item(void) if (!cons) break; - struct ao_lisp_cons *read = ao_lisp_cons(v, NULL); + struct ao_lisp_cons *read = ao_lisp_cons_cons(v, NULL); if (read_cons_tail) - read_cons_tail->cdr = read; + read_cons_tail->cdr = ao_lisp_cons_poly(read); else read_cons = read; read_cons_tail = read; @@ -440,7 +453,7 @@ read_item(void) return v; } -ao_lisp_poly +ao_poly ao_lisp_read(void) { parse_token = lex(); diff --git a/src/lisp/ao_lisp_rep.c b/src/lisp/ao_lisp_rep.c new file mode 100644 index 00000000..d26d270c --- /dev/null +++ b/src/lisp/ao_lisp_rep.c @@ -0,0 +1,40 @@ +/* + * Copyright © 2016 Keith Packard + * + * 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" + +ao_poly +ao_lisp_read_eval_print(void) +{ + ao_poly in, out = AO_LISP_NIL; + for(;;) { + in = ao_lisp_read(); + if (!in) + break; + out = ao_lisp_eval(in); + if (ao_lisp_exception) { + if (ao_lisp_exception & AO_LISP_OOM) + printf("out of memory\n"); + if (ao_lisp_exception & AO_LISP_DIVIDE_BY_ZERO) + printf("divide by zero\n"); + if (ao_lisp_exception & AO_LISP_INVALID) + printf("invalid operation\n"); + ao_lisp_exception = 0; + } else { + ao_lisp_poly_print(out); + putchar ('\n'); + } + } + return out; +} diff --git a/src/lisp/ao_lisp_string.c b/src/lisp/ao_lisp_string.c index 1ab56933..39c3dc81 100644 --- a/src/lisp/ao_lisp_string.c +++ b/src/lisp/ao_lisp_string.c @@ -68,16 +68,18 @@ ao_lisp_string_cat(char *a, char *b) return r; } -const struct ao_lisp_mem_type ao_lisp_string_type = { +const struct ao_lisp_type ao_lisp_string_type = { .mark = string_mark, .size = string_size, .move = string_move, }; void -ao_lisp_string_print(char *s) +ao_lisp_string_print(ao_poly p) { + char *s = ao_lisp_poly_string(p); char c; + putchar('"'); while ((c = *s++)) { switch (c) { diff --git a/src/nucleao-32/.gitignore b/src/nucleao-32/.gitignore new file mode 100644 index 00000000..cb8f78e5 --- /dev/null +++ b/src/nucleao-32/.gitignore @@ -0,0 +1,2 @@ +ao_product.h +nucleo-32* diff --git a/src/nucleao-32/Makefile b/src/nucleao-32/Makefile index a160fd2f..0df44317 100644 --- a/src/nucleao-32/Makefile +++ b/src/nucleao-32/Makefile @@ -32,6 +32,17 @@ ALTOS_SRC = \ ao_mutex.c \ ao_usb_stm.c \ ao_serial_stm.c \ + ao_lisp_lex.c \ + ao_lisp_mem.c \ + ao_lisp_cons.c \ + ao_lisp_eval.c \ + ao_lisp_string.c \ + ao_lisp_atom.c \ + ao_lisp_int.c \ + ao_lisp_prim.c \ + ao_lisp_builtin.c \ + ao_lisp_read.c \ + ao_lisp_rep.c \ ao_exti_stm.c PRODUCT=Nucleo-32 diff --git a/src/nucleao-32/ao_nucleo.c b/src/nucleao-32/ao_nucleo.c index cda889c6..113e2399 100644 --- a/src/nucleao-32/ao_nucleo.c +++ b/src/nucleao-32/ao_nucleo.c @@ -13,6 +13,7 @@ */ #include +#include static uint16_t blink_delay, blink_running; @@ -41,11 +42,17 @@ static void blink_cmd() { ao_sleep(&blink_running); } +static void lisp_cmd() { + ao_lisp_read_eval_print(); +} + static const struct ao_cmds blink_cmds[] = { { blink_cmd, "b \0Blink the green LED" }, + { lisp_cmd, "l\0Run lisp interpreter" }, { 0, 0 } }; + void main(void) { ao_led_init(LEDS_AVAILABLE); diff --git a/src/nucleao-32/flash-loader/.gitignore b/src/nucleao-32/flash-loader/.gitignore new file mode 100644 index 00000000..cb8f78e5 --- /dev/null +++ b/src/nucleao-32/flash-loader/.gitignore @@ -0,0 +1,2 @@ +ao_product.h +nucleo-32* diff --git a/src/test/Makefile b/src/test/Makefile index e841bfde..6c51c421 100644 --- a/src/test/Makefile +++ b/src/test/Makefile @@ -10,7 +10,7 @@ INCS=ao_kalman.h ao_ms5607.h ao_log.h ao_data.h altitude-pa.h altitude.h ao_quat KALMAN=make-kalman -CFLAGS=-I.. -I. -I../kernel -I../drivers -I../micropeak -I../product -I../lisp -O0 -g -Wall +CFLAGS=-I.. -I. -I../kernel -I../drivers -I../micropeak -I../product -I../lisp -O0 -g -Wall -DAO_LISP_TEST all: $(PROGS) ao_aprs_data.wav @@ -89,9 +89,11 @@ ao_quaternion_test: ao_quaternion_test.c ao_quaternion.h cc $(CFLAGS) -o $@ ao_quaternion_test.c -lm -AO_LISP_OBJS = ao_lisp_test.o ao_lisp_mem.o ao_lisp_lex.o ao_lisp_cons.o ao_lisp_string.o ao_lisp_atom.o ao_lisp_int.o ao_lisp_prim.o ao_lisp_eval.o ao_lisp_poly.o ao_lisp_builtin.o ao_lisp_read.o +#AO_LISP_OBJS = ao_lisp_test.o ao_lisp_mem.o ao_lisp_lex.o ao_lisp_cons.o ao_lisp_string.o ao_lisp_atom.o ao_lisp_int.o ao_lisp_prim.o ao_lisp_eval.o ao_lisp_poly.o ao_lisp_builtin.o ao_lisp_read.o + +AO_LISP_OBJS = ao_lisp_test.o ao_lisp_mem.o ao_lisp_cons.o ao_lisp_string.o ao_lisp_atom.o ao_lisp_int.o ao_lisp_prim.o ao_lisp_eval.o ao_lisp_poly.o ao_lisp_builtin.o ao_lisp_read.o ao_lisp_rep.o ao_lisp_test: $(AO_LISP_OBJS) cc $(CFLAGS) -o $@ $(AO_LISP_OBJS) -$(AO_LISP_OBJS): ao_lisp.h +$(AO_LISP_OBJS): ao_lisp.h ao_lisp_const.h diff --git a/src/test/ao_lisp_test.c b/src/test/ao_lisp_test.c index 96f1fd72..810a1528 100644 --- a/src/test/ao_lisp_test.c +++ b/src/test/ao_lisp_test.c @@ -21,9 +21,9 @@ static char *string; int main (int argc, char **argv) { - int i, j; + int i, j; struct ao_lisp_atom *atom; - ao_lisp_poly poly; + ao_lisp_root_add(&ao_lisp_cons_type, (void **) &list); ao_lisp_root_add(&ao_lisp_string_type, (void **) &string); @@ -31,37 +31,35 @@ main (int argc, char **argv) for (j = 0; j < 10; j++) { list = 0; string = ao_lisp_string_new(0); - for (i = 0; i < 7; i++) { + for (i = 0; i < 2; i++) { string = ao_lisp_string_cat(string, "a"); - list = ao_lisp_cons(ao_lisp_string_poly(string), list); - list = ao_lisp_cons(ao_lisp_int_poly(i), list); + list = ao_lisp_cons_cons(ao_lisp_string_poly(string), list); + list = ao_lisp_cons_cons(ao_lisp_int_poly(i), list); atom = ao_lisp_atom_intern("ant"); atom->val = ao_lisp_cons_poly(list); - list = ao_lisp_cons(ao_lisp_atom_poly(atom), list); + list = ao_lisp_cons_cons(ao_lisp_atom_poly(atom), list); } ao_lisp_poly_print(ao_lisp_cons_poly(list)); printf("\n"); } - atom = ao_lisp_atom_intern("ant"); - atom->val = ao_lisp_string_poly(ao_lisp_string_cat("hello world", "")); - - list = ao_lisp_cons(ao_lisp_atom_poly(ao_lisp_atom_intern("plus")), - ao_lisp_cons(ao_lisp_cons_poly(ao_lisp_cons(ao_lisp_atom_poly(ao_lisp_atom_intern("plus")), - ao_lisp_cons(ao_lisp_int_poly(3), - ao_lisp_cons(ao_lisp_int_poly(4), NULL)))), - ao_lisp_cons(ao_lisp_int_poly(2), NULL))); + for (atom = ao_lisp_poly_atom(ao_builtin_atoms); atom; atom = ao_lisp_poly_atom(atom->next)) { + printf("%s = ", atom->name); + ao_lisp_poly_print(atom->val); + printf("\n"); + } +#if 1 + list = ao_lisp_cons_cons(ao_lisp_atom_poly(ao_lisp_atom_intern("+")), + ao_lisp_cons_cons(ao_lisp_cons_poly(ao_lisp_cons_cons(ao_lisp_atom_poly(ao_lisp_atom_intern("+")), + ao_lisp_cons_cons(ao_lisp_int_poly(3), + ao_lisp_cons_cons(ao_lisp_int_poly(4), NULL)))), + ao_lisp_cons_cons(ao_lisp_int_poly(2), NULL))); printf("list: "); ao_lisp_poly_print(ao_lisp_cons_poly(list)); printf ("\n"); ao_lisp_poly_print(ao_lisp_eval(ao_lisp_cons_poly(list))); printf ("\n"); - while ((poly = ao_lisp_read())) { - poly = ao_lisp_eval(poly); - ao_lisp_poly_print(poly); - putchar ('\n'); - fflush(stdout); - } - + ao_lisp_read_eval_print(); +#endif } -- cgit v1.2.3 From 11cb03b1d336ee90c422be27588f57be573a9546 Mon Sep 17 00:00:00 2001 From: Keith Packard Date: Wed, 2 Nov 2016 22:56:01 -0700 Subject: altos/lisp: Separate out values from atoms This enables changing values of atoms declared as constants, should enable lets, and with some work, even lexical scoping. this required changing the constant computation to run ao_lisp_collect() before dumping the block of constant data, and that uncovered some minor memory manager bugs. Signed-off-by: Keith Packard --- src/lisp/Makefile | 3 +- src/lisp/ao_lisp.h | 105 +++++++++++++++++------ src/lisp/ao_lisp_atom.c | 51 +++++++++-- src/lisp/ao_lisp_builtin.c | 37 ++++++-- src/lisp/ao_lisp_cons.c | 27 +++++- src/lisp/ao_lisp_eval.c | 5 +- src/lisp/ao_lisp_frame.c | 191 ++++++++++++++++++++++++++++++++++++++++++ src/lisp/ao_lisp_make_const.c | 44 ++++++++-- src/lisp/ao_lisp_mem.c | 168 +++++++++++++++++++++++++++++++------ src/lisp/ao_lisp_prim.c | 41 +++++---- src/lisp/ao_lisp_read.c | 23 ++--- src/nucleao-32/Makefile | 3 + src/test/Makefile | 4 +- src/test/ao_lisp_test.c | 3 +- 14 files changed, 597 insertions(+), 108 deletions(-) create mode 100644 src/lisp/ao_lisp_frame.c (limited to 'src/nucleao-32') diff --git a/src/lisp/Makefile b/src/lisp/Makefile index e8c3c02c..9e2fb58c 100644 --- a/src/lisp/Makefile +++ b/src/lisp/Makefile @@ -16,7 +16,8 @@ SRCS=\ ao_lisp_poly.c \ ao_lisp_prim.c \ ao_lisp_builtin.c \ - ao_lisp_read.c + ao_lisp_read.c \ + ao_lisp_frame.c OBJS=$(SRCS:.c=.o) diff --git a/src/lisp/ao_lisp.h b/src/lisp/ao_lisp.h index d4108662..98e99acb 100644 --- a/src/lisp/ao_lisp.h +++ b/src/lisp/ao_lisp.h @@ -15,9 +15,12 @@ #ifndef _AO_LISP_H_ #define _AO_LISP_H_ +#include + #if !defined(AO_LISP_TEST) && !defined(AO_LISP_MAKE_CONST) #include #define AO_LISP_ALTOS 1 +#define abort() ao_panic(1) #endif #include @@ -27,9 +30,14 @@ #ifdef AO_LISP_MAKE_CONST #define AO_LISP_POOL_CONST 16384 extern uint8_t ao_lisp_const[AO_LISP_POOL_CONST]; +#define ao_lisp_pool ao_lisp_const +#define AO_LISP_POOL AO_LISP_POOL_CONST #define _ao_lisp_atom_quote ao_lisp_atom_poly(ao_lisp_atom_intern("quote")) +#define _ao_lisp_atom_set ao_lisp_atom_poly(ao_lisp_atom_intern("set")) #else #include "ao_lisp_const.h" +#define AO_LISP_POOL 1024 +extern uint8_t ao_lisp_pool[AO_LISP_POOL]; #endif /* Primitive types */ @@ -46,13 +54,11 @@ extern uint8_t ao_lisp_const[AO_LISP_POOL_CONST]; /* These have a type value at the start of the struct */ #define AO_LISP_ATOM 4 #define AO_LISP_BUILTIN 5 -#define AO_LISP_NUM_TYPE 6 +#define AO_LISP_FRAME 6 +#define AO_LISP_NUM_TYPE 7 #define AO_LISP_NIL 0 -#define AO_LISP_POOL 1024 - -extern uint8_t ao_lisp_pool[AO_LISP_POOL]; extern uint16_t ao_lisp_top; #define AO_LISP_OOM 0x01 @@ -68,37 +74,31 @@ ao_lisp_is_const(ao_poly poly) { return poly & AO_LISP_CONST; } +#define AO_LISP_POOL_BASE (ao_lisp_pool - 4) +#define AO_LISP_CONST_BASE (ao_lisp_const - 4) + +#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) + static inline void * ao_lisp_ref(ao_poly poly) { if (poly == AO_LISP_NIL) return NULL; if (poly & AO_LISP_CONST) - return (void *) ((ao_lisp_const - 4) + (poly & AO_LISP_REF_MASK)); - else - return (void *) ((ao_lisp_pool - 4) + (poly & AO_LISP_REF_MASK)); + return (void *) (AO_LISP_CONST_BASE + (poly & AO_LISP_REF_MASK)); + return (void *) (AO_LISP_POOL_BASE + (poly & AO_LISP_REF_MASK)); } static inline ao_poly ao_lisp_poly(const void *addr, ao_poly type) { const uint8_t *a = addr; - if (addr == NULL) + if (a == NULL) return AO_LISP_NIL; - if (ao_lisp_pool <= a && a < ao_lisp_pool + AO_LISP_POOL) - return (a - (ao_lisp_pool - 4)) | type; - else if (ao_lisp_const <= a && a <= ao_lisp_const + AO_LISP_POOL_CONST) - return AO_LISP_CONST | (a - (ao_lisp_const - 4)) | type; - else { - ao_lisp_exception |= AO_LISP_INVALID; - return AO_LISP_NIL; - } + if (AO_LISP_IS_CONST(a)) + return AO_LISP_CONST | (a - AO_LISP_CONST_BASE) | type; + return (a - AO_LISP_POOL_BASE) | type; } -#define AO_LISP_POLY(addr, type) (((ao_lisp_pool <= ((uint8_t *) (a)) && \ - ((uint8_t *) (a)) < ao_lisp_pool + AO_LISP_POOL) ? \ - ((uint8_t *) (a) - (ao_lisp_pool - 4)) : \ - (((uint8_t *) (a) - (ao_lisp_const - 4)) | AO_LISP_POOL_CONST)) | \ - (type)) - struct ao_lisp_type { void (*mark)(void *addr); int (*size)(void *addr); @@ -113,11 +113,32 @@ struct ao_lisp_cons { struct ao_lisp_atom { uint8_t type; uint8_t pad[1]; - ao_poly val; ao_poly next; char name[]; }; +struct ao_lisp_val { + ao_poly atom; + ao_poly val; +}; + +struct ao_lisp_frame { + uint8_t num; + uint8_t readonly; + ao_poly next; + struct ao_lisp_val vals[]; +}; + +static inline struct ao_lisp_frame * +ao_lisp_poly_frame(ao_poly poly) { + return ao_lisp_ref(poly); +} + +static inline ao_poly +ao_lisp_frame_poly(struct ao_lisp_frame *frame) { + return ao_lisp_poly(frame, AO_LISP_OTHER); +} + #define AO_LISP_LAMBDA 0 #define AO_LISP_NLAMBDA 1 #define AO_LISP_MACRO 2 @@ -160,6 +181,11 @@ ao_lisp_poly_other(ao_poly poly) { return ao_lisp_ref(poly); } +static inline uint8_t +ao_lisp_other_type(void *other) { + return *((uint8_t *) other); +} + static inline ao_poly ao_lisp_other_poly(const void *other) { @@ -175,9 +201,9 @@ ao_lisp_mem_round(int size) #define AO_LISP_OTHER_POLY(other) ((ao_poly)(other) + AO_LISP_OTHER) static inline int ao_lisp_poly_type(ao_poly poly) { - int type = poly & 3; + int type = poly & AO_LISP_TYPE_MASK; if (type == AO_LISP_OTHER) - return *((uint8_t *) ao_lisp_poly_other(poly)); + return ao_lisp_other_type(ao_lisp_poly_other(poly)); return type; } @@ -249,6 +275,9 @@ ao_lisp_mark(const struct ao_lisp_type *type, void *addr); int ao_lisp_mark_memory(void *addr, int size); +void * +ao_lisp_move_map(void *addr); + void * ao_lisp_move(const struct ao_lisp_type *type, void *addr); @@ -259,6 +288,9 @@ ao_lisp_move_memory(void *addr, int size); void * ao_lisp_alloc(int size); +void +ao_lisp_collect(void); + int ao_lisp_root_add(const struct ao_lisp_type *type, void *addr); @@ -303,6 +335,12 @@ ao_lisp_atom_print(ao_poly a); struct ao_lisp_atom * ao_lisp_atom_intern(char *name); +ao_poly +ao_lisp_atom_get(ao_poly atom); + +ao_poly +ao_lisp_atom_set(ao_poly atom, ao_poly val); + /* int */ void ao_lisp_int_print(ao_poly i); @@ -325,6 +363,8 @@ ao_lisp_eval(ao_poly p); void ao_lisp_builtin_print(ao_poly b); +extern const struct ao_lisp_type ao_lisp_builtin_type; + /* read */ ao_poly ao_lisp_read(void); @@ -333,4 +373,19 @@ ao_lisp_read(void); ao_poly ao_lisp_read_eval_print(void); +/* frame */ +extern const struct ao_lisp_type ao_lisp_frame_type; + +int +ao_lisp_frame_set(struct ao_lisp_frame *frame, ao_poly atom, ao_poly val); + +ao_poly +ao_lisp_frame_get(struct ao_lisp_frame *frame, ao_poly atom); + +struct ao_lisp_frame * +ao_lisp_frame_new(int num, int readonly); + +struct ao_lisp_frame * +ao_lisp_frame_add(struct ao_lisp_frame *frame, ao_poly atom, ao_poly val); + #endif /* _AO_LISP_H_ */ diff --git a/src/lisp/ao_lisp_atom.c b/src/lisp/ao_lisp_atom.c index aaa84b8d..e5d28c3b 100644 --- a/src/lisp/ao_lisp_atom.c +++ b/src/lisp/ao_lisp_atom.c @@ -17,6 +17,12 @@ #include "ao_lisp.h" +#if 0 +#define DBG(...) printf(__VA_ARGS__) +#else +#define DBG(...) +#endif + static int name_size(char *name) { return sizeof(struct ao_lisp_atom) + strlen(name) + 1; @@ -34,31 +40,38 @@ static void atom_mark(void *addr) { struct ao_lisp_atom *atom = addr; + DBG ("\tatom start %s\n", atom->name); for (;;) { - ao_lisp_poly_mark(atom->val); atom = ao_lisp_poly_atom(atom->next); if (!atom) break; + DBG("\t\tatom mark %s %d\n", atom->name, (uint8_t *) atom - ao_lisp_const); if (ao_lisp_mark_memory(atom, atom_size(atom))) break; } + DBG ("\tatom done\n"); } static void atom_move(void *addr) { struct ao_lisp_atom *atom = addr; + DBG("\tatom move start %s %d next %s %d\n", + atom->name, ((uint8_t *) atom - ao_lisp_const), + atom->next ? ao_lisp_poly_atom(atom->next)->name : "(none)", + atom->next ? ((uint8_t *) ao_lisp_poly_atom(atom->next) - ao_lisp_const) : 0); for (;;) { struct ao_lisp_atom *next; - atom->val = ao_lisp_poly_move(atom->val); next = ao_lisp_poly_atom(atom->next); next = ao_lisp_move_memory(next, atom_size(next)); if (!next) break; + DBG("\t\tatom move %s %d->%d\n", next->name, ((uint8_t *) ao_lisp_poly_atom(atom->next) - ao_lisp_const), ((uint8_t *) next - ao_lisp_const)); atom->next = ao_lisp_atom_poly(next); atom = next; } + DBG("\tatom move end\n"); } const struct ao_lisp_type ao_lisp_atom_type = { @@ -73,7 +86,6 @@ struct ao_lisp_atom * ao_lisp_atom_intern(char *name) { struct ao_lisp_atom *atom; -// int b; for (atom = ao_lisp_atoms; atom; atom = ao_lisp_poly_atom(atom->next)) { if (!strcmp(atom->name, name)) @@ -85,19 +97,46 @@ ao_lisp_atom_intern(char *name) return atom; } #endif - if (!ao_lisp_atoms) - ao_lisp_root_add(&ao_lisp_atom_type, (void **) &ao_lisp_atoms); atom = ao_lisp_alloc(name_size(name)); if (atom) { atom->type = AO_LISP_ATOM; atom->next = ao_lisp_atom_poly(ao_lisp_atoms); + if (!ao_lisp_atoms) + ao_lisp_root_add(&ao_lisp_atom_type, &ao_lisp_atoms); ao_lisp_atoms = atom; strcpy(atom->name, name); - atom->val = AO_LISP_NIL; } return atom; } +static struct ao_lisp_frame *globals; + +ao_poly +ao_lisp_atom_get(ao_poly atom) +{ + struct ao_lisp_frame *frame = globals; +#ifdef ao_builtin_frame + if (!frame) + frame = ao_lisp_poly_frame(ao_builtin_frame); +#endif + return ao_lisp_frame_get(frame, atom); +} + +ao_poly +ao_lisp_atom_set(ao_poly atom, ao_poly val) +{ + if (!ao_lisp_frame_set(globals, atom, val)) { + globals = ao_lisp_frame_add(globals, atom, val); + if (!globals->next) { + ao_lisp_root_add(&ao_lisp_frame_type, &globals); +#ifdef ao_builtin_frame + globals->next = ao_builtin_frame; +#endif + } + } + return val; +} + void ao_lisp_atom_print(ao_poly a) { diff --git a/src/lisp/ao_lisp_builtin.c b/src/lisp/ao_lisp_builtin.c index 63fb69fd..8c481793 100644 --- a/src/lisp/ao_lisp_builtin.c +++ b/src/lisp/ao_lisp_builtin.c @@ -14,6 +14,31 @@ #include "ao_lisp.h" +static int +builtin_size(void *addr) +{ + (void) addr; + return sizeof (struct ao_lisp_builtin); +} + +static void +builtin_mark(void *addr) +{ + (void) addr; +} + +static void +builtin_move(void *addr) +{ + (void) addr; +} + +const struct ao_lisp_type ao_lisp_builtin_type = { + .size = builtin_size, + .mark = builtin_mark, + .move = builtin_move +}; + void ao_lisp_builtin_print(ao_poly b) { @@ -120,20 +145,12 @@ ao_lisp_quote(struct ao_lisp_cons *cons) ao_poly ao_lisp_set(struct ao_lisp_cons *cons) { - ao_poly atom, val; if (!check_argc(cons, 2, 2)) return AO_LISP_NIL; if (!check_argt(cons, 0, AO_LISP_ATOM, 0)) return AO_LISP_NIL; - atom = cons->car; - val = ao_lisp_poly_cons(cons->cdr)->car; - if (ao_lisp_is_const(atom)) { - ao_lisp_exception |= AO_LISP_INVALID; - return AO_LISP_NIL; - } - ao_lisp_poly_atom(atom)->val = val; - return val; + return ao_lisp_atom_set(cons->car, ao_lisp_poly_cons(cons->cdr)->car); } ao_poly @@ -157,6 +174,8 @@ ao_lisp_print(struct ao_lisp_cons *cons) val = cons->car; ao_lisp_poly_print(val); cons = ao_lisp_poly_cons(cons->cdr); + if (cons) + printf(" "); } return val; } diff --git a/src/lisp/ao_lisp_cons.c b/src/lisp/ao_lisp_cons.c index 65908e30..f8a34ed4 100644 --- a/src/lisp/ao_lisp_cons.c +++ b/src/lisp/ao_lisp_cons.c @@ -14,6 +14,23 @@ #include "ao_lisp.h" +#define OFFSET(a) ((int) ((uint8_t *) (a) - ao_lisp_const)) + +#if 0 +static int cons_depth; +#define DBG(...) do { int d; for (d = 0; d < cons_depth; d++) printf (" "); printf(__VA_ARGS__); } while(0) +#define DBG_IN() (cons_depth++) +#define DBG_OUT() (cons_depth--) +#define DBG_PR(c) ao_lisp_cons_print(ao_lisp_cons_poly(c)) +#define DBG_PRP(p) ao_lisp_poly_print(p) +#else +#define DBG(...) +#define DBG_IN() +#define DBG_OUT() +#define DBG_PR(c) +#define DBG_PRP(p) +#endif + static void cons_mark(void *addr) { struct ao_lisp_cons *cons = addr; @@ -38,17 +55,25 @@ static void cons_move(void *addr) { struct ao_lisp_cons *cons = addr; + DBG_IN(); + DBG("move cons start %d\n", OFFSET(cons)); for (;;) { struct ao_lisp_cons *cdr; + ao_poly car; - cons->car = ao_lisp_poly_move(cons->car); + car = ao_lisp_poly_move(cons->car); + DBG(" moved car %d -> %d\n", OFFSET(ao_lisp_ref(cons->car)), OFFSET(ao_lisp_ref(car))); + cons->car = car; cdr = ao_lisp_poly_cons(cons->cdr); cdr = ao_lisp_move_memory(cdr, sizeof (struct ao_lisp_cons)); if (!cdr) break; + DBG(" moved cdr %d -> %d\n", OFFSET(ao_lisp_poly_cons(cons->cdr)), OFFSET(cdr)); cons->cdr = ao_lisp_cons_poly(cdr); cons = cdr; } + DBG("move cons end\n"); + DBG_OUT(); } const struct ao_lisp_type ao_lisp_cons_type = { diff --git a/src/lisp/ao_lisp_eval.c b/src/lisp/ao_lisp_eval.c index 2374fdb2..6eef1f23 100644 --- a/src/lisp/ao_lisp_eval.c +++ b/src/lisp/ao_lisp_eval.c @@ -91,7 +91,7 @@ ao_lisp_eval(ao_poly v) case AO_LISP_STRING: break; case AO_LISP_ATOM: - v = ao_lisp_poly_atom(v)->val; + v = ao_lisp_atom_get(v); break; } @@ -187,6 +187,9 @@ ao_lisp_eval(ao_poly v) DBG("stack pop: actuals"); DBG_CONS(actuals); DBG("\n"); DBG("stack pop: formals"); DBG_CONS(formals); DBG("\n"); } else { + actuals = 0; + formals = 0; + formals_tail = 0; DBG("done func\n"); break; } diff --git a/src/lisp/ao_lisp_frame.c b/src/lisp/ao_lisp_frame.c new file mode 100644 index 00000000..5aa50f6b --- /dev/null +++ b/src/lisp/ao_lisp_frame.c @@ -0,0 +1,191 @@ +/* + * Copyright © 2016 Keith Packard + * + * 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" + +#if 0 +#define DBG(...) printf(__VA_ARGS__) +#else +#define DBG(...) +#endif + +static inline int +frame_num_size(int num) +{ + return sizeof (struct ao_lisp_frame) + num * sizeof (struct ao_lisp_val); +} + +static int +frame_size(void *addr) +{ + struct ao_lisp_frame *frame = addr; + return frame_num_size(frame->num); +} + +#define OFFSET(a) ((uint8_t *) (ao_lisp_ref(a)) - ao_lisp_const) + +static void +frame_mark(void *addr) +{ + struct ao_lisp_frame *frame = addr; + int f; + + for (;;) { + if (frame->readonly) + break; + for (f = 0; f < frame->num; f++) { + struct ao_lisp_val *v = &frame->vals[f]; + + ao_lisp_poly_mark(v->atom); + ao_lisp_poly_mark(v->val); + DBG ("\tframe mark atom %s %d val %d at %d\n", ao_lisp_poly_atom(v->atom)->name, OFFSET(v->atom), OFFSET(v->val), f); + } + frame = ao_lisp_poly_frame(frame->next); + if (!frame) + break; + if (ao_lisp_mark_memory(frame, frame_size(frame))) + break; + } +} + +static void +frame_move(void *addr) +{ + struct ao_lisp_frame *frame = addr; + int f; + + for (;;) { + struct ao_lisp_frame *next; + if (frame->readonly) + break; + for (f = 0; f < frame->num; f++) { + struct ao_lisp_val *v = &frame->vals[f]; + ao_poly t; + + t = ao_lisp_poly_move(v->atom); + DBG("\t\tatom %s %d -> %d\n", ao_lisp_poly_atom(t)->name, OFFSET(v->atom), OFFSET(t)); + v->atom = t; + t = ao_lisp_poly_move(v->val); + DBG("\t\tval %d -> %d\n", OFFSET(v->val), OFFSET(t)); + v->val = t; + } + next = ao_lisp_poly_frame(frame->next); + if (!next) + break; + next = ao_lisp_move_memory(next, frame_size(next)); + frame->next = ao_lisp_frame_poly(next); + frame = next; + } +} + +const struct ao_lisp_type ao_lisp_frame_type = { + .mark = frame_mark, + .size = frame_size, + .move = frame_move +}; + +static ao_poly * +ao_lisp_frame_ref(struct ao_lisp_frame *frame, ao_poly atom) +{ + int f; + for (f = 0; f < frame->num; f++) + if (frame->vals[f].atom == atom) + return &frame->vals[f].val; + return NULL; +} + +int +ao_lisp_frame_set(struct ao_lisp_frame *frame, ao_poly atom, ao_poly val) +{ + while (frame) { + if (!frame->readonly) { + ao_poly *ref = ao_lisp_frame_ref(frame, atom); + if (ref) { + *ref = val; + return 1; + } + } + frame = ao_lisp_poly_frame(frame->next); + } + return 0; +} + +ao_poly +ao_lisp_frame_get(struct ao_lisp_frame *frame, ao_poly atom) +{ + while (frame) { + ao_poly *ref = ao_lisp_frame_ref(frame, atom); + if (ref) + return *ref; + frame = ao_lisp_poly_frame(frame->next); + } + return AO_LISP_NIL; +} + +struct ao_lisp_frame * +ao_lisp_frame_new(int num, int readonly) +{ + struct ao_lisp_frame *frame = ao_lisp_alloc(frame_num_size(num)); + + if (!frame) + return NULL; + frame->num = num; + frame->readonly = readonly; + frame->next = AO_LISP_NIL; + memset(frame->vals, '\0', num * sizeof (struct ao_lisp_val)); + return frame; +} + +static struct ao_lisp_frame * +ao_lisp_frame_realloc(struct ao_lisp_frame *frame, int new_num, int readonly) +{ + struct ao_lisp_frame *new; + int copy; + + if (new_num == frame->num) + return frame; + new = ao_lisp_frame_new(new_num, readonly); + if (!new) + return NULL; + copy = new_num; + if (copy > frame->num) + copy = frame->num; + memcpy(new->vals, frame->vals, copy * sizeof (struct ao_lisp_val)); + if (frame) + new->next = frame->next; + return new; +} + +struct ao_lisp_frame * +ao_lisp_frame_add(struct ao_lisp_frame *frame, ao_poly atom, ao_poly val) +{ + ao_poly *ref = frame ? ao_lisp_frame_ref(frame, atom) : NULL; + if (!ref) { + int f; + if (frame) { + f = frame->num; + frame = ao_lisp_frame_realloc(frame, f + 1, frame->readonly); + } else { + f = 0; + frame = ao_lisp_frame_new(1, 0); + } + if (!frame) + return NULL; + DBG ("add atom %s %d, val %d at %d\n", ao_lisp_poly_atom(atom)->name, OFFSET(atom), OFFSET(val), f); + frame->vals[f].atom = atom; + ref = &frame->vals[f].val; + } + *ref = val; + return frame; +} diff --git a/src/lisp/ao_lisp_make_const.c b/src/lisp/ao_lisp_make_const.c index 8d3e03a9..6b603979 100644 --- a/src/lisp/ao_lisp_make_const.c +++ b/src/lisp/ao_lisp_make_const.c @@ -49,19 +49,43 @@ struct builtin_func funcs[] = { #define N_FUNC (sizeof funcs / sizeof funcs[0]) +struct ao_lisp_frame *globals; + +static int +is_atom(int offset) +{ + struct ao_lisp_atom *a; + + for (a = ao_lisp_atoms; a; a = ao_lisp_poly_atom(a->next)) + if (((uint8_t *) a->name - ao_lisp_const) == offset) + return strlen(a->name); + return 0; +} + int main(int argc, char **argv) { int f, o; ao_poly atom, val; struct ao_lisp_atom *a; + int in_atom; + printf("/*\n"); + printf(" * Generated file, do not edit\n"); + ao_lisp_root_add(&ao_lisp_frame_type, &globals); + globals = ao_lisp_frame_new(0, 0); for (f = 0; f < N_FUNC; f++) { struct ao_lisp_builtin *b = ao_lisp_make_builtin(funcs[f].func, funcs[f].args); struct ao_lisp_atom *a = ao_lisp_atom_intern(funcs[f].name); - a->val = ao_lisp_builtin_poly(b); + globals = ao_lisp_frame_add(globals, ao_lisp_atom_poly(a), ao_lisp_builtin_poly(b)); } + /* boolean constants */ + a = ao_lisp_atom_intern("nil"); + globals = ao_lisp_frame_add(globals, ao_lisp_atom_poly(a), AO_LISP_NIL); + a = ao_lisp_atom_intern("t"); + globals = ao_lisp_frame_add(globals, ao_lisp_atom_poly(a), ao_lisp_atom_poly(a)); + for (;;) { atom = ao_lisp_read(); if (!atom) @@ -73,13 +97,19 @@ main(int argc, char **argv) fprintf(stderr, "input must be atom val pairs\n"); exit(1); } - ao_lisp_poly_atom(atom)->val = val; + globals = ao_lisp_frame_add(globals, atom, val); } - printf("/* constant objects, all referenced from atoms */\n\n"); + /* Reduce to referenced values */ + ao_lisp_collect(); + printf(" */\n"); + + globals->readonly = 1; + printf("#define AO_LISP_POOL_CONST %d\n", ao_lisp_top); printf("extern const uint8_t ao_lisp_const[AO_LISP_POOL_CONST] __attribute__((aligned(4)));\n"); printf("#define ao_builtin_atoms 0x%04x\n", ao_lisp_atom_poly(ao_lisp_atoms)); + printf("#define ao_builtin_frame 0x%04x\n", ao_lisp_frame_poly(globals)); for (a = ao_lisp_atoms; a; a = ao_lisp_poly_atom(a->next)) { char *n = a->name, c; @@ -101,10 +131,14 @@ main(int argc, char **argv) else printf(" "); c = ao_lisp_const[o]; - if (' ' < c && c <= '~' && c != '\'') + if (!in_atom) + in_atom = is_atom(o); + if (in_atom) { printf (" '%c',", c); - else + in_atom--; + } else { printf("0x%02x,", c); + } } printf("\n};\n"); printf("#endif /* AO_LISP_CONST_BITS */\n"); diff --git a/src/lisp/ao_lisp_mem.c b/src/lisp/ao_lisp_mem.c index 7295d150..27f5b666 100644 --- a/src/lisp/ao_lisp_mem.c +++ b/src/lisp/ao_lisp_mem.c @@ -17,11 +17,32 @@ #include "ao_lisp.h" #include -uint8_t ao_lisp_pool[AO_LISP_POOL] __attribute__((aligned(4))); - #ifdef AO_LISP_MAKE_CONST #include uint8_t ao_lisp_const[AO_LISP_POOL_CONST] __attribute__((aligned(4))); +#define ao_lisp_pool ao_lisp_const +#undef AO_LISP_POOL +#define AO_LISP_POOL AO_LISP_POOL_CONST +#else +uint8_t ao_lisp_pool[AO_LISP_POOL] __attribute__((aligned(4))); +#endif + +#if 0 +#define DBG_DUMP +#define DBG_OFFSET(a) ((int) ((uint8_t *) (a) - ao_lisp_pool)) +#define DBG(...) printf(__VA_ARGS__) +static int move_dump; +static int move_depth; +#define DBG_RESET() (move_depth = 0) +#define DBG_MOVE(...) do { if(move_dump) { int d; for (d = 0; d < move_depth; d++) printf (" "); printf(__VA_ARGS__); } } while (0) +#define DBG_MOVE_IN() (move_depth++) +#define DBG_MOVE_OUT() (move_depth--) +#else +#define DBG(...) +#define DBG_RESET() +#define DBG_MOVE(...) +#define DBG_MOVE_IN() +#define DBG_MOVE_OUT() #endif uint8_t ao_lisp_exception; @@ -112,6 +133,23 @@ clear_object(uint8_t *tag, void *addr, int size) { return 0; } +static int +busy_object(uint8_t *tag, void *addr) { + int base; + + if (!addr) + return 1; + + if ((uint8_t *) addr < ao_lisp_pool || ao_lisp_pool + AO_LISP_POOL <= (uint8_t*) addr) + return 1; + + base = (uint8_t *) addr - ao_lisp_pool; + base = limit(base); + if (busy(tag, base)) + return 1; + return 0; +} + static void *move_old, *move_new; static int move_size; @@ -120,53 +158,96 @@ move_object(void) { int i; + DBG_RESET(); + DBG_MOVE("move %d -> %d\n", DBG_OFFSET(move_old), DBG_OFFSET(move_new)); + DBG_MOVE_IN(); memset(ao_lisp_moving, '\0', sizeof (ao_lisp_moving)); for (i = 0; i < AO_LISP_ROOT; i++) - if (ao_lisp_root[i].addr) { + if (ao_lisp_root[i].addr && *ao_lisp_root[i].addr) { void *new; + DBG_MOVE("root %d\n", DBG_OFFSET(*ao_lisp_root[i].addr)); new = ao_lisp_move(ao_lisp_root[i].type, *ao_lisp_root[i].addr); if (new) *ao_lisp_root[i].addr = new; } + DBG_MOVE_OUT(); + DBG_MOVE("move done\n"); } +#ifdef DBG_DUMP static void -collect(void) +dump_busy(void) +{ + int i; + printf("busy:"); + for (i = 0; i < ao_lisp_top; i += 4) { + if ((i & 0xff) == 0) + printf("\n"); + else if ((i & 0x1f) == 0) + printf(" "); + if (busy(ao_lisp_busy, i)) + putchar('*'); + else + putchar('-'); + } + printf ("\n"); +} +#define DUMP_BUSY() dump_busy() +#else +#define DUMP_BUSY() +#endif + +void +ao_lisp_collect(void) { int i; + int top; /* Mark */ memset(ao_lisp_busy, '\0', sizeof (ao_lisp_busy)); + DBG("mark\n"); for (i = 0; i < AO_LISP_ROOT; i++) - if (ao_lisp_root[i].addr) + if (ao_lisp_root[i].addr && *ao_lisp_root[i].addr) { + DBG("root %p\n", *ao_lisp_root[i].addr); ao_lisp_mark(ao_lisp_root[i].type, *ao_lisp_root[i].addr); + } + DUMP_BUSY(); /* Compact */ - ao_lisp_top = 0; - for (i = 0; i < AO_LISP_POOL; i += 4) { + DBG("find first busy\n"); + for (i = 0; i < ao_lisp_top; i += 4) { if (!busy(ao_lisp_busy, i)) break; } - ao_lisp_top = i; - while(i < AO_LISP_POOL) { + top = i; + while(i < ao_lisp_top) { if (busy(ao_lisp_busy, i)) { + DBG("busy %d -> %d\n", i, top); move_old = &ao_lisp_pool[i]; - move_new = &ao_lisp_pool[ao_lisp_top]; + move_new = &ao_lisp_pool[top]; move_size = 0; move_object(); + DBG("\tbusy size %d\n", move_size); + if (move_size == 0) + abort(); clear_object(ao_lisp_busy, move_old, move_size); + mark_object(ao_lisp_busy, move_new, move_size); i += move_size; - ao_lisp_top += move_size; + top += move_size; + DUMP_BUSY(); } else { i += 4; } } + ao_lisp_top = top; } void ao_lisp_mark(const struct ao_lisp_type *type, void *addr) { + if (!addr) + return; if (mark_object(ao_lisp_busy, addr, type->size(addr))) return; type->mark(addr); @@ -178,12 +259,32 @@ ao_lisp_mark_memory(void *addr, int size) return mark_object(ao_lisp_busy, addr, size); } +/* + * After the object has been moved, we have to reference it + * in the new location. This is only relevant for ao_lisp_poly_move + * as it needs to fetch the type byte from the object, which + * may have been overwritten by the copy + */ +void * +ao_lisp_move_map(void *addr) +{ + if (addr == move_old) { + if (busy_object(ao_lisp_moving, addr)) + return move_new; + } + return addr; +} + static void * check_move(void *addr, int size) { if (addr == move_old) { - memmove(move_new, move_old, size); - move_size = (size + 3) & ~3; + DBG_MOVE("mapping %d -> %d\n", DBG_OFFSET(addr), DBG_OFFSET(move_new)); + if (!busy_object(ao_lisp_moving, addr)) { + DBG_MOVE(" copy %d\n", size); + memmove(move_new, move_old, size); + move_size = (size + 3) & ~3; + } addr = move_new; } return addr; @@ -192,15 +293,32 @@ check_move(void *addr, int size) void * ao_lisp_move(const struct ao_lisp_type *type, void *addr) { + uint8_t *a = addr; int size = type->size(addr); if (!addr) return NULL; +#ifndef AO_LISP_MAKE_CONST + if (AO_LISP_IS_CONST(addr)) + return addr; +#endif + DBG_MOVE("object %d\n", DBG_OFFSET(addr)); + if (a < ao_lisp_pool || ao_lisp_pool + AO_LISP_POOL <= a) + abort(); + DBG_MOVE_IN(); addr = check_move(addr, size); - if (mark_object(ao_lisp_moving, addr, size)) + if (mark_object(ao_lisp_moving, addr, size)) { + DBG_MOVE("already moved\n"); + DBG_MOVE_OUT(); return addr; + } + DBG_MOVE_OUT(); + DBG_MOVE("recursing...\n"); + DBG_MOVE_IN(); type->move(addr); + DBG_MOVE_OUT(); + DBG_MOVE("done %d\n", DBG_OFFSET(addr)); return addr; } @@ -210,9 +328,15 @@ ao_lisp_move_memory(void *addr, int size) if (!addr) return NULL; + DBG_MOVE("memory %d\n", DBG_OFFSET(addr)); + DBG_MOVE_IN(); addr = check_move(addr, size); - if (mark_object(ao_lisp_moving, addr, size)) - return NULL; + if (mark_object(ao_lisp_moving, addr, size)) { + DBG_MOVE("already moved\n"); + DBG_MOVE_OUT(); + return addr; + } + DBG_MOVE_OUT(); return addr; } @@ -222,22 +346,14 @@ ao_lisp_alloc(int size) void *addr; size = ao_lisp_mem_round(size); -#ifdef AO_LISP_MAKE_CONST - if (ao_lisp_top + size > AO_LISP_POOL_CONST) { - fprintf(stderr, "Too much constant data, increase AO_LISP_POOL_CONST\n"); - exit(1); - } - addr = ao_lisp_const + ao_lisp_top; -#else if (ao_lisp_top + size > AO_LISP_POOL) { - collect(); + ao_lisp_collect(); if (ao_lisp_top + size > AO_LISP_POOL) { ao_lisp_exception |= AO_LISP_OOM; return NULL; } } addr = ao_lisp_pool + ao_lisp_top; -#endif ao_lisp_top += size; return addr; } @@ -246,6 +362,7 @@ int ao_lisp_root_add(const struct ao_lisp_type *type, void *addr) { int i; + DBG("add root type %p addr %p\n", type, addr); for (i = 0; i < AO_LISP_ROOT; i++) { if (!ao_lisp_root[i].addr) { ao_lisp_root[i].addr = addr; @@ -253,6 +370,7 @@ ao_lisp_root_add(const struct ao_lisp_type *type, void *addr) return 1; } } + abort(); return 0; } diff --git a/src/lisp/ao_lisp_prim.c b/src/lisp/ao_lisp_prim.c index 38dcb961..e9367553 100644 --- a/src/lisp/ao_lisp_prim.c +++ b/src/lisp/ao_lisp_prim.c @@ -31,35 +31,32 @@ ao_lisp_poly_print(ao_poly p) return p; } +static const struct ao_lisp_type const *ao_lisp_types[AO_LISP_NUM_TYPE] = { + [AO_LISP_CONS] = &ao_lisp_cons_type, + [AO_LISP_STRING] = &ao_lisp_string_type, + [AO_LISP_ATOM] = &ao_lisp_atom_type, + [AO_LISP_BUILTIN] = &ao_lisp_builtin_type, +}; + void ao_lisp_poly_mark(ao_poly p) { - switch (ao_lisp_poly_type(p)) { - case AO_LISP_CONS: - ao_lisp_mark(&ao_lisp_cons_type, ao_lisp_poly_cons(p)); - break; - case AO_LISP_STRING: - ao_lisp_mark(&ao_lisp_string_type, ao_lisp_poly_string(p)); - break; - case AO_LISP_ATOM: - ao_lisp_mark(&ao_lisp_atom_type, ao_lisp_poly_atom(p)); - break; - } + const struct ao_lisp_type *lisp_type = ao_lisp_types[ao_lisp_poly_type(p)]; + if (lisp_type) + ao_lisp_mark(lisp_type, ao_lisp_ref(p)); } ao_poly ao_lisp_poly_move(ao_poly p) { - switch (ao_lisp_poly_type(p)) { - case AO_LISP_CONS: - p = ao_lisp_cons_poly(ao_lisp_move(&ao_lisp_cons_type, ao_lisp_poly_cons(p))); - break; - case AO_LISP_STRING: - p = ao_lisp_string_poly(ao_lisp_move(&ao_lisp_string_type, ao_lisp_poly_string(p))); - break; - case AO_LISP_ATOM: - p = ao_lisp_atom_poly(ao_lisp_move(&ao_lisp_atom_type, ao_lisp_poly_atom(p))); - break; - } + uint8_t type = p & AO_LISP_TYPE_MASK; + const struct ao_lisp_type *lisp_type; + + if (type == AO_LISP_OTHER) + type = ao_lisp_other_type(ao_lisp_move_map(ao_lisp_poly_other(p))); + + lisp_type = ao_lisp_types[type]; + if (lisp_type) + p = ao_lisp_poly(ao_lisp_move(lisp_type, ao_lisp_ref(p)), p & AO_LISP_TYPE_MASK); return p; } diff --git a/src/lisp/ao_lisp_read.c b/src/lisp/ao_lisp_read.c index 8fc134e5..bc1eb36b 100644 --- a/src/lisp/ao_lisp_read.c +++ b/src/lisp/ao_lisp_read.c @@ -188,8 +188,6 @@ lex_quoted (void) int count; c = lex_get(); -// if (jumping) -// return nil; if (c == EOF) return EOF; c &= 0x7f; @@ -218,8 +216,6 @@ lex_quoted (void) count = 1; while (count <= 3) { c = lex_get(); -// if (jumping) -// return nil; if (c == EOF) return EOF; c &= 0x7f; @@ -288,11 +284,17 @@ lex(void) if (lex_class & ENDOFFILE) return AO_LISP_NIL; -// if (jumping) -// return nil; if (lex_class & WHITE) continue; + if (lex_class & COMMENT) { + while ((c = lexc()) != '\n') { + if (lex_class & ENDOFFILE) + return AO_LISP_NIL; + } + continue; + } + if (lex_class & (BRA|KET|QUOTEC)) { add_token(c); end_token(); @@ -312,8 +314,6 @@ lex(void) if (lex_class & STRINGC) { for (;;) { c = lexc(); -// if (jumping) -// return nil; if (lex_class & (STRINGC|ENDOFFILE)) { end_token(); return STRING; @@ -349,8 +349,6 @@ lex(void) } add_token (c); c = lexc (); -// if (jumping) -// return nil; if (lex_class & (NOTNAME)) { // if (lex_class & ENDOFFILE) // clearerr (f); @@ -403,6 +401,10 @@ pop_read_stack(int cons) read_cons_tail && read_cons_tail->cdr; read_cons_tail = ao_lisp_poly_cons(read_cons_tail->cdr)) ; + } else { + read_cons = 0; + read_cons_tail = 0; + read_stack = 0; } return in_quote; } @@ -420,6 +422,7 @@ ao_lisp_read(void) ao_lisp_root_add(&ao_lisp_cons_type, &read_cons); ao_lisp_root_add(&ao_lisp_cons_type, &read_cons_tail); ao_lisp_root_add(&ao_lisp_cons_type, &read_stack); + been_here = 1; } parse_token = lex(); diff --git a/src/nucleao-32/Makefile b/src/nucleao-32/Makefile index 0df44317..1b7e0bb0 100644 --- a/src/nucleao-32/Makefile +++ b/src/nucleao-32/Makefile @@ -13,6 +13,8 @@ INC = \ ao_pins.h \ ao_product.h \ ao_task.h \ + ao_lisp.h \ + ao_lisp_const.h \ stm32f0.h \ Makefile @@ -43,6 +45,7 @@ ALTOS_SRC = \ ao_lisp_builtin.c \ ao_lisp_read.c \ ao_lisp_rep.c \ + ao_lisp_frame.c \ ao_exti_stm.c PRODUCT=Nucleo-32 diff --git a/src/test/Makefile b/src/test/Makefile index 6c51c421..bd195161 100644 --- a/src/test/Makefile +++ b/src/test/Makefile @@ -91,7 +91,9 @@ ao_quaternion_test: ao_quaternion_test.c ao_quaternion.h #AO_LISP_OBJS = ao_lisp_test.o ao_lisp_mem.o ao_lisp_lex.o ao_lisp_cons.o ao_lisp_string.o ao_lisp_atom.o ao_lisp_int.o ao_lisp_prim.o ao_lisp_eval.o ao_lisp_poly.o ao_lisp_builtin.o ao_lisp_read.o -AO_LISP_OBJS = ao_lisp_test.o ao_lisp_mem.o ao_lisp_cons.o ao_lisp_string.o ao_lisp_atom.o ao_lisp_int.o ao_lisp_prim.o ao_lisp_eval.o ao_lisp_poly.o ao_lisp_builtin.o ao_lisp_read.o ao_lisp_rep.o +AO_LISP_OBJS = ao_lisp_test.o ao_lisp_mem.o ao_lisp_cons.o ao_lisp_string.o \ + ao_lisp_atom.o ao_lisp_int.o ao_lisp_prim.o ao_lisp_eval.o ao_lisp_poly.o \ + ao_lisp_builtin.o ao_lisp_read.o ao_lisp_rep.o ao_lisp_frame.o ao_lisp_test: $(AO_LISP_OBJS) cc $(CFLAGS) -o $@ $(AO_LISP_OBJS) diff --git a/src/test/ao_lisp_test.c b/src/test/ao_lisp_test.c index 810a1528..e303869f 100644 --- a/src/test/ao_lisp_test.c +++ b/src/test/ao_lisp_test.c @@ -36,7 +36,6 @@ main (int argc, char **argv) list = ao_lisp_cons_cons(ao_lisp_string_poly(string), list); list = ao_lisp_cons_cons(ao_lisp_int_poly(i), list); atom = ao_lisp_atom_intern("ant"); - atom->val = ao_lisp_cons_poly(list); list = ao_lisp_cons_cons(ao_lisp_atom_poly(atom), list); } ao_lisp_poly_print(ao_lisp_cons_poly(list)); @@ -45,7 +44,7 @@ main (int argc, char **argv) for (atom = ao_lisp_poly_atom(ao_builtin_atoms); atom; atom = ao_lisp_poly_atom(atom->next)) { printf("%s = ", atom->name); - ao_lisp_poly_print(atom->val); + ao_lisp_poly_print(ao_lisp_atom_get(ao_lisp_atom_poly(atom))); printf("\n"); } #if 1 -- cgit v1.2.3 From 77db0e8162cd01c2b42737b3d71b38cea942484f Mon Sep 17 00:00:00 2001 From: Keith Packard Date: Thu, 3 Nov 2016 21:49:50 -0700 Subject: altos: Add lambda support to lisp Signed-off-by: Keith Packard --- src/lisp/Makefile | 3 +- src/lisp/ao_lisp.h | 51 ++++-- src/lisp/ao_lisp_atom.c | 62 +++++-- src/lisp/ao_lisp_builtin.c | 123 +++++++------- src/lisp/ao_lisp_const.lisp | 3 + src/lisp/ao_lisp_error.c | 29 ++++ src/lisp/ao_lisp_eval.c | 368 +++++++++++++++++++++++++++++++++++------- src/lisp/ao_lisp_frame.c | 2 +- src/lisp/ao_lisp_make_const.c | 29 +++- src/lisp/ao_lisp_rep.c | 6 - src/nucleao-32/Makefile | 1 + src/nucleao-32/ao_pins.h | 2 + src/test/Makefile | 3 +- src/test/ao_lisp_test.c | 11 +- 14 files changed, 528 insertions(+), 165 deletions(-) create mode 100644 src/lisp/ao_lisp_error.c (limited to 'src/nucleao-32') diff --git a/src/lisp/Makefile b/src/lisp/Makefile index 9e2fb58c..be19b432 100644 --- a/src/lisp/Makefile +++ b/src/lisp/Makefile @@ -17,7 +17,8 @@ SRCS=\ ao_lisp_prim.c \ ao_lisp_builtin.c \ ao_lisp_read.c \ - ao_lisp_frame.c + ao_lisp_frame.c \ + ao_lisp_error.c OBJS=$(SRCS:.c=.o) diff --git a/src/lisp/ao_lisp.h b/src/lisp/ao_lisp.h index 98e99acb..9a5cc63e 100644 --- a/src/lisp/ao_lisp.h +++ b/src/lisp/ao_lisp.h @@ -32,11 +32,22 @@ extern uint8_t ao_lisp_const[AO_LISP_POOL_CONST]; #define ao_lisp_pool ao_lisp_const #define AO_LISP_POOL AO_LISP_POOL_CONST -#define _ao_lisp_atom_quote ao_lisp_atom_poly(ao_lisp_atom_intern("quote")) -#define _ao_lisp_atom_set ao_lisp_atom_poly(ao_lisp_atom_intern("set")) + +#define _atom(n) ao_lisp_atom_poly(ao_lisp_atom_intern(n)) + +#define _ao_lisp_atom_quote _atom("quote") +#define _ao_lisp_atom_set _atom("set") +#define _ao_lisp_atom_setq _atom("setq") +#define _ao_lisp_atom_t _atom("t") +#define _ao_lisp_atom_car _atom("car") +#define _ao_lisp_atom_cdr _atom("cdr") +#define _ao_lisp_atom_cons _atom("cons") +#define _ao_lisp_atom_cond _atom("cond") #else #include "ao_lisp_const.h" +#ifndef AO_LISP_POOL #define AO_LISP_POOL 1024 +#endif extern uint8_t ao_lisp_pool[AO_LISP_POOL]; #endif @@ -68,6 +79,7 @@ extern uint16_t ao_lisp_top; extern uint8_t ao_lisp_exception; typedef uint16_t ao_poly; +typedef int16_t ao_signed_poly; static inline int ao_lisp_is_const(ao_poly poly) { @@ -157,6 +169,7 @@ enum ao_lisp_builtin_id { builtin_quote, builtin_set, builtin_setq, + builtin_cond, builtin_print, builtin_plus, builtin_minus, @@ -222,13 +235,13 @@ ao_lisp_cons_poly(struct ao_lisp_cons *cons) static inline int ao_lisp_poly_int(ao_poly poly) { - return (int) poly >> AO_LISP_TYPE_SHIFT; + return (int) ((ao_signed_poly) poly >> AO_LISP_TYPE_SHIFT); } static inline ao_poly ao_lisp_int_poly(int i) { - return ((ao_poly) i << 2) + AO_LISP_INT; + return ((ao_poly) i << 2) | AO_LISP_INT; } static inline char * @@ -326,8 +339,7 @@ extern const struct ao_lisp_type ao_lisp_atom_type; extern struct ao_lisp_atom *ao_lisp_atoms; -void -ao_lisp_atom_init(void); +extern struct ao_lisp_frame *ao_lisp_frame_current; void ao_lisp_atom_print(ao_poly a); @@ -359,12 +371,27 @@ ao_lisp_poly_move(ao_poly p); ao_poly ao_lisp_eval(ao_poly p); +ao_poly +ao_lisp_set_cond(struct ao_lisp_cons *cons); + /* builtin */ void ao_lisp_builtin_print(ao_poly b); extern const struct ao_lisp_type ao_lisp_builtin_type; +/* Check argument count */ +ao_poly +ao_lisp_check_argc(ao_poly name, struct ao_lisp_cons *cons, int min, int max); + +/* Check argument type */ +ao_poly +ao_lisp_check_argt(ao_poly name, struct ao_lisp_cons *cons, int argc, int type, int nil_ok); + +/* Fetch an arg (nil if off the end) */ +ao_poly +ao_lisp_arg(struct ao_lisp_cons *cons, int argc); + /* read */ ao_poly ao_lisp_read(void); @@ -376,11 +403,8 @@ ao_lisp_read_eval_print(void); /* frame */ extern const struct ao_lisp_type ao_lisp_frame_type; -int -ao_lisp_frame_set(struct ao_lisp_frame *frame, ao_poly atom, ao_poly val); - -ao_poly -ao_lisp_frame_get(struct ao_lisp_frame *frame, ao_poly atom); +ao_poly * +ao_lisp_frame_ref(struct ao_lisp_frame *frame, ao_poly atom); struct ao_lisp_frame * ao_lisp_frame_new(int num, int readonly); @@ -388,4 +412,9 @@ ao_lisp_frame_new(int num, int readonly); struct ao_lisp_frame * ao_lisp_frame_add(struct ao_lisp_frame *frame, ao_poly atom, ao_poly val); +/* error */ + +ao_poly +ao_lisp_error(int error, char *format, ...); + #endif /* _AO_LISP_H_ */ diff --git a/src/lisp/ao_lisp_atom.c b/src/lisp/ao_lisp_atom.c index e5d28c3b..ea04741e 100644 --- a/src/lisp/ao_lisp_atom.c +++ b/src/lisp/ao_lisp_atom.c @@ -109,31 +109,65 @@ ao_lisp_atom_intern(char *name) return atom; } -static struct ao_lisp_frame *globals; +static struct ao_lisp_frame *ao_lisp_frame_global; +struct ao_lisp_frame *ao_lisp_frame_current; + +static void +ao_lisp_atom_init(void) +{ + if (!ao_lisp_frame_global) { + ao_lisp_frame_global = ao_lisp_frame_new(0, 0); + ao_lisp_root_add(&ao_lisp_frame_type, &ao_lisp_frame_global); + ao_lisp_root_add(&ao_lisp_frame_type, &ao_lisp_frame_current); + } +} + +static ao_poly * +ao_lisp_atom_ref(struct ao_lisp_frame *frame, ao_poly atom) +{ + ao_poly *ref; + ao_lisp_atom_init(); + while (frame) { + ref = ao_lisp_frame_ref(frame, atom); + if (ref) + return ref; + frame = ao_lisp_poly_frame(frame->next); + } + if (ao_lisp_frame_global) { + ref = ao_lisp_frame_ref(ao_lisp_frame_global, atom); + if (ref) + return ref; + } + return NULL; +} ao_poly ao_lisp_atom_get(ao_poly atom) { - struct ao_lisp_frame *frame = globals; + ao_poly *ref = ao_lisp_atom_ref(ao_lisp_frame_current, atom); + + if (!ref && ao_lisp_frame_global) + ref = ao_lisp_frame_ref(ao_lisp_frame_global, atom); #ifdef ao_builtin_frame - if (!frame) - frame = ao_lisp_poly_frame(ao_builtin_frame); + if (!ref) + ref = ao_lisp_frame_ref(ao_lisp_poly_frame(ao_builtin_frame), atom); #endif - return ao_lisp_frame_get(frame, atom); + if (ref) + return *ref; + return AO_LISP_NIL; } ao_poly ao_lisp_atom_set(ao_poly atom, ao_poly val) { - if (!ao_lisp_frame_set(globals, atom, val)) { - globals = ao_lisp_frame_add(globals, atom, val); - if (!globals->next) { - ao_lisp_root_add(&ao_lisp_frame_type, &globals); -#ifdef ao_builtin_frame - globals->next = ao_builtin_frame; -#endif - } - } + ao_poly *ref = ao_lisp_atom_ref(ao_lisp_frame_current, atom); + + if (!ref && ao_lisp_frame_global) + ref = ao_lisp_frame_ref(ao_lisp_frame_global, atom); + if (ref) + *ref = val; + else + ao_lisp_frame_global = ao_lisp_frame_add(ao_lisp_frame_global, atom, val); return val; } diff --git a/src/lisp/ao_lisp_builtin.c b/src/lisp/ao_lisp_builtin.c index 8c481793..2976bc95 100644 --- a/src/lisp/ao_lisp_builtin.c +++ b/src/lisp/ao_lisp_builtin.c @@ -46,7 +46,8 @@ ao_lisp_builtin_print(ao_poly b) printf("[builtin]"); } -static int check_argc(struct ao_lisp_cons *cons, int min, int max) +ao_poly +ao_lisp_check_argc(ao_poly name, struct ao_lisp_cons *cons, int min, int max) { int argc = 0; @@ -54,28 +55,30 @@ static int check_argc(struct ao_lisp_cons *cons, int min, int max) argc++; cons = ao_lisp_poly_cons(cons->cdr); } - if (argc < min || argc > max) { - ao_lisp_exception |= AO_LISP_INVALID; - return 0; - } - return 1; + if (argc < min || argc > max) + return ao_lisp_error(AO_LISP_INVALID, "%s: invalid arg count", ao_lisp_poly_atom(name)->name); + return _ao_lisp_atom_t; } -static int check_argt(struct ao_lisp_cons *cons, int argc, int type, int nil_ok) +ao_poly +ao_lisp_arg(struct ao_lisp_cons *cons, int argc) { - ao_poly car; - - /* find the desired arg */ - while (argc--) + while (argc--) { + if (!cons) + return AO_LISP_NIL; cons = ao_lisp_poly_cons(cons->cdr); - car = cons->car; - if ((!car && !nil_ok) || - ao_lisp_poly_type(car) != type) - { - ao_lisp_exception |= AO_LISP_INVALID; - return 0; } - return 1; + return cons->car; +} + +ao_poly +ao_lisp_check_argt(ao_poly name, struct ao_lisp_cons *cons, int argc, int type, int nil_ok) +{ + ao_poly car = ao_lisp_arg(cons, argc); + + if ((!car && !nil_ok) || ao_lisp_poly_type(car) != type) + return ao_lisp_error(AO_LISP_INVALID, "%s: invalid type for arg %d", ao_lisp_poly_atom(name)->name, argc); + return _ao_lisp_atom_t; } enum math_op { math_plus, math_minus, math_times, math_divide, math_mod }; @@ -83,30 +86,20 @@ enum math_op { math_plus, math_minus, math_times, math_divide, math_mod }; ao_poly ao_lisp_car(struct ao_lisp_cons *cons) { - if (!check_argc(cons, 1, 1)) + if (!ao_lisp_check_argc(_ao_lisp_atom_car, cons, 1, 1)) return AO_LISP_NIL; - if (!check_argt(cons, 0, AO_LISP_CONS, 0)) { - ao_lisp_exception |= AO_LISP_INVALID; + if (!ao_lisp_check_argt(_ao_lisp_atom_car, cons, 0, AO_LISP_CONS, 0)) return AO_LISP_NIL; - } return ao_lisp_poly_cons(cons->car)->car; } ao_poly ao_lisp_cdr(struct ao_lisp_cons *cons) { - if (!cons) { - ao_lisp_exception |= AO_LISP_INVALID; + if (!ao_lisp_check_argc(_ao_lisp_atom_cdr, cons, 1, 1)) return AO_LISP_NIL; - } - if (!cons->car) { - ao_lisp_exception |= AO_LISP_INVALID; - return AO_LISP_NIL; - } - if (ao_lisp_poly_type(cons->car) != AO_LISP_CONS) { - ao_lisp_exception |= AO_LISP_INVALID; + if (!ao_lisp_check_argt(_ao_lisp_atom_cdr, cons, 0, AO_LISP_CONS, 0)) return AO_LISP_NIL; - } return ao_lisp_poly_cons(cons->car)->cdr; } @@ -114,50 +107,39 @@ ao_poly ao_lisp_cons(struct ao_lisp_cons *cons) { ao_poly car, cdr; - if (!cons) { - ao_lisp_exception |= AO_LISP_INVALID; - return AO_LISP_NIL; - } - car = cons->car; - cdr = cons->cdr; - if (!car || !cdr) { - ao_lisp_exception |= AO_LISP_INVALID; + if(!ao_lisp_check_argc(_ao_lisp_atom_cons, cons, 2, 2)) return AO_LISP_NIL; - } - cdr = ao_lisp_poly_cons(cdr)->car; - if (ao_lisp_poly_type(cdr) != AO_LISP_CONS) { - ao_lisp_exception |= AO_LISP_INVALID; + if (!ao_lisp_check_argt(_ao_lisp_atom_cons, cons, 1, AO_LISP_CONS, 1)) return AO_LISP_NIL; - } + car = ao_lisp_arg(cons, 0); + cdr = ao_lisp_arg(cons, 1); return ao_lisp_cons_poly(ao_lisp_cons_cons(car, ao_lisp_poly_cons(cdr))); } ao_poly ao_lisp_quote(struct ao_lisp_cons *cons) { - if (!cons) { - ao_lisp_exception |= AO_LISP_INVALID; + if (!ao_lisp_check_argc(_ao_lisp_atom_quote, cons, 1, 1)) return AO_LISP_NIL; - } - return cons->car; + return ao_lisp_arg(cons, 0); } ao_poly ao_lisp_set(struct ao_lisp_cons *cons) { - if (!check_argc(cons, 2, 2)) + if (!ao_lisp_check_argc(_ao_lisp_atom_set, cons, 2, 2)) return AO_LISP_NIL; - if (!check_argt(cons, 0, AO_LISP_ATOM, 0)) + if (!ao_lisp_check_argt(_ao_lisp_atom_set, cons, 0, AO_LISP_ATOM, 0)) return AO_LISP_NIL; - return ao_lisp_atom_set(cons->car, ao_lisp_poly_cons(cons->cdr)->car); + return ao_lisp_atom_set(ao_lisp_arg(cons, 0), ao_lisp_poly_cons(ao_lisp_arg(cons, 1))->car); } ao_poly ao_lisp_setq(struct ao_lisp_cons *cons) { struct ao_lisp_cons *expand = 0; - if (!check_argc(cons, 2, 2)) + if (!ao_lisp_check_argc(_ao_lisp_atom_setq, cons, 2, 2)) return AO_LISP_NIL; expand = ao_lisp_cons_cons(_ao_lisp_atom_set, ao_lisp_cons_cons(ao_lisp_cons_poly(ao_lisp_cons_cons(_ao_lisp_atom_quote, @@ -166,6 +148,22 @@ ao_lisp_setq(struct ao_lisp_cons *cons) return ao_lisp_cons_poly(expand); } +ao_poly +ao_lisp_cond(struct ao_lisp_cons *cons) +{ + int argc; + struct ao_lisp_cons *arg; + + argc = 0; + for (arg = cons, argc = 0; arg; arg = ao_lisp_poly_cons(arg->cdr), argc++) { + if (ao_lisp_poly_type(arg->car) != AO_LISP_CONS) + return ao_lisp_error(AO_LISP_INVALID, "%s: invalid type for arg %d", + ao_lisp_poly_atom(_ao_lisp_atom_cond)->name, argc); + } + ao_lisp_set_cond(cons); + return AO_LISP_NIL; +} + ao_poly ao_lisp_print(struct ao_lisp_cons *cons) { @@ -210,17 +208,13 @@ ao_lisp_math(struct ao_lisp_cons *cons, enum math_op op) r *= c; break; case math_divide: - if (c == 0) { - ao_lisp_exception |= AO_LISP_DIVIDE_BY_ZERO; - return AO_LISP_NIL; - } + if (c == 0) + return ao_lisp_error(AO_LISP_DIVIDE_BY_ZERO, "divide by zero"); r /= c; break; case math_mod: - if (c == 0) { - ao_lisp_exception |= AO_LISP_DIVIDE_BY_ZERO; - return AO_LISP_NIL; - } + if (c == 0) + return ao_lisp_error(AO_LISP_DIVIDE_BY_ZERO, "mod by zero"); r %= c; break; } @@ -230,10 +224,8 @@ ao_lisp_math(struct ao_lisp_cons *cons, enum math_op op) else if (rt == AO_LISP_STRING && ct == AO_LISP_STRING && op == math_plus) ret = ao_lisp_string_poly(ao_lisp_string_cat(ao_lisp_poly_string(ret), ao_lisp_poly_string(car))); - else { - ao_lisp_exception |= AO_LISP_INVALID; - return AO_LISP_NIL; - } + else + return ao_lisp_error(AO_LISP_INVALID, "invalid args"); } return ret; } @@ -275,6 +267,7 @@ ao_lisp_func_t ao_lisp_builtins[] = { [builtin_quote] = ao_lisp_quote, [builtin_set] = ao_lisp_set, [builtin_setq] = ao_lisp_setq, + [builtin_cond] = ao_lisp_cond, [builtin_print] = ao_lisp_print, [builtin_plus] = ao_lisp_plus, [builtin_minus] = ao_lisp_minus, diff --git a/src/lisp/ao_lisp_const.lisp b/src/lisp/ao_lisp_const.lisp index aa356d45..5ee15899 100644 --- a/src/lisp/ao_lisp_const.lisp +++ b/src/lisp/ao_lisp_const.lisp @@ -1 +1,4 @@ cadr (lambda (l) (car (cdr l))) +list (lexpr (l) l) +1+ (lambda (x) (+ x 1)) +1- (lambda (x) (- x 1)) diff --git a/src/lisp/ao_lisp_error.c b/src/lisp/ao_lisp_error.c new file mode 100644 index 00000000..ea8111d9 --- /dev/null +++ b/src/lisp/ao_lisp_error.c @@ -0,0 +1,29 @@ +/* + * Copyright © 2016 Keith Packard + * + * 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 + +ao_poly +ao_lisp_error(int error, char *format, ...) +{ + va_list args; + + ao_lisp_exception |= error; + va_start(args, format); + vprintf(format, args); + va_end(args); + printf("\n"); + return AO_LISP_NIL; +} diff --git a/src/lisp/ao_lisp_eval.c b/src/lisp/ao_lisp_eval.c index 6eef1f23..803f1e2e 100644 --- a/src/lisp/ao_lisp_eval.c +++ b/src/lisp/ao_lisp_eval.c @@ -14,32 +14,238 @@ #include "ao_lisp.h" -/* - * Non-recursive eval - * - * Plan: walk actuals, construct formals - * - * stack > save > actuals > actual_1 - * v v - * formals . > actual_2 - */ - -static struct ao_lisp_cons *stack; -static struct ao_lisp_cons *actuals; -static struct ao_lisp_cons *formals; -static struct ao_lisp_cons *formals_tail; -static uint8_t been_here; - #if 0 #define DBG(...) printf(__VA_ARGS__) -#define DBG_CONS(a) ao_lisp_cons_print(a) +#define DBG_CONS(a) ao_lisp_cons_print(ao_lisp_cons_poly(a)) #define DBG_POLY(a) ao_lisp_poly_print(a) +#define OFFSET(a) ((a) ? (int) ((uint8_t *) a - ao_lisp_pool) : -1) #else #define DBG(...) #define DBG_CONS(a) #define DBG_POLY(a) #endif +struct ao_lisp_stack { + ao_poly next; + ao_poly actuals; + ao_poly formals; + ao_poly frame; + ao_poly cond; +}; + +static struct ao_lisp_stack * +ao_lisp_poly_stack(ao_poly p) +{ + return ao_lisp_ref(p); +} + +static ao_poly +ao_lisp_stack_poly(struct ao_lisp_stack *stack) +{ + return ao_lisp_poly(stack, AO_LISP_OTHER); +} + +static int +stack_size(void *addr) +{ + (void) addr; + return sizeof (struct ao_lisp_stack); +} + +static void +stack_mark(void *addr) +{ + struct ao_lisp_stack *stack = addr; + for (;;) { + ao_lisp_poly_mark(stack->actuals); + ao_lisp_poly_mark(stack->formals); + ao_lisp_poly_mark(stack->frame); + ao_lisp_poly_mark(stack->cond); + stack = ao_lisp_poly_stack(stack->next); + if (ao_lisp_mark_memory(stack, sizeof (struct ao_lisp_stack))) + break; + } +} + +static void +stack_move(void *addr) +{ + struct ao_lisp_stack *stack = addr; + + for (;;) { + struct ao_lisp_stack *next; + stack->actuals = ao_lisp_poly_move(stack->actuals); + stack->formals = ao_lisp_poly_move(stack->formals); + stack->frame = ao_lisp_poly_move(stack->frame); + stack->cond = ao_lisp_poly_move(stack->cond); + next = ao_lisp_ref(stack->next); + next = ao_lisp_move_memory(next, sizeof (struct ao_lisp_stack)); + stack->next = ao_lisp_stack_poly(next); + stack = next; + } +} + +static const struct ao_lisp_type ao_lisp_stack_type = { + .size = stack_size, + .mark = stack_mark, + .move = stack_move +}; + + +static struct ao_lisp_stack *stack; +static struct ao_lisp_cons *actuals; +static struct ao_lisp_cons *formals; +static struct ao_lisp_cons *formals_tail; +static struct ao_lisp_cons *cond; +struct ao_lisp_frame *next_frame; +static uint8_t been_here; + +ao_poly +ao_lisp_set_cond(struct ao_lisp_cons *c) +{ + cond = c; + return AO_LISP_NIL; +} + +static int +ao_lisp_stack_push(void) +{ + struct ao_lisp_stack *n = ao_lisp_alloc(sizeof (struct ao_lisp_stack)); + if (!n) + return 0; + n->next = ao_lisp_stack_poly(stack); + n->actuals = ao_lisp_cons_poly(actuals); + n->formals = ao_lisp_cons_poly(formals); + n->cond = ao_lisp_cons_poly(cond); + n->frame = ao_lisp_frame_poly(ao_lisp_frame_current); + DBG("push frame %d\n", OFFSET(ao_lisp_frame_current)); + stack = n; + return 1; +} + +static void +ao_lisp_stack_pop(void) +{ + actuals = ao_lisp_poly_cons(stack->actuals); + formals = ao_lisp_poly_cons(stack->formals); + cond = ao_lisp_poly_cons(stack->cond); + ao_lisp_frame_current = ao_lisp_poly_frame(stack->frame); + DBG("pop frame %d\n", OFFSET(ao_lisp_frame_current)); + formals_tail = 0; + + /* Recompute the tail of the formals list */ + if (formals) { + struct ao_lisp_cons *formal; + for (formal = formals; formal->cdr != AO_LISP_NIL; formal = ao_lisp_poly_cons(formal->cdr)); + formals_tail = formal; + } + stack = ao_lisp_poly_stack(stack->next); +} + +static void +ao_lisp_stack_clear(void) +{ + stack = 0; + actuals = formals = formals_tail = 0; + cond = 0; + ao_lisp_frame_current = 0; +} + + +static ao_poly +func_type(ao_poly func) +{ + struct ao_lisp_cons *cons; + struct ao_lisp_cons *args; + int f; + + DBG("func type "); DBG_POLY(func); DBG("\n"); + if (func == AO_LISP_NIL) + return ao_lisp_error(AO_LISP_INVALID, "func is nil"); + if (ao_lisp_poly_type(func) != AO_LISP_CONS) + return ao_lisp_error(AO_LISP_INVALID, "func is not list"); + cons = ao_lisp_poly_cons(func); + if (!ao_lisp_check_argc(_ao_lisp_atom_lambda, cons, 3, 3)) + return AO_LISP_NIL; + if (!ao_lisp_check_argt(_ao_lisp_atom_lambda, cons, 0, AO_LISP_ATOM, 0)) + return AO_LISP_NIL; + if (!ao_lisp_check_argt(_ao_lisp_atom_lambda, cons, 1, AO_LISP_CONS, 1)) + return AO_LISP_NIL; + args = ao_lisp_poly_cons(ao_lisp_arg(cons, 1)); + f = 0; + while (args) { + if (ao_lisp_poly_type(args->car) != AO_LISP_ATOM) { + return ao_lisp_error(ao_lisp_arg(cons, 0), "formal %d is not an atom", f); + } + args = ao_lisp_poly_cons(args->cdr); + f++; + } + return ao_lisp_arg(cons, 0); +} + +static int +ao_lisp_cons_length(struct ao_lisp_cons *cons) +{ + int len = 0; + while (cons) { + len++; + cons = ao_lisp_poly_cons(cons->cdr); + } + return len; +} + +static ao_poly +ao_lisp_lambda(struct ao_lisp_cons *cons) +{ + ao_poly type; + struct ao_lisp_cons *lambda; + struct ao_lisp_cons *args; + int args_wanted; + int args_provided; + + lambda = ao_lisp_poly_cons(ao_lisp_arg(cons, 0)); + DBG("lambda "); DBG_CONS(lambda); DBG("\n"); + type = ao_lisp_arg(lambda, 0); + args = ao_lisp_poly_cons(ao_lisp_arg(lambda, 1)); + + args_wanted = ao_lisp_cons_length(args); + + /* Create a frame to hold the variables + */ + if (type == _ao_lisp_atom_lambda) + args_provided = ao_lisp_cons_length(cons) - 1; + else + args_provided = 1; + if (args_wanted != args_provided) + return ao_lisp_error(AO_LISP_INVALID, "need %d args, not %d", args_wanted, args_provided); + next_frame = ao_lisp_frame_new(args_wanted, 0); + DBG("new frame %d\n", OFFSET(next_frame)); + switch (type) { + case _ao_lisp_atom_lambda: { + int f; + struct ao_lisp_cons *vals = ao_lisp_poly_cons(cons->cdr); + + for (f = 0; f < args_wanted; f++) { + next_frame->vals[f].atom = args->car; + next_frame->vals[f].val = vals->car; + args = ao_lisp_poly_cons(args->cdr); + vals = ao_lisp_poly_cons(vals->cdr); + } + break; + } + case _ao_lisp_atom_lexpr: + case _ao_lisp_atom_nlambda: + next_frame->vals[0].atom = args->car; + next_frame->vals[0].val = cons->cdr; + break; + case _ao_lisp_atom_macro: + next_frame->vals[0].atom = args->car; + next_frame->vals[0].val = ao_lisp_cons_poly(cons); + break; + } + return ao_lisp_arg(lambda, 2); +} + ao_poly ao_lisp_eval(ao_poly v) { @@ -48,7 +254,7 @@ ao_lisp_eval(ao_poly v) if (!been_here) { been_here = 1; - ao_lisp_root_add(&ao_lisp_cons_type, &stack); + ao_lisp_root_add(&ao_lisp_stack_type, &stack); ao_lisp_root_add(&ao_lisp_cons_type, &actuals); ao_lisp_root_add(&ao_lisp_cons_type, &formals); ao_lisp_root_add(&ao_lisp_cons_type, &formals_tail); @@ -57,29 +263,43 @@ ao_lisp_eval(ao_poly v) actuals = 0; formals = 0; formals_tail = 0; + cond = 0; for (;;) { restart: + if (cond) { + if (cond->car == AO_LISP_NIL) { + cond = AO_LISP_NIL; + v = AO_LISP_NIL; + } else { + if (ao_lisp_poly_type(cond->car) != AO_LISP_CONS) { + ao_lisp_error(AO_LISP_INVALID, "malformed cond"); + goto bail; + } + v = ao_lisp_poly_cons(cond->car)->car; + } + } + /* Build stack frames for each list */ while (ao_lisp_poly_type(v) == AO_LISP_CONS) { if (v == AO_LISP_NIL) break; - /* Push existing frame on the stack */ - if (cons++) { - struct ao_lisp_cons *frame; + /* Push existing bits on the stack */ + if (cons++) + if (!ao_lisp_stack_push()) + goto bail; - frame = ao_lisp_cons_cons(ao_lisp_cons_poly(actuals), formals); - stack = ao_lisp_cons_cons(ao_lisp_cons_poly(frame), stack); - } actuals = ao_lisp_poly_cons(v); formals = NULL; formals_tail = NULL; + cond = NULL; + v = actuals->car; - DBG("start: stack"); DBG_CONS(stack); DBG("\n"); - DBG("start: actuals"); DBG_CONS(actuals); DBG("\n"); - DBG("start: formals"); DBG_CONS(formals); DBG("\n"); +// DBG("start: stack"); DBG_CONS(stack); DBG("\n"); +// DBG("start: actuals"); DBG_CONS(actuals); DBG("\n"); +// DBG("start: formals"); DBG_CONS(formals); DBG("\n"); } /* Evaluate primitive types */ @@ -95,19 +315,19 @@ ao_lisp_eval(ao_poly v) break; } - if (!cons) - break; - - for (;;) { + while (cons) { DBG("add formal: "); DBG_POLY(v); DBG("\n"); + /* We've processed the first element of the list, go check + * what kind of function we've got + */ if (formals == NULL) { if (ao_lisp_poly_type(v) == AO_LISP_BUILTIN) { struct ao_lisp_builtin *b = ao_lisp_poly_builtin(v); switch (b->args) { case AO_LISP_NLAMBDA: - v = ao_lisp_func(b)(ao_lisp_poly_cons(actuals->cdr)); - goto done_eval; + formals = actuals; + goto eval; case AO_LISP_MACRO: v = ao_lisp_func(b)(ao_lisp_poly_cons(actuals->cdr)); @@ -115,15 +335,28 @@ ao_lisp_eval(ao_poly v) DBG(" -> "); DBG_POLY(v); DBG("\n"); if (ao_lisp_poly_type(v) != AO_LISP_CONS) { - ao_lisp_exception |= AO_LISP_INVALID; - return AO_LISP_NIL; + ao_lisp_error(AO_LISP_INVALID, "macro didn't return list"); + goto bail; } - /* Reset frame to the new list */ actuals = ao_lisp_poly_cons(v); v = actuals->car; goto restart; } + } else { + switch (func_type(v)) { + case _ao_lisp_atom_lambda: + case _ao_lisp_atom_lexpr: + break; + case _ao_lisp_atom_nlambda: + formals = actuals; + goto eval; + case _ao_lisp_atom_macro: + break; + default: + ao_lisp_error(AO_LISP_INVALID, "operator is not a function"); + goto bail; + } } } @@ -150,6 +383,8 @@ ao_lisp_eval(ao_poly v) v = formals->car; + eval: + /* Evaluate the resulting list */ if (ao_lisp_poly_type(v) == AO_LISP_BUILTIN) { struct ao_lisp_builtin *b = ao_lisp_poly_builtin(v); @@ -161,41 +396,54 @@ ao_lisp_eval(ao_poly v) DBG(" -> "); DBG_POLY(v); DBG ("\n"); + if (ao_lisp_exception) + goto bail; + + if (cond) + goto restart; } else { - ao_lisp_exception |= AO_LISP_INVALID; + v = ao_lisp_lambda(formals); + if (ao_lisp_exception) + goto bail; } - if (ao_lisp_exception) - return AO_LISP_NIL; - done_eval: - if (--cons) { - struct ao_lisp_cons *frame; - - /* Pop the previous frame off the stack */ - frame = ao_lisp_poly_cons(stack->car); - actuals = ao_lisp_poly_cons(frame->car); - formals = ao_lisp_poly_cons(frame->cdr); - formals_tail = NULL; - - /* Recompute the tail of the formals list */ - if (formals) { - for (formal = formals; formal->cdr != AO_LISP_NIL; formal = ao_lisp_poly_cons(formal->cdr)); - formals_tail = formal; - } - stack = ao_lisp_poly_cons(stack->cdr); - DBG("stack pop: stack"); DBG_CONS(stack); DBG("\n"); - DBG("stack pop: actuals"); DBG_CONS(actuals); DBG("\n"); - DBG("stack pop: formals"); DBG_CONS(formals); DBG("\n"); + --cons; + if (cons) { + ao_lisp_stack_pop(); +// DBG("stack pop: stack"); DBG_CONS(stack); DBG("\n"); +// DBG("stack pop: actuals"); DBG_CONS(actuals); DBG("\n"); +// DBG("stack pop: formals"); DBG_CONS(formals); DBG("\n"); } else { actuals = 0; formals = 0; formals_tail = 0; - DBG("done func\n"); - break; + ao_lisp_frame_current = 0; + } + if (next_frame) { + ao_lisp_frame_current = next_frame; + DBG("next frame %d\n", OFFSET(next_frame)); + next_frame = 0; + goto restart; + } + if (cond) { + if (v) { + v = ao_lisp_poly_cons(cond->car)->cdr; + if (v != AO_LISP_NIL) { + v = ao_lisp_poly_cons(v)->car; + goto restart; + } + } else { + cond = ao_lisp_poly_cons(cond->cdr); + goto restart; + } } } if (!cons) break; } + DBG("leaving frame at %d\n", OFFSET(ao_lisp_frame_current)); return v; +bail: + ao_lisp_stack_clear(); + return AO_LISP_NIL; } diff --git a/src/lisp/ao_lisp_frame.c b/src/lisp/ao_lisp_frame.c index 5aa50f6b..1853f6d7 100644 --- a/src/lisp/ao_lisp_frame.c +++ b/src/lisp/ao_lisp_frame.c @@ -95,7 +95,7 @@ const struct ao_lisp_type ao_lisp_frame_type = { .move = frame_move }; -static ao_poly * +ao_poly * ao_lisp_frame_ref(struct ao_lisp_frame *frame, ao_poly atom) { int f; diff --git a/src/lisp/ao_lisp_make_const.c b/src/lisp/ao_lisp_make_const.c index 6b603979..9c2ea74c 100644 --- a/src/lisp/ao_lisp_make_const.c +++ b/src/lisp/ao_lisp_make_const.c @@ -39,6 +39,7 @@ struct builtin_func funcs[] = { "quote", AO_LISP_NLAMBDA,builtin_quote, "set", AO_LISP_LEXPR, builtin_set, "setq", AO_LISP_MACRO, builtin_setq, + "cond", AO_LISP_NLAMBDA,builtin_cond, "print", AO_LISP_LEXPR, builtin_print, "+", AO_LISP_LEXPR, builtin_plus, "-", AO_LISP_LEXPR, builtin_minus, @@ -47,8 +48,25 @@ struct builtin_func funcs[] = { "%", AO_LISP_LEXPR, builtin_mod }; +ao_poly +ao_lisp_set_cond(struct ao_lisp_cons *c) +{ + (void) c; + return AO_LISP_NIL; +} + #define N_FUNC (sizeof funcs / sizeof funcs[0]) +/* Syntactic atoms */ +char *atoms[] = { + "lambda", + "nlambda", + "lexpr", + "macro" +}; + +#define N_ATOM (sizeof atoms / sizeof atoms[0]) + struct ao_lisp_frame *globals; static int @@ -65,9 +83,10 @@ is_atom(int offset) int main(int argc, char **argv) { - int f, o; + int f, o, i; ao_poly atom, val; struct ao_lisp_atom *a; + struct ao_lisp_builtin *b; int in_atom; printf("/*\n"); @@ -75,11 +94,15 @@ main(int argc, char **argv) ao_lisp_root_add(&ao_lisp_frame_type, &globals); globals = ao_lisp_frame_new(0, 0); for (f = 0; f < N_FUNC; f++) { - struct ao_lisp_builtin *b = ao_lisp_make_builtin(funcs[f].func, funcs[f].args); - struct ao_lisp_atom *a = ao_lisp_atom_intern(funcs[f].name); + b = ao_lisp_make_builtin(funcs[f].func, funcs[f].args); + a = ao_lisp_atom_intern(funcs[f].name); globals = ao_lisp_frame_add(globals, ao_lisp_atom_poly(a), ao_lisp_builtin_poly(b)); } + /* atoms for syntax */ + for (i = 0; i < N_ATOM; i++) + (void) ao_lisp_atom_intern(atoms[i]); + /* boolean constants */ a = ao_lisp_atom_intern("nil"); globals = ao_lisp_frame_add(globals, ao_lisp_atom_poly(a), AO_LISP_NIL); diff --git a/src/lisp/ao_lisp_rep.c b/src/lisp/ao_lisp_rep.c index a1f9fa1f..d780186a 100644 --- a/src/lisp/ao_lisp_rep.c +++ b/src/lisp/ao_lisp_rep.c @@ -25,12 +25,6 @@ ao_lisp_read_eval_print(void) // printf ("in: "); ao_lisp_poly_print(in); printf("\n"); out = ao_lisp_eval(in); if (ao_lisp_exception) { - if (ao_lisp_exception & AO_LISP_OOM) - printf("out of memory\n"); - if (ao_lisp_exception & AO_LISP_DIVIDE_BY_ZERO) - printf("divide by zero\n"); - if (ao_lisp_exception & AO_LISP_INVALID) - printf("invalid operation\n"); ao_lisp_exception = 0; } else { ao_lisp_poly_print(out); diff --git a/src/nucleao-32/Makefile b/src/nucleao-32/Makefile index 1b7e0bb0..388e581c 100644 --- a/src/nucleao-32/Makefile +++ b/src/nucleao-32/Makefile @@ -46,6 +46,7 @@ ALTOS_SRC = \ ao_lisp_read.c \ ao_lisp_rep.c \ ao_lisp_frame.c \ + ao_lisp_error.c \ ao_exti_stm.c PRODUCT=Nucleo-32 diff --git a/src/nucleao-32/ao_pins.h b/src/nucleao-32/ao_pins.h index 76200176..65de89ed 100644 --- a/src/nucleao-32/ao_pins.h +++ b/src/nucleao-32/ao_pins.h @@ -24,6 +24,8 @@ #define LED_PIN_GREEN 3 #define AO_LED_GREEN (1 << LED_PIN_GREEN) #define AO_LED_PANIC AO_LED_GREEN +#define AO_CMD_LEN 128 +#define AO_LISP_POOL 2048 #define LEDS_AVAILABLE (AO_LED_GREEN) diff --git a/src/test/Makefile b/src/test/Makefile index bd195161..8d617eea 100644 --- a/src/test/Makefile +++ b/src/test/Makefile @@ -93,7 +93,8 @@ ao_quaternion_test: ao_quaternion_test.c ao_quaternion.h AO_LISP_OBJS = ao_lisp_test.o ao_lisp_mem.o ao_lisp_cons.o ao_lisp_string.o \ ao_lisp_atom.o ao_lisp_int.o ao_lisp_prim.o ao_lisp_eval.o ao_lisp_poly.o \ - ao_lisp_builtin.o ao_lisp_read.o ao_lisp_rep.o ao_lisp_frame.o + ao_lisp_builtin.o ao_lisp_read.o ao_lisp_rep.o ao_lisp_frame.o \ + ao_lisp_error.o ao_lisp_test: $(AO_LISP_OBJS) cc $(CFLAGS) -o $@ $(AO_LISP_OBJS) diff --git a/src/test/ao_lisp_test.c b/src/test/ao_lisp_test.c index e303869f..8bc677da 100644 --- a/src/test/ao_lisp_test.c +++ b/src/test/ao_lisp_test.c @@ -15,15 +15,18 @@ #include "ao_lisp.h" #include +#if 0 static struct ao_lisp_cons *list; static char *string; +#endif int main (int argc, char **argv) { +#if 0 int i, j; - struct ao_lisp_atom *atom; + struct ao_lisp_atom *atom; ao_lisp_root_add(&ao_lisp_cons_type, (void **) &list); ao_lisp_root_add(&ao_lisp_string_type, (void **) &string); @@ -47,7 +50,8 @@ main (int argc, char **argv) ao_lisp_poly_print(ao_lisp_atom_get(ao_lisp_atom_poly(atom))); printf("\n"); } -#if 1 +#endif +#if 0 list = ao_lisp_cons_cons(ao_lisp_atom_poly(ao_lisp_atom_intern("+")), ao_lisp_cons_cons(ao_lisp_cons_poly(ao_lisp_cons_cons(ao_lisp_atom_poly(ao_lisp_atom_intern("+")), ao_lisp_cons_cons(ao_lisp_int_poly(3), @@ -58,7 +62,8 @@ main (int argc, char **argv) printf ("\n"); ao_lisp_poly_print(ao_lisp_eval(ao_lisp_cons_poly(list))); printf ("\n"); - +#endif +#if 1 ao_lisp_read_eval_print(); #endif } -- cgit v1.2.3 From d8cf97fe22acefab40d7bb321138e46d4483fef7 Mon Sep 17 00:00:00 2001 From: Keith Packard Date: Sat, 5 Nov 2016 17:53:15 -0700 Subject: altos/lisp: more GC issues. add patom Use global ao_lisp_stack instead of local stack so that gc moves of that item work. Signed-off-by: Keith Packard --- src/lambdakey-v1.0/ao_lambdakey.c | 28 ------ src/lambdakey-v1.0/ao_pins.h | 3 +- src/lisp/ao_lisp.h | 12 ++- src/lisp/ao_lisp_builtin.c | 13 +++ src/lisp/ao_lisp_cons.c | 11 +++ src/lisp/ao_lisp_eval.c | 197 +++++++++++++++++++++++++------------- src/lisp/ao_lisp_make_const.c | 1 + src/lisp/ao_lisp_mem.c | 11 ++- src/lisp/ao_lisp_prim.c | 61 +++++++++--- src/lisp/ao_lisp_string.c | 10 ++ src/nucleao-32/ao_pins.h | 3 +- 11 files changed, 237 insertions(+), 113 deletions(-) (limited to 'src/nucleao-32') diff --git a/src/lambdakey-v1.0/ao_lambdakey.c b/src/lambdakey-v1.0/ao_lambdakey.c index 6ac78717..8353d811 100644 --- a/src/lambdakey-v1.0/ao_lambdakey.c +++ b/src/lambdakey-v1.0/ao_lambdakey.c @@ -15,39 +15,11 @@ #include #include -static uint16_t blink_delay, blink_running; - -static void blink(void) { - blink_running = 1; - while (blink_delay) { - ao_led_on(AO_LED_RED); - ao_delay(blink_delay); - ao_led_off(AO_LED_RED); - ao_delay(blink_delay); - } - blink_running = 0; - ao_wakeup(&blink_running); - ao_exit(); -} - -struct ao_task blink_task; - -static void blink_cmd() { - ao_cmd_decimal(); - blink_delay = ao_cmd_lex_i; - if (blink_delay && !blink_running) - ao_add_task(&blink_task, blink, "blink"); - if (!blink_delay) - while (blink_running) - ao_sleep(&blink_running); -} - static void lisp_cmd() { ao_lisp_read_eval_print(); } static const struct ao_cmds blink_cmds[] = { - { blink_cmd, "b \0Blink the green LED" }, { lisp_cmd, "l\0Run lisp interpreter" }, { 0, 0 } }; diff --git a/src/lambdakey-v1.0/ao_pins.h b/src/lambdakey-v1.0/ao_pins.h index e379ed12..4da638b9 100644 --- a/src/lambdakey-v1.0/ao_pins.h +++ b/src/lambdakey-v1.0/ao_pins.h @@ -25,7 +25,8 @@ #define AO_LED_RED (1 << LED_PIN_RED) #define AO_LED_PANIC AO_LED_RED #define AO_CMD_LEN 128 -#define AO_LISP_POOL 2048 +#define AO_LISP_POOL 1536 +#define AO_STACK_SIZE 2048 #define LEDS_AVAILABLE (AO_LED_RED) diff --git a/src/lisp/ao_lisp.h b/src/lisp/ao_lisp.h index 27174e13..0d179942 100644 --- a/src/lisp/ao_lisp.h +++ b/src/lisp/ao_lisp.h @@ -173,6 +173,7 @@ enum ao_lisp_builtin_id { builtin_setq, builtin_cond, builtin_print, + builtin_patom, builtin_plus, builtin_minus, builtin_times, @@ -331,6 +332,9 @@ ao_lisp_cons_cons(ao_poly car, struct ao_lisp_cons *cdr); void ao_lisp_cons_print(ao_poly); +void +ao_lisp_cons_patom(ao_poly); + /* string */ extern const struct ao_lisp_type ao_lisp_string_type; @@ -346,6 +350,9 @@ ao_lisp_string_cat(char *a, char *b); void ao_lisp_string_print(ao_poly s); +void +ao_lisp_string_patom(ao_poly s); + /* atom */ extern const struct ao_lisp_type ao_lisp_atom_type; @@ -370,9 +377,12 @@ void ao_lisp_int_print(ao_poly i); /* prim */ -ao_poly +void ao_lisp_poly_print(ao_poly p); +void +ao_lisp_poly_patom(ao_poly p); + int ao_lisp_poly_mark(ao_poly p); diff --git a/src/lisp/ao_lisp_builtin.c b/src/lisp/ao_lisp_builtin.c index 0ad1f464..49b6c37d 100644 --- a/src/lisp/ao_lisp_builtin.c +++ b/src/lisp/ao_lisp_builtin.c @@ -179,6 +179,18 @@ ao_lisp_print(struct ao_lisp_cons *cons) return val; } +ao_poly +ao_lisp_patom(struct ao_lisp_cons *cons) +{ + ao_poly val = AO_LISP_NIL; + while (cons) { + val = cons->car; + ao_lisp_poly_patom(val); + cons = ao_lisp_poly_cons(cons->cdr); + } + return val; +} + ao_poly ao_lisp_math(struct ao_lisp_cons *cons, enum ao_lisp_builtin_id op) { @@ -376,6 +388,7 @@ ao_lisp_func_t ao_lisp_builtins[] = { [builtin_setq] = ao_lisp_setq, [builtin_cond] = ao_lisp_cond, [builtin_print] = ao_lisp_print, + [builtin_patom] = ao_lisp_patom, [builtin_plus] = ao_lisp_plus, [builtin_minus] = ao_lisp_minus, [builtin_times] = ao_lisp_times, diff --git a/src/lisp/ao_lisp_cons.c b/src/lisp/ao_lisp_cons.c index 4929b91c..7d3ca68d 100644 --- a/src/lisp/ao_lisp_cons.c +++ b/src/lisp/ao_lisp_cons.c @@ -83,3 +83,14 @@ ao_lisp_cons_print(ao_poly c) } printf(")"); } + +void +ao_lisp_cons_patom(ao_poly c) +{ + struct ao_lisp_cons *cons = ao_lisp_poly_cons(c); + + while (cons) { + ao_lisp_poly_patom(cons->car); + cons = ao_lisp_poly_cons(cons->cdr); + } +} diff --git a/src/lisp/ao_lisp_eval.c b/src/lisp/ao_lisp_eval.c index 0de3f190..e3d653b9 100644 --- a/src/lisp/ao_lisp_eval.c +++ b/src/lisp/ao_lisp_eval.c @@ -15,12 +15,13 @@ #include "ao_lisp.h" #if 0 +#define DBG_CODE 1 static int stack_depth; #define DBG_INDENT() do { int _s; for(_s = 0; _s < stack_depth; _s++) printf(" "); } while(0) #define DBG_IN() (++stack_depth) #define DBG_OUT() (--stack_depth) #define DBG(...) printf(__VA_ARGS__) -#define DBGI(...) do { DBG_INDENT(); DBG(__VA_ARGS__); } while (0) +#define DBGI(...) do { DBG_INDENT(); DBG("%4d: ", __LINE__); DBG(__VA_ARGS__); } while (0) #define DBG_CONS(a) ao_lisp_cons_print(ao_lisp_cons_poly(a)) #define DBG_POLY(a) ao_lisp_poly_print(a) #define OFFSET(a) ((a) ? (int) ((uint8_t *) a - ao_lisp_pool) : -1) @@ -90,6 +91,29 @@ stack_mark(void *addr) static const struct ao_lisp_type ao_lisp_stack_type; +#if DBG_CODE +static void +stack_validate_tail(struct ao_lisp_stack *stack) +{ + struct ao_lisp_cons *head = ao_lisp_poly_cons(stack->formals); + struct ao_lisp_cons *tail = ao_lisp_poly_cons(stack->formals_tail); + struct ao_lisp_cons *cons; + for (cons = head; cons && cons->cdr && cons != tail; cons = ao_lisp_poly_cons(cons->cdr)) + ; + if (cons != tail || (tail && tail->cdr)) { + if (!tail) { + printf("tail null\n"); + } else { + printf("tail validate fail head %d actual %d recorded %d\n", + OFFSET(head), OFFSET(cons), OFFSET(tail)); + abort(); + } + } +} +#else +#define stack_validate_tail(s) +#endif + static void stack_move(void *addr) { @@ -106,7 +130,8 @@ stack_move(void *addr) ret = ao_lisp_move(&ao_lisp_stack_type, &prev); if (prev != ao_lisp_poly_stack(stack->prev)) stack->prev = ao_lisp_stack_poly(prev); - if (ret); + stack_validate_tail(stack); + if (ret) break; stack = ao_lisp_poly_stack(stack->prev); } @@ -122,6 +147,19 @@ static struct ao_lisp_stack *ao_lisp_stack; static ao_poly ao_lisp_v; static uint8_t been_here; +#if DBG_CODE +static void +stack_validate_tails(void) +{ + struct ao_lisp_stack *stack; + + for (stack = ao_lisp_stack; stack; stack = ao_lisp_poly_stack(stack->prev)) + stack_validate_tail(stack); +} +#else +#define stack_validate_tails(s) +#endif + ao_poly ao_lisp_set_cond(struct ao_lisp_cons *c) { @@ -139,27 +177,35 @@ ao_lisp_stack_reset(struct ao_lisp_stack *stack) stack->formals = AO_LISP_NIL; stack->formals_tail = AO_LISP_NIL; stack->frame = ao_lisp_frame_poly(ao_lisp_frame_current); + stack_validate_tails(); } -struct ao_lisp_stack * +int ao_lisp_stack_push(void) { + stack_validate_tails(); + if (ao_lisp_stack) { + DBGI("formals "); DBG_POLY(ao_lisp_stack->formals); DBG("\n"); + DBGI("actuals "); DBG_POLY(ao_lisp_stack->actuals); DBG("\n"); + } + DBGI("stack push\n"); + DBG_IN(); struct ao_lisp_stack *stack = ao_lisp_alloc(sizeof (struct ao_lisp_stack)); if (!stack) - return NULL; + return 0; stack->prev = ao_lisp_stack_poly(ao_lisp_stack); ao_lisp_stack = stack; ao_lisp_stack_reset(stack); - DBGI("stack push\n"); - DBG_IN(); - return stack; + stack_validate_tails(); + return 1; } -struct ao_lisp_stack * +void ao_lisp_stack_pop(void) { if (!ao_lisp_stack) - return NULL; + return; + stack_validate_tails(); DBG_OUT(); DBGI("stack pop\n"); ao_lisp_stack = ao_lisp_poly_stack(ao_lisp_stack->prev); @@ -167,12 +213,16 @@ ao_lisp_stack_pop(void) ao_lisp_frame_current = ao_lisp_poly_frame(ao_lisp_stack->frame); else ao_lisp_frame_current = NULL; - return ao_lisp_stack; + if (ao_lisp_stack) { + DBGI("formals "); DBG_POLY(ao_lisp_stack->formals); DBG("\n"); + DBGI("actuals "); DBG_POLY(ao_lisp_stack->actuals); DBG("\n"); + } } static void ao_lisp_stack_clear(void) { + stack_validate_tails(); ao_lisp_stack = NULL; ao_lisp_frame_current = NULL; } @@ -285,7 +335,6 @@ ao_lisp_lambda(struct ao_lisp_cons *cons) ao_poly ao_lisp_eval(ao_poly _v) { - struct ao_lisp_stack *stack; ao_poly formal; ao_lisp_v = _v; @@ -295,45 +344,50 @@ ao_lisp_eval(ao_poly _v) ao_lisp_root_poly_add(&ao_lisp_v); } - stack = ao_lisp_stack_push(); + if (!ao_lisp_stack_push()) + goto bail; for (;;) { if (ao_lisp_exception) - return AO_LISP_NIL; - switch (stack->state) { + goto bail; + switch (ao_lisp_stack->state) { case eval_sexpr: DBGI("sexpr: "); DBG_POLY(ao_lisp_v); DBG("\n"); switch (ao_lisp_poly_type(ao_lisp_v)) { case AO_LISP_CONS: if (ao_lisp_v == AO_LISP_NIL) { - stack->state = eval_exec; + ao_lisp_stack->state = eval_exec; break; } - stack->actuals = ao_lisp_v; - stack->state = eval_formal; - stack = ao_lisp_stack_push(); + ao_lisp_stack->actuals = ao_lisp_v; + DBGI("actuals now "); DBG_POLY(ao_lisp_v); DBG("\n"); + ao_lisp_stack->state = eval_formal; + if (!ao_lisp_stack_push()) + goto bail; ao_lisp_v = ao_lisp_poly_cons(ao_lisp_v)->car; + stack_validate_tails(); break; case AO_LISP_ATOM: ao_lisp_v = ao_lisp_atom_get(ao_lisp_v); /* fall through */ case AO_LISP_INT: case AO_LISP_STRING: - stack->state = eval_val; + case AO_LISP_BUILTIN: + ao_lisp_stack->state = eval_val; break; } break; case eval_val: DBGI("val: "); DBG_POLY(ao_lisp_v); DBG("\n"); - stack = ao_lisp_stack_pop(); - if (!stack) + ao_lisp_stack_pop(); + if (!ao_lisp_stack) return ao_lisp_v; - DBGI("..state %d\n", stack->state); + DBGI("..state %d\n", ao_lisp_stack->state); break; case eval_formal: /* Check what kind of function we've got */ - if (!stack->formals) { + if (!ao_lisp_stack->formals) { switch (func_type(ao_lisp_v)) { case AO_LISP_LAMBDA: case _ao_lisp_atom_lambda: @@ -343,99 +397,108 @@ ao_lisp_eval(ao_poly _v) break; case AO_LISP_MACRO: case _ao_lisp_atom_macro: - stack->macro = 1; + ao_lisp_stack->macro = 1; case AO_LISP_NLAMBDA: case _ao_lisp_atom_nlambda: DBGI(".. nlambda or macro\n"); - stack->formals = stack->actuals; - stack->state = eval_exec_direct; + ao_lisp_stack->formals = ao_lisp_stack->actuals; + ao_lisp_stack->formals_tail = AO_LISP_NIL; + ao_lisp_stack->state = eval_exec_direct; + stack_validate_tails(); break; } - if (stack->state == eval_exec_direct) + if (ao_lisp_stack->state == eval_exec_direct) break; } + DBGI("add formal "); DBG_POLY(ao_lisp_v); DBG("\n"); + stack_validate_tails(); formal = ao_lisp_cons_poly(ao_lisp_cons_cons(ao_lisp_v, NULL)); - if (!formal) { - ao_lisp_stack_clear(); - return AO_LISP_NIL; - } + stack_validate_tails(); + if (!formal) + goto bail; - if (stack->formals_tail) - ao_lisp_poly_cons(stack->formals_tail)->cdr = formal; + if (ao_lisp_stack->formals_tail) + ao_lisp_poly_cons(ao_lisp_stack->formals_tail)->cdr = formal; else - stack->formals = formal; - stack->formals_tail = formal; + ao_lisp_stack->formals = formal; + ao_lisp_stack->formals_tail = formal; - DBGI("formals now "); DBG_POLY(stack->formals); DBG("\n"); + DBGI("formals now "); DBG_POLY(ao_lisp_stack->formals); DBG("\n"); - ao_lisp_v = ao_lisp_poly_cons(stack->actuals)->cdr; + ao_lisp_v = ao_lisp_poly_cons(ao_lisp_stack->actuals)->cdr; - stack->state = eval_sexpr; + stack_validate_tails(); + ao_lisp_stack->state = eval_sexpr; break; case eval_exec: - if (!stack->formals) { + if (!ao_lisp_stack->formals) { ao_lisp_v = AO_LISP_NIL; - stack->state = eval_val; + ao_lisp_stack->state = eval_val; break; } - ao_lisp_v = ao_lisp_poly_cons(stack->formals)->car; + ao_lisp_v = ao_lisp_poly_cons(ao_lisp_stack->formals)->car; case eval_exec_direct: - DBGI("exec: macro %d ", stack->macro); DBG_POLY(ao_lisp_v); DBG(" formals "); DBG_POLY(stack->formals); DBG ("\n"); + DBGI("exec: macro %d ", ao_lisp_stack->macro); DBG_POLY(ao_lisp_v); DBG(" formals "); DBG_POLY(ao_lisp_stack->formals); DBG ("\n"); if (ao_lisp_poly_type(ao_lisp_v) == AO_LISP_BUILTIN) { - struct ao_lisp_builtin *b = ao_lisp_poly_builtin(ao_lisp_v); - struct ao_lisp_cons *f = ao_lisp_poly_cons(ao_lisp_poly_cons(stack->formals)->cdr); + stack_validate_tails(); + struct ao_lisp_builtin *b = ao_lisp_poly_builtin(ao_lisp_v); + stack_validate_tails(); + struct ao_lisp_cons *f = ao_lisp_poly_cons(ao_lisp_poly_cons(ao_lisp_stack->formals)->cdr); DBGI(".. builtin formals "); DBG_CONS(f); DBG("\n"); - if (stack->macro) - stack->state = eval_sexpr; + stack_validate_tails(); + if (ao_lisp_stack->macro) + ao_lisp_stack->state = eval_sexpr; else - stack->state = eval_val; - stack->macro = 0; + ao_lisp_stack->state = eval_val; + ao_lisp_stack->macro = 0; + ao_lisp_stack->actuals = ao_lisp_stack->formals = ao_lisp_stack->formals_tail = AO_LISP_NIL; ao_lisp_v = ao_lisp_func(b) (f); DBGI("builtin result:"); DBG_POLY(ao_lisp_v); DBG ("\n"); - if (ao_lisp_exception) { - ao_lisp_stack_clear(); - return AO_LISP_NIL; - } + if (ao_lisp_exception) + goto bail; break; } else { - ao_lisp_v = ao_lisp_lambda(ao_lisp_poly_cons(stack->formals)); - ao_lisp_stack_reset(stack); + ao_lisp_v = ao_lisp_lambda(ao_lisp_poly_cons(ao_lisp_stack->formals)); + ao_lisp_stack_reset(ao_lisp_stack); } break; case eval_cond: - DBGI("cond: "); DBG_POLY(stack->actuals); DBG("\n"); - if (!stack->actuals) { + DBGI("cond: "); DBG_POLY(ao_lisp_stack->actuals); DBG("\n"); + if (!ao_lisp_stack->actuals) { ao_lisp_v = AO_LISP_NIL; - stack->state = eval_val; + ao_lisp_stack->state = eval_val; } else { - ao_lisp_v = ao_lisp_poly_cons(stack->actuals)->car; + ao_lisp_v = ao_lisp_poly_cons(ao_lisp_stack->actuals)->car; if (!ao_lisp_v || ao_lisp_poly_type(ao_lisp_v) != AO_LISP_CONS) { ao_lisp_error(AO_LISP_INVALID, "invalid cond clause"); goto bail; } ao_lisp_v = ao_lisp_poly_cons(ao_lisp_v)->car; - stack->state = eval_cond_test; - stack = ao_lisp_stack_push(); - stack->state = eval_sexpr; + ao_lisp_stack->state = eval_cond_test; + stack_validate_tails(); + ao_lisp_stack_push(); + stack_validate_tails(); + ao_lisp_stack->state = eval_sexpr; } break; case eval_cond_test: - DBGI("cond_test "); DBG_POLY(ao_lisp_v); DBG("\n"); + DBGI("cond_test: "); DBG_POLY(ao_lisp_v); DBG(" actuals "); DBG_POLY(ao_lisp_stack->actuals); DBG("\n"); if (ao_lisp_v) { - struct ao_lisp_cons *car = ao_lisp_poly_cons(ao_lisp_poly_cons(stack->actuals)->car); + struct ao_lisp_cons *car = ao_lisp_poly_cons(ao_lisp_poly_cons(ao_lisp_stack->actuals)->car); struct ao_lisp_cons *c = ao_lisp_poly_cons(car->cdr); if (c) { ao_lisp_v = c->car; - stack->state = eval_sexpr; + ao_lisp_stack->state = eval_sexpr; } else { - stack->state = eval_val; + ao_lisp_stack->state = eval_val; } } else { - stack->actuals = ao_lisp_poly_cons(stack->actuals)->cdr; - stack->state = eval_cond; + ao_lisp_stack->actuals = ao_lisp_poly_cons(ao_lisp_stack->actuals)->cdr; + DBGI("actuals now "); DBG_POLY(ao_lisp_stack->actuals); DBG("\n"); + ao_lisp_stack->state = eval_cond; } break; } diff --git a/src/lisp/ao_lisp_make_const.c b/src/lisp/ao_lisp_make_const.c index 9768dc22..f2e3cea1 100644 --- a/src/lisp/ao_lisp_make_const.c +++ b/src/lisp/ao_lisp_make_const.c @@ -41,6 +41,7 @@ struct builtin_func funcs[] = { "setq", AO_LISP_MACRO, builtin_setq, "cond", AO_LISP_NLAMBDA,builtin_cond, "print", AO_LISP_LEXPR, builtin_print, + "patom", AO_LISP_LEXPR, builtin_patom, "+", AO_LISP_LEXPR, builtin_plus, "-", AO_LISP_LEXPR, builtin_minus, "*", AO_LISP_LEXPR, builtin_times, diff --git a/src/lisp/ao_lisp_mem.c b/src/lisp/ao_lisp_mem.c index 9e716da9..6e656454 100644 --- a/src/lisp/ao_lisp_mem.c +++ b/src/lisp/ao_lisp_mem.c @@ -36,6 +36,7 @@ uint8_t ao_lisp_pool[AO_LISP_POOL] __attribute__((aligned(4))); #endif #if 0 +#define DBG_INCLUDE #define DBG_DUMP 0 #define DBG_OFFSET(a) ((int) ((uint8_t *) (a) - ao_lisp_pool)) #define DBG(...) printf(__VA_ARGS__) @@ -179,15 +180,17 @@ move_object(void) DBG_DO(void *addr = *ao_lisp_root[i].addr); DBG_MOVE("root %d\n", DBG_OFFSET(addr)); if (!ao_lisp_move(ao_lisp_root[i].type, - ao_lisp_root[i].addr)) + ao_lisp_root[i].addr)) { DBG_MOVE("root moves from %p to %p\n", addr, *ao_lisp_root[i].addr); + } } else { DBG_DO(ao_poly p = *(ao_poly *) ao_lisp_root[i].addr); - if (!ao_lisp_poly_move((ao_poly *) ao_lisp_root[i].addr)) + if (!ao_lisp_poly_move((ao_poly *) ao_lisp_root[i].addr)) { DBG_MOVE("root poly move from %04x to %04x\n", p, *(ao_poly *) ao_lisp_root[i].addr); + } } } DBG_MOVE_OUT(); @@ -338,7 +341,7 @@ ao_lisp_move(const struct ao_lisp_type *type, void **ref) int size = type->size(addr); if (!addr) - return NULL; + return 1; #ifndef AO_LISP_MAKE_CONST if (AO_LISP_IS_CONST(addr)) @@ -370,7 +373,7 @@ ao_lisp_move_memory(void **ref, int size) { void *addr = *ref; if (!addr) - return NULL; + return 1; DBG_MOVE("memory %d\n", DBG_OFFSET(addr)); DBG_MOVE_IN(); diff --git a/src/lisp/ao_lisp_prim.c b/src/lisp/ao_lisp_prim.c index 7f02505d..82386a83 100644 --- a/src/lisp/ao_lisp_prim.c +++ b/src/lisp/ao_lisp_prim.c @@ -20,21 +20,60 @@ #define DBG(...) #endif -static void (*const ao_lisp_print_funcs[AO_LISP_NUM_TYPE])(ao_poly) = { - [AO_LISP_CONS] = ao_lisp_cons_print, - [AO_LISP_STRING] = ao_lisp_string_print, - [AO_LISP_INT] = ao_lisp_int_print, - [AO_LISP_ATOM] = ao_lisp_atom_print, - [AO_LISP_BUILTIN] = ao_lisp_builtin_print +struct ao_lisp_funcs { + void (*print)(ao_poly); + void (*patom)(ao_poly); }; -ao_poly +static const struct ao_lisp_funcs ao_lisp_funcs[AO_LISP_NUM_TYPE] = { + [AO_LISP_CONS] = { + .print = ao_lisp_cons_print, + .patom = ao_lisp_cons_patom, + }, + [AO_LISP_STRING] = { + .print = ao_lisp_string_print, + .patom = ao_lisp_string_patom, + }, + [AO_LISP_INT] = { + .print = ao_lisp_int_print, + .patom = ao_lisp_int_print, + }, + [AO_LISP_ATOM] = { + .print = ao_lisp_atom_print, + .patom = ao_lisp_atom_print, + }, + [AO_LISP_BUILTIN] = { + .print = ao_lisp_builtin_print, + .patom = ao_lisp_builtin_print, + } +}; + +static const struct ao_lisp_funcs * +funcs(ao_poly p) +{ + uint8_t type = ao_lisp_poly_type(p); + + if (type < AO_LISP_NUM_TYPE) + return &ao_lisp_funcs[type]; + return NULL; +} + +void ao_lisp_poly_print(ao_poly p) { - void (*print)(ao_poly) = ao_lisp_print_funcs[ao_lisp_poly_type(p)]; - if (print) - print(p); - return p; + const struct ao_lisp_funcs *f = funcs(p); + + if (f && f->print) + f->print(p); +} + +void +ao_lisp_poly_patom(ao_poly p) +{ + const struct ao_lisp_funcs *f = funcs(p); + + if (f && f->patom) + f->patom(p); } static const struct ao_lisp_type const *ao_lisp_types[AO_LISP_NUM_TYPE] = { diff --git a/src/lisp/ao_lisp_string.c b/src/lisp/ao_lisp_string.c index 39c3dc81..0064064c 100644 --- a/src/lisp/ao_lisp_string.c +++ b/src/lisp/ao_lisp_string.c @@ -99,3 +99,13 @@ ao_lisp_string_print(ao_poly p) } putchar('"'); } + +void +ao_lisp_string_patom(ao_poly p) +{ + char *s = ao_lisp_poly_string(p); + char c; + + while ((c = *s++)) + putchar(c); +} diff --git a/src/nucleao-32/ao_pins.h b/src/nucleao-32/ao_pins.h index 65de89ed..092d347c 100644 --- a/src/nucleao-32/ao_pins.h +++ b/src/nucleao-32/ao_pins.h @@ -25,7 +25,8 @@ #define AO_LED_GREEN (1 << LED_PIN_GREEN) #define AO_LED_PANIC AO_LED_GREEN #define AO_CMD_LEN 128 -#define AO_LISP_POOL 2048 +#define AO_LISP_POOL 1024 +#define AO_STACK_SIZE 1536 #define LEDS_AVAILABLE (AO_LED_GREEN) -- cgit v1.2.3 From 41175ff82bc0e35c99c60b49aa62944a12917157 Mon Sep 17 00:00:00 2001 From: Keith Packard Date: Tue, 15 Nov 2016 10:18:12 -0800 Subject: altos/lisp: Get lambdakey and nucleo-32 building again Remove exti from the build list to make things fit. Signed-off-by: Keith Packard --- src/lambdakey-v1.0/Makefile | 3 +-- src/lisp/ao_lisp_builtin.c | 1 + src/nucleao-32/Makefile | 9 +++++++-- src/nucleao-32/ao_nucleo.c | 29 ----------------------------- src/nucleao-32/ao_pins.h | 5 +++-- 5 files changed, 12 insertions(+), 35 deletions(-) (limited to 'src/nucleao-32') diff --git a/src/lambdakey-v1.0/Makefile b/src/lambdakey-v1.0/Makefile index c71e1ab5..7f71761b 100644 --- a/src/lambdakey-v1.0/Makefile +++ b/src/lambdakey-v1.0/Makefile @@ -50,8 +50,7 @@ ALTOS_SRC = \ ao_lisp_error.c \ ao_lisp_lambda.c \ ao_lisp_save.c \ - ao_lisp_os_save.c \ - ao_exti_stm.c + ao_lisp_os_save.c PRODUCT=LambdaKey-v1.0 PRODUCT_DEF=-DLAMBDAKEY diff --git a/src/lisp/ao_lisp_builtin.c b/src/lisp/ao_lisp_builtin.c index e4b7ef52..b808cbc5 100644 --- a/src/lisp/ao_lisp_builtin.c +++ b/src/lisp/ao_lisp_builtin.c @@ -106,6 +106,7 @@ static const ao_poly ao_lisp_args_atoms[] = { char * ao_lisp_args_name(uint8_t args) { + args &= AO_LISP_FUNC_MASK; if (args < sizeof ao_lisp_args_atoms / sizeof ao_lisp_args_atoms[0]) return ao_lisp_poly_atom(ao_lisp_args_atoms[args])->name; return "(unknown)"; diff --git a/src/nucleao-32/Makefile b/src/nucleao-32/Makefile index 388e581c..57fb4cde 100644 --- a/src/nucleao-32/Makefile +++ b/src/nucleao-32/Makefile @@ -34,6 +34,7 @@ ALTOS_SRC = \ ao_mutex.c \ ao_usb_stm.c \ ao_serial_stm.c \ + ao_flash_stm.c \ ao_lisp_lex.c \ ao_lisp_mem.c \ ao_lisp_cons.c \ @@ -41,13 +42,15 @@ ALTOS_SRC = \ ao_lisp_string.c \ ao_lisp_atom.c \ ao_lisp_int.c \ - ao_lisp_prim.c \ + ao_lisp_poly.c \ ao_lisp_builtin.c \ ao_lisp_read.c \ ao_lisp_rep.c \ ao_lisp_frame.c \ ao_lisp_error.c \ - ao_exti_stm.c + ao_lisp_lambda.c \ + ao_lisp_save.c \ + ao_lisp_os_save.c PRODUCT=Nucleo-32 PRODUCT_DEF=-DNUCLEO @@ -55,6 +58,8 @@ IDPRODUCT=0x000a CFLAGS = $(PRODUCT_DEF) $(STMF0_CFLAGS) -Os -g +LDFLAGS=$(CFLAGS) -L$(TOPDIR)/stmf0 -Wl,-Tload.ld + PROGNAME=nucleo-32 PROG=$(PROGNAME)-$(VERSION).elf HEX=$(PROGNAME)-$(VERSION).ihx diff --git a/src/nucleao-32/ao_nucleo.c b/src/nucleao-32/ao_nucleo.c index 113e2399..3e448865 100644 --- a/src/nucleao-32/ao_nucleo.c +++ b/src/nucleao-32/ao_nucleo.c @@ -15,44 +15,15 @@ #include #include -static uint16_t blink_delay, blink_running; - -static void blink(void) { - blink_running = 1; - while (blink_delay) { - ao_led_on(AO_LED_GREEN); - ao_delay(blink_delay); - ao_led_off(AO_LED_GREEN); - ao_delay(blink_delay); - } - blink_running = 0; - ao_wakeup(&blink_running); - ao_exit(); -} - -struct ao_task blink_task; - -static void blink_cmd() { - ao_cmd_decimal(); - blink_delay = ao_cmd_lex_i; - if (blink_delay && !blink_running) - ao_add_task(&blink_task, blink, "blink"); - if (!blink_delay) - while (blink_running) - ao_sleep(&blink_running); -} - static void lisp_cmd() { ao_lisp_read_eval_print(); } static const struct ao_cmds blink_cmds[] = { - { blink_cmd, "b \0Blink the green LED" }, { lisp_cmd, "l\0Run lisp interpreter" }, { 0, 0 } }; - void main(void) { ao_led_init(LEDS_AVAILABLE); diff --git a/src/nucleao-32/ao_pins.h b/src/nucleao-32/ao_pins.h index 092d347c..e631db7b 100644 --- a/src/nucleao-32/ao_pins.h +++ b/src/nucleao-32/ao_pins.h @@ -25,8 +25,9 @@ #define AO_LED_GREEN (1 << LED_PIN_GREEN) #define AO_LED_PANIC AO_LED_GREEN #define AO_CMD_LEN 128 -#define AO_LISP_POOL 1024 -#define AO_STACK_SIZE 1536 +#define AO_LISP_POOL_TOTAL 3072 +#define AO_LISP_SAVE 1 +#define AO_STACK_SIZE 1024 #define LEDS_AVAILABLE (AO_LED_GREEN) -- cgit v1.2.3 From d1c2a5729da00be9d393015bbaa2d2f58e936d84 Mon Sep 17 00:00:00 2001 From: Keith Packard Date: Mon, 20 Feb 2017 17:34:43 -0800 Subject: altos/nucleo-32: Update lisp files, add beeper support Signed-off-by: Keith Packard --- src/nucleao-32/Makefile | 18 ++++++++++-------- src/nucleao-32/ao_nucleo.c | 7 +++++++ src/nucleao-32/ao_pins.h | 7 ++++++- 3 files changed, 23 insertions(+), 9 deletions(-) (limited to 'src/nucleao-32') diff --git a/src/nucleao-32/Makefile b/src/nucleao-32/Makefile index 57fb4cde..69049982 100644 --- a/src/nucleao-32/Makefile +++ b/src/nucleao-32/Makefile @@ -27,6 +27,7 @@ ALTOS_SRC = \ ao_config.c \ ao_task.c \ ao_led.c \ + ao_beep_stm.c \ ao_dma_stm.c \ ao_stdio.c \ ao_panic.c \ @@ -35,21 +36,22 @@ ALTOS_SRC = \ ao_usb_stm.c \ ao_serial_stm.c \ ao_flash_stm.c \ - ao_lisp_lex.c \ - ao_lisp_mem.c \ + ao_lisp_atom.c \ + ao_lisp_builtin.c \ ao_lisp_cons.c \ + ao_lisp_error.c \ ao_lisp_eval.c \ - ao_lisp_string.c \ - ao_lisp_atom.c \ + ao_lisp_frame.c \ ao_lisp_int.c \ + ao_lisp_lambda.c \ + ao_lisp_lex.c \ + ao_lisp_mem.c \ ao_lisp_poly.c \ - ao_lisp_builtin.c \ ao_lisp_read.c \ ao_lisp_rep.c \ - ao_lisp_frame.c \ - ao_lisp_error.c \ - ao_lisp_lambda.c \ ao_lisp_save.c \ + ao_lisp_stack.c \ + ao_lisp_string.c \ ao_lisp_os_save.c PRODUCT=Nucleo-32 diff --git a/src/nucleao-32/ao_nucleo.c b/src/nucleao-32/ao_nucleo.c index 3e448865..6b4cbaae 100644 --- a/src/nucleao-32/ao_nucleo.c +++ b/src/nucleao-32/ao_nucleo.c @@ -14,13 +14,19 @@ #include #include +#include static void lisp_cmd() { ao_lisp_read_eval_print(); } +static void beep() { + ao_beep_for(AO_BEEP_MID, AO_MS_TO_TICKS(200)); +} + static const struct ao_cmds blink_cmds[] = { { lisp_cmd, "l\0Run lisp interpreter" }, + { beep, "b\0Beep" }, { 0, 0 } }; @@ -33,6 +39,7 @@ void main(void) ao_dma_init(); ao_usb_init(); ao_serial_init(); + ao_beep_init(); ao_cmd_init(); ao_cmd_register(blink_cmds); ao_start_scheduler(); diff --git a/src/nucleao-32/ao_pins.h b/src/nucleao-32/ao_pins.h index e631db7b..cee4616f 100644 --- a/src/nucleao-32/ao_pins.h +++ b/src/nucleao-32/ao_pins.h @@ -47,7 +47,12 @@ #define HAS_USB 1 #define AO_USB_DIRECTIO 0 #define AO_PA11_PA12_RMP 0 -#define HAS_BEEP 0 +#define HAS_BEEP 1 + +#define BEEPER_TIMER 2 +#define BEEPER_CHANNEL 4 +#define BEEPER_PORT (&stm_gpioa) +#define BEEPER_PIN 3 #define IS_FLASH_LOADER 0 -- cgit v1.2.3