From 770998be2c15dd41a63520d0c8747d7cf32ec447 Mon Sep 17 00:00:00 2001 From: Keith Packard Date: Mon, 2 Oct 2017 16:57:15 -0700 Subject: altos: Allow pyro config name to end with newline, not just space/tab A pyro config like 'Descending' has no value associated. When it is at the end of the line, allow a newline to terminate the name instead of just a space. Signed-off-by: Keith Packard --- src/kernel/ao_pyro.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'src') diff --git a/src/kernel/ao_pyro.c b/src/kernel/ao_pyro.c index 9543b3ef..0aed50d5 100644 --- a/src/kernel/ao_pyro.c +++ b/src/kernel/ao_pyro.c @@ -482,7 +482,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(); -- cgit v1.2.3 From c8dbfff65dd61e42d0a02158dcb520e7710ef87e Mon Sep 17 00:00:00 2001 From: Keith Packard Date: Sun, 8 Oct 2017 18:50:59 -0700 Subject: altos: Stop storing pyro fired status in config block We already have the fired status saved in the ao_pyro_fired variable, so just use that to detect whether a channel has already been fired. Fixes possible cases where the pyro config data gets written back to eeprom with the fired bit set, which then inhibits the channel during flight. Signed-off-by: Keith Packard --- src/kernel/ao_pyro.c | 15 +++++++-------- src/kernel/ao_pyro.h | 2 +- 2 files changed, 8 insertions(+), 9 deletions(-) (limited to 'src') diff --git a/src/kernel/ao_pyro.c b/src/kernel/ao_pyro.c index 0aed50d5..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; } 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) -- cgit v1.2.3 From 9d7bb706918fd7d6db77eab21931b4fc74cb9105 Mon Sep 17 00:00:00 2001 From: Keith Packard Date: Thu, 12 Oct 2017 00:14:30 -0700 Subject: altos: Add MPU9250 driver (accel/gyro only for now) This is almost an exact copy of the MPU6000 driver, just a few minor register changes. Signed-off-by: Keith Packard --- src/drivers/ao_mpu9250.c | 415 +++++++++++++++++++++++++++++++++++++++++++++++ src/drivers/ao_mpu9250.h | 220 +++++++++++++++++++++++++ 2 files changed, 635 insertions(+) create mode 100644 src/drivers/ao_mpu9250.c create mode 100644 src/drivers/ao_mpu9250.h (limited to 'src') diff --git a/src/drivers/ao_mpu9250.c b/src/drivers/ao_mpu9250.c new file mode 100644 index 00000000..b79f27ca --- /dev/null +++ b/src/drivers/ao_mpu9250.c @@ -0,0 +1,415 @@ +/* + * Copyright © 2012 Keith Packard + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation; either version 2 of the License, or + * (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, but + * WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + * General Public License for more details. + * + * You should have received a copy of the GNU General Public License along + * with this program; if not, write to the Free Software Foundation, Inc., + * 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA. + */ + +#include +#include +#include + +#if HAS_MPU9250 + +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)) + +#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_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 + +static void +_ao_mpu9250_setup(void) +{ + struct ao_mpu9250_sample normal_mode, test_mode; + int errors; + int st_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) | + (0 << 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 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; + + /* 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(); +#if AO_MPU9250_SPI + ao_mpu9250_spi_put(); +#endif + for (;;) + { +#if AO_MPU9250_SPI + ao_mpu9250_spi_get(); +#endif + _ao_mpu9250_sample(&sample); +#if AO_MPU9250_SPI + ao_mpu9250_spi_put(); +#endif + 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\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); +} + +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 const struct ao_cmds ao_mpu9250_cmds[] = { + { ao_mpu9250_show, "I\0Show MPU9250 status" }, + { ao_mpu9250_read, "R \0Read MPU9250 register" }, + { ao_mpu9250_write, "W \0Write MPU9250 register" }, + { 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..a124d799 --- /dev/null +++ b/src/drivers/ao_mpu9250.h @@ -0,0 +1,220 @@ +/* + * Copyright © 2012 Keith Packard + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation; either version 2 of the License, or + * (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, but + * WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + * General Public License for more details. + * + * You should have received a copy of the GNU General Public License along + * with this program; if not, write to the Free Software Foundation, Inc., + * 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA. + */ + +#ifndef _AO_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_INT_ENABLE 0x38 +#define MPU9250_INT_ENABLE_FF_EN 7 +#define MPU9250_INT_ENABLE_MOT_EN 6 +#define MPU9250_INT_ENABLE_ZMOT_EN 5 +#define MPU9250_INT_ENABLE_FIFO_OFLOW_EN 4 +#define MPU9250_INT_ENABLE_I2C_MST_INT_EN 3 +#define MPU9250_INT_ENABLE_DATA_RDY_EN 0 + +#define MPU9250_INT_STATUS 0x3a +#define MPU9250_INT_STATUS_FF_EN 7 +#define MPU9250_INT_STATUS_MOT_EN 6 +#define MPU9250_INT_STATUS_ZMOT_EN 5 +#define MPU9250_INT_STATUS_FIFO_OFLOW_EN 4 +#define MPU9250_INT_STATUS_I2C_MST_INT_EN 3 +#define MPU9250_INT_STATUS_DATA_RDY_EN 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_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 + +/* 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; +}; + +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_ */ -- cgit v1.2.3 From 4431f70044f4e1120d606f0ded1845349295d68e Mon Sep 17 00:00:00 2001 From: Keith Packard Date: Thu, 12 Oct 2017 00:31:26 -0700 Subject: altos: Add MPU9250 support to self test and data The remaining hooks to make the MPU9250 work in flight. Signed-off-by: Keith Packard --- src/kernel/ao.h | 1 + src/kernel/ao_data.h | 12 +++++++++++- 2 files changed, 12 insertions(+), 1 deletion(-) (limited to 'src') 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_data.h b/src/kernel/ao_data.h index d62852ef..9a3b389c 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 +#define AO_DATA_MPU9250 (1 << 2) +#else +#define AO_DATA_MPU9250 0 +#endif + #if HAS_HMC5883 #include #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 -- cgit v1.2.3 From 15af16ad21f67019065763a93d52cea6097a69d1 Mon Sep 17 00:00:00 2001 From: Keith Packard Date: Sun, 22 Oct 2017 15:39:25 -0500 Subject: altos: Remove cross-block storage I/O on cc1111 We don't ever need to be able to do storage read/write across chunks of flash on the old cc1111 products, so remove the loops that support it to save space. Signed-off-by: Keith Packard --- src/cc1111/Makefile.cc1111 | 2 +- src/kernel/ao_storage.c | 161 ++++++++++++++++++++++++++++++++++++++++++++- 2 files changed, 161 insertions(+), 2 deletions(-) (limited to 'src') 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/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 \0Erase " }, { ao_storage_zapall,"Z \0Erase all. is doit with D&I" }, +#if AO_STORAGE_TEST + { ao_storage_test, "V \0Validate flash (destructive). is doit with D&I" }, +#endif { 0, NULL }, }; -- cgit v1.2.3 From 256ddea8c430b4b5dcb8bb95c19ad26032129e1b Mon Sep 17 00:00:00 2001 From: Keith Packard Date: Sun, 22 Oct 2017 15:43:07 -0500 Subject: altos: Define AO_LOG_FORMAT in */ao_pins.h. Use in ao_cmd.c Instead of having a global variable define the log format, use a macro instead to save data space. Signed-off-by: Keith Packard --- src/cc1111/ao_pins.h | 5 +++++ src/easymega-v1.0/ao_pins.h | 4 +++- src/kernel/ao_cmd.c | 2 +- src/teleballoon-v2.0/ao_pins.h | 1 + src/telegps-v0.3/ao_pins.h | 1 + src/telegps-v1.0/ao_pins.h | 1 + src/telegps-v2.0/ao_pins.h | 1 + src/telemega-v0.1/ao_pins.h | 1 + src/telemega-v1.0/ao_pins.h | 1 + src/telemega-v2.0/ao_pins.h | 1 + src/telemetrum-v2.0/ao_pins.h | 1 + src/telemetrum-v3.0/ao_pins.h | 1 + src/telescience-v0.2/ao_pins.h | 1 + src/teleterra-v0.2/ao_pins.h | 2 ++ 14 files changed, 21 insertions(+), 2 deletions(-) (limited to 'src') 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/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_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/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/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 -- cgit v1.2.3 From 83929cd290279963b01b2ccd52c70d61bdeff6b0 Mon Sep 17 00:00:00 2001 From: Keith Packard Date: Sun, 22 Oct 2017 15:44:32 -0500 Subject: altos: Share common logging code. Deal with corrupt initial flight records Move common logging APIs from per-format files into ao_log.c. Then, change that code to check the first log record in a slot (containing the flight number) to see if it's invalid and deal with it. That involves not re-using that slot, and allowing it to be erased. Corrupted log blocks are reported with a negative flight number. Signed-off-by: Keith Packard --- src/kernel/ao_gps_report.c | 12 ++-- src/kernel/ao_gps_report_mega.c | 4 +- src/kernel/ao_gps_report_metrum.c | 8 +-- src/kernel/ao_log.c | 125 ++++++++++++++++++++++++++++++++------ src/kernel/ao_log.h | 69 ++++++++++++++++----- src/kernel/ao_log_big.c | 67 ++------------------ src/kernel/ao_log_gps.c | 77 ++++------------------- src/kernel/ao_log_mega.c | 64 ++----------------- src/kernel/ao_log_metrum.c | 65 ++------------------ src/kernel/ao_log_mini.c | 63 +------------------ src/kernel/ao_log_tiny.c | 4 +- 11 files changed, 199 insertions(+), 359 deletions(-) (limited to 'src') 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_log.c b/src/kernel/ao_log.c index 0589b4b0..08af5b58 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..1c186364 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; @@ -56,15 +56,25 @@ extern __pdata enum ao_flight_state ao_log_state; #define AO_LOG_FORMAT_EASYMINI2 14 /* 16-byte MS5607 baro only, 3.3V supply, stm32f042 SoC */ #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 +473,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 +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 #include -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..d1cf4f13 100644 --- a/src/kernel/ao_log_mega.c +++ b/src/kernel/ao_log_mega.c @@ -21,50 +21,6 @@ #include #include -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 @@ -139,7 +95,7 @@ ao_log(void) log.u.sensor.mag_y = ao_data_ring[ao_log_data_pos].hmc5883.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 +109,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 +122,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 +141,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 #include -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 #include -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; -- cgit v1.2.3 From 5460d7ff46116901bceacd43282b406c446dded5 Mon Sep 17 00:00:00 2001 From: Keith Packard Date: Thu, 2 Nov 2017 09:11:39 -0700 Subject: altos: whitespace cleanup in ao_adc_stm.c Signed-off-by: Keith Packard --- src/stm/ao_adc_stm.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'src') diff --git a/src/stm/ao_adc_stm.c b/src/stm/ao_adc_stm.c index 77f121dc..c3cca5e4 100644 --- a/src/stm/ao_adc_stm.c +++ b/src/stm/ao_adc_stm.c @@ -377,7 +377,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; -- cgit v1.2.3 From 82e552d194216b41d27d805bee2947127c2d555b Mon Sep 17 00:00:00 2001 From: Keith Packard Date: Thu, 2 Nov 2017 09:12:18 -0700 Subject: altos/stm: Add AO_EXTI_MODE_PULL_NONE This is clearer than using '0'. Signed-off-by: Keith Packard --- src/stm/ao_exti.h | 1 + 1 file changed, 1 insertion(+) (limited to 'src') 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 -- cgit v1.2.3 From a2097545dec62cd0970725bf690128dad6baf22e Mon Sep 17 00:00:00 2001 From: Keith Packard Date: Sat, 11 Nov 2017 16:38:40 -0800 Subject: altos/test: Adapt flight test to int16_t flight number type Flight numbers are now limited to 32767 to allow for negative values for corrupted slots. Signed-off-by: Keith Packard --- src/test/ao_flight_test.c | 10 ++++++++-- 1 file changed, 8 insertions(+), 2 deletions(-) (limited to 'src') 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 #include #include +#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; -- cgit v1.2.3 From f3b279141cd30ad6a212ce75f5a7c2b8e3d33870 Mon Sep 17 00:00:00 2001 From: Keith Packard Date: Sat, 11 Nov 2017 20:50:45 -0800 Subject: altos: Fix inverted test for corrupt flight log Was reporting correct flight log as corrupted. Oops. Signed-off-by: Keith Packard --- src/kernel/ao_log.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'src') diff --git a/src/kernel/ao_log.c b/src/kernel/ao_log.c index 08af5b58..f70c7232 100644 --- a/src/kernel/ao_log.c +++ b/src/kernel/ao_log.c @@ -183,7 +183,7 @@ ao_log_flight(uint8_t slot) if (ao_log_check_clear()) return 0; - if (ao_log_check_data() || log.type != AO_LOG_FLIGHT) + if (!ao_log_check_data() || log.type != AO_LOG_FLIGHT) return -(int16_t) (slot + 1); return log.u.flight.flight; -- cgit v1.2.3 From 23cf8fb4d5745ad76d9517c9702d03d10c58144a Mon Sep 17 00:00:00 2001 From: Keith Packard Date: Sat, 11 Nov 2017 20:52:01 -0800 Subject: altos: Fix new GCC warnings * Duplicate 'const' in test code. * Mis-formatted loop in kf_rem_pio2 * Unused 'one' in sf_cos Signed-off-by: Keith Packard --- src/kernel/ao_host.h | 2 +- src/math/kf_rem_pio2.c | 3 ++- src/math/sf_cos.c | 6 ------ 3 files changed, 3 insertions(+), 8 deletions(-) (limited to 'src') 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/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 @@ -15,12 +15,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 -- cgit v1.2.3 From bd881a5b85d7cd4fb82127f92f32e089499b50cb Mon Sep 17 00:00:00 2001 From: Keith Packard Date: Thu, 16 Nov 2017 13:02:07 -0800 Subject: altos/lisp: Add non-cons cdr support The cdr of a cons can be any value; add support for lexing and printing them. Signed-off-by: Keith Packard --- src/lisp/ao_lisp.h | 5 ++- src/lisp/ao_lisp_builtin.c | 14 +++---- src/lisp/ao_lisp_cons.c | 25 +++++++++--- src/lisp/ao_lisp_eval.c | 2 +- src/lisp/ao_lisp_mem.c | 2 +- src/lisp/ao_lisp_read.c | 96 ++++++++++++++++++++++++++++++---------------- src/lisp/ao_lisp_read.h | 4 +- src/lisp/ao_lisp_string.c | 2 +- 8 files changed, 98 insertions(+), 52 deletions(-) (limited to 'src') diff --git a/src/lisp/ao_lisp.h b/src/lisp/ao_lisp.h index 980514cc..79f8fcc3 100644 --- a/src/lisp/ao_lisp.h +++ b/src/lisp/ao_lisp.h @@ -499,7 +499,10 @@ ao_lisp_stack_fetch(int id) { 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); +ao_lisp_cons_cons(ao_poly car, ao_poly cdr); + +ao_poly +ao_lisp__cons(ao_poly car, ao_poly cdr); extern struct ao_lisp_cons *ao_lisp_cons_free_list; diff --git a/src/lisp/ao_lisp_builtin.c b/src/lisp/ao_lisp_builtin.c index 902f60e2..5a960873 100644 --- a/src/lisp/ao_lisp_builtin.c +++ b/src/lisp/ao_lisp_builtin.c @@ -190,11 +190,9 @@ 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))); + return ao_lisp__cons(car, cdr); } ao_poly @@ -247,14 +245,12 @@ ao_lisp_set(struct ao_lisp_cons *cons) 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); + return ao_lisp__cons(_ao_lisp_atom_set, + ao_lisp__cons(ao_lisp__cons(_ao_lisp_atom_quote, + ao_lisp__cons(cons->car, AO_LISP_NIL)), + cons->cdr)); } ao_poly diff --git a/src/lisp/ao_lisp_cons.c b/src/lisp/ao_lisp_cons.c index d2b60c9a..81a16a7a 100644 --- a/src/lisp/ao_lisp_cons.c +++ b/src/lisp/ao_lisp_cons.c @@ -72,7 +72,7 @@ const struct ao_lisp_type ao_lisp_cons_type = { 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) +ao_lisp_cons_cons(ao_poly car, ao_poly cdr) { struct ao_lisp_cons *cons; @@ -81,18 +81,24 @@ ao_lisp_cons_cons(ao_poly car, struct ao_lisp_cons *cdr) ao_lisp_cons_free_list = ao_lisp_poly_cons(cons->cdr); } else { ao_lisp_poly_stash(0, car); - ao_lisp_cons_stash(0, cdr); + ao_lisp_poly_stash(1, cdr); cons = ao_lisp_alloc(sizeof (struct ao_lisp_cons)); car = ao_lisp_poly_fetch(0); - cdr = ao_lisp_cons_fetch(0); + cdr = ao_lisp_poly_fetch(1); if (!cons) return NULL; } cons->car = car; - cons->cdr = ao_lisp_cons_poly(cdr); + cons->cdr = cdr; return cons; } +ao_poly +ao_lisp__cons(ao_poly car, ao_poly cdr) +{ + return ao_lisp_cons_poly(ao_lisp_cons_cons(car, cdr)); +} + void ao_lisp_cons_free(struct ao_lisp_cons *cons) { @@ -114,8 +120,15 @@ ao_lisp_cons_print(ao_poly c) if (!first) printf(" "); ao_lisp_poly_print(cons->car); - cons = ao_lisp_poly_cons(cons->cdr); - first = 0; + c = cons->cdr; + if (ao_lisp_poly_type(c) == AO_LISP_CONS) { + cons = ao_lisp_poly_cons(c); + first = 0; + } else { + printf(" . "); + ao_lisp_poly_print(c); + cons = NULL; + } } printf(")"); } diff --git a/src/lisp/ao_lisp_eval.c b/src/lisp/ao_lisp_eval.c index 3be7c9c4..3e68d14a 100644 --- a/src/lisp/ao_lisp_eval.c +++ b/src/lisp/ao_lisp_eval.c @@ -210,7 +210,7 @@ ao_lisp_eval_formal(void) } /* Append formal to list of values */ - formal = ao_lisp_cons_poly(ao_lisp_cons_cons(ao_lisp_v, NULL)); + formal = ao_lisp__cons(ao_lisp_v, AO_LISP_NIL); if (!formal) return 0; diff --git a/src/lisp/ao_lisp_mem.c b/src/lisp/ao_lisp_mem.c index d067ea07..d7c8d7a6 100644 --- a/src/lisp/ao_lisp_mem.c +++ b/src/lisp/ao_lisp_mem.c @@ -437,7 +437,7 @@ dump_busy(void) #define DUMP_BUSY() #endif -static const struct ao_lisp_type const *ao_lisp_types[AO_LISP_NUM_TYPE] = { +static const struct ao_lisp_type *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, diff --git a/src/lisp/ao_lisp_read.c b/src/lisp/ao_lisp_read.c index 84ef2a61..550f62c2 100644 --- a/src/lisp/ao_lisp_read.c +++ b/src/lisp/ao_lisp_read.c @@ -62,7 +62,7 @@ static const uint16_t lex_classes[128] = { PRINTABLE|SIGN, /* + */ PRINTABLE, /* , */ PRINTABLE|SIGN, /* - */ - PRINTABLE, /* . */ + PRINTABLE|DOTC, /* . */ PRINTABLE, /* / */ PRINTABLE|DIGIT, /* 0 */ PRINTABLE|DIGIT, /* 1 */ @@ -262,7 +262,7 @@ static inline void end_token(void) { } static int -lex(void) +_lex(void) { int c; @@ -295,6 +295,11 @@ lex(void) return QUOTE; } } + if (lex_class & (DOTC)) { + add_token(c); + end_token(); + return DOT; + } if (lex_class & TWIDDLE) { token_int = lexc(); return NUM; @@ -355,21 +360,32 @@ lex(void) } } +static inline int lex(void) +{ + int parse_token = _lex(); + DBGI("token %d (%s)\n", parse_token, token_string); + return parse_token; +} + 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; +#define READ_IN_QUOTE 0x01 +#define READ_SAW_DOT 0x02 +#define READ_DONE_DOT 0x04 + static int -push_read_stack(int cons, int in_quote) +push_read_stack(int cons, int read_state) { - DBGI("push read stack %p %d\n", ao_lisp_read_cons, in_quote); + DBGI("push read stack %p 0x%x\n", ao_lisp_read_cons, read_state); 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)); + ao_lisp__cons(ao_lisp_int_poly(read_state), + ao_lisp_cons_poly(ao_lisp_read_stack))); if (!ao_lisp_read_stack) return 0; } @@ -381,11 +397,11 @@ push_read_stack(int cons, int in_quote) static int pop_read_stack(int cons) { - int in_quote = 0; + int read_state = 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); + read_state = 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; @@ -397,8 +413,8 @@ pop_read_stack(int cons) ao_lisp_read_stack = 0; } DBG_OUT(); - DBGI("pop read stack %p %d\n", ao_lisp_read_cons, in_quote); - return in_quote; + DBGI("pop read stack %p %d\n", ao_lisp_read_cons, read_state); + return read_state; } ao_poly @@ -407,23 +423,21 @@ ao_lisp_read(void) struct ao_lisp_atom *atom; char *string; int cons; - int in_quote; + int read_state; ao_poly v; - parse_token = lex(); - DBGI("token %d (%s)\n", parse_token, token_string); cons = 0; - in_quote = 0; + read_state = 0; ao_lisp_read_cons = ao_lisp_read_cons_tail = ao_lisp_read_stack = 0; for (;;) { + parse_token = lex(); while (parse_token == OPEN) { - if (!push_read_stack(cons, in_quote)) + if (!push_read_stack(cons, read_state)) return AO_LISP_NIL; cons++; - in_quote = 0; + read_state = 0; parse_token = lex(); - DBGI("token %d (%s)\n", parse_token, token_string); } switch (parse_token) { @@ -451,10 +465,10 @@ ao_lisp_read(void) v = AO_LISP_NIL; break; case QUOTE: - if (!push_read_stack(cons, in_quote)) + if (!push_read_stack(cons, read_state)) return AO_LISP_NIL; cons++; - in_quote = 1; + read_state |= READ_IN_QUOTE; v = _ao_lisp_atom_quote; break; case CLOSE: @@ -464,8 +478,19 @@ ao_lisp_read(void) } v = ao_lisp_cons_poly(ao_lisp_read_cons); --cons; - in_quote = pop_read_stack(cons); + read_state = pop_read_stack(cons); break; + case DOT: + if (!cons) { + ao_lisp_error(AO_LISP_INVALID, ". outside of cons"); + return AO_LISP_NIL; + } + if (!ao_lisp_read_cons) { + ao_lisp_error(AO_LISP_INVALID, ". first in cons"); + return AO_LISP_NIL; + } + read_state |= READ_SAW_DOT; + continue; } /* loop over QUOTE ends */ @@ -473,26 +498,33 @@ ao_lisp_read(void) if (!cons) return v; - struct ao_lisp_cons *read = ao_lisp_cons_cons(v, NULL); - if (!read) + if (read_state & READ_DONE_DOT) { + ao_lisp_error(AO_LISP_INVALID, ". not last in cons"); 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 (read_state & READ_SAW_DOT) { + read_state |= READ_DONE_DOT; + ao_lisp_read_cons_tail->cdr = v; + } else { + struct ao_lisp_cons *read = ao_lisp_cons_cons(v, AO_LISP_NIL); + if (!read) + return AO_LISP_NIL; - if (!in_quote || !ao_lisp_read_cons->cdr) + 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 (!(read_state & READ_IN_QUOTE) || !ao_lisp_read_cons->cdr) break; v = ao_lisp_cons_poly(ao_lisp_read_cons); --cons; - in_quote = pop_read_stack(cons); + read_state = 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 index 1c994d56..30dcac3f 100644 --- a/src/lisp/ao_lisp_read.h +++ b/src/lisp/ao_lisp_read.h @@ -22,6 +22,7 @@ # define QUOTE 4 # define STRING 5 # define NUM 6 +# define DOT 7 /* * character classes @@ -42,8 +43,9 @@ # define VBAR 0x00001000 /* | */ # define TWIDDLE 0x00002000 /* ~ */ # define STRINGC 0x00004000 /* " */ +# define DOTC 0x00008000 /* . */ -# define NOTNAME (STRINGC|TWIDDLE|VBAR|QUOTEC|COMMENT|ENDOFFILE|WHITE|KET|BRA) +# define NOTNAME (STRINGC|TWIDDLE|VBAR|QUOTEC|COMMENT|ENDOFFILE|WHITE|KET|BRA|DOTC) # define NUMBER (DIGIT|SIGN) #endif /* _AO_LISP_READ_H_ */ diff --git a/src/lisp/ao_lisp_string.c b/src/lisp/ao_lisp_string.c index cd7b27a9..af23f7b3 100644 --- a/src/lisp/ao_lisp_string.c +++ b/src/lisp/ao_lisp_string.c @@ -103,7 +103,7 @@ ao_lisp_string_unpack(char *a) 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); + struct ao_lisp_cons *n = ao_lisp_cons_cons(ao_lisp_int_poly(c), AO_LISP_NIL); a = ao_lisp_string_fetch(0); cons = ao_lisp_cons_fetch(0); tail = ao_lisp_cons_fetch(1); -- cgit v1.2.3 From b3b4731fcb89cb404433f37a7704a503567c43bd Mon Sep 17 00:00:00 2001 From: Keith Packard Date: Thu, 16 Nov 2017 17:49:47 -0800 Subject: altos/lisp: Add scheme-style bools (#t and #f) Cond and while compare against #f, just like scheme says to. Signed-off-by: Keith Packard --- src/lisp/.gitignore | 1 + src/lisp/Makefile | 10 +- src/lisp/Makefile-inc | 5 +- src/lisp/ao_lisp.h | 165 ++++++++++++++------------------ src/lisp/ao_lisp_bool.c | 73 ++++++++++++++ src/lisp/ao_lisp_builtin.c | 216 ++++++++++++++++-------------------------- src/lisp/ao_lisp_builtin.txt | 40 ++++++++ src/lisp/ao_lisp_const.lisp | 29 +++--- src/lisp/ao_lisp_eval.c | 5 +- src/lisp/ao_lisp_lambda.c | 8 +- src/lisp/ao_lisp_make_builtin | 149 +++++++++++++++++++++++++++++ src/lisp/ao_lisp_make_const.c | 55 ++--------- src/lisp/ao_lisp_mem.c | 11 +++ src/lisp/ao_lisp_poly.c | 4 + src/lisp/ao_lisp_read.c | 39 +++++--- src/lisp/ao_lisp_read.h | 37 ++++---- src/lisp/ao_lisp_rep.c | 2 +- src/lisp/ao_lisp_save.c | 14 +-- src/lisp/ao_lisp_stack.c | 2 +- 19 files changed, 528 insertions(+), 337 deletions(-) create mode 100644 src/lisp/ao_lisp_bool.c create mode 100644 src/lisp/ao_lisp_builtin.txt create mode 100644 src/lisp/ao_lisp_make_builtin (limited to 'src') diff --git a/src/lisp/.gitignore b/src/lisp/.gitignore index 76a555ea..1faa9b67 100644 --- a/src/lisp/.gitignore +++ b/src/lisp/.gitignore @@ -1,2 +1,3 @@ ao_lisp_make_const ao_lisp_const.h +ao_lisp_builtin.h diff --git a/src/lisp/Makefile b/src/lisp/Makefile index 25796ec5..4563dad3 100644 --- a/src/lisp/Makefile +++ b/src/lisp/Makefile @@ -1,13 +1,16 @@ -all: ao_lisp_const.h +all: ao_lisp_builtin.h ao_lisp_const.h clean: - rm -f ao_lisp_const.h $(OBJS) ao_lisp_make_const + rm -f ao_lisp_const.h ao_lisp_builtin.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 +ao_lisp_builtin.h: ao_lisp_make_builtin ao_lisp_builtin.txt + nickle ./ao_lisp_make_builtin ao_lisp_builtin.txt > $@ + include Makefile-inc -SRCS=$(LISP_SRCS) +SRCS=$(LISP_SRCS) ao_lisp_make_const.c HDRS=$(LISP_HDRS) @@ -15,7 +18,6 @@ OBJS=$(SRCS:.c=.o) CFLAGS=-DAO_LISP_MAKE_CONST -O0 -g -I. -Wall -Wextra -no-pie - ao_lisp_make_const: $(OBJS) $(CC) $(CFLAGS) -o $@ $(OBJS) diff --git a/src/lisp/Makefile-inc b/src/lisp/Makefile-inc index 126deeb0..6c8702fb 100644 --- a/src/lisp/Makefile-inc +++ b/src/lisp/Makefile-inc @@ -1,11 +1,11 @@ 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_bool.c \ ao_lisp_builtin.c \ ao_lisp_read.c \ ao_lisp_frame.c \ @@ -19,4 +19,5 @@ LISP_SRCS=\ LISP_HDRS=\ ao_lisp.h \ ao_lisp_os.h \ - ao_lisp_read.h + ao_lisp_read.h \ + ao_lisp_builtin.h diff --git a/src/lisp/ao_lisp.h b/src/lisp/ao_lisp.h index 79f8fcc3..cd002cc2 100644 --- a/src/lisp/ao_lisp.h +++ b/src/lisp/ao_lisp.h @@ -54,35 +54,37 @@ 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?") +#define _atom(n) ao_lisp_atom_poly(ao_lisp_atom_intern(#n)) +#define _bool(v) ao_lisp_bool_poly(ao_lisp_bool_get(v)) + +#define _ao_lisp_bool_true _bool(1) +#define _ao_lisp_bool_false _bool(0) +#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_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 @@ -108,7 +110,8 @@ extern uint8_t ao_lisp_pool[AO_LISP_POOL + AO_LISP_POOL_EXTRA] __attribute__((a #define AO_LISP_FRAME 6 #define AO_LISP_LAMBDA 7 #define AO_LISP_STACK 8 -#define AO_LISP_NUM_TYPE 9 +#define AO_LISP_BOOL 9 +#define AO_LISP_NUM_TYPE 10 /* Leave two bits for types to use as they please */ #define AO_LISP_OTHER_TYPE_MASK 0x3f @@ -171,6 +174,12 @@ struct ao_lisp_frame { struct ao_lisp_val vals[]; }; +struct ao_lisp_bool { + uint8_t type; + uint8_t value; + uint16_t pad; +}; + /* Set on type when the frame escapes the lambda */ #define AO_LISP_FRAME_MARK 0x80 #define AO_LISP_FRAME_PRINT 0x40 @@ -257,47 +266,8 @@ struct ao_lisp_builtin { 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 -}; +#define AO_LISP_BUILTIN_ID +#include "ao_lisp_builtin.h" typedef ao_poly (*ao_lisp_func_t)(struct ao_lisp_cons *cons); @@ -433,6 +403,17 @@ ao_lisp_builtin_poly(struct ao_lisp_builtin *b) return ao_lisp_poly(b, AO_LISP_OTHER); } +static inline ao_poly +ao_lisp_bool_poly(struct ao_lisp_bool *b) +{ + return ao_lisp_poly(b, AO_LISP_OTHER); +} + +static inline struct ao_lisp_bool * +ao_lisp_poly_bool(ao_poly poly) +{ + return ao_lisp_ref(poly); +} /* memory functions */ extern int ao_lisp_collects[2]; @@ -495,6 +476,20 @@ ao_lisp_stack_fetch(int id) { return ao_lisp_poly_stack(ao_lisp_poly_fetch(id)); } +/* bool */ + +extern const struct ao_lisp_type ao_lisp_bool_type; + +void +ao_lisp_bool_print(ao_poly v); + +#ifdef AO_LISP_MAKE_CONST +struct ao_lisp_bool *ao_lisp_true, *ao_lisp_false; + +struct ao_lisp_bool * +ao_lisp_bool_get(uint8_t value); +#endif + /* cons */ extern const struct ao_lisp_type ao_lisp_cons_type; @@ -665,29 +660,9 @@ 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; @@ -712,9 +687,6 @@ 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 @@ -726,6 +698,11 @@ ao_lisp_error_frame(int indent, char *name, struct ao_lisp_frame *frame); ao_poly ao_lisp_error(int error, char *format, ...); +/* builtins */ + +#define AO_LISP_BUILTIN_DECLS +#include "ao_lisp_builtin.h" + /* debugging macros */ #if DBG_EVAL diff --git a/src/lisp/ao_lisp_bool.c b/src/lisp/ao_lisp_bool.c new file mode 100644 index 00000000..ad25afba --- /dev/null +++ b/src/lisp/ao_lisp_bool.c @@ -0,0 +1,73 @@ +/* + * Copyright © 2017 Keith Packard + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation, either version 2 of the License, or + * (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, but + * WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + * General Public License for more details. + */ + +#include "ao_lisp.h" + +static void bool_mark(void *addr) +{ + (void) addr; +} + +static int bool_size(void *addr) +{ + (void) addr; + return sizeof (struct ao_lisp_bool); +} + +static void bool_move(void *addr) +{ + (void) addr; +} + +const struct ao_lisp_type ao_lisp_bool_type = { + .mark = bool_mark, + .size = bool_size, + .move = bool_move, + .name = "bool" +}; + +void +ao_lisp_bool_print(ao_poly v) +{ + struct ao_lisp_bool *b = ao_lisp_poly_bool(v); + + if (b->value) + printf("#t"); + else + printf("#f"); +} + +#ifdef AO_LISP_MAKE_CONST + +struct ao_lisp_bool *ao_lisp_true, *ao_lisp_false; + +struct ao_lisp_bool * +ao_lisp_bool_get(uint8_t value) +{ + struct ao_lisp_bool **b; + + if (value) + b = &ao_lisp_true; + else + b = &ao_lisp_false; + + if (!*b) { + *b = ao_lisp_alloc(sizeof (struct ao_lisp_bool)); + (*b)->type = AO_LISP_BOOL; + (*b)->value = value; + } + return *b; +} + +#endif diff --git a/src/lisp/ao_lisp_builtin.c b/src/lisp/ao_lisp_builtin.c index 5a960873..6fc28820 100644 --- a/src/lisp/ao_lisp_builtin.c +++ b/src/lisp/ao_lisp_builtin.c @@ -40,61 +40,26 @@ const struct ao_lisp_type ao_lisp_builtin_type = { }; #ifdef AO_LISP_MAKE_CONST -char *ao_lisp_builtin_name(enum ao_lisp_builtin_id b) { - (void) b; - return "???"; -} + +#define AO_LISP_BUILTIN_CASENAME +#include "ao_lisp_builtin.h" + +#define _atomn(n) ao_lisp_poly_atom(_atom(n)) + char *ao_lisp_args_name(uint8_t args) { - (void) args; - return "???"; + args &= AO_LISP_FUNC_MASK; + switch (args) { + case AO_LISP_FUNC_LAMBDA: return _atomn(lambda)->name; + case AO_LISP_FUNC_LEXPR: return _atomn(lexpr)->name; + case AO_LISP_FUNC_NLAMBDA: return _atomn(nlambda)->name; + case AO_LISP_FUNC_MACRO: return _atomn(macro)->name; + default: 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 -}; + +#define AO_LISP_BUILTIN_ARRAYNAME +#include "ao_lisp_builtin.h" static char * ao_lisp_builtin_name(enum ao_lisp_builtin_id b) { @@ -138,7 +103,7 @@ ao_lisp_check_argc(ao_poly name, struct ao_lisp_cons *cons, int min, int max) } 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; + return _ao_lisp_bool_true; } ao_poly @@ -161,11 +126,11 @@ ao_lisp_check_argt(ao_poly name, struct ao_lisp_cons *cons, int argc, int type, 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; + return _ao_lisp_bool_true; } ao_poly -ao_lisp_car(struct ao_lisp_cons *cons) +ao_lisp_do_car(struct ao_lisp_cons *cons) { if (!ao_lisp_check_argc(_ao_lisp_atom_car, cons, 1, 1)) return AO_LISP_NIL; @@ -175,7 +140,7 @@ ao_lisp_car(struct ao_lisp_cons *cons) } ao_poly -ao_lisp_cdr(struct ao_lisp_cons *cons) +ao_lisp_do_cdr(struct ao_lisp_cons *cons) { if (!ao_lisp_check_argc(_ao_lisp_atom_cdr, cons, 1, 1)) return AO_LISP_NIL; @@ -185,7 +150,7 @@ ao_lisp_cdr(struct ao_lisp_cons *cons) } ao_poly -ao_lisp_cons(struct ao_lisp_cons *cons) +ao_lisp_do_cons(struct ao_lisp_cons *cons) { ao_poly car, cdr; if(!ao_lisp_check_argc(_ao_lisp_atom_cons, cons, 2, 2)) @@ -196,7 +161,7 @@ ao_lisp_cons(struct ao_lisp_cons *cons) } ao_poly -ao_lisp_last(struct ao_lisp_cons *cons) +ao_lisp_do_last(struct ao_lisp_cons *cons) { ao_poly l; if (!ao_lisp_check_argc(_ao_lisp_atom_last, cons, 1, 1)) @@ -214,7 +179,7 @@ ao_lisp_last(struct ao_lisp_cons *cons) } ao_poly -ao_lisp_length(struct ao_lisp_cons *cons) +ao_lisp_do_length(struct ao_lisp_cons *cons) { if (!ao_lisp_check_argc(_ao_lisp_atom_length, cons, 1, 1)) return AO_LISP_NIL; @@ -224,7 +189,7 @@ ao_lisp_length(struct ao_lisp_cons *cons) } ao_poly -ao_lisp_quote(struct ao_lisp_cons *cons) +ao_lisp_do_quote(struct ao_lisp_cons *cons) { if (!ao_lisp_check_argc(_ao_lisp_atom_quote, cons, 1, 1)) return AO_LISP_NIL; @@ -232,7 +197,7 @@ ao_lisp_quote(struct ao_lisp_cons *cons) } ao_poly -ao_lisp_set(struct ao_lisp_cons *cons) +ao_lisp_do_set(struct ao_lisp_cons *cons) { if (!ao_lisp_check_argc(_ao_lisp_atom_set, cons, 2, 2)) return AO_LISP_NIL; @@ -243,7 +208,7 @@ ao_lisp_set(struct ao_lisp_cons *cons) } ao_poly -ao_lisp_setq(struct ao_lisp_cons *cons) +ao_lisp_do_setq(struct ao_lisp_cons *cons) { if (!ao_lisp_check_argc(_ao_lisp_atom_setq, cons, 2, 2)) return AO_LISP_NIL; @@ -254,14 +219,14 @@ ao_lisp_setq(struct ao_lisp_cons *cons) } ao_poly -ao_lisp_cond(struct ao_lisp_cons *cons) +ao_lisp_do_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_do_progn(struct ao_lisp_cons *cons) { ao_lisp_stack->state = eval_progn; ao_lisp_stack->sexprs = ao_lisp_cons_poly(cons); @@ -269,7 +234,7 @@ ao_lisp_progn(struct ao_lisp_cons *cons) } ao_poly -ao_lisp_while(struct ao_lisp_cons *cons) +ao_lisp_do_while(struct ao_lisp_cons *cons) { ao_lisp_stack->state = eval_while; ao_lisp_stack->sexprs = ao_lisp_cons_poly(cons); @@ -277,7 +242,7 @@ ao_lisp_while(struct ao_lisp_cons *cons) } ao_poly -ao_lisp_print(struct ao_lisp_cons *cons) +ao_lisp_do_print(struct ao_lisp_cons *cons) { ao_poly val = AO_LISP_NIL; while (cons) { @@ -292,7 +257,7 @@ ao_lisp_print(struct ao_lisp_cons *cons) } ao_poly -ao_lisp_patom(struct ao_lisp_cons *cons) +ao_lisp_do_patom(struct ao_lisp_cons *cons) { ao_poly val = AO_LISP_NIL; while (cons) { @@ -358,31 +323,31 @@ ao_lisp_math(struct ao_lisp_cons *cons, enum ao_lisp_builtin_id op) } ao_poly -ao_lisp_plus(struct ao_lisp_cons *cons) +ao_lisp_do_plus(struct ao_lisp_cons *cons) { return ao_lisp_math(cons, builtin_plus); } ao_poly -ao_lisp_minus(struct ao_lisp_cons *cons) +ao_lisp_do_minus(struct ao_lisp_cons *cons) { return ao_lisp_math(cons, builtin_minus); } ao_poly -ao_lisp_times(struct ao_lisp_cons *cons) +ao_lisp_do_times(struct ao_lisp_cons *cons) { return ao_lisp_math(cons, builtin_times); } ao_poly -ao_lisp_divide(struct ao_lisp_cons *cons) +ao_lisp_do_divide(struct ao_lisp_cons *cons) { return ao_lisp_math(cons, builtin_divide); } ao_poly -ao_lisp_mod(struct ao_lisp_cons *cons) +ao_lisp_do_mod(struct ao_lisp_cons *cons) { return ao_lisp_math(cons, builtin_mod); } @@ -393,7 +358,7 @@ ao_lisp_compare(struct ao_lisp_cons *cons, enum ao_lisp_builtin_id op) ao_poly left; if (!cons) - return _ao_lisp_atom_t; + return _ao_lisp_bool_true; left = cons->car; cons = ao_lisp_poly_cons(cons->cdr); @@ -402,7 +367,7 @@ ao_lisp_compare(struct ao_lisp_cons *cons, enum ao_lisp_builtin_id op) if (op == builtin_equal) { if (left != right) - return AO_LISP_NIL; + return _ao_lisp_bool_false; } else { uint8_t lt = ao_lisp_poly_type(left); uint8_t rt = ao_lisp_poly_type(right); @@ -413,19 +378,19 @@ ao_lisp_compare(struct ao_lisp_cons *cons, enum ao_lisp_builtin_id op) switch (op) { case builtin_less: if (!(l < r)) - return AO_LISP_NIL; + return _ao_lisp_bool_false; break; case builtin_greater: if (!(l > r)) - return AO_LISP_NIL; + return _ao_lisp_bool_false; break; case builtin_less_equal: if (!(l <= r)) - return AO_LISP_NIL; + return _ao_lisp_bool_false; break; case builtin_greater_equal: if (!(l >= r)) - return AO_LISP_NIL; + return _ao_lisp_bool_false; break; default: break; @@ -436,19 +401,19 @@ ao_lisp_compare(struct ao_lisp_cons *cons, enum ao_lisp_builtin_id op) switch (op) { case builtin_less: if (!(c < 0)) - return AO_LISP_NIL; + return _ao_lisp_bool_false; break; case builtin_greater: if (!(c > 0)) - return AO_LISP_NIL; + return _ao_lisp_bool_false; break; case builtin_less_equal: if (!(c <= 0)) - return AO_LISP_NIL; + return _ao_lisp_bool_false; break; case builtin_greater_equal: if (!(c >= 0)) - return AO_LISP_NIL; + return _ao_lisp_bool_false; break; default: break; @@ -458,41 +423,41 @@ ao_lisp_compare(struct ao_lisp_cons *cons, enum ao_lisp_builtin_id op) left = right; cons = ao_lisp_poly_cons(cons->cdr); } - return _ao_lisp_atom_t; + return _ao_lisp_bool_true; } ao_poly -ao_lisp_equal(struct ao_lisp_cons *cons) +ao_lisp_do_equal(struct ao_lisp_cons *cons) { return ao_lisp_compare(cons, builtin_equal); } ao_poly -ao_lisp_less(struct ao_lisp_cons *cons) +ao_lisp_do_less(struct ao_lisp_cons *cons) { return ao_lisp_compare(cons, builtin_less); } ao_poly -ao_lisp_greater(struct ao_lisp_cons *cons) +ao_lisp_do_greater(struct ao_lisp_cons *cons) { return ao_lisp_compare(cons, builtin_greater); } ao_poly -ao_lisp_less_equal(struct ao_lisp_cons *cons) +ao_lisp_do_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) +ao_lisp_do_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) +ao_lisp_do_pack(struct ao_lisp_cons *cons) { if (!ao_lisp_check_argc(_ao_lisp_atom_pack, cons, 1, 1)) return AO_LISP_NIL; @@ -502,7 +467,7 @@ ao_lisp_pack(struct ao_lisp_cons *cons) } ao_poly -ao_lisp_unpack(struct ao_lisp_cons *cons) +ao_lisp_do_unpack(struct ao_lisp_cons *cons) { if (!ao_lisp_check_argc(_ao_lisp_atom_unpack, cons, 1, 1)) return AO_LISP_NIL; @@ -512,16 +477,16 @@ ao_lisp_unpack(struct ao_lisp_cons *cons) } ao_poly -ao_lisp_flush(struct ao_lisp_cons *cons) +ao_lisp_do_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; + return _ao_lisp_bool_true; } ao_poly -ao_lisp_led(struct ao_lisp_cons *cons) +ao_lisp_do_led(struct ao_lisp_cons *cons) { ao_poly led; if (!ao_lisp_check_argc(_ao_lisp_atom_led, cons, 1, 1)) @@ -534,7 +499,7 @@ ao_lisp_led(struct ao_lisp_cons *cons) } ao_poly -ao_lisp_delay(struct ao_lisp_cons *cons) +ao_lisp_do_delay(struct ao_lisp_cons *cons) { ao_poly delay; if (!ao_lisp_check_argc(_ao_lisp_atom_led, cons, 1, 1)) @@ -572,44 +537,27 @@ ao_lisp_do_collect(struct ao_lisp_cons *cons) 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, -}; +ao_poly +ao_lisp_do_nullp(struct ao_lisp_cons *cons) +{ + if (!ao_lisp_check_argc(_ao_lisp_atom_led, cons, 1, 1)) + return AO_LISP_NIL; + if (ao_lisp_arg(cons, 0) == AO_LISP_NIL) + return _ao_lisp_bool_true; + else + return _ao_lisp_bool_false; +} + +ao_poly +ao_lisp_do_not(struct ao_lisp_cons *cons) +{ + if (!ao_lisp_check_argc(_ao_lisp_atom_led, cons, 1, 1)) + return AO_LISP_NIL; + if (ao_lisp_arg(cons, 0) == _ao_lisp_bool_false) + return _ao_lisp_bool_true; + else + return _ao_lisp_bool_false; +} +#define AO_LISP_BUILTIN_FUNCS +#include "ao_lisp_builtin.h" diff --git a/src/lisp/ao_lisp_builtin.txt b/src/lisp/ao_lisp_builtin.txt new file mode 100644 index 00000000..02320df0 --- /dev/null +++ b/src/lisp/ao_lisp_builtin.txt @@ -0,0 +1,40 @@ +lambda eval +lambda read +nlambda lambda +nlambda lexpr +nlambda nlambda +nlambda macro +lambda car +lambda cdr +lambda cons +lambda last +lambda length +nlambda quote +lambda set +macro setq +nlambda cond +nlambda progn +nlambda while +lexpr print +lexpr patom +lexpr plus + +lexpr minus - +lexpr times * +lexpr divide / +lexpr mod % +lexpr equal = +lexpr less < +lexpr greater > +lexpr less_equal <= +lexpr greater_equal >= +lambda pack +lambda unpack +lambda flush +lambda delay +lexpr led +lambda save +lambda restore +lambda call_cc call/cc +lambda collect +lambda nullp null? +lambda not diff --git a/src/lisp/ao_lisp_const.lisp b/src/lisp/ao_lisp_const.lisp index 3c8fd21b..df277fce 100644 --- a/src/lisp/ao_lisp_const.lisp +++ b/src/lisp/ao_lisp_const.lisp @@ -95,7 +95,7 @@ ; (setq make-names (lambda (vars) - (cond (vars + (cond ((not (null? vars)) (cons (car (car vars)) (make-names (cdr vars)))) ) @@ -108,7 +108,7 @@ ; expressions to evaluate (setq make-exprs (lambda (vars exprs) - (cond (vars (cons + (cond ((not (null? vars)) (cons (list set (list quote (car (car vars)) @@ -127,7 +127,7 @@ ; of nils of the right length (setq make-nils (lambda (vars) - (cond (vars (cons nil (make-nils (cdr vars)))) + (cond ((not (null? vars)) (cons () (make-nils (cdr vars)))) ) ) ) @@ -149,13 +149,14 @@ ) ) +(let ((x 1)) x) + ; boolean operators (def or (lexpr (l) - (let ((ret nil)) - (while l - (cond ((setq ret (car l)) - (setq l nil)) + (let ((ret #f)) + (while (not (null? l)) + (cond ((car l) (setq ret #t) (setq l ())) ((setq l (cdr l))))) ret ) @@ -164,14 +165,16 @@ ; execute to resolve macros -(or nil t) +(or #f #t) (def and (lexpr (l) - (let ((ret t)) - (while l - (cond ((setq ret (car l)) + (let ((ret #t)) + (while (not (null? l)) + (cond ((car l) (setq l (cdr l))) - ((setq ret (setq l nil))) + (#t + (setq ret #f) + (setq l ())) ) ) ret @@ -181,4 +184,4 @@ ; execute to resolve macros -(and t nil) +(and #t #f) diff --git a/src/lisp/ao_lisp_eval.c b/src/lisp/ao_lisp_eval.c index 3e68d14a..b6cb4fd8 100644 --- a/src/lisp/ao_lisp_eval.c +++ b/src/lisp/ao_lisp_eval.c @@ -107,6 +107,7 @@ ao_lisp_eval_sexpr(void) 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_BOOL: case AO_LISP_INT: case AO_LISP_STRING: case AO_LISP_BUILTIN: @@ -345,7 +346,7 @@ 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) { + if (ao_lisp_v != _ao_lisp_bool_false) { struct ao_lisp_cons *car = ao_lisp_poly_cons(ao_lisp_poly_cons(ao_lisp_stack->sexprs)->car); ao_poly c = car->cdr; @@ -432,7 +433,7 @@ ao_lisp_eval_while_test(void) 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) { + if (ao_lisp_v != _ao_lisp_bool_false) { 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; diff --git a/src/lisp/ao_lisp_lambda.c b/src/lisp/ao_lisp_lambda.c index 526863c5..cc333d6f 100644 --- a/src/lisp/ao_lisp_lambda.c +++ b/src/lisp/ao_lisp_lambda.c @@ -98,25 +98,25 @@ ao_lisp_lambda_alloc(struct ao_lisp_cons *code, int args) } ao_poly -ao_lisp_lambda(struct ao_lisp_cons *cons) +ao_lisp_do_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) +ao_lisp_do_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) +ao_lisp_do_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) +ao_lisp_do_macro(struct ao_lisp_cons *cons) { return ao_lisp_lambda_alloc(cons, AO_LISP_FUNC_MACRO); } diff --git a/src/lisp/ao_lisp_make_builtin b/src/lisp/ao_lisp_make_builtin new file mode 100644 index 00000000..5e98516c --- /dev/null +++ b/src/lisp/ao_lisp_make_builtin @@ -0,0 +1,149 @@ +#!/usr/bin/nickle + +typedef struct { + string type; + string c_name; + string lisp_name; +} builtin_t; + +string[string] type_map = { + "lambda" => "F_LAMBDA", + "nlambda" => "NLAMBDA", + "lexpr" => "F_LEXPR", + "macro" => "MACRO", +}; + +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_name = dim(tokens) > 2 ? tokens[2] : tokens[1] + }; +} + +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; +} + +void +dump_ids(builtin_t[*] builtins) { + printf("#ifdef AO_LISP_BUILTIN_ID\n"); + printf("#undef AO_LISP_BUILTIN_ID\n"); + printf("enum ao_lisp_builtin_id {\n"); + for (int i = 0; i < dim(builtins); i++) + printf("\tbuiltin_%s,\n", builtins[i].c_name); + printf("\t_builtin_last\n"); + printf("};\n"); + printf("#endif /* AO_LISP_BUILTIN_ID */\n"); +} + +void +dump_casename(builtin_t[*] builtins) { + printf("#ifdef AO_LISP_BUILTIN_CASENAME\n"); + printf("#undef AO_LISP_BUILTIN_CASENAME\n"); + printf("static char *ao_lisp_builtin_name(enum ao_lisp_builtin_id b) {\n"); + printf("\tswitch(b) {\n"); + for (int i = 0; i < dim(builtins); i++) + printf("\tcase builtin_%s: return ao_lisp_poly_atom(_atom(%s))->name;\n", + builtins[i].c_name, builtins[i].c_name); + printf("\tdefault: return \"???\";\n"); + printf("\t}\n"); + printf("}\n"); + printf("#endif /* AO_LISP_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_LISP_BUILTIN_ARRAYNAME\n"); + printf("#undef AO_LISP_BUILTIN_ARRAYNAME\n"); + printf("static const ao_poly builtin_names[] = {\n"); + for (int i = 0; i < dim(builtins); i++) { + printf("\t[builtin_%s] = _ao_lisp_atom_", + builtins[i].c_name); + cify_lisp(builtins[i].lisp_name); + printf(",\n"); + } + printf("};\n"); + printf("#endif /* AO_LISP_BUILTIN_ARRAYNAME */\n"); +} + +void +dump_funcs(builtin_t[*] builtins) { + printf("#ifdef AO_LISP_BUILTIN_FUNCS\n"); + printf("#undef AO_LISP_BUILTIN_FUNCS\n"); + printf("const ao_lisp_func_t ao_lisp_builtins[] = {\n"); + for (int i = 0; i < dim(builtins); i++) { + printf("\t[builtin_%s] = ao_lisp_do_%s,\n", + builtins[i].c_name, + builtins[i].c_name); + } + printf("};\n"); + printf("#endif /* AO_LISP_BUILTIN_FUNCS */\n"); +} + +void +dump_decls(builtin_t[*] builtins) { + printf("#ifdef AO_LISP_BUILTIN_DECLS\n"); + printf("#undef AO_LISP_BUILTIN_DECLS\n"); + for (int i = 0; i < dim(builtins); i++) { + printf("ao_poly\n"); + printf("ao_lisp_do_%s(struct ao_lisp_cons *cons);\n", + builtins[i].c_name); + } + printf("#endif /* AO_LISP_BUILTIN_DECLS */\n"); +} + +void +dump_consts(builtin_t[*] builtins) { + printf("#ifdef AO_LISP_BUILTIN_CONSTS\n"); + printf("#undef AO_LISP_BUILTIN_CONSTS\n"); + printf("struct builtin_func funcs[] = {\n"); + for (int i = 0; i < dim(builtins); i++) { + printf ("\t{ .name = \"%s\", .args = AO_LISP_FUNC_%s, .func = builtin_%s },\n", + builtins[i].lisp_name, builtins[i].type, builtins[i].c_name); + } + printf("};\n"); + printf("#endif /* AO_LISP_BUILTIN_CONSTS */\n"); +} + +void main() { + if (dim(argv) < 2) { + File::fprintf(stderr, "usage: %s \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); + } +} + +main(); diff --git a/src/lisp/ao_lisp_make_const.c b/src/lisp/ao_lisp_make_const.c index 49f989e6..02cfa67e 100644 --- a/src/lisp/ao_lisp_make_const.c +++ b/src/lisp/ao_lisp_make_const.c @@ -34,46 +34,8 @@ struct builtin_func { 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 AO_LISP_BUILTIN_CONSTS +#include "ao_lisp_builtin.h" #define N_FUNC (sizeof funcs / sizeof funcs[0]) @@ -326,6 +288,10 @@ main(int argc, char **argv) } } + /* Boolean values #f and #t */ + ao_lisp_bool_get(0); + ao_lisp_bool_get(1); + 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); @@ -333,13 +299,6 @@ main(int argc, char **argv) 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), @@ -387,6 +346,8 @@ main(int argc, char **argv) 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)); + fprintf(out, "#define _ao_lisp_bool_false 0x%04x\n", ao_lisp_bool_poly(ao_lisp_false)); + fprintf(out, "#define _ao_lisp_bool_true 0x%04x\n", ao_lisp_bool_poly(ao_lisp_true)); for (a = ao_lisp_atoms; a; a = ao_lisp_poly_atom(a->next)) { char *n = a->name, c; diff --git a/src/lisp/ao_lisp_mem.c b/src/lisp/ao_lisp_mem.c index d7c8d7a6..156221e8 100644 --- a/src/lisp/ao_lisp_mem.c +++ b/src/lisp/ao_lisp_mem.c @@ -211,6 +211,16 @@ static const struct ao_lisp_root ao_lisp_root[] = { .type = &ao_lisp_cons_type, .addr = (void **) &ao_lisp_read_stack, }, +#ifdef AO_LISP_MAKE_CONST + { + .type = &ao_lisp_bool_type, + .addr = (void **) &ao_lisp_false, + }, + { + .type = &ao_lisp_bool_type, + .addr = (void **) &ao_lisp_true, + }, +#endif }; #define AO_LISP_ROOT (sizeof (ao_lisp_root) / sizeof (ao_lisp_root[0])) @@ -447,6 +457,7 @@ static const struct ao_lisp_type *ao_lisp_types[AO_LISP_NUM_TYPE] = { [AO_LISP_FRAME] = &ao_lisp_frame_type, [AO_LISP_LAMBDA] = &ao_lisp_lambda_type, [AO_LISP_STACK] = &ao_lisp_stack_type, + [AO_LISP_BOOL] = &ao_lisp_bool_type, }; static int diff --git a/src/lisp/ao_lisp_poly.c b/src/lisp/ao_lisp_poly.c index fb3b06fe..160734b1 100644 --- a/src/lisp/ao_lisp_poly.c +++ b/src/lisp/ao_lisp_poly.c @@ -52,6 +52,10 @@ static const struct ao_lisp_funcs ao_lisp_funcs[AO_LISP_NUM_TYPE] = { .print = ao_lisp_stack_print, .patom = ao_lisp_stack_print, }, + [AO_LISP_BOOL] = { + .print = ao_lisp_bool_print, + .patom = ao_lisp_bool_print, + }, }; static const struct ao_lisp_funcs * diff --git a/src/lisp/ao_lisp_read.c b/src/lisp/ao_lisp_read.c index 550f62c2..508d16b4 100644 --- a/src/lisp/ao_lisp_read.c +++ b/src/lisp/ao_lisp_read.c @@ -51,18 +51,18 @@ static const uint16_t lex_classes[128] = { PRINTABLE|WHITE, /* */ PRINTABLE, /* ! */ PRINTABLE|STRINGC, /* " */ - PRINTABLE|COMMENT, /* # */ + PRINTABLE|POUND, /* # */ PRINTABLE, /* $ */ PRINTABLE, /* % */ PRINTABLE, /* & */ - PRINTABLE|QUOTEC, /* ' */ - PRINTABLE|BRA, /* ( */ - PRINTABLE|KET, /* ) */ + PRINTABLE|SPECIAL, /* ' */ + PRINTABLE|SPECIAL, /* ( */ + PRINTABLE|SPECIAL, /* ) */ PRINTABLE, /* * */ PRINTABLE|SIGN, /* + */ PRINTABLE, /* , */ PRINTABLE|SIGN, /* - */ - PRINTABLE|DOTC, /* . */ + PRINTABLE|SPECIAL, /* . */ PRINTABLE, /* / */ PRINTABLE|DIGIT, /* 0 */ PRINTABLE|DIGIT, /* 1 */ @@ -283,27 +283,38 @@ _lex(void) continue; } - if (lex_class & (BRA|KET|QUOTEC)) { + if (lex_class & SPECIAL) { add_token(c); end_token(); switch (c) { case '(': + case '[': return OPEN; case ')': + case ']': return CLOSE; case '\'': return QUOTE; + case '.': + return DOT; } } - if (lex_class & (DOTC)) { - add_token(c); - end_token(); - return DOT; - } if (lex_class & TWIDDLE) { token_int = lexc(); return NUM; } + if (lex_class & POUND) { + for (;;) { + c = lexc(); + add_token(c); + switch (c) { + case 't': + return BOOL; + case 'f': + return BOOL; + } + } + } if (lex_class & STRINGC) { for (;;) { c = lexc(); @@ -457,6 +468,12 @@ ao_lisp_read(void) case NUM: v = ao_lisp_int_poly(token_int); break; + case BOOL: + if (token_string[0] == 't') + v = _ao_lisp_bool_true; + else + v = _ao_lisp_bool_false; + break; case STRING: string = ao_lisp_string_copy(token_string); if (string) diff --git a/src/lisp/ao_lisp_read.h b/src/lisp/ao_lisp_read.h index 30dcac3f..f8bcd195 100644 --- a/src/lisp/ao_lisp_read.h +++ b/src/lisp/ao_lisp_read.h @@ -15,6 +15,10 @@ #ifndef _AO_LISP_READ_H_ #define _AO_LISP_READ_H_ +/* + * token classes + */ + # define END 0 # define NAME 1 # define OPEN 2 @@ -23,29 +27,28 @@ # define STRING 5 # define NUM 6 # define DOT 7 +# define BOOL 8 /* * 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 DOTC 0x00008000 /* . */ +# define PRINTABLE 0x0001 /* \t \n ' ' - '~' */ +# define QUOTED 0x0002 /* \ anything */ +# define SPECIAL 0x0004 /* ( [ { ) ] } ' . */ +# define WHITE 0x0008 /* ' ' \t \n */ +# define DIGIT 0x0010 /* [0-9] */ +# define SIGN 0x0020 /* +- */ +# define ENDOFFILE 0x0040 /* end of file */ +# define COMMENT 0x0080 /* ; */ +# define IGNORE 0x0100 /* \0 - ' ' */ +# define BACKSLASH 0x0200 /* \ */ +# define VBAR 0x0400 /* | */ +# define TWIDDLE 0x0800 /* ~ */ +# define STRINGC 0x1000 /* " */ +# define POUND 0x2000 /* # */ -# define NOTNAME (STRINGC|TWIDDLE|VBAR|QUOTEC|COMMENT|ENDOFFILE|WHITE|KET|BRA|DOTC) +# define NOTNAME (STRINGC|TWIDDLE|VBAR|COMMENT|ENDOFFILE|WHITE|SPECIAL) # define NUMBER (DIGIT|SIGN) #endif /* _AO_LISP_READ_H_ */ diff --git a/src/lisp/ao_lisp_rep.c b/src/lisp/ao_lisp_rep.c index 3be95d44..ef7dbaf2 100644 --- a/src/lisp/ao_lisp_rep.c +++ b/src/lisp/ao_lisp_rep.c @@ -20,7 +20,7 @@ ao_lisp_read_eval_print(void) ao_poly in, out = AO_LISP_NIL; for(;;) { in = ao_lisp_read(); - if (in == _ao_lisp_atom_eof || in == AO_LISP_NIL) + if (in == _ao_lisp_atom_eof) break; out = ao_lisp_eval(in); if (ao_lisp_exception) { diff --git a/src/lisp/ao_lisp_save.c b/src/lisp/ao_lisp_save.c index 4f850fb9..cbc8e925 100644 --- a/src/lisp/ao_lisp_save.c +++ b/src/lisp/ao_lisp_save.c @@ -15,7 +15,7 @@ #include ao_poly -ao_lisp_save(struct ao_lisp_cons *cons) +ao_lisp_do_save(struct ao_lisp_cons *cons) { if (!ao_lisp_check_argc(_ao_lisp_atom_save, cons, 0, 0)) return AO_LISP_NIL; @@ -30,13 +30,13 @@ ao_lisp_save(struct ao_lisp_cons *cons) os->const_checksum_inv = (uint16_t) ~ao_lisp_const_checksum; if (ao_lisp_os_save()) - return _ao_lisp_atom_t; + return _ao_lisp_bool_true; #endif - return AO_LISP_NIL; + return _ao_lisp_bool_false; } ao_poly -ao_lisp_restore(struct ao_lisp_cons *cons) +ao_lisp_do_restore(struct ao_lisp_cons *cons) { if (!ao_lisp_check_argc(_ao_lisp_atom_save, cons, 0, 0)) return AO_LISP_NIL; @@ -68,9 +68,9 @@ ao_lisp_restore(struct ao_lisp_cons *cons) /* Re-create the evaluator stack */ if (!ao_lisp_eval_restart()) - return AO_LISP_NIL; - return _ao_lisp_atom_t; + return _ao_lisp_bool_false; + return _ao_lisp_bool_true; } #endif - return AO_LISP_NIL; + return _ao_lisp_bool_false; } diff --git a/src/lisp/ao_lisp_stack.c b/src/lisp/ao_lisp_stack.c index 53adf432..729a63ba 100644 --- a/src/lisp/ao_lisp_stack.c +++ b/src/lisp/ao_lisp_stack.c @@ -241,7 +241,7 @@ ao_lisp_stack_eval(void) * it a single argument which is the current continuation */ ao_poly -ao_lisp_call_cc(struct ao_lisp_cons *cons) +ao_lisp_do_call_cc(struct ao_lisp_cons *cons) { struct ao_lisp_stack *new; ao_poly v; -- cgit v1.2.3 From 0ced351c8f4449f7086b04e42c822d649f040d1f Mon Sep 17 00:00:00 2001 From: Keith Packard Date: Thu, 16 Nov 2017 18:41:18 -0800 Subject: altos/lisp: Add 'else' sematics to cond Signed-off-by: Keith Packard --- src/lisp/ao_lisp.h | 1 + src/lisp/ao_lisp_eval.c | 5 +++++ src/lisp/ao_lisp_make_const.c | 3 +++ 3 files changed, 9 insertions(+) (limited to 'src') diff --git a/src/lisp/ao_lisp.h b/src/lisp/ao_lisp.h index cd002cc2..9a48a445 100644 --- a/src/lisp/ao_lisp.h +++ b/src/lisp/ao_lisp.h @@ -68,6 +68,7 @@ extern uint8_t ao_lisp_const[AO_LISP_POOL_CONST] __attribute__((aligned(4))); #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_else _atom(else) #define _ao_lisp_atom_lambda _atom(lambda) #define _ao_lisp_atom_led _atom(led) #define _ao_lisp_atom_delay _atom(delay) diff --git a/src/lisp/ao_lisp_eval.c b/src/lisp/ao_lisp_eval.c index b6cb4fd8..57227e93 100644 --- a/src/lisp/ao_lisp_eval.c +++ b/src/lisp/ao_lisp_eval.c @@ -324,6 +324,8 @@ ao_lisp_eval_cond(void) return 0; } ao_lisp_v = ao_lisp_poly_cons(ao_lisp_v)->car; + if (ao_lisp_v == _ao_lisp_atom_else) + ao_lisp_v = _ao_lisp_bool_true; ao_lisp_stack->state = eval_cond_test; if (!ao_lisp_stack_push()) return 0; @@ -492,6 +494,9 @@ const char *ao_lisp_state_names[] = { "cond", "cond_test", "progn", + "while", + "while_test", + "macro", }; /* diff --git a/src/lisp/ao_lisp_make_const.c b/src/lisp/ao_lisp_make_const.c index 02cfa67e..826c98b9 100644 --- a/src/lisp/ao_lisp_make_const.c +++ b/src/lisp/ao_lisp_make_const.c @@ -304,6 +304,9 @@ main(int argc, char **argv) ao_lisp_atom_set(ao_lisp_atom_poly(a), ao_lisp_atom_poly(a)); + /* 'else' */ + a = ao_lisp_atom_intern("else"); + if (argv[optind]){ in = fopen(argv[optind], "r"); if (!in) { -- cgit v1.2.3 From 2e58b6c380bc6440490c47650fbf11d45b3f2e72 Mon Sep 17 00:00:00 2001 From: Keith Packard Date: Thu, 16 Nov 2017 18:46:03 -0800 Subject: altos/lisp: More schemisms Add 'if'. setq -> set!, but doesn't define new variables def -> define Add pair? and list? Add eq? and eqv? as aliases for = Signed-off-by: Keith Packard --- src/lisp/ao_lisp_builtin.c | 36 +++++++++++++++++- src/lisp/ao_lisp_builtin.txt | 6 ++- src/lisp/ao_lisp_const.lisp | 87 ++++++++++++++++++++++++++++++------------- src/lisp/ao_lisp_make_builtin | 22 ++++++++--- 4 files changed, 117 insertions(+), 34 deletions(-) (limited to 'src') diff --git a/src/lisp/ao_lisp_builtin.c b/src/lisp/ao_lisp_builtin.c index 6fc28820..d89404dc 100644 --- a/src/lisp/ao_lisp_builtin.c +++ b/src/lisp/ao_lisp_builtin.c @@ -210,11 +210,17 @@ ao_lisp_do_set(struct ao_lisp_cons *cons) ao_poly ao_lisp_do_setq(struct ao_lisp_cons *cons) { + ao_poly name; if (!ao_lisp_check_argc(_ao_lisp_atom_setq, cons, 2, 2)) return AO_LISP_NIL; + name = cons->car; + if (ao_lisp_poly_type(name) != AO_LISP_ATOM) + return ao_lisp_error(AO_LISP_INVALID, "set! of non-atom"); + if (!ao_lisp_atom_ref(ao_lisp_frame_current, name)) + return ao_lisp_error(AO_LISP_INVALID, "atom not defined"); return ao_lisp__cons(_ao_lisp_atom_set, ao_lisp__cons(ao_lisp__cons(_ao_lisp_atom_quote, - ao_lisp__cons(cons->car, AO_LISP_NIL)), + ao_lisp__cons(name, AO_LISP_NIL)), cons->cdr)); } @@ -559,5 +565,33 @@ ao_lisp_do_not(struct ao_lisp_cons *cons) return _ao_lisp_bool_false; } +ao_poly +ao_lisp_do_listp(struct ao_lisp_cons *cons) +{ + ao_poly v; + if (!ao_lisp_check_argc(_ao_lisp_atom_led, cons, 1, 1)) + return AO_LISP_NIL; + v = ao_lisp_arg(cons, 0); + for (;;) { + if (v == AO_LISP_NIL) + return _ao_lisp_bool_true; + if (ao_lisp_poly_type(v) != AO_LISP_CONS) + return _ao_lisp_bool_false; + v = ao_lisp_poly_cons(v)->cdr; + } +} + +ao_poly +ao_lisp_do_pairp(struct ao_lisp_cons *cons) +{ + ao_poly v; + if (!ao_lisp_check_argc(_ao_lisp_atom_led, cons, 1, 1)) + return AO_LISP_NIL; + v = ao_lisp_arg(cons, 0); + if (ao_lisp_poly_type(v) == AO_LISP_CONS) + return _ao_lisp_bool_true; + return _ao_lisp_bool_false; +} + #define AO_LISP_BUILTIN_FUNCS #include "ao_lisp_builtin.h" diff --git a/src/lisp/ao_lisp_builtin.txt b/src/lisp/ao_lisp_builtin.txt index 02320df0..2b891dba 100644 --- a/src/lisp/ao_lisp_builtin.txt +++ b/src/lisp/ao_lisp_builtin.txt @@ -11,7 +11,7 @@ lambda last lambda length nlambda quote lambda set -macro setq +macro setq set! nlambda cond nlambda progn nlambda while @@ -22,7 +22,7 @@ lexpr minus - lexpr times * lexpr divide / lexpr mod % -lexpr equal = +lexpr equal = eq? eqv? lexpr less < lexpr greater > lexpr less_equal <= @@ -38,3 +38,5 @@ lambda call_cc call/cc lambda collect lambda nullp null? lambda not +lambda listp list? +lambda pairp pair? diff --git a/src/lisp/ao_lisp_const.lisp b/src/lisp/ao_lisp_const.lisp index df277fce..37307a68 100644 --- a/src/lisp/ao_lisp_const.lisp +++ b/src/lisp/ao_lisp_const.lisp @@ -23,17 +23,17 @@ ; having lots of output generated ; -(setq def (macro (name val rest) - (list - 'progn - (list - 'set - (list 'quote name) - val) - (list 'quote name) - ) - ) - ) +(set (quote define) (macro (name val rest) + (list + 'progn + (list + 'set + (list 'quote name) + val) + (list 'quote name) + ) + ) + ) ; ; A slightly more convenient form @@ -42,9 +42,9 @@ ; (defun () s-exprs) ; -(def defun (macro (name args exprs) +(define defun (macro (name args exprs) (list - def + define name (cons 'lambda (cons args exprs)) ) @@ -69,6 +69,28 @@ (defun 1+ (x) (+ x 1)) (defun 1- (x) (- x 1)) +(define if (macro (test args) + (cond ((null? (cdr args)) + (list + cond + (list test (car args))) + ) + (else + (list + cond + (list test (car args)) + (list 'else (cadr args)) + ) + ) + ) + ) + ) + +(if (> 3 2) 'yes) +(if (> 3 2) 'yes 'no) +(if (> 2 3) 'no 'yes) +(if (> 2 3) 'no) + ; define a set of local ; variables and then evaluate ; a list of sexprs @@ -85,16 +107,16 @@ ; ; e.g. ; - ; (let ((x 1) (y)) (setq y (+ x 1)) y) + ; (let ((x 1) (y)) (set! y (+ x 1)) y) -(def let (macro (vars exprs) +(define let (macro (vars exprs) ((lambda (make-names make-exprs make-nils) ; ; make the list of names in the let ; - (setq make-names (lambda (vars) + (set! make-names (lambda (vars) (cond ((not (null? vars)) (cons (car (car vars)) (make-names (cdr vars)))) @@ -107,7 +129,7 @@ ; pre-pended to the ; expressions to evaluate - (setq make-exprs (lambda (vars exprs) + (set! make-exprs (lambda (vars exprs) (cond ((not (null? vars)) (cons (list set (list quote @@ -126,7 +148,7 @@ ; the parameters to the lambda is a list ; of nils of the right length - (setq make-nils (lambda (vars) + (set! make-nils (lambda (vars) (cond ((not (null? vars)) (cons () (make-nils (cdr vars)))) ) ) @@ -134,7 +156,7 @@ ; prepend the set operations ; to the expressions - (setq exprs (make-exprs vars exprs)) + (set! exprs (make-exprs vars exprs)) ; build the lambda. @@ -153,11 +175,11 @@ ; boolean operators -(def or (lexpr (l) +(define or (lexpr (l) (let ((ret #f)) (while (not (null? l)) - (cond ((car l) (setq ret #t) (setq l ())) - ((setq l (cdr l))))) + (cond ((car l) (set! ret #t) (set! l ())) + ((set! l (cdr l))))) ret ) ) @@ -167,14 +189,14 @@ (or #f #t) -(def and (lexpr (l) +(define and (lexpr (l) (let ((ret #t)) (while (not (null? l)) (cond ((car l) - (setq l (cdr l))) + (set! l (cdr l))) (#t - (setq ret #f) - (setq l ())) + (set! ret #f) + (set! l ())) ) ) ret @@ -185,3 +207,16 @@ ; execute to resolve macros (and #t #f) + +(defun 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)) diff --git a/src/lisp/ao_lisp_make_builtin b/src/lisp/ao_lisp_make_builtin index 5e98516c..b7b17cf4 100644 --- a/src/lisp/ao_lisp_make_builtin +++ b/src/lisp/ao_lisp_make_builtin @@ -3,7 +3,7 @@ typedef struct { string type; string c_name; - string lisp_name; + string[*] lisp_names; } builtin_t; string[string] type_map = { @@ -13,6 +13,16 @@ string[string] type_map = { "macro" => "MACRO", }; +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); @@ -21,7 +31,7 @@ read_builtin(file f) { return (builtin_t) { .type = dim(tokens) > 0 ? type_map[tokens[0]] : "#", .c_name = dim(tokens) > 1 ? tokens[1] : "#", - .lisp_name = dim(tokens) > 2 ? tokens[2] : tokens[1] + .lisp_names = make_lisp(tokens), }; } @@ -84,7 +94,7 @@ dump_arrayname(builtin_t[*] builtins) { for (int i = 0; i < dim(builtins); i++) { printf("\t[builtin_%s] = _ao_lisp_atom_", builtins[i].c_name); - cify_lisp(builtins[i].lisp_name); + cify_lisp(builtins[i].lisp_names[0]); printf(",\n"); } printf("};\n"); @@ -123,8 +133,10 @@ dump_consts(builtin_t[*] builtins) { printf("#undef AO_LISP_BUILTIN_CONSTS\n"); printf("struct builtin_func funcs[] = {\n"); for (int i = 0; i < dim(builtins); i++) { - printf ("\t{ .name = \"%s\", .args = AO_LISP_FUNC_%s, .func = builtin_%s },\n", - builtins[i].lisp_name, builtins[i].type, builtins[i].c_name); + for (int j = 0; j < dim(builtins[i].lisp_names); j++) { + printf ("\t{ .name = \"%s\", .args = AO_LISP_FUNC_%s, .func = builtin_%s },\n", + builtins[i].lisp_names[j], builtins[i].type, builtins[i].c_name); + } } printf("};\n"); printf("#endif /* AO_LISP_BUILTIN_CONSTS */\n"); -- cgit v1.2.3 From cc76030d669600051fbb42a8cf85701aaaf5f5b7 Mon Sep 17 00:00:00 2001 From: Keith Packard Date: Thu, 16 Nov 2017 18:47:34 -0800 Subject: altos/test: Get lisp test building using Makefile-inc Instead of re-defining all of the lisp sources and headers Signed-off-by: Keith Packard --- src/test/Makefile | 21 ++++++++++++++------- 1 file changed, 14 insertions(+), 7 deletions(-) (limited to 'src') diff --git a/src/test/Makefile b/src/test/Makefile index 08808430..8d8740e4 100644 --- a/src/test/Makefile +++ b/src/test/Makefile @@ -1,4 +1,7 @@ -vpath % ..:../kernel:../drivers:../util:../micropeak:../aes:../product:../lisp +vpath %.o . +vpath %.c ..:../kernel:../drivers:../util:../micropeak:../aes:../product:../lisp +vpath %.h ..:../kernel:../drivers:../util:../micropeak:../aes:../product:../lisp +vpath make-kalman ..:../kernel:../drivers:../util:../micropeak:../aes:../product:../lisp 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 \ @@ -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,16 @@ 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 +include ../lisp/Makefile-inc + +AO_LISP_SRCS=$(LISP_SRCS) ao_lisp_test.c + +AO_LISP_OBJS=$(AO_LISP_SRCS:.c=.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 +$(AO_LISP_OBJS): $(LISP_HDRS) + +clean:: + rm -f $(AO_LISP_OBJS) -- cgit v1.2.3 From 435a91ae3889cd361b543f4555a78488905e0bbb Mon Sep 17 00:00:00 2001 From: Keith Packard Date: Thu, 16 Nov 2017 22:13:46 -0800 Subject: altos/lisp: Lots more scheme bits * Arithmetic functions and tests * append, reverse and list-tail * set-car! and set-cdr! Signed-off-by: Keith Packard --- src/lisp/ao_lisp.h | 2 +- src/lisp/ao_lisp_builtin.c | 105 ++++++++++++++++++++++++++++++--- src/lisp/ao_lisp_builtin.txt | 8 ++- src/lisp/ao_lisp_const.lisp | 136 +++++++++++++++++++++++++++++++++++++++++++ 4 files changed, 240 insertions(+), 11 deletions(-) (limited to 'src') diff --git a/src/lisp/ao_lisp.h b/src/lisp/ao_lisp.h index 9a48a445..341996c0 100644 --- a/src/lisp/ao_lisp.h +++ b/src/lisp/ao_lisp.h @@ -136,7 +136,7 @@ ao_lisp_is_const(ao_poly poly) { #define AO_LISP_IS_CONST(a) (ao_lisp_const <= ((uint8_t *) (a)) && ((uint8_t *) (a)) < ao_lisp_const + AO_LISP_POOL_CONST) #define AO_LISP_IS_POOL(a) (ao_lisp_pool <= ((uint8_t *) (a)) && ((uint8_t *) (a)) < ao_lisp_pool + AO_LISP_POOL) -#define AO_LISP_IS_INT(p) (ao_lisp_base_type(p) == AO_LISP_INT); +#define AO_LISP_IS_INT(p) (ao_lisp_poly_base_type(p) == AO_LISP_INT) void * ao_lisp_ref(ao_poly poly); diff --git a/src/lisp/ao_lisp_builtin.c b/src/lisp/ao_lisp_builtin.c index d89404dc..2c5608e7 100644 --- a/src/lisp/ao_lisp_builtin.c +++ b/src/lisp/ao_lisp_builtin.c @@ -277,6 +277,7 @@ ao_lisp_do_patom(struct ao_lisp_cons *cons) ao_poly ao_lisp_math(struct ao_lisp_cons *cons, enum ao_lisp_builtin_id op) { + struct ao_lisp_cons *orig_cons = cons; ao_poly ret = AO_LISP_NIL; while (cons) { @@ -284,12 +285,29 @@ ao_lisp_math(struct ao_lisp_cons *cons, enum ao_lisp_builtin_id op) uint8_t rt = ao_lisp_poly_type(ret); uint8_t ct = ao_lisp_poly_type(car); - cons = ao_lisp_poly_cons(cons->cdr); - - if (rt == AO_LISP_NIL) + if (cons == orig_cons) { ret = car; - - else if (rt == AO_LISP_INT && ct == AO_LISP_INT) { + if (cons->cdr == AO_LISP_NIL && ct == AO_LISP_INT) { + switch (op) { + case builtin_minus: + ret = ao_lisp_int_poly(-ao_lisp_poly_int(ret)); + break; + case builtin_divide: + switch (ao_lisp_poly_int(ret)) { + case 0: + return ao_lisp_error(AO_LISP_DIVIDE_BY_ZERO, "divide by zero"); + case 1: + break; + default: + ret = ao_lisp_int_poly(0); + break; + } + break; + default: + break; + } + } + } else if (rt == AO_LISP_INT && ct == AO_LISP_INT) { int r = ao_lisp_poly_int(ret); int c = ao_lisp_poly_int(car); @@ -308,11 +326,26 @@ ao_lisp_math(struct ao_lisp_cons *cons, enum ao_lisp_builtin_id op) return ao_lisp_error(AO_LISP_DIVIDE_BY_ZERO, "divide by zero"); r /= c; break; - case builtin_mod: + case builtin_quotient: if (c == 0) - return ao_lisp_error(AO_LISP_DIVIDE_BY_ZERO, "mod by zero"); + return ao_lisp_error(AO_LISP_DIVIDE_BY_ZERO, "quotient by zero"); + if (r % c != 0 && (c < 0) != (r < 0)) + r = r / c - 1; + else + r = r / c; + break; + case builtin_remainder: + if (c == 0) + return ao_lisp_error(AO_LISP_DIVIDE_BY_ZERO, "remainder by zero"); r %= c; break; + case builtin_modulo: + if (c == 0) + return ao_lisp_error(AO_LISP_DIVIDE_BY_ZERO, "modulo by zero"); + r %= c; + if ((r < 0) != (c < 0)) + r += c; + break; default: break; } @@ -324,6 +357,8 @@ ao_lisp_math(struct ao_lisp_cons *cons, enum ao_lisp_builtin_id op) ao_lisp_poly_string(car))); else return ao_lisp_error(AO_LISP_INVALID, "invalid args"); + + cons = ao_lisp_poly_cons(cons->cdr); } return ret; } @@ -353,9 +388,21 @@ ao_lisp_do_divide(struct ao_lisp_cons *cons) } ao_poly -ao_lisp_do_mod(struct ao_lisp_cons *cons) +ao_lisp_do_quotient(struct ao_lisp_cons *cons) +{ + return ao_lisp_math(cons, builtin_quotient); +} + +ao_poly +ao_lisp_do_modulo(struct ao_lisp_cons *cons) { - return ao_lisp_math(cons, builtin_mod); + return ao_lisp_math(cons, builtin_modulo); +} + +ao_poly +ao_lisp_do_remainder(struct ao_lisp_cons *cons) +{ + return ao_lisp_math(cons, builtin_remainder); } ao_poly @@ -593,5 +640,45 @@ ao_lisp_do_pairp(struct ao_lisp_cons *cons) return _ao_lisp_bool_false; } +ao_poly +ao_lisp_do_numberp(struct ao_lisp_cons *cons) +{ + if (!ao_lisp_check_argc(_ao_lisp_atom_led, cons, 1, 1)) + return AO_LISP_NIL; + if (AO_LISP_IS_INT(ao_lisp_arg(cons, 0))) + return _ao_lisp_bool_true; + return _ao_lisp_bool_false; +} + +ao_poly +ao_lisp_do_booleanp(struct ao_lisp_cons *cons) +{ + if (!ao_lisp_check_argc(_ao_lisp_atom_led, cons, 1, 1)) + return AO_LISP_NIL; + if (ao_lisp_poly_type(ao_lisp_arg(cons, 0)) == AO_LISP_BOOL) + return _ao_lisp_bool_true; + return _ao_lisp_bool_false; +} + +ao_poly +ao_lisp_do_set_car(struct ao_lisp_cons *cons) +{ + if (!ao_lisp_check_argc(_ao_lisp_atom_led, cons, 2, 2)) + return AO_LISP_NIL; + if (!ao_lisp_check_argt(_ao_lisp_atom_led, cons, 0, AO_LISP_CONS, 0)) + return AO_LISP_NIL; + return ao_lisp_poly_cons(ao_lisp_arg(cons, 0))->car = ao_lisp_arg(cons, 1); +} + +ao_poly +ao_lisp_do_set_cdr(struct ao_lisp_cons *cons) +{ + if (!ao_lisp_check_argc(_ao_lisp_atom_led, cons, 2, 2)) + return AO_LISP_NIL; + if (!ao_lisp_check_argt(_ao_lisp_atom_led, cons, 0, AO_LISP_CONS, 0)) + return AO_LISP_NIL; + return ao_lisp_poly_cons(ao_lisp_arg(cons, 0))->cdr = ao_lisp_arg(cons, 1); +} + #define AO_LISP_BUILTIN_FUNCS #include "ao_lisp_builtin.h" diff --git a/src/lisp/ao_lisp_builtin.txt b/src/lisp/ao_lisp_builtin.txt index 2b891dba..b27985ff 100644 --- a/src/lisp/ao_lisp_builtin.txt +++ b/src/lisp/ao_lisp_builtin.txt @@ -21,7 +21,9 @@ lexpr plus + lexpr minus - lexpr times * lexpr divide / -lexpr mod % +lexpr modulo modulo % +lexpr remainder +lexpr quotient lexpr equal = eq? eqv? lexpr less < lexpr greater > @@ -40,3 +42,7 @@ lambda nullp null? lambda not lambda listp list? lambda pairp pair? +lambda numberp number? integer? +lambda booleanp boolean? +lambda set_car set-car! +lambda set_cdr set-cdr! diff --git a/src/lisp/ao_lisp_const.lisp b/src/lisp/ao_lisp_const.lisp index 37307a68..3ba6aaf5 100644 --- a/src/lisp/ao_lisp_const.lisp +++ b/src/lisp/ao_lisp_const.lisp @@ -69,6 +69,93 @@ (defun 1+ (x) (+ x 1)) (defun 1- (x) (- x 1)) +(define zero? (macro (value rest) + (list + eq? + value + 0) + ) + ) + +(zero? 1) +(zero? 0) +(zero? "hello") + +(define positive? (macro (value rest) + (list + > + value + 0) + ) + ) + +(positive? 12) +(positive? -12) + +(define negative? (macro (value rest) + (list + < + value + 0) + ) + ) + +(negative? 12) +(negative? -12) + +(defun abs (x) (cond ((>= x 0) x) + (else (- x))) + ) + +(abs 12) +(abs -12) + +(define max (lexpr (first rest) + (while (not (null? rest)) + (cond ((< first (car rest)) + (set! first (car rest))) + ) + (set! rest (cdr rest)) + ) + first) + ) + +(max 1 2 3) +(max 3 2 1) + +(define min (lexpr (first rest) + (while (not (null? rest)) + (cond ((> first (car rest)) + (set! first (car rest))) + ) + (set! rest (cdr rest)) + ) + first) + ) + +(min 1 2 3) +(min 3 2 1) + +(defun even? (x) (zero? (% x 2))) + +(even? 2) +(even? -2) +(even? 3) +(even? -1) + +(defun odd? (x) (not (even? x))) + +(odd? 2) +(odd? -2) +(odd? 3) +(odd? -1) + +(define exact? number?) +(defun inexact? (x) #f) + + ; (if ) + ; (if string (lexpr (arg opt) +; (let ((base (if (null? opt) 10 (car opt))) + ; +; + -- cgit v1.2.3 From cd9152973f29f4e775569f5acbbe8fab2d93d170 Mon Sep 17 00:00:00 2001 From: Keith Packard Date: Thu, 16 Nov 2017 22:15:06 -0800 Subject: altos/test: More lisp test Makefile fixes Depend on ao_lisp_const.h Signed-off-by: Keith Packard --- src/test/Makefile | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'src') diff --git a/src/test/Makefile b/src/test/Makefile index 8d8740e4..9fe886b9 100644 --- a/src/test/Makefile +++ b/src/test/Makefile @@ -106,7 +106,7 @@ AO_LISP_OBJS=$(AO_LISP_SRCS:.c=.o) ao_lisp_test: $(AO_LISP_OBJS) cc $(CFLAGS) -o $@ $(AO_LISP_OBJS) -$(AO_LISP_OBJS): $(LISP_HDRS) +$(AO_LISP_OBJS): $(LISP_HDRS) ao_lisp_const.h clean:: rm -f $(AO_LISP_OBJS) -- cgit v1.2.3 From 5b6f4b5de89a2bb0d63442e2651cf8d2ee0f4b10 Mon Sep 17 00:00:00 2001 From: Keith Packard Date: Fri, 17 Nov 2017 08:04:28 -0800 Subject: altos/lisp: Generate built-in lambda atoms for const creation Signed-off-by: Keith Packard --- src/lisp/ao_lisp.h | 32 ++++++-------------------------- src/lisp/ao_lisp_make_builtin | 17 +++++++++++++++++ 2 files changed, 23 insertions(+), 26 deletions(-) (limited to 'src') diff --git a/src/lisp/ao_lisp.h b/src/lisp/ao_lisp.h index 341996c0..77a94cf1 100644 --- a/src/lisp/ao_lisp.h +++ b/src/lisp/ao_lisp.h @@ -59,33 +59,13 @@ extern uint8_t ao_lisp_const[AO_LISP_POOL_CONST] __attribute__((aligned(4))); #define _ao_lisp_bool_true _bool(1) #define _ao_lisp_bool_false _bool(0) -#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_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_else _atom(else) -#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?) +#define _ao_lisp_atom_else _atom(else) + +#define AO_LISP_BUILTIN_ATOMS +#include "ao_lisp_builtin.h" + #else #include "ao_lisp_const.h" #ifndef AO_LISP_POOL diff --git a/src/lisp/ao_lisp_make_builtin b/src/lisp/ao_lisp_make_builtin index b7b17cf4..ddc9a0b3 100644 --- a/src/lisp/ao_lisp_make_builtin +++ b/src/lisp/ao_lisp_make_builtin @@ -142,6 +142,22 @@ dump_consts(builtin_t[*] builtins) { printf("#endif /* AO_LISP_BUILTIN_CONSTS */\n"); } +void +dump_atoms(builtin_t[*] builtins) { + printf("#ifdef AO_LISP_BUILTIN_ATOMS\n"); + printf("#undef AO_LISP_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_lisp_atom_"); + cify_lisp(builtins[i].lisp_names[j]); + printf(" _atom("); + cify_lisp(builtins[i].lisp_names[j]); + printf(")\n"); + } + } + printf("#endif /* AO_LISP_BUILTIN_ATOMS */\n"); +} + void main() { if (dim(argv) < 2) { File::fprintf(stderr, "usage: %s \n", argv[0]); @@ -155,6 +171,7 @@ void main() { dump_funcs(builtins); dump_decls(builtins); dump_consts(builtins); + dump_atoms(builtins); } } -- cgit v1.2.3 From a4e18a13029cc7b16b2ed9da84d6e606bc725ac3 Mon Sep 17 00:00:00 2001 From: Keith Packard Date: Fri, 17 Nov 2017 08:50:50 -0800 Subject: altos/lisp: Character consts. String and assoc builtins. Also add back escaped characters in strings. Signed-off-by: Keith Packard --- src/lisp/ao_lisp_builtin.c | 98 ++++++++++++++++++++++++------------- src/lisp/ao_lisp_builtin.txt | 8 ++- src/lisp/ao_lisp_const.lisp | 110 +++++++++++++++++++++++++++++++++++++++++ src/lisp/ao_lisp_read.c | 113 +++++++++++++++++++++++++++---------------- src/lisp/ao_lisp_read.h | 7 ++- 5 files changed, 256 insertions(+), 80 deletions(-) (limited to 'src') diff --git a/src/lisp/ao_lisp_builtin.c b/src/lisp/ao_lisp_builtin.c index 2c5608e7..b2941d58 100644 --- a/src/lisp/ao_lisp_builtin.c +++ b/src/lisp/ao_lisp_builtin.c @@ -211,7 +211,7 @@ ao_poly ao_lisp_do_setq(struct ao_lisp_cons *cons) { ao_poly name; - if (!ao_lisp_check_argc(_ao_lisp_atom_setq, cons, 2, 2)) + if (!ao_lisp_check_argc(_ao_lisp_atom_set21, cons, 2, 2)) return AO_LISP_NIL; name = cons->car; if (ao_lisp_poly_type(name) != AO_LISP_ATOM) @@ -510,21 +510,21 @@ ao_lisp_do_greater_equal(struct ao_lisp_cons *cons) } ao_poly -ao_lisp_do_pack(struct ao_lisp_cons *cons) +ao_lisp_do_list_to_string(struct ao_lisp_cons *cons) { - if (!ao_lisp_check_argc(_ao_lisp_atom_pack, cons, 1, 1)) + if (!ao_lisp_check_argc(_ao_lisp_atom_list2d3estring, cons, 1, 1)) return AO_LISP_NIL; - if (!ao_lisp_check_argt(_ao_lisp_atom_pack, cons, 0, AO_LISP_CONS, 1)) + if (!ao_lisp_check_argt(_ao_lisp_atom_list2d3estring, 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_do_unpack(struct ao_lisp_cons *cons) +ao_lisp_do_string_to_list(struct ao_lisp_cons *cons) { - if (!ao_lisp_check_argc(_ao_lisp_atom_unpack, cons, 1, 1)) + if (!ao_lisp_check_argc(_ao_lisp_atom_string2d3elist, cons, 1, 1)) return AO_LISP_NIL; - if (!ao_lisp_check_argt(_ao_lisp_atom_unpack, cons, 0, AO_LISP_STRING, 0)) + if (!ao_lisp_check_argt(_ao_lisp_atom_string2d3elist, cons, 0, AO_LISP_STRING, 0)) return AO_LISP_NIL; return ao_lisp_string_unpack(ao_lisp_poly_string(ao_lisp_arg(cons, 0))); } @@ -612,52 +612,63 @@ ao_lisp_do_not(struct ao_lisp_cons *cons) return _ao_lisp_bool_false; } -ao_poly -ao_lisp_do_listp(struct ao_lisp_cons *cons) +static ao_poly +ao_lisp_do_typep(int type, struct ao_lisp_cons *cons) { - ao_poly v; if (!ao_lisp_check_argc(_ao_lisp_atom_led, cons, 1, 1)) return AO_LISP_NIL; - v = ao_lisp_arg(cons, 0); - for (;;) { - if (v == AO_LISP_NIL) - return _ao_lisp_bool_true; - if (ao_lisp_poly_type(v) != AO_LISP_CONS) - return _ao_lisp_bool_false; - v = ao_lisp_poly_cons(v)->cdr; - } + if (ao_lisp_poly_type(ao_lisp_arg(cons, 0)) == type) + return _ao_lisp_bool_true; + return _ao_lisp_bool_false; } ao_poly ao_lisp_do_pairp(struct ao_lisp_cons *cons) { - ao_poly v; - if (!ao_lisp_check_argc(_ao_lisp_atom_led, cons, 1, 1)) - return AO_LISP_NIL; - v = ao_lisp_arg(cons, 0); - if (ao_lisp_poly_type(v) == AO_LISP_CONS) - return _ao_lisp_bool_true; - return _ao_lisp_bool_false; + return ao_lisp_do_typep(AO_LISP_CONS, cons); } ao_poly ao_lisp_do_numberp(struct ao_lisp_cons *cons) { - if (!ao_lisp_check_argc(_ao_lisp_atom_led, cons, 1, 1)) - return AO_LISP_NIL; - if (AO_LISP_IS_INT(ao_lisp_arg(cons, 0))) - return _ao_lisp_bool_true; - return _ao_lisp_bool_false; + return ao_lisp_do_typep(AO_LISP_INT, cons); +} + +ao_poly +ao_lisp_do_stringp(struct ao_lisp_cons *cons) +{ + return ao_lisp_do_typep(AO_LISP_STRING, cons); +} + +ao_poly +ao_lisp_do_symbolp(struct ao_lisp_cons *cons) +{ + return ao_lisp_do_typep(AO_LISP_ATOM, cons); } ao_poly ao_lisp_do_booleanp(struct ao_lisp_cons *cons) { + return ao_lisp_do_typep(AO_LISP_BOOL, cons); +} + +/* This one is special -- a list is either nil or + * a 'proper' list with only cons cells + */ +ao_poly +ao_lisp_do_listp(struct ao_lisp_cons *cons) +{ + ao_poly v; if (!ao_lisp_check_argc(_ao_lisp_atom_led, cons, 1, 1)) return AO_LISP_NIL; - if (ao_lisp_poly_type(ao_lisp_arg(cons, 0)) == AO_LISP_BOOL) - return _ao_lisp_bool_true; - return _ao_lisp_bool_false; + v = ao_lisp_arg(cons, 0); + for (;;) { + if (v == AO_LISP_NIL) + return _ao_lisp_bool_true; + if (ao_lisp_poly_type(v) != AO_LISP_CONS) + return _ao_lisp_bool_false; + v = ao_lisp_poly_cons(v)->cdr; + } } ao_poly @@ -680,5 +691,26 @@ ao_lisp_do_set_cdr(struct ao_lisp_cons *cons) return ao_lisp_poly_cons(ao_lisp_arg(cons, 0))->cdr = ao_lisp_arg(cons, 1); } +ao_poly +ao_lisp_do_symbol_to_string(struct ao_lisp_cons *cons) +{ + 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_ATOM, 0)) + return AO_LISP_NIL; + return ao_lisp_string_poly(ao_lisp_string_copy(ao_lisp_poly_atom(ao_lisp_arg(cons, 0))->name)); +} + +ao_poly +ao_lisp_do_string_to_symbol(struct ao_lisp_cons *cons) +{ + 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_STRING, 0)) + return AO_LISP_NIL; + + return ao_lisp_atom_poly(ao_lisp_atom_intern(ao_lisp_poly_string(ao_lisp_arg(cons, 0)))); +} + #define AO_LISP_BUILTIN_FUNCS #include "ao_lisp_builtin.h" diff --git a/src/lisp/ao_lisp_builtin.txt b/src/lisp/ao_lisp_builtin.txt index b27985ff..6cb4fdae 100644 --- a/src/lisp/ao_lisp_builtin.txt +++ b/src/lisp/ao_lisp_builtin.txt @@ -29,8 +29,8 @@ lexpr less < lexpr greater > lexpr less_equal <= lexpr greater_equal >= -lambda pack -lambda unpack +lambda list_to_string list->string +lambda string_to_list string->list lambda flush lambda delay lexpr led @@ -46,3 +46,7 @@ lambda numberp number? integer? lambda booleanp boolean? lambda set_car set-car! lambda set_cdr set-cdr! +lambda symbolp symbol? +lambda symbol_to_string symbol->string +lambda string_to_symbol string->symbol +lambda stringp string? diff --git a/src/lisp/ao_lisp_const.lisp b/src/lisp/ao_lisp_const.lisp index 3ba6aaf5..17509044 100644 --- a/src/lisp/ao_lisp_const.lisp +++ b/src/lisp/ao_lisp_const.lisp @@ -54,6 +54,8 @@ ; basic list accessors +(defun caar (l) (car (car l))) + (defun cadr (l) (car (cdr l))) (defun caddr (l) (car (cdr (cdr l)))) @@ -336,6 +338,12 @@ (list-tail (cdr x) (- k 1))))) (list-tail '(1 2 3) 2) + +(defun list-ref (x k) (car (list-tail x k))) + +(list-ref '(1 2 3) 2) + + ; recursive equality (defun equal? (a b) @@ -351,6 +359,108 @@ (equal? '(a b c) '(a b c)) (equal? '(a b c) '(a b b)) +(defun _member (obj list test?) + (if (null? list) + #f + (if (test? obj (car list)) + list + (memq obj (cdr list))))) + +(defun memq (obj list) (_member obj list eq?)) + +(memq 2 '(1 2 3)) + +(memq 4 '(1 2 3)) + +(defun memv (obj list) (_member obj list eqv?)) + +(memv 2 '(1 2 3)) + +(memv 4 '(1 2 3)) + +(defun member (obj list) (_member obj list equal?)) + +(member '(2) '((1) (2) (3))) + +(member '(4) '((1) (2) (3))) + +(defun _assoc (obj list test?) + (if (null? list) + #f + (if (test? obj (caar list)) + (car list) + (_assoc obj (cdr list) test?) + ) + ) + ) + +(defun assq (obj list) (_assoc obj list eq?)) +(defun assv (obj list) (_assoc obj list eqv?)) +(defun 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") + +(defun char-upper-case? (c) (<= #\A c #\Z)) + +(char-upper-case? #\a) +(char-upper-case? #\B) +(char-upper-case? #\0) +(char-upper-case? #\space) + +(defun char-lower-case? (c) (<= #\a c #\a)) + +(char-lower-case? #\a) +(char-lower-case? #\B) +(char-lower-case? #\0) +(char-lower-case? #\space) + +(defun char-alphabetic? (c) (or (char-upper-case? c) (char-lower-case? c))) + +(char-alphabetic? #\a) +(char-alphabetic? #\B) +(char-alphabetic? #\0) +(char-alphabetic? #\space) + +(defun char-numeric? (c) (<= #\0 c #\9)) + +(char-numeric? #\a) +(char-numeric? #\B) +(char-numeric? #\0) +(char-numeric? #\space) + +(defun char-whitespace? (c) (or (<= #\tab c #\return) (= #\space c))) + +(char-whitespace? #\a) +(char-whitespace? #\B) +(char-whitespace? #\0) +(char-whitespace? #\space) + +(defun char->integer (c) c) +(defun integer->char (c) char-integer) + +(defun char-upcase (c) (if (char-lower-case? c) (+ c (- #\A #\a)) c)) + +(char-upcase #\a) +(char-upcase #\B) +(char-upcase #\0) +(char-upcase #\space) + +(defun 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 (lexpr (chars) (list->string chars))) + ;(define number->string (lexpr (arg opt) ; (let ((base (if (null? opt) 10 (car opt))) ; diff --git a/src/lisp/ao_lisp_read.c b/src/lisp/ao_lisp_read.c index 508d16b4..bcd23ce1 100644 --- a/src/lisp/ao_lisp_read.c +++ b/src/lisp/ao_lisp_read.c @@ -142,7 +142,7 @@ static const uint16_t lex_classes[128] = { PRINTABLE, /* { */ PRINTABLE|VBAR, /* | */ PRINTABLE, /* } */ - PRINTABLE|TWIDDLE, /* ~ */ + PRINTABLE, /* ~ */ IGNORE, /* ^? */ }; @@ -168,16 +168,38 @@ lex_unget(int c) 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) +lex_quoted(void) { int c; int v; int count; c = lex_get(); - if (c == EOF) - return EOF; + if (c == EOF) { + lex_class = ENDOFFILE; + return 0; + } + lex_class = 0; c &= 0x7f; switch (c) { case 'n': @@ -220,32 +242,6 @@ lex_quoted (void) } } -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]; @@ -299,25 +295,60 @@ _lex(void) return DOT; } } - if (lex_class & TWIDDLE) { - token_int = lexc(); - return NUM; - } if (lex_class & POUND) { - for (;;) { - c = lexc(); + c = lexc(); + switch (c) { + case 't': add_token(c); - switch (c) { - case 't': - return BOOL; - case 'f': - return BOOL; + end_token(); + return BOOL; + case 'f': + add_token(c); + end_token(); + return BOOL; + 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_lisp_error(AO_LISP_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; diff --git a/src/lisp/ao_lisp_read.h b/src/lisp/ao_lisp_read.h index f8bcd195..fc74a8e4 100644 --- a/src/lisp/ao_lisp_read.h +++ b/src/lisp/ao_lisp_read.h @@ -44,11 +44,10 @@ # define IGNORE 0x0100 /* \0 - ' ' */ # define BACKSLASH 0x0200 /* \ */ # define VBAR 0x0400 /* | */ -# define TWIDDLE 0x0800 /* ~ */ -# define STRINGC 0x1000 /* " */ -# define POUND 0x2000 /* # */ +# define STRINGC 0x0800 /* " */ +# define POUND 0x1000 /* # */ -# define NOTNAME (STRINGC|TWIDDLE|VBAR|COMMENT|ENDOFFILE|WHITE|SPECIAL) +# define NOTNAME (STRINGC|VBAR|COMMENT|ENDOFFILE|WHITE|SPECIAL) # define NUMBER (DIGIT|SIGN) #endif /* _AO_LISP_READ_H_ */ -- cgit v1.2.3 From e1acf5eb12aceda7aa838df031c1da1129d0fa5d Mon Sep 17 00:00:00 2001 From: Keith Packard Date: Fri, 17 Nov 2017 22:14:19 -0800 Subject: altos/lisp: Add apply And all of the library routines that use it, map, string-map and friends. Signed-off-by: Keith Packard --- src/lisp/ao_lisp.h | 7 +-- src/lisp/ao_lisp_builtin.c | 40 +++++++++++++--- src/lisp/ao_lisp_builtin.txt | 106 +++++++++++++++++++++--------------------- src/lisp/ao_lisp_cons.c | 30 ++++++++---- src/lisp/ao_lisp_const.lisp | 74 +++++++++++++++++++++++++---- src/lisp/ao_lisp_eval.c | 57 ++++++++++++++++++----- src/lisp/ao_lisp_make_builtin | 14 +++--- src/lisp/ao_lisp_read.c | 2 +- 8 files changed, 230 insertions(+), 100 deletions(-) (limited to 'src') diff --git a/src/lisp/ao_lisp.h b/src/lisp/ao_lisp.h index 77a94cf1..a445dddd 100644 --- a/src/lisp/ao_lisp.h +++ b/src/lisp/ao_lisp.h @@ -54,14 +54,14 @@ 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 _atom(n) ao_lisp_atom_poly(ao_lisp_atom_intern(n)) #define _bool(v) ao_lisp_bool_poly(ao_lisp_bool_get(v)) #define _ao_lisp_bool_true _bool(1) #define _ao_lisp_bool_false _bool(0) -#define _ao_lisp_atom_eof _atom(eof) -#define _ao_lisp_atom_else _atom(else) +#define _ao_lisp_atom_eof _atom("eof") +#define _ao_lisp_atom_else _atom("else") #define AO_LISP_BUILTIN_ATOMS #include "ao_lisp_builtin.h" @@ -184,6 +184,7 @@ enum eval_state { 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_progn, /* Start next progn entry */ diff --git a/src/lisp/ao_lisp_builtin.c b/src/lisp/ao_lisp_builtin.c index b2941d58..d37d0284 100644 --- a/src/lisp/ao_lisp_builtin.c +++ b/src/lisp/ao_lisp_builtin.c @@ -13,6 +13,7 @@ */ #include "ao_lisp.h" +#include static int builtin_size(void *addr) @@ -44,15 +45,13 @@ const struct ao_lisp_type ao_lisp_builtin_type = { #define AO_LISP_BUILTIN_CASENAME #include "ao_lisp_builtin.h" -#define _atomn(n) ao_lisp_poly_atom(_atom(n)) - char *ao_lisp_args_name(uint8_t args) { args &= AO_LISP_FUNC_MASK; switch (args) { - case AO_LISP_FUNC_LAMBDA: return _atomn(lambda)->name; - case AO_LISP_FUNC_LEXPR: return _atomn(lexpr)->name; - case AO_LISP_FUNC_NLAMBDA: return _atomn(nlambda)->name; - case AO_LISP_FUNC_MACRO: return _atomn(macro)->name; + case AO_LISP_FUNC_LAMBDA: return ao_lisp_poly_atom(_ao_lisp_atom_lambda)->name; + case AO_LISP_FUNC_LEXPR: return ao_lisp_poly_atom(_ao_lisp_atom_lexpr)->name; + case AO_LISP_FUNC_NLAMBDA: return ao_lisp_poly_atom(_ao_lisp_atom_nlambda)->name; + case AO_LISP_FUNC_MACRO: return ao_lisp_poly_atom(_ao_lisp_atom_macro)->name; default: return "???"; } } @@ -282,6 +281,7 @@ ao_lisp_math(struct ao_lisp_cons *cons, enum ao_lisp_builtin_id op) while (cons) { ao_poly car = cons->car; + ao_poly cdr; uint8_t rt = ao_lisp_poly_type(ret); uint8_t ct = ao_lisp_poly_type(car); @@ -358,7 +358,10 @@ ao_lisp_math(struct ao_lisp_cons *cons, enum ao_lisp_builtin_id op) else return ao_lisp_error(AO_LISP_INVALID, "invalid args"); - cons = ao_lisp_poly_cons(cons->cdr); + cdr = cons->cdr; + if (cdr != AO_LISP_NIL && ao_lisp_poly_type(cdr) != AO_LISP_CONS) + return ao_lisp_error(AO_LISP_INVALID, "improper list"); + cons = ao_lisp_poly_cons(cdr); } return ret; } @@ -573,6 +576,15 @@ ao_lisp_do_eval(struct ao_lisp_cons *cons) return cons->car; } +ao_poly +ao_lisp_do_apply(struct ao_lisp_cons *cons) +{ + if (!ao_lisp_check_argc(_ao_lisp_atom_apply, cons, 2, INT_MAX)) + return AO_LISP_NIL; + ao_lisp_stack->state = eval_apply; + return ao_lisp_cons_poly(cons); +} + ao_poly ao_lisp_do_read(struct ao_lisp_cons *cons) { @@ -652,6 +664,20 @@ ao_lisp_do_booleanp(struct ao_lisp_cons *cons) return ao_lisp_do_typep(AO_LISP_BOOL, cons); } +ao_poly +ao_lisp_do_procedurep(struct ao_lisp_cons *cons) +{ + if (!ao_lisp_check_argc(_ao_lisp_atom_led, cons, 1, 1)) + return AO_LISP_NIL; + switch (ao_lisp_poly_type(ao_lisp_arg(cons, 0))) { + case AO_LISP_BUILTIN: + case AO_LISP_LAMBDA: + return _ao_lisp_bool_true; + default: + return _ao_lisp_bool_false; + } +} + /* This one is special -- a list is either nil or * a 'proper' list with only cons cells */ diff --git a/src/lisp/ao_lisp_builtin.txt b/src/lisp/ao_lisp_builtin.txt index 6cb4fdae..ba6455ab 100644 --- a/src/lisp/ao_lisp_builtin.txt +++ b/src/lisp/ao_lisp_builtin.txt @@ -1,52 +1,54 @@ -lambda eval -lambda read -nlambda lambda -nlambda lexpr -nlambda nlambda -nlambda macro -lambda car -lambda cdr -lambda cons -lambda last -lambda length -nlambda quote -lambda set -macro setq set! -nlambda cond -nlambda progn -nlambda while -lexpr print -lexpr patom -lexpr plus + -lexpr minus - -lexpr times * -lexpr divide / -lexpr modulo modulo % -lexpr remainder -lexpr quotient -lexpr equal = eq? eqv? -lexpr less < -lexpr greater > -lexpr less_equal <= -lexpr greater_equal >= -lambda list_to_string list->string -lambda string_to_list string->list -lambda flush -lambda delay -lexpr led -lambda save -lambda restore -lambda call_cc call/cc -lambda collect -lambda nullp null? -lambda not -lambda listp list? -lambda pairp pair? -lambda numberp number? integer? -lambda booleanp boolean? -lambda set_car set-car! -lambda set_cdr set-cdr! -lambda symbolp symbol? -lambda symbol_to_string symbol->string -lambda string_to_symbol string->symbol -lambda stringp string? +f_lambda eval +f_lambda read +nlambda lambda +nlambda lexpr +nlambda nlambda +nlambda macro +f_lambda car +f_lambda cdr +f_lambda cons +f_lambda last +f_lambda length +nlambda quote +f_lambda set +macro setq set! +nlambda cond +nlambda progn +nlambda while +f_lexpr print +f_lexpr patom +f_lexpr plus + +f_lexpr minus - +f_lexpr times * +f_lexpr divide / +f_lexpr modulo modulo % +f_lexpr remainder +f_lexpr quotient +f_lexpr equal = eq? eqv? +f_lexpr less < +f_lexpr greater > +f_lexpr less_equal <= +f_lexpr greater_equal >= +f_lambda list_to_string list->string +f_lambda string_to_list string->list +f_lambda flush +f_lambda delay +f_lexpr 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 numberp number? integer? +f_lambda booleanp boolean? +f_lambda set_car set-car! +f_lambda set_cdr set-cdr! +f_lambda symbolp symbol? +f_lambda symbol_to_string symbol->string +f_lambda string_to_symbol string->symbol +f_lambda stringp string? +f_lambda procedurep procedure? +lexpr apply diff --git a/src/lisp/ao_lisp_cons.c b/src/lisp/ao_lisp_cons.c index 81a16a7a..8d607372 100644 --- a/src/lisp/ao_lisp_cons.c +++ b/src/lisp/ao_lisp_cons.c @@ -19,10 +19,16 @@ static void cons_mark(void *addr) struct ao_lisp_cons *cons = addr; for (;;) { + ao_poly cdr = cons->cdr; + ao_lisp_poly_mark(cons->car, 1); - cons = ao_lisp_poly_cons(cons->cdr); - if (!cons) + if (!cdr) break; + if (ao_lisp_poly_type(cdr) != AO_LISP_CONS) { + ao_lisp_poly_mark(cdr, 1); + break; + } + cons = ao_lisp_poly_cons(cdr); if (ao_lisp_mark_memory(&ao_lisp_cons_type, cons)) break; } @@ -42,23 +48,29 @@ static void cons_move(void *addr) return; for (;;) { - struct ao_lisp_cons *cdr; - int ret; + ao_poly cdr; + struct ao_lisp_cons *c; + 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); + cdr = 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); + if (ao_lisp_poly_type(cdr) != AO_LISP_CONS) { + (void) ao_lisp_poly_move(&cons->cdr, 1); + break; + } + c = ao_lisp_poly_cons(cdr); + ret = ao_lisp_move_memory(&ao_lisp_cons_type, (void **) &c); + if (c != ao_lisp_poly_cons(cons->cdr)) + cons->cdr = ao_lisp_cons_poly(c); 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; + cons = c; } } diff --git a/src/lisp/ao_lisp_const.lisp b/src/lisp/ao_lisp_const.lisp index 17509044..d9b1c1f2 100644 --- a/src/lisp/ao_lisp_const.lisp +++ b/src/lisp/ao_lisp_const.lisp @@ -219,16 +219,18 @@ ; expressions to evaluate (set! make-exprs (lambda (vars exprs) - (cond ((not (null? vars)) (cons - (list set - (list quote - (car (car vars)) - ) - (cadr (car vars)) - ) - (make-exprs (cdr vars) exprs) - ) - ) + (cond ((not (null? vars)) + (cons + (list set + (list quote + (car (car vars)) + ) + (cond ((null? (cdr (car vars))) ()) + (else (cadr (car vars)))) + ) + (make-exprs (cdr vars) exprs) + ) + ) (exprs) ) ) @@ -461,6 +463,58 @@ (define string (lexpr (chars) (list->string chars))) +(patom "apply\n") +(apply cons '(a b)) + +(define save ()) + +(define map (lexpr (proc lists) + (let ((args (lambda (lists) + (if (null? lists) () + (cons (caar lists) (args (cdr lists)))))) + (next (lambda (lists) + (if (null? lists) () + (cons (cdr (car lists)) (next (cdr lists)))))) + (domap (lambda (lists) + (if (null? (car lists)) () + (cons (apply proc (args lists)) (domap (next lists))) + ))) + ) + (domap lists)))) + +(map cadr '((a b) (d e) (g h))) + +(define for-each (lexpr (proc lists) + (apply map proc lists) + #t)) + +(for-each patom '("hello" " " "world" "\n")) + +(define string-map (lexpr (proc strings) + (let ((make-lists (lambda (strings) + (if (null? strings) () + (cons (string->list (car strings)) (make-lists (cdr strings)))))) + ) + (list->string (apply map proc (make-lists strings)))))) + +(string-map 1+ "HAL") + +(define string-for-each (lexpr (proc strings) + (apply string-map proc strings) + #t)) + +(string-for-each patom "IBM") + + +(call-with-current-continuation + (lambda (exit) + (for-each (lambda (x) + (print "test" x) + (if (negative? x) + (exit x))) + '(54 0 37 -3 245 19)) + #t)) + ;(define number->string (lexpr (arg opt) ; (let ((base (if (null? opt) 10 (car opt))) ; diff --git a/src/lisp/ao_lisp_eval.c b/src/lisp/ao_lisp_eval.c index 57227e93..844e7ce7 100644 --- a/src/lisp/ao_lisp_eval.c +++ b/src/lisp/ao_lisp_eval.c @@ -17,6 +17,7 @@ struct ao_lisp_stack *ao_lisp_stack; ao_poly ao_lisp_v; +uint8_t ao_lisp_skip_cons_free; ao_poly ao_lisp_set_cond(struct ao_lisp_cons *c) @@ -269,7 +270,7 @@ ao_lisp_eval_exec(void) 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)) + if (builtin->args & AO_LISP_FUNC_FREE_ARGS && !ao_lisp_stack_marked(ao_lisp_stack) && !ao_lisp_skip_cons_free) ao_lisp_cons_free(ao_lisp_poly_cons(ao_lisp_stack->values)); ao_lisp_v = v; @@ -295,6 +296,38 @@ ao_lisp_eval_exec(void) DBGI(".. frame "); DBG_POLY(ao_lisp_frame_poly(ao_lisp_frame_current)); DBG("\n"); break; } + ao_lisp_skip_cons_free = 0; + return 1; +} + +/* + * Finish setting up the apply evaluation + * + * The value is the list to execute + */ +static int +ao_lisp_eval_apply(void) +{ + struct ao_lisp_cons *cons = ao_lisp_poly_cons(ao_lisp_v); + struct ao_lisp_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_lisp_poly_cons(prev->cdr); + if (cdr->cdr == AO_LISP_NIL) + break; + } + DBGI("before mangling: "); DBG_POLY(ao_lisp_v); DBG("\n"); + prev->cdr = cdr->car; + ao_lisp_stack->values = ao_lisp_v; + ao_lisp_v = ao_lisp_poly_cons(ao_lisp_stack->values)->car; + DBGI("apply: "); DBG_POLY(ao_lisp_stack->values); DBG ("\n"); + ao_lisp_stack->state = eval_exec; + ao_lisp_skip_cons_free = 1; return 1; } @@ -478,6 +511,7 @@ static int (*const evals[])(void) = { [eval_val] = ao_lisp_eval_val, [eval_formal] = ao_lisp_eval_formal, [eval_exec] = ao_lisp_eval_exec, + [eval_apply] = ao_lisp_eval_apply, [eval_cond] = ao_lisp_eval_cond, [eval_cond_test] = ao_lisp_eval_cond_test, [eval_progn] = ao_lisp_eval_progn, @@ -487,16 +521,17 @@ static int (*const evals[])(void) = { }; const char *ao_lisp_state_names[] = { - "sexpr", - "val", - "formal", - "exec", - "cond", - "cond_test", - "progn", - "while", - "while_test", - "macro", + [eval_sexpr] = "sexpr", + [eval_val] = "val", + [eval_formal] = "formal", + [eval_exec] = "exec", + [eval_apply] = "apply", + [eval_cond] = "cond", + [eval_cond_test] = "cond_test", + [eval_progn] = "progn", + [eval_while] = "while", + [eval_while_test] = "while_test", + [eval_macro] = "macro", }; /* diff --git a/src/lisp/ao_lisp_make_builtin b/src/lisp/ao_lisp_make_builtin index ddc9a0b3..11838e33 100644 --- a/src/lisp/ao_lisp_make_builtin +++ b/src/lisp/ao_lisp_make_builtin @@ -7,10 +7,12 @@ typedef struct { } builtin_t; string[string] type_map = { - "lambda" => "F_LAMBDA", + "lambda" => "LAMBDA", "nlambda" => "NLAMBDA", - "lexpr" => "F_LEXPR", + "lexpr" => "LEXPR", "macro" => "MACRO", + "f_lambda" => "F_LAMBDA", + "f_lexpr" => "F_LEXPR", }; string[*] @@ -67,8 +69,8 @@ dump_casename(builtin_t[*] builtins) { printf("static char *ao_lisp_builtin_name(enum ao_lisp_builtin_id b) {\n"); printf("\tswitch(b) {\n"); for (int i = 0; i < dim(builtins); i++) - printf("\tcase builtin_%s: return ao_lisp_poly_atom(_atom(%s))->name;\n", - builtins[i].c_name, builtins[i].c_name); + printf("\tcase builtin_%s: return ao_lisp_poly_atom(_atom(\"%s\"))->name;\n", + builtins[i].c_name, builtins[i].lisp_names[0]); printf("\tdefault: return \"???\";\n"); printf("\t}\n"); printf("}\n"); @@ -150,9 +152,7 @@ dump_atoms(builtin_t[*] builtins) { for (int j = 0; j < dim(builtins[i].lisp_names); j++) { printf("#define _ao_lisp_atom_"); cify_lisp(builtins[i].lisp_names[j]); - printf(" _atom("); - cify_lisp(builtins[i].lisp_names[j]); - printf(")\n"); + printf(" _atom(\"%s\")\n", builtins[i].lisp_names[j]); } } printf("#endif /* AO_LISP_BUILTIN_ATOMS */\n"); diff --git a/src/lisp/ao_lisp_read.c b/src/lisp/ao_lisp_read.c index bcd23ce1..8c06e198 100644 --- a/src/lisp/ao_lisp_read.c +++ b/src/lisp/ao_lisp_read.c @@ -516,7 +516,7 @@ ao_lisp_read(void) if (!push_read_stack(cons, read_state)) return AO_LISP_NIL; cons++; - read_state |= READ_IN_QUOTE; + read_state = READ_IN_QUOTE; v = _ao_lisp_atom_quote; break; case CLOSE: -- cgit v1.2.3 From cf5729a0bae51172f12fc9ec4339d4e975a45fcc Mon Sep 17 00:00:00 2001 From: Keith Packard Date: Fri, 17 Nov 2017 23:23:50 -0800 Subject: altos/lisp: Finish first pass through r7rs * print -> write, patom -> display * Add read-char, write-char * Add exit, current-jiffy, current-second, jiffies-per-second * Add for-each and string-for-each * Avoid duplicate builtins with different atoms Signed-off-by: Keith Packard --- src/lisp/README | 11 +++++++ src/lisp/ao_lisp.h | 33 +++++++++---------- src/lisp/ao_lisp_atom.c | 2 +- src/lisp/ao_lisp_bool.c | 2 +- src/lisp/ao_lisp_builtin.c | 74 +++++++++++++++++++++++++++++++++++++++---- src/lisp/ao_lisp_builtin.txt | 10 ++++-- src/lisp/ao_lisp_cons.c | 10 +++--- src/lisp/ao_lisp_const.lisp | 26 +++++++-------- src/lisp/ao_lisp_error.c | 14 ++++---- src/lisp/ao_lisp_eval.c | 2 +- src/lisp/ao_lisp_frame.c | 8 ++--- src/lisp/ao_lisp_int.c | 2 +- src/lisp/ao_lisp_lambda.c | 4 +-- src/lisp/ao_lisp_make_builtin | 4 ++- src/lisp/ao_lisp_make_const.c | 19 ++++++----- src/lisp/ao_lisp_os.h | 16 ++++++++-- src/lisp/ao_lisp_poly.c | 52 +++++++++++++++--------------- src/lisp/ao_lisp_rep.c | 4 ++- src/lisp/ao_lisp_save.c | 1 + src/lisp/ao_lisp_stack.c | 4 +-- src/lisp/ao_lisp_string.c | 4 +-- 21 files changed, 199 insertions(+), 103 deletions(-) create mode 100644 src/lisp/README (limited to 'src') diff --git a/src/lisp/README b/src/lisp/README new file mode 100644 index 00000000..c1e84475 --- /dev/null +++ b/src/lisp/README @@ -0,0 +1,11 @@ +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; we have macros instead +* define inside of lambda does not add name to lambda scope +* No record types +* No libraries diff --git a/src/lisp/ao_lisp.h b/src/lisp/ao_lisp.h index a445dddd..a10ccc43 100644 --- a/src/lisp/ao_lisp.h +++ b/src/lisp/ao_lisp.h @@ -106,6 +106,7 @@ extern uint16_t ao_lisp_top; #define AO_LISP_INVALID 0x04 #define AO_LISP_UNDEFINED 0x08 #define AO_LISP_EOF 0x10 +#define AO_LISP_EXIT 0x20 extern uint8_t ao_lisp_exception; @@ -463,7 +464,7 @@ ao_lisp_stack_fetch(int id) { extern const struct ao_lisp_type ao_lisp_bool_type; void -ao_lisp_bool_print(ao_poly v); +ao_lisp_bool_write(ao_poly v); #ifdef AO_LISP_MAKE_CONST struct ao_lisp_bool *ao_lisp_true, *ao_lisp_false; @@ -487,10 +488,10 @@ void ao_lisp_cons_free(struct ao_lisp_cons *cons); void -ao_lisp_cons_print(ao_poly); +ao_lisp_cons_write(ao_poly); void -ao_lisp_cons_patom(ao_poly); +ao_lisp_cons_display(ao_poly); int ao_lisp_cons_length(struct ao_lisp_cons *cons); @@ -511,10 +512,10 @@ ao_poly ao_lisp_string_unpack(char *a); void -ao_lisp_string_print(ao_poly s); +ao_lisp_string_write(ao_poly s); void -ao_lisp_string_patom(ao_poly s); +ao_lisp_string_display(ao_poly s); /* atom */ extern const struct ao_lisp_type ao_lisp_atom_type; @@ -524,7 +525,7 @@ 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); +ao_lisp_atom_write(ao_poly a); struct ao_lisp_atom * ao_lisp_atom_intern(char *name); @@ -540,14 +541,14 @@ ao_lisp_atom_set(ao_poly atom, ao_poly val); /* int */ void -ao_lisp_int_print(ao_poly i); +ao_lisp_int_write(ao_poly i); /* prim */ void -ao_lisp_poly_print(ao_poly p); +ao_lisp_poly_write(ao_poly p); void -ao_lisp_poly_patom(ao_poly p); +ao_lisp_poly_display(ao_poly p); int ao_lisp_poly_mark(ao_poly p, uint8_t note_cons); @@ -572,7 +573,7 @@ ao_lisp_set_cond(struct ao_lisp_cons *cons); /* builtin */ void -ao_lisp_builtin_print(ao_poly b); +ao_lisp_builtin_write(ao_poly b); extern const struct ao_lisp_type ao_lisp_builtin_type; @@ -629,7 +630,7 @@ int ao_lisp_frame_add(struct ao_lisp_frame **frame, ao_poly atom, ao_poly val); void -ao_lisp_frame_print(ao_poly p); +ao_lisp_frame_write(ao_poly p); /* lambda */ extern const struct ao_lisp_type ao_lisp_lambda_type; @@ -640,7 +641,7 @@ struct ao_lisp_lambda * ao_lisp_lambda_new(ao_poly cons); void -ao_lisp_lambda_print(ao_poly lambda); +ao_lisp_lambda_write(ao_poly lambda); ao_poly ao_lisp_lambda_eval(void); @@ -664,7 +665,7 @@ void ao_lisp_stack_clear(void); void -ao_lisp_stack_print(ao_poly stack); +ao_lisp_stack_write(ao_poly stack); ao_poly ao_lisp_stack_eval(void); @@ -697,10 +698,10 @@ int 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 DBG_CONS(a) ao_lisp_cons_write(ao_lisp_cons_poly(a)) +#define DBG_POLY(a) ao_lisp_poly_write(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)) +#define DBG_STACK() ao_lisp_stack_write(ao_lisp_stack_poly(ao_lisp_stack)) static inline void ao_lisp_frames_dump(void) { diff --git a/src/lisp/ao_lisp_atom.c b/src/lisp/ao_lisp_atom.c index 8c9e8ed1..ede13567 100644 --- a/src/lisp/ao_lisp_atom.c +++ b/src/lisp/ao_lisp_atom.c @@ -158,7 +158,7 @@ ao_lisp_atom_set(ao_poly atom, ao_poly val) } void -ao_lisp_atom_print(ao_poly a) +ao_lisp_atom_write(ao_poly a) { struct ao_lisp_atom *atom = ao_lisp_poly_atom(a); printf("%s", atom->name); diff --git a/src/lisp/ao_lisp_bool.c b/src/lisp/ao_lisp_bool.c index ad25afba..391a7f78 100644 --- a/src/lisp/ao_lisp_bool.c +++ b/src/lisp/ao_lisp_bool.c @@ -38,7 +38,7 @@ const struct ao_lisp_type ao_lisp_bool_type = { }; void -ao_lisp_bool_print(ao_poly v) +ao_lisp_bool_write(ao_poly v) { struct ao_lisp_bool *b = ao_lisp_poly_bool(v); diff --git a/src/lisp/ao_lisp_builtin.c b/src/lisp/ao_lisp_builtin.c index d37d0284..6dd4d5e6 100644 --- a/src/lisp/ao_lisp_builtin.c +++ b/src/lisp/ao_lisp_builtin.c @@ -85,7 +85,7 @@ ao_lisp_args_name(uint8_t args) #endif void -ao_lisp_builtin_print(ao_poly b) +ao_lisp_builtin_write(ao_poly b) { struct ao_lisp_builtin *builtin = ao_lisp_poly_builtin(b); printf("%s", ao_lisp_builtin_name(builtin->func)); @@ -247,30 +247,30 @@ ao_lisp_do_while(struct ao_lisp_cons *cons) } ao_poly -ao_lisp_do_print(struct ao_lisp_cons *cons) +ao_lisp_do_write(struct ao_lisp_cons *cons) { ao_poly val = AO_LISP_NIL; while (cons) { val = cons->car; - ao_lisp_poly_print(val); + ao_lisp_poly_write(val); cons = ao_lisp_poly_cons(cons->cdr); if (cons) printf(" "); } printf("\n"); - return val; + return _ao_lisp_bool_true; } ao_poly -ao_lisp_do_patom(struct ao_lisp_cons *cons) +ao_lisp_do_display(struct ao_lisp_cons *cons) { ao_poly val = AO_LISP_NIL; while (cons) { val = cons->car; - ao_lisp_poly_patom(val); + ao_lisp_poly_display(val); cons = ao_lisp_poly_cons(cons->cdr); } - return val; + return _ao_lisp_bool_true; } ao_poly @@ -738,5 +738,65 @@ ao_lisp_do_string_to_symbol(struct ao_lisp_cons *cons) return ao_lisp_atom_poly(ao_lisp_atom_intern(ao_lisp_poly_string(ao_lisp_arg(cons, 0)))); } +ao_poly +ao_lisp_do_read_char(struct ao_lisp_cons *cons) +{ + int c; + if (!ao_lisp_check_argc(_ao_lisp_atom_led, cons, 0, 0)) + return AO_LISP_NIL; + c = getchar(); + return ao_lisp_int_poly(c); +} + +ao_poly +ao_lisp_do_write_char(struct ao_lisp_cons *cons) +{ + 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; + putchar(ao_lisp_poly_int(ao_lisp_arg(cons, 0))); + return _ao_lisp_bool_true; +} + +ao_poly +ao_lisp_do_exit(struct ao_lisp_cons *cons) +{ + if (!ao_lisp_check_argc(_ao_lisp_atom_led, cons, 0, 0)) + return AO_LISP_NIL; + ao_lisp_exception |= AO_LISP_EXIT; + return _ao_lisp_bool_true; +} + +ao_poly +ao_lisp_do_current_jiffy(struct ao_lisp_cons *cons) +{ + int jiffy; + + if (!ao_lisp_check_argc(_ao_lisp_atom_led, cons, 0, 0)) + return AO_LISP_NIL; + jiffy = ao_lisp_os_jiffy(); + return (ao_lisp_int_poly(jiffy)); +} + +ao_poly +ao_lisp_do_current_second(struct ao_lisp_cons *cons) +{ + int second; + + if (!ao_lisp_check_argc(_ao_lisp_atom_led, cons, 0, 0)) + return AO_LISP_NIL; + second = ao_lisp_os_jiffy() / AO_LISP_JIFFIES_PER_SECOND; + return (ao_lisp_int_poly(second)); +} + +ao_poly +ao_lisp_do_jiffies_per_second(struct ao_lisp_cons *cons) +{ + if (!ao_lisp_check_argc(_ao_lisp_atom_led, cons, 0, 0)) + return AO_LISP_NIL; + return (ao_lisp_int_poly(AO_LISP_JIFFIES_PER_SECOND)); +} + #define AO_LISP_BUILTIN_FUNCS #include "ao_lisp_builtin.h" diff --git a/src/lisp/ao_lisp_builtin.txt b/src/lisp/ao_lisp_builtin.txt index ba6455ab..4c484337 100644 --- a/src/lisp/ao_lisp_builtin.txt +++ b/src/lisp/ao_lisp_builtin.txt @@ -15,8 +15,8 @@ macro setq set! nlambda cond nlambda progn nlambda while -f_lexpr print -f_lexpr patom +f_lexpr write +f_lexpr display f_lexpr plus + f_lexpr minus - f_lexpr times * @@ -52,3 +52,9 @@ f_lambda string_to_symbol string->symbol f_lambda stringp string? f_lambda procedurep procedure? lexpr 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 diff --git a/src/lisp/ao_lisp_cons.c b/src/lisp/ao_lisp_cons.c index 8d607372..9379597c 100644 --- a/src/lisp/ao_lisp_cons.c +++ b/src/lisp/ao_lisp_cons.c @@ -123,7 +123,7 @@ ao_lisp_cons_free(struct ao_lisp_cons *cons) } void -ao_lisp_cons_print(ao_poly c) +ao_lisp_cons_write(ao_poly c) { struct ao_lisp_cons *cons = ao_lisp_poly_cons(c); int first = 1; @@ -131,14 +131,14 @@ ao_lisp_cons_print(ao_poly c) while (cons) { if (!first) printf(" "); - ao_lisp_poly_print(cons->car); + ao_lisp_poly_write(cons->car); c = cons->cdr; if (ao_lisp_poly_type(c) == AO_LISP_CONS) { cons = ao_lisp_poly_cons(c); first = 0; } else { printf(" . "); - ao_lisp_poly_print(c); + ao_lisp_poly_write(c); cons = NULL; } } @@ -146,12 +146,12 @@ ao_lisp_cons_print(ao_poly c) } void -ao_lisp_cons_patom(ao_poly c) +ao_lisp_cons_display(ao_poly c) { struct ao_lisp_cons *cons = ao_lisp_poly_cons(c); while (cons) { - ao_lisp_poly_patom(cons->car); + ao_lisp_poly_display(cons->car); cons = ao_lisp_poly_cons(cons->cdr); } } diff --git a/src/lisp/ao_lisp_const.lisp b/src/lisp/ao_lisp_const.lisp index d9b1c1f2..191ef005 100644 --- a/src/lisp/ao_lisp_const.lisp +++ b/src/lisp/ao_lisp_const.lisp @@ -463,11 +463,9 @@ (define string (lexpr (chars) (list->string chars))) -(patom "apply\n") +(display "apply\n") (apply cons '(a b)) -(define save ()) - (define map (lexpr (proc lists) (let ((args (lambda (lists) (if (null? lists) () @@ -488,28 +486,30 @@ (apply map proc lists) #t)) -(for-each patom '("hello" " " "world" "\n")) +(for-each display '("hello" " " "world" "\n")) + +(define -string-ml (lambda (strings) + (if (null? strings) () + (cons (string->list (car strings)) (-string-ml (cdr strings)))))) (define string-map (lexpr (proc strings) - (let ((make-lists (lambda (strings) - (if (null? strings) () - (cons (string->list (car strings)) (make-lists (cdr strings)))))) - ) - (list->string (apply map proc (make-lists strings)))))) + (list->string (apply map proc (-string-ml strings)))))) (string-map 1+ "HAL") (define string-for-each (lexpr (proc strings) - (apply string-map proc strings) - #t)) + (apply for-each proc (-string-ml strings)))) + +(string-for-each write-char "IBM\n") -(string-for-each patom "IBM") +(define newline (lambda () (write-char #\newline))) +(newline) (call-with-current-continuation (lambda (exit) (for-each (lambda (x) - (print "test" x) + (write "test" x) (if (negative? x) (exit x))) '(54 0 37 -3 245 19)) diff --git a/src/lisp/ao_lisp_error.c b/src/lisp/ao_lisp_error.c index 54a9be10..d1c9b941 100644 --- a/src/lisp/ao_lisp_error.c +++ b/src/lisp/ao_lisp_error.c @@ -28,7 +28,7 @@ ao_lisp_error_poly(char *name, ao_poly poly, ao_poly last) printf("\t\t "); else first = 0; - ao_lisp_poly_print(cons->car); + ao_lisp_poly_write(cons->car); printf("\n"); if (poly == last) break; @@ -38,7 +38,7 @@ ao_lisp_error_poly(char *name, ao_poly poly, ao_poly last) } else printf(")\n"); } else { - ao_lisp_poly_print(poly); + ao_lisp_poly_write(poly); printf("\n"); } } @@ -66,9 +66,9 @@ ao_lisp_error_frame(int indent, char *name, struct ao_lisp_frame *frame) tabs(indent); printf(" "); } - ao_lisp_poly_print(frame->vals[f].atom); + ao_lisp_poly_write(frame->vals[f].atom); printf(" = "); - ao_lisp_poly_print(frame->vals[f].val); + ao_lisp_poly_write(frame->vals[f].val); printf("\n"); } if (frame->prev) @@ -92,11 +92,11 @@ ao_lisp_error(int error, char *format, ...) vprintf(format, args); va_end(args); printf("\n"); - printf("Value: "); ao_lisp_poly_print(ao_lisp_v); printf("\n"); + printf("Value: "); ao_lisp_poly_write(ao_lisp_v); printf("\n"); printf("Stack:\n"); - ao_lisp_stack_print(ao_lisp_stack_poly(ao_lisp_stack)); + ao_lisp_stack_write(ao_lisp_stack_poly(ao_lisp_stack)); printf("Globals:\n\t"); - ao_lisp_frame_print(ao_lisp_frame_poly(ao_lisp_frame_global)); + ao_lisp_frame_write(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 index 844e7ce7..758a9232 100644 --- a/src/lisp/ao_lisp_eval.c +++ b/src/lisp/ao_lisp_eval.c @@ -270,7 +270,7 @@ ao_lisp_eval_exec(void) 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_skip_cons_free) + if (builtin && builtin->args & AO_LISP_FUNC_FREE_ARGS && !ao_lisp_stack_marked(ao_lisp_stack) && !ao_lisp_skip_cons_free) ao_lisp_cons_free(ao_lisp_poly_cons(ao_lisp_stack->values)); ao_lisp_v = v; diff --git a/src/lisp/ao_lisp_frame.c b/src/lisp/ao_lisp_frame.c index 05f6d253..ebdb7757 100644 --- a/src/lisp/ao_lisp_frame.c +++ b/src/lisp/ao_lisp_frame.c @@ -102,7 +102,7 @@ const struct ao_lisp_type ao_lisp_frame_type = { }; void -ao_lisp_frame_print(ao_poly p) +ao_lisp_frame_write(ao_poly p) { struct ao_lisp_frame *frame = ao_lisp_poly_frame(p); int f; @@ -116,12 +116,12 @@ ao_lisp_frame_print(ao_poly p) for (f = 0; f < frame->num; f++) { if (f != 0) printf(", "); - ao_lisp_poly_print(frame->vals[f].atom); + ao_lisp_poly_write(frame->vals[f].atom); printf(" = "); - ao_lisp_poly_print(frame->vals[f].val); + ao_lisp_poly_write(frame->vals[f].val); } if (frame->prev) - ao_lisp_poly_print(frame->prev); + ao_lisp_poly_write(frame->prev); frame->type &= ~AO_LISP_FRAME_PRINT; } } diff --git a/src/lisp/ao_lisp_int.c b/src/lisp/ao_lisp_int.c index 77f65e95..3b5341bd 100644 --- a/src/lisp/ao_lisp_int.c +++ b/src/lisp/ao_lisp_int.c @@ -15,7 +15,7 @@ #include "ao_lisp.h" void -ao_lisp_int_print(ao_poly p) +ao_lisp_int_write(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 index cc333d6f..71aebed0 100644 --- a/src/lisp/ao_lisp_lambda.c +++ b/src/lisp/ao_lisp_lambda.c @@ -50,7 +50,7 @@ const struct ao_lisp_type ao_lisp_lambda_type = { }; void -ao_lisp_lambda_print(ao_poly poly) +ao_lisp_lambda_write(ao_poly poly) { struct ao_lisp_lambda *lambda = ao_lisp_poly_lambda(poly); struct ao_lisp_cons *cons = ao_lisp_poly_cons(lambda->code); @@ -59,7 +59,7 @@ ao_lisp_lambda_print(ao_poly poly) printf("%s", ao_lisp_args_name(lambda->args)); while (cons) { printf(" "); - ao_lisp_poly_print(cons->car); + ao_lisp_poly_write(cons->car); cons = ao_lisp_poly_cons(cons->cdr); } printf(")"); diff --git a/src/lisp/ao_lisp_make_builtin b/src/lisp/ao_lisp_make_builtin index 11838e33..531e388d 100644 --- a/src/lisp/ao_lisp_make_builtin +++ b/src/lisp/ao_lisp_make_builtin @@ -137,7 +137,9 @@ dump_consts(builtin_t[*] builtins) { for (int i = 0; i < dim(builtins); i++) { for (int j = 0; j < dim(builtins[i].lisp_names); j++) { printf ("\t{ .name = \"%s\", .args = AO_LISP_FUNC_%s, .func = builtin_%s },\n", - builtins[i].lisp_names[j], builtins[i].type, builtins[i].c_name); + builtins[i].lisp_names[j], + builtins[i].type, + builtins[i].c_name); } } printf("};\n"); diff --git a/src/lisp/ao_lisp_make_const.c b/src/lisp/ao_lisp_make_const.c index 826c98b9..f23d34db 100644 --- a/src/lisp/ao_lisp_make_const.c +++ b/src/lisp/ao_lisp_make_const.c @@ -31,7 +31,7 @@ ao_lisp_make_builtin(enum ao_lisp_builtin_id func, int args) { struct builtin_func { char *name; int args; - int func; + enum ao_lisp_builtin_id func; }; #define AO_LISP_BUILTIN_CONSTS @@ -146,7 +146,7 @@ ao_is_macro(ao_poly p) struct ao_lisp_lambda *lambda; ao_poly ret; - MACRO_DEBUG(indent(); printf ("is macro "); ao_lisp_poly_print(p); printf("\n"); ++macro_scan_depth); + MACRO_DEBUG(indent(); printf ("is macro "); ao_lisp_poly_write(p); printf("\n"); ++macro_scan_depth); switch (ao_lisp_poly_type(p)) { case AO_LISP_ATOM: if (ao_lisp_macro_push(p)) @@ -181,7 +181,7 @@ ao_is_macro(ao_poly p) ret = AO_LISP_NIL; break; } - MACRO_DEBUG(--macro_scan_depth; indent(); printf ("... "); ao_lisp_poly_print(ret); printf("\n")); + MACRO_DEBUG(--macro_scan_depth; indent(); printf ("... "); ao_lisp_poly_write(ret); printf("\n")); return ret; } @@ -195,7 +195,7 @@ ao_has_macro(ao_poly p) 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); + MACRO_DEBUG(indent(); printf("has macro "); ao_lisp_poly_write(p); printf("\n"); ++macro_scan_depth); switch (ao_lisp_poly_type(p)) { case AO_LISP_LAMBDA: lambda = ao_lisp_poly_lambda(p); @@ -222,7 +222,7 @@ ao_has_macro(ao_poly p) p = AO_LISP_NIL; break; } - MACRO_DEBUG(--macro_scan_depth; indent(); printf("... "); ao_lisp_poly_print(p); printf("\n")); + MACRO_DEBUG(--macro_scan_depth; indent(); printf("... "); ao_lisp_poly_write(p); printf("\n")); return p; } @@ -237,7 +237,7 @@ ao_lisp_read_eval_abort(void) out = ao_lisp_eval(in); if (ao_lisp_exception) return 0; - ao_lisp_poly_print(out); + ao_lisp_poly_write(out); putchar ('\n'); } return 1; @@ -273,6 +273,7 @@ main(int argc, char **argv) int in_atom = 0; char *out_name = NULL; int c; + enum ao_lisp_builtin_id prev_func; in = stdin; out = stdout; @@ -292,8 +293,10 @@ main(int argc, char **argv) ao_lisp_bool_get(0); ao_lisp_bool_get(1); + prev_func = _builtin_last; for (f = 0; f < (int) N_FUNC; f++) { - b = ao_lisp_make_builtin(funcs[f].func, funcs[f].args); + if (funcs[f].func != prev_func) + 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)); @@ -327,7 +330,7 @@ main(int argc, char **argv) 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); + ao_lisp_poly_write(val); printf("\n"); exit(1); } diff --git a/src/lisp/ao_lisp_os.h b/src/lisp/ao_lisp_os.h index 5fa3686b..4285cb8c 100644 --- a/src/lisp/ao_lisp_os.h +++ b/src/lisp/ao_lisp_os.h @@ -41,13 +41,23 @@ ao_lisp_os_led(int led) printf("leds set to 0x%x\n", led); } +#define AO_LISP_JIFFIES_PER_SECOND 100 + static inline void -ao_lisp_os_delay(int delay) +ao_lisp_os_delay(int jiffies) { struct timespec ts = { - .tv_sec = delay / 1000, - .tv_nsec = (delay % 1000) * 1000000, + .tv_sec = jiffies / AO_LISP_JIFFIES_PER_SECOND, + .tv_nsec = (jiffies % AO_LISP_JIFFIES_PER_SECOND) * (1000000000L / AO_LISP_JIFFIES_PER_SECOND) }; nanosleep(&ts, NULL); } + +static inline int +ao_lisp_os_jiffy(void) +{ + struct timespec tp; + clock_gettime(CLOCK_MONOTONIC, &tp); + return tp.tv_sec * AO_LISP_JIFFIES_PER_SECOND + (tp.tv_nsec / (1000000000L / AO_LISP_JIFFIES_PER_SECOND)); +} #endif diff --git a/src/lisp/ao_lisp_poly.c b/src/lisp/ao_lisp_poly.c index 160734b1..7e4c98d2 100644 --- a/src/lisp/ao_lisp_poly.c +++ b/src/lisp/ao_lisp_poly.c @@ -15,46 +15,46 @@ #include "ao_lisp.h" struct ao_lisp_funcs { - void (*print)(ao_poly); - void (*patom)(ao_poly); + void (*write)(ao_poly); + void (*display)(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, + .write = ao_lisp_cons_write, + .display = ao_lisp_cons_display, }, [AO_LISP_STRING] = { - .print = ao_lisp_string_print, - .patom = ao_lisp_string_patom, + .write = ao_lisp_string_write, + .display = ao_lisp_string_display, }, [AO_LISP_INT] = { - .print = ao_lisp_int_print, - .patom = ao_lisp_int_print, + .write = ao_lisp_int_write, + .display = ao_lisp_int_write, }, [AO_LISP_ATOM] = { - .print = ao_lisp_atom_print, - .patom = ao_lisp_atom_print, + .write = ao_lisp_atom_write, + .display = ao_lisp_atom_write, }, [AO_LISP_BUILTIN] = { - .print = ao_lisp_builtin_print, - .patom = ao_lisp_builtin_print, + .write = ao_lisp_builtin_write, + .display = ao_lisp_builtin_write, }, [AO_LISP_FRAME] = { - .print = ao_lisp_frame_print, - .patom = ao_lisp_frame_print, + .write = ao_lisp_frame_write, + .display = ao_lisp_frame_write, }, [AO_LISP_LAMBDA] = { - .print = ao_lisp_lambda_print, - .patom = ao_lisp_lambda_print, + .write = ao_lisp_lambda_write, + .display = ao_lisp_lambda_write, }, [AO_LISP_STACK] = { - .print = ao_lisp_stack_print, - .patom = ao_lisp_stack_print, + .write = ao_lisp_stack_write, + .display = ao_lisp_stack_write, }, [AO_LISP_BOOL] = { - .print = ao_lisp_bool_print, - .patom = ao_lisp_bool_print, + .write = ao_lisp_bool_write, + .display = ao_lisp_bool_write, }, }; @@ -69,21 +69,21 @@ funcs(ao_poly p) } void -ao_lisp_poly_print(ao_poly p) +ao_lisp_poly_write(ao_poly p) { const struct ao_lisp_funcs *f = funcs(p); - if (f && f->print) - f->print(p); + if (f && f->write) + f->write(p); } void -ao_lisp_poly_patom(ao_poly p) +ao_lisp_poly_display(ao_poly p) { const struct ao_lisp_funcs *f = funcs(p); - if (f && f->patom) - f->patom(p); + if (f && f->display) + f->display(p); } void * diff --git a/src/lisp/ao_lisp_rep.c b/src/lisp/ao_lisp_rep.c index ef7dbaf2..43cc387f 100644 --- a/src/lisp/ao_lisp_rep.c +++ b/src/lisp/ao_lisp_rep.c @@ -24,9 +24,11 @@ ao_lisp_read_eval_print(void) break; out = ao_lisp_eval(in); if (ao_lisp_exception) { + if (ao_lisp_exception & AO_LISP_EXIT) + break; ao_lisp_exception = 0; } else { - ao_lisp_poly_print(out); + ao_lisp_poly_write(out); putchar ('\n'); } } diff --git a/src/lisp/ao_lisp_save.c b/src/lisp/ao_lisp_save.c index cbc8e925..c990e9c6 100644 --- a/src/lisp/ao_lisp_save.c +++ b/src/lisp/ao_lisp_save.c @@ -69,6 +69,7 @@ ao_lisp_do_restore(struct ao_lisp_cons *cons) /* Re-create the evaluator stack */ if (!ao_lisp_eval_restart()) return _ao_lisp_bool_false; + return _ao_lisp_bool_true; } #endif diff --git a/src/lisp/ao_lisp_stack.c b/src/lisp/ao_lisp_stack.c index 729a63ba..af68b656 100644 --- a/src/lisp/ao_lisp_stack.c +++ b/src/lisp/ao_lisp_stack.c @@ -156,7 +156,7 @@ ao_lisp_stack_clear(void) } void -ao_lisp_stack_print(ao_poly poly) +ao_lisp_stack_write(ao_poly poly) { struct ao_lisp_stack *s = ao_lisp_poly_stack(poly); @@ -167,7 +167,7 @@ ao_lisp_stack_print(ao_poly poly) } s->type |= AO_LISP_STACK_PRINT; printf("\t[\n"); - printf("\t\texpr: "); ao_lisp_poly_print(s->list); printf("\n"); + printf("\t\texpr: "); ao_lisp_poly_write(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); diff --git a/src/lisp/ao_lisp_string.c b/src/lisp/ao_lisp_string.c index af23f7b3..87f9289c 100644 --- a/src/lisp/ao_lisp_string.c +++ b/src/lisp/ao_lisp_string.c @@ -122,7 +122,7 @@ ao_lisp_string_unpack(char *a) } void -ao_lisp_string_print(ao_poly p) +ao_lisp_string_write(ao_poly p) { char *s = ao_lisp_poly_string(p); char c; @@ -148,7 +148,7 @@ ao_lisp_string_print(ao_poly p) } void -ao_lisp_string_patom(ao_poly p) +ao_lisp_string_display(ao_poly p) { char *s = ao_lisp_poly_string(p); char c; -- cgit v1.2.3 From 65fb0ad8693407cc9bd114424c1f51b6aa6befc3 Mon Sep 17 00:00:00 2001 From: Keith Packard Date: Fri, 17 Nov 2017 23:27:36 -0800 Subject: altos/test: Add jiffy funcs to lisp test Signed-off-by: Keith Packard --- src/test/ao_lisp_os.h | 19 ++++++++++++++----- 1 file changed, 14 insertions(+), 5 deletions(-) (limited to 'src') diff --git a/src/test/ao_lisp_os.h b/src/test/ao_lisp_os.h index 9ff2e1fe..9b021900 100644 --- a/src/test/ao_lisp_os.h +++ b/src/test/ao_lisp_os.h @@ -45,15 +45,24 @@ ao_lisp_os_led(int led) printf("leds set to 0x%x\n", led); } +#define AO_LISP_JIFFIES_PER_SECOND 100 + static inline void -ao_lisp_os_delay(int delay) +ao_lisp_os_delay(int jiffies) { - if (!delay) - return; struct timespec ts = { - .tv_sec = delay / 1000, - .tv_nsec = (delay % 1000) * 1000000, + .tv_sec = jiffies / AO_LISP_JIFFIES_PER_SECOND, + .tv_nsec = (jiffies % AO_LISP_JIFFIES_PER_SECOND) * (1000000000L / AO_LISP_JIFFIES_PER_SECOND) }; nanosleep(&ts, NULL); } + +static inline int +ao_lisp_os_jiffy(void) +{ + struct timespec tp; + clock_gettime(CLOCK_MONOTONIC, &tp); + return tp.tv_sec * AO_LISP_JIFFIES_PER_SECOND + (tp.tv_nsec / (1000000000L / AO_LISP_JIFFIES_PER_SECOND)); +} + #endif -- cgit v1.2.3 From e745229311366a792110d78d8480a2bf83eef9a0 Mon Sep 17 00:00:00 2001 From: Keith Packard Date: Fri, 17 Nov 2017 23:28:08 -0800 Subject: altos/cortexelf-v1: Make lisp compile again Signed-off-by: Keith Packard --- src/cortexelf-v1/Makefile | 1 + src/cortexelf-v1/ao_lisp_os.h | 10 +++++++++- src/cortexelf-v1/ao_pins.h | 2 ++ 3 files changed, 12 insertions(+), 1 deletion(-) (limited to 'src') diff --git a/src/cortexelf-v1/Makefile b/src/cortexelf-v1/Makefile index 8cc6ce31..be225e57 100644 --- a/src/cortexelf-v1/Makefile +++ b/src/cortexelf-v1/Makefile @@ -82,6 +82,7 @@ ALTOS_SRC = \ ao_lisp_atom.c \ ao_lisp_int.c \ ao_lisp_poly.c \ + ao_lisp_bool.c \ ao_lisp_builtin.c \ ao_lisp_read.c \ ao_lisp_rep.c \ diff --git a/src/cortexelf-v1/ao_lisp_os.h b/src/cortexelf-v1/ao_lisp_os.h index d0c1f7b7..50c9d40f 100644 --- a/src/cortexelf-v1/ao_lisp_os.h +++ b/src/cortexelf-v1/ao_lisp_os.h @@ -56,10 +56,18 @@ ao_lisp_os_led(int led) (void) led; } +#define AO_LISP_JIFFIES_PER_SECOND AO_HERTZ + static inline void ao_lisp_os_delay(int delay) { - ao_delay(AO_MS_TO_TICKS(delay)); + ao_delay(delay); +} + +static inline int +ao_lisp_os_jiffy(void) +{ + return ao_tick_count; } #endif 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 -- cgit v1.2.3 From 5f8f0ed5cd5d4b4f793c602ed09f9b4bdb98f7e8 Mon Sep 17 00:00:00 2001 From: Keith Packard Date: Sat, 18 Nov 2017 20:38:15 -0800 Subject: altos/lisp: Add 'big' ints -- 24 bits wide With the default ints being only 14 bits, having a larger type with more precision seems useful. This is not exposed to the application. Signed-off-by: Keith Packard --- src/cortexelf-v1/ao_lisp_os.h | 6 ++++ src/lisp/ao_lisp.h | 69 ++++++++++++++++++++++++++++++++++++++++--- src/lisp/ao_lisp_builtin.c | 30 ++++++++++++------- src/lisp/ao_lisp_eval.c | 1 + src/lisp/ao_lisp_int.c | 57 +++++++++++++++++++++++++++++++++++ src/lisp/ao_lisp_mem.c | 1 + src/lisp/ao_lisp_poly.c | 4 +++ src/lisp/ao_lisp_read.c | 4 +-- src/lisp/ao_lisp_string.c | 4 +-- 9 files changed, 157 insertions(+), 19 deletions(-) (limited to 'src') diff --git a/src/cortexelf-v1/ao_lisp_os.h b/src/cortexelf-v1/ao_lisp_os.h index 50c9d40f..27ea7806 100644 --- a/src/cortexelf-v1/ao_lisp_os.h +++ b/src/cortexelf-v1/ao_lisp_os.h @@ -23,6 +23,12 @@ #define AO_LISP_POOL_TOTAL 16384 #define AO_LISP_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() { static uint8_t at_eol; diff --git a/src/lisp/ao_lisp.h b/src/lisp/ao_lisp.h index a10ccc43..08278fe7 100644 --- a/src/lisp/ao_lisp.h +++ b/src/lisp/ao_lisp.h @@ -21,6 +21,9 @@ #include #include #include +#ifndef __BYTE_ORDER +#include +#endif typedef uint16_t ao_poly; typedef int16_t ao_signed_poly; @@ -92,7 +95,8 @@ extern uint8_t ao_lisp_pool[AO_LISP_POOL + AO_LISP_POOL_EXTRA] __attribute__((a #define AO_LISP_LAMBDA 7 #define AO_LISP_STACK 8 #define AO_LISP_BOOL 9 -#define AO_LISP_NUM_TYPE 10 +#define AO_LISP_BIGINT 10 +#define AO_LISP_NUM_TYPE 11 /* Leave two bits for types to use as they please */ #define AO_LISP_OTHER_TYPE_MASK 0x3f @@ -162,6 +166,35 @@ struct ao_lisp_bool { uint16_t pad; }; +struct ao_lisp_bigint { + uint32_t value; +}; + +#if __BYTE_ORDER == __LITTLE_ENDIAN +static inline uint32_t +ao_lisp_int_bigint(int32_t i) { + return AO_LISP_BIGINT | (i << 8); +} +static inline int32_t +ao_lisp_bigint_int(uint32_t bi) { + return (int32_t) bi >> 8; +} +#else +static inline uint32_t +ao_lisp_int_bigint(int32_t i) { + return (uint32_t) (i & 0xffffff) | (AO_LISP_BIGINT << 24); +} +static inlint int32_t +ao_lisp_bigint_int(uint32_t bi) { + return (int32_t) (bi << 8) >> 8; +} +#endif + +#define AO_LISP_MIN_INT (-(1 << (15 - AO_LISP_TYPE_SHIFT))) +#define AO_LISP_MAX_INT ((1 << (15 - AO_LISP_TYPE_SHIFT)) - 1) + +#define AO_LISP_NOT_INTEGER 0x7fffffff + /* Set on type when the frame escapes the lambda */ #define AO_LISP_FRAME_MARK 0x80 #define AO_LISP_FRAME_PRINT 0x40 @@ -338,18 +371,30 @@ ao_lisp_cons_poly(struct ao_lisp_cons *cons) return ao_lisp_poly(cons, AO_LISP_CONS); } -static inline int +static inline int32_t ao_lisp_poly_int(ao_poly poly) { - return (int) ((ao_signed_poly) poly >> AO_LISP_TYPE_SHIFT); + return (int32_t) ((ao_signed_poly) poly >> AO_LISP_TYPE_SHIFT); } static inline ao_poly -ao_lisp_int_poly(int i) +ao_lisp_int_poly(int32_t i) { return ((ao_poly) i << 2) | AO_LISP_INT; } +static inline struct ao_lisp_bigint * +ao_lisp_poly_bigint(ao_poly poly) +{ + return ao_lisp_ref(poly); +} + +static inline ao_poly +ao_lisp_bigint_poly(struct ao_lisp_bigint *bi) +{ + return ao_lisp_poly(bi, AO_LISP_OTHER); +} + static inline char * ao_lisp_poly_string(ao_poly poly) { @@ -543,6 +588,22 @@ ao_lisp_atom_set(ao_poly atom, ao_poly val); void ao_lisp_int_write(ao_poly i); +int32_t +ao_lisp_poly_integer(ao_poly p); + +ao_poly +ao_lisp_integer_poly(int32_t i); + +static inline int +ao_lisp_integer_typep(uint8_t t) +{ + return (t == AO_LISP_INT) || (t == AO_LISP_BIGINT); +} + +void +ao_lisp_bigint_write(ao_poly i); + +extern const struct ao_lisp_type ao_lisp_bigint_type; /* prim */ void ao_lisp_poly_write(ao_poly p); diff --git a/src/lisp/ao_lisp_builtin.c b/src/lisp/ao_lisp_builtin.c index 6dd4d5e6..ccd13d07 100644 --- a/src/lisp/ao_lisp_builtin.c +++ b/src/lisp/ao_lisp_builtin.c @@ -290,10 +290,10 @@ ao_lisp_math(struct ao_lisp_cons *cons, enum ao_lisp_builtin_id op) if (cons->cdr == AO_LISP_NIL && ct == AO_LISP_INT) { switch (op) { case builtin_minus: - ret = ao_lisp_int_poly(-ao_lisp_poly_int(ret)); + ret = ao_lisp_integer_poly(-ao_lisp_poly_integer(ret)); break; case builtin_divide: - switch (ao_lisp_poly_int(ret)) { + switch (ao_lisp_poly_integer(ret)) { case 0: return ao_lisp_error(AO_LISP_DIVIDE_BY_ZERO, "divide by zero"); case 1: @@ -307,9 +307,9 @@ ao_lisp_math(struct ao_lisp_cons *cons, enum ao_lisp_builtin_id op) break; } } - } else if (rt == AO_LISP_INT && ct == AO_LISP_INT) { - int r = ao_lisp_poly_int(ret); - int c = ao_lisp_poly_int(car); + } else if (ao_lisp_integer_typep(rt) && ao_lisp_integer_typep(ct)) { + int32_t r = ao_lisp_poly_integer(ret); + int32_t c = ao_lisp_poly_integer(car); switch(op) { case builtin_plus: @@ -349,7 +349,7 @@ ao_lisp_math(struct ao_lisp_cons *cons, enum ao_lisp_builtin_id op) default: break; } - ret = ao_lisp_int_poly(r); + ret = ao_lisp_integer_poly(r); } else if (rt == AO_LISP_STRING && ct == AO_LISP_STRING && op == builtin_plus) @@ -427,9 +427,9 @@ ao_lisp_compare(struct ao_lisp_cons *cons, enum ao_lisp_builtin_id op) } 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); + if (ao_lisp_integer_typep(lt) && ao_lisp_integer_typep(rt)) { + int32_t l = ao_lisp_poly_integer(left); + int32_t r = ao_lisp_poly_integer(right); switch (op) { case builtin_less: @@ -643,7 +643,15 @@ ao_lisp_do_pairp(struct ao_lisp_cons *cons) ao_poly ao_lisp_do_numberp(struct ao_lisp_cons *cons) { - return ao_lisp_do_typep(AO_LISP_INT, cons); + if (!ao_lisp_check_argc(_ao_lisp_atom_led, cons, 1, 1)) + return AO_LISP_NIL; + switch (ao_lisp_poly_type(ao_lisp_arg(cons, 0))) { + case AO_LISP_INT: + case AO_LISP_BIGINT: + return _ao_lisp_bool_true; + default: + return _ao_lisp_bool_false; + } } ao_poly @@ -755,7 +763,7 @@ ao_lisp_do_write_char(struct ao_lisp_cons *cons) return AO_LISP_NIL; if (!ao_lisp_check_argt(_ao_lisp_atom_led, cons, 0, AO_LISP_INT, 0)) return AO_LISP_NIL; - putchar(ao_lisp_poly_int(ao_lisp_arg(cons, 0))); + putchar(ao_lisp_poly_integer(ao_lisp_arg(cons, 0))); return _ao_lisp_bool_true; } diff --git a/src/lisp/ao_lisp_eval.c b/src/lisp/ao_lisp_eval.c index 758a9232..8fa488e2 100644 --- a/src/lisp/ao_lisp_eval.c +++ b/src/lisp/ao_lisp_eval.c @@ -110,6 +110,7 @@ ao_lisp_eval_sexpr(void) /* fall through */ case AO_LISP_BOOL: case AO_LISP_INT: + case AO_LISP_BIGINT: case AO_LISP_STRING: case AO_LISP_BUILTIN: case AO_LISP_LAMBDA: diff --git a/src/lisp/ao_lisp_int.c b/src/lisp/ao_lisp_int.c index 3b5341bd..8e467755 100644 --- a/src/lisp/ao_lisp_int.c +++ b/src/lisp/ao_lisp_int.c @@ -20,3 +20,60 @@ ao_lisp_int_write(ao_poly p) int i = ao_lisp_poly_int(p); printf("%d", i); } + +int32_t +ao_lisp_poly_integer(ao_poly p) +{ + switch (ao_lisp_poly_base_type(p)) { + case AO_LISP_INT: + return ao_lisp_poly_int(p); + case AO_LISP_OTHER: + if (ao_lisp_other_type(ao_lisp_poly_other(p)) == AO_LISP_BIGINT) + return ao_lisp_bigint_int(ao_lisp_poly_bigint(p)->value); + } + return AO_LISP_NOT_INTEGER; +} + +ao_poly +ao_lisp_integer_poly(int32_t p) +{ + struct ao_lisp_bigint *bi; + + if (AO_LISP_MIN_INT <= p && p <= AO_LISP_MAX_INT) + return ao_lisp_int_poly(p); + bi = ao_lisp_alloc(sizeof (struct ao_lisp_bigint)); + bi->value = ao_lisp_int_bigint(p); + return ao_lisp_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_lisp_bigint); +} + +static void bigint_move(void *addr) +{ + (void) addr; +} + +const struct ao_lisp_type ao_lisp_bigint_type = { + .mark = bigint_mark, + .size = bigint_size, + .move = bigint_move, + .name = "bigint", +}; + +void +ao_lisp_bigint_write(ao_poly p) +{ + struct ao_lisp_bigint *bi = ao_lisp_poly_bigint(p); + + printf("%d", ao_lisp_bigint_int(bi->value)); +} diff --git a/src/lisp/ao_lisp_mem.c b/src/lisp/ao_lisp_mem.c index 156221e8..f333073a 100644 --- a/src/lisp/ao_lisp_mem.c +++ b/src/lisp/ao_lisp_mem.c @@ -458,6 +458,7 @@ static const struct ao_lisp_type *ao_lisp_types[AO_LISP_NUM_TYPE] = { [AO_LISP_LAMBDA] = &ao_lisp_lambda_type, [AO_LISP_STACK] = &ao_lisp_stack_type, [AO_LISP_BOOL] = &ao_lisp_bool_type, + [AO_LISP_BIGINT] = &ao_lisp_bigint_type, }; static int diff --git a/src/lisp/ao_lisp_poly.c b/src/lisp/ao_lisp_poly.c index 7e4c98d2..94ecd042 100644 --- a/src/lisp/ao_lisp_poly.c +++ b/src/lisp/ao_lisp_poly.c @@ -56,6 +56,10 @@ static const struct ao_lisp_funcs ao_lisp_funcs[AO_LISP_NUM_TYPE] = { .write = ao_lisp_bool_write, .display = ao_lisp_bool_write, }, + [AO_LISP_BIGINT] = { + .write = ao_lisp_bigint_write, + .display = ao_lisp_bigint_write, + }, }; static const struct ao_lisp_funcs * diff --git a/src/lisp/ao_lisp_read.c b/src/lisp/ao_lisp_read.c index 8c06e198..5115f46e 100644 --- a/src/lisp/ao_lisp_read.c +++ b/src/lisp/ao_lisp_read.c @@ -245,7 +245,7 @@ lex_quoted(void) #define AO_LISP_TOKEN_MAX 32 static char token_string[AO_LISP_TOKEN_MAX]; -static int token_int; +static int32_t token_int; static int token_len; static inline void add_token(int c) { @@ -497,7 +497,7 @@ ao_lisp_read(void) v = AO_LISP_NIL; break; case NUM: - v = ao_lisp_int_poly(token_int); + v = ao_lisp_integer_poly(token_int); break; case BOOL: if (token_string[0] == 't') diff --git a/src/lisp/ao_lisp_string.c b/src/lisp/ao_lisp_string.c index 87f9289c..fff218df 100644 --- a/src/lisp/ao_lisp_string.c +++ b/src/lisp/ao_lisp_string.c @@ -83,9 +83,9 @@ ao_lisp_string_pack(struct ao_lisp_cons *cons) char *s = r; while (cons) { - if (ao_lisp_poly_type(cons->car) != AO_LISP_INT) + if (!ao_lisp_integer_typep(ao_lisp_poly_type(cons->car))) return ao_lisp_error(AO_LISP_INVALID, "non-int passed to pack"); - *s++ = ao_lisp_poly_int(cons->car); + *s++ = ao_lisp_poly_integer(cons->car); cons = ao_lisp_poly_cons(cons->cdr); } *s++ = 0; -- cgit v1.2.3 From 12a1f6ad48f2b924f71239effeb90afca75a090f Mon Sep 17 00:00:00 2001 From: Keith Packard Date: Sat, 18 Nov 2017 22:00:44 -0800 Subject: altos/lisp: Fix some scheme compat issues flush -> flush-output nth -> list-ref (oh, and add list-tail) add let* (same as let for now) write control chars in octal make hanoi example work Signed-off-by: Keith Packard --- src/lisp/ao_lisp_builtin.c | 4 +- src/lisp/ao_lisp_builtin.txt | 2 +- src/lisp/ao_lisp_const.lisp | 16 +++- src/lisp/ao_lisp_string.c | 5 +- src/test/hanoi.lisp | 185 ++++++++++++++++++++++--------------------- 5 files changed, 115 insertions(+), 97 deletions(-) (limited to 'src') diff --git a/src/lisp/ao_lisp_builtin.c b/src/lisp/ao_lisp_builtin.c index ccd13d07..e5370f90 100644 --- a/src/lisp/ao_lisp_builtin.c +++ b/src/lisp/ao_lisp_builtin.c @@ -533,9 +533,9 @@ ao_lisp_do_string_to_list(struct ao_lisp_cons *cons) } ao_poly -ao_lisp_do_flush(struct ao_lisp_cons *cons) +ao_lisp_do_flush_output(struct ao_lisp_cons *cons) { - if (!ao_lisp_check_argc(_ao_lisp_atom_flush, cons, 0, 0)) + if (!ao_lisp_check_argc(_ao_lisp_atom_flush2doutput, cons, 0, 0)) return AO_LISP_NIL; ao_lisp_os_flush(); return _ao_lisp_bool_true; diff --git a/src/lisp/ao_lisp_builtin.txt b/src/lisp/ao_lisp_builtin.txt index 4c484337..c324ca67 100644 --- a/src/lisp/ao_lisp_builtin.txt +++ b/src/lisp/ao_lisp_builtin.txt @@ -31,7 +31,7 @@ f_lexpr less_equal <= f_lexpr greater_equal >= f_lambda list_to_string list->string f_lambda string_to_list string->list -f_lambda flush +f_lambda flush_output flush-output f_lambda delay f_lexpr led f_lambda save diff --git a/src/lisp/ao_lisp_const.lisp b/src/lisp/ao_lisp_const.lisp index 191ef005..861a4fc8 100644 --- a/src/lisp/ao_lisp_const.lisp +++ b/src/lisp/ao_lisp_const.lisp @@ -60,10 +60,17 @@ (defun caddr (l) (car (cdr (cdr l)))) -(defun nth (list n) - (cond ((= n 0) (car list)) - ((nth (cdr list) (1- n))) - ) +(define list-tail (lambda (x k) + (if (zero? k) + x + (list-tail (cdr x (- k 1))) + ) + ) + ) + +(define list-ref (lambda (x k) + (car (list-tail x k)) + ) ) ; simple math operators @@ -264,6 +271,7 @@ (let ((x 1)) x) +(define let* let) ; boolean operators (define or (lexpr (l) diff --git a/src/lisp/ao_lisp_string.c b/src/lisp/ao_lisp_string.c index fff218df..1daa50ea 100644 --- a/src/lisp/ao_lisp_string.c +++ b/src/lisp/ao_lisp_string.c @@ -140,7 +140,10 @@ ao_lisp_string_write(ao_poly p) printf ("\\t"); break; default: - putchar(c); + if (c < ' ') + printf("\\%03o", c); + else + putchar(c); break; } } diff --git a/src/test/hanoi.lisp b/src/test/hanoi.lisp index e2eb0fa0..e873c796 100644 --- a/src/test/hanoi.lisp +++ b/src/test/hanoi.lisp @@ -16,129 +16,133 @@ ; ANSI control sequences -(defun move-to (col row) - (patom "\033[" row ";" col "H") +(define move-to (lambda (col row) + (for-each display (list "\033[" row ";" col "H")) + ) ) -(defun clear () - (patom "\033[2J") +(define clear (lambda () + (display "\033[2J") + ) ) -(defun display-string (x y str) - (move-to x y) - (patom str) +(define display-string (lambda (x y str) + (move-to x y) + (display str) + ) ) ; Here's the pieces to display -(setq stack '(" * " " *** " " ***** " " ******* " " ********* " "***********")) +(define tower '(" * " " *** " " ***** " " ******* " " ********* " "***********")) - ; Here's all of the stacks of pieces + ; Here's all of the towers of pieces ; This is generated when the program is run -(setq stacks nil) +(define towers ()) - ; Display one stack, clearing any +(define 1- (lambda (x) (- x 1))) + ; Display one tower, 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) - ) - ) +(define display-tower (lambda (x y clear tower) + (cond ((= 0 clear) + (cond ((not (null? tower)) + (display-string x y (car tower)) + (display-tower x (1+ y) 0 (cdr tower)) + ) + ) + ) + (else + (display-string x y " ") + (display-tower x (1+ y) (1- clear) tower) + ) + ) + ) ) - ; Position of the top of the stack on the screen - ; Shorter stacks start further down the screen + ; Position of the top of the tower on the screen + ; Shorter towers start further down the screen -(defun stack-pos (y stack) - (- y (length stack)) +(define tower-pos (lambda (y tower) + (- y (length tower)) + ) ) - ; Display all of the stacks, spaced 20 columns apart + ; Display all of the towers, 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))) - ) +(define display-towers (lambda (x y towers) + (cond ((not (null? towers)) + (display-tower x 0 (tower-pos y (car towers)) (car towers)) + (display-towers (+ x 20) y (cdr towers))) + ) + ) ) - ; Display all of the stacks, then move the cursor +(define top 0) + ; Display all of the towers, then move the cursor ; out of the way and flush the output -(defun display () - (display-stacks 0 top stacks) - (move-to 1 21) - (flush) +(define display-hanoi (lambda () + (display-towers 0 top towers) + (move-to 1 21) + (flush-output) + ) ) - ; Reset stacks to the starting state, with - ; all of the pieces in the first stack and the + ; Reset towers to the starting state, with + ; all of the pieces in the first tower 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) - ) +(define reset-towers (lambda () + (set! towers (list tower () ())) + (set! top (+ (length tower) 3)) + (length tower) + ) ) - ; Replace a stack in the list of stacks + ; Replace a tower in the list of towers ; 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))) - ) +(define replace (lambda (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 + ; Move a piece from the top of one tower ; 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) - ) +(define move-delay 10) + +(define move-piece (lambda (from to) + (let* ((from-tower (list-ref towers from)) + (to-tower (list-ref towers to)) + (piece (car from-tower))) + (set! from-tower (cdr from-tower)) + (set! to-tower (cons piece to-tower)) + (set! towers (replace towers from from-tower)) + (set! towers (replace towers to to-tower)) + (display-hanoi) +; (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) - ) - ) +(define _hanoi (lambda (n from to use) + (cond ((= 1 n) + (move-piece from to) + ) + (else + (_hanoi (1- n) from use to) + (_hanoi 1 from to use) + (_hanoi (1- n) use to from) + ) + ) + ) ) ; A pretty interface which @@ -146,10 +150,13 @@ ; clears the screen and runs ; the program -(defun hanoi () - (setq len (reset-stacks)) - (clear) - (_hanoi len 0 1 2) - (move-to 0 23) - t +(define hanoi (lambda () + (let ((len)) + (set! len (reset-towers)) + (clear) + (_hanoi len 0 1 2) + (move-to 0 23) + #t + ) + ) ) -- cgit v1.2.3 From 6d2f271a45759bd792d299f04a424d3382ef4798 Mon Sep 17 00:00:00 2001 From: Keith Packard Date: Sun, 19 Nov 2017 21:07:00 -0800 Subject: altos/lisp: Add floats Signed-off-by: Keith Packard --- src/lisp/Makefile | 2 +- src/lisp/Makefile-inc | 1 + src/lisp/ao_lisp.h | 48 +++++++++++++- src/lisp/ao_lisp_builtin.c | 119 ++++++++++++++++++++++++---------- src/lisp/ao_lisp_builtin.txt | 7 +- src/lisp/ao_lisp_cons.c | 13 ++++ src/lisp/ao_lisp_const.lisp | 3 - src/lisp/ao_lisp_eval.c | 1 + src/lisp/ao_lisp_float.c | 148 +++++++++++++++++++++++++++++++++++++++++++ src/lisp/ao_lisp_mem.c | 1 + src/lisp/ao_lisp_poly.c | 4 ++ src/lisp/ao_lisp_read.c | 77 ++++++++++++++++++---- src/lisp/ao_lisp_read.h | 24 +++---- 13 files changed, 384 insertions(+), 64 deletions(-) create mode 100644 src/lisp/ao_lisp_float.c (limited to 'src') diff --git a/src/lisp/Makefile b/src/lisp/Makefile index 4563dad3..05f54550 100644 --- a/src/lisp/Makefile +++ b/src/lisp/Makefile @@ -19,6 +19,6 @@ OBJS=$(SRCS:.c=.o) CFLAGS=-DAO_LISP_MAKE_CONST -O0 -g -I. -Wall -Wextra -no-pie ao_lisp_make_const: $(OBJS) - $(CC) $(CFLAGS) -o $@ $(OBJS) + $(CC) $(CFLAGS) -o $@ $(OBJS) -lm $(OBJS): $(HDRS) diff --git a/src/lisp/Makefile-inc b/src/lisp/Makefile-inc index 6c8702fb..a097f1be 100644 --- a/src/lisp/Makefile-inc +++ b/src/lisp/Makefile-inc @@ -6,6 +6,7 @@ LISP_SRCS=\ ao_lisp_int.c \ ao_lisp_poly.c \ ao_lisp_bool.c \ + ao_lisp_float.c \ ao_lisp_builtin.c \ ao_lisp_read.c \ ao_lisp_frame.c \ diff --git a/src/lisp/ao_lisp.h b/src/lisp/ao_lisp.h index 08278fe7..cbbbe9a4 100644 --- a/src/lisp/ao_lisp.h +++ b/src/lisp/ao_lisp.h @@ -96,7 +96,8 @@ extern uint8_t ao_lisp_pool[AO_LISP_POOL + AO_LISP_POOL_EXTRA] __attribute__((a #define AO_LISP_STACK 8 #define AO_LISP_BOOL 9 #define AO_LISP_BIGINT 10 -#define AO_LISP_NUM_TYPE 11 +#define AO_LISP_FLOAT 11 +#define AO_LISP_NUM_TYPE 12 /* Leave two bits for types to use as they please */ #define AO_LISP_OTHER_TYPE_MASK 0x3f @@ -170,6 +171,13 @@ struct ao_lisp_bigint { uint32_t value; }; +struct ao_lisp_float { + uint8_t type; + uint8_t pad1; + uint16_t pad2; + float value; +}; + #if __BYTE_ORDER == __LITTLE_ENDIAN static inline uint32_t ao_lisp_int_bigint(int32_t i) { @@ -442,6 +450,22 @@ ao_lisp_poly_bool(ao_poly poly) { return ao_lisp_ref(poly); } + +static inline ao_poly +ao_lisp_float_poly(struct ao_lisp_float *f) +{ + return ao_lisp_poly(f, AO_LISP_OTHER); +} + +static inline struct ao_lisp_float * +ao_lisp_poly_float(ao_poly poly) +{ + return ao_lisp_ref(poly); +} + +float +ao_lisp_poly_number(ao_poly p); + /* memory functions */ extern int ao_lisp_collects[2]; @@ -524,6 +548,10 @@ extern const struct ao_lisp_type ao_lisp_cons_type; struct ao_lisp_cons * ao_lisp_cons_cons(ao_poly car, ao_poly cdr); +/* Return a cons or NULL for a proper list, else error */ +struct ao_lisp_cons * +ao_lisp_cons_cdr(struct ao_lisp_cons *cons); + ao_poly ao_lisp__cons(ao_poly car, ao_poly cdr); @@ -632,6 +660,24 @@ ao_lisp_eval(ao_poly p); ao_poly ao_lisp_set_cond(struct ao_lisp_cons *cons); +/* float */ +extern const struct ao_lisp_type ao_lisp_float_type; + +void +ao_lisp_float_write(ao_poly p); + +ao_poly +ao_lisp_float_get(float value); + +static inline uint8_t +ao_lisp_number_typep(uint8_t t) +{ + return ao_lisp_integer_typep(t) || (t == AO_LISP_FLOAT); +} + +float +ao_lisp_poly_number(ao_poly p); + /* builtin */ void ao_lisp_builtin_write(ao_poly b); diff --git a/src/lisp/ao_lisp_builtin.c b/src/lisp/ao_lisp_builtin.c index e5370f90..d4dc8a86 100644 --- a/src/lisp/ao_lisp_builtin.c +++ b/src/lisp/ao_lisp_builtin.c @@ -14,6 +14,7 @@ #include "ao_lisp.h" #include +#include static int builtin_size(void *addr) @@ -98,7 +99,7 @@ ao_lisp_check_argc(ao_poly name, struct ao_lisp_cons *cons, int min, int max) while (cons && argc <= max) { argc++; - cons = ao_lisp_poly_cons(cons->cdr); + cons = ao_lisp_cons_cdr(cons); } if (argc < min || argc > max) return ao_lisp_error(AO_LISP_INVALID, "%s: invalid arg count", ao_lisp_poly_atom(name)->name); @@ -113,7 +114,7 @@ ao_lisp_arg(struct ao_lisp_cons *cons, int argc) while (argc--) { if (!cons) return AO_LISP_NIL; - cons = ao_lisp_poly_cons(cons->cdr); + cons = ao_lisp_cons_cdr(cons); } return cons->car; } @@ -162,17 +163,17 @@ ao_lisp_do_cons(struct ao_lisp_cons *cons) ao_poly ao_lisp_do_last(struct ao_lisp_cons *cons) { - ao_poly l; + struct ao_lisp_cons *list; if (!ao_lisp_check_argc(_ao_lisp_atom_last, cons, 1, 1)) return AO_LISP_NIL; if (!ao_lisp_check_argt(_ao_lisp_atom_last, cons, 0, AO_LISP_CONS, 1)) return AO_LISP_NIL; - l = ao_lisp_arg(cons, 0); - while (l) { - struct ao_lisp_cons *list = ao_lisp_poly_cons(l); + for (list = ao_lisp_poly_cons(ao_lisp_arg(cons, 0)); + list; + list = ao_lisp_cons_cdr(list)) + { if (!list->cdr) return list->car; - l = list->cdr; } return AO_LISP_NIL; } @@ -253,7 +254,7 @@ ao_lisp_do_write(struct ao_lisp_cons *cons) while (cons) { val = cons->car; ao_lisp_poly_write(val); - cons = ao_lisp_poly_cons(cons->cdr); + cons = ao_lisp_cons_cdr(cons); if (cons) printf(" "); } @@ -268,39 +269,38 @@ ao_lisp_do_display(struct ao_lisp_cons *cons) while (cons) { val = cons->car; ao_lisp_poly_display(val); - cons = ao_lisp_poly_cons(cons->cdr); + cons = ao_lisp_cons_cdr(cons); } return _ao_lisp_bool_true; } ao_poly -ao_lisp_math(struct ao_lisp_cons *cons, enum ao_lisp_builtin_id op) +ao_lisp_math(struct ao_lisp_cons *orig_cons, enum ao_lisp_builtin_id op) { - struct ao_lisp_cons *orig_cons = cons; + struct ao_lisp_cons *cons = cons; ao_poly ret = AO_LISP_NIL; - while (cons) { + for (cons = orig_cons; cons; cons = ao_lisp_cons_cdr(cons)) { ao_poly car = cons->car; - ao_poly cdr; uint8_t rt = ao_lisp_poly_type(ret); uint8_t ct = ao_lisp_poly_type(car); if (cons == orig_cons) { ret = car; - if (cons->cdr == AO_LISP_NIL && ct == AO_LISP_INT) { + if (cons->cdr == AO_LISP_NIL) { switch (op) { case builtin_minus: - ret = ao_lisp_integer_poly(-ao_lisp_poly_integer(ret)); + if (ao_lisp_integer_typep(ct)) + ret = ao_lisp_integer_poly(-ao_lisp_poly_integer(ret)); + else if (ct == AO_LISP_FLOAT) + ret = ao_lisp_float_get(-ao_lisp_poly_number(ret)); break; case builtin_divide: - switch (ao_lisp_poly_integer(ret)) { - case 0: - return ao_lisp_error(AO_LISP_DIVIDE_BY_ZERO, "divide by zero"); - case 1: - break; - default: - ret = ao_lisp_int_poly(0); - break; + if (ao_lisp_integer_typep(ct) && ao_lisp_poly_integer(ret) == 1) + ; + else if (ao_lisp_number_typep(ct)) { + float v = ao_lisp_poly_number(ret); + ret = ao_lisp_float_get(1/v); } break; default: @@ -322,10 +322,54 @@ ao_lisp_math(struct ao_lisp_cons *cons, enum ao_lisp_builtin_id op) r *= c; break; case builtin_divide: + if (c != 0 && (r % c) == 0) + r /= c; + else { + ret = ao_lisp_float_get((float) r / (float) c); + continue; + } + break; + case builtin_quotient: + if (c == 0) + return ao_lisp_error(AO_LISP_DIVIDE_BY_ZERO, "quotient by zero"); + if (r % c != 0 && (c < 0) != (r < 0)) + r = r / c - 1; + else + r = r / c; + break; + case builtin_remainder: if (c == 0) - return ao_lisp_error(AO_LISP_DIVIDE_BY_ZERO, "divide by zero"); + return ao_lisp_error(AO_LISP_DIVIDE_BY_ZERO, "remainder by zero"); + r %= c; + break; + case builtin_modulo: + if (c == 0) + return ao_lisp_error(AO_LISP_DIVIDE_BY_ZERO, "modulo by zero"); + r %= c; + if ((r < 0) != (c < 0)) + r += c; + break; + default: + break; + } + ret = ao_lisp_integer_poly(r); + } else if (ao_lisp_number_typep(rt) && ao_lisp_number_typep(ct)) { + float r = ao_lisp_poly_number(ret); + float c = ao_lisp_poly_number(car); + switch(op) { + case builtin_plus: + r += c; + break; + case builtin_minus: + r -= c; + break; + case builtin_times: + r *= c; + break; + case builtin_divide: r /= c; break; +#if 0 case builtin_quotient: if (c == 0) return ao_lisp_error(AO_LISP_DIVIDE_BY_ZERO, "quotient by zero"); @@ -346,10 +390,11 @@ ao_lisp_math(struct ao_lisp_cons *cons, enum ao_lisp_builtin_id op) if ((r < 0) != (c < 0)) r += c; break; +#endif default: break; } - ret = ao_lisp_integer_poly(r); + ret = ao_lisp_float_get(r); } else if (rt == AO_LISP_STRING && ct == AO_LISP_STRING && op == builtin_plus) @@ -357,11 +402,6 @@ ao_lisp_math(struct ao_lisp_cons *cons, enum ao_lisp_builtin_id op) ao_lisp_poly_string(car))); else return ao_lisp_error(AO_LISP_INVALID, "invalid args"); - - cdr = cons->cdr; - if (cdr != AO_LISP_NIL && ao_lisp_poly_type(cdr) != AO_LISP_CONS) - return ao_lisp_error(AO_LISP_INVALID, "improper list"); - cons = ao_lisp_poly_cons(cdr); } return ret; } @@ -417,8 +457,7 @@ ao_lisp_compare(struct ao_lisp_cons *cons, enum ao_lisp_builtin_id op) return _ao_lisp_bool_true; left = cons->car; - cons = ao_lisp_poly_cons(cons->cdr); - while (cons) { + for (cons = ao_lisp_cons_cdr(cons); cons; cons = ao_lisp_cons_cdr(cons)) { ao_poly right = cons->car; if (op == builtin_equal) { @@ -477,7 +516,6 @@ ao_lisp_compare(struct ao_lisp_cons *cons, enum ao_lisp_builtin_id op) } } left = right; - cons = ao_lisp_poly_cons(cons->cdr); } return _ao_lisp_bool_true; } @@ -640,6 +678,20 @@ ao_lisp_do_pairp(struct ao_lisp_cons *cons) return ao_lisp_do_typep(AO_LISP_CONS, cons); } +ao_poly +ao_lisp_do_integerp(struct ao_lisp_cons *cons) +{ + if (!ao_lisp_check_argc(_ao_lisp_atom_led, cons, 1, 1)) + return AO_LISP_NIL; + switch (ao_lisp_poly_type(ao_lisp_arg(cons, 0))) { + case AO_LISP_INT: + case AO_LISP_BIGINT: + return _ao_lisp_bool_true; + default: + return _ao_lisp_bool_false; + } +} + ao_poly ao_lisp_do_numberp(struct ao_lisp_cons *cons) { @@ -648,6 +700,7 @@ ao_lisp_do_numberp(struct ao_lisp_cons *cons) switch (ao_lisp_poly_type(ao_lisp_arg(cons, 0))) { case AO_LISP_INT: case AO_LISP_BIGINT: + case AO_LISP_FLOAT: return _ao_lisp_bool_true; default: return _ao_lisp_bool_false; diff --git a/src/lisp/ao_lisp_builtin.txt b/src/lisp/ao_lisp_builtin.txt index c324ca67..2e11bdad 100644 --- a/src/lisp/ao_lisp_builtin.txt +++ b/src/lisp/ao_lisp_builtin.txt @@ -42,7 +42,8 @@ f_lambda nullp null? f_lambda not f_lambda listp list? f_lambda pairp pair? -f_lambda numberp number? integer? +f_lambda integerp integer? exact? exact-integer? +f_lambda numberp number? real? f_lambda booleanp boolean? f_lambda set_car set-car! f_lambda set_cdr set-cdr! @@ -58,3 +59,7 @@ f_lambda exit f_lambda current_jiffy current-jiffy f_lambda current_second current-second f_lambda jiffies_per_second jiffies-per-second +f_lambda finitep finite? +f_lambda infinitep infinite? +f_lambda inexactp inexact? +f_lambda sqrt diff --git a/src/lisp/ao_lisp_cons.c b/src/lisp/ao_lisp_cons.c index 9379597c..c70aa1ca 100644 --- a/src/lisp/ao_lisp_cons.c +++ b/src/lisp/ao_lisp_cons.c @@ -105,6 +105,19 @@ ao_lisp_cons_cons(ao_poly car, ao_poly cdr) return cons; } +struct ao_lisp_cons * +ao_lisp_cons_cdr(struct ao_lisp_cons *cons) +{ + ao_poly cdr = cons->cdr; + if (cdr == AO_LISP_NIL) + return NULL; + if (ao_lisp_poly_type(cdr) != AO_LISP_CONS) { + (void) ao_lisp_error(AO_LISP_INVALID, "improper list"); + return NULL; + } + return ao_lisp_poly_cons(cdr); +} + ao_poly ao_lisp__cons(ao_poly car, ao_poly cdr) { diff --git a/src/lisp/ao_lisp_const.lisp b/src/lisp/ao_lisp_const.lisp index 861a4fc8..9fb7634c 100644 --- a/src/lisp/ao_lisp_const.lisp +++ b/src/lisp/ao_lisp_const.lisp @@ -159,9 +159,6 @@ (odd? 3) (odd? -1) -(define exact? number?) -(defun inexact? (x) #f) - ; (if ) ; (if + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation, either version 2 of the License, or + * (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, but + * WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + * General Public License for more details. + */ + +#include "ao_lisp.h" +#include + +static void float_mark(void *addr) +{ + (void) addr; +} + +static int float_size(void *addr) +{ + if (!addr) + return 0; + return sizeof (struct ao_lisp_float); +} + +static void float_move(void *addr) +{ + (void) addr; +} + +const struct ao_lisp_type ao_lisp_float_type = { + .mark = float_mark, + .size = float_size, + .move = float_move, + .name = "float", +}; + +void +ao_lisp_float_write(ao_poly p) +{ + struct ao_lisp_float *f = ao_lisp_poly_float(p); + float v = f->value; + + if (isnanf(v)) + printf("+nan.0"); + else if (isinff(v)) { + if (v < 0) + printf("-"); + else + printf("+"); + printf("inf.0"); + } else + printf ("%g", f->value); +} + +float +ao_lisp_poly_number(ao_poly p) +{ + switch (ao_lisp_poly_base_type(p)) { + case AO_LISP_INT: + return ao_lisp_poly_int(p); + case AO_LISP_OTHER: + switch (ao_lisp_other_type(ao_lisp_poly_other(p))) { + case AO_LISP_BIGINT: + return ao_lisp_bigint_int(ao_lisp_poly_bigint(p)->value); + case AO_LISP_FLOAT: + return ao_lisp_poly_float(p)->value; + } + } + return NAN; +} + +ao_poly +ao_lisp_float_get(float value) +{ + struct ao_lisp_float *f; + + f = ao_lisp_alloc(sizeof (struct ao_lisp_float)); + f->type = AO_LISP_FLOAT; + f->value = value; + return ao_lisp_float_poly(f); +} + +ao_poly +ao_lisp_do_inexactp(struct ao_lisp_cons *cons) +{ + if (!ao_lisp_check_argc(_ao_lisp_atom_led, cons, 1, 1)) + return AO_LISP_NIL; + if (ao_lisp_poly_type(ao_lisp_arg(cons, 0)) == AO_LISP_FLOAT) + return _ao_lisp_bool_true; + return _ao_lisp_bool_false; +} + +ao_poly +ao_lisp_do_finitep(struct ao_lisp_cons *cons) +{ + ao_poly value; + float f; + + if (!ao_lisp_check_argc(_ao_lisp_atom_led, cons, 1, 1)) + return AO_LISP_NIL; + value = ao_lisp_arg(cons, 0); + switch (ao_lisp_poly_type(value)) { + case AO_LISP_INT: + case AO_LISP_BIGINT: + return _ao_lisp_bool_true; + case AO_LISP_FLOAT: + f = ao_lisp_poly_float(value)->value; + if (!isnan(f) && !isinf(f)) + return _ao_lisp_bool_true; + } + return _ao_lisp_bool_false; +} + +ao_poly +ao_lisp_do_infinitep(struct ao_lisp_cons *cons) +{ + ao_poly value; + float f; + + if (!ao_lisp_check_argc(_ao_lisp_atom_led, cons, 1, 1)) + return AO_LISP_NIL; + value = ao_lisp_arg(cons, 0); + switch (ao_lisp_poly_type(value)) { + case AO_LISP_FLOAT: + f = ao_lisp_poly_float(value)->value; + if (isinf(f)) + return _ao_lisp_bool_true; + } + return _ao_lisp_bool_false; +} + +ao_poly +ao_lisp_do_sqrt(struct ao_lisp_cons *cons) +{ + ao_poly value; + + if (!ao_lisp_check_argc(_ao_lisp_atom_sqrt, cons, 1, 1)) + return AO_LISP_NIL; + value = ao_lisp_arg(cons, 0); + if (!ao_lisp_number_typep(ao_lisp_poly_type(value))) + return ao_lisp_error(AO_LISP_INVALID, "%s: non-numeric", ao_lisp_poly_atom(_ao_lisp_atom_sqrt)->name); + return ao_lisp_float_get(sqrtf(ao_lisp_poly_number(value))); +} diff --git a/src/lisp/ao_lisp_mem.c b/src/lisp/ao_lisp_mem.c index f333073a..dc0008c4 100644 --- a/src/lisp/ao_lisp_mem.c +++ b/src/lisp/ao_lisp_mem.c @@ -459,6 +459,7 @@ static const struct ao_lisp_type *ao_lisp_types[AO_LISP_NUM_TYPE] = { [AO_LISP_STACK] = &ao_lisp_stack_type, [AO_LISP_BOOL] = &ao_lisp_bool_type, [AO_LISP_BIGINT] = &ao_lisp_bigint_type, + [AO_LISP_FLOAT] = &ao_lisp_float_type, }; static int diff --git a/src/lisp/ao_lisp_poly.c b/src/lisp/ao_lisp_poly.c index 94ecd042..e93e1192 100644 --- a/src/lisp/ao_lisp_poly.c +++ b/src/lisp/ao_lisp_poly.c @@ -60,6 +60,10 @@ static const struct ao_lisp_funcs ao_lisp_funcs[AO_LISP_NUM_TYPE] = { .write = ao_lisp_bigint_write, .display = ao_lisp_bigint_write, }, + [AO_LISP_FLOAT] = { + .write = ao_lisp_float_write, + .display = ao_lisp_float_write, + }, }; static const struct ao_lisp_funcs * diff --git a/src/lisp/ao_lisp_read.c b/src/lisp/ao_lisp_read.c index 5115f46e..c5a238cc 100644 --- a/src/lisp/ao_lisp_read.c +++ b/src/lisp/ao_lisp_read.c @@ -14,6 +14,7 @@ #include "ao_lisp.h" #include "ao_lisp_read.h" +#include static const uint16_t lex_classes[128] = { IGNORE, /* ^@ */ @@ -62,7 +63,7 @@ static const uint16_t lex_classes[128] = { PRINTABLE|SIGN, /* + */ PRINTABLE, /* , */ PRINTABLE|SIGN, /* - */ - PRINTABLE|SPECIAL, /* . */ + PRINTABLE|DOTC|FLOATC, /* . */ PRINTABLE, /* / */ PRINTABLE|DIGIT, /* 0 */ PRINTABLE|DIGIT, /* 1 */ @@ -85,7 +86,7 @@ static const uint16_t lex_classes[128] = { PRINTABLE, /* B */ PRINTABLE, /* C */ PRINTABLE, /* D */ - PRINTABLE, /* E */ + PRINTABLE|FLOATC, /* E */ PRINTABLE, /* F */ PRINTABLE, /* G */ PRINTABLE, /* H */ @@ -117,7 +118,7 @@ static const uint16_t lex_classes[128] = { PRINTABLE, /* b */ PRINTABLE, /* c */ PRINTABLE, /* d */ - PRINTABLE, /* e */ + PRINTABLE|FLOATC, /* e */ PRINTABLE, /* f */ PRINTABLE, /* g */ PRINTABLE, /* h */ @@ -140,7 +141,7 @@ static const uint16_t lex_classes[128] = { PRINTABLE, /* y */ PRINTABLE, /* z */ PRINTABLE, /* { */ - PRINTABLE|VBAR, /* | */ + PRINTABLE, /* | */ PRINTABLE, /* } */ PRINTABLE, /* ~ */ IGNORE, /* ^? */ @@ -247,16 +248,36 @@ lex_quoted(void) static char token_string[AO_LISP_TOKEN_MAX]; static int32_t token_int; static int token_len; +static float token_float; static inline void add_token(int c) { if (c && token_len < AO_LISP_TOKEN_MAX - 1) token_string[token_len++] = c; } +static inline void del_token(void) { + if (token_len > 0) + token_len--; +} + static inline void end_token(void) { token_string[token_len] = '\0'; } +struct namedfloat { + const char *name; + float value; +}; + +static const struct namedfloat namedfloats[] = { + { .name = "+inf.0", .value = INFINITY }, + { .name = "-inf.0", .value = -INFINITY }, + { .name = "+nan.0", .value = NAN }, + { .name = "-nan.0", .value = NAN }, +}; + +#define NUM_NAMED_FLOATS (sizeof namedfloats / sizeof namedfloats[0]) + static int _lex(void) { @@ -279,7 +300,7 @@ _lex(void) continue; } - if (lex_class & SPECIAL) { + if (lex_class & (SPECIAL|DOTC)) { add_token(c); end_token(); switch (c) { @@ -357,47 +378,72 @@ _lex(void) } } if (lex_class & PRINTABLE) { - int isnum; + int isfloat; int hasdigit; int isneg; + int isint; + int epos; - isnum = 1; + isfloat = 1; + isint = 1; hasdigit = 0; token_int = 0; isneg = 0; + epos = 0; for (;;) { if (!(lex_class & NUMBER)) { - isnum = 0; + isint = 0; + isfloat = 0; } else { - if (token_len != 0 && + if (!(lex_class & INTEGER)) + isint = 0; + if (token_len != epos && (lex_class & SIGN)) { - isnum = 0; + isint = 0; + isfloat = 0; } if (c == '-') isneg = 1; + if (c == '.' && epos != 0) + isfloat = 0; + if (c == 'e' || c == 'E') { + if (token_len == 0) + isfloat = 0; + else + epos = token_len + 1; + } if (lex_class & DIGIT) { hasdigit = 1; - if (isnum) + if (isint) token_int = token_int * 10 + c - '0'; } } add_token (c); c = lexc (); - if (lex_class & (NOTNAME)) { + if ((lex_class & (NOTNAME)) && (c != '.' || !isfloat)) { + unsigned int u; // if (lex_class & ENDOFFILE) // clearerr (f); lex_unget(c); end_token (); - if (isnum && hasdigit) { + if (isint && hasdigit) { if (isneg) token_int = -token_int; return NUM; } + if (isfloat && hasdigit) { + token_float = atof(token_string); + return FLOAT; + } + for (u = 0; u < NUM_NAMED_FLOATS; u++) + if (!strcmp(namedfloats[u].name, token_string)) { + token_float = namedfloats[u].value; + return FLOAT; + } return NAME; } } - } } } @@ -499,6 +545,9 @@ ao_lisp_read(void) case NUM: v = ao_lisp_integer_poly(token_int); break; + case FLOAT: + v = ao_lisp_float_get(token_float); + break; case BOOL: if (token_string[0] == 't') v = _ao_lisp_bool_true; diff --git a/src/lisp/ao_lisp_read.h b/src/lisp/ao_lisp_read.h index fc74a8e4..20c9c18a 100644 --- a/src/lisp/ao_lisp_read.h +++ b/src/lisp/ao_lisp_read.h @@ -26,28 +26,30 @@ # define QUOTE 4 # define STRING 5 # define NUM 6 -# define DOT 7 -# define BOOL 8 +# define FLOAT 7 +# define DOT 8 +# define BOOL 9 /* * character classes */ # define PRINTABLE 0x0001 /* \t \n ' ' - '~' */ -# define QUOTED 0x0002 /* \ anything */ -# define SPECIAL 0x0004 /* ( [ { ) ] } ' . */ +# define SPECIAL 0x0002 /* ( [ { ) ] } ' */ +# define DOTC 0x0004 /* . */ # define WHITE 0x0008 /* ' ' \t \n */ # define DIGIT 0x0010 /* [0-9] */ # define SIGN 0x0020 /* +- */ -# define ENDOFFILE 0x0040 /* end of file */ -# define COMMENT 0x0080 /* ; */ -# define IGNORE 0x0100 /* \0 - ' ' */ -# define BACKSLASH 0x0200 /* \ */ -# define VBAR 0x0400 /* | */ +# define FLOATC 0x0040 /* . e E */ +# define ENDOFFILE 0x0080 /* end of file */ +# define COMMENT 0x0100 /* ; */ +# define IGNORE 0x0200 /* \0 - ' ' */ +# define BACKSLASH 0x0400 /* \ */ # define STRINGC 0x0800 /* " */ # define POUND 0x1000 /* # */ -# define NOTNAME (STRINGC|VBAR|COMMENT|ENDOFFILE|WHITE|SPECIAL) -# define NUMBER (DIGIT|SIGN) +# define NOTNAME (STRINGC|COMMENT|ENDOFFILE|WHITE|SPECIAL) +# define INTEGER (DIGIT|SIGN) +# define NUMBER (INTEGER|FLOATC) #endif /* _AO_LISP_READ_H_ */ -- cgit v1.2.3 From 5f9f97cc2d43936d1941da3a9a130c279bc70b99 Mon Sep 17 00:00:00 2001 From: Keith Packard Date: Sun, 19 Nov 2017 21:07:23 -0800 Subject: altos/test: Update to build altos lisp test app Signed-off-by: Keith Packard --- src/test/Makefile | 2 +- src/test/hanoi.lisp | 15 ++++++++------- 2 files changed, 9 insertions(+), 8 deletions(-) (limited to 'src') diff --git a/src/test/Makefile b/src/test/Makefile index 9fe886b9..4ac2c893 100644 --- a/src/test/Makefile +++ b/src/test/Makefile @@ -104,7 +104,7 @@ AO_LISP_SRCS=$(LISP_SRCS) ao_lisp_test.c AO_LISP_OBJS=$(AO_LISP_SRCS:.c=.o) ao_lisp_test: $(AO_LISP_OBJS) - cc $(CFLAGS) -o $@ $(AO_LISP_OBJS) + cc $(CFLAGS) -o $@ $(AO_LISP_OBJS) -lm $(AO_LISP_OBJS): $(LISP_HDRS) ao_lisp_const.h diff --git a/src/test/hanoi.lisp b/src/test/hanoi.lisp index e873c796..02e16876 100644 --- a/src/test/hanoi.lisp +++ b/src/test/hanoi.lisp @@ -41,7 +41,8 @@ (define towers ()) -(define 1- (lambda (x) (- x 1))) +(define one- (lambda (x) (- x 1))) +(define one+ (lambda (x) (+ x 1))) ; Display one tower, clearing any ; space above it @@ -49,13 +50,13 @@ (cond ((= 0 clear) (cond ((not (null? tower)) (display-string x y (car tower)) - (display-tower x (1+ y) 0 (cdr tower)) + (display-tower x (one+ y) 0 (cdr tower)) ) ) ) (else (display-string x y " ") - (display-tower x (1+ y) (1- clear) tower) + (display-tower x (one+ y) (one- clear) tower) ) ) ) @@ -106,7 +107,7 @@ (define replace (lambda (list pos member) (cond ((= pos 0) (cons member (cdr list))) - ((cons (car list) (replace (cdr list) (1- pos) member))) + ((cons (car list) (replace (cdr list) (one- pos) member))) ) ) ) @@ -125,7 +126,7 @@ (set! towers (replace towers from from-tower)) (set! towers (replace towers to to-tower)) (display-hanoi) -; (delay move-delay) + (delay move-delay) ) ) ) @@ -137,9 +138,9 @@ (move-piece from to) ) (else - (_hanoi (1- n) from use to) + (_hanoi (one- n) from use to) (_hanoi 1 from to use) - (_hanoi (1- n) use to from) + (_hanoi (one- n) use to from) ) ) ) -- cgit v1.2.3 From 00bf2ca86b60e6501880011897cea073865c5a03 Mon Sep 17 00:00:00 2001 From: Keith Packard Date: Sat, 25 Nov 2017 17:29:10 -0800 Subject: altos/lisp: Rename progn to begin Match scheme name. Signed-off-by: Keith Packard --- src/lisp/ao_lisp.h | 2 +- src/lisp/ao_lisp_builtin.c | 4 ++-- src/lisp/ao_lisp_builtin.txt | 2 +- src/lisp/ao_lisp_const.lisp | 22 +++++++++++++++++++++- src/lisp/ao_lisp_eval.c | 20 ++++++++++---------- src/lisp/ao_lisp_stack.c | 2 +- 6 files changed, 36 insertions(+), 16 deletions(-) (limited to 'src') diff --git a/src/lisp/ao_lisp.h b/src/lisp/ao_lisp.h index cbbbe9a4..858212dd 100644 --- a/src/lisp/ao_lisp.h +++ b/src/lisp/ao_lisp.h @@ -229,7 +229,7 @@ enum eval_state { eval_apply, /* Execute apply */ eval_cond, /* Start next cond clause */ eval_cond_test, /* Check cond condition */ - eval_progn, /* Start next progn entry */ + eval_begin, /* Start next begin entry */ eval_while, /* Start while condition */ eval_while_test, /* Check while condition */ eval_macro, /* Finished with macro generation */ diff --git a/src/lisp/ao_lisp_builtin.c b/src/lisp/ao_lisp_builtin.c index d4dc8a86..693cc3ca 100644 --- a/src/lisp/ao_lisp_builtin.c +++ b/src/lisp/ao_lisp_builtin.c @@ -232,9 +232,9 @@ ao_lisp_do_cond(struct ao_lisp_cons *cons) } ao_poly -ao_lisp_do_progn(struct ao_lisp_cons *cons) +ao_lisp_do_begin(struct ao_lisp_cons *cons) { - ao_lisp_stack->state = eval_progn; + ao_lisp_stack->state = eval_begin; ao_lisp_stack->sexprs = ao_lisp_cons_poly(cons); return AO_LISP_NIL; } diff --git a/src/lisp/ao_lisp_builtin.txt b/src/lisp/ao_lisp_builtin.txt index 2e11bdad..236cadb4 100644 --- a/src/lisp/ao_lisp_builtin.txt +++ b/src/lisp/ao_lisp_builtin.txt @@ -13,7 +13,7 @@ nlambda quote f_lambda set macro setq set! nlambda cond -nlambda progn +nlambda begin nlambda while f_lexpr write f_lexpr display diff --git a/src/lisp/ao_lisp_const.lisp b/src/lisp/ao_lisp_const.lisp index 9fb7634c..f8a70979 100644 --- a/src/lisp/ao_lisp_const.lisp +++ b/src/lisp/ao_lisp_const.lisp @@ -25,7 +25,7 @@ (set (quote define) (macro (name val rest) (list - 'progn + 'begin (list 'set (list 'quote name) @@ -520,6 +520,26 @@ '(54 0 37 -3 245 19)) #t)) +(define repeat (macro (count rest) + (list + let + (list + (list '__count__ count)) + (append + (list + while + (list + <= + 0 + (list + set! + '__count__ + (list + - + '__count__ + 1)))) + rest)))) + ;(define number->string (lexpr (arg opt) ; (let ((base (if (null? opt) 10 (car opt))) ; diff --git a/src/lisp/ao_lisp_eval.c b/src/lisp/ao_lisp_eval.c index cfa71fa7..1044aa48 100644 --- a/src/lisp/ao_lisp_eval.c +++ b/src/lisp/ao_lisp_eval.c @@ -283,7 +283,7 @@ ao_lisp_eval_exec(void) 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; + ao_lisp_stack->state = eval_begin; v = ao_lisp_lambda_eval(); ao_lisp_stack->sexprs = v; ao_lisp_stack->values = AO_LISP_NIL; @@ -388,7 +388,7 @@ ao_lisp_eval_cond_test(void) ao_poly c = car->cdr; if (c) { - ao_lisp_stack->state = eval_progn; + ao_lisp_stack->state = eval_begin; ao_lisp_stack->sexprs = c; } else ao_lisp_stack->state = eval_val; @@ -403,17 +403,17 @@ ao_lisp_eval_cond_test(void) /* * 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 + * ao_lisp_begin 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 + * 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_lisp_eval_progn(void) +ao_lisp_eval_begin(void) { - DBGI("progn: "); DBG_POLY(ao_lisp_v); DBG(" sexprs "); DBG_POLY(ao_lisp_stack->sexprs); DBG("\n"); + DBGI("begin: "); 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"); @@ -428,7 +428,7 @@ ao_lisp_eval_progn(void) * return the value of the last one by just landing in eval_sexpr */ if (ao_lisp_stack->sexprs) { - ao_lisp_stack->state = eval_progn; + ao_lisp_stack->state = eval_begin; if (!ao_lisp_stack_push()) return 0; } @@ -476,7 +476,7 @@ ao_lisp_eval_while_test(void) ao_lisp_stack->state = eval_while; if (!ao_lisp_stack_push()) return 0; - ao_lisp_stack->state = eval_progn; + ao_lisp_stack->state = eval_begin; ao_lisp_stack->sexprs = ao_lisp_v; } else @@ -516,7 +516,7 @@ static int (*const evals[])(void) = { [eval_apply] = ao_lisp_eval_apply, [eval_cond] = ao_lisp_eval_cond, [eval_cond_test] = ao_lisp_eval_cond_test, - [eval_progn] = ao_lisp_eval_progn, + [eval_begin] = ao_lisp_eval_begin, [eval_while] = ao_lisp_eval_while, [eval_while_test] = ao_lisp_eval_while_test, [eval_macro] = ao_lisp_eval_macro, @@ -530,7 +530,7 @@ const char *ao_lisp_state_names[] = { [eval_apply] = "apply", [eval_cond] = "cond", [eval_cond_test] = "cond_test", - [eval_progn] = "progn", + [eval_begin] = "begin", [eval_while] = "while", [eval_while_test] = "while_test", [eval_macro] = "macro", diff --git a/src/lisp/ao_lisp_stack.c b/src/lisp/ao_lisp_stack.c index af68b656..9d6cccc4 100644 --- a/src/lisp/ao_lisp_stack.c +++ b/src/lisp/ao_lisp_stack.c @@ -273,6 +273,6 @@ ao_lisp_do_call_cc(struct ao_lisp_cons *cons) cons->cdr = AO_LISP_NIL; v = ao_lisp_lambda_eval(); ao_lisp_stack->sexprs = v; - ao_lisp_stack->state = eval_progn; + ao_lisp_stack->state = eval_begin; return AO_LISP_NIL; } -- cgit v1.2.3 From cd0bd9791a77868c226d285bf4d57e8c321755d5 Mon Sep 17 00:00:00 2001 From: Keith Packard Date: Fri, 1 Dec 2017 10:12:38 +0100 Subject: altos/lisp: Add quasiquote This adds read support for quasiquote syntax, and then adds a quasiquote implementation in lisp Signed-off-by: Keith Packard --- src/lisp/ao_lisp_builtin.txt | 3 + src/lisp/ao_lisp_const.lisp | 573 ++++++++++++++++++++++++++++-------------- src/lisp/ao_lisp_make_builtin | 48 ++-- src/lisp/ao_lisp_read.c | 34 ++- src/lisp/ao_lisp_read.h | 27 +- 5 files changed, 458 insertions(+), 227 deletions(-) (limited to 'src') diff --git a/src/lisp/ao_lisp_builtin.txt b/src/lisp/ao_lisp_builtin.txt index 236cadb4..6925ac17 100644 --- a/src/lisp/ao_lisp_builtin.txt +++ b/src/lisp/ao_lisp_builtin.txt @@ -10,6 +10,9 @@ f_lambda cons f_lambda last f_lambda length nlambda quote +atom quasiquote +atom unquote +atom unquote_splicing unquote-splicing f_lambda set macro setq set! nlambda cond diff --git a/src/lisp/ao_lisp_const.lisp b/src/lisp/ao_lisp_const.lisp index f8a70979..f1c2ed00 100644 --- a/src/lisp/ao_lisp_const.lisp +++ b/src/lisp/ao_lisp_const.lisp @@ -14,107 +14,320 @@ ; 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 - ; +(set (quote set!) + (macro (name value rest) + (list + set + (list + quote + name) + value) + ) + ) -(set (quote define) (macro (name val rest) - (list - 'begin - (list - 'set - (list 'quote name) - val) - (list 'quote name) - ) - ) +(set! append + (lexpr (args) + ((lambda (append-list append-lists) + (set! append-list + (lambda (a b) + (cond ((null? a) b) + (else (cons (car a) (append-list (cdr a) b))) + ) + ) + ) + (set! 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 '(a b c) '(d e f) '(g h i)) + + ; boolean operators + +(set! or + (macro (l) + ((lambda (_or) + (set! _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)) ()))) + + ; execute to resolve macros + +(or #f #t) + + +(set! and + (macro (l) + ((lambda (_and) + (set! _and + (lambda (l) + (cond ((null? l) #t) + ((null? (cdr l)) + (car l)) + (else + (list + cond + (list + (car l) + (_and (cdr l)) + ) + ) + ) + ) + ) + ) + (_and l)) ()) + ) ) + + ; execute to resolve macros + +(and #t #f) + +(set! quasiquote + (macro (x rest) + ((lambda (constant? combine-skeletons expand-quasiquote) + (set! 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)) + ) + ) + ) + ) + (set! 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) + ) + ) + ) + ) + + (set! 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) + ) + ) + ) + ) + (expand-quasiquote x 0) + ) () () ()) + ) + ) ; - ; A slightly more convenient form - ; for defining lambdas. + ; Define a variable without returning the value + ; Useful when defining functions to avoid + ; having lots of output generated. ; - ; (defun () s-exprs) + ; Also accepts the alternate + ; form for defining lambdas of + ; (define (name x y z) sexprs ...) ; -(define defun (macro (name args exprs) - (list - define - name - (cons 'lambda (cons args exprs)) +(set! 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)) + ) ) - ) - ) + `(begin + (set! ,first ,rest) + (quote ,first)) + ) + ) ; basic list accessors -(defun caar (l) (car (car l))) +(define (caar l) (car (car l))) -(defun cadr (l) (car (cdr l))) +(define (cadr l) (car (cdr l))) -(defun caddr (l) (car (cdr (cdr l)))) +(define (cdar l) (cdr (car l))) -(define list-tail (lambda (x k) - (if (zero? k) - x - (list-tail (cdr x (- k 1))) - ) - ) - ) +(define (caddr l) (car (cdr (cdr l)))) -(define list-ref (lambda (x k) - (car (list-tail x k)) - ) +(define (list-tail x k) + (if (zero? k) + x + (list-tail (cdr x (- k 1))) + ) ) - ; simple math operators +(define (list-ref x k) + (car (list-tail x k)) + ) -(defun 1+ (x) (+ x 1)) -(defun 1- (x) (- x 1)) + ; (if ) + ; (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 rest) `(eq? ,value 0))) + (zero? 1) (zero? 0) (zero? "hello") -(define positive? (macro (value rest) - (list - > - value - 0) - ) - ) +(define positive? (macro (value rest) `(> ,value 0))) (positive? 12) (positive? -12) -(define negative? (macro (value rest) - (list - < - value - 0) - ) - ) +(define negative? (macro (value rest) `(< ,value 0))) (negative? 12) (negative? -12) -(defun abs (x) (cond ((>= x 0) x) - (else (- x))) - ) +(define (abs x) (if (>= x 0) x (- x))) (abs 12) (abs -12) @@ -145,44 +358,20 @@ (min 1 2 3) (min 3 2 1) -(defun even? (x) (zero? (% x 2))) +(define (even? x) (zero? (% x 2))) (even? 2) (even? -2) (even? 3) (even? -1) -(defun odd? (x) (not (even? x))) +(define (odd? x) (not (even? x))) (odd? 2) (odd? -2) (odd? 3) (odd? -1) - ; (if ) - ; (if 3 2) 'yes) -(if (> 3 2) 'yes 'no) -(if (> 2 3) 'no 'yes) -(if (> 2 3) 'no) ; define a set of local ; variables and then evaluate @@ -213,6 +402,7 @@ (cond ((not (null? vars)) (cons (car (car vars)) (make-names (cdr vars)))) + (else ()) ) ) ) @@ -235,7 +425,7 @@ (make-exprs (cdr vars) exprs) ) ) - (exprs) + (else exprs) ) ) ) @@ -245,6 +435,7 @@ (set! make-nils (lambda (vars) (cond ((not (null? vars)) (cons () (make-nils (cdr vars)))) + (else ()) ) ) ) @@ -269,65 +460,22 @@ (let ((x 1)) x) (define let* let) - ; boolean operators -(define or (lexpr (l) - (let ((ret #f)) - (while (not (null? l)) - (cond ((car l) (set! ret #t) (set! l ())) - ((set! l (cdr l))))) - ret - ) - ) - ) +(define when (macro (test l) + (list + cond + (cons test l)))) - ; execute to resolve macros - -(or #f #t) +(when #t (display 'when)) -(define and (lexpr (l) - (let ((ret #t)) - (while (not (null? l)) - (cond ((car l) - (set! l (cdr l))) - (#t - (set! ret #f) - (set! l ())) - ) - ) - ret - ) - ) - ) - - ; execute to resolve macros - -(and #t #f) - - -(define append (lexpr (args) - (let ((append-list (lambda (a b) - (cond ((null? a) b) - (else (cons (car a) (append-list (cdr a) b))) - ) - ) - ) - (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) - ) - ) - ) +(define unless (macro (test l) + (list + cond + (cons (list not test) l)))) -(append '(a b c) '(d e f) '(g h i)) +(unless #f (display 'unless)) -(defun reverse (list) +(define (reverse list) (let ((result ())) (while (not (null? list)) (set! result (cons (car list) result)) @@ -338,22 +486,20 @@ (reverse '(1 2 3)) -(define list-tail - (lambda (x k) - (if (zero? k) - x - (list-tail (cdr x) (- k 1))))) +(define (list-tail x k) + (if (zero? k) + x + (list-tail (cdr x) (- k 1))))) (list-tail '(1 2 3) 2) -(defun list-ref (x k) (car (list-tail x k))) +(define (list-ref x k) (car (list-tail x k))) (list-ref '(1 2 3) 2) - ; recursive equality -(defun equal? (a b) +(define (equal? a b) (cond ((eq? a b) #t) ((and (pair? a) (pair? b)) (and (equal? (car a) (car b)) @@ -366,32 +512,32 @@ (equal? '(a b c) '(a b c)) (equal? '(a b c) '(a b b)) -(defun _member (obj list test?) +(define (_member obj list test?) (if (null? list) #f (if (test? obj (car list)) list (memq obj (cdr list))))) -(defun memq (obj list) (_member obj list eq?)) +(define (memq obj list) (_member obj list eq?)) (memq 2 '(1 2 3)) (memq 4 '(1 2 3)) -(defun memv (obj list) (_member obj list eqv?)) +(define (memv obj list) (_member obj list eqv?)) (memv 2 '(1 2 3)) (memv 4 '(1 2 3)) -(defun member (obj list) (_member obj list equal?)) +(define (member obj list) (_member obj list equal?)) (member '(2) '((1) (2) (3))) (member '(4) '((1) (2) (3))) -(defun _assoc (obj list test?) +(define (_assoc obj list test?) (if (null? list) #f (if (test? obj (caar list)) @@ -401,9 +547,9 @@ ) ) -(defun assq (obj list) (_assoc obj list eq?)) -(defun assv (obj list) (_assoc obj list eqv?)) -(defun assoc (obj list) (_assoc obj list equal?)) +(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))) @@ -414,52 +560,52 @@ (char? #\q) (char? "h") -(defun char-upper-case? (c) (<= #\A c #\Z)) +(define (char-upper-case? c) (<= #\A c #\Z)) (char-upper-case? #\a) (char-upper-case? #\B) (char-upper-case? #\0) (char-upper-case? #\space) -(defun char-lower-case? (c) (<= #\a c #\a)) +(define (char-lower-case? c) (<= #\a c #\a)) (char-lower-case? #\a) (char-lower-case? #\B) (char-lower-case? #\0) (char-lower-case? #\space) -(defun char-alphabetic? (c) (or (char-upper-case? c) (char-lower-case? c))) +(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) -(defun char-numeric? (c) (<= #\0 c #\9)) +(define (char-numeric? c) (<= #\0 c #\9)) (char-numeric? #\a) (char-numeric? #\B) (char-numeric? #\0) (char-numeric? #\space) -(defun char-whitespace? (c) (or (<= #\tab c #\return) (= #\space c))) +(define (char-whitespace? c) (or (<= #\tab c #\return) (= #\space c))) (char-whitespace? #\a) (char-whitespace? #\B) (char-whitespace? #\0) (char-whitespace? #\space) -(defun char->integer (c) c) -(defun integer->char (c) char-integer) +(define (char->integer c) c) +(define (integer->char c) char-integer) -(defun char-upcase (c) (if (char-lower-case? c) (+ c (- #\A #\a)) c)) +(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) -(defun char-downcase (c) (if (char-upper-case? c) (+ c (- #\a #\A)) c)) +(define (char-downcase c) (if (char-upper-case? c) (+ c (- #\a #\A)) c)) (char-downcase #\a) (char-downcase #\B) @@ -493,17 +639,17 @@ (for-each display '("hello" " " "world" "\n")) -(define -string-ml (lambda (strings) +(define _string-ml (lambda (strings) (if (null? strings) () - (cons (string->list (car strings)) (-string-ml (cdr strings)))))) + (cons (string->list (car strings)) (_string-ml (cdr strings)))))) (define string-map (lexpr (proc strings) - (list->string (apply map proc (-string-ml strings)))))) + (list->string (apply map proc (_string-ml strings)))))) -(string-map 1+ "HAL") +(string-map (lambda (x) (+ 1 x)) "HAL") (define string-for-each (lexpr (proc strings) - (apply for-each proc (-string-ml strings)))) + (apply for-each proc (_string-ml strings)))) (string-for-each write-char "IBM\n") @@ -520,25 +666,64 @@ '(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) - (list - let - (list - (list '__count__ count)) - (append - (list - while - (list - <= - 0 - (list - set! - '__count__ - (list - - - '__count__ - 1)))) - rest)))) + `(let ((__count__ ,count)) + (while (<= 0 (set! __count__ (- __count__ 1))) ,@rest)))) + +(repeat 2 (write 'hello)) +(repeat 3 (write 'goodbye)) + +(define case (macro (test l) + (let ((_unarrow + ; construct the body of the + ; case, dealing with the + ; lambda version ( => lambda) + + (lambda (l) + (cond ((null? l) l) + ((eq? (car l) '=>) `(( ,(cadr l) __key__))) + (else l)))) + (_case (lambda (l) + + ; Build the case elements, which is + ; simply a list of cond clauses + + (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 (lexpr (arg opt) ; (let ((base (if (null? opt) 10 (car opt))) diff --git a/src/lisp/ao_lisp_make_builtin b/src/lisp/ao_lisp_make_builtin index 531e388d..c4ba9d94 100644 --- a/src/lisp/ao_lisp_make_builtin +++ b/src/lisp/ao_lisp_make_builtin @@ -13,6 +13,7 @@ string[string] type_map = { "macro" => "MACRO", "f_lambda" => "F_LAMBDA", "f_lexpr" => "F_LEXPR", + "atom" => "atom", }; string[*] @@ -50,13 +51,16 @@ read_builtins(file f) { return builtins; } +bool is_atom(builtin_t b) = b.type == "atom"; + void dump_ids(builtin_t[*] builtins) { printf("#ifdef AO_LISP_BUILTIN_ID\n"); printf("#undef AO_LISP_BUILTIN_ID\n"); printf("enum ao_lisp_builtin_id {\n"); for (int i = 0; i < dim(builtins); i++) - printf("\tbuiltin_%s,\n", builtins[i].c_name); + if (!is_atom(builtins[i])) + printf("\tbuiltin_%s,\n", builtins[i].c_name); printf("\t_builtin_last\n"); printf("};\n"); printf("#endif /* AO_LISP_BUILTIN_ID */\n"); @@ -69,8 +73,9 @@ dump_casename(builtin_t[*] builtins) { printf("static char *ao_lisp_builtin_name(enum ao_lisp_builtin_id b) {\n"); printf("\tswitch(b) {\n"); for (int i = 0; i < dim(builtins); i++) - printf("\tcase builtin_%s: return ao_lisp_poly_atom(_atom(\"%s\"))->name;\n", - builtins[i].c_name, builtins[i].lisp_names[0]); + if (!is_atom(builtins[i])) + printf("\tcase builtin_%s: return ao_lisp_poly_atom(_atom(\"%s\"))->name;\n", + builtins[i].c_name, builtins[i].lisp_names[0]); printf("\tdefault: return \"???\";\n"); printf("\t}\n"); printf("}\n"); @@ -94,10 +99,12 @@ dump_arrayname(builtin_t[*] builtins) { printf("#undef AO_LISP_BUILTIN_ARRAYNAME\n"); printf("static const ao_poly builtin_names[] = {\n"); for (int i = 0; i < dim(builtins); i++) { - printf("\t[builtin_%s] = _ao_lisp_atom_", - builtins[i].c_name); - cify_lisp(builtins[i].lisp_names[0]); - printf(",\n"); + if (!is_atom(builtins[i])) { + printf("\t[builtin_%s] = _ao_lisp_atom_", + builtins[i].c_name); + cify_lisp(builtins[i].lisp_names[0]); + printf(",\n"); + } } printf("};\n"); printf("#endif /* AO_LISP_BUILTIN_ARRAYNAME */\n"); @@ -109,9 +116,10 @@ dump_funcs(builtin_t[*] builtins) { printf("#undef AO_LISP_BUILTIN_FUNCS\n"); printf("const ao_lisp_func_t ao_lisp_builtins[] = {\n"); for (int i = 0; i < dim(builtins); i++) { - printf("\t[builtin_%s] = ao_lisp_do_%s,\n", - builtins[i].c_name, - builtins[i].c_name); + if (!is_atom(builtins[i])) + printf("\t[builtin_%s] = ao_lisp_do_%s,\n", + builtins[i].c_name, + builtins[i].c_name); } printf("};\n"); printf("#endif /* AO_LISP_BUILTIN_FUNCS */\n"); @@ -122,9 +130,11 @@ dump_decls(builtin_t[*] builtins) { printf("#ifdef AO_LISP_BUILTIN_DECLS\n"); printf("#undef AO_LISP_BUILTIN_DECLS\n"); for (int i = 0; i < dim(builtins); i++) { - printf("ao_poly\n"); - printf("ao_lisp_do_%s(struct ao_lisp_cons *cons);\n", - builtins[i].c_name); + if (!is_atom(builtins[i])) { + printf("ao_poly\n"); + printf("ao_lisp_do_%s(struct ao_lisp_cons *cons);\n", + builtins[i].c_name); + } } printf("#endif /* AO_LISP_BUILTIN_DECLS */\n"); } @@ -135,11 +145,13 @@ dump_consts(builtin_t[*] builtins) { printf("#undef AO_LISP_BUILTIN_CONSTS\n"); printf("struct builtin_func funcs[] = {\n"); for (int i = 0; i < dim(builtins); i++) { - for (int j = 0; j < dim(builtins[i].lisp_names); j++) { - printf ("\t{ .name = \"%s\", .args = AO_LISP_FUNC_%s, .func = builtin_%s },\n", - builtins[i].lisp_names[j], - builtins[i].type, - builtins[i].c_name); + if (!is_atom(builtins[i])) { + for (int j = 0; j < dim(builtins[i].lisp_names); j++) { + printf ("\t{ .name = \"%s\", .args = AO_LISP_FUNC_%s, .func = builtin_%s },\n", + builtins[i].lisp_names[j], + builtins[i].type, + builtins[i].c_name); + } } } printf("};\n"); diff --git a/src/lisp/ao_lisp_read.c b/src/lisp/ao_lisp_read.c index c5a238cc..747963ab 100644 --- a/src/lisp/ao_lisp_read.c +++ b/src/lisp/ao_lisp_read.c @@ -61,7 +61,7 @@ static const uint16_t lex_classes[128] = { PRINTABLE|SPECIAL, /* ) */ PRINTABLE, /* * */ PRINTABLE|SIGN, /* + */ - PRINTABLE, /* , */ + PRINTABLE|SPECIAL, /* , */ PRINTABLE|SIGN, /* - */ PRINTABLE|DOTC|FLOATC, /* . */ PRINTABLE, /* / */ @@ -113,7 +113,7 @@ static const uint16_t lex_classes[128] = { PRINTABLE, /* ] */ PRINTABLE, /* ^ */ PRINTABLE, /* _ */ - PRINTABLE, /* ` */ + PRINTABLE|SPECIAL, /* ` */ PRINTABLE, /* a */ PRINTABLE, /* b */ PRINTABLE, /* c */ @@ -314,6 +314,18 @@ _lex(void) 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) { @@ -562,11 +574,27 @@ ao_lisp_read(void) v = AO_LISP_NIL; break; case QUOTE: + case QUASIQUOTE: + case UNQUOTE: + case UNQUOTE_SPLICING: if (!push_read_stack(cons, read_state)) return AO_LISP_NIL; cons++; read_state = READ_IN_QUOTE; - v = _ao_lisp_atom_quote; + switch (parse_token) { + case QUOTE: + v = _ao_lisp_atom_quote; + break; + case QUASIQUOTE: + v = _ao_lisp_atom_quasiquote; + break; + case UNQUOTE: + v = _ao_lisp_atom_unquote; + break; + case UNQUOTE_SPLICING: + v = _ao_lisp_atom_unquote2dsplicing; + break; + } break; case CLOSE: if (!cons) { diff --git a/src/lisp/ao_lisp_read.h b/src/lisp/ao_lisp_read.h index 20c9c18a..8f6bf130 100644 --- a/src/lisp/ao_lisp_read.h +++ b/src/lisp/ao_lisp_read.h @@ -19,23 +19,26 @@ * token classes */ -# define END 0 -# define NAME 1 -# define OPEN 2 -# define CLOSE 3 -# define QUOTE 4 -# define STRING 5 -# define NUM 6 -# define FLOAT 7 -# define DOT 8 -# define BOOL 9 +# 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 /* * character classes */ -# define PRINTABLE 0x0001 /* \t \n ' ' - '~' */ -# define SPECIAL 0x0002 /* ( [ { ) ] } ' */ +# define PRINTABLE 0x0001 /* \t \n ' ' - ~ */ +# define SPECIAL 0x0002 /* ( [ { ) ] } ' ` , */ # define DOTC 0x0004 /* . */ # define WHITE 0x0008 /* ' ' \t \n */ # define DIGIT 0x0010 /* [0-9] */ -- cgit v1.2.3 From 796017262cd433af5d143cc7168c944e1e05f4e2 Mon Sep 17 00:00:00 2001 From: Keith Packard Date: Fri, 1 Dec 2017 11:31:29 +0100 Subject: altos/lisp: Fix pairp builtin Pairs are non-nil cons values; add an explicit check for nil here Signed-off-by: Keith Packard --- src/lisp/ao_lisp_builtin.c | 8 +++++++- 1 file changed, 7 insertions(+), 1 deletion(-) (limited to 'src') diff --git a/src/lisp/ao_lisp_builtin.c b/src/lisp/ao_lisp_builtin.c index 693cc3ca..f13f2180 100644 --- a/src/lisp/ao_lisp_builtin.c +++ b/src/lisp/ao_lisp_builtin.c @@ -675,7 +675,13 @@ ao_lisp_do_typep(int type, struct ao_lisp_cons *cons) ao_poly ao_lisp_do_pairp(struct ao_lisp_cons *cons) { - return ao_lisp_do_typep(AO_LISP_CONS, cons); + ao_poly v; + if (!ao_lisp_check_argc(_ao_lisp_atom_led, cons, 1, 1)) + return AO_LISP_NIL; + v = ao_lisp_arg(cons, 0); + if (v != AO_LISP_NIL && ao_lisp_poly_type(v) == AO_LISP_CONS) + return _ao_lisp_bool_true; + return _ao_lisp_bool_false; } ao_poly -- cgit v1.2.3 From 5d0b85f25fa1e5cc816a8256afb38cf9552f6d9d Mon Sep 17 00:00:00 2001 From: Keith Packard Date: Fri, 1 Dec 2017 11:32:27 +0100 Subject: altos/lisp: return from unmatched cond is #f, not nil Fix the return value when we fall off the end of a cond expression to be #f Signed-off-by: Keith Packard --- src/lisp/ao_lisp_eval.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'src') diff --git a/src/lisp/ao_lisp_eval.c b/src/lisp/ao_lisp_eval.c index 1044aa48..fa25edf0 100644 --- a/src/lisp/ao_lisp_eval.c +++ b/src/lisp/ao_lisp_eval.c @@ -350,7 +350,7 @@ ao_lisp_eval_cond(void) 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_v = _ao_lisp_bool_false; ao_lisp_stack->state = eval_val; } else { ao_lisp_v = ao_lisp_poly_cons(ao_lisp_stack->sexprs)->car; -- cgit v1.2.3 From 835bf4131f9e20575bfdf2179462ebdf54a14761 Mon Sep 17 00:00:00 2001 From: Keith Packard Date: Fri, 1 Dec 2017 12:06:04 +0100 Subject: altos/lisp: Make let distinct from let* let is supposed to define the values all at once, evaluating the initializers in the enclosing context. let* defines the new names and then initializes them one at a time. Signed-off-by: Keith Packard --- src/lisp/ao_lisp_const.lisp | 183 ++++++++++++++++++++++++++++++-------------- 1 file changed, 124 insertions(+), 59 deletions(-) (limited to 'src') diff --git a/src/lisp/ao_lisp_const.lisp b/src/lisp/ao_lisp_const.lisp index f1c2ed00..5c1aa75b 100644 --- a/src/lisp/ao_lisp_const.lisp +++ b/src/lisp/ao_lisp_const.lisp @@ -374,8 +374,9 @@ ; define a set of local - ; variables and then evaluate - ; a list of sexprs + ; variables all at once and + ; then evaluate a list of + ; sexprs ; ; (let (var-defines) sexprs) ; @@ -392,6 +393,71 @@ ; (let ((x 1) (y)) (set! y (+ x 1)) y) (define let (macro (vars exprs) + ((lambda (make-names make-vals) + + ; + ; make the list of names in the let + ; + + (set! make-names (lambda (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 + + (set! make-vals (lambda (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) ((lambda (make-names make-exprs make-nils) ; @@ -446,9 +512,7 @@ ; build the lambda. - (cons (cons 'lambda (cons (make-names vars) exprs)) - (make-nils vars) - ) + `((lambda ,(make-names vars) ,@exprs) ,@(make-nils vars)) ) () () @@ -457,23 +521,15 @@ ) ) -(let ((x 1)) x) +(let* ((x 1)) x) -(define let* let) +(define when (macro (test l) `(cond (,test ,@l)))) -(define when (macro (test l) - (list - cond - (cons test l)))) +(when #t (write 'when)) -(when #t (display 'when)) +(define unless (macro (test l) `(cond ((not ,test) ,@l)))) -(define unless (macro (test l) - (list - cond - (cons (list not test) l)))) - -(unless #f (display 'unless)) +(unless #f (write 'unless)) (define (reverse list) (let ((result ())) @@ -512,30 +568,39 @@ (equal? '(a b c) '(a b c)) (equal? '(a b c) '(a b b)) -(define (_member obj list test?) - (if (null? list) - #f - (if (test? obj (car list)) - list - (memq obj (cdr list))))) +(define member (lexpr (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?)) +(define (memq obj list) (member obj list eq?)) (memq 2 '(1 2 3)) (memq 4 '(1 2 3)) -(define (memv obj list) (_member obj list eqv?)) +(memq '(2) '((1) (2) (3))) + +(define (memv obj list) (member obj list eqv?)) (memv 2 '(1 2 3)) (memv 4 '(1 2 3)) -(define (member obj list) (_member obj list equal?)) - -(member '(2) '((1) (2) (3))) - -(member '(4) '((1) (2) (3))) +(memv '(2) '((1) (2) (3))) (define (_assoc obj list test?) (if (null? list) @@ -618,17 +683,17 @@ (apply cons '(a b)) (define map (lexpr (proc lists) - (let ((args (lambda (lists) - (if (null? lists) () - (cons (caar lists) (args (cdr lists)))))) - (next (lambda (lists) - (if (null? lists) () - (cons (cdr (car lists)) (next (cdr lists)))))) - (domap (lambda (lists) - (if (null? (car lists)) () - (cons (apply proc (args lists)) (domap (next lists))) - ))) - ) + (let* ((args (lambda (lists) + (if (null? lists) () + (cons (caar lists) (args (cdr lists)))))) + (next (lambda (lists) + (if (null? lists) () + (cons (cdr (car lists)) (next (cdr lists)))))) + (domap (lambda (lists) + (if (null? (car lists)) () + (cons (apply proc (args lists)) (domap (next lists))) + ))) + ) (domap lists)))) (map cadr '((a b) (d e) (g h))) @@ -684,36 +749,36 @@ (repeat 3 (write 'goodbye)) (define case (macro (test l) - (let ((_unarrow + (let* ((_unarrow ; construct the body of the ; case, dealing with the ; lambda version ( => lambda) - - (lambda (l) - (cond ((null? l) l) - ((eq? (car l) '=>) `(( ,(cadr l) __key__))) - (else l)))) - (_case (lambda (l) + + (lambda (l) + (cond ((null? l) l) + ((eq? (car l) '=>) `(( ,(cadr l) __key__))) + (else l)))) + (_case (lambda (l) ; Build the case elements, which is ; simply a list of cond clauses - (cond ((null? l) ()) + (cond ((null? l) ()) ; else case - ((eq? (caar l) 'else) - `((else ,@(_unarrow (cdr (car l)))))) + ((eq? (caar l) 'else) + `((else ,@(_unarrow (cdr (car l)))))) ; regular case - (else - (cons - `((eqv? ,(caar l) __key__) - ,@(_unarrow (cdr (car l)))) - (_case (cdr l))) - ) - )))) + (else + (cons + `((eqv? ,(caar l) __key__) + ,@(_unarrow (cdr (car l)))) + (_case (cdr l))) + ) + )))) ; now construct the overall ; expression, using a lambda -- cgit v1.2.3 From 98923ae1189f062b8b94120d47a56892db25493f Mon Sep 17 00:00:00 2001 From: Keith Packard Date: Fri, 1 Dec 2017 18:28:16 +0100 Subject: altos/lisp: Split out frame vals from frame struct This lets the frame be resized without moving the base structure. The plan is to allow all frames to be resized, not just the global frame. Signed-off-by: Keith Packard --- src/lisp/ao_lisp.h | 38 ++++++-- src/lisp/ao_lisp_error.c | 5 +- src/lisp/ao_lisp_frame.c | 207 ++++++++++++++++++++++++------------------ src/lisp/ao_lisp_make_const.c | 5 +- src/lisp/ao_lisp_mem.c | 42 +++++++++ src/lisp/ao_lisp_poly.c | 4 + 6 files changed, 200 insertions(+), 101 deletions(-) (limited to 'src') diff --git a/src/lisp/ao_lisp.h b/src/lisp/ao_lisp.h index 858212dd..96a7a05f 100644 --- a/src/lisp/ao_lisp.h +++ b/src/lisp/ao_lisp.h @@ -92,12 +92,13 @@ extern uint8_t ao_lisp_pool[AO_LISP_POOL + AO_LISP_POOL_EXTRA] __attribute__((a #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_BOOL 9 -#define AO_LISP_BIGINT 10 -#define AO_LISP_FLOAT 11 -#define AO_LISP_NUM_TYPE 12 +#define AO_LISP_FRAME_VALS 7 +#define AO_LISP_LAMBDA 8 +#define AO_LISP_STACK 9 +#define AO_LISP_BOOL 10 +#define AO_LISP_BIGINT 11 +#define AO_LISP_FLOAT 12 +#define AO_LISP_NUM_TYPE 13 /* Leave two bits for types to use as they please */ #define AO_LISP_OTHER_TYPE_MASK 0x3f @@ -154,11 +155,17 @@ struct ao_lisp_val { ao_poly val; }; +struct ao_lisp_frame_vals { + uint8_t type; + uint8_t size; + struct ao_lisp_val vals[]; +}; + struct ao_lisp_frame { uint8_t type; uint8_t num; ao_poly prev; - struct ao_lisp_val vals[]; + ao_poly vals; }; struct ao_lisp_bool { @@ -221,6 +228,16 @@ ao_lisp_frame_poly(struct ao_lisp_frame *frame) { return ao_lisp_poly(frame, AO_LISP_OTHER); } +static inline struct ao_lisp_frame_vals * +ao_lisp_poly_frame_vals(ao_poly poly) { + return ao_lisp_ref(poly); +} + +static inline ao_poly +ao_lisp_frame_vals_poly(struct ao_lisp_frame_vals *vals) { + return ao_lisp_poly(vals, AO_LISP_OTHER); +} + enum eval_state { eval_sexpr, /* Evaluate an sexpr */ eval_val, /* Value computed */ @@ -528,6 +545,12 @@ ao_lisp_stack_fetch(int id) { return ao_lisp_poly_stack(ao_lisp_poly_fetch(id)); } +void +ao_lisp_frame_stash(int id, struct ao_lisp_frame *frame); + +struct ao_lisp_frame * +ao_lisp_frame_fetch(int id); + /* bool */ extern const struct ao_lisp_type ao_lisp_bool_type; @@ -713,6 +736,7 @@ ao_lisp_read_eval_print(void); /* frame */ extern const struct ao_lisp_type ao_lisp_frame_type; +extern const struct ao_lisp_type ao_lisp_frame_vals_type; #define AO_LISP_FRAME_FREE 6 diff --git a/src/lisp/ao_lisp_error.c b/src/lisp/ao_lisp_error.c index d1c9b941..ba135834 100644 --- a/src/lisp/ao_lisp_error.c +++ b/src/lisp/ao_lisp_error.c @@ -57,6 +57,7 @@ ao_lisp_error_frame(int indent, char *name, struct ao_lisp_frame *frame) tabs(indent); printf ("%s{", name); if (frame) { + struct ao_lisp_frame_vals *vals = ao_lisp_poly_frame_vals(frame->vals); if (frame->type & AO_LISP_FRAME_PRINT) printf("recurse..."); else { @@ -66,9 +67,9 @@ ao_lisp_error_frame(int indent, char *name, struct ao_lisp_frame *frame) tabs(indent); printf(" "); } - ao_lisp_poly_write(frame->vals[f].atom); + ao_lisp_poly_write(vals->vals[f].atom); printf(" = "); - ao_lisp_poly_write(frame->vals[f].val); + ao_lisp_poly_write(vals->vals[f].val); printf("\n"); } if (frame->prev) diff --git a/src/lisp/ao_lisp_frame.c b/src/lisp/ao_lisp_frame.c index ebdb7757..dd29e079 100644 --- a/src/lisp/ao_lisp_frame.c +++ b/src/lisp/ao_lisp_frame.c @@ -15,37 +15,77 @@ #include "ao_lisp.h" static inline int -frame_num_size(int num) +frame_vals_num_size(int num) { - return sizeof (struct ao_lisp_frame) + num * sizeof (struct ao_lisp_val); + return sizeof (struct ao_lisp_frame_vals) + num * sizeof (struct ao_lisp_val); } +static int +frame_vals_size(void *addr) +{ + struct ao_lisp_frame_vals *vals = addr; + return frame_vals_num_size(vals->size); +} + +static void +frame_vals_mark(void *addr) +{ + struct ao_lisp_frame_vals *vals = addr; + int f; + + for (f = 0; f < vals->size; f++) { + struct ao_lisp_val *v = &vals->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); + } +} + +static void +frame_vals_move(void *addr) +{ + struct ao_lisp_frame_vals *vals = addr; + int f; + + for (f = 0; f < vals->size; f++) { + struct ao_lisp_val *v = &vals->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); + } +} + +const struct ao_lisp_type ao_lisp_frame_vals_type = { + .mark = frame_vals_mark, + .size = frame_vals_size, + .move = frame_vals_move, + .name = "frame_vals" +}; + static int frame_size(void *addr) { - struct ao_lisp_frame *frame = addr; - return frame_num_size(frame->num); + (void) addr; + return sizeof (struct ao_lisp_frame); } 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); - } + ao_lisp_poly_mark(frame->vals, 0); frame = ao_lisp_poly_frame(frame->prev); MDBG_MOVE("frame next %d\n", MDBG_OFFSET(frame)); if (!frame) @@ -59,7 +99,6 @@ static void frame_move(void *addr) { struct ao_lisp_frame *frame = addr; - int f; for (;;) { struct ao_lisp_frame *prev; @@ -68,16 +107,7 @@ frame_move(void *addr) 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); - } + ao_lisp_poly_move(&frame->vals, 0); prev = ao_lisp_poly_frame(frame->prev); if (!prev) break; @@ -104,8 +134,9 @@ const struct ao_lisp_type ao_lisp_frame_type = { void ao_lisp_frame_write(ao_poly p) { - struct ao_lisp_frame *frame = ao_lisp_poly_frame(p); - int f; + struct ao_lisp_frame *frame = ao_lisp_poly_frame(p); + struct ao_lisp_frame_vals *vals = ao_lisp_poly_frame_vals(frame->vals); + int f; printf ("{"); if (frame) { @@ -116,9 +147,9 @@ ao_lisp_frame_write(ao_poly p) for (f = 0; f < frame->num; f++) { if (f != 0) printf(", "); - ao_lisp_poly_write(frame->vals[f].atom); + ao_lisp_poly_write(vals->vals[f].atom); printf(" = "); - ao_lisp_poly_write(frame->vals[f].val); + ao_lisp_poly_write(vals->vals[f].val); } if (frame->prev) ao_lisp_poly_write(frame->prev); @@ -131,11 +162,13 @@ ao_lisp_frame_write(ao_poly p) static int ao_lisp_frame_find(struct ao_lisp_frame *frame, int top, ao_poly atom) { - int l = 0; - int r = top - 1; + struct ao_lisp_frame_vals *vals = ao_lisp_poly_frame_vals(frame->vals); + int l = 0; + int r = top - 1; + while (l <= r) { int m = (l + r) >> 1; - if (frame->vals[m].atom < atom) + if (vals->vals[m].atom < atom) l = m + 1; else r = m - 1; @@ -146,62 +179,57 @@ ao_lisp_frame_find(struct ao_lisp_frame *frame, int top, ao_poly atom) ao_poly * ao_lisp_frame_ref(struct ao_lisp_frame *frame, ao_poly atom) { - int l = ao_lisp_frame_find(frame, frame->num, atom); + struct ao_lisp_frame_vals *vals = ao_lisp_poly_frame_vals(frame->vals); + int l = ao_lisp_frame_find(frame, frame->num, atom); if (l >= frame->num) return NULL; - if (frame->vals[l].atom != atom) + if (vals->vals[l].atom != atom) return NULL; - return &frame->vals[l].val; + return &vals->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; -} +struct ao_lisp_frame *ao_lisp_frame_free_list[AO_LISP_FRAME_FREE]; -ao_poly -ao_lisp_frame_get(struct ao_lisp_frame *frame, ao_poly atom) +static struct ao_lisp_frame_vals * +ao_lisp_frame_vals_new(int num) { - 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_vals *vals; -struct ao_lisp_frame *ao_lisp_frame_free_list[AO_LISP_FRAME_FREE]; + vals = ao_lisp_alloc(frame_vals_num_size(num)); + if (!vals) + return NULL; + vals->type = AO_LISP_FRAME_VALS; + vals->size = num; + return vals; +} struct ao_lisp_frame * ao_lisp_frame_new(int num) { - struct ao_lisp_frame *frame; + struct ao_lisp_frame *frame; + struct ao_lisp_frame_vals *vals; - if (num < AO_LISP_FRAME_FREE && (frame = ao_lisp_frame_free_list[num])) + 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)); + vals = ao_lisp_poly_frame_vals(frame->vals); + } else { + frame = ao_lisp_alloc(sizeof (struct ao_lisp_frame)); if (!frame) return NULL; + frame->type = AO_LISP_FRAME; + frame->num = 0; + frame->prev = AO_LISP_NIL; + frame->vals = AO_LISP_NIL; + ao_lisp_poly_stash(0, ao_lisp_frame_poly(frame)); + vals = ao_lisp_frame_vals_new(num); + frame = ao_lisp_poly_frame(ao_lisp_poly_fetch(0)); + frame->vals = ao_lisp_frame_vals_poly(vals); } - frame->type = AO_LISP_FRAME; frame->num = num; frame->prev = AO_LISP_NIL; - memset(frame->vals, '\0', num * sizeof (struct ao_lisp_val)); + memset(vals, '\0', vals->size * sizeof (struct ao_lisp_val)); return frame; } @@ -227,47 +255,46 @@ ao_lisp_frame_free(struct ao_lisp_frame *frame) } static struct ao_lisp_frame * -ao_lisp_frame_realloc(struct ao_lisp_frame **frame_ref, int new_num) +ao_lisp_frame_realloc(struct ao_lisp_frame *frame, int new_num) { - struct ao_lisp_frame *frame = *frame_ref; - struct ao_lisp_frame *new; - int copy; + struct ao_lisp_frame_vals *vals; + struct ao_lisp_frame_vals *new_vals; + int copy; if (new_num == frame->num) return frame; - new = ao_lisp_frame_new(new_num); - if (!new) + ao_lisp_frame_stash(0, frame); + new_vals = ao_lisp_frame_vals_new(new_num); + if (!new_vals) return NULL; - /* - * Re-fetch the frame as it may have moved - * during the allocation - */ - frame = *frame_ref; + frame = ao_lisp_frame_fetch(0); + vals = ao_lisp_poly_frame_vals(frame->vals); 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; + memcpy(new_vals->vals, vals->vals, copy * sizeof (struct ao_lisp_val)); + frame->vals = ao_lisp_frame_vals_poly(new_vals); + frame->num = new_num; + return frame; } 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); + struct ao_lisp_frame_vals *vals = ao_lisp_poly_frame_vals(frame->vals); + int l = ao_lisp_frame_find(frame, num, atom); - memmove(&frame->vals[l+1], - &frame->vals[l], + memmove(&vals->vals[l+1], + &vals->vals[l], (num - l) * sizeof (struct ao_lisp_val)); - frame->vals[l].atom = atom; - frame->vals[l].val = val; + vals->vals[l].atom = atom; + vals->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; + struct ao_lisp_frame *frame = *frame_ref; ao_poly *ref = frame ? ao_lisp_frame_ref(frame, atom) : NULL; if (!ref) { @@ -276,14 +303,14 @@ ao_lisp_frame_add(struct ao_lisp_frame **frame_ref, ao_poly atom, ao_poly val) ao_lisp_poly_stash(1, val); if (frame) { f = frame->num; - frame = ao_lisp_frame_realloc(frame_ref, f + 1); + frame = ao_lisp_frame_realloc(frame, f + 1); } else { f = 0; frame = ao_lisp_frame_new(1); + *frame_ref = frame; } 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); diff --git a/src/lisp/ao_lisp_make_const.c b/src/lisp/ao_lisp_make_const.c index f23d34db..f9bb5452 100644 --- a/src/lisp/ao_lisp_make_const.c +++ b/src/lisp/ao_lisp_make_const.c @@ -326,10 +326,11 @@ main(int argc, char **argv) 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); + struct ao_lisp_frame_vals *vals = ao_lisp_poly_frame_vals(ao_lisp_frame_global->vals); + val = ao_has_macro(vals->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_atom(vals->vals[f].atom)->name); ao_lisp_poly_write(val); printf("\n"); exit(1); diff --git a/src/lisp/ao_lisp_mem.c b/src/lisp/ao_lisp_mem.c index dc0008c4..890eba1b 100644 --- a/src/lisp/ao_lisp_mem.c +++ b/src/lisp/ao_lisp_mem.c @@ -148,6 +148,7 @@ struct ao_lisp_root { static struct ao_lisp_cons *save_cons[2]; static char *save_string[2]; +static struct ao_lisp_frame *save_frame[1]; static ao_poly save_poly[3]; static const struct ao_lisp_root ao_lisp_root[] = { @@ -167,6 +168,10 @@ static const struct ao_lisp_root ao_lisp_root[] = { .type = &ao_lisp_string_type, .addr = (void **) &save_string[1], }, + { + .type = &ao_lisp_frame_type, + .addr = (void **) &save_frame[0], + }, { .type = NULL, .addr = (void **) (void *) &save_poly[0] @@ -455,6 +460,7 @@ static const struct ao_lisp_type *ao_lisp_types[AO_LISP_NUM_TYPE] = { [AO_LISP_ATOM] = &ao_lisp_atom_type, [AO_LISP_BUILTIN] = &ao_lisp_builtin_type, [AO_LISP_FRAME] = &ao_lisp_frame_type, + [AO_LISP_FRAME_VALS] = &ao_lisp_frame_vals_type, [AO_LISP_LAMBDA] = &ao_lisp_lambda_type, [AO_LISP_STACK] = &ao_lisp_stack_type, [AO_LISP_BOOL] = &ao_lisp_bool_type, @@ -620,6 +626,29 @@ ao_lisp_collect(uint8_t style) * Mark interfaces for objects */ + +/* + * Mark a block of memory with an explicit size + */ + +int +ao_lisp_mark_block(void *addr, int size) +{ + 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, size); + return 0; +} + /* * Note a reference to memory and collect information about a few * object sizes at a time @@ -891,3 +920,16 @@ ao_lisp_string_fetch(int id) return string; } +void +ao_lisp_frame_stash(int id, struct ao_lisp_frame *frame) +{ + save_frame[id] = frame; +} + +struct ao_lisp_frame * +ao_lisp_frame_fetch(int id) +{ + struct ao_lisp_frame *frame = save_frame[id]; + save_frame[id] = NULL; + return frame; +} diff --git a/src/lisp/ao_lisp_poly.c b/src/lisp/ao_lisp_poly.c index e93e1192..d14f4151 100644 --- a/src/lisp/ao_lisp_poly.c +++ b/src/lisp/ao_lisp_poly.c @@ -44,6 +44,10 @@ static const struct ao_lisp_funcs ao_lisp_funcs[AO_LISP_NUM_TYPE] = { .write = ao_lisp_frame_write, .display = ao_lisp_frame_write, }, + [AO_LISP_FRAME_VALS] = { + .write = NULL, + .display = NULL, + }, [AO_LISP_LAMBDA] = { .write = ao_lisp_lambda_write, .display = ao_lisp_lambda_write, -- cgit v1.2.3 From c31744299e5a4342bbe26d3735ee2d8f09192ae9 Mon Sep 17 00:00:00 2001 From: Keith Packard Date: Fri, 1 Dec 2017 15:40:23 -0600 Subject: altos/lisp: split set/def. Add def support to lambdas In scheme, set can only re-define existing variables while def cannot redefine existing variables in lambda context. Def within lambda creates a new variable at the nearest enclosing scope. Signed-off-by: Keith Packard --- src/lisp/ao_lisp.h | 19 +- src/lisp/ao_lisp_atom.c | 54 +++-- src/lisp/ao_lisp_builtin.c | 13 +- src/lisp/ao_lisp_builtin.txt | 1 + src/lisp/ao_lisp_const.lisp | 487 ++++++++++++++++++++---------------------- src/lisp/ao_lisp_eval.c | 2 + src/lisp/ao_lisp_frame.c | 43 ++-- src/lisp/ao_lisp_make_const.c | 8 +- src/lisp/ao_lisp_mem.c | 2 + src/lisp/ao_lisp_stack.c | 4 +- src/test/ao_lisp_os.h | 2 +- src/test/hanoi.lisp | 152 ++++++------- 12 files changed, 395 insertions(+), 392 deletions(-) (limited to 'src') diff --git a/src/lisp/ao_lisp.h b/src/lisp/ao_lisp.h index 96a7a05f..1f3fb2b4 100644 --- a/src/lisp/ao_lisp.h +++ b/src/lisp/ao_lisp.h @@ -111,8 +111,9 @@ extern uint16_t ao_lisp_top; #define AO_LISP_DIVIDE_BY_ZERO 0x02 #define AO_LISP_INVALID 0x04 #define AO_LISP_UNDEFINED 0x08 -#define AO_LISP_EOF 0x10 -#define AO_LISP_EXIT 0x20 +#define AO_LISP_REDEFINED 0x10 +#define AO_LISP_EOF 0x20 +#define AO_LISP_EXIT 0x40 extern uint8_t ao_lisp_exception; @@ -627,7 +628,7 @@ 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_lisp_atom_ref(ao_poly atom); ao_poly ao_lisp_atom_get(ao_poly atom); @@ -635,6 +636,9 @@ ao_lisp_atom_get(ao_poly atom); ao_poly ao_lisp_atom_set(ao_poly atom, ao_poly val); +ao_poly +ao_lisp_atom_def(ao_poly atom, ao_poly val); + /* int */ void ao_lisp_int_write(ao_poly i); @@ -757,12 +761,15 @@ 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); +ao_poly +ao_lisp_frame_add(struct ao_lisp_frame *frame, ao_poly atom, ao_poly val); void ao_lisp_frame_write(ao_poly p); +void +ao_lisp_frame_init(void); + /* lambda */ extern const struct ao_lisp_type ao_lisp_lambda_type; @@ -864,7 +871,7 @@ ao_lisp_frames_dump(void) #include extern int dbg_move_depth; #define MDBG_DUMP 1 -#define MDBG_OFFSET(a) ((int) ((uint8_t *) (a) - ao_lisp_pool)) +#define MDBG_OFFSET(a) ((a) ? (int) ((uint8_t *) (a) - ao_lisp_pool) : -1) extern int dbg_mem; diff --git a/src/lisp/ao_lisp_atom.c b/src/lisp/ao_lisp_atom.c index ede13567..a633c223 100644 --- a/src/lisp/ao_lisp_atom.c +++ b/src/lisp/ao_lisp_atom.c @@ -98,42 +98,25 @@ ao_lisp_atom_intern(char *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_lisp_atom_ref(ao_poly atom) { ao_poly *ref; - ao_lisp_atom_init(); - while (frame) { + struct ao_lisp_frame *frame; + + for (frame = ao_lisp_frame_current; frame; frame = ao_lisp_poly_frame(frame->prev)) { 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; + return ao_lisp_frame_ref(ao_lisp_frame_global, atom); } ao_poly ao_lisp_atom_get(ao_poly atom) { - ao_poly *ref = ao_lisp_atom_ref(ao_lisp_frame_current, atom); + ao_poly *ref = ao_lisp_atom_ref(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); @@ -146,17 +129,28 @@ ao_lisp_atom_get(ao_poly atom) ao_poly ao_lisp_atom_set(ao_poly atom, ao_poly val) { - ao_poly *ref = ao_lisp_atom_ref(ao_lisp_frame_current, atom); + ao_poly *ref = ao_lisp_atom_ref(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); + if (!ref) + return ao_lisp_error(AO_LISP_UNDEFINED, "undefined atom %s", ao_lisp_poly_atom(atom)->name); + *ref = val; return val; } +ao_poly +ao_lisp_atom_def(ao_poly atom, ao_poly val) +{ + ao_poly *ref = ao_lisp_atom_ref(atom); + + if (ref) { + if (ao_lisp_frame_current) + return ao_lisp_error(AO_LISP_REDEFINED, "attempt to redefine atom %s", ao_lisp_poly_atom(atom)->name); + *ref = val; + return val; + } + return ao_lisp_frame_add(ao_lisp_frame_current ? ao_lisp_frame_current : ao_lisp_frame_global, atom, val); +} + void ao_lisp_atom_write(ao_poly a) { diff --git a/src/lisp/ao_lisp_builtin.c b/src/lisp/ao_lisp_builtin.c index f13f2180..d4751ac2 100644 --- a/src/lisp/ao_lisp_builtin.c +++ b/src/lisp/ao_lisp_builtin.c @@ -207,6 +207,17 @@ ao_lisp_do_set(struct ao_lisp_cons *cons) return ao_lisp_atom_set(ao_lisp_arg(cons, 0), ao_lisp_arg(cons, 1)); } +ao_poly +ao_lisp_do_def(struct ao_lisp_cons *cons) +{ + if (!ao_lisp_check_argc(_ao_lisp_atom_def, cons, 2, 2)) + return AO_LISP_NIL; + if (!ao_lisp_check_argt(_ao_lisp_atom_def, cons, 0, AO_LISP_ATOM, 0)) + return AO_LISP_NIL; + + return ao_lisp_atom_def(ao_lisp_arg(cons, 0), ao_lisp_arg(cons, 1)); +} + ao_poly ao_lisp_do_setq(struct ao_lisp_cons *cons) { @@ -216,7 +227,7 @@ ao_lisp_do_setq(struct ao_lisp_cons *cons) name = cons->car; if (ao_lisp_poly_type(name) != AO_LISP_ATOM) return ao_lisp_error(AO_LISP_INVALID, "set! of non-atom"); - if (!ao_lisp_atom_ref(ao_lisp_frame_current, name)) + if (!ao_lisp_atom_ref(name)) return ao_lisp_error(AO_LISP_INVALID, "atom not defined"); return ao_lisp__cons(_ao_lisp_atom_set, ao_lisp__cons(ao_lisp__cons(_ao_lisp_atom_quote, diff --git a/src/lisp/ao_lisp_builtin.txt b/src/lisp/ao_lisp_builtin.txt index 6925ac17..abed7afe 100644 --- a/src/lisp/ao_lisp_builtin.txt +++ b/src/lisp/ao_lisp_builtin.txt @@ -15,6 +15,7 @@ atom unquote atom unquote_splicing unquote-splicing f_lambda set macro setq set! +f_lambda def nlambda cond nlambda begin nlambda while diff --git a/src/lisp/ao_lisp_const.lisp b/src/lisp/ao_lisp_const.lisp index 5c1aa75b..436da3dc 100644 --- a/src/lisp/ao_lisp_const.lisp +++ b/src/lisp/ao_lisp_const.lisp @@ -14,187 +14,185 @@ ; Lisp code placed in ROM ; return a list containing all of the arguments -(set (quote list) (lexpr (l) l)) +(def (quote list) (lexpr (l) l)) -(set (quote set!) +(def (quote def!) (macro (name value rest) (list - set - (list - quote - name) + def + (list quote name) value) ) ) -(set! append - (lexpr (args) - ((lambda (append-list append-lists) - (set! append-list - (lambda (a b) - (cond ((null? a) b) - (else (cons (car a) (append-list (cdr a) b))) - ) - ) - ) - (set! 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) - ) () ()) - ) - ) +(begin + (def! append + (lexpr (args) + ((lambda (append-list append-lists) + (set! append-list + (lambda (a b) + (cond ((null? a) b) + (else (cons (car a) (append-list (cdr a) b))) + ) + ) + ) + (set! 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 -(set! or - (macro (l) - ((lambda (_or) - (set! _or - (lambda (l) - (cond ((null? l) #f) - ((null? (cdr l)) - (car l)) - (else - (list - cond - (list - (car l)) - (list - 'else - (_or (cdr l)) - ) - ) - ) - ) +(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 l))) + 'or) ; execute to resolve macros (or #f #t) - -(set! and - (macro (l) - ((lambda (_and) - (set! _and - (lambda (l) - (cond ((null? l) #t) - ((null? (cdr l)) - (car l)) - (else - (list - cond - (list - (car l) - (_and (cdr l)) - ) - ) - ) - ) +(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 l))) + 'and) ; execute to resolve macros (and #t #f) -(set! quasiquote - (macro (x rest) - ((lambda (constant? combine-skeletons expand-quasiquote) - (set! constant? +(begin + (def! quasiquote + (macro (x rest) + (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)) - ) - ) - ) - ) - (set! 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))) + (lambda (exp) + (cond ((pair? exp) + (eq? (car exp) 'quote) ) (else - (list 'cons left right) + (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) + ) + ) + ) + ) - (set! expand-quasiquote - (lambda (exp nesting) - (cond + (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) - ) - ) - ) + ((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)) - ) - ) + ((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)) + ((and (eq? (car exp) 'quasiquote) (= (length exp) 2)) + (combine-skeletons ''quasiquote + (expand-quasiquote (cdr exp) (+ nesting 1)) + exp)) ; check for an ; unquote-splicing member, @@ -202,36 +200,36 @@ ; 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)) - ) - ) + ((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) - ) - ) - ) - ) - (expand-quasiquote x 0) - ) () () ()) - ) - ) + (else (combine-skeletons (expand-quasiquote (car exp) nesting) + (expand-quasiquote (cdr exp) nesting) + exp) + ) + ) + ) + ) + (expand-quasiquote x 0) + ) + ) + 'quasiquote) ; ; Define a variable without returning the value ; Useful when defining functions to avoid @@ -242,9 +240,8 @@ ; (define (name x y z) sexprs ...) ; -(set! define +(def! define (macro (first rest) - ; check for alternate lambda definition form (cond ((list? first) @@ -261,14 +258,13 @@ ) ) `(begin - (set! ,first ,rest) + (def (quote ,first) ,rest) (quote ,first)) ) ) ; basic list accessors - (define (caar l) (car (car l))) (define (cadr l) (car (cdr l))) @@ -392,47 +388,36 @@ ; ; (let ((x 1) (y)) (set! y (+ x 1)) y) -(define let (macro (vars exprs) - ((lambda (make-names make-vals) - - ; - ; make the list of names in the let - ; - - (set! make-names (lambda (vars) - (cond ((not (null? vars)) - (cons (car (car vars)) - (make-names (cdr vars)))) - (else ()) - ) - ) - ) +(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 - (set! make-vals (lambda (vars) - (cond ((not (null? vars)) - (cons (cond ((null? (cdr (car vars))) ()) - (else - (car (cdr (car vars)))) - ) - (make-vals (cdr vars)))) - (else ()) - ) - ) - ) + (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)) - ) - () - () - ) - ) + `((lambda ,(make-names vars) ,@exprs) ,@(make-vals vars)) + ) ) @@ -457,71 +442,58 @@ ; ; (let* ((x 1) (y)) (set! y (+ x 1)) y) -(define let* (macro (vars exprs) - ((lambda (make-names make-exprs make-nils) +(define let* + (macro (vars exprs) ; ; make the list of names in the let ; - (set! make-names (lambda (vars) - (cond ((not (null? vars)) - (cons (car (car vars)) - (make-names (cdr vars)))) - (else ()) - ) - ) - ) + (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 - (set! make-exprs (lambda (vars exprs) - (cond ((not (null? vars)) - (cons - (list set - (list quote - (car (car vars)) - ) - (cond ((null? (cdr (car vars))) ()) - (else (cadr (car vars)))) - ) - (make-exprs (cdr vars) exprs) - ) - ) - (else exprs) - ) - ) + (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 - (set! make-nils (lambda (vars) - (cond ((not (null? vars)) (cons () (make-nils (cdr vars)))) - (else ()) - ) - ) - ) - ; prepend the set operations - ; to the expressions - - (set! exprs (make-exprs vars exprs)) - + (define (make-nils vars) + (cond ((null? vars) ()) + (else (cons () (make-nils (cdr vars)))) + ) + ) ; build the lambda. - `((lambda ,(make-names vars) ,@exprs) ,@(make-nils vars)) - ) - () - () - () - ) - ) + `((lambda ,(make-names vars) ,@(make-exprs vars exprs)) ,@(make-nils vars)) + ) ) -(let* ((x 1)) x) +(let* ((x 1) (y x)) (+ x y)) (define when (macro (test l) `(cond (,test ,@l)))) @@ -545,7 +517,7 @@ (define (list-tail x k) (if (zero? k) x - (list-tail (cdr x) (- k 1))))) + (list-tail (cdr x) (- k 1)))) (list-tail '(1 2 3) 2) @@ -682,19 +654,32 @@ (display "apply\n") (apply cons '(a b)) -(define map (lexpr (proc lists) - (let* ((args (lambda (lists) - (if (null? lists) () - (cons (caar lists) (args (cdr lists)))))) - (next (lambda (lists) - (if (null? lists) () - (cons (cdr (car lists)) (next (cdr lists)))))) - (domap (lambda (lists) - (if (null? (car lists)) () - (cons (apply proc (args lists)) (domap (next lists))) - ))) - ) - (domap lists)))) +(define map + (lexpr (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))) diff --git a/src/lisp/ao_lisp_eval.c b/src/lisp/ao_lisp_eval.c index fa25edf0..02329ee6 100644 --- a/src/lisp/ao_lisp_eval.c +++ b/src/lisp/ao_lisp_eval.c @@ -559,6 +559,8 @@ ao_lisp_eval(ao_poly _v) { ao_lisp_v = _v; + ao_lisp_frame_init(); + if (!ao_lisp_stack_push()) return AO_LISP_NIL; diff --git a/src/lisp/ao_lisp_frame.c b/src/lisp/ao_lisp_frame.c index dd29e079..13a68b38 100644 --- a/src/lisp/ao_lisp_frame.c +++ b/src/lisp/ao_lisp_frame.c @@ -37,10 +37,12 @@ frame_vals_mark(void *addr) struct ao_lisp_val *v = &vals->vals[f]; ao_lisp_poly_mark(v->val, 0); - MDBG_MOVE("frame mark atom %s %d val %d at %d\n", + MDBG_MOVE("frame mark atom %s %d val %d at %d ", ao_lisp_poly_atom(v->atom)->name, MDBG_OFFSET(ao_lisp_ref(v->atom)), MDBG_OFFSET(ao_lisp_ref(v->val)), f); + MDBG_DO(ao_lisp_poly_write(v->val)); + MDBG_DO(printf("\n")); } } @@ -202,6 +204,7 @@ ao_lisp_frame_vals_new(int num) return NULL; vals->type = AO_LISP_FRAME_VALS; vals->size = num; + memset(vals->vals, '\0', num * sizeof (struct ao_lisp_val)); return vals; } @@ -226,10 +229,9 @@ ao_lisp_frame_new(int num) vals = ao_lisp_frame_vals_new(num); frame = ao_lisp_poly_frame(ao_lisp_poly_fetch(0)); frame->vals = ao_lisp_frame_vals_poly(vals); + frame->num = num; } - frame->num = num; frame->prev = AO_LISP_NIL; - memset(vals, '\0', vals->size * sizeof (struct ao_lisp_val)); return frame; } @@ -245,9 +247,13 @@ ao_lisp_frame_mark(struct ao_lisp_frame *frame) void ao_lisp_frame_free(struct ao_lisp_frame *frame) { - if (!ao_lisp_frame_marked(frame)) { + if (frame && !ao_lisp_frame_marked(frame)) { int num = frame->num; if (num < AO_LISP_FRAME_FREE) { + struct ao_lisp_frame_vals *vals; + + vals = ao_lisp_poly_frame_vals(frame->vals); + memset(vals->vals, '\0', vals->size * sizeof (struct ao_lisp_val)); frame->prev = ao_lisp_frame_poly(ao_lisp_frame_free_list[num]); ao_lisp_frame_free_list[num] = frame; } @@ -291,30 +297,33 @@ ao_lisp_frame_bind(struct ao_lisp_frame *frame, int num, ao_poly atom, ao_poly v vals->vals[l].val = val; } -int -ao_lisp_frame_add(struct ao_lisp_frame **frame_ref, ao_poly atom, ao_poly val) +ao_poly +ao_lisp_frame_add(struct ao_lisp_frame *frame, 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, f + 1); - } else { - f = 0; - frame = ao_lisp_frame_new(1); - *frame_ref = frame; - } + f = frame->num; + frame = ao_lisp_frame_realloc(frame, f + 1); if (!frame) - return 0; + return AO_LISP_NIL; 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; + return val; +} + +struct ao_lisp_frame *ao_lisp_frame_global; +struct ao_lisp_frame *ao_lisp_frame_current; + +void +ao_lisp_frame_init(void) +{ + if (!ao_lisp_frame_global) + ao_lisp_frame_global = ao_lisp_frame_new(0); } diff --git a/src/lisp/ao_lisp_make_const.c b/src/lisp/ao_lisp_make_const.c index f9bb5452..f3ea6be0 100644 --- a/src/lisp/ao_lisp_make_const.c +++ b/src/lisp/ao_lisp_make_const.c @@ -133,7 +133,7 @@ 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); + ao_poly *ref = ao_lisp_atom_ref(atom); if (ref) return *ref; return AO_LISP_NIL; @@ -289,6 +289,8 @@ main(int argc, char **argv) } } + ao_lisp_frame_init(); + /* Boolean values #f and #t */ ao_lisp_bool_get(0); ao_lisp_bool_get(1); @@ -298,13 +300,13 @@ main(int argc, char **argv) if (funcs[f].func != prev_func) 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_atom_def(ao_lisp_atom_poly(a), ao_lisp_builtin_poly(b)); } /* end of file value */ a = ao_lisp_atom_intern("eof"); - ao_lisp_atom_set(ao_lisp_atom_poly(a), + ao_lisp_atom_def(ao_lisp_atom_poly(a), ao_lisp_atom_poly(a)); /* 'else' */ diff --git a/src/lisp/ao_lisp_mem.c b/src/lisp/ao_lisp_mem.c index 890eba1b..3a704380 100644 --- a/src/lisp/ao_lisp_mem.c +++ b/src/lisp/ao_lisp_mem.c @@ -501,6 +501,7 @@ ao_lisp_collect(uint8_t style) MDBG_MOVE("collect %d\n", ao_lisp_collects[style]); #endif + MDBG_DO(ao_lisp_frame_write(ao_lisp_frame_poly(ao_lisp_frame_global))); /* The first time through, we're doing a full collect */ if (ao_lisp_last_top == 0) @@ -875,6 +876,7 @@ ao_lisp_alloc(int size) } addr = ao_lisp_pool + ao_lisp_top; ao_lisp_top += size; + MDBG_MOVE("alloc %d size %d\n", MDBG_OFFSET(addr), size); return addr; } diff --git a/src/lisp/ao_lisp_stack.c b/src/lisp/ao_lisp_stack.c index 9d6cccc4..e7c89801 100644 --- a/src/lisp/ao_lisp_stack.c +++ b/src/lisp/ao_lisp_stack.c @@ -103,7 +103,9 @@ ao_lisp_stack_new(void) int ao_lisp_stack_push(void) { - struct ao_lisp_stack *stack = ao_lisp_stack_new(); + struct ao_lisp_stack *stack; + + stack = ao_lisp_stack_new(); if (!stack) return 0; diff --git a/src/test/ao_lisp_os.h b/src/test/ao_lisp_os.h index 9b021900..ebd16bb4 100644 --- a/src/test/ao_lisp_os.h +++ b/src/test/ao_lisp_os.h @@ -22,7 +22,7 @@ #include #include -#define AO_LISP_POOL_TOTAL 3072 +#define AO_LISP_POOL_TOTAL 16384 #define AO_LISP_SAVE 1 #define DBG_MEM_STATS 1 diff --git a/src/test/hanoi.lisp b/src/test/hanoi.lisp index 02e16876..4afde883 100644 --- a/src/test/hanoi.lisp +++ b/src/test/hanoi.lisp @@ -16,20 +16,17 @@ ; ANSI control sequences -(define move-to (lambda (col row) - (for-each display (list "\033[" row ";" col "H")) - ) +(define (move-to col row) + (for-each display (list "\033[" row ";" col "H")) ) -(define clear (lambda () - (display "\033[2J") - ) +(define (clear) + (display "\033[2J") ) -(define display-string (lambda (x y str) - (move-to x y) - (display str) - ) +(define (display-string x y str) + (move-to x y) + (display str) ) ; Here's the pieces to display @@ -41,75 +38,69 @@ (define towers ()) -(define one- (lambda (x) (- x 1))) -(define one+ (lambda (x) (+ x 1))) +(define (one- x) (- x 1)) +(define (one+ x) (+ x 1)) ; Display one tower, clearing any ; space above it -(define display-tower (lambda (x y clear tower) - (cond ((= 0 clear) - (cond ((not (null? tower)) - (display-string x y (car tower)) - (display-tower x (one+ y) 0 (cdr tower)) - ) - ) - ) - (else - (display-string x y " ") - (display-tower x (one+ y) (one- clear) tower) - ) - ) - ) +(define (display-tower x y clear tower) + (cond ((= 0 clear) + (cond ((not (null? tower)) + (display-string x y (car tower)) + (display-tower x (one+ y) 0 (cdr tower)) + ) + ) + ) + (else + (display-string x y " ") + (display-tower x (one+ y) (one- clear) tower) + ) + ) ) ; Position of the top of the tower on the screen ; Shorter towers start further down the screen -(define tower-pos (lambda (y tower) - (- y (length tower)) - ) +(define (tower-pos y tower) + (- y (length tower)) ) ; Display all of the towers, spaced 20 columns apart -(define display-towers (lambda (x y towers) - (cond ((not (null? towers)) - (display-tower x 0 (tower-pos y (car towers)) (car towers)) - (display-towers (+ x 20) y (cdr towers))) - ) - ) +(define (display-towers x y towers) + (cond ((not (null? towers)) + (display-tower x 0 (tower-pos y (car towers)) (car towers)) + (display-towers (+ x 20) y (cdr towers))) + ) ) (define top 0) ; Display all of the towers, then move the cursor ; out of the way and flush the output -(define display-hanoi (lambda () - (display-towers 0 top towers) - (move-to 1 21) - (flush-output) - ) +(define (display-hanoi) + (display-towers 0 top towers) + (move-to 1 21) + (flush-output) ) ; Reset towers to the starting state, with ; all of the pieces in the first tower and the ; other two empty -(define reset-towers (lambda () - (set! towers (list tower () ())) - (set! top (+ (length tower) 3)) - (length tower) - ) +(define (reset-towers) + (set! towers (list tower () ())) + (set! top (+ (length tower) 3)) + (length tower) ) ; Replace a tower in the list of towers ; with a new value -(define replace (lambda (list pos member) - (cond ((= pos 0) (cons member (cdr list))) - ((cons (car list) (replace (cdr list) (one- pos) member))) - ) - ) +(define (replace list pos member) + (cond ((= pos 0) (cons member (cdr list))) + (else (cons (car list) (replace (cdr list) (one- pos) member))) + ) ) ; Move a piece from the top of one tower @@ -117,33 +108,31 @@ (define move-delay 10) -(define move-piece (lambda (from to) - (let* ((from-tower (list-ref towers from)) - (to-tower (list-ref towers to)) - (piece (car from-tower))) - (set! from-tower (cdr from-tower)) - (set! to-tower (cons piece to-tower)) - (set! towers (replace towers from from-tower)) - (set! towers (replace towers to to-tower)) - (display-hanoi) - (delay move-delay) - ) - ) +(define (move-piece from to) + (let* ((from-tower (list-ref towers from)) + (to-tower (list-ref towers to)) + (piece (car from-tower))) + (set! from-tower (cdr from-tower)) + (set! to-tower (cons piece to-tower)) + (set! towers (replace towers from from-tower)) + (set! towers (replace towers to to-tower)) + (display-hanoi) + (delay move-delay) + ) ) ; The implementation of the game -(define _hanoi (lambda (n from to use) - (cond ((= 1 n) - (move-piece from to) - ) - (else - (_hanoi (one- n) from use to) - (_hanoi 1 from to use) - (_hanoi (one- n) use to from) - ) - ) - ) +(define (_hanoi n from to use) + (cond ((= 1 n) + (move-piece from to) + ) + (else + (_hanoi (one- n) from use to) + (_hanoi 1 from to use) + (_hanoi (one- n) use to from) + ) + ) ) ; A pretty interface which @@ -151,13 +140,12 @@ ; clears the screen and runs ; the program -(define hanoi (lambda () - (let ((len)) - (set! len (reset-towers)) - (clear) - (_hanoi len 0 1 2) - (move-to 0 23) - #t - ) - ) +(define (hanoi) + (let ((len (reset-towers))) + (clear) + (_hanoi len 0 1 2) + (move-to 0 23) + #t + ) + ) ) -- cgit v1.2.3 From f0068719b17019c5cd7ed318364a0581caf64e1a Mon Sep 17 00:00:00 2001 From: Keith Packard Date: Sat, 2 Dec 2017 15:32:38 -0600 Subject: altos/kernel: MPU9250 support Use MPU9250 for accel, gyro and mag data in logging, telemetry and flight status computations. Signed-off-by: Keith Packard --- src/kernel/ao_data.h | 58 +++++++++++++++++++++++++++++++++++++++++++++++ src/kernel/ao_flight.c | 2 +- src/kernel/ao_log.h | 3 ++- src/kernel/ao_log_mega.c | 11 +++++++++ src/kernel/ao_sample.c | 6 ++--- src/kernel/ao_telemetry.c | 16 ++++++++++++- 6 files changed, 90 insertions(+), 6 deletions(-) (limited to 'src') diff --git a/src/kernel/ao_data.h b/src/kernel/ao_data.h index 9a3b389c..88d0e916 100644 --- a/src/kernel/ao_data.h +++ b/src/kernel/ao_data.h @@ -330,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 @@ -344,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 #endif -#if HAS_MPU6000 +#if HAS_MPU6000 || HAS_MPU9250 #include #endif diff --git a/src/kernel/ao_log.h b/src/kernel/ao_log.h index 1c186364..5f04ef9a 100644 --- a/src/kernel/ao_log.h +++ b/src/kernel/ao_log.h @@ -54,6 +54,7 @@ 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 */ /* Return the flight number from the given log slot, 0 if none, -slot on failure */ @@ -473,7 +474,7 @@ struct ao_log_gps { } u; }; -#if AO_LOG_FORMAT == AO_LOG_FOMAT_TELEMEGA_OLD || AO_LOG_FORMAT == AO_LOG_FORMAT_TELEMEGA +#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 diff --git a/src/kernel/ao_log_mega.c b/src/kernel/ao_log_mega.c index d1cf4f13..c6bdf1e2 100644 --- a/src/kernel/ao_log_mega.c +++ b/src/kernel/ao_log_mega.c @@ -93,6 +93,17 @@ ao_log(void) log.u.sensor.mag_x = ao_data_ring[ao_log_data_pos].hmc5883.x; 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_write(&log); 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_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(); } -- cgit v1.2.3 From ecc075596d6cd2b9c0a3107036d5368ebc3a77bd Mon Sep 17 00:00:00 2001 From: Keith Packard Date: Sat, 2 Dec 2017 15:31:06 -0600 Subject: altos: Add TeleMega v3.0 Adds files to build telemega v3.0 flash loader and firmware Signed-off-by: Keith Packard --- src/telemega-v3.0/.gitignore | 2 + src/telemega-v3.0/Makefile | 153 ++++++++++++ src/telemega-v3.0/ao_pins.h | 402 +++++++++++++++++++++++++++++++ src/telemega-v3.0/ao_telemega.c | 104 ++++++++ src/telemega-v3.0/flash-loader/Makefile | 8 + src/telemega-v3.0/flash-loader/ao_pins.h | 35 +++ 6 files changed, 704 insertions(+) create mode 100644 src/telemega-v3.0/.gitignore create mode 100644 src/telemega-v3.0/Makefile create mode 100644 src/telemega-v3.0/ao_pins.h create mode 100644 src/telemega-v3.0/ao_telemega.c create mode 100644 src/telemega-v3.0/flash-loader/Makefile create mode 100644 src/telemega-v3.0/flash-loader/ao_pins.h (limited to 'src') 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 + * + * 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 + * + * 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 +#include +#include +#include +#include +#include +#include +#include +#include +#if HAS_SAMPLE_PROFILE +#include +#endif +#include +#if HAS_STACK_GUARD +#include +#endif +#include + +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 + * + * 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 + +/* 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_ */ -- cgit v1.2.3 From 8c19778d8b56aafa048ddf9654c40b32bd8c64b0 Mon Sep 17 00:00:00 2001 From: Keith Packard Date: Sat, 2 Dec 2017 15:53:05 -0600 Subject: altos: Build TeleMega v3.0 by default Signed-off-by: Keith Packard --- src/Makefile | 1 + 1 file changed, 1 insertion(+) (limited to 'src') diff --git a/src/Makefile b/src/Makefile index 661fd333..defeea96 100644 --- a/src/Makefile +++ b/src/Makefile @@ -30,6 +30,7 @@ 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 \ -- cgit v1.2.3 From 577911241db454bc3129fc47566c6a55752c4182 Mon Sep 17 00:00:00 2001 From: Keith Packard Date: Sat, 2 Dec 2017 23:19:44 -0600 Subject: altos/lisp: Overflow int computations to float When an int computation overflows, switch to float. Signed-off-by: Keith Packard --- src/lisp/ao_lisp.h | 2 ++ src/lisp/ao_lisp_builtin.c | 42 ++++++++++++++++-------------------------- 2 files changed, 18 insertions(+), 26 deletions(-) (limited to 'src') diff --git a/src/lisp/ao_lisp.h b/src/lisp/ao_lisp.h index 1f3fb2b4..7cd8b5a5 100644 --- a/src/lisp/ao_lisp.h +++ b/src/lisp/ao_lisp.h @@ -208,6 +208,8 @@ ao_lisp_bigint_int(uint32_t bi) { #define AO_LISP_MIN_INT (-(1 << (15 - AO_LISP_TYPE_SHIFT))) #define AO_LISP_MAX_INT ((1 << (15 - AO_LISP_TYPE_SHIFT)) - 1) +#define AO_LISP_MIN_BIGINT (-(1 << 24)) +#define AO_LISP_MAX_BIGINT ((1 << 24) - 1) #define AO_LISP_NOT_INTEGER 0x7fffffff diff --git a/src/lisp/ao_lisp_builtin.c b/src/lisp/ao_lisp_builtin.c index d4751ac2..ad8f4125 100644 --- a/src/lisp/ao_lisp_builtin.c +++ b/src/lisp/ao_lisp_builtin.c @@ -321,24 +321,30 @@ ao_lisp_math(struct ao_lisp_cons *orig_cons, enum ao_lisp_builtin_id op) } else if (ao_lisp_integer_typep(rt) && ao_lisp_integer_typep(ct)) { int32_t r = ao_lisp_poly_integer(ret); int32_t c = ao_lisp_poly_integer(car); + int64_t t; switch(op) { case builtin_plus: r += c; + check_overflow: + if (r < AO_LISP_MIN_BIGINT || AO_LISP_MAX_BIGINT < r) + goto inexact; break; case builtin_minus: r -= c; + goto check_overflow; break; case builtin_times: - r *= c; + t = (int64_t) r * (int64_t) c; + if (t < AO_LISP_MIN_BIGINT || AO_LISP_MAX_BIGINT < t) + goto inexact; + r = (int32_t) t; break; case builtin_divide: if (c != 0 && (r % c) == 0) r /= c; - else { - ret = ao_lisp_float_get((float) r / (float) c); - continue; - } + else + goto inexact; break; case builtin_quotient: if (c == 0) @@ -365,8 +371,10 @@ ao_lisp_math(struct ao_lisp_cons *orig_cons, enum ao_lisp_builtin_id op) } ret = ao_lisp_integer_poly(r); } else if (ao_lisp_number_typep(rt) && ao_lisp_number_typep(ct)) { - float r = ao_lisp_poly_number(ret); - float c = ao_lisp_poly_number(car); + float r, c; + inexact: + r = ao_lisp_poly_number(ret); + c = ao_lisp_poly_number(car); switch(op) { case builtin_plus: r += c; @@ -380,28 +388,10 @@ ao_lisp_math(struct ao_lisp_cons *orig_cons, enum ao_lisp_builtin_id op) case builtin_divide: r /= c; break; -#if 0 case builtin_quotient: - if (c == 0) - return ao_lisp_error(AO_LISP_DIVIDE_BY_ZERO, "quotient by zero"); - if (r % c != 0 && (c < 0) != (r < 0)) - r = r / c - 1; - else - r = r / c; - break; case builtin_remainder: - if (c == 0) - return ao_lisp_error(AO_LISP_DIVIDE_BY_ZERO, "remainder by zero"); - r %= c; - break; case builtin_modulo: - if (c == 0) - return ao_lisp_error(AO_LISP_DIVIDE_BY_ZERO, "modulo by zero"); - r %= c; - if ((r < 0) != (c < 0)) - r += c; - break; -#endif + return ao_lisp_error(AO_LISP_INVALID, "non-integer value in integer divide"); default: break; } -- cgit v1.2.3 From 880c35363a2596202c8a3d980bf4ac41eceead66 Mon Sep 17 00:00:00 2001 From: Keith Packard Date: Sat, 2 Dec 2017 23:21:01 -0600 Subject: altos/lisp: Convert more builtin lisp code to scheme format Use defines where possible, use (define (name args ...)) form for lambdas Signed-off-by: Keith Packard --- src/lisp/ao_lisp_const.lisp | 159 +++++++++++++++++++++++++------------------- 1 file changed, 92 insertions(+), 67 deletions(-) (limited to 'src') diff --git a/src/lisp/ao_lisp_const.lisp b/src/lisp/ao_lisp_const.lisp index 436da3dc..bb413e7d 100644 --- a/src/lisp/ao_lisp_const.lisp +++ b/src/lisp/ao_lisp_const.lisp @@ -28,24 +28,23 @@ (begin (def! append (lexpr (args) - ((lambda (append-list append-lists) - (set! append-list - (lambda (a b) - (cond ((null? a) b) - (else (cons (car a) (append-list (cdr a) b))) - ) - ) - ) - (set! 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) - ) () ()) + (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) @@ -240,28 +239,31 @@ ; (define (name x y z) sexprs ...) ; -(def! define - (macro (first rest) +(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)) - ) - ) - `(begin - (def (quote ,first) ,rest) - (quote ,first)) - ) - ) + (cond ((list? first) + (set! rest + (append + (list + 'lambda + (cdr first)) + rest)) + (set! first (car first)) + ) + (else + (set! rest (car rest)) + ) + ) + `(begin + (def (quote ,first) ,rest) + (quote ,first)) + ) + ) + 'define + ) ; basic list accessors @@ -689,9 +691,11 @@ (for-each display '("hello" " " "world" "\n")) -(define _string-ml (lambda (strings) - (if (null? strings) () - (cons (string->list (car strings)) (_string-ml (cdr strings)))))) +(define (_string-ml strings) + (if (null? strings) () + (cons (string->list (car strings)) (_string-ml (cdr strings))) + ) + ) (define string-map (lexpr (proc strings) (list->string (apply map proc (_string-ml strings)))))) @@ -703,7 +707,7 @@ (string-for-each write-char "IBM\n") -(define newline (lambda () (write-char #\newline))) +(define (newline) (write-char #\newline)) (newline) @@ -726,52 +730,73 @@ `(hello ,(+ 1 2) ,@(list 1 2 3) `foo) -(define repeat (macro (count rest) - `(let ((__count__ ,count)) - (while (<= 0 (set! __count__ (- __count__ 1))) ,@rest)))) + +(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 3 (write 'goodbye)) +(repeat (x 3) (write 'goodbye x)) -(define case (macro (test l) - (let* ((_unarrow +(define case + (macro (test l) ; construct the body of the ; case, dealing with the ; lambda version ( => lambda) - - (lambda (l) - (cond ((null? l) l) - ((eq? (car l) '=>) `(( ,(cadr l) __key__))) - (else l)))) - (_case (lambda (l) + + (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 - (cond ((null? l) ()) + (define (_case l) + + (cond ((null? l) ()) ; else case - ((eq? (caar l) 'else) - `((else ,@(_unarrow (cdr (car l)))))) + ((eq? (caar l) 'else) + `((else ,@(_unarrow (cdr (car l)))))) ; regular case - - (else - (cons - `((eqv? ,(caar l) __key__) - ,@(_unarrow (cdr (car l)))) - (_case (cdr l))) - ) - )))) + + (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)))) + `((lambda (__key__) + (cond ,@(_case l))) ,test) + ) + ) (case 12 (1 "one") (2 "two") (3 => (lambda (x) (write "the value is" x))) (12 "twelve") (else "else")) -- cgit v1.2.3 From b9009b3916956db00b7b78bd06fb0df704690eb1 Mon Sep 17 00:00:00 2001 From: Keith Packard Date: Sat, 2 Dec 2017 23:21:55 -0600 Subject: altos/lisp: use strtof instead of atof atof returns double, strtof returns float. Signed-off-by: Keith Packard --- src/lisp/ao_lisp_read.c | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) (limited to 'src') diff --git a/src/lisp/ao_lisp_read.c b/src/lisp/ao_lisp_read.c index 747963ab..f3b627bb 100644 --- a/src/lisp/ao_lisp_read.c +++ b/src/lisp/ao_lisp_read.c @@ -15,6 +15,7 @@ #include "ao_lisp.h" #include "ao_lisp_read.h" #include +#include static const uint16_t lex_classes[128] = { IGNORE, /* ^@ */ @@ -445,7 +446,7 @@ _lex(void) return NUM; } if (isfloat && hasdigit) { - token_float = atof(token_string); + token_float = strtof(token_string, NULL); return FLOAT; } for (u = 0; u < NUM_NAMED_FLOATS; u++) @@ -524,8 +525,7 @@ ao_lisp_read(void) char *string; int cons; int read_state; - ao_poly v; - + ao_poly v = AO_LISP_NIL; cons = 0; read_state = 0; -- cgit v1.2.3 From ed6967cef5d82baacafe1c23229f44d58c838326 Mon Sep 17 00:00:00 2001 From: Keith Packard Date: Sun, 3 Dec 2017 19:47:03 -0800 Subject: altos/lisp: Split out read debug, add memory validation Split read debug into a separate #define to reduce debug noise Add some memory validation -- validate stash API, and validate cons_free calls. Signed-off-by: Keith Packard --- src/lisp/ao_lisp.h | 42 ++++++++++++++++++++++++++++++++++++---- src/lisp/ao_lisp_builtin.c | 6 +++--- src/lisp/ao_lisp_cons.c | 3 +++ src/lisp/ao_lisp_error.c | 48 ++++++++++++++++++++++++++++++++++++++++------ src/lisp/ao_lisp_eval.c | 6 +++--- src/lisp/ao_lisp_mem.c | 31 ++++++++++++++++++++++++++++++ src/lisp/ao_lisp_read.c | 10 +++++----- 7 files changed, 125 insertions(+), 21 deletions(-) (limited to 'src') diff --git a/src/lisp/ao_lisp.h b/src/lisp/ao_lisp.h index 7cd8b5a5..d32e7dcd 100644 --- a/src/lisp/ao_lisp.h +++ b/src/lisp/ao_lisp.h @@ -17,6 +17,9 @@ #define DBG_MEM 0 #define DBG_EVAL 0 +#define DBG_READ 0 +#define DBG_FREE_CONS 0 +#define NDEBUG 1 #include #include @@ -387,6 +390,16 @@ static inline int ao_lisp_poly_type(ao_poly poly) { return type; } +static inline int +ao_lisp_is_cons(ao_poly poly) { + return (ao_lisp_poly_base_type(poly) == AO_LISP_CONS); +} + +static inline int +ao_lisp_is_pair(ao_poly poly) { + return poly != AO_LISP_NIL && (ao_lisp_poly_base_type(poly) == AO_LISP_CONS); +} + static inline struct ao_lisp_cons * ao_lisp_poly_cons(ao_poly poly) { @@ -520,6 +533,11 @@ ao_lisp_alloc(int size); int ao_lisp_collect(uint8_t style); +#if DBG_FREE_CONS +void +ao_lisp_cons_check(struct ao_lisp_cons *cons); +#endif + void ao_lisp_cons_stash(int id, struct ao_lisp_cons *cons); @@ -812,6 +830,12 @@ ao_lisp_stack_eval(void); /* error */ +void +ao_lisp_vprintf(char *format, va_list args); + +void +ao_lisp_printf(char *format, ...); + void ao_lisp_error_poly(char *name, ao_poly poly, ao_poly last); @@ -828,7 +852,7 @@ ao_lisp_error(int error, char *format, ...); /* debugging macros */ -#if DBG_EVAL +#if DBG_EVAL || DBG_READ || DBG_MEM #define DBG_CODE 1 int ao_lisp_stack_depth; #define DBG_DO(a) a @@ -836,8 +860,8 @@ int ao_lisp_stack_depth; #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(...) ao_lisp_printf(__VA_ARGS__) +#define DBGI(...) do { printf("%4d: ", __LINE__); DBG_INDENT(); DBG(__VA_ARGS__); } while (0) #define DBG_CONS(a) ao_lisp_cons_write(ao_lisp_cons_poly(a)) #define DBG_POLY(a) ao_lisp_poly_write(a) #define OFFSET(a) ((a) ? (int) ((uint8_t *) a - ao_lisp_pool) : -1) @@ -866,6 +890,16 @@ ao_lisp_frames_dump(void) #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 @@ -877,7 +911,7 @@ extern int dbg_move_depth; extern int dbg_mem; -#define MDBG_DO(a) a +#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++) diff --git a/src/lisp/ao_lisp_builtin.c b/src/lisp/ao_lisp_builtin.c index ad8f4125..fdca0208 100644 --- a/src/lisp/ao_lisp_builtin.c +++ b/src/lisp/ao_lisp_builtin.c @@ -125,7 +125,7 @@ ao_lisp_check_argt(ao_poly name, struct ao_lisp_cons *cons, int argc, int type, 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_error(AO_LISP_INVALID, "%s: arg %d invalid type %v", ao_lisp_poly_atom(name)->name, argc, car); return _ao_lisp_bool_true; } @@ -226,9 +226,9 @@ ao_lisp_do_setq(struct ao_lisp_cons *cons) return AO_LISP_NIL; name = cons->car; if (ao_lisp_poly_type(name) != AO_LISP_ATOM) - return ao_lisp_error(AO_LISP_INVALID, "set! of non-atom"); + return ao_lisp_error(AO_LISP_INVALID, "set! of non-atom %v", name); if (!ao_lisp_atom_ref(name)) - return ao_lisp_error(AO_LISP_INVALID, "atom not defined"); + return ao_lisp_error(AO_LISP_INVALID, "atom %v not defined", name); return ao_lisp__cons(_ao_lisp_atom_set, ao_lisp__cons(ao_lisp__cons(_ao_lisp_atom_quote, ao_lisp__cons(name, AO_LISP_NIL)), diff --git a/src/lisp/ao_lisp_cons.c b/src/lisp/ao_lisp_cons.c index c70aa1ca..06e9d361 100644 --- a/src/lisp/ao_lisp_cons.c +++ b/src/lisp/ao_lisp_cons.c @@ -127,6 +127,9 @@ ao_lisp__cons(ao_poly car, ao_poly cdr) void ao_lisp_cons_free(struct ao_lisp_cons *cons) { +#if DBG_FREE_CONS + ao_lisp_cons_check(cons); +#endif while (cons) { ao_poly cdr = cons->cdr; cons->cdr = ao_lisp_cons_poly(ao_lisp_cons_free_list); diff --git a/src/lisp/ao_lisp_error.c b/src/lisp/ao_lisp_error.c index ba135834..7f909487 100644 --- a/src/lisp/ao_lisp_error.c +++ b/src/lisp/ao_lisp_error.c @@ -82,6 +82,43 @@ ao_lisp_error_frame(int indent, char *name, struct ao_lisp_frame *frame) printf ("}\n"); } +void +ao_lisp_vprintf(char *format, va_list args) +{ + char c; + + while ((c = *format++) != '\0') { + if (c == '%') { + switch (c = *format++) { + case 'v': + ao_lisp_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_lisp_printf(char *format, ...) +{ + va_list args; + va_start(args, format); + ao_lisp_vprintf(format, args); + va_end(args); +} ao_poly ao_lisp_error(int error, char *format, ...) @@ -90,14 +127,13 @@ ao_lisp_error(int error, char *format, ...) ao_lisp_exception |= error; va_start(args, format); - vprintf(format, args); + ao_lisp_vprintf(format, args); + putchar('\n'); va_end(args); - printf("\n"); - printf("Value: "); ao_lisp_poly_write(ao_lisp_v); printf("\n"); + ao_lisp_printf("Value: %v\n", ao_lisp_v); + ao_lisp_printf("Frame: %v\n", ao_lisp_frame_poly(ao_lisp_frame_current)); printf("Stack:\n"); ao_lisp_stack_write(ao_lisp_stack_poly(ao_lisp_stack)); - printf("Globals:\n\t"); - ao_lisp_frame_write(ao_lisp_frame_poly(ao_lisp_frame_global)); - printf("\n"); + ao_lisp_printf("Globals: %v\n", ao_lisp_frame_poly(ao_lisp_frame_global)); return AO_LISP_NIL; } diff --git a/src/lisp/ao_lisp_eval.c b/src/lisp/ao_lisp_eval.c index 02329ee6..ced182f6 100644 --- a/src/lisp/ao_lisp_eval.c +++ b/src/lisp/ao_lisp_eval.c @@ -68,7 +68,7 @@ func_type(ao_poly func) static int ao_lisp_eval_sexpr(void) { - DBGI("sexpr: "); DBG_POLY(ao_lisp_v); DBG("\n"); + DBGI("sexpr: %v\n", ao_lisp_v); switch (ao_lisp_poly_type(ao_lisp_v)) { case AO_LISP_CONS: if (ao_lisp_v == AO_LISP_NIL) { @@ -193,8 +193,8 @@ ao_lisp_eval_formal(void) 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"); + DBGI("\t.. sexprs "); DBG_POLY(ao_lisp_stack->sexprs); DBG("\n"); + DBGI("\t.. values "); DBG_POLY(ao_lisp_stack->values); DBG("\n"); DBG_FRAMES(); /* fall through ... */ diff --git a/src/lisp/ao_lisp_mem.c b/src/lisp/ao_lisp_mem.c index 3a704380..5471b137 100644 --- a/src/lisp/ao_lisp_mem.c +++ b/src/lisp/ao_lisp_mem.c @@ -16,6 +16,7 @@ #include "ao_lisp.h" #include +#include #ifdef AO_LISP_MAKE_CONST @@ -623,6 +624,32 @@ ao_lisp_collect(uint8_t style) return AO_LISP_POOL - ao_lisp_top; } +#if DBG_FREE_CONS +void +ao_lisp_cons_check(struct ao_lisp_cons *cons) +{ + ao_poly cdr; + int offset; + + chunk_low = 0; + reset_chunks(); + walk(ao_lisp_mark_ref, ao_lisp_poly_mark_ref); + while (cons) { + if (!AO_LISP_IS_POOL(cons)) + break; + offset = pool_offset(cons); + if (busy(ao_lisp_busy, offset)) { + ao_lisp_printf("cons at %p offset %d poly %d is busy\n\t%v\n", cons, offset, ao_lisp_cons_poly(cons), ao_lisp_cons_poly(cons)); + abort(); + } + cdr = cons->cdr; + if (!ao_lisp_is_pair(cdr)) + break; + cons = ao_lisp_poly_cons(cdr); + } +} +#endif + /* * Mark interfaces for objects */ @@ -883,6 +910,7 @@ ao_lisp_alloc(int size) void ao_lisp_cons_stash(int id, struct ao_lisp_cons *cons) { + assert(save_cons[id] == 0); save_cons[id] = cons; } @@ -897,6 +925,7 @@ ao_lisp_cons_fetch(int id) void ao_lisp_poly_stash(int id, ao_poly poly) { + assert(save_poly[id] == AO_LISP_NIL); save_poly[id] = poly; } @@ -911,6 +940,7 @@ ao_lisp_poly_fetch(int id) void ao_lisp_string_stash(int id, char *string) { + assert(save_string[id] == NULL); save_string[id] = string; } @@ -925,6 +955,7 @@ ao_lisp_string_fetch(int id) void ao_lisp_frame_stash(int id, struct ao_lisp_frame *frame) { + assert(save_frame[id] == NULL); save_frame[id] = frame; } diff --git a/src/lisp/ao_lisp_read.c b/src/lisp/ao_lisp_read.c index f3b627bb..0ca12a81 100644 --- a/src/lisp/ao_lisp_read.c +++ b/src/lisp/ao_lisp_read.c @@ -464,7 +464,7 @@ _lex(void) static inline int lex(void) { int parse_token = _lex(); - DBGI("token %d (%s)\n", parse_token, token_string); + RDBGI("token %d (%s)\n", parse_token, token_string); return parse_token; } @@ -481,8 +481,8 @@ struct ao_lisp_cons *ao_lisp_read_stack; static int push_read_stack(int cons, int read_state) { - DBGI("push read stack %p 0x%x\n", ao_lisp_read_cons, read_state); - DBG_IN(); + RDBGI("push read stack %p 0x%x\n", ao_lisp_read_cons, read_state); + RDBG_IN(); if (cons) { ao_lisp_read_stack = ao_lisp_cons_cons(ao_lisp_cons_poly(ao_lisp_read_cons), ao_lisp__cons(ao_lisp_int_poly(read_state), @@ -513,8 +513,8 @@ pop_read_stack(int cons) ao_lisp_read_cons_tail = 0; ao_lisp_read_stack = 0; } - DBG_OUT(); - DBGI("pop read stack %p %d\n", ao_lisp_read_cons, read_state); + RDBG_OUT(); + RDBGI("pop read stack %p %d\n", ao_lisp_read_cons, read_state); return read_state; } -- cgit v1.2.3 From 32ab76c3049b913283caafbaef873754d76dc9d4 Mon Sep 17 00:00:00 2001 From: Keith Packard Date: Sun, 3 Dec 2017 19:49:20 -0800 Subject: altos/lisp: Check only cdr base type when moving cons cells The cdr may have moved, so we can't look at the target object type. Fortunately, the base type encoded in the reference itself is sufficient to check for a non-cons cdr. Signed-off-by: Keith Packard --- src/lisp/ao_lisp_cons.c | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) (limited to 'src') diff --git a/src/lisp/ao_lisp_cons.c b/src/lisp/ao_lisp_cons.c index 06e9d361..d3b97383 100644 --- a/src/lisp/ao_lisp_cons.c +++ b/src/lisp/ao_lisp_cons.c @@ -58,8 +58,8 @@ static void cons_move(void *addr) cdr = cons->cdr; if (!cdr) break; - if (ao_lisp_poly_type(cdr) != AO_LISP_CONS) { - (void) ao_lisp_poly_move(&cons->cdr, 1); + if (ao_lisp_poly_base_type(cdr) != AO_LISP_CONS) { + (void) ao_lisp_poly_move(&cons->cdr, 0); break; } c = ao_lisp_poly_cons(cdr); @@ -95,8 +95,8 @@ ao_lisp_cons_cons(ao_poly car, ao_poly cdr) ao_lisp_poly_stash(0, car); ao_lisp_poly_stash(1, cdr); cons = ao_lisp_alloc(sizeof (struct ao_lisp_cons)); - car = ao_lisp_poly_fetch(0); cdr = ao_lisp_poly_fetch(1); + car = ao_lisp_poly_fetch(0); if (!cons) return NULL; } -- cgit v1.2.3 From a1d013ab8cc508d4e17ae8876bc5465d1a2dfc1e Mon Sep 17 00:00:00 2001 From: Keith Packard Date: Sun, 3 Dec 2017 19:52:11 -0800 Subject: altos/lisp: Fix stash usage across frame allocation Must un-stash before allocation failure check. Use frame_stash instead of poly_stash for frames. Signed-off-by: Keith Packard --- src/lisp/ao_lisp_frame.c | 15 ++++++++------- 1 file changed, 8 insertions(+), 7 deletions(-) (limited to 'src') diff --git a/src/lisp/ao_lisp_frame.c b/src/lisp/ao_lisp_frame.c index 13a68b38..c285527e 100644 --- a/src/lisp/ao_lisp_frame.c +++ b/src/lisp/ao_lisp_frame.c @@ -225,9 +225,11 @@ ao_lisp_frame_new(int num) frame->num = 0; frame->prev = AO_LISP_NIL; frame->vals = AO_LISP_NIL; - ao_lisp_poly_stash(0, ao_lisp_frame_poly(frame)); + ao_lisp_frame_stash(0, frame); vals = ao_lisp_frame_vals_new(num); - frame = ao_lisp_poly_frame(ao_lisp_poly_fetch(0)); + frame = ao_lisp_frame_fetch(0); + if (!vals) + return NULL; frame->vals = ao_lisp_frame_vals_poly(vals); frame->num = num; } @@ -271,9 +273,9 @@ ao_lisp_frame_realloc(struct ao_lisp_frame *frame, int new_num) return frame; ao_lisp_frame_stash(0, frame); new_vals = ao_lisp_frame_vals_new(new_num); + frame = ao_lisp_frame_fetch(0); if (!new_vals) return NULL; - frame = ao_lisp_frame_fetch(0); vals = ao_lisp_poly_frame_vals(frame->vals); copy = new_num; if (copy > frame->num) @@ -303,15 +305,14 @@ ao_lisp_frame_add(struct ao_lisp_frame *frame, ao_poly atom, ao_poly val) ao_poly *ref = frame ? ao_lisp_frame_ref(frame, atom) : NULL; if (!ref) { - int f; + int f = frame->num; ao_lisp_poly_stash(0, atom); ao_lisp_poly_stash(1, val); - f = frame->num; frame = ao_lisp_frame_realloc(frame, f + 1); + val = ao_lisp_poly_fetch(1); + atom = ao_lisp_poly_fetch(0); if (!frame) return AO_LISP_NIL; - 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; -- cgit v1.2.3 From 9dbc686ad7d3289dc0f9bcf4a973f71100e02ded Mon Sep 17 00:00:00 2001 From: Keith Packard Date: Sun, 3 Dec 2017 19:54:18 -0800 Subject: altos/lisp: Switch to scheme formal syntax for varargs Scheme uses bare symbols to indicate a varargs parameter; any bare (i.e., not wrapped in a cons cell) parameter will get the 'rest' of the parameter list. This works for lambdas, nlambdas and macros. As a result, the 'lexpr' form has been removed as it is equivalent to a lambda with a varargs formal. Signed-off-by: Keith Packard --- src/lisp/ao_lisp.h | 2 - src/lisp/ao_lisp_builtin.c | 2 - src/lisp/ao_lisp_builtin.txt | 33 ++++++------ src/lisp/ao_lisp_const.lisp | 90 +++++++++++++++++---------------- src/lisp/ao_lisp_eval.c | 14 +++--- src/lisp/ao_lisp_lambda.c | 114 +++++++++++++++++++++++------------------- src/lisp/ao_lisp_make_builtin | 2 - src/lisp/ao_lisp_make_const.c | 8 +-- 8 files changed, 140 insertions(+), 125 deletions(-) (limited to 'src') diff --git a/src/lisp/ao_lisp.h b/src/lisp/ao_lisp.h index d32e7dcd..b5e03b1e 100644 --- a/src/lisp/ao_lisp.h +++ b/src/lisp/ao_lisp.h @@ -297,7 +297,6 @@ 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 @@ -305,7 +304,6 @@ extern ao_poly ao_lisp_v; #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; diff --git a/src/lisp/ao_lisp_builtin.c b/src/lisp/ao_lisp_builtin.c index fdca0208..6af2a6ea 100644 --- a/src/lisp/ao_lisp_builtin.c +++ b/src/lisp/ao_lisp_builtin.c @@ -50,7 +50,6 @@ char *ao_lisp_args_name(uint8_t args) { args &= AO_LISP_FUNC_MASK; switch (args) { case AO_LISP_FUNC_LAMBDA: return ao_lisp_poly_atom(_ao_lisp_atom_lambda)->name; - case AO_LISP_FUNC_LEXPR: return ao_lisp_poly_atom(_ao_lisp_atom_lexpr)->name; case AO_LISP_FUNC_NLAMBDA: return ao_lisp_poly_atom(_ao_lisp_atom_nlambda)->name; case AO_LISP_FUNC_MACRO: return ao_lisp_poly_atom(_ao_lisp_atom_macro)->name; default: return "???"; @@ -70,7 +69,6 @@ ao_lisp_builtin_name(enum ao_lisp_builtin_id b) { 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, }; diff --git a/src/lisp/ao_lisp_builtin.txt b/src/lisp/ao_lisp_builtin.txt index abed7afe..cb65e252 100644 --- a/src/lisp/ao_lisp_builtin.txt +++ b/src/lisp/ao_lisp_builtin.txt @@ -1,7 +1,6 @@ f_lambda eval f_lambda read nlambda lambda -nlambda lexpr nlambda nlambda nlambda macro f_lambda car @@ -19,25 +18,25 @@ f_lambda def nlambda cond nlambda begin nlambda while -f_lexpr write -f_lexpr display -f_lexpr plus + -f_lexpr minus - -f_lexpr times * -f_lexpr divide / -f_lexpr modulo modulo % -f_lexpr remainder -f_lexpr quotient -f_lexpr equal = eq? eqv? -f_lexpr less < -f_lexpr greater > -f_lexpr less_equal <= -f_lexpr greater_equal >= +f_lambda write +f_lambda display +f_lambda plus + +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 < +f_lambda greater > +f_lambda less_equal <= +f_lambda greater_equal >= f_lambda list_to_string list->string f_lambda string_to_list string->list f_lambda flush_output flush-output f_lambda delay -f_lexpr led +f_lambda led f_lambda save f_lambda restore f_lambda call_cc call-with-current-continuation call/cc @@ -56,7 +55,7 @@ f_lambda symbol_to_string symbol->string f_lambda string_to_symbol string->symbol f_lambda stringp string? f_lambda procedurep procedure? -lexpr apply +lambda apply f_lambda read_char read-char f_lambda write_char write-char f_lambda exit diff --git a/src/lisp/ao_lisp_const.lisp b/src/lisp/ao_lisp_const.lisp index bb413e7d..422bdd63 100644 --- a/src/lisp/ao_lisp_const.lisp +++ b/src/lisp/ao_lisp_const.lisp @@ -14,10 +14,10 @@ ; Lisp code placed in ROM ; return a list containing all of the arguments -(def (quote list) (lexpr (l) l)) +(def (quote list) (lambda l l)) (def (quote def!) - (macro (name value rest) + (macro (name value) (list def (list quote name) @@ -27,7 +27,7 @@ (begin (def! append - (lexpr (args) + (lambda args (def! append-list (lambda (a b) (cond ((null? a) b) @@ -55,7 +55,7 @@ (begin (def! or - (macro (l) + (macro l (def! _or (lambda (l) (cond ((null? l) #f) @@ -84,7 +84,7 @@ (begin (def! and - (macro (l) + (macro l (def! _and (lambda (l) (cond ((null? l) #t) @@ -102,7 +102,9 @@ ) ) ) - (_and l))) + (_and l) + ) + ) 'and) ; execute to resolve macros @@ -111,7 +113,7 @@ (begin (def! quasiquote - (macro (x rest) + (macro (x) (def! constant? ; A constant value is either a pair starting with quote, ; or anything which is neither a pair nor a symbol @@ -225,10 +227,12 @@ ) ) ) - (expand-quasiquote x 0) + (def! result (expand-quasiquote x 0)) + result ) ) 'quasiquote) + ; ; Define a variable without returning the value ; Useful when defining functions to avoid @@ -241,7 +245,7 @@ (begin (def! define - (macro (first rest) + (macro (first . rest) ; check for alternate lambda definition form (cond ((list? first) @@ -257,9 +261,11 @@ (set! rest (car rest)) ) ) - `(begin - (def (quote ,first) ,rest) - (quote ,first)) + (def! result `(,begin + (,def (,quote ,first) ,rest) + (,quote ,first)) + ) + result ) ) 'define @@ -275,22 +281,11 @@ (define (caddr l) (car (cdr (cdr l)))) -(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)) - ) - ; (if ) ; (if ,value 0))) +(define positive? (macro (value) `(> ,value 0))) (positive? 12) (positive? -12) -(define negative? (macro (value rest) `(< ,value 0))) +(define negative? (macro (value) `(< ,value 0))) (negative? 12) (negative? -12) @@ -330,7 +325,7 @@ (abs 12) (abs -12) -(define max (lexpr (first rest) +(define max (lambda (first . rest) (while (not (null? rest)) (cond ((< first (car rest)) (set! first (car rest))) @@ -343,7 +338,7 @@ (max 1 2 3) (max 3 2 1) -(define min (lexpr (first rest) +(define min (lambda (first . rest) (while (not (null? rest)) (cond ((> first (car rest)) (set! first (car rest))) @@ -371,6 +366,17 @@ (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 @@ -391,7 +397,7 @@ ; (let ((x 1) (y)) (set! y (+ x 1)) y) (define let - (macro (vars exprs) + (macro (vars . exprs) (define (make-names vars) (cond ((not (null? vars)) (cons (car (car vars)) @@ -445,7 +451,7 @@ ; (let* ((x 1) (y)) (set! y (+ x 1)) y) (define let* - (macro (vars exprs) + (macro (vars . exprs) ; ; make the list of names in the let @@ -497,11 +503,11 @@ (let* ((x 1) (y x)) (+ x y)) -(define when (macro (test l) `(cond (,test ,@l)))) +(define when (macro (test . l) `(cond (,test ,@l)))) (when #t (write 'when)) -(define unless (macro (test l) `(cond ((not ,test) ,@l)))) +(define unless (macro (test . l) `(cond ((not ,test) ,@l)))) (unless #f (write 'unless)) @@ -542,7 +548,7 @@ (equal? '(a b c) '(a b c)) (equal? '(a b c) '(a b b)) -(define member (lexpr (obj list test?) +(define member (lambda (obj list . test?) (cond ((null? list) #f ) @@ -651,13 +657,13 @@ (char-downcase #\0) (char-downcase #\space) -(define string (lexpr (chars) (list->string chars))) +(define string (lambda chars (list->string chars))) (display "apply\n") (apply cons '(a b)) (define map - (lexpr (proc lists) + (lambda (proc . lists) (define (args lists) (cond ((null? lists) ()) (else @@ -685,7 +691,7 @@ (map cadr '((a b) (d e) (g h))) -(define for-each (lexpr (proc lists) +(define for-each (lambda (proc . lists) (apply map proc lists) #t)) @@ -697,12 +703,12 @@ ) ) -(define string-map (lexpr (proc 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 (lexpr (proc strings) +(define string-for-each (lambda (proc . strings) (apply for-each proc (_string-ml strings)))) (string-for-each write-char "IBM\n") @@ -732,7 +738,7 @@ (define repeat - (macro (count rest) + (macro (count . rest) (define counter '__count__) (cond ((pair? count) (set! counter (car count)) @@ -754,7 +760,7 @@ (repeat (x 3) (write 'goodbye x)) (define case - (macro (test l) + (macro (test . l) ; construct the body of the ; case, dealing with the ; lambda version ( => lambda) @@ -800,7 +806,7 @@ (case 12 (1 "one") (2 "two") (3 => (lambda (x) (write "the value is" x))) (12 "twelve") (else "else")) -;(define number->string (lexpr (arg opt) +;(define number->string (lambda (arg . opt) ; (let ((base (if (null? opt) 10 (car opt))) ; ; diff --git a/src/lisp/ao_lisp_eval.c b/src/lisp/ao_lisp_eval.c index ced182f6..c3dd2ed2 100644 --- a/src/lisp/ao_lisp_eval.c +++ b/src/lisp/ao_lisp_eval.c @@ -152,9 +152,9 @@ ao_lisp_eval_val(void) * 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. + * lamda, macro or nlambda. * - * For lambda/lexpr, go compute another formal. This will terminate + * 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 @@ -177,8 +177,7 @@ ao_lisp_eval_formal(void) 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"); + DBGI(".. lambda\n"); break; case AO_LISP_FUNC_MACRO: /* Evaluate the result once more */ @@ -272,8 +271,11 @@ ao_lisp_eval_exec(void) DBGI("set "); DBG_POLY(atom); DBG(" = "); DBG_POLY(val); DBG("\n"); }); builtin = ao_lisp_poly_builtin(ao_lisp_v); - if (builtin && builtin->args & AO_LISP_FUNC_FREE_ARGS && !ao_lisp_stack_marked(ao_lisp_stack) && !ao_lisp_skip_cons_free) - ao_lisp_cons_free(ao_lisp_poly_cons(ao_lisp_stack->values)); + if (builtin && (builtin->args & AO_LISP_FUNC_FREE_ARGS) && !ao_lisp_stack_marked(ao_lisp_stack) && !ao_lisp_skip_cons_free) { + struct ao_lisp_cons *cons = ao_lisp_poly_cons(ao_lisp_stack->values); + ao_lisp_stack->values = AO_LISP_NIL; + ao_lisp_cons_free(cons); + } ao_lisp_v = v; ao_lisp_stack->values = AO_LISP_NIL; diff --git a/src/lisp/ao_lisp_lambda.c b/src/lisp/ao_lisp_lambda.c index 71aebed0..e72281db 100644 --- a/src/lisp/ao_lisp_lambda.c +++ b/src/lisp/ao_lisp_lambda.c @@ -68,26 +68,33 @@ ao_lisp_lambda_write(ao_poly poly) ao_poly ao_lisp_lambda_alloc(struct ao_lisp_cons *code, int args) { + struct ao_lisp_lambda *lambda; + ao_poly formal; + struct ao_lisp_cons *cons; + + formal = ao_lisp_arg(code, 0); + while (formal != AO_LISP_NIL) { + switch (ao_lisp_poly_type(formal)) { + case AO_LISP_CONS: + cons = ao_lisp_poly_cons(formal); + if (ao_lisp_poly_type(cons->car) != AO_LISP_ATOM) + return ao_lisp_error(AO_LISP_INVALID, "formal %p is not atom", cons->car); + formal = cons->cdr; + break; + case AO_LISP_ATOM: + formal = AO_LISP_NIL; + break; + default: + return ao_lisp_error(AO_LISP_INVALID, "formal %p is not atom", formal); + } + } + ao_lisp_cons_stash(0, code); - struct ao_lisp_lambda *lambda = ao_lisp_alloc(sizeof (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); @@ -103,12 +110,6 @@ ao_lisp_do_lambda(struct ao_lisp_cons *cons) return ao_lisp_lambda_alloc(cons, AO_LISP_FUNC_LAMBDA); } -ao_poly -ao_lisp_do_lexpr(struct ao_lisp_cons *cons) -{ - return ao_lisp_lambda_alloc(cons, AO_LISP_FUNC_LEXPR); -} - ao_poly ao_lisp_do_nlambda(struct ao_lisp_cons *cons) { @@ -127,67 +128,78 @@ 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)); + ao_poly formals; struct ao_lisp_frame *next_frame; int args_wanted; + ao_poly varargs = AO_LISP_NIL; 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); + args_wanted = 0; + for (formals = ao_lisp_arg(code, 0); + ao_lisp_is_pair(formals); + formals = ao_lisp_poly_cons(formals)->cdr) + ++args_wanted; + if (formals != AO_LISP_NIL) { + if (ao_lisp_poly_type(formals) != AO_LISP_ATOM) + return ao_lisp_error(AO_LISP_INVALID, "bad lambda form"); + varargs = formals; + } /* Create a frame to hold the variables */ args_provided = ao_lisp_cons_length(cons) - 1; - if (lambda->args == AO_LISP_FUNC_LAMBDA) { + if (varargs == AO_LISP_NIL) { 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) + if (args_provided < args_wanted) 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); + ao_lisp_poly_stash(1, varargs); + next_frame = ao_lisp_frame_new(args_wanted + (varargs != AO_LISP_NIL)); + varargs = ao_lisp_poly_fetch(1); + if (!next_frame) + return AO_LISP_NIL; /* 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)); + formals = 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)) + for (f = 0; f < args_wanted; f++) { + struct ao_lisp_cons *arg = ao_lisp_poly_cons(formals); + DBGI("bind "); DBG_POLY(arg->car); DBG(" = "); DBG_POLY(vals->car); DBG("\n"); + ao_lisp_frame_bind(next_frame, f, arg->car, vals->car); + formals = arg->cdr; + vals = ao_lisp_poly_cons(vals->cdr); + } + if (varargs) { + DBGI("bind "); DBG_POLY(varargs); DBG(" = "); DBG_POLY(ao_lisp_cons_poly(vals)); DBG("\n"); + /* + * Bind the rest of the arguments to the final parameter + */ + ao_lisp_frame_bind(next_frame, f, varargs, ao_lisp_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_LISP_FUNC_LAMBDA && !ao_lisp_stack_marked(ao_lisp_stack)) { + ao_lisp_stack->values = AO_LISP_NIL; 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(); diff --git a/src/lisp/ao_lisp_make_builtin b/src/lisp/ao_lisp_make_builtin index c4ba9d94..783ab378 100644 --- a/src/lisp/ao_lisp_make_builtin +++ b/src/lisp/ao_lisp_make_builtin @@ -9,10 +9,8 @@ typedef struct { string[string] type_map = { "lambda" => "LAMBDA", "nlambda" => "NLAMBDA", - "lexpr" => "LEXPR", "macro" => "MACRO", "f_lambda" => "F_LAMBDA", - "f_lexpr" => "F_LEXPR", "atom" => "atom", }; diff --git a/src/lisp/ao_lisp_make_const.c b/src/lisp/ao_lisp_make_const.c index f3ea6be0..6e4b411e 100644 --- a/src/lisp/ao_lisp_make_const.c +++ b/src/lisp/ao_lisp_make_const.c @@ -191,6 +191,7 @@ ao_has_macro(ao_poly p) struct ao_lisp_cons *cons; struct ao_lisp_lambda *lambda; ao_poly m; + ao_poly list; if (p == AO_LISP_NIL) return AO_LISP_NIL; @@ -206,15 +207,16 @@ ao_has_macro(ao_poly p) if ((p = ao_is_macro(cons->car))) break; - cons = ao_lisp_poly_cons(cons->cdr); + list = cons->cdr; p = AO_LISP_NIL; - while (cons) { + while (list != AO_LISP_NIL && ao_lisp_poly_type(list) == AO_LISP_CONS) { + cons = ao_lisp_poly_cons(list); m = ao_has_macro(cons->car); if (m) { p = m; break; } - cons = ao_lisp_poly_cons(cons->cdr); + list = cons->cdr; } break; -- cgit v1.2.3 From 195cbeec19a6a44f309a9040d727d37fe4e2ec97 Mon Sep 17 00:00:00 2001 From: Keith Packard Date: Tue, 5 Dec 2017 10:29:13 -0800 Subject: altos/scheme: Rename to 'scheme', clean up build Constant block is now built in a subdir to avoid messing up source directory. Renamed to ao_scheme to reflect language target. Signed-off-by: Keith Packard --- src/lisp/.gitignore | 3 - src/lisp/Makefile | 24 - src/lisp/Makefile-inc | 24 - src/lisp/Makefile-lisp | 4 - src/lisp/README | 11 - src/lisp/ao_lisp.h | 928 --------------------------------- src/lisp/ao_lisp_atom.c | 159 ------ src/lisp/ao_lisp_bool.c | 73 --- src/lisp/ao_lisp_builtin.c | 868 ------------------------------- src/lisp/ao_lisp_builtin.txt | 68 --- src/lisp/ao_lisp_cons.c | 184 ------- src/lisp/ao_lisp_const.lisp | 813 ----------------------------- src/lisp/ao_lisp_error.c | 139 ----- src/lisp/ao_lisp_eval.c | 578 --------------------- src/lisp/ao_lisp_float.c | 148 ------ src/lisp/ao_lisp_frame.c | 330 ------------ src/lisp/ao_lisp_int.c | 79 --- src/lisp/ao_lisp_lambda.c | 208 -------- src/lisp/ao_lisp_lex.c | 16 - src/lisp/ao_lisp_make_builtin | 190 ------- src/lisp/ao_lisp_make_const.c | 395 -------------- src/lisp/ao_lisp_mem.c | 968 ----------------------------------- src/lisp/ao_lisp_os.h | 63 --- src/lisp/ao_lisp_poly.c | 118 ----- src/lisp/ao_lisp_read.c | 655 ------------------------ src/lisp/ao_lisp_read.h | 58 --- src/lisp/ao_lisp_rep.c | 36 -- src/lisp/ao_lisp_save.c | 77 --- src/lisp/ao_lisp_stack.c | 280 ---------- src/lisp/ao_lisp_string.c | 161 ------ src/scheme/.gitignore | 2 + src/scheme/Makefile | 16 + src/scheme/Makefile-inc | 24 + src/scheme/Makefile-scheme | 4 + src/scheme/README | 10 + src/scheme/ao_scheme.h | 928 +++++++++++++++++++++++++++++++++ src/scheme/ao_scheme_atom.c | 167 ++++++ src/scheme/ao_scheme_bool.c | 73 +++ src/scheme/ao_scheme_builtin.c | 868 +++++++++++++++++++++++++++++++ src/scheme/ao_scheme_builtin.txt | 68 +++ src/scheme/ao_scheme_cons.c | 201 ++++++++ src/scheme/ao_scheme_const.lisp | 813 +++++++++++++++++++++++++++++ src/scheme/ao_scheme_error.c | 139 +++++ src/scheme/ao_scheme_eval.c | 578 +++++++++++++++++++++ src/scheme/ao_scheme_float.c | 148 ++++++ src/scheme/ao_scheme_frame.c | 330 ++++++++++++ src/scheme/ao_scheme_int.c | 79 +++ src/scheme/ao_scheme_lambda.c | 208 ++++++++ src/scheme/ao_scheme_lex.c | 16 + src/scheme/ao_scheme_make_builtin | 190 +++++++ src/scheme/ao_scheme_make_const.c | 395 ++++++++++++++ src/scheme/ao_scheme_mem.c | 968 +++++++++++++++++++++++++++++++++++ src/scheme/ao_scheme_poly.c | 118 +++++ src/scheme/ao_scheme_read.c | 655 ++++++++++++++++++++++++ src/scheme/ao_scheme_read.h | 58 +++ src/scheme/ao_scheme_rep.c | 36 ++ src/scheme/ao_scheme_save.c | 77 +++ src/scheme/ao_scheme_stack.c | 280 ++++++++++ src/scheme/ao_scheme_string.c | 161 ++++++ src/scheme/make-const/.gitignore | 1 + src/scheme/make-const/Makefile | 26 + src/scheme/make-const/ao_scheme_os.h | 63 +++ src/test/ao_lisp_os.h | 68 --- src/test/ao_lisp_test.c | 134 ----- src/test/ao_scheme_os.h | 68 +++ src/test/ao_scheme_test.c | 134 +++++ 66 files changed, 7902 insertions(+), 7860 deletions(-) delete mode 100644 src/lisp/.gitignore delete mode 100644 src/lisp/Makefile delete mode 100644 src/lisp/Makefile-inc delete mode 100644 src/lisp/Makefile-lisp delete mode 100644 src/lisp/README delete mode 100644 src/lisp/ao_lisp.h delete mode 100644 src/lisp/ao_lisp_atom.c delete mode 100644 src/lisp/ao_lisp_bool.c delete mode 100644 src/lisp/ao_lisp_builtin.c delete mode 100644 src/lisp/ao_lisp_builtin.txt delete mode 100644 src/lisp/ao_lisp_cons.c delete mode 100644 src/lisp/ao_lisp_const.lisp delete mode 100644 src/lisp/ao_lisp_error.c delete mode 100644 src/lisp/ao_lisp_eval.c delete mode 100644 src/lisp/ao_lisp_float.c delete mode 100644 src/lisp/ao_lisp_frame.c delete mode 100644 src/lisp/ao_lisp_int.c delete mode 100644 src/lisp/ao_lisp_lambda.c delete mode 100644 src/lisp/ao_lisp_lex.c delete mode 100644 src/lisp/ao_lisp_make_builtin delete mode 100644 src/lisp/ao_lisp_make_const.c delete mode 100644 src/lisp/ao_lisp_mem.c delete mode 100644 src/lisp/ao_lisp_os.h delete mode 100644 src/lisp/ao_lisp_poly.c delete mode 100644 src/lisp/ao_lisp_read.c delete mode 100644 src/lisp/ao_lisp_read.h delete mode 100644 src/lisp/ao_lisp_rep.c delete mode 100644 src/lisp/ao_lisp_save.c delete mode 100644 src/lisp/ao_lisp_stack.c delete mode 100644 src/lisp/ao_lisp_string.c create mode 100644 src/scheme/.gitignore create mode 100644 src/scheme/Makefile create mode 100644 src/scheme/Makefile-inc create mode 100644 src/scheme/Makefile-scheme create mode 100644 src/scheme/README create mode 100644 src/scheme/ao_scheme.h create mode 100644 src/scheme/ao_scheme_atom.c create mode 100644 src/scheme/ao_scheme_bool.c create mode 100644 src/scheme/ao_scheme_builtin.c create mode 100644 src/scheme/ao_scheme_builtin.txt create mode 100644 src/scheme/ao_scheme_cons.c create mode 100644 src/scheme/ao_scheme_const.lisp create mode 100644 src/scheme/ao_scheme_error.c create mode 100644 src/scheme/ao_scheme_eval.c create mode 100644 src/scheme/ao_scheme_float.c create mode 100644 src/scheme/ao_scheme_frame.c create mode 100644 src/scheme/ao_scheme_int.c create mode 100644 src/scheme/ao_scheme_lambda.c create mode 100644 src/scheme/ao_scheme_lex.c create mode 100644 src/scheme/ao_scheme_make_builtin create mode 100644 src/scheme/ao_scheme_make_const.c create mode 100644 src/scheme/ao_scheme_mem.c create mode 100644 src/scheme/ao_scheme_poly.c create mode 100644 src/scheme/ao_scheme_read.c create mode 100644 src/scheme/ao_scheme_read.h create mode 100644 src/scheme/ao_scheme_rep.c create mode 100644 src/scheme/ao_scheme_save.c create mode 100644 src/scheme/ao_scheme_stack.c create mode 100644 src/scheme/ao_scheme_string.c create mode 100644 src/scheme/make-const/.gitignore create mode 100644 src/scheme/make-const/Makefile create mode 100644 src/scheme/make-const/ao_scheme_os.h delete mode 100644 src/test/ao_lisp_os.h delete mode 100644 src/test/ao_lisp_test.c create mode 100644 src/test/ao_scheme_os.h create mode 100644 src/test/ao_scheme_test.c (limited to 'src') diff --git a/src/lisp/.gitignore b/src/lisp/.gitignore deleted file mode 100644 index 1faa9b67..00000000 --- a/src/lisp/.gitignore +++ /dev/null @@ -1,3 +0,0 @@ -ao_lisp_make_const -ao_lisp_const.h -ao_lisp_builtin.h diff --git a/src/lisp/Makefile b/src/lisp/Makefile deleted file mode 100644 index 05f54550..00000000 --- a/src/lisp/Makefile +++ /dev/null @@ -1,24 +0,0 @@ -all: ao_lisp_builtin.h ao_lisp_const.h - -clean: - rm -f ao_lisp_const.h ao_lisp_builtin.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 - -ao_lisp_builtin.h: ao_lisp_make_builtin ao_lisp_builtin.txt - nickle ./ao_lisp_make_builtin ao_lisp_builtin.txt > $@ - -include Makefile-inc -SRCS=$(LISP_SRCS) ao_lisp_make_const.c - -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) -lm - -$(OBJS): $(HDRS) diff --git a/src/lisp/Makefile-inc b/src/lisp/Makefile-inc deleted file mode 100644 index a097f1be..00000000 --- a/src/lisp/Makefile-inc +++ /dev/null @@ -1,24 +0,0 @@ -LISP_SRCS=\ - 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_bool.c \ - ao_lisp_float.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 \ - ao_lisp_builtin.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/README b/src/lisp/README deleted file mode 100644 index c1e84475..00000000 --- a/src/lisp/README +++ /dev/null @@ -1,11 +0,0 @@ -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; we have macros instead -* define inside of lambda does not add name to lambda scope -* No record types -* No libraries diff --git a/src/lisp/ao_lisp.h b/src/lisp/ao_lisp.h deleted file mode 100644 index b5e03b1e..00000000 --- a/src/lisp/ao_lisp.h +++ /dev/null @@ -1,928 +0,0 @@ -/* - * Copyright © 2016 Keith Packard - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation, either version 2 of the License, or - * (at your option) any later version. - * - * This program is distributed in the hope that it will be useful, but - * WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU - * General Public License for more details. - */ - -#ifndef _AO_LISP_H_ -#define _AO_LISP_H_ - -#define DBG_MEM 0 -#define DBG_EVAL 0 -#define DBG_READ 0 -#define DBG_FREE_CONS 0 -#define NDEBUG 1 - -#include -#include -#include -#ifndef __BYTE_ORDER -#include -#endif - -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 _bool(v) ao_lisp_bool_poly(ao_lisp_bool_get(v)) - -#define _ao_lisp_bool_true _bool(1) -#define _ao_lisp_bool_false _bool(0) - -#define _ao_lisp_atom_eof _atom("eof") -#define _ao_lisp_atom_else _atom("else") - -#define AO_LISP_BUILTIN_ATOMS -#include "ao_lisp_builtin.h" - -#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_FRAME_VALS 7 -#define AO_LISP_LAMBDA 8 -#define AO_LISP_STACK 9 -#define AO_LISP_BOOL 10 -#define AO_LISP_BIGINT 11 -#define AO_LISP_FLOAT 12 -#define AO_LISP_NUM_TYPE 13 - -/* 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_REDEFINED 0x10 -#define AO_LISP_EOF 0x20 -#define AO_LISP_EXIT 0x40 - -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_poly_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_vals { - uint8_t type; - uint8_t size; - struct ao_lisp_val vals[]; -}; - -struct ao_lisp_frame { - uint8_t type; - uint8_t num; - ao_poly prev; - ao_poly vals; -}; - -struct ao_lisp_bool { - uint8_t type; - uint8_t value; - uint16_t pad; -}; - -struct ao_lisp_bigint { - uint32_t value; -}; - -struct ao_lisp_float { - uint8_t type; - uint8_t pad1; - uint16_t pad2; - float value; -}; - -#if __BYTE_ORDER == __LITTLE_ENDIAN -static inline uint32_t -ao_lisp_int_bigint(int32_t i) { - return AO_LISP_BIGINT | (i << 8); -} -static inline int32_t -ao_lisp_bigint_int(uint32_t bi) { - return (int32_t) bi >> 8; -} -#else -static inline uint32_t -ao_lisp_int_bigint(int32_t i) { - return (uint32_t) (i & 0xffffff) | (AO_LISP_BIGINT << 24); -} -static inlint int32_t -ao_lisp_bigint_int(uint32_t bi) { - return (int32_t) (bi << 8) >> 8; -} -#endif - -#define AO_LISP_MIN_INT (-(1 << (15 - AO_LISP_TYPE_SHIFT))) -#define AO_LISP_MAX_INT ((1 << (15 - AO_LISP_TYPE_SHIFT)) - 1) -#define AO_LISP_MIN_BIGINT (-(1 << 24)) -#define AO_LISP_MAX_BIGINT ((1 << 24) - 1) - -#define AO_LISP_NOT_INTEGER 0x7fffffff - -/* 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); -} - -static inline struct ao_lisp_frame_vals * -ao_lisp_poly_frame_vals(ao_poly poly) { - return ao_lisp_ref(poly); -} - -static inline ao_poly -ao_lisp_frame_vals_poly(struct ao_lisp_frame_vals *vals) { - return ao_lisp_poly(vals, 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_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_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_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) - -struct ao_lisp_builtin { - uint8_t type; - uint8_t args; - uint16_t func; -}; - -#define AO_LISP_BUILTIN_ID -#include "ao_lisp_builtin.h" - -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 int -ao_lisp_is_cons(ao_poly poly) { - return (ao_lisp_poly_base_type(poly) == AO_LISP_CONS); -} - -static inline int -ao_lisp_is_pair(ao_poly poly) { - return poly != AO_LISP_NIL && (ao_lisp_poly_base_type(poly) == AO_LISP_CONS); -} - -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 int32_t -ao_lisp_poly_int(ao_poly poly) -{ - return (int32_t) ((ao_signed_poly) poly >> AO_LISP_TYPE_SHIFT); -} - -static inline ao_poly -ao_lisp_int_poly(int32_t i) -{ - return ((ao_poly) i << 2) | AO_LISP_INT; -} - -static inline struct ao_lisp_bigint * -ao_lisp_poly_bigint(ao_poly poly) -{ - return ao_lisp_ref(poly); -} - -static inline ao_poly -ao_lisp_bigint_poly(struct ao_lisp_bigint *bi) -{ - return ao_lisp_poly(bi, AO_LISP_OTHER); -} - -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); -} - -static inline ao_poly -ao_lisp_bool_poly(struct ao_lisp_bool *b) -{ - return ao_lisp_poly(b, AO_LISP_OTHER); -} - -static inline struct ao_lisp_bool * -ao_lisp_poly_bool(ao_poly poly) -{ - return ao_lisp_ref(poly); -} - -static inline ao_poly -ao_lisp_float_poly(struct ao_lisp_float *f) -{ - return ao_lisp_poly(f, AO_LISP_OTHER); -} - -static inline struct ao_lisp_float * -ao_lisp_poly_float(ao_poly poly) -{ - return ao_lisp_ref(poly); -} - -float -ao_lisp_poly_number(ao_poly p); - -/* memory functions */ - -extern int ao_lisp_collects[2]; -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); - -#if DBG_FREE_CONS -void -ao_lisp_cons_check(struct ao_lisp_cons *cons); -#endif - -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)); -} - -void -ao_lisp_frame_stash(int id, struct ao_lisp_frame *frame); - -struct ao_lisp_frame * -ao_lisp_frame_fetch(int id); - -/* bool */ - -extern const struct ao_lisp_type ao_lisp_bool_type; - -void -ao_lisp_bool_write(ao_poly v); - -#ifdef AO_LISP_MAKE_CONST -struct ao_lisp_bool *ao_lisp_true, *ao_lisp_false; - -struct ao_lisp_bool * -ao_lisp_bool_get(uint8_t value); -#endif - -/* cons */ -extern const struct ao_lisp_type ao_lisp_cons_type; - -struct ao_lisp_cons * -ao_lisp_cons_cons(ao_poly car, ao_poly cdr); - -/* Return a cons or NULL for a proper list, else error */ -struct ao_lisp_cons * -ao_lisp_cons_cdr(struct ao_lisp_cons *cons); - -ao_poly -ao_lisp__cons(ao_poly car, ao_poly cdr); - -extern struct ao_lisp_cons *ao_lisp_cons_free_list; - -void -ao_lisp_cons_free(struct ao_lisp_cons *cons); - -void -ao_lisp_cons_write(ao_poly); - -void -ao_lisp_cons_display(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_write(ao_poly s); - -void -ao_lisp_string_display(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_write(ao_poly a); - -struct ao_lisp_atom * -ao_lisp_atom_intern(char *name); - -ao_poly * -ao_lisp_atom_ref(ao_poly atom); - -ao_poly -ao_lisp_atom_get(ao_poly atom); - -ao_poly -ao_lisp_atom_set(ao_poly atom, ao_poly val); - -ao_poly -ao_lisp_atom_def(ao_poly atom, ao_poly val); - -/* int */ -void -ao_lisp_int_write(ao_poly i); - -int32_t -ao_lisp_poly_integer(ao_poly p); - -ao_poly -ao_lisp_integer_poly(int32_t i); - -static inline int -ao_lisp_integer_typep(uint8_t t) -{ - return (t == AO_LISP_INT) || (t == AO_LISP_BIGINT); -} - -void -ao_lisp_bigint_write(ao_poly i); - -extern const struct ao_lisp_type ao_lisp_bigint_type; -/* prim */ -void -ao_lisp_poly_write(ao_poly p); - -void -ao_lisp_poly_display(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); - -/* float */ -extern const struct ao_lisp_type ao_lisp_float_type; - -void -ao_lisp_float_write(ao_poly p); - -ao_poly -ao_lisp_float_get(float value); - -static inline uint8_t -ao_lisp_number_typep(uint8_t t) -{ - return ao_lisp_integer_typep(t) || (t == AO_LISP_FLOAT); -} - -float -ao_lisp_poly_number(ao_poly p); - -/* builtin */ -void -ao_lisp_builtin_write(ao_poly b); - -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; -extern const struct ao_lisp_type ao_lisp_frame_vals_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); - -ao_poly -ao_lisp_frame_add(struct ao_lisp_frame *frame, ao_poly atom, ao_poly val); - -void -ao_lisp_frame_write(ao_poly p); - -void -ao_lisp_frame_init(void); - -/* 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_write(ao_poly lambda); - -ao_poly -ao_lisp_lambda_eval(void); - -/* 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_write(ao_poly stack); - -ao_poly -ao_lisp_stack_eval(void); - -/* error */ - -void -ao_lisp_vprintf(char *format, va_list args); - -void -ao_lisp_printf(char *format, ...); - -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, ...); - -/* builtins */ - -#define AO_LISP_BUILTIN_DECLS -#include "ao_lisp_builtin.h" - -/* debugging macros */ - -#if DBG_EVAL || DBG_READ || DBG_MEM -#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(...) ao_lisp_printf(__VA_ARGS__) -#define DBGI(...) do { printf("%4d: ", __LINE__); DBG_INDENT(); DBG(__VA_ARGS__); } while (0) -#define DBG_CONS(a) ao_lisp_cons_write(ao_lisp_cons_poly(a)) -#define DBG_POLY(a) ao_lisp_poly_write(a) -#define OFFSET(a) ((a) ? (int) ((uint8_t *) a - ao_lisp_pool) : -1) -#define DBG_STACK() ao_lisp_stack_write(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 - -#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 -extern int dbg_move_depth; -#define MDBG_DUMP 1 -#define MDBG_OFFSET(a) ((a) ? (int) ((uint8_t *) (a) - ao_lisp_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_LISP_H_ */ diff --git a/src/lisp/ao_lisp_atom.c b/src/lisp/ao_lisp_atom.c deleted file mode 100644 index a633c223..00000000 --- a/src/lisp/ao_lisp_atom.c +++ /dev/null @@ -1,159 +0,0 @@ -/* - * Copyright © 2016 Keith Packard - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation; 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; -} - -ao_poly * -ao_lisp_atom_ref(ao_poly atom) -{ - ao_poly *ref; - struct ao_lisp_frame *frame; - - for (frame = ao_lisp_frame_current; frame; frame = ao_lisp_poly_frame(frame->prev)) { - ref = ao_lisp_frame_ref(frame, atom); - if (ref) - return ref; - } - return ao_lisp_frame_ref(ao_lisp_frame_global, atom); -} - -ao_poly -ao_lisp_atom_get(ao_poly atom) -{ - ao_poly *ref = ao_lisp_atom_ref(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(atom); - - if (!ref) - return ao_lisp_error(AO_LISP_UNDEFINED, "undefined atom %s", ao_lisp_poly_atom(atom)->name); - *ref = val; - return val; -} - -ao_poly -ao_lisp_atom_def(ao_poly atom, ao_poly val) -{ - ao_poly *ref = ao_lisp_atom_ref(atom); - - if (ref) { - if (ao_lisp_frame_current) - return ao_lisp_error(AO_LISP_REDEFINED, "attempt to redefine atom %s", ao_lisp_poly_atom(atom)->name); - *ref = val; - return val; - } - return ao_lisp_frame_add(ao_lisp_frame_current ? ao_lisp_frame_current : ao_lisp_frame_global, atom, val); -} - -void -ao_lisp_atom_write(ao_poly a) -{ - struct ao_lisp_atom *atom = ao_lisp_poly_atom(a); - printf("%s", atom->name); -} diff --git a/src/lisp/ao_lisp_bool.c b/src/lisp/ao_lisp_bool.c deleted file mode 100644 index 391a7f78..00000000 --- a/src/lisp/ao_lisp_bool.c +++ /dev/null @@ -1,73 +0,0 @@ -/* - * Copyright © 2017 Keith Packard - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation, either version 2 of the License, or - * (at your option) any later version. - * - * This program is distributed in the hope that it will be useful, but - * WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU - * General Public License for more details. - */ - -#include "ao_lisp.h" - -static void bool_mark(void *addr) -{ - (void) addr; -} - -static int bool_size(void *addr) -{ - (void) addr; - return sizeof (struct ao_lisp_bool); -} - -static void bool_move(void *addr) -{ - (void) addr; -} - -const struct ao_lisp_type ao_lisp_bool_type = { - .mark = bool_mark, - .size = bool_size, - .move = bool_move, - .name = "bool" -}; - -void -ao_lisp_bool_write(ao_poly v) -{ - struct ao_lisp_bool *b = ao_lisp_poly_bool(v); - - if (b->value) - printf("#t"); - else - printf("#f"); -} - -#ifdef AO_LISP_MAKE_CONST - -struct ao_lisp_bool *ao_lisp_true, *ao_lisp_false; - -struct ao_lisp_bool * -ao_lisp_bool_get(uint8_t value) -{ - struct ao_lisp_bool **b; - - if (value) - b = &ao_lisp_true; - else - b = &ao_lisp_false; - - if (!*b) { - *b = ao_lisp_alloc(sizeof (struct ao_lisp_bool)); - (*b)->type = AO_LISP_BOOL; - (*b)->value = value; - } - return *b; -} - -#endif diff --git a/src/lisp/ao_lisp_builtin.c b/src/lisp/ao_lisp_builtin.c deleted file mode 100644 index 6af2a6ea..00000000 --- a/src/lisp/ao_lisp_builtin.c +++ /dev/null @@ -1,868 +0,0 @@ -/* - * Copyright © 2016 Keith Packard - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation, either version 2 of the License, or - * (at your option) any later version. - * - * This program is distributed in the hope that it will be useful, but - * WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU - * General Public License for more details. - */ - -#include "ao_lisp.h" -#include -#include - -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 - -#define AO_LISP_BUILTIN_CASENAME -#include "ao_lisp_builtin.h" - -char *ao_lisp_args_name(uint8_t args) { - args &= AO_LISP_FUNC_MASK; - switch (args) { - case AO_LISP_FUNC_LAMBDA: return ao_lisp_poly_atom(_ao_lisp_atom_lambda)->name; - case AO_LISP_FUNC_NLAMBDA: return ao_lisp_poly_atom(_ao_lisp_atom_nlambda)->name; - case AO_LISP_FUNC_MACRO: return ao_lisp_poly_atom(_ao_lisp_atom_macro)->name; - default: return "???"; - } -} -#else - -#define AO_LISP_BUILTIN_ARRAYNAME -#include "ao_lisp_builtin.h" - -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_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_write(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_cons_cdr(cons); - } - if (argc < min || argc > max) - return ao_lisp_error(AO_LISP_INVALID, "%s: invalid arg count", ao_lisp_poly_atom(name)->name); - return _ao_lisp_bool_true; -} - -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_cons_cdr(cons); - } - 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: arg %d invalid type %v", ao_lisp_poly_atom(name)->name, argc, car); - return _ao_lisp_bool_true; -} - -ao_poly -ao_lisp_do_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_do_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_do_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; - car = ao_lisp_arg(cons, 0); - cdr = ao_lisp_arg(cons, 1); - return ao_lisp__cons(car, cdr); -} - -ao_poly -ao_lisp_do_last(struct ao_lisp_cons *cons) -{ - struct ao_lisp_cons *list; - if (!ao_lisp_check_argc(_ao_lisp_atom_last, cons, 1, 1)) - return AO_LISP_NIL; - if (!ao_lisp_check_argt(_ao_lisp_atom_last, cons, 0, AO_LISP_CONS, 1)) - return AO_LISP_NIL; - for (list = ao_lisp_poly_cons(ao_lisp_arg(cons, 0)); - list; - list = ao_lisp_cons_cdr(list)) - { - if (!list->cdr) - return list->car; - } - return AO_LISP_NIL; -} - -ao_poly -ao_lisp_do_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_do_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_do_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_do_def(struct ao_lisp_cons *cons) -{ - if (!ao_lisp_check_argc(_ao_lisp_atom_def, cons, 2, 2)) - return AO_LISP_NIL; - if (!ao_lisp_check_argt(_ao_lisp_atom_def, cons, 0, AO_LISP_ATOM, 0)) - return AO_LISP_NIL; - - return ao_lisp_atom_def(ao_lisp_arg(cons, 0), ao_lisp_arg(cons, 1)); -} - -ao_poly -ao_lisp_do_setq(struct ao_lisp_cons *cons) -{ - ao_poly name; - if (!ao_lisp_check_argc(_ao_lisp_atom_set21, cons, 2, 2)) - return AO_LISP_NIL; - name = cons->car; - if (ao_lisp_poly_type(name) != AO_LISP_ATOM) - return ao_lisp_error(AO_LISP_INVALID, "set! of non-atom %v", name); - if (!ao_lisp_atom_ref(name)) - return ao_lisp_error(AO_LISP_INVALID, "atom %v not defined", name); - return ao_lisp__cons(_ao_lisp_atom_set, - ao_lisp__cons(ao_lisp__cons(_ao_lisp_atom_quote, - ao_lisp__cons(name, AO_LISP_NIL)), - cons->cdr)); -} - -ao_poly -ao_lisp_do_cond(struct ao_lisp_cons *cons) -{ - ao_lisp_set_cond(cons); - return AO_LISP_NIL; -} - -ao_poly -ao_lisp_do_begin(struct ao_lisp_cons *cons) -{ - ao_lisp_stack->state = eval_begin; - ao_lisp_stack->sexprs = ao_lisp_cons_poly(cons); - return AO_LISP_NIL; -} - -ao_poly -ao_lisp_do_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_do_write(struct ao_lisp_cons *cons) -{ - ao_poly val = AO_LISP_NIL; - while (cons) { - val = cons->car; - ao_lisp_poly_write(val); - cons = ao_lisp_cons_cdr(cons); - if (cons) - printf(" "); - } - printf("\n"); - return _ao_lisp_bool_true; -} - -ao_poly -ao_lisp_do_display(struct ao_lisp_cons *cons) -{ - ao_poly val = AO_LISP_NIL; - while (cons) { - val = cons->car; - ao_lisp_poly_display(val); - cons = ao_lisp_cons_cdr(cons); - } - return _ao_lisp_bool_true; -} - -ao_poly -ao_lisp_math(struct ao_lisp_cons *orig_cons, enum ao_lisp_builtin_id op) -{ - struct ao_lisp_cons *cons = cons; - ao_poly ret = AO_LISP_NIL; - - for (cons = orig_cons; cons; cons = ao_lisp_cons_cdr(cons)) { - ao_poly car = cons->car; - uint8_t rt = ao_lisp_poly_type(ret); - uint8_t ct = ao_lisp_poly_type(car); - - if (cons == orig_cons) { - ret = car; - if (cons->cdr == AO_LISP_NIL) { - switch (op) { - case builtin_minus: - if (ao_lisp_integer_typep(ct)) - ret = ao_lisp_integer_poly(-ao_lisp_poly_integer(ret)); - else if (ct == AO_LISP_FLOAT) - ret = ao_lisp_float_get(-ao_lisp_poly_number(ret)); - break; - case builtin_divide: - if (ao_lisp_integer_typep(ct) && ao_lisp_poly_integer(ret) == 1) - ; - else if (ao_lisp_number_typep(ct)) { - float v = ao_lisp_poly_number(ret); - ret = ao_lisp_float_get(1/v); - } - break; - default: - break; - } - } - } else if (ao_lisp_integer_typep(rt) && ao_lisp_integer_typep(ct)) { - int32_t r = ao_lisp_poly_integer(ret); - int32_t c = ao_lisp_poly_integer(car); - int64_t t; - - switch(op) { - case builtin_plus: - r += c; - check_overflow: - if (r < AO_LISP_MIN_BIGINT || AO_LISP_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_LISP_MIN_BIGINT || AO_LISP_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_lisp_error(AO_LISP_DIVIDE_BY_ZERO, "quotient by zero"); - if (r % c != 0 && (c < 0) != (r < 0)) - r = r / c - 1; - else - r = r / c; - break; - case builtin_remainder: - if (c == 0) - return ao_lisp_error(AO_LISP_DIVIDE_BY_ZERO, "remainder by zero"); - r %= c; - break; - case builtin_modulo: - if (c == 0) - return ao_lisp_error(AO_LISP_DIVIDE_BY_ZERO, "modulo by zero"); - r %= c; - if ((r < 0) != (c < 0)) - r += c; - break; - default: - break; - } - ret = ao_lisp_integer_poly(r); - } else if (ao_lisp_number_typep(rt) && ao_lisp_number_typep(ct)) { - float r, c; - inexact: - r = ao_lisp_poly_number(ret); - c = ao_lisp_poly_number(car); - switch(op) { - case builtin_plus: - r += c; - break; - case builtin_minus: - r -= c; - break; - case builtin_times: - r *= c; - break; - case builtin_divide: - r /= c; - break; - case builtin_quotient: - case builtin_remainder: - case builtin_modulo: - return ao_lisp_error(AO_LISP_INVALID, "non-integer value in integer divide"); - default: - break; - } - ret = ao_lisp_float_get(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_do_plus(struct ao_lisp_cons *cons) -{ - return ao_lisp_math(cons, builtin_plus); -} - -ao_poly -ao_lisp_do_minus(struct ao_lisp_cons *cons) -{ - return ao_lisp_math(cons, builtin_minus); -} - -ao_poly -ao_lisp_do_times(struct ao_lisp_cons *cons) -{ - return ao_lisp_math(cons, builtin_times); -} - -ao_poly -ao_lisp_do_divide(struct ao_lisp_cons *cons) -{ - return ao_lisp_math(cons, builtin_divide); -} - -ao_poly -ao_lisp_do_quotient(struct ao_lisp_cons *cons) -{ - return ao_lisp_math(cons, builtin_quotient); -} - -ao_poly -ao_lisp_do_modulo(struct ao_lisp_cons *cons) -{ - return ao_lisp_math(cons, builtin_modulo); -} - -ao_poly -ao_lisp_do_remainder(struct ao_lisp_cons *cons) -{ - return ao_lisp_math(cons, builtin_remainder); -} - -ao_poly -ao_lisp_compare(struct ao_lisp_cons *cons, enum ao_lisp_builtin_id op) -{ - ao_poly left; - - if (!cons) - return _ao_lisp_bool_true; - - left = cons->car; - for (cons = ao_lisp_cons_cdr(cons); cons; cons = ao_lisp_cons_cdr(cons)) { - ao_poly right = cons->car; - - if (op == builtin_equal) { - if (left != right) - return _ao_lisp_bool_false; - } else { - uint8_t lt = ao_lisp_poly_type(left); - uint8_t rt = ao_lisp_poly_type(right); - if (ao_lisp_integer_typep(lt) && ao_lisp_integer_typep(rt)) { - int32_t l = ao_lisp_poly_integer(left); - int32_t r = ao_lisp_poly_integer(right); - - switch (op) { - case builtin_less: - if (!(l < r)) - return _ao_lisp_bool_false; - break; - case builtin_greater: - if (!(l > r)) - return _ao_lisp_bool_false; - break; - case builtin_less_equal: - if (!(l <= r)) - return _ao_lisp_bool_false; - break; - case builtin_greater_equal: - if (!(l >= r)) - return _ao_lisp_bool_false; - 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_bool_false; - break; - case builtin_greater: - if (!(c > 0)) - return _ao_lisp_bool_false; - break; - case builtin_less_equal: - if (!(c <= 0)) - return _ao_lisp_bool_false; - break; - case builtin_greater_equal: - if (!(c >= 0)) - return _ao_lisp_bool_false; - break; - default: - break; - } - } - } - left = right; - } - return _ao_lisp_bool_true; -} - -ao_poly -ao_lisp_do_equal(struct ao_lisp_cons *cons) -{ - return ao_lisp_compare(cons, builtin_equal); -} - -ao_poly -ao_lisp_do_less(struct ao_lisp_cons *cons) -{ - return ao_lisp_compare(cons, builtin_less); -} - -ao_poly -ao_lisp_do_greater(struct ao_lisp_cons *cons) -{ - return ao_lisp_compare(cons, builtin_greater); -} - -ao_poly -ao_lisp_do_less_equal(struct ao_lisp_cons *cons) -{ - return ao_lisp_compare(cons, builtin_less_equal); -} - -ao_poly -ao_lisp_do_greater_equal(struct ao_lisp_cons *cons) -{ - return ao_lisp_compare(cons, builtin_greater_equal); -} - -ao_poly -ao_lisp_do_list_to_string(struct ao_lisp_cons *cons) -{ - if (!ao_lisp_check_argc(_ao_lisp_atom_list2d3estring, cons, 1, 1)) - return AO_LISP_NIL; - if (!ao_lisp_check_argt(_ao_lisp_atom_list2d3estring, 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_do_string_to_list(struct ao_lisp_cons *cons) -{ - if (!ao_lisp_check_argc(_ao_lisp_atom_string2d3elist, cons, 1, 1)) - return AO_LISP_NIL; - if (!ao_lisp_check_argt(_ao_lisp_atom_string2d3elist, 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_do_flush_output(struct ao_lisp_cons *cons) -{ - if (!ao_lisp_check_argc(_ao_lisp_atom_flush2doutput, cons, 0, 0)) - return AO_LISP_NIL; - ao_lisp_os_flush(); - return _ao_lisp_bool_true; -} - -ao_poly -ao_lisp_do_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_do_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_apply(struct ao_lisp_cons *cons) -{ - if (!ao_lisp_check_argc(_ao_lisp_atom_apply, cons, 2, INT_MAX)) - return AO_LISP_NIL; - ao_lisp_stack->state = eval_apply; - return ao_lisp_cons_poly(cons); -} - -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); -} - -ao_poly -ao_lisp_do_nullp(struct ao_lisp_cons *cons) -{ - if (!ao_lisp_check_argc(_ao_lisp_atom_led, cons, 1, 1)) - return AO_LISP_NIL; - if (ao_lisp_arg(cons, 0) == AO_LISP_NIL) - return _ao_lisp_bool_true; - else - return _ao_lisp_bool_false; -} - -ao_poly -ao_lisp_do_not(struct ao_lisp_cons *cons) -{ - if (!ao_lisp_check_argc(_ao_lisp_atom_led, cons, 1, 1)) - return AO_LISP_NIL; - if (ao_lisp_arg(cons, 0) == _ao_lisp_bool_false) - return _ao_lisp_bool_true; - else - return _ao_lisp_bool_false; -} - -static ao_poly -ao_lisp_do_typep(int type, struct ao_lisp_cons *cons) -{ - if (!ao_lisp_check_argc(_ao_lisp_atom_led, cons, 1, 1)) - return AO_LISP_NIL; - if (ao_lisp_poly_type(ao_lisp_arg(cons, 0)) == type) - return _ao_lisp_bool_true; - return _ao_lisp_bool_false; -} - -ao_poly -ao_lisp_do_pairp(struct ao_lisp_cons *cons) -{ - ao_poly v; - if (!ao_lisp_check_argc(_ao_lisp_atom_led, cons, 1, 1)) - return AO_LISP_NIL; - v = ao_lisp_arg(cons, 0); - if (v != AO_LISP_NIL && ao_lisp_poly_type(v) == AO_LISP_CONS) - return _ao_lisp_bool_true; - return _ao_lisp_bool_false; -} - -ao_poly -ao_lisp_do_integerp(struct ao_lisp_cons *cons) -{ - if (!ao_lisp_check_argc(_ao_lisp_atom_led, cons, 1, 1)) - return AO_LISP_NIL; - switch (ao_lisp_poly_type(ao_lisp_arg(cons, 0))) { - case AO_LISP_INT: - case AO_LISP_BIGINT: - return _ao_lisp_bool_true; - default: - return _ao_lisp_bool_false; - } -} - -ao_poly -ao_lisp_do_numberp(struct ao_lisp_cons *cons) -{ - if (!ao_lisp_check_argc(_ao_lisp_atom_led, cons, 1, 1)) - return AO_LISP_NIL; - switch (ao_lisp_poly_type(ao_lisp_arg(cons, 0))) { - case AO_LISP_INT: - case AO_LISP_BIGINT: - case AO_LISP_FLOAT: - return _ao_lisp_bool_true; - default: - return _ao_lisp_bool_false; - } -} - -ao_poly -ao_lisp_do_stringp(struct ao_lisp_cons *cons) -{ - return ao_lisp_do_typep(AO_LISP_STRING, cons); -} - -ao_poly -ao_lisp_do_symbolp(struct ao_lisp_cons *cons) -{ - return ao_lisp_do_typep(AO_LISP_ATOM, cons); -} - -ao_poly -ao_lisp_do_booleanp(struct ao_lisp_cons *cons) -{ - return ao_lisp_do_typep(AO_LISP_BOOL, cons); -} - -ao_poly -ao_lisp_do_procedurep(struct ao_lisp_cons *cons) -{ - if (!ao_lisp_check_argc(_ao_lisp_atom_led, cons, 1, 1)) - return AO_LISP_NIL; - switch (ao_lisp_poly_type(ao_lisp_arg(cons, 0))) { - case AO_LISP_BUILTIN: - case AO_LISP_LAMBDA: - return _ao_lisp_bool_true; - default: - return _ao_lisp_bool_false; - } -} - -/* This one is special -- a list is either nil or - * a 'proper' list with only cons cells - */ -ao_poly -ao_lisp_do_listp(struct ao_lisp_cons *cons) -{ - ao_poly v; - if (!ao_lisp_check_argc(_ao_lisp_atom_led, cons, 1, 1)) - return AO_LISP_NIL; - v = ao_lisp_arg(cons, 0); - for (;;) { - if (v == AO_LISP_NIL) - return _ao_lisp_bool_true; - if (ao_lisp_poly_type(v) != AO_LISP_CONS) - return _ao_lisp_bool_false; - v = ao_lisp_poly_cons(v)->cdr; - } -} - -ao_poly -ao_lisp_do_set_car(struct ao_lisp_cons *cons) -{ - if (!ao_lisp_check_argc(_ao_lisp_atom_led, cons, 2, 2)) - return AO_LISP_NIL; - if (!ao_lisp_check_argt(_ao_lisp_atom_led, cons, 0, AO_LISP_CONS, 0)) - return AO_LISP_NIL; - return ao_lisp_poly_cons(ao_lisp_arg(cons, 0))->car = ao_lisp_arg(cons, 1); -} - -ao_poly -ao_lisp_do_set_cdr(struct ao_lisp_cons *cons) -{ - if (!ao_lisp_check_argc(_ao_lisp_atom_led, cons, 2, 2)) - return AO_LISP_NIL; - if (!ao_lisp_check_argt(_ao_lisp_atom_led, cons, 0, AO_LISP_CONS, 0)) - return AO_LISP_NIL; - return ao_lisp_poly_cons(ao_lisp_arg(cons, 0))->cdr = ao_lisp_arg(cons, 1); -} - -ao_poly -ao_lisp_do_symbol_to_string(struct ao_lisp_cons *cons) -{ - 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_ATOM, 0)) - return AO_LISP_NIL; - return ao_lisp_string_poly(ao_lisp_string_copy(ao_lisp_poly_atom(ao_lisp_arg(cons, 0))->name)); -} - -ao_poly -ao_lisp_do_string_to_symbol(struct ao_lisp_cons *cons) -{ - 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_STRING, 0)) - return AO_LISP_NIL; - - return ao_lisp_atom_poly(ao_lisp_atom_intern(ao_lisp_poly_string(ao_lisp_arg(cons, 0)))); -} - -ao_poly -ao_lisp_do_read_char(struct ao_lisp_cons *cons) -{ - int c; - if (!ao_lisp_check_argc(_ao_lisp_atom_led, cons, 0, 0)) - return AO_LISP_NIL; - c = getchar(); - return ao_lisp_int_poly(c); -} - -ao_poly -ao_lisp_do_write_char(struct ao_lisp_cons *cons) -{ - 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; - putchar(ao_lisp_poly_integer(ao_lisp_arg(cons, 0))); - return _ao_lisp_bool_true; -} - -ao_poly -ao_lisp_do_exit(struct ao_lisp_cons *cons) -{ - if (!ao_lisp_check_argc(_ao_lisp_atom_led, cons, 0, 0)) - return AO_LISP_NIL; - ao_lisp_exception |= AO_LISP_EXIT; - return _ao_lisp_bool_true; -} - -ao_poly -ao_lisp_do_current_jiffy(struct ao_lisp_cons *cons) -{ - int jiffy; - - if (!ao_lisp_check_argc(_ao_lisp_atom_led, cons, 0, 0)) - return AO_LISP_NIL; - jiffy = ao_lisp_os_jiffy(); - return (ao_lisp_int_poly(jiffy)); -} - -ao_poly -ao_lisp_do_current_second(struct ao_lisp_cons *cons) -{ - int second; - - if (!ao_lisp_check_argc(_ao_lisp_atom_led, cons, 0, 0)) - return AO_LISP_NIL; - second = ao_lisp_os_jiffy() / AO_LISP_JIFFIES_PER_SECOND; - return (ao_lisp_int_poly(second)); -} - -ao_poly -ao_lisp_do_jiffies_per_second(struct ao_lisp_cons *cons) -{ - if (!ao_lisp_check_argc(_ao_lisp_atom_led, cons, 0, 0)) - return AO_LISP_NIL; - return (ao_lisp_int_poly(AO_LISP_JIFFIES_PER_SECOND)); -} - -#define AO_LISP_BUILTIN_FUNCS -#include "ao_lisp_builtin.h" diff --git a/src/lisp/ao_lisp_builtin.txt b/src/lisp/ao_lisp_builtin.txt deleted file mode 100644 index cb65e252..00000000 --- a/src/lisp/ao_lisp_builtin.txt +++ /dev/null @@ -1,68 +0,0 @@ -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 -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 + -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 < -f_lambda greater > -f_lambda less_equal <= -f_lambda greater_equal >= -f_lambda list_to_string list->string -f_lambda string_to_list string->list -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 symbol_to_string symbol->string -f_lambda string_to_symbol string->symbol -f_lambda stringp string? -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 diff --git a/src/lisp/ao_lisp_cons.c b/src/lisp/ao_lisp_cons.c deleted file mode 100644 index d3b97383..00000000 --- a/src/lisp/ao_lisp_cons.c +++ /dev/null @@ -1,184 +0,0 @@ -/* - * Copyright © 2016 Keith Packard - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation, either version 2 of the License, or - * (at your option) any later version. - * - * This program is distributed in the hope that it will be useful, but - * WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU - * General Public License for more details. - */ - -#include "ao_lisp.h" - -static void cons_mark(void *addr) -{ - struct ao_lisp_cons *cons = addr; - - for (;;) { - ao_poly cdr = cons->cdr; - - ao_lisp_poly_mark(cons->car, 1); - if (!cdr) - break; - if (ao_lisp_poly_type(cdr) != AO_LISP_CONS) { - ao_lisp_poly_mark(cdr, 1); - break; - } - cons = ao_lisp_poly_cons(cdr); - 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 (;;) { - ao_poly cdr; - struct ao_lisp_cons *c; - 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 = cons->cdr; - if (!cdr) - break; - if (ao_lisp_poly_base_type(cdr) != AO_LISP_CONS) { - (void) ao_lisp_poly_move(&cons->cdr, 0); - break; - } - c = ao_lisp_poly_cons(cdr); - ret = ao_lisp_move_memory(&ao_lisp_cons_type, (void **) &c); - if (c != ao_lisp_poly_cons(cons->cdr)) - cons->cdr = ao_lisp_cons_poly(c); - 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 = c; - } -} - -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, ao_poly 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_poly_stash(1, cdr); - cons = ao_lisp_alloc(sizeof (struct ao_lisp_cons)); - cdr = ao_lisp_poly_fetch(1); - car = ao_lisp_poly_fetch(0); - if (!cons) - return NULL; - } - cons->car = car; - cons->cdr = cdr; - return cons; -} - -struct ao_lisp_cons * -ao_lisp_cons_cdr(struct ao_lisp_cons *cons) -{ - ao_poly cdr = cons->cdr; - if (cdr == AO_LISP_NIL) - return NULL; - if (ao_lisp_poly_type(cdr) != AO_LISP_CONS) { - (void) ao_lisp_error(AO_LISP_INVALID, "improper list"); - return NULL; - } - return ao_lisp_poly_cons(cdr); -} - -ao_poly -ao_lisp__cons(ao_poly car, ao_poly cdr) -{ - return ao_lisp_cons_poly(ao_lisp_cons_cons(car, cdr)); -} - -void -ao_lisp_cons_free(struct ao_lisp_cons *cons) -{ -#if DBG_FREE_CONS - ao_lisp_cons_check(cons); -#endif - 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_write(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_write(cons->car); - c = cons->cdr; - if (ao_lisp_poly_type(c) == AO_LISP_CONS) { - cons = ao_lisp_poly_cons(c); - first = 0; - } else { - printf(" . "); - ao_lisp_poly_write(c); - cons = NULL; - } - } - printf(")"); -} - -void -ao_lisp_cons_display(ao_poly c) -{ - struct ao_lisp_cons *cons = ao_lisp_poly_cons(c); - - while (cons) { - ao_lisp_poly_display(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 422bdd63..00000000 --- a/src/lisp/ao_lisp_const.lisp +++ /dev/null @@ -1,813 +0,0 @@ -; -; Copyright © 2016 Keith Packard -; -; This program is free software; you can redistribute it and/or modify -; it under the terms of the GNU General Public License as published by -; the Free Software Foundation, either version 2 of the License, or -; (at your option) any later version. -; -; This program is distributed in the hope that it will be useful, but -; WITHOUT ANY WARRANTY; without even the implied warranty of -; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -; General Public License for more details. -; -; 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 ) - ; (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 c) 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/lisp/ao_lisp_error.c b/src/lisp/ao_lisp_error.c deleted file mode 100644 index 7f909487..00000000 --- a/src/lisp/ao_lisp_error.c +++ /dev/null @@ -1,139 +0,0 @@ -/* - * Copyright © 2016 Keith Packard - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation, either version 2 of the License, or - * (at your option) any later version. - * - * This program is distributed in the hope that it will be useful, but - * WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU - * General Public License for more details. - */ - -#include "ao_lisp.h" -#include - -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_write(cons->car); - printf("\n"); - if (poly == last) - break; - poly = cons->cdr; - } - printf("\t\t )\n"); - } else - printf(")\n"); - } else { - ao_lisp_poly_write(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) { - struct ao_lisp_frame_vals *vals = ao_lisp_poly_frame_vals(frame->vals); - 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_write(vals->vals[f].atom); - printf(" = "); - ao_lisp_poly_write(vals->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"); -} - -void -ao_lisp_vprintf(char *format, va_list args) -{ - char c; - - while ((c = *format++) != '\0') { - if (c == '%') { - switch (c = *format++) { - case 'v': - ao_lisp_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_lisp_printf(char *format, ...) -{ - va_list args; - va_start(args, format); - ao_lisp_vprintf(format, args); - va_end(args); -} - -ao_poly -ao_lisp_error(int error, char *format, ...) -{ - va_list args; - - ao_lisp_exception |= error; - va_start(args, format); - ao_lisp_vprintf(format, args); - putchar('\n'); - va_end(args); - ao_lisp_printf("Value: %v\n", ao_lisp_v); - ao_lisp_printf("Frame: %v\n", ao_lisp_frame_poly(ao_lisp_frame_current)); - printf("Stack:\n"); - ao_lisp_stack_write(ao_lisp_stack_poly(ao_lisp_stack)); - ao_lisp_printf("Globals: %v\n", ao_lisp_frame_poly(ao_lisp_frame_global)); - 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 c3dd2ed2..00000000 --- a/src/lisp/ao_lisp_eval.c +++ /dev/null @@ -1,578 +0,0 @@ -/* - * Copyright © 2016 Keith Packard - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation, either version 2 of the License, or - * (at your option) any later version. - * - * This program is distributed in the hope that it will be useful, but - * WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU - * General Public License for more details. - */ - -#include "ao_lisp.h" -#include - -struct ao_lisp_stack *ao_lisp_stack; -ao_poly ao_lisp_v; -uint8_t ao_lisp_skip_cons_free; - -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: %v\n", ao_lisp_v); - 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_BOOL: - case AO_LISP_INT: - case AO_LISP_BIGINT: - case AO_LISP_FLOAT: - case AO_LISP_STRING: - case AO_LISP_BUILTIN: - case AO_LISP_LAMBDA: - 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, 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_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: - DBGI(".. lambda\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("\t.. sexprs "); DBG_POLY(ao_lisp_stack->sexprs); DBG("\n"); - DBGI("\t.. 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(ao_lisp_v, AO_LISP_NIL); - 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 && (builtin->args & AO_LISP_FUNC_FREE_ARGS) && !ao_lisp_stack_marked(ao_lisp_stack) && !ao_lisp_skip_cons_free) { - struct ao_lisp_cons *cons = ao_lisp_poly_cons(ao_lisp_stack->values); - ao_lisp_stack->values = AO_LISP_NIL; - ao_lisp_cons_free(cons); - } - - 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_begin; - 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; - } - ao_lisp_skip_cons_free = 0; - return 1; -} - -/* - * Finish setting up the apply evaluation - * - * The value is the list to execute - */ -static int -ao_lisp_eval_apply(void) -{ - struct ao_lisp_cons *cons = ao_lisp_poly_cons(ao_lisp_v); - struct ao_lisp_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_lisp_poly_cons(prev->cdr); - if (cdr->cdr == AO_LISP_NIL) - break; - } - DBGI("before mangling: "); DBG_POLY(ao_lisp_v); DBG("\n"); - prev->cdr = cdr->car; - ao_lisp_stack->values = ao_lisp_v; - ao_lisp_v = ao_lisp_poly_cons(ao_lisp_stack->values)->car; - DBGI("apply: "); DBG_POLY(ao_lisp_stack->values); DBG ("\n"); - ao_lisp_stack->state = eval_exec; - ao_lisp_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_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_bool_false; - 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; - if (ao_lisp_v == _ao_lisp_atom_else) - ao_lisp_v = _ao_lisp_bool_true; - 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 != _ao_lisp_bool_false) { - 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_begin; - 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_begin 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_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_lisp_eval_begin(void) -{ - DBGI("begin: "); 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_begin; - 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_bool_false) { - 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_begin; - 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_apply] = ao_lisp_eval_apply, - [eval_cond] = ao_lisp_eval_cond, - [eval_cond_test] = ao_lisp_eval_cond_test, - [eval_begin] = ao_lisp_eval_begin, - [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[] = { - [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_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; - - ao_lisp_frame_init(); - - 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_float.c b/src/lisp/ao_lisp_float.c deleted file mode 100644 index 0aa6f2ea..00000000 --- a/src/lisp/ao_lisp_float.c +++ /dev/null @@ -1,148 +0,0 @@ -/* - * Copyright © 2017 Keith Packard - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation, either version 2 of the License, or - * (at your option) any later version. - * - * This program is distributed in the hope that it will be useful, but - * WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU - * General Public License for more details. - */ - -#include "ao_lisp.h" -#include - -static void float_mark(void *addr) -{ - (void) addr; -} - -static int float_size(void *addr) -{ - if (!addr) - return 0; - return sizeof (struct ao_lisp_float); -} - -static void float_move(void *addr) -{ - (void) addr; -} - -const struct ao_lisp_type ao_lisp_float_type = { - .mark = float_mark, - .size = float_size, - .move = float_move, - .name = "float", -}; - -void -ao_lisp_float_write(ao_poly p) -{ - struct ao_lisp_float *f = ao_lisp_poly_float(p); - float v = f->value; - - if (isnanf(v)) - printf("+nan.0"); - else if (isinff(v)) { - if (v < 0) - printf("-"); - else - printf("+"); - printf("inf.0"); - } else - printf ("%g", f->value); -} - -float -ao_lisp_poly_number(ao_poly p) -{ - switch (ao_lisp_poly_base_type(p)) { - case AO_LISP_INT: - return ao_lisp_poly_int(p); - case AO_LISP_OTHER: - switch (ao_lisp_other_type(ao_lisp_poly_other(p))) { - case AO_LISP_BIGINT: - return ao_lisp_bigint_int(ao_lisp_poly_bigint(p)->value); - case AO_LISP_FLOAT: - return ao_lisp_poly_float(p)->value; - } - } - return NAN; -} - -ao_poly -ao_lisp_float_get(float value) -{ - struct ao_lisp_float *f; - - f = ao_lisp_alloc(sizeof (struct ao_lisp_float)); - f->type = AO_LISP_FLOAT; - f->value = value; - return ao_lisp_float_poly(f); -} - -ao_poly -ao_lisp_do_inexactp(struct ao_lisp_cons *cons) -{ - if (!ao_lisp_check_argc(_ao_lisp_atom_led, cons, 1, 1)) - return AO_LISP_NIL; - if (ao_lisp_poly_type(ao_lisp_arg(cons, 0)) == AO_LISP_FLOAT) - return _ao_lisp_bool_true; - return _ao_lisp_bool_false; -} - -ao_poly -ao_lisp_do_finitep(struct ao_lisp_cons *cons) -{ - ao_poly value; - float f; - - if (!ao_lisp_check_argc(_ao_lisp_atom_led, cons, 1, 1)) - return AO_LISP_NIL; - value = ao_lisp_arg(cons, 0); - switch (ao_lisp_poly_type(value)) { - case AO_LISP_INT: - case AO_LISP_BIGINT: - return _ao_lisp_bool_true; - case AO_LISP_FLOAT: - f = ao_lisp_poly_float(value)->value; - if (!isnan(f) && !isinf(f)) - return _ao_lisp_bool_true; - } - return _ao_lisp_bool_false; -} - -ao_poly -ao_lisp_do_infinitep(struct ao_lisp_cons *cons) -{ - ao_poly value; - float f; - - if (!ao_lisp_check_argc(_ao_lisp_atom_led, cons, 1, 1)) - return AO_LISP_NIL; - value = ao_lisp_arg(cons, 0); - switch (ao_lisp_poly_type(value)) { - case AO_LISP_FLOAT: - f = ao_lisp_poly_float(value)->value; - if (isinf(f)) - return _ao_lisp_bool_true; - } - return _ao_lisp_bool_false; -} - -ao_poly -ao_lisp_do_sqrt(struct ao_lisp_cons *cons) -{ - ao_poly value; - - if (!ao_lisp_check_argc(_ao_lisp_atom_sqrt, cons, 1, 1)) - return AO_LISP_NIL; - value = ao_lisp_arg(cons, 0); - if (!ao_lisp_number_typep(ao_lisp_poly_type(value))) - return ao_lisp_error(AO_LISP_INVALID, "%s: non-numeric", ao_lisp_poly_atom(_ao_lisp_atom_sqrt)->name); - return ao_lisp_float_get(sqrtf(ao_lisp_poly_number(value))); -} diff --git a/src/lisp/ao_lisp_frame.c b/src/lisp/ao_lisp_frame.c deleted file mode 100644 index c285527e..00000000 --- a/src/lisp/ao_lisp_frame.c +++ /dev/null @@ -1,330 +0,0 @@ -/* - * Copyright © 2016 Keith Packard - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation, either version 2 of the License, or - * (at your option) any later version. - * - * This program is distributed in the hope that it will be useful, but - * WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU - * General Public License for more details. - */ - -#include "ao_lisp.h" - -static inline int -frame_vals_num_size(int num) -{ - return sizeof (struct ao_lisp_frame_vals) + num * sizeof (struct ao_lisp_val); -} - -static int -frame_vals_size(void *addr) -{ - struct ao_lisp_frame_vals *vals = addr; - return frame_vals_num_size(vals->size); -} - -static void -frame_vals_mark(void *addr) -{ - struct ao_lisp_frame_vals *vals = addr; - int f; - - for (f = 0; f < vals->size; f++) { - struct ao_lisp_val *v = &vals->vals[f]; - - ao_lisp_poly_mark(v->val, 0); - MDBG_MOVE("frame mark atom %s %d val %d at %d ", - ao_lisp_poly_atom(v->atom)->name, - MDBG_OFFSET(ao_lisp_ref(v->atom)), - MDBG_OFFSET(ao_lisp_ref(v->val)), f); - MDBG_DO(ao_lisp_poly_write(v->val)); - MDBG_DO(printf("\n")); - } -} - -static void -frame_vals_move(void *addr) -{ - struct ao_lisp_frame_vals *vals = addr; - int f; - - for (f = 0; f < vals->size; f++) { - struct ao_lisp_val *v = &vals->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); - } -} - -const struct ao_lisp_type ao_lisp_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_lisp_frame); -} - -static void -frame_mark(void *addr) -{ - struct ao_lisp_frame *frame = addr; - - for (;;) { - MDBG_MOVE("frame mark %d\n", MDBG_OFFSET(frame)); - if (!AO_LISP_IS_POOL(frame)) - break; - ao_lisp_poly_mark(frame->vals, 0); - 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; - - for (;;) { - struct ao_lisp_frame *prev; - int ret; - - MDBG_MOVE("frame move %d\n", MDBG_OFFSET(frame)); - if (!AO_LISP_IS_POOL(frame)) - break; - ao_lisp_poly_move(&frame->vals, 0); - 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_write(ao_poly p) -{ - struct ao_lisp_frame *frame = ao_lisp_poly_frame(p); - struct ao_lisp_frame_vals *vals = ao_lisp_poly_frame_vals(frame->vals); - 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_write(vals->vals[f].atom); - printf(" = "); - ao_lisp_poly_write(vals->vals[f].val); - } - if (frame->prev) - ao_lisp_poly_write(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) -{ - struct ao_lisp_frame_vals *vals = ao_lisp_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_lisp_frame_ref(struct ao_lisp_frame *frame, ao_poly atom) -{ - struct ao_lisp_frame_vals *vals = ao_lisp_poly_frame_vals(frame->vals); - int l = ao_lisp_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_lisp_frame *ao_lisp_frame_free_list[AO_LISP_FRAME_FREE]; - -static struct ao_lisp_frame_vals * -ao_lisp_frame_vals_new(int num) -{ - struct ao_lisp_frame_vals *vals; - - vals = ao_lisp_alloc(frame_vals_num_size(num)); - if (!vals) - return NULL; - vals->type = AO_LISP_FRAME_VALS; - vals->size = num; - memset(vals->vals, '\0', num * sizeof (struct ao_lisp_val)); - return vals; -} - -struct ao_lisp_frame * -ao_lisp_frame_new(int num) -{ - struct ao_lisp_frame *frame; - struct ao_lisp_frame_vals *vals; - - 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); - vals = ao_lisp_poly_frame_vals(frame->vals); - } else { - frame = ao_lisp_alloc(sizeof (struct ao_lisp_frame)); - if (!frame) - return NULL; - frame->type = AO_LISP_FRAME; - frame->num = 0; - frame->prev = AO_LISP_NIL; - frame->vals = AO_LISP_NIL; - ao_lisp_frame_stash(0, frame); - vals = ao_lisp_frame_vals_new(num); - frame = ao_lisp_frame_fetch(0); - if (!vals) - return NULL; - frame->vals = ao_lisp_frame_vals_poly(vals); - frame->num = num; - } - frame->prev = AO_LISP_NIL; - 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 (frame && !ao_lisp_frame_marked(frame)) { - int num = frame->num; - if (num < AO_LISP_FRAME_FREE) { - struct ao_lisp_frame_vals *vals; - - vals = ao_lisp_poly_frame_vals(frame->vals); - memset(vals->vals, '\0', vals->size * sizeof (struct ao_lisp_val)); - 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, int new_num) -{ - struct ao_lisp_frame_vals *vals; - struct ao_lisp_frame_vals *new_vals; - int copy; - - if (new_num == frame->num) - return frame; - ao_lisp_frame_stash(0, frame); - new_vals = ao_lisp_frame_vals_new(new_num); - frame = ao_lisp_frame_fetch(0); - if (!new_vals) - return NULL; - vals = ao_lisp_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_lisp_val)); - frame->vals = ao_lisp_frame_vals_poly(new_vals); - frame->num = new_num; - return frame; -} - -void -ao_lisp_frame_bind(struct ao_lisp_frame *frame, int num, ao_poly atom, ao_poly val) -{ - struct ao_lisp_frame_vals *vals = ao_lisp_poly_frame_vals(frame->vals); - int l = ao_lisp_frame_find(frame, num, atom); - - memmove(&vals->vals[l+1], - &vals->vals[l], - (num - l) * sizeof (struct ao_lisp_val)); - vals->vals[l].atom = atom; - vals->vals[l].val = val; -} - -ao_poly -ao_lisp_frame_add(struct ao_lisp_frame *frame, ao_poly atom, ao_poly val) -{ - ao_poly *ref = frame ? ao_lisp_frame_ref(frame, atom) : NULL; - - if (!ref) { - int f = frame->num; - ao_lisp_poly_stash(0, atom); - ao_lisp_poly_stash(1, val); - frame = ao_lisp_frame_realloc(frame, f + 1); - val = ao_lisp_poly_fetch(1); - atom = ao_lisp_poly_fetch(0); - if (!frame) - return AO_LISP_NIL; - ao_lisp_frame_bind(frame, frame->num - 1, atom, val); - } else - *ref = val; - return val; -} - -struct ao_lisp_frame *ao_lisp_frame_global; -struct ao_lisp_frame *ao_lisp_frame_current; - -void -ao_lisp_frame_init(void) -{ - if (!ao_lisp_frame_global) - ao_lisp_frame_global = ao_lisp_frame_new(0); -} diff --git a/src/lisp/ao_lisp_int.c b/src/lisp/ao_lisp_int.c deleted file mode 100644 index 8e467755..00000000 --- a/src/lisp/ao_lisp_int.c +++ /dev/null @@ -1,79 +0,0 @@ -/* - * Copyright © 2016 Keith Packard - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation, either version 2 of the License, or - * (at your option) any later version. - * - * This program is distributed in the hope that it will be useful, but - * WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU - * General Public License for more details. - */ - -#include "ao_lisp.h" - -void -ao_lisp_int_write(ao_poly p) -{ - int i = ao_lisp_poly_int(p); - printf("%d", i); -} - -int32_t -ao_lisp_poly_integer(ao_poly p) -{ - switch (ao_lisp_poly_base_type(p)) { - case AO_LISP_INT: - return ao_lisp_poly_int(p); - case AO_LISP_OTHER: - if (ao_lisp_other_type(ao_lisp_poly_other(p)) == AO_LISP_BIGINT) - return ao_lisp_bigint_int(ao_lisp_poly_bigint(p)->value); - } - return AO_LISP_NOT_INTEGER; -} - -ao_poly -ao_lisp_integer_poly(int32_t p) -{ - struct ao_lisp_bigint *bi; - - if (AO_LISP_MIN_INT <= p && p <= AO_LISP_MAX_INT) - return ao_lisp_int_poly(p); - bi = ao_lisp_alloc(sizeof (struct ao_lisp_bigint)); - bi->value = ao_lisp_int_bigint(p); - return ao_lisp_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_lisp_bigint); -} - -static void bigint_move(void *addr) -{ - (void) addr; -} - -const struct ao_lisp_type ao_lisp_bigint_type = { - .mark = bigint_mark, - .size = bigint_size, - .move = bigint_move, - .name = "bigint", -}; - -void -ao_lisp_bigint_write(ao_poly p) -{ - struct ao_lisp_bigint *bi = ao_lisp_poly_bigint(p); - - printf("%d", ao_lisp_bigint_int(bi->value)); -} diff --git a/src/lisp/ao_lisp_lambda.c b/src/lisp/ao_lisp_lambda.c deleted file mode 100644 index e72281db..00000000 --- a/src/lisp/ao_lisp_lambda.c +++ /dev/null @@ -1,208 +0,0 @@ -/* - * Copyright © 2016 Keith Packard - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation; 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_write(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_write(cons->car); - cons = ao_lisp_poly_cons(cons->cdr); - } - printf(")"); -} - -ao_poly -ao_lisp_lambda_alloc(struct ao_lisp_cons *code, int args) -{ - struct ao_lisp_lambda *lambda; - ao_poly formal; - struct ao_lisp_cons *cons; - - formal = ao_lisp_arg(code, 0); - while (formal != AO_LISP_NIL) { - switch (ao_lisp_poly_type(formal)) { - case AO_LISP_CONS: - cons = ao_lisp_poly_cons(formal); - if (ao_lisp_poly_type(cons->car) != AO_LISP_ATOM) - return ao_lisp_error(AO_LISP_INVALID, "formal %p is not atom", cons->car); - formal = cons->cdr; - break; - case AO_LISP_ATOM: - formal = AO_LISP_NIL; - break; - default: - return ao_lisp_error(AO_LISP_INVALID, "formal %p is not atom", formal); - } - } - - ao_lisp_cons_stash(0, code); - lambda = ao_lisp_alloc(sizeof (struct ao_lisp_lambda)); - code = ao_lisp_cons_fetch(0); - if (!lambda) - return AO_LISP_NIL; - - 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_do_lambda(struct ao_lisp_cons *cons) -{ - return ao_lisp_lambda_alloc(cons, AO_LISP_FUNC_LAMBDA); -} - -ao_poly -ao_lisp_do_nlambda(struct ao_lisp_cons *cons) -{ - return ao_lisp_lambda_alloc(cons, AO_LISP_FUNC_NLAMBDA); -} - -ao_poly -ao_lisp_do_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); - ao_poly formals; - struct ao_lisp_frame *next_frame; - int args_wanted; - ao_poly varargs = AO_LISP_NIL; - int args_provided; - int f; - struct ao_lisp_cons *vals; - - DBGI("lambda "); DBG_POLY(ao_lisp_lambda_poly(lambda)); DBG("\n"); - - args_wanted = 0; - for (formals = ao_lisp_arg(code, 0); - ao_lisp_is_pair(formals); - formals = ao_lisp_poly_cons(formals)->cdr) - ++args_wanted; - if (formals != AO_LISP_NIL) { - if (ao_lisp_poly_type(formals) != AO_LISP_ATOM) - return ao_lisp_error(AO_LISP_INVALID, "bad lambda form"); - varargs = formals; - } - - /* Create a frame to hold the variables - */ - args_provided = ao_lisp_cons_length(cons) - 1; - if (varargs == AO_LISP_NIL) { - 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) - return ao_lisp_error(AO_LISP_INVALID, "need at least %d args, got %d", args_wanted, args_provided); - } - - ao_lisp_poly_stash(1, varargs); - next_frame = ao_lisp_frame_new(args_wanted + (varargs != AO_LISP_NIL)); - varargs = ao_lisp_poly_fetch(1); - if (!next_frame) - return AO_LISP_NIL; - - /* 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); - formals = 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); - - for (f = 0; f < args_wanted; f++) { - struct ao_lisp_cons *arg = ao_lisp_poly_cons(formals); - DBGI("bind "); DBG_POLY(arg->car); DBG(" = "); DBG_POLY(vals->car); DBG("\n"); - ao_lisp_frame_bind(next_frame, f, arg->car, vals->car); - formals = arg->cdr; - vals = ao_lisp_poly_cons(vals->cdr); - } - if (varargs) { - DBGI("bind "); DBG_POLY(varargs); DBG(" = "); DBG_POLY(ao_lisp_cons_poly(vals)); DBG("\n"); - /* - * Bind the rest of the arguments to the final parameter - */ - ao_lisp_frame_bind(next_frame, f, varargs, ao_lisp_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_LISP_FUNC_LAMBDA && !ao_lisp_stack_marked(ao_lisp_stack)) { - ao_lisp_stack->values = AO_LISP_NIL; - ao_lisp_cons_free(cons); - } - } - 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_lex.c b/src/lisp/ao_lisp_lex.c deleted file mode 100644 index fe7c47f4..00000000 --- a/src/lisp/ao_lisp_lex.c +++ /dev/null @@ -1,16 +0,0 @@ -/* - * Copyright © 2016 Keith Packard - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation, either version 2 of the License, or - * (at your option) any later version. - * - * This program is distributed in the hope that it will be useful, but - * WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU - * General Public License for more details. - */ - -#include "ao_lisp.h" - diff --git a/src/lisp/ao_lisp_make_builtin b/src/lisp/ao_lisp_make_builtin deleted file mode 100644 index 783ab378..00000000 --- a/src/lisp/ao_lisp_make_builtin +++ /dev/null @@ -1,190 +0,0 @@ -#!/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_LISP_BUILTIN_ID\n"); - printf("#undef AO_LISP_BUILTIN_ID\n"); - printf("enum ao_lisp_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_LISP_BUILTIN_ID */\n"); -} - -void -dump_casename(builtin_t[*] builtins) { - printf("#ifdef AO_LISP_BUILTIN_CASENAME\n"); - printf("#undef AO_LISP_BUILTIN_CASENAME\n"); - printf("static char *ao_lisp_builtin_name(enum ao_lisp_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_lisp_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_LISP_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_LISP_BUILTIN_ARRAYNAME\n"); - printf("#undef AO_LISP_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_lisp_atom_", - builtins[i].c_name); - cify_lisp(builtins[i].lisp_names[0]); - printf(",\n"); - } - } - printf("};\n"); - printf("#endif /* AO_LISP_BUILTIN_ARRAYNAME */\n"); -} - -void -dump_funcs(builtin_t[*] builtins) { - printf("#ifdef AO_LISP_BUILTIN_FUNCS\n"); - printf("#undef AO_LISP_BUILTIN_FUNCS\n"); - printf("const ao_lisp_func_t ao_lisp_builtins[] = {\n"); - for (int i = 0; i < dim(builtins); i++) { - if (!is_atom(builtins[i])) - printf("\t[builtin_%s] = ao_lisp_do_%s,\n", - builtins[i].c_name, - builtins[i].c_name); - } - printf("};\n"); - printf("#endif /* AO_LISP_BUILTIN_FUNCS */\n"); -} - -void -dump_decls(builtin_t[*] builtins) { - printf("#ifdef AO_LISP_BUILTIN_DECLS\n"); - printf("#undef AO_LISP_BUILTIN_DECLS\n"); - for (int i = 0; i < dim(builtins); i++) { - if (!is_atom(builtins[i])) { - printf("ao_poly\n"); - printf("ao_lisp_do_%s(struct ao_lisp_cons *cons);\n", - builtins[i].c_name); - } - } - printf("#endif /* AO_LISP_BUILTIN_DECLS */\n"); -} - -void -dump_consts(builtin_t[*] builtins) { - printf("#ifdef AO_LISP_BUILTIN_CONSTS\n"); - printf("#undef AO_LISP_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_LISP_FUNC_%s, .func = builtin_%s },\n", - builtins[i].lisp_names[j], - builtins[i].type, - builtins[i].c_name); - } - } - } - printf("};\n"); - printf("#endif /* AO_LISP_BUILTIN_CONSTS */\n"); -} - -void -dump_atoms(builtin_t[*] builtins) { - printf("#ifdef AO_LISP_BUILTIN_ATOMS\n"); - printf("#undef AO_LISP_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_lisp_atom_"); - cify_lisp(builtins[i].lisp_names[j]); - printf(" _atom(\"%s\")\n", builtins[i].lisp_names[j]); - } - } - printf("#endif /* AO_LISP_BUILTIN_ATOMS */\n"); -} - -void main() { - if (dim(argv) < 2) { - File::fprintf(stderr, "usage: %s \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/lisp/ao_lisp_make_const.c b/src/lisp/ao_lisp_make_const.c deleted file mode 100644 index 6e4b411e..00000000 --- a/src/lisp/ao_lisp_make_const.c +++ /dev/null @@ -1,395 +0,0 @@ -/* - * Copyright © 2016 Keith Packard - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation, either version 2 of the License, or - * (at your option) any later version. - * - * This program is distributed in the hope that it will be useful, but - * WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU - * General Public License for more details. - */ - -#include "ao_lisp.h" -#include -#include -#include -#include - -static struct ao_lisp_builtin * -ao_lisp_make_builtin(enum ao_lisp_builtin_id func, int args) { - struct ao_lisp_builtin *b = ao_lisp_alloc(sizeof (struct ao_lisp_builtin)); - - b->type = AO_LISP_BUILTIN; - b->func = func; - b->args = args; - return b; -} - -struct builtin_func { - char *name; - int args; - enum ao_lisp_builtin_id func; -}; - -#define AO_LISP_BUILTIN_CONSTS -#include "ao_lisp_builtin.h" - -#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(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_write(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_write(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; - ao_poly list; - - if (p == AO_LISP_NIL) - return AO_LISP_NIL; - - MACRO_DEBUG(indent(); printf("has macro "); ao_lisp_poly_write(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; - - list = cons->cdr; - p = AO_LISP_NIL; - while (list != AO_LISP_NIL && ao_lisp_poly_type(list) == AO_LISP_CONS) { - cons = ao_lisp_poly_cons(list); - m = ao_has_macro(cons->car); - if (m) { - p = m; - break; - } - list = cons->cdr; - } - break; - - default: - p = AO_LISP_NIL; - break; - } - MACRO_DEBUG(--macro_scan_depth; indent(); printf("... "); ao_lisp_poly_write(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_write(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=] [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; - enum ao_lisp_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_lisp_frame_init(); - - /* Boolean values #f and #t */ - ao_lisp_bool_get(0); - ao_lisp_bool_get(1); - - prev_func = _builtin_last; - for (f = 0; f < (int) N_FUNC; f++) { - if (funcs[f].func != prev_func) - b = ao_lisp_make_builtin(funcs[f].func, funcs[f].args); - a = ao_lisp_atom_intern(funcs[f].name); - ao_lisp_atom_def(ao_lisp_atom_poly(a), - ao_lisp_builtin_poly(b)); - } - - /* end of file value */ - a = ao_lisp_atom_intern("eof"); - ao_lisp_atom_def(ao_lisp_atom_poly(a), - ao_lisp_atom_poly(a)); - - /* 'else' */ - a = ao_lisp_atom_intern("else"); - - 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++) { - struct ao_lisp_frame_vals *vals = ao_lisp_poly_frame_vals(ao_lisp_frame_global->vals); - val = ao_has_macro(vals->vals[f].val); - if (val != AO_LISP_NIL) { - printf("error: function %s contains unresolved macro: ", - ao_lisp_poly_atom(vals->vals[f].atom)->name); - ao_lisp_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_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)); - - fprintf(out, "#define _ao_lisp_bool_false 0x%04x\n", ao_lisp_bool_poly(ao_lisp_false)); - fprintf(out, "#define _ao_lisp_bool_true 0x%04x\n", ao_lisp_bool_poly(ao_lisp_true)); - - 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 5471b137..00000000 --- a/src/lisp/ao_lisp_mem.c +++ /dev/null @@ -1,968 +0,0 @@ -/* - * Copyright © 2016 Keith Packard - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation, either version 2 of the License, or - * (at your option) any later version. - * - * This program is distributed in the hope that it will be useful, but - * WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU - * General Public License for more details. - */ - -#define AO_LISP_CONST_BITS - -#include "ao_lisp.h" -#include -#include - -#ifdef AO_LISP_MAKE_CONST - -/* - * When building the constant table, it is the - * pool for allocations. - */ - -#include -uint8_t ao_lisp_const[AO_LISP_POOL_CONST] __attribute__((aligned(4))); -#define ao_lisp_pool ao_lisp_const -#undef AO_LISP_POOL -#define AO_LISP_POOL AO_LISP_POOL_CONST - -#else - -uint8_t ao_lisp_pool[AO_LISP_POOL + 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 struct ao_lisp_frame *save_frame[1]; -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 = &ao_lisp_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_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, - }, -#ifdef AO_LISP_MAKE_CONST - { - .type = &ao_lisp_bool_type, - .addr = (void **) &ao_lisp_false, - }, - { - .type = &ao_lisp_bool_type, - .addr = (void **) &ao_lisp_true, - }, -#endif -}; - -#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 *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_FRAME_VALS] = &ao_lisp_frame_vals_type, - [AO_LISP_LAMBDA] = &ao_lisp_lambda_type, - [AO_LISP_STACK] = &ao_lisp_stack_type, - [AO_LISP_BOOL] = &ao_lisp_bool_type, - [AO_LISP_BIGINT] = &ao_lisp_bigint_type, - [AO_LISP_FLOAT] = &ao_lisp_float_type, -}; - -static int -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 - MDBG_DO(ao_lisp_frame_write(ao_lisp_frame_poly(ao_lisp_frame_global))); - - /* 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; -} - -#if DBG_FREE_CONS -void -ao_lisp_cons_check(struct ao_lisp_cons *cons) -{ - ao_poly cdr; - int offset; - - chunk_low = 0; - reset_chunks(); - walk(ao_lisp_mark_ref, ao_lisp_poly_mark_ref); - while (cons) { - if (!AO_LISP_IS_POOL(cons)) - break; - offset = pool_offset(cons); - if (busy(ao_lisp_busy, offset)) { - ao_lisp_printf("cons at %p offset %d poly %d is busy\n\t%v\n", cons, offset, ao_lisp_cons_poly(cons), ao_lisp_cons_poly(cons)); - abort(); - } - cdr = cons->cdr; - if (!ao_lisp_is_pair(cdr)) - break; - cons = ao_lisp_poly_cons(cdr); - } -} -#endif - -/* - * Mark interfaces for objects - */ - - -/* - * Mark a block of memory with an explicit size - */ - -int -ao_lisp_mark_block(void *addr, int size) -{ - 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, size); - return 0; -} - -/* - * 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; - MDBG_MOVE("alloc %d size %d\n", MDBG_OFFSET(addr), size); - return addr; -} - -void -ao_lisp_cons_stash(int id, struct ao_lisp_cons *cons) -{ - assert(save_cons[id] == 0); - 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) -{ - assert(save_poly[id] == AO_LISP_NIL); - 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) -{ - assert(save_string[id] == NULL); - save_string[id] = string; -} - -char * -ao_lisp_string_fetch(int id) -{ - char *string = save_string[id]; - save_string[id] = NULL; - return string; -} - -void -ao_lisp_frame_stash(int id, struct ao_lisp_frame *frame) -{ - assert(save_frame[id] == NULL); - save_frame[id] = frame; -} - -struct ao_lisp_frame * -ao_lisp_frame_fetch(int id) -{ - struct ao_lisp_frame *frame = save_frame[id]; - save_frame[id] = NULL; - return frame; -} diff --git a/src/lisp/ao_lisp_os.h b/src/lisp/ao_lisp_os.h deleted file mode 100644 index 4285cb8c..00000000 --- a/src/lisp/ao_lisp_os.h +++ /dev/null @@ -1,63 +0,0 @@ -/* - * Copyright © 2016 Keith Packard - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation; 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_LISP_OS_H_ -#define _AO_LISP_OS_H_ - -#include -#include -#include - -extern int ao_lisp_getc(void); - -static inline void -ao_lisp_os_flush(void) { - fflush(stdout); -} - -static inline void -ao_lisp_abort(void) -{ - abort(); -} - -static inline void -ao_lisp_os_led(int led) -{ - printf("leds set to 0x%x\n", led); -} - -#define AO_LISP_JIFFIES_PER_SECOND 100 - -static inline void -ao_lisp_os_delay(int jiffies) -{ - struct timespec ts = { - .tv_sec = jiffies / AO_LISP_JIFFIES_PER_SECOND, - .tv_nsec = (jiffies % AO_LISP_JIFFIES_PER_SECOND) * (1000000000L / AO_LISP_JIFFIES_PER_SECOND) - }; - nanosleep(&ts, NULL); -} - -static inline int -ao_lisp_os_jiffy(void) -{ - struct timespec tp; - clock_gettime(CLOCK_MONOTONIC, &tp); - return tp.tv_sec * AO_LISP_JIFFIES_PER_SECOND + (tp.tv_nsec / (1000000000L / AO_LISP_JIFFIES_PER_SECOND)); -} -#endif diff --git a/src/lisp/ao_lisp_poly.c b/src/lisp/ao_lisp_poly.c deleted file mode 100644 index d14f4151..00000000 --- a/src/lisp/ao_lisp_poly.c +++ /dev/null @@ -1,118 +0,0 @@ -/* - * Copyright © 2016 Keith Packard - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation, either version 2 of the License, or - * (at your option) any later version. - * - * This program is distributed in the hope that it will be useful, but - * WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU - * General Public License for more details. - */ - -#include "ao_lisp.h" - -struct ao_lisp_funcs { - void (*write)(ao_poly); - void (*display)(ao_poly); -}; - -static const struct ao_lisp_funcs ao_lisp_funcs[AO_LISP_NUM_TYPE] = { - [AO_LISP_CONS] = { - .write = ao_lisp_cons_write, - .display = ao_lisp_cons_display, - }, - [AO_LISP_STRING] = { - .write = ao_lisp_string_write, - .display = ao_lisp_string_display, - }, - [AO_LISP_INT] = { - .write = ao_lisp_int_write, - .display = ao_lisp_int_write, - }, - [AO_LISP_ATOM] = { - .write = ao_lisp_atom_write, - .display = ao_lisp_atom_write, - }, - [AO_LISP_BUILTIN] = { - .write = ao_lisp_builtin_write, - .display = ao_lisp_builtin_write, - }, - [AO_LISP_FRAME] = { - .write = ao_lisp_frame_write, - .display = ao_lisp_frame_write, - }, - [AO_LISP_FRAME_VALS] = { - .write = NULL, - .display = NULL, - }, - [AO_LISP_LAMBDA] = { - .write = ao_lisp_lambda_write, - .display = ao_lisp_lambda_write, - }, - [AO_LISP_STACK] = { - .write = ao_lisp_stack_write, - .display = ao_lisp_stack_write, - }, - [AO_LISP_BOOL] = { - .write = ao_lisp_bool_write, - .display = ao_lisp_bool_write, - }, - [AO_LISP_BIGINT] = { - .write = ao_lisp_bigint_write, - .display = ao_lisp_bigint_write, - }, - [AO_LISP_FLOAT] = { - .write = ao_lisp_float_write, - .display = ao_lisp_float_write, - }, -}; - -static const struct ao_lisp_funcs * -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_write(ao_poly p) -{ - const struct ao_lisp_funcs *f = funcs(p); - - if (f && f->write) - f->write(p); -} - -void -ao_lisp_poly_display(ao_poly p) -{ - const struct ao_lisp_funcs *f = funcs(p); - - if (f && f->display) - f->display(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 0ca12a81..00000000 --- a/src/lisp/ao_lisp_read.c +++ /dev/null @@ -1,655 +0,0 @@ -/* - * Copyright © 2016 Keith Packard - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation, either version 2 of the License, or - * (at your option) any later version. - * - * This program is distributed in the hope that it will be useful, but - * WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU - * General Public License for more details. - */ - -#include "ao_lisp.h" -#include "ao_lisp_read.h" -#include -#include - -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() -{ - 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 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_LISP_TOKEN_MAX 32 - -static char token_string[AO_LISP_TOKEN_MAX]; -static int32_t token_int; -static int token_len; -static float token_float; - -static inline void add_token(int c) { - if (c && token_len < AO_LISP_TOKEN_MAX - 1) - token_string[token_len++] = c; -} - -static inline void del_token(void) { - if (token_len > 0) - token_len--; -} - -static inline void end_token(void) { - token_string[token_len] = '\0'; -} - -struct namedfloat { - const char *name; - float value; -}; - -static const struct namedfloat namedfloats[] = { - { .name = "+inf.0", .value = INFINITY }, - { .name = "-inf.0", .value = -INFINITY }, - { .name = "+nan.0", .value = NAN }, - { .name = "-nan.0", .value = NAN }, -}; - -#define NUM_NAMED_FLOATS (sizeof namedfloats / sizeof namedfloats[0]) - -static int -_lex(void) -{ - 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 '\\': - 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_lisp_error(AO_LISP_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; - -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; - -#define READ_IN_QUOTE 0x01 -#define READ_SAW_DOT 0x02 -#define READ_DONE_DOT 0x04 - -static int -push_read_stack(int cons, int read_state) -{ - RDBGI("push read stack %p 0x%x\n", ao_lisp_read_cons, read_state); - RDBG_IN(); - if (cons) { - ao_lisp_read_stack = ao_lisp_cons_cons(ao_lisp_cons_poly(ao_lisp_read_cons), - ao_lisp__cons(ao_lisp_int_poly(read_state), - ao_lisp_cons_poly(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 read_state = 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); - read_state = 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; - } - RDBG_OUT(); - RDBGI("pop read stack %p %d\n", ao_lisp_read_cons, read_state); - return read_state; -} - -ao_poly -ao_lisp_read(void) -{ - struct ao_lisp_atom *atom; - char *string; - int cons; - int read_state; - ao_poly v = AO_LISP_NIL; - - cons = 0; - read_state = 0; - ao_lisp_read_cons = ao_lisp_read_cons_tail = ao_lisp_read_stack = 0; - for (;;) { - parse_token = lex(); - while (parse_token == OPEN) { - if (!push_read_stack(cons, read_state)) - return AO_LISP_NIL; - cons++; - read_state = 0; - parse_token = lex(); - } - - 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_integer_poly(token_int); - break; - case FLOAT: - v = ao_lisp_float_get(token_float); - break; - case BOOL: - if (token_string[0] == 't') - v = _ao_lisp_bool_true; - else - v = _ao_lisp_bool_false; - 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: - case QUASIQUOTE: - case UNQUOTE: - case UNQUOTE_SPLICING: - if (!push_read_stack(cons, read_state)) - return AO_LISP_NIL; - cons++; - read_state = READ_IN_QUOTE; - switch (parse_token) { - case QUOTE: - v = _ao_lisp_atom_quote; - break; - case QUASIQUOTE: - v = _ao_lisp_atom_quasiquote; - break; - case UNQUOTE: - v = _ao_lisp_atom_unquote; - break; - case UNQUOTE_SPLICING: - v = _ao_lisp_atom_unquote2dsplicing; - break; - } - break; - case CLOSE: - if (!cons) { - v = AO_LISP_NIL; - break; - } - v = ao_lisp_cons_poly(ao_lisp_read_cons); - --cons; - read_state = pop_read_stack(cons); - break; - case DOT: - if (!cons) { - ao_lisp_error(AO_LISP_INVALID, ". outside of cons"); - return AO_LISP_NIL; - } - if (!ao_lisp_read_cons) { - ao_lisp_error(AO_LISP_INVALID, ". first in cons"); - return AO_LISP_NIL; - } - read_state |= READ_SAW_DOT; - continue; - } - - /* loop over QUOTE ends */ - for (;;) { - if (!cons) - return v; - - if (read_state & READ_DONE_DOT) { - ao_lisp_error(AO_LISP_INVALID, ". not last in cons"); - return AO_LISP_NIL; - } - - if (read_state & READ_SAW_DOT) { - read_state |= READ_DONE_DOT; - ao_lisp_read_cons_tail->cdr = v; - } else { - struct ao_lisp_cons *read = ao_lisp_cons_cons(v, AO_LISP_NIL); - 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 (!(read_state & READ_IN_QUOTE) || !ao_lisp_read_cons->cdr) - break; - - v = ao_lisp_cons_poly(ao_lisp_read_cons); - --cons; - read_state = pop_read_stack(cons); - } - } - return v; -} diff --git a/src/lisp/ao_lisp_read.h b/src/lisp/ao_lisp_read.h deleted file mode 100644 index 8f6bf130..00000000 --- a/src/lisp/ao_lisp_read.h +++ /dev/null @@ -1,58 +0,0 @@ -/* - * Copyright © 2016 Keith Packard - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation, either version 2 of the License, or - * (at your option) any later version. - * - * This program is distributed in the hope that it will be useful, but - * WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU - * General Public License for more details. - */ - -#ifndef _AO_LISP_READ_H_ -#define _AO_LISP_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 - -/* - * 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_LISP_READ_H_ */ diff --git a/src/lisp/ao_lisp_rep.c b/src/lisp/ao_lisp_rep.c deleted file mode 100644 index 43cc387f..00000000 --- a/src/lisp/ao_lisp_rep.c +++ /dev/null @@ -1,36 +0,0 @@ -/* - * Copyright © 2016 Keith Packard - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation, either version 2 of the License, or - * (at your option) any later version. - * - * This program is distributed in the hope that it will be useful, but - * WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU - * General Public License for more details. - */ - -#include "ao_lisp.h" - -ao_poly -ao_lisp_read_eval_print(void) -{ - ao_poly in, out = AO_LISP_NIL; - for(;;) { - in = ao_lisp_read(); - if (in == _ao_lisp_atom_eof) - break; - out = ao_lisp_eval(in); - if (ao_lisp_exception) { - if (ao_lisp_exception & AO_LISP_EXIT) - break; - ao_lisp_exception = 0; - } else { - ao_lisp_poly_write(out); - putchar ('\n'); - } - } - return out; -} diff --git a/src/lisp/ao_lisp_save.c b/src/lisp/ao_lisp_save.c deleted file mode 100644 index c990e9c6..00000000 --- a/src/lisp/ao_lisp_save.c +++ /dev/null @@ -1,77 +0,0 @@ -/* - * Copyright © 2016 Keith Packard - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation, either version 2 of the License, or - * (at your option) any later version. - * - * This program is distributed in the hope that it will be useful, but - * WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU - * General Public License for more details. - */ - -#include - -ao_poly -ao_lisp_do_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_bool_true; -#endif - return _ao_lisp_bool_false; -} - -ao_poly -ao_lisp_do_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_bool_false; - - return _ao_lisp_bool_true; - } -#endif - return _ao_lisp_bool_false; -} diff --git a/src/lisp/ao_lisp_stack.c b/src/lisp/ao_lisp_stack.c deleted file mode 100644 index e7c89801..00000000 --- a/src/lisp/ao_lisp_stack.c +++ /dev/null @@ -1,280 +0,0 @@ -/* - * Copyright © 2016 Keith Packard - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation, either version 2 of the License, or - * (at your option) any later version. - * - * This program is distributed in the hope that it will be useful, but - * WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU - * General Public License for more details. - */ - -#include "ao_lisp.h" - -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; - - 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_write(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_write(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_do_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_begin; - return AO_LISP_NIL; -} diff --git a/src/lisp/ao_lisp_string.c b/src/lisp/ao_lisp_string.c deleted file mode 100644 index 1daa50ea..00000000 --- a/src/lisp/ao_lisp_string.c +++ /dev/null @@ -1,161 +0,0 @@ -/* - * Copyright © 2016 Keith Packard - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation; 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 void string_mark(void *addr) -{ - (void) addr; -} - -static int string_size(void *addr) -{ - if (!addr) - return 0; - return strlen(addr) + 1; -} - -static void string_move(void *addr) -{ - (void) addr; -} - -const struct ao_lisp_type ao_lisp_string_type = { - .mark = string_mark, - .size = string_size, - .move = string_move, - .name = "string", -}; - -char * -ao_lisp_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); - if (!r) - return NULL; - strcpy(r, a); - return r; -} - -char * -ao_lisp_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); - if (!r) - return NULL; - strcpy(r, a); - strcpy(r+alen, b); - return r; -} - -ao_poly -ao_lisp_string_pack(struct ao_lisp_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); - char *s = r; - - while (cons) { - if (!ao_lisp_integer_typep(ao_lisp_poly_type(cons->car))) - return ao_lisp_error(AO_LISP_INVALID, "non-int passed to pack"); - *s++ = ao_lisp_poly_integer(cons->car); - cons = ao_lisp_poly_cons(cons->cdr); - } - *s++ = 0; - return ao_lisp_string_poly(r); -} - -ao_poly -ao_lisp_string_unpack(char *a) -{ - struct ao_lisp_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), AO_LISP_NIL); - a = ao_lisp_string_fetch(0); - cons = ao_lisp_cons_fetch(0); - tail = ao_lisp_cons_fetch(1); - - if (!n) { - cons = NULL; - break; - } - if (tail) - tail->cdr = ao_lisp_cons_poly(n); - else - cons = n; - tail = n; - } - return ao_lisp_cons_poly(cons); -} - -void -ao_lisp_string_write(ao_poly p) -{ - char *s = ao_lisp_poly_string(p); - char c; - - putchar('"'); - while ((c = *s++)) { - switch (c) { - case '\n': - printf ("\\n"); - break; - case '\r': - printf ("\\r"); - break; - case '\t': - printf ("\\t"); - break; - default: - if (c < ' ') - printf("\\%03o", c); - else - putchar(c); - break; - } - } - putchar('"'); -} - -void -ao_lisp_string_display(ao_poly p) -{ - char *s = ao_lisp_poly_string(p); - char c; - - while ((c = *s++)) - putchar(c); -} 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..d8e4b553 --- /dev/null +++ b/src/scheme/Makefile @@ -0,0 +1,16 @@ +all: ao_scheme_builtin.h ao_scheme_const.h + +clean: + +cd make-const && make clean + rm -f ao_scheme_const.h ao_scheme_builtin.h + +ao_scheme_const.h: ao_scheme_const.lisp make-const/ao_scheme_make_const + make-const/ao_scheme_make_const -o $@ ao_scheme_const.lisp + +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 + +cd make-const && make ao_scheme_make_const + +FRC: diff --git a/src/scheme/Makefile-inc b/src/scheme/Makefile-inc new file mode 100644 index 00000000..d23ee3d7 --- /dev/null +++ b/src/scheme/Makefile-inc @@ -0,0 +1,24 @@ +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 + +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..2427cffa --- /dev/null +++ b/src/scheme/Makefile-scheme @@ -0,0 +1,4 @@ +include ../lisp/Makefile-inc + +ao_scheme_const.h: $(LISP_SRCS) $(LISP_HDRS) + +cd ../lisp && make $@ diff --git a/src/scheme/README b/src/scheme/README new file mode 100644 index 00000000..98932b44 --- /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; (have classic macros) +* 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..4589f8a5 --- /dev/null +++ b/src/scheme/ao_scheme.h @@ -0,0 +1,928 @@ +/* + * Copyright © 2016 Keith Packard + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation, either version 2 of the License, or + * (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, but + * WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + * General Public License for more details. + */ + +#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 +#include +#include +#ifndef __BYTE_ORDER +#include +#endif + +typedef uint16_t ao_poly; +typedef int16_t ao_signed_poly; + +#ifdef 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 +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_NUM_TYPE 13 + +/* 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; +}; + +#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); + +/* memory functions */ + +extern int ao_scheme_collects[2]; +extern int ao_scheme_freed[2]; +extern int 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); + +/* 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; +/* 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 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 +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 + * + * 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 + * + * 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..49f218f6 --- /dev/null +++ b/src/scheme/ao_scheme_builtin.c @@ -0,0 +1,868 @@ +/* + * Copyright © 2016 Keith Packard + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation, either version 2 of the License, or + * (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, but + * WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + * General Public License for more details. + */ + +#include "ao_scheme.h" +#include +#include + +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, "%s: arg %d invalid type %v", ao_scheme_poly_atom(name)->name, argc, car); + return _ao_scheme_bool_true; +} + +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_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(" "); + } + printf("\n"); + 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; + 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; + } + } + } 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; + } + ret = ao_scheme_integer_poly(r); + } 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; + } + ret = ao_scheme_float_get(r); + } + + else if (rt == AO_SCHEME_STRING && ct == AO_SCHEME_STRING && op == builtin_plus) + ret = ao_scheme_string_poly(ao_scheme_string_cat(ao_scheme_poly_string(ret), + ao_scheme_poly_string(car))); + 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) { + if (left != right) + return _ao_scheme_bool_false; + } 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; + 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; + default: + break; + } + } + } + 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_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) +{ + ao_poly led; + 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; + 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) +{ + ao_poly delay; + 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; + delay = ao_scheme_arg(cons, 0); + ao_scheme_os_delay(ao_scheme_poly_int(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_int_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_led, 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)); +} + +#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..cb65e252 --- /dev/null +++ b/src/scheme/ao_scheme_builtin.txt @@ -0,0 +1,68 @@ +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 +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 + +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 < +f_lambda greater > +f_lambda less_equal <= +f_lambda greater_equal >= +f_lambda list_to_string list->string +f_lambda string_to_list string->list +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 symbol_to_string symbol->string +f_lambda string_to_symbol string->symbol +f_lambda stringp string? +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 diff --git a/src/scheme/ao_scheme_cons.c b/src/scheme/ao_scheme_cons.c new file mode 100644 index 00000000..03dad956 --- /dev/null +++ b/src/scheme/ao_scheme_cons.c @@ -0,0 +1,201 @@ +/* + * Copyright © 2016 Keith Packard + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation, either version 2 of the License, or + * (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, but + * WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + * General Public License for more details. + */ + +#include "ao_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 list"); + 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)); +} + +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_poly_cons(cons->cdr); + } + return len; +} diff --git a/src/scheme/ao_scheme_const.lisp b/src/scheme/ao_scheme_const.lisp new file mode 100644 index 00000000..422bdd63 --- /dev/null +++ b/src/scheme/ao_scheme_const.lisp @@ -0,0 +1,813 @@ +; +; Copyright © 2016 Keith Packard +; +; This program is free software; you can redistribute it and/or modify +; it under the terms of the GNU General Public License as published by +; the Free Software Foundation, either version 2 of the License, or +; (at your option) any later version. +; +; This program is distributed in the hope that it will be useful, but +; WITHOUT ANY WARRANTY; without even the implied warranty of +; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +; General Public License for more details. +; +; 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 ) + ; (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 c) 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 + * + * 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 + +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..9b3cf63e --- /dev/null +++ b/src/scheme/ao_scheme_eval.c @@ -0,0 +1,578 @@ +/* + * Copyright © 2016 Keith Packard + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation, either version 2 of the License, or + * (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, but + * WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + * General Public License for more details. + */ + +#include "ao_scheme.h" +#include + +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 */ + case AO_SCHEME_BOOL: + case AO_SCHEME_INT: + case AO_SCHEME_BIGINT: + case AO_SCHEME_FLOAT: + case AO_SCHEME_STRING: + case AO_SCHEME_BUILTIN: + case AO_SCHEME_LAMBDA: + 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..541f0264 --- /dev/null +++ b/src/scheme/ao_scheme_float.c @@ -0,0 +1,148 @@ +/* + * Copyright © 2017 Keith Packard + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation, either version 2 of the License, or + * (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, but + * WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + * General Public License for more details. + */ + +#include "ao_scheme.h" +#include + +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", +}; + +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 ("%g", f->value); +} + +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 + * + * 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 + * + * 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 + * + * 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/scheme/ao_scheme_lex.c b/src/scheme/ao_scheme_lex.c new file mode 100644 index 00000000..266b1fc0 --- /dev/null +++ b/src/scheme/ao_scheme_lex.c @@ -0,0 +1,16 @@ +/* + * Copyright © 2016 Keith Packard + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation, either version 2 of the License, or + * (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, but + * WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + * General Public License for more details. + */ + +#include "ao_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 \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 + * + * 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 +#include +#include +#include + +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=] [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..acc726c8 --- /dev/null +++ b/src/scheme/ao_scheme_mem.c @@ -0,0 +1,968 @@ +/* + * Copyright © 2016 Keith Packard + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation, either version 2 of the License, or + * (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, but + * WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + * General Public License for more details. + */ + +#define AO_SCHEME_CONST_BITS + +#include "ao_scheme.h" +#include +#include + +#ifdef AO_SCHEME_MAKE_CONST + +/* + * When building the constant table, it is the + * pool for allocations. + */ + +#include +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, +}; + +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 +int ao_scheme_collects[2]; +int ao_scheme_freed[2]; +int 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..d726321c --- /dev/null +++ b/src/scheme/ao_scheme_poly.c @@ -0,0 +1,118 @@ +/* + * Copyright © 2016 Keith Packard + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation, either version 2 of the License, or + * (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, but + * WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + * General Public License for more details. + */ + +#include "ao_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, + }, +}; + +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..6b1e9d66 --- /dev/null +++ b/src/scheme/ao_scheme_read.c @@ -0,0 +1,655 @@ +/* + * Copyright © 2016 Keith Packard + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation, either version 2 of the License, or + * (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, but + * WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + * General Public License for more details. + */ + +#include "ao_scheme.h" +#include "ao_scheme_read.h" +#include +#include + +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() +{ + 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 32 + +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 '\\': + 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; + +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; + +#define READ_IN_QUOTE 0x01 +#define READ_SAW_DOT 0x02 +#define READ_DONE_DOT 0x04 + +static int +push_read_stack(int cons, int read_state) +{ + RDBGI("push read stack %p 0x%x\n", ao_scheme_read_cons, read_state); + RDBG_IN(); + if (cons) { + 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; + } + ao_scheme_read_cons = NULL; + ao_scheme_read_cons_tail = NULL; + return 1; +} + +static int +pop_read_stack(int cons) +{ + int read_state = 0; + if (cons) { + 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; + } + 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 cons; + int read_state; + ao_poly v = AO_SCHEME_NIL; + + cons = 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) { + if (!push_read_stack(cons, read_state)) + return AO_SCHEME_NIL; + cons++; + read_state = 0; + parse_token = lex(); + } + + switch (parse_token) { + case END: + default: + if (cons) + 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(cons, read_state)) + return AO_SCHEME_NIL; + cons++; + 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 (!cons) { + v = AO_SCHEME_NIL; + break; + } + v = ao_scheme_cons_poly(ao_scheme_read_cons); + --cons; + read_state = pop_read_stack(cons); + break; + case DOT: + if (!cons) { + 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 (!cons) + 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); + --cons; + read_state = pop_read_stack(cons); + } + } + return v; +} diff --git a/src/scheme/ao_scheme_read.h b/src/scheme/ao_scheme_read.h new file mode 100644 index 00000000..e9508835 --- /dev/null +++ b/src/scheme/ao_scheme_read.h @@ -0,0 +1,58 @@ +/* + * Copyright © 2016 Keith Packard + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation, either version 2 of the License, or + * (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, but + * WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + * General Public License for more details. + */ + +#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 + +/* + * 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/scheme/ao_scheme_rep.c b/src/scheme/ao_scheme_rep.c new file mode 100644 index 00000000..9dbce5f2 --- /dev/null +++ b/src/scheme/ao_scheme_rep.c @@ -0,0 +1,36 @@ +/* + * Copyright © 2016 Keith Packard + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation, either version 2 of the License, or + * (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, but + * WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + * General Public License for more details. + */ + +#include "ao_scheme.h" + +ao_poly +ao_scheme_read_eval_print(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) { + if (ao_scheme_exception & AO_SCHEME_EXIT) + break; + ao_scheme_exception = 0; + } else { + ao_scheme_poly_write(out); + putchar ('\n'); + } + } + return out; +} 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 + * + * 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 + * + * 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/scheme/ao_scheme_string.c b/src/scheme/ao_scheme_string.c new file mode 100644 index 00000000..e25306cb --- /dev/null +++ b/src/scheme/ao_scheme_string.c @@ -0,0 +1,161 @@ +/* + * Copyright © 2016 Keith Packard + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation; 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 void string_mark(void *addr) +{ + (void) addr; +} + +static int string_size(void *addr) +{ + if (!addr) + return 0; + return strlen(addr) + 1; +} + +static void string_move(void *addr) +{ + (void) addr; +} + +const struct ao_scheme_type ao_scheme_string_type = { + .mark = string_mark, + .size = string_size, + .move = string_move, + .name = "string", +}; + +char * +ao_scheme_string_copy(char *a) +{ + int alen = strlen(a); + + 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); + return r; +} + +char * +ao_scheme_string_cat(char *a, char *b) +{ + int alen = strlen(a); + int blen = strlen(b); + + 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); + strcpy(r+alen, b); + return r; +} + +ao_poly +ao_scheme_string_pack(struct ao_scheme_cons *cons) +{ + 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_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_scheme_string_poly(r); +} + +ao_poly +ao_scheme_string_unpack(char *a) +{ + struct ao_scheme_cons *cons = NULL, *tail = NULL; + int c; + int i; + + for (i = 0; (c = a[i]); i++) { + 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_scheme_cons_poly(n); + else + cons = n; + tail = n; + } + return ao_scheme_cons_poly(cons); +} + +void +ao_scheme_string_write(ao_poly p) +{ + char *s = ao_scheme_poly_string(p); + char c; + + putchar('"'); + while ((c = *s++)) { + switch (c) { + case '\n': + printf ("\\n"); + break; + case '\r': + printf ("\\r"); + break; + case '\t': + printf ("\\t"); + break; + default: + if (c < ' ') + printf("\\%03o", c); + else + putchar(c); + break; + } + } + putchar('"'); +} + +void +ao_scheme_string_display(ao_poly p) +{ + char *s = ao_scheme_poly_string(p); + char c; + + while ((c = *s++)) + putchar(c); +} 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/scheme/make-const/ao_scheme_os.h b/src/scheme/make-const/ao_scheme_os.h new file mode 100644 index 00000000..f06bbbb1 --- /dev/null +++ b/src/scheme/make-const/ao_scheme_os.h @@ -0,0 +1,63 @@ +/* + * Copyright © 2016 Keith Packard + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation; 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 +#include +#include + +extern int ao_scheme_getc(void); + +static inline void +ao_scheme_os_flush(void) { + fflush(stdout); +} + +static inline void +ao_scheme_abort(void) +{ + abort(); +} + +static inline void +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_scheme_os_delay(int jiffies) +{ + struct timespec ts = { + .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/test/ao_lisp_os.h b/src/test/ao_lisp_os.h deleted file mode 100644 index ebd16bb4..00000000 --- a/src/test/ao_lisp_os.h +++ /dev/null @@ -1,68 +0,0 @@ -/* - * Copyright © 2016 Keith Packard - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation; 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_LISP_OS_H_ -#define _AO_LISP_OS_H_ - -#include -#include -#include - -#define AO_LISP_POOL_TOTAL 16384 -#define AO_LISP_SAVE 1 -#define DBG_MEM_STATS 1 - -extern int ao_lisp_getc(void); - -static inline void -ao_lisp_os_flush() { - fflush(stdout); -} - -static inline void -ao_lisp_abort(void) -{ - abort(); -} - -static inline void -ao_lisp_os_led(int led) -{ - printf("leds set to 0x%x\n", led); -} - -#define AO_LISP_JIFFIES_PER_SECOND 100 - -static inline void -ao_lisp_os_delay(int jiffies) -{ - struct timespec ts = { - .tv_sec = jiffies / AO_LISP_JIFFIES_PER_SECOND, - .tv_nsec = (jiffies % AO_LISP_JIFFIES_PER_SECOND) * (1000000000L / AO_LISP_JIFFIES_PER_SECOND) - }; - nanosleep(&ts, NULL); -} - -static inline int -ao_lisp_os_jiffy(void) -{ - struct timespec tp; - clock_gettime(CLOCK_MONOTONIC, &tp); - return tp.tv_sec * AO_LISP_JIFFIES_PER_SECOND + (tp.tv_nsec / (1000000000L / AO_LISP_JIFFIES_PER_SECOND)); -} - -#endif 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 - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation, either version 2 of the License, or - * (at your option) any later version. - * - * This program is distributed in the hope that it will be useful, but - * WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU - * General Public License for more details. - */ - -#include "ao_lisp.h" -#include - -static 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/ao_scheme_os.h b/src/test/ao_scheme_os.h new file mode 100644 index 00000000..ebd16bb4 --- /dev/null +++ b/src/test/ao_scheme_os.h @@ -0,0 +1,68 @@ +/* + * Copyright © 2016 Keith Packard + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation; 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_LISP_OS_H_ +#define _AO_LISP_OS_H_ + +#include +#include +#include + +#define AO_LISP_POOL_TOTAL 16384 +#define AO_LISP_SAVE 1 +#define DBG_MEM_STATS 1 + +extern int ao_lisp_getc(void); + +static inline void +ao_lisp_os_flush() { + fflush(stdout); +} + +static inline void +ao_lisp_abort(void) +{ + abort(); +} + +static inline void +ao_lisp_os_led(int led) +{ + printf("leds set to 0x%x\n", led); +} + +#define AO_LISP_JIFFIES_PER_SECOND 100 + +static inline void +ao_lisp_os_delay(int jiffies) +{ + struct timespec ts = { + .tv_sec = jiffies / AO_LISP_JIFFIES_PER_SECOND, + .tv_nsec = (jiffies % AO_LISP_JIFFIES_PER_SECOND) * (1000000000L / AO_LISP_JIFFIES_PER_SECOND) + }; + nanosleep(&ts, NULL); +} + +static inline int +ao_lisp_os_jiffy(void) +{ + struct timespec tp; + clock_gettime(CLOCK_MONOTONIC, &tp); + return tp.tv_sec * AO_LISP_JIFFIES_PER_SECOND + (tp.tv_nsec / (1000000000L / AO_LISP_JIFFIES_PER_SECOND)); +} + +#endif diff --git a/src/test/ao_scheme_test.c b/src/test/ao_scheme_test.c new file mode 100644 index 00000000..68e3a202 --- /dev/null +++ b/src/test/ao_scheme_test.c @@ -0,0 +1,134 @@ +/* + * Copyright © 2016 Keith Packard + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation, either version 2 of the License, or + * (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, but + * WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + * General Public License for more details. + */ + +#include "ao_lisp.h" +#include + +static 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]); +} -- cgit v1.2.3 From bd7a19a86f6d4fe19c7e72904e9b8ac0f2081ff7 Mon Sep 17 00:00:00 2001 From: Keith Packard Date: Tue, 5 Dec 2017 10:38:14 -0800 Subject: altos/scheme: Move scheme test program to scheme sub-directory Keeps it away from the usual test setup Signed-off-by: Keith Packard --- src/scheme/Makefile | 6 +- src/scheme/test/.gitignore | 1 + src/scheme/test/ao_scheme_os.h | 68 +++++++++++++++ src/scheme/test/ao_scheme_test.c | 139 +++++++++++++++++++++++++++++++ src/scheme/test/hanoi.scheme | 174 +++++++++++++++++++++++++++++++++++++++ src/test/Makefile | 21 +---- src/test/ao_scheme_os.h | 68 --------------- src/test/ao_scheme_test.c | 134 ------------------------------ src/test/hanoi.lisp | 151 --------------------------------- 9 files changed, 391 insertions(+), 371 deletions(-) create mode 100644 src/scheme/test/.gitignore create mode 100644 src/scheme/test/ao_scheme_os.h create mode 100644 src/scheme/test/ao_scheme_test.c create mode 100644 src/scheme/test/hanoi.scheme delete mode 100644 src/test/ao_scheme_os.h delete mode 100644 src/test/ao_scheme_test.c delete mode 100644 src/test/hanoi.lisp (limited to 'src') diff --git a/src/scheme/Makefile b/src/scheme/Makefile index d8e4b553..e3174be8 100644 --- a/src/scheme/Makefile +++ b/src/scheme/Makefile @@ -1,7 +1,8 @@ -all: ao_scheme_builtin.h ao_scheme_const.h +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.lisp make-const/ao_scheme_make_const @@ -13,4 +14,7 @@ ao_scheme_builtin.h: ao_scheme_make_builtin ao_scheme_builtin.txt make-const/ao_scheme_make_const: FRC +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/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/ao_scheme_os.h b/src/scheme/test/ao_scheme_os.h new file mode 100644 index 00000000..09a945bc --- /dev/null +++ b/src/scheme/test/ao_scheme_os.h @@ -0,0 +1,68 @@ +/* + * Copyright © 2016 Keith Packard + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation; 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 +#include +#include + +#define AO_SCHEME_POOL_TOTAL 16384 +#define AO_SCHEME_SAVE 1 +#define DBG_MEM_STATS 1 + +extern int ao_scheme_getc(void); + +static inline void +ao_scheme_os_flush() { + fflush(stdout); +} + +static inline void +ao_scheme_abort(void) +{ + abort(); +} + +static inline void +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_scheme_os_delay(int jiffies) +{ + struct timespec ts = { + .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..15c71203 --- /dev/null +++ b/src/scheme/test/ao_scheme_test.c @@ -0,0 +1,139 @@ +/* + * Copyright © 2016 Keith Packard + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation, either version 2 of the License, or + * (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, but + * WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + * General Public License for more details. + */ + +#include "ao_scheme.h" +#include + +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_stack) + 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: %d incremental %d\n", + ao_scheme_collects[AO_SCHEME_COLLECT_FULL], + ao_scheme_collects[AO_SCHEME_COLLECT_INCREMENTAL]); + + printf ("freed: full %d incremental %d\n", + ao_scheme_freed[AO_SCHEME_COLLECT_FULL], + ao_scheme_freed[AO_SCHEME_COLLECT_INCREMENTAL]); + + printf("loops: full %d incremental %d\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 +; +; 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/test/Makefile b/src/test/Makefile index 4ac2c893..7bd13db9 100644 --- a/src/test/Makefile +++ b/src/test/Makefile @@ -1,13 +1,13 @@ vpath %.o . -vpath %.c ..:../kernel:../drivers:../util:../micropeak:../aes:../product:../lisp -vpath %.h ..:../kernel:../drivers:../util:../micropeak:../aes:../product:../lisp -vpath make-kalman ..:../kernel:../drivers:../util:../micropeak:../aes:../product:../lisp +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 @@ -97,16 +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 -include ../lisp/Makefile-inc - -AO_LISP_SRCS=$(LISP_SRCS) ao_lisp_test.c - -AO_LISP_OBJS=$(AO_LISP_SRCS:.c=.o) - -ao_lisp_test: $(AO_LISP_OBJS) - cc $(CFLAGS) -o $@ $(AO_LISP_OBJS) -lm - -$(AO_LISP_OBJS): $(LISP_HDRS) ao_lisp_const.h - -clean:: - rm -f $(AO_LISP_OBJS) diff --git a/src/test/ao_scheme_os.h b/src/test/ao_scheme_os.h deleted file mode 100644 index ebd16bb4..00000000 --- a/src/test/ao_scheme_os.h +++ /dev/null @@ -1,68 +0,0 @@ -/* - * Copyright © 2016 Keith Packard - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation; 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_LISP_OS_H_ -#define _AO_LISP_OS_H_ - -#include -#include -#include - -#define AO_LISP_POOL_TOTAL 16384 -#define AO_LISP_SAVE 1 -#define DBG_MEM_STATS 1 - -extern int ao_lisp_getc(void); - -static inline void -ao_lisp_os_flush() { - fflush(stdout); -} - -static inline void -ao_lisp_abort(void) -{ - abort(); -} - -static inline void -ao_lisp_os_led(int led) -{ - printf("leds set to 0x%x\n", led); -} - -#define AO_LISP_JIFFIES_PER_SECOND 100 - -static inline void -ao_lisp_os_delay(int jiffies) -{ - struct timespec ts = { - .tv_sec = jiffies / AO_LISP_JIFFIES_PER_SECOND, - .tv_nsec = (jiffies % AO_LISP_JIFFIES_PER_SECOND) * (1000000000L / AO_LISP_JIFFIES_PER_SECOND) - }; - nanosleep(&ts, NULL); -} - -static inline int -ao_lisp_os_jiffy(void) -{ - struct timespec tp; - clock_gettime(CLOCK_MONOTONIC, &tp); - return tp.tv_sec * AO_LISP_JIFFIES_PER_SECOND + (tp.tv_nsec / (1000000000L / AO_LISP_JIFFIES_PER_SECOND)); -} - -#endif diff --git a/src/test/ao_scheme_test.c b/src/test/ao_scheme_test.c deleted file mode 100644 index 68e3a202..00000000 --- a/src/test/ao_scheme_test.c +++ /dev/null @@ -1,134 +0,0 @@ -/* - * Copyright © 2016 Keith Packard - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation, either version 2 of the License, or - * (at your option) any later version. - * - * This program is distributed in the hope that it will be useful, but - * WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU - * General Public License for more details. - */ - -#include "ao_lisp.h" -#include - -static 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 4afde883..00000000 --- a/src/test/hanoi.lisp +++ /dev/null @@ -1,151 +0,0 @@ -; -; Towers of Hanoi -; -; Copyright © 2016 Keith Packard -; -; This program is free software; you can redistribute it and/or modify -; it under the terms of the GNU General Public License as published by -; the Free Software Foundation, either version 2 of the License, or -; (at your option) any later version. -; -; This program is distributed in the hope that it will be useful, but -; WITHOUT ANY WARRANTY; without even the implied warranty of -; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -; General Public License for more details. -; - - ; 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) - ) - - ; Here's the pieces to display - -(define tower '(" * " " *** " " ***** " " ******* " " ********* " "***********")) - - ; Here's all of the towers of pieces - ; This is generated when the program is run - -(define towers ()) - -(define (one- x) (- x 1)) -(define (one+ x) (+ x 1)) - ; 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 (one+ y) 0 (cdr tower)) - ) - ) - ) - (else - (display-string x y " ") - (display-tower x (one+ y) (one- clear) tower) - ) - ) - ) - - ; Position of the top of the tower on the screen - ; Shorter towers start further down the screen - -(define (tower-pos y tower) - (- y (length tower)) - ) - - ; Display all of the towers, spaced 20 columns apart - -(define (display-towers x y towers) - (cond ((not (null? towers)) - (display-tower x 0 (tower-pos y (car towers)) (car towers)) - (display-towers (+ x 20) y (cdr towers))) - ) - ) - -(define top 0) - ; Display all of the towers, then move the cursor - ; out of the way and flush the output - -(define (display-hanoi) - (display-towers 0 top towers) - (move-to 1 21) - (flush-output) - ) - - ; Reset towers to the starting state, with - ; all of the pieces in the first tower and the - ; other two empty - -(define (reset-towers) - (set! towers (list tower () ())) - (set! top (+ (length tower) 3)) - (length tower) - ) - - ; Replace a tower in the list of towers - ; with a new value - -(define (replace list pos member) - (cond ((= pos 0) (cons member (cdr list))) - (else (cons (car list) (replace (cdr list) (one- pos) member))) - ) - ) - - ; Move a piece from the top of one tower - ; to the top of another - -(define move-delay 10) - -(define (move-piece from to) - (let* ((from-tower (list-ref towers from)) - (to-tower (list-ref towers to)) - (piece (car from-tower))) - (set! from-tower (cdr from-tower)) - (set! to-tower (cons piece to-tower)) - (set! towers (replace towers from from-tower)) - (set! towers (replace towers to to-tower)) - (display-hanoi) - (delay move-delay) - ) - ) - -; The implementation of the game - -(define (_hanoi n from to use) - (cond ((= 1 n) - (move-piece from to) - ) - (else - (_hanoi (one- n) from use to) - (_hanoi 1 from to use) - (_hanoi (one- n) use to from) - ) - ) - ) - - ; A pretty interface which - ; resets the state of the game, - ; clears the screen and runs - ; the program - -(define (hanoi) - (let ((len (reset-towers))) - (clear) - (_hanoi len 0 1 2) - (move-to 0 23) - #t - ) - ) - ) -- cgit v1.2.3 From 038581bd212e66bcf017c7ace28c80a3ae0d0f50 Mon Sep 17 00:00:00 2001 From: Keith Packard Date: Tue, 5 Dec 2017 10:42:02 -0800 Subject: altos/scheme: Add explicit dependency on ao_scheme_builtin.h for ao_scheme_make_const This ensures that a parallel build will wait for ao_scheme_builtin.h to be complete before attempting to compile ao_scheme_make_const Signed-off-by: Keith Packard --- src/scheme/Makefile | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'src') diff --git a/src/scheme/Makefile b/src/scheme/Makefile index e3174be8..ea94c1c0 100644 --- a/src/scheme/Makefile +++ b/src/scheme/Makefile @@ -11,7 +11,7 @@ ao_scheme_const.h: ao_scheme_const.lisp make-const/ao_scheme_make_const 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 +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 -- cgit v1.2.3 From 2aa02234b1ac2b1701b44fcec9e9bd82bea526b7 Mon Sep 17 00:00:00 2001 From: Keith Packard Date: Tue, 5 Dec 2017 10:48:04 -0800 Subject: altos/cortexelf-v1: Adapt to lisp->scheme name change Signed-off-by: Keith Packard --- src/cortexelf-v1/.gitignore | 3 ++ src/cortexelf-v1/Makefile | 44 ++++++++------------ src/cortexelf-v1/ao_cortexelf.c | 8 ++-- src/cortexelf-v1/ao_lisp_os.h | 79 ------------------------------------ src/cortexelf-v1/ao_lisp_os_save.c | 53 ------------------------ src/cortexelf-v1/ao_scheme_os.h | 79 ++++++++++++++++++++++++++++++++++++ src/cortexelf-v1/ao_scheme_os_save.c | 53 ++++++++++++++++++++++++ src/scheme/Makefile-scheme | 6 +-- src/stm/Makefile.defs | 2 +- 9 files changed, 161 insertions(+), 166 deletions(-) create mode 100644 src/cortexelf-v1/.gitignore delete mode 100644 src/cortexelf-v1/ao_lisp_os.h delete mode 100644 src/cortexelf-v1/ao_lisp_os_save.c create mode 100644 src/cortexelf-v1/ao_scheme_os.h create mode 100644 src/cortexelf-v1/ao_scheme_os_save.c (limited to 'src') 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 be225e57..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,24 +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_bool.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) @@ -100,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) @@ -131,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 #include #include -#include +#include #include #include #include @@ -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_lisp_os.h b/src/cortexelf-v1/ao_lisp_os.h deleted file mode 100644 index 27ea7806..00000000 --- a/src/cortexelf-v1/ao_lisp_os.h +++ /dev/null @@ -1,79 +0,0 @@ -/* - * Copyright © 2016 Keith Packard - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation; 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_LISP_OS_H_ -#define _AO_LISP_OS_H_ - -#include "ao.h" - -#define AO_LISP_POOL_TOTAL 16384 -#define AO_LISP_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() { - 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_lisp_os_flush(void) -{ - flush(); -} - -static inline void -ao_lisp_abort(void) -{ - ao_panic(1); -} - -static inline void -ao_lisp_os_led(int led) -{ - (void) led; -} - -#define AO_LISP_JIFFIES_PER_SECOND AO_HERTZ - -static inline void -ao_lisp_os_delay(int delay) -{ - ao_delay(delay); -} - -static inline int -ao_lisp_os_jiffy(void) -{ - return ao_tick_count; -} - -#endif diff --git a/src/cortexelf-v1/ao_lisp_os_save.c b/src/cortexelf-v1/ao_lisp_os_save.c deleted file mode 100644 index 7c853990..00000000 --- a/src/cortexelf-v1/ao_lisp_os_save.c +++ /dev/null @@ -1,53 +0,0 @@ -/* - * Copyright © 2016 Keith Packard - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation, either version 2 of the License, or - * (at your option) any later version. - * - * This program is distributed in the hope that it will be useful, but - * WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU - * General Public License for more details. - */ - -#include -#include -#include - -extern uint8_t __flash__[]; - -/* saved variables to rebuild the heap - - ao_lisp_atoms - ao_lisp_frame_global - */ - -int -ao_lisp_os_save(void) -{ - int i; - - for (i = 0; i < AO_LISP_POOL_TOTAL; i += 256) { - uint32_t *dst = (uint32_t *) (void *) &__flash__[i]; - uint32_t *src = (uint32_t *) (void *) &ao_lisp_pool[i]; - - ao_flash_page(dst, src); - } - return 1; -} - -int -ao_lisp_os_restore_save(struct ao_lisp_os_save *save, int offset) -{ - memcpy(save, &__flash__[offset], sizeof (struct ao_lisp_os_save)); - return 1; -} - -int -ao_lisp_os_restore(void) -{ - memcpy(ao_lisp_pool, __flash__, AO_LISP_POOL_TOTAL); - return 1; -} diff --git a/src/cortexelf-v1/ao_scheme_os.h b/src/cortexelf-v1/ao_scheme_os.h new file mode 100644 index 00000000..58e4f5b3 --- /dev/null +++ b/src/cortexelf-v1/ao_scheme_os.h @@ -0,0 +1,79 @@ +/* + * Copyright © 2016 Keith Packard + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation; 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_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_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) +{ + (void) 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/cortexelf-v1/ao_scheme_os_save.c b/src/cortexelf-v1/ao_scheme_os_save.c new file mode 100644 index 00000000..4cec79c6 --- /dev/null +++ b/src/cortexelf-v1/ao_scheme_os_save.c @@ -0,0 +1,53 @@ +/* + * Copyright © 2016 Keith Packard + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation, either version 2 of the License, or + * (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, but + * WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + * General Public License for more details. + */ + +#include +#include +#include + +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/scheme/Makefile-scheme b/src/scheme/Makefile-scheme index 2427cffa..b9018e19 100644 --- a/src/scheme/Makefile-scheme +++ b/src/scheme/Makefile-scheme @@ -1,4 +1,4 @@ -include ../lisp/Makefile-inc +include ../scheme/Makefile-inc -ao_scheme_const.h: $(LISP_SRCS) $(LISP_HDRS) - +cd ../lisp && make $@ +ao_scheme_const.h: $(SCHEME_SRCS) $(SCHEME_HDRS) + +cd ../scheme && make $@ 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 -- cgit v1.2.3 From 185b11367cd85948885fceafb5d46303b6f1356d Mon Sep 17 00:00:00 2001 From: Keith Packard Date: Tue, 5 Dec 2017 12:22:34 -0800 Subject: altos/drivers: Start adding defines to get mag data out of MPU9250 Signed-off-by: Keith Packard --- src/drivers/ao_mpu9250.h | 71 ++++++++++++++++++++++++++++++++++++++++-------- 1 file changed, 60 insertions(+), 11 deletions(-) (limited to 'src') diff --git a/src/drivers/ao_mpu9250.h b/src/drivers/ao_mpu9250.h index a124d799..df1be7c7 100644 --- a/src/drivers/ao_mpu9250.h +++ b/src/drivers/ao_mpu9250.h @@ -102,21 +102,67 @@ # 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_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_DI 0x35 + +#define MPU9250_I2C_MST_STATUS 0x36 + +#define MPU9250_INT_PIN_CFG 0x37 + #define MPU9250_INT_ENABLE 0x38 -#define MPU9250_INT_ENABLE_FF_EN 7 -#define MPU9250_INT_ENABLE_MOT_EN 6 -#define MPU9250_INT_ENABLE_ZMOT_EN 5 +#define MPU9250_INT_ENABLE_WOM_EN 6 #define MPU9250_INT_ENABLE_FIFO_OFLOW_EN 4 -#define MPU9250_INT_ENABLE_I2C_MST_INT_EN 3 -#define MPU9250_INT_ENABLE_DATA_RDY_EN 0 +#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_FF_EN 7 -#define MPU9250_INT_STATUS_MOT_EN 6 -#define MPU9250_INT_STATUS_ZMOT_EN 5 -#define MPU9250_INT_STATUS_FIFO_OFLOW_EN 4 -#define MPU9250_INT_STATUS_I2C_MST_INT_EN 3 -#define MPU9250_INT_STATUS_DATA_RDY_EN 0 +#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 @@ -194,6 +240,9 @@ struct ao_mpu9250_sample { 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; -- cgit v1.2.3 From 1133130986a78628ea297ce1f6a023baf4382d8f Mon Sep 17 00:00:00 2001 From: Keith Packard Date: Sat, 9 Dec 2017 16:56:20 -0800 Subject: altos/scheme: Let readline know if there's a list in progress This lets the interactive prompt change based on what state the lexer is in Signed-off-by: Keith Packard --- src/scheme/ao_scheme.h | 6 +- src/scheme/ao_scheme_builtin.c | 2 +- src/scheme/ao_scheme_const.scheme | 813 ++++++++++++++++++++++++++++++++++++++ src/scheme/ao_scheme_float.c | 6 +- src/scheme/ao_scheme_read.c | 40 +- src/scheme/test/ao_scheme_test.c | 2 +- 6 files changed, 845 insertions(+), 24 deletions(-) create mode 100644 src/scheme/ao_scheme_const.scheme (limited to 'src') diff --git a/src/scheme/ao_scheme.h b/src/scheme/ao_scheme.h index 4589f8a5..10518716 100644 --- a/src/scheme/ao_scheme.h +++ b/src/scheme/ao_scheme.h @@ -31,7 +31,7 @@ typedef uint16_t ao_poly; typedef int16_t ao_signed_poly; -#ifdef AO_SCHEME_SAVE +#if AO_SCHEME_SAVE struct ao_scheme_os_save { ao_poly atoms; @@ -77,6 +77,9 @@ extern uint8_t ao_scheme_const[AO_SCHEME_POOL_CONST] __attribute__((aligned(4))) #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 @@ -745,6 +748,7 @@ 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; diff --git a/src/scheme/ao_scheme_builtin.c b/src/scheme/ao_scheme_builtin.c index 49f218f6..aa818646 100644 --- a/src/scheme/ao_scheme_builtin.c +++ b/src/scheme/ao_scheme_builtin.c @@ -636,7 +636,7 @@ ao_scheme_do_collect(struct ao_scheme_cons *cons) int free; (void) cons; free = ao_scheme_collect(AO_SCHEME_COLLECT_FULL); - return ao_scheme_int_poly(free); + return ao_scheme_integer_poly(free); } ao_poly diff --git a/src/scheme/ao_scheme_const.scheme b/src/scheme/ao_scheme_const.scheme new file mode 100644 index 00000000..422bdd63 --- /dev/null +++ b/src/scheme/ao_scheme_const.scheme @@ -0,0 +1,813 @@ +; +; Copyright © 2016 Keith Packard +; +; This program is free software; you can redistribute it and/or modify +; it under the terms of the GNU General Public License as published by +; the Free Software Foundation, either version 2 of the License, or +; (at your option) any later version. +; +; This program is distributed in the hope that it will be useful, but +; WITHOUT ANY WARRANTY; without even the implied warranty of +; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +; General Public License for more details. +; +; 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 ) + ; (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 c) 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_float.c b/src/scheme/ao_scheme_float.c index 541f0264..99249030 100644 --- a/src/scheme/ao_scheme_float.c +++ b/src/scheme/ao_scheme_float.c @@ -39,6 +39,10 @@ const struct ao_scheme_type ao_scheme_float_type = { .name = "float", }; +#ifndef FLOAT_FORMAT +#define FLOAT_FORMAT "%g" +#endif + void ao_scheme_float_write(ao_poly p) { @@ -54,7 +58,7 @@ ao_scheme_float_write(ao_poly p) printf("+"); printf("inf.0"); } else - printf ("%g", f->value); + printf (FLOAT_FORMAT, v); } float diff --git a/src/scheme/ao_scheme_read.c b/src/scheme/ao_scheme_read.c index 6b1e9d66..30e29441 100644 --- a/src/scheme/ao_scheme_read.c +++ b/src/scheme/ao_scheme_read.c @@ -151,7 +151,7 @@ static const uint16_t lex_classes[128] = { static int lex_unget_c; static inline int -lex_get() +lex_get(void) { int c; if (lex_unget_c) { @@ -244,7 +244,7 @@ lex_quoted(void) } } -#define AO_SCHEME_TOKEN_MAX 32 +#define AO_SCHEME_TOKEN_MAX 128 static char token_string[AO_SCHEME_TOKEN_MAX]; static int32_t token_int; @@ -470,6 +470,7 @@ static inline int lex(void) 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; @@ -479,11 +480,11 @@ struct ao_scheme_cons *ao_scheme_read_stack; #define READ_DONE_DOT 0x04 static int -push_read_stack(int cons, int read_state) +push_read_stack(int read_state) { RDBGI("push read stack %p 0x%x\n", ao_scheme_read_cons, read_state); RDBG_IN(); - if (cons) { + 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))); @@ -496,10 +497,10 @@ push_read_stack(int cons, int read_state) } static int -pop_read_stack(int cons) +pop_read_stack(void) { int read_state = 0; - if (cons) { + 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); @@ -523,19 +524,18 @@ ao_scheme_read(void) { struct ao_scheme_atom *atom; char *string; - int cons; int read_state; ao_poly v = AO_SCHEME_NIL; - cons = 0; + 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) { - if (!push_read_stack(cons, read_state)) + if (!push_read_stack(read_state)) return AO_SCHEME_NIL; - cons++; + ao_scheme_read_list++; read_state = 0; parse_token = lex(); } @@ -543,7 +543,7 @@ ao_scheme_read(void) switch (parse_token) { case END: default: - if (cons) + if (ao_scheme_read_list) ao_scheme_error(AO_SCHEME_EOF, "unexpected end of file"); return _ao_scheme_atom_eof; break; @@ -577,9 +577,9 @@ ao_scheme_read(void) case QUASIQUOTE: case UNQUOTE: case UNQUOTE_SPLICING: - if (!push_read_stack(cons, read_state)) + if (!push_read_stack(read_state)) return AO_SCHEME_NIL; - cons++; + ao_scheme_read_list++; read_state = READ_IN_QUOTE; switch (parse_token) { case QUOTE: @@ -597,16 +597,16 @@ ao_scheme_read(void) } break; case CLOSE: - if (!cons) { + if (!ao_scheme_read_list) { v = AO_SCHEME_NIL; break; } v = ao_scheme_cons_poly(ao_scheme_read_cons); - --cons; - read_state = pop_read_stack(cons); + --ao_scheme_read_list; + read_state = pop_read_stack(); break; case DOT: - if (!cons) { + if (!ao_scheme_read_list) { ao_scheme_error(AO_SCHEME_INVALID, ". outside of cons"); return AO_SCHEME_NIL; } @@ -620,7 +620,7 @@ ao_scheme_read(void) /* loop over QUOTE ends */ for (;;) { - if (!cons) + if (!ao_scheme_read_list) return v; if (read_state & READ_DONE_DOT) { @@ -647,8 +647,8 @@ ao_scheme_read(void) break; v = ao_scheme_cons_poly(ao_scheme_read_cons); - --cons; - read_state = pop_read_stack(cons); + --ao_scheme_read_list; + read_state = pop_read_stack(); } } return v; diff --git a/src/scheme/test/ao_scheme_test.c b/src/scheme/test/ao_scheme_test.c index 15c71203..686e7169 100644 --- a/src/scheme/test/ao_scheme_test.c +++ b/src/scheme/test/ao_scheme_test.c @@ -78,7 +78,7 @@ ao_scheme_getc(void) return getc(ao_scheme_file); if (newline) { - if (ao_scheme_read_stack) + if (ao_scheme_read_list) printf("+ "); else printf("> "); -- cgit v1.2.3 From 0d3365e2c04793cd8432c30a66881f53385a2e60 Mon Sep 17 00:00:00 2001 From: Keith Packard Date: Sun, 10 Dec 2017 00:00:23 -0800 Subject: altos/scheme: Fix name of constant scheme file .lisp -> .scheme Signed-off-by: Keith Packard --- src/scheme/Makefile | 4 ++-- src/scheme/ao_scheme_const.scheme | 2 +- 2 files changed, 3 insertions(+), 3 deletions(-) (limited to 'src') diff --git a/src/scheme/Makefile b/src/scheme/Makefile index ea94c1c0..dc36dde1 100644 --- a/src/scheme/Makefile +++ b/src/scheme/Makefile @@ -5,8 +5,8 @@ clean: +cd test && make clean rm -f ao_scheme_const.h ao_scheme_builtin.h -ao_scheme_const.h: ao_scheme_const.lisp make-const/ao_scheme_make_const - make-const/ao_scheme_make_const -o $@ ao_scheme_const.lisp +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 > $@ diff --git a/src/scheme/ao_scheme_const.scheme b/src/scheme/ao_scheme_const.scheme index 422bdd63..ab6a309a 100644 --- a/src/scheme/ao_scheme_const.scheme +++ b/src/scheme/ao_scheme_const.scheme @@ -641,7 +641,7 @@ (char-whitespace? #\space) (define (char->integer c) c) -(define (integer->char c) char-integer) +(define integer->char char->integer) (define (char-upcase c) (if (char-lower-case? c) (+ c (- #\A #\a)) c)) -- cgit v1.2.3 From 17fe6de833cccb6d43d0ac0ed84a4faaa3463a09 Mon Sep 17 00:00:00 2001 From: Keith Packard Date: Sun, 10 Dec 2017 00:02:00 -0800 Subject: altos/scheme: Add vectors Constant time and smaller can be a feature. Signed-off-by: Keith Packard --- src/scheme/Makefile-inc | 3 +- src/scheme/README | 2 +- src/scheme/ao_scheme.h | 48 ++- src/scheme/ao_scheme_builtin.c | 65 +++- src/scheme/ao_scheme_builtin.txt | 7 + src/scheme/ao_scheme_const.lisp | 813 --------------------------------------- src/scheme/ao_scheme_eval.c | 8 +- src/scheme/ao_scheme_mem.c | 1 + src/scheme/ao_scheme_poly.c | 4 + src/scheme/ao_scheme_read.c | 14 +- src/scheme/ao_scheme_read.h | 1 + 11 files changed, 139 insertions(+), 827 deletions(-) delete mode 100644 src/scheme/ao_scheme_const.lisp (limited to 'src') diff --git a/src/scheme/Makefile-inc b/src/scheme/Makefile-inc index d23ee3d7..1a080a4e 100644 --- a/src/scheme/Makefile-inc +++ b/src/scheme/Makefile-inc @@ -15,7 +15,8 @@ SCHEME_SRCS=\ ao_scheme_rep.c \ ao_scheme_save.c \ ao_scheme_stack.c \ - ao_scheme_error.c + ao_scheme_error.c \ + ao_scheme_vector.c SCHEME_HDRS=\ ao_scheme.h \ diff --git a/src/scheme/README b/src/scheme/README index 98932b44..a18457fd 100644 --- a/src/scheme/README +++ b/src/scheme/README @@ -5,6 +5,6 @@ This follows the R7RS with the following known exceptions: * No dynamic-wind or exceptions * No environments * No ports -* No syntax-rules; (have classic macros) +* No syntax-rules * No record types * No libraries diff --git a/src/scheme/ao_scheme.h b/src/scheme/ao_scheme.h index 10518716..89616617 100644 --- a/src/scheme/ao_scheme.h +++ b/src/scheme/ao_scheme.h @@ -104,7 +104,8 @@ extern uint8_t ao_scheme_pool[AO_SCHEME_POOL + AO_SCHEME_POOL_EXTRA] __attribut #define AO_SCHEME_BOOL 10 #define AO_SCHEME_BIGINT 11 #define AO_SCHEME_FLOAT 12 -#define AO_SCHEME_NUM_TYPE 13 +#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 @@ -192,6 +193,13 @@ struct ao_scheme_float { 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) { @@ -500,6 +508,18 @@ ao_scheme_poly_float(ao_poly 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 int ao_scheme_collects[2]; @@ -680,6 +700,32 @@ 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); diff --git a/src/scheme/ao_scheme_builtin.c b/src/scheme/ao_scheme_builtin.c index aa818646..ae96df7f 100644 --- a/src/scheme/ao_scheme_builtin.c +++ b/src/scheme/ao_scheme_builtin.c @@ -267,7 +267,6 @@ ao_scheme_do_write(struct ao_scheme_cons *cons) if (cons) printf(" "); } - printf("\n"); return _ao_scheme_bool_true; } @@ -751,7 +750,7 @@ ao_poly ao_scheme_do_listp(struct ao_scheme_cons *cons) { ao_poly v; - if (!ao_scheme_check_argc(_ao_scheme_atom_led, cons, 1, 1)) + if (!ao_scheme_check_argc(_ao_scheme_atom_list3f, cons, 1, 1)) return AO_SCHEME_NIL; v = ao_scheme_arg(cons, 0); for (;;) { @@ -864,5 +863,67 @@ ao_scheme_do_jiffies_per_second(struct ao_scheme_cons *cons) 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_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 index cb65e252..e7b3d75c 100644 --- a/src/scheme/ao_scheme_builtin.txt +++ b/src/scheme/ao_scheme_builtin.txt @@ -66,3 +66,10 @@ 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 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_const.lisp b/src/scheme/ao_scheme_const.lisp deleted file mode 100644 index 422bdd63..00000000 --- a/src/scheme/ao_scheme_const.lisp +++ /dev/null @@ -1,813 +0,0 @@ -; -; Copyright © 2016 Keith Packard -; -; This program is free software; you can redistribute it and/or modify -; it under the terms of the GNU General Public License as published by -; the Free Software Foundation, either version 2 of the License, or -; (at your option) any later version. -; -; This program is distributed in the hope that it will be useful, but -; WITHOUT ANY WARRANTY; without even the implied warranty of -; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -; General Public License for more details. -; -; 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 ) - ; (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 c) 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_eval.c b/src/scheme/ao_scheme_eval.c index 9b3cf63e..907ecf0b 100644 --- a/src/scheme/ao_scheme_eval.c +++ b/src/scheme/ao_scheme_eval.c @@ -108,13 +108,7 @@ ao_scheme_eval_sexpr(void) 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 */ - case AO_SCHEME_BOOL: - case AO_SCHEME_INT: - case AO_SCHEME_BIGINT: - case AO_SCHEME_FLOAT: - case AO_SCHEME_STRING: - case AO_SCHEME_BUILTIN: - case AO_SCHEME_LAMBDA: + default: ao_scheme_stack->state = eval_val; break; } diff --git a/src/scheme/ao_scheme_mem.c b/src/scheme/ao_scheme_mem.c index acc726c8..fe4bc4f5 100644 --- a/src/scheme/ao_scheme_mem.c +++ b/src/scheme/ao_scheme_mem.c @@ -467,6 +467,7 @@ static const struct ao_scheme_type * const ao_scheme_types[AO_SCHEME_NUM_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 diff --git a/src/scheme/ao_scheme_poly.c b/src/scheme/ao_scheme_poly.c index d726321c..553585db 100644 --- a/src/scheme/ao_scheme_poly.c +++ b/src/scheme/ao_scheme_poly.c @@ -68,6 +68,10 @@ static const struct ao_scheme_funcs ao_scheme_funcs[AO_SCHEME_NUM_TYPE] = { .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 * diff --git a/src/scheme/ao_scheme_read.c b/src/scheme/ao_scheme_read.c index 30e29441..9ed54b9f 100644 --- a/src/scheme/ao_scheme_read.c +++ b/src/scheme/ao_scheme_read.c @@ -340,6 +340,8 @@ _lex(void) add_token(c); end_token(); return BOOL; + case '(': + return OPEN_VECTOR; case '\\': for (;;) { int alphabetic; @@ -474,10 +476,12 @@ 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) @@ -490,7 +494,8 @@ push_read_stack(int 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; @@ -513,6 +518,7 @@ pop_read_stack(void) 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); @@ -532,7 +538,9 @@ ao_scheme_read(void) ao_scheme_read_cons = ao_scheme_read_cons_tail = ao_scheme_read_stack = 0; for (;;) { parse_token = lex(); - while (parse_token == OPEN) { + 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++; @@ -604,6 +612,8 @@ ao_scheme_read(void) 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) { diff --git a/src/scheme/ao_scheme_read.h b/src/scheme/ao_scheme_read.h index e9508835..e10a7d05 100644 --- a/src/scheme/ao_scheme_read.h +++ b/src/scheme/ao_scheme_read.h @@ -32,6 +32,7 @@ # define FLOAT 10 # define DOT 11 # define BOOL 12 +# define OPEN_VECTOR 13 /* * character classes -- cgit v1.2.3 From abb856cd66e00d739e4efb1930b5c168eaf48029 Mon Sep 17 00:00:00 2001 From: Keith Packard Date: Sun, 10 Dec 2017 00:02:34 -0800 Subject: altos/scheme: Avoid crashing with non-list in length Use ao_scheme_cons_cdr to fetch the next list element as that returns NULL for non-cons elements. Signed-off-by: Keith Packard --- src/scheme/ao_scheme_cons.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'src') diff --git a/src/scheme/ao_scheme_cons.c b/src/scheme/ao_scheme_cons.c index 03dad956..21ee10cc 100644 --- a/src/scheme/ao_scheme_cons.c +++ b/src/scheme/ao_scheme_cons.c @@ -195,7 +195,7 @@ ao_scheme_cons_length(struct ao_scheme_cons *cons) int len = 0; while (cons) { len++; - cons = ao_scheme_poly_cons(cons->cdr); + cons = ao_scheme_cons_cdr(cons); } return len; } -- cgit v1.2.3 From 7e14e243565e814ddd524c8d09454719dc89c6d8 Mon Sep 17 00:00:00 2001 From: Keith Packard Date: Sun, 10 Dec 2017 13:13:27 -0800 Subject: altos/scheme: Add a bunch of string and vector builtins Just make the language closer to r7rs Signed-off-by: Keith Packard --- src/scheme/ao_scheme_builtin.c | 124 ++++++++++++++++++++++++++++++++++++--- src/scheme/ao_scheme_builtin.txt | 19 +++--- 2 files changed, 128 insertions(+), 15 deletions(-) (limited to 'src') diff --git a/src/scheme/ao_scheme_builtin.c b/src/scheme/ao_scheme_builtin.c index ae96df7f..397ce032 100644 --- a/src/scheme/ao_scheme_builtin.c +++ b/src/scheme/ao_scheme_builtin.c @@ -123,10 +123,21 @@ ao_scheme_check_argt(ao_poly name, struct ao_scheme_cons *cons, int argc, int ty 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, "%s: arg %d invalid type %v", ao_scheme_poly_atom(name)->name, argc, car); + 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) { @@ -568,6 +579,88 @@ ao_scheme_do_string_to_list(struct ao_scheme_cons *cons) 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) { @@ -580,10 +673,11 @@ ao_scheme_do_flush_output(struct ao_scheme_cons *cons) ao_poly ao_scheme_do_led(struct ao_scheme_cons *cons) { - ao_poly led; + int32_t led; 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)) + 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)); @@ -593,13 +687,14 @@ ao_scheme_do_led(struct ao_scheme_cons *cons) ao_poly ao_scheme_do_delay(struct ao_scheme_cons *cons) { - ao_poly delay; - if (!ao_scheme_check_argc(_ao_scheme_atom_led, cons, 1, 1)) + int32_t delay; + + if (!ao_scheme_check_argc(_ao_scheme_atom_delay, cons, 1, 1)) return AO_SCHEME_NIL; - if (!ao_scheme_check_argt(_ao_scheme_atom_led, cons, 0, AO_SCHEME_INT, 0)) + delay = ao_scheme_arg_int(_ao_scheme_atom_delay, cons, 0); + if (delay == AO_SCHEME_NOT_INTEGER) return AO_SCHEME_NIL; - delay = ao_scheme_arg(cons, 0); - ao_scheme_os_delay(ao_scheme_poly_int(delay)); + ao_scheme_os_delay(delay); return delay; } @@ -869,6 +964,19 @@ 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) { diff --git a/src/scheme/ao_scheme_builtin.txt b/src/scheme/ao_scheme_builtin.txt index e7b3d75c..b7261ce1 100644 --- a/src/scheme/ao_scheme_builtin.txt +++ b/src/scheme/ao_scheme_builtin.txt @@ -20,7 +20,7 @@ nlambda begin nlambda while f_lambda write f_lambda display -f_lambda plus + +f_lambda plus + string-append f_lambda minus - f_lambda times * f_lambda divide / @@ -28,12 +28,10 @@ f_lambda modulo modulo % f_lambda remainder f_lambda quotient f_lambda equal = eq? eqv? -f_lambda less < -f_lambda greater > -f_lambda less_equal <= -f_lambda greater_equal >= -f_lambda list_to_string list->string -f_lambda string_to_list string->list +f_lambda less < string string>? +f_lambda less_equal <= string<=? +f_lambda greater_equal >= string>=? f_lambda flush_output flush-output f_lambda delay f_lambda led @@ -51,9 +49,15 @@ 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 @@ -69,6 +73,7 @@ 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 -- cgit v1.2.3 From 7517da1646fc30faaa9ee1c969cfa35ae1a17423 Mon Sep 17 00:00:00 2001 From: Keith Packard Date: Sun, 10 Dec 2017 16:50:06 -0800 Subject: altos/scheme: Use 64-bit ints to track memory allocation stats These are only collected for debug purposes, but can get quite large if the interpreter runs for a while. Signed-off-by: Keith Packard --- src/scheme/ao_scheme.h | 6 +++--- src/scheme/ao_scheme_mem.c | 6 +++--- src/scheme/test/ao_scheme_test.c | 6 +++--- 3 files changed, 9 insertions(+), 9 deletions(-) (limited to 'src') diff --git a/src/scheme/ao_scheme.h b/src/scheme/ao_scheme.h index 89616617..4655b2a9 100644 --- a/src/scheme/ao_scheme.h +++ b/src/scheme/ao_scheme.h @@ -522,9 +522,9 @@ ao_scheme_poly_vector(ao_poly poly) /* memory functions */ -extern int ao_scheme_collects[2]; -extern int ao_scheme_freed[2]; -extern int ao_scheme_loops[2]; +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 diff --git a/src/scheme/ao_scheme_mem.c b/src/scheme/ao_scheme_mem.c index fe4bc4f5..45d4de98 100644 --- a/src/scheme/ao_scheme_mem.c +++ b/src/scheme/ao_scheme_mem.c @@ -483,9 +483,9 @@ ao_scheme_poly_mark_ref(ao_poly *p, uint8_t do_note_cons) } #if DBG_MEM_STATS -int ao_scheme_collects[2]; -int ao_scheme_freed[2]; -int ao_scheme_loops[2]; +uint64_t ao_scheme_collects[2]; +uint64_t ao_scheme_freed[2]; +uint64_t ao_scheme_loops[2]; #endif int ao_scheme_last_top; diff --git a/src/scheme/test/ao_scheme_test.c b/src/scheme/test/ao_scheme_test.c index 686e7169..0c77d8d5 100644 --- a/src/scheme/test/ao_scheme_test.c +++ b/src/scheme/test/ao_scheme_test.c @@ -107,15 +107,15 @@ main (int argc, char **argv) } ao_scheme_read_eval_print(); - printf ("collects: full: %d incremental %d\n", + printf ("collects: full: %lu incremental %lu\n", ao_scheme_collects[AO_SCHEME_COLLECT_FULL], ao_scheme_collects[AO_SCHEME_COLLECT_INCREMENTAL]); - printf ("freed: full %d incremental %d\n", + printf ("freed: full %lu incremental %lu\n", ao_scheme_freed[AO_SCHEME_COLLECT_FULL], ao_scheme_freed[AO_SCHEME_COLLECT_INCREMENTAL]); - printf("loops: full %d incremental %d\n", + printf("loops: full %lu incremental %lu\n", ao_scheme_loops[AO_SCHEME_COLLECT_FULL], ao_scheme_loops[AO_SCHEME_COLLECT_INCREMENTAL]); -- cgit v1.2.3 From b72638e60b6636b479b79bbf0047cf7409f58820 Mon Sep 17 00:00:00 2001 From: Keith Packard Date: Sun, 10 Dec 2017 16:51:25 -0800 Subject: altos/scheme: add list-copy A lot easier as a built-in; the obvious scheme version is recursive. Signed-off-by: Keith Packard --- src/scheme/ao_scheme.h | 3 +++ src/scheme/ao_scheme_builtin.c | 13 +++++++++++++ src/scheme/ao_scheme_builtin.txt | 1 + src/scheme/ao_scheme_cons.c | 38 +++++++++++++++++++++++++++++++++++++- 4 files changed, 54 insertions(+), 1 deletion(-) (limited to 'src') diff --git a/src/scheme/ao_scheme.h b/src/scheme/ao_scheme.h index 4655b2a9..2fa1ed60 100644 --- a/src/scheme/ao_scheme.h +++ b/src/scheme/ao_scheme.h @@ -634,6 +634,9 @@ 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; diff --git a/src/scheme/ao_scheme_builtin.c b/src/scheme/ao_scheme_builtin.c index 397ce032..6f9e1390 100644 --- a/src/scheme/ao_scheme_builtin.c +++ b/src/scheme/ao_scheme_builtin.c @@ -197,6 +197,19 @@ ao_scheme_do_length(struct ao_scheme_cons *cons) 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) { diff --git a/src/scheme/ao_scheme_builtin.txt b/src/scheme/ao_scheme_builtin.txt index b7261ce1..17f5ea0c 100644 --- a/src/scheme/ao_scheme_builtin.txt +++ b/src/scheme/ao_scheme_builtin.txt @@ -8,6 +8,7 @@ f_lambda cdr f_lambda cons f_lambda last f_lambda length +f_lambda list_copy list-copy nlambda quote atom quasiquote atom unquote diff --git a/src/scheme/ao_scheme_cons.c b/src/scheme/ao_scheme_cons.c index 21ee10cc..02512e15 100644 --- a/src/scheme/ao_scheme_cons.c +++ b/src/scheme/ao_scheme_cons.c @@ -112,7 +112,7 @@ ao_scheme_cons_cdr(struct ao_scheme_cons *cons) if (cdr == AO_SCHEME_NIL) return NULL; if (ao_scheme_poly_type(cdr) != AO_SCHEME_CONS) { - (void) ao_scheme_error(AO_SCHEME_INVALID, "improper list"); + (void) ao_scheme_error(AO_SCHEME_INVALID, "improper cdr %v", cdr); return NULL; } return ao_scheme_poly_cons(cdr); @@ -124,6 +124,42 @@ 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) { -- cgit v1.2.3 From bdafb4dfad89d92efec37ed826d5f22e9167e717 Mon Sep 17 00:00:00 2001 From: Keith Packard Date: Sun, 10 Dec 2017 16:52:26 -0800 Subject: altos/scheme: Stash cons across value allocation in compare Large ints, strings and floats can cause allocation, requiring that the 'cons' pointer be stashed and retrieved in case it moved. Signed-off-by: Keith Packard --- src/scheme/ao_scheme_builtin.c | 16 +++++++++++++--- 1 file changed, 13 insertions(+), 3 deletions(-) (limited to 'src') diff --git a/src/scheme/ao_scheme_builtin.c b/src/scheme/ao_scheme_builtin.c index 6f9e1390..7a590735 100644 --- a/src/scheme/ao_scheme_builtin.c +++ b/src/scheme/ao_scheme_builtin.c @@ -319,6 +319,7 @@ ao_scheme_math(struct ao_scheme_cons *orig_cons, enum ao_scheme_builtin_id op) if (cons == orig_cons) { ret = car; + ao_scheme_cons_stash(0, cons); if (cons->cdr == AO_SCHEME_NIL) { switch (op) { case builtin_minus: @@ -339,6 +340,7 @@ ao_scheme_math(struct ao_scheme_cons *orig_cons, enum ao_scheme_builtin_id op) 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); @@ -390,7 +392,9 @@ ao_scheme_math(struct ao_scheme_cons *orig_cons, enum ao_scheme_builtin_id op) 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: @@ -416,12 +420,18 @@ ao_scheme_math(struct ao_scheme_cons *orig_cons, enum ao_scheme_builtin_id op) 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) + 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))); + 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"); } -- cgit v1.2.3 From 3e7a703bb2e70a0568b44159b993386f7ec46e04 Mon Sep 17 00:00:00 2001 From: Keith Packard Date: Sun, 10 Dec 2017 16:53:25 -0800 Subject: altos/scheme: Make eqv? work for numbers and strings Large numbers, floats and strings need a value check, not just a comparison between ao_polys Signed-off-by: Keith Packard --- src/scheme/ao_scheme_builtin.c | 44 ++++++++++++++++++++++++++++++++++++++---- 1 file changed, 40 insertions(+), 4 deletions(-) (limited to 'src') diff --git a/src/scheme/ao_scheme_builtin.c b/src/scheme/ao_scheme_builtin.c index 7a590735..1754e677 100644 --- a/src/scheme/ao_scheme_builtin.c +++ b/src/scheme/ao_scheme_builtin.c @@ -492,9 +492,8 @@ ao_scheme_compare(struct ao_scheme_cons *cons, enum ao_scheme_builtin_id op) for (cons = ao_scheme_cons_cdr(cons); cons; cons = ao_scheme_cons_cdr(cons)) { ao_poly right = cons->car; - if (op == builtin_equal) { - if (left != right) - return _ao_scheme_bool_false; + if (op == builtin_equal && left == right) { + ; } else { uint8_t lt = ao_scheme_poly_type(left); uint8_t rt = ao_scheme_poly_type(right); @@ -519,6 +518,38 @@ ao_scheme_compare(struct ao_scheme_cons *cons, enum ao_scheme_builtin_id op) 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; } @@ -542,10 +573,15 @@ ao_scheme_compare(struct ao_scheme_cons *cons, enum ao_scheme_builtin_id op) 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; } -- cgit v1.2.3 From dd2ed58fcdffaff7b5a9ef898affa3e1ec01ef44 Mon Sep 17 00:00:00 2001 From: Keith Packard Date: Sun, 10 Dec 2017 16:54:50 -0800 Subject: altos/scheme: Make test scheme app heap maximum size It's only 32kB. Signed-off-by: Keith Packard --- src/scheme/test/ao_scheme_os.h | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'src') diff --git a/src/scheme/test/ao_scheme_os.h b/src/scheme/test/ao_scheme_os.h index 09a945bc..ea363fb3 100644 --- a/src/scheme/test/ao_scheme_os.h +++ b/src/scheme/test/ao_scheme_os.h @@ -22,7 +22,7 @@ #include #include -#define AO_SCHEME_POOL_TOTAL 16384 +#define AO_SCHEME_POOL_TOTAL 32768 #define AO_SCHEME_SAVE 1 #define DBG_MEM_STATS 1 -- cgit v1.2.3 From 7d77071f5b45632937f262600ca95c7b71f4d3da Mon Sep 17 00:00:00 2001 From: Keith Packard Date: Sun, 10 Dec 2017 16:55:57 -0800 Subject: altos/scheme: Add Makefile for scheme test app Signed-off-by: Keith Packard --- src/scheme/test/Makefile | 19 +++++++++++++++++++ 1 file changed, 19 insertions(+) create mode 100644 src/scheme/test/Makefile (limited to 'src') diff --git a/src/scheme/test/Makefile b/src/scheme/test/Makefile new file mode 100644 index 00000000..9d39d33e --- /dev/null +++ b/src/scheme/test/Makefile @@ -0,0 +1,19 @@ +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 -- cgit v1.2.3 From 655576011e9cc648c7c4bbf51179744a427ff237 Mon Sep 17 00:00:00 2001 From: Keith Packard Date: Sun, 10 Dec 2017 18:21:01 -0800 Subject: altos/lambdakey-v1.0: Switch to newlib, get things compiling again scheme is now way too large to fit on this device; some subsetting is clearly indicated. Signed-off-by: Keith Packard --- src/lambdakey-v1.0/Makefile | 35 +++++++-------- src/lambdakey-v1.0/ao_lambdakey.c | 8 ++-- src/lambdakey-v1.0/ao_lisp_os.h | 62 -------------------------- src/lambdakey-v1.0/ao_lisp_os_save.c | 53 ----------------------- src/lambdakey-v1.0/ao_scheme_os.h | 79 ++++++++++++++++++++++++++++++++++ src/lambdakey-v1.0/ao_scheme_os_save.c | 53 +++++++++++++++++++++++ 6 files changed, 151 insertions(+), 139 deletions(-) delete mode 100644 src/lambdakey-v1.0/ao_lisp_os.h delete mode 100644 src/lambdakey-v1.0/ao_lisp_os_save.c create mode 100644 src/lambdakey-v1.0/ao_scheme_os.h create mode 100644 src/lambdakey-v1.0/ao_scheme_os_save.c (limited to 'src') diff --git a/src/lambdakey-v1.0/Makefile b/src/lambdakey-v1.0/Makefile index 2609bea3..6b819ffb 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 + 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 -#include +#include -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_lisp_os.h b/src/lambdakey-v1.0/ao_lisp_os.h deleted file mode 100644 index 1993ac44..00000000 --- a/src/lambdakey-v1.0/ao_lisp_os.h +++ /dev/null @@ -1,62 +0,0 @@ -/* - * Copyright © 2016 Keith Packard - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation; 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_LISP_OS_H_ -#define _AO_LISP_OS_H_ - -#include "ao.h" - -static inline int -ao_lisp_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_lisp_os_flush(void) -{ - flush(); -} - -static inline void -ao_lisp_abort(void) -{ - ao_panic(1); -} - -static inline void -ao_lisp_os_led(int led) -{ - ao_led_set(led); -} - -static inline void -ao_lisp_os_delay(int delay) -{ - ao_delay(AO_MS_TO_TICKS(delay)); -} - -#endif diff --git a/src/lambdakey-v1.0/ao_lisp_os_save.c b/src/lambdakey-v1.0/ao_lisp_os_save.c deleted file mode 100644 index 44138398..00000000 --- a/src/lambdakey-v1.0/ao_lisp_os_save.c +++ /dev/null @@ -1,53 +0,0 @@ -/* - * Copyright © 2016 Keith Packard - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation, either version 2 of the License, or - * (at your option) any later version. - * - * This program is distributed in the hope that it will be useful, but - * WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU - * General Public License for more details. - */ - -#include -#include -#include - -extern uint8_t __flash__[]; - -/* saved variables to rebuild the heap - - ao_lisp_atoms - ao_lisp_frame_global - */ - -int -ao_lisp_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]; - - ao_flash_page(dst, src); - } - return 1; -} - -int -ao_lisp_os_restore_save(struct ao_lisp_os_save *save, int offset) -{ - memcpy(save, &__flash__[offset], sizeof (struct ao_lisp_os_save)); - return 1; -} - -int -ao_lisp_os_restore(void) -{ - memcpy(ao_lisp_pool, __flash__, AO_LISP_POOL_TOTAL); - return 1; -} 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 + * + * 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_scheme_os_save.c b/src/lambdakey-v1.0/ao_scheme_os_save.c new file mode 100644 index 00000000..184ddb8d --- /dev/null +++ b/src/lambdakey-v1.0/ao_scheme_os_save.c @@ -0,0 +1,53 @@ +/* + * Copyright © 2016 Keith Packard + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation, either version 2 of the License, or + * (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, but + * WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + * General Public License for more details. + */ + +#include +#include +#include + +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) { + void *dst = &__flash__[i]; + void *src = &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; +} -- cgit v1.2.3 From b0de72d942eb87c5acd190878dd57ca4f812e8a1 Mon Sep 17 00:00:00 2001 From: Keith Packard Date: Sun, 10 Dec 2017 18:32:18 -0800 Subject: altos: Add scheme for stm discovery board demo Signed-off-by: Keith Packard --- src/stm-scheme-newlib/.gitignore | 4 ++ src/stm-scheme-newlib/Makefile | 84 +++++++++++++++++++++++++ src/stm-scheme-newlib/ao_demo.c | 51 ++++++++++++++++ src/stm-scheme-newlib/ao_pins.h | 91 ++++++++++++++++++++++++++++ src/stm-scheme-newlib/ao_scheme_os.h | 78 ++++++++++++++++++++++++ src/stm-scheme-newlib/ao_scheme_os_save.c | 53 ++++++++++++++++ src/stm-scheme-newlib/flash-loader/Makefile | 8 +++ src/stm-scheme-newlib/flash-loader/ao_pins.h | 36 +++++++++++ 8 files changed, 405 insertions(+) create mode 100644 src/stm-scheme-newlib/.gitignore create mode 100644 src/stm-scheme-newlib/Makefile create mode 100644 src/stm-scheme-newlib/ao_demo.c create mode 100644 src/stm-scheme-newlib/ao_pins.h create mode 100644 src/stm-scheme-newlib/ao_scheme_os.h create mode 100644 src/stm-scheme-newlib/ao_scheme_os_save.c create mode 100644 src/stm-scheme-newlib/flash-loader/Makefile create mode 100644 src/stm-scheme-newlib/flash-loader/ao_pins.h (limited to 'src') 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 + * + * 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 +#include +#include + +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 + * + * 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/stm-scheme-newlib/ao_scheme_os.h b/src/stm-scheme-newlib/ao_scheme_os.h new file mode 100644 index 00000000..21b6001a --- /dev/null +++ b/src/stm-scheme-newlib/ao_scheme_os.h @@ -0,0 +1,78 @@ +/* + * Copyright © 2016 Keith Packard + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation; 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_POOL 10240 + +#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/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 + * + * 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 +#include "ao_scheme.h" +#include + +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 + * + * 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 + +/* 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_ */ -- cgit v1.2.3 From 8ebecd364fd328e9c649c11729bddf58731aaafb Mon Sep 17 00:00:00 2001 From: Keith Packard Date: Sun, 10 Dec 2017 18:34:49 -0800 Subject: altos: Allow building with newlib + avr stdio on ARM Redefines some stdio bits so that we can build with either pdclib or newlib + avr stdio. Signed-off-by: Keith Packard --- src/cc1111/ao_arch.h | 4 ++++ src/kernel/ao_stdio.c | 4 ++-- src/kernel/ao_task.h | 3 +++ src/lambdakey-v1.0/Makefile | 2 +- src/stm/ao_serial_stm.c | 8 ++++---- src/stmf0/Makefile-stmf0.defs | 2 +- 6 files changed, 15 insertions(+), 8 deletions(-) (limited to 'src') 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/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_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/lambdakey-v1.0/Makefile b/src/lambdakey-v1.0/Makefile index 6b819ffb..4eb045b6 100644 --- a/src/lambdakey-v1.0/Makefile +++ b/src/lambdakey-v1.0/Makefile @@ -54,7 +54,7 @@ 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 +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 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 -- cgit v1.2.3 From ec638405045d33d48476ab85edf09a2e1756e3e3 Mon Sep 17 00:00:00 2001 From: Keith Packard Date: Sun, 10 Dec 2017 18:35:53 -0800 Subject: altos/scheme: Allow ao_scheme_read_eval_print to be restarted Reset exceptions at the top so that we can call it more than once. Signed-off-by: Keith Packard --- src/scheme/ao_scheme_rep.c | 2 ++ src/scheme/test/Makefile | 3 +++ 2 files changed, 5 insertions(+) (limited to 'src') diff --git a/src/scheme/ao_scheme_rep.c b/src/scheme/ao_scheme_rep.c index 9dbce5f2..5b94d940 100644 --- a/src/scheme/ao_scheme_rep.c +++ b/src/scheme/ao_scheme_rep.c @@ -18,6 +18,8 @@ ao_poly ao_scheme_read_eval_print(void) { ao_poly in, out = AO_SCHEME_NIL; + + ao_scheme_exception = 0; for(;;) { in = ao_scheme_read(); if (in == _ao_scheme_atom_eof) diff --git a/src/scheme/test/Makefile b/src/scheme/test/Makefile index 9d39d33e..c48add1f 100644 --- a/src/scheme/test/Makefile +++ b/src/scheme/test/Makefile @@ -17,3 +17,6 @@ $(OBJS): $(SCHEME_HDRS) clean:: rm -f $(OBJS) ao_scheme_test + +install: ao_scheme_test + cp ao_scheme_test $$HOME/bin/ao-scheme -- cgit v1.2.3 From 8d65e7b367712075a42d26c6d4bbff474dc1ae14 Mon Sep 17 00:00:00 2001 From: Keith Packard Date: Tue, 5 Dec 2017 12:22:34 -0800 Subject: altos/drivers: Hook up mag sensor for MPU9250 Set mag sensor to provide data at 100Hz. Set i2c master to pull mag data at sample rate (200Hz). Signed-off-by: Keith Packard --- src/drivers/ao_mpu9250.c | 180 ++++++++++++++++++++++++++++++++++++++++++++--- src/drivers/ao_mpu9250.h | 71 +++++++++++++++++++ 2 files changed, 241 insertions(+), 10 deletions(-) (limited to 'src') diff --git a/src/drivers/ao_mpu9250.c b/src/drivers/ao_mpu9250.c index b79f27ca..ae8dacd0 100644 --- a/src/drivers/ao_mpu9250.c +++ b/src/drivers/ao_mpu9250.c @@ -22,6 +22,8 @@ #if HAS_MPU9250 +#define MPU9250_TEST 0 + static uint8_t ao_mpu9250_configured; extern uint8_t ao_sensor_errors; @@ -43,8 +45,12 @@ extern uint8_t ao_sensor_errors; #define ao_mpu9250_spi_end() ao_spi_clr_cs(AO_MPU9250_SPI_CS_PORT, \ (1 << AO_MPU9250_SPI_CS_PIN)) -#endif +#else +#define ao_mpu9250_spi_get() +#define ao_mpu9250_spi_put() + +#endif static void _ao_mpu9250_reg_write(uint8_t addr, uint8_t value) @@ -102,6 +108,61 @@ _ao_mpu9250_reg_read(uint8_t addr) 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) { @@ -180,6 +241,7 @@ _ao_mpu9250_wait_alive(void) } #define ST_TRIES 10 +#define MAG_TRIES 10 static void _ao_mpu9250_setup(void) @@ -187,6 +249,7 @@ _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; @@ -205,7 +268,7 @@ _ao_mpu9250_setup(void) /* Reset signal conditioning, disabling I2C on SPI systems */ _ao_mpu9250_reg_write(MPU9250_USER_CTRL, (0 << MPU9250_USER_CTRL_FIFO_EN) | - (0 << MPU9250_USER_CTRL_I2C_MST_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) | @@ -233,6 +296,14 @@ _ao_mpu9250_setup(void) (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); @@ -292,6 +363,53 @@ _ao_mpu9250_setup(void) 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) | @@ -312,20 +430,15 @@ static void ao_mpu9250(void) { struct ao_mpu9250_sample sample; + /* ao_mpu9250_init already grabbed the SPI bus and mutex */ _ao_mpu9250_setup(); -#if AO_MPU9250_SPI ao_mpu9250_spi_put(); -#endif for (;;) { -#if AO_MPU9250_SPI ao_mpu9250_spi_get(); -#endif _ao_mpu9250_sample(&sample); -#if AO_MPU9250_SPI ao_mpu9250_spi_put(); -#endif ao_arch_block_interrupts(); ao_mpu9250_current = sample; AO_DATA_PRESENT(AO_DATA_MPU9250); @@ -339,15 +452,20 @@ static struct ao_task ao_mpu9250_task; static void ao_mpu9250_show(void) { - printf ("Accel: %7d %7d %7d Gyro: %7d %7d %7d\n", + 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.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) { @@ -384,10 +502,52 @@ ao_mpu9250_write(void) 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 \0Read MPU9250 register" }, { ao_mpu9250_write, "W \0Write MPU9250 register" }, + { ao_mpu9250_mag_read, "G \0Read MPU9250 Mag register" }, + { ao_mpu9250_mag_write, "P \0Write MPU9250 Mag register" }, +#endif { 0, NULL } }; diff --git a/src/drivers/ao_mpu9250.h b/src/drivers/ao_mpu9250.h index df1be7c7..5e8e0885 100644 --- a/src/drivers/ao_mpu9250.h +++ b/src/drivers/ao_mpu9250.h @@ -130,6 +130,12 @@ #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 @@ -146,6 +152,11 @@ #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 @@ -179,6 +190,15 @@ #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 @@ -212,6 +232,57 @@ #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)) -- cgit v1.2.3 From 05efe58cb13b58292527668ca51639eaebe1112b Mon Sep 17 00:00:00 2001 From: Bdale Garbee Date: Mon, 11 Dec 2017 14:44:15 -0700 Subject: take telescience out of the routine builds --- src/Makefile | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) (limited to 'src') diff --git a/src/Makefile b/src/Makefile index defeea96..03a5314d 100644 --- a/src/Makefile +++ b/src/Makefile @@ -39,7 +39,6 @@ ARMM3DIRS=\ 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 \ @@ -56,7 +55,7 @@ ARMM0DIRS=\ micropeak-v2.0 micropeak-v2.0/flash-loader AVRDIRS=\ - telescience-v0.1 telescience-pwm micropeak nanopeak-v0.1 microkite + micropeak nanopeak-v0.1 microkite SUBDIRS= -- cgit v1.2.3 From 962df1f8c7f7ffbebe9b32d6ac363b333af606b3 Mon Sep 17 00:00:00 2001 From: Keith Packard Date: Mon, 11 Dec 2017 13:47:54 -0800 Subject: altos: Remove more software for hardware prototypes These never saw the light of day. Signed-off-by: Keith Packard --- src/Makefile | 5 +---- 1 file changed, 1 insertion(+), 4 deletions(-) (limited to 'src') diff --git a/src/Makefile b/src/Makefile index 03a5314d..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 @@ -33,7 +32,6 @@ ARMM3DIRS=\ 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 \ @@ -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=\ - micropeak nanopeak-v0.1 microkite + micropeak microkite SUBDIRS= -- cgit v1.2.3 From fa3ff3a089e4af88dd0cc9a9e92511a0ba4a8e0f Mon Sep 17 00:00:00 2001 From: Keith Packard Date: Mon, 11 Dec 2017 14:08:32 -0800 Subject: altos: Actually store current MPU9250 data in data ring The ring is updated when the ADC finishes; all of the other sensor data needs to be copied in at that point. Signed-off-by: Keith Packard --- src/stm/ao_adc_stm.c | 3 +++ 1 file changed, 3 insertions(+) (limited to 'src') diff --git a/src/stm/ao_adc_stm.c b/src/stm/ao_adc_stm.c index c3cca5e4..24912bb2 100644 --- a/src/stm/ao_adc_stm.c +++ b/src/stm/ao_adc_stm.c @@ -57,6 +57,9 @@ static void ao_adc_done(int index) #endif #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); -- cgit v1.2.3