diff options
Diffstat (limited to 'src')
134 files changed, 10877 insertions, 6272 deletions
diff --git a/src/Makefile b/src/Makefile index 661fd333..8420b376 100644 --- a/src/Makefile +++ b/src/Makefile @@ -21,7 +21,6 @@ SDCCDIRS=\ teledongle-v0.2 \ telemini-v1.0 \ telebt-v1.0 \ - teleterra-v0.2 teleshield-v0.1 \ telefire-v0.1 telefire-v0.2 \ telerepeat-v1.0 @@ -30,15 +29,14 @@ ARMM3DIRS=\ telemega-v0.1 telemega-v0.1/flash-loader \ telemega-v1.0 telemega-v1.0/flash-loader \ telemega-v2.0 telemega-v2.0/flash-loader \ + telemega-v3.0 telemega-v3.0/flash-loader \ telemetrum-v2.0 telemetrum-v2.0/flash-loader \ telemetrum-v3.0 telemetrum-v3.0/flash-loader \ - megadongle-v0.1 megadongle-v0.1/flash-loader \ telegps-v0.3 telegps-v0.3/flash-loader \ telegps-v1.0 telegps-v1.0/flash-loader \ telegps-v2.0 telegps-v2.0/flash-loader \ telelco-v0.2 telelco-v0.2/flash-loader \ telelco-v0.3 telelco-v0.3/flash-loader \ - telescience-v0.2 telescience-v0.2/flash-loader \ teledongle-v3.0 teledongle-v3.0/flash-loader \ teleballoon-v2.0 \ telebt-v3.0 telebt-v3.0/flash-loader \ @@ -48,14 +46,13 @@ ARMM3DIRS=\ ARMM0DIRS=\ easymini-v1.0 easymini-v1.0/flash-loader \ - chaoskey-v0.1 chaoskey-v0.1/flash-loader \ chaoskey-v1.0 chaoskey-v1.0/flash-loader \ telemini-v3.0 telemini-v3.0/flash-loader \ easymini-v2.0 easymini-v2.0/flash-loader \ micropeak-v2.0 micropeak-v2.0/flash-loader AVRDIRS=\ - telescience-v0.1 telescience-pwm micropeak nanopeak-v0.1 microkite + micropeak microkite SUBDIRS= diff --git a/src/cc1111/Makefile.cc1111 b/src/cc1111/Makefile.cc1111 index 0ea30e1d..cb2d3db4 100644 --- a/src/cc1111/Makefile.cc1111 +++ b/src/cc1111/Makefile.cc1111 @@ -1,7 +1,7 @@ include ../Makedefs CC=$(SDCC) -CFLAGS=--model-small --debug --opt-code-speed -DCODESIZE=$(CODESIZE) +CFLAGS=--model-small --debug --opt-code-speed -DCODESIZE=$(CODESIZE) -DCC1111 CFLAGS += $(PRODUCT_DEF) -I. -I.. -I../kernel -I../cc1111 -I../drivers -I../product diff --git a/src/cc1111/ao_arch.h b/src/cc1111/ao_arch.h index bacfabb8..937e6d0c 100644 --- a/src/cc1111/ao_arch.h +++ b/src/cc1111/ao_arch.h @@ -234,6 +234,10 @@ ao_button_get(uint16_t timeout) __critical; void ao_button_clear(void) __critical; +/* console I/O funcs */ +#define ao_getchar getchar +#define ao_putchar putchar + /* ao_string.c */ void diff --git a/src/cc1111/ao_pins.h b/src/cc1111/ao_pins.h index 10b1f802..9d6e1c1d 100644 --- a/src/cc1111/ao_pins.h +++ b/src/cc1111/ao_pins.h @@ -63,6 +63,7 @@ #define HAS_RADIO_RATE 0 /* not enough space for this */ #define HAS_MUTEX_TRY 0 #define HAS_TASK_INFO 0 /* not enough space for this either */ + #define AO_LOG_FORMAT AO_LOG_FORMAT_FULL #endif #if defined(TELEMETRUM_V_1_1) @@ -106,6 +107,7 @@ #define HAS_TELEMETRY 1 #define HAS_RADIO_RATE 0 /* not enough space for this */ #define HAS_MUTEX_TRY 0 + #define AO_LOG_FORMAT AO_LOG_FORMAT_FULL #endif #if defined(TELEMETRUM_V_1_2) @@ -149,6 +151,7 @@ #define HAS_TELEMETRY 1 #define HAS_RADIO_RATE 0 /* not enough space for this */ #define HAS_MUTEX_TRY 0 + #define AO_LOG_FORMAT AO_LOG_FORMAT_FULL #endif #if defined(TELEDONGLE_V_0_2) @@ -210,6 +213,7 @@ #define HAS_MONITOR 0 #define HAS_TELEMETRY 1 #define HAS_RADIO_RATE 0 /* not enough space for this */ + #define AO_LOG_FORMAT AO_LOG_FORMAT_TINY #endif #if defined(TELENANO_V_0_1) @@ -274,6 +278,7 @@ #define HAS_TELEMETRY 1 #define HAS_RADIO_RATE 0 /* not enough space for this */ #define AO_CONFIG_DEFAULT_FLIGHT_LOG_MAX ((uint32_t) 127 * (uint32_t) 1024) + #define AO_LOG_FORMAT AO_LOG_FORMAT_FULL #endif #if defined(TELEDONGLE_V_0_1) diff --git a/src/cortexelf-v1/.gitignore b/src/cortexelf-v1/.gitignore new file mode 100644 index 00000000..0189131b --- /dev/null +++ b/src/cortexelf-v1/.gitignore @@ -0,0 +1,3 @@ +cortexelf-v1*.elf +cortexelf-v1*.hex +ao_product.h diff --git a/src/cortexelf-v1/Makefile b/src/cortexelf-v1/Makefile index 8cc6ce31..12c658dc 100644 --- a/src/cortexelf-v1/Makefile +++ b/src/cortexelf-v1/Makefile @@ -4,7 +4,8 @@ # include ../stm/Makefile.defs -LDFLAGS=-L../stm -Wl,-Tcortexelf.ld +include ../scheme/Makefile-inc + INC = \ ao.h \ @@ -19,15 +20,12 @@ INC = \ math.h \ ao_mpu.h \ stm32l.h \ - math.h \ ao_vga.h \ ao_draw.h \ ao_draw_int.h \ ao_font.h \ ao_ps2.h \ - ao_lisp.h \ - ao_lisp_const.h \ - ao_lisp_os.h \ + $(SCHEME_HDRS) \ ao_flip_bits.h \ Makefile @@ -46,6 +44,7 @@ ALTOS_SRC = \ ao_cmd.c \ ao_config.c \ ao_task.c \ + ao_errno.c \ ao_stdio.c \ ao_panic.c \ ao_timer.c \ @@ -74,23 +73,8 @@ ALTOS_SRC = \ ao_event.c \ ao_1802.c \ ao_hex.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_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_os_save.c \ + $(SCHEME_SRCS) \ + ao_scheme_os_save.c \ $(PROFILE) \ $(SAMPLE_PROFILE) \ $(STACK_GUARD) @@ -99,12 +83,21 @@ PRODUCT=CortexELF-v1 PRODUCT_DEF=-DCORTEXELF IDPRODUCT=0x000a -CFLAGS = $(PRODUCT_DEF) $(STM_CFLAGS) $(PROFILE_DEF) $(SAMPLE_PROFILE_DEF) $(STACK_GUARD_DEF) -Os -g - PROGNAME=cortexelf-v1 PROG=$(PROGNAME)-$(VERSION).elf HEX=$(PROGNAME)-$(VERSION).ihx +MAP=$(PROG).map + +MAPFILE=-Wl,-M=$(MAP) + +LDFLAGS=-L../stm -L/local/newlib-mini/arm-none-eabi/lib/thumb/v7-m/ -Wl,-Tcortexelf.ld $(MAPFILE) -nostartfiles +AO_CFLAGS=-I. -I../stm -I../kernel -I../drivers -I../draw -I../scheme -I.. -I/local/newlib-mini/arm-none-eabi/include +LIBS=-lc -lm -lgcc + +CFLAGS = $(PRODUCT_DEF) $(STM_CFLAGS) $(PROFILE_DEF) $(SAMPLE_PROFILE_DEF) $(STACK_GUARD_DEF) -Os -g + + SRC=$(ALTOS_SRC) ao_cortexelf.c OBJ=$(SRC:.c=.o) @@ -130,7 +123,7 @@ clean:: ao_flip_bits.h: ao_flip_bits.5c nickle ao_flip_bits.5c > $@ -include ../lisp/Makefile-lisp +include ../scheme/Makefile-scheme install: diff --git a/src/cortexelf-v1/ao_cortexelf.c b/src/cortexelf-v1/ao_cortexelf.c index 61a9d219..5ed78bf0 100644 --- a/src/cortexelf-v1/ao_cortexelf.c +++ b/src/cortexelf-v1/ao_cortexelf.c @@ -27,7 +27,7 @@ #include <ao_console.h> #include <ao_sdcard.h> #include <ao_fat.h> -#include <ao_lisp.h> +#include <ao_scheme.h> #include <ao_button.h> #include <ao_event.h> #include <ao_as1107.h> @@ -188,8 +188,8 @@ ao_console_send(void) } } -static void lisp_cmd() { - ao_lisp_read_eval_print(); +static void scheme_cmd() { + ao_scheme_read_eval_print(); } static void @@ -224,7 +224,7 @@ __code struct ao_cmds ao_demo_cmds[] = { { ao_ps2_read_keys, "K\0Read keys from keyboard" }, { ao_console_send, "C\0Send data to console, end with ~" }, { ao_serial_blather, "S\0Blather on serial ports briefly" }, - { lisp_cmd, "l\0Run lisp interpreter" }, + { scheme_cmd, "l\0Run scheme interpreter" }, { led_cmd, "L start value\0Show value (byte) at digit start" }, { 0, NULL } }; diff --git a/src/cortexelf-v1/ao_pins.h b/src/cortexelf-v1/ao_pins.h index 258ffe31..c2bbf2d2 100644 --- a/src/cortexelf-v1/ao_pins.h +++ b/src/cortexelf-v1/ao_pins.h @@ -62,6 +62,8 @@ #define USE_SERIAL_2_STDIN 1 #define SERIAL_2_PA2_PA3 0 #define SERIAL_2_PD5_PD6 1 +#define USE_SERIAL_2_FLOW 0 +#define USE_SERIAL_2_SW_FLOW 0 #define HAS_SERIAL_3 0 #define USE_SERIAL_3_STDIN 0 diff --git a/src/cortexelf-v1/ao_lisp_os.h b/src/cortexelf-v1/ao_scheme_os.h index d0c1f7b7..58e4f5b3 100644 --- a/src/cortexelf-v1/ao_lisp_os.h +++ b/src/cortexelf-v1/ao_scheme_os.h @@ -15,16 +15,22 @@ * 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA. */ -#ifndef _AO_LISP_OS_H_ -#define _AO_LISP_OS_H_ +#ifndef _AO_SCHEME_OS_H_ +#define _AO_SCHEME_OS_H_ #include "ao.h" -#define AO_LISP_POOL_TOTAL 16384 -#define AO_LISP_SAVE 1 +#define AO_SCHEME_POOL_TOTAL 16384 +#define AO_SCHEME_SAVE 1 + +#ifndef __BYTE_ORDER +#define __LITTLE_ENDIAN 1234 +#define __BIG_ENDIAN 4321 +#define __BYTE_ORDER __LITTLE_ENDIAN +#endif static inline int -ao_lisp_getc() { +ao_scheme_getc() { static uint8_t at_eol; int c; @@ -39,27 +45,35 @@ ao_lisp_getc() { } static inline void -ao_lisp_os_flush(void) +ao_scheme_os_flush(void) { flush(); } static inline void -ao_lisp_abort(void) +ao_scheme_abort(void) { ao_panic(1); } static inline void -ao_lisp_os_led(int led) +ao_scheme_os_led(int led) { (void) led; } +#define AO_SCHEME_JIFFIES_PER_SECOND AO_HERTZ + static inline void -ao_lisp_os_delay(int delay) +ao_scheme_os_delay(int delay) +{ + ao_delay(delay); +} + +static inline int +ao_scheme_os_jiffy(void) { - ao_delay(AO_MS_TO_TICKS(delay)); + return ao_tick_count; } #endif diff --git a/src/cortexelf-v1/ao_lisp_os_save.c b/src/cortexelf-v1/ao_scheme_os_save.c index 7c853990..4cec79c6 100644 --- a/src/cortexelf-v1/ao_lisp_os_save.c +++ b/src/cortexelf-v1/ao_scheme_os_save.c @@ -13,25 +13,25 @@ */ #include <ao.h> -#include <ao_lisp.h> +#include <ao_scheme.h> #include <ao_flash.h> extern uint8_t __flash__[]; /* saved variables to rebuild the heap - ao_lisp_atoms - ao_lisp_frame_global + ao_scheme_atoms + ao_scheme_frame_global */ int -ao_lisp_os_save(void) +ao_scheme_os_save(void) { int i; - for (i = 0; i < AO_LISP_POOL_TOTAL; i += 256) { + for (i = 0; i < AO_SCHEME_POOL_TOTAL; i += 256) { uint32_t *dst = (uint32_t *) (void *) &__flash__[i]; - uint32_t *src = (uint32_t *) (void *) &ao_lisp_pool[i]; + uint32_t *src = (uint32_t *) (void *) &ao_scheme_pool[i]; ao_flash_page(dst, src); } @@ -39,15 +39,15 @@ ao_lisp_os_save(void) } int -ao_lisp_os_restore_save(struct ao_lisp_os_save *save, int offset) +ao_scheme_os_restore_save(struct ao_scheme_os_save *save, int offset) { - memcpy(save, &__flash__[offset], sizeof (struct ao_lisp_os_save)); + memcpy(save, &__flash__[offset], sizeof (struct ao_scheme_os_save)); return 1; } int -ao_lisp_os_restore(void) +ao_scheme_os_restore(void) { - memcpy(ao_lisp_pool, __flash__, AO_LISP_POOL_TOTAL); + memcpy(ao_scheme_pool, __flash__, AO_SCHEME_POOL_TOTAL); return 1; } diff --git a/src/drivers/ao_mpu9250.c b/src/drivers/ao_mpu9250.c new file mode 100644 index 00000000..ae8dacd0 --- /dev/null +++ b/src/drivers/ao_mpu9250.c @@ -0,0 +1,575 @@ +/* + * Copyright © 2012 Keith Packard <keithp@keithp.com> + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation; either version 2 of the License, or + * (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, but + * WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + * General Public License for more details. + * + * 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. + */ + +#include <ao.h> +#include <ao_mpu9250.h> +#include <ao_exti.h> + +#if HAS_MPU9250 + +#define MPU9250_TEST 0 + +static uint8_t ao_mpu9250_configured; + +extern uint8_t ao_sensor_errors; + +#ifndef AO_MPU9250_I2C_INDEX +#define AO_MPU9250_SPI 1 +#else +#define AO_MPU9250_SPI 0 +#endif + +#if AO_MPU9250_SPI + +#define ao_mpu9250_spi_get() ao_spi_get(AO_MPU9250_SPI_BUS, AO_SPI_SPEED_1MHz) +#define ao_mpu9250_spi_put() ao_spi_put(AO_MPU9250_SPI_BUS) + +#define ao_mpu9250_spi_start() ao_spi_set_cs(AO_MPU9250_SPI_CS_PORT, \ + (1 << AO_MPU9250_SPI_CS_PIN)) + +#define ao_mpu9250_spi_end() ao_spi_clr_cs(AO_MPU9250_SPI_CS_PORT, \ + (1 << AO_MPU9250_SPI_CS_PIN)) + +#else + +#define ao_mpu9250_spi_get() +#define ao_mpu9250_spi_put() + +#endif + +static void +_ao_mpu9250_reg_write(uint8_t addr, uint8_t value) +{ + uint8_t d[2] = { addr, value }; +#if AO_MPU9250_SPI + ao_mpu9250_spi_start(); + ao_spi_send(d, 2, AO_MPU9250_SPI_BUS); + ao_mpu9250_spi_end(); +#else + ao_i2c_get(AO_MPU9250_I2C_INDEX); + ao_i2c_start(AO_MPU9250_I2C_INDEX, MPU9250_ADDR_WRITE); + ao_i2c_send(d, 2, AO_MPU9250_I2C_INDEX, TRUE); + ao_i2c_put(AO_MPU9250_I2C_INDEX); +#endif +} + +static void +_ao_mpu9250_read(uint8_t addr, void *data, uint8_t len) +{ +#if AO_MPU9250_SPI + addr |= 0x80; + ao_mpu9250_spi_start(); + ao_spi_send(&addr, 1, AO_MPU9250_SPI_BUS); + ao_spi_recv(data, len, AO_MPU9250_SPI_BUS); + ao_mpu9250_spi_end(); +#else + ao_i2c_get(AO_MPU9250_I2C_INDEX); + ao_i2c_start(AO_MPU9250_I2C_INDEX, MPU9250_ADDR_WRITE); + ao_i2c_send(&addr, 1, AO_MPU9250_I2C_INDEX, FALSE); + ao_i2c_start(AO_MPU9250_I2C_INDEX, MPU9250_ADDR_READ); + ao_i2c_recv(data, len, AO_MPU9250_I2C_INDEX, TRUE); + ao_i2c_put(AO_MPU9250_I2C_INDEX); +#endif +} + +static uint8_t +_ao_mpu9250_reg_read(uint8_t addr) +{ + uint8_t value; +#if AO_MPU9250_SPI + addr |= 0x80; + ao_mpu9250_spi_start(); + ao_spi_send(&addr, 1, AO_MPU9250_SPI_BUS); + ao_spi_recv(&value, 1, AO_MPU9250_SPI_BUS); + ao_mpu9250_spi_end(); +#else + ao_i2c_get(AO_MPU9250_I2C_INDEX); + ao_i2c_start(AO_MPU9250_I2C_INDEX, MPU9250_ADDR_WRITE); + ao_i2c_send(&addr, 1, AO_MPU9250_I2C_INDEX, FALSE); + ao_i2c_start(AO_MPU9250_I2C_INDEX, MPU9250_ADDR_READ); + ao_i2c_recv(&value, 1, AO_MPU9250_I2C_INDEX, TRUE); + ao_i2c_put(AO_MPU9250_I2C_INDEX); +#endif + return value; +} + +static void +_ao_mpu9250_slv4_setup(uint8_t addr, uint8_t reg) +{ + /* Set i2c slave address */ + _ao_mpu9250_reg_write(MPU9250_I2C_SLV4_ADDR, + addr); + + /* Set i2c register address */ + _ao_mpu9250_reg_write(MPU9250_I2C_SLV4_REG, + reg); +} + +static void +_ao_mpu9250_slv4_run(void) +{ + uint8_t ctrl; + + /* Start the transfer */ + _ao_mpu9250_reg_write(MPU9250_I2C_SLV4_CTRL, + (1 << MPU9250_I2C_SLV4_CTRL_I2C_SLV4_EN) | + (0 << MPU9250_I2C_SLV4_CTRL_SLV4_DONE_INT_EN) | + (0 << MPU9250_I2C_SLV4_CTRL_I2C_SLV4_REG_DIS) | + (0 << MPU9250_I2C_SLV4_CTRL_I2C_MST_DLY)); + + /* Poll for completion */ + for (;;) { + ctrl = _ao_mpu9250_reg_read(MPU9250_I2C_SLV4_CTRL); + if ((ctrl & (1 << MPU9250_I2C_SLV4_CTRL_I2C_SLV4_EN)) == 0) + break; + ao_delay(0); + } +} + +static uint8_t +_ao_mpu9250_mag_reg_read(uint8_t reg) +{ + _ao_mpu9250_slv4_setup((1 << 7) | MPU9250_MAG_ADDR, reg); + + _ao_mpu9250_slv4_run(); + + return _ao_mpu9250_reg_read(MPU9250_I2C_SLV4_DI); +} + +static void +_ao_mpu9250_mag_reg_write(uint8_t reg, uint8_t value) +{ + _ao_mpu9250_slv4_setup((0 << 7) | MPU9250_MAG_ADDR, reg); + + /* Set the data */ + _ao_mpu9250_reg_write(MPU9250_I2C_SLV4_DO, + value); + + _ao_mpu9250_slv4_run(); +} + +static void +_ao_mpu9250_sample(struct ao_mpu9250_sample *sample) +{ + uint16_t *d = (uint16_t *) sample; + int i = sizeof (*sample) / 2; + + _ao_mpu9250_read(MPU9250_ACCEL_XOUT_H, sample, sizeof (*sample)); +#if __BYTE_ORDER == __LITTLE_ENDIAN + /* byte swap */ + while (i--) { + uint16_t t = *d; + *d++ = (t >> 8) | (t << 8); + } +#endif +} + +#define G 981 /* in cm/s² */ + +#if 0 +static int16_t /* cm/s² */ +ao_mpu9250_accel(int16_t v) +{ + return (int16_t) ((v * (int32_t) (16.0 * 980.665 + 0.5)) / 32767); +} + +static int16_t /* deg*10/s */ +ao_mpu9250_gyro(int16_t v) +{ + return (int16_t) ((v * (int32_t) 20000) / 32767); +} +#endif + +static uint8_t +ao_mpu9250_accel_check(int16_t normal, int16_t test) +{ + int16_t diff = test - normal; + + if (diff < MPU9250_ST_ACCEL(16) / 4) { + return 1; + } + if (diff > MPU9250_ST_ACCEL(16) * 4) { + return 1; + } + return 0; +} + +static uint8_t +ao_mpu9250_gyro_check(int16_t normal, int16_t test) +{ + int16_t diff = test - normal; + + if (diff < 0) + diff = -diff; + if (diff < MPU9250_ST_GYRO(2000) / 4) { + return 1; + } + if (diff > MPU9250_ST_GYRO(2000) * 4) { + return 1; + } + return 0; +} + +static void +_ao_mpu9250_wait_alive(void) +{ + uint8_t i; + + /* Wait for the chip to wake up */ + for (i = 0; i < 30; i++) { + ao_delay(AO_MS_TO_TICKS(100)); + if (_ao_mpu9250_reg_read(MPU9250_WHO_AM_I) == MPU9250_I_AM_9250) + break; + } + if (i == 30) + ao_panic(AO_PANIC_SELF_TEST_MPU9250); +} + +#define ST_TRIES 10 +#define MAG_TRIES 10 + +static void +_ao_mpu9250_setup(void) +{ + struct ao_mpu9250_sample normal_mode, test_mode; + int errors; + int st_tries; + int mag_tries; + + if (ao_mpu9250_configured) + return; + + _ao_mpu9250_wait_alive(); + + /* Reset the whole chip */ + + _ao_mpu9250_reg_write(MPU9250_PWR_MGMT_1, + (1 << MPU9250_PWR_MGMT_1_DEVICE_RESET)); + + /* Wait for it to reset. If we talk too quickly, it appears to get confused */ + + _ao_mpu9250_wait_alive(); + + /* Reset signal conditioning, disabling I2C on SPI systems */ + _ao_mpu9250_reg_write(MPU9250_USER_CTRL, + (0 << MPU9250_USER_CTRL_FIFO_EN) | + (1 << MPU9250_USER_CTRL_I2C_MST_EN) | + (AO_MPU9250_SPI << MPU9250_USER_CTRL_I2C_IF_DIS) | + (0 << MPU9250_USER_CTRL_FIFO_RESET) | + (0 << MPU9250_USER_CTRL_I2C_MST_RESET) | + (1 << MPU9250_USER_CTRL_SIG_COND_RESET)); + + while (_ao_mpu9250_reg_read(MPU9250_USER_CTRL) & (1 << MPU9250_USER_CTRL_SIG_COND_RESET)) + ao_delay(AO_MS_TO_TICKS(10)); + + /* Reset signal paths */ + _ao_mpu9250_reg_write(MPU9250_SIGNAL_PATH_RESET, + (1 << MPU9250_SIGNAL_PATH_RESET_GYRO_RESET) | + (1 << MPU9250_SIGNAL_PATH_RESET_ACCEL_RESET) | + (1 << MPU9250_SIGNAL_PATH_RESET_TEMP_RESET)); + + _ao_mpu9250_reg_write(MPU9250_SIGNAL_PATH_RESET, + (0 << MPU9250_SIGNAL_PATH_RESET_GYRO_RESET) | + (0 << MPU9250_SIGNAL_PATH_RESET_ACCEL_RESET) | + (0 << MPU9250_SIGNAL_PATH_RESET_TEMP_RESET)); + + /* Select clocks, disable sleep */ + _ao_mpu9250_reg_write(MPU9250_PWR_MGMT_1, + (0 << MPU9250_PWR_MGMT_1_DEVICE_RESET) | + (0 << MPU9250_PWR_MGMT_1_SLEEP) | + (0 << MPU9250_PWR_MGMT_1_CYCLE) | + (0 << MPU9250_PWR_MGMT_1_TEMP_DIS) | + (MPU9250_PWR_MGMT_1_CLKSEL_PLL_X_AXIS << MPU9250_PWR_MGMT_1_CLKSEL)); + + /* Set I2C clock and options */ + _ao_mpu9250_reg_write(MPU9250_MST_CTRL, + (0 << MPU9250_MST_CTRL_MULT_MST_EN) | + (0 << MPU9250_MST_CTRL_WAIT_FOR_ES) | + (0 << MPU9250_MST_CTRL_SLV_3_FIFO_EN) | + (0 << MPU9250_MST_CTRL_I2C_MST_P_NSR) | + (MPU9250_MST_CTRL_I2C_MST_CLK_400 << MPU9250_MST_CTRL_I2C_MST_CLK)); + + /* Set sample rate divider to sample at full speed */ + _ao_mpu9250_reg_write(MPU9250_SMPRT_DIV, 0); + + /* Disable filtering */ + _ao_mpu9250_reg_write(MPU9250_CONFIG, + (MPU9250_CONFIG_EXT_SYNC_SET_DISABLED << MPU9250_CONFIG_EXT_SYNC_SET) | + (MPU9250_CONFIG_DLPF_CFG_250 << MPU9250_CONFIG_DLPF_CFG)); + + for (st_tries = 0; st_tries < ST_TRIES; st_tries++) { + errors = 0; + + /* Configure accelerometer to +/-16G in self-test mode */ + _ao_mpu9250_reg_write(MPU9250_ACCEL_CONFIG, + (1 << MPU9250_ACCEL_CONFIG_XA_ST) | + (1 << MPU9250_ACCEL_CONFIG_YA_ST) | + (1 << MPU9250_ACCEL_CONFIG_ZA_ST) | + (MPU9250_ACCEL_CONFIG_AFS_SEL_16G << MPU9250_ACCEL_CONFIG_AFS_SEL)); + + /* Configure gyro to +/- 2000°/s in self-test mode */ + _ao_mpu9250_reg_write(MPU9250_GYRO_CONFIG, + (1 << MPU9250_GYRO_CONFIG_XG_ST) | + (1 << MPU9250_GYRO_CONFIG_YG_ST) | + (1 << MPU9250_GYRO_CONFIG_ZG_ST) | + (MPU9250_GYRO_CONFIG_FS_SEL_2000 << MPU9250_GYRO_CONFIG_FS_SEL)); + + ao_delay(AO_MS_TO_TICKS(200)); + _ao_mpu9250_sample(&test_mode); + + /* Configure accelerometer to +/-16G */ + _ao_mpu9250_reg_write(MPU9250_ACCEL_CONFIG, + (0 << MPU9250_ACCEL_CONFIG_XA_ST) | + (0 << MPU9250_ACCEL_CONFIG_YA_ST) | + (0 << MPU9250_ACCEL_CONFIG_ZA_ST) | + (MPU9250_ACCEL_CONFIG_AFS_SEL_16G << MPU9250_ACCEL_CONFIG_AFS_SEL)); + + /* Configure gyro to +/- 2000°/s */ + _ao_mpu9250_reg_write(MPU9250_GYRO_CONFIG, + (0 << MPU9250_GYRO_CONFIG_XG_ST) | + (0 << MPU9250_GYRO_CONFIG_YG_ST) | + (0 << MPU9250_GYRO_CONFIG_ZG_ST) | + (MPU9250_GYRO_CONFIG_FS_SEL_2000 << MPU9250_GYRO_CONFIG_FS_SEL)); + + ao_delay(AO_MS_TO_TICKS(200)); + _ao_mpu9250_sample(&normal_mode); + + errors += ao_mpu9250_accel_check(normal_mode.accel_x, test_mode.accel_x); + errors += ao_mpu9250_accel_check(normal_mode.accel_y, test_mode.accel_y); + errors += ao_mpu9250_accel_check(normal_mode.accel_z, test_mode.accel_z); + + errors += ao_mpu9250_gyro_check(normal_mode.gyro_x, test_mode.gyro_x); + errors += ao_mpu9250_gyro_check(normal_mode.gyro_y, test_mode.gyro_y); + errors += ao_mpu9250_gyro_check(normal_mode.gyro_z, test_mode.gyro_z); + if (!errors) + break; + } + + if (st_tries == ST_TRIES) + ao_sensor_errors = 1; + + /* Set up the mag sensor */ + + /* make sure it's alive */ + for (mag_tries = 0; mag_tries < MAG_TRIES; mag_tries++) { + if (_ao_mpu9250_mag_reg_read(MPU9250_MAG_WIA) == MPU9250_MAG_WIA_VALUE) + break; + } + + if (mag_tries == MAG_TRIES) + ao_sensor_errors = 1; + + /* Select continuous mode 2 (100Hz), 16 bit samples */ + + _ao_mpu9250_mag_reg_write(MPU9250_MAG_CNTL1, + (MPU9250_MAG_CNTL1_BIT_16 << MPU9250_MAG_CNTL1_BIT) | + (MPU9250_MAG_CNTL1_MODE_CONT_2 << MPU9250_MAG_CNTL1_MODE)); + + /* Set i2c master to delay shadowing data until read is + * complete (avoids tearing the data) */ + + _ao_mpu9250_reg_write(MPU9250_I2C_MST_DELAY_CTRL, + (1 << MPU9250_I2C_MST_DELAY_CTRL_DELAY_ES_SHADOW) | + (0 << MPU9250_I2C_MST_DELAY_CTRL_I2C_SLV4_DLY_EN) | + (0 << MPU9250_I2C_MST_DELAY_CTRL_I2C_SLV3_DLY_EN) | + (0 << MPU9250_I2C_MST_DELAY_CTRL_I2C_SLV2_DLY_EN) | + (0 << MPU9250_I2C_MST_DELAY_CTRL_I2C_SLV1_DLY_EN) | + (0 << MPU9250_I2C_MST_DELAY_CTRL_I2C_SLV0_DLY_EN)); + + /* Set up i2c slave 0 to read the mag registers starting at HXL (3) */ + + _ao_mpu9250_reg_write(MPU9250_I2C_SLV0_ADDR, + (1 << 7) | MPU9250_MAG_ADDR); + + _ao_mpu9250_reg_write(MPU9250_I2C_SLV0_REG, + MPU9250_MAG_HXL); + + /* Byte swap so the mag values match the gyro/accel. Read 7 bytes + * to include the status register + */ + + _ao_mpu9250_reg_write(MPU9250_I2C_SLV0_CTRL, + (1 << MPU9250_I2C_SLV0_CTRL_I2C_SLV0_EN) | + (1 << MPU9250_I2C_SLV0_CTRL_I2C_SLV0_BYTE_SW) | + (0 << MPU9250_I2C_SLV0_CTRL_I2C_SLV0_REG_DIS) | + (1 << MPU9250_I2C_SLV0_CTRL_I2C_SLV0_GRP) | + (MPU9250_MAG_ST2 - MPU9250_MAG_HXL + 1) << MPU9250_I2C_SLV0_CTRL_I2C_SLV0_LENG); + + /* Filter to about 100Hz, which also sets the gyro rate to 1000Hz */ + _ao_mpu9250_reg_write(MPU9250_CONFIG, + (MPU9250_CONFIG_FIFO_MODE_REPLACE << MPU9250_CONFIG_FIFO_MODE) | + (MPU9250_CONFIG_EXT_SYNC_SET_DISABLED << MPU9250_CONFIG_EXT_SYNC_SET) | + (MPU9250_CONFIG_DLPF_CFG_92 << MPU9250_CONFIG_DLPF_CFG)); + + /* Set sample rate divider to sample at 200Hz (v = gyro/rate - 1) */ + _ao_mpu9250_reg_write(MPU9250_SMPRT_DIV, + 1000 / 200 - 1); + + ao_delay(AO_MS_TO_TICKS(100)); + ao_mpu9250_configured = 1; +} + +struct ao_mpu9250_sample ao_mpu9250_current; + +static void +ao_mpu9250(void) +{ + struct ao_mpu9250_sample sample; + + /* ao_mpu9250_init already grabbed the SPI bus and mutex */ + _ao_mpu9250_setup(); + ao_mpu9250_spi_put(); + for (;;) + { + ao_mpu9250_spi_get(); + _ao_mpu9250_sample(&sample); + ao_mpu9250_spi_put(); + ao_arch_block_interrupts(); + ao_mpu9250_current = sample; + AO_DATA_PRESENT(AO_DATA_MPU9250); + AO_DATA_WAIT(); + ao_arch_release_interrupts(); + } +} + +static struct ao_task ao_mpu9250_task; + +static void +ao_mpu9250_show(void) +{ + printf ("Accel: %7d %7d %7d Gyro: %7d %7d %7d Mag: %7d %7d %7d\n", + ao_mpu9250_current.accel_x, + ao_mpu9250_current.accel_y, + ao_mpu9250_current.accel_z, + ao_mpu9250_current.gyro_x, + ao_mpu9250_current.gyro_y, + ao_mpu9250_current.gyro_z, + ao_mpu9250_current.mag_x, + ao_mpu9250_current.mag_y, + ao_mpu9250_current.mag_z); +} + +#if MPU9250_TEST + +static void +ao_mpu9250_read(void) +{ + uint8_t addr; + uint8_t val; + + ao_cmd_hex(); + if (ao_cmd_status != ao_cmd_success) + return; + addr = ao_cmd_lex_i; + ao_mpu9250_spi_get(); + val = _ao_mpu9250_reg_read(addr); + ao_mpu9250_spi_put(); + printf("Addr %02x val %02x\n", addr, val); +} + +static void +ao_mpu9250_write(void) +{ + uint8_t addr; + uint8_t val; + + ao_cmd_hex(); + if (ao_cmd_status != ao_cmd_success) + return; + addr = ao_cmd_lex_i; + ao_cmd_hex(); + if (ao_cmd_status != ao_cmd_success) + return; + val = ao_cmd_lex_i; + printf("Addr %02x val %02x\n", addr, val); + ao_mpu9250_spi_get(); + _ao_mpu9250_reg_write(addr, val); + ao_mpu9250_spi_put(); +} + +static void +ao_mpu9250_mag_read(void) +{ + uint8_t addr; + uint8_t val; + + ao_cmd_hex(); + if (ao_cmd_status != ao_cmd_success) + return; + addr = ao_cmd_lex_i; + ao_mpu9250_spi_get(); + val = _ao_mpu9250_mag_reg_read(addr); + ao_mpu9250_spi_put(); + printf("Addr %02x val %02x\n", addr, val); +} + +static void +ao_mpu9250_mag_write(void) +{ + uint8_t addr; + uint8_t val; + + ao_cmd_hex(); + if (ao_cmd_status != ao_cmd_success) + return; + addr = ao_cmd_lex_i; + ao_cmd_hex(); + if (ao_cmd_status != ao_cmd_success) + return; + val = ao_cmd_lex_i; + printf("Addr %02x val %02x\n", addr, val); + ao_mpu9250_spi_get(); + _ao_mpu9250_mag_reg_write(addr, val); + ao_mpu9250_spi_put(); +} + +#endif /* MPU9250_TEST */ + +static const struct ao_cmds ao_mpu9250_cmds[] = { + { ao_mpu9250_show, "I\0Show MPU9250 status" }, +#if MPU9250_TEST + { ao_mpu9250_read, "R <addr>\0Read MPU9250 register" }, + { ao_mpu9250_write, "W <addr> <val>\0Write MPU9250 register" }, + { ao_mpu9250_mag_read, "G <addr>\0Read MPU9250 Mag register" }, + { ao_mpu9250_mag_write, "P <addr> <val>\0Write MPU9250 Mag register" }, +#endif + { 0, NULL } +}; + +void +ao_mpu9250_init(void) +{ + ao_mpu9250_configured = 0; + + ao_add_task(&ao_mpu9250_task, ao_mpu9250, "mpu9250"); + +#if AO_MPU9250_SPI + ao_spi_init_cs(AO_MPU9250_SPI_CS_PORT, (1 << AO_MPU9250_SPI_CS_PIN)); + + /* Pretend to be the mpu9250 task. Grab the SPI bus right away and + * hold it for the task so that nothing else uses the SPI bus before + * we get the I2C mode disabled in the chip + */ + + ao_cur_task = &ao_mpu9250_task; + ao_spi_get(AO_MPU9250_SPI_BUS, AO_SPI_SPEED_1MHz); + ao_cur_task = NULL; +#endif + ao_cmd_register(&ao_mpu9250_cmds[0]); +} +#endif diff --git a/src/drivers/ao_mpu9250.h b/src/drivers/ao_mpu9250.h new file mode 100644 index 00000000..5e8e0885 --- /dev/null +++ b/src/drivers/ao_mpu9250.h @@ -0,0 +1,340 @@ +/* + * Copyright © 2012 Keith Packard <keithp@keithp.com> + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation; either version 2 of the License, or + * (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, but + * WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + * General Public License for more details. + * + * 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_MPU9250_H_ +#define _AO_MPU9250_H_ + +#ifndef M_PI +#define M_PI 3.1415926535897832384626433 +#endif + +#define MPU9250_ADDR_WRITE 0xd0 +#define MPU9250_ADDR_READ 0xd1 + +/* From Tridge */ +#define MPUREG_XG_OFFS_TC 0x00 +#define MPUREG_YG_OFFS_TC 0x01 +#define MPUREG_ZG_OFFS_TC 0x02 +#define MPUREG_X_FINE_GAIN 0x03 +#define MPUREG_Y_FINE_GAIN 0x04 +#define MPUREG_Z_FINE_GAIN 0x05 +#define MPUREG_XA_OFFS_H 0x06 // X axis accelerometer offset (high byte) +#define MPUREG_XA_OFFS_L 0x07 // X axis accelerometer offset (low byte) +#define MPUREG_YA_OFFS_H 0x08 // Y axis accelerometer offset (high byte) +#define MPUREG_YA_OFFS_L 0x09 // Y axis accelerometer offset (low byte) +#define MPUREG_ZA_OFFS_H 0x0A // Z axis accelerometer offset (high byte) +#define MPUREG_ZA_OFFS_L 0x0B // Z axis accelerometer offset (low byte) +#define MPUREG_PRODUCT_ID 0x0C // Product ID Register +#define MPUREG_XG_OFFS_USRH 0x13 // X axis gyro offset (high byte) +#define MPUREG_XG_OFFS_USRL 0x14 // X axis gyro offset (low byte) +#define MPUREG_YG_OFFS_USRH 0x15 // Y axis gyro offset (high byte) +#define MPUREG_YG_OFFS_USRL 0x16 // Y axis gyro offset (low byte) +#define MPUREG_ZG_OFFS_USRH 0x17 // Z axis gyro offset (high byte) +#define MPUREG_ZG_OFFS_USRL 0x18 // Z axis gyro offset (low byte) + +#define MPU9250_SMPRT_DIV 0x19 + +#define MPU9250_CONFIG 0x1a + +#define MPU9250_CONFIG_FIFO_MODE 6 +# define MPU9250_CONFIG_FIFO_MODE_REPLACE 0 +# define MPU9250_CONFIG_FIFO_MODE_DROP 1 + +#define MPU9250_CONFIG_EXT_SYNC_SET 3 +#define MPU9250_CONFIG_EXT_SYNC_SET_DISABLED 0 +#define MPU9250_CONFIG_EXT_SYNC_SET_TEMP_OUT_L 1 +#define MPU9250_CONFIG_EXT_SYNC_SET_GYRO_XOUT_L 2 +#define MPU9250_CONFIG_EXT_SYNC_SET_GYRO_YOUT_L 3 +#define MPU9250_CONFIG_EXT_SYNC_SET_GYRO_ZOUT_L 4 +#define MPU9250_CONFIG_EXT_SYNC_SET_ACCEL_XOUT_L 5 +#define MPU9250_CONFIG_EXT_SYNC_SET_ACCEL_YOUT_L 6 +#define MPU9250_CONFIG_EXT_SYNC_SET_ACCEL_ZOUT_L 7 +#define MPU9250_CONFIG_EXT_SYNC_SET_MASK 7 + +#define MPU9250_CONFIG_DLPF_CFG 0 +#define MPU9250_CONFIG_DLPF_CFG_250 0 +#define MPU9250_CONFIG_DLPF_CFG_184 1 +#define MPU9250_CONFIG_DLPF_CFG_92 2 +#define MPU9250_CONFIG_DLPF_CFG_41 3 +#define MPU9250_CONFIG_DLPF_CFG_20 4 +#define MPU9250_CONFIG_DLPF_CFG_10 5 +#define MPU9250_CONFIG_DLPF_CFG_5 6 +#define MPU9250_CONFIG_DLPF_CFG_MASK 7 + +#define MPU9250_GYRO_CONFIG 0x1b +# define MPU9250_GYRO_CONFIG_XG_ST 7 +# define MPU9250_GYRO_CONFIG_YG_ST 6 +# define MPU9250_GYRO_CONFIG_ZG_ST 5 +# define MPU9250_GYRO_CONFIG_FS_SEL 3 +# define MPU9250_GYRO_CONFIG_FS_SEL_250 0 +# define MPU9250_GYRO_CONFIG_FS_SEL_500 1 +# define MPU9250_GYRO_CONFIG_FS_SEL_1000 2 +# define MPU9250_GYRO_CONFIG_FS_SEL_2000 3 +# define MPU9250_GYRO_CONFIG_FS_SEL_MASK 3 +# define MPU9250_GYRO_CONFIG_FCHOICE_B 0 +# define MPU9250_GYRO_CONFIG_FCHOICE_B_8800 3 +# define MPU9250_GYRO_CONFIG_FCHOICE_B_3600 2 +# define MPU9250_GYRO_CONFIG_FCHOICE_B_LOW 0 + +#define MPU9250_ACCEL_CONFIG 0x1c +# define MPU9250_ACCEL_CONFIG_XA_ST 7 +# define MPU9250_ACCEL_CONFIG_YA_ST 6 +# define MPU9250_ACCEL_CONFIG_ZA_ST 5 +# define MPU9250_ACCEL_CONFIG_AFS_SEL 3 +# define MPU9250_ACCEL_CONFIG_AFS_SEL_2G 0 +# define MPU9250_ACCEL_CONFIG_AFS_SEL_4G 1 +# define MPU9250_ACCEL_CONFIG_AFS_SEL_8G 2 +# define MPU9250_ACCEL_CONFIG_AFS_SEL_16G 3 +# define MPU9250_ACCEL_CONFIG_AFS_SEL_MASK 3 + +#define MPU9250_MST_CTRL 0x24 +#define MPU9250_MST_CTRL_MULT_MST_EN 7 +#define MPU9250_MST_CTRL_WAIT_FOR_ES 6 +#define MPU9250_MST_CTRL_SLV_3_FIFO_EN 5 +#define MPU9250_MST_CTRL_I2C_MST_P_NSR 4 +#define MPU9250_MST_CTRL_I2C_MST_CLK 0 +#define MPU9250_MST_CTRL_I2C_MST_CLK_348 0 +#define MPU9250_MST_CTRL_I2C_MST_CLK_333 1 +#define MPU9250_MST_CTRL_I2C_MST_CLK_320 2 +#define MPU9250_MST_CTRL_I2C_MST_CLK_308 3 +#define MPU9250_MST_CTRL_I2C_MST_CLK_296 4 +#define MPU9250_MST_CTRL_I2C_MST_CLK_286 5 +#define MPU9250_MST_CTRL_I2C_MST_CLK_276 6 +#define MPU9250_MST_CTRL_I2C_MST_CLK_267 7 +#define MPU9250_MST_CTRL_I2C_MST_CLK_258 8 +#define MPU9250_MST_CTRL_I2C_MST_CLK_500 9 +#define MPU9250_MST_CTRL_I2C_MST_CLK_471 10 +#define MPU9250_MST_CTRL_I2C_MST_CLK_444 11 +#define MPU9250_MST_CTRL_I2C_MST_CLK_421 12 +#define MPU9250_MST_CTRL_I2C_MST_CLK_400 13 +#define MPU9250_MST_CTRL_I2C_MST_CLK_381 14 +#define MPU9250_MST_CTRL_I2C_MST_CLK_364 15 +#define MPU9250_MST_CTRL_I2C_MST_CLK_MASK 15 + +#define MPU9250_I2C_SLV0_ADDR 0x25 +#define MPU9250_I2C_SLV0_REG 0x26 +#define MPU9250_I2C_SLV0_CTRL 0x27 + +#define MPU9250_I2C_SLV0_CTRL_I2C_SLV0_EN 7 +#define MPU9250_I2C_SLV0_CTRL_I2C_SLV0_BYTE_SW 6 +#define MPU9250_I2C_SLV0_CTRL_I2C_SLV0_REG_DIS 5 +#define MPU9250_I2C_SLV0_CTRL_I2C_SLV0_GRP 4 +#define MPU9250_I2C_SLV0_CTRL_I2C_SLV0_LENG 0 + +#define MPU9250_I2C_SLV1_ADDR 0x28 +#define MPU9250_I2C_SLV1_REG 0x29 +#define MPU9250_I2C_SLV1_CTRL 0x2a + +#define MPU9250_I2C_SLV2_ADDR 0x2b +#define MPU9250_I2C_SLV2_REG 0x2c +#define MPU9250_I2C_SLV2_CTRL 0x2d + +#define MPU9250_I2C_SLV3_ADDR 0x2e +#define MPU9250_I2C_SLV3_REG 0x2f +#define MPU9250_I2C_SLV3_CTRL 0x30 + +#define MPU9250_I2C_SLV4_ADDR 0x31 +#define MPU9250_I2C_SLV4_REG 0x32 +#define MPU9250_I2C_SLV4_DO 0x33 +#define MPU9250_I2C_SLV4_CTRL 0x34 +#define MPU9250_I2C_SLV4_CTRL_I2C_SLV4_EN 7 +#define MPU9250_I2C_SLV4_CTRL_SLV4_DONE_INT_EN 6 +#define MPU9250_I2C_SLV4_CTRL_I2C_SLV4_REG_DIS 5 +#define MPU9250_I2C_SLV4_CTRL_I2C_MST_DLY 0 + +#define MPU9250_I2C_SLV4_DI 0x35 + +#define MPU9250_I2C_MST_STATUS 0x36 + +#define MPU9250_INT_PIN_CFG 0x37 + +#define MPU9250_INT_ENABLE 0x38 +#define MPU9250_INT_ENABLE_WOM_EN 6 +#define MPU9250_INT_ENABLE_FIFO_OFLOW_EN 4 +#define MPU9250_INT_ENABLE_FSYNC_INT_EN 3 +#define MPU9250_INT_ENABLE_RAW_RDY_EN 0 + +#define MPU9250_INT_STATUS 0x3a +#define MPU9250_INT_STATUS_WOM_INT 6 +#define MPU9250_INT_STATUS_FIFO_OFLOW_INT 4 +#define MPU9250_INT_STATUS_FSYNC_INT 3 +#define MPU9250_INT_STATUS_RAW_RDY_INT 0 + +#define MPU9250_ACCEL_XOUT_H 0x3b +#define MPU9250_ACCEL_XOUT_L 0x3c +#define MPU9250_ACCEL_YOUT_H 0x3d +#define MPU9250_ACCEL_YOUT_L 0x3e +#define MPU9250_ACCEL_ZOUT_H 0x3f +#define MPU9250_ACCEL_ZOUT_L 0x40 +#define MPU9250_TEMP_H 0x41 +#define MPU9250_TEMP_L 0x42 +#define MPU9250_GYRO_XOUT_H 0x43 +#define MPU9250_GYRO_XOUT_L 0x44 +#define MPU9250_GYRO_YOUT_H 0x45 +#define MPU9250_GYRO_YOUT_L 0x46 +#define MPU9250_GYRO_ZOUT_H 0x47 +#define MPU9250_GYRO_ZOUT_L 0x48 + +#define MPU9250_I2C_MST_DELAY_CTRL 0x67 + +#define MPU9250_I2C_MST_DELAY_CTRL_DELAY_ES_SHADOW 7 +#define MPU9250_I2C_MST_DELAY_CTRL_I2C_SLV4_DLY_EN 4 +#define MPU9250_I2C_MST_DELAY_CTRL_I2C_SLV3_DLY_EN 3 +#define MPU9250_I2C_MST_DELAY_CTRL_I2C_SLV2_DLY_EN 2 +#define MPU9250_I2C_MST_DELAY_CTRL_I2C_SLV1_DLY_EN 1 +#define MPU9250_I2C_MST_DELAY_CTRL_I2C_SLV0_DLY_EN 0 + +#define MPU9250_SIGNAL_PATH_RESET 0x68 +#define MPU9250_SIGNAL_PATH_RESET_GYRO_RESET 2 +#define MPU9250_SIGNAL_PATH_RESET_ACCEL_RESET 1 +#define MPU9250_SIGNAL_PATH_RESET_TEMP_RESET 0 + +#define MPU9250_USER_CTRL 0x6a +#define MPU9250_USER_CTRL_FIFO_EN 6 +#define MPU9250_USER_CTRL_I2C_MST_EN 5 +#define MPU9250_USER_CTRL_I2C_IF_DIS 4 +#define MPU9250_USER_CTRL_FIFO_RESET 2 +#define MPU9250_USER_CTRL_I2C_MST_RESET 1 +#define MPU9250_USER_CTRL_SIG_COND_RESET 0 + +#define MPU9250_PWR_MGMT_1 0x6b +#define MPU9250_PWR_MGMT_1_DEVICE_RESET 7 +#define MPU9250_PWR_MGMT_1_SLEEP 6 +#define MPU9250_PWR_MGMT_1_CYCLE 5 +#define MPU9250_PWR_MGMT_1_TEMP_DIS 3 +#define MPU9250_PWR_MGMT_1_CLKSEL 0 +#define MPU9250_PWR_MGMT_1_CLKSEL_INTERNAL 0 +#define MPU9250_PWR_MGMT_1_CLKSEL_PLL_X_AXIS 1 +#define MPU9250_PWR_MGMT_1_CLKSEL_PLL_Y_AXIS 2 +#define MPU9250_PWR_MGMT_1_CLKSEL_PLL_Z_AXIS 3 +#define MPU9250_PWR_MGMT_1_CLKSEL_PLL_EXTERNAL_32K 4 +#define MPU9250_PWR_MGMT_1_CLKSEL_PLL_EXTERNAL_19M 5 +#define MPU9250_PWR_MGMT_1_CLKSEL_STOP 7 +#define MPU9250_PWR_MGMT_1_CLKSEL_MASK 7 + +#define MPU9250_PWR_MGMT_2 0x6c + +#define MPU9250_WHO_AM_I 0x75 +#define MPU9250_I_AM_9250 0x71 + +/* AK8963 mag sensor on the I2C bus */ + +#define MPU9250_MAG_ADDR 0x0c + +#define MPU9250_MAG_WIA 0x00 +#define MPU9250_MAG_WIA_VALUE 0x48 + +#define MPU9250_MAG_INFO 0x01 +#define MPU9250_MAG_ST1 0x02 +#define MPU9250_MAG_ST1_DOR 1 +#define MPU9250_MAG_ST1_DRDY 0 + +#define MPU9250_MAG_HXL 0x03 +#define MPU9250_MAG_HXH 0x04 +#define MPU9250_MAG_HYL 0x05 +#define MPU9250_MAG_HYH 0x06 +#define MPU9250_MAG_HZL 0x07 +#define MPU9250_MAG_HZH 0x08 +#define MPU9250_MAG_ST2 0x09 +#define MPU9250_MAG_ST2_BITM 4 +#define MPU9250_MAG_ST2_HOFL 3 + +#define MPU9250_MAG_CNTL1 0x0a +#define MPU9250_MAG_CNTL1_MODE 0 +#define MPU9250_MAG_CNTL1_MODE_POWER_DOWN 0x0 +#define MPU9250_MAG_CNTL1_MODE_SINGLE 0x1 +#define MPU9250_MAG_CNTL1_MODE_CONT_1 0x2 /* 8Hz */ +#define MPU9250_MAG_CNTL1_MODE_CONT_2 0x6 /* 100Hz */ +#define MPU9250_MAG_CNTL1_MODE_EXTERNAL 0x4 +#define MPU9250_MAG_CNTL1_MODE_SELF_TEST 0x8 +#define MPU9250_MAG_CNTL1_MODE_FUSE_ACCESS 0xf + +#define MPU9250_MAG_CNTL1_BIT 4 +#define MPU9250_MAG_CNTL1_BIT_14 0 +#define MPU9250_MAG_CNTL1_BIT_16 1 + +#define MPU9250_MAG_CNTL2 0x0b +#define MPU9250_MAG_CNTL2_SRST 0 + +#define MPU9250_MAG_ASTC 0x0c +#define MPU9250_MAG_ASTC_SELF 6 + +#define MPU9250_MAG_TS1 0x0d +#define MPU9250_MAG_TS2 0x0e +#define MPU9250_MAG_I2CDIS 0x0f +#define MPU9250_MAG_I2CDIS_VALUE 0x1d + +#define MPU9250_MAG_ASAX 0x10 +#define MPU9250_MAG_ASAY 0x11 +#define MPU9250_MAG_ASAZ 0x12 + +/* Self test acceleration is approximately 0.5g */ +#define MPU9250_ST_ACCEL(full_scale) (32767 / ((full_scale) * 2)) + +/* Self test gyro is approximately 50°/s */ +#define MPU9250_ST_GYRO(full_scale) ((int16_t) (((int32_t) 32767 * (int32_t) 50) / (full_scale))) + +#define MPU9250_GYRO_FULLSCALE ((float) 2000 * M_PI/180.0) + +static inline float +ao_mpu9250_gyro(float sensor) { + return sensor * ((float) (MPU9250_GYRO_FULLSCALE / 32767.0)); +} + +#define MPU9250_ACCEL_FULLSCALE 16 + +static inline float +ao_mpu9250_accel(int16_t sensor) { + return (float) sensor * ((float) (MPU9250_ACCEL_FULLSCALE * GRAVITY / 32767.0)); +} + +struct ao_mpu9250_sample { + int16_t accel_x; + int16_t accel_y; + int16_t accel_z; + int16_t temp; + int16_t gyro_x; + int16_t gyro_y; + int16_t gyro_z; + int16_t mag_x; + int16_t mag_y; + int16_t mag_z; +}; + +extern struct ao_mpu9250_sample ao_mpu9250_current; + +void +ao_mpu9250_init(void); + +/* Product ID Description for MPU9250 + * high 4 bits low 4 bits + * Product Name Product Revision + */ +#define MPU9250ES_REV_C4 0x14 /* 0001 0100 */ +#define MPU9250ES_REV_C5 0x15 /* 0001 0101 */ +#define MPU9250ES_REV_D6 0x16 /* 0001 0110 */ +#define MPU9250ES_REV_D7 0x17 /* 0001 0111 */ +#define MPU9250ES_REV_D8 0x18 /* 0001 1000 */ +#define MPU9250_REV_C4 0x54 /* 0101 0100 */ +#define MPU9250_REV_C5 0x55 /* 0101 0101 */ +#define MPU9250_REV_D6 0x56 /* 0101 0110 */ +#define MPU9250_REV_D7 0x57 /* 0101 0111 */ +#define MPU9250_REV_D8 0x58 /* 0101 1000 */ +#define MPU9250_REV_D9 0x59 /* 0101 1001 */ + +#endif /* _AO_MPU9250_H_ */ diff --git a/src/easymega-v1.0/ao_pins.h b/src/easymega-v1.0/ao_pins.h index 42a8b09c..b8016478 100644 --- a/src/easymega-v1.0/ao_pins.h +++ b/src/easymega-v1.0/ao_pins.h @@ -69,6 +69,8 @@ #define AO_CONFIG_MAX_SIZE 1024 #define LOG_ERASE_MARK 0x55 #define LOG_MAX_ERASE 128 +#define AO_LOG_FORMAT AO_LOG_FORMAT_TELEMEGA + #define HAS_EEPROM 1 #define USE_INTERNAL_FLASH 0 #define USE_EEPROM_CONFIG 1 @@ -84,7 +86,7 @@ #define HAS_SPI_1 1 #define SPI_1_PA5_PA6_PA7 1 /* Barometer */ #define SPI_1_PB3_PB4_PB5 1 /* Accelerometer, Gyro */ -#define SPI_1_PE13_PE14_PE15 0 +#define SPI_1_PE13_PE14_PE15 0 #define SPI_1_OSPEEDR STM_OSPEEDR_10MHz #define HAS_SPI_2 1 diff --git a/src/kernel/ao.h b/src/kernel/ao.h index e56fbb2e..139050cf 100644 --- a/src/kernel/ao.h +++ b/src/kernel/ao.h @@ -78,6 +78,7 @@ typedef AO_PORT_TYPE ao_port_t; #define AO_PANIC_SELF_TEST_CC1120 0x40 | 1 /* Self test failure */ #define AO_PANIC_SELF_TEST_HMC5883 0x40 | 2 /* Self test failure */ #define AO_PANIC_SELF_TEST_MPU6000 0x40 | 3 /* Self test failure */ +#define AO_PANIC_SELF_TEST_MPU9250 0x40 | 3 /* Self test failure */ #define AO_PANIC_SELF_TEST_MS5607 0x40 | 4 /* Self test failure */ /* Stop the operating system, beeping and blinking the reason */ diff --git a/src/kernel/ao_cmd.c b/src/kernel/ao_cmd.c index 881f3500..c1e9cef2 100644 --- a/src/kernel/ao_cmd.c +++ b/src/kernel/ao_cmd.c @@ -304,7 +304,7 @@ version(void) , ao_flight_number #endif #if HAS_LOG - , ao_log_format + , AO_LOG_FORMAT #if !DISABLE_LOG_SPACE , (unsigned long) ao_storage_log_max #endif diff --git a/src/kernel/ao_data.h b/src/kernel/ao_data.h index d62852ef..88d0e916 100644 --- a/src/kernel/ao_data.h +++ b/src/kernel/ao_data.h @@ -41,6 +41,13 @@ #define AO_DATA_MPU6000 0 #endif +#if HAS_MPU9250 +#include <ao_mpu9250.h> +#define AO_DATA_MPU9250 (1 << 2) +#else +#define AO_DATA_MPU9250 0 +#endif + #if HAS_HMC5883 #include <ao_hmc5883.h> #define AO_DATA_HMC5883 (1 << 3) @@ -57,7 +64,7 @@ #ifdef AO_DATA_RING -#define AO_DATA_ALL (AO_DATA_ADC|AO_DATA_MS5607|AO_DATA_MPU6000|AO_DATA_HMC5883|AO_DATA_MMA655X) +#define AO_DATA_ALL (AO_DATA_ADC|AO_DATA_MS5607|AO_DATA_MPU6000|AO_DATA_HMC5883|AO_DATA_MMA655X|AO_DATA_MPU9250) struct ao_data { uint16_t tick; @@ -74,6 +81,9 @@ struct ao_data { int16_t z_accel; #endif #endif +#if HAS_MPU9250 + struct ao_mpu9250_sample mpu9250; +#endif #if HAS_HMC5883 struct ao_hmc5883_sample hmc5883; #endif @@ -320,6 +330,47 @@ typedef int16_t angle_t; /* in degrees */ #define ao_data_pitch(packet) ((packet)->mpu6000.gyro_x) #define ao_data_yaw(packet) ((packet)->mpu6000.gyro_z) +static inline float ao_convert_gyro(float sensor) +{ + return ao_mpu6000_gyro(sensor); +} + +static inline float ao_convert_accel(int16_t sensor) +{ + return ao_mpu6000_accel(sensor); +} + +#endif + +#if !HAS_GYRO && HAS_MPU9250 + +#define HAS_GYRO 1 + +typedef int16_t gyro_t; /* in raw sample units */ +typedef int16_t angle_t; /* in degrees */ + +/* Y axis is aligned with the direction of motion (along) */ +/* X axis is aligned in the other board axis (across) */ +/* Z axis is aligned perpendicular to the board (through) */ + +#define ao_data_along(packet) ((packet)->mpu9250.accel_y) +#define ao_data_across(packet) ((packet)->mpu9250.accel_x) +#define ao_data_through(packet) ((packet)->mpu9250.accel_z) + +#define ao_data_roll(packet) ((packet)->mpu9250.gyro_y) +#define ao_data_pitch(packet) ((packet)->mpu9250.gyro_x) +#define ao_data_yaw(packet) ((packet)->mpu9250.gyro_z) + +static inline float ao_convert_gyro(float sensor) +{ + return ao_mpu9250_gyro(sensor); +} + +static inline float ao_convert_accel(int16_t sensor) +{ + return ao_mpu9250_accel(sensor); +} + #endif #if !HAS_MAG && HAS_HMC5883 @@ -334,4 +385,21 @@ typedef int16_t ao_mag_t; /* in raw sample units */ #endif +#if !HAS_MAG && HAS_MPU9250 + +#define HAS_MAG 1 + +typedef int16_t ao_mag_t; /* in raw sample units */ + +/* Note that this order is different from the accel and gyro. For some + * reason, the mag sensor axes aren't the same as the other two + * sensors. Also, the Z axis is flipped in sign. + */ + +#define ao_data_mag_along(packet) ((packet)->mpu9250.mag_x) +#define ao_data_mag_across(packet) ((packet)->mpu9250.mag_y) +#define ao_data_mag_through(packet) ((packet)->mpu9250.mag_z) + +#endif + #endif /* _AO_DATA_H_ */ diff --git a/src/kernel/ao_flight.c b/src/kernel/ao_flight.c index f06125cd..cb02c454 100644 --- a/src/kernel/ao_flight.c +++ b/src/kernel/ao_flight.c @@ -21,7 +21,7 @@ #include <ao_log.h> #endif -#if HAS_MPU6000 +#if HAS_MPU6000 || HAS_MPU9250 #include <ao_quaternion.h> #endif diff --git a/src/kernel/ao_gps_report.c b/src/kernel/ao_gps_report.c index 39688fea..75c2f367 100644 --- a/src/kernel/ao_gps_report.c +++ b/src/kernel/ao_gps_report.c @@ -45,13 +45,13 @@ ao_gps_report(void) gps_log.u.gps_time.minute = gps_data.minute; gps_log.u.gps_time.second = gps_data.second; gps_log.u.gps_time.flags = gps_data.flags; - ao_log_data(&gps_log); + ao_log_write(&gps_log); gps_log.type = AO_LOG_GPS_LAT; gps_log.u.gps_latitude = gps_data.latitude; - ao_log_data(&gps_log); + ao_log_write(&gps_log); gps_log.type = AO_LOG_GPS_LON; gps_log.u.gps_longitude = gps_data.longitude; - ao_log_data(&gps_log); + ao_log_write(&gps_log); gps_log.type = AO_LOG_GPS_ALT; gps_log.u.gps_altitude.altitude_low = gps_data.altitude_low; #if HAS_WIDE_GPS @@ -59,14 +59,14 @@ ao_gps_report(void) #else gps_log.u.gps_altitude.altitude_high = 0xffff; #endif - ao_log_data(&gps_log); + ao_log_write(&gps_log); if (!date_reported && (gps_data.flags & AO_GPS_DATE_VALID)) { gps_log.type = AO_LOG_GPS_DATE; gps_log.u.gps_date.year = gps_data.year; gps_log.u.gps_date.month = gps_data.month; gps_log.u.gps_date.day = gps_data.day; gps_log.u.gps_date.extra = 0; - date_reported = ao_log_data(&gps_log); + date_reported = ao_log_write(&gps_log); } } if (new & AO_GPS_NEW_TRACKING) { @@ -78,7 +78,7 @@ ao_gps_report(void) if ((gps_log.u.gps_sat.svid = gps_tracking_data.sats[c].svid)) { gps_log.u.gps_sat.c_n = gps_tracking_data.sats[c].c_n_1; - ao_log_data(&gps_log); + ao_log_write(&gps_log); } } } diff --git a/src/kernel/ao_gps_report_mega.c b/src/kernel/ao_gps_report_mega.c index 8a298655..85614b85 100644 --- a/src/kernel/ao_gps_report_mega.c +++ b/src/kernel/ao_gps_report_mega.c @@ -105,7 +105,7 @@ ao_gps_report_mega(void) gps_log.u.gps.hdop = gps_data.hdop; gps_log.u.gps.vdop = gps_data.vdop; gps_log.u.gps.mode = gps_data.mode; - ao_log_mega(&gps_log); + ao_log_write(&gps_log); } if ((new & AO_GPS_NEW_TRACKING) && (n = gps_tracking_data.channels) != 0) { gps_log.tick = ao_gps_tick; @@ -120,7 +120,7 @@ ao_gps_report_mega(void) break; } gps_log.u.gps_sat.channels = i; - ao_log_mega(&gps_log); + ao_log_write(&gps_log); } } } diff --git a/src/kernel/ao_gps_report_metrum.c b/src/kernel/ao_gps_report_metrum.c index 508f1519..523fb17f 100644 --- a/src/kernel/ao_gps_report_metrum.c +++ b/src/kernel/ao_gps_report_metrum.c @@ -47,7 +47,7 @@ ao_gps_report_metrum(void) gps_log.u.gps.longitude = gps_data.longitude; gps_log.u.gps.altitude_low = gps_data.altitude_low; gps_log.u.gps.altitude_high = gps_data.altitude_high; - ao_log_metrum(&gps_log); + ao_log_write(&gps_log); gps_log.type = AO_LOG_GPS_TIME; gps_log.u.gps_time.hour = gps_data.hour; @@ -58,7 +58,7 @@ ao_gps_report_metrum(void) gps_log.u.gps_time.month = gps_data.month; gps_log.u.gps_time.day = gps_data.day; gps_log.u.gps_time.pdop = gps_data.pdop; - ao_log_metrum(&gps_log); + ao_log_write(&gps_log); } if ((new & AO_GPS_NEW_TRACKING) && (n = gps_tracking_data.channels)) { @@ -71,7 +71,7 @@ ao_gps_report_metrum(void) if (i == 4) { gps_log.u.gps_sat.channels = i; gps_log.u.gps_sat.more = 1; - ao_log_metrum(&gps_log); + ao_log_write(&gps_log); i = 0; } gps_log.u.gps_sat.sats[i].svid = svid; @@ -82,7 +82,7 @@ ao_gps_report_metrum(void) if (i) { gps_log.u.gps_sat.channels = i; gps_log.u.gps_sat.more = 0; - ao_log_metrum(&gps_log); + ao_log_write(&gps_log); } } } diff --git a/src/kernel/ao_host.h b/src/kernel/ao_host.h index a7fa5ec2..50583f52 100644 --- a/src/kernel/ao_host.h +++ b/src/kernel/ao_host.h @@ -111,7 +111,7 @@ ao_dump_state(void *wchan); void ao_sleep(void *wchan); -const char const * const ao_state_names[] = { +const char * const ao_state_names[] = { "startup", "idle", "pad", "boost", "fast", "coast", "drogue", "main", "landed", "invalid" }; diff --git a/src/kernel/ao_log.c b/src/kernel/ao_log.c index 0589b4b0..f70c7232 100644 --- a/src/kernel/ao_log.c +++ b/src/kernel/ao_log.c @@ -29,7 +29,7 @@ __pdata uint32_t ao_log_end_pos; __pdata uint32_t ao_log_start_pos; __xdata uint8_t ao_log_running; __pdata enum ao_flight_state ao_log_state; -__xdata uint16_t ao_flight_number; +__xdata int16_t ao_flight_number; void ao_log_flush(void) @@ -111,6 +111,85 @@ ao_log_erase_mark(void) ao_config_put(); } +#ifndef AO_LOG_UNCOMMON +/* + * Common logging functions which depend on the type of the log data + * structure. + */ + +__xdata ao_log_type log; + +static uint8_t +ao_log_csum(__xdata uint8_t *b) __reentrant +{ + uint8_t sum = 0x5a; + uint8_t i; + + for (i = 0; i < sizeof (ao_log_type); i++) + sum += *b++; + return -sum; +} + +uint8_t +ao_log_write(__xdata ao_log_type *log) __reentrant +{ + uint8_t wrote = 0; + /* set checksum */ + log->csum = 0; + log->csum = ao_log_csum((__xdata uint8_t *) log); + ao_mutex_get(&ao_log_mutex); { + if (ao_log_current_pos >= ao_log_end_pos && ao_log_running) + ao_log_stop(); + if (ao_log_running) { + wrote = 1; + ao_storage_write(ao_log_current_pos, + log, + sizeof (ao_log_type)); + ao_log_current_pos += sizeof (ao_log_type); + } + } ao_mutex_put(&ao_log_mutex); + return wrote; +} + +uint8_t +ao_log_check_data(void) +{ + if (ao_log_csum((uint8_t *) &log) != 0) + return 0; + return 1; +} + +uint8_t +ao_log_check_clear(void) +{ + uint8_t *b = (uint8_t *) &log; + uint8_t i; + + for (i = 0; i < sizeof (ao_log_type); i++) { + if (*b++ != 0xff) + return 0; + } + return 1; +} + +int16_t +ao_log_flight(uint8_t slot) +{ + if (!ao_storage_read(ao_log_pos(slot), + &log, + sizeof (ao_log_type))) + return -(int16_t) (slot + 1); + + if (ao_log_check_clear()) + return 0; + + if (!ao_log_check_data() || log.type != AO_LOG_FLIGHT) + return -(int16_t) (slot + 1); + + return log.u.flight.flight; +} +#endif + static uint8_t ao_log_slots() { @@ -123,21 +202,21 @@ ao_log_pos(uint8_t slot) return ((slot) * ao_config.flight_log_max); } -static uint16_t +static int16_t ao_log_max_flight(void) { uint8_t log_slot; uint8_t log_slots; - uint16_t log_flight; - uint16_t max_flight = 0; + int16_t log_flight; + int16_t max_flight = 0; /* Scan the log space looking for the biggest flight number */ log_slots = ao_log_slots(); for (log_slot = 0; log_slot < log_slots; log_slot++) { log_flight = ao_log_flight(log_slot); - if (!log_flight) + if (log_flight <= 0) continue; - if (max_flight == 0 || (int16_t) (log_flight - max_flight) > 0) + if (max_flight == 0 || log_flight > max_flight) max_flight = log_flight; } return max_flight; @@ -228,24 +307,24 @@ ao_log_scan(void) __reentrant if (ao_flight_number) { uint32_t full = ao_log_current_pos; - uint32_t empty = ao_log_end_pos - ao_log_size; + uint32_t empty = ao_log_end_pos - AO_LOG_SIZE; /* If there's already a flight started, then find the * end of it */ for (;;) { ao_log_current_pos = (full + empty) >> 1; - ao_log_current_pos -= ao_log_current_pos % ao_log_size; + ao_log_current_pos -= ao_log_current_pos % AO_LOG_SIZE; if (ao_log_current_pos == full) { - if (ao_log_check(ao_log_current_pos)) - ao_log_current_pos += ao_log_size; + if (ao_log_check(ao_log_current_pos) != AO_LOG_EMPTY) + ao_log_current_pos += AO_LOG_SIZE; break; } if (ao_log_current_pos == empty) break; - if (ao_log_check(ao_log_current_pos)) { + if (ao_log_check(ao_log_current_pos) != AO_LOG_EMPTY) { full = ao_log_current_pos; } else { empty = ao_log_current_pos; @@ -259,10 +338,11 @@ ao_log_scan(void) __reentrant ao_wakeup(&ao_flight_number); return ret; #else - - if (ao_flight_number) - if (++ao_flight_number == 0) + if (ao_flight_number) { + ++ao_flight_number; + if (ao_flight_number <= 0) ao_flight_number = 1; + } ao_log_find_max_erase_flight(); @@ -330,7 +410,7 @@ ao_log_list(void) __reentrant { uint8_t slot; uint8_t slots; - uint16_t flight; + int16_t flight; slots = ao_log_slots(); for (slot = 0; slot < slots; slot++) @@ -350,18 +430,25 @@ ao_log_delete(void) __reentrant { uint8_t slot; uint8_t slots; + int16_t cmd_flight = 1; + ao_cmd_white(); + if (ao_cmd_lex_c == '-') { + cmd_flight = -1; + ao_cmd_lex(); + } ao_cmd_decimal(); if (ao_cmd_status != ao_cmd_success) return; + cmd_flight *= (int16_t) ao_cmd_lex_i; slots = ao_log_slots(); /* Look for the flight log matching the requested flight */ - if (ao_cmd_lex_i) { + if (cmd_flight) { for (slot = 0; slot < slots; slot++) { - if (ao_log_flight(slot) == ao_cmd_lex_i) { + if (ao_log_flight(slot) == cmd_flight) { #if HAS_TRACKER - ao_tracker_erase_start(ao_cmd_lex_i); + ao_tracker_erase_start(cmd_flight); #endif ao_log_erase(slot); #if HAS_TRACKER @@ -372,7 +459,7 @@ ao_log_delete(void) __reentrant } } } - printf("No such flight: %d\n", ao_cmd_lex_i); + printf("No such flight: %d\n", cmd_flight); } __code struct ao_cmds ao_log_cmds[] = { diff --git a/src/kernel/ao_log.h b/src/kernel/ao_log.h index aca669db..5f04ef9a 100644 --- a/src/kernel/ao_log.h +++ b/src/kernel/ao_log.h @@ -29,7 +29,7 @@ * the log. Tasks may wait for this to be initialized * by sleeping on this variable. */ -extern __xdata uint16_t ao_flight_number; +extern __xdata int16_t ao_flight_number; extern __xdata uint8_t ao_log_mutex; extern __pdata uint32_t ao_log_current_pos; extern __pdata uint32_t ao_log_end_pos; @@ -54,17 +54,28 @@ extern __pdata enum ao_flight_state ao_log_state; #define AO_LOG_FORMAT_TELEMINI3 12 /* 16-byte MS5607 baro only, 3.3V supply, stm32f042 SoC */ #define AO_LOG_FORMAT_TELEFIRETWO 13 /* 32-byte test stand data */ #define AO_LOG_FORMAT_EASYMINI2 14 /* 16-byte MS5607 baro only, 3.3V supply, stm32f042 SoC */ +#define AO_LOG_FORMAT_TELEMEGA_3 15 /* 32 byte typed telemega records with 32 bit gyro cal and mpu9250 */ #define AO_LOG_FORMAT_NONE 127 /* No log at all */ -extern __code uint8_t ao_log_format; -extern __code uint8_t ao_log_size; +/* Return the flight number from the given log slot, 0 if none, -slot on failure */ -/* Return the flight number from the given log slot, 0 if none */ -uint16_t +int16_t ao_log_flight(uint8_t slot); -/* Check if there is valid log data at the specified location */ +/* Checksum the loaded log record */ +uint8_t +ao_log_check_data(void); + +/* Check to see if the loaded log record is empty */ uint8_t +ao_log_check_clear(void); + +/* Check if there is valid log data at the specified location */ +#define AO_LOG_VALID 1 +#define AO_LOG_EMPTY 0 +#define AO_LOG_INVALID -1 + +int8_t ao_log_check(uint32_t pos); /* Flush the log */ @@ -463,21 +474,48 @@ struct ao_log_gps { } u; }; -/* Write a record to the eeprom log */ -uint8_t -ao_log_data(__xdata struct ao_log_record *log) __reentrant; +#if AO_LOG_FORMAT == AO_LOG_FOMAT_TELEMEGA_OLD || AO_LOG_FORMAT == AO_LOG_FORMAT_TELEMEGA || AO_LOG_FORMAT == AO_LOG_FORMAT_TELEMEGA_3 +typedef struct ao_log_mega ao_log_type; +#endif -uint8_t -ao_log_mega(__xdata struct ao_log_mega *log) __reentrant; +#if AO_LOG_FORMAT == AO_LOG_FORMAT_TELEMETRUM +typedef struct ao_log_metrum ao_log_type; +#endif -uint8_t -ao_log_metrum(__xdata struct ao_log_metrum *log) __reentrant; +#if AO_LOG_FORMAT == AO_LOG_FORMAT_EASYMINI1 || AO_LOG_FORMAT == AO_LOG_FORMAT_EASYMINI2 || AO_LOG_FORMAT == AO_LOG_FORMAT_TELEMINI2 || AO_LOG_FORMAT == AO_LOG_FORMAT_TELEMINI3 +typedef struct ao_log_mini ao_log_type; +#endif -uint8_t -ao_log_mini(__xdata struct ao_log_mini *log) __reentrant; +#if AO_LOG_FORMAT == AO_LOG_FORMAT_TELEGPS +typedef struct ao_log_gps ao_log_type; +#endif + +#if AO_LOG_FORMAT == AO_LOG_FORMAT_FULL +typedef struct ao_log_record ao_log_type; +#endif + +#if AO_LOG_FORMAT == AO_LOG_FORMAT_TINY +#define AO_LOG_UNCOMMON 1 +#endif + +#if AO_LOG_FORMAT == AO_LOG_FORMAT_TELEMETRY +#define AO_LOG_UNCOMMON 1 +#endif + +#if AO_LOG_FORMAT == AO_LOG_FORMAT_TELESCIENCE +#define AO_LOG_UNCOMMON 1 +#endif + +#ifndef AO_LOG_UNCOMMON +extern __xdata ao_log_type log; + +#define AO_LOG_SIZE sizeof(ao_log_type) + +/* Write a record to the eeprom log */ uint8_t -ao_log_gps(__xdata struct ao_log_gps *log) __reentrant; +ao_log_write(__xdata ao_log_type *log) __reentrant; +#endif void ao_log_flush(void); diff --git a/src/kernel/ao_log_big.c b/src/kernel/ao_log_big.c index e32abd1a..28a893c7 100644 --- a/src/kernel/ao_log_big.c +++ b/src/kernel/ao_log_big.c @@ -18,50 +18,6 @@ #include "ao.h" -static __xdata struct ao_log_record log; - -__code uint8_t ao_log_format = AO_LOG_FORMAT_FULL; - -static uint8_t -ao_log_csum(__xdata uint8_t *b) __reentrant -{ - uint8_t sum = 0x5a; - uint8_t i; - - for (i = 0; i < sizeof (struct ao_log_record); i++) - sum += *b++; - return -sum; -} - -uint8_t -ao_log_data(__xdata struct ao_log_record *log) __reentrant -{ - uint8_t wrote = 0; - /* set checksum */ - log->csum = 0; - log->csum = ao_log_csum((__xdata uint8_t *) log); - ao_mutex_get(&ao_log_mutex); { - if (ao_log_current_pos >= ao_log_end_pos && ao_log_running) - ao_log_stop(); - if (ao_log_running) { - wrote = 1; - ao_storage_write(ao_log_current_pos, - log, - sizeof (struct ao_log_record)); - ao_log_current_pos += sizeof (struct ao_log_record); - } - } ao_mutex_put(&ao_log_mutex); - return wrote; -} - -static uint8_t -ao_log_dump_check_data(void) -{ - if (ao_log_csum((uint8_t *) &log) != 0) - return 0; - return 1; -} - static __data uint8_t ao_log_data_pos; /* a hack to make sure that ao_log_records fill the eeprom block in even units */ @@ -91,7 +47,7 @@ ao_log(void) log.u.flight.ground_accel = ao_ground_accel; #endif log.u.flight.flight = ao_flight_number; - ao_log_data(&log); + ao_log_write(&log); /* Write the whole contents of the ring to the log * when starting up. @@ -107,7 +63,7 @@ ao_log(void) log.type = AO_LOG_SENSOR; log.u.sensor.accel = ao_data_ring[ao_log_data_pos].adc.accel; log.u.sensor.pres = ao_data_ring[ao_log_data_pos].adc.pres; - ao_log_data(&log); + ao_log_write(&log); if (ao_log_state <= ao_flight_coast) next_sensor = log.tick + AO_SENSOR_INTERVAL_ASCENT; else @@ -117,11 +73,11 @@ ao_log(void) log.type = AO_LOG_TEMP_VOLT; log.u.temp_volt.temp = ao_data_ring[ao_log_data_pos].adc.temp; log.u.temp_volt.v_batt = ao_data_ring[ao_log_data_pos].adc.v_batt; - ao_log_data(&log); + ao_log_write(&log); log.type = AO_LOG_DEPLOY; log.u.deploy.drogue = ao_data_ring[ao_log_data_pos].adc.sense_d; log.u.deploy.main = ao_data_ring[ao_log_data_pos].adc.sense_m; - ao_log_data(&log); + ao_log_write(&log); next_other = log.tick + AO_OTHER_INTERVAL; } ao_log_data_pos = ao_data_ring_next(ao_log_data_pos); @@ -133,7 +89,7 @@ ao_log(void) log.tick = ao_sample_tick; log.u.state.state = ao_log_state; log.u.state.reason = 0; - ao_log_data(&log); + ao_log_write(&log); if (ao_log_state == ao_flight_landed) ao_log_stop(); @@ -147,16 +103,3 @@ ao_log(void) ao_sleep(&ao_log_running); } } - -uint16_t -ao_log_flight(uint8_t slot) -{ - if (!ao_storage_read(ao_log_pos(slot), - &log, - sizeof (struct ao_log_record))) - return 0; - - if (ao_log_dump_check_data() && log.type == AO_LOG_FLIGHT) - return log.u.flight.flight; - return 0; -} diff --git a/src/kernel/ao_log_gps.c b/src/kernel/ao_log_gps.c index 02551169..a55d93f1 100644 --- a/src/kernel/ao_log_gps.c +++ b/src/kernel/ao_log_gps.c @@ -24,50 +24,13 @@ #include <ao_distance.h> #include <ao_tracker.h> -static __xdata struct ao_log_gps log; - -__code uint8_t ao_log_format = AO_LOG_FORMAT_TELEGPS; -__code uint8_t ao_log_size = sizeof (struct ao_log_gps); - -static uint8_t -ao_log_csum(__xdata uint8_t *b) __reentrant -{ - uint8_t sum = 0x5a; - uint8_t i; - - for (i = 0; i < sizeof (struct ao_log_gps); i++) - sum += *b++; - return -sum; -} - -uint8_t -ao_log_gps(__xdata struct ao_log_gps *log) __reentrant -{ - uint8_t wrote = 0; - /* set checksum */ - log->csum = 0; - log->csum = ao_log_csum((__xdata uint8_t *) log); - ao_mutex_get(&ao_log_mutex); { - if (ao_log_current_pos >= ao_log_end_pos && ao_log_running) - ao_log_stop(); - if (ao_log_running) { - wrote = 1; - ao_storage_write(ao_log_current_pos, - log, - sizeof (struct ao_log_gps)); - ao_log_current_pos += sizeof (struct ao_log_gps); - } - } ao_mutex_put(&ao_log_mutex); - return wrote; -} - void ao_log_gps_flight(void) { log.type = AO_LOG_FLIGHT; log.tick = ao_time(); log.u.flight.flight = ao_flight_number; - ao_log_gps(&log); + ao_log_write(&log); } void @@ -94,7 +57,7 @@ ao_log_gps_data(uint16_t tick, struct ao_telemetry_location *gps_data) log.u.gps.hdop = gps_data->hdop; log.u.gps.vdop = gps_data->vdop; log.u.gps.mode = gps_data->mode; - ao_log_gps(&log); + ao_log_write(&log); } void @@ -115,39 +78,21 @@ ao_log_gps_tracking(uint16_t tick, struct ao_telemetry_satellite *gps_tracking_d break; } log.u.gps_sat.channels = i; - ao_log_gps(&log); + ao_log_write(&log); } -static uint8_t -ao_log_dump_check_data(void) -{ - if (ao_log_csum((uint8_t *) &log) != 0) - return 0; - return 1; -} - -uint16_t -ao_log_flight(uint8_t slot) -{ - if (!ao_storage_read(ao_log_pos(slot), - &log, - sizeof (struct ao_log_gps))) - return 0; - - if (ao_log_dump_check_data() && log.type == AO_LOG_FLIGHT) - return log.u.flight.flight; - return 0; -} - -uint8_t +int8_t ao_log_check(uint32_t pos) { if (!ao_storage_read(pos, &log, sizeof (struct ao_log_gps))) - return 0; + return AO_LOG_INVALID; + + if (ao_log_check_clear()) + return AO_LOG_EMPTY; - if (ao_log_dump_check_data()) - return 1; - return 0; + if (!ao_log_check_data()) + return AO_LOG_INVALID; + return AO_LOG_VALID; } diff --git a/src/kernel/ao_log_mega.c b/src/kernel/ao_log_mega.c index b86abe7a..c6bdf1e2 100644 --- a/src/kernel/ao_log_mega.c +++ b/src/kernel/ao_log_mega.c @@ -21,50 +21,6 @@ #include <ao_data.h> #include <ao_flight.h> -static __xdata struct ao_log_mega log; - -__code uint8_t ao_log_format = AO_LOG_FORMAT_TELEMEGA; - -static uint8_t -ao_log_csum(__xdata uint8_t *b) __reentrant -{ - uint8_t sum = 0x5a; - uint8_t i; - - for (i = 0; i < sizeof (struct ao_log_mega); i++) - sum += *b++; - return -sum; -} - -uint8_t -ao_log_mega(__xdata struct ao_log_mega *log) __reentrant -{ - uint8_t wrote = 0; - /* set checksum */ - log->csum = 0; - log->csum = ao_log_csum((__xdata uint8_t *) log); - ao_mutex_get(&ao_log_mutex); { - if (ao_log_current_pos >= ao_log_end_pos && ao_log_running) - ao_log_stop(); - if (ao_log_running) { - wrote = 1; - ao_storage_write(ao_log_current_pos, - log, - sizeof (struct ao_log_mega)); - ao_log_current_pos += sizeof (struct ao_log_mega); - } - } ao_mutex_put(&ao_log_mutex); - return wrote; -} - -static uint8_t -ao_log_dump_check_data(void) -{ - if (ao_log_csum((uint8_t *) &log) != 0) - return 0; - return 1; -} - #if HAS_FLIGHT static __data uint8_t ao_log_data_pos; @@ -106,7 +62,7 @@ ao_log(void) #endif log.u.flight.ground_pres = ao_ground_pres; log.u.flight.flight = ao_flight_number; - ao_log_mega(&log); + ao_log_write(&log); #endif /* Write the whole contents of the ring to the log @@ -138,8 +94,19 @@ ao_log(void) log.u.sensor.mag_z = ao_data_ring[ao_log_data_pos].hmc5883.z; log.u.sensor.mag_y = ao_data_ring[ao_log_data_pos].hmc5883.y; #endif +#if HAS_MPU9250 + log.u.sensor.accel_x = ao_data_ring[ao_log_data_pos].mpu9250.accel_x; + log.u.sensor.accel_y = ao_data_ring[ao_log_data_pos].mpu9250.accel_y; + log.u.sensor.accel_z = ao_data_ring[ao_log_data_pos].mpu9250.accel_z; + log.u.sensor.gyro_x = ao_data_ring[ao_log_data_pos].mpu9250.gyro_x; + log.u.sensor.gyro_y = ao_data_ring[ao_log_data_pos].mpu9250.gyro_y; + log.u.sensor.gyro_z = ao_data_ring[ao_log_data_pos].mpu9250.gyro_z; + log.u.sensor.mag_x = ao_data_ring[ao_log_data_pos].mpu9250.mag_x; + log.u.sensor.mag_z = ao_data_ring[ao_log_data_pos].mpu9250.mag_z; + log.u.sensor.mag_y = ao_data_ring[ao_log_data_pos].mpu9250.mag_y; +#endif log.u.sensor.accel = ao_data_accel(&ao_data_ring[ao_log_data_pos]); - ao_log_mega(&log); + ao_log_write(&log); if (ao_log_state <= ao_flight_coast) next_sensor = log.tick + AO_SENSOR_INTERVAL_ASCENT; else @@ -153,7 +120,7 @@ ao_log(void) for (i = 0; i < AO_ADC_NUM_SENSE; i++) log.u.volt.sense[i] = ao_data_ring[ao_log_data_pos].adc.sense[i]; log.u.volt.pyro = ao_pyro_fired; - ao_log_mega(&log); + ao_log_write(&log); next_other = log.tick + AO_OTHER_INTERVAL; } ao_log_data_pos = ao_data_ring_next(ao_log_data_pos); @@ -166,7 +133,7 @@ ao_log(void) log.tick = ao_time(); log.u.state.state = ao_log_state; log.u.state.reason = 0; - ao_log_mega(&log); + ao_log_write(&log); if (ao_log_state == ao_flight_landed) ao_log_stop(); @@ -185,15 +152,3 @@ ao_log(void) } #endif /* HAS_FLIGHT */ -uint16_t -ao_log_flight(uint8_t slot) -{ - if (!ao_storage_read(ao_log_pos(slot), - &log, - sizeof (struct ao_log_mega))) - return 0; - - if (ao_log_dump_check_data() && log.type == AO_LOG_FLIGHT) - return log.u.flight.flight; - return 0; -} diff --git a/src/kernel/ao_log_metrum.c b/src/kernel/ao_log_metrum.c index 154b1740..afb8f637 100644 --- a/src/kernel/ao_log_metrum.c +++ b/src/kernel/ao_log_metrum.c @@ -21,50 +21,6 @@ #include <ao_data.h> #include <ao_flight.h> -static __xdata struct ao_log_metrum log; - -__code uint8_t ao_log_format = AO_LOG_FORMAT_TELEMETRUM; - -static uint8_t -ao_log_csum(__xdata uint8_t *b) __reentrant -{ - uint8_t sum = 0x5a; - uint8_t i; - - for (i = 0; i < sizeof (struct ao_log_metrum); i++) - sum += *b++; - return -sum; -} - -uint8_t -ao_log_metrum(__xdata struct ao_log_metrum *log) __reentrant -{ - uint8_t wrote = 0; - /* set checksum */ - log->csum = 0; - log->csum = ao_log_csum((__xdata uint8_t *) log); - ao_mutex_get(&ao_log_mutex); { - if (ao_log_current_pos >= ao_log_end_pos && ao_log_running) - ao_log_stop(); - if (ao_log_running) { - wrote = 1; - ao_storage_write(ao_log_current_pos, - log, - sizeof (struct ao_log_metrum)); - ao_log_current_pos += sizeof (struct ao_log_metrum); - } - } ao_mutex_put(&ao_log_mutex); - return wrote; -} - -static uint8_t -ao_log_dump_check_data(void) -{ - if (ao_log_csum((uint8_t *) &log) != 0) - return 0; - return 1; -} - #if HAS_ADC static __data uint8_t ao_log_data_pos; @@ -97,7 +53,7 @@ ao_log(void) #endif log.u.flight.ground_pres = ao_ground_pres; log.u.flight.flight = ao_flight_number; - ao_log_metrum(&log); + ao_log_write(&log); #endif /* Write the whole contents of the ring to the log @@ -119,7 +75,7 @@ ao_log(void) #if HAS_ACCEL log.u.sensor.accel = ao_data_accel(&ao_data_ring[ao_log_data_pos]); #endif - ao_log_metrum(&log); + ao_log_write(&log); if (ao_log_state <= ao_flight_coast) next_sensor = log.tick + AO_SENSOR_INTERVAL_ASCENT; else @@ -130,7 +86,7 @@ ao_log(void) log.u.volt.v_batt = ao_data_ring[ao_log_data_pos].adc.v_batt; log.u.volt.sense_a = ao_data_ring[ao_log_data_pos].adc.sense_a; log.u.volt.sense_m = ao_data_ring[ao_log_data_pos].adc.sense_m; - ao_log_metrum(&log); + ao_log_write(&log); next_other = log.tick + AO_OTHER_INTERVAL; } ao_log_data_pos = ao_data_ring_next(ao_log_data_pos); @@ -143,7 +99,7 @@ ao_log(void) log.tick = ao_time(); log.u.state.state = ao_log_state; log.u.state.reason = 0; - ao_log_metrum(&log); + ao_log_write(&log); if (ao_log_state == ao_flight_landed) ao_log_stop(); @@ -161,16 +117,3 @@ ao_log(void) } } #endif - -uint16_t -ao_log_flight(uint8_t slot) -{ - if (!ao_storage_read(ao_log_pos(slot), - &log, - sizeof (struct ao_log_metrum))) - return 0; - - if (ao_log_dump_check_data() && log.type == AO_LOG_FLIGHT) - return log.u.flight.flight; - return 0; -} diff --git a/src/kernel/ao_log_mini.c b/src/kernel/ao_log_mini.c index d5735cdc..af2fa605 100644 --- a/src/kernel/ao_log_mini.c +++ b/src/kernel/ao_log_mini.c @@ -21,50 +21,6 @@ #include <ao_data.h> #include <ao_flight.h> -static __xdata struct ao_log_mini log; - -__code uint8_t ao_log_format = AO_LOG_FORMAT; - -static uint8_t -ao_log_csum(__xdata uint8_t *b) __reentrant -{ - uint8_t sum = 0x5a; - uint8_t i; - - for (i = 0; i < sizeof (struct ao_log_mini); i++) - sum += *b++; - return -sum; -} - -uint8_t -ao_log_mini(__xdata struct ao_log_mini *log) __reentrant -{ - uint8_t wrote = 0; - /* set checksum */ - log->csum = 0; - log->csum = ao_log_csum((__xdata uint8_t *) log); - ao_mutex_get(&ao_log_mutex); { - if (ao_log_current_pos >= ao_log_end_pos && ao_log_running) - ao_log_stop(); - if (ao_log_running) { - wrote = 1; - ao_storage_write(ao_log_current_pos, - log, - sizeof (struct ao_log_mini)); - ao_log_current_pos += sizeof (struct ao_log_mini); - } - } ao_mutex_put(&ao_log_mutex); - return wrote; -} - -static uint8_t -ao_log_dump_check_data(void) -{ - if (ao_log_csum((uint8_t *) &log) != 0) - return 0; - return 1; -} - static __data uint8_t ao_log_data_pos; /* a hack to make sure that ao_log_minis fill the eeprom block in even units */ @@ -92,7 +48,7 @@ ao_log(void) log.tick = ao_sample_tick; log.u.flight.flight = ao_flight_number; log.u.flight.ground_pres = ao_ground_pres; - ao_log_mini(&log); + ao_log_write(&log); #endif /* Write the whole contents of the ring to the log @@ -116,7 +72,7 @@ ao_log(void) log.u.sensor.sense_m = ao_data_ring[ao_log_data_pos].adc.sense_m; log.u.sensor.v_batt = ao_data_ring[ao_log_data_pos].adc.v_batt; #endif - ao_log_mini(&log); + ao_log_write(&log); if (ao_log_state <= ao_flight_coast) next_sensor = log.tick + AO_SENSOR_INTERVAL_ASCENT; else @@ -132,7 +88,7 @@ ao_log(void) log.tick = ao_time(); log.u.state.state = ao_log_state; log.u.state.reason = 0; - ao_log_mini(&log); + ao_log_write(&log); if (ao_log_state == ao_flight_landed) ao_log_stop(); @@ -149,16 +105,3 @@ ao_log(void) ao_sleep(&ao_log_running); } } - -uint16_t -ao_log_flight(uint8_t slot) -{ - if (!ao_storage_read(ao_log_pos(slot), - &log, - sizeof (struct ao_log_mini))) - return 0; - - if (ao_log_dump_check_data() && log.type == AO_LOG_FLIGHT) - return log.u.flight.flight; - return 0; -} diff --git a/src/kernel/ao_log_tiny.c b/src/kernel/ao_log_tiny.c index 7769b7b5..0b8e39d6 100644 --- a/src/kernel/ao_log_tiny.c +++ b/src/kernel/ao_log_tiny.c @@ -29,8 +29,6 @@ static __data uint16_t ao_log_tiny_interval; #define AO_PAD_RING 2 #endif -__code uint8_t ao_log_format = AO_LOG_FORMAT_TINY; - void ao_log_tiny_set_interval(uint16_t ticks) { @@ -149,7 +147,7 @@ ao_log(void) } } -uint16_t +int16_t ao_log_flight(uint8_t slot) { static __xdata uint16_t flight; diff --git a/src/kernel/ao_pyro.c b/src/kernel/ao_pyro.c index 9543b3ef..e5c30eec 100644 --- a/src/kernel/ao_pyro.c +++ b/src/kernel/ao_pyro.c @@ -76,7 +76,7 @@ uint16_t ao_pyro_fired; #if PYRO_DBG int pyro_dbg; -#define DBG(...) do { if (pyro_dbg) printf("\t%d: ", (int) (pyro - ao_config.pyro)); printf(__VA_ARGS__); } while (0) +#define DBG(...) do { if (pyro_dbg) { printf("\t%d: ", (int) (pyro - ao_config.pyro)); printf(__VA_ARGS__); } } while (0) #else #define DBG(...) #endif @@ -239,11 +239,8 @@ ao_pyro_pins_fire(uint16_t fire) } ao_delay(ao_config.pyro_time); for (p = 0; p < AO_PYRO_NUM; p++) { - if (fire & (1 << p)) { + if (fire & (1 << p)) ao_pyro_pin_set(p, 0); - ao_config.pyro[p].fired = 1; - ao_pyro_fired |= (1 << p); - } } ao_delay(AO_MS_TO_TICKS(50)); } @@ -261,7 +258,7 @@ ao_pyro_check(void) /* Ignore igniters which have already fired */ - if (pyro->fired) + if (ao_pyro_fired & (1 << p)) continue; /* Ignore disabled igniters @@ -296,7 +293,7 @@ ao_pyro_check(void) * by setting the fired bit */ if (!ao_pyro_ready(pyro)) { - pyro->fired = 1; + ao_pyro_fired |= (1 << p); continue; } @@ -307,8 +304,10 @@ ao_pyro_check(void) fire |= (1 << p); } - if (fire) + if (fire) { + ao_pyro_fired |= fire; ao_pyro_pins_fire(fire); + } return any_waiting; } @@ -482,7 +481,7 @@ ao_pyro_set(void) break; for (c = 0; c < AO_PYRO_NAME_LEN - 1; c++) { - if (ao_cmd_is_white()) + if (ao_cmd_is_white() || ao_cmd_lex_c == '\n') break; name[c] = ao_cmd_lex_c; ao_cmd_lex(); diff --git a/src/kernel/ao_pyro.h b/src/kernel/ao_pyro.h index a730ef19..3ab5af3b 100644 --- a/src/kernel/ao_pyro.h +++ b/src/kernel/ao_pyro.h @@ -63,7 +63,7 @@ struct ao_pyro { uint8_t state_less, state_greater_or_equal; int16_t motor; uint16_t delay_done; - uint8_t fired; + uint8_t _unused; /* was 'fired' */ }; #define AO_PYRO_8_BIT_VALUE (ao_pyro_state_less|ao_pyro_state_greater_or_equal) diff --git a/src/kernel/ao_sample.c b/src/kernel/ao_sample.c index f0ab0169..61519478 100644 --- a/src/kernel/ao_sample.c +++ b/src/kernel/ao_sample.c @@ -184,9 +184,9 @@ ao_sample_rotate(void) #else static const float dt = 1/TIME_DIV; #endif - float x = ao_mpu6000_gyro((float) ((ao_sample_pitch << 9) - ao_ground_pitch) / 512.0f) * dt; - float y = ao_mpu6000_gyro((float) ((ao_sample_yaw << 9) - ao_ground_yaw) / 512.0f) * dt; - float z = ao_mpu6000_gyro((float) ((ao_sample_roll << 9) - ao_ground_roll) / 512.0f) * dt; + float x = ao_convert_gyro((float) ((ao_sample_pitch << 9) - ao_ground_pitch) / 512.0f) * dt; + float y = ao_convert_gyro((float) ((ao_sample_yaw << 9) - ao_ground_yaw) / 512.0f) * dt; + float z = ao_convert_gyro((float) ((ao_sample_roll << 9) - ao_ground_roll) / 512.0f) * dt; struct ao_quaternion rot; ao_quaternion_init_half_euler(&rot, x, y, z); diff --git a/src/kernel/ao_stdio.c b/src/kernel/ao_stdio.c index f0ee0a14..dc09b5c7 100644 --- a/src/kernel/ao_stdio.c +++ b/src/kernel/ao_stdio.c @@ -84,7 +84,7 @@ __pdata int8_t ao_cur_stdio; #endif void -putchar(char c) +ao_putchar(char c) { #if LOW_LEVEL_DEBUG if (!ao_cur_task) { @@ -110,7 +110,7 @@ flush(void) __xdata uint8_t ao_stdin_ready; char -getchar(void) __reentrant +ao_getchar(void) __reentrant { int c; int8_t stdio; diff --git a/src/kernel/ao_storage.c b/src/kernel/ao_storage.c index bee9293e..400751de 100644 --- a/src/kernel/ao_storage.c +++ b/src/kernel/ao_storage.c @@ -22,6 +22,9 @@ uint8_t ao_storage_read(ao_pos_t pos, __xdata void *buf, uint16_t len) __reentrant { +#ifdef CC1111 + return ao_storage_device_read(pos, buf, len); +#else uint16_t this_len; uint16_t this_off; @@ -47,11 +50,15 @@ ao_storage_read(ao_pos_t pos, __xdata void *buf, uint16_t len) __reentrant pos += this_len; } return 1; +#endif } uint8_t ao_storage_write(ao_pos_t pos, __xdata void *buf, uint16_t len) __reentrant { +#ifdef CC1111 + return ao_storage_device_write(pos, buf, len); +#else uint16_t this_len; uint16_t this_off; @@ -77,9 +84,10 @@ ao_storage_write(ao_pos_t pos, __xdata void *buf, uint16_t len) __reentrant pos += this_len; } return 1; +#endif } -static __xdata uint8_t storage_data[8]; +static __xdata uint8_t storage_data[128]; static void ao_storage_dump(void) __reentrant @@ -159,6 +167,154 @@ ao_storage_zapall(void) __reentrant ao_storage_erase(pos); } +#if AO_STORAGE_TEST + +static void +ao_storage_failure(uint32_t pos, char *format, ...) +{ + va_list a; + printf("TEST FAILURE AT %08x: ", pos); + va_start(a, format); + vprintf(format, a); + va_end(a); +} + +static uint8_t +ao_storage_check_block(uint32_t pos, uint8_t value) +{ + uint32_t offset; + uint32_t byte; + + for (offset = 0; offset < ao_storage_block; offset += sizeof (storage_data)) { + if (!ao_storage_read(pos + offset, storage_data, sizeof (storage_data))) { + ao_storage_failure(pos + offset, "read failed\n"); + return 0; + } + for (byte = 0; byte < sizeof (storage_data); byte++) + if (storage_data[byte] != value) { + ao_storage_failure(pos + offset + byte, + "want %02x got %02x\n", + value, storage_data[byte]); + return 0; + } + } + return 1; +} + +static uint8_t +ao_storage_fill_block(uint32_t pos, uint8_t value) +{ + uint32_t offset; + uint32_t byte; + + for (byte = 0; byte < sizeof (storage_data); byte++) + storage_data[byte] = value; + for (offset = 0; offset < ao_storage_block; offset += sizeof (storage_data)) { + if (!ao_storage_write(pos + offset, storage_data, sizeof (storage_data))) { + ao_storage_failure(pos + offset, "write failed\n"); + return 0; + } + } + return 1; +} + +static uint8_t +ao_storage_check_incr_block(uint32_t pos) +{ + uint32_t offset; + uint32_t byte; + + for (offset = 0; offset < ao_storage_block; offset += sizeof (storage_data)) { + if (!ao_storage_read(pos + offset, storage_data, sizeof (storage_data))) { + ao_storage_failure(pos + offset, "read failed\n"); + return 0; + } + for (byte = 0; byte < sizeof (storage_data); byte++) { + uint8_t value = offset + byte; + if (storage_data[byte] != value) { + ao_storage_failure(pos + offset + byte, + "want %02x got %02x\n", + value, storage_data[byte]); + return 0; + } + } + } + return 1; +} + +static uint8_t +ao_storage_fill_incr_block(uint32_t pos) +{ + uint32_t offset; + uint32_t byte; + + for (offset = 0; offset < ao_storage_block; offset += sizeof (storage_data)) { + for (byte = 0; byte < sizeof (storage_data); byte++) + storage_data[byte] = offset + byte; + if (!ao_storage_write(pos + offset, storage_data, sizeof (storage_data))) { + ao_storage_failure(pos + offset, "write failed\n"); + return 0; + } + } + return 1; +} + +static uint8_t +ao_storage_fill_check_block(uint32_t pos, uint8_t value) +{ + return ao_storage_fill_block(pos, value) && ao_storage_check_block(pos, value); +} + +static uint8_t +ao_storage_incr_check_block(uint32_t pos) +{ + return ao_storage_fill_incr_block(pos) && ao_storage_check_incr_block(pos); +} + +static uint8_t +ao_storage_test_block(uint32_t pos) __reentrant +{ + ao_storage_erase(pos); + printf(" erase"); flush(); + if (!ao_storage_check_block(pos, 0xff)) + return 0; + printf(" zero"); flush(); + if (!ao_storage_fill_check_block(pos, 0x00)) + return 0; + ao_storage_erase(pos); + printf(" 0xaa"); flush(); + if (!ao_storage_fill_check_block(pos, 0xaa)) + return 0; + ao_storage_erase(pos); + printf(" 0x55"); flush(); + if (!ao_storage_fill_check_block(pos, 0x55)) + return 0; + ao_storage_erase(pos); + printf(" increment"); flush(); + if (!ao_storage_incr_check_block(pos)) + return 0; + ao_storage_erase(pos); + printf(" pass\n"); flush(); + return 1; +} + +static void +ao_storage_test(void) __reentrant +{ + uint32_t pos; + + ao_cmd_white(); + if (!ao_match_word("DoIt")) + return; + for (pos = 0; pos < ao_storage_log_max; pos += ao_storage_block) { + printf("Testing block 0x%08x:", pos); flush(); + if (!ao_storage_test_block(pos)) + break; + } + printf("Test complete\n"); +} +#endif /* AO_STORAGE_TEST */ + void ao_storage_info(void) __reentrant { @@ -176,6 +332,9 @@ __code struct ao_cmds ao_storage_cmds[] = { #endif { ao_storage_zap, "z <block>\0Erase <block>" }, { ao_storage_zapall,"Z <key>\0Erase all. <key> is doit with D&I" }, +#if AO_STORAGE_TEST + { ao_storage_test, "V <key>\0Validate flash (destructive). <key> is doit with D&I" }, +#endif { 0, NULL }, }; diff --git a/src/kernel/ao_task.h b/src/kernel/ao_task.h index 30b018ff..7549b598 100644 --- a/src/kernel/ao_task.h +++ b/src/kernel/ao_task.h @@ -44,6 +44,9 @@ struct ao_task { ao_arch_task_members /* any architecture-specific fields */ uint8_t task_id; /* unique id */ __code char *name; /* task name */ +#ifdef NEWLIB + int __errno; /* storage for errno in newlib libc */ +#endif #if HAS_TASK_QUEUE struct ao_list queue; struct ao_list alarm_queue; diff --git a/src/kernel/ao_telemetry.c b/src/kernel/ao_telemetry.c index 2ae1e41b..9ed612ce 100644 --- a/src/kernel/ao_telemetry.c +++ b/src/kernel/ao_telemetry.c @@ -141,7 +141,7 @@ ao_send_mega_sensor(void) telemetry.generic.tick = packet->tick; telemetry.generic.type = AO_TELEMETRY_MEGA_SENSOR; -#if HAS_MPU6000 +#if HAS_MPU6000 || HAS_MPU9250 telemetry.mega_sensor.orient = ao_sample_orient; #endif telemetry.mega_sensor.accel = ao_data_accel(packet); @@ -164,6 +164,20 @@ ao_send_mega_sensor(void) telemetry.mega_sensor.mag_y = packet->hmc5883.y; #endif +#if HAS_MPU9250 + telemetry.mega_sensor.accel_x = packet->mpu9250.accel_x; + telemetry.mega_sensor.accel_y = packet->mpu9250.accel_y; + telemetry.mega_sensor.accel_z = packet->mpu9250.accel_z; + + telemetry.mega_sensor.gyro_x = packet->mpu9250.gyro_x; + telemetry.mega_sensor.gyro_y = packet->mpu9250.gyro_y; + telemetry.mega_sensor.gyro_z = packet->mpu9250.gyro_z; + + telemetry.mega_sensor.mag_x = packet->mpu9250.mag_x; + telemetry.mega_sensor.mag_z = packet->mpu9250.mag_z; + telemetry.mega_sensor.mag_y = packet->mpu9250.mag_y; +#endif + ao_telemetry_send(); } diff --git a/src/lambdakey-v1.0/Makefile b/src/lambdakey-v1.0/Makefile index 2609bea3..4eb045b6 100644 --- a/src/lambdakey-v1.0/Makefile +++ b/src/lambdakey-v1.0/Makefile @@ -5,6 +5,12 @@ include ../stmf0/Makefile.defs +include ../scheme/Makefile-inc + +NEWLIB_FULL=-lm -lc -lgcc + +LIBS=$(NEWLIB_FULL) + INC = \ ao.h \ ao_arch.h \ @@ -13,9 +19,7 @@ INC = \ ao_pins.h \ ao_product.h \ ao_task.h \ - ao_lisp.h \ - ao_lisp_const.h \ - ao_lisp_os.h \ + $(SCHEME_HDRS) \ stm32f0.h \ Makefile @@ -35,23 +39,8 @@ ALTOS_SRC = \ ao_timer.c \ ao_usb_stm.c \ ao_flash_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_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_os_save.c + $(SCHEME_SRCS) \ + ao_scheme_os_save.c PRODUCT=LambdaKey-v1.0 PRODUCT_DEF=-DLAMBDAKEY @@ -61,6 +50,12 @@ CFLAGS = $(PRODUCT_DEF) -I. $(STMF0_CFLAGS) -Os -g LDFLAGS=$(CFLAGS) -L$(TOPDIR)/stmf0 -Wl,-Tlambda.ld +MAP=$(PROG).map +NEWLIB=/local/newlib-mini +MAPFILE=-Wl,-M=$(MAP) +LDFLAGS=-L../stmf0 -L$(NEWLIB)/arm-none-eabi/lib/thumb/v6-m/ -Wl,-Tlambda.ld $(MAPFILE) -nostartfiles +AO_CFLAGS=-I. -I../stmf0 -I../kernel -I../drivers -I.. -I../scheme -isystem $(NEWLIB)/arm-none-eabi/include -DNEWLIB + PROGNAME=lambdakey-v1.0 PROG=$(PROGNAME)-$(VERSION).elf HEX=$(PROGNAME)-$(VERSION).ihx diff --git a/src/lambdakey-v1.0/ao_lambdakey.c b/src/lambdakey-v1.0/ao_lambdakey.c index 8bd344cf..d0996eb4 100644 --- a/src/lambdakey-v1.0/ao_lambdakey.c +++ b/src/lambdakey-v1.0/ao_lambdakey.c @@ -13,14 +13,14 @@ */ #include <ao.h> -#include <ao_lisp.h> +#include <ao_scheme.h> -static void lisp_cmd() { - ao_lisp_read_eval_print(); +static void scheme_cmd() { + ao_scheme_read_eval_print(); } static const struct ao_cmds blink_cmds[] = { - { lisp_cmd, "l\0Run lisp interpreter" }, + { scheme_cmd, "l\0Run scheme interpreter" }, { 0, 0 } }; diff --git a/src/lambdakey-v1.0/ao_scheme_os.h b/src/lambdakey-v1.0/ao_scheme_os.h new file mode 100644 index 00000000..a620684f --- /dev/null +++ b/src/lambdakey-v1.0/ao_scheme_os.h @@ -0,0 +1,79 @@ +/* + * Copyright © 2016 Keith Packard <keithp@keithp.com> + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation; version 2 of the License. + * + * 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_SCHEME_OS_H_ +#define _AO_SCHEME_OS_H_ + +#include "ao.h" + +#define AO_SCHEME_SAVE 1 + +#define AO_SCHEME_POOL_TOTAL 2048 + +#ifndef __BYTE_ORDER +#define __LITTLE_ENDIAN 1234 +#define __BIG_ENDIAN 4321 +#define __BYTE_ORDER __LITTLE_ENDIAN +#endif + +static inline int +ao_scheme_getc() { + static uint8_t at_eol; + int c; + + if (at_eol) { + ao_cmd_readline(); + at_eol = 0; + } + c = ao_cmd_lex(); + if (c == '\n') + at_eol = 1; + return c; +} + +static inline void +ao_scheme_os_flush(void) +{ + flush(); +} + +static inline void +ao_scheme_abort(void) +{ + ao_panic(1); +} + +static inline void +ao_scheme_os_led(int led) +{ + ao_led_set(led); +} + +#define AO_SCHEME_JIFFIES_PER_SECOND AO_HERTZ + +static inline void +ao_scheme_os_delay(int delay) +{ + ao_delay(delay); +} + +static inline int +ao_scheme_os_jiffy(void) +{ + return ao_tick_count; +} +#endif diff --git a/src/lambdakey-v1.0/ao_lisp_os_save.c b/src/lambdakey-v1.0/ao_scheme_os_save.c index 44138398..184ddb8d 100644 --- a/src/lambdakey-v1.0/ao_lisp_os_save.c +++ b/src/lambdakey-v1.0/ao_scheme_os_save.c @@ -13,25 +13,25 @@ */ #include <ao.h> -#include <ao_lisp.h> +#include <ao_scheme.h> #include <ao_flash.h> extern uint8_t __flash__[]; /* saved variables to rebuild the heap - ao_lisp_atoms - ao_lisp_frame_global + ao_scheme_atoms + ao_scheme_frame_global */ int -ao_lisp_os_save(void) +ao_scheme_os_save(void) { int i; - for (i = 0; i < AO_LISP_POOL_TOTAL; i += 256) { - uint32_t *dst = (uint32_t *) &__flash__[i]; - uint32_t *src = (uint32_t *) &ao_lisp_pool[i]; + for (i = 0; i < AO_SCHEME_POOL_TOTAL; i += 256) { + void *dst = &__flash__[i]; + void *src = &ao_scheme_pool[i]; ao_flash_page(dst, src); } @@ -39,15 +39,15 @@ ao_lisp_os_save(void) } int -ao_lisp_os_restore_save(struct ao_lisp_os_save *save, int offset) +ao_scheme_os_restore_save(struct ao_scheme_os_save *save, int offset) { - memcpy(save, &__flash__[offset], sizeof (struct ao_lisp_os_save)); + memcpy(save, &__flash__[offset], sizeof (struct ao_scheme_os_save)); return 1; } int -ao_lisp_os_restore(void) +ao_scheme_os_restore(void) { - memcpy(ao_lisp_pool, __flash__, AO_LISP_POOL_TOTAL); + memcpy(ao_scheme_pool, __flash__, AO_SCHEME_POOL_TOTAL); return 1; } diff --git a/src/lisp/.gitignore b/src/lisp/.gitignore deleted file mode 100644 index 76a555ea..00000000 --- a/src/lisp/.gitignore +++ /dev/null @@ -1,2 +0,0 @@ -ao_lisp_make_const -ao_lisp_const.h diff --git a/src/lisp/Makefile b/src/lisp/Makefile deleted file mode 100644 index 25796ec5..00000000 --- a/src/lisp/Makefile +++ /dev/null @@ -1,22 +0,0 @@ -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 -o $@ ao_lisp_const.lisp - -include Makefile-inc -SRCS=$(LISP_SRCS) - -HDRS=$(LISP_HDRS) - -OBJS=$(SRCS:.c=.o) - -CFLAGS=-DAO_LISP_MAKE_CONST -O0 -g -I. -Wall -Wextra -no-pie - - -ao_lisp_make_const: $(OBJS) - $(CC) $(CFLAGS) -o $@ $(OBJS) - -$(OBJS): $(HDRS) diff --git a/src/lisp/Makefile-inc b/src/lisp/Makefile-inc deleted file mode 100644 index 126deeb0..00000000 --- a/src/lisp/Makefile-inc +++ /dev/null @@ -1,22 +0,0 @@ -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_builtin.c \ - ao_lisp_read.c \ - ao_lisp_frame.c \ - ao_lisp_lambda.c \ - ao_lisp_eval.c \ - ao_lisp_rep.c \ - ao_lisp_save.c \ - ao_lisp_stack.c \ - ao_lisp_error.c - -LISP_HDRS=\ - ao_lisp.h \ - ao_lisp_os.h \ - ao_lisp_read.h diff --git a/src/lisp/Makefile-lisp b/src/lisp/Makefile-lisp deleted file mode 100644 index 998c7673..00000000 --- a/src/lisp/Makefile-lisp +++ /dev/null @@ -1,4 +0,0 @@ -include ../lisp/Makefile-inc - -ao_lisp_const.h: $(LISP_SRCS) $(LISP_HDRS) - +cd ../lisp && make $@ diff --git a/src/lisp/ao_lisp.h b/src/lisp/ao_lisp.h deleted file mode 100644 index 980514cc..00000000 --- a/src/lisp/ao_lisp.h +++ /dev/null @@ -1,793 +0,0 @@ -/* - * Copyright © 2016 Keith Packard <keithp@keithp.com> - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation, either version 2 of the License, or - * (at your option) any later version. - * - * This program is distributed in the hope that it will be useful, but - * WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU - * General Public License for more details. - */ - -#ifndef _AO_LISP_H_ -#define _AO_LISP_H_ - -#define DBG_MEM 0 -#define DBG_EVAL 0 - -#include <stdint.h> -#include <string.h> -#include <ao_lisp_os.h> - -typedef uint16_t ao_poly; -typedef int16_t ao_signed_poly; - -#ifdef AO_LISP_SAVE - -struct ao_lisp_os_save { - ao_poly atoms; - ao_poly globals; - uint16_t const_checksum; - uint16_t const_checksum_inv; -}; - -#define AO_LISP_POOL_EXTRA (sizeof(struct ao_lisp_os_save)) -#define AO_LISP_POOL ((int) (AO_LISP_POOL_TOTAL - AO_LISP_POOL_EXTRA)) - -int -ao_lisp_os_save(void); - -int -ao_lisp_os_restore_save(struct ao_lisp_os_save *save, int offset); - -int -ao_lisp_os_restore(void); - -#endif - -#ifdef AO_LISP_MAKE_CONST -#define AO_LISP_POOL_CONST 16384 -extern uint8_t ao_lisp_const[AO_LISP_POOL_CONST] __attribute__((aligned(4))); -#define ao_lisp_pool ao_lisp_const -#define AO_LISP_POOL AO_LISP_POOL_CONST - -#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_last _atom("last") -#define _ao_lisp_atom_length _atom("length") -#define _ao_lisp_atom_cond _atom("cond") -#define _ao_lisp_atom_lambda _atom("lambda") -#define _ao_lisp_atom_led _atom("led") -#define _ao_lisp_atom_delay _atom("delay") -#define _ao_lisp_atom_pack _atom("pack") -#define _ao_lisp_atom_unpack _atom("unpack") -#define _ao_lisp_atom_flush _atom("flush") -#define _ao_lisp_atom_eval _atom("eval") -#define _ao_lisp_atom_read _atom("read") -#define _ao_lisp_atom_eof _atom("eof") -#define _ao_lisp_atom_save _atom("save") -#define _ao_lisp_atom_restore _atom("restore") -#define _ao_lisp_atom_call2fcc _atom("call/cc") -#define _ao_lisp_atom_collect _atom("collect") -#define _ao_lisp_atom_symbolp _atom("symbol?") -#define _ao_lisp_atom_builtin _atom("builtin?") -#define _ao_lisp_atom_symbolp _atom("symbol?") -#define _ao_lisp_atom_symbolp _atom("symbol?") -#else -#include "ao_lisp_const.h" -#ifndef AO_LISP_POOL -#define AO_LISP_POOL 3072 -#endif -extern uint8_t ao_lisp_pool[AO_LISP_POOL + AO_LISP_POOL_EXTRA] __attribute__((aligned(4))); -#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_TYPE_MASK 0x0003 -#define AO_LISP_TYPE_SHIFT 2 -#define AO_LISP_REF_MASK 0x7ffc -#define AO_LISP_CONST 0x8000 - -/* These have a type value at the start of the struct */ -#define AO_LISP_ATOM 4 -#define AO_LISP_BUILTIN 5 -#define AO_LISP_FRAME 6 -#define AO_LISP_LAMBDA 7 -#define AO_LISP_STACK 8 -#define AO_LISP_NUM_TYPE 9 - -/* Leave two bits for types to use as they please */ -#define AO_LISP_OTHER_TYPE_MASK 0x3f - -#define AO_LISP_NIL 0 - -extern uint16_t ao_lisp_top; - -#define AO_LISP_OOM 0x01 -#define AO_LISP_DIVIDE_BY_ZERO 0x02 -#define AO_LISP_INVALID 0x04 -#define AO_LISP_UNDEFINED 0x08 -#define AO_LISP_EOF 0x10 - -extern uint8_t ao_lisp_exception; - -static inline int -ao_lisp_is_const(ao_poly poly) { - return poly & AO_LISP_CONST; -} - -#define AO_LISP_IS_CONST(a) (ao_lisp_const <= ((uint8_t *) (a)) && ((uint8_t *) (a)) < ao_lisp_const + AO_LISP_POOL_CONST) -#define AO_LISP_IS_POOL(a) (ao_lisp_pool <= ((uint8_t *) (a)) && ((uint8_t *) (a)) < ao_lisp_pool + AO_LISP_POOL) -#define AO_LISP_IS_INT(p) (ao_lisp_base_type(p) == AO_LISP_INT); - -void * -ao_lisp_ref(ao_poly poly); - -ao_poly -ao_lisp_poly(const void *addr, ao_poly type); - -struct ao_lisp_type { - int (*size)(void *addr); - void (*mark)(void *addr); - void (*move)(void *addr); - char name[]; -}; - -struct ao_lisp_cons { - ao_poly car; - ao_poly cdr; -}; - -struct ao_lisp_atom { - uint8_t type; - uint8_t pad[1]; - ao_poly next; - char name[]; -}; - -struct ao_lisp_val { - ao_poly atom; - ao_poly val; -}; - -struct ao_lisp_frame { - uint8_t type; - uint8_t num; - ao_poly prev; - struct ao_lisp_val vals[]; -}; - -/* Set on type when the frame escapes the lambda */ -#define AO_LISP_FRAME_MARK 0x80 -#define AO_LISP_FRAME_PRINT 0x40 - -static inline int ao_lisp_frame_marked(struct ao_lisp_frame *f) { - return f->type & AO_LISP_FRAME_MARK; -} - -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); -} - -enum eval_state { - eval_sexpr, /* Evaluate an sexpr */ - eval_val, /* Value computed */ - eval_formal, /* Formal computed */ - eval_exec, /* Start a lambda evaluation */ - eval_cond, /* Start next cond clause */ - eval_cond_test, /* Check cond condition */ - eval_progn, /* Start next progn entry */ - eval_while, /* Start while condition */ - eval_while_test, /* Check while condition */ - eval_macro, /* Finished with macro generation */ -}; - -struct ao_lisp_stack { - uint8_t type; /* AO_LISP_STACK */ - uint8_t state; /* enum eval_state */ - ao_poly prev; /* previous stack frame */ - ao_poly sexprs; /* expressions to evaluate */ - ao_poly values; /* values computed */ - ao_poly values_tail; /* end of the values list for easy appending */ - ao_poly frame; /* current lookup frame */ - ao_poly list; /* most recent function call */ -}; - -#define AO_LISP_STACK_MARK 0x80 /* set on type when a reference has been taken */ -#define AO_LISP_STACK_PRINT 0x40 /* stack is being printed */ - -static inline int ao_lisp_stack_marked(struct ao_lisp_stack *s) { - return s->type & AO_LISP_STACK_MARK; -} - -static inline void ao_lisp_stack_mark(struct ao_lisp_stack *s) { - s->type |= AO_LISP_STACK_MARK; -} - -static inline struct ao_lisp_stack * -ao_lisp_poly_stack(ao_poly p) -{ - return ao_lisp_ref(p); -} - -static inline ao_poly -ao_lisp_stack_poly(struct ao_lisp_stack *stack) -{ - return ao_lisp_poly(stack, AO_LISP_OTHER); -} - -extern ao_poly ao_lisp_v; - -#define AO_LISP_FUNC_LAMBDA 0 -#define AO_LISP_FUNC_NLAMBDA 1 -#define AO_LISP_FUNC_MACRO 2 -#define AO_LISP_FUNC_LEXPR 3 - -#define AO_LISP_FUNC_FREE_ARGS 0x80 -#define AO_LISP_FUNC_MASK 0x7f - -#define AO_LISP_FUNC_F_LAMBDA (AO_LISP_FUNC_FREE_ARGS | AO_LISP_FUNC_LAMBDA) -#define AO_LISP_FUNC_F_NLAMBDA (AO_LISP_FUNC_FREE_ARGS | AO_LISP_FUNC_NLAMBDA) -#define AO_LISP_FUNC_F_MACRO (AO_LISP_FUNC_FREE_ARGS | AO_LISP_FUNC_MACRO) -#define AO_LISP_FUNC_F_LEXPR (AO_LISP_FUNC_FREE_ARGS | AO_LISP_FUNC_LEXPR) - -struct ao_lisp_builtin { - uint8_t type; - uint8_t args; - uint16_t func; -}; - -enum ao_lisp_builtin_id { - builtin_eval, - builtin_read, - builtin_lambda, - builtin_lexpr, - builtin_nlambda, - builtin_macro, - builtin_car, - builtin_cdr, - builtin_cons, - builtin_last, - builtin_length, - builtin_quote, - builtin_set, - builtin_setq, - builtin_cond, - builtin_progn, - builtin_while, - builtin_print, - builtin_patom, - builtin_plus, - builtin_minus, - builtin_times, - builtin_divide, - builtin_mod, - builtin_equal, - builtin_less, - builtin_greater, - builtin_less_equal, - builtin_greater_equal, - builtin_pack, - builtin_unpack, - builtin_flush, - builtin_delay, - builtin_led, - builtin_save, - builtin_restore, - builtin_call_cc, - builtin_collect, - _builtin_last -}; - -typedef ao_poly (*ao_lisp_func_t)(struct ao_lisp_cons *cons); - -extern const 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]; -} - -struct ao_lisp_lambda { - uint8_t type; - uint8_t args; - ao_poly code; - ao_poly frame; -}; - -static inline struct ao_lisp_lambda * -ao_lisp_poly_lambda(ao_poly poly) -{ - return ao_lisp_ref(poly); -} - -static inline ao_poly -ao_lisp_lambda_poly(struct ao_lisp_lambda *lambda) -{ - return ao_lisp_poly(lambda, AO_LISP_OTHER); -} - -static inline void * -ao_lisp_poly_other(ao_poly poly) { - return ao_lisp_ref(poly); -} - -static inline uint8_t -ao_lisp_other_type(void *other) { -#if DBG_MEM - if ((*((uint8_t *) other) & AO_LISP_OTHER_TYPE_MASK) >= AO_LISP_NUM_TYPE) - ao_lisp_abort(); -#endif - return *((uint8_t *) other) & AO_LISP_OTHER_TYPE_MASK; -} - -static inline ao_poly -ao_lisp_other_poly(const void *other) -{ - return ao_lisp_poly(other, AO_LISP_OTHER); -} - -static inline int -ao_lisp_size_round(int size) -{ - return (size + 3) & ~3; -} - -static inline int -ao_lisp_size(const struct ao_lisp_type *type, void *addr) -{ - return ao_lisp_size_round(type->size(addr)); -} - -#define AO_LISP_OTHER_POLY(other) ((ao_poly)(other) + AO_LISP_OTHER) - -static inline int ao_lisp_poly_base_type(ao_poly poly) { - return poly & AO_LISP_TYPE_MASK; -} - -static inline int ao_lisp_poly_type(ao_poly poly) { - int type = poly & AO_LISP_TYPE_MASK; - if (type == AO_LISP_OTHER) - return ao_lisp_other_type(ao_lisp_poly_other(poly)); - return type; -} - -static inline struct ao_lisp_cons * -ao_lisp_poly_cons(ao_poly poly) -{ - return ao_lisp_ref(poly); -} - -static inline ao_poly -ao_lisp_cons_poly(struct ao_lisp_cons *cons) -{ - return ao_lisp_poly(cons, AO_LISP_CONS); -} - -static inline int -ao_lisp_poly_int(ao_poly poly) -{ - 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; -} - -static inline char * -ao_lisp_poly_string(ao_poly poly) -{ - return ao_lisp_ref(poly); -} - -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_poly poly) -{ - return ao_lisp_ref(poly); -} - -static inline ao_poly -ao_lisp_atom_poly(struct ao_lisp_atom *a) -{ - return ao_lisp_poly(a, AO_LISP_OTHER); -} - -static inline struct ao_lisp_builtin * -ao_lisp_poly_builtin(ao_poly poly) -{ - return ao_lisp_ref(poly); -} - -static inline ao_poly -ao_lisp_builtin_poly(struct ao_lisp_builtin *b) -{ - return ao_lisp_poly(b, AO_LISP_OTHER); -} - -/* memory functions */ - -extern int ao_lisp_collects[2]; -extern int ao_lisp_freed[2]; -extern int ao_lisp_loops[2]; - -/* returns 1 if the object was already marked */ -int -ao_lisp_mark(const struct ao_lisp_type *type, void *addr); - -/* returns 1 if the object was already marked */ -int -ao_lisp_mark_memory(const struct ao_lisp_type *type, void *addr); - -void * -ao_lisp_move_map(void *addr); - -/* returns 1 if the object was already moved */ -int -ao_lisp_move(const struct ao_lisp_type *type, void **ref); - -/* returns 1 if the object was already moved */ -int -ao_lisp_move_memory(const struct ao_lisp_type *type, void **ref); - -void * -ao_lisp_alloc(int size); - -#define AO_LISP_COLLECT_FULL 1 -#define AO_LISP_COLLECT_INCREMENTAL 0 - -int -ao_lisp_collect(uint8_t style); - -void -ao_lisp_cons_stash(int id, struct ao_lisp_cons *cons); - -struct ao_lisp_cons * -ao_lisp_cons_fetch(int id); - -void -ao_lisp_poly_stash(int id, ao_poly poly); - -ao_poly -ao_lisp_poly_fetch(int id); - -void -ao_lisp_string_stash(int id, char *string); - -char * -ao_lisp_string_fetch(int id); - -static inline void -ao_lisp_stack_stash(int id, struct ao_lisp_stack *stack) { - ao_lisp_poly_stash(id, ao_lisp_stack_poly(stack)); -} - -static inline struct ao_lisp_stack * -ao_lisp_stack_fetch(int id) { - return ao_lisp_poly_stack(ao_lisp_poly_fetch(id)); -} - -/* cons */ -extern const struct ao_lisp_type ao_lisp_cons_type; - -struct ao_lisp_cons * -ao_lisp_cons_cons(ao_poly car, struct ao_lisp_cons *cdr); - -extern struct ao_lisp_cons *ao_lisp_cons_free_list; - -void -ao_lisp_cons_free(struct ao_lisp_cons *cons); - -void -ao_lisp_cons_print(ao_poly); - -void -ao_lisp_cons_patom(ao_poly); - -int -ao_lisp_cons_length(struct ao_lisp_cons *cons); - -/* string */ -extern const struct ao_lisp_type ao_lisp_string_type; - -char * -ao_lisp_string_copy(char *a); - -char * -ao_lisp_string_cat(char *a, char *b); - -ao_poly -ao_lisp_string_pack(struct ao_lisp_cons *cons); - -ao_poly -ao_lisp_string_unpack(char *a); - -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; - -extern struct ao_lisp_atom *ao_lisp_atoms; -extern struct ao_lisp_frame *ao_lisp_frame_global; -extern struct ao_lisp_frame *ao_lisp_frame_current; - -void -ao_lisp_atom_print(ao_poly a); - -struct ao_lisp_atom * -ao_lisp_atom_intern(char *name); - -ao_poly * -ao_lisp_atom_ref(struct ao_lisp_frame *frame, ao_poly atom); - -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); - -/* prim */ -void -ao_lisp_poly_print(ao_poly p); - -void -ao_lisp_poly_patom(ao_poly p); - -int -ao_lisp_poly_mark(ao_poly p, uint8_t note_cons); - -/* returns 1 if the object has already been moved */ -int -ao_lisp_poly_move(ao_poly *p, uint8_t note_cons); - -/* eval */ - -void -ao_lisp_eval_clear_globals(void); - -int -ao_lisp_eval_restart(void); - -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); - -char * -ao_lisp_args_name(uint8_t args); - -/* read */ -extern struct ao_lisp_cons *ao_lisp_read_cons; -extern struct ao_lisp_cons *ao_lisp_read_cons_tail; -extern struct ao_lisp_cons *ao_lisp_read_stack; - -ao_poly -ao_lisp_read(void); - -/* rep */ -ao_poly -ao_lisp_read_eval_print(void); - -/* frame */ -extern const struct ao_lisp_type ao_lisp_frame_type; - -#define AO_LISP_FRAME_FREE 6 - -extern struct ao_lisp_frame *ao_lisp_frame_free_list[AO_LISP_FRAME_FREE]; - -ao_poly -ao_lisp_frame_mark(struct ao_lisp_frame *frame); - -ao_poly * -ao_lisp_frame_ref(struct ao_lisp_frame *frame, ao_poly atom); - -struct ao_lisp_frame * -ao_lisp_frame_new(int num); - -void -ao_lisp_frame_free(struct ao_lisp_frame *frame); - -void -ao_lisp_frame_bind(struct ao_lisp_frame *frame, int num, ao_poly atom, ao_poly val); - -int -ao_lisp_frame_add(struct ao_lisp_frame **frame, ao_poly atom, ao_poly val); - -void -ao_lisp_frame_print(ao_poly p); - -/* lambda */ -extern const struct ao_lisp_type ao_lisp_lambda_type; - -extern const char *ao_lisp_state_names[]; - -struct ao_lisp_lambda * -ao_lisp_lambda_new(ao_poly cons); - -void -ao_lisp_lambda_print(ao_poly lambda); - -ao_poly -ao_lisp_lambda(struct ao_lisp_cons *cons); - -ao_poly -ao_lisp_lexpr(struct ao_lisp_cons *cons); - -ao_poly -ao_lisp_nlambda(struct ao_lisp_cons *cons); - -ao_poly -ao_lisp_macro(struct ao_lisp_cons *cons); - -ao_poly -ao_lisp_lambda_eval(void); - -/* save */ - -ao_poly -ao_lisp_save(struct ao_lisp_cons *cons); - -ao_poly -ao_lisp_restore(struct ao_lisp_cons *cons); - -/* stack */ - -extern const struct ao_lisp_type ao_lisp_stack_type; -extern struct ao_lisp_stack *ao_lisp_stack; -extern struct ao_lisp_stack *ao_lisp_stack_free_list; - -void -ao_lisp_stack_reset(struct ao_lisp_stack *stack); - -int -ao_lisp_stack_push(void); - -void -ao_lisp_stack_pop(void); - -void -ao_lisp_stack_clear(void); - -void -ao_lisp_stack_print(ao_poly stack); - -ao_poly -ao_lisp_stack_eval(void); - -ao_poly -ao_lisp_call_cc(struct ao_lisp_cons *cons); - -/* error */ - -void -ao_lisp_error_poly(char *name, ao_poly poly, ao_poly last); - -void -ao_lisp_error_frame(int indent, char *name, struct ao_lisp_frame *frame); - -ao_poly -ao_lisp_error(int error, char *format, ...); - -/* debugging macros */ - -#if DBG_EVAL -#define DBG_CODE 1 -int ao_lisp_stack_depth; -#define DBG_DO(a) a -#define DBG_INDENT() do { int _s; for(_s = 0; _s < ao_lisp_stack_depth; _s++) printf(" "); } while(0) -#define DBG_IN() (++ao_lisp_stack_depth) -#define DBG_OUT() (--ao_lisp_stack_depth) -#define DBG_RESET() (ao_lisp_stack_depth = 0) -#define DBG(...) printf(__VA_ARGS__) -#define DBGI(...) do { DBG("%4d: ", __LINE__); DBG_INDENT(); 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) -#define DBG_STACK() ao_lisp_stack_print(ao_lisp_stack_poly(ao_lisp_stack)) -static inline void -ao_lisp_frames_dump(void) -{ - struct ao_lisp_stack *s; - DBGI(".. current frame: "); DBG_POLY(ao_lisp_frame_poly(ao_lisp_frame_current)); DBG("\n"); - for (s = ao_lisp_stack; s; s = ao_lisp_poly_stack(s->prev)) { - DBGI(".. stack frame: "); DBG_POLY(s->frame); DBG("\n"); - } -} -#define DBG_FRAMES() ao_lisp_frames_dump() -#else -#define DBG_DO(a) -#define DBG_INDENT() -#define DBG_IN() -#define DBG_OUT() -#define DBG(...) -#define DBGI(...) -#define DBG_CONS(a) -#define DBG_POLY(a) -#define DBG_RESET() -#define DBG_STACK() -#define DBG_FRAMES() -#endif - -#define DBG_MEM_START 1 - -#if DBG_MEM - -#include <assert.h> -extern int dbg_move_depth; -#define MDBG_DUMP 1 -#define MDBG_OFFSET(a) ((int) ((uint8_t *) (a) - ao_lisp_pool)) - -extern int dbg_mem; - -#define MDBG_DO(a) a -#define MDBG_MOVE(...) do { if (dbg_mem) { int d; for (d = 0; d < dbg_move_depth; d++) printf (" "); printf(__VA_ARGS__); } } while (0) -#define MDBG_MORE(...) do { if (dbg_mem) printf(__VA_ARGS__); } while (0) -#define MDBG_MOVE_IN() (dbg_move_depth++) -#define MDBG_MOVE_OUT() (assert(--dbg_move_depth >= 0)) - -#else - -#define MDBG_DO(a) -#define MDBG_MOVE(...) -#define MDBG_MORE(...) -#define MDBG_MOVE_IN() -#define MDBG_MOVE_OUT() - -#endif - -#endif /* _AO_LISP_H_ */ diff --git a/src/lisp/ao_lisp_atom.c b/src/lisp/ao_lisp_atom.c deleted file mode 100644 index 8c9e8ed1..00000000 --- a/src/lisp/ao_lisp_atom.c +++ /dev/null @@ -1,165 +0,0 @@ -/* - * Copyright © 2016 Keith Packard <keithp@keithp.com> - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation; version 2 of the License. - * - * 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. - */ - -#include "ao_lisp.h" - -static int name_size(char *name) -{ - return sizeof(struct ao_lisp_atom) + strlen(name) + 1; -} - -static int atom_size(void *addr) -{ - struct ao_lisp_atom *atom = addr; - if (!atom) - return 0; - return name_size(atom->name); -} - -static void atom_mark(void *addr) -{ - struct ao_lisp_atom *atom = addr; - - for (;;) { - atom = ao_lisp_poly_atom(atom->next); - if (!atom) - break; - if (ao_lisp_mark_memory(&ao_lisp_atom_type, atom)) - break; - } -} - -static void atom_move(void *addr) -{ - struct ao_lisp_atom *atom = addr; - int ret; - - for (;;) { - struct ao_lisp_atom *next = ao_lisp_poly_atom(atom->next); - - if (!next) - break; - ret = ao_lisp_move_memory(&ao_lisp_atom_type, (void **) &next); - if (next != ao_lisp_poly_atom(atom->next)) - atom->next = ao_lisp_atom_poly(next); - if (ret) - break; - atom = next; - } -} - -const struct ao_lisp_type ao_lisp_atom_type = { - .mark = atom_mark, - .size = atom_size, - .move = atom_move, - .name = "atom" -}; - -struct ao_lisp_atom *ao_lisp_atoms; - -struct ao_lisp_atom * -ao_lisp_atom_intern(char *name) -{ - struct ao_lisp_atom *atom; - - 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; - } -#endif - ao_lisp_string_stash(0, name); - atom = ao_lisp_alloc(name_size(name)); - name = ao_lisp_string_fetch(0); - if (atom) { - atom->type = AO_LISP_ATOM; - atom->next = ao_lisp_atom_poly(ao_lisp_atoms); - ao_lisp_atoms = atom; - strcpy(atom->name, name); - } - return atom; -} - -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); -} - -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->prev); - } - 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) -{ - 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 (!ref) - ref = ao_lisp_frame_ref(ao_lisp_poly_frame(ao_builtin_frame), atom); -#endif - if (ref) - return *ref; - return ao_lisp_error(AO_LISP_UNDEFINED, "undefined atom %s", ao_lisp_poly_atom(atom)->name); -} - -ao_poly -ao_lisp_atom_set(ao_poly atom, ao_poly val) -{ - 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_add(&ao_lisp_frame_global, atom, val); - return val; -} - -void -ao_lisp_atom_print(ao_poly a) -{ - 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 deleted file mode 100644 index 902f60e2..00000000 --- a/src/lisp/ao_lisp_builtin.c +++ /dev/null @@ -1,619 +0,0 @@ -/* - * Copyright © 2016 Keith Packard <keithp@keithp.com> - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation, either version 2 of the License, or - * (at your option) any later version. - * - * This program is distributed in the hope that it will be useful, but - * WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU - * General Public License for more details. - */ - -#include "ao_lisp.h" - -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 -}; - -#ifdef AO_LISP_MAKE_CONST -char *ao_lisp_builtin_name(enum ao_lisp_builtin_id b) { - (void) b; - return "???"; -} -char *ao_lisp_args_name(uint8_t args) { - (void) args; - return "???"; -} -#else -static const ao_poly builtin_names[] = { - [builtin_eval] = _ao_lisp_atom_eval, - [builtin_read] = _ao_lisp_atom_read, - [builtin_lambda] = _ao_lisp_atom_lambda, - [builtin_lexpr] = _ao_lisp_atom_lexpr, - [builtin_nlambda] = _ao_lisp_atom_nlambda, - [builtin_macro] = _ao_lisp_atom_macro, - [builtin_car] = _ao_lisp_atom_car, - [builtin_cdr] = _ao_lisp_atom_cdr, - [builtin_cons] = _ao_lisp_atom_cons, - [builtin_last] = _ao_lisp_atom_last, - [builtin_length] = _ao_lisp_atom_length, - [builtin_quote] = _ao_lisp_atom_quote, - [builtin_set] = _ao_lisp_atom_set, - [builtin_setq] = _ao_lisp_atom_setq, - [builtin_cond] = _ao_lisp_atom_cond, - [builtin_progn] = _ao_lisp_atom_progn, - [builtin_while] = _ao_lisp_atom_while, - [builtin_print] = _ao_lisp_atom_print, - [builtin_patom] = _ao_lisp_atom_patom, - [builtin_plus] = _ao_lisp_atom_2b, - [builtin_minus] = _ao_lisp_atom_2d, - [builtin_times] = _ao_lisp_atom_2a, - [builtin_divide] = _ao_lisp_atom_2f, - [builtin_mod] = _ao_lisp_atom_25, - [builtin_equal] = _ao_lisp_atom_3d, - [builtin_less] = _ao_lisp_atom_3c, - [builtin_greater] = _ao_lisp_atom_3e, - [builtin_less_equal] = _ao_lisp_atom_3c3d, - [builtin_greater_equal] = _ao_lisp_atom_3e3d, - [builtin_pack] = _ao_lisp_atom_pack, - [builtin_unpack] = _ao_lisp_atom_unpack, - [builtin_flush] = _ao_lisp_atom_flush, - [builtin_delay] = _ao_lisp_atom_delay, - [builtin_led] = _ao_lisp_atom_led, - [builtin_save] = _ao_lisp_atom_save, - [builtin_restore] = _ao_lisp_atom_restore, - [builtin_call_cc] = _ao_lisp_atom_call2fcc, - [builtin_collect] = _ao_lisp_atom_collect, -#if 0 - [builtin_symbolp] = _ao_lisp_atom_symbolp, - [builtin_listp] = _ao_lisp_atom_listp, - [builtin_stringp] = _ao_lisp_atom_stringp, - [builtin_numberp] = _ao_lisp_atom_numberp, -#endif -}; - -static char * -ao_lisp_builtin_name(enum ao_lisp_builtin_id b) { - if (b < _builtin_last) - return ao_lisp_poly_atom(builtin_names[b])->name; - return "???"; -} - -static const ao_poly ao_lisp_args_atoms[] = { - [AO_LISP_FUNC_LAMBDA] = _ao_lisp_atom_lambda, - [AO_LISP_FUNC_LEXPR] = _ao_lisp_atom_lexpr, - [AO_LISP_FUNC_NLAMBDA] = _ao_lisp_atom_nlambda, - [AO_LISP_FUNC_MACRO] = _ao_lisp_atom_macro, -}; - -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)"; -} -#endif - -void -ao_lisp_builtin_print(ao_poly b) -{ - struct ao_lisp_builtin *builtin = ao_lisp_poly_builtin(b); - printf("%s", ao_lisp_builtin_name(builtin->func)); -} - -ao_poly -ao_lisp_check_argc(ao_poly name, struct ao_lisp_cons *cons, int min, int max) -{ - int argc = 0; - - while (cons && argc <= max) { - argc++; - cons = ao_lisp_poly_cons(cons->cdr); - } - 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; -} - -ao_poly -ao_lisp_arg(struct ao_lisp_cons *cons, int argc) -{ - if (!cons) - return AO_LISP_NIL; - while (argc--) { - if (!cons) - return AO_LISP_NIL; - cons = ao_lisp_poly_cons(cons->cdr); - } - 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; -} - -ao_poly -ao_lisp_car(struct ao_lisp_cons *cons) -{ - if (!ao_lisp_check_argc(_ao_lisp_atom_car, cons, 1, 1)) - return AO_LISP_NIL; - 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 (!ao_lisp_check_argc(_ao_lisp_atom_cdr, cons, 1, 1)) - return AO_LISP_NIL; - 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; -} - -ao_poly -ao_lisp_cons(struct ao_lisp_cons *cons) -{ - ao_poly car, cdr; - if(!ao_lisp_check_argc(_ao_lisp_atom_cons, cons, 2, 2)) - return AO_LISP_NIL; - 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_last(struct ao_lisp_cons *cons) -{ - ao_poly l; - if (!ao_lisp_check_argc(_ao_lisp_atom_last, cons, 1, 1)) - return AO_LISP_NIL; - if (!ao_lisp_check_argt(_ao_lisp_atom_last, cons, 0, AO_LISP_CONS, 1)) - return AO_LISP_NIL; - l = ao_lisp_arg(cons, 0); - while (l) { - struct ao_lisp_cons *list = ao_lisp_poly_cons(l); - if (!list->cdr) - return list->car; - l = list->cdr; - } - return AO_LISP_NIL; -} - -ao_poly -ao_lisp_length(struct ao_lisp_cons *cons) -{ - if (!ao_lisp_check_argc(_ao_lisp_atom_length, cons, 1, 1)) - return AO_LISP_NIL; - if (!ao_lisp_check_argt(_ao_lisp_atom_length, cons, 0, AO_LISP_CONS, 1)) - return AO_LISP_NIL; - return ao_lisp_int_poly(ao_lisp_cons_length(ao_lisp_poly_cons(ao_lisp_arg(cons, 0)))); -} - -ao_poly -ao_lisp_quote(struct ao_lisp_cons *cons) -{ - if (!ao_lisp_check_argc(_ao_lisp_atom_quote, cons, 1, 1)) - return AO_LISP_NIL; - return ao_lisp_arg(cons, 0); -} - -ao_poly -ao_lisp_set(struct ao_lisp_cons *cons) -{ - if (!ao_lisp_check_argc(_ao_lisp_atom_set, cons, 2, 2)) - return AO_LISP_NIL; - if (!ao_lisp_check_argt(_ao_lisp_atom_set, cons, 0, AO_LISP_ATOM, 0)) - return AO_LISP_NIL; - - return ao_lisp_atom_set(ao_lisp_arg(cons, 0), ao_lisp_arg(cons, 1)); -} - -ao_poly -ao_lisp_setq(struct ao_lisp_cons *cons) -{ - struct ao_lisp_cons *expand = 0; - 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, - ao_lisp_cons_cons(cons->car, NULL))), - ao_lisp_poly_cons(cons->cdr))); - return ao_lisp_cons_poly(expand); -} - -ao_poly -ao_lisp_cond(struct ao_lisp_cons *cons) -{ - ao_lisp_set_cond(cons); - return AO_LISP_NIL; -} - -ao_poly -ao_lisp_progn(struct ao_lisp_cons *cons) -{ - ao_lisp_stack->state = eval_progn; - ao_lisp_stack->sexprs = ao_lisp_cons_poly(cons); - return AO_LISP_NIL; -} - -ao_poly -ao_lisp_while(struct ao_lisp_cons *cons) -{ - ao_lisp_stack->state = eval_while; - ao_lisp_stack->sexprs = ao_lisp_cons_poly(cons); - return AO_LISP_NIL; -} - -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); - if (cons) - printf(" "); - } - printf("\n"); - 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) -{ - 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 builtin_plus: - r += c; - break; - case builtin_minus: - r -= c; - break; - case builtin_times: - r *= c; - break; - case builtin_divide: - if (c == 0) - return ao_lisp_error(AO_LISP_DIVIDE_BY_ZERO, "divide by zero"); - r /= c; - break; - case builtin_mod: - if (c == 0) - return ao_lisp_error(AO_LISP_DIVIDE_BY_ZERO, "mod by zero"); - r %= c; - break; - default: - break; - } - ret = ao_lisp_int_poly(r); - } - - else if (rt == AO_LISP_STRING && ct == AO_LISP_STRING && op == builtin_plus) - ret = ao_lisp_string_poly(ao_lisp_string_cat(ao_lisp_poly_string(ret), - ao_lisp_poly_string(car))); - else - return ao_lisp_error(AO_LISP_INVALID, "invalid args"); - } - return ret; -} - -ao_poly -ao_lisp_plus(struct ao_lisp_cons *cons) -{ - return ao_lisp_math(cons, builtin_plus); -} - -ao_poly -ao_lisp_minus(struct ao_lisp_cons *cons) -{ - return ao_lisp_math(cons, builtin_minus); -} - -ao_poly -ao_lisp_times(struct ao_lisp_cons *cons) -{ - return ao_lisp_math(cons, builtin_times); -} - -ao_poly -ao_lisp_divide(struct ao_lisp_cons *cons) -{ - return ao_lisp_math(cons, builtin_divide); -} - -ao_poly -ao_lisp_mod(struct ao_lisp_cons *cons) -{ - return ao_lisp_math(cons, builtin_mod); -} - -ao_poly -ao_lisp_compare(struct ao_lisp_cons *cons, enum ao_lisp_builtin_id op) -{ - ao_poly left; - - if (!cons) - return _ao_lisp_atom_t; - - left = cons->car; - cons = ao_lisp_poly_cons(cons->cdr); - while (cons) { - ao_poly right = cons->car; - - if (op == builtin_equal) { - if (left != right) - return AO_LISP_NIL; - } else { - uint8_t lt = ao_lisp_poly_type(left); - uint8_t rt = ao_lisp_poly_type(right); - if (lt == AO_LISP_INT && rt == AO_LISP_INT) { - int l = ao_lisp_poly_int(left); - int r = ao_lisp_poly_int(right); - - switch (op) { - case builtin_less: - if (!(l < r)) - return AO_LISP_NIL; - break; - case builtin_greater: - if (!(l > r)) - return AO_LISP_NIL; - break; - case builtin_less_equal: - if (!(l <= r)) - return AO_LISP_NIL; - break; - case builtin_greater_equal: - if (!(l >= r)) - return AO_LISP_NIL; - break; - default: - break; - } - } else if (lt == AO_LISP_STRING && rt == AO_LISP_STRING) { - int c = strcmp(ao_lisp_poly_string(left), - ao_lisp_poly_string(right)); - switch (op) { - case builtin_less: - if (!(c < 0)) - return AO_LISP_NIL; - break; - case builtin_greater: - if (!(c > 0)) - return AO_LISP_NIL; - break; - case builtin_less_equal: - if (!(c <= 0)) - return AO_LISP_NIL; - break; - case builtin_greater_equal: - if (!(c >= 0)) - return AO_LISP_NIL; - break; - default: - break; - } - } - } - left = right; - cons = ao_lisp_poly_cons(cons->cdr); - } - return _ao_lisp_atom_t; -} - -ao_poly -ao_lisp_equal(struct ao_lisp_cons *cons) -{ - return ao_lisp_compare(cons, builtin_equal); -} - -ao_poly -ao_lisp_less(struct ao_lisp_cons *cons) -{ - return ao_lisp_compare(cons, builtin_less); -} - -ao_poly -ao_lisp_greater(struct ao_lisp_cons *cons) -{ - return ao_lisp_compare(cons, builtin_greater); -} - -ao_poly -ao_lisp_less_equal(struct ao_lisp_cons *cons) -{ - return ao_lisp_compare(cons, builtin_less_equal); -} - -ao_poly -ao_lisp_greater_equal(struct ao_lisp_cons *cons) -{ - return ao_lisp_compare(cons, builtin_greater_equal); -} - -ao_poly -ao_lisp_pack(struct ao_lisp_cons *cons) -{ - if (!ao_lisp_check_argc(_ao_lisp_atom_pack, cons, 1, 1)) - return AO_LISP_NIL; - if (!ao_lisp_check_argt(_ao_lisp_atom_pack, cons, 0, AO_LISP_CONS, 1)) - return AO_LISP_NIL; - return ao_lisp_string_pack(ao_lisp_poly_cons(ao_lisp_arg(cons, 0))); -} - -ao_poly -ao_lisp_unpack(struct ao_lisp_cons *cons) -{ - if (!ao_lisp_check_argc(_ao_lisp_atom_unpack, cons, 1, 1)) - return AO_LISP_NIL; - if (!ao_lisp_check_argt(_ao_lisp_atom_unpack, cons, 0, AO_LISP_STRING, 0)) - return AO_LISP_NIL; - return ao_lisp_string_unpack(ao_lisp_poly_string(ao_lisp_arg(cons, 0))); -} - -ao_poly -ao_lisp_flush(struct ao_lisp_cons *cons) -{ - if (!ao_lisp_check_argc(_ao_lisp_atom_flush, cons, 0, 0)) - return AO_LISP_NIL; - ao_lisp_os_flush(); - return _ao_lisp_atom_t; -} - -ao_poly -ao_lisp_led(struct ao_lisp_cons *cons) -{ - ao_poly led; - if (!ao_lisp_check_argc(_ao_lisp_atom_led, cons, 1, 1)) - return AO_LISP_NIL; - if (!ao_lisp_check_argt(_ao_lisp_atom_led, cons, 0, AO_LISP_INT, 0)) - return AO_LISP_NIL; - led = ao_lisp_arg(cons, 0); - ao_lisp_os_led(ao_lisp_poly_int(led)); - return led; -} - -ao_poly -ao_lisp_delay(struct ao_lisp_cons *cons) -{ - ao_poly delay; - if (!ao_lisp_check_argc(_ao_lisp_atom_led, cons, 1, 1)) - return AO_LISP_NIL; - if (!ao_lisp_check_argt(_ao_lisp_atom_led, cons, 0, AO_LISP_INT, 0)) - return AO_LISP_NIL; - delay = ao_lisp_arg(cons, 0); - ao_lisp_os_delay(ao_lisp_poly_int(delay)); - return delay; -} - -ao_poly -ao_lisp_do_eval(struct ao_lisp_cons *cons) -{ - if (!ao_lisp_check_argc(_ao_lisp_atom_eval, cons, 1, 1)) - return AO_LISP_NIL; - ao_lisp_stack->state = eval_sexpr; - return cons->car; -} - -ao_poly -ao_lisp_do_read(struct ao_lisp_cons *cons) -{ - if (!ao_lisp_check_argc(_ao_lisp_atom_read, cons, 0, 0)) - return AO_LISP_NIL; - return ao_lisp_read(); -} - -ao_poly -ao_lisp_do_collect(struct ao_lisp_cons *cons) -{ - int free; - (void) cons; - free = ao_lisp_collect(AO_LISP_COLLECT_FULL); - return ao_lisp_int_poly(free); -} - -const ao_lisp_func_t ao_lisp_builtins[] = { - [builtin_eval] = ao_lisp_do_eval, - [builtin_read] = ao_lisp_do_read, - [builtin_lambda] = ao_lisp_lambda, - [builtin_lexpr] = ao_lisp_lexpr, - [builtin_nlambda] = ao_lisp_nlambda, - [builtin_macro] = ao_lisp_macro, - [builtin_car] = ao_lisp_car, - [builtin_cdr] = ao_lisp_cdr, - [builtin_cons] = ao_lisp_cons, - [builtin_last] = ao_lisp_last, - [builtin_length] = ao_lisp_length, - [builtin_quote] = ao_lisp_quote, - [builtin_set] = ao_lisp_set, - [builtin_setq] = ao_lisp_setq, - [builtin_cond] = ao_lisp_cond, - [builtin_progn] = ao_lisp_progn, - [builtin_while] = ao_lisp_while, - [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, - [builtin_divide] = ao_lisp_divide, - [builtin_mod] = ao_lisp_mod, - [builtin_equal] = ao_lisp_equal, - [builtin_less] = ao_lisp_less, - [builtin_greater] = ao_lisp_greater, - [builtin_less_equal] = ao_lisp_less_equal, - [builtin_greater_equal] = ao_lisp_greater_equal, - [builtin_pack] = ao_lisp_pack, - [builtin_unpack] = ao_lisp_unpack, - [builtin_flush] = ao_lisp_flush, - [builtin_led] = ao_lisp_led, - [builtin_delay] = ao_lisp_delay, - [builtin_save] = ao_lisp_save, - [builtin_restore] = ao_lisp_restore, - [builtin_call_cc] = ao_lisp_call_cc, - [builtin_collect] = ao_lisp_do_collect, -}; - diff --git a/src/lisp/ao_lisp_cons.c b/src/lisp/ao_lisp_cons.c deleted file mode 100644 index d2b60c9a..00000000 --- a/src/lisp/ao_lisp_cons.c +++ /dev/null @@ -1,143 +0,0 @@ -/* - * Copyright © 2016 Keith Packard <keithp@keithp.com> - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation, either version 2 of the License, or - * (at your option) any later version. - * - * This program is distributed in the hope that it will be useful, but - * WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU - * General Public License for more details. - */ - -#include "ao_lisp.h" - -static void cons_mark(void *addr) -{ - struct ao_lisp_cons *cons = addr; - - for (;;) { - ao_lisp_poly_mark(cons->car, 1); - cons = ao_lisp_poly_cons(cons->cdr); - if (!cons) - break; - if (ao_lisp_mark_memory(&ao_lisp_cons_type, cons)) - break; - } -} - -static int cons_size(void *addr) -{ - (void) addr; - return sizeof (struct ao_lisp_cons); -} - -static void cons_move(void *addr) -{ - struct ao_lisp_cons *cons = addr; - - if (!cons) - return; - - for (;;) { - struct ao_lisp_cons *cdr; - int ret; - - MDBG_MOVE("cons_move start %d (%d, %d)\n", - MDBG_OFFSET(cons), MDBG_OFFSET(ao_lisp_ref(cons->car)), MDBG_OFFSET(ao_lisp_ref(cons->cdr))); - (void) ao_lisp_poly_move(&cons->car, 1); - cdr = ao_lisp_poly_cons(cons->cdr); - if (!cdr) - break; - ret = ao_lisp_move_memory(&ao_lisp_cons_type, (void **) &cdr); - if (cdr != ao_lisp_poly_cons(cons->cdr)) - cons->cdr = ao_lisp_cons_poly(cdr); - MDBG_MOVE("cons_move end %d (%d, %d)\n", - MDBG_OFFSET(cons), MDBG_OFFSET(ao_lisp_ref(cons->car)), MDBG_OFFSET(ao_lisp_ref(cons->cdr))); - if (ret) - break; - cons = cdr; - } -} - -const struct ao_lisp_type ao_lisp_cons_type = { - .mark = cons_mark, - .size = cons_size, - .move = cons_move, - .name = "cons", -}; - -struct ao_lisp_cons *ao_lisp_cons_free_list; - -struct ao_lisp_cons * -ao_lisp_cons_cons(ao_poly car, struct ao_lisp_cons *cdr) -{ - struct ao_lisp_cons *cons; - - if (ao_lisp_cons_free_list) { - cons = ao_lisp_cons_free_list; - ao_lisp_cons_free_list = ao_lisp_poly_cons(cons->cdr); - } else { - ao_lisp_poly_stash(0, car); - ao_lisp_cons_stash(0, cdr); - cons = ao_lisp_alloc(sizeof (struct ao_lisp_cons)); - car = ao_lisp_poly_fetch(0); - cdr = ao_lisp_cons_fetch(0); - if (!cons) - return NULL; - } - cons->car = car; - cons->cdr = ao_lisp_cons_poly(cdr); - return cons; -} - -void -ao_lisp_cons_free(struct ao_lisp_cons *cons) -{ - while (cons) { - ao_poly cdr = cons->cdr; - cons->cdr = ao_lisp_cons_poly(ao_lisp_cons_free_list); - ao_lisp_cons_free_list = cons; - cons = ao_lisp_poly_cons(cdr); - } -} - -void -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(" "); - ao_lisp_poly_print(cons->car); - cons = ao_lisp_poly_cons(cons->cdr); - first = 0; - } - 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); - } -} - -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; -} diff --git a/src/lisp/ao_lisp_const.lisp b/src/lisp/ao_lisp_const.lisp deleted file mode 100644 index 3c8fd21b..00000000 --- a/src/lisp/ao_lisp_const.lisp +++ /dev/null @@ -1,184 +0,0 @@ -; -; Copyright © 2016 Keith Packard <keithp@keithp.com> -; -; This program is free software; you can redistribute it and/or modify -; it under the terms of the GNU General Public License as published by -; the Free Software Foundation, either version 2 of the License, or -; (at your option) any later version. -; -; This program is distributed in the hope that it will be useful, but -; WITHOUT ANY WARRANTY; without even the implied warranty of -; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -; General Public License for more details. -; -; Lisp code placed in ROM - - ; return a list containing all of the arguments - -(set (quote list) (lexpr (l) l)) - - ; - ; Define a variable without returning the value - ; Useful when defining functions to avoid - ; having lots of output generated - ; - -(setq def (macro (name val rest) - (list - 'progn - (list - 'set - (list 'quote name) - val) - (list 'quote name) - ) - ) - ) - - ; - ; A slightly more convenient form - ; for defining lambdas. - ; - ; (defun <name> (<params>) s-exprs) - ; - -(def defun (macro (name args exprs) - (list - def - name - (cons 'lambda (cons args exprs)) - ) - ) - ) - - ; basic list accessors - - -(defun cadr (l) (car (cdr l))) - -(defun caddr (l) (car (cdr (cdr l)))) - -(defun nth (list n) - (cond ((= n 0) (car list)) - ((nth (cdr list) (1- n))) - ) - ) - - ; simple math operators - -(defun 1+ (x) (+ x 1)) -(defun 1- (x) (- x 1)) - - ; define a set of local - ; variables and then evaluate - ; a list of sexprs - ; - ; (let (var-defines) sexprs) - ; - ; where var-defines are either - ; - ; (name value) - ; - ; or - ; - ; (name) - ; - ; e.g. - ; - ; (let ((x 1) (y)) (setq y (+ x 1)) y) - -(def let (macro (vars exprs) - ((lambda (make-names make-exprs make-nils) - - ; - ; make the list of names in the let - ; - - (setq make-names (lambda (vars) - (cond (vars - (cons (car (car vars)) - (make-names (cdr vars)))) - ) - ) - ) - - ; the set of expressions is - ; the list of set expressions - ; pre-pended to the - ; expressions to evaluate - - (setq make-exprs (lambda (vars exprs) - (cond (vars (cons - (list set - (list quote - (car (car vars)) - ) - (cadr (car vars)) - ) - (make-exprs (cdr vars) exprs) - ) - ) - (exprs) - ) - ) - ) - - ; the parameters to the lambda is a list - ; of nils of the right length - - (setq make-nils (lambda (vars) - (cond (vars (cons nil (make-nils (cdr vars)))) - ) - ) - ) - ; prepend the set operations - ; to the expressions - - (setq exprs (make-exprs vars exprs)) - - ; build the lambda. - - (cons (cons 'lambda (cons (make-names vars) exprs)) - (make-nils vars) - ) - ) - () - () - () - ) - ) - ) - - ; boolean operators - -(def or (lexpr (l) - (let ((ret nil)) - (while l - (cond ((setq ret (car l)) - (setq l nil)) - ((setq l (cdr l))))) - ret - ) - ) - ) - - ; execute to resolve macros - -(or nil t) - -(def and (lexpr (l) - (let ((ret t)) - (while l - (cond ((setq ret (car l)) - (setq l (cdr l))) - ((setq ret (setq l nil))) - ) - ) - ret - ) - ) - ) - - ; execute to resolve macros - -(and t nil) diff --git a/src/lisp/ao_lisp_error.c b/src/lisp/ao_lisp_error.c deleted file mode 100644 index 54a9be10..00000000 --- a/src/lisp/ao_lisp_error.c +++ /dev/null @@ -1,102 +0,0 @@ -/* - * Copyright © 2016 Keith Packard <keithp@keithp.com> - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation, either version 2 of the License, or - * (at your option) any later version. - * - * This program is distributed in the hope that it will be useful, but - * WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU - * General Public License for more details. - */ - -#include "ao_lisp.h" -#include <stdarg.h> - -void -ao_lisp_error_poly(char *name, ao_poly poly, ao_poly last) -{ - int first = 1; - printf("\t\t%s(", name); - if (ao_lisp_poly_type(poly) == AO_LISP_CONS) { - if (poly) { - while (poly) { - struct ao_lisp_cons *cons = ao_lisp_poly_cons(poly); - if (!first) - printf("\t\t "); - else - first = 0; - ao_lisp_poly_print(cons->car); - printf("\n"); - if (poly == last) - break; - poly = cons->cdr; - } - printf("\t\t )\n"); - } else - printf(")\n"); - } else { - ao_lisp_poly_print(poly); - printf("\n"); - } -} - -static void tabs(int indent) -{ - while (indent--) - printf("\t"); -} - -void -ao_lisp_error_frame(int indent, char *name, struct ao_lisp_frame *frame) -{ - int f; - - tabs(indent); - printf ("%s{", name); - if (frame) { - if (frame->type & AO_LISP_FRAME_PRINT) - printf("recurse..."); - else { - frame->type |= AO_LISP_FRAME_PRINT; - for (f = 0; f < frame->num; f++) { - if (f != 0) { - tabs(indent); - printf(" "); - } - ao_lisp_poly_print(frame->vals[f].atom); - printf(" = "); - ao_lisp_poly_print(frame->vals[f].val); - printf("\n"); - } - if (frame->prev) - ao_lisp_error_frame(indent + 1, "prev: ", ao_lisp_poly_frame(frame->prev)); - frame->type &= ~AO_LISP_FRAME_PRINT; - } - tabs(indent); - printf(" }\n"); - } else - printf ("}\n"); -} - - -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"); - printf("Value: "); ao_lisp_poly_print(ao_lisp_v); printf("\n"); - printf("Stack:\n"); - ao_lisp_stack_print(ao_lisp_stack_poly(ao_lisp_stack)); - printf("Globals:\n\t"); - ao_lisp_frame_print(ao_lisp_frame_poly(ao_lisp_frame_global)); - printf("\n"); - return AO_LISP_NIL; -} diff --git a/src/lisp/ao_lisp_eval.c b/src/lisp/ao_lisp_eval.c deleted file mode 100644 index 3be7c9c4..00000000 --- a/src/lisp/ao_lisp_eval.c +++ /dev/null @@ -1,531 +0,0 @@ -/* - * Copyright © 2016 Keith Packard <keithp@keithp.com> - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation, either version 2 of the License, or - * (at your option) any later version. - * - * This program is distributed in the hope that it will be useful, but - * WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU - * General Public License for more details. - */ - -#include "ao_lisp.h" -#include <assert.h> - -struct ao_lisp_stack *ao_lisp_stack; -ao_poly ao_lisp_v; - -ao_poly -ao_lisp_set_cond(struct ao_lisp_cons *c) -{ - ao_lisp_stack->state = eval_cond; - ao_lisp_stack->sexprs = ao_lisp_cons_poly(c); - return AO_LISP_NIL; -} - -static int -func_type(ao_poly func) -{ - if (func == AO_LISP_NIL) - return ao_lisp_error(AO_LISP_INVALID, "func is nil"); - switch (ao_lisp_poly_type(func)) { - case AO_LISP_BUILTIN: - return ao_lisp_poly_builtin(func)->args & AO_LISP_FUNC_MASK; - case AO_LISP_LAMBDA: - return ao_lisp_poly_lambda(func)->args; - case AO_LISP_STACK: - return AO_LISP_FUNC_LAMBDA; - default: - ao_lisp_error(AO_LISP_INVALID, "not a func"); - return -1; - } -} - -/* - * Flattened eval to avoid stack issues - */ - -/* - * Evaluate an s-expression - * - * For a list, evaluate all of the elements and - * then execute the resulting function call. - * - * Each element of the list is evaluated in - * a clean stack context. - * - * The current stack state is set to 'formal' so that - * when the evaluation is complete, the value - * will get appended to the values list. - * - * For other types, compute the value directly. - */ - -static int -ao_lisp_eval_sexpr(void) -{ - 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) { - if (!ao_lisp_stack->values) { - /* - * empty list evaluates to empty list - */ - ao_lisp_v = AO_LISP_NIL; - ao_lisp_stack->state = eval_val; - } else { - /* - * done with arguments, go execute it - */ - ao_lisp_v = ao_lisp_poly_cons(ao_lisp_stack->values)->car; - ao_lisp_stack->state = eval_exec; - } - } else { - if (!ao_lisp_stack->values) - ao_lisp_stack->list = ao_lisp_v; - /* - * Evaluate another argument and then switch - * to 'formal' to add the value to the values - * list - */ - ao_lisp_stack->sexprs = ao_lisp_v; - ao_lisp_stack->state = eval_formal; - if (!ao_lisp_stack_push()) - return 0; - /* - * push will reset the state to 'sexpr', which - * will evaluate the expression - */ - ao_lisp_v = ao_lisp_poly_cons(ao_lisp_v)->car; - } - break; - case AO_LISP_ATOM: - DBGI("..frame "); DBG_POLY(ao_lisp_frame_poly(ao_lisp_frame_current)); DBG("\n"); - ao_lisp_v = ao_lisp_atom_get(ao_lisp_v); - /* fall through */ - case AO_LISP_INT: - case AO_LISP_STRING: - case AO_LISP_BUILTIN: - case AO_LISP_LAMBDA: - ao_lisp_stack->state = eval_val; - break; - } - DBGI(".. result "); DBG_POLY(ao_lisp_v); DBG("\n"); - return 1; -} - -/* - * A value has been computed. - * - * If the value was computed from a macro, - * then we want to reset the current context - * to evaluate the macro result again. - * - * If not a macro, then pop the stack. - * If the stack is empty, we're done. - * Otherwise, the stack will contain - * the next state. - */ - -static int -ao_lisp_eval_val(void) -{ - DBGI("val: "); DBG_POLY(ao_lisp_v); DBG("\n"); - /* - * Value computed, pop the stack - * to figure out what to do with the value - */ - ao_lisp_stack_pop(); - DBGI("..state %d\n", ao_lisp_stack ? ao_lisp_stack->state : -1); - return 1; -} - -/* - * A formal has been computed. - * - * If this is the first formal, then check to see if we've got a - * lamda/lexpr or macro/nlambda. - * - * For lambda/lexpr, go compute another formal. This will terminate - * when the sexpr state sees nil. - * - * For macro/nlambda, we're done, so move the sexprs into the values - * and go execute it. - * - * Macros have an additional step of saving a stack frame holding the - * macro value execution context, which then gets the result of the - * macro to run - */ - -static int -ao_lisp_eval_formal(void) -{ - ao_poly formal; - struct ao_lisp_stack *prev; - - DBGI("formal: "); DBG_POLY(ao_lisp_v); DBG("\n"); - - /* Check what kind of function we've got */ - if (!ao_lisp_stack->values) { - switch (func_type(ao_lisp_v)) { - case AO_LISP_FUNC_LAMBDA: - case AO_LISP_FUNC_LEXPR: - DBGI(".. lambda or lexpr\n"); - break; - case AO_LISP_FUNC_MACRO: - /* Evaluate the result once more */ - ao_lisp_stack->state = eval_macro; - if (!ao_lisp_stack_push()) - return 0; - - /* After the function returns, take that - * value and re-evaluate it - */ - prev = ao_lisp_poly_stack(ao_lisp_stack->prev); - ao_lisp_stack->sexprs = prev->sexprs; - - DBGI(".. start macro\n"); - DBGI(".. sexprs "); DBG_POLY(ao_lisp_stack->sexprs); DBG("\n"); - DBGI(".. values "); DBG_POLY(ao_lisp_stack->values); DBG("\n"); - DBG_FRAMES(); - - /* fall through ... */ - case AO_LISP_FUNC_NLAMBDA: - DBGI(".. nlambda or macro\n"); - - /* use the raw sexprs as values */ - ao_lisp_stack->values = ao_lisp_stack->sexprs; - ao_lisp_stack->values_tail = AO_LISP_NIL; - ao_lisp_stack->state = eval_exec; - - /* ready to execute now */ - return 1; - case -1: - return 0; - } - } - - /* Append formal to list of values */ - formal = ao_lisp_cons_poly(ao_lisp_cons_cons(ao_lisp_v, NULL)); - if (!formal) - return 0; - - if (ao_lisp_stack->values_tail) - ao_lisp_poly_cons(ao_lisp_stack->values_tail)->cdr = formal; - else - ao_lisp_stack->values = formal; - ao_lisp_stack->values_tail = formal; - - DBGI(".. values "); DBG_POLY(ao_lisp_stack->values); DBG("\n"); - - /* - * Step to the next argument, if this is last, then - * 'sexpr' will end up switching to 'exec' - */ - ao_lisp_v = ao_lisp_poly_cons(ao_lisp_stack->sexprs)->cdr; - - ao_lisp_stack->state = eval_sexpr; - - DBGI(".. "); DBG_POLY(ao_lisp_v); DBG("\n"); - return 1; -} - -/* - * Start executing a function call - * - * Most builtins are easy, just call the function. - * 'cond' is magic; it sticks the list of clauses - * in 'sexprs' and switches to 'cond' state. That - * bit of magic is done in ao_lisp_set_cond. - * - * Lambdas build a new frame to hold the locals and - * then re-use the current stack context to evaluate - * the s-expression from the lambda. - */ - -static int -ao_lisp_eval_exec(void) -{ - ao_poly v; - struct ao_lisp_builtin *builtin; - - DBGI("exec: "); DBG_POLY(ao_lisp_v); DBG(" values "); DBG_POLY(ao_lisp_stack->values); DBG ("\n"); - ao_lisp_stack->sexprs = AO_LISP_NIL; - switch (ao_lisp_poly_type(ao_lisp_v)) { - case AO_LISP_BUILTIN: - ao_lisp_stack->state = eval_val; - builtin = ao_lisp_poly_builtin(ao_lisp_v); - v = ao_lisp_func(builtin) ( - ao_lisp_poly_cons(ao_lisp_poly_cons(ao_lisp_stack->values)->cdr)); - DBG_DO(if (!ao_lisp_exception && ao_lisp_poly_builtin(ao_lisp_v)->func == builtin_set) { - struct ao_lisp_cons *cons = ao_lisp_poly_cons(ao_lisp_stack->values); - ao_poly atom = ao_lisp_arg(cons, 1); - ao_poly val = ao_lisp_arg(cons, 2); - DBGI("set "); DBG_POLY(atom); DBG(" = "); DBG_POLY(val); DBG("\n"); - }); - builtin = ao_lisp_poly_builtin(ao_lisp_v); - if (builtin->args & AO_LISP_FUNC_FREE_ARGS && !ao_lisp_stack_marked(ao_lisp_stack)) - ao_lisp_cons_free(ao_lisp_poly_cons(ao_lisp_stack->values)); - - ao_lisp_v = v; - ao_lisp_stack->values = AO_LISP_NIL; - ao_lisp_stack->values_tail = AO_LISP_NIL; - DBGI(".. result "); DBG_POLY(ao_lisp_v); DBG ("\n"); - DBGI(".. frame "); DBG_POLY(ao_lisp_frame_poly(ao_lisp_frame_current)); DBG("\n"); - break; - case AO_LISP_LAMBDA: - DBGI(".. frame "); DBG_POLY(ao_lisp_frame_poly(ao_lisp_frame_current)); DBG("\n"); - ao_lisp_stack->state = eval_progn; - v = ao_lisp_lambda_eval(); - ao_lisp_stack->sexprs = v; - ao_lisp_stack->values = AO_LISP_NIL; - ao_lisp_stack->values_tail = AO_LISP_NIL; - DBGI(".. sexprs "); DBG_POLY(ao_lisp_stack->sexprs); DBG("\n"); - DBGI(".. frame "); DBG_POLY(ao_lisp_frame_poly(ao_lisp_frame_current)); DBG("\n"); - break; - case AO_LISP_STACK: - DBGI(".. stack "); DBG_POLY(ao_lisp_v); DBG("\n"); - ao_lisp_v = ao_lisp_stack_eval(); - DBGI(".. value "); DBG_POLY(ao_lisp_v); DBG("\n"); - DBGI(".. frame "); DBG_POLY(ao_lisp_frame_poly(ao_lisp_frame_current)); DBG("\n"); - break; - } - return 1; -} - -/* - * Start evaluating the next cond clause - * - * If the list of clauses is empty, then - * the result of the cond is nil. - * - * Otherwise, set the current stack state to 'cond_test' and create a - * new stack context to evaluate the test s-expression. Once that's - * complete, we'll land in 'cond_test' to finish the clause. - */ -static int -ao_lisp_eval_cond(void) -{ - DBGI("cond: "); DBG_POLY(ao_lisp_stack->sexprs); DBG("\n"); - DBGI(".. frame "); DBG_POLY(ao_lisp_frame_poly(ao_lisp_frame_current)); DBG("\n"); - DBGI(".. saved frame "); DBG_POLY(ao_lisp_stack->frame); DBG("\n"); - if (!ao_lisp_stack->sexprs) { - ao_lisp_v = AO_LISP_NIL; - ao_lisp_stack->state = eval_val; - } else { - ao_lisp_v = ao_lisp_poly_cons(ao_lisp_stack->sexprs)->car; - if (!ao_lisp_v || ao_lisp_poly_type(ao_lisp_v) != AO_LISP_CONS) { - ao_lisp_error(AO_LISP_INVALID, "invalid cond clause"); - return 0; - } - ao_lisp_v = ao_lisp_poly_cons(ao_lisp_v)->car; - ao_lisp_stack->state = eval_cond_test; - if (!ao_lisp_stack_push()) - return 0; - } - return 1; -} - -/* - * Finish a cond clause. - * - * Check the value from the test expression, if - * non-nil, then set up to evaluate the value expression. - * - * Otherwise, step to the next clause and go back to the 'cond' - * state - */ -static int -ao_lisp_eval_cond_test(void) -{ - DBGI("cond_test: "); DBG_POLY(ao_lisp_v); DBG(" sexprs "); DBG_POLY(ao_lisp_stack->sexprs); DBG("\n"); - DBGI(".. frame "); DBG_POLY(ao_lisp_frame_poly(ao_lisp_frame_current)); DBG("\n"); - DBGI(".. saved frame "); DBG_POLY(ao_lisp_stack->frame); DBG("\n"); - if (ao_lisp_v) { - struct ao_lisp_cons *car = ao_lisp_poly_cons(ao_lisp_poly_cons(ao_lisp_stack->sexprs)->car); - ao_poly c = car->cdr; - - if (c) { - ao_lisp_stack->state = eval_progn; - ao_lisp_stack->sexprs = c; - } else - ao_lisp_stack->state = eval_val; - } else { - ao_lisp_stack->sexprs = ao_lisp_poly_cons(ao_lisp_stack->sexprs)->cdr; - DBGI("next cond: "); DBG_POLY(ao_lisp_stack->sexprs); DBG("\n"); - ao_lisp_stack->state = eval_cond; - } - return 1; -} - -/* - * Evaluate a list of sexprs, returning the value from the last one. - * - * ao_lisp_progn records the list in stack->sexprs, so we just need to - * walk that list. Set ao_lisp_v to the car of the list and jump to - * eval_sexpr. When that's done, it will land in eval_val. For all but - * the last, leave a stack frame with eval_progn set so that we come - * back here. For the last, don't add a stack frame so that we can - * just continue on. - */ -static int -ao_lisp_eval_progn(void) -{ - DBGI("progn: "); DBG_POLY(ao_lisp_v); DBG(" sexprs "); DBG_POLY(ao_lisp_stack->sexprs); DBG("\n"); - DBGI(".. frame "); DBG_POLY(ao_lisp_frame_poly(ao_lisp_frame_current)); DBG("\n"); - DBGI(".. saved frame "); DBG_POLY(ao_lisp_stack->frame); DBG("\n"); - - if (!ao_lisp_stack->sexprs) { - ao_lisp_v = AO_LISP_NIL; - ao_lisp_stack->state = eval_val; - } else { - ao_lisp_v = ao_lisp_poly_cons(ao_lisp_stack->sexprs)->car; - ao_lisp_stack->sexprs = ao_lisp_poly_cons(ao_lisp_stack->sexprs)->cdr; - - /* If there are more sexprs to do, then come back here, otherwise - * return the value of the last one by just landing in eval_sexpr - */ - if (ao_lisp_stack->sexprs) { - ao_lisp_stack->state = eval_progn; - if (!ao_lisp_stack_push()) - return 0; - } - ao_lisp_stack->state = eval_sexpr; - } - return 1; -} - -/* - * Conditionally execute a list of sexprs while the first is true - */ -static int -ao_lisp_eval_while(void) -{ - DBGI("while: "); DBG_POLY(ao_lisp_stack->sexprs); DBG("\n"); - DBGI(".. frame "); DBG_POLY(ao_lisp_frame_poly(ao_lisp_frame_current)); DBG("\n"); - DBGI(".. saved frame "); DBG_POLY(ao_lisp_stack->frame); DBG("\n"); - - ao_lisp_stack->values = ao_lisp_v; - if (!ao_lisp_stack->sexprs) { - ao_lisp_v = AO_LISP_NIL; - ao_lisp_stack->state = eval_val; - } else { - ao_lisp_v = ao_lisp_poly_cons(ao_lisp_stack->sexprs)->car; - ao_lisp_stack->state = eval_while_test; - if (!ao_lisp_stack_push()) - return 0; - } - return 1; -} - -/* - * Check the while condition, terminate the loop if nil. Otherwise keep going - */ -static int -ao_lisp_eval_while_test(void) -{ - DBGI("while_test: "); DBG_POLY(ao_lisp_v); DBG(" sexprs "); DBG_POLY(ao_lisp_stack->sexprs); DBG("\n"); - DBGI(".. frame "); DBG_POLY(ao_lisp_frame_poly(ao_lisp_frame_current)); DBG("\n"); - DBGI(".. saved frame "); DBG_POLY(ao_lisp_stack->frame); DBG("\n"); - - if (ao_lisp_v) { - ao_lisp_stack->values = ao_lisp_v; - ao_lisp_v = ao_lisp_poly_cons(ao_lisp_stack->sexprs)->cdr; - ao_lisp_stack->state = eval_while; - if (!ao_lisp_stack_push()) - return 0; - ao_lisp_stack->state = eval_progn; - ao_lisp_stack->sexprs = ao_lisp_v; - } - else - { - ao_lisp_stack->state = eval_val; - ao_lisp_v = ao_lisp_stack->values; - } - return 1; -} - -/* - * Replace the original sexpr with the macro expansion, then - * execute that - */ -static int -ao_lisp_eval_macro(void) -{ - DBGI("macro: "); DBG_POLY(ao_lisp_v); DBG(" sexprs "); DBG_POLY(ao_lisp_stack->sexprs); DBG("\n"); - - if (ao_lisp_v == AO_LISP_NIL) - ao_lisp_abort(); - if (ao_lisp_poly_type(ao_lisp_v) == AO_LISP_CONS) { - *ao_lisp_poly_cons(ao_lisp_stack->sexprs) = *ao_lisp_poly_cons(ao_lisp_v); - ao_lisp_v = ao_lisp_stack->sexprs; - DBGI("sexprs rewritten to: "); DBG_POLY(ao_lisp_v); DBG("\n"); - } - ao_lisp_stack->sexprs = AO_LISP_NIL; - ao_lisp_stack->state = eval_sexpr; - return 1; -} - -static int (*const evals[])(void) = { - [eval_sexpr] = ao_lisp_eval_sexpr, - [eval_val] = ao_lisp_eval_val, - [eval_formal] = ao_lisp_eval_formal, - [eval_exec] = ao_lisp_eval_exec, - [eval_cond] = ao_lisp_eval_cond, - [eval_cond_test] = ao_lisp_eval_cond_test, - [eval_progn] = ao_lisp_eval_progn, - [eval_while] = ao_lisp_eval_while, - [eval_while_test] = ao_lisp_eval_while_test, - [eval_macro] = ao_lisp_eval_macro, -}; - -const char *ao_lisp_state_names[] = { - "sexpr", - "val", - "formal", - "exec", - "cond", - "cond_test", - "progn", -}; - -/* - * Called at restore time to reset all execution state - */ - -void -ao_lisp_eval_clear_globals(void) -{ - ao_lisp_stack = NULL; - ao_lisp_frame_current = NULL; - ao_lisp_v = AO_LISP_NIL; -} - -int -ao_lisp_eval_restart(void) -{ - return ao_lisp_stack_push(); -} - -ao_poly -ao_lisp_eval(ao_poly _v) -{ - ao_lisp_v = _v; - - if (!ao_lisp_stack_push()) - return AO_LISP_NIL; - - while (ao_lisp_stack) { - if (!(*evals[ao_lisp_stack->state])() || ao_lisp_exception) { - ao_lisp_stack_clear(); - return AO_LISP_NIL; - } - } - DBG_DO(if (ao_lisp_frame_current) {DBGI("frame left as "); DBG_POLY(ao_lisp_frame_poly(ao_lisp_frame_current)); DBG("\n");}); - ao_lisp_frame_current = NULL; - return ao_lisp_v; -} diff --git a/src/lisp/ao_lisp_frame.c b/src/lisp/ao_lisp_frame.c deleted file mode 100644 index 05f6d253..00000000 --- a/src/lisp/ao_lisp_frame.c +++ /dev/null @@ -1,293 +0,0 @@ -/* - * Copyright © 2016 Keith Packard <keithp@keithp.com> - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation, either version 2 of the License, or - * (at your option) any later version. - * - * This program is distributed in the hope that it will be useful, but - * WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU - * General Public License for more details. - */ - -#include "ao_lisp.h" - -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); -} - -static void -frame_mark(void *addr) -{ - struct ao_lisp_frame *frame = addr; - int f; - - for (;;) { - MDBG_MOVE("frame mark %d\n", MDBG_OFFSET(frame)); - if (!AO_LISP_IS_POOL(frame)) - break; - for (f = 0; f < frame->num; f++) { - struct ao_lisp_val *v = &frame->vals[f]; - - ao_lisp_poly_mark(v->val, 0); - MDBG_MOVE("frame mark atom %s %d val %d at %d\n", - ao_lisp_poly_atom(v->atom)->name, - MDBG_OFFSET(ao_lisp_ref(v->atom)), - MDBG_OFFSET(ao_lisp_ref(v->val)), f); - } - frame = ao_lisp_poly_frame(frame->prev); - MDBG_MOVE("frame next %d\n", MDBG_OFFSET(frame)); - if (!frame) - break; - if (ao_lisp_mark_memory(&ao_lisp_frame_type, frame)) - break; - } -} - -static void -frame_move(void *addr) -{ - struct ao_lisp_frame *frame = addr; - int f; - - for (;;) { - struct ao_lisp_frame *prev; - int ret; - - MDBG_MOVE("frame move %d\n", MDBG_OFFSET(frame)); - if (!AO_LISP_IS_POOL(frame)) - break; - for (f = 0; f < frame->num; f++) { - struct ao_lisp_val *v = &frame->vals[f]; - - ao_lisp_poly_move(&v->atom, 0); - ao_lisp_poly_move(&v->val, 0); - MDBG_MOVE("frame move atom %s %d val %d at %d\n", - ao_lisp_poly_atom(v->atom)->name, - MDBG_OFFSET(ao_lisp_ref(v->atom)), - MDBG_OFFSET(ao_lisp_ref(v->val)), f); - } - prev = ao_lisp_poly_frame(frame->prev); - if (!prev) - break; - ret = ao_lisp_move_memory(&ao_lisp_frame_type, (void **) &prev); - if (prev != ao_lisp_poly_frame(frame->prev)) { - MDBG_MOVE("frame prev moved from %d to %d\n", - MDBG_OFFSET(ao_lisp_poly_frame(frame->prev)), - MDBG_OFFSET(prev)); - frame->prev = ao_lisp_frame_poly(prev); - } - if (ret) - break; - frame = prev; - } -} - -const struct ao_lisp_type ao_lisp_frame_type = { - .mark = frame_mark, - .size = frame_size, - .move = frame_move, - .name = "frame", -}; - -void -ao_lisp_frame_print(ao_poly p) -{ - struct ao_lisp_frame *frame = ao_lisp_poly_frame(p); - int f; - - printf ("{"); - if (frame) { - if (frame->type & AO_LISP_FRAME_PRINT) - printf("recurse..."); - else { - frame->type |= AO_LISP_FRAME_PRINT; - for (f = 0; f < frame->num; f++) { - if (f != 0) - printf(", "); - ao_lisp_poly_print(frame->vals[f].atom); - printf(" = "); - ao_lisp_poly_print(frame->vals[f].val); - } - if (frame->prev) - ao_lisp_poly_print(frame->prev); - frame->type &= ~AO_LISP_FRAME_PRINT; - } - } - printf("}"); -} - -static int -ao_lisp_frame_find(struct ao_lisp_frame *frame, int top, ao_poly atom) -{ - int l = 0; - int r = top - 1; - while (l <= r) { - int m = (l + r) >> 1; - if (frame->vals[m].atom < atom) - l = m + 1; - else - r = m - 1; - } - return l; -} - -ao_poly * -ao_lisp_frame_ref(struct ao_lisp_frame *frame, ao_poly atom) -{ - int l = ao_lisp_frame_find(frame, frame->num, atom); - - if (l >= frame->num) - return NULL; - - if (frame->vals[l].atom != atom) - return NULL; - return &frame->vals[l].val; -} - -int -ao_lisp_frame_set(struct ao_lisp_frame *frame, ao_poly atom, ao_poly val) -{ - while (frame) { - if (!AO_LISP_IS_CONST(frame)) { - ao_poly *ref = ao_lisp_frame_ref(frame, atom); - if (ref) { - *ref = val; - return 1; - } - } - frame = ao_lisp_poly_frame(frame->prev); - } - 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->prev); - } - return AO_LISP_NIL; -} - -struct ao_lisp_frame *ao_lisp_frame_free_list[AO_LISP_FRAME_FREE]; - -struct ao_lisp_frame * -ao_lisp_frame_new(int num) -{ - struct ao_lisp_frame *frame; - - if (num < AO_LISP_FRAME_FREE && (frame = ao_lisp_frame_free_list[num])) - ao_lisp_frame_free_list[num] = ao_lisp_poly_frame(frame->prev); - else { - frame = ao_lisp_alloc(frame_num_size(num)); - if (!frame) - return NULL; - } - frame->type = AO_LISP_FRAME; - frame->num = num; - frame->prev = AO_LISP_NIL; - memset(frame->vals, '\0', num * sizeof (struct ao_lisp_val)); - return frame; -} - -ao_poly -ao_lisp_frame_mark(struct ao_lisp_frame *frame) -{ - if (!frame) - return AO_LISP_NIL; - frame->type |= AO_LISP_FRAME_MARK; - return ao_lisp_frame_poly(frame); -} - -void -ao_lisp_frame_free(struct ao_lisp_frame *frame) -{ - if (!ao_lisp_frame_marked(frame)) { - int num = frame->num; - if (num < AO_LISP_FRAME_FREE) { - frame->prev = ao_lisp_frame_poly(ao_lisp_frame_free_list[num]); - ao_lisp_frame_free_list[num] = frame; - } - } -} - -static struct ao_lisp_frame * -ao_lisp_frame_realloc(struct ao_lisp_frame **frame_ref, int new_num) -{ - struct ao_lisp_frame *frame = *frame_ref; - struct ao_lisp_frame *new; - int copy; - - if (new_num == frame->num) - return frame; - new = ao_lisp_frame_new(new_num); - if (!new) - return NULL; - /* - * Re-fetch the frame as it may have moved - * during the allocation - */ - frame = *frame_ref; - copy = new_num; - if (copy > frame->num) - copy = frame->num; - memcpy(new->vals, frame->vals, copy * sizeof (struct ao_lisp_val)); - new->prev = frame->prev; - ao_lisp_frame_free(frame); - return new; -} - -void -ao_lisp_frame_bind(struct ao_lisp_frame *frame, int num, ao_poly atom, ao_poly val) -{ - int l = ao_lisp_frame_find(frame, num, atom); - - memmove(&frame->vals[l+1], - &frame->vals[l], - (num - l) * sizeof (struct ao_lisp_val)); - frame->vals[l].atom = atom; - frame->vals[l].val = val; -} - -int -ao_lisp_frame_add(struct ao_lisp_frame **frame_ref, ao_poly atom, ao_poly val) -{ - struct ao_lisp_frame *frame = *frame_ref; - ao_poly *ref = frame ? ao_lisp_frame_ref(frame, atom) : NULL; - - if (!ref) { - int f; - ao_lisp_poly_stash(0, atom); - ao_lisp_poly_stash(1, val); - if (frame) { - f = frame->num; - frame = ao_lisp_frame_realloc(frame_ref, f + 1); - } else { - f = 0; - frame = ao_lisp_frame_new(1); - } - if (!frame) - return 0; - *frame_ref = frame; - atom = ao_lisp_poly_fetch(0); - val = ao_lisp_poly_fetch(1); - ao_lisp_frame_bind(frame, frame->num - 1, atom, val); - } else - *ref = val; - return 1; -} diff --git a/src/lisp/ao_lisp_int.c b/src/lisp/ao_lisp_int.c deleted file mode 100644 index 77f65e95..00000000 --- a/src/lisp/ao_lisp_int.c +++ /dev/null @@ -1,22 +0,0 @@ -/* - * Copyright © 2016 Keith Packard <keithp@keithp.com> - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation, either version 2 of the License, or - * (at your option) any later version. - * - * This program is distributed in the hope that it will be useful, but - * WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU - * General Public License for more details. - */ - -#include "ao_lisp.h" - -void -ao_lisp_int_print(ao_poly p) -{ - int i = ao_lisp_poly_int(p); - printf("%d", i); -} diff --git a/src/lisp/ao_lisp_lambda.c b/src/lisp/ao_lisp_lambda.c deleted file mode 100644 index 526863c5..00000000 --- a/src/lisp/ao_lisp_lambda.c +++ /dev/null @@ -1,196 +0,0 @@ -/* - * Copyright © 2016 Keith Packard <keithp@keithp.com> - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation; version 2 of the License. - * - * 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. - */ - -#include "ao_lisp.h" - -int -lambda_size(void *addr) -{ - (void) addr; - return sizeof (struct ao_lisp_lambda); -} - -void -lambda_mark(void *addr) -{ - struct ao_lisp_lambda *lambda = addr; - - ao_lisp_poly_mark(lambda->code, 0); - ao_lisp_poly_mark(lambda->frame, 0); -} - -void -lambda_move(void *addr) -{ - struct ao_lisp_lambda *lambda = addr; - - ao_lisp_poly_move(&lambda->code, 0); - ao_lisp_poly_move(&lambda->frame, 0); -} - -const struct ao_lisp_type ao_lisp_lambda_type = { - .size = lambda_size, - .mark = lambda_mark, - .move = lambda_move, - .name = "lambda", -}; - -void -ao_lisp_lambda_print(ao_poly poly) -{ - struct ao_lisp_lambda *lambda = ao_lisp_poly_lambda(poly); - struct ao_lisp_cons *cons = ao_lisp_poly_cons(lambda->code); - - printf("("); - printf("%s", ao_lisp_args_name(lambda->args)); - while (cons) { - printf(" "); - ao_lisp_poly_print(cons->car); - cons = ao_lisp_poly_cons(cons->cdr); - } - printf(")"); -} - -ao_poly -ao_lisp_lambda_alloc(struct ao_lisp_cons *code, int args) -{ - ao_lisp_cons_stash(0, code); - struct ao_lisp_lambda *lambda = ao_lisp_alloc(sizeof (struct ao_lisp_lambda)); - code = ao_lisp_cons_fetch(0); - struct ao_lisp_cons *arg; - int f; - - if (!lambda) - return AO_LISP_NIL; - - if (!ao_lisp_check_argt(_ao_lisp_atom_lambda, code, 0, AO_LISP_CONS, 1)) - return AO_LISP_NIL; - f = 0; - arg = ao_lisp_poly_cons(ao_lisp_arg(code, 0)); - while (arg) { - if (ao_lisp_poly_type(arg->car) != AO_LISP_ATOM) - return ao_lisp_error(AO_LISP_INVALID, "formal %d is not an atom", f); - arg = ao_lisp_poly_cons(arg->cdr); - f++; - } - - lambda->type = AO_LISP_LAMBDA; - lambda->args = args; - lambda->code = ao_lisp_cons_poly(code); - lambda->frame = ao_lisp_frame_mark(ao_lisp_frame_current); - DBGI("build frame: "); DBG_POLY(lambda->frame); DBG("\n"); - DBG_STACK(); - return ao_lisp_lambda_poly(lambda); -} - -ao_poly -ao_lisp_lambda(struct ao_lisp_cons *cons) -{ - return ao_lisp_lambda_alloc(cons, AO_LISP_FUNC_LAMBDA); -} - -ao_poly -ao_lisp_lexpr(struct ao_lisp_cons *cons) -{ - return ao_lisp_lambda_alloc(cons, AO_LISP_FUNC_LEXPR); -} - -ao_poly -ao_lisp_nlambda(struct ao_lisp_cons *cons) -{ - return ao_lisp_lambda_alloc(cons, AO_LISP_FUNC_NLAMBDA); -} - -ao_poly -ao_lisp_macro(struct ao_lisp_cons *cons) -{ - return ao_lisp_lambda_alloc(cons, AO_LISP_FUNC_MACRO); -} - -ao_poly -ao_lisp_lambda_eval(void) -{ - struct ao_lisp_lambda *lambda = ao_lisp_poly_lambda(ao_lisp_v); - struct ao_lisp_cons *cons = ao_lisp_poly_cons(ao_lisp_stack->values); - struct ao_lisp_cons *code = ao_lisp_poly_cons(lambda->code); - struct ao_lisp_cons *args = ao_lisp_poly_cons(ao_lisp_arg(code, 0)); - struct ao_lisp_frame *next_frame; - int args_wanted; - int args_provided; - int f; - struct ao_lisp_cons *vals; - - DBGI("lambda "); DBG_POLY(ao_lisp_lambda_poly(lambda)); DBG("\n"); - - args_wanted = ao_lisp_cons_length(args); - - /* Create a frame to hold the variables - */ - args_provided = ao_lisp_cons_length(cons) - 1; - if (lambda->args == AO_LISP_FUNC_LAMBDA) { - if (args_wanted != args_provided) - return ao_lisp_error(AO_LISP_INVALID, "need %d args, got %d", args_wanted, args_provided); - } else { - if (args_provided < args_wanted - 1) - return ao_lisp_error(AO_LISP_INVALID, "need at least %d args, got %d", args_wanted, args_provided); - } - - next_frame = ao_lisp_frame_new(args_wanted); - - /* Re-fetch all of the values in case something moved */ - lambda = ao_lisp_poly_lambda(ao_lisp_v); - cons = ao_lisp_poly_cons(ao_lisp_stack->values); - code = ao_lisp_poly_cons(lambda->code); - args = ao_lisp_poly_cons(ao_lisp_arg(code, 0)); - vals = ao_lisp_poly_cons(cons->cdr); - - next_frame->prev = lambda->frame; - ao_lisp_frame_current = next_frame; - ao_lisp_stack->frame = ao_lisp_frame_poly(ao_lisp_frame_current); - - switch (lambda->args) { - case AO_LISP_FUNC_LAMBDA: - for (f = 0; f < args_wanted; f++) { - DBGI("bind "); DBG_POLY(args->car); DBG(" = "); DBG_POLY(vals->car); DBG("\n"); - ao_lisp_frame_bind(next_frame, f, args->car, vals->car); - args = ao_lisp_poly_cons(args->cdr); - vals = ao_lisp_poly_cons(vals->cdr); - } - if (!ao_lisp_stack_marked(ao_lisp_stack)) - ao_lisp_cons_free(cons); - cons = NULL; - break; - case AO_LISP_FUNC_LEXPR: - case AO_LISP_FUNC_NLAMBDA: - case AO_LISP_FUNC_MACRO: - for (f = 0; f < args_wanted - 1; f++) { - DBGI("bind "); DBG_POLY(args->car); DBG(" = "); DBG_POLY(vals->car); DBG("\n"); - ao_lisp_frame_bind(next_frame, f, args->car, vals->car); - args = ao_lisp_poly_cons(args->cdr); - vals = ao_lisp_poly_cons(vals->cdr); - } - DBGI("bind "); DBG_POLY(args->car); DBG(" = "); DBG_POLY(ao_lisp_cons_poly(vals)); DBG("\n"); - ao_lisp_frame_bind(next_frame, f, args->car, ao_lisp_cons_poly(vals)); - break; - default: - break; - } - DBGI("eval frame: "); DBG_POLY(ao_lisp_frame_poly(next_frame)); DBG("\n"); - DBG_STACK(); - DBGI("eval code: "); DBG_POLY(code->cdr); DBG("\n"); - return code->cdr; -} diff --git a/src/lisp/ao_lisp_make_const.c b/src/lisp/ao_lisp_make_const.c deleted file mode 100644 index 49f989e6..00000000 --- a/src/lisp/ao_lisp_make_const.c +++ /dev/null @@ -1,423 +0,0 @@ -/* - * Copyright © 2016 Keith Packard <keithp@keithp.com> - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation, either version 2 of the License, or - * (at your option) any later version. - * - * This program is distributed in the hope that it will be useful, but - * WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU - * General Public License for more details. - */ - -#include "ao_lisp.h" -#include <stdlib.h> -#include <ctype.h> -#include <unistd.h> -#include <getopt.h> - -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[] = { - { .name = "eval", .args = AO_LISP_FUNC_F_LAMBDA, .func = builtin_eval }, - { .name = "read", .args = AO_LISP_FUNC_F_LAMBDA, .func = builtin_read }, - { .name = "lambda", .args = AO_LISP_FUNC_NLAMBDA, .func = builtin_lambda }, - { .name = "lexpr", .args = AO_LISP_FUNC_NLAMBDA, .func = builtin_lexpr }, - { .name = "nlambda", .args = AO_LISP_FUNC_NLAMBDA, .func = builtin_nlambda }, - { .name = "macro", .args = AO_LISP_FUNC_NLAMBDA, .func = builtin_macro }, - { .name = "car", .args = AO_LISP_FUNC_F_LAMBDA, .func = builtin_car }, - { .name = "cdr", .args = AO_LISP_FUNC_F_LAMBDA, .func = builtin_cdr }, - { .name = "cons", .args = AO_LISP_FUNC_F_LAMBDA, .func = builtin_cons }, - { .name = "last", .args = AO_LISP_FUNC_F_LAMBDA, .func = builtin_last }, - { .name = "length", .args = AO_LISP_FUNC_F_LAMBDA, .func = builtin_length }, - { .name = "quote", .args = AO_LISP_FUNC_NLAMBDA, .func = builtin_quote }, - { .name = "set", .args = AO_LISP_FUNC_F_LAMBDA, .func = builtin_set }, - { .name = "setq", .args = AO_LISP_FUNC_MACRO, .func = builtin_setq }, - { .name = "cond", .args = AO_LISP_FUNC_NLAMBDA, .func = builtin_cond }, - { .name = "progn", .args = AO_LISP_FUNC_NLAMBDA, .func = builtin_progn }, - { .name = "while", .args = AO_LISP_FUNC_NLAMBDA, .func = builtin_while }, - { .name = "print", .args = AO_LISP_FUNC_F_LEXPR, .func = builtin_print }, - { .name = "patom", .args = AO_LISP_FUNC_F_LEXPR, .func = builtin_patom }, - { .name = "+", .args = AO_LISP_FUNC_F_LEXPR, .func = builtin_plus }, - { .name = "-", .args = AO_LISP_FUNC_F_LEXPR, .func = builtin_minus }, - { .name = "*", .args = AO_LISP_FUNC_F_LEXPR, .func = builtin_times }, - { .name = "/", .args = AO_LISP_FUNC_F_LEXPR, .func = builtin_divide }, - { .name = "%", .args = AO_LISP_FUNC_F_LEXPR, .func = builtin_mod }, - { .name = "=", .args = AO_LISP_FUNC_F_LEXPR, .func = builtin_equal }, - { .name = "<", .args = AO_LISP_FUNC_F_LEXPR, .func = builtin_less }, - { .name = ">", .args = AO_LISP_FUNC_F_LEXPR, .func = builtin_greater }, - { .name = "<=", .args = AO_LISP_FUNC_F_LEXPR, .func = builtin_less_equal }, - { .name = ">=", .args = AO_LISP_FUNC_F_LEXPR, .func = builtin_greater_equal }, - { .name = "pack", .args = AO_LISP_FUNC_F_LAMBDA, .func = builtin_pack }, - { .name = "unpack", .args = AO_LISP_FUNC_F_LAMBDA, .func = builtin_unpack }, - { .name = "flush", .args = AO_LISP_FUNC_F_LAMBDA, .func = builtin_flush }, - { .name = "delay", .args = AO_LISP_FUNC_F_LAMBDA, .func = builtin_delay }, - { .name = "led", .args = AO_LISP_FUNC_F_LEXPR, .func = builtin_led }, - { .name = "save", .args = AO_LISP_FUNC_F_LAMBDA, .func = builtin_save }, - { .name = "restore", .args = AO_LISP_FUNC_F_LAMBDA, .func = builtin_restore }, - { .name = "call/cc", .args = AO_LISP_FUNC_F_LAMBDA, .func = builtin_call_cc }, - { .name = "collect", .args = AO_LISP_FUNC_F_LAMBDA, .func = builtin_collect }, -}; - -#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; -} - -#define AO_FEC_CRC_INIT 0xffff - -static inline uint16_t -ao_fec_crc_byte(uint8_t byte, uint16_t crc) -{ - uint8_t bit; - - for (bit = 0; bit < 8; bit++) { - if (((crc & 0x8000) >> 8) ^ (byte & 0x80)) - crc = (crc << 1) ^ 0x8005; - else - crc = (crc << 1); - byte <<= 1; - } - return crc; -} - -uint16_t -ao_fec_crc(const uint8_t *bytes, uint8_t len) -{ - uint16_t crc = AO_FEC_CRC_INIT; - - while (len--) - crc = ao_fec_crc_byte(*bytes++, crc); - return crc; -} - -struct ao_lisp_macro_stack { - struct ao_lisp_macro_stack *next; - ao_poly p; -}; - -struct ao_lisp_macro_stack *macro_stack; - -int -ao_lisp_macro_push(ao_poly p) -{ - struct ao_lisp_macro_stack *m = macro_stack; - - while (m) { - if (m->p == p) - return 1; - m = m->next; - } - m = malloc (sizeof (struct ao_lisp_macro_stack)); - m->p = p; - m->next = macro_stack; - macro_stack = m; - return 0; -} - -void -ao_lisp_macro_pop(void) -{ - struct ao_lisp_macro_stack *m = macro_stack; - - macro_stack = m->next; - free(m); -} - -#define DBG_MACRO 0 -#if DBG_MACRO -int macro_scan_depth; - -void indent(void) -{ - int i; - for (i = 0; i < macro_scan_depth; i++) - printf(" "); -} -#define MACRO_DEBUG(a) a -#else -#define MACRO_DEBUG(a) -#endif - -ao_poly -ao_has_macro(ao_poly p); - -ao_poly -ao_macro_test_get(ao_poly atom) -{ - ao_poly *ref = ao_lisp_atom_ref(ao_lisp_frame_global, atom); - if (ref) - return *ref; - return AO_LISP_NIL; -} - -ao_poly -ao_is_macro(ao_poly p) -{ - struct ao_lisp_builtin *builtin; - struct ao_lisp_lambda *lambda; - ao_poly ret; - - MACRO_DEBUG(indent(); printf ("is macro "); ao_lisp_poly_print(p); printf("\n"); ++macro_scan_depth); - switch (ao_lisp_poly_type(p)) { - case AO_LISP_ATOM: - if (ao_lisp_macro_push(p)) - ret = AO_LISP_NIL; - else { - if (ao_is_macro(ao_macro_test_get(p))) - ret = p; - else - ret = AO_LISP_NIL; - ao_lisp_macro_pop(); - } - break; - case AO_LISP_CONS: - ret = ao_has_macro(p); - break; - case AO_LISP_BUILTIN: - builtin = ao_lisp_poly_builtin(p); - if ((builtin->args & AO_LISP_FUNC_MASK) == AO_LISP_FUNC_MACRO) - ret = p; - else - ret = 0; - break; - - case AO_LISP_LAMBDA: - lambda = ao_lisp_poly_lambda(p); - if (lambda->args == AO_LISP_FUNC_MACRO) - ret = p; - else - ret = ao_has_macro(lambda->code); - break; - default: - ret = AO_LISP_NIL; - break; - } - MACRO_DEBUG(--macro_scan_depth; indent(); printf ("... "); ao_lisp_poly_print(ret); printf("\n")); - return ret; -} - -ao_poly -ao_has_macro(ao_poly p) -{ - struct ao_lisp_cons *cons; - struct ao_lisp_lambda *lambda; - ao_poly m; - - if (p == AO_LISP_NIL) - return AO_LISP_NIL; - - MACRO_DEBUG(indent(); printf("has macro "); ao_lisp_poly_print(p); printf("\n"); ++macro_scan_depth); - switch (ao_lisp_poly_type(p)) { - case AO_LISP_LAMBDA: - lambda = ao_lisp_poly_lambda(p); - p = ao_has_macro(lambda->code); - break; - case AO_LISP_CONS: - cons = ao_lisp_poly_cons(p); - if ((p = ao_is_macro(cons->car))) - break; - - cons = ao_lisp_poly_cons(cons->cdr); - p = AO_LISP_NIL; - while (cons) { - m = ao_has_macro(cons->car); - if (m) { - p = m; - break; - } - cons = ao_lisp_poly_cons(cons->cdr); - } - break; - - default: - p = AO_LISP_NIL; - break; - } - MACRO_DEBUG(--macro_scan_depth; indent(); printf("... "); ao_lisp_poly_print(p); printf("\n")); - return p; -} - -int -ao_lisp_read_eval_abort(void) -{ - ao_poly in, out = AO_LISP_NIL; - for(;;) { - in = ao_lisp_read(); - if (in == _ao_lisp_atom_eof) - break; - out = ao_lisp_eval(in); - if (ao_lisp_exception) - return 0; - ao_lisp_poly_print(out); - putchar ('\n'); - } - return 1; -} - -static FILE *in; -static FILE *out; - -int -ao_lisp_getc(void) -{ - return getc(in); -} - -static const struct option options[] = { - { .name = "out", .has_arg = 1, .val = 'o' }, - { 0, 0, 0, 0 } -}; - -static void usage(char *program) -{ - fprintf(stderr, "usage: %s [--out=<output>] [input]\n", program); - exit(1); -} - -int -main(int argc, char **argv) -{ - int f, o; - ao_poly val; - struct ao_lisp_atom *a; - struct ao_lisp_builtin *b; - int in_atom = 0; - char *out_name = NULL; - int c; - - in = stdin; - out = stdout; - - while ((c = getopt_long(argc, argv, "o:", options, NULL)) != -1) { - switch (c) { - case 'o': - out_name = optarg; - break; - default: - usage(argv[0]); - break; - } - } - - for (f = 0; f < (int) N_FUNC; f++) { - b = ao_lisp_make_builtin(funcs[f].func, funcs[f].args); - a = ao_lisp_atom_intern(funcs[f].name); - ao_lisp_atom_set(ao_lisp_atom_poly(a), - ao_lisp_builtin_poly(b)); - } - - /* boolean constants */ - ao_lisp_atom_set(ao_lisp_atom_poly(ao_lisp_atom_intern("nil")), - AO_LISP_NIL); - a = ao_lisp_atom_intern("t"); - ao_lisp_atom_set(ao_lisp_atom_poly(a), - ao_lisp_atom_poly(a)); - - /* end of file value */ - a = ao_lisp_atom_intern("eof"); - ao_lisp_atom_set(ao_lisp_atom_poly(a), - ao_lisp_atom_poly(a)); - - if (argv[optind]){ - in = fopen(argv[optind], "r"); - if (!in) { - perror(argv[optind]); - exit(1); - } - } - if (!ao_lisp_read_eval_abort()) { - fprintf(stderr, "eval failed\n"); - exit(1); - } - - /* Reduce to referenced values */ - ao_lisp_collect(AO_LISP_COLLECT_FULL); - - for (f = 0; f < ao_lisp_frame_global->num; f++) { - val = ao_has_macro(ao_lisp_frame_global->vals[f].val); - if (val != AO_LISP_NIL) { - printf("error: function %s contains unresolved macro: ", - ao_lisp_poly_atom(ao_lisp_frame_global->vals[f].atom)->name); - ao_lisp_poly_print(val); - printf("\n"); - exit(1); - } - } - - if (out_name) { - out = fopen(out_name, "w"); - if (!out) { - perror(out_name); - exit(1); - } - } - - fprintf(out, "/* Generated file, do not edit */\n\n"); - - fprintf(out, "#define AO_LISP_POOL_CONST %d\n", ao_lisp_top); - fprintf(out, "extern const uint8_t ao_lisp_const[AO_LISP_POOL_CONST] __attribute__((aligned(4)));\n"); - fprintf(out, "#define ao_builtin_atoms 0x%04x\n", ao_lisp_atom_poly(ao_lisp_atoms)); - fprintf(out, "#define ao_builtin_frame 0x%04x\n", ao_lisp_frame_poly(ao_lisp_frame_global)); - fprintf(out, "#define ao_lisp_const_checksum ((uint16_t) 0x%04x)\n", ao_fec_crc(ao_lisp_const, ao_lisp_top)); - - - for (a = ao_lisp_atoms; a; a = ao_lisp_poly_atom(a->next)) { - char *n = a->name, c; - fprintf(out, "#define _ao_lisp_atom_"); - while ((c = *n++)) { - if (isalnum(c)) - fprintf(out, "%c", c); - else - fprintf(out, "%02x", c); - } - fprintf(out, " 0x%04x\n", ao_lisp_atom_poly(a)); - } - fprintf(out, "#ifdef AO_LISP_CONST_BITS\n"); - fprintf(out, "const uint8_t ao_lisp_const[AO_LISP_POOL_CONST] __attribute((aligned(4))) = {"); - for (o = 0; o < ao_lisp_top; o++) { - uint8_t c; - if ((o & 0xf) == 0) - fprintf(out, "\n\t"); - else - fprintf(out, " "); - c = ao_lisp_const[o]; - if (!in_atom) - in_atom = is_atom(o); - if (in_atom) { - fprintf(out, " '%c',", c); - in_atom--; - } else { - fprintf(out, "0x%02x,", c); - } - } - fprintf(out, "\n};\n"); - fprintf(out, "#endif /* AO_LISP_CONST_BITS */\n"); - exit(0); -} diff --git a/src/lisp/ao_lisp_mem.c b/src/lisp/ao_lisp_mem.c deleted file mode 100644 index d067ea07..00000000 --- a/src/lisp/ao_lisp_mem.c +++ /dev/null @@ -1,880 +0,0 @@ -/* - * Copyright © 2016 Keith Packard <keithp@keithp.com> - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation, either version 2 of the License, or - * (at your option) any later version. - * - * This program is distributed in the hope that it will be useful, but - * WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU - * General Public License for more details. - */ - -#define AO_LISP_CONST_BITS - -#include "ao_lisp.h" -#include <stdio.h> - -#ifdef AO_LISP_MAKE_CONST - -/* - * When building the constant table, it is the - * pool for allocations. - */ - -#include <stdlib.h> -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 + AO_LISP_POOL_EXTRA] __attribute__((aligned(4))); - -#endif - -#ifndef DBG_MEM_STATS -#define DBG_MEM_STATS DBG_MEM -#endif - -#if DBG_MEM -int dbg_move_depth; -int dbg_mem = DBG_MEM_START; -int dbg_validate = 0; - -struct ao_lisp_record { - struct ao_lisp_record *next; - const struct ao_lisp_type *type; - void *addr; - int size; -}; - -static struct ao_lisp_record *record_head, **record_tail; - -static void -ao_lisp_record_free(struct ao_lisp_record *record) -{ - while (record) { - struct ao_lisp_record *next = record->next; - free(record); - record = next; - } -} - -static void -ao_lisp_record_reset(void) -{ - ao_lisp_record_free(record_head); - record_head = NULL; - record_tail = &record_head; -} - -static void -ao_lisp_record(const struct ao_lisp_type *type, - void *addr, - int size) -{ - struct ao_lisp_record *r = malloc(sizeof (struct ao_lisp_record)); - - r->next = NULL; - r->type = type; - r->addr = addr; - r->size = size; - *record_tail = r; - record_tail = &r->next; -} - -static struct ao_lisp_record * -ao_lisp_record_save(void) -{ - struct ao_lisp_record *r = record_head; - - record_head = NULL; - record_tail = &record_head; - return r; -} - -static void -ao_lisp_record_compare(char *where, - struct ao_lisp_record *a, - struct ao_lisp_record *b) -{ - while (a && b) { - if (a->type != b->type || a->size != b->size) { - printf("%s record difers %d %s %d -> %d %s %d\n", - where, - MDBG_OFFSET(a->addr), - a->type->name, - a->size, - MDBG_OFFSET(b->addr), - b->type->name, - b->size); - ao_lisp_abort(); - } - a = a->next; - b = b->next; - } - if (a) { - printf("%s record differs %d %s %d -> NULL\n", - where, - MDBG_OFFSET(a->addr), - a->type->name, - a->size); - ao_lisp_abort(); - } - if (b) { - printf("%s record differs NULL -> %d %s %d\n", - where, - MDBG_OFFSET(b->addr), - b->type->name, - b->size); - ao_lisp_abort(); - } -} - -#else -#define ao_lisp_record_reset() -#endif - -uint8_t ao_lisp_exception; - -struct ao_lisp_root { - const struct ao_lisp_type *type; - void **addr; -}; - -static struct ao_lisp_cons *save_cons[2]; -static char *save_string[2]; -static ao_poly save_poly[3]; - -static const struct ao_lisp_root ao_lisp_root[] = { - { - .type = &ao_lisp_cons_type, - .addr = (void **) &save_cons[0], - }, - { - .type = &ao_lisp_cons_type, - .addr = (void **) &save_cons[1], - }, - { - .type = &ao_lisp_string_type, - .addr = (void **) &save_string[0], - }, - { - .type = &ao_lisp_string_type, - .addr = (void **) &save_string[1], - }, - { - .type = NULL, - .addr = (void **) (void *) &save_poly[0] - }, - { - .type = NULL, - .addr = (void **) (void *) &save_poly[1] - }, - { - .type = NULL, - .addr = (void **) (void *) &save_poly[2] - }, - { - .type = &ao_lisp_atom_type, - .addr = (void **) &ao_lisp_atoms - }, - { - .type = &ao_lisp_frame_type, - .addr = (void **) &ao_lisp_frame_global, - }, - { - .type = &ao_lisp_frame_type, - .addr = (void **) &ao_lisp_frame_current, - }, - { - .type = &ao_lisp_stack_type, - .addr = (void **) &ao_lisp_stack, - }, - { - .type = NULL, - .addr = (void **) (void *) &ao_lisp_v, - }, - { - .type = &ao_lisp_cons_type, - .addr = (void **) &ao_lisp_read_cons, - }, - { - .type = &ao_lisp_cons_type, - .addr = (void **) &ao_lisp_read_cons_tail, - }, - { - .type = &ao_lisp_cons_type, - .addr = (void **) &ao_lisp_read_stack, - }, -}; - -#define AO_LISP_ROOT (sizeof (ao_lisp_root) / sizeof (ao_lisp_root[0])) - -static const void ** const ao_lisp_cache[] = { - (const void **) &ao_lisp_cons_free_list, - (const void **) &ao_lisp_stack_free_list, - (const void **) &ao_lisp_frame_free_list[0], - (const void **) &ao_lisp_frame_free_list[1], - (const void **) &ao_lisp_frame_free_list[2], - (const void **) &ao_lisp_frame_free_list[3], - (const void **) &ao_lisp_frame_free_list[4], - (const void **) &ao_lisp_frame_free_list[5], -}; - -#if AO_LISP_FRAME_FREE != 6 -#error Unexpected AO_LISP_FRAME_FREE value -#endif - -#define AO_LISP_CACHE (sizeof (ao_lisp_cache) / sizeof (ao_lisp_cache[0])) - -#define AO_LISP_BUSY_SIZE ((AO_LISP_POOL + 31) / 32) - -static uint8_t ao_lisp_busy[AO_LISP_BUSY_SIZE]; -static uint8_t ao_lisp_cons_note[AO_LISP_BUSY_SIZE]; -static uint8_t ao_lisp_cons_last[AO_LISP_BUSY_SIZE]; -static uint8_t ao_lisp_cons_noted; - -uint16_t ao_lisp_top; - -struct ao_lisp_chunk { - uint16_t old_offset; - union { - uint16_t size; - uint16_t new_offset; - }; -}; - -#define AO_LISP_NCHUNK 64 - -static struct ao_lisp_chunk ao_lisp_chunk[AO_LISP_NCHUNK]; - -/* Offset of an address within the pool. */ -static inline uint16_t pool_offset(void *addr) { -#if DBG_MEM - if (!AO_LISP_IS_POOL(addr)) - ao_lisp_abort(); -#endif - return ((uint8_t *) addr) - ao_lisp_pool; -} - -static inline void mark(uint8_t *tag, int offset) { - int byte = offset >> 5; - int bit = (offset >> 2) & 7; - tag[byte] |= (1 << bit); -} - -static inline void clear(uint8_t *tag, int offset) { - int byte = offset >> 5; - int bit = (offset >> 2) & 7; - tag[byte] &= ~(1 << bit); -} - -static inline int busy(uint8_t *tag, int offset) { - int byte = offset >> 5; - int bit = (offset >> 2) & 7; - return (tag[byte] >> bit) & 1; -} - -static inline int min(int a, int b) { return a < b ? a : b; } -static inline int max(int a, int b) { return a > b ? a : b; } - -static inline int limit(int offset) { - return min(AO_LISP_POOL, max(offset, 0)); -} - -static void -note_cons(uint16_t offset) -{ - MDBG_MOVE("note cons %d\n", offset); - ao_lisp_cons_noted = 1; - mark(ao_lisp_cons_note, offset); -} - -static uint16_t chunk_low, chunk_high; -static uint16_t chunk_first, chunk_last; - -static int -find_chunk(uint16_t offset) -{ - int l, r; - /* Binary search for the location */ - l = chunk_first; - r = chunk_last - 1; - while (l <= r) { - int m = (l + r) >> 1; - if (ao_lisp_chunk[m].old_offset < offset) - l = m + 1; - else - r = m - 1; - } - return l; -} - -static void -note_chunk(uint16_t offset, uint16_t size) -{ - int l; - - if (offset < chunk_low || chunk_high <= offset) - return; - - l = find_chunk(offset); - - /* - * The correct location is always in 'l', with r = l-1 being - * the entry before the right one - */ - -#if DBG_MEM - /* Off the right side */ - if (l >= AO_LISP_NCHUNK) - ao_lisp_abort(); - - /* Off the left side */ - if (l == 0 && chunk_last && offset > ao_lisp_chunk[0].old_offset) - ao_lisp_abort(); -#endif - - /* Shuffle existing entries right */ - int end = min(AO_LISP_NCHUNK, chunk_last + 1); - - memmove(&ao_lisp_chunk[l+1], - &ao_lisp_chunk[l], - (end - (l+1)) * sizeof (struct ao_lisp_chunk)); - - /* Add new entry */ - ao_lisp_chunk[l].old_offset = offset; - ao_lisp_chunk[l].size = size; - - /* Increment the number of elements up to the size of the array */ - if (chunk_last < AO_LISP_NCHUNK) - chunk_last++; - - /* Set the top address if the array is full */ - if (chunk_last == AO_LISP_NCHUNK) - chunk_high = ao_lisp_chunk[AO_LISP_NCHUNK-1].old_offset + - ao_lisp_chunk[AO_LISP_NCHUNK-1].size; -} - -static void -reset_chunks(void) -{ - chunk_high = ao_lisp_top; - chunk_last = 0; - chunk_first = 0; -} - -/* - * Walk all referenced objects calling functions on each one - */ - -static void -walk(int (*visit_addr)(const struct ao_lisp_type *type, void **addr), - int (*visit_poly)(ao_poly *p, uint8_t do_note_cons)) -{ - int i; - - ao_lisp_record_reset(); - memset(ao_lisp_busy, '\0', sizeof (ao_lisp_busy)); - memset(ao_lisp_cons_note, '\0', sizeof (ao_lisp_cons_note)); - ao_lisp_cons_noted = 0; - for (i = 0; i < (int) AO_LISP_ROOT; i++) { - if (ao_lisp_root[i].type) { - void **a = ao_lisp_root[i].addr, *v; - if (a && (v = *a)) { - MDBG_MOVE("root ptr %d\n", MDBG_OFFSET(v)); - visit_addr(ao_lisp_root[i].type, a); - } - } else { - ao_poly *a = (ao_poly *) ao_lisp_root[i].addr, p; - if (a && (p = *a)) { - MDBG_MOVE("root poly %d\n", MDBG_OFFSET(ao_lisp_ref(p))); - visit_poly(a, 0); - } - } - } - while (ao_lisp_cons_noted) { - memcpy(ao_lisp_cons_last, ao_lisp_cons_note, sizeof (ao_lisp_cons_note)); - memset(ao_lisp_cons_note, '\0', sizeof (ao_lisp_cons_note)); - ao_lisp_cons_noted = 0; - for (i = 0; i < AO_LISP_POOL; i += 4) { - if (busy(ao_lisp_cons_last, i)) { - void *v = ao_lisp_pool + i; - MDBG_MOVE("root cons %d\n", MDBG_OFFSET(v)); - visit_addr(&ao_lisp_cons_type, &v); - } - } - } -} - -#if MDBG_DUMP -static void -dump_busy(void) -{ - int i; - MDBG_MOVE("busy:"); - for (i = 0; i < ao_lisp_top; i += 4) { - if ((i & 0xff) == 0) { - MDBG_MORE("\n"); - MDBG_MOVE("%s", ""); - } - else if ((i & 0x1f) == 0) - MDBG_MORE(" "); - if (busy(ao_lisp_busy, i)) - MDBG_MORE("*"); - else - MDBG_MORE("-"); - } - MDBG_MORE ("\n"); -} -#define DUMP_BUSY() dump_busy() -#else -#define DUMP_BUSY() -#endif - -static const struct ao_lisp_type const *ao_lisp_types[AO_LISP_NUM_TYPE] = { - [AO_LISP_CONS] = &ao_lisp_cons_type, - [AO_LISP_INT] = NULL, - [AO_LISP_STRING] = &ao_lisp_string_type, - [AO_LISP_OTHER] = (void *) 0x1, - [AO_LISP_ATOM] = &ao_lisp_atom_type, - [AO_LISP_BUILTIN] = &ao_lisp_builtin_type, - [AO_LISP_FRAME] = &ao_lisp_frame_type, - [AO_LISP_LAMBDA] = &ao_lisp_lambda_type, - [AO_LISP_STACK] = &ao_lisp_stack_type, -}; - -static int -ao_lisp_mark_ref(const struct ao_lisp_type *type, void **ref) -{ - return ao_lisp_mark(type, *ref); -} - -static int -ao_lisp_poly_mark_ref(ao_poly *p, uint8_t do_note_cons) -{ - return ao_lisp_poly_mark(*p, do_note_cons); -} - -#if DBG_MEM_STATS -int ao_lisp_collects[2]; -int ao_lisp_freed[2]; -int ao_lisp_loops[2]; -#endif - -int ao_lisp_last_top; - -int -ao_lisp_collect(uint8_t style) -{ - int i; - int top; -#if DBG_MEM_STATS - int loops = 0; -#endif -#if DBG_MEM - struct ao_lisp_record *mark_record = NULL, *move_record = NULL; - - MDBG_MOVE("collect %d\n", ao_lisp_collects[style]); -#endif - - /* The first time through, we're doing a full collect */ - if (ao_lisp_last_top == 0) - style = AO_LISP_COLLECT_FULL; - - /* Clear references to all caches */ - for (i = 0; i < (int) AO_LISP_CACHE; i++) - *ao_lisp_cache[i] = NULL; - if (style == AO_LISP_COLLECT_FULL) { - chunk_low = top = 0; - } else { - chunk_low = top = ao_lisp_last_top; - } - for (;;) { -#if DBG_MEM_STATS - loops++; -#endif - MDBG_MOVE("move chunks from %d to %d\n", chunk_low, top); - /* Find the sizes of the first chunk of objects to move */ - reset_chunks(); - walk(ao_lisp_mark_ref, ao_lisp_poly_mark_ref); -#if DBG_MEM - - ao_lisp_record_free(mark_record); - mark_record = ao_lisp_record_save(); - if (mark_record && move_record) - ao_lisp_record_compare("mark", move_record, mark_record); -#endif - - DUMP_BUSY(); - - /* Find the first moving object */ - for (i = 0; i < chunk_last; i++) { - uint16_t size = ao_lisp_chunk[i].size; - -#if DBG_MEM - if (!size) - ao_lisp_abort(); -#endif - - if (ao_lisp_chunk[i].old_offset > top) - break; - - MDBG_MOVE("chunk %d %d not moving\n", - ao_lisp_chunk[i].old_offset, - ao_lisp_chunk[i].size); -#if DBG_MEM - if (ao_lisp_chunk[i].old_offset != top) - ao_lisp_abort(); -#endif - top += size; - } - - /* - * Limit amount of chunk array used in mapping moves - * to the active region - */ - chunk_first = i; - chunk_low = ao_lisp_chunk[i].old_offset; - - /* Copy all of the objects */ - for (; i < chunk_last; i++) { - uint16_t size = ao_lisp_chunk[i].size; - -#if DBG_MEM - if (!size) - ao_lisp_abort(); -#endif - - MDBG_MOVE("chunk %d %d -> %d\n", - ao_lisp_chunk[i].old_offset, - size, - top); - ao_lisp_chunk[i].new_offset = top; - - memmove(&ao_lisp_pool[top], - &ao_lisp_pool[ao_lisp_chunk[i].old_offset], - size); - - top += size; - } - - if (chunk_first < chunk_last) { - /* Relocate all references to the objects */ - walk(ao_lisp_move, ao_lisp_poly_move); - -#if DBG_MEM - ao_lisp_record_free(move_record); - move_record = ao_lisp_record_save(); - if (mark_record && move_record) - ao_lisp_record_compare("move", mark_record, move_record); -#endif - } - - /* If we ran into the end of the heap, then - * there's no need to keep walking - */ - if (chunk_last != AO_LISP_NCHUNK) - break; - - /* Next loop starts right above this loop */ - chunk_low = chunk_high; - } - -#if DBG_MEM_STATS - /* Collect stats */ - ++ao_lisp_collects[style]; - ao_lisp_freed[style] += ao_lisp_top - top; - ao_lisp_loops[style] += loops; -#endif - - ao_lisp_top = top; - if (style == AO_LISP_COLLECT_FULL) - ao_lisp_last_top = top; - - MDBG_DO(memset(ao_lisp_chunk, '\0', sizeof (ao_lisp_chunk)); - walk(ao_lisp_mark_ref, ao_lisp_poly_mark_ref)); - - return AO_LISP_POOL - ao_lisp_top; -} - -/* - * Mark interfaces for objects - */ - -/* - * Note a reference to memory and collect information about a few - * object sizes at a time - */ - -int -ao_lisp_mark_memory(const struct ao_lisp_type *type, void *addr) -{ - int offset; - if (!AO_LISP_IS_POOL(addr)) - return 1; - - offset = pool_offset(addr); - MDBG_MOVE("mark memory %d\n", MDBG_OFFSET(addr)); - if (busy(ao_lisp_busy, offset)) { - MDBG_MOVE("already marked\n"); - return 1; - } - mark(ao_lisp_busy, offset); - note_chunk(offset, ao_lisp_size(type, addr)); - return 0; -} - -/* - * Mark an object and all that it refereces - */ -int -ao_lisp_mark(const struct ao_lisp_type *type, void *addr) -{ - int ret; - MDBG_MOVE("mark %d\n", MDBG_OFFSET(addr)); - MDBG_MOVE_IN(); - ret = ao_lisp_mark_memory(type, addr); - if (!ret) { - MDBG_MOVE("mark recurse\n"); - type->mark(addr); - } - MDBG_MOVE_OUT(); - return ret; -} - -/* - * Mark an object, unless it is a cons cell and - * do_note_cons is set. In that case, just - * set a bit in the cons note array; those - * will be marked in a separate pass to avoid - * deep recursion in the collector - */ -int -ao_lisp_poly_mark(ao_poly p, uint8_t do_note_cons) -{ - uint8_t type; - void *addr; - - type = ao_lisp_poly_base_type(p); - - if (type == AO_LISP_INT) - return 1; - - addr = ao_lisp_ref(p); - if (!AO_LISP_IS_POOL(addr)) - return 1; - - if (type == AO_LISP_CONS && do_note_cons) { - note_cons(pool_offset(addr)); - return 1; - } else { - if (type == AO_LISP_OTHER) - type = ao_lisp_other_type(addr); - - const struct ao_lisp_type *lisp_type = ao_lisp_types[type]; -#if DBG_MEM - if (!lisp_type) - ao_lisp_abort(); -#endif - - return ao_lisp_mark(lisp_type, addr); - } -} - -/* - * Find the current location of an object - * based on the original location. For unmoved - * objects, this is simple. For moved objects, - * go search for it - */ - -static uint16_t -move_map(uint16_t offset) -{ - int l; - - if (offset < chunk_low || chunk_high <= offset) - return offset; - - l = find_chunk(offset); - -#if DBG_MEM - if (ao_lisp_chunk[l].old_offset != offset) - ao_lisp_abort(); -#endif - return ao_lisp_chunk[l].new_offset; -} - -int -ao_lisp_move_memory(const struct ao_lisp_type *type, void **ref) -{ - void *addr = *ref; - uint16_t offset, orig_offset; - - if (!AO_LISP_IS_POOL(addr)) - return 1; - - (void) type; - - MDBG_MOVE("move memory %d\n", MDBG_OFFSET(addr)); - orig_offset = pool_offset(addr); - offset = move_map(orig_offset); - if (offset != orig_offset) { - MDBG_MOVE("update ref %d %d -> %d\n", - AO_LISP_IS_POOL(ref) ? MDBG_OFFSET(ref) : -1, - orig_offset, offset); - *ref = ao_lisp_pool + offset; - } - if (busy(ao_lisp_busy, offset)) { - MDBG_MOVE("already moved\n"); - return 1; - } - mark(ao_lisp_busy, offset); - MDBG_DO(ao_lisp_record(type, addr, ao_lisp_size(type, addr))); - return 0; -} - -int -ao_lisp_move(const struct ao_lisp_type *type, void **ref) -{ - int ret; - MDBG_MOVE("move object %d\n", MDBG_OFFSET(*ref)); - MDBG_MOVE_IN(); - ret = ao_lisp_move_memory(type, ref); - if (!ret) { - MDBG_MOVE("move recurse\n"); - type->move(*ref); - } - MDBG_MOVE_OUT(); - return ret; -} - -int -ao_lisp_poly_move(ao_poly *ref, uint8_t do_note_cons) -{ - uint8_t type; - ao_poly p = *ref; - int ret; - void *addr; - uint16_t offset, orig_offset; - uint8_t base_type; - - base_type = type = ao_lisp_poly_base_type(p); - - if (type == AO_LISP_INT) - return 1; - - addr = ao_lisp_ref(p); - if (!AO_LISP_IS_POOL(addr)) - return 1; - - orig_offset = pool_offset(addr); - offset = move_map(orig_offset); - - if (type == AO_LISP_CONS && do_note_cons) { - note_cons(orig_offset); - ret = 1; - } else { - if (type == AO_LISP_OTHER) - type = ao_lisp_other_type(ao_lisp_pool + offset); - - const struct ao_lisp_type *lisp_type = ao_lisp_types[type]; -#if DBG_MEM - if (!lisp_type) - ao_lisp_abort(); -#endif - - ret = ao_lisp_move(lisp_type, &addr); - } - - /* Re-write the poly value */ - if (offset != orig_offset) { - ao_poly np = ao_lisp_poly(ao_lisp_pool + offset, base_type); - MDBG_MOVE("poly %d moved %d -> %d\n", - type, orig_offset, offset); - *ref = np; - } - return ret; -} - -#if DBG_MEM -void -ao_lisp_validate(void) -{ - chunk_low = 0; - memset(ao_lisp_chunk, '\0', sizeof (ao_lisp_chunk)); - walk(ao_lisp_mark_ref, ao_lisp_poly_mark_ref); -} - -int dbg_allocs; - -#endif - -void * -ao_lisp_alloc(int size) -{ - void *addr; - - MDBG_DO(++dbg_allocs); - MDBG_DO(if (dbg_validate) ao_lisp_validate()); - size = ao_lisp_size_round(size); - if (AO_LISP_POOL - ao_lisp_top < size && - ao_lisp_collect(AO_LISP_COLLECT_INCREMENTAL) < size && - ao_lisp_collect(AO_LISP_COLLECT_FULL) < size) - { - ao_lisp_error(AO_LISP_OOM, "out of memory"); - return NULL; - } - addr = ao_lisp_pool + ao_lisp_top; - ao_lisp_top += size; - return addr; -} - -void -ao_lisp_cons_stash(int id, struct ao_lisp_cons *cons) -{ - save_cons[id] = cons; -} - -struct ao_lisp_cons * -ao_lisp_cons_fetch(int id) -{ - struct ao_lisp_cons *cons = save_cons[id]; - save_cons[id] = NULL; - return cons; -} - -void -ao_lisp_poly_stash(int id, ao_poly poly) -{ - save_poly[id] = poly; -} - -ao_poly -ao_lisp_poly_fetch(int id) -{ - ao_poly poly = save_poly[id]; - save_poly[id] = AO_LISP_NIL; - return poly; -} - -void -ao_lisp_string_stash(int id, char *string) -{ - save_string[id] = string; -} - -char * -ao_lisp_string_fetch(int id) -{ - char *string = save_string[id]; - save_string[id] = NULL; - return string; -} - diff --git a/src/lisp/ao_lisp_poly.c b/src/lisp/ao_lisp_poly.c deleted file mode 100644 index fb3b06fe..00000000 --- a/src/lisp/ao_lisp_poly.c +++ /dev/null @@ -1,102 +0,0 @@ -/* - * Copyright © 2016 Keith Packard <keithp@keithp.com> - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation, either version 2 of the License, or - * (at your option) any later version. - * - * This program is distributed in the hope that it will be useful, but - * WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU - * General Public License for more details. - */ - -#include "ao_lisp.h" - -struct ao_lisp_funcs { - void (*print)(ao_poly); - void (*patom)(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, - }, - [AO_LISP_FRAME] = { - .print = ao_lisp_frame_print, - .patom = ao_lisp_frame_print, - }, - [AO_LISP_LAMBDA] = { - .print = ao_lisp_lambda_print, - .patom = ao_lisp_lambda_print, - }, - [AO_LISP_STACK] = { - .print = ao_lisp_stack_print, - .patom = ao_lisp_stack_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) -{ - 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); -} - -void * -ao_lisp_ref(ao_poly poly) { - if (poly == AO_LISP_NIL) - return NULL; - if (poly & AO_LISP_CONST) - return (void *) (ao_lisp_const + (poly & AO_LISP_REF_MASK) - 4); - return (void *) (ao_lisp_pool + (poly & AO_LISP_REF_MASK) - 4); -} - -ao_poly -ao_lisp_poly(const void *addr, ao_poly type) { - const uint8_t *a = addr; - if (a == NULL) - return AO_LISP_NIL; - if (AO_LISP_IS_CONST(a)) - return AO_LISP_CONST | (a - ao_lisp_const + 4) | type; - return (a - ao_lisp_pool + 4) | type; -} diff --git a/src/lisp/ao_lisp_read.c b/src/lisp/ao_lisp_read.c deleted file mode 100644 index 84ef2a61..00000000 --- a/src/lisp/ao_lisp_read.c +++ /dev/null @@ -1,498 +0,0 @@ -/* - * Copyright © 2016 Keith Packard <keithp@keithp.com> - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation, either version 2 of the License, or - * (at your option) any later version. - * - * This program is distributed in the hope that it will be useful, but - * WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU - * General Public License for more details. - */ - -#include "ao_lisp.h" -#include "ao_lisp_read.h" - -static const uint16_t lex_classes[128] = { - IGNORE, /* ^@ */ - IGNORE, /* ^A */ - IGNORE, /* ^B */ - IGNORE, /* ^C */ - IGNORE, /* ^D */ - IGNORE, /* ^E */ - IGNORE, /* ^F */ - IGNORE, /* ^G */ - IGNORE, /* ^H */ - WHITE, /* ^I */ - WHITE, /* ^J */ - WHITE, /* ^K */ - WHITE, /* ^L */ - WHITE, /* ^M */ - IGNORE, /* ^N */ - IGNORE, /* ^O */ - IGNORE, /* ^P */ - IGNORE, /* ^Q */ - IGNORE, /* ^R */ - IGNORE, /* ^S */ - IGNORE, /* ^T */ - IGNORE, /* ^U */ - IGNORE, /* ^V */ - IGNORE, /* ^W */ - IGNORE, /* ^X */ - IGNORE, /* ^Y */ - IGNORE, /* ^Z */ - IGNORE, /* ^[ */ - IGNORE, /* ^\ */ - IGNORE, /* ^] */ - IGNORE, /* ^^ */ - IGNORE, /* ^_ */ - PRINTABLE|WHITE, /* */ - PRINTABLE, /* ! */ - PRINTABLE|STRINGC, /* " */ - PRINTABLE|COMMENT, /* # */ - PRINTABLE, /* $ */ - PRINTABLE, /* % */ - PRINTABLE, /* & */ - PRINTABLE|QUOTEC, /* ' */ - PRINTABLE|BRA, /* ( */ - PRINTABLE|KET, /* ) */ - PRINTABLE, /* * */ - PRINTABLE|SIGN, /* + */ - PRINTABLE, /* , */ - PRINTABLE|SIGN, /* - */ - PRINTABLE, /* . */ - PRINTABLE, /* / */ - PRINTABLE|DIGIT, /* 0 */ - PRINTABLE|DIGIT, /* 1 */ - PRINTABLE|DIGIT, /* 2 */ - PRINTABLE|DIGIT, /* 3 */ - PRINTABLE|DIGIT, /* 4 */ - PRINTABLE|DIGIT, /* 5 */ - PRINTABLE|DIGIT, /* 6 */ - PRINTABLE|DIGIT, /* 7 */ - PRINTABLE|DIGIT, /* 8 */ - PRINTABLE|DIGIT, /* 9 */ - PRINTABLE, /* : */ - PRINTABLE|COMMENT, /* ; */ - PRINTABLE, /* < */ - PRINTABLE, /* = */ - PRINTABLE, /* > */ - PRINTABLE, /* ? */ - PRINTABLE, /* @ */ - PRINTABLE, /* A */ - PRINTABLE, /* B */ - PRINTABLE, /* C */ - PRINTABLE, /* D */ - PRINTABLE, /* E */ - PRINTABLE, /* F */ - PRINTABLE, /* G */ - PRINTABLE, /* H */ - PRINTABLE, /* I */ - PRINTABLE, /* J */ - PRINTABLE, /* K */ - PRINTABLE, /* L */ - PRINTABLE, /* M */ - PRINTABLE, /* N */ - PRINTABLE, /* O */ - PRINTABLE, /* P */ - PRINTABLE, /* Q */ - PRINTABLE, /* R */ - PRINTABLE, /* S */ - PRINTABLE, /* T */ - PRINTABLE, /* U */ - PRINTABLE, /* V */ - PRINTABLE, /* W */ - PRINTABLE, /* X */ - PRINTABLE, /* Y */ - PRINTABLE, /* Z */ - PRINTABLE, /* [ */ - PRINTABLE|BACKSLASH, /* \ */ - PRINTABLE, /* ] */ - PRINTABLE, /* ^ */ - PRINTABLE, /* _ */ - PRINTABLE, /* ` */ - PRINTABLE, /* a */ - PRINTABLE, /* b */ - PRINTABLE, /* c */ - PRINTABLE, /* d */ - PRINTABLE, /* e */ - PRINTABLE, /* f */ - PRINTABLE, /* g */ - PRINTABLE, /* h */ - PRINTABLE, /* i */ - PRINTABLE, /* j */ - PRINTABLE, /* k */ - PRINTABLE, /* l */ - PRINTABLE, /* m */ - PRINTABLE, /* n */ - PRINTABLE, /* o */ - PRINTABLE, /* p */ - PRINTABLE, /* q */ - PRINTABLE, /* r */ - PRINTABLE, /* s */ - PRINTABLE, /* t */ - PRINTABLE, /* u */ - PRINTABLE, /* v */ - PRINTABLE, /* w */ - PRINTABLE, /* x */ - PRINTABLE, /* y */ - PRINTABLE, /* z */ - PRINTABLE, /* { */ - PRINTABLE|VBAR, /* | */ - PRINTABLE, /* } */ - PRINTABLE|TWIDDLE, /* ~ */ - IGNORE, /* ^? */ -}; - -static int lex_unget_c; - -static inline int -lex_get() -{ - int c; - if (lex_unget_c) { - c = lex_unget_c; - lex_unget_c = 0; - } else { - c = ao_lisp_getc(); - } - return c; -} - -static inline void -lex_unget(int c) -{ - if (c != EOF) - lex_unget_c = c; -} - -static int -lex_quoted (void) -{ - int c; - int v; - int count; - - c = lex_get(); - if (c == EOF) - return EOF; - c &= 0x7f; - switch (c) { - case 'n': - return '\n'; - case 'f': - return '\f'; - case 'b': - return '\b'; - case 'r': - return '\r'; - case 'v': - return '\v'; - case 't': - return '\t'; - case '0': - case '1': - case '2': - case '3': - case '4': - case '5': - case '6': - case '7': - v = c - '0'; - count = 1; - while (count <= 3) { - c = lex_get(); - if (c == EOF) - return EOF; - c &= 0x7f; - if (c < '0' || '7' < c) { - lex_unget(c); - break; - } - v = (v << 3) + c - '0'; - ++count; - } - return v; - default: - return c; - } -} - -static uint16_t lex_class; - -static int -lexc(void) -{ - int c; - do { - c = lex_get(); - if (c == EOF) { - lex_class = ENDOFFILE; - c = 0; - } else { - c &= 0x7f; - lex_class = lex_classes[c]; - if (lex_class & BACKSLASH) { - c = lex_quoted(); - if (c == EOF) - lex_class = ENDOFFILE; - else - lex_class = PRINTABLE; - } - } - } while (lex_class & IGNORE); - return c; -} - -#define AO_LISP_TOKEN_MAX 32 - -static char token_string[AO_LISP_TOKEN_MAX]; -static int token_int; -static int token_len; - -static inline void add_token(int c) { - if (c && token_len < AO_LISP_TOKEN_MAX - 1) - token_string[token_len++] = c; -} - -static inline void end_token(void) { - token_string[token_len] = '\0'; -} - -static int -lex(void) -{ - int c; - - token_len = 0; - for (;;) { - c = lexc(); - if (lex_class & ENDOFFILE) - return END; - - if (lex_class & WHITE) - continue; - - if (lex_class & COMMENT) { - while ((c = lexc()) != '\n') { - if (lex_class & ENDOFFILE) - return END; - } - continue; - } - - if (lex_class & (BRA|KET|QUOTEC)) { - add_token(c); - end_token(); - switch (c) { - case '(': - return OPEN; - case ')': - return CLOSE; - case '\'': - return QUOTE; - } - } - if (lex_class & TWIDDLE) { - token_int = lexc(); - return NUM; - } - if (lex_class & STRINGC) { - for (;;) { - c = lexc(); - if (lex_class & (STRINGC|ENDOFFILE)) { - end_token(); - return STRING; - } - add_token(c); - } - } - if (lex_class & PRINTABLE) { - int isnum; - int hasdigit; - int isneg; - - isnum = 1; - hasdigit = 0; - token_int = 0; - isneg = 0; - for (;;) { - if (!(lex_class & NUMBER)) { - isnum = 0; - } else { - if (token_len != 0 && - (lex_class & SIGN)) - { - isnum = 0; - } - if (c == '-') - isneg = 1; - if (lex_class & DIGIT) { - hasdigit = 1; - if (isnum) - token_int = token_int * 10 + c - '0'; - } - } - add_token (c); - c = lexc (); - if (lex_class & (NOTNAME)) { -// if (lex_class & ENDOFFILE) -// clearerr (f); - lex_unget(c); - end_token (); - if (isnum && hasdigit) { - if (isneg) - token_int = -token_int; - return NUM; - } - return NAME; - } - } - - } - } -} - -static int parse_token; - -struct ao_lisp_cons *ao_lisp_read_cons; -struct ao_lisp_cons *ao_lisp_read_cons_tail; -struct ao_lisp_cons *ao_lisp_read_stack; - -static int -push_read_stack(int cons, int in_quote) -{ - DBGI("push read stack %p %d\n", ao_lisp_read_cons, in_quote); - DBG_IN(); - if (cons) { - ao_lisp_read_stack = ao_lisp_cons_cons(ao_lisp_cons_poly(ao_lisp_read_cons), - ao_lisp_cons_cons(ao_lisp_int_poly(in_quote), - ao_lisp_read_stack)); - if (!ao_lisp_read_stack) - return 0; - } - ao_lisp_read_cons = NULL; - ao_lisp_read_cons_tail = NULL; - return 1; -} - -static int -pop_read_stack(int cons) -{ - int in_quote = 0; - if (cons) { - ao_lisp_read_cons = ao_lisp_poly_cons(ao_lisp_read_stack->car); - ao_lisp_read_stack = ao_lisp_poly_cons(ao_lisp_read_stack->cdr); - in_quote = ao_lisp_poly_int(ao_lisp_read_stack->car); - ao_lisp_read_stack = ao_lisp_poly_cons(ao_lisp_read_stack->cdr); - for (ao_lisp_read_cons_tail = ao_lisp_read_cons; - ao_lisp_read_cons_tail && ao_lisp_read_cons_tail->cdr; - ao_lisp_read_cons_tail = ao_lisp_poly_cons(ao_lisp_read_cons_tail->cdr)) - ; - } else { - ao_lisp_read_cons = 0; - ao_lisp_read_cons_tail = 0; - ao_lisp_read_stack = 0; - } - DBG_OUT(); - DBGI("pop read stack %p %d\n", ao_lisp_read_cons, in_quote); - return in_quote; -} - -ao_poly -ao_lisp_read(void) -{ - struct ao_lisp_atom *atom; - char *string; - int cons; - int in_quote; - ao_poly v; - - parse_token = lex(); - DBGI("token %d (%s)\n", parse_token, token_string); - - cons = 0; - in_quote = 0; - ao_lisp_read_cons = ao_lisp_read_cons_tail = ao_lisp_read_stack = 0; - for (;;) { - while (parse_token == OPEN) { - if (!push_read_stack(cons, in_quote)) - return AO_LISP_NIL; - cons++; - in_quote = 0; - parse_token = lex(); - DBGI("token %d (%s)\n", parse_token, token_string); - } - - switch (parse_token) { - case END: - default: - if (cons) - ao_lisp_error(AO_LISP_EOF, "unexpected end of file"); - return _ao_lisp_atom_eof; - break; - case NAME: - atom = ao_lisp_atom_intern(token_string); - if (atom) - v = ao_lisp_atom_poly(atom); - else - v = AO_LISP_NIL; - break; - case NUM: - v = ao_lisp_int_poly(token_int); - break; - case STRING: - string = ao_lisp_string_copy(token_string); - if (string) - v = ao_lisp_string_poly(string); - else - v = AO_LISP_NIL; - break; - case QUOTE: - if (!push_read_stack(cons, in_quote)) - return AO_LISP_NIL; - cons++; - in_quote = 1; - v = _ao_lisp_atom_quote; - break; - case CLOSE: - if (!cons) { - v = AO_LISP_NIL; - break; - } - v = ao_lisp_cons_poly(ao_lisp_read_cons); - --cons; - in_quote = pop_read_stack(cons); - break; - } - - /* loop over QUOTE ends */ - for (;;) { - if (!cons) - return v; - - struct ao_lisp_cons *read = ao_lisp_cons_cons(v, NULL); - if (!read) - return AO_LISP_NIL; - - if (ao_lisp_read_cons_tail) - ao_lisp_read_cons_tail->cdr = ao_lisp_cons_poly(read); - else - ao_lisp_read_cons = read; - ao_lisp_read_cons_tail = read; - - if (!in_quote || !ao_lisp_read_cons->cdr) - break; - - v = ao_lisp_cons_poly(ao_lisp_read_cons); - --cons; - in_quote = pop_read_stack(cons); - } - - parse_token = lex(); - DBGI("token %d (%s)\n", parse_token, token_string); - } - return v; -} diff --git a/src/lisp/ao_lisp_read.h b/src/lisp/ao_lisp_read.h deleted file mode 100644 index 1c994d56..00000000 --- a/src/lisp/ao_lisp_read.h +++ /dev/null @@ -1,49 +0,0 @@ -/* - * Copyright © 2016 Keith Packard <keithp@keithp.com> - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation, either version 2 of the License, or - * (at your option) any later version. - * - * This program is distributed in the hope that it will be useful, but - * WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU - * General Public License for more details. - */ - -#ifndef _AO_LISP_READ_H_ -#define _AO_LISP_READ_H_ - -# define END 0 -# define NAME 1 -# define OPEN 2 -# define CLOSE 3 -# define QUOTE 4 -# define STRING 5 -# define NUM 6 - -/* - * character classes - */ - -# define PRINTABLE 0x00000001 /* \t \n ' ' - '~' */ -# define QUOTED 0x00000002 /* \ anything */ -# define BRA 0x00000004 /* ( [ { */ -# define KET 0x00000008 /* ) ] } */ -# define WHITE 0x00000010 /* ' ' \t \n */ -# define DIGIT 0x00000020 /* [0-9] */ -# define SIGN 0x00000040 /* +- */ -# define ENDOFFILE 0x00000080 /* end of file */ -# define COMMENT 0x00000100 /* ; # */ -# define IGNORE 0x00000200 /* \0 - ' ' */ -# define QUOTEC 0x00000400 /* ' */ -# define BACKSLASH 0x00000800 /* \ */ -# define VBAR 0x00001000 /* | */ -# define TWIDDLE 0x00002000 /* ~ */ -# define STRINGC 0x00004000 /* " */ - -# define NOTNAME (STRINGC|TWIDDLE|VBAR|QUOTEC|COMMENT|ENDOFFILE|WHITE|KET|BRA) -# define NUMBER (DIGIT|SIGN) - -#endif /* _AO_LISP_READ_H_ */ diff --git a/src/lisp/ao_lisp_save.c b/src/lisp/ao_lisp_save.c deleted file mode 100644 index 4f850fb9..00000000 --- a/src/lisp/ao_lisp_save.c +++ /dev/null @@ -1,76 +0,0 @@ -/* - * Copyright © 2016 Keith Packard <keithp@keithp.com> - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation, either version 2 of the License, or - * (at your option) any later version. - * - * This program is distributed in the hope that it will be useful, but - * WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU - * General Public License for more details. - */ - -#include <ao_lisp.h> - -ao_poly -ao_lisp_save(struct ao_lisp_cons *cons) -{ - if (!ao_lisp_check_argc(_ao_lisp_atom_save, cons, 0, 0)) - return AO_LISP_NIL; - -#ifdef AO_LISP_SAVE - struct ao_lisp_os_save *os = (struct ao_lisp_os_save *) (void *) &ao_lisp_pool[AO_LISP_POOL]; - - ao_lisp_collect(AO_LISP_COLLECT_FULL); - os->atoms = ao_lisp_atom_poly(ao_lisp_atoms); - os->globals = ao_lisp_frame_poly(ao_lisp_frame_global); - os->const_checksum = ao_lisp_const_checksum; - os->const_checksum_inv = (uint16_t) ~ao_lisp_const_checksum; - - if (ao_lisp_os_save()) - return _ao_lisp_atom_t; -#endif - return AO_LISP_NIL; -} - -ao_poly -ao_lisp_restore(struct ao_lisp_cons *cons) -{ - if (!ao_lisp_check_argc(_ao_lisp_atom_save, cons, 0, 0)) - return AO_LISP_NIL; - -#ifdef AO_LISP_SAVE - struct ao_lisp_os_save save; - struct ao_lisp_os_save *os = (struct ao_lisp_os_save *) (void *) &ao_lisp_pool[AO_LISP_POOL]; - - if (!ao_lisp_os_restore_save(&save, AO_LISP_POOL)) - return ao_lisp_error(AO_LISP_INVALID, "header restore failed"); - - if (save.const_checksum != ao_lisp_const_checksum || - save.const_checksum_inv != (uint16_t) ~ao_lisp_const_checksum) - { - return ao_lisp_error(AO_LISP_INVALID, "image is corrupted or stale"); - } - - if (ao_lisp_os_restore()) { - - ao_lisp_atoms = ao_lisp_poly_atom(os->atoms); - ao_lisp_frame_global = ao_lisp_poly_frame(os->globals); - - /* Clear the eval global variabls */ - ao_lisp_eval_clear_globals(); - - /* Reset the allocator */ - ao_lisp_top = AO_LISP_POOL; - ao_lisp_collect(AO_LISP_COLLECT_FULL); - - /* Re-create the evaluator stack */ - if (!ao_lisp_eval_restart()) - return AO_LISP_NIL; - return _ao_lisp_atom_t; - } -#endif - return AO_LISP_NIL; -} diff --git a/src/lisp/ao_lisp_stack.c b/src/lisp/ao_lisp_stack.c deleted file mode 100644 index 53adf432..00000000 --- a/src/lisp/ao_lisp_stack.c +++ /dev/null @@ -1,278 +0,0 @@ -/* - * Copyright © 2016 Keith Packard <keithp@keithp.com> - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation, either version 2 of the License, or - * (at your option) any later version. - * - * This program is distributed in the hope that it will be useful, but - * WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU - * General Public License for more details. - */ - -#include "ao_lisp.h" - -const struct ao_lisp_type ao_lisp_stack_type; - -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->sexprs, 0); - ao_lisp_poly_mark(stack->values, 0); - /* no need to mark values_tail */ - ao_lisp_poly_mark(stack->frame, 0); - ao_lisp_poly_mark(stack->list, 0); - stack = ao_lisp_poly_stack(stack->prev); - if (ao_lisp_mark_memory(&ao_lisp_stack_type, stack)) - break; - } -} - -static void -stack_move(void *addr) -{ - struct ao_lisp_stack *stack = addr; - - while (stack) { - struct ao_lisp_stack *prev; - int ret; - (void) ao_lisp_poly_move(&stack->sexprs, 0); - (void) ao_lisp_poly_move(&stack->values, 0); - (void) ao_lisp_poly_move(&stack->values_tail, 0); - (void) ao_lisp_poly_move(&stack->frame, 0); - (void) ao_lisp_poly_move(&stack->list, 0); - prev = ao_lisp_poly_stack(stack->prev); - if (!prev) - break; - ret = ao_lisp_move_memory(&ao_lisp_stack_type, (void **) &prev); - if (prev != ao_lisp_poly_stack(stack->prev)) - stack->prev = ao_lisp_stack_poly(prev); - if (ret) - break; - stack = prev; - } -} - -const struct ao_lisp_type ao_lisp_stack_type = { - .size = stack_size, - .mark = stack_mark, - .move = stack_move, - .name = "stack" -}; - -struct ao_lisp_stack *ao_lisp_stack_free_list; - -void -ao_lisp_stack_reset(struct ao_lisp_stack *stack) -{ - stack->state = eval_sexpr; - stack->sexprs = AO_LISP_NIL; - stack->values = AO_LISP_NIL; - stack->values_tail = AO_LISP_NIL; -} - -static struct ao_lisp_stack * -ao_lisp_stack_new(void) -{ - struct ao_lisp_stack *stack; - - if (ao_lisp_stack_free_list) { - stack = ao_lisp_stack_free_list; - ao_lisp_stack_free_list = ao_lisp_poly_stack(stack->prev); - } else { - stack = ao_lisp_alloc(sizeof (struct ao_lisp_stack)); - if (!stack) - return 0; - stack->type = AO_LISP_STACK; - } - ao_lisp_stack_reset(stack); - return stack; -} - -int -ao_lisp_stack_push(void) -{ - struct ao_lisp_stack *stack = ao_lisp_stack_new(); - - if (!stack) - return 0; - - stack->prev = ao_lisp_stack_poly(ao_lisp_stack); - stack->frame = ao_lisp_frame_poly(ao_lisp_frame_current); - stack->list = AO_LISP_NIL; - - ao_lisp_stack = stack; - - DBGI("stack push\n"); - DBG_FRAMES(); - DBG_IN(); - return 1; -} - -void -ao_lisp_stack_pop(void) -{ - ao_poly prev; - struct ao_lisp_frame *prev_frame; - - if (!ao_lisp_stack) - return; - prev = ao_lisp_stack->prev; - if (!ao_lisp_stack_marked(ao_lisp_stack)) { - ao_lisp_stack->prev = ao_lisp_stack_poly(ao_lisp_stack_free_list); - ao_lisp_stack_free_list = ao_lisp_stack; - } - - ao_lisp_stack = ao_lisp_poly_stack(prev); - prev_frame = ao_lisp_frame_current; - if (ao_lisp_stack) - ao_lisp_frame_current = ao_lisp_poly_frame(ao_lisp_stack->frame); - else - ao_lisp_frame_current = NULL; - if (ao_lisp_frame_current != prev_frame) - ao_lisp_frame_free(prev_frame); - DBG_OUT(); - DBGI("stack pop\n"); - DBG_FRAMES(); -} - -void -ao_lisp_stack_clear(void) -{ - ao_lisp_stack = NULL; - ao_lisp_frame_current = NULL; - ao_lisp_v = AO_LISP_NIL; -} - -void -ao_lisp_stack_print(ao_poly poly) -{ - struct ao_lisp_stack *s = ao_lisp_poly_stack(poly); - - while (s) { - if (s->type & AO_LISP_STACK_PRINT) { - printf("[recurse...]"); - return; - } - s->type |= AO_LISP_STACK_PRINT; - printf("\t[\n"); - printf("\t\texpr: "); ao_lisp_poly_print(s->list); printf("\n"); - printf("\t\tstate: %s\n", ao_lisp_state_names[s->state]); - ao_lisp_error_poly ("values: ", s->values, s->values_tail); - ao_lisp_error_poly ("sexprs: ", s->sexprs, AO_LISP_NIL); - ao_lisp_error_frame(2, "frame: ", ao_lisp_poly_frame(s->frame)); - printf("\t]\n"); - s->type &= ~AO_LISP_STACK_PRINT; - s = ao_lisp_poly_stack(s->prev); - } -} - -/* - * Copy a stack, being careful to keep everybody referenced - */ -static struct ao_lisp_stack * -ao_lisp_stack_copy(struct ao_lisp_stack *old) -{ - struct ao_lisp_stack *new = NULL; - struct ao_lisp_stack *n, *prev = NULL; - - while (old) { - ao_lisp_stack_stash(0, old); - ao_lisp_stack_stash(1, new); - ao_lisp_stack_stash(2, prev); - n = ao_lisp_stack_new(); - prev = ao_lisp_stack_fetch(2); - new = ao_lisp_stack_fetch(1); - old = ao_lisp_stack_fetch(0); - if (!n) - return NULL; - - ao_lisp_stack_mark(old); - ao_lisp_frame_mark(ao_lisp_poly_frame(old->frame)); - *n = *old; - - if (prev) - prev->prev = ao_lisp_stack_poly(n); - else - new = n; - prev = n; - - old = ao_lisp_poly_stack(old->prev); - } - return new; -} - -/* - * Evaluate a continuation invocation - */ -ao_poly -ao_lisp_stack_eval(void) -{ - struct ao_lisp_stack *new = ao_lisp_stack_copy(ao_lisp_poly_stack(ao_lisp_v)); - if (!new) - return AO_LISP_NIL; - - struct ao_lisp_cons *cons = ao_lisp_poly_cons(ao_lisp_stack->values); - - if (!cons || !cons->cdr) - return ao_lisp_error(AO_LISP_INVALID, "continuation requires a value"); - - new->state = eval_val; - - ao_lisp_stack = new; - ao_lisp_frame_current = ao_lisp_poly_frame(ao_lisp_stack->frame); - - return ao_lisp_poly_cons(cons->cdr)->car; -} - -/* - * Call with current continuation. This calls a lambda, passing - * it a single argument which is the current continuation - */ -ao_poly -ao_lisp_call_cc(struct ao_lisp_cons *cons) -{ - struct ao_lisp_stack *new; - ao_poly v; - - /* Make sure the single parameter is a lambda */ - if (!ao_lisp_check_argc(_ao_lisp_atom_call2fcc, cons, 1, 1)) - return AO_LISP_NIL; - if (!ao_lisp_check_argt(_ao_lisp_atom_call2fcc, cons, 0, AO_LISP_LAMBDA, 0)) - return AO_LISP_NIL; - - /* go get the lambda */ - ao_lisp_v = ao_lisp_arg(cons, 0); - - /* Note that the whole call chain now has - * a reference to it which may escape - */ - new = ao_lisp_stack_copy(ao_lisp_stack); - if (!new) - return AO_LISP_NIL; - - /* re-fetch cons after the allocation */ - cons = ao_lisp_poly_cons(ao_lisp_poly_cons(ao_lisp_stack->values)->cdr); - - /* Reset the arg list to the current stack, - * and call the lambda - */ - - cons->car = ao_lisp_stack_poly(new); - cons->cdr = AO_LISP_NIL; - v = ao_lisp_lambda_eval(); - ao_lisp_stack->sexprs = v; - ao_lisp_stack->state = eval_progn; - return AO_LISP_NIL; -} diff --git a/src/math/kf_rem_pio2.c b/src/math/kf_rem_pio2.c index 261c4812..1573ca9f 100644 --- a/src/math/kf_rem_pio2.c +++ b/src/math/kf_rem_pio2.c @@ -77,7 +77,8 @@ twon8 = 3.9062500000e-03; /* 0x3b800000 */ /* compute q[0],q[1],...q[jk] */ for (i=0;i<=jk;i++) { - for(j=0,fw=0.0;j<=jx;j++) fw += x[j]*f[jx+i-j]; q[i] = fw; + for(j=0,fw=0.0;j<=jx;j++) fw += x[j]*f[jx+i-j]; + q[i] = fw; } jz = jk; diff --git a/src/math/sf_cos.c b/src/math/sf_cos.c index 4c0a9a53..2f46ec32 100644 --- a/src/math/sf_cos.c +++ b/src/math/sf_cos.c @@ -16,12 +16,6 @@ #include "fdlibm.h" #ifdef __STDC__ -static const float one=1.0; -#else -static float one=1.0; -#endif - -#ifdef __STDC__ float cosf(float x) #else float cosf(x) diff --git a/src/scheme/.gitignore b/src/scheme/.gitignore new file mode 100644 index 00000000..ee72cb9d --- /dev/null +++ b/src/scheme/.gitignore @@ -0,0 +1,2 @@ +ao_scheme_const.h +ao_scheme_builtin.h diff --git a/src/scheme/Makefile b/src/scheme/Makefile new file mode 100644 index 00000000..dc36dde1 --- /dev/null +++ b/src/scheme/Makefile @@ -0,0 +1,20 @@ +all: ao_scheme_builtin.h ao_scheme_const.h test/ao_scheme_test + +clean: + +cd make-const && make clean + +cd test && make clean + rm -f ao_scheme_const.h ao_scheme_builtin.h + +ao_scheme_const.h: ao_scheme_const.scheme make-const/ao_scheme_make_const + make-const/ao_scheme_make_const -o $@ ao_scheme_const.scheme + +ao_scheme_builtin.h: ao_scheme_make_builtin ao_scheme_builtin.txt + nickle ao_scheme_make_builtin ao_scheme_builtin.txt > $@ + +make-const/ao_scheme_make_const: FRC ao_scheme_builtin.h + +cd make-const && make ao_scheme_make_const + +test/ao_scheme_test: FRC ao_scheme_const.h ao_scheme_builtin.h + +cd test && make ao_scheme_test + +FRC: diff --git a/src/scheme/Makefile-inc b/src/scheme/Makefile-inc new file mode 100644 index 00000000..1a080a4e --- /dev/null +++ b/src/scheme/Makefile-inc @@ -0,0 +1,25 @@ +SCHEME_SRCS=\ + ao_scheme_mem.c \ + ao_scheme_cons.c \ + ao_scheme_string.c \ + ao_scheme_atom.c \ + ao_scheme_int.c \ + ao_scheme_poly.c \ + ao_scheme_bool.c \ + ao_scheme_float.c \ + ao_scheme_builtin.c \ + ao_scheme_read.c \ + ao_scheme_frame.c \ + ao_scheme_lambda.c \ + ao_scheme_eval.c \ + ao_scheme_rep.c \ + ao_scheme_save.c \ + ao_scheme_stack.c \ + ao_scheme_error.c \ + ao_scheme_vector.c + +SCHEME_HDRS=\ + ao_scheme.h \ + ao_scheme_os.h \ + ao_scheme_read.h \ + ao_scheme_builtin.h diff --git a/src/scheme/Makefile-scheme b/src/scheme/Makefile-scheme new file mode 100644 index 00000000..b9018e19 --- /dev/null +++ b/src/scheme/Makefile-scheme @@ -0,0 +1,4 @@ +include ../scheme/Makefile-inc + +ao_scheme_const.h: $(SCHEME_SRCS) $(SCHEME_HDRS) + +cd ../scheme && make $@ diff --git a/src/scheme/README b/src/scheme/README new file mode 100644 index 00000000..a18457fd --- /dev/null +++ b/src/scheme/README @@ -0,0 +1,10 @@ +This follows the R7RS with the following known exceptions: + +* No vectors or bytevectors +* Characters are just numbers +* No dynamic-wind or exceptions +* No environments +* No ports +* No syntax-rules +* No record types +* No libraries diff --git a/src/scheme/ao_scheme.h b/src/scheme/ao_scheme.h new file mode 100644 index 00000000..2fa1ed60 --- /dev/null +++ b/src/scheme/ao_scheme.h @@ -0,0 +1,981 @@ +/* + * Copyright © 2016 Keith Packard <keithp@keithp.com> + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation, either version 2 of the License, or + * (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, but + * WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + * General Public License for more details. + */ + +#ifndef _AO_SCHEME_H_ +#define _AO_SCHEME_H_ + +#define DBG_MEM 0 +#define DBG_EVAL 0 +#define DBG_READ 0 +#define DBG_FREE_CONS 0 +#define NDEBUG 1 + +#include <stdint.h> +#include <string.h> +#include <ao_scheme_os.h> +#ifndef __BYTE_ORDER +#include <endian.h> +#endif + +typedef uint16_t ao_poly; +typedef int16_t ao_signed_poly; + +#if AO_SCHEME_SAVE + +struct ao_scheme_os_save { + ao_poly atoms; + ao_poly globals; + uint16_t const_checksum; + uint16_t const_checksum_inv; +}; + +#define AO_SCHEME_POOL_EXTRA (sizeof(struct ao_scheme_os_save)) +#define AO_SCHEME_POOL ((int) (AO_SCHEME_POOL_TOTAL - AO_SCHEME_POOL_EXTRA)) + +int +ao_scheme_os_save(void); + +int +ao_scheme_os_restore_save(struct ao_scheme_os_save *save, int offset); + +int +ao_scheme_os_restore(void); + +#endif + +#ifdef AO_SCHEME_MAKE_CONST +#define AO_SCHEME_POOL_CONST 16384 +extern uint8_t ao_scheme_const[AO_SCHEME_POOL_CONST] __attribute__((aligned(4))); +#define ao_scheme_pool ao_scheme_const +#define AO_SCHEME_POOL AO_SCHEME_POOL_CONST + +#define _atom(n) ao_scheme_atom_poly(ao_scheme_atom_intern(n)) +#define _bool(v) ao_scheme_bool_poly(ao_scheme_bool_get(v)) + +#define _ao_scheme_bool_true _bool(1) +#define _ao_scheme_bool_false _bool(0) + +#define _ao_scheme_atom_eof _atom("eof") +#define _ao_scheme_atom_else _atom("else") + +#define AO_SCHEME_BUILTIN_ATOMS +#include "ao_scheme_builtin.h" + +#else +#include "ao_scheme_const.h" +#ifndef AO_SCHEME_POOL +#define AO_SCHEME_POOL 3072 +#endif +#ifndef AO_SCHEME_POOL_EXTRA +#define AO_SCHEME_POOL_EXTRA 0 +#endif +extern uint8_t ao_scheme_pool[AO_SCHEME_POOL + AO_SCHEME_POOL_EXTRA] __attribute__((aligned(4))); +#endif + +/* Primitive types */ +#define AO_SCHEME_CONS 0 +#define AO_SCHEME_INT 1 +#define AO_SCHEME_STRING 2 +#define AO_SCHEME_OTHER 3 + +#define AO_SCHEME_TYPE_MASK 0x0003 +#define AO_SCHEME_TYPE_SHIFT 2 +#define AO_SCHEME_REF_MASK 0x7ffc +#define AO_SCHEME_CONST 0x8000 + +/* These have a type value at the start of the struct */ +#define AO_SCHEME_ATOM 4 +#define AO_SCHEME_BUILTIN 5 +#define AO_SCHEME_FRAME 6 +#define AO_SCHEME_FRAME_VALS 7 +#define AO_SCHEME_LAMBDA 8 +#define AO_SCHEME_STACK 9 +#define AO_SCHEME_BOOL 10 +#define AO_SCHEME_BIGINT 11 +#define AO_SCHEME_FLOAT 12 +#define AO_SCHEME_VECTOR 13 +#define AO_SCHEME_NUM_TYPE 14 + +/* Leave two bits for types to use as they please */ +#define AO_SCHEME_OTHER_TYPE_MASK 0x3f + +#define AO_SCHEME_NIL 0 + +extern uint16_t ao_scheme_top; + +#define AO_SCHEME_OOM 0x01 +#define AO_SCHEME_DIVIDE_BY_ZERO 0x02 +#define AO_SCHEME_INVALID 0x04 +#define AO_SCHEME_UNDEFINED 0x08 +#define AO_SCHEME_REDEFINED 0x10 +#define AO_SCHEME_EOF 0x20 +#define AO_SCHEME_EXIT 0x40 + +extern uint8_t ao_scheme_exception; + +static inline int +ao_scheme_is_const(ao_poly poly) { + return poly & AO_SCHEME_CONST; +} + +#define AO_SCHEME_IS_CONST(a) (ao_scheme_const <= ((uint8_t *) (a)) && ((uint8_t *) (a)) < ao_scheme_const + AO_SCHEME_POOL_CONST) +#define AO_SCHEME_IS_POOL(a) (ao_scheme_pool <= ((uint8_t *) (a)) && ((uint8_t *) (a)) < ao_scheme_pool + AO_SCHEME_POOL) +#define AO_SCHEME_IS_INT(p) (ao_scheme_poly_base_type(p) == AO_SCHEME_INT) + +void * +ao_scheme_ref(ao_poly poly); + +ao_poly +ao_scheme_poly(const void *addr, ao_poly type); + +struct ao_scheme_type { + int (*size)(void *addr); + void (*mark)(void *addr); + void (*move)(void *addr); + char name[]; +}; + +struct ao_scheme_cons { + ao_poly car; + ao_poly cdr; +}; + +struct ao_scheme_atom { + uint8_t type; + uint8_t pad[1]; + ao_poly next; + char name[]; +}; + +struct ao_scheme_val { + ao_poly atom; + ao_poly val; +}; + +struct ao_scheme_frame_vals { + uint8_t type; + uint8_t size; + struct ao_scheme_val vals[]; +}; + +struct ao_scheme_frame { + uint8_t type; + uint8_t num; + ao_poly prev; + ao_poly vals; +}; + +struct ao_scheme_bool { + uint8_t type; + uint8_t value; + uint16_t pad; +}; + +struct ao_scheme_bigint { + uint32_t value; +}; + +struct ao_scheme_float { + uint8_t type; + uint8_t pad1; + uint16_t pad2; + float value; +}; + +struct ao_scheme_vector { + uint8_t type; + uint8_t pad1; + uint16_t length; + ao_poly vals[]; +}; + +#if __BYTE_ORDER == __LITTLE_ENDIAN +static inline uint32_t +ao_scheme_int_bigint(int32_t i) { + return AO_SCHEME_BIGINT | (i << 8); +} +static inline int32_t +ao_scheme_bigint_int(uint32_t bi) { + return (int32_t) bi >> 8; +} +#else +static inline uint32_t +ao_scheme_int_bigint(int32_t i) { + return (uint32_t) (i & 0xffffff) | (AO_SCHEME_BIGINT << 24); +} +static inlint int32_t +ao_scheme_bigint_int(uint32_t bi) { + return (int32_t) (bi << 8) >> 8; +} +#endif + +#define AO_SCHEME_MIN_INT (-(1 << (15 - AO_SCHEME_TYPE_SHIFT))) +#define AO_SCHEME_MAX_INT ((1 << (15 - AO_SCHEME_TYPE_SHIFT)) - 1) +#define AO_SCHEME_MIN_BIGINT (-(1 << 24)) +#define AO_SCHEME_MAX_BIGINT ((1 << 24) - 1) + +#define AO_SCHEME_NOT_INTEGER 0x7fffffff + +/* Set on type when the frame escapes the lambda */ +#define AO_SCHEME_FRAME_MARK 0x80 +#define AO_SCHEME_FRAME_PRINT 0x40 + +static inline int ao_scheme_frame_marked(struct ao_scheme_frame *f) { + return f->type & AO_SCHEME_FRAME_MARK; +} + +static inline struct ao_scheme_frame * +ao_scheme_poly_frame(ao_poly poly) { + return ao_scheme_ref(poly); +} + +static inline ao_poly +ao_scheme_frame_poly(struct ao_scheme_frame *frame) { + return ao_scheme_poly(frame, AO_SCHEME_OTHER); +} + +static inline struct ao_scheme_frame_vals * +ao_scheme_poly_frame_vals(ao_poly poly) { + return ao_scheme_ref(poly); +} + +static inline ao_poly +ao_scheme_frame_vals_poly(struct ao_scheme_frame_vals *vals) { + return ao_scheme_poly(vals, AO_SCHEME_OTHER); +} + +enum eval_state { + eval_sexpr, /* Evaluate an sexpr */ + eval_val, /* Value computed */ + eval_formal, /* Formal computed */ + eval_exec, /* Start a lambda evaluation */ + eval_apply, /* Execute apply */ + eval_cond, /* Start next cond clause */ + eval_cond_test, /* Check cond condition */ + eval_begin, /* Start next begin entry */ + eval_while, /* Start while condition */ + eval_while_test, /* Check while condition */ + eval_macro, /* Finished with macro generation */ +}; + +struct ao_scheme_stack { + uint8_t type; /* AO_SCHEME_STACK */ + uint8_t state; /* enum eval_state */ + ao_poly prev; /* previous stack frame */ + ao_poly sexprs; /* expressions to evaluate */ + ao_poly values; /* values computed */ + ao_poly values_tail; /* end of the values list for easy appending */ + ao_poly frame; /* current lookup frame */ + ao_poly list; /* most recent function call */ +}; + +#define AO_SCHEME_STACK_MARK 0x80 /* set on type when a reference has been taken */ +#define AO_SCHEME_STACK_PRINT 0x40 /* stack is being printed */ + +static inline int ao_scheme_stack_marked(struct ao_scheme_stack *s) { + return s->type & AO_SCHEME_STACK_MARK; +} + +static inline void ao_scheme_stack_mark(struct ao_scheme_stack *s) { + s->type |= AO_SCHEME_STACK_MARK; +} + +static inline struct ao_scheme_stack * +ao_scheme_poly_stack(ao_poly p) +{ + return ao_scheme_ref(p); +} + +static inline ao_poly +ao_scheme_stack_poly(struct ao_scheme_stack *stack) +{ + return ao_scheme_poly(stack, AO_SCHEME_OTHER); +} + +extern ao_poly ao_scheme_v; + +#define AO_SCHEME_FUNC_LAMBDA 0 +#define AO_SCHEME_FUNC_NLAMBDA 1 +#define AO_SCHEME_FUNC_MACRO 2 + +#define AO_SCHEME_FUNC_FREE_ARGS 0x80 +#define AO_SCHEME_FUNC_MASK 0x7f + +#define AO_SCHEME_FUNC_F_LAMBDA (AO_SCHEME_FUNC_FREE_ARGS | AO_SCHEME_FUNC_LAMBDA) +#define AO_SCHEME_FUNC_F_NLAMBDA (AO_SCHEME_FUNC_FREE_ARGS | AO_SCHEME_FUNC_NLAMBDA) +#define AO_SCHEME_FUNC_F_MACRO (AO_SCHEME_FUNC_FREE_ARGS | AO_SCHEME_FUNC_MACRO) + +struct ao_scheme_builtin { + uint8_t type; + uint8_t args; + uint16_t func; +}; + +#define AO_SCHEME_BUILTIN_ID +#include "ao_scheme_builtin.h" + +typedef ao_poly (*ao_scheme_func_t)(struct ao_scheme_cons *cons); + +extern const ao_scheme_func_t ao_scheme_builtins[]; + +static inline ao_scheme_func_t +ao_scheme_func(struct ao_scheme_builtin *b) +{ + return ao_scheme_builtins[b->func]; +} + +struct ao_scheme_lambda { + uint8_t type; + uint8_t args; + ao_poly code; + ao_poly frame; +}; + +static inline struct ao_scheme_lambda * +ao_scheme_poly_lambda(ao_poly poly) +{ + return ao_scheme_ref(poly); +} + +static inline ao_poly +ao_scheme_lambda_poly(struct ao_scheme_lambda *lambda) +{ + return ao_scheme_poly(lambda, AO_SCHEME_OTHER); +} + +static inline void * +ao_scheme_poly_other(ao_poly poly) { + return ao_scheme_ref(poly); +} + +static inline uint8_t +ao_scheme_other_type(void *other) { +#if DBG_MEM + if ((*((uint8_t *) other) & AO_SCHEME_OTHER_TYPE_MASK) >= AO_SCHEME_NUM_TYPE) + ao_scheme_abort(); +#endif + return *((uint8_t *) other) & AO_SCHEME_OTHER_TYPE_MASK; +} + +static inline ao_poly +ao_scheme_other_poly(const void *other) +{ + return ao_scheme_poly(other, AO_SCHEME_OTHER); +} + +static inline int +ao_scheme_size_round(int size) +{ + return (size + 3) & ~3; +} + +static inline int +ao_scheme_size(const struct ao_scheme_type *type, void *addr) +{ + return ao_scheme_size_round(type->size(addr)); +} + +#define AO_SCHEME_OTHER_POLY(other) ((ao_poly)(other) + AO_SCHEME_OTHER) + +static inline int ao_scheme_poly_base_type(ao_poly poly) { + return poly & AO_SCHEME_TYPE_MASK; +} + +static inline int ao_scheme_poly_type(ao_poly poly) { + int type = poly & AO_SCHEME_TYPE_MASK; + if (type == AO_SCHEME_OTHER) + return ao_scheme_other_type(ao_scheme_poly_other(poly)); + return type; +} + +static inline int +ao_scheme_is_cons(ao_poly poly) { + return (ao_scheme_poly_base_type(poly) == AO_SCHEME_CONS); +} + +static inline int +ao_scheme_is_pair(ao_poly poly) { + return poly != AO_SCHEME_NIL && (ao_scheme_poly_base_type(poly) == AO_SCHEME_CONS); +} + +static inline struct ao_scheme_cons * +ao_scheme_poly_cons(ao_poly poly) +{ + return ao_scheme_ref(poly); +} + +static inline ao_poly +ao_scheme_cons_poly(struct ao_scheme_cons *cons) +{ + return ao_scheme_poly(cons, AO_SCHEME_CONS); +} + +static inline int32_t +ao_scheme_poly_int(ao_poly poly) +{ + return (int32_t) ((ao_signed_poly) poly >> AO_SCHEME_TYPE_SHIFT); +} + +static inline ao_poly +ao_scheme_int_poly(int32_t i) +{ + return ((ao_poly) i << 2) | AO_SCHEME_INT; +} + +static inline struct ao_scheme_bigint * +ao_scheme_poly_bigint(ao_poly poly) +{ + return ao_scheme_ref(poly); +} + +static inline ao_poly +ao_scheme_bigint_poly(struct ao_scheme_bigint *bi) +{ + return ao_scheme_poly(bi, AO_SCHEME_OTHER); +} + +static inline char * +ao_scheme_poly_string(ao_poly poly) +{ + return ao_scheme_ref(poly); +} + +static inline ao_poly +ao_scheme_string_poly(char *s) +{ + return ao_scheme_poly(s, AO_SCHEME_STRING); +} + +static inline struct ao_scheme_atom * +ao_scheme_poly_atom(ao_poly poly) +{ + return ao_scheme_ref(poly); +} + +static inline ao_poly +ao_scheme_atom_poly(struct ao_scheme_atom *a) +{ + return ao_scheme_poly(a, AO_SCHEME_OTHER); +} + +static inline struct ao_scheme_builtin * +ao_scheme_poly_builtin(ao_poly poly) +{ + return ao_scheme_ref(poly); +} + +static inline ao_poly +ao_scheme_builtin_poly(struct ao_scheme_builtin *b) +{ + return ao_scheme_poly(b, AO_SCHEME_OTHER); +} + +static inline ao_poly +ao_scheme_bool_poly(struct ao_scheme_bool *b) +{ + return ao_scheme_poly(b, AO_SCHEME_OTHER); +} + +static inline struct ao_scheme_bool * +ao_scheme_poly_bool(ao_poly poly) +{ + return ao_scheme_ref(poly); +} + +static inline ao_poly +ao_scheme_float_poly(struct ao_scheme_float *f) +{ + return ao_scheme_poly(f, AO_SCHEME_OTHER); +} + +static inline struct ao_scheme_float * +ao_scheme_poly_float(ao_poly poly) +{ + return ao_scheme_ref(poly); +} + +float +ao_scheme_poly_number(ao_poly p); + +static inline ao_poly +ao_scheme_vector_poly(struct ao_scheme_vector *v) +{ + return ao_scheme_poly(v, AO_SCHEME_OTHER); +} + +static inline struct ao_scheme_vector * +ao_scheme_poly_vector(ao_poly poly) +{ + return ao_scheme_ref(poly); +} + +/* memory functions */ + +extern uint64_t ao_scheme_collects[2]; +extern uint64_t ao_scheme_freed[2]; +extern uint64_t ao_scheme_loops[2]; + +/* returns 1 if the object was already marked */ +int +ao_scheme_mark(const struct ao_scheme_type *type, void *addr); + +/* returns 1 if the object was already marked */ +int +ao_scheme_mark_memory(const struct ao_scheme_type *type, void *addr); + +void * +ao_scheme_move_map(void *addr); + +/* returns 1 if the object was already moved */ +int +ao_scheme_move(const struct ao_scheme_type *type, void **ref); + +/* returns 1 if the object was already moved */ +int +ao_scheme_move_memory(const struct ao_scheme_type *type, void **ref); + +void * +ao_scheme_alloc(int size); + +#define AO_SCHEME_COLLECT_FULL 1 +#define AO_SCHEME_COLLECT_INCREMENTAL 0 + +int +ao_scheme_collect(uint8_t style); + +#if DBG_FREE_CONS +void +ao_scheme_cons_check(struct ao_scheme_cons *cons); +#endif + +void +ao_scheme_cons_stash(int id, struct ao_scheme_cons *cons); + +struct ao_scheme_cons * +ao_scheme_cons_fetch(int id); + +void +ao_scheme_poly_stash(int id, ao_poly poly); + +ao_poly +ao_scheme_poly_fetch(int id); + +void +ao_scheme_string_stash(int id, char *string); + +char * +ao_scheme_string_fetch(int id); + +static inline void +ao_scheme_stack_stash(int id, struct ao_scheme_stack *stack) { + ao_scheme_poly_stash(id, ao_scheme_stack_poly(stack)); +} + +static inline struct ao_scheme_stack * +ao_scheme_stack_fetch(int id) { + return ao_scheme_poly_stack(ao_scheme_poly_fetch(id)); +} + +void +ao_scheme_frame_stash(int id, struct ao_scheme_frame *frame); + +struct ao_scheme_frame * +ao_scheme_frame_fetch(int id); + +/* bool */ + +extern const struct ao_scheme_type ao_scheme_bool_type; + +void +ao_scheme_bool_write(ao_poly v); + +#ifdef AO_SCHEME_MAKE_CONST +struct ao_scheme_bool *ao_scheme_true, *ao_scheme_false; + +struct ao_scheme_bool * +ao_scheme_bool_get(uint8_t value); +#endif + +/* cons */ +extern const struct ao_scheme_type ao_scheme_cons_type; + +struct ao_scheme_cons * +ao_scheme_cons_cons(ao_poly car, ao_poly cdr); + +/* Return a cons or NULL for a proper list, else error */ +struct ao_scheme_cons * +ao_scheme_cons_cdr(struct ao_scheme_cons *cons); + +ao_poly +ao_scheme__cons(ao_poly car, ao_poly cdr); + +extern struct ao_scheme_cons *ao_scheme_cons_free_list; + +void +ao_scheme_cons_free(struct ao_scheme_cons *cons); + +void +ao_scheme_cons_write(ao_poly); + +void +ao_scheme_cons_display(ao_poly); + +int +ao_scheme_cons_length(struct ao_scheme_cons *cons); + +struct ao_scheme_cons * +ao_scheme_cons_copy(struct ao_scheme_cons *cons); + +/* string */ +extern const struct ao_scheme_type ao_scheme_string_type; + +char * +ao_scheme_string_copy(char *a); + +char * +ao_scheme_string_cat(char *a, char *b); + +ao_poly +ao_scheme_string_pack(struct ao_scheme_cons *cons); + +ao_poly +ao_scheme_string_unpack(char *a); + +void +ao_scheme_string_write(ao_poly s); + +void +ao_scheme_string_display(ao_poly s); + +/* atom */ +extern const struct ao_scheme_type ao_scheme_atom_type; + +extern struct ao_scheme_atom *ao_scheme_atoms; +extern struct ao_scheme_frame *ao_scheme_frame_global; +extern struct ao_scheme_frame *ao_scheme_frame_current; + +void +ao_scheme_atom_write(ao_poly a); + +struct ao_scheme_atom * +ao_scheme_atom_intern(char *name); + +ao_poly * +ao_scheme_atom_ref(ao_poly atom, struct ao_scheme_frame **frame_ref); + +ao_poly +ao_scheme_atom_get(ao_poly atom); + +ao_poly +ao_scheme_atom_set(ao_poly atom, ao_poly val); + +ao_poly +ao_scheme_atom_def(ao_poly atom, ao_poly val); + +/* int */ +void +ao_scheme_int_write(ao_poly i); + +int32_t +ao_scheme_poly_integer(ao_poly p); + +ao_poly +ao_scheme_integer_poly(int32_t i); + +static inline int +ao_scheme_integer_typep(uint8_t t) +{ + return (t == AO_SCHEME_INT) || (t == AO_SCHEME_BIGINT); +} + +void +ao_scheme_bigint_write(ao_poly i); + +extern const struct ao_scheme_type ao_scheme_bigint_type; + +/* vector */ + +void +ao_scheme_vector_write(ao_poly v); + +void +ao_scheme_vector_display(ao_poly v); + +struct ao_scheme_vector * +ao_scheme_vector_alloc(uint16_t length, ao_poly fill); + +ao_poly +ao_scheme_vector_get(ao_poly v, ao_poly i); + +ao_poly +ao_scheme_vector_set(ao_poly v, ao_poly i, ao_poly p); + +struct ao_scheme_vector * +ao_scheme_list_to_vector(struct ao_scheme_cons *cons); + +struct ao_scheme_cons * +ao_scheme_vector_to_list(struct ao_scheme_vector *vector); + +extern const struct ao_scheme_type ao_scheme_vector_type; + +/* prim */ +void +ao_scheme_poly_write(ao_poly p); + +void +ao_scheme_poly_display(ao_poly p); + +int +ao_scheme_poly_mark(ao_poly p, uint8_t note_cons); + +/* returns 1 if the object has already been moved */ +int +ao_scheme_poly_move(ao_poly *p, uint8_t note_cons); + +/* eval */ + +void +ao_scheme_eval_clear_globals(void); + +int +ao_scheme_eval_restart(void); + +ao_poly +ao_scheme_eval(ao_poly p); + +ao_poly +ao_scheme_set_cond(struct ao_scheme_cons *cons); + +/* float */ +extern const struct ao_scheme_type ao_scheme_float_type; + +void +ao_scheme_float_write(ao_poly p); + +ao_poly +ao_scheme_float_get(float value); + +static inline uint8_t +ao_scheme_number_typep(uint8_t t) +{ + return ao_scheme_integer_typep(t) || (t == AO_SCHEME_FLOAT); +} + +float +ao_scheme_poly_number(ao_poly p); + +/* builtin */ +void +ao_scheme_builtin_write(ao_poly b); + +extern const struct ao_scheme_type ao_scheme_builtin_type; + +/* Check argument count */ +ao_poly +ao_scheme_check_argc(ao_poly name, struct ao_scheme_cons *cons, int min, int max); + +/* Check argument type */ +ao_poly +ao_scheme_check_argt(ao_poly name, struct ao_scheme_cons *cons, int argc, int type, int nil_ok); + +/* Fetch an arg (nil if off the end) */ +ao_poly +ao_scheme_arg(struct ao_scheme_cons *cons, int argc); + +char * +ao_scheme_args_name(uint8_t args); + +/* read */ +extern int ao_scheme_read_list; +extern struct ao_scheme_cons *ao_scheme_read_cons; +extern struct ao_scheme_cons *ao_scheme_read_cons_tail; +extern struct ao_scheme_cons *ao_scheme_read_stack; + +ao_poly +ao_scheme_read(void); + +/* rep */ +ao_poly +ao_scheme_read_eval_print(void); + +/* frame */ +extern const struct ao_scheme_type ao_scheme_frame_type; +extern const struct ao_scheme_type ao_scheme_frame_vals_type; + +#define AO_SCHEME_FRAME_FREE 6 + +extern struct ao_scheme_frame *ao_scheme_frame_free_list[AO_SCHEME_FRAME_FREE]; + +ao_poly +ao_scheme_frame_mark(struct ao_scheme_frame *frame); + +ao_poly * +ao_scheme_frame_ref(struct ao_scheme_frame *frame, ao_poly atom); + +struct ao_scheme_frame * +ao_scheme_frame_new(int num); + +void +ao_scheme_frame_free(struct ao_scheme_frame *frame); + +void +ao_scheme_frame_bind(struct ao_scheme_frame *frame, int num, ao_poly atom, ao_poly val); + +ao_poly +ao_scheme_frame_add(struct ao_scheme_frame *frame, ao_poly atom, ao_poly val); + +void +ao_scheme_frame_write(ao_poly p); + +void +ao_scheme_frame_init(void); + +/* lambda */ +extern const struct ao_scheme_type ao_scheme_lambda_type; + +extern const char * const ao_scheme_state_names[]; + +struct ao_scheme_lambda * +ao_scheme_lambda_new(ao_poly cons); + +void +ao_scheme_lambda_write(ao_poly lambda); + +ao_poly +ao_scheme_lambda_eval(void); + +/* stack */ + +extern const struct ao_scheme_type ao_scheme_stack_type; +extern struct ao_scheme_stack *ao_scheme_stack; +extern struct ao_scheme_stack *ao_scheme_stack_free_list; + +void +ao_scheme_stack_reset(struct ao_scheme_stack *stack); + +int +ao_scheme_stack_push(void); + +void +ao_scheme_stack_pop(void); + +void +ao_scheme_stack_clear(void); + +void +ao_scheme_stack_write(ao_poly stack); + +ao_poly +ao_scheme_stack_eval(void); + +/* error */ + +void +ao_scheme_vprintf(char *format, va_list args); + +void +ao_scheme_printf(char *format, ...); + +void +ao_scheme_error_poly(char *name, ao_poly poly, ao_poly last); + +void +ao_scheme_error_frame(int indent, char *name, struct ao_scheme_frame *frame); + +ao_poly +ao_scheme_error(int error, char *format, ...); + +/* builtins */ + +#define AO_SCHEME_BUILTIN_DECLS +#include "ao_scheme_builtin.h" + +/* debugging macros */ + +#if DBG_EVAL || DBG_READ || DBG_MEM +#define DBG_CODE 1 +int ao_scheme_stack_depth; +#define DBG_DO(a) a +#define DBG_INDENT() do { int _s; for(_s = 0; _s < ao_scheme_stack_depth; _s++) printf(" "); } while(0) +#define DBG_IN() (++ao_scheme_stack_depth) +#define DBG_OUT() (--ao_scheme_stack_depth) +#define DBG_RESET() (ao_scheme_stack_depth = 0) +#define DBG(...) ao_scheme_printf(__VA_ARGS__) +#define DBGI(...) do { printf("%4d: ", __LINE__); DBG_INDENT(); DBG(__VA_ARGS__); } while (0) +#define DBG_CONS(a) ao_scheme_cons_write(ao_scheme_cons_poly(a)) +#define DBG_POLY(a) ao_scheme_poly_write(a) +#define OFFSET(a) ((a) ? (int) ((uint8_t *) a - ao_scheme_pool) : -1) +#define DBG_STACK() ao_scheme_stack_write(ao_scheme_stack_poly(ao_scheme_stack)) +static inline void +ao_scheme_frames_dump(void) +{ + struct ao_scheme_stack *s; + DBGI(".. current frame: "); DBG_POLY(ao_scheme_frame_poly(ao_scheme_frame_current)); DBG("\n"); + for (s = ao_scheme_stack; s; s = ao_scheme_poly_stack(s->prev)) { + DBGI(".. stack frame: "); DBG_POLY(s->frame); DBG("\n"); + } +} +#define DBG_FRAMES() ao_scheme_frames_dump() +#else +#define DBG_DO(a) +#define DBG_INDENT() +#define DBG_IN() +#define DBG_OUT() +#define DBG(...) +#define DBGI(...) +#define DBG_CONS(a) +#define DBG_POLY(a) +#define DBG_RESET() +#define DBG_STACK() +#define DBG_FRAMES() +#endif + +#if DBG_READ +#define RDBGI(...) DBGI(__VA_ARGS__) +#define RDBG_IN() DBG_IN() +#define RDBG_OUT() DBG_OUT() +#else +#define RDBGI(...) +#define RDBG_IN() +#define RDBG_OUT() +#endif + +#define DBG_MEM_START 1 + +#if DBG_MEM + +#include <assert.h> +extern int dbg_move_depth; +#define MDBG_DUMP 1 +#define MDBG_OFFSET(a) ((a) ? (int) ((uint8_t *) (a) - ao_scheme_pool) : -1) + +extern int dbg_mem; + +#define MDBG_DO(a) DBG_DO(a) +#define MDBG_MOVE(...) do { if (dbg_mem) { int d; for (d = 0; d < dbg_move_depth; d++) printf (" "); printf(__VA_ARGS__); } } while (0) +#define MDBG_MORE(...) do { if (dbg_mem) printf(__VA_ARGS__); } while (0) +#define MDBG_MOVE_IN() (dbg_move_depth++) +#define MDBG_MOVE_OUT() (assert(--dbg_move_depth >= 0)) + +#else + +#define MDBG_DO(a) +#define MDBG_MOVE(...) +#define MDBG_MORE(...) +#define MDBG_MOVE_IN() +#define MDBG_MOVE_OUT() + +#endif + +#endif /* _AO_SCHEME_H_ */ diff --git a/src/scheme/ao_scheme_atom.c b/src/scheme/ao_scheme_atom.c new file mode 100644 index 00000000..cb32b7fe --- /dev/null +++ b/src/scheme/ao_scheme_atom.c @@ -0,0 +1,167 @@ +/* + * Copyright © 2016 Keith Packard <keithp@keithp.com> + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation; version 2 of the License. + * + * 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. + */ + +#include "ao_scheme.h" + +static int name_size(char *name) +{ + return sizeof(struct ao_scheme_atom) + strlen(name) + 1; +} + +static int atom_size(void *addr) +{ + struct ao_scheme_atom *atom = addr; + if (!atom) + return 0; + return name_size(atom->name); +} + +static void atom_mark(void *addr) +{ + struct ao_scheme_atom *atom = addr; + + for (;;) { + atom = ao_scheme_poly_atom(atom->next); + if (!atom) + break; + if (ao_scheme_mark_memory(&ao_scheme_atom_type, atom)) + break; + } +} + +static void atom_move(void *addr) +{ + struct ao_scheme_atom *atom = addr; + int ret; + + for (;;) { + struct ao_scheme_atom *next = ao_scheme_poly_atom(atom->next); + + if (!next) + break; + ret = ao_scheme_move_memory(&ao_scheme_atom_type, (void **) &next); + if (next != ao_scheme_poly_atom(atom->next)) + atom->next = ao_scheme_atom_poly(next); + if (ret) + break; + atom = next; + } +} + +const struct ao_scheme_type ao_scheme_atom_type = { + .mark = atom_mark, + .size = atom_size, + .move = atom_move, + .name = "atom" +}; + +struct ao_scheme_atom *ao_scheme_atoms; + +struct ao_scheme_atom * +ao_scheme_atom_intern(char *name) +{ + struct ao_scheme_atom *atom; + + for (atom = ao_scheme_atoms; atom; atom = ao_scheme_poly_atom(atom->next)) { + if (!strcmp(atom->name, name)) + return atom; + } +#ifdef ao_builtin_atoms + for (atom = ao_scheme_poly_atom(ao_builtin_atoms); atom; atom = ao_scheme_poly_atom(atom->next)) { + if (!strcmp(atom->name, name)) + return atom; + } +#endif + ao_scheme_string_stash(0, name); + atom = ao_scheme_alloc(name_size(name)); + name = ao_scheme_string_fetch(0); + if (atom) { + atom->type = AO_SCHEME_ATOM; + atom->next = ao_scheme_atom_poly(ao_scheme_atoms); + ao_scheme_atoms = atom; + strcpy(atom->name, name); + } + return atom; +} + +ao_poly * +ao_scheme_atom_ref(ao_poly atom, struct ao_scheme_frame **frame_ref) +{ + ao_poly *ref; + struct ao_scheme_frame *frame; + + for (frame = ao_scheme_frame_current; frame; frame = ao_scheme_poly_frame(frame->prev)) { + ref = ao_scheme_frame_ref(frame, atom); + if (ref) { + if (frame_ref) + *frame_ref = frame; + return ref; + } + } + ref = ao_scheme_frame_ref(ao_scheme_frame_global, atom); + if (ref) + if (frame_ref) + *frame_ref = ao_scheme_frame_global; + return ref; +} + +ao_poly +ao_scheme_atom_get(ao_poly atom) +{ + ao_poly *ref = ao_scheme_atom_ref(atom, NULL); + +#ifdef ao_builtin_frame + if (!ref) + ref = ao_scheme_frame_ref(ao_scheme_poly_frame(ao_builtin_frame), atom); +#endif + if (ref) + return *ref; + return ao_scheme_error(AO_SCHEME_UNDEFINED, "undefined atom %s", ao_scheme_poly_atom(atom)->name); +} + +ao_poly +ao_scheme_atom_set(ao_poly atom, ao_poly val) +{ + ao_poly *ref = ao_scheme_atom_ref(atom, NULL); + + if (!ref) + return ao_scheme_error(AO_SCHEME_UNDEFINED, "undefined atom %s", ao_scheme_poly_atom(atom)->name); + *ref = val; + return val; +} + +ao_poly +ao_scheme_atom_def(ao_poly atom, ao_poly val) +{ + struct ao_scheme_frame *frame; + ao_poly *ref = ao_scheme_atom_ref(atom, &frame); + + if (ref) { + if (frame == ao_scheme_frame_current) + return ao_scheme_error(AO_SCHEME_REDEFINED, "attempt to redefine atom %s", ao_scheme_poly_atom(atom)->name); + *ref = val; + return val; + } + return ao_scheme_frame_add(ao_scheme_frame_current ? ao_scheme_frame_current : ao_scheme_frame_global, atom, val); +} + +void +ao_scheme_atom_write(ao_poly a) +{ + struct ao_scheme_atom *atom = ao_scheme_poly_atom(a); + printf("%s", atom->name); +} diff --git a/src/scheme/ao_scheme_bool.c b/src/scheme/ao_scheme_bool.c new file mode 100644 index 00000000..c1e880ca --- /dev/null +++ b/src/scheme/ao_scheme_bool.c @@ -0,0 +1,73 @@ +/* + * Copyright © 2017 Keith Packard <keithp@keithp.com> + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation, either version 2 of the License, or + * (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, but + * WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + * General Public License for more details. + */ + +#include "ao_scheme.h" + +static void bool_mark(void *addr) +{ + (void) addr; +} + +static int bool_size(void *addr) +{ + (void) addr; + return sizeof (struct ao_scheme_bool); +} + +static void bool_move(void *addr) +{ + (void) addr; +} + +const struct ao_scheme_type ao_scheme_bool_type = { + .mark = bool_mark, + .size = bool_size, + .move = bool_move, + .name = "bool" +}; + +void +ao_scheme_bool_write(ao_poly v) +{ + struct ao_scheme_bool *b = ao_scheme_poly_bool(v); + + if (b->value) + printf("#t"); + else + printf("#f"); +} + +#ifdef AO_SCHEME_MAKE_CONST + +struct ao_scheme_bool *ao_scheme_true, *ao_scheme_false; + +struct ao_scheme_bool * +ao_scheme_bool_get(uint8_t value) +{ + struct ao_scheme_bool **b; + + if (value) + b = &ao_scheme_true; + else + b = &ao_scheme_false; + + if (!*b) { + *b = ao_scheme_alloc(sizeof (struct ao_scheme_bool)); + (*b)->type = AO_SCHEME_BOOL; + (*b)->value = value; + } + return *b; +} + +#endif diff --git a/src/scheme/ao_scheme_builtin.c b/src/scheme/ao_scheme_builtin.c new file mode 100644 index 00000000..1754e677 --- /dev/null +++ b/src/scheme/ao_scheme_builtin.c @@ -0,0 +1,1096 @@ +/* + * Copyright © 2016 Keith Packard <keithp@keithp.com> + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation, either version 2 of the License, or + * (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, but + * WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + * General Public License for more details. + */ + +#include "ao_scheme.h" +#include <limits.h> +#include <math.h> + +static int +builtin_size(void *addr) +{ + (void) addr; + return sizeof (struct ao_scheme_builtin); +} + +static void +builtin_mark(void *addr) +{ + (void) addr; +} + +static void +builtin_move(void *addr) +{ + (void) addr; +} + +const struct ao_scheme_type ao_scheme_builtin_type = { + .size = builtin_size, + .mark = builtin_mark, + .move = builtin_move +}; + +#ifdef AO_SCHEME_MAKE_CONST + +#define AO_SCHEME_BUILTIN_CASENAME +#include "ao_scheme_builtin.h" + +char *ao_scheme_args_name(uint8_t args) { + args &= AO_SCHEME_FUNC_MASK; + switch (args) { + case AO_SCHEME_FUNC_LAMBDA: return ao_scheme_poly_atom(_ao_scheme_atom_lambda)->name; + case AO_SCHEME_FUNC_NLAMBDA: return ao_scheme_poly_atom(_ao_scheme_atom_nlambda)->name; + case AO_SCHEME_FUNC_MACRO: return ao_scheme_poly_atom(_ao_scheme_atom_macro)->name; + default: return "???"; + } +} +#else + +#define AO_SCHEME_BUILTIN_ARRAYNAME +#include "ao_scheme_builtin.h" + +static char * +ao_scheme_builtin_name(enum ao_scheme_builtin_id b) { + if (b < _builtin_last) + return ao_scheme_poly_atom(builtin_names[b])->name; + return "???"; +} + +static const ao_poly ao_scheme_args_atoms[] = { + [AO_SCHEME_FUNC_LAMBDA] = _ao_scheme_atom_lambda, + [AO_SCHEME_FUNC_NLAMBDA] = _ao_scheme_atom_nlambda, + [AO_SCHEME_FUNC_MACRO] = _ao_scheme_atom_macro, +}; + +char * +ao_scheme_args_name(uint8_t args) +{ + args &= AO_SCHEME_FUNC_MASK; + if (args < sizeof ao_scheme_args_atoms / sizeof ao_scheme_args_atoms[0]) + return ao_scheme_poly_atom(ao_scheme_args_atoms[args])->name; + return "(unknown)"; +} +#endif + +void +ao_scheme_builtin_write(ao_poly b) +{ + struct ao_scheme_builtin *builtin = ao_scheme_poly_builtin(b); + printf("%s", ao_scheme_builtin_name(builtin->func)); +} + +ao_poly +ao_scheme_check_argc(ao_poly name, struct ao_scheme_cons *cons, int min, int max) +{ + int argc = 0; + + while (cons && argc <= max) { + argc++; + cons = ao_scheme_cons_cdr(cons); + } + if (argc < min || argc > max) + return ao_scheme_error(AO_SCHEME_INVALID, "%s: invalid arg count", ao_scheme_poly_atom(name)->name); + return _ao_scheme_bool_true; +} + +ao_poly +ao_scheme_arg(struct ao_scheme_cons *cons, int argc) +{ + if (!cons) + return AO_SCHEME_NIL; + while (argc--) { + if (!cons) + return AO_SCHEME_NIL; + cons = ao_scheme_cons_cdr(cons); + } + return cons->car; +} + +ao_poly +ao_scheme_check_argt(ao_poly name, struct ao_scheme_cons *cons, int argc, int type, int nil_ok) +{ + ao_poly car = ao_scheme_arg(cons, argc); + + if ((!car && !nil_ok) || ao_scheme_poly_type(car) != type) + return ao_scheme_error(AO_SCHEME_INVALID, "%v: arg %d invalid type %v", name, argc, car); + return _ao_scheme_bool_true; +} + +int32_t +ao_scheme_arg_int(ao_poly name, struct ao_scheme_cons *cons, int argc) +{ + ao_poly p = ao_scheme_arg(cons, argc); + int32_t i = ao_scheme_poly_integer(p); + + if (i == AO_SCHEME_NOT_INTEGER) + (void) ao_scheme_error(AO_SCHEME_INVALID, "%v: arg %d invalid type %v", name, argc, p); + return i; +} + +ao_poly +ao_scheme_do_car(struct ao_scheme_cons *cons) +{ + if (!ao_scheme_check_argc(_ao_scheme_atom_car, cons, 1, 1)) + return AO_SCHEME_NIL; + if (!ao_scheme_check_argt(_ao_scheme_atom_car, cons, 0, AO_SCHEME_CONS, 0)) + return AO_SCHEME_NIL; + return ao_scheme_poly_cons(cons->car)->car; +} + +ao_poly +ao_scheme_do_cdr(struct ao_scheme_cons *cons) +{ + if (!ao_scheme_check_argc(_ao_scheme_atom_cdr, cons, 1, 1)) + return AO_SCHEME_NIL; + if (!ao_scheme_check_argt(_ao_scheme_atom_cdr, cons, 0, AO_SCHEME_CONS, 0)) + return AO_SCHEME_NIL; + return ao_scheme_poly_cons(cons->car)->cdr; +} + +ao_poly +ao_scheme_do_cons(struct ao_scheme_cons *cons) +{ + ao_poly car, cdr; + if(!ao_scheme_check_argc(_ao_scheme_atom_cons, cons, 2, 2)) + return AO_SCHEME_NIL; + car = ao_scheme_arg(cons, 0); + cdr = ao_scheme_arg(cons, 1); + return ao_scheme__cons(car, cdr); +} + +ao_poly +ao_scheme_do_last(struct ao_scheme_cons *cons) +{ + struct ao_scheme_cons *list; + if (!ao_scheme_check_argc(_ao_scheme_atom_last, cons, 1, 1)) + return AO_SCHEME_NIL; + if (!ao_scheme_check_argt(_ao_scheme_atom_last, cons, 0, AO_SCHEME_CONS, 1)) + return AO_SCHEME_NIL; + for (list = ao_scheme_poly_cons(ao_scheme_arg(cons, 0)); + list; + list = ao_scheme_cons_cdr(list)) + { + if (!list->cdr) + return list->car; + } + return AO_SCHEME_NIL; +} + +ao_poly +ao_scheme_do_length(struct ao_scheme_cons *cons) +{ + if (!ao_scheme_check_argc(_ao_scheme_atom_length, cons, 1, 1)) + return AO_SCHEME_NIL; + if (!ao_scheme_check_argt(_ao_scheme_atom_length, cons, 0, AO_SCHEME_CONS, 1)) + return AO_SCHEME_NIL; + return ao_scheme_int_poly(ao_scheme_cons_length(ao_scheme_poly_cons(ao_scheme_arg(cons, 0)))); +} + +ao_poly +ao_scheme_do_list_copy(struct ao_scheme_cons *cons) +{ + struct ao_scheme_cons *new; + + if (!ao_scheme_check_argc(_ao_scheme_atom_length, cons, 1, 1)) + return AO_SCHEME_NIL; + if (!ao_scheme_check_argt(_ao_scheme_atom_length, cons, 0, AO_SCHEME_CONS, 1)) + return AO_SCHEME_NIL; + new = ao_scheme_cons_copy(ao_scheme_poly_cons(ao_scheme_arg(cons, 0))); + return ao_scheme_cons_poly(new); +} + +ao_poly +ao_scheme_do_quote(struct ao_scheme_cons *cons) +{ + if (!ao_scheme_check_argc(_ao_scheme_atom_quote, cons, 1, 1)) + return AO_SCHEME_NIL; + return ao_scheme_arg(cons, 0); +} + +ao_poly +ao_scheme_do_set(struct ao_scheme_cons *cons) +{ + if (!ao_scheme_check_argc(_ao_scheme_atom_set, cons, 2, 2)) + return AO_SCHEME_NIL; + if (!ao_scheme_check_argt(_ao_scheme_atom_set, cons, 0, AO_SCHEME_ATOM, 0)) + return AO_SCHEME_NIL; + + return ao_scheme_atom_set(ao_scheme_arg(cons, 0), ao_scheme_arg(cons, 1)); +} + +ao_poly +ao_scheme_do_def(struct ao_scheme_cons *cons) +{ + if (!ao_scheme_check_argc(_ao_scheme_atom_def, cons, 2, 2)) + return AO_SCHEME_NIL; + if (!ao_scheme_check_argt(_ao_scheme_atom_def, cons, 0, AO_SCHEME_ATOM, 0)) + return AO_SCHEME_NIL; + + return ao_scheme_atom_def(ao_scheme_arg(cons, 0), ao_scheme_arg(cons, 1)); +} + +ao_poly +ao_scheme_do_setq(struct ao_scheme_cons *cons) +{ + ao_poly name; + if (!ao_scheme_check_argc(_ao_scheme_atom_set21, cons, 2, 2)) + return AO_SCHEME_NIL; + name = cons->car; + if (ao_scheme_poly_type(name) != AO_SCHEME_ATOM) + return ao_scheme_error(AO_SCHEME_INVALID, "set! of non-atom %v", name); + if (!ao_scheme_atom_ref(name, NULL)) + return ao_scheme_error(AO_SCHEME_INVALID, "atom %v not defined", name); + return ao_scheme__cons(_ao_scheme_atom_set, + ao_scheme__cons(ao_scheme__cons(_ao_scheme_atom_quote, + ao_scheme__cons(name, AO_SCHEME_NIL)), + cons->cdr)); +} + +ao_poly +ao_scheme_do_cond(struct ao_scheme_cons *cons) +{ + ao_scheme_set_cond(cons); + return AO_SCHEME_NIL; +} + +ao_poly +ao_scheme_do_begin(struct ao_scheme_cons *cons) +{ + ao_scheme_stack->state = eval_begin; + ao_scheme_stack->sexprs = ao_scheme_cons_poly(cons); + return AO_SCHEME_NIL; +} + +ao_poly +ao_scheme_do_while(struct ao_scheme_cons *cons) +{ + ao_scheme_stack->state = eval_while; + ao_scheme_stack->sexprs = ao_scheme_cons_poly(cons); + return AO_SCHEME_NIL; +} + +ao_poly +ao_scheme_do_write(struct ao_scheme_cons *cons) +{ + ao_poly val = AO_SCHEME_NIL; + while (cons) { + val = cons->car; + ao_scheme_poly_write(val); + cons = ao_scheme_cons_cdr(cons); + if (cons) + printf(" "); + } + return _ao_scheme_bool_true; +} + +ao_poly +ao_scheme_do_display(struct ao_scheme_cons *cons) +{ + ao_poly val = AO_SCHEME_NIL; + while (cons) { + val = cons->car; + ao_scheme_poly_display(val); + cons = ao_scheme_cons_cdr(cons); + } + return _ao_scheme_bool_true; +} + +ao_poly +ao_scheme_math(struct ao_scheme_cons *orig_cons, enum ao_scheme_builtin_id op) +{ + struct ao_scheme_cons *cons = cons; + ao_poly ret = AO_SCHEME_NIL; + + for (cons = orig_cons; cons; cons = ao_scheme_cons_cdr(cons)) { + ao_poly car = cons->car; + uint8_t rt = ao_scheme_poly_type(ret); + uint8_t ct = ao_scheme_poly_type(car); + + if (cons == orig_cons) { + ret = car; + ao_scheme_cons_stash(0, cons); + if (cons->cdr == AO_SCHEME_NIL) { + switch (op) { + case builtin_minus: + if (ao_scheme_integer_typep(ct)) + ret = ao_scheme_integer_poly(-ao_scheme_poly_integer(ret)); + else if (ct == AO_SCHEME_FLOAT) + ret = ao_scheme_float_get(-ao_scheme_poly_number(ret)); + break; + case builtin_divide: + if (ao_scheme_integer_typep(ct) && ao_scheme_poly_integer(ret) == 1) + ; + else if (ao_scheme_number_typep(ct)) { + float v = ao_scheme_poly_number(ret); + ret = ao_scheme_float_get(1/v); + } + break; + default: + break; + } + } + cons = ao_scheme_cons_fetch(0); + } else if (ao_scheme_integer_typep(rt) && ao_scheme_integer_typep(ct)) { + int32_t r = ao_scheme_poly_integer(ret); + int32_t c = ao_scheme_poly_integer(car); + int64_t t; + + switch(op) { + case builtin_plus: + r += c; + check_overflow: + if (r < AO_SCHEME_MIN_BIGINT || AO_SCHEME_MAX_BIGINT < r) + goto inexact; + break; + case builtin_minus: + r -= c; + goto check_overflow; + break; + case builtin_times: + t = (int64_t) r * (int64_t) c; + if (t < AO_SCHEME_MIN_BIGINT || AO_SCHEME_MAX_BIGINT < t) + goto inexact; + r = (int32_t) t; + break; + case builtin_divide: + if (c != 0 && (r % c) == 0) + r /= c; + else + goto inexact; + break; + case builtin_quotient: + if (c == 0) + return ao_scheme_error(AO_SCHEME_DIVIDE_BY_ZERO, "quotient by zero"); + if (r % c != 0 && (c < 0) != (r < 0)) + r = r / c - 1; + else + r = r / c; + break; + case builtin_remainder: + if (c == 0) + return ao_scheme_error(AO_SCHEME_DIVIDE_BY_ZERO, "remainder by zero"); + r %= c; + break; + case builtin_modulo: + if (c == 0) + return ao_scheme_error(AO_SCHEME_DIVIDE_BY_ZERO, "modulo by zero"); + r %= c; + if ((r < 0) != (c < 0)) + r += c; + break; + default: + break; + } + ao_scheme_cons_stash(0, cons); + ret = ao_scheme_integer_poly(r); + cons = ao_scheme_cons_fetch(0); + } else if (ao_scheme_number_typep(rt) && ao_scheme_number_typep(ct)) { + float r, c; + inexact: + r = ao_scheme_poly_number(ret); + c = ao_scheme_poly_number(car); + switch(op) { + case builtin_plus: + r += c; + break; + case builtin_minus: + r -= c; + break; + case builtin_times: + r *= c; + break; + case builtin_divide: + r /= c; + break; + case builtin_quotient: + case builtin_remainder: + case builtin_modulo: + return ao_scheme_error(AO_SCHEME_INVALID, "non-integer value in integer divide"); + default: + break; + } + ao_scheme_cons_stash(0, cons); + ret = ao_scheme_float_get(r); + cons = ao_scheme_cons_fetch(0); + } + else if (rt == AO_SCHEME_STRING && ct == AO_SCHEME_STRING && op == builtin_plus) { + ao_scheme_cons_stash(0, cons); + ret = ao_scheme_string_poly(ao_scheme_string_cat(ao_scheme_poly_string(ret), + ao_scheme_poly_string(car))); + cons = ao_scheme_cons_fetch(0); + if (!ret) + return ret; + } + else + return ao_scheme_error(AO_SCHEME_INVALID, "invalid args"); + } + return ret; +} + +ao_poly +ao_scheme_do_plus(struct ao_scheme_cons *cons) +{ + return ao_scheme_math(cons, builtin_plus); +} + +ao_poly +ao_scheme_do_minus(struct ao_scheme_cons *cons) +{ + return ao_scheme_math(cons, builtin_minus); +} + +ao_poly +ao_scheme_do_times(struct ao_scheme_cons *cons) +{ + return ao_scheme_math(cons, builtin_times); +} + +ao_poly +ao_scheme_do_divide(struct ao_scheme_cons *cons) +{ + return ao_scheme_math(cons, builtin_divide); +} + +ao_poly +ao_scheme_do_quotient(struct ao_scheme_cons *cons) +{ + return ao_scheme_math(cons, builtin_quotient); +} + +ao_poly +ao_scheme_do_modulo(struct ao_scheme_cons *cons) +{ + return ao_scheme_math(cons, builtin_modulo); +} + +ao_poly +ao_scheme_do_remainder(struct ao_scheme_cons *cons) +{ + return ao_scheme_math(cons, builtin_remainder); +} + +ao_poly +ao_scheme_compare(struct ao_scheme_cons *cons, enum ao_scheme_builtin_id op) +{ + ao_poly left; + + if (!cons) + return _ao_scheme_bool_true; + + left = cons->car; + for (cons = ao_scheme_cons_cdr(cons); cons; cons = ao_scheme_cons_cdr(cons)) { + ao_poly right = cons->car; + + if (op == builtin_equal && left == right) { + ; + } else { + uint8_t lt = ao_scheme_poly_type(left); + uint8_t rt = ao_scheme_poly_type(right); + if (ao_scheme_integer_typep(lt) && ao_scheme_integer_typep(rt)) { + int32_t l = ao_scheme_poly_integer(left); + int32_t r = ao_scheme_poly_integer(right); + + switch (op) { + case builtin_less: + if (!(l < r)) + return _ao_scheme_bool_false; + break; + case builtin_greater: + if (!(l > r)) + return _ao_scheme_bool_false; + break; + case builtin_less_equal: + if (!(l <= r)) + return _ao_scheme_bool_false; + break; + case builtin_greater_equal: + if (!(l >= r)) + return _ao_scheme_bool_false; + break; + case builtin_equal: + if (!(l == r)) + return _ao_scheme_bool_false; + default: + break; + } + } else if (ao_scheme_number_typep(lt) && ao_scheme_number_typep(rt)) { + float l, r; + + l = ao_scheme_poly_number(left); + r = ao_scheme_poly_number(right); + + switch (op) { + case builtin_less: + if (!(l < r)) + return _ao_scheme_bool_false; + break; + case builtin_greater: + if (!(l > r)) + return _ao_scheme_bool_false; + break; + case builtin_less_equal: + if (!(l <= r)) + return _ao_scheme_bool_false; + break; + case builtin_greater_equal: + if (!(l >= r)) + return _ao_scheme_bool_false; + break; + case builtin_equal: + if (!(l == r)) + return _ao_scheme_bool_false; + default: + break; + } + } else if (lt == AO_SCHEME_STRING && rt == AO_SCHEME_STRING) { + int c = strcmp(ao_scheme_poly_string(left), + ao_scheme_poly_string(right)); + switch (op) { + case builtin_less: + if (!(c < 0)) + return _ao_scheme_bool_false; + break; + case builtin_greater: + if (!(c > 0)) + return _ao_scheme_bool_false; + break; + case builtin_less_equal: + if (!(c <= 0)) + return _ao_scheme_bool_false; + break; + case builtin_greater_equal: + if (!(c >= 0)) + return _ao_scheme_bool_false; + break; + case builtin_equal: + if (!(c == 0)) + return _ao_scheme_bool_false; + break; + default: + break; + } + } else + return _ao_scheme_bool_false; + } + left = right; + } + return _ao_scheme_bool_true; +} + +ao_poly +ao_scheme_do_equal(struct ao_scheme_cons *cons) +{ + return ao_scheme_compare(cons, builtin_equal); +} + +ao_poly +ao_scheme_do_less(struct ao_scheme_cons *cons) +{ + return ao_scheme_compare(cons, builtin_less); +} + +ao_poly +ao_scheme_do_greater(struct ao_scheme_cons *cons) +{ + return ao_scheme_compare(cons, builtin_greater); +} + +ao_poly +ao_scheme_do_less_equal(struct ao_scheme_cons *cons) +{ + return ao_scheme_compare(cons, builtin_less_equal); +} + +ao_poly +ao_scheme_do_greater_equal(struct ao_scheme_cons *cons) +{ + return ao_scheme_compare(cons, builtin_greater_equal); +} + +ao_poly +ao_scheme_do_list_to_string(struct ao_scheme_cons *cons) +{ + if (!ao_scheme_check_argc(_ao_scheme_atom_list2d3estring, cons, 1, 1)) + return AO_SCHEME_NIL; + if (!ao_scheme_check_argt(_ao_scheme_atom_list2d3estring, cons, 0, AO_SCHEME_CONS, 1)) + return AO_SCHEME_NIL; + return ao_scheme_string_pack(ao_scheme_poly_cons(ao_scheme_arg(cons, 0))); +} + +ao_poly +ao_scheme_do_string_to_list(struct ao_scheme_cons *cons) +{ + if (!ao_scheme_check_argc(_ao_scheme_atom_string2d3elist, cons, 1, 1)) + return AO_SCHEME_NIL; + if (!ao_scheme_check_argt(_ao_scheme_atom_string2d3elist, cons, 0, AO_SCHEME_STRING, 0)) + return AO_SCHEME_NIL; + return ao_scheme_string_unpack(ao_scheme_poly_string(ao_scheme_arg(cons, 0))); +} + +ao_poly +ao_scheme_do_string_ref(struct ao_scheme_cons *cons) +{ + char *string; + int32_t ref; + if (!ao_scheme_check_argc(_ao_scheme_atom_string2dref, cons, 2, 2)) + return AO_SCHEME_NIL; + if (!ao_scheme_check_argt(_ao_scheme_atom_string2dref, cons, 0, AO_SCHEME_STRING, 0)) + return AO_SCHEME_NIL; + ref = ao_scheme_arg_int(_ao_scheme_atom_string2dref, cons, 1); + if (ref == AO_SCHEME_NOT_INTEGER) + return AO_SCHEME_NIL; + string = ao_scheme_poly_string(ao_scheme_arg(cons, 0)); + while (*string && ref) { + ++string; + --ref; + } + if (!*string) + return ao_scheme_error(AO_SCHEME_INVALID, "%v: string %v ref %v invalid", + _ao_scheme_atom_string2dref, + ao_scheme_arg(cons, 0), + ao_scheme_arg(cons, 1)); + return ao_scheme_int_poly(*string); +} + +ao_poly +ao_scheme_do_string_length(struct ao_scheme_cons *cons) +{ + char *string; + + if (!ao_scheme_check_argc(_ao_scheme_atom_string2dlength, cons, 1, 1)) + return AO_SCHEME_NIL; + if (!ao_scheme_check_argt(_ao_scheme_atom_string2dlength, cons, 0, AO_SCHEME_STRING, 0)) + return AO_SCHEME_NIL; + string = ao_scheme_poly_string(ao_scheme_arg(cons, 0)); + return ao_scheme_integer_poly(strlen(string)); +} + +ao_poly +ao_scheme_do_string_copy(struct ao_scheme_cons *cons) +{ + char *string; + + if (!ao_scheme_check_argc(_ao_scheme_atom_string2dcopy, cons, 1, 1)) + return AO_SCHEME_NIL; + if (!ao_scheme_check_argt(_ao_scheme_atom_string2dcopy, cons, 0, AO_SCHEME_STRING, 0)) + return AO_SCHEME_NIL; + string = ao_scheme_poly_string(ao_scheme_arg(cons, 0)); + return ao_scheme_string_poly(ao_scheme_string_copy(string)); +} + +ao_poly +ao_scheme_do_string_set(struct ao_scheme_cons *cons) +{ + char *string; + int32_t ref; + int32_t val; + + if (!ao_scheme_check_argc(_ao_scheme_atom_string2dset21, cons, 3, 3)) + return AO_SCHEME_NIL; + if (!ao_scheme_check_argt(_ao_scheme_atom_string2dset21, cons, 0, AO_SCHEME_STRING, 0)) + return AO_SCHEME_NIL; + string = ao_scheme_poly_string(ao_scheme_arg(cons, 0)); + ref = ao_scheme_arg_int(_ao_scheme_atom_string2dset21, cons, 1); + if (ref == AO_SCHEME_NOT_INTEGER) + return AO_SCHEME_NIL; + val = ao_scheme_arg_int(_ao_scheme_atom_string2dset21, cons, 2); + if (val == AO_SCHEME_NOT_INTEGER) + return AO_SCHEME_NIL; + while (*string && ref) { + ++string; + --ref; + } + if (!*string) + return ao_scheme_error(AO_SCHEME_INVALID, "%v: string %v ref %v invalid", + _ao_scheme_atom_string2dset21, + ao_scheme_arg(cons, 0), + ao_scheme_arg(cons, 1)); + *string = val; + return ao_scheme_int_poly(*string); +} + +ao_poly +ao_scheme_do_flush_output(struct ao_scheme_cons *cons) +{ + if (!ao_scheme_check_argc(_ao_scheme_atom_flush2doutput, cons, 0, 0)) + return AO_SCHEME_NIL; + ao_scheme_os_flush(); + return _ao_scheme_bool_true; +} + +ao_poly +ao_scheme_do_led(struct ao_scheme_cons *cons) +{ + int32_t led; + if (!ao_scheme_check_argc(_ao_scheme_atom_led, cons, 1, 1)) + return AO_SCHEME_NIL; + led = ao_scheme_arg_int(_ao_scheme_atom_led, cons, 0); + if (led == AO_SCHEME_NOT_INTEGER) + return AO_SCHEME_NIL; + led = ao_scheme_arg(cons, 0); + ao_scheme_os_led(ao_scheme_poly_int(led)); + return led; +} + +ao_poly +ao_scheme_do_delay(struct ao_scheme_cons *cons) +{ + int32_t delay; + + if (!ao_scheme_check_argc(_ao_scheme_atom_delay, cons, 1, 1)) + return AO_SCHEME_NIL; + delay = ao_scheme_arg_int(_ao_scheme_atom_delay, cons, 0); + if (delay == AO_SCHEME_NOT_INTEGER) + return AO_SCHEME_NIL; + ao_scheme_os_delay(delay); + return delay; +} + +ao_poly +ao_scheme_do_eval(struct ao_scheme_cons *cons) +{ + if (!ao_scheme_check_argc(_ao_scheme_atom_eval, cons, 1, 1)) + return AO_SCHEME_NIL; + ao_scheme_stack->state = eval_sexpr; + return cons->car; +} + +ao_poly +ao_scheme_do_apply(struct ao_scheme_cons *cons) +{ + if (!ao_scheme_check_argc(_ao_scheme_atom_apply, cons, 2, INT_MAX)) + return AO_SCHEME_NIL; + ao_scheme_stack->state = eval_apply; + return ao_scheme_cons_poly(cons); +} + +ao_poly +ao_scheme_do_read(struct ao_scheme_cons *cons) +{ + if (!ao_scheme_check_argc(_ao_scheme_atom_read, cons, 0, 0)) + return AO_SCHEME_NIL; + return ao_scheme_read(); +} + +ao_poly +ao_scheme_do_collect(struct ao_scheme_cons *cons) +{ + int free; + (void) cons; + free = ao_scheme_collect(AO_SCHEME_COLLECT_FULL); + return ao_scheme_integer_poly(free); +} + +ao_poly +ao_scheme_do_nullp(struct ao_scheme_cons *cons) +{ + if (!ao_scheme_check_argc(_ao_scheme_atom_led, cons, 1, 1)) + return AO_SCHEME_NIL; + if (ao_scheme_arg(cons, 0) == AO_SCHEME_NIL) + return _ao_scheme_bool_true; + else + return _ao_scheme_bool_false; +} + +ao_poly +ao_scheme_do_not(struct ao_scheme_cons *cons) +{ + if (!ao_scheme_check_argc(_ao_scheme_atom_led, cons, 1, 1)) + return AO_SCHEME_NIL; + if (ao_scheme_arg(cons, 0) == _ao_scheme_bool_false) + return _ao_scheme_bool_true; + else + return _ao_scheme_bool_false; +} + +static ao_poly +ao_scheme_do_typep(int type, struct ao_scheme_cons *cons) +{ + if (!ao_scheme_check_argc(_ao_scheme_atom_led, cons, 1, 1)) + return AO_SCHEME_NIL; + if (ao_scheme_poly_type(ao_scheme_arg(cons, 0)) == type) + return _ao_scheme_bool_true; + return _ao_scheme_bool_false; +} + +ao_poly +ao_scheme_do_pairp(struct ao_scheme_cons *cons) +{ + ao_poly v; + if (!ao_scheme_check_argc(_ao_scheme_atom_led, cons, 1, 1)) + return AO_SCHEME_NIL; + v = ao_scheme_arg(cons, 0); + if (v != AO_SCHEME_NIL && ao_scheme_poly_type(v) == AO_SCHEME_CONS) + return _ao_scheme_bool_true; + return _ao_scheme_bool_false; +} + +ao_poly +ao_scheme_do_integerp(struct ao_scheme_cons *cons) +{ + if (!ao_scheme_check_argc(_ao_scheme_atom_led, cons, 1, 1)) + return AO_SCHEME_NIL; + switch (ao_scheme_poly_type(ao_scheme_arg(cons, 0))) { + case AO_SCHEME_INT: + case AO_SCHEME_BIGINT: + return _ao_scheme_bool_true; + default: + return _ao_scheme_bool_false; + } +} + +ao_poly +ao_scheme_do_numberp(struct ao_scheme_cons *cons) +{ + if (!ao_scheme_check_argc(_ao_scheme_atom_led, cons, 1, 1)) + return AO_SCHEME_NIL; + switch (ao_scheme_poly_type(ao_scheme_arg(cons, 0))) { + case AO_SCHEME_INT: + case AO_SCHEME_BIGINT: + case AO_SCHEME_FLOAT: + return _ao_scheme_bool_true; + default: + return _ao_scheme_bool_false; + } +} + +ao_poly +ao_scheme_do_stringp(struct ao_scheme_cons *cons) +{ + return ao_scheme_do_typep(AO_SCHEME_STRING, cons); +} + +ao_poly +ao_scheme_do_symbolp(struct ao_scheme_cons *cons) +{ + return ao_scheme_do_typep(AO_SCHEME_ATOM, cons); +} + +ao_poly +ao_scheme_do_booleanp(struct ao_scheme_cons *cons) +{ + return ao_scheme_do_typep(AO_SCHEME_BOOL, cons); +} + +ao_poly +ao_scheme_do_procedurep(struct ao_scheme_cons *cons) +{ + if (!ao_scheme_check_argc(_ao_scheme_atom_led, cons, 1, 1)) + return AO_SCHEME_NIL; + switch (ao_scheme_poly_type(ao_scheme_arg(cons, 0))) { + case AO_SCHEME_BUILTIN: + case AO_SCHEME_LAMBDA: + return _ao_scheme_bool_true; + default: + return _ao_scheme_bool_false; + } +} + +/* This one is special -- a list is either nil or + * a 'proper' list with only cons cells + */ +ao_poly +ao_scheme_do_listp(struct ao_scheme_cons *cons) +{ + ao_poly v; + if (!ao_scheme_check_argc(_ao_scheme_atom_list3f, cons, 1, 1)) + return AO_SCHEME_NIL; + v = ao_scheme_arg(cons, 0); + for (;;) { + if (v == AO_SCHEME_NIL) + return _ao_scheme_bool_true; + if (ao_scheme_poly_type(v) != AO_SCHEME_CONS) + return _ao_scheme_bool_false; + v = ao_scheme_poly_cons(v)->cdr; + } +} + +ao_poly +ao_scheme_do_set_car(struct ao_scheme_cons *cons) +{ + if (!ao_scheme_check_argc(_ao_scheme_atom_led, cons, 2, 2)) + return AO_SCHEME_NIL; + if (!ao_scheme_check_argt(_ao_scheme_atom_led, cons, 0, AO_SCHEME_CONS, 0)) + return AO_SCHEME_NIL; + return ao_scheme_poly_cons(ao_scheme_arg(cons, 0))->car = ao_scheme_arg(cons, 1); +} + +ao_poly +ao_scheme_do_set_cdr(struct ao_scheme_cons *cons) +{ + if (!ao_scheme_check_argc(_ao_scheme_atom_led, cons, 2, 2)) + return AO_SCHEME_NIL; + if (!ao_scheme_check_argt(_ao_scheme_atom_led, cons, 0, AO_SCHEME_CONS, 0)) + return AO_SCHEME_NIL; + return ao_scheme_poly_cons(ao_scheme_arg(cons, 0))->cdr = ao_scheme_arg(cons, 1); +} + +ao_poly +ao_scheme_do_symbol_to_string(struct ao_scheme_cons *cons) +{ + if (!ao_scheme_check_argc(_ao_scheme_atom_led, cons, 1, 1)) + return AO_SCHEME_NIL; + if (!ao_scheme_check_argt(_ao_scheme_atom_led, cons, 0, AO_SCHEME_ATOM, 0)) + return AO_SCHEME_NIL; + return ao_scheme_string_poly(ao_scheme_string_copy(ao_scheme_poly_atom(ao_scheme_arg(cons, 0))->name)); +} + +ao_poly +ao_scheme_do_string_to_symbol(struct ao_scheme_cons *cons) +{ + if (!ao_scheme_check_argc(_ao_scheme_atom_led, cons, 1, 1)) + return AO_SCHEME_NIL; + if (!ao_scheme_check_argt(_ao_scheme_atom_led, cons, 0, AO_SCHEME_STRING, 0)) + return AO_SCHEME_NIL; + + return ao_scheme_atom_poly(ao_scheme_atom_intern(ao_scheme_poly_string(ao_scheme_arg(cons, 0)))); +} + +ao_poly +ao_scheme_do_read_char(struct ao_scheme_cons *cons) +{ + int c; + if (!ao_scheme_check_argc(_ao_scheme_atom_led, cons, 0, 0)) + return AO_SCHEME_NIL; + c = getchar(); + return ao_scheme_int_poly(c); +} + +ao_poly +ao_scheme_do_write_char(struct ao_scheme_cons *cons) +{ + if (!ao_scheme_check_argc(_ao_scheme_atom_led, cons, 1, 1)) + return AO_SCHEME_NIL; + if (!ao_scheme_check_argt(_ao_scheme_atom_led, cons, 0, AO_SCHEME_INT, 0)) + return AO_SCHEME_NIL; + putchar(ao_scheme_poly_integer(ao_scheme_arg(cons, 0))); + return _ao_scheme_bool_true; +} + +ao_poly +ao_scheme_do_exit(struct ao_scheme_cons *cons) +{ + if (!ao_scheme_check_argc(_ao_scheme_atom_led, cons, 0, 0)) + return AO_SCHEME_NIL; + ao_scheme_exception |= AO_SCHEME_EXIT; + return _ao_scheme_bool_true; +} + +ao_poly +ao_scheme_do_current_jiffy(struct ao_scheme_cons *cons) +{ + int jiffy; + + if (!ao_scheme_check_argc(_ao_scheme_atom_led, cons, 0, 0)) + return AO_SCHEME_NIL; + jiffy = ao_scheme_os_jiffy(); + return (ao_scheme_int_poly(jiffy)); +} + +ao_poly +ao_scheme_do_current_second(struct ao_scheme_cons *cons) +{ + int second; + + if (!ao_scheme_check_argc(_ao_scheme_atom_led, cons, 0, 0)) + return AO_SCHEME_NIL; + second = ao_scheme_os_jiffy() / AO_SCHEME_JIFFIES_PER_SECOND; + return (ao_scheme_int_poly(second)); +} + +ao_poly +ao_scheme_do_jiffies_per_second(struct ao_scheme_cons *cons) +{ + if (!ao_scheme_check_argc(_ao_scheme_atom_led, cons, 0, 0)) + return AO_SCHEME_NIL; + return (ao_scheme_int_poly(AO_SCHEME_JIFFIES_PER_SECOND)); +} + +ao_poly +ao_scheme_do_vector(struct ao_scheme_cons *cons) +{ + return ao_scheme_vector_poly(ao_scheme_list_to_vector(cons)); +} + +ao_poly +ao_scheme_do_make_vector(struct ao_scheme_cons *cons) +{ + int32_t k; + + if (!ao_scheme_check_argc(_ao_scheme_atom_make2dvector, cons, 2, 2)) + return AO_SCHEME_NIL; + k = ao_scheme_arg_int(_ao_scheme_atom_make2dvector, cons, 0); + if (k == AO_SCHEME_NOT_INTEGER) + return AO_SCHEME_NIL; + return ao_scheme_vector_poly(ao_scheme_vector_alloc(k, ao_scheme_arg(cons, 1))); +} + +ao_poly +ao_scheme_do_vector_ref(struct ao_scheme_cons *cons) +{ + if (!ao_scheme_check_argc(_ao_scheme_atom_vector2dref, cons, 2, 2)) + return AO_SCHEME_NIL; + if (!ao_scheme_check_argt(_ao_scheme_atom_vector2dref, cons, 0, AO_SCHEME_VECTOR, 0)) + return AO_SCHEME_NIL; + return ao_scheme_vector_get(ao_scheme_arg(cons, 0), ao_scheme_arg(cons, 1)); +} + +ao_poly +ao_scheme_do_vector_set(struct ao_scheme_cons *cons) +{ + if (!ao_scheme_check_argc(_ao_scheme_atom_vector2dset21, cons, 3, 3)) + return AO_SCHEME_NIL; + if (!ao_scheme_check_argt(_ao_scheme_atom_vector2dset21, cons, 0, AO_SCHEME_VECTOR, 0)) + return AO_SCHEME_NIL; + return ao_scheme_vector_set(ao_scheme_arg(cons, 0), ao_scheme_arg(cons, 1), ao_scheme_arg(cons, 2)); +} + +ao_poly +ao_scheme_do_list_to_vector(struct ao_scheme_cons *cons) +{ + if (!ao_scheme_check_argc(_ao_scheme_atom_list2d3evector, cons, 1, 1)) + return AO_SCHEME_NIL; + if (!ao_scheme_check_argt(_ao_scheme_atom_list2d3evector, cons, 0, AO_SCHEME_CONS, 0)) + return AO_SCHEME_NIL; + return ao_scheme_vector_poly(ao_scheme_list_to_vector(ao_scheme_poly_cons(ao_scheme_arg(cons, 0)))); +} + +ao_poly +ao_scheme_do_vector_to_list(struct ao_scheme_cons *cons) +{ + if (!ao_scheme_check_argc(_ao_scheme_atom_vector2d3elist, cons, 1, 1)) + return AO_SCHEME_NIL; + if (!ao_scheme_check_argt(_ao_scheme_atom_vector2d3elist, cons, 0, AO_SCHEME_VECTOR, 0)) + return AO_SCHEME_NIL; + return ao_scheme_cons_poly(ao_scheme_vector_to_list(ao_scheme_poly_vector(ao_scheme_arg(cons, 0)))); +} + +ao_poly +ao_scheme_do_vector_length(struct ao_scheme_cons *cons) +{ + if (!ao_scheme_check_argc(_ao_scheme_atom_vector2d3elist, cons, 1, 1)) + return AO_SCHEME_NIL; + if (!ao_scheme_check_argt(_ao_scheme_atom_vector2d3elist, cons, 0, AO_SCHEME_VECTOR, 0)) + return AO_SCHEME_NIL; + return ao_scheme_integer_poly(ao_scheme_poly_vector(ao_scheme_arg(cons, 0))->length); +} + +ao_poly +ao_scheme_do_vectorp(struct ao_scheme_cons *cons) +{ + return ao_scheme_do_typep(AO_SCHEME_VECTOR, cons); +} + +#define AO_SCHEME_BUILTIN_FUNCS +#include "ao_scheme_builtin.h" diff --git a/src/scheme/ao_scheme_builtin.txt b/src/scheme/ao_scheme_builtin.txt new file mode 100644 index 00000000..17f5ea0c --- /dev/null +++ b/src/scheme/ao_scheme_builtin.txt @@ -0,0 +1,81 @@ +f_lambda eval +f_lambda read +nlambda lambda +nlambda nlambda +nlambda macro +f_lambda car +f_lambda cdr +f_lambda cons +f_lambda last +f_lambda length +f_lambda list_copy list-copy +nlambda quote +atom quasiquote +atom unquote +atom unquote_splicing unquote-splicing +f_lambda set +macro setq set! +f_lambda def +nlambda cond +nlambda begin +nlambda while +f_lambda write +f_lambda display +f_lambda plus + string-append +f_lambda minus - +f_lambda times * +f_lambda divide / +f_lambda modulo modulo % +f_lambda remainder +f_lambda quotient +f_lambda equal = eq? eqv? +f_lambda less < string<? +f_lambda greater > string>? +f_lambda less_equal <= string<=? +f_lambda greater_equal >= string>=? +f_lambda flush_output flush-output +f_lambda delay +f_lambda led +f_lambda save +f_lambda restore +f_lambda call_cc call-with-current-continuation call/cc +f_lambda collect +f_lambda nullp null? +f_lambda not +f_lambda listp list? +f_lambda pairp pair? +f_lambda integerp integer? exact? exact-integer? +f_lambda numberp number? real? +f_lambda booleanp boolean? +f_lambda set_car set-car! +f_lambda set_cdr set-cdr! +f_lambda symbolp symbol? +f_lambda list_to_string list->string +f_lambda string_to_list string->list +f_lambda symbol_to_string symbol->string +f_lambda string_to_symbol string->symbol +f_lambda stringp string? +f_lambda string_ref string-ref +f_lambda string_set string-set! +f_lambda string_copy string-copy +f_lambda string_length string-length +f_lambda procedurep procedure? +lambda apply +f_lambda read_char read-char +f_lambda write_char write-char +f_lambda exit +f_lambda current_jiffy current-jiffy +f_lambda current_second current-second +f_lambda jiffies_per_second jiffies-per-second +f_lambda finitep finite? +f_lambda infinitep infinite? +f_lambda inexactp inexact? +f_lambda sqrt +f_lambda vector_ref vector-ref +f_lambda vector_set vector-set! +f_lambda vector +f_lambda make_vector make-vector +f_lambda list_to_vector list->vector +f_lambda vector_to_list vector->list +f_lambda vector_length vector-length +f_lambda vectorp vector? diff --git a/src/scheme/ao_scheme_cons.c b/src/scheme/ao_scheme_cons.c new file mode 100644 index 00000000..02512e15 --- /dev/null +++ b/src/scheme/ao_scheme_cons.c @@ -0,0 +1,237 @@ +/* + * Copyright © 2016 Keith Packard <keithp@keithp.com> + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation, either version 2 of the License, or + * (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, but + * WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + * General Public License for more details. + */ + +#include "ao_scheme.h" + +static void cons_mark(void *addr) +{ + struct ao_scheme_cons *cons = addr; + + for (;;) { + ao_poly cdr = cons->cdr; + + ao_scheme_poly_mark(cons->car, 1); + if (!cdr) + break; + if (ao_scheme_poly_type(cdr) != AO_SCHEME_CONS) { + ao_scheme_poly_mark(cdr, 1); + break; + } + cons = ao_scheme_poly_cons(cdr); + if (ao_scheme_mark_memory(&ao_scheme_cons_type, cons)) + break; + } +} + +static int cons_size(void *addr) +{ + (void) addr; + return sizeof (struct ao_scheme_cons); +} + +static void cons_move(void *addr) +{ + struct ao_scheme_cons *cons = addr; + + if (!cons) + return; + + for (;;) { + ao_poly cdr; + struct ao_scheme_cons *c; + int ret; + + MDBG_MOVE("cons_move start %d (%d, %d)\n", + MDBG_OFFSET(cons), MDBG_OFFSET(ao_scheme_ref(cons->car)), MDBG_OFFSET(ao_scheme_ref(cons->cdr))); + (void) ao_scheme_poly_move(&cons->car, 1); + cdr = cons->cdr; + if (!cdr) + break; + if (ao_scheme_poly_base_type(cdr) != AO_SCHEME_CONS) { + (void) ao_scheme_poly_move(&cons->cdr, 0); + break; + } + c = ao_scheme_poly_cons(cdr); + ret = ao_scheme_move_memory(&ao_scheme_cons_type, (void **) &c); + if (c != ao_scheme_poly_cons(cons->cdr)) + cons->cdr = ao_scheme_cons_poly(c); + MDBG_MOVE("cons_move end %d (%d, %d)\n", + MDBG_OFFSET(cons), MDBG_OFFSET(ao_scheme_ref(cons->car)), MDBG_OFFSET(ao_scheme_ref(cons->cdr))); + if (ret) + break; + cons = c; + } +} + +const struct ao_scheme_type ao_scheme_cons_type = { + .mark = cons_mark, + .size = cons_size, + .move = cons_move, + .name = "cons", +}; + +struct ao_scheme_cons *ao_scheme_cons_free_list; + +struct ao_scheme_cons * +ao_scheme_cons_cons(ao_poly car, ao_poly cdr) +{ + struct ao_scheme_cons *cons; + + if (ao_scheme_cons_free_list) { + cons = ao_scheme_cons_free_list; + ao_scheme_cons_free_list = ao_scheme_poly_cons(cons->cdr); + } else { + ao_scheme_poly_stash(0, car); + ao_scheme_poly_stash(1, cdr); + cons = ao_scheme_alloc(sizeof (struct ao_scheme_cons)); + cdr = ao_scheme_poly_fetch(1); + car = ao_scheme_poly_fetch(0); + if (!cons) + return NULL; + } + cons->car = car; + cons->cdr = cdr; + return cons; +} + +struct ao_scheme_cons * +ao_scheme_cons_cdr(struct ao_scheme_cons *cons) +{ + ao_poly cdr = cons->cdr; + if (cdr == AO_SCHEME_NIL) + return NULL; + if (ao_scheme_poly_type(cdr) != AO_SCHEME_CONS) { + (void) ao_scheme_error(AO_SCHEME_INVALID, "improper cdr %v", cdr); + return NULL; + } + return ao_scheme_poly_cons(cdr); +} + +ao_poly +ao_scheme__cons(ao_poly car, ao_poly cdr) +{ + return ao_scheme_cons_poly(ao_scheme_cons_cons(car, cdr)); +} + +struct ao_scheme_cons * +ao_scheme_cons_copy(struct ao_scheme_cons *cons) +{ + struct ao_scheme_cons *head = NULL; + struct ao_scheme_cons *tail = NULL; + + while (cons) { + struct ao_scheme_cons *new; + ao_poly cdr; + + ao_scheme_cons_stash(0, cons); + ao_scheme_cons_stash(1, head); + ao_scheme_poly_stash(0, ao_scheme_cons_poly(tail)); + new = ao_scheme_alloc(sizeof (struct ao_scheme_cons)); + cons = ao_scheme_cons_fetch(0); + head = ao_scheme_cons_fetch(1); + tail = ao_scheme_poly_cons(ao_scheme_poly_fetch(0)); + if (!new) + return AO_SCHEME_NIL; + new->car = cons->car; + new->cdr = AO_SCHEME_NIL; + if (!head) + head = new; + else + tail->cdr = ao_scheme_cons_poly(new); + tail = new; + cdr = cons->cdr; + if (ao_scheme_poly_type(cdr) != AO_SCHEME_CONS) { + tail->cdr = cdr; + break; + } + cons = ao_scheme_poly_cons(cdr); + } + return head; +} + +void +ao_scheme_cons_free(struct ao_scheme_cons *cons) +{ +#if DBG_FREE_CONS + ao_scheme_cons_check(cons); +#endif + while (cons) { + ao_poly cdr = cons->cdr; + cons->cdr = ao_scheme_cons_poly(ao_scheme_cons_free_list); + ao_scheme_cons_free_list = cons; + cons = ao_scheme_poly_cons(cdr); + } +} + +void +ao_scheme_cons_write(ao_poly c) +{ + struct ao_scheme_cons *cons = ao_scheme_poly_cons(c); + ao_poly cdr; + int first = 1; + + printf("("); + while (cons) { + if (!first) + printf(" "); + ao_scheme_poly_write(cons->car); + cdr = cons->cdr; + if (cdr == c) { + printf(" ..."); + break; + } + if (ao_scheme_poly_type(cdr) == AO_SCHEME_CONS) { + cons = ao_scheme_poly_cons(cdr); + first = 0; + } else { + printf(" . "); + ao_scheme_poly_write(cdr); + cons = NULL; + } + } + printf(")"); +} + +void +ao_scheme_cons_display(ao_poly c) +{ + struct ao_scheme_cons *cons = ao_scheme_poly_cons(c); + ao_poly cdr; + + while (cons) { + ao_scheme_poly_display(cons->car); + cdr = cons->cdr; + if (cdr == c) { + printf("..."); + break; + } + if (ao_scheme_poly_type(cdr) == AO_SCHEME_CONS) + cons = ao_scheme_poly_cons(cdr); + else { + ao_scheme_poly_display(cdr); + cons = NULL; + } + } +} + +int +ao_scheme_cons_length(struct ao_scheme_cons *cons) +{ + int len = 0; + while (cons) { + len++; + cons = ao_scheme_cons_cdr(cons); + } + return len; +} diff --git a/src/scheme/ao_scheme_const.scheme b/src/scheme/ao_scheme_const.scheme new file mode 100644 index 00000000..ab6a309a --- /dev/null +++ b/src/scheme/ao_scheme_const.scheme @@ -0,0 +1,813 @@ +; +; Copyright © 2016 Keith Packard <keithp@keithp.com> +; +; This program is free software; you can redistribute it and/or modify +; it under the terms of the GNU General Public License as published by +; the Free Software Foundation, either version 2 of the License, or +; (at your option) any later version. +; +; This program is distributed in the hope that it will be useful, but +; WITHOUT ANY WARRANTY; without even the implied warranty of +; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +; General Public License for more details. +; +; Lisp code placed in ROM + + ; return a list containing all of the arguments +(def (quote list) (lambda l l)) + +(def (quote def!) + (macro (name value) + (list + def + (list quote name) + value) + ) + ) + +(begin + (def! append + (lambda args + (def! append-list + (lambda (a b) + (cond ((null? a) b) + (else (cons (car a) (append-list (cdr a) b))) + ) + ) + ) + + (def! append-lists + (lambda (lists) + (cond ((null? lists) lists) + ((null? (cdr lists)) (car lists)) + (else (append-list (car lists) (append-lists (cdr lists)))) + ) + ) + ) + (append-lists args) + ) + ) + 'append) + +(append '(a b c) '(d e f) '(g h i)) + + ; boolean operators + +(begin + (def! or + (macro l + (def! _or + (lambda (l) + (cond ((null? l) #f) + ((null? (cdr l)) + (car l)) + (else + (list + cond + (list + (car l)) + (list + 'else + (_or (cdr l)) + ) + ) + ) + ) + ) + ) + (_or l))) + 'or) + + ; execute to resolve macros + +(or #f #t) + +(begin + (def! and + (macro l + (def! _and + (lambda (l) + (cond ((null? l) #t) + ((null? (cdr l)) + (car l)) + (else + (list + cond + (list + (car l) + (_and (cdr l)) + ) + ) + ) + ) + ) + ) + (_and l) + ) + ) + 'and) + + ; execute to resolve macros + +(and #t #f) + +(begin + (def! quasiquote + (macro (x) + (def! constant? + ; A constant value is either a pair starting with quote, + ; or anything which is neither a pair nor a symbol + + (lambda (exp) + (cond ((pair? exp) + (eq? (car exp) 'quote) + ) + (else + (not (symbol? exp)) + ) + ) + ) + ) + (def! combine-skeletons + (lambda (left right exp) + (cond + ((and (constant? left) (constant? right)) + (cond ((and (eqv? (eval left) (car exp)) + (eqv? (eval right) (cdr exp))) + (list 'quote exp) + ) + (else + (list 'quote (cons (eval left) (eval right))) + ) + ) + ) + ((null? right) + (list 'list left) + ) + ((and (pair? right) (eq? (car right) 'list)) + (cons 'list (cons left (cdr right))) + ) + (else + (list 'cons left right) + ) + ) + ) + ) + + (def! expand-quasiquote + (lambda (exp nesting) + (cond + + ; non cons -- constants + ; themselves, others are + ; quoted + + ((not (pair? exp)) + (cond ((constant? exp) + exp + ) + (else + (list 'quote exp) + ) + ) + ) + + ; check for an unquote exp and + ; add the param unquoted + + ((and (eq? (car exp) 'unquote) (= (length exp) 2)) + (cond ((= nesting 0) + (car (cdr exp)) + ) + (else + (combine-skeletons ''unquote + (expand-quasiquote (cdr exp) (- nesting 1)) + exp)) + ) + ) + + ; nested quasi-quote -- + ; construct the right + ; expression + + ((and (eq? (car exp) 'quasiquote) (= (length exp) 2)) + (combine-skeletons ''quasiquote + (expand-quasiquote (cdr exp) (+ nesting 1)) + exp)) + + ; check for an + ; unquote-splicing member, + ; compute the expansion of the + ; value and append the rest of + ; the quasiquote result to it + + ((and (pair? (car exp)) + (eq? (car (car exp)) 'unquote-splicing) + (= (length (car exp)) 2)) + (cond ((= nesting 0) + (list 'append (car (cdr (car exp))) + (expand-quasiquote (cdr exp) nesting)) + ) + (else + (combine-skeletons (expand-quasiquote (car exp) (- nesting 1)) + (expand-quasiquote (cdr exp) nesting) + exp)) + ) + ) + + ; for other lists, just glue + ; the expansion of the first + ; element to the expansion of + ; the rest of the list + + (else (combine-skeletons (expand-quasiquote (car exp) nesting) + (expand-quasiquote (cdr exp) nesting) + exp) + ) + ) + ) + ) + (def! result (expand-quasiquote x 0)) + result + ) + ) + 'quasiquote) + + ; + ; Define a variable without returning the value + ; Useful when defining functions to avoid + ; having lots of output generated. + ; + ; Also accepts the alternate + ; form for defining lambdas of + ; (define (name x y z) sexprs ...) + ; + +(begin + (def! define + (macro (first . rest) + ; check for alternate lambda definition form + + (cond ((list? first) + (set! rest + (append + (list + 'lambda + (cdr first)) + rest)) + (set! first (car first)) + ) + (else + (set! rest (car rest)) + ) + ) + (def! result `(,begin + (,def (,quote ,first) ,rest) + (,quote ,first)) + ) + result + ) + ) + 'define + ) + + ; basic list accessors + +(define (caar l) (car (car l))) + +(define (cadr l) (car (cdr l))) + +(define (cdar l) (cdr (car l))) + +(define (caddr l) (car (cdr (cdr l)))) + + ; (if <condition> <if-true>) + ; (if <condition> <if-true> <if-false) + +(define if + (macro (test . args) + (cond ((null? (cdr args)) + `(cond (,test ,(car args))) + ) + (else + `(cond (,test ,(car args)) + (else ,(cadr args))) + ) + ) + ) + ) + +(if (> 3 2) 'yes) +(if (> 3 2) 'yes 'no) +(if (> 2 3) 'no 'yes) +(if (> 2 3) 'no) + + ; simple math operators + +(define zero? (macro (value) `(eq? ,value 0))) + +(zero? 1) +(zero? 0) +(zero? "hello") + +(define positive? (macro (value) `(> ,value 0))) + +(positive? 12) +(positive? -12) + +(define negative? (macro (value) `(< ,value 0))) + +(negative? 12) +(negative? -12) + +(define (abs x) (if (>= x 0) x (- x))) + +(abs 12) +(abs -12) + +(define max (lambda (first . rest) + (while (not (null? rest)) + (cond ((< first (car rest)) + (set! first (car rest))) + ) + (set! rest (cdr rest)) + ) + first) + ) + +(max 1 2 3) +(max 3 2 1) + +(define min (lambda (first . rest) + (while (not (null? rest)) + (cond ((> first (car rest)) + (set! first (car rest))) + ) + (set! rest (cdr rest)) + ) + first) + ) + +(min 1 2 3) +(min 3 2 1) + +(define (even? x) (zero? (% x 2))) + +(even? 2) +(even? -2) +(even? 3) +(even? -1) + +(define (odd? x) (not (even? x))) + +(odd? 2) +(odd? -2) +(odd? 3) +(odd? -1) + + +(define (list-tail x k) + (if (zero? k) + x + (list-tail (cdr x (- k 1))) + ) + ) + +(define (list-ref x k) + (car (list-tail x k)) + ) + + ; define a set of local + ; variables all at once and + ; then evaluate a list of + ; sexprs + ; + ; (let (var-defines) sexprs) + ; + ; where var-defines are either + ; + ; (name value) + ; + ; or + ; + ; (name) + ; + ; e.g. + ; + ; (let ((x 1) (y)) (set! y (+ x 1)) y) + +(define let + (macro (vars . exprs) + (define (make-names vars) + (cond ((not (null? vars)) + (cons (car (car vars)) + (make-names (cdr vars)))) + (else ()) + ) + ) + + ; the parameters to the lambda is a list + ; of nils of the right length + + (define (make-vals vars) + (cond ((not (null? vars)) + (cons (cond ((null? (cdr (car vars))) ()) + (else + (car (cdr (car vars)))) + ) + (make-vals (cdr vars)))) + (else ()) + ) + ) + ; prepend the set operations + ; to the expressions + + ; build the lambda. + + `((lambda ,(make-names vars) ,@exprs) ,@(make-vals vars)) + ) + ) + + +(let ((x 1) (y)) (set! y 2) (+ x y)) + + ; define a set of local + ; variables one at a time and + ; then evaluate a list of + ; sexprs + ; + ; (let* (var-defines) sexprs) + ; + ; where var-defines are either + ; + ; (name value) + ; + ; or + ; + ; (name) + ; + ; e.g. + ; + ; (let* ((x 1) (y)) (set! y (+ x 1)) y) + +(define let* + (macro (vars . exprs) + + ; + ; make the list of names in the let + ; + + (define (make-names vars) + (cond ((not (null? vars)) + (cons (car (car vars)) + (make-names (cdr vars)))) + (else ()) + ) + ) + + ; the set of expressions is + ; the list of set expressions + ; pre-pended to the + ; expressions to evaluate + + (define (make-exprs vars exprs) + (cond ((null? vars) exprs) + (else + (cons + (list set + (list quote + (car (car vars)) + ) + (cond ((null? (cdr (car vars))) ()) + (else (cadr (car vars)))) + ) + (make-exprs (cdr vars) exprs) + ) + ) + ) + ) + + ; the parameters to the lambda is a list + ; of nils of the right length + + (define (make-nils vars) + (cond ((null? vars) ()) + (else (cons () (make-nils (cdr vars)))) + ) + ) + ; build the lambda. + + `((lambda ,(make-names vars) ,@(make-exprs vars exprs)) ,@(make-nils vars)) + ) + ) + +(let* ((x 1) (y x)) (+ x y)) + +(define when (macro (test . l) `(cond (,test ,@l)))) + +(when #t (write 'when)) + +(define unless (macro (test . l) `(cond ((not ,test) ,@l)))) + +(unless #f (write 'unless)) + +(define (reverse list) + (let ((result ())) + (while (not (null? list)) + (set! result (cons (car list) result)) + (set! list (cdr list)) + ) + result) + ) + +(reverse '(1 2 3)) + +(define (list-tail x k) + (if (zero? k) + x + (list-tail (cdr x) (- k 1)))) + +(list-tail '(1 2 3) 2) + +(define (list-ref x k) (car (list-tail x k))) + +(list-ref '(1 2 3) 2) + + ; recursive equality + +(define (equal? a b) + (cond ((eq? a b) #t) + ((and (pair? a) (pair? b)) + (and (equal? (car a) (car b)) + (equal? (cdr a) (cdr b))) + ) + (else #f) + ) + ) + +(equal? '(a b c) '(a b c)) +(equal? '(a b c) '(a b b)) + +(define member (lambda (obj list . test?) + (cond ((null? list) + #f + ) + (else + (if (null? test?) (set! test? equal?) (set! test? (car test?))) + (if (test? obj (car list)) + list + (member obj (cdr list) test?)) + ) + ) + ) + ) + +(member '(2) '((1) (2) (3))) + +(member '(4) '((1) (2) (3))) + +(define (memq obj list) (member obj list eq?)) + +(memq 2 '(1 2 3)) + +(memq 4 '(1 2 3)) + +(memq '(2) '((1) (2) (3))) + +(define (memv obj list) (member obj list eqv?)) + +(memv 2 '(1 2 3)) + +(memv 4 '(1 2 3)) + +(memv '(2) '((1) (2) (3))) + +(define (_assoc obj list test?) + (if (null? list) + #f + (if (test? obj (caar list)) + (car list) + (_assoc obj (cdr list) test?) + ) + ) + ) + +(define (assq obj list) (_assoc obj list eq?)) +(define (assv obj list) (_assoc obj list eqv?)) +(define (assoc obj list) (_assoc obj list equal?)) + +(assq 'a '((a 1) (b 2) (c 3))) +(assv 'b '((a 1) (b 2) (c 3))) +(assoc '(c) '((a 1) (b 2) ((c) 3))) + +(define char? integer?) + +(char? #\q) +(char? "h") + +(define (char-upper-case? c) (<= #\A c #\Z)) + +(char-upper-case? #\a) +(char-upper-case? #\B) +(char-upper-case? #\0) +(char-upper-case? #\space) + +(define (char-lower-case? c) (<= #\a c #\a)) + +(char-lower-case? #\a) +(char-lower-case? #\B) +(char-lower-case? #\0) +(char-lower-case? #\space) + +(define (char-alphabetic? c) (or (char-upper-case? c) (char-lower-case? c))) + +(char-alphabetic? #\a) +(char-alphabetic? #\B) +(char-alphabetic? #\0) +(char-alphabetic? #\space) + +(define (char-numeric? c) (<= #\0 c #\9)) + +(char-numeric? #\a) +(char-numeric? #\B) +(char-numeric? #\0) +(char-numeric? #\space) + +(define (char-whitespace? c) (or (<= #\tab c #\return) (= #\space c))) + +(char-whitespace? #\a) +(char-whitespace? #\B) +(char-whitespace? #\0) +(char-whitespace? #\space) + +(define (char->integer c) c) +(define integer->char char->integer) + +(define (char-upcase c) (if (char-lower-case? c) (+ c (- #\A #\a)) c)) + +(char-upcase #\a) +(char-upcase #\B) +(char-upcase #\0) +(char-upcase #\space) + +(define (char-downcase c) (if (char-upper-case? c) (+ c (- #\a #\A)) c)) + +(char-downcase #\a) +(char-downcase #\B) +(char-downcase #\0) +(char-downcase #\space) + +(define string (lambda chars (list->string chars))) + +(display "apply\n") +(apply cons '(a b)) + +(define map + (lambda (proc . lists) + (define (args lists) + (cond ((null? lists) ()) + (else + (cons (caar lists) (args (cdr lists))) + ) + ) + ) + (define (next lists) + (cond ((null? lists) ()) + (else + (cons (cdr (car lists)) (next (cdr lists))) + ) + ) + ) + (define (domap lists) + (cond ((null? (car lists)) ()) + (else + (cons (apply proc (args lists)) (domap (next lists))) + ) + ) + ) + (domap lists) + ) + ) + +(map cadr '((a b) (d e) (g h))) + +(define for-each (lambda (proc . lists) + (apply map proc lists) + #t)) + +(for-each display '("hello" " " "world" "\n")) + +(define (_string-ml strings) + (if (null? strings) () + (cons (string->list (car strings)) (_string-ml (cdr strings))) + ) + ) + +(define string-map (lambda (proc . strings) + (list->string (apply map proc (_string-ml strings)))))) + +(string-map (lambda (x) (+ 1 x)) "HAL") + +(define string-for-each (lambda (proc . strings) + (apply for-each proc (_string-ml strings)))) + +(string-for-each write-char "IBM\n") + +(define (newline) (write-char #\newline)) + +(newline) + +(call-with-current-continuation + (lambda (exit) + (for-each (lambda (x) + (write "test" x) + (if (negative? x) + (exit x))) + '(54 0 37 -3 245 19)) + #t)) + + + ; `q -> (quote q) + ; `(q) -> (append (quote (q))) + ; `(a ,(+ 1 2)) -> (append (quote (a)) (list (+ 1 2))) + ; `(a ,@(list 1 2 3) -> (append (quote (a)) (list 1 2 3)) + + + +`(hello ,(+ 1 2) ,@(list 1 2 3) `foo) + + +(define repeat + (macro (count . rest) + (define counter '__count__) + (cond ((pair? count) + (set! counter (car count)) + (set! count (cadr count)) + ) + ) + `(let ((,counter 0) + (__max__ ,count) + ) + (while (< ,counter __max__) + ,@rest + (set! ,counter (+ ,counter 1)) + ) + ) + ) + ) + +(repeat 2 (write 'hello)) +(repeat (x 3) (write 'goodbye x)) + +(define case + (macro (test . l) + ; construct the body of the + ; case, dealing with the + ; lambda version ( => lambda) + + (define (_unarrow l) + (cond ((null? l) l) + ((eq? (car l) '=>) `(( ,(cadr l) __key__))) + (else l)) + ) + + ; Build the case elements, which is + ; simply a list of cond clauses + + (define (_case l) + + (cond ((null? l) ()) + + ; else case + + ((eq? (caar l) 'else) + `((else ,@(_unarrow (cdr (car l)))))) + + ; regular case + + (else + (cons + `((eqv? ,(caar l) __key__) + ,@(_unarrow (cdr (car l)))) + (_case (cdr l))) + ) + ) + ) + + ; now construct the overall + ; expression, using a lambda + ; to hold the computed value + ; of the test expression + + `((lambda (__key__) + (cond ,@(_case l))) ,test) + ) + ) + +(case 12 (1 "one") (2 "two") (3 => (lambda (x) (write "the value is" x))) (12 "twelve") (else "else")) + +;(define number->string (lambda (arg . opt) +; (let ((base (if (null? opt) 10 (car opt))) + ; +; + diff --git a/src/scheme/ao_scheme_error.c b/src/scheme/ao_scheme_error.c new file mode 100644 index 00000000..d580a2c0 --- /dev/null +++ b/src/scheme/ao_scheme_error.c @@ -0,0 +1,139 @@ +/* + * Copyright © 2016 Keith Packard <keithp@keithp.com> + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation, either version 2 of the License, or + * (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, but + * WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + * General Public License for more details. + */ + +#include "ao_scheme.h" +#include <stdarg.h> + +void +ao_scheme_error_poly(char *name, ao_poly poly, ao_poly last) +{ + int first = 1; + printf("\t\t%s(", name); + if (ao_scheme_poly_type(poly) == AO_SCHEME_CONS) { + if (poly) { + while (poly) { + struct ao_scheme_cons *cons = ao_scheme_poly_cons(poly); + if (!first) + printf("\t\t "); + else + first = 0; + ao_scheme_poly_write(cons->car); + printf("\n"); + if (poly == last) + break; + poly = cons->cdr; + } + printf("\t\t )\n"); + } else + printf(")\n"); + } else { + ao_scheme_poly_write(poly); + printf("\n"); + } +} + +static void tabs(int indent) +{ + while (indent--) + printf("\t"); +} + +void +ao_scheme_error_frame(int indent, char *name, struct ao_scheme_frame *frame) +{ + int f; + + tabs(indent); + printf ("%s{", name); + if (frame) { + struct ao_scheme_frame_vals *vals = ao_scheme_poly_frame_vals(frame->vals); + if (frame->type & AO_SCHEME_FRAME_PRINT) + printf("recurse..."); + else { + frame->type |= AO_SCHEME_FRAME_PRINT; + for (f = 0; f < frame->num; f++) { + if (f != 0) { + tabs(indent); + printf(" "); + } + ao_scheme_poly_write(vals->vals[f].atom); + printf(" = "); + ao_scheme_poly_write(vals->vals[f].val); + printf("\n"); + } + if (frame->prev) + ao_scheme_error_frame(indent + 1, "prev: ", ao_scheme_poly_frame(frame->prev)); + frame->type &= ~AO_SCHEME_FRAME_PRINT; + } + tabs(indent); + printf(" }\n"); + } else + printf ("}\n"); +} + +void +ao_scheme_vprintf(char *format, va_list args) +{ + char c; + + while ((c = *format++) != '\0') { + if (c == '%') { + switch (c = *format++) { + case 'v': + ao_scheme_poly_write((ao_poly) va_arg(args, unsigned int)); + break; + case 'p': + printf("%p", va_arg(args, void *)); + break; + case 'd': + printf("%d", va_arg(args, int)); + break; + case 's': + printf("%s", va_arg(args, char *)); + break; + default: + putchar(c); + break; + } + } else + putchar(c); + } +} + +void +ao_scheme_printf(char *format, ...) +{ + va_list args; + va_start(args, format); + ao_scheme_vprintf(format, args); + va_end(args); +} + +ao_poly +ao_scheme_error(int error, char *format, ...) +{ + va_list args; + + ao_scheme_exception |= error; + va_start(args, format); + ao_scheme_vprintf(format, args); + putchar('\n'); + va_end(args); + ao_scheme_printf("Value: %v\n", ao_scheme_v); + ao_scheme_printf("Frame: %v\n", ao_scheme_frame_poly(ao_scheme_frame_current)); + printf("Stack:\n"); + ao_scheme_stack_write(ao_scheme_stack_poly(ao_scheme_stack)); + ao_scheme_printf("Globals: %v\n", ao_scheme_frame_poly(ao_scheme_frame_global)); + return AO_SCHEME_NIL; +} diff --git a/src/scheme/ao_scheme_eval.c b/src/scheme/ao_scheme_eval.c new file mode 100644 index 00000000..907ecf0b --- /dev/null +++ b/src/scheme/ao_scheme_eval.c @@ -0,0 +1,572 @@ +/* + * Copyright © 2016 Keith Packard <keithp@keithp.com> + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation, either version 2 of the License, or + * (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, but + * WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + * General Public License for more details. + */ + +#include "ao_scheme.h" +#include <assert.h> + +struct ao_scheme_stack *ao_scheme_stack; +ao_poly ao_scheme_v; +uint8_t ao_scheme_skip_cons_free; + +ao_poly +ao_scheme_set_cond(struct ao_scheme_cons *c) +{ + ao_scheme_stack->state = eval_cond; + ao_scheme_stack->sexprs = ao_scheme_cons_poly(c); + return AO_SCHEME_NIL; +} + +static int +func_type(ao_poly func) +{ + if (func == AO_SCHEME_NIL) + return ao_scheme_error(AO_SCHEME_INVALID, "func is nil"); + switch (ao_scheme_poly_type(func)) { + case AO_SCHEME_BUILTIN: + return ao_scheme_poly_builtin(func)->args & AO_SCHEME_FUNC_MASK; + case AO_SCHEME_LAMBDA: + return ao_scheme_poly_lambda(func)->args; + case AO_SCHEME_STACK: + return AO_SCHEME_FUNC_LAMBDA; + default: + ao_scheme_error(AO_SCHEME_INVALID, "not a func"); + return -1; + } +} + +/* + * Flattened eval to avoid stack issues + */ + +/* + * Evaluate an s-expression + * + * For a list, evaluate all of the elements and + * then execute the resulting function call. + * + * Each element of the list is evaluated in + * a clean stack context. + * + * The current stack state is set to 'formal' so that + * when the evaluation is complete, the value + * will get appended to the values list. + * + * For other types, compute the value directly. + */ + +static int +ao_scheme_eval_sexpr(void) +{ + DBGI("sexpr: %v\n", ao_scheme_v); + switch (ao_scheme_poly_type(ao_scheme_v)) { + case AO_SCHEME_CONS: + if (ao_scheme_v == AO_SCHEME_NIL) { + if (!ao_scheme_stack->values) { + /* + * empty list evaluates to empty list + */ + ao_scheme_v = AO_SCHEME_NIL; + ao_scheme_stack->state = eval_val; + } else { + /* + * done with arguments, go execute it + */ + ao_scheme_v = ao_scheme_poly_cons(ao_scheme_stack->values)->car; + ao_scheme_stack->state = eval_exec; + } + } else { + if (!ao_scheme_stack->values) + ao_scheme_stack->list = ao_scheme_v; + /* + * Evaluate another argument and then switch + * to 'formal' to add the value to the values + * list + */ + ao_scheme_stack->sexprs = ao_scheme_v; + ao_scheme_stack->state = eval_formal; + if (!ao_scheme_stack_push()) + return 0; + /* + * push will reset the state to 'sexpr', which + * will evaluate the expression + */ + ao_scheme_v = ao_scheme_poly_cons(ao_scheme_v)->car; + } + break; + case AO_SCHEME_ATOM: + DBGI("..frame "); DBG_POLY(ao_scheme_frame_poly(ao_scheme_frame_current)); DBG("\n"); + ao_scheme_v = ao_scheme_atom_get(ao_scheme_v); + /* fall through */ + default: + ao_scheme_stack->state = eval_val; + break; + } + DBGI(".. result "); DBG_POLY(ao_scheme_v); DBG("\n"); + return 1; +} + +/* + * A value has been computed. + * + * If the value was computed from a macro, + * then we want to reset the current context + * to evaluate the macro result again. + * + * If not a macro, then pop the stack. + * If the stack is empty, we're done. + * Otherwise, the stack will contain + * the next state. + */ + +static int +ao_scheme_eval_val(void) +{ + DBGI("val: "); DBG_POLY(ao_scheme_v); DBG("\n"); + /* + * Value computed, pop the stack + * to figure out what to do with the value + */ + ao_scheme_stack_pop(); + DBGI("..state %d\n", ao_scheme_stack ? ao_scheme_stack->state : -1); + return 1; +} + +/* + * A formal has been computed. + * + * If this is the first formal, then check to see if we've got a + * lamda, macro or nlambda. + * + * For lambda, go compute another formal. This will terminate + * when the sexpr state sees nil. + * + * For macro/nlambda, we're done, so move the sexprs into the values + * and go execute it. + * + * Macros have an additional step of saving a stack frame holding the + * macro value execution context, which then gets the result of the + * macro to run + */ + +static int +ao_scheme_eval_formal(void) +{ + ao_poly formal; + struct ao_scheme_stack *prev; + + DBGI("formal: "); DBG_POLY(ao_scheme_v); DBG("\n"); + + /* Check what kind of function we've got */ + if (!ao_scheme_stack->values) { + switch (func_type(ao_scheme_v)) { + case AO_SCHEME_FUNC_LAMBDA: + DBGI(".. lambda\n"); + break; + case AO_SCHEME_FUNC_MACRO: + /* Evaluate the result once more */ + ao_scheme_stack->state = eval_macro; + if (!ao_scheme_stack_push()) + return 0; + + /* After the function returns, take that + * value and re-evaluate it + */ + prev = ao_scheme_poly_stack(ao_scheme_stack->prev); + ao_scheme_stack->sexprs = prev->sexprs; + + DBGI(".. start macro\n"); + DBGI("\t.. sexprs "); DBG_POLY(ao_scheme_stack->sexprs); DBG("\n"); + DBGI("\t.. values "); DBG_POLY(ao_scheme_stack->values); DBG("\n"); + DBG_FRAMES(); + + /* fall through ... */ + case AO_SCHEME_FUNC_NLAMBDA: + DBGI(".. nlambda or macro\n"); + + /* use the raw sexprs as values */ + ao_scheme_stack->values = ao_scheme_stack->sexprs; + ao_scheme_stack->values_tail = AO_SCHEME_NIL; + ao_scheme_stack->state = eval_exec; + + /* ready to execute now */ + return 1; + case -1: + return 0; + } + } + + /* Append formal to list of values */ + formal = ao_scheme__cons(ao_scheme_v, AO_SCHEME_NIL); + if (!formal) + return 0; + + if (ao_scheme_stack->values_tail) + ao_scheme_poly_cons(ao_scheme_stack->values_tail)->cdr = formal; + else + ao_scheme_stack->values = formal; + ao_scheme_stack->values_tail = formal; + + DBGI(".. values "); DBG_POLY(ao_scheme_stack->values); DBG("\n"); + + /* + * Step to the next argument, if this is last, then + * 'sexpr' will end up switching to 'exec' + */ + ao_scheme_v = ao_scheme_poly_cons(ao_scheme_stack->sexprs)->cdr; + + ao_scheme_stack->state = eval_sexpr; + + DBGI(".. "); DBG_POLY(ao_scheme_v); DBG("\n"); + return 1; +} + +/* + * Start executing a function call + * + * Most builtins are easy, just call the function. + * 'cond' is magic; it sticks the list of clauses + * in 'sexprs' and switches to 'cond' state. That + * bit of magic is done in ao_scheme_set_cond. + * + * Lambdas build a new frame to hold the locals and + * then re-use the current stack context to evaluate + * the s-expression from the lambda. + */ + +static int +ao_scheme_eval_exec(void) +{ + ao_poly v; + struct ao_scheme_builtin *builtin; + + DBGI("exec: "); DBG_POLY(ao_scheme_v); DBG(" values "); DBG_POLY(ao_scheme_stack->values); DBG ("\n"); + ao_scheme_stack->sexprs = AO_SCHEME_NIL; + switch (ao_scheme_poly_type(ao_scheme_v)) { + case AO_SCHEME_BUILTIN: + ao_scheme_stack->state = eval_val; + builtin = ao_scheme_poly_builtin(ao_scheme_v); + v = ao_scheme_func(builtin) ( + ao_scheme_poly_cons(ao_scheme_poly_cons(ao_scheme_stack->values)->cdr)); + DBG_DO(if (!ao_scheme_exception && ao_scheme_poly_builtin(ao_scheme_v)->func == builtin_set) { + struct ao_scheme_cons *cons = ao_scheme_poly_cons(ao_scheme_stack->values); + ao_poly atom = ao_scheme_arg(cons, 1); + ao_poly val = ao_scheme_arg(cons, 2); + DBGI("set "); DBG_POLY(atom); DBG(" = "); DBG_POLY(val); DBG("\n"); + }); + builtin = ao_scheme_poly_builtin(ao_scheme_v); + if (builtin && (builtin->args & AO_SCHEME_FUNC_FREE_ARGS) && !ao_scheme_stack_marked(ao_scheme_stack) && !ao_scheme_skip_cons_free) { + struct ao_scheme_cons *cons = ao_scheme_poly_cons(ao_scheme_stack->values); + ao_scheme_stack->values = AO_SCHEME_NIL; + ao_scheme_cons_free(cons); + } + + ao_scheme_v = v; + ao_scheme_stack->values = AO_SCHEME_NIL; + ao_scheme_stack->values_tail = AO_SCHEME_NIL; + DBGI(".. result "); DBG_POLY(ao_scheme_v); DBG ("\n"); + DBGI(".. frame "); DBG_POLY(ao_scheme_frame_poly(ao_scheme_frame_current)); DBG("\n"); + break; + case AO_SCHEME_LAMBDA: + DBGI(".. frame "); DBG_POLY(ao_scheme_frame_poly(ao_scheme_frame_current)); DBG("\n"); + ao_scheme_stack->state = eval_begin; + v = ao_scheme_lambda_eval(); + ao_scheme_stack->sexprs = v; + ao_scheme_stack->values = AO_SCHEME_NIL; + ao_scheme_stack->values_tail = AO_SCHEME_NIL; + DBGI(".. sexprs "); DBG_POLY(ao_scheme_stack->sexprs); DBG("\n"); + DBGI(".. frame "); DBG_POLY(ao_scheme_frame_poly(ao_scheme_frame_current)); DBG("\n"); + break; + case AO_SCHEME_STACK: + DBGI(".. stack "); DBG_POLY(ao_scheme_v); DBG("\n"); + ao_scheme_v = ao_scheme_stack_eval(); + DBGI(".. value "); DBG_POLY(ao_scheme_v); DBG("\n"); + DBGI(".. frame "); DBG_POLY(ao_scheme_frame_poly(ao_scheme_frame_current)); DBG("\n"); + break; + } + ao_scheme_skip_cons_free = 0; + return 1; +} + +/* + * Finish setting up the apply evaluation + * + * The value is the list to execute + */ +static int +ao_scheme_eval_apply(void) +{ + struct ao_scheme_cons *cons = ao_scheme_poly_cons(ao_scheme_v); + struct ao_scheme_cons *cdr, *prev; + + /* Glue the arguments into the right shape. That's all but the last + * concatenated onto the last + */ + cdr = cons; + for (;;) { + prev = cdr; + cdr = ao_scheme_poly_cons(prev->cdr); + if (cdr->cdr == AO_SCHEME_NIL) + break; + } + DBGI("before mangling: "); DBG_POLY(ao_scheme_v); DBG("\n"); + prev->cdr = cdr->car; + ao_scheme_stack->values = ao_scheme_v; + ao_scheme_v = ao_scheme_poly_cons(ao_scheme_stack->values)->car; + DBGI("apply: "); DBG_POLY(ao_scheme_stack->values); DBG ("\n"); + ao_scheme_stack->state = eval_exec; + ao_scheme_skip_cons_free = 1; + return 1; +} + +/* + * Start evaluating the next cond clause + * + * If the list of clauses is empty, then + * the result of the cond is nil. + * + * Otherwise, set the current stack state to 'cond_test' and create a + * new stack context to evaluate the test s-expression. Once that's + * complete, we'll land in 'cond_test' to finish the clause. + */ +static int +ao_scheme_eval_cond(void) +{ + DBGI("cond: "); DBG_POLY(ao_scheme_stack->sexprs); DBG("\n"); + DBGI(".. frame "); DBG_POLY(ao_scheme_frame_poly(ao_scheme_frame_current)); DBG("\n"); + DBGI(".. saved frame "); DBG_POLY(ao_scheme_stack->frame); DBG("\n"); + if (!ao_scheme_stack->sexprs) { + ao_scheme_v = _ao_scheme_bool_false; + ao_scheme_stack->state = eval_val; + } else { + ao_scheme_v = ao_scheme_poly_cons(ao_scheme_stack->sexprs)->car; + if (!ao_scheme_v || ao_scheme_poly_type(ao_scheme_v) != AO_SCHEME_CONS) { + ao_scheme_error(AO_SCHEME_INVALID, "invalid cond clause"); + return 0; + } + ao_scheme_v = ao_scheme_poly_cons(ao_scheme_v)->car; + if (ao_scheme_v == _ao_scheme_atom_else) + ao_scheme_v = _ao_scheme_bool_true; + ao_scheme_stack->state = eval_cond_test; + if (!ao_scheme_stack_push()) + return 0; + } + return 1; +} + +/* + * Finish a cond clause. + * + * Check the value from the test expression, if + * non-nil, then set up to evaluate the value expression. + * + * Otherwise, step to the next clause and go back to the 'cond' + * state + */ +static int +ao_scheme_eval_cond_test(void) +{ + DBGI("cond_test: "); DBG_POLY(ao_scheme_v); DBG(" sexprs "); DBG_POLY(ao_scheme_stack->sexprs); DBG("\n"); + DBGI(".. frame "); DBG_POLY(ao_scheme_frame_poly(ao_scheme_frame_current)); DBG("\n"); + DBGI(".. saved frame "); DBG_POLY(ao_scheme_stack->frame); DBG("\n"); + if (ao_scheme_v != _ao_scheme_bool_false) { + struct ao_scheme_cons *car = ao_scheme_poly_cons(ao_scheme_poly_cons(ao_scheme_stack->sexprs)->car); + ao_poly c = car->cdr; + + if (c) { + ao_scheme_stack->state = eval_begin; + ao_scheme_stack->sexprs = c; + } else + ao_scheme_stack->state = eval_val; + } else { + ao_scheme_stack->sexprs = ao_scheme_poly_cons(ao_scheme_stack->sexprs)->cdr; + DBGI("next cond: "); DBG_POLY(ao_scheme_stack->sexprs); DBG("\n"); + ao_scheme_stack->state = eval_cond; + } + return 1; +} + +/* + * Evaluate a list of sexprs, returning the value from the last one. + * + * ao_scheme_begin records the list in stack->sexprs, so we just need to + * walk that list. Set ao_scheme_v to the car of the list and jump to + * eval_sexpr. When that's done, it will land in eval_val. For all but + * the last, leave a stack frame with eval_begin set so that we come + * back here. For the last, don't add a stack frame so that we can + * just continue on. + */ +static int +ao_scheme_eval_begin(void) +{ + DBGI("begin: "); DBG_POLY(ao_scheme_v); DBG(" sexprs "); DBG_POLY(ao_scheme_stack->sexprs); DBG("\n"); + DBGI(".. frame "); DBG_POLY(ao_scheme_frame_poly(ao_scheme_frame_current)); DBG("\n"); + DBGI(".. saved frame "); DBG_POLY(ao_scheme_stack->frame); DBG("\n"); + + if (!ao_scheme_stack->sexprs) { + ao_scheme_v = AO_SCHEME_NIL; + ao_scheme_stack->state = eval_val; + } else { + ao_scheme_v = ao_scheme_poly_cons(ao_scheme_stack->sexprs)->car; + ao_scheme_stack->sexprs = ao_scheme_poly_cons(ao_scheme_stack->sexprs)->cdr; + + /* If there are more sexprs to do, then come back here, otherwise + * return the value of the last one by just landing in eval_sexpr + */ + if (ao_scheme_stack->sexprs) { + ao_scheme_stack->state = eval_begin; + if (!ao_scheme_stack_push()) + return 0; + } + ao_scheme_stack->state = eval_sexpr; + } + return 1; +} + +/* + * Conditionally execute a list of sexprs while the first is true + */ +static int +ao_scheme_eval_while(void) +{ + DBGI("while: "); DBG_POLY(ao_scheme_stack->sexprs); DBG("\n"); + DBGI(".. frame "); DBG_POLY(ao_scheme_frame_poly(ao_scheme_frame_current)); DBG("\n"); + DBGI(".. saved frame "); DBG_POLY(ao_scheme_stack->frame); DBG("\n"); + + ao_scheme_stack->values = ao_scheme_v; + if (!ao_scheme_stack->sexprs) { + ao_scheme_v = AO_SCHEME_NIL; + ao_scheme_stack->state = eval_val; + } else { + ao_scheme_v = ao_scheme_poly_cons(ao_scheme_stack->sexprs)->car; + ao_scheme_stack->state = eval_while_test; + if (!ao_scheme_stack_push()) + return 0; + } + return 1; +} + +/* + * Check the while condition, terminate the loop if nil. Otherwise keep going + */ +static int +ao_scheme_eval_while_test(void) +{ + DBGI("while_test: "); DBG_POLY(ao_scheme_v); DBG(" sexprs "); DBG_POLY(ao_scheme_stack->sexprs); DBG("\n"); + DBGI(".. frame "); DBG_POLY(ao_scheme_frame_poly(ao_scheme_frame_current)); DBG("\n"); + DBGI(".. saved frame "); DBG_POLY(ao_scheme_stack->frame); DBG("\n"); + + if (ao_scheme_v != _ao_scheme_bool_false) { + ao_scheme_stack->values = ao_scheme_v; + ao_scheme_v = ao_scheme_poly_cons(ao_scheme_stack->sexprs)->cdr; + ao_scheme_stack->state = eval_while; + if (!ao_scheme_stack_push()) + return 0; + ao_scheme_stack->state = eval_begin; + ao_scheme_stack->sexprs = ao_scheme_v; + } + else + { + ao_scheme_stack->state = eval_val; + ao_scheme_v = ao_scheme_stack->values; + } + return 1; +} + +/* + * Replace the original sexpr with the macro expansion, then + * execute that + */ +static int +ao_scheme_eval_macro(void) +{ + DBGI("macro: "); DBG_POLY(ao_scheme_v); DBG(" sexprs "); DBG_POLY(ao_scheme_stack->sexprs); DBG("\n"); + + if (ao_scheme_v == AO_SCHEME_NIL) + ao_scheme_abort(); + if (ao_scheme_poly_type(ao_scheme_v) == AO_SCHEME_CONS) { + *ao_scheme_poly_cons(ao_scheme_stack->sexprs) = *ao_scheme_poly_cons(ao_scheme_v); + ao_scheme_v = ao_scheme_stack->sexprs; + DBGI("sexprs rewritten to: "); DBG_POLY(ao_scheme_v); DBG("\n"); + } + ao_scheme_stack->sexprs = AO_SCHEME_NIL; + ao_scheme_stack->state = eval_sexpr; + return 1; +} + +static int (*const evals[])(void) = { + [eval_sexpr] = ao_scheme_eval_sexpr, + [eval_val] = ao_scheme_eval_val, + [eval_formal] = ao_scheme_eval_formal, + [eval_exec] = ao_scheme_eval_exec, + [eval_apply] = ao_scheme_eval_apply, + [eval_cond] = ao_scheme_eval_cond, + [eval_cond_test] = ao_scheme_eval_cond_test, + [eval_begin] = ao_scheme_eval_begin, + [eval_while] = ao_scheme_eval_while, + [eval_while_test] = ao_scheme_eval_while_test, + [eval_macro] = ao_scheme_eval_macro, +}; + +const char * const ao_scheme_state_names[] = { + [eval_sexpr] = "sexpr", + [eval_val] = "val", + [eval_formal] = "formal", + [eval_exec] = "exec", + [eval_apply] = "apply", + [eval_cond] = "cond", + [eval_cond_test] = "cond_test", + [eval_begin] = "begin", + [eval_while] = "while", + [eval_while_test] = "while_test", + [eval_macro] = "macro", +}; + +/* + * Called at restore time to reset all execution state + */ + +void +ao_scheme_eval_clear_globals(void) +{ + ao_scheme_stack = NULL; + ao_scheme_frame_current = NULL; + ao_scheme_v = AO_SCHEME_NIL; +} + +int +ao_scheme_eval_restart(void) +{ + return ao_scheme_stack_push(); +} + +ao_poly +ao_scheme_eval(ao_poly _v) +{ + ao_scheme_v = _v; + + ao_scheme_frame_init(); + + if (!ao_scheme_stack_push()) + return AO_SCHEME_NIL; + + while (ao_scheme_stack) { + if (!(*evals[ao_scheme_stack->state])() || ao_scheme_exception) { + ao_scheme_stack_clear(); + return AO_SCHEME_NIL; + } + } + DBG_DO(if (ao_scheme_frame_current) {DBGI("frame left as "); DBG_POLY(ao_scheme_frame_poly(ao_scheme_frame_current)); DBG("\n");}); + ao_scheme_frame_current = NULL; + return ao_scheme_v; +} diff --git a/src/scheme/ao_scheme_float.c b/src/scheme/ao_scheme_float.c new file mode 100644 index 00000000..99249030 --- /dev/null +++ b/src/scheme/ao_scheme_float.c @@ -0,0 +1,152 @@ +/* + * Copyright © 2017 Keith Packard <keithp@keithp.com> + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation, either version 2 of the License, or + * (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, but + * WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + * General Public License for more details. + */ + +#include "ao_scheme.h" +#include <math.h> + +static void float_mark(void *addr) +{ + (void) addr; +} + +static int float_size(void *addr) +{ + if (!addr) + return 0; + return sizeof (struct ao_scheme_float); +} + +static void float_move(void *addr) +{ + (void) addr; +} + +const struct ao_scheme_type ao_scheme_float_type = { + .mark = float_mark, + .size = float_size, + .move = float_move, + .name = "float", +}; + +#ifndef FLOAT_FORMAT +#define FLOAT_FORMAT "%g" +#endif + +void +ao_scheme_float_write(ao_poly p) +{ + struct ao_scheme_float *f = ao_scheme_poly_float(p); + float v = f->value; + + if (isnanf(v)) + printf("+nan.0"); + else if (isinff(v)) { + if (v < 0) + printf("-"); + else + printf("+"); + printf("inf.0"); + } else + printf (FLOAT_FORMAT, v); +} + +float +ao_scheme_poly_number(ao_poly p) +{ + switch (ao_scheme_poly_base_type(p)) { + case AO_SCHEME_INT: + return ao_scheme_poly_int(p); + case AO_SCHEME_OTHER: + switch (ao_scheme_other_type(ao_scheme_poly_other(p))) { + case AO_SCHEME_BIGINT: + return ao_scheme_bigint_int(ao_scheme_poly_bigint(p)->value); + case AO_SCHEME_FLOAT: + return ao_scheme_poly_float(p)->value; + } + } + return NAN; +} + +ao_poly +ao_scheme_float_get(float value) +{ + struct ao_scheme_float *f; + + f = ao_scheme_alloc(sizeof (struct ao_scheme_float)); + f->type = AO_SCHEME_FLOAT; + f->value = value; + return ao_scheme_float_poly(f); +} + +ao_poly +ao_scheme_do_inexactp(struct ao_scheme_cons *cons) +{ + if (!ao_scheme_check_argc(_ao_scheme_atom_led, cons, 1, 1)) + return AO_SCHEME_NIL; + if (ao_scheme_poly_type(ao_scheme_arg(cons, 0)) == AO_SCHEME_FLOAT) + return _ao_scheme_bool_true; + return _ao_scheme_bool_false; +} + +ao_poly +ao_scheme_do_finitep(struct ao_scheme_cons *cons) +{ + ao_poly value; + float f; + + if (!ao_scheme_check_argc(_ao_scheme_atom_led, cons, 1, 1)) + return AO_SCHEME_NIL; + value = ao_scheme_arg(cons, 0); + switch (ao_scheme_poly_type(value)) { + case AO_SCHEME_INT: + case AO_SCHEME_BIGINT: + return _ao_scheme_bool_true; + case AO_SCHEME_FLOAT: + f = ao_scheme_poly_float(value)->value; + if (!isnan(f) && !isinf(f)) + return _ao_scheme_bool_true; + } + return _ao_scheme_bool_false; +} + +ao_poly +ao_scheme_do_infinitep(struct ao_scheme_cons *cons) +{ + ao_poly value; + float f; + + if (!ao_scheme_check_argc(_ao_scheme_atom_led, cons, 1, 1)) + return AO_SCHEME_NIL; + value = ao_scheme_arg(cons, 0); + switch (ao_scheme_poly_type(value)) { + case AO_SCHEME_FLOAT: + f = ao_scheme_poly_float(value)->value; + if (isinf(f)) + return _ao_scheme_bool_true; + } + return _ao_scheme_bool_false; +} + +ao_poly +ao_scheme_do_sqrt(struct ao_scheme_cons *cons) +{ + ao_poly value; + + if (!ao_scheme_check_argc(_ao_scheme_atom_sqrt, cons, 1, 1)) + return AO_SCHEME_NIL; + value = ao_scheme_arg(cons, 0); + if (!ao_scheme_number_typep(ao_scheme_poly_type(value))) + return ao_scheme_error(AO_SCHEME_INVALID, "%s: non-numeric", ao_scheme_poly_atom(_ao_scheme_atom_sqrt)->name); + return ao_scheme_float_get(sqrtf(ao_scheme_poly_number(value))); +} diff --git a/src/scheme/ao_scheme_frame.c b/src/scheme/ao_scheme_frame.c new file mode 100644 index 00000000..e5d481e7 --- /dev/null +++ b/src/scheme/ao_scheme_frame.c @@ -0,0 +1,330 @@ +/* + * Copyright © 2016 Keith Packard <keithp@keithp.com> + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation, either version 2 of the License, or + * (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, but + * WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + * General Public License for more details. + */ + +#include "ao_scheme.h" + +static inline int +frame_vals_num_size(int num) +{ + return sizeof (struct ao_scheme_frame_vals) + num * sizeof (struct ao_scheme_val); +} + +static int +frame_vals_size(void *addr) +{ + struct ao_scheme_frame_vals *vals = addr; + return frame_vals_num_size(vals->size); +} + +static void +frame_vals_mark(void *addr) +{ + struct ao_scheme_frame_vals *vals = addr; + int f; + + for (f = 0; f < vals->size; f++) { + struct ao_scheme_val *v = &vals->vals[f]; + + ao_scheme_poly_mark(v->val, 0); + MDBG_MOVE("frame mark atom %s %d val %d at %d ", + ao_scheme_poly_atom(v->atom)->name, + MDBG_OFFSET(ao_scheme_ref(v->atom)), + MDBG_OFFSET(ao_scheme_ref(v->val)), f); + MDBG_DO(ao_scheme_poly_write(v->val)); + MDBG_DO(printf("\n")); + } +} + +static void +frame_vals_move(void *addr) +{ + struct ao_scheme_frame_vals *vals = addr; + int f; + + for (f = 0; f < vals->size; f++) { + struct ao_scheme_val *v = &vals->vals[f]; + + ao_scheme_poly_move(&v->atom, 0); + ao_scheme_poly_move(&v->val, 0); + MDBG_MOVE("frame move atom %s %d val %d at %d\n", + ao_scheme_poly_atom(v->atom)->name, + MDBG_OFFSET(ao_scheme_ref(v->atom)), + MDBG_OFFSET(ao_scheme_ref(v->val)), f); + } +} + +const struct ao_scheme_type ao_scheme_frame_vals_type = { + .mark = frame_vals_mark, + .size = frame_vals_size, + .move = frame_vals_move, + .name = "frame_vals" +}; + +static int +frame_size(void *addr) +{ + (void) addr; + return sizeof (struct ao_scheme_frame); +} + +static void +frame_mark(void *addr) +{ + struct ao_scheme_frame *frame = addr; + + for (;;) { + MDBG_MOVE("frame mark %d\n", MDBG_OFFSET(frame)); + if (!AO_SCHEME_IS_POOL(frame)) + break; + ao_scheme_poly_mark(frame->vals, 0); + frame = ao_scheme_poly_frame(frame->prev); + MDBG_MOVE("frame next %d\n", MDBG_OFFSET(frame)); + if (!frame) + break; + if (ao_scheme_mark_memory(&ao_scheme_frame_type, frame)) + break; + } +} + +static void +frame_move(void *addr) +{ + struct ao_scheme_frame *frame = addr; + + for (;;) { + struct ao_scheme_frame *prev; + int ret; + + MDBG_MOVE("frame move %d\n", MDBG_OFFSET(frame)); + if (!AO_SCHEME_IS_POOL(frame)) + break; + ao_scheme_poly_move(&frame->vals, 0); + prev = ao_scheme_poly_frame(frame->prev); + if (!prev) + break; + ret = ao_scheme_move_memory(&ao_scheme_frame_type, (void **) &prev); + if (prev != ao_scheme_poly_frame(frame->prev)) { + MDBG_MOVE("frame prev moved from %d to %d\n", + MDBG_OFFSET(ao_scheme_poly_frame(frame->prev)), + MDBG_OFFSET(prev)); + frame->prev = ao_scheme_frame_poly(prev); + } + if (ret) + break; + frame = prev; + } +} + +const struct ao_scheme_type ao_scheme_frame_type = { + .mark = frame_mark, + .size = frame_size, + .move = frame_move, + .name = "frame", +}; + +void +ao_scheme_frame_write(ao_poly p) +{ + struct ao_scheme_frame *frame = ao_scheme_poly_frame(p); + struct ao_scheme_frame_vals *vals = ao_scheme_poly_frame_vals(frame->vals); + int f; + + printf ("{"); + if (frame) { + if (frame->type & AO_SCHEME_FRAME_PRINT) + printf("recurse..."); + else { + frame->type |= AO_SCHEME_FRAME_PRINT; + for (f = 0; f < frame->num; f++) { + if (f != 0) + printf(", "); + ao_scheme_poly_write(vals->vals[f].atom); + printf(" = "); + ao_scheme_poly_write(vals->vals[f].val); + } + if (frame->prev) + ao_scheme_poly_write(frame->prev); + frame->type &= ~AO_SCHEME_FRAME_PRINT; + } + } + printf("}"); +} + +static int +ao_scheme_frame_find(struct ao_scheme_frame *frame, int top, ao_poly atom) +{ + struct ao_scheme_frame_vals *vals = ao_scheme_poly_frame_vals(frame->vals); + int l = 0; + int r = top - 1; + + while (l <= r) { + int m = (l + r) >> 1; + if (vals->vals[m].atom < atom) + l = m + 1; + else + r = m - 1; + } + return l; +} + +ao_poly * +ao_scheme_frame_ref(struct ao_scheme_frame *frame, ao_poly atom) +{ + struct ao_scheme_frame_vals *vals = ao_scheme_poly_frame_vals(frame->vals); + int l = ao_scheme_frame_find(frame, frame->num, atom); + + if (l >= frame->num) + return NULL; + + if (vals->vals[l].atom != atom) + return NULL; + return &vals->vals[l].val; +} + +struct ao_scheme_frame *ao_scheme_frame_free_list[AO_SCHEME_FRAME_FREE]; + +static struct ao_scheme_frame_vals * +ao_scheme_frame_vals_new(int num) +{ + struct ao_scheme_frame_vals *vals; + + vals = ao_scheme_alloc(frame_vals_num_size(num)); + if (!vals) + return NULL; + vals->type = AO_SCHEME_FRAME_VALS; + vals->size = num; + memset(vals->vals, '\0', num * sizeof (struct ao_scheme_val)); + return vals; +} + +struct ao_scheme_frame * +ao_scheme_frame_new(int num) +{ + struct ao_scheme_frame *frame; + struct ao_scheme_frame_vals *vals; + + if (num < AO_SCHEME_FRAME_FREE && (frame = ao_scheme_frame_free_list[num])) { + ao_scheme_frame_free_list[num] = ao_scheme_poly_frame(frame->prev); + vals = ao_scheme_poly_frame_vals(frame->vals); + } else { + frame = ao_scheme_alloc(sizeof (struct ao_scheme_frame)); + if (!frame) + return NULL; + frame->type = AO_SCHEME_FRAME; + frame->num = 0; + frame->prev = AO_SCHEME_NIL; + frame->vals = AO_SCHEME_NIL; + ao_scheme_frame_stash(0, frame); + vals = ao_scheme_frame_vals_new(num); + frame = ao_scheme_frame_fetch(0); + if (!vals) + return NULL; + frame->vals = ao_scheme_frame_vals_poly(vals); + frame->num = num; + } + frame->prev = AO_SCHEME_NIL; + return frame; +} + +ao_poly +ao_scheme_frame_mark(struct ao_scheme_frame *frame) +{ + if (!frame) + return AO_SCHEME_NIL; + frame->type |= AO_SCHEME_FRAME_MARK; + return ao_scheme_frame_poly(frame); +} + +void +ao_scheme_frame_free(struct ao_scheme_frame *frame) +{ + if (frame && !ao_scheme_frame_marked(frame)) { + int num = frame->num; + if (num < AO_SCHEME_FRAME_FREE) { + struct ao_scheme_frame_vals *vals; + + vals = ao_scheme_poly_frame_vals(frame->vals); + memset(vals->vals, '\0', vals->size * sizeof (struct ao_scheme_val)); + frame->prev = ao_scheme_frame_poly(ao_scheme_frame_free_list[num]); + ao_scheme_frame_free_list[num] = frame; + } + } +} + +static struct ao_scheme_frame * +ao_scheme_frame_realloc(struct ao_scheme_frame *frame, int new_num) +{ + struct ao_scheme_frame_vals *vals; + struct ao_scheme_frame_vals *new_vals; + int copy; + + if (new_num == frame->num) + return frame; + ao_scheme_frame_stash(0, frame); + new_vals = ao_scheme_frame_vals_new(new_num); + frame = ao_scheme_frame_fetch(0); + if (!new_vals) + return NULL; + vals = ao_scheme_poly_frame_vals(frame->vals); + copy = new_num; + if (copy > frame->num) + copy = frame->num; + memcpy(new_vals->vals, vals->vals, copy * sizeof (struct ao_scheme_val)); + frame->vals = ao_scheme_frame_vals_poly(new_vals); + frame->num = new_num; + return frame; +} + +void +ao_scheme_frame_bind(struct ao_scheme_frame *frame, int num, ao_poly atom, ao_poly val) +{ + struct ao_scheme_frame_vals *vals = ao_scheme_poly_frame_vals(frame->vals); + int l = ao_scheme_frame_find(frame, num, atom); + + memmove(&vals->vals[l+1], + &vals->vals[l], + (num - l) * sizeof (struct ao_scheme_val)); + vals->vals[l].atom = atom; + vals->vals[l].val = val; +} + +ao_poly +ao_scheme_frame_add(struct ao_scheme_frame *frame, ao_poly atom, ao_poly val) +{ + ao_poly *ref = frame ? ao_scheme_frame_ref(frame, atom) : NULL; + + if (!ref) { + int f = frame->num; + ao_scheme_poly_stash(0, atom); + ao_scheme_poly_stash(1, val); + frame = ao_scheme_frame_realloc(frame, f + 1); + val = ao_scheme_poly_fetch(1); + atom = ao_scheme_poly_fetch(0); + if (!frame) + return AO_SCHEME_NIL; + ao_scheme_frame_bind(frame, frame->num - 1, atom, val); + } else + *ref = val; + return val; +} + +struct ao_scheme_frame *ao_scheme_frame_global; +struct ao_scheme_frame *ao_scheme_frame_current; + +void +ao_scheme_frame_init(void) +{ + if (!ao_scheme_frame_global) + ao_scheme_frame_global = ao_scheme_frame_new(0); +} diff --git a/src/scheme/ao_scheme_int.c b/src/scheme/ao_scheme_int.c new file mode 100644 index 00000000..350a5d35 --- /dev/null +++ b/src/scheme/ao_scheme_int.c @@ -0,0 +1,79 @@ +/* + * Copyright © 2016 Keith Packard <keithp@keithp.com> + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation, either version 2 of the License, or + * (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, but + * WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + * General Public License for more details. + */ + +#include "ao_scheme.h" + +void +ao_scheme_int_write(ao_poly p) +{ + int i = ao_scheme_poly_int(p); + printf("%d", i); +} + +int32_t +ao_scheme_poly_integer(ao_poly p) +{ + switch (ao_scheme_poly_base_type(p)) { + case AO_SCHEME_INT: + return ao_scheme_poly_int(p); + case AO_SCHEME_OTHER: + if (ao_scheme_other_type(ao_scheme_poly_other(p)) == AO_SCHEME_BIGINT) + return ao_scheme_bigint_int(ao_scheme_poly_bigint(p)->value); + } + return AO_SCHEME_NOT_INTEGER; +} + +ao_poly +ao_scheme_integer_poly(int32_t p) +{ + struct ao_scheme_bigint *bi; + + if (AO_SCHEME_MIN_INT <= p && p <= AO_SCHEME_MAX_INT) + return ao_scheme_int_poly(p); + bi = ao_scheme_alloc(sizeof (struct ao_scheme_bigint)); + bi->value = ao_scheme_int_bigint(p); + return ao_scheme_bigint_poly(bi); +} + +static void bigint_mark(void *addr) +{ + (void) addr; +} + +static int bigint_size(void *addr) +{ + if (!addr) + return 0; + return sizeof (struct ao_scheme_bigint); +} + +static void bigint_move(void *addr) +{ + (void) addr; +} + +const struct ao_scheme_type ao_scheme_bigint_type = { + .mark = bigint_mark, + .size = bigint_size, + .move = bigint_move, + .name = "bigint", +}; + +void +ao_scheme_bigint_write(ao_poly p) +{ + struct ao_scheme_bigint *bi = ao_scheme_poly_bigint(p); + + printf("%d", ao_scheme_bigint_int(bi->value)); +} diff --git a/src/scheme/ao_scheme_lambda.c b/src/scheme/ao_scheme_lambda.c new file mode 100644 index 00000000..ec6f858c --- /dev/null +++ b/src/scheme/ao_scheme_lambda.c @@ -0,0 +1,208 @@ +/* + * Copyright © 2016 Keith Packard <keithp@keithp.com> + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation; version 2 of the License. + * + * 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. + */ + +#include "ao_scheme.h" + +int +lambda_size(void *addr) +{ + (void) addr; + return sizeof (struct ao_scheme_lambda); +} + +void +lambda_mark(void *addr) +{ + struct ao_scheme_lambda *lambda = addr; + + ao_scheme_poly_mark(lambda->code, 0); + ao_scheme_poly_mark(lambda->frame, 0); +} + +void +lambda_move(void *addr) +{ + struct ao_scheme_lambda *lambda = addr; + + ao_scheme_poly_move(&lambda->code, 0); + ao_scheme_poly_move(&lambda->frame, 0); +} + +const struct ao_scheme_type ao_scheme_lambda_type = { + .size = lambda_size, + .mark = lambda_mark, + .move = lambda_move, + .name = "lambda", +}; + +void +ao_scheme_lambda_write(ao_poly poly) +{ + struct ao_scheme_lambda *lambda = ao_scheme_poly_lambda(poly); + struct ao_scheme_cons *cons = ao_scheme_poly_cons(lambda->code); + + printf("("); + printf("%s", ao_scheme_args_name(lambda->args)); + while (cons) { + printf(" "); + ao_scheme_poly_write(cons->car); + cons = ao_scheme_poly_cons(cons->cdr); + } + printf(")"); +} + +ao_poly +ao_scheme_lambda_alloc(struct ao_scheme_cons *code, int args) +{ + struct ao_scheme_lambda *lambda; + ao_poly formal; + struct ao_scheme_cons *cons; + + formal = ao_scheme_arg(code, 0); + while (formal != AO_SCHEME_NIL) { + switch (ao_scheme_poly_type(formal)) { + case AO_SCHEME_CONS: + cons = ao_scheme_poly_cons(formal); + if (ao_scheme_poly_type(cons->car) != AO_SCHEME_ATOM) + return ao_scheme_error(AO_SCHEME_INVALID, "formal %p is not atom", cons->car); + formal = cons->cdr; + break; + case AO_SCHEME_ATOM: + formal = AO_SCHEME_NIL; + break; + default: + return ao_scheme_error(AO_SCHEME_INVALID, "formal %p is not atom", formal); + } + } + + ao_scheme_cons_stash(0, code); + lambda = ao_scheme_alloc(sizeof (struct ao_scheme_lambda)); + code = ao_scheme_cons_fetch(0); + if (!lambda) + return AO_SCHEME_NIL; + + lambda->type = AO_SCHEME_LAMBDA; + lambda->args = args; + lambda->code = ao_scheme_cons_poly(code); + lambda->frame = ao_scheme_frame_mark(ao_scheme_frame_current); + DBGI("build frame: "); DBG_POLY(lambda->frame); DBG("\n"); + DBG_STACK(); + return ao_scheme_lambda_poly(lambda); +} + +ao_poly +ao_scheme_do_lambda(struct ao_scheme_cons *cons) +{ + return ao_scheme_lambda_alloc(cons, AO_SCHEME_FUNC_LAMBDA); +} + +ao_poly +ao_scheme_do_nlambda(struct ao_scheme_cons *cons) +{ + return ao_scheme_lambda_alloc(cons, AO_SCHEME_FUNC_NLAMBDA); +} + +ao_poly +ao_scheme_do_macro(struct ao_scheme_cons *cons) +{ + return ao_scheme_lambda_alloc(cons, AO_SCHEME_FUNC_MACRO); +} + +ao_poly +ao_scheme_lambda_eval(void) +{ + struct ao_scheme_lambda *lambda = ao_scheme_poly_lambda(ao_scheme_v); + struct ao_scheme_cons *cons = ao_scheme_poly_cons(ao_scheme_stack->values); + struct ao_scheme_cons *code = ao_scheme_poly_cons(lambda->code); + ao_poly formals; + struct ao_scheme_frame *next_frame; + int args_wanted; + ao_poly varargs = AO_SCHEME_NIL; + int args_provided; + int f; + struct ao_scheme_cons *vals; + + DBGI("lambda "); DBG_POLY(ao_scheme_lambda_poly(lambda)); DBG("\n"); + + args_wanted = 0; + for (formals = ao_scheme_arg(code, 0); + ao_scheme_is_pair(formals); + formals = ao_scheme_poly_cons(formals)->cdr) + ++args_wanted; + if (formals != AO_SCHEME_NIL) { + if (ao_scheme_poly_type(formals) != AO_SCHEME_ATOM) + return ao_scheme_error(AO_SCHEME_INVALID, "bad lambda form"); + varargs = formals; + } + + /* Create a frame to hold the variables + */ + args_provided = ao_scheme_cons_length(cons) - 1; + if (varargs == AO_SCHEME_NIL) { + if (args_wanted != args_provided) + return ao_scheme_error(AO_SCHEME_INVALID, "need %d args, got %d", args_wanted, args_provided); + } else { + if (args_provided < args_wanted) + return ao_scheme_error(AO_SCHEME_INVALID, "need at least %d args, got %d", args_wanted, args_provided); + } + + ao_scheme_poly_stash(1, varargs); + next_frame = ao_scheme_frame_new(args_wanted + (varargs != AO_SCHEME_NIL)); + varargs = ao_scheme_poly_fetch(1); + if (!next_frame) + return AO_SCHEME_NIL; + + /* Re-fetch all of the values in case something moved */ + lambda = ao_scheme_poly_lambda(ao_scheme_v); + cons = ao_scheme_poly_cons(ao_scheme_stack->values); + code = ao_scheme_poly_cons(lambda->code); + formals = ao_scheme_arg(code, 0); + vals = ao_scheme_poly_cons(cons->cdr); + + next_frame->prev = lambda->frame; + ao_scheme_frame_current = next_frame; + ao_scheme_stack->frame = ao_scheme_frame_poly(ao_scheme_frame_current); + + for (f = 0; f < args_wanted; f++) { + struct ao_scheme_cons *arg = ao_scheme_poly_cons(formals); + DBGI("bind "); DBG_POLY(arg->car); DBG(" = "); DBG_POLY(vals->car); DBG("\n"); + ao_scheme_frame_bind(next_frame, f, arg->car, vals->car); + formals = arg->cdr; + vals = ao_scheme_poly_cons(vals->cdr); + } + if (varargs) { + DBGI("bind "); DBG_POLY(varargs); DBG(" = "); DBG_POLY(ao_scheme_cons_poly(vals)); DBG("\n"); + /* + * Bind the rest of the arguments to the final parameter + */ + ao_scheme_frame_bind(next_frame, f, varargs, ao_scheme_cons_poly(vals)); + } else { + /* + * Mark the cons cells from the actuals as freed for immediate re-use, unless + * the actuals point into the source function (nlambdas and macros), or if the + * stack containing them was copied as a part of a continuation + */ + if (lambda->args == AO_SCHEME_FUNC_LAMBDA && !ao_scheme_stack_marked(ao_scheme_stack)) { + ao_scheme_stack->values = AO_SCHEME_NIL; + ao_scheme_cons_free(cons); + } + } + DBGI("eval frame: "); DBG_POLY(ao_scheme_frame_poly(next_frame)); DBG("\n"); + DBG_STACK(); + DBGI("eval code: "); DBG_POLY(code->cdr); DBG("\n"); + return code->cdr; +} diff --git a/src/lisp/ao_lisp_lex.c b/src/scheme/ao_scheme_lex.c index fe7c47f4..266b1fc0 100644 --- a/src/lisp/ao_lisp_lex.c +++ b/src/scheme/ao_scheme_lex.c @@ -12,5 +12,5 @@ * General Public License for more details. */ -#include "ao_lisp.h" +#include "ao_scheme.h" diff --git a/src/scheme/ao_scheme_make_builtin b/src/scheme/ao_scheme_make_builtin new file mode 100644 index 00000000..8e9c2c0b --- /dev/null +++ b/src/scheme/ao_scheme_make_builtin @@ -0,0 +1,190 @@ +#!/usr/bin/nickle + +typedef struct { + string type; + string c_name; + string[*] lisp_names; +} builtin_t; + +string[string] type_map = { + "lambda" => "LAMBDA", + "nlambda" => "NLAMBDA", + "macro" => "MACRO", + "f_lambda" => "F_LAMBDA", + "atom" => "atom", +}; + +string[*] +make_lisp(string[*] tokens) +{ + string[...] lisp = {}; + + if (dim(tokens) < 3) + return (string[1]) { tokens[dim(tokens) - 1] }; + return (string[dim(tokens)-2]) { [i] = tokens[i+2] }; +} + +builtin_t +read_builtin(file f) { + string line = File::fgets(f); + string[*] tokens = String::wordsplit(line, " \t"); + + return (builtin_t) { + .type = dim(tokens) > 0 ? type_map[tokens[0]] : "#", + .c_name = dim(tokens) > 1 ? tokens[1] : "#", + .lisp_names = make_lisp(tokens), + }; +} + +builtin_t[*] +read_builtins(file f) { + builtin_t[...] builtins = {}; + + while (!File::end(f)) { + builtin_t b = read_builtin(f); + + if (b.type[0] != '#') + builtins[dim(builtins)] = b; + } + return builtins; +} + +bool is_atom(builtin_t b) = b.type == "atom"; + +void +dump_ids(builtin_t[*] builtins) { + printf("#ifdef AO_SCHEME_BUILTIN_ID\n"); + printf("#undef AO_SCHEME_BUILTIN_ID\n"); + printf("enum ao_scheme_builtin_id {\n"); + for (int i = 0; i < dim(builtins); i++) + if (!is_atom(builtins[i])) + printf("\tbuiltin_%s,\n", builtins[i].c_name); + printf("\t_builtin_last\n"); + printf("};\n"); + printf("#endif /* AO_SCHEME_BUILTIN_ID */\n"); +} + +void +dump_casename(builtin_t[*] builtins) { + printf("#ifdef AO_SCHEME_BUILTIN_CASENAME\n"); + printf("#undef AO_SCHEME_BUILTIN_CASENAME\n"); + printf("static char *ao_scheme_builtin_name(enum ao_scheme_builtin_id b) {\n"); + printf("\tswitch(b) {\n"); + for (int i = 0; i < dim(builtins); i++) + if (!is_atom(builtins[i])) + printf("\tcase builtin_%s: return ao_scheme_poly_atom(_atom(\"%s\"))->name;\n", + builtins[i].c_name, builtins[i].lisp_names[0]); + printf("\tdefault: return \"???\";\n"); + printf("\t}\n"); + printf("}\n"); + printf("#endif /* AO_SCHEME_BUILTIN_CASENAME */\n"); +} + +void +cify_lisp(string l) { + for (int j = 0; j < String::length(l); j++) { + int c= l[j]; + if (Ctype::isalnum(c) || c == '_') + printf("%c", c); + else + printf("%02x", c); + } +} + +void +dump_arrayname(builtin_t[*] builtins) { + printf("#ifdef AO_SCHEME_BUILTIN_ARRAYNAME\n"); + printf("#undef AO_SCHEME_BUILTIN_ARRAYNAME\n"); + printf("static const ao_poly builtin_names[] = {\n"); + for (int i = 0; i < dim(builtins); i++) { + if (!is_atom(builtins[i])) { + printf("\t[builtin_%s] = _ao_scheme_atom_", + builtins[i].c_name); + cify_lisp(builtins[i].lisp_names[0]); + printf(",\n"); + } + } + printf("};\n"); + printf("#endif /* AO_SCHEME_BUILTIN_ARRAYNAME */\n"); +} + +void +dump_funcs(builtin_t[*] builtins) { + printf("#ifdef AO_SCHEME_BUILTIN_FUNCS\n"); + printf("#undef AO_SCHEME_BUILTIN_FUNCS\n"); + printf("const ao_scheme_func_t ao_scheme_builtins[] = {\n"); + for (int i = 0; i < dim(builtins); i++) { + if (!is_atom(builtins[i])) + printf("\t[builtin_%s] = ao_scheme_do_%s,\n", + builtins[i].c_name, + builtins[i].c_name); + } + printf("};\n"); + printf("#endif /* AO_SCHEME_BUILTIN_FUNCS */\n"); +} + +void +dump_decls(builtin_t[*] builtins) { + printf("#ifdef AO_SCHEME_BUILTIN_DECLS\n"); + printf("#undef AO_SCHEME_BUILTIN_DECLS\n"); + for (int i = 0; i < dim(builtins); i++) { + if (!is_atom(builtins[i])) { + printf("ao_poly\n"); + printf("ao_scheme_do_%s(struct ao_scheme_cons *cons);\n", + builtins[i].c_name); + } + } + printf("#endif /* AO_SCHEME_BUILTIN_DECLS */\n"); +} + +void +dump_consts(builtin_t[*] builtins) { + printf("#ifdef AO_SCHEME_BUILTIN_CONSTS\n"); + printf("#undef AO_SCHEME_BUILTIN_CONSTS\n"); + printf("struct builtin_func funcs[] = {\n"); + for (int i = 0; i < dim(builtins); i++) { + if (!is_atom(builtins[i])) { + for (int j = 0; j < dim(builtins[i].lisp_names); j++) { + printf ("\t{ .name = \"%s\", .args = AO_SCHEME_FUNC_%s, .func = builtin_%s },\n", + builtins[i].lisp_names[j], + builtins[i].type, + builtins[i].c_name); + } + } + } + printf("};\n"); + printf("#endif /* AO_SCHEME_BUILTIN_CONSTS */\n"); +} + +void +dump_atoms(builtin_t[*] builtins) { + printf("#ifdef AO_SCHEME_BUILTIN_ATOMS\n"); + printf("#undef AO_SCHEME_BUILTIN_ATOMS\n"); + for (int i = 0; i < dim(builtins); i++) { + for (int j = 0; j < dim(builtins[i].lisp_names); j++) { + printf("#define _ao_scheme_atom_"); + cify_lisp(builtins[i].lisp_names[j]); + printf(" _atom(\"%s\")\n", builtins[i].lisp_names[j]); + } + } + printf("#endif /* AO_SCHEME_BUILTIN_ATOMS */\n"); +} + +void main() { + if (dim(argv) < 2) { + File::fprintf(stderr, "usage: %s <file>\n", argv[0]); + exit(1); + } + twixt(file f = File::open(argv[1], "r"); File::close(f)) { + builtin_t[*] builtins = read_builtins(f); + dump_ids(builtins); + dump_casename(builtins); + dump_arrayname(builtins); + dump_funcs(builtins); + dump_decls(builtins); + dump_consts(builtins); + dump_atoms(builtins); + } +} + +main(); diff --git a/src/scheme/ao_scheme_make_const.c b/src/scheme/ao_scheme_make_const.c new file mode 100644 index 00000000..cf42ec52 --- /dev/null +++ b/src/scheme/ao_scheme_make_const.c @@ -0,0 +1,395 @@ +/* + * Copyright © 2016 Keith Packard <keithp@keithp.com> + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation, either version 2 of the License, or + * (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, but + * WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + * General Public License for more details. + */ + +#include "ao_scheme.h" +#include <stdlib.h> +#include <ctype.h> +#include <unistd.h> +#include <getopt.h> + +static struct ao_scheme_builtin * +ao_scheme_make_builtin(enum ao_scheme_builtin_id func, int args) { + struct ao_scheme_builtin *b = ao_scheme_alloc(sizeof (struct ao_scheme_builtin)); + + b->type = AO_SCHEME_BUILTIN; + b->func = func; + b->args = args; + return b; +} + +struct builtin_func { + char *name; + int args; + enum ao_scheme_builtin_id func; +}; + +#define AO_SCHEME_BUILTIN_CONSTS +#include "ao_scheme_builtin.h" + +#define N_FUNC (sizeof funcs / sizeof funcs[0]) + +struct ao_scheme_frame *globals; + +static int +is_atom(int offset) +{ + struct ao_scheme_atom *a; + + for (a = ao_scheme_atoms; a; a = ao_scheme_poly_atom(a->next)) + if (((uint8_t *) a->name - ao_scheme_const) == offset) + return strlen(a->name); + return 0; +} + +#define AO_FEC_CRC_INIT 0xffff + +static inline uint16_t +ao_fec_crc_byte(uint8_t byte, uint16_t crc) +{ + uint8_t bit; + + for (bit = 0; bit < 8; bit++) { + if (((crc & 0x8000) >> 8) ^ (byte & 0x80)) + crc = (crc << 1) ^ 0x8005; + else + crc = (crc << 1); + byte <<= 1; + } + return crc; +} + +uint16_t +ao_fec_crc(const uint8_t *bytes, uint8_t len) +{ + uint16_t crc = AO_FEC_CRC_INIT; + + while (len--) + crc = ao_fec_crc_byte(*bytes++, crc); + return crc; +} + +struct ao_scheme_macro_stack { + struct ao_scheme_macro_stack *next; + ao_poly p; +}; + +struct ao_scheme_macro_stack *macro_stack; + +int +ao_scheme_macro_push(ao_poly p) +{ + struct ao_scheme_macro_stack *m = macro_stack; + + while (m) { + if (m->p == p) + return 1; + m = m->next; + } + m = malloc (sizeof (struct ao_scheme_macro_stack)); + m->p = p; + m->next = macro_stack; + macro_stack = m; + return 0; +} + +void +ao_scheme_macro_pop(void) +{ + struct ao_scheme_macro_stack *m = macro_stack; + + macro_stack = m->next; + free(m); +} + +#define DBG_MACRO 0 +#if DBG_MACRO +int macro_scan_depth; + +void indent(void) +{ + int i; + for (i = 0; i < macro_scan_depth; i++) + printf(" "); +} +#define MACRO_DEBUG(a) a +#else +#define MACRO_DEBUG(a) +#endif + +ao_poly +ao_has_macro(ao_poly p); + +ao_poly +ao_macro_test_get(ao_poly atom) +{ + ao_poly *ref = ao_scheme_atom_ref(atom, NULL); + if (ref) + return *ref; + return AO_SCHEME_NIL; +} + +ao_poly +ao_is_macro(ao_poly p) +{ + struct ao_scheme_builtin *builtin; + struct ao_scheme_lambda *lambda; + ao_poly ret; + + MACRO_DEBUG(indent(); printf ("is macro "); ao_scheme_poly_write(p); printf("\n"); ++macro_scan_depth); + switch (ao_scheme_poly_type(p)) { + case AO_SCHEME_ATOM: + if (ao_scheme_macro_push(p)) + ret = AO_SCHEME_NIL; + else { + if (ao_is_macro(ao_macro_test_get(p))) + ret = p; + else + ret = AO_SCHEME_NIL; + ao_scheme_macro_pop(); + } + break; + case AO_SCHEME_CONS: + ret = ao_has_macro(p); + break; + case AO_SCHEME_BUILTIN: + builtin = ao_scheme_poly_builtin(p); + if ((builtin->args & AO_SCHEME_FUNC_MASK) == AO_SCHEME_FUNC_MACRO) + ret = p; + else + ret = 0; + break; + + case AO_SCHEME_LAMBDA: + lambda = ao_scheme_poly_lambda(p); + if (lambda->args == AO_SCHEME_FUNC_MACRO) + ret = p; + else + ret = ao_has_macro(lambda->code); + break; + default: + ret = AO_SCHEME_NIL; + break; + } + MACRO_DEBUG(--macro_scan_depth; indent(); printf ("... "); ao_scheme_poly_write(ret); printf("\n")); + return ret; +} + +ao_poly +ao_has_macro(ao_poly p) +{ + struct ao_scheme_cons *cons; + struct ao_scheme_lambda *lambda; + ao_poly m; + ao_poly list; + + if (p == AO_SCHEME_NIL) + return AO_SCHEME_NIL; + + MACRO_DEBUG(indent(); printf("has macro "); ao_scheme_poly_write(p); printf("\n"); ++macro_scan_depth); + switch (ao_scheme_poly_type(p)) { + case AO_SCHEME_LAMBDA: + lambda = ao_scheme_poly_lambda(p); + p = ao_has_macro(lambda->code); + break; + case AO_SCHEME_CONS: + cons = ao_scheme_poly_cons(p); + if ((p = ao_is_macro(cons->car))) + break; + + list = cons->cdr; + p = AO_SCHEME_NIL; + while (list != AO_SCHEME_NIL && ao_scheme_poly_type(list) == AO_SCHEME_CONS) { + cons = ao_scheme_poly_cons(list); + m = ao_has_macro(cons->car); + if (m) { + p = m; + break; + } + list = cons->cdr; + } + break; + + default: + p = AO_SCHEME_NIL; + break; + } + MACRO_DEBUG(--macro_scan_depth; indent(); printf("... "); ao_scheme_poly_write(p); printf("\n")); + return p; +} + +int +ao_scheme_read_eval_abort(void) +{ + ao_poly in, out = AO_SCHEME_NIL; + for(;;) { + in = ao_scheme_read(); + if (in == _ao_scheme_atom_eof) + break; + out = ao_scheme_eval(in); + if (ao_scheme_exception) + return 0; + ao_scheme_poly_write(out); + putchar ('\n'); + } + return 1; +} + +static FILE *in; +static FILE *out; + +int +ao_scheme_getc(void) +{ + return getc(in); +} + +static const struct option options[] = { + { .name = "out", .has_arg = 1, .val = 'o' }, + { 0, 0, 0, 0 } +}; + +static void usage(char *program) +{ + fprintf(stderr, "usage: %s [--out=<output>] [input]\n", program); + exit(1); +} + +int +main(int argc, char **argv) +{ + int f, o; + ao_poly val; + struct ao_scheme_atom *a; + struct ao_scheme_builtin *b; + int in_atom = 0; + char *out_name = NULL; + int c; + enum ao_scheme_builtin_id prev_func; + + in = stdin; + out = stdout; + + while ((c = getopt_long(argc, argv, "o:", options, NULL)) != -1) { + switch (c) { + case 'o': + out_name = optarg; + break; + default: + usage(argv[0]); + break; + } + } + + ao_scheme_frame_init(); + + /* Boolean values #f and #t */ + ao_scheme_bool_get(0); + ao_scheme_bool_get(1); + + prev_func = _builtin_last; + for (f = 0; f < (int) N_FUNC; f++) { + if (funcs[f].func != prev_func) + b = ao_scheme_make_builtin(funcs[f].func, funcs[f].args); + a = ao_scheme_atom_intern(funcs[f].name); + ao_scheme_atom_def(ao_scheme_atom_poly(a), + ao_scheme_builtin_poly(b)); + } + + /* end of file value */ + a = ao_scheme_atom_intern("eof"); + ao_scheme_atom_def(ao_scheme_atom_poly(a), + ao_scheme_atom_poly(a)); + + /* 'else' */ + a = ao_scheme_atom_intern("else"); + + if (argv[optind]){ + in = fopen(argv[optind], "r"); + if (!in) { + perror(argv[optind]); + exit(1); + } + } + if (!ao_scheme_read_eval_abort()) { + fprintf(stderr, "eval failed\n"); + exit(1); + } + + /* Reduce to referenced values */ + ao_scheme_collect(AO_SCHEME_COLLECT_FULL); + + for (f = 0; f < ao_scheme_frame_global->num; f++) { + struct ao_scheme_frame_vals *vals = ao_scheme_poly_frame_vals(ao_scheme_frame_global->vals); + val = ao_has_macro(vals->vals[f].val); + if (val != AO_SCHEME_NIL) { + printf("error: function %s contains unresolved macro: ", + ao_scheme_poly_atom(vals->vals[f].atom)->name); + ao_scheme_poly_write(val); + printf("\n"); + exit(1); + } + } + + if (out_name) { + out = fopen(out_name, "w"); + if (!out) { + perror(out_name); + exit(1); + } + } + + fprintf(out, "/* Generated file, do not edit */\n\n"); + + fprintf(out, "#define AO_SCHEME_POOL_CONST %d\n", ao_scheme_top); + fprintf(out, "extern const uint8_t ao_scheme_const[AO_SCHEME_POOL_CONST] __attribute__((aligned(4)));\n"); + fprintf(out, "#define ao_builtin_atoms 0x%04x\n", ao_scheme_atom_poly(ao_scheme_atoms)); + fprintf(out, "#define ao_builtin_frame 0x%04x\n", ao_scheme_frame_poly(ao_scheme_frame_global)); + fprintf(out, "#define ao_scheme_const_checksum ((uint16_t) 0x%04x)\n", ao_fec_crc(ao_scheme_const, ao_scheme_top)); + + fprintf(out, "#define _ao_scheme_bool_false 0x%04x\n", ao_scheme_bool_poly(ao_scheme_false)); + fprintf(out, "#define _ao_scheme_bool_true 0x%04x\n", ao_scheme_bool_poly(ao_scheme_true)); + + for (a = ao_scheme_atoms; a; a = ao_scheme_poly_atom(a->next)) { + char *n = a->name, c; + fprintf(out, "#define _ao_scheme_atom_"); + while ((c = *n++)) { + if (isalnum(c)) + fprintf(out, "%c", c); + else + fprintf(out, "%02x", c); + } + fprintf(out, " 0x%04x\n", ao_scheme_atom_poly(a)); + } + fprintf(out, "#ifdef AO_SCHEME_CONST_BITS\n"); + fprintf(out, "const uint8_t ao_scheme_const[AO_SCHEME_POOL_CONST] __attribute((aligned(4))) = {"); + for (o = 0; o < ao_scheme_top; o++) { + uint8_t c; + if ((o & 0xf) == 0) + fprintf(out, "\n\t"); + else + fprintf(out, " "); + c = ao_scheme_const[o]; + if (!in_atom) + in_atom = is_atom(o); + if (in_atom) { + fprintf(out, " '%c',", c); + in_atom--; + } else { + fprintf(out, "0x%02x,", c); + } + } + fprintf(out, "\n};\n"); + fprintf(out, "#endif /* AO_SCHEME_CONST_BITS */\n"); + exit(0); +} diff --git a/src/scheme/ao_scheme_mem.c b/src/scheme/ao_scheme_mem.c new file mode 100644 index 00000000..45d4de98 --- /dev/null +++ b/src/scheme/ao_scheme_mem.c @@ -0,0 +1,969 @@ +/* + * Copyright © 2016 Keith Packard <keithp@keithp.com> + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation, either version 2 of the License, or + * (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, but + * WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + * General Public License for more details. + */ + +#define AO_SCHEME_CONST_BITS + +#include "ao_scheme.h" +#include <stdio.h> +#include <assert.h> + +#ifdef AO_SCHEME_MAKE_CONST + +/* + * When building the constant table, it is the + * pool for allocations. + */ + +#include <stdlib.h> +uint8_t ao_scheme_const[AO_SCHEME_POOL_CONST] __attribute__((aligned(4))); +#define ao_scheme_pool ao_scheme_const +#undef AO_SCHEME_POOL +#define AO_SCHEME_POOL AO_SCHEME_POOL_CONST + +#else + +uint8_t ao_scheme_pool[AO_SCHEME_POOL + AO_SCHEME_POOL_EXTRA] __attribute__((aligned(4))); + +#endif + +#ifndef DBG_MEM_STATS +#define DBG_MEM_STATS DBG_MEM +#endif + +#if DBG_MEM +int dbg_move_depth; +int dbg_mem = DBG_MEM_START; +int dbg_validate = 0; + +struct ao_scheme_record { + struct ao_scheme_record *next; + const struct ao_scheme_type *type; + void *addr; + int size; +}; + +static struct ao_scheme_record *record_head, **record_tail; + +static void +ao_scheme_record_free(struct ao_scheme_record *record) +{ + while (record) { + struct ao_scheme_record *next = record->next; + free(record); + record = next; + } +} + +static void +ao_scheme_record_reset(void) +{ + ao_scheme_record_free(record_head); + record_head = NULL; + record_tail = &record_head; +} + +static void +ao_scheme_record(const struct ao_scheme_type *type, + void *addr, + int size) +{ + struct ao_scheme_record *r = malloc(sizeof (struct ao_scheme_record)); + + r->next = NULL; + r->type = type; + r->addr = addr; + r->size = size; + *record_tail = r; + record_tail = &r->next; +} + +static struct ao_scheme_record * +ao_scheme_record_save(void) +{ + struct ao_scheme_record *r = record_head; + + record_head = NULL; + record_tail = &record_head; + return r; +} + +static void +ao_scheme_record_compare(char *where, + struct ao_scheme_record *a, + struct ao_scheme_record *b) +{ + while (a && b) { + if (a->type != b->type || a->size != b->size) { + printf("%s record difers %d %s %d -> %d %s %d\n", + where, + MDBG_OFFSET(a->addr), + a->type->name, + a->size, + MDBG_OFFSET(b->addr), + b->type->name, + b->size); + ao_scheme_abort(); + } + a = a->next; + b = b->next; + } + if (a) { + printf("%s record differs %d %s %d -> NULL\n", + where, + MDBG_OFFSET(a->addr), + a->type->name, + a->size); + ao_scheme_abort(); + } + if (b) { + printf("%s record differs NULL -> %d %s %d\n", + where, + MDBG_OFFSET(b->addr), + b->type->name, + b->size); + ao_scheme_abort(); + } +} + +#else +#define ao_scheme_record_reset() +#endif + +uint8_t ao_scheme_exception; + +struct ao_scheme_root { + const struct ao_scheme_type *type; + void **addr; +}; + +static struct ao_scheme_cons *save_cons[2]; +static char *save_string[2]; +static struct ao_scheme_frame *save_frame[1]; +static ao_poly save_poly[3]; + +static const struct ao_scheme_root ao_scheme_root[] = { + { + .type = &ao_scheme_cons_type, + .addr = (void **) &save_cons[0], + }, + { + .type = &ao_scheme_cons_type, + .addr = (void **) &save_cons[1], + }, + { + .type = &ao_scheme_string_type, + .addr = (void **) &save_string[0], + }, + { + .type = &ao_scheme_string_type, + .addr = (void **) &save_string[1], + }, + { + .type = &ao_scheme_frame_type, + .addr = (void **) &save_frame[0], + }, + { + .type = NULL, + .addr = (void **) (void *) &save_poly[0] + }, + { + .type = NULL, + .addr = (void **) (void *) &save_poly[1] + }, + { + .type = NULL, + .addr = (void **) (void *) &save_poly[2] + }, + { + .type = &ao_scheme_atom_type, + .addr = (void **) &ao_scheme_atoms + }, + { + .type = &ao_scheme_frame_type, + .addr = (void **) &ao_scheme_frame_global, + }, + { + .type = &ao_scheme_frame_type, + .addr = (void **) &ao_scheme_frame_current, + }, + { + .type = &ao_scheme_stack_type, + .addr = (void **) &ao_scheme_stack, + }, + { + .type = NULL, + .addr = (void **) (void *) &ao_scheme_v, + }, + { + .type = &ao_scheme_cons_type, + .addr = (void **) &ao_scheme_read_cons, + }, + { + .type = &ao_scheme_cons_type, + .addr = (void **) &ao_scheme_read_cons_tail, + }, + { + .type = &ao_scheme_cons_type, + .addr = (void **) &ao_scheme_read_stack, + }, +#ifdef AO_SCHEME_MAKE_CONST + { + .type = &ao_scheme_bool_type, + .addr = (void **) &ao_scheme_false, + }, + { + .type = &ao_scheme_bool_type, + .addr = (void **) &ao_scheme_true, + }, +#endif +}; + +#define AO_SCHEME_ROOT (sizeof (ao_scheme_root) / sizeof (ao_scheme_root[0])) + +static const void ** const ao_scheme_cache[] = { + (const void **) &ao_scheme_cons_free_list, + (const void **) &ao_scheme_stack_free_list, + (const void **) &ao_scheme_frame_free_list[0], + (const void **) &ao_scheme_frame_free_list[1], + (const void **) &ao_scheme_frame_free_list[2], + (const void **) &ao_scheme_frame_free_list[3], + (const void **) &ao_scheme_frame_free_list[4], + (const void **) &ao_scheme_frame_free_list[5], +}; + +#if AO_SCHEME_FRAME_FREE != 6 +#error Unexpected AO_SCHEME_FRAME_FREE value +#endif + +#define AO_SCHEME_CACHE (sizeof (ao_scheme_cache) / sizeof (ao_scheme_cache[0])) + +#define AO_SCHEME_BUSY_SIZE ((AO_SCHEME_POOL + 31) / 32) + +static uint8_t ao_scheme_busy[AO_SCHEME_BUSY_SIZE]; +static uint8_t ao_scheme_cons_note[AO_SCHEME_BUSY_SIZE]; +static uint8_t ao_scheme_cons_last[AO_SCHEME_BUSY_SIZE]; +static uint8_t ao_scheme_cons_noted; + +uint16_t ao_scheme_top; + +struct ao_scheme_chunk { + uint16_t old_offset; + union { + uint16_t size; + uint16_t new_offset; + }; +}; + +#define AO_SCHEME_NCHUNK 64 + +static struct ao_scheme_chunk ao_scheme_chunk[AO_SCHEME_NCHUNK]; + +/* Offset of an address within the pool. */ +static inline uint16_t pool_offset(void *addr) { +#if DBG_MEM + if (!AO_SCHEME_IS_POOL(addr)) + ao_scheme_abort(); +#endif + return ((uint8_t *) addr) - ao_scheme_pool; +} + +static inline void mark(uint8_t *tag, int offset) { + int byte = offset >> 5; + int bit = (offset >> 2) & 7; + tag[byte] |= (1 << bit); +} + +static inline void clear(uint8_t *tag, int offset) { + int byte = offset >> 5; + int bit = (offset >> 2) & 7; + tag[byte] &= ~(1 << bit); +} + +static inline int busy(uint8_t *tag, int offset) { + int byte = offset >> 5; + int bit = (offset >> 2) & 7; + return (tag[byte] >> bit) & 1; +} + +static inline int min(int a, int b) { return a < b ? a : b; } +static inline int max(int a, int b) { return a > b ? a : b; } + +static inline int limit(int offset) { + return min(AO_SCHEME_POOL, max(offset, 0)); +} + +static void +note_cons(uint16_t offset) +{ + MDBG_MOVE("note cons %d\n", offset); + ao_scheme_cons_noted = 1; + mark(ao_scheme_cons_note, offset); +} + +static uint16_t chunk_low, chunk_high; +static uint16_t chunk_first, chunk_last; + +static int +find_chunk(uint16_t offset) +{ + int l, r; + /* Binary search for the location */ + l = chunk_first; + r = chunk_last - 1; + while (l <= r) { + int m = (l + r) >> 1; + if (ao_scheme_chunk[m].old_offset < offset) + l = m + 1; + else + r = m - 1; + } + return l; +} + +static void +note_chunk(uint16_t offset, uint16_t size) +{ + int l; + + if (offset < chunk_low || chunk_high <= offset) + return; + + l = find_chunk(offset); + + /* + * The correct location is always in 'l', with r = l-1 being + * the entry before the right one + */ + +#if DBG_MEM + /* Off the right side */ + if (l >= AO_SCHEME_NCHUNK) + ao_scheme_abort(); + + /* Off the left side */ + if (l == 0 && chunk_last && offset > ao_scheme_chunk[0].old_offset) + ao_scheme_abort(); +#endif + + /* Shuffle existing entries right */ + int end = min(AO_SCHEME_NCHUNK, chunk_last + 1); + + memmove(&ao_scheme_chunk[l+1], + &ao_scheme_chunk[l], + (end - (l+1)) * sizeof (struct ao_scheme_chunk)); + + /* Add new entry */ + ao_scheme_chunk[l].old_offset = offset; + ao_scheme_chunk[l].size = size; + + /* Increment the number of elements up to the size of the array */ + if (chunk_last < AO_SCHEME_NCHUNK) + chunk_last++; + + /* Set the top address if the array is full */ + if (chunk_last == AO_SCHEME_NCHUNK) + chunk_high = ao_scheme_chunk[AO_SCHEME_NCHUNK-1].old_offset + + ao_scheme_chunk[AO_SCHEME_NCHUNK-1].size; +} + +static void +reset_chunks(void) +{ + chunk_high = ao_scheme_top; + chunk_last = 0; + chunk_first = 0; +} + +/* + * Walk all referenced objects calling functions on each one + */ + +static void +walk(int (*visit_addr)(const struct ao_scheme_type *type, void **addr), + int (*visit_poly)(ao_poly *p, uint8_t do_note_cons)) +{ + int i; + + ao_scheme_record_reset(); + memset(ao_scheme_busy, '\0', sizeof (ao_scheme_busy)); + memset(ao_scheme_cons_note, '\0', sizeof (ao_scheme_cons_note)); + ao_scheme_cons_noted = 0; + for (i = 0; i < (int) AO_SCHEME_ROOT; i++) { + if (ao_scheme_root[i].type) { + void **a = ao_scheme_root[i].addr, *v; + if (a && (v = *a)) { + MDBG_MOVE("root ptr %d\n", MDBG_OFFSET(v)); + visit_addr(ao_scheme_root[i].type, a); + } + } else { + ao_poly *a = (ao_poly *) ao_scheme_root[i].addr, p; + if (a && (p = *a)) { + MDBG_MOVE("root poly %d\n", MDBG_OFFSET(ao_scheme_ref(p))); + visit_poly(a, 0); + } + } + } + while (ao_scheme_cons_noted) { + memcpy(ao_scheme_cons_last, ao_scheme_cons_note, sizeof (ao_scheme_cons_note)); + memset(ao_scheme_cons_note, '\0', sizeof (ao_scheme_cons_note)); + ao_scheme_cons_noted = 0; + for (i = 0; i < AO_SCHEME_POOL; i += 4) { + if (busy(ao_scheme_cons_last, i)) { + void *v = ao_scheme_pool + i; + MDBG_MOVE("root cons %d\n", MDBG_OFFSET(v)); + visit_addr(&ao_scheme_cons_type, &v); + } + } + } +} + +#if MDBG_DUMP +static void +dump_busy(void) +{ + int i; + MDBG_MOVE("busy:"); + for (i = 0; i < ao_scheme_top; i += 4) { + if ((i & 0xff) == 0) { + MDBG_MORE("\n"); + MDBG_MOVE("%s", ""); + } + else if ((i & 0x1f) == 0) + MDBG_MORE(" "); + if (busy(ao_scheme_busy, i)) + MDBG_MORE("*"); + else + MDBG_MORE("-"); + } + MDBG_MORE ("\n"); +} +#define DUMP_BUSY() dump_busy() +#else +#define DUMP_BUSY() +#endif + +static const struct ao_scheme_type * const ao_scheme_types[AO_SCHEME_NUM_TYPE] = { + [AO_SCHEME_CONS] = &ao_scheme_cons_type, + [AO_SCHEME_INT] = NULL, + [AO_SCHEME_STRING] = &ao_scheme_string_type, + [AO_SCHEME_OTHER] = (void *) 0x1, + [AO_SCHEME_ATOM] = &ao_scheme_atom_type, + [AO_SCHEME_BUILTIN] = &ao_scheme_builtin_type, + [AO_SCHEME_FRAME] = &ao_scheme_frame_type, + [AO_SCHEME_FRAME_VALS] = &ao_scheme_frame_vals_type, + [AO_SCHEME_LAMBDA] = &ao_scheme_lambda_type, + [AO_SCHEME_STACK] = &ao_scheme_stack_type, + [AO_SCHEME_BOOL] = &ao_scheme_bool_type, + [AO_SCHEME_BIGINT] = &ao_scheme_bigint_type, + [AO_SCHEME_FLOAT] = &ao_scheme_float_type, + [AO_SCHEME_VECTOR] = &ao_scheme_vector_type, +}; + +static int +ao_scheme_mark_ref(const struct ao_scheme_type *type, void **ref) +{ + return ao_scheme_mark(type, *ref); +} + +static int +ao_scheme_poly_mark_ref(ao_poly *p, uint8_t do_note_cons) +{ + return ao_scheme_poly_mark(*p, do_note_cons); +} + +#if DBG_MEM_STATS +uint64_t ao_scheme_collects[2]; +uint64_t ao_scheme_freed[2]; +uint64_t ao_scheme_loops[2]; +#endif + +int ao_scheme_last_top; + +int +ao_scheme_collect(uint8_t style) +{ + int i; + int top; +#if DBG_MEM_STATS + int loops = 0; +#endif +#if DBG_MEM + struct ao_scheme_record *mark_record = NULL, *move_record = NULL; + + MDBG_MOVE("collect %d\n", ao_scheme_collects[style]); +#endif + MDBG_DO(ao_scheme_frame_write(ao_scheme_frame_poly(ao_scheme_frame_global))); + + /* The first time through, we're doing a full collect */ + if (ao_scheme_last_top == 0) + style = AO_SCHEME_COLLECT_FULL; + + /* Clear references to all caches */ + for (i = 0; i < (int) AO_SCHEME_CACHE; i++) + *ao_scheme_cache[i] = NULL; + if (style == AO_SCHEME_COLLECT_FULL) { + chunk_low = top = 0; + } else { + chunk_low = top = ao_scheme_last_top; + } + for (;;) { +#if DBG_MEM_STATS + loops++; +#endif + MDBG_MOVE("move chunks from %d to %d\n", chunk_low, top); + /* Find the sizes of the first chunk of objects to move */ + reset_chunks(); + walk(ao_scheme_mark_ref, ao_scheme_poly_mark_ref); +#if DBG_MEM + + ao_scheme_record_free(mark_record); + mark_record = ao_scheme_record_save(); + if (mark_record && move_record) + ao_scheme_record_compare("mark", move_record, mark_record); +#endif + + DUMP_BUSY(); + + /* Find the first moving object */ + for (i = 0; i < chunk_last; i++) { + uint16_t size = ao_scheme_chunk[i].size; + +#if DBG_MEM + if (!size) + ao_scheme_abort(); +#endif + + if (ao_scheme_chunk[i].old_offset > top) + break; + + MDBG_MOVE("chunk %d %d not moving\n", + ao_scheme_chunk[i].old_offset, + ao_scheme_chunk[i].size); +#if DBG_MEM + if (ao_scheme_chunk[i].old_offset != top) + ao_scheme_abort(); +#endif + top += size; + } + + /* + * Limit amount of chunk array used in mapping moves + * to the active region + */ + chunk_first = i; + chunk_low = ao_scheme_chunk[i].old_offset; + + /* Copy all of the objects */ + for (; i < chunk_last; i++) { + uint16_t size = ao_scheme_chunk[i].size; + +#if DBG_MEM + if (!size) + ao_scheme_abort(); +#endif + + MDBG_MOVE("chunk %d %d -> %d\n", + ao_scheme_chunk[i].old_offset, + size, + top); + ao_scheme_chunk[i].new_offset = top; + + memmove(&ao_scheme_pool[top], + &ao_scheme_pool[ao_scheme_chunk[i].old_offset], + size); + + top += size; + } + + if (chunk_first < chunk_last) { + /* Relocate all references to the objects */ + walk(ao_scheme_move, ao_scheme_poly_move); + +#if DBG_MEM + ao_scheme_record_free(move_record); + move_record = ao_scheme_record_save(); + if (mark_record && move_record) + ao_scheme_record_compare("move", mark_record, move_record); +#endif + } + + /* If we ran into the end of the heap, then + * there's no need to keep walking + */ + if (chunk_last != AO_SCHEME_NCHUNK) + break; + + /* Next loop starts right above this loop */ + chunk_low = chunk_high; + } + +#if DBG_MEM_STATS + /* Collect stats */ + ++ao_scheme_collects[style]; + ao_scheme_freed[style] += ao_scheme_top - top; + ao_scheme_loops[style] += loops; +#endif + + ao_scheme_top = top; + if (style == AO_SCHEME_COLLECT_FULL) + ao_scheme_last_top = top; + + MDBG_DO(memset(ao_scheme_chunk, '\0', sizeof (ao_scheme_chunk)); + walk(ao_scheme_mark_ref, ao_scheme_poly_mark_ref)); + + return AO_SCHEME_POOL - ao_scheme_top; +} + +#if DBG_FREE_CONS +void +ao_scheme_cons_check(struct ao_scheme_cons *cons) +{ + ao_poly cdr; + int offset; + + chunk_low = 0; + reset_chunks(); + walk(ao_scheme_mark_ref, ao_scheme_poly_mark_ref); + while (cons) { + if (!AO_SCHEME_IS_POOL(cons)) + break; + offset = pool_offset(cons); + if (busy(ao_scheme_busy, offset)) { + ao_scheme_printf("cons at %p offset %d poly %d is busy\n\t%v\n", cons, offset, ao_scheme_cons_poly(cons), ao_scheme_cons_poly(cons)); + abort(); + } + cdr = cons->cdr; + if (!ao_scheme_is_pair(cdr)) + break; + cons = ao_scheme_poly_cons(cdr); + } +} +#endif + +/* + * Mark interfaces for objects + */ + + +/* + * Mark a block of memory with an explicit size + */ + +int +ao_scheme_mark_block(void *addr, int size) +{ + int offset; + if (!AO_SCHEME_IS_POOL(addr)) + return 1; + + offset = pool_offset(addr); + MDBG_MOVE("mark memory %d\n", MDBG_OFFSET(addr)); + if (busy(ao_scheme_busy, offset)) { + MDBG_MOVE("already marked\n"); + return 1; + } + mark(ao_scheme_busy, offset); + note_chunk(offset, size); + return 0; +} + +/* + * Note a reference to memory and collect information about a few + * object sizes at a time + */ + +int +ao_scheme_mark_memory(const struct ao_scheme_type *type, void *addr) +{ + int offset; + if (!AO_SCHEME_IS_POOL(addr)) + return 1; + + offset = pool_offset(addr); + MDBG_MOVE("mark memory %d\n", MDBG_OFFSET(addr)); + if (busy(ao_scheme_busy, offset)) { + MDBG_MOVE("already marked\n"); + return 1; + } + mark(ao_scheme_busy, offset); + note_chunk(offset, ao_scheme_size(type, addr)); + return 0; +} + +/* + * Mark an object and all that it refereces + */ +int +ao_scheme_mark(const struct ao_scheme_type *type, void *addr) +{ + int ret; + MDBG_MOVE("mark %d\n", MDBG_OFFSET(addr)); + MDBG_MOVE_IN(); + ret = ao_scheme_mark_memory(type, addr); + if (!ret) { + MDBG_MOVE("mark recurse\n"); + type->mark(addr); + } + MDBG_MOVE_OUT(); + return ret; +} + +/* + * Mark an object, unless it is a cons cell and + * do_note_cons is set. In that case, just + * set a bit in the cons note array; those + * will be marked in a separate pass to avoid + * deep recursion in the collector + */ +int +ao_scheme_poly_mark(ao_poly p, uint8_t do_note_cons) +{ + uint8_t type; + void *addr; + + type = ao_scheme_poly_base_type(p); + + if (type == AO_SCHEME_INT) + return 1; + + addr = ao_scheme_ref(p); + if (!AO_SCHEME_IS_POOL(addr)) + return 1; + + if (type == AO_SCHEME_CONS && do_note_cons) { + note_cons(pool_offset(addr)); + return 1; + } else { + if (type == AO_SCHEME_OTHER) + type = ao_scheme_other_type(addr); + + const struct ao_scheme_type *lisp_type = ao_scheme_types[type]; +#if DBG_MEM + if (!lisp_type) + ao_scheme_abort(); +#endif + + return ao_scheme_mark(lisp_type, addr); + } +} + +/* + * Find the current location of an object + * based on the original location. For unmoved + * objects, this is simple. For moved objects, + * go search for it + */ + +static uint16_t +move_map(uint16_t offset) +{ + int l; + + if (offset < chunk_low || chunk_high <= offset) + return offset; + + l = find_chunk(offset); + +#if DBG_MEM + if (ao_scheme_chunk[l].old_offset != offset) + ao_scheme_abort(); +#endif + return ao_scheme_chunk[l].new_offset; +} + +int +ao_scheme_move_memory(const struct ao_scheme_type *type, void **ref) +{ + void *addr = *ref; + uint16_t offset, orig_offset; + + if (!AO_SCHEME_IS_POOL(addr)) + return 1; + + (void) type; + + MDBG_MOVE("move memory %d\n", MDBG_OFFSET(addr)); + orig_offset = pool_offset(addr); + offset = move_map(orig_offset); + if (offset != orig_offset) { + MDBG_MOVE("update ref %d %d -> %d\n", + AO_SCHEME_IS_POOL(ref) ? MDBG_OFFSET(ref) : -1, + orig_offset, offset); + *ref = ao_scheme_pool + offset; + } + if (busy(ao_scheme_busy, offset)) { + MDBG_MOVE("already moved\n"); + return 1; + } + mark(ao_scheme_busy, offset); + MDBG_DO(ao_scheme_record(type, addr, ao_scheme_size(type, addr))); + return 0; +} + +int +ao_scheme_move(const struct ao_scheme_type *type, void **ref) +{ + int ret; + MDBG_MOVE("move object %d\n", MDBG_OFFSET(*ref)); + MDBG_MOVE_IN(); + ret = ao_scheme_move_memory(type, ref); + if (!ret) { + MDBG_MOVE("move recurse\n"); + type->move(*ref); + } + MDBG_MOVE_OUT(); + return ret; +} + +int +ao_scheme_poly_move(ao_poly *ref, uint8_t do_note_cons) +{ + uint8_t type; + ao_poly p = *ref; + int ret; + void *addr; + uint16_t offset, orig_offset; + uint8_t base_type; + + base_type = type = ao_scheme_poly_base_type(p); + + if (type == AO_SCHEME_INT) + return 1; + + addr = ao_scheme_ref(p); + if (!AO_SCHEME_IS_POOL(addr)) + return 1; + + orig_offset = pool_offset(addr); + offset = move_map(orig_offset); + + if (type == AO_SCHEME_CONS && do_note_cons) { + note_cons(orig_offset); + ret = 1; + } else { + if (type == AO_SCHEME_OTHER) + type = ao_scheme_other_type(ao_scheme_pool + offset); + + const struct ao_scheme_type *lisp_type = ao_scheme_types[type]; +#if DBG_MEM + if (!lisp_type) + ao_scheme_abort(); +#endif + + ret = ao_scheme_move(lisp_type, &addr); + } + + /* Re-write the poly value */ + if (offset != orig_offset) { + ao_poly np = ao_scheme_poly(ao_scheme_pool + offset, base_type); + MDBG_MOVE("poly %d moved %d -> %d\n", + type, orig_offset, offset); + *ref = np; + } + return ret; +} + +#if DBG_MEM +void +ao_scheme_validate(void) +{ + chunk_low = 0; + memset(ao_scheme_chunk, '\0', sizeof (ao_scheme_chunk)); + walk(ao_scheme_mark_ref, ao_scheme_poly_mark_ref); +} + +int dbg_allocs; + +#endif + +void * +ao_scheme_alloc(int size) +{ + void *addr; + + MDBG_DO(++dbg_allocs); + MDBG_DO(if (dbg_validate) ao_scheme_validate()); + size = ao_scheme_size_round(size); + if (AO_SCHEME_POOL - ao_scheme_top < size && + ao_scheme_collect(AO_SCHEME_COLLECT_INCREMENTAL) < size && + ao_scheme_collect(AO_SCHEME_COLLECT_FULL) < size) + { + ao_scheme_error(AO_SCHEME_OOM, "out of memory"); + return NULL; + } + addr = ao_scheme_pool + ao_scheme_top; + ao_scheme_top += size; + MDBG_MOVE("alloc %d size %d\n", MDBG_OFFSET(addr), size); + return addr; +} + +void +ao_scheme_cons_stash(int id, struct ao_scheme_cons *cons) +{ + assert(save_cons[id] == 0); + save_cons[id] = cons; +} + +struct ao_scheme_cons * +ao_scheme_cons_fetch(int id) +{ + struct ao_scheme_cons *cons = save_cons[id]; + save_cons[id] = NULL; + return cons; +} + +void +ao_scheme_poly_stash(int id, ao_poly poly) +{ + assert(save_poly[id] == AO_SCHEME_NIL); + save_poly[id] = poly; +} + +ao_poly +ao_scheme_poly_fetch(int id) +{ + ao_poly poly = save_poly[id]; + save_poly[id] = AO_SCHEME_NIL; + return poly; +} + +void +ao_scheme_string_stash(int id, char *string) +{ + assert(save_string[id] == NULL); + save_string[id] = string; +} + +char * +ao_scheme_string_fetch(int id) +{ + char *string = save_string[id]; + save_string[id] = NULL; + return string; +} + +void +ao_scheme_frame_stash(int id, struct ao_scheme_frame *frame) +{ + assert(save_frame[id] == NULL); + save_frame[id] = frame; +} + +struct ao_scheme_frame * +ao_scheme_frame_fetch(int id) +{ + struct ao_scheme_frame *frame = save_frame[id]; + save_frame[id] = NULL; + return frame; +} diff --git a/src/scheme/ao_scheme_poly.c b/src/scheme/ao_scheme_poly.c new file mode 100644 index 00000000..553585db --- /dev/null +++ b/src/scheme/ao_scheme_poly.c @@ -0,0 +1,122 @@ +/* + * Copyright © 2016 Keith Packard <keithp@keithp.com> + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation, either version 2 of the License, or + * (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, but + * WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + * General Public License for more details. + */ + +#include "ao_scheme.h" + +struct ao_scheme_funcs { + void (*write)(ao_poly); + void (*display)(ao_poly); +}; + +static const struct ao_scheme_funcs ao_scheme_funcs[AO_SCHEME_NUM_TYPE] = { + [AO_SCHEME_CONS] = { + .write = ao_scheme_cons_write, + .display = ao_scheme_cons_display, + }, + [AO_SCHEME_STRING] = { + .write = ao_scheme_string_write, + .display = ao_scheme_string_display, + }, + [AO_SCHEME_INT] = { + .write = ao_scheme_int_write, + .display = ao_scheme_int_write, + }, + [AO_SCHEME_ATOM] = { + .write = ao_scheme_atom_write, + .display = ao_scheme_atom_write, + }, + [AO_SCHEME_BUILTIN] = { + .write = ao_scheme_builtin_write, + .display = ao_scheme_builtin_write, + }, + [AO_SCHEME_FRAME] = { + .write = ao_scheme_frame_write, + .display = ao_scheme_frame_write, + }, + [AO_SCHEME_FRAME_VALS] = { + .write = NULL, + .display = NULL, + }, + [AO_SCHEME_LAMBDA] = { + .write = ao_scheme_lambda_write, + .display = ao_scheme_lambda_write, + }, + [AO_SCHEME_STACK] = { + .write = ao_scheme_stack_write, + .display = ao_scheme_stack_write, + }, + [AO_SCHEME_BOOL] = { + .write = ao_scheme_bool_write, + .display = ao_scheme_bool_write, + }, + [AO_SCHEME_BIGINT] = { + .write = ao_scheme_bigint_write, + .display = ao_scheme_bigint_write, + }, + [AO_SCHEME_FLOAT] = { + .write = ao_scheme_float_write, + .display = ao_scheme_float_write, + }, + [AO_SCHEME_VECTOR] = { + .write = ao_scheme_vector_write, + .display = ao_scheme_vector_display + }, +}; + +static const struct ao_scheme_funcs * +funcs(ao_poly p) +{ + uint8_t type = ao_scheme_poly_type(p); + + if (type < AO_SCHEME_NUM_TYPE) + return &ao_scheme_funcs[type]; + return NULL; +} + +void +ao_scheme_poly_write(ao_poly p) +{ + const struct ao_scheme_funcs *f = funcs(p); + + if (f && f->write) + f->write(p); +} + +void +ao_scheme_poly_display(ao_poly p) +{ + const struct ao_scheme_funcs *f = funcs(p); + + if (f && f->display) + f->display(p); +} + +void * +ao_scheme_ref(ao_poly poly) { + if (poly == AO_SCHEME_NIL) + return NULL; + if (poly & AO_SCHEME_CONST) + return (void *) (ao_scheme_const + (poly & AO_SCHEME_REF_MASK) - 4); + return (void *) (ao_scheme_pool + (poly & AO_SCHEME_REF_MASK) - 4); +} + +ao_poly +ao_scheme_poly(const void *addr, ao_poly type) { + const uint8_t *a = addr; + if (a == NULL) + return AO_SCHEME_NIL; + if (AO_SCHEME_IS_CONST(a)) + return AO_SCHEME_CONST | (a - ao_scheme_const + 4) | type; + return (a - ao_scheme_pool + 4) | type; +} diff --git a/src/scheme/ao_scheme_read.c b/src/scheme/ao_scheme_read.c new file mode 100644 index 00000000..9ed54b9f --- /dev/null +++ b/src/scheme/ao_scheme_read.c @@ -0,0 +1,665 @@ +/* + * Copyright © 2016 Keith Packard <keithp@keithp.com> + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation, either version 2 of the License, or + * (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, but + * WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + * General Public License for more details. + */ + +#include "ao_scheme.h" +#include "ao_scheme_read.h" +#include <math.h> +#include <stdlib.h> + +static const uint16_t lex_classes[128] = { + IGNORE, /* ^@ */ + IGNORE, /* ^A */ + IGNORE, /* ^B */ + IGNORE, /* ^C */ + IGNORE, /* ^D */ + IGNORE, /* ^E */ + IGNORE, /* ^F */ + IGNORE, /* ^G */ + IGNORE, /* ^H */ + WHITE, /* ^I */ + WHITE, /* ^J */ + WHITE, /* ^K */ + WHITE, /* ^L */ + WHITE, /* ^M */ + IGNORE, /* ^N */ + IGNORE, /* ^O */ + IGNORE, /* ^P */ + IGNORE, /* ^Q */ + IGNORE, /* ^R */ + IGNORE, /* ^S */ + IGNORE, /* ^T */ + IGNORE, /* ^U */ + IGNORE, /* ^V */ + IGNORE, /* ^W */ + IGNORE, /* ^X */ + IGNORE, /* ^Y */ + IGNORE, /* ^Z */ + IGNORE, /* ^[ */ + IGNORE, /* ^\ */ + IGNORE, /* ^] */ + IGNORE, /* ^^ */ + IGNORE, /* ^_ */ + PRINTABLE|WHITE, /* */ + PRINTABLE, /* ! */ + PRINTABLE|STRINGC, /* " */ + PRINTABLE|POUND, /* # */ + PRINTABLE, /* $ */ + PRINTABLE, /* % */ + PRINTABLE, /* & */ + PRINTABLE|SPECIAL, /* ' */ + PRINTABLE|SPECIAL, /* ( */ + PRINTABLE|SPECIAL, /* ) */ + PRINTABLE, /* * */ + PRINTABLE|SIGN, /* + */ + PRINTABLE|SPECIAL, /* , */ + PRINTABLE|SIGN, /* - */ + PRINTABLE|DOTC|FLOATC, /* . */ + PRINTABLE, /* / */ + PRINTABLE|DIGIT, /* 0 */ + PRINTABLE|DIGIT, /* 1 */ + PRINTABLE|DIGIT, /* 2 */ + PRINTABLE|DIGIT, /* 3 */ + PRINTABLE|DIGIT, /* 4 */ + PRINTABLE|DIGIT, /* 5 */ + PRINTABLE|DIGIT, /* 6 */ + PRINTABLE|DIGIT, /* 7 */ + PRINTABLE|DIGIT, /* 8 */ + PRINTABLE|DIGIT, /* 9 */ + PRINTABLE, /* : */ + PRINTABLE|COMMENT, /* ; */ + PRINTABLE, /* < */ + PRINTABLE, /* = */ + PRINTABLE, /* > */ + PRINTABLE, /* ? */ + PRINTABLE, /* @ */ + PRINTABLE, /* A */ + PRINTABLE, /* B */ + PRINTABLE, /* C */ + PRINTABLE, /* D */ + PRINTABLE|FLOATC, /* E */ + PRINTABLE, /* F */ + PRINTABLE, /* G */ + PRINTABLE, /* H */ + PRINTABLE, /* I */ + PRINTABLE, /* J */ + PRINTABLE, /* K */ + PRINTABLE, /* L */ + PRINTABLE, /* M */ + PRINTABLE, /* N */ + PRINTABLE, /* O */ + PRINTABLE, /* P */ + PRINTABLE, /* Q */ + PRINTABLE, /* R */ + PRINTABLE, /* S */ + PRINTABLE, /* T */ + PRINTABLE, /* U */ + PRINTABLE, /* V */ + PRINTABLE, /* W */ + PRINTABLE, /* X */ + PRINTABLE, /* Y */ + PRINTABLE, /* Z */ + PRINTABLE, /* [ */ + PRINTABLE|BACKSLASH, /* \ */ + PRINTABLE, /* ] */ + PRINTABLE, /* ^ */ + PRINTABLE, /* _ */ + PRINTABLE|SPECIAL, /* ` */ + PRINTABLE, /* a */ + PRINTABLE, /* b */ + PRINTABLE, /* c */ + PRINTABLE, /* d */ + PRINTABLE|FLOATC, /* e */ + PRINTABLE, /* f */ + PRINTABLE, /* g */ + PRINTABLE, /* h */ + PRINTABLE, /* i */ + PRINTABLE, /* j */ + PRINTABLE, /* k */ + PRINTABLE, /* l */ + PRINTABLE, /* m */ + PRINTABLE, /* n */ + PRINTABLE, /* o */ + PRINTABLE, /* p */ + PRINTABLE, /* q */ + PRINTABLE, /* r */ + PRINTABLE, /* s */ + PRINTABLE, /* t */ + PRINTABLE, /* u */ + PRINTABLE, /* v */ + PRINTABLE, /* w */ + PRINTABLE, /* x */ + PRINTABLE, /* y */ + PRINTABLE, /* z */ + PRINTABLE, /* { */ + PRINTABLE, /* | */ + PRINTABLE, /* } */ + PRINTABLE, /* ~ */ + IGNORE, /* ^? */ +}; + +static int lex_unget_c; + +static inline int +lex_get(void) +{ + int c; + if (lex_unget_c) { + c = lex_unget_c; + lex_unget_c = 0; + } else { + c = ao_scheme_getc(); + } + return c; +} + +static inline void +lex_unget(int c) +{ + if (c != EOF) + lex_unget_c = c; +} + +static uint16_t lex_class; + +static int +lexc(void) +{ + int c; + do { + c = lex_get(); + if (c == EOF) { + c = 0; + lex_class = ENDOFFILE; + } else { + c &= 0x7f; + lex_class = lex_classes[c]; + } + } while (lex_class & IGNORE); + return c; +} + +static int +lex_quoted(void) +{ + int c; + int v; + int count; + + c = lex_get(); + if (c == EOF) { + lex_class = ENDOFFILE; + return 0; + } + lex_class = 0; + c &= 0x7f; + switch (c) { + case 'n': + return '\n'; + case 'f': + return '\f'; + case 'b': + return '\b'; + case 'r': + return '\r'; + case 'v': + return '\v'; + case 't': + return '\t'; + case '0': + case '1': + case '2': + case '3': + case '4': + case '5': + case '6': + case '7': + v = c - '0'; + count = 1; + while (count <= 3) { + c = lex_get(); + if (c == EOF) + return EOF; + c &= 0x7f; + if (c < '0' || '7' < c) { + lex_unget(c); + break; + } + v = (v << 3) + c - '0'; + ++count; + } + return v; + default: + return c; + } +} + +#define AO_SCHEME_TOKEN_MAX 128 + +static char token_string[AO_SCHEME_TOKEN_MAX]; +static int32_t token_int; +static int token_len; +static float token_float; + +static inline void add_token(int c) { + if (c && token_len < AO_SCHEME_TOKEN_MAX - 1) + token_string[token_len++] = c; +} + +static inline void del_token(void) { + if (token_len > 0) + token_len--; +} + +static inline void end_token(void) { + token_string[token_len] = '\0'; +} + +struct namedfloat { + const char *name; + float value; +}; + +static const struct namedfloat namedfloats[] = { + { .name = "+inf.0", .value = INFINITY }, + { .name = "-inf.0", .value = -INFINITY }, + { .name = "+nan.0", .value = NAN }, + { .name = "-nan.0", .value = NAN }, +}; + +#define NUM_NAMED_FLOATS (sizeof namedfloats / sizeof namedfloats[0]) + +static int +_lex(void) +{ + int c; + + token_len = 0; + for (;;) { + c = lexc(); + if (lex_class & ENDOFFILE) + return END; + + if (lex_class & WHITE) + continue; + + if (lex_class & COMMENT) { + while ((c = lexc()) != '\n') { + if (lex_class & ENDOFFILE) + return END; + } + continue; + } + + if (lex_class & (SPECIAL|DOTC)) { + add_token(c); + end_token(); + switch (c) { + case '(': + case '[': + return OPEN; + case ')': + case ']': + return CLOSE; + case '\'': + return QUOTE; + case '.': + return DOT; + case '`': + return QUASIQUOTE; + case ',': + c = lexc(); + if (c == '@') { + add_token(c); + end_token(); + return UNQUOTE_SPLICING; + } else { + lex_unget(c); + return UNQUOTE; + } + } + } + if (lex_class & POUND) { + c = lexc(); + switch (c) { + case 't': + add_token(c); + end_token(); + return BOOL; + case 'f': + add_token(c); + end_token(); + return BOOL; + case '(': + return OPEN_VECTOR; + case '\\': + for (;;) { + int alphabetic; + c = lexc(); + alphabetic = (('a' <= c && c <= 'z') || ('A' <= c && c <= 'Z')); + if (token_len == 0) { + add_token(c); + if (!alphabetic) + break; + } else { + if (alphabetic) + add_token(c); + else { + lex_unget(c); + break; + } + } + } + end_token(); + if (token_len == 1) + token_int = token_string[0]; + else if (!strcmp(token_string, "space")) + token_int = ' '; + else if (!strcmp(token_string, "newline")) + token_int = '\n'; + else if (!strcmp(token_string, "tab")) + token_int = '\t'; + else if (!strcmp(token_string, "return")) + token_int = '\r'; + else if (!strcmp(token_string, "formfeed")) + token_int = '\f'; + else { + ao_scheme_error(AO_SCHEME_INVALID, "invalid character token #\\%s", token_string); + continue; + } + return NUM; + } + } + if (lex_class & STRINGC) { + for (;;) { + c = lexc(); + if (lex_class & BACKSLASH) + c = lex_quoted(); + if (lex_class & (STRINGC|ENDOFFILE)) { + end_token(); + return STRING; + } + add_token(c); + } + } + if (lex_class & PRINTABLE) { + int isfloat; + int hasdigit; + int isneg; + int isint; + int epos; + + isfloat = 1; + isint = 1; + hasdigit = 0; + token_int = 0; + isneg = 0; + epos = 0; + for (;;) { + if (!(lex_class & NUMBER)) { + isint = 0; + isfloat = 0; + } else { + if (!(lex_class & INTEGER)) + isint = 0; + if (token_len != epos && + (lex_class & SIGN)) + { + isint = 0; + isfloat = 0; + } + if (c == '-') + isneg = 1; + if (c == '.' && epos != 0) + isfloat = 0; + if (c == 'e' || c == 'E') { + if (token_len == 0) + isfloat = 0; + else + epos = token_len + 1; + } + if (lex_class & DIGIT) { + hasdigit = 1; + if (isint) + token_int = token_int * 10 + c - '0'; + } + } + add_token (c); + c = lexc (); + if ((lex_class & (NOTNAME)) && (c != '.' || !isfloat)) { + unsigned int u; +// if (lex_class & ENDOFFILE) +// clearerr (f); + lex_unget(c); + end_token (); + if (isint && hasdigit) { + if (isneg) + token_int = -token_int; + return NUM; + } + if (isfloat && hasdigit) { + token_float = strtof(token_string, NULL); + return FLOAT; + } + for (u = 0; u < NUM_NAMED_FLOATS; u++) + if (!strcmp(namedfloats[u].name, token_string)) { + token_float = namedfloats[u].value; + return FLOAT; + } + return NAME; + } + } + } + } +} + +static inline int lex(void) +{ + int parse_token = _lex(); + RDBGI("token %d (%s)\n", parse_token, token_string); + return parse_token; +} + +static int parse_token; + +int ao_scheme_read_list; +struct ao_scheme_cons *ao_scheme_read_cons; +struct ao_scheme_cons *ao_scheme_read_cons_tail; +struct ao_scheme_cons *ao_scheme_read_stack; +static int ao_scheme_read_state; + +#define READ_IN_QUOTE 0x01 +#define READ_SAW_DOT 0x02 +#define READ_DONE_DOT 0x04 +#define READ_SAW_VECTOR 0x08 + +static int +push_read_stack(int read_state) +{ + RDBGI("push read stack %p 0x%x\n", ao_scheme_read_cons, read_state); + RDBG_IN(); + if (ao_scheme_read_list) { + ao_scheme_read_stack = ao_scheme_cons_cons(ao_scheme_cons_poly(ao_scheme_read_cons), + ao_scheme__cons(ao_scheme_int_poly(read_state), + ao_scheme_cons_poly(ao_scheme_read_stack))); + if (!ao_scheme_read_stack) + return 0; + } else + ao_scheme_read_state = read_state; + ao_scheme_read_cons = NULL; + ao_scheme_read_cons_tail = NULL; + return 1; +} + +static int +pop_read_stack(void) +{ + int read_state = 0; + if (ao_scheme_read_list) { + ao_scheme_read_cons = ao_scheme_poly_cons(ao_scheme_read_stack->car); + ao_scheme_read_stack = ao_scheme_poly_cons(ao_scheme_read_stack->cdr); + read_state = ao_scheme_poly_int(ao_scheme_read_stack->car); + ao_scheme_read_stack = ao_scheme_poly_cons(ao_scheme_read_stack->cdr); + for (ao_scheme_read_cons_tail = ao_scheme_read_cons; + ao_scheme_read_cons_tail && ao_scheme_read_cons_tail->cdr; + ao_scheme_read_cons_tail = ao_scheme_poly_cons(ao_scheme_read_cons_tail->cdr)) + ; + } else { + ao_scheme_read_cons = 0; + ao_scheme_read_cons_tail = 0; + ao_scheme_read_stack = 0; + read_state = ao_scheme_read_state; + } + RDBG_OUT(); + RDBGI("pop read stack %p %d\n", ao_scheme_read_cons, read_state); + return read_state; +} + +ao_poly +ao_scheme_read(void) +{ + struct ao_scheme_atom *atom; + char *string; + int read_state; + ao_poly v = AO_SCHEME_NIL; + + ao_scheme_read_list = 0; + read_state = 0; + ao_scheme_read_cons = ao_scheme_read_cons_tail = ao_scheme_read_stack = 0; + for (;;) { + parse_token = lex(); + while (parse_token == OPEN || parse_token == OPEN_VECTOR) { + if (parse_token == OPEN_VECTOR) + read_state |= READ_SAW_VECTOR; + if (!push_read_stack(read_state)) + return AO_SCHEME_NIL; + ao_scheme_read_list++; + read_state = 0; + parse_token = lex(); + } + + switch (parse_token) { + case END: + default: + if (ao_scheme_read_list) + ao_scheme_error(AO_SCHEME_EOF, "unexpected end of file"); + return _ao_scheme_atom_eof; + break; + case NAME: + atom = ao_scheme_atom_intern(token_string); + if (atom) + v = ao_scheme_atom_poly(atom); + else + v = AO_SCHEME_NIL; + break; + case NUM: + v = ao_scheme_integer_poly(token_int); + break; + case FLOAT: + v = ao_scheme_float_get(token_float); + break; + case BOOL: + if (token_string[0] == 't') + v = _ao_scheme_bool_true; + else + v = _ao_scheme_bool_false; + break; + case STRING: + string = ao_scheme_string_copy(token_string); + if (string) + v = ao_scheme_string_poly(string); + else + v = AO_SCHEME_NIL; + break; + case QUOTE: + case QUASIQUOTE: + case UNQUOTE: + case UNQUOTE_SPLICING: + if (!push_read_stack(read_state)) + return AO_SCHEME_NIL; + ao_scheme_read_list++; + read_state = READ_IN_QUOTE; + switch (parse_token) { + case QUOTE: + v = _ao_scheme_atom_quote; + break; + case QUASIQUOTE: + v = _ao_scheme_atom_quasiquote; + break; + case UNQUOTE: + v = _ao_scheme_atom_unquote; + break; + case UNQUOTE_SPLICING: + v = _ao_scheme_atom_unquote2dsplicing; + break; + } + break; + case CLOSE: + if (!ao_scheme_read_list) { + v = AO_SCHEME_NIL; + break; + } + v = ao_scheme_cons_poly(ao_scheme_read_cons); + --ao_scheme_read_list; + read_state = pop_read_stack(); + if (read_state & READ_SAW_VECTOR) + v = ao_scheme_vector_poly(ao_scheme_list_to_vector(ao_scheme_poly_cons(v))); + break; + case DOT: + if (!ao_scheme_read_list) { + ao_scheme_error(AO_SCHEME_INVALID, ". outside of cons"); + return AO_SCHEME_NIL; + } + if (!ao_scheme_read_cons) { + ao_scheme_error(AO_SCHEME_INVALID, ". first in cons"); + return AO_SCHEME_NIL; + } + read_state |= READ_SAW_DOT; + continue; + } + + /* loop over QUOTE ends */ + for (;;) { + if (!ao_scheme_read_list) + return v; + + if (read_state & READ_DONE_DOT) { + ao_scheme_error(AO_SCHEME_INVALID, ". not last in cons"); + return AO_SCHEME_NIL; + } + + if (read_state & READ_SAW_DOT) { + read_state |= READ_DONE_DOT; + ao_scheme_read_cons_tail->cdr = v; + } else { + struct ao_scheme_cons *read = ao_scheme_cons_cons(v, AO_SCHEME_NIL); + if (!read) + return AO_SCHEME_NIL; + + if (ao_scheme_read_cons_tail) + ao_scheme_read_cons_tail->cdr = ao_scheme_cons_poly(read); + else + ao_scheme_read_cons = read; + ao_scheme_read_cons_tail = read; + } + + if (!(read_state & READ_IN_QUOTE) || !ao_scheme_read_cons->cdr) + break; + + v = ao_scheme_cons_poly(ao_scheme_read_cons); + --ao_scheme_read_list; + read_state = pop_read_stack(); + } + } + return v; +} diff --git a/src/scheme/ao_scheme_read.h b/src/scheme/ao_scheme_read.h new file mode 100644 index 00000000..e10a7d05 --- /dev/null +++ b/src/scheme/ao_scheme_read.h @@ -0,0 +1,59 @@ +/* + * Copyright © 2016 Keith Packard <keithp@keithp.com> + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation, either version 2 of the License, or + * (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, but + * WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + * General Public License for more details. + */ + +#ifndef _AO_SCHEME_READ_H_ +#define _AO_SCHEME_READ_H_ + +/* + * token classes + */ + +# define END 0 +# define NAME 1 +# define OPEN 2 +# define CLOSE 3 +# define QUOTE 4 +# define QUASIQUOTE 5 +# define UNQUOTE 6 +# define UNQUOTE_SPLICING 7 +# define STRING 8 +# define NUM 9 +# define FLOAT 10 +# define DOT 11 +# define BOOL 12 +# define OPEN_VECTOR 13 + +/* + * character classes + */ + +# define PRINTABLE 0x0001 /* \t \n ' ' - ~ */ +# define SPECIAL 0x0002 /* ( [ { ) ] } ' ` , */ +# define DOTC 0x0004 /* . */ +# define WHITE 0x0008 /* ' ' \t \n */ +# define DIGIT 0x0010 /* [0-9] */ +# define SIGN 0x0020 /* +- */ +# define FLOATC 0x0040 /* . e E */ +# define ENDOFFILE 0x0080 /* end of file */ +# define COMMENT 0x0100 /* ; */ +# define IGNORE 0x0200 /* \0 - ' ' */ +# define BACKSLASH 0x0400 /* \ */ +# define STRINGC 0x0800 /* " */ +# define POUND 0x1000 /* # */ + +# define NOTNAME (STRINGC|COMMENT|ENDOFFILE|WHITE|SPECIAL) +# define INTEGER (DIGIT|SIGN) +# define NUMBER (INTEGER|FLOATC) + +#endif /* _AO_SCHEME_READ_H_ */ diff --git a/src/lisp/ao_lisp_rep.c b/src/scheme/ao_scheme_rep.c index 3be95d44..5b94d940 100644 --- a/src/lisp/ao_lisp_rep.c +++ b/src/scheme/ao_scheme_rep.c @@ -12,21 +12,25 @@ * General Public License for more details. */ -#include "ao_lisp.h" +#include "ao_scheme.h" ao_poly -ao_lisp_read_eval_print(void) +ao_scheme_read_eval_print(void) { - ao_poly in, out = AO_LISP_NIL; + ao_poly in, out = AO_SCHEME_NIL; + + ao_scheme_exception = 0; for(;;) { - in = ao_lisp_read(); - if (in == _ao_lisp_atom_eof || in == AO_LISP_NIL) + in = ao_scheme_read(); + if (in == _ao_scheme_atom_eof) break; - out = ao_lisp_eval(in); - if (ao_lisp_exception) { - ao_lisp_exception = 0; + out = ao_scheme_eval(in); + if (ao_scheme_exception) { + if (ao_scheme_exception & AO_SCHEME_EXIT) + break; + ao_scheme_exception = 0; } else { - ao_lisp_poly_print(out); + ao_scheme_poly_write(out); putchar ('\n'); } } diff --git a/src/scheme/ao_scheme_save.c b/src/scheme/ao_scheme_save.c new file mode 100644 index 00000000..af9345b8 --- /dev/null +++ b/src/scheme/ao_scheme_save.c @@ -0,0 +1,77 @@ +/* + * Copyright © 2016 Keith Packard <keithp@keithp.com> + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation, either version 2 of the License, or + * (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, but + * WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + * General Public License for more details. + */ + +#include "ao_scheme.h" + +ao_poly +ao_scheme_do_save(struct ao_scheme_cons *cons) +{ + if (!ao_scheme_check_argc(_ao_scheme_atom_save, cons, 0, 0)) + return AO_SCHEME_NIL; + +#ifdef AO_SCHEME_SAVE + struct ao_scheme_os_save *os = (struct ao_scheme_os_save *) (void *) &ao_scheme_pool[AO_SCHEME_POOL]; + + ao_scheme_collect(AO_SCHEME_COLLECT_FULL); + os->atoms = ao_scheme_atom_poly(ao_scheme_atoms); + os->globals = ao_scheme_frame_poly(ao_scheme_frame_global); + os->const_checksum = ao_scheme_const_checksum; + os->const_checksum_inv = (uint16_t) ~ao_scheme_const_checksum; + + if (ao_scheme_os_save()) + return _ao_scheme_bool_true; +#endif + return _ao_scheme_bool_false; +} + +ao_poly +ao_scheme_do_restore(struct ao_scheme_cons *cons) +{ + if (!ao_scheme_check_argc(_ao_scheme_atom_save, cons, 0, 0)) + return AO_SCHEME_NIL; + +#ifdef AO_SCHEME_SAVE + struct ao_scheme_os_save save; + struct ao_scheme_os_save *os = (struct ao_scheme_os_save *) (void *) &ao_scheme_pool[AO_SCHEME_POOL]; + + if (!ao_scheme_os_restore_save(&save, AO_SCHEME_POOL)) + return ao_scheme_error(AO_SCHEME_INVALID, "header restore failed"); + + if (save.const_checksum != ao_scheme_const_checksum || + save.const_checksum_inv != (uint16_t) ~ao_scheme_const_checksum) + { + return ao_scheme_error(AO_SCHEME_INVALID, "image is corrupted or stale"); + } + + if (ao_scheme_os_restore()) { + + ao_scheme_atoms = ao_scheme_poly_atom(os->atoms); + ao_scheme_frame_global = ao_scheme_poly_frame(os->globals); + + /* Clear the eval global variabls */ + ao_scheme_eval_clear_globals(); + + /* Reset the allocator */ + ao_scheme_top = AO_SCHEME_POOL; + ao_scheme_collect(AO_SCHEME_COLLECT_FULL); + + /* Re-create the evaluator stack */ + if (!ao_scheme_eval_restart()) + return _ao_scheme_bool_false; + + return _ao_scheme_bool_true; + } +#endif + return _ao_scheme_bool_false; +} diff --git a/src/scheme/ao_scheme_stack.c b/src/scheme/ao_scheme_stack.c new file mode 100644 index 00000000..d19dd6d6 --- /dev/null +++ b/src/scheme/ao_scheme_stack.c @@ -0,0 +1,280 @@ +/* + * Copyright © 2016 Keith Packard <keithp@keithp.com> + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation, either version 2 of the License, or + * (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, but + * WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + * General Public License for more details. + */ + +#include "ao_scheme.h" + +const struct ao_scheme_type ao_scheme_stack_type; + +static int +stack_size(void *addr) +{ + (void) addr; + return sizeof (struct ao_scheme_stack); +} + +static void +stack_mark(void *addr) +{ + struct ao_scheme_stack *stack = addr; + for (;;) { + ao_scheme_poly_mark(stack->sexprs, 0); + ao_scheme_poly_mark(stack->values, 0); + /* no need to mark values_tail */ + ao_scheme_poly_mark(stack->frame, 0); + ao_scheme_poly_mark(stack->list, 0); + stack = ao_scheme_poly_stack(stack->prev); + if (ao_scheme_mark_memory(&ao_scheme_stack_type, stack)) + break; + } +} + +static void +stack_move(void *addr) +{ + struct ao_scheme_stack *stack = addr; + + while (stack) { + struct ao_scheme_stack *prev; + int ret; + (void) ao_scheme_poly_move(&stack->sexprs, 0); + (void) ao_scheme_poly_move(&stack->values, 0); + (void) ao_scheme_poly_move(&stack->values_tail, 0); + (void) ao_scheme_poly_move(&stack->frame, 0); + (void) ao_scheme_poly_move(&stack->list, 0); + prev = ao_scheme_poly_stack(stack->prev); + if (!prev) + break; + ret = ao_scheme_move_memory(&ao_scheme_stack_type, (void **) &prev); + if (prev != ao_scheme_poly_stack(stack->prev)) + stack->prev = ao_scheme_stack_poly(prev); + if (ret) + break; + stack = prev; + } +} + +const struct ao_scheme_type ao_scheme_stack_type = { + .size = stack_size, + .mark = stack_mark, + .move = stack_move, + .name = "stack" +}; + +struct ao_scheme_stack *ao_scheme_stack_free_list; + +void +ao_scheme_stack_reset(struct ao_scheme_stack *stack) +{ + stack->state = eval_sexpr; + stack->sexprs = AO_SCHEME_NIL; + stack->values = AO_SCHEME_NIL; + stack->values_tail = AO_SCHEME_NIL; +} + +static struct ao_scheme_stack * +ao_scheme_stack_new(void) +{ + struct ao_scheme_stack *stack; + + if (ao_scheme_stack_free_list) { + stack = ao_scheme_stack_free_list; + ao_scheme_stack_free_list = ao_scheme_poly_stack(stack->prev); + } else { + stack = ao_scheme_alloc(sizeof (struct ao_scheme_stack)); + if (!stack) + return 0; + stack->type = AO_SCHEME_STACK; + } + ao_scheme_stack_reset(stack); + return stack; +} + +int +ao_scheme_stack_push(void) +{ + struct ao_scheme_stack *stack; + + stack = ao_scheme_stack_new(); + + if (!stack) + return 0; + + stack->prev = ao_scheme_stack_poly(ao_scheme_stack); + stack->frame = ao_scheme_frame_poly(ao_scheme_frame_current); + stack->list = AO_SCHEME_NIL; + + ao_scheme_stack = stack; + + DBGI("stack push\n"); + DBG_FRAMES(); + DBG_IN(); + return 1; +} + +void +ao_scheme_stack_pop(void) +{ + ao_poly prev; + struct ao_scheme_frame *prev_frame; + + if (!ao_scheme_stack) + return; + prev = ao_scheme_stack->prev; + if (!ao_scheme_stack_marked(ao_scheme_stack)) { + ao_scheme_stack->prev = ao_scheme_stack_poly(ao_scheme_stack_free_list); + ao_scheme_stack_free_list = ao_scheme_stack; + } + + ao_scheme_stack = ao_scheme_poly_stack(prev); + prev_frame = ao_scheme_frame_current; + if (ao_scheme_stack) + ao_scheme_frame_current = ao_scheme_poly_frame(ao_scheme_stack->frame); + else + ao_scheme_frame_current = NULL; + if (ao_scheme_frame_current != prev_frame) + ao_scheme_frame_free(prev_frame); + DBG_OUT(); + DBGI("stack pop\n"); + DBG_FRAMES(); +} + +void +ao_scheme_stack_clear(void) +{ + ao_scheme_stack = NULL; + ao_scheme_frame_current = NULL; + ao_scheme_v = AO_SCHEME_NIL; +} + +void +ao_scheme_stack_write(ao_poly poly) +{ + struct ao_scheme_stack *s = ao_scheme_poly_stack(poly); + + while (s) { + if (s->type & AO_SCHEME_STACK_PRINT) { + printf("[recurse...]"); + return; + } + s->type |= AO_SCHEME_STACK_PRINT; + printf("\t[\n"); + printf("\t\texpr: "); ao_scheme_poly_write(s->list); printf("\n"); + printf("\t\tstate: %s\n", ao_scheme_state_names[s->state]); + ao_scheme_error_poly ("values: ", s->values, s->values_tail); + ao_scheme_error_poly ("sexprs: ", s->sexprs, AO_SCHEME_NIL); + ao_scheme_error_frame(2, "frame: ", ao_scheme_poly_frame(s->frame)); + printf("\t]\n"); + s->type &= ~AO_SCHEME_STACK_PRINT; + s = ao_scheme_poly_stack(s->prev); + } +} + +/* + * Copy a stack, being careful to keep everybody referenced + */ +static struct ao_scheme_stack * +ao_scheme_stack_copy(struct ao_scheme_stack *old) +{ + struct ao_scheme_stack *new = NULL; + struct ao_scheme_stack *n, *prev = NULL; + + while (old) { + ao_scheme_stack_stash(0, old); + ao_scheme_stack_stash(1, new); + ao_scheme_stack_stash(2, prev); + n = ao_scheme_stack_new(); + prev = ao_scheme_stack_fetch(2); + new = ao_scheme_stack_fetch(1); + old = ao_scheme_stack_fetch(0); + if (!n) + return NULL; + + ao_scheme_stack_mark(old); + ao_scheme_frame_mark(ao_scheme_poly_frame(old->frame)); + *n = *old; + + if (prev) + prev->prev = ao_scheme_stack_poly(n); + else + new = n; + prev = n; + + old = ao_scheme_poly_stack(old->prev); + } + return new; +} + +/* + * Evaluate a continuation invocation + */ +ao_poly +ao_scheme_stack_eval(void) +{ + struct ao_scheme_stack *new = ao_scheme_stack_copy(ao_scheme_poly_stack(ao_scheme_v)); + if (!new) + return AO_SCHEME_NIL; + + struct ao_scheme_cons *cons = ao_scheme_poly_cons(ao_scheme_stack->values); + + if (!cons || !cons->cdr) + return ao_scheme_error(AO_SCHEME_INVALID, "continuation requires a value"); + + new->state = eval_val; + + ao_scheme_stack = new; + ao_scheme_frame_current = ao_scheme_poly_frame(ao_scheme_stack->frame); + + return ao_scheme_poly_cons(cons->cdr)->car; +} + +/* + * Call with current continuation. This calls a lambda, passing + * it a single argument which is the current continuation + */ +ao_poly +ao_scheme_do_call_cc(struct ao_scheme_cons *cons) +{ + struct ao_scheme_stack *new; + ao_poly v; + + /* Make sure the single parameter is a lambda */ + if (!ao_scheme_check_argc(_ao_scheme_atom_call2fcc, cons, 1, 1)) + return AO_SCHEME_NIL; + if (!ao_scheme_check_argt(_ao_scheme_atom_call2fcc, cons, 0, AO_SCHEME_LAMBDA, 0)) + return AO_SCHEME_NIL; + + /* go get the lambda */ + ao_scheme_v = ao_scheme_arg(cons, 0); + + /* Note that the whole call chain now has + * a reference to it which may escape + */ + new = ao_scheme_stack_copy(ao_scheme_stack); + if (!new) + return AO_SCHEME_NIL; + + /* re-fetch cons after the allocation */ + cons = ao_scheme_poly_cons(ao_scheme_poly_cons(ao_scheme_stack->values)->cdr); + + /* Reset the arg list to the current stack, + * and call the lambda + */ + + cons->car = ao_scheme_stack_poly(new); + cons->cdr = AO_SCHEME_NIL; + v = ao_scheme_lambda_eval(); + ao_scheme_stack->sexprs = v; + ao_scheme_stack->state = eval_begin; + return AO_SCHEME_NIL; +} diff --git a/src/lisp/ao_lisp_string.c b/src/scheme/ao_scheme_string.c index cd7b27a9..e25306cb 100644 --- a/src/lisp/ao_lisp_string.c +++ b/src/scheme/ao_scheme_string.c @@ -15,7 +15,7 @@ * 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA. */ -#include "ao_lisp.h" +#include "ao_scheme.h" static void string_mark(void *addr) { @@ -34,7 +34,7 @@ static void string_move(void *addr) (void) addr; } -const struct ao_lisp_type ao_lisp_string_type = { +const struct ao_scheme_type ao_scheme_string_type = { .mark = string_mark, .size = string_size, .move = string_move, @@ -42,13 +42,13 @@ const struct ao_lisp_type ao_lisp_string_type = { }; char * -ao_lisp_string_copy(char *a) +ao_scheme_string_copy(char *a) { int alen = strlen(a); - ao_lisp_string_stash(0, a); - char *r = ao_lisp_alloc(alen + 1); - a = ao_lisp_string_fetch(0); + ao_scheme_string_stash(0, a); + char *r = ao_scheme_alloc(alen + 1); + a = ao_scheme_string_fetch(0); if (!r) return NULL; strcpy(r, a); @@ -56,16 +56,16 @@ ao_lisp_string_copy(char *a) } char * -ao_lisp_string_cat(char *a, char *b) +ao_scheme_string_cat(char *a, char *b) { int alen = strlen(a); int blen = strlen(b); - ao_lisp_string_stash(0, a); - ao_lisp_string_stash(1, b); - char *r = ao_lisp_alloc(alen + blen + 1); - a = ao_lisp_string_fetch(0); - b = ao_lisp_string_fetch(1); + ao_scheme_string_stash(0, a); + ao_scheme_string_stash(1, b); + char *r = ao_scheme_alloc(alen + blen + 1); + a = ao_scheme_string_fetch(0); + b = ao_scheme_string_fetch(1); if (!r) return NULL; strcpy(r, a); @@ -74,57 +74,57 @@ ao_lisp_string_cat(char *a, char *b) } ao_poly -ao_lisp_string_pack(struct ao_lisp_cons *cons) +ao_scheme_string_pack(struct ao_scheme_cons *cons) { - int len = ao_lisp_cons_length(cons); - ao_lisp_cons_stash(0, cons); - char *r = ao_lisp_alloc(len + 1); - cons = ao_lisp_cons_fetch(0); + int len = ao_scheme_cons_length(cons); + ao_scheme_cons_stash(0, cons); + char *r = ao_scheme_alloc(len + 1); + cons = ao_scheme_cons_fetch(0); char *s = r; while (cons) { - if (ao_lisp_poly_type(cons->car) != AO_LISP_INT) - return ao_lisp_error(AO_LISP_INVALID, "non-int passed to pack"); - *s++ = ao_lisp_poly_int(cons->car); - cons = ao_lisp_poly_cons(cons->cdr); + if (!ao_scheme_integer_typep(ao_scheme_poly_type(cons->car))) + return ao_scheme_error(AO_SCHEME_INVALID, "non-int passed to pack"); + *s++ = ao_scheme_poly_integer(cons->car); + cons = ao_scheme_poly_cons(cons->cdr); } *s++ = 0; - return ao_lisp_string_poly(r); + return ao_scheme_string_poly(r); } ao_poly -ao_lisp_string_unpack(char *a) +ao_scheme_string_unpack(char *a) { - struct ao_lisp_cons *cons = NULL, *tail = NULL; + struct ao_scheme_cons *cons = NULL, *tail = NULL; int c; int i; for (i = 0; (c = a[i]); i++) { - ao_lisp_cons_stash(0, cons); - ao_lisp_cons_stash(1, tail); - ao_lisp_string_stash(0, a); - struct ao_lisp_cons *n = ao_lisp_cons_cons(ao_lisp_int_poly(c), NULL); - a = ao_lisp_string_fetch(0); - cons = ao_lisp_cons_fetch(0); - tail = ao_lisp_cons_fetch(1); + ao_scheme_cons_stash(0, cons); + ao_scheme_cons_stash(1, tail); + ao_scheme_string_stash(0, a); + struct ao_scheme_cons *n = ao_scheme_cons_cons(ao_scheme_int_poly(c), AO_SCHEME_NIL); + a = ao_scheme_string_fetch(0); + cons = ao_scheme_cons_fetch(0); + tail = ao_scheme_cons_fetch(1); if (!n) { cons = NULL; break; } if (tail) - tail->cdr = ao_lisp_cons_poly(n); + tail->cdr = ao_scheme_cons_poly(n); else cons = n; tail = n; } - return ao_lisp_cons_poly(cons); + return ao_scheme_cons_poly(cons); } void -ao_lisp_string_print(ao_poly p) +ao_scheme_string_write(ao_poly p) { - char *s = ao_lisp_poly_string(p); + char *s = ao_scheme_poly_string(p); char c; putchar('"'); @@ -140,7 +140,10 @@ ao_lisp_string_print(ao_poly p) printf ("\\t"); break; default: - putchar(c); + if (c < ' ') + printf("\\%03o", c); + else + putchar(c); break; } } @@ -148,9 +151,9 @@ ao_lisp_string_print(ao_poly p) } void -ao_lisp_string_patom(ao_poly p) +ao_scheme_string_display(ao_poly p) { - char *s = ao_lisp_poly_string(p); + char *s = ao_scheme_poly_string(p); char c; while ((c = *s++)) diff --git a/src/scheme/make-const/.gitignore b/src/scheme/make-const/.gitignore new file mode 100644 index 00000000..bcd57242 --- /dev/null +++ b/src/scheme/make-const/.gitignore @@ -0,0 +1 @@ +ao_scheme_make_const diff --git a/src/scheme/make-const/Makefile b/src/scheme/make-const/Makefile new file mode 100644 index 00000000..caf7acbe --- /dev/null +++ b/src/scheme/make-const/Makefile @@ -0,0 +1,26 @@ +include ../Makefile-inc + +vpath %.o . +vpath %.c .. +vpath %.h .. + +SRCS=$(SCHEME_SRCS) ao_scheme_make_const.c +HDRS=$(SCHEME_HDRS) ao_scheme_os.h + +OBJS=$(SRCS:.c=.o) + +CC=cc +CFLAGS=-DAO_SCHEME_MAKE_CONST -O0 -g -I. -Wall -Wextra + +.c.o: + $(CC) -c $(CFLAGS) $< -o $@ + +all: ao_scheme_make_const + +ao_scheme_make_const: $(OBJS) + $(CC) $(CFLAGS) -o $@ $^ -lm + +clean: + rm -f $(OBJS) ao_scheme_make_const + +$(OBJS): $(SCHEME_HDRS) diff --git a/src/test/ao_lisp_os.h b/src/scheme/make-const/ao_scheme_os.h index 9ff2e1fe..f06bbbb1 100644 --- a/src/test/ao_lisp_os.h +++ b/src/scheme/make-const/ao_scheme_os.h @@ -15,45 +15,49 @@ * 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA. */ -#ifndef _AO_LISP_OS_H_ -#define _AO_LISP_OS_H_ +#ifndef _AO_SCHEME_OS_H_ +#define _AO_SCHEME_OS_H_ #include <stdio.h> #include <stdlib.h> #include <time.h> -#define AO_LISP_POOL_TOTAL 3072 -#define AO_LISP_SAVE 1 -#define DBG_MEM_STATS 1 - -extern int ao_lisp_getc(void); +extern int ao_scheme_getc(void); static inline void -ao_lisp_os_flush() { +ao_scheme_os_flush(void) { fflush(stdout); } static inline void -ao_lisp_abort(void) +ao_scheme_abort(void) { abort(); } static inline void -ao_lisp_os_led(int led) +ao_scheme_os_led(int led) { printf("leds set to 0x%x\n", led); } +#define AO_SCHEME_JIFFIES_PER_SECOND 100 + static inline void -ao_lisp_os_delay(int delay) +ao_scheme_os_delay(int jiffies) { - if (!delay) - return; struct timespec ts = { - .tv_sec = delay / 1000, - .tv_nsec = (delay % 1000) * 1000000, + .tv_sec = jiffies / AO_SCHEME_JIFFIES_PER_SECOND, + .tv_nsec = (jiffies % AO_SCHEME_JIFFIES_PER_SECOND) * (1000000000L / AO_SCHEME_JIFFIES_PER_SECOND) }; nanosleep(&ts, NULL); } + +static inline int +ao_scheme_os_jiffy(void) +{ + struct timespec tp; + clock_gettime(CLOCK_MONOTONIC, &tp); + return tp.tv_sec * AO_SCHEME_JIFFIES_PER_SECOND + (tp.tv_nsec / (1000000000L / AO_SCHEME_JIFFIES_PER_SECOND)); +} #endif diff --git a/src/scheme/test/.gitignore b/src/scheme/test/.gitignore new file mode 100644 index 00000000..3cdae594 --- /dev/null +++ b/src/scheme/test/.gitignore @@ -0,0 +1 @@ +ao_scheme_test diff --git a/src/scheme/test/Makefile b/src/scheme/test/Makefile new file mode 100644 index 00000000..c48add1f --- /dev/null +++ b/src/scheme/test/Makefile @@ -0,0 +1,22 @@ +include ../Makefile-inc + +vpath %.o . +vpath %.c .. +vpath %.h .. + +SRCS=$(SCHEME_SRCS) ao_scheme_test.c + +OBJS=$(SRCS:.c=.o) + +CFLAGS=-O2 -g -Wall -Wextra -I. -I.. + +ao_scheme_test: $(OBJS) + cc $(CFLAGS) -o $@ $(OBJS) -lm + +$(OBJS): $(SCHEME_HDRS) + +clean:: + rm -f $(OBJS) ao_scheme_test + +install: ao_scheme_test + cp ao_scheme_test $$HOME/bin/ao-scheme diff --git a/src/lisp/ao_lisp_os.h b/src/scheme/test/ao_scheme_os.h index 5fa3686b..ea363fb3 100644 --- a/src/lisp/ao_lisp_os.h +++ b/src/scheme/test/ao_scheme_os.h @@ -15,39 +15,54 @@ * 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA. */ -#ifndef _AO_LISP_OS_H_ -#define _AO_LISP_OS_H_ +#ifndef _AO_SCHEME_OS_H_ +#define _AO_SCHEME_OS_H_ #include <stdio.h> #include <stdlib.h> #include <time.h> -extern int ao_lisp_getc(void); +#define AO_SCHEME_POOL_TOTAL 32768 +#define AO_SCHEME_SAVE 1 +#define DBG_MEM_STATS 1 + +extern int ao_scheme_getc(void); static inline void -ao_lisp_os_flush(void) { +ao_scheme_os_flush() { fflush(stdout); } static inline void -ao_lisp_abort(void) +ao_scheme_abort(void) { abort(); } static inline void -ao_lisp_os_led(int led) +ao_scheme_os_led(int led) { printf("leds set to 0x%x\n", led); } +#define AO_SCHEME_JIFFIES_PER_SECOND 100 + static inline void -ao_lisp_os_delay(int delay) +ao_scheme_os_delay(int jiffies) { struct timespec ts = { - .tv_sec = delay / 1000, - .tv_nsec = (delay % 1000) * 1000000, + .tv_sec = jiffies / AO_SCHEME_JIFFIES_PER_SECOND, + .tv_nsec = (jiffies % AO_SCHEME_JIFFIES_PER_SECOND) * (1000000000L / AO_SCHEME_JIFFIES_PER_SECOND) }; nanosleep(&ts, NULL); } + +static inline int +ao_scheme_os_jiffy(void) +{ + struct timespec tp; + clock_gettime(CLOCK_MONOTONIC, &tp); + return tp.tv_sec * AO_SCHEME_JIFFIES_PER_SECOND + (tp.tv_nsec / (1000000000L / AO_SCHEME_JIFFIES_PER_SECOND)); +} + #endif diff --git a/src/scheme/test/ao_scheme_test.c b/src/scheme/test/ao_scheme_test.c new file mode 100644 index 00000000..0c77d8d5 --- /dev/null +++ b/src/scheme/test/ao_scheme_test.c @@ -0,0 +1,139 @@ +/* + * Copyright © 2016 Keith Packard <keithp@keithp.com> + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation, either version 2 of the License, or + * (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, but + * WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + * General Public License for more details. + */ + +#include "ao_scheme.h" +#include <stdio.h> + +static FILE *ao_scheme_file; +static int newline = 1; + +static char save_file[] = "scheme.image"; + +int +ao_scheme_os_save(void) +{ + FILE *save = fopen(save_file, "w"); + + if (!save) { + perror(save_file); + return 0; + } + fwrite(ao_scheme_pool, 1, AO_SCHEME_POOL_TOTAL, save); + fclose(save); + return 1; +} + +int +ao_scheme_os_restore_save(struct ao_scheme_os_save *save, int offset) +{ + FILE *restore = fopen(save_file, "r"); + size_t ret; + + if (!restore) { + perror(save_file); + return 0; + } + fseek(restore, offset, SEEK_SET); + ret = fread(save, sizeof (struct ao_scheme_os_save), 1, restore); + fclose(restore); + if (ret != 1) + return 0; + return 1; +} + +int +ao_scheme_os_restore(void) +{ + FILE *restore = fopen(save_file, "r"); + size_t ret; + + if (!restore) { + perror(save_file); + return 0; + } + ret = fread(ao_scheme_pool, 1, AO_SCHEME_POOL_TOTAL, restore); + fclose(restore); + if (ret != AO_SCHEME_POOL_TOTAL) + return 0; + return 1; +} + +int +ao_scheme_getc(void) +{ + int c; + + if (ao_scheme_file) + return getc(ao_scheme_file); + + if (newline) { + if (ao_scheme_read_list) + printf("+ "); + else + printf("> "); + newline = 0; + } + c = getchar(); + if (c == '\n') + newline = 1; + return c; +} + +int +main (int argc, char **argv) +{ + (void) argc; + + while (*++argv) { + ao_scheme_file = fopen(*argv, "r"); + if (!ao_scheme_file) { + perror(*argv); + exit(1); + } + ao_scheme_read_eval_print(); + fclose(ao_scheme_file); + ao_scheme_file = NULL; + } + ao_scheme_read_eval_print(); + + printf ("collects: full: %lu incremental %lu\n", + ao_scheme_collects[AO_SCHEME_COLLECT_FULL], + ao_scheme_collects[AO_SCHEME_COLLECT_INCREMENTAL]); + + printf ("freed: full %lu incremental %lu\n", + ao_scheme_freed[AO_SCHEME_COLLECT_FULL], + ao_scheme_freed[AO_SCHEME_COLLECT_INCREMENTAL]); + + printf("loops: full %lu incremental %lu\n", + ao_scheme_loops[AO_SCHEME_COLLECT_FULL], + ao_scheme_loops[AO_SCHEME_COLLECT_INCREMENTAL]); + + printf("loops per collect: full %f incremental %f\n", + (double) ao_scheme_loops[AO_SCHEME_COLLECT_FULL] / + (double) ao_scheme_collects[AO_SCHEME_COLLECT_FULL], + (double) ao_scheme_loops[AO_SCHEME_COLLECT_INCREMENTAL] / + (double) ao_scheme_collects[AO_SCHEME_COLLECT_INCREMENTAL]); + + printf("freed per collect: full %f incremental %f\n", + (double) ao_scheme_freed[AO_SCHEME_COLLECT_FULL] / + (double) ao_scheme_collects[AO_SCHEME_COLLECT_FULL], + (double) ao_scheme_freed[AO_SCHEME_COLLECT_INCREMENTAL] / + (double) ao_scheme_collects[AO_SCHEME_COLLECT_INCREMENTAL]); + + printf("freed per loop: full %f incremental %f\n", + (double) ao_scheme_freed[AO_SCHEME_COLLECT_FULL] / + (double) ao_scheme_loops[AO_SCHEME_COLLECT_FULL], + (double) ao_scheme_freed[AO_SCHEME_COLLECT_INCREMENTAL] / + (double) ao_scheme_loops[AO_SCHEME_COLLECT_INCREMENTAL]); +} diff --git a/src/scheme/test/hanoi.scheme b/src/scheme/test/hanoi.scheme new file mode 100644 index 00000000..c4ae7378 --- /dev/null +++ b/src/scheme/test/hanoi.scheme @@ -0,0 +1,174 @@ +; +; Towers of Hanoi +; +; Copyright © 2016 Keith Packard <keithp@keithp.com> +; +; This program is free software; you can redistribute it and/or modify +; it under the terms of the GNU General Public License as published by +; the Free Software Foundation, either version 2 of the License, or +; (at your option) any later version. +; +; This program is distributed in the hope that it will be useful, but +; WITHOUT ANY WARRANTY; without even the implied warranty of +; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +; General Public License for more details. +; + + ; ANSI control sequences + +(define (move-to col row) + (for-each display (list "\033[" row ";" col "H")) + ) + +(define (clear) + (display "\033[2J") + ) + +(define (display-string x y str) + (move-to x y) + (display str) + ) + +(define (make-piece num max) + ; A piece for position 'num' + ; is num + 1 + num stars + ; centered in a field of max * + ; 2 + 1 characters with spaces + ; on either side. This way, + ; every piece is the same + ; number of characters + + (define (chars n c) + (if (zero? n) "" + (+ c (chars (- n 1) c)) + ) + ) + (+ (chars (- max num 1) " ") + (chars (+ (* num 2) 1) "*") + (chars (- max num 1) " ") + ) + ) + +(define (make-pieces max) + ; Make a list of numbers from 0 to max-1 + (define (nums cur max) + (if (= cur max) () + (cons cur (nums (+ cur 1) max)) + ) + ) + ; Create a list of pieces + + (map (lambda (x) (make-piece x max)) (nums 0 max)) + ) + + ; Here's all of the towers of pieces + ; This is generated when the program is run + +(define towers ()) + + ; position of the bottom of + ; the stacks set at runtime +(define bottom-y 0) +(define left-x 0) + +(define move-delay 25) + + ; Display one tower, clearing any + ; space above it + +(define (display-tower x y clear tower) + (cond ((= 0 clear) + (cond ((not (null? tower)) + (display-string x y (car tower)) + (display-tower x (+ y 1) 0 (cdr tower)) + ) + ) + ) + (else + (display-string x y " ") + (display-tower x (+ y 1) (- clear 1) tower) + ) + ) + ) + + ; Position of the top of the tower on the screen + ; Shorter towers start further down the screen + +(define (tower-pos tower) + (- bottom-y (length tower)) + ) + + ; Display all of the towers, spaced 20 columns apart + +(define (display-towers x towers) + (cond ((not (null? towers)) + (display-tower x 0 (tower-pos (car towers)) (car towers)) + (display-towers (+ x 20) (cdr towers))) + ) + ) + + ; Display all of the towers, then move the cursor + ; out of the way and flush the output + +(define (display-hanoi) + (display-towers left-x towers) + (move-to 1 23) + (flush-output) + (delay move-delay) + ) + + ; Reset towers to the starting state, with + ; all of the pieces in the first tower and the + ; other two empty + +(define (reset-towers len) + (set! towers (list (make-pieces len) () ())) + (set! bottom-y (+ len 3)) + ) + + ; Move a piece from the top of one tower + ; to the top of another + +(define (move-piece from to) + + ; references to the cons holding the two towers + + (define from-tower (list-tail towers from)) + (define to-tower (list-tail towers to)) + + ; stick the car of from-tower onto to-tower + + (set-car! to-tower (cons (caar from-tower) (car to-tower))) + + ; remove the car of from-tower + + (set-car! from-tower (cdar from-tower)) + ) + + ; The implementation of the game + +(define (_hanoi n from to use) + (cond ((= 1 n) + (move-piece from to) + (display-hanoi) + ) + (else + (_hanoi (- n 1) from use to) + (_hanoi 1 from to use) + (_hanoi (- n 1) use to from) + ) + ) + ) + + ; A pretty interface which + ; resets the state of the game, + ; clears the screen and runs + ; the program + +(define (hanoi len) + (reset-towers len) + (clear) + (display-hanoi) + (_hanoi len 0 1 2) + #t + ) diff --git a/src/stm-scheme-newlib/.gitignore b/src/stm-scheme-newlib/.gitignore new file mode 100644 index 00000000..60d664f4 --- /dev/null +++ b/src/stm-scheme-newlib/.gitignore @@ -0,0 +1,4 @@ +*.elf +*.map +*.syms +ao_product.h diff --git a/src/stm-scheme-newlib/Makefile b/src/stm-scheme-newlib/Makefile new file mode 100644 index 00000000..a4c249a3 --- /dev/null +++ b/src/stm-scheme-newlib/Makefile @@ -0,0 +1,84 @@ +# +# AltOS build +# +# + +include ../stm/Makefile.defs +include ../scheme/Makefile-inc + +NEWLIB_FULL=-lm -lc -lgcc + +LIBS=$(NEWLIB_FULL) + +INC = \ + ao.h \ + ao_arch.h \ + ao_arch_funcs.h \ + ao_boot.h \ + ao_pins.h \ + ao_product.h \ + ao_task.h \ + $(SCHEME_HDRS) + +# +# Common AltOS sources +# +ALTOS_SRC = \ + ao_interrupt.c \ + ao_boot_chain.c \ + ao_product.c \ + ao_romconfig.c \ + ao_cmd.c \ + ao_task.c \ + ao_led.c \ + ao_stdio_newlib.c \ + ao_panic.c \ + ao_timer.c \ + ao_mutex.c \ + ao_dma_stm.c \ + ao_usb_stm.c \ + ao_exti_stm.c \ + $(SCHEME_SRCS) + +PRODUCT=StmScheme-v0.0 +PRODUCT_DEF=-DSTM_SCHEME +IDPRODUCT=0x000a + +CFLAGS = $(PRODUCT_DEF) $(STM_CFLAGS) -g -Os + +PROG=stm-scheme-$(VERSION) +ELF=$(PROG).elf +IHX=$(PROG).ihx +LIBSYMS=$(PROG).syms +MAP=$(PROG).map + +NEWLIB=/local/newlib-mini +MAPFILE=-Wl,-M=$(MAP) +LDFLAGS=-L../stm -L$(NEWLIB)/arm-none-eabi/lib/thumb/v7-m/ -Wl,-Taltos.ld $(MAPFILE) -nostartfiles +AO_CFLAGS=-I. -I../stm -I../kernel -I../drivers -I.. -I../scheme -isystem $(NEWLIB)/arm-none-eabi/include -DNEWLIB + +SRC=$(ALTOS_SRC) ao_demo.c +OBJ=$(SRC:.c=.o) + +all: $(ELF) $(IHX) $(LIBSYMS) + +$(ELF): Makefile $(OBJ) + $(call quiet,CC) $(LDFLAGS) $(CFLAGS) -o $@ $(OBJ) $(LIBS) + +$(LIBSYMS): $(ELF) + grep '^ ' $(MAP) | grep -v 'size before relaxing' > $@ + +ao_product.h: ao-make-product.5c ../Version + $(call quiet,NICKLE,$<) $< -m altusmetrum.org -i $(IDPRODUCT) -p $(PRODUCT) -v $(VERSION) > $@ + +$(OBJ): $(INC) + +distclean: clean + +clean: + rm -f *.o *.elf *.ihx *.map *.syms + rm -f ao_product.h + +install: + +uninstall: diff --git a/src/stm-scheme-newlib/ao_demo.c b/src/stm-scheme-newlib/ao_demo.c new file mode 100644 index 00000000..13a31288 --- /dev/null +++ b/src/stm-scheme-newlib/ao_demo.c @@ -0,0 +1,51 @@ +/* + * Copyright © 2011 Keith Packard <keithp@keithp.com> + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation; either version 2 of the License, or + * (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, but + * WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + * General Public License for more details. + * + * 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. + */ + +#include "ao.h" +#include <ao_exti.h> +#include <ao_boot.h> +#include <ao_scheme.h> + +static void scheme_cmd() { + ao_scheme_read_eval_print(); +} + + +__code struct ao_cmds ao_demo_cmds[] = { + { scheme_cmd, "l\0Run scheme interpreter" }, + { 0, NULL } +}; + +int +main(void) +{ + ao_clock_init(); + + ao_task_init(); + + ao_led_init(LEDS_AVAILABLE); + ao_timer_init(); + ao_dma_init(); + ao_cmd_init(); + ao_usb_init(); + + ao_cmd_register(&ao_demo_cmds[0]); + + ao_start_scheduler(); + return 0; +} diff --git a/src/stm-scheme-newlib/ao_pins.h b/src/stm-scheme-newlib/ao_pins.h new file mode 100644 index 00000000..524490f7 --- /dev/null +++ b/src/stm-scheme-newlib/ao_pins.h @@ -0,0 +1,91 @@ +/* + * Copyright © 2012 Keith Packard <keithp@keithp.com> + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation; either version 2 of the License, or + * (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, but + * WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + * General Public License for more details. + * + * 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_ + +/* Bridge SB17 on the board and use the MCO from the other chip */ +#define AO_HSE 8000000 +#define AO_HSE_BYPASS 1 + +/* PLLVCO = 96MHz (so that USB will work) */ +#define AO_PLLMUL 12 +#define AO_RCC_CFGR_PLLMUL (STM_RCC_CFGR_PLLMUL_12) + +/* SYSCLK = 32MHz */ +#define AO_PLLDIV 3 +#define AO_RCC_CFGR_PLLDIV (STM_RCC_CFGR_PLLDIV_3) + +/* HCLK = 32MHZ (CPU clock) */ +#define AO_AHB_PRESCALER 1 +#define AO_RCC_CFGR_HPRE_DIV STM_RCC_CFGR_HPRE_DIV_1 + +/* Run APB1 at HCLK/1 */ +#define AO_APB1_PRESCALER 1 +#define AO_RCC_CFGR_PPRE1_DIV STM_RCC_CFGR_PPRE2_DIV_1 + +/* Run APB2 at HCLK/1 */ +#define AO_APB2_PRESCALER 1 +#define AO_RCC_CFGR_PPRE2_DIV STM_RCC_CFGR_PPRE2_DIV_1 + +#define HAS_SERIAL_1 0 +#define USE_SERIAL_1_STDIN 0 +#define SERIAL_1_PB6_PB7 1 +#define SERIAL_1_PA9_PA10 0 + +#define HAS_SERIAL_2 0 +#define USE_SERIAL_2_STDIN 0 +#define SERIAL_2_PA2_PA3 0 +#define SERIAL_2_PD5_PD6 1 + +#define HAS_SERIAL_3 0 +#define USE_SERIAL_3_STDIN 1 +#define SERIAL_3_PB10_PB11 0 +#define SERIAL_3_PC10_PC11 0 +#define SERIAL_3_PD8_PD9 1 + +#define HAS_SPI_1 0 +#define SPI_1_PB3_PB4_PB5 1 +#define SPI_1_OSPEEDR STM_OSPEEDR_10MHz + +#define HAS_SPI_2 0 + +#define HAS_USB 1 +#define HAS_BEEP 0 +#define PACKET_HAS_SLAVE 0 + +#define AO_BOOT_CHAIN 1 + +#define LOW_LEVEL_DEBUG 0 + +#define LED_PORT_ENABLE STM_RCC_AHBENR_GPIOBEN +#define LED_PORT (&stm_gpiob) +#define LED_PIN_GREEN 7 +#define LED_PIN_BLUE 6 +#define AO_LED_GREEN (1 << LED_PIN_GREEN) +#define AO_LED_BLUE (1 << LED_PIN_BLUE) +#define AO_LED_PANIC AO_LED_BLUE + +#define LEDS_AVAILABLE (AO_LED_BLUE | AO_LED_GREEN) + +#define HAS_ADC 0 + +#define AO_TICK_TYPE uint32_t +#define AO_TICK_SIGNED int32_t + +#endif /* _AO_PINS_H_ */ diff --git a/src/lambdakey-v1.0/ao_lisp_os.h b/src/stm-scheme-newlib/ao_scheme_os.h index 1993ac44..21b6001a 100644 --- a/src/lambdakey-v1.0/ao_lisp_os.h +++ b/src/stm-scheme-newlib/ao_scheme_os.h @@ -15,13 +15,21 @@ * 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA. */ -#ifndef _AO_LISP_OS_H_ -#define _AO_LISP_OS_H_ +#ifndef _AO_SCHEME_OS_H_ +#define _AO_SCHEME_OS_H_ #include "ao.h" +#define AO_SCHEME_POOL 10240 + +#ifndef __BYTE_ORDER +#define __LITTLE_ENDIAN 1234 +#define __BIG_ENDIAN 4321 +#define __BYTE_ORDER __LITTLE_ENDIAN +#endif + static inline int -ao_lisp_getc() { +ao_scheme_getc() { static uint8_t at_eol; int c; @@ -36,27 +44,35 @@ ao_lisp_getc() { } static inline void -ao_lisp_os_flush(void) +ao_scheme_os_flush(void) { flush(); } static inline void -ao_lisp_abort(void) +ao_scheme_abort(void) { ao_panic(1); } static inline void -ao_lisp_os_led(int led) +ao_scheme_os_led(int led) { ao_led_set(led); } +#define AO_SCHEME_JIFFIES_PER_SECOND AO_HERTZ + static inline void -ao_lisp_os_delay(int delay) +ao_scheme_os_delay(int delay) +{ + ao_delay(delay); +} + +static inline int +ao_scheme_os_jiffy(void) { - ao_delay(AO_MS_TO_TICKS(delay)); + return ao_tick_count; } #endif diff --git a/src/stm-scheme-newlib/ao_scheme_os_save.c b/src/stm-scheme-newlib/ao_scheme_os_save.c new file mode 100644 index 00000000..ce46f18e --- /dev/null +++ b/src/stm-scheme-newlib/ao_scheme_os_save.c @@ -0,0 +1,53 @@ +/* + * Copyright © 2016 Keith Packard <keithp@keithp.com> + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation, either version 2 of the License, or + * (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, but + * WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + * General Public License for more details. + */ + +#include <ao.h> +#include "ao_scheme.h" +#include <ao_flash.h> + +extern uint8_t __flash__[]; + +/* saved variables to rebuild the heap + + ao_scheme_atoms + ao_scheme_frame_global + */ + +int +ao_scheme_os_save(void) +{ + int i; + + for (i = 0; i < AO_SCHEME_POOL_TOTAL; i += 256) { + uint32_t *dst = (uint32_t *) (void *) &__flash__[i]; + uint32_t *src = (uint32_t *) (void *) &ao_scheme_pool[i]; + + ao_flash_page(dst, src); + } + return 1; +} + +int +ao_scheme_os_restore_save(struct ao_scheme_os_save *save, int offset) +{ + memcpy(save, &__flash__[offset], sizeof (struct ao_scheme_os_save)); + return 1; +} + +int +ao_scheme_os_restore(void) +{ + memcpy(ao_scheme_pool, __flash__, AO_SCHEME_POOL_TOTAL); + return 1; +} diff --git a/src/stm-scheme-newlib/flash-loader/Makefile b/src/stm-scheme-newlib/flash-loader/Makefile new file mode 100644 index 00000000..4c60f317 --- /dev/null +++ b/src/stm-scheme-newlib/flash-loader/Makefile @@ -0,0 +1,8 @@ +# +# AltOS flash loader build +# +# + +TOPDIR=../.. +HARDWARE=stm-scheme +include $(TOPDIR)/stm/Makefile-flash.defs diff --git a/src/stm-scheme-newlib/flash-loader/ao_pins.h b/src/stm-scheme-newlib/flash-loader/ao_pins.h new file mode 100644 index 00000000..eb5fcb8b --- /dev/null +++ b/src/stm-scheme-newlib/flash-loader/ao_pins.h @@ -0,0 +1,36 @@ +/* + * Copyright © 2013 Keith Packard <keithp@keithp.com> + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation; either version 2 of the License, or + * (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, but + * WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + * General Public License for more details. + * + * 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_ + +/* Bridge SB17 on the board and use the MCO from the other chip */ +#define AO_HSE 8000000 +#define AO_HSE_BYPASS 1 + +#include <ao_flash_stm_pins.h> + +/* Use the 'user switch' to force boot loader on power on */ + +#define AO_BOOT_PIN 1 +#define AO_BOOT_APPLICATION_GPIO stm_gpioa +#define AO_BOOT_APPLICATION_PIN 0 +#define AO_BOOT_APPLICATION_VALUE 0 +#define AO_BOOT_APPLICATION_MODE 0 + +#endif /* _AO_PINS_H_ */ diff --git a/src/stm/Makefile.defs b/src/stm/Makefile.defs index 66ed4be8..4d0d27c7 100644 --- a/src/stm/Makefile.defs +++ b/src/stm/Makefile.defs @@ -1,4 +1,4 @@ -vpath % ../stm:../product:../drivers:../kernel:../util:../kalman:../aes:../math:../draw:../lisp:.. +vpath % ../stm:../product:../drivers:../kernel:../util:../kalman:../aes:../math:../draw:../scheme:.. vpath make-altitude ../util vpath make-kalman ../util vpath kalman.5c ../kalman diff --git a/src/stm/ao_adc_stm.c b/src/stm/ao_adc_stm.c index 77f121dc..24912bb2 100644 --- a/src/stm/ao_adc_stm.c +++ b/src/stm/ao_adc_stm.c @@ -58,6 +58,9 @@ static void ao_adc_done(int index) #if HAS_MPU6000 ao_data_ring[ao_data_head].mpu6000 = ao_mpu6000_current; #endif +#if HAS_MPU9250 + ao_data_ring[ao_data_head].mpu9250 = ao_mpu9250_current; +#endif ao_data_ring[ao_data_head].tick = ao_tick_count; ao_data_head = ao_data_ring_next(ao_data_head); ao_wakeup((void *) &ao_data_head); @@ -377,7 +380,7 @@ ao_adc_init(void) #if AO_NUM_ADC > 18 #error "need to finish stm_adc.sqr settings" #endif - + /* Turn ADC on */ stm_adc.cr2 = AO_ADC_CR2_VAL; diff --git a/src/stm/ao_exti.h b/src/stm/ao_exti.h index 4f3e6132..8aa2bdca 100644 --- a/src/stm/ao_exti.h +++ b/src/stm/ao_exti.h @@ -21,6 +21,7 @@ #define AO_EXTI_MODE_RISING 1 #define AO_EXTI_MODE_FALLING 2 +#define AO_EXTI_MODE_PULL_NONE 0 #define AO_EXTI_MODE_PULL_UP 4 #define AO_EXTI_MODE_PULL_DOWN 8 #define AO_EXTI_PRIORITY_LOW 16 diff --git a/src/stm/ao_serial_stm.c b/src/stm/ao_serial_stm.c index ef562313..2afee5b5 100644 --- a/src/stm/ao_serial_stm.c +++ b/src/stm/ao_serial_stm.c @@ -60,13 +60,13 @@ _ao_usart_cts(struct ao_stm_usart *usart) #endif static void -_ao_usart_rx(struct ao_stm_usart *usart, int stdin) +_ao_usart_rx(struct ao_stm_usart *usart, int is_stdin) { if (usart->reg->sr & (1 << STM_USART_SR_RXNE)) { if (!ao_fifo_full(usart->rx_fifo)) { ao_fifo_insert(usart->rx_fifo, usart->reg->dr); ao_wakeup(&usart->rx_fifo); - if (stdin) + if (is_stdin) ao_wakeup(&ao_stdin_ready); #if HAS_SERIAL_SW_FLOW /* If the fifo is nearly full, turn off RTS and wait @@ -84,9 +84,9 @@ _ao_usart_rx(struct ao_stm_usart *usart, int stdin) } static void -ao_usart_isr(struct ao_stm_usart *usart, int stdin) +ao_usart_isr(struct ao_stm_usart *usart, int is_stdin) { - _ao_usart_rx(usart, stdin); + _ao_usart_rx(usart, is_stdin); if (!_ao_usart_tx_start(usart)) usart->reg->cr1 &= ~(1<< STM_USART_CR1_TXEIE); diff --git a/src/stmf0/Makefile-stmf0.defs b/src/stmf0/Makefile-stmf0.defs index f2c53499..fa6e6e86 100644 --- a/src/stmf0/Makefile-stmf0.defs +++ b/src/stmf0/Makefile-stmf0.defs @@ -4,7 +4,7 @@ endif include $(TOPDIR)/Makedefs -vpath % $(TOPDIR)/stmf0:$(TOPDIR)/product:$(TOPDIR)/drivers:$(TOPDIR)/kernel:$(TOPDIR)/util:$(TOPDIR)/kalman:$(TOPDIR)/aes:$(TOPDIR):$(TOPDIR)/math:$(TOPDIR)/lisp +vpath % $(TOPDIR)/stmf0:$(TOPDIR)/product:$(TOPDIR)/drivers:$(TOPDIR)/kernel:$(TOPDIR)/util:$(TOPDIR)/kalman:$(TOPDIR)/aes:$(TOPDIR):$(TOPDIR)/math:$(TOPDIR)/scheme vpath make-altitude $(TOPDIR)/util vpath make-kalman $(TOPDIR)/util vpath kalman.5c $(TOPDIR)/kalman diff --git a/src/teleballoon-v2.0/ao_pins.h b/src/teleballoon-v2.0/ao_pins.h index 746bb3ee..d98e85d7 100644 --- a/src/teleballoon-v2.0/ao_pins.h +++ b/src/teleballoon-v2.0/ao_pins.h @@ -64,6 +64,7 @@ #define AO_CONFIG_MAX_SIZE 1024 #define LOG_ERASE_MARK 0x55 #define LOG_MAX_ERASE 128 +#define AO_LOG_FORMAT AO_LOG_FORMAT_TELEMETRUM #define HAS_EEPROM 1 #define USE_INTERNAL_FLASH 0 diff --git a/src/telegps-v0.3/ao_pins.h b/src/telegps-v0.3/ao_pins.h index 28ae30a4..873474bb 100644 --- a/src/telegps-v0.3/ao_pins.h +++ b/src/telegps-v0.3/ao_pins.h @@ -75,6 +75,7 @@ #define AO_CONFIG_DEFAULT_APRS_INTERVAL 0 #define AO_CONFIG_DEFAULT_RADIO_POWER 0xc0 #define AO_CONFIG_DEFAULT_FLIGHT_LOG_MAX 496 * 1024 +#define AO_LOG_FORMAT AO_LOG_FORMAT_TELEGPS /* * GPS diff --git a/src/telegps-v1.0/ao_pins.h b/src/telegps-v1.0/ao_pins.h index 9672ab03..f3bdc0ac 100644 --- a/src/telegps-v1.0/ao_pins.h +++ b/src/telegps-v1.0/ao_pins.h @@ -77,6 +77,7 @@ #define AO_CONFIG_DEFAULT_APRS_INTERVAL 0 #define AO_CONFIG_DEFAULT_RADIO_POWER 0xc0 +#define AO_LOG_FORMAT AO_LOG_FORMAT_TELEGPS /* * GPS diff --git a/src/telegps-v2.0/ao_pins.h b/src/telegps-v2.0/ao_pins.h index fa175371..a2e812fa 100644 --- a/src/telegps-v2.0/ao_pins.h +++ b/src/telegps-v2.0/ao_pins.h @@ -136,6 +136,7 @@ struct ao_adc { #define AO_CONFIG_DEFAULT_APRS_INTERVAL 0 #define AO_CONFIG_DEFAULT_RADIO_POWER 0xc0 +#define AO_LOG_FORMAT AO_LOG_FORMAT_TELEGPS /* * GPS diff --git a/src/telemega-v0.1/ao_pins.h b/src/telemega-v0.1/ao_pins.h index 11c4267c..94e77f98 100644 --- a/src/telemega-v0.1/ao_pins.h +++ b/src/telemega-v0.1/ao_pins.h @@ -69,6 +69,7 @@ #define AO_CONFIG_MAX_SIZE 1024 #define LOG_ERASE_MARK 0x55 #define LOG_MAX_ERASE 128 +#define AO_LOG_FORMAT AO_LOG_FORMAT_TELEMEGA #define HAS_EEPROM 1 #define USE_INTERNAL_FLASH 0 diff --git a/src/telemega-v1.0/ao_pins.h b/src/telemega-v1.0/ao_pins.h index 4decbbf7..d44394f0 100644 --- a/src/telemega-v1.0/ao_pins.h +++ b/src/telemega-v1.0/ao_pins.h @@ -69,6 +69,7 @@ #define AO_CONFIG_MAX_SIZE 1024 #define LOG_ERASE_MARK 0x55 #define LOG_MAX_ERASE 128 +#define AO_LOG_FORMAT AO_LOG_FORMAT_TELEMEGA #define HAS_EEPROM 1 #define USE_INTERNAL_FLASH 0 diff --git a/src/telemega-v2.0/ao_pins.h b/src/telemega-v2.0/ao_pins.h index c7c8ad19..42c00c94 100644 --- a/src/telemega-v2.0/ao_pins.h +++ b/src/telemega-v2.0/ao_pins.h @@ -69,6 +69,7 @@ #define AO_CONFIG_MAX_SIZE 1024 #define LOG_ERASE_MARK 0x55 #define LOG_MAX_ERASE 128 +#define AO_LOG_FORMAT AO_LOG_FORMAT_TELEMEGA #define HAS_EEPROM 1 #define USE_INTERNAL_FLASH 0 diff --git a/src/telemega-v3.0/.gitignore b/src/telemega-v3.0/.gitignore new file mode 100644 index 00000000..e67759a2 --- /dev/null +++ b/src/telemega-v3.0/.gitignore @@ -0,0 +1,2 @@ +ao_product.h +telemega-*.elf diff --git a/src/telemega-v3.0/Makefile b/src/telemega-v3.0/Makefile new file mode 100644 index 00000000..ae22bf01 --- /dev/null +++ b/src/telemega-v3.0/Makefile @@ -0,0 +1,153 @@ +# +# AltOS build +# +# + +include ../stm/Makefile.defs + +INC = \ + ao.h \ + ao_arch.h \ + ao_arch_funcs.h \ + ao_boot.h \ + ao_companion.h \ + ao_data.h \ + ao_sample.h \ + ao_pins.h \ + altitude-pa.h \ + ao_kalman.h \ + ao_product.h \ + ao_ms5607.h \ + ao_mpu9250.h \ + ao_mma655x.h \ + ao_cc1200_CC1200.h \ + ao_profile.h \ + ao_task.h \ + ao_whiten.h \ + ao_sample_profile.h \ + ao_quaternion.h \ + math.h \ + ao_mpu.h \ + stm32l.h \ + math.h \ + ao_ms5607_convert.c \ + Makefile + +# +# Common AltOS sources +# + +#PROFILE=ao_profile.c +#PROFILE_DEF=-DAO_PROFILE=1 + +#SAMPLE_PROFILE=ao_sample_profile.c \ +# ao_sample_profile_timer.c +#SAMPLE_PROFILE_DEF=-DHAS_SAMPLE_PROFILE=1 + +#STACK_GUARD=ao_mpu_stm.c +#STACK_GUARD_DEF=-DHAS_STACK_GUARD=1 + +MATH_SRC=\ + ef_acos.c \ + ef_sqrt.c \ + ef_rem_pio2.c \ + kf_cos.c \ + kf_sin.c \ + kf_rem_pio2.c \ + sf_copysign.c \ + sf_cos.c \ + sf_fabs.c \ + sf_floor.c \ + sf_scalbn.c \ + sf_sin.c \ + ef_log.c + +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_stdio.c \ + ao_panic.c \ + ao_timer.c \ + ao_mutex.c \ + ao_serial_stm.c \ + ao_gps_ublox.c \ + ao_gps_show.c \ + ao_gps_report_mega.c \ + ao_ignite.c \ + ao_freq.c \ + ao_dma_stm.c \ + ao_spi_stm.c \ + ao_cc1200.c \ + ao_data.c \ + ao_ms5607.c \ + ao_mma655x.c \ + ao_adc_stm.c \ + ao_beep_stm.c \ + ao_eeprom_stm.c \ + ao_storage.c \ + ao_m25.c \ + ao_usb_stm.c \ + ao_exti_stm.c \ + ao_report.c \ + ao_i2c_stm.c \ + ao_mpu9250.c \ + ao_convert_pa.c \ + ao_convert_volt.c \ + ao_log.c \ + ao_log_mega.c \ + ao_sample.c \ + ao_kalman.c \ + ao_flight.c \ + ao_telemetry.c \ + ao_packet_slave.c \ + ao_packet.c \ + ao_companion.c \ + ao_pyro.c \ + ao_aprs.c \ + ao_pwm_stm.c \ + $(MATH_SRC) \ + $(PROFILE) \ + $(SAMPLE_PROFILE) \ + $(STACK_GUARD) + +PRODUCT=TeleMega-v3.0 +PRODUCT_DEF=-DTELEMEGA +IDPRODUCT=0x0023 + +CFLAGS = $(PRODUCT_DEF) $(STM_CFLAGS) $(PROFILE_DEF) $(SAMPLE_PROFILE_DEF) $(STACK_GUARD_DEF) -Os -g + +PROGNAME=telemega-v3.0 +PROG=$(PROGNAME)-$(VERSION).elf +HEX=$(PROGNAME)-$(VERSION).ihx + +SRC=$(ALTOS_SRC) ao_telemega.c +OBJ=$(SRC:.c=.o) + +all: $(PROG) $(HEX) + +$(PROG): Makefile $(OBJ) altos.ld + $(call quiet,CC) $(LDFLAGS) $(CFLAGS) -o $(PROG) $(OBJ) $(LIBS) + +../altitude-pa.h: make-altitude-pa + nickle $< > $@ + +$(OBJ): $(INC) + +ao_product.h: ao-make-product.5c ../Version + $(call quiet,NICKLE,$<) $< -m altusmetrum.org -i $(IDPRODUCT) -p $(PRODUCT) -v $(VERSION) > $@ + +distclean: clean + +clean: + rm -f *.o $(PROGNAME)-*.elf $(PROGNAME)-*.ihx + rm -f ao_product.h + +install: + +uninstall: diff --git a/src/telemega-v3.0/ao_pins.h b/src/telemega-v3.0/ao_pins.h new file mode 100644 index 00000000..73278600 --- /dev/null +++ b/src/telemega-v3.0/ao_pins.h @@ -0,0 +1,402 @@ +/* + * Copyright © 2017 Keith Packard <keithp@keithp.com> + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation; either version 2 of the License, or + * (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, but + * WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + * General Public License for more details. + * + * 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 HAS_TASK_QUEUE 1 + +/* 8MHz High speed external crystal */ +#define AO_HSE 8000000 + +/* PLLVCO = 96MHz (so that USB will work) */ +#define AO_PLLMUL 12 +#define AO_RCC_CFGR_PLLMUL (STM_RCC_CFGR_PLLMUL_12) + +/* SYSCLK = 32MHz (no need to go faster than CPU) */ +#define AO_PLLDIV 3 +#define AO_RCC_CFGR_PLLDIV (STM_RCC_CFGR_PLLDIV_3) + +/* HCLK = 32MHz (CPU clock) */ +#define AO_AHB_PRESCALER 1 +#define AO_RCC_CFGR_HPRE_DIV STM_RCC_CFGR_HPRE_DIV_1 + +/* Run APB1 at 16MHz (HCLK/2) */ +#define AO_APB1_PRESCALER 2 +#define AO_RCC_CFGR_PPRE1_DIV STM_RCC_CFGR_PPRE2_DIV_2 + +/* Run APB2 at 16MHz (HCLK/2) */ +#define AO_APB2_PRESCALER 2 +#define AO_RCC_CFGR_PPRE2_DIV STM_RCC_CFGR_PPRE2_DIV_2 + +#define HAS_SERIAL_1 0 +#define USE_SERIAL_1_STDIN 0 +#define SERIAL_1_PB6_PB7 0 +#define SERIAL_1_PA9_PA10 1 + +#define HAS_SERIAL_2 0 +#define USE_SERIAL_2_STDIN 0 +#define SERIAL_2_PA2_PA3 0 +#define SERIAL_2_PD5_PD6 0 + +#define HAS_SERIAL_3 1 +#define USE_SERIAL_3_STDIN 0 +#define SERIAL_3_PB10_PB11 0 +#define SERIAL_3_PC10_PC11 1 +#define SERIAL_3_PD8_PD9 0 + +#define ao_gps_getchar ao_serial3_getchar +#define ao_gps_putchar ao_serial3_putchar +#define ao_gps_set_speed ao_serial3_set_speed +#define ao_gps_fifo (ao_stm_usart3.rx_fifo) + +#define AO_CONFIG_DEFAULT_FLIGHT_LOG_MAX (1024 * 1024) +#define AO_CONFIG_MAX_SIZE 1024 +#define LOG_ERASE_MARK 0x55 +#define LOG_MAX_ERASE 128 +#define AO_LOG_FORMAT AO_LOG_FORMAT_TELEMEGA_3 + +#define HAS_EEPROM 1 +#define USE_INTERNAL_FLASH 0 +#define USE_EEPROM_CONFIG 1 +#define USE_STORAGE_CONFIG 0 +#define HAS_USB 1 +#define HAS_BEEP 1 +#define HAS_BATTERY_REPORT 1 +#define HAS_RADIO 1 +#define HAS_TELEMETRY 1 +#define HAS_APRS 1 +#define HAS_COMPANION 1 + +#define HAS_SPI_1 1 +#define SPI_1_PA5_PA6_PA7 1 /* Barometer */ +#define SPI_1_PB3_PB4_PB5 0 +#define SPI_1_PE13_PE14_PE15 1 /* Accelerometer, Gyro */ +#define SPI_1_OSPEEDR STM_OSPEEDR_10MHz + +#define HAS_SPI_2 1 +#define SPI_2_PB13_PB14_PB15 1 /* Flash, Companion */ +#define SPI_2_PD1_PD3_PD4 0 +#define SPI_2_OSPEEDR STM_OSPEEDR_10MHz + +#define SPI_2_PORT (&stm_gpiob) +#define SPI_2_SCK_PIN 13 +#define SPI_2_MISO_PIN 14 +#define SPI_2_MOSI_PIN 15 + +#define HAS_I2C_1 1 +#define I2C_1_PB8_PB9 1 + +#define HAS_I2C_2 0 +#define I2C_2_PB10_PB11 0 + +#define PACKET_HAS_SLAVE 1 +#define PACKET_HAS_MASTER 0 + +#define LOW_LEVEL_DEBUG 0 + +#define LED_PORT_ENABLE STM_RCC_AHBENR_GPIOCEN +#define LED_PORT (&stm_gpioc) +#define LED_PIN_RED 8 +#define LED_PIN_GREEN 9 +#define AO_LED_RED (1 << LED_PIN_RED) +#define AO_LED_GREEN (1 << LED_PIN_GREEN) + +#define LEDS_AVAILABLE (AO_LED_RED | AO_LED_GREEN) + +#define HAS_GPS 1 +#define HAS_FLIGHT 1 +#define HAS_ADC 1 +#define HAS_ADC_TEMP 1 +#define HAS_LOG 1 + +/* + * Igniter + */ + +#define HAS_IGNITE 1 +#define HAS_IGNITE_REPORT 1 + +#define AO_SENSE_PYRO(p,n) ((p)->adc.sense[n]) +#define AO_SENSE_DROGUE(p) ((p)->adc.sense[4]) +#define AO_SENSE_MAIN(p) ((p)->adc.sense[5]) +#define AO_IGNITER_CLOSED 400 +#define AO_IGNITER_OPEN 60 + +/* Pyro A */ +#define AO_PYRO_PORT_0 (&stm_gpiod) +#define AO_PYRO_PIN_0 6 + +/* Pyro B */ +#define AO_PYRO_PORT_1 (&stm_gpiod) +#define AO_PYRO_PIN_1 7 + +/* Pyro C */ +#define AO_PYRO_PORT_2 (&stm_gpiob) +#define AO_PYRO_PIN_2 5 + +/* Pyro D */ +#define AO_PYRO_PORT_3 (&stm_gpioe) +#define AO_PYRO_PIN_3 4 + +/* Drogue */ +#define AO_IGNITER_DROGUE_PORT (&stm_gpioe) +#define AO_IGNITER_DROGUE_PIN 6 + +/* Main */ +#define AO_IGNITER_MAIN_PORT (&stm_gpioe) +#define AO_IGNITER_MAIN_PIN 5 + +/* Number of general purpose pyro channels available */ +#define AO_PYRO_NUM 4 + +#define AO_IGNITER_SET_DROGUE(v) stm_gpio_set(AO_IGNITER_DROGUE_PORT, AO_IGNITER_DROGUE_PIN, v) +#define AO_IGNITER_SET_MAIN(v) stm_gpio_set(AO_IGNITER_MAIN_PORT, AO_IGNITER_MAIN_PIN, v) + +/* + * ADC + */ +#define AO_DATA_RING 32 +#define AO_ADC_NUM_SENSE 6 + +struct ao_adc { + int16_t sense[AO_ADC_NUM_SENSE]; + int16_t v_batt; + int16_t v_pbatt; + int16_t temp; +}; + +#define AO_ADC_DUMP(p) \ + printf("tick: %5u A: %5d B: %5d C: %5d D: %5d drogue: %5d main: %5d batt: %5d pbatt: %5d temp: %5d\n", \ + (p)->tick, \ + (p)->adc.sense[0], (p)->adc.sense[1], (p)->adc.sense[2], \ + (p)->adc.sense[3], (p)->adc.sense[4], (p)->adc.sense[5], \ + (p)->adc.v_batt, (p)->adc.v_pbatt, (p)->adc.temp) + +#define AO_ADC_SENSE_A 0 +#define AO_ADC_SENSE_A_PORT (&stm_gpioa) +#define AO_ADC_SENSE_A_PIN 0 + +#define AO_ADC_SENSE_B 1 +#define AO_ADC_SENSE_B_PORT (&stm_gpioa) +#define AO_ADC_SENSE_B_PIN 1 + +#define AO_ADC_SENSE_C 2 +#define AO_ADC_SENSE_C_PORT (&stm_gpioa) +#define AO_ADC_SENSE_C_PIN 2 + +#define AO_ADC_SENSE_D 3 +#define AO_ADC_SENSE_D_PORT (&stm_gpioa) +#define AO_ADC_SENSE_D_PIN 3 + +#define AO_ADC_SENSE_DROGUE 4 +#define AO_ADC_SENSE_DROGUE_PORT (&stm_gpioa) +#define AO_ADC_SENSE_DROGUE_PIN 4 + +#define AO_ADC_SENSE_MAIN 22 +#define AO_ADC_SENSE_MAIN_PORT (&stm_gpioe) +#define AO_ADC_SENSE_MAIN_PIN 7 + +#define AO_ADC_V_BATT 8 +#define AO_ADC_V_BATT_PORT (&stm_gpiob) +#define AO_ADC_V_BATT_PIN 0 + +#define AO_ADC_V_PBATT 9 +#define AO_ADC_V_PBATT_PORT (&stm_gpiob) +#define AO_ADC_V_PBATT_PIN 1 + +#define AO_ADC_TEMP 16 + +#define AO_ADC_RCC_AHBENR ((1 << STM_RCC_AHBENR_GPIOAEN) | \ + (1 << STM_RCC_AHBENR_GPIOEEN) | \ + (1 << STM_RCC_AHBENR_GPIOBEN)) + +#define AO_NUM_ADC_PIN (AO_ADC_NUM_SENSE + 2) + +#define AO_ADC_PIN0_PORT AO_ADC_SENSE_A_PORT +#define AO_ADC_PIN0_PIN AO_ADC_SENSE_A_PIN +#define AO_ADC_PIN1_PORT AO_ADC_SENSE_B_PORT +#define AO_ADC_PIN1_PIN AO_ADC_SENSE_B_PIN +#define AO_ADC_PIN2_PORT AO_ADC_SENSE_C_PORT +#define AO_ADC_PIN2_PIN AO_ADC_SENSE_C_PIN +#define AO_ADC_PIN3_PORT AO_ADC_SENSE_D_PORT +#define AO_ADC_PIN3_PIN AO_ADC_SENSE_D_PIN +#define AO_ADC_PIN4_PORT AO_ADC_SENSE_DROGUE_PORT +#define AO_ADC_PIN4_PIN AO_ADC_SENSE_DROGUE_PIN +#define AO_ADC_PIN5_PORT AO_ADC_SENSE_MAIN_PORT +#define AO_ADC_PIN5_PIN AO_ADC_SENSE_MAIN_PIN +#define AO_ADC_PIN6_PORT AO_ADC_V_BATT_PORT +#define AO_ADC_PIN6_PIN AO_ADC_V_BATT_PIN +#define AO_ADC_PIN7_PORT AO_ADC_V_PBATT_PORT +#define AO_ADC_PIN7_PIN AO_ADC_V_PBATT_PIN + +#define AO_NUM_ADC (AO_ADC_NUM_SENSE + 3) + +#define AO_ADC_SQ1 AO_ADC_SENSE_A +#define AO_ADC_SQ2 AO_ADC_SENSE_B +#define AO_ADC_SQ3 AO_ADC_SENSE_C +#define AO_ADC_SQ4 AO_ADC_SENSE_D +#define AO_ADC_SQ5 AO_ADC_SENSE_DROGUE +#define AO_ADC_SQ6 AO_ADC_SENSE_MAIN +#define AO_ADC_SQ7 AO_ADC_V_BATT +#define AO_ADC_SQ8 AO_ADC_V_PBATT +#define AO_ADC_SQ9 AO_ADC_TEMP + +/* + * Voltage divider on ADC battery sampler + */ +#define AO_BATTERY_DIV_PLUS 56 /* 5.6k */ +#define AO_BATTERY_DIV_MINUS 100 /* 10k */ + +/* + * Voltage divider on ADC igniter samplers + */ +#define AO_IGNITE_DIV_PLUS 100 /* 100k */ +#define AO_IGNITE_DIV_MINUS 27 /* 27k */ + +/* + * ADC reference in decivolts + */ +#define AO_ADC_REFERENCE_DV 33 + +/* + * Pressure sensor settings + */ +#define HAS_MS5607 1 +#define HAS_MS5611 0 +#define AO_MS5607_PRIVATE_PINS 1 +#define AO_MS5607_CS_PORT (&stm_gpioc) +#define AO_MS5607_CS_PIN 4 +#define AO_MS5607_CS_MASK (1 << AO_MS5607_CS) +#define AO_MS5607_MISO_PORT (&stm_gpioa) +#define AO_MS5607_MISO_PIN 6 +#define AO_MS5607_MISO_MASK (1 << AO_MS5607_MISO) +#define AO_MS5607_SPI_INDEX AO_SPI_1_PA5_PA6_PA7 + +/* + * SPI Flash memory + */ + +#define M25_MAX_CHIPS 1 +#define AO_M25_SPI_CS_PORT (&stm_gpiod) +#define AO_M25_SPI_CS_MASK (1 << 3) +#define AO_M25_SPI_BUS AO_SPI_2_PB13_PB14_PB15 + +/* + * Radio (cc1120) + */ + +/* gets pretty close to 434.550 */ + +#define AO_RADIO_CAL_DEFAULT 5695733 + +#define AO_FEC_DEBUG 0 +#define AO_CC1200_SPI_CS_PORT (&stm_gpioc) +#define AO_CC1200_SPI_CS_PIN 5 +#define AO_CC1200_SPI_BUS AO_SPI_2_PB13_PB14_PB15 +#define AO_CC1200_SPI stm_spi2 +#define AO_CC1200_SPI_SPEED AO_SPI_SPEED_FAST + +#define AO_CC1200_INT_PORT (&stm_gpioe) +#define AO_CC1200_INT_PIN 1 +#define AO_CC1200_MCU_WAKEUP_PORT (&stm_gpioc) +#define AO_CC1200_MCU_WAKEUP_PIN (0) + +#define AO_CC1200_INT_GPIO 2 +#define AO_CC1200_INT_GPIO_IOCFG CC1200_IOCFG2 + +#define AO_CC1200_MARC_GPIO 3 +#define AO_CC1200_MARC_GPIO_IOCFG CC1200_IOCFG3 + +#define HAS_BOOT_RADIO 0 + +/* + * mpu9250 + */ + +#define HAS_MPU9250 1 +#define AO_MPU9250_INT_PORT (&stm_gpioe) +#define AO_MPU9250_INT_PIN 0 +#define AO_MPU9250_SPI_BUS AO_SPI_1_PE13_PE14_PE15 +#define AO_MPU9250_SPI_CS_PORT (&stm_gpiod) +#define AO_MPU9250_SPI_CS_PIN 2 +#define HAS_IMU 1 + +/* + * mma655x + */ + +#define HAS_MMA655X 1 +#define AO_MMA655X_INVERT 0 +#define AO_MMA655X_SPI_INDEX AO_SPI_1_PE13_PE14_PE15 +#define AO_MMA655X_CS_PORT (&stm_gpiod) +#define AO_MMA655X_CS_PIN 4 + +#define NUM_CMDS 16 + +/* + * Companion + */ + +#define AO_COMPANION_CS_PORT (&stm_gpiob) +#define AO_COMPANION_CS_PIN_0 (6) +#define AO_COMPANION_CS_PIN AO_COMPANION_CS_PIN_0 +#define AO_COMPANION_CS_PIN_1 (7) +#define AO_COMPANION_SPI_BUS AO_SPI_2_PB13_PB14_PB15 + +/* + * Monitor + */ + +#define HAS_MONITOR 0 +#define LEGACY_MONITOR 0 +#define HAS_MONITOR_PUT 1 +#define AO_MONITOR_LED 0 +#define HAS_RSSI 0 + +/* + * Profiling Viterbi decoding + */ + +#ifndef AO_PROFILE +#define AO_PROFILE 0 +#endif + +/* + * PWM output + */ + +#define NUM_PWM 4 +#define PWM_MAX 20000 +#define AO_PWM_TIMER stm_tim4 +#define AO_PWM_TIMER_ENABLE STM_RCC_APB1ENR_TIM4EN +#define AO_PWM_TIMER_SCALE 32 + +#define AO_PWM_0_GPIO (&stm_gpiod) +#define AO_PWM_0_PIN 12 + +#define AO_PWM_1_GPIO (&stm_gpiod) +#define AO_PWM_1_PIN 13 + +#define AO_PWM_2_GPIO (&stm_gpiod) +#define AO_PWM_2_PIN 14 + +#define AO_PWM_3_GPIO (&stm_gpiod) +#define AO_PWM_3_PIN 15 + +#endif /* _AO_PINS_H_ */ diff --git a/src/telemega-v3.0/ao_telemega.c b/src/telemega-v3.0/ao_telemega.c new file mode 100644 index 00000000..2259c751 --- /dev/null +++ b/src/telemega-v3.0/ao_telemega.c @@ -0,0 +1,104 @@ +/* + * Copyright © 2017 Keith Packard <keithp@keithp.com> + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation; either version 2 of the License, or + * (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, but + * WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + * General Public License for more details. + * + * 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. + */ + +#include <ao.h> +#include <ao_mpu9250.h> +#include <ao_mma655x.h> +#include <ao_log.h> +#include <ao_exti.h> +#include <ao_packet.h> +#include <ao_companion.h> +#include <ao_profile.h> +#include <ao_eeprom.h> +#if HAS_SAMPLE_PROFILE +#include <ao_sample_profile.h> +#endif +#include <ao_pyro.h> +#if HAS_STACK_GUARD +#include <ao_mpu.h> +#endif +#include <ao_pwm.h> + +int +main(void) +{ + ao_clock_init(); + +#if HAS_STACK_GUARD + ao_mpu_init(); +#endif + + ao_task_init(); + ao_serial_init(); + ao_led_init(LEDS_AVAILABLE); + ao_led_on(LEDS_AVAILABLE); + ao_timer_init(); + + ao_i2c_init(); + ao_spi_init(); + ao_dma_init(); + ao_exti_init(); + + ao_adc_init(); +#if HAS_BEEP + ao_beep_init(); +#endif + ao_cmd_init(); + +#if HAS_MS5607 + ao_ms5607_init(); +#endif +#if HAS_MPU9250 + ao_mpu9250_init(); +#endif +#if HAS_MMA655X + ao_mma655x_init(); +#endif + + ao_eeprom_init(); + ao_storage_init(); + + ao_flight_init(); + ao_log_init(); + ao_report_init(); + + ao_usb_init(); + ao_gps_init(); + ao_gps_report_mega_init(); + ao_telemetry_init(); + ao_radio_init(); + ao_packet_slave_init(FALSE); + ao_igniter_init(); + ao_companion_init(); + ao_pyro_init(); + + ao_config_init(); +#if AO_PROFILE + ao_profile_init(); +#endif +#if HAS_SAMPLE_PROFILE + ao_sample_profile_init(); +#endif + + ao_pwm_init(); + + ao_led_off(LEDS_AVAILABLE); + + ao_start_scheduler(); + return 0; +} diff --git a/src/telemega-v3.0/flash-loader/Makefile b/src/telemega-v3.0/flash-loader/Makefile new file mode 100644 index 00000000..9e00293f --- /dev/null +++ b/src/telemega-v3.0/flash-loader/Makefile @@ -0,0 +1,8 @@ +# +# AltOS flash loader build +# +# + +TOPDIR=../.. +HARDWARE=telemega-v3.0 +include $(TOPDIR)/stm/Makefile-flash.defs diff --git a/src/telemega-v3.0/flash-loader/ao_pins.h b/src/telemega-v3.0/flash-loader/ao_pins.h new file mode 100644 index 00000000..6e9bba57 --- /dev/null +++ b/src/telemega-v3.0/flash-loader/ao_pins.h @@ -0,0 +1,35 @@ +/* + * Copyright © 2017 Keith Packard <keithp@keithp.com> + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation; either version 2 of the License, or + * (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, but + * WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + * General Public License for more details. + * + * 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_ + +/* External crystal at 8MHz */ +#define AO_HSE 8000000 + +#include <ao_flash_stm_pins.h> + +/* Companion port cs_companion0 PB6 */ + +#define AO_BOOT_PIN 1 +#define AO_BOOT_APPLICATION_GPIO stm_gpiob +#define AO_BOOT_APPLICATION_PIN 6 +#define AO_BOOT_APPLICATION_VALUE 1 +#define AO_BOOT_APPLICATION_MODE AO_EXTI_MODE_PULL_UP + +#endif /* _AO_PINS_H_ */ diff --git a/src/telemetrum-v2.0/ao_pins.h b/src/telemetrum-v2.0/ao_pins.h index d9063173..d26a5193 100644 --- a/src/telemetrum-v2.0/ao_pins.h +++ b/src/telemetrum-v2.0/ao_pins.h @@ -64,6 +64,7 @@ #define AO_CONFIG_MAX_SIZE 1024 #define LOG_ERASE_MARK 0x55 #define LOG_MAX_ERASE 128 +#define AO_LOG_FORMAT AO_LOG_FORMAT_TELEMETRUM #define HAS_EEPROM 1 #define USE_INTERNAL_FLASH 0 diff --git a/src/telemetrum-v3.0/ao_pins.h b/src/telemetrum-v3.0/ao_pins.h index b937b422..6d4369c9 100644 --- a/src/telemetrum-v3.0/ao_pins.h +++ b/src/telemetrum-v3.0/ao_pins.h @@ -64,6 +64,7 @@ #define AO_CONFIG_MAX_SIZE 1024 #define LOG_ERASE_MARK 0x55 #define LOG_MAX_ERASE 128 +#define AO_LOG_FORMAT AO_LOG_FORMAT_TELEMETRUM #define HAS_EEPROM 1 #define USE_INTERNAL_FLASH 0 diff --git a/src/telescience-v0.2/ao_pins.h b/src/telescience-v0.2/ao_pins.h index c78766cd..29f16114 100644 --- a/src/telescience-v0.2/ao_pins.h +++ b/src/telescience-v0.2/ao_pins.h @@ -111,6 +111,7 @@ #define HAS_ADC 1 #define HAS_ADC_TEMP 1 #define HAS_LOG 1 +#define AO_LOG_FORMAT AO_LOG_FORMAT_TELESCIENCE /* * SPI Flash memory diff --git a/src/teleterra-v0.2/ao_pins.h b/src/teleterra-v0.2/ao_pins.h index 8d9f7a2f..5bcf2c8a 100644 --- a/src/teleterra-v0.2/ao_pins.h +++ b/src/teleterra-v0.2/ao_pins.h @@ -75,6 +75,8 @@ #define HAS_TELEMETRY 0 #define AO_VALUE_32 0 + + #define AO_LOG_FORMAT AO_LOG_FORMAT_TELEMETRY #endif #if DBG_ON_P1 diff --git a/src/test/Makefile b/src/test/Makefile index 08808430..7bd13db9 100644 --- a/src/test/Makefile +++ b/src/test/Makefile @@ -1,10 +1,13 @@ -vpath % ..:../kernel:../drivers:../util:../micropeak:../aes:../product:../lisp +vpath %.o . +vpath %.c ..:../kernel:../drivers:../util:../micropeak:../aes:../product +vpath %.h ..:../kernel:../drivers:../util:../micropeak:../aes:../product +vpath make-kalman ..:../kernel:../drivers:../util:../micropeak:../aes:../product PROGS=ao_flight_test ao_flight_test_baro ao_flight_test_accel ao_flight_test_noisy_accel ao_flight_test_mm \ ao_flight_test_metrum ao_flight_test_mini \ ao_gps_test ao_gps_test_skytraq ao_gps_test_ublox ao_convert_test ao_convert_pa_test ao_fec_test \ ao_aprs_test ao_micropeak_test ao_fat_test ao_aes_test ao_int64_test \ - ao_ms5607_convert_test ao_quaternion_test ao_lisp_test + ao_ms5607_convert_test ao_quaternion_test INCS=ao_kalman.h ao_ms5607.h ao_log.h ao_data.h altitude-pa.h altitude.h ao_quaternion.h ao_eeprom_read.h TEST_SRC=ao_flight_test.c @@ -17,7 +20,7 @@ CFLAGS=-I.. -I. -I../kernel -I../drivers -I../micropeak -I../product -I../lisp - all: $(PROGS) ao_aprs_data.wav -clean: +clean:: rm -f $(PROGS) ao_aprs_data.wav run-out.baro run-out.full install: @@ -94,12 +97,3 @@ ao_ms5607_convert_test: ao_ms5607_convert_test.c ao_ms5607_convert_8051.c ao_int 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_cons.o ao_lisp_string.o \ - ao_lisp_atom.o ao_lisp_int.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_lambda.o ao_lisp_error.o ao_lisp_save.o ao_lisp_stack.o - -ao_lisp_test: $(AO_LISP_OBJS) - cc $(CFLAGS) -o $@ $(AO_LISP_OBJS) - -$(AO_LISP_OBJS): ao_lisp.h ao_lisp_const.h ao_lisp_os.h diff --git a/src/test/ao_flight_test.c b/src/test/ao_flight_test.c index 298848d6..2d862f82 100644 --- a/src/test/ao_flight_test.c +++ b/src/test/ao_flight_test.c @@ -25,6 +25,7 @@ #include <string.h> #include <getopt.h> #include <math.h> +#define log ao_log_data #define GRAVITY 9.80665 @@ -370,7 +371,7 @@ extern int16_t ao_accel_2g; typedef int16_t accel_t; uint16_t ao_serial_number; -uint16_t ao_flight_number; +int16_t ao_flight_number; extern uint16_t ao_sample_tick; @@ -998,7 +999,7 @@ main (int argc, char **argv) #else emulator_app="baro"; #endif - while ((c = getopt_long(argc, argv, "sdi:", options, NULL)) != -1) { + while ((c = getopt_long(argc, argv, "sdpi:", options, NULL)) != -1) { switch (c) { case 's': summary = 1; @@ -1006,6 +1007,11 @@ main (int argc, char **argv) case 'd': ao_flight_debug = 1; break; + case 'p': +#if PYRO_DBG + pyro_dbg = 1; +#endif + break; case 'i': info = optarg; break; diff --git a/src/test/ao_lisp_test.c b/src/test/ao_lisp_test.c deleted file mode 100644 index 68e3a202..00000000 --- a/src/test/ao_lisp_test.c +++ /dev/null @@ -1,134 +0,0 @@ -/* - * Copyright © 2016 Keith Packard <keithp@keithp.com> - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation, either version 2 of the License, or - * (at your option) any later version. - * - * This program is distributed in the hope that it will be useful, but - * WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU - * General Public License for more details. - */ - -#include "ao_lisp.h" -#include <stdio.h> - -static FILE *ao_lisp_file; -static int newline = 1; - -static char save_file[] = "lisp.image"; - -int -ao_lisp_os_save(void) -{ - FILE *save = fopen(save_file, "w"); - - if (!save) { - perror(save_file); - return 0; - } - fwrite(ao_lisp_pool, 1, AO_LISP_POOL_TOTAL, save); - fclose(save); - return 1; -} - -int -ao_lisp_os_restore_save(struct ao_lisp_os_save *save, int offset) -{ - FILE *restore = fopen(save_file, "r"); - size_t ret; - - if (!restore) { - perror(save_file); - return 0; - } - fseek(restore, offset, SEEK_SET); - ret = fread(save, sizeof (struct ao_lisp_os_save), 1, restore); - fclose(restore); - if (ret != 1) - return 0; - return 1; -} - -int -ao_lisp_os_restore(void) -{ - FILE *restore = fopen(save_file, "r"); - size_t ret; - - if (!restore) { - perror(save_file); - return 0; - } - ret = fread(ao_lisp_pool, 1, AO_LISP_POOL_TOTAL, restore); - fclose(restore); - if (ret != AO_LISP_POOL_TOTAL) - return 0; - return 1; -} - -int -ao_lisp_getc(void) -{ - int c; - - if (ao_lisp_file) - return getc(ao_lisp_file); - - if (newline) { - printf("> "); - newline = 0; - } - c = getchar(); - if (c == '\n') - newline = 1; - return c; -} - -int -main (int argc, char **argv) -{ - while (*++argv) { - ao_lisp_file = fopen(*argv, "r"); - if (!ao_lisp_file) { - perror(*argv); - exit(1); - } - ao_lisp_read_eval_print(); - fclose(ao_lisp_file); - ao_lisp_file = NULL; - } - ao_lisp_read_eval_print(); - - printf ("collects: full: %d incremental %d\n", - ao_lisp_collects[AO_LISP_COLLECT_FULL], - ao_lisp_collects[AO_LISP_COLLECT_INCREMENTAL]); - - printf ("freed: full %d incremental %d\n", - ao_lisp_freed[AO_LISP_COLLECT_FULL], - ao_lisp_freed[AO_LISP_COLLECT_INCREMENTAL]); - - printf("loops: full %d incremental %d\n", - ao_lisp_loops[AO_LISP_COLLECT_FULL], - ao_lisp_loops[AO_LISP_COLLECT_INCREMENTAL]); - - printf("loops per collect: full %f incremental %f\n", - (double) ao_lisp_loops[AO_LISP_COLLECT_FULL] / - (double) ao_lisp_collects[AO_LISP_COLLECT_FULL], - (double) ao_lisp_loops[AO_LISP_COLLECT_INCREMENTAL] / - (double) ao_lisp_collects[AO_LISP_COLLECT_INCREMENTAL]); - - printf("freed per collect: full %f incremental %f\n", - (double) ao_lisp_freed[AO_LISP_COLLECT_FULL] / - (double) ao_lisp_collects[AO_LISP_COLLECT_FULL], - (double) ao_lisp_freed[AO_LISP_COLLECT_INCREMENTAL] / - (double) ao_lisp_collects[AO_LISP_COLLECT_INCREMENTAL]); - - printf("freed per loop: full %f incremental %f\n", - (double) ao_lisp_freed[AO_LISP_COLLECT_FULL] / - (double) ao_lisp_loops[AO_LISP_COLLECT_FULL], - (double) ao_lisp_freed[AO_LISP_COLLECT_INCREMENTAL] / - (double) ao_lisp_loops[AO_LISP_COLLECT_INCREMENTAL]); -} diff --git a/src/test/hanoi.lisp b/src/test/hanoi.lisp deleted file mode 100644 index e2eb0fa0..00000000 --- a/src/test/hanoi.lisp +++ /dev/null @@ -1,155 +0,0 @@ -; -; Towers of Hanoi -; -; Copyright © 2016 Keith Packard <keithp@keithp.com> -; -; This program is free software; you can redistribute it and/or modify -; it under the terms of the GNU General Public License as published by -; the Free Software Foundation, either version 2 of the License, or -; (at your option) any later version. -; -; This program is distributed in the hope that it will be useful, but -; WITHOUT ANY WARRANTY; without even the implied warranty of -; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -; General Public License for more details. -; - - ; ANSI control sequences - -(defun move-to (col row) - (patom "\033[" row ";" col "H") - ) - -(defun clear () - (patom "\033[2J") - ) - -(defun display-string (x y str) - (move-to x y) - (patom str) - ) - - ; Here's the pieces to display - -(setq stack '(" * " " *** " " ***** " " ******* " " ********* " "***********")) - - ; Here's all of the stacks of pieces - ; This is generated when the program is run - -(setq stacks nil) - - ; Display one stack, clearing any - ; space above it - -(defun display-stack (x y clear stack) - (cond ((= 0 clear) - (cond (stack - (display-string x y (car stack)) - (display-stack x (1+ y) 0 (cdr stack)) - ) - ) - ) - (t - (display-string x y " ") - (display-stack x (1+ y) (1- clear) stack) - ) - ) - ) - - ; Position of the top of the stack on the screen - ; Shorter stacks start further down the screen - -(defun stack-pos (y stack) - (- y (length stack)) - ) - - ; Display all of the stacks, spaced 20 columns apart - -(defun display-stacks (x y stacks) - (cond (stacks - (display-stack x 0 (stack-pos y (car stacks)) (car stacks)) - (display-stacks (+ x 20) y (cdr stacks))) - ) - ) - - ; Display all of the stacks, then move the cursor - ; out of the way and flush the output - -(defun display () - (display-stacks 0 top stacks) - (move-to 1 21) - (flush) - ) - - ; Reset stacks to the starting state, with - ; all of the pieces in the first stack and the - ; other two empty - -(defun reset-stacks () - (setq stacks (list stack nil nil)) - (setq top (+ (length stack) 3)) - (length stack) - ) - - ; more functions which could usefully - ; be in the rom image - -(defun min (a b) - (cond ((< a b) a) - (b) - ) - ) - - ; Replace a stack in the list of stacks - ; with a new value - -(defun replace (list pos member) - (cond ((= pos 0) (cons member (cdr list))) - ((cons (car list) (replace (cdr list) (1- pos) member))) - ) - ) - - ; Move a piece from the top of one stack - ; to the top of another - -(setq move-delay 100) - -(defun move-piece (from to) - (let ((from-stack (nth stacks from)) - (to-stack (nth stacks to)) - (piece (car from-stack))) - (setq from-stack (cdr from-stack)) - (setq to-stack (cons piece to-stack)) - (setq stacks (replace stacks from from-stack)) - (setq stacks (replace stacks to to-stack)) - (display) - (delay move-delay) - ) - ) - -; The implementation of the game - -(defun _hanoi (n from to use) - (cond ((= 1 n) - (move-piece from to) - ) - (t - (_hanoi (1- n) from use to) - (_hanoi 1 from to use) - (_hanoi (1- n) use to from) - ) - ) - ) - - ; A pretty interface which - ; resets the state of the game, - ; clears the screen and runs - ; the program - -(defun hanoi () - (setq len (reset-stacks)) - (clear) - (_hanoi len 0 1 2) - (move-to 0 23) - t - ) |