diff options
| author | Bdale Garbee <bdale@gag.com> | 2017-12-11 21:39:38 -0700 | 
|---|---|---|
| committer | Bdale Garbee <bdale@gag.com> | 2017-12-11 21:39:38 -0700 | 
| commit | 8e0b575ad1dfd5a49136d3fe945d27f6afda1178 (patch) | |
| tree | 74657870764e6a3792bdd7e90acd725353c20904 /src | |
| parent | 132b92a95bdebabf573a680301bfb1e93eaa6721 (diff) | |
| parent | fe38c22595b050435dbacd35f1baae064fb7de75 (diff) | |
Merge branch 'branch-1.8' into debian
Diffstat (limited to 'src')
134 files changed, 10877 insertions, 6272 deletions
diff --git a/src/Makefile b/src/Makefile index 661fd333..8420b376 100644 --- a/src/Makefile +++ b/src/Makefile @@ -21,7 +21,6 @@ SDCCDIRS=\  	teledongle-v0.2 \  	telemini-v1.0 \  	telebt-v1.0 \ -	teleterra-v0.2 teleshield-v0.1 \  	telefire-v0.1 telefire-v0.2 \  	telerepeat-v1.0 @@ -30,15 +29,14 @@ ARMM3DIRS=\  	telemega-v0.1 telemega-v0.1/flash-loader \  	telemega-v1.0 telemega-v1.0/flash-loader \  	telemega-v2.0 telemega-v2.0/flash-loader \ +	telemega-v3.0 telemega-v3.0/flash-loader \  	telemetrum-v2.0 telemetrum-v2.0/flash-loader \  	telemetrum-v3.0 telemetrum-v3.0/flash-loader \ -	megadongle-v0.1 megadongle-v0.1/flash-loader \  	telegps-v0.3 telegps-v0.3/flash-loader \  	telegps-v1.0 telegps-v1.0/flash-loader \  	telegps-v2.0 telegps-v2.0/flash-loader \  	telelco-v0.2 telelco-v0.2/flash-loader \  	telelco-v0.3 telelco-v0.3/flash-loader \ -	telescience-v0.2 telescience-v0.2/flash-loader \  	teledongle-v3.0 teledongle-v3.0/flash-loader \  	teleballoon-v2.0 \  	telebt-v3.0 telebt-v3.0/flash-loader \ @@ -48,14 +46,13 @@ ARMM3DIRS=\  ARMM0DIRS=\  	easymini-v1.0 easymini-v1.0/flash-loader \ -	chaoskey-v0.1 chaoskey-v0.1/flash-loader \  	chaoskey-v1.0 chaoskey-v1.0/flash-loader \  	telemini-v3.0 telemini-v3.0/flash-loader \  	easymini-v2.0 easymini-v2.0/flash-loader \  	micropeak-v2.0 micropeak-v2.0/flash-loader  AVRDIRS=\ -	telescience-v0.1 telescience-pwm micropeak nanopeak-v0.1 microkite +	micropeak microkite  SUBDIRS= diff --git a/src/cc1111/Makefile.cc1111 b/src/cc1111/Makefile.cc1111 index 0ea30e1d..cb2d3db4 100644 --- a/src/cc1111/Makefile.cc1111 +++ b/src/cc1111/Makefile.cc1111 @@ -1,7 +1,7 @@  include ../Makedefs  CC=$(SDCC) -CFLAGS=--model-small --debug --opt-code-speed -DCODESIZE=$(CODESIZE) +CFLAGS=--model-small --debug --opt-code-speed -DCODESIZE=$(CODESIZE) -DCC1111  CFLAGS += $(PRODUCT_DEF) -I. -I.. -I../kernel -I../cc1111 -I../drivers -I../product diff --git a/src/cc1111/ao_arch.h b/src/cc1111/ao_arch.h index bacfabb8..937e6d0c 100644 --- a/src/cc1111/ao_arch.h +++ b/src/cc1111/ao_arch.h @@ -234,6 +234,10 @@ ao_button_get(uint16_t timeout) __critical;  void  ao_button_clear(void) __critical; +/* console I/O funcs */ +#define ao_getchar getchar +#define ao_putchar putchar +  /* ao_string.c */  void diff --git a/src/cc1111/ao_pins.h b/src/cc1111/ao_pins.h index 10b1f802..9d6e1c1d 100644 --- a/src/cc1111/ao_pins.h +++ b/src/cc1111/ao_pins.h @@ -63,6 +63,7 @@  	#define HAS_RADIO_RATE		0	/* not enough space for this */  	#define HAS_MUTEX_TRY		0  	#define HAS_TASK_INFO		0	/* not enough space for this either */ +	#define AO_LOG_FORMAT		AO_LOG_FORMAT_FULL  #endif  #if defined(TELEMETRUM_V_1_1) @@ -106,6 +107,7 @@  	#define HAS_TELEMETRY		1  	#define HAS_RADIO_RATE		0	/* not enough space for this */  	#define HAS_MUTEX_TRY		0 +	#define AO_LOG_FORMAT		AO_LOG_FORMAT_FULL  #endif  #if defined(TELEMETRUM_V_1_2) @@ -149,6 +151,7 @@  	#define HAS_TELEMETRY		1  	#define HAS_RADIO_RATE		0	/* not enough space for this */  	#define HAS_MUTEX_TRY		0 +	#define AO_LOG_FORMAT		AO_LOG_FORMAT_FULL  #endif  #if defined(TELEDONGLE_V_0_2) @@ -210,6 +213,7 @@  	#define HAS_MONITOR		0  	#define HAS_TELEMETRY		1  	#define HAS_RADIO_RATE		0	/* not enough space for this */ +	#define AO_LOG_FORMAT 		AO_LOG_FORMAT_TINY  #endif  #if defined(TELENANO_V_0_1) @@ -274,6 +278,7 @@  	#define HAS_TELEMETRY		1  	#define HAS_RADIO_RATE		0	/* not enough space for this */  	#define AO_CONFIG_DEFAULT_FLIGHT_LOG_MAX	((uint32_t) 127 * (uint32_t) 1024) +	#define AO_LOG_FORMAT		AO_LOG_FORMAT_FULL  #endif  #if defined(TELEDONGLE_V_0_1) diff --git a/src/cortexelf-v1/.gitignore b/src/cortexelf-v1/.gitignore new file mode 100644 index 00000000..0189131b --- /dev/null +++ b/src/cortexelf-v1/.gitignore @@ -0,0 +1,3 @@ +cortexelf-v1*.elf +cortexelf-v1*.hex +ao_product.h diff --git a/src/cortexelf-v1/Makefile b/src/cortexelf-v1/Makefile index 8cc6ce31..12c658dc 100644 --- a/src/cortexelf-v1/Makefile +++ b/src/cortexelf-v1/Makefile @@ -4,7 +4,8 @@  #  include ../stm/Makefile.defs -LDFLAGS=-L../stm -Wl,-Tcortexelf.ld +include ../scheme/Makefile-inc +  INC = \  	ao.h \ @@ -19,15 +20,12 @@ INC = \  	math.h \  	ao_mpu.h \  	stm32l.h \ -	math.h \  	ao_vga.h \  	ao_draw.h \  	ao_draw_int.h \  	ao_font.h \  	ao_ps2.h \ -	ao_lisp.h \ -	ao_lisp_const.h \ -	ao_lisp_os.h \ +	$(SCHEME_HDRS) \  	ao_flip_bits.h \  	Makefile @@ -46,6 +44,7 @@ ALTOS_SRC = \  	ao_cmd.c \  	ao_config.c \  	ao_task.c \ +	ao_errno.c \  	ao_stdio.c \  	ao_panic.c \  	ao_timer.c \ @@ -74,23 +73,8 @@ ALTOS_SRC = \  	ao_event.c \  	ao_1802.c \  	ao_hex.c \ -	ao_lisp_lex.c \ -	ao_lisp_mem.c \ -	ao_lisp_cons.c \ -	ao_lisp_eval.c \ -	ao_lisp_string.c \ -	ao_lisp_atom.c \ -	ao_lisp_int.c \ -	ao_lisp_poly.c \ -	ao_lisp_builtin.c \ -	ao_lisp_read.c \ -	ao_lisp_rep.c \ -	ao_lisp_frame.c \ -	ao_lisp_error.c \ -	ao_lisp_lambda.c \ -	ao_lisp_save.c \ -	ao_lisp_stack.c \ -	ao_lisp_os_save.c \ +	$(SCHEME_SRCS) \ +	ao_scheme_os_save.c \  	$(PROFILE) \  	$(SAMPLE_PROFILE) \  	$(STACK_GUARD) @@ -99,12 +83,21 @@ PRODUCT=CortexELF-v1  PRODUCT_DEF=-DCORTEXELF  IDPRODUCT=0x000a -CFLAGS = $(PRODUCT_DEF) $(STM_CFLAGS) $(PROFILE_DEF) $(SAMPLE_PROFILE_DEF) $(STACK_GUARD_DEF) -Os -g -  PROGNAME=cortexelf-v1  PROG=$(PROGNAME)-$(VERSION).elf  HEX=$(PROGNAME)-$(VERSION).ihx +MAP=$(PROG).map + +MAPFILE=-Wl,-M=$(MAP) + +LDFLAGS=-L../stm -L/local/newlib-mini/arm-none-eabi/lib/thumb/v7-m/ -Wl,-Tcortexelf.ld $(MAPFILE) -nostartfiles +AO_CFLAGS=-I. -I../stm -I../kernel -I../drivers -I../draw -I../scheme -I.. -I/local/newlib-mini/arm-none-eabi/include +LIBS=-lc -lm -lgcc + +CFLAGS = $(PRODUCT_DEF) $(STM_CFLAGS) $(PROFILE_DEF) $(SAMPLE_PROFILE_DEF) $(STACK_GUARD_DEF) -Os -g + +  SRC=$(ALTOS_SRC) ao_cortexelf.c  OBJ=$(SRC:.c=.o) @@ -130,7 +123,7 @@ clean::  ao_flip_bits.h: ao_flip_bits.5c  	nickle ao_flip_bits.5c > $@ -include ../lisp/Makefile-lisp +include ../scheme/Makefile-scheme  install: diff --git a/src/cortexelf-v1/ao_cortexelf.c b/src/cortexelf-v1/ao_cortexelf.c index 61a9d219..5ed78bf0 100644 --- a/src/cortexelf-v1/ao_cortexelf.c +++ b/src/cortexelf-v1/ao_cortexelf.c @@ -27,7 +27,7 @@  #include <ao_console.h>  #include <ao_sdcard.h>  #include <ao_fat.h> -#include <ao_lisp.h> +#include <ao_scheme.h>  #include <ao_button.h>  #include <ao_event.h>  #include <ao_as1107.h> @@ -188,8 +188,8 @@ ao_console_send(void)  	}  } -static void lisp_cmd() { -	ao_lisp_read_eval_print(); +static void scheme_cmd() { +	ao_scheme_read_eval_print();  }  static void @@ -224,7 +224,7 @@ __code struct ao_cmds ao_demo_cmds[] = {  	{ ao_ps2_read_keys, "K\0Read keys from keyboard" },  	{ ao_console_send, "C\0Send data to console, end with ~" },  	{ ao_serial_blather, "S\0Blather on serial ports briefly" }, -	{ lisp_cmd, "l\0Run lisp interpreter" }, +	{ scheme_cmd, "l\0Run scheme interpreter" },  	{ led_cmd, "L start value\0Show value (byte) at digit start" },  	{ 0, NULL }  }; diff --git a/src/cortexelf-v1/ao_pins.h b/src/cortexelf-v1/ao_pins.h index 258ffe31..c2bbf2d2 100644 --- a/src/cortexelf-v1/ao_pins.h +++ b/src/cortexelf-v1/ao_pins.h @@ -62,6 +62,8 @@  #define USE_SERIAL_2_STDIN	1  #define SERIAL_2_PA2_PA3	0  #define SERIAL_2_PD5_PD6	1 +#define USE_SERIAL_2_FLOW	0 +#define USE_SERIAL_2_SW_FLOW	0  #define HAS_SERIAL_3		0  #define USE_SERIAL_3_STDIN	0 diff --git a/src/cortexelf-v1/ao_lisp_os.h b/src/cortexelf-v1/ao_scheme_os.h index d0c1f7b7..58e4f5b3 100644 --- a/src/cortexelf-v1/ao_lisp_os.h +++ b/src/cortexelf-v1/ao_scheme_os.h @@ -15,16 +15,22 @@   * 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA.   */ -#ifndef _AO_LISP_OS_H_ -#define _AO_LISP_OS_H_ +#ifndef _AO_SCHEME_OS_H_ +#define _AO_SCHEME_OS_H_  #include "ao.h" -#define AO_LISP_POOL_TOTAL		16384 -#define AO_LISP_SAVE			1 +#define AO_SCHEME_POOL_TOTAL		16384 +#define AO_SCHEME_SAVE			1 + +#ifndef __BYTE_ORDER +#define	__LITTLE_ENDIAN	1234 +#define	__BIG_ENDIAN	4321 +#define __BYTE_ORDER	__LITTLE_ENDIAN +#endif  static inline int -ao_lisp_getc() { +ao_scheme_getc() {  	static uint8_t	at_eol;  	int c; @@ -39,27 +45,35 @@ ao_lisp_getc() {  }  static inline void -ao_lisp_os_flush(void) +ao_scheme_os_flush(void)  {  	flush();  }  static inline void -ao_lisp_abort(void) +ao_scheme_abort(void)  {  	ao_panic(1);  }  static inline void -ao_lisp_os_led(int led) +ao_scheme_os_led(int led)  {  	(void) led;  } +#define AO_SCHEME_JIFFIES_PER_SECOND	AO_HERTZ +  static inline void -ao_lisp_os_delay(int delay) +ao_scheme_os_delay(int delay) +{ +	ao_delay(delay); +} + +static inline int +ao_scheme_os_jiffy(void)  { -	ao_delay(AO_MS_TO_TICKS(delay)); +	return ao_tick_count;  }  #endif diff --git a/src/cortexelf-v1/ao_lisp_os_save.c b/src/cortexelf-v1/ao_scheme_os_save.c index 7c853990..4cec79c6 100644 --- a/src/cortexelf-v1/ao_lisp_os_save.c +++ b/src/cortexelf-v1/ao_scheme_os_save.c @@ -13,25 +13,25 @@   */  #include <ao.h> -#include <ao_lisp.h> +#include <ao_scheme.h>  #include <ao_flash.h>  extern uint8_t	__flash__[];  /* saved variables to rebuild the heap -   ao_lisp_atoms -   ao_lisp_frame_global +   ao_scheme_atoms +   ao_scheme_frame_global   */  int -ao_lisp_os_save(void) +ao_scheme_os_save(void)  {  	int i; -	for (i = 0; i < AO_LISP_POOL_TOTAL; i += 256) { +	for (i = 0; i < AO_SCHEME_POOL_TOTAL; i += 256) {  		uint32_t	*dst = (uint32_t *) (void *) &__flash__[i]; -		uint32_t	*src = (uint32_t *) (void *) &ao_lisp_pool[i]; +		uint32_t	*src = (uint32_t *) (void *) &ao_scheme_pool[i];  		ao_flash_page(dst, src);  	} @@ -39,15 +39,15 @@ ao_lisp_os_save(void)  }  int -ao_lisp_os_restore_save(struct ao_lisp_os_save *save, int offset) +ao_scheme_os_restore_save(struct ao_scheme_os_save *save, int offset)  { -	memcpy(save, &__flash__[offset], sizeof (struct ao_lisp_os_save)); +	memcpy(save, &__flash__[offset], sizeof (struct ao_scheme_os_save));  	return 1;  }  int -ao_lisp_os_restore(void) +ao_scheme_os_restore(void)  { -	memcpy(ao_lisp_pool, __flash__, AO_LISP_POOL_TOTAL); +	memcpy(ao_scheme_pool, __flash__, AO_SCHEME_POOL_TOTAL);  	return 1;  } diff --git a/src/drivers/ao_mpu9250.c b/src/drivers/ao_mpu9250.c new file mode 100644 index 00000000..ae8dacd0 --- /dev/null +++ b/src/drivers/ao_mpu9250.c @@ -0,0 +1,575 @@ +/* + * Copyright © 2012 Keith Packard <keithp@keithp.com> + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation; either version 2 of the License, or + * (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, but + * WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU + * General Public License for more details. + * + * You should have received a copy of the GNU General Public License along + * with this program; if not, write to the Free Software Foundation, Inc., + * 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA. + */ + +#include <ao.h> +#include <ao_mpu9250.h> +#include <ao_exti.h> + +#if HAS_MPU9250 + +#define MPU9250_TEST	0 + +static uint8_t	ao_mpu9250_configured; + +extern uint8_t ao_sensor_errors; + +#ifndef AO_MPU9250_I2C_INDEX +#define AO_MPU9250_SPI	1 +#else +#define AO_MPU9250_SPI	0 +#endif + +#if AO_MPU9250_SPI + +#define ao_mpu9250_spi_get()	ao_spi_get(AO_MPU9250_SPI_BUS, AO_SPI_SPEED_1MHz) +#define ao_mpu9250_spi_put()	ao_spi_put(AO_MPU9250_SPI_BUS) + +#define ao_mpu9250_spi_start() 	ao_spi_set_cs(AO_MPU9250_SPI_CS_PORT,	\ +					      (1 << AO_MPU9250_SPI_CS_PIN)) + +#define ao_mpu9250_spi_end() 	ao_spi_clr_cs(AO_MPU9250_SPI_CS_PORT,	\ +					      (1 << AO_MPU9250_SPI_CS_PIN)) + +#else + +#define ao_mpu9250_spi_get() +#define ao_mpu9250_spi_put() + +#endif + +static void +_ao_mpu9250_reg_write(uint8_t addr, uint8_t value) +{ +	uint8_t	d[2] = { addr, value }; +#if AO_MPU9250_SPI +	ao_mpu9250_spi_start(); +	ao_spi_send(d, 2, AO_MPU9250_SPI_BUS); +	ao_mpu9250_spi_end(); +#else +	ao_i2c_get(AO_MPU9250_I2C_INDEX); +	ao_i2c_start(AO_MPU9250_I2C_INDEX, MPU9250_ADDR_WRITE); +	ao_i2c_send(d, 2, AO_MPU9250_I2C_INDEX, TRUE); +	ao_i2c_put(AO_MPU9250_I2C_INDEX); +#endif +} + +static void +_ao_mpu9250_read(uint8_t addr, void *data, uint8_t len) +{ +#if AO_MPU9250_SPI +	addr |= 0x80; +	ao_mpu9250_spi_start(); +	ao_spi_send(&addr, 1, AO_MPU9250_SPI_BUS); +	ao_spi_recv(data, len, AO_MPU9250_SPI_BUS); +	ao_mpu9250_spi_end(); +#else +	ao_i2c_get(AO_MPU9250_I2C_INDEX); +	ao_i2c_start(AO_MPU9250_I2C_INDEX, MPU9250_ADDR_WRITE); +	ao_i2c_send(&addr, 1, AO_MPU9250_I2C_INDEX, FALSE); +	ao_i2c_start(AO_MPU9250_I2C_INDEX, MPU9250_ADDR_READ); +	ao_i2c_recv(data, len, AO_MPU9250_I2C_INDEX, TRUE); +	ao_i2c_put(AO_MPU9250_I2C_INDEX); +#endif +} + +static uint8_t +_ao_mpu9250_reg_read(uint8_t addr) +{ +	uint8_t	value; +#if AO_MPU9250_SPI +	addr |= 0x80; +	ao_mpu9250_spi_start(); +	ao_spi_send(&addr, 1, AO_MPU9250_SPI_BUS); +	ao_spi_recv(&value, 1, AO_MPU9250_SPI_BUS); +	ao_mpu9250_spi_end(); +#else +	ao_i2c_get(AO_MPU9250_I2C_INDEX); +	ao_i2c_start(AO_MPU9250_I2C_INDEX, MPU9250_ADDR_WRITE); +	ao_i2c_send(&addr, 1, AO_MPU9250_I2C_INDEX, FALSE); +	ao_i2c_start(AO_MPU9250_I2C_INDEX, MPU9250_ADDR_READ); +	ao_i2c_recv(&value, 1, AO_MPU9250_I2C_INDEX, TRUE); +	ao_i2c_put(AO_MPU9250_I2C_INDEX); +#endif +	return value; +} + +static void +_ao_mpu9250_slv4_setup(uint8_t addr, uint8_t reg) +{ +	/* Set i2c slave address */ +	_ao_mpu9250_reg_write(MPU9250_I2C_SLV4_ADDR, +			      addr); + +	/* Set i2c register address */ +	_ao_mpu9250_reg_write(MPU9250_I2C_SLV4_REG, +			      reg); +} + +static void +_ao_mpu9250_slv4_run(void) +{ +	uint8_t	ctrl; + +	/* Start the transfer */ +	_ao_mpu9250_reg_write(MPU9250_I2C_SLV4_CTRL, +			      (1 << MPU9250_I2C_SLV4_CTRL_I2C_SLV4_EN) | +			      (0 << MPU9250_I2C_SLV4_CTRL_SLV4_DONE_INT_EN) | +			      (0 << MPU9250_I2C_SLV4_CTRL_I2C_SLV4_REG_DIS) | +			      (0 << MPU9250_I2C_SLV4_CTRL_I2C_MST_DLY)); + +	/* Poll for completion */ +	for (;;) { +		ctrl = _ao_mpu9250_reg_read(MPU9250_I2C_SLV4_CTRL); +		if ((ctrl & (1 << MPU9250_I2C_SLV4_CTRL_I2C_SLV4_EN)) == 0) +			break; +		ao_delay(0); +	} +} + +static uint8_t +_ao_mpu9250_mag_reg_read(uint8_t reg) +{ +	_ao_mpu9250_slv4_setup((1 << 7) | MPU9250_MAG_ADDR, reg); + +	_ao_mpu9250_slv4_run(); + +	return _ao_mpu9250_reg_read(MPU9250_I2C_SLV4_DI); +} + +static void +_ao_mpu9250_mag_reg_write(uint8_t reg, uint8_t value) +{ +	_ao_mpu9250_slv4_setup((0 << 7) | MPU9250_MAG_ADDR, reg); + +	/* Set the data */ +	_ao_mpu9250_reg_write(MPU9250_I2C_SLV4_DO, +			      value); + +	_ao_mpu9250_slv4_run(); +} + +static void +_ao_mpu9250_sample(struct ao_mpu9250_sample *sample) +{ +	uint16_t	*d = (uint16_t *) sample; +	int		i = sizeof (*sample) / 2; + +	_ao_mpu9250_read(MPU9250_ACCEL_XOUT_H, sample, sizeof (*sample)); +#if __BYTE_ORDER == __LITTLE_ENDIAN +	/* byte swap */ +	while (i--) { +		uint16_t	t = *d; +		*d++ = (t >> 8) | (t << 8); +	} +#endif +} + +#define G	981	/* in cm/s² */ + +#if 0 +static int16_t /* cm/s² */ +ao_mpu9250_accel(int16_t v) +{ +	return (int16_t) ((v * (int32_t) (16.0 * 980.665 + 0.5)) / 32767); +} + +static int16_t	/* deg*10/s */ +ao_mpu9250_gyro(int16_t v) +{ +	return (int16_t) ((v * (int32_t) 20000) / 32767); +} +#endif + +static uint8_t +ao_mpu9250_accel_check(int16_t normal, int16_t test) +{ +	int16_t	diff = test - normal; + +	if (diff < MPU9250_ST_ACCEL(16) / 4) { +		return 1; +	} +	if (diff > MPU9250_ST_ACCEL(16) * 4) { +		return 1; +	} +	return 0; +} + +static uint8_t +ao_mpu9250_gyro_check(int16_t normal, int16_t test) +{ +	int16_t	diff = test - normal; + +	if (diff < 0) +		diff = -diff; +	if (diff < MPU9250_ST_GYRO(2000) / 4) { +		return 1; +	} +	if (diff > MPU9250_ST_GYRO(2000) * 4) { +		return 1; +	} +	return 0; +} + +static void +_ao_mpu9250_wait_alive(void) +{ +	uint8_t	i; + +	/* Wait for the chip to wake up */ +	for (i = 0; i < 30; i++) { +		ao_delay(AO_MS_TO_TICKS(100)); +		if (_ao_mpu9250_reg_read(MPU9250_WHO_AM_I) == MPU9250_I_AM_9250) +			break; +	} +	if (i == 30) +		ao_panic(AO_PANIC_SELF_TEST_MPU9250); +} + +#define ST_TRIES	10 +#define MAG_TRIES	10 + +static void +_ao_mpu9250_setup(void) +{ +	struct ao_mpu9250_sample	normal_mode, test_mode; +	int				errors; +	int				st_tries; +	int				mag_tries; + +	if (ao_mpu9250_configured) +		return; + +	_ao_mpu9250_wait_alive(); + +	/* Reset the whole chip */ + +	_ao_mpu9250_reg_write(MPU9250_PWR_MGMT_1, +			      (1 << MPU9250_PWR_MGMT_1_DEVICE_RESET)); + +	/* Wait for it to reset. If we talk too quickly, it appears to get confused */ + +	_ao_mpu9250_wait_alive(); + +	/* Reset signal conditioning, disabling I2C on SPI systems */ +	_ao_mpu9250_reg_write(MPU9250_USER_CTRL, +			      (0 << MPU9250_USER_CTRL_FIFO_EN) | +			      (1 << MPU9250_USER_CTRL_I2C_MST_EN) | +			      (AO_MPU9250_SPI << MPU9250_USER_CTRL_I2C_IF_DIS) | +			      (0 << MPU9250_USER_CTRL_FIFO_RESET) | +			      (0 << MPU9250_USER_CTRL_I2C_MST_RESET) | +			      (1 << MPU9250_USER_CTRL_SIG_COND_RESET)); + +	while (_ao_mpu9250_reg_read(MPU9250_USER_CTRL) & (1 << MPU9250_USER_CTRL_SIG_COND_RESET)) +		ao_delay(AO_MS_TO_TICKS(10)); + +	/* Reset signal paths */ +	_ao_mpu9250_reg_write(MPU9250_SIGNAL_PATH_RESET, +			      (1 << MPU9250_SIGNAL_PATH_RESET_GYRO_RESET) | +			      (1 << MPU9250_SIGNAL_PATH_RESET_ACCEL_RESET) | +			      (1 << MPU9250_SIGNAL_PATH_RESET_TEMP_RESET)); + +	_ao_mpu9250_reg_write(MPU9250_SIGNAL_PATH_RESET, +			      (0 << MPU9250_SIGNAL_PATH_RESET_GYRO_RESET) | +			      (0 << MPU9250_SIGNAL_PATH_RESET_ACCEL_RESET) | +			      (0 << MPU9250_SIGNAL_PATH_RESET_TEMP_RESET)); + +	/* Select clocks, disable sleep */ +	_ao_mpu9250_reg_write(MPU9250_PWR_MGMT_1, +			      (0 << MPU9250_PWR_MGMT_1_DEVICE_RESET) | +			      (0 << MPU9250_PWR_MGMT_1_SLEEP) | +			      (0 << MPU9250_PWR_MGMT_1_CYCLE) | +			      (0 << MPU9250_PWR_MGMT_1_TEMP_DIS) | +			      (MPU9250_PWR_MGMT_1_CLKSEL_PLL_X_AXIS << MPU9250_PWR_MGMT_1_CLKSEL)); + +	/* Set I2C clock and options */ +	_ao_mpu9250_reg_write(MPU9250_MST_CTRL, +			      (0 << MPU9250_MST_CTRL_MULT_MST_EN) | +			      (0 << MPU9250_MST_CTRL_WAIT_FOR_ES) | +			      (0 << MPU9250_MST_CTRL_SLV_3_FIFO_EN) | +			      (0 << MPU9250_MST_CTRL_I2C_MST_P_NSR) | +			      (MPU9250_MST_CTRL_I2C_MST_CLK_400 << MPU9250_MST_CTRL_I2C_MST_CLK)); + +	/* Set sample rate divider to sample at full speed */ +	_ao_mpu9250_reg_write(MPU9250_SMPRT_DIV, 0); + +	/* Disable filtering */ +	_ao_mpu9250_reg_write(MPU9250_CONFIG, +			      (MPU9250_CONFIG_EXT_SYNC_SET_DISABLED << MPU9250_CONFIG_EXT_SYNC_SET) | +			      (MPU9250_CONFIG_DLPF_CFG_250 << MPU9250_CONFIG_DLPF_CFG)); + +	for (st_tries = 0; st_tries < ST_TRIES; st_tries++) { +		errors = 0; + +		/* Configure accelerometer to +/-16G in self-test mode */ +		_ao_mpu9250_reg_write(MPU9250_ACCEL_CONFIG, +				      (1 << MPU9250_ACCEL_CONFIG_XA_ST) | +				      (1 << MPU9250_ACCEL_CONFIG_YA_ST) | +				      (1 << MPU9250_ACCEL_CONFIG_ZA_ST) | +				      (MPU9250_ACCEL_CONFIG_AFS_SEL_16G << MPU9250_ACCEL_CONFIG_AFS_SEL)); + +		/* Configure gyro to +/- 2000°/s in self-test mode */ +		_ao_mpu9250_reg_write(MPU9250_GYRO_CONFIG, +				      (1 << MPU9250_GYRO_CONFIG_XG_ST) | +				      (1 << MPU9250_GYRO_CONFIG_YG_ST) | +				      (1 << MPU9250_GYRO_CONFIG_ZG_ST) | +				      (MPU9250_GYRO_CONFIG_FS_SEL_2000 << MPU9250_GYRO_CONFIG_FS_SEL)); + +		ao_delay(AO_MS_TO_TICKS(200)); +		_ao_mpu9250_sample(&test_mode); + +		/* Configure accelerometer to +/-16G */ +		_ao_mpu9250_reg_write(MPU9250_ACCEL_CONFIG, +				      (0 << MPU9250_ACCEL_CONFIG_XA_ST) | +				      (0 << MPU9250_ACCEL_CONFIG_YA_ST) | +				      (0 << MPU9250_ACCEL_CONFIG_ZA_ST) | +				      (MPU9250_ACCEL_CONFIG_AFS_SEL_16G << MPU9250_ACCEL_CONFIG_AFS_SEL)); + +		/* Configure gyro to +/- 2000°/s */ +		_ao_mpu9250_reg_write(MPU9250_GYRO_CONFIG, +				      (0 << MPU9250_GYRO_CONFIG_XG_ST) | +				      (0 << MPU9250_GYRO_CONFIG_YG_ST) | +				      (0 << MPU9250_GYRO_CONFIG_ZG_ST) | +				      (MPU9250_GYRO_CONFIG_FS_SEL_2000 << MPU9250_GYRO_CONFIG_FS_SEL)); + +		ao_delay(AO_MS_TO_TICKS(200)); +		_ao_mpu9250_sample(&normal_mode); + +		errors += ao_mpu9250_accel_check(normal_mode.accel_x, test_mode.accel_x); +		errors += ao_mpu9250_accel_check(normal_mode.accel_y, test_mode.accel_y); +		errors += ao_mpu9250_accel_check(normal_mode.accel_z, test_mode.accel_z); + +		errors += ao_mpu9250_gyro_check(normal_mode.gyro_x, test_mode.gyro_x); +		errors += ao_mpu9250_gyro_check(normal_mode.gyro_y, test_mode.gyro_y); +		errors += ao_mpu9250_gyro_check(normal_mode.gyro_z, test_mode.gyro_z); +		if (!errors) +			break; +	} + +	if (st_tries == ST_TRIES) +		ao_sensor_errors = 1; + +	/* Set up the mag sensor */ + +	/* make sure it's alive */ +	for (mag_tries = 0; mag_tries < MAG_TRIES; mag_tries++) { +		if (_ao_mpu9250_mag_reg_read(MPU9250_MAG_WIA) == MPU9250_MAG_WIA_VALUE) +			break; +	} + +	if (mag_tries == MAG_TRIES) +		ao_sensor_errors = 1; + +	/* Select continuous mode 2 (100Hz), 16 bit samples */ + +	_ao_mpu9250_mag_reg_write(MPU9250_MAG_CNTL1, +				  (MPU9250_MAG_CNTL1_BIT_16 << MPU9250_MAG_CNTL1_BIT) | +				  (MPU9250_MAG_CNTL1_MODE_CONT_2 << MPU9250_MAG_CNTL1_MODE)); + +	/* Set i2c master to delay shadowing data until read is +	 * complete (avoids tearing the data) */ + +	_ao_mpu9250_reg_write(MPU9250_I2C_MST_DELAY_CTRL, +			      (1 << MPU9250_I2C_MST_DELAY_CTRL_DELAY_ES_SHADOW) | +			      (0 << MPU9250_I2C_MST_DELAY_CTRL_I2C_SLV4_DLY_EN) | +			      (0 << MPU9250_I2C_MST_DELAY_CTRL_I2C_SLV3_DLY_EN) | +			      (0 << MPU9250_I2C_MST_DELAY_CTRL_I2C_SLV2_DLY_EN) | +			      (0 << MPU9250_I2C_MST_DELAY_CTRL_I2C_SLV1_DLY_EN) | +			      (0 << MPU9250_I2C_MST_DELAY_CTRL_I2C_SLV0_DLY_EN)); + +	/* Set up i2c slave 0 to read the mag registers starting at HXL (3) */ + +	_ao_mpu9250_reg_write(MPU9250_I2C_SLV0_ADDR, +			      (1 << 7) | MPU9250_MAG_ADDR); + +	_ao_mpu9250_reg_write(MPU9250_I2C_SLV0_REG, +			      MPU9250_MAG_HXL); + +	/* Byte swap so the mag values match the gyro/accel. Read 7 bytes +	 * to include the status register +	 */ + +	_ao_mpu9250_reg_write(MPU9250_I2C_SLV0_CTRL, +			      (1 << MPU9250_I2C_SLV0_CTRL_I2C_SLV0_EN) | +			      (1 << MPU9250_I2C_SLV0_CTRL_I2C_SLV0_BYTE_SW) | +			      (0 << MPU9250_I2C_SLV0_CTRL_I2C_SLV0_REG_DIS) | +			      (1 << MPU9250_I2C_SLV0_CTRL_I2C_SLV0_GRP) | +			      (MPU9250_MAG_ST2 - MPU9250_MAG_HXL + 1) << MPU9250_I2C_SLV0_CTRL_I2C_SLV0_LENG); + +	/* Filter to about 100Hz, which also sets the gyro rate to 1000Hz */ +	_ao_mpu9250_reg_write(MPU9250_CONFIG, +			      (MPU9250_CONFIG_FIFO_MODE_REPLACE << MPU9250_CONFIG_FIFO_MODE) | +			      (MPU9250_CONFIG_EXT_SYNC_SET_DISABLED << MPU9250_CONFIG_EXT_SYNC_SET) | +			      (MPU9250_CONFIG_DLPF_CFG_92 << MPU9250_CONFIG_DLPF_CFG)); + +	/* Set sample rate divider to sample at 200Hz (v = gyro/rate - 1) */ +	_ao_mpu9250_reg_write(MPU9250_SMPRT_DIV, +			      1000 / 200 - 1); + +	ao_delay(AO_MS_TO_TICKS(100)); +	ao_mpu9250_configured = 1; +} + +struct ao_mpu9250_sample	ao_mpu9250_current; + +static void +ao_mpu9250(void) +{ +	struct ao_mpu9250_sample	sample; + +	/* ao_mpu9250_init already grabbed the SPI bus and mutex */ +	_ao_mpu9250_setup(); +	ao_mpu9250_spi_put(); +	for (;;) +	{ +		ao_mpu9250_spi_get(); +		_ao_mpu9250_sample(&sample); +		ao_mpu9250_spi_put(); +		ao_arch_block_interrupts(); +		ao_mpu9250_current = sample; +		AO_DATA_PRESENT(AO_DATA_MPU9250); +		AO_DATA_WAIT(); +		ao_arch_release_interrupts(); +	} +} + +static struct ao_task ao_mpu9250_task; + +static void +ao_mpu9250_show(void) +{ +	printf ("Accel: %7d %7d %7d Gyro: %7d %7d %7d Mag: %7d %7d %7d\n", +		ao_mpu9250_current.accel_x, +		ao_mpu9250_current.accel_y, +		ao_mpu9250_current.accel_z, +		ao_mpu9250_current.gyro_x, +		ao_mpu9250_current.gyro_y, +		ao_mpu9250_current.gyro_z, +		ao_mpu9250_current.mag_x, +		ao_mpu9250_current.mag_y, +		ao_mpu9250_current.mag_z); +} + +#if MPU9250_TEST + +static void +ao_mpu9250_read(void) +{ +	uint8_t	addr; +	uint8_t val; + +	ao_cmd_hex(); +	if (ao_cmd_status != ao_cmd_success) +		return; +	addr = ao_cmd_lex_i; +	ao_mpu9250_spi_get(); +	val = _ao_mpu9250_reg_read(addr); +	ao_mpu9250_spi_put(); +	printf("Addr %02x val %02x\n", addr, val); +} + +static void +ao_mpu9250_write(void) +{ +	uint8_t	addr; +	uint8_t val; + +	ao_cmd_hex(); +	if (ao_cmd_status != ao_cmd_success) +		return; +	addr = ao_cmd_lex_i; +	ao_cmd_hex(); +	if (ao_cmd_status != ao_cmd_success) +		return; +	val = ao_cmd_lex_i; +	printf("Addr %02x val %02x\n", addr, val); +	ao_mpu9250_spi_get(); +	_ao_mpu9250_reg_write(addr, val); +	ao_mpu9250_spi_put(); +} + +static void +ao_mpu9250_mag_read(void) +{ +	uint8_t	addr; +	uint8_t val; + +	ao_cmd_hex(); +	if (ao_cmd_status != ao_cmd_success) +		return; +	addr = ao_cmd_lex_i; +	ao_mpu9250_spi_get(); +	val = _ao_mpu9250_mag_reg_read(addr); +	ao_mpu9250_spi_put(); +	printf("Addr %02x val %02x\n", addr, val); +} + +static void +ao_mpu9250_mag_write(void) +{ +	uint8_t	addr; +	uint8_t val; + +	ao_cmd_hex(); +	if (ao_cmd_status != ao_cmd_success) +		return; +	addr = ao_cmd_lex_i; +	ao_cmd_hex(); +	if (ao_cmd_status != ao_cmd_success) +		return; +	val = ao_cmd_lex_i; +	printf("Addr %02x val %02x\n", addr, val); +	ao_mpu9250_spi_get(); +	_ao_mpu9250_mag_reg_write(addr, val); +	ao_mpu9250_spi_put(); +} + +#endif /* MPU9250_TEST */ + +static const struct ao_cmds ao_mpu9250_cmds[] = { +	{ ao_mpu9250_show,	"I\0Show MPU9250 status" }, +#if MPU9250_TEST +	{ ao_mpu9250_read,	"R <addr>\0Read MPU9250 register" }, +	{ ao_mpu9250_write,	"W <addr> <val>\0Write MPU9250 register" }, +	{ ao_mpu9250_mag_read,	"G <addr>\0Read MPU9250 Mag register" }, +	{ ao_mpu9250_mag_write,	"P <addr> <val>\0Write MPU9250 Mag register" }, +#endif +	{ 0, NULL } +}; + +void +ao_mpu9250_init(void) +{ +	ao_mpu9250_configured = 0; + +	ao_add_task(&ao_mpu9250_task, ao_mpu9250, "mpu9250"); + +#if AO_MPU9250_SPI +	ao_spi_init_cs(AO_MPU9250_SPI_CS_PORT, (1 << AO_MPU9250_SPI_CS_PIN)); + +	/* Pretend to be the mpu9250 task. Grab the SPI bus right away and +	 * hold it for the task so that nothing else uses the SPI bus before +	 * we get the I2C mode disabled in the chip +	 */ + +	ao_cur_task = &ao_mpu9250_task; +	ao_spi_get(AO_MPU9250_SPI_BUS, AO_SPI_SPEED_1MHz); +	ao_cur_task = NULL; +#endif +	ao_cmd_register(&ao_mpu9250_cmds[0]); +} +#endif diff --git a/src/drivers/ao_mpu9250.h b/src/drivers/ao_mpu9250.h new file mode 100644 index 00000000..5e8e0885 --- /dev/null +++ b/src/drivers/ao_mpu9250.h @@ -0,0 +1,340 @@ +/* + * Copyright © 2012 Keith Packard <keithp@keithp.com> + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation; either version 2 of the License, or + * (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, but + * WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU + * General Public License for more details. + * + * You should have received a copy of the GNU General Public License along + * with this program; if not, write to the Free Software Foundation, Inc., + * 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA. + */ + +#ifndef _AO_MPU9250_H_ +#define _AO_MPU9250_H_ + +#ifndef M_PI +#define M_PI 3.1415926535897832384626433 +#endif + +#define MPU9250_ADDR_WRITE	0xd0 +#define MPU9250_ADDR_READ	0xd1 + +/* From Tridge */ +#define MPUREG_XG_OFFS_TC 0x00 +#define MPUREG_YG_OFFS_TC 0x01 +#define MPUREG_ZG_OFFS_TC 0x02 +#define MPUREG_X_FINE_GAIN 0x03 +#define MPUREG_Y_FINE_GAIN 0x04 +#define MPUREG_Z_FINE_GAIN 0x05 +#define MPUREG_XA_OFFS_H 0x06 // X axis accelerometer offset (high byte) +#define MPUREG_XA_OFFS_L 0x07 // X axis accelerometer offset (low byte) +#define MPUREG_YA_OFFS_H 0x08 // Y axis accelerometer offset (high byte) +#define MPUREG_YA_OFFS_L 0x09 // Y axis accelerometer offset (low byte) +#define MPUREG_ZA_OFFS_H 0x0A // Z axis accelerometer offset (high byte) +#define MPUREG_ZA_OFFS_L 0x0B // Z axis accelerometer offset (low byte) +#define MPUREG_PRODUCT_ID 0x0C // Product ID Register +#define MPUREG_XG_OFFS_USRH 0x13 // X axis gyro offset (high byte) +#define MPUREG_XG_OFFS_USRL 0x14 // X axis gyro offset (low byte) +#define MPUREG_YG_OFFS_USRH 0x15 // Y axis gyro offset (high byte) +#define MPUREG_YG_OFFS_USRL 0x16 // Y axis gyro offset (low byte) +#define MPUREG_ZG_OFFS_USRH 0x17 // Z axis gyro offset (high byte) +#define MPUREG_ZG_OFFS_USRL 0x18 // Z axis gyro offset (low byte) + +#define MPU9250_SMPRT_DIV	0x19 + +#define MPU9250_CONFIG		0x1a + +#define  MPU9250_CONFIG_FIFO_MODE	6 +# define  MPU9250_CONFIG_FIFO_MODE_REPLACE	0 +# define  MPU9250_CONFIG_FIFO_MODE_DROP		1 + +#define  MPU9250_CONFIG_EXT_SYNC_SET	3 +#define  MPU9250_CONFIG_EXT_SYNC_SET_DISABLED		0 +#define  MPU9250_CONFIG_EXT_SYNC_SET_TEMP_OUT_L		1 +#define  MPU9250_CONFIG_EXT_SYNC_SET_GYRO_XOUT_L	2 +#define  MPU9250_CONFIG_EXT_SYNC_SET_GYRO_YOUT_L	3 +#define  MPU9250_CONFIG_EXT_SYNC_SET_GYRO_ZOUT_L	4 +#define  MPU9250_CONFIG_EXT_SYNC_SET_ACCEL_XOUT_L	5 +#define  MPU9250_CONFIG_EXT_SYNC_SET_ACCEL_YOUT_L	6 +#define  MPU9250_CONFIG_EXT_SYNC_SET_ACCEL_ZOUT_L	7 +#define  MPU9250_CONFIG_EXT_SYNC_SET_MASK		7 + +#define  MPU9250_CONFIG_DLPF_CFG	0 +#define  MPU9250_CONFIG_DLPF_CFG_250			0 +#define  MPU9250_CONFIG_DLPF_CFG_184			1 +#define  MPU9250_CONFIG_DLPF_CFG_92			2 +#define  MPU9250_CONFIG_DLPF_CFG_41			3 +#define  MPU9250_CONFIG_DLPF_CFG_20			4 +#define  MPU9250_CONFIG_DLPF_CFG_10			5 +#define  MPU9250_CONFIG_DLPF_CFG_5			6 +#define  MPU9250_CONFIG_DLPF_CFG_MASK			7 + +#define MPU9250_GYRO_CONFIG	0x1b +# define MPU9250_GYRO_CONFIG_XG_ST	7 +# define MPU9250_GYRO_CONFIG_YG_ST	6 +# define MPU9250_GYRO_CONFIG_ZG_ST	5 +# define MPU9250_GYRO_CONFIG_FS_SEL	3 +# define MPU9250_GYRO_CONFIG_FS_SEL_250		0 +# define MPU9250_GYRO_CONFIG_FS_SEL_500		1 +# define MPU9250_GYRO_CONFIG_FS_SEL_1000	2 +# define MPU9250_GYRO_CONFIG_FS_SEL_2000	3 +# define MPU9250_GYRO_CONFIG_FS_SEL_MASK	3 +# define MPU9250_GYRO_CONFIG_FCHOICE_B	0 +# define MPU9250_GYRO_CONFIG_FCHOICE_B_8800	3 +# define MPU9250_GYRO_CONFIG_FCHOICE_B_3600	2 +# define MPU9250_GYRO_CONFIG_FCHOICE_B_LOW	0 + +#define MPU9250_ACCEL_CONFIG	0x1c +# define MPU9250_ACCEL_CONFIG_XA_ST	7 +# define MPU9250_ACCEL_CONFIG_YA_ST	6 +# define MPU9250_ACCEL_CONFIG_ZA_ST	5 +# define MPU9250_ACCEL_CONFIG_AFS_SEL	3 +# define MPU9250_ACCEL_CONFIG_AFS_SEL_2G		0 +# define MPU9250_ACCEL_CONFIG_AFS_SEL_4G		1 +# define MPU9250_ACCEL_CONFIG_AFS_SEL_8G		2 +# define MPU9250_ACCEL_CONFIG_AFS_SEL_16G	3 +# define MPU9250_ACCEL_CONFIG_AFS_SEL_MASK	3 + +#define MPU9250_MST_CTRL	0x24 +#define  MPU9250_MST_CTRL_MULT_MST_EN		7 +#define  MPU9250_MST_CTRL_WAIT_FOR_ES		6 +#define  MPU9250_MST_CTRL_SLV_3_FIFO_EN		5 +#define  MPU9250_MST_CTRL_I2C_MST_P_NSR		4 +#define  MPU9250_MST_CTRL_I2C_MST_CLK		0 +#define  MPU9250_MST_CTRL_I2C_MST_CLK_348		0 +#define  MPU9250_MST_CTRL_I2C_MST_CLK_333		1 +#define  MPU9250_MST_CTRL_I2C_MST_CLK_320		2 +#define  MPU9250_MST_CTRL_I2C_MST_CLK_308		3 +#define  MPU9250_MST_CTRL_I2C_MST_CLK_296		4 +#define  MPU9250_MST_CTRL_I2C_MST_CLK_286		5 +#define  MPU9250_MST_CTRL_I2C_MST_CLK_276		6 +#define  MPU9250_MST_CTRL_I2C_MST_CLK_267		7 +#define  MPU9250_MST_CTRL_I2C_MST_CLK_258		8 +#define  MPU9250_MST_CTRL_I2C_MST_CLK_500		9 +#define  MPU9250_MST_CTRL_I2C_MST_CLK_471		10 +#define  MPU9250_MST_CTRL_I2C_MST_CLK_444		11 +#define  MPU9250_MST_CTRL_I2C_MST_CLK_421		12 +#define  MPU9250_MST_CTRL_I2C_MST_CLK_400		13 +#define  MPU9250_MST_CTRL_I2C_MST_CLK_381		14 +#define  MPU9250_MST_CTRL_I2C_MST_CLK_364		15 +#define  MPU9250_MST_CTRL_I2C_MST_CLK_MASK		15 + +#define MPU9250_I2C_SLV0_ADDR	0x25 +#define MPU9250_I2C_SLV0_REG	0x26 +#define MPU9250_I2C_SLV0_CTRL	0x27 + +#define  MPU9250_I2C_SLV0_CTRL_I2C_SLV0_EN	7 +#define  MPU9250_I2C_SLV0_CTRL_I2C_SLV0_BYTE_SW	6 +#define  MPU9250_I2C_SLV0_CTRL_I2C_SLV0_REG_DIS	5 +#define  MPU9250_I2C_SLV0_CTRL_I2C_SLV0_GRP	4 +#define  MPU9250_I2C_SLV0_CTRL_I2C_SLV0_LENG	0 + +#define MPU9250_I2C_SLV1_ADDR	0x28 +#define MPU9250_I2C_SLV1_REG	0x29 +#define MPU9250_I2C_SLV1_CTRL	0x2a + +#define MPU9250_I2C_SLV2_ADDR	0x2b +#define MPU9250_I2C_SLV2_REG	0x2c +#define MPU9250_I2C_SLV2_CTRL	0x2d + +#define MPU9250_I2C_SLV3_ADDR	0x2e +#define MPU9250_I2C_SLV3_REG	0x2f +#define MPU9250_I2C_SLV3_CTRL	0x30 + +#define MPU9250_I2C_SLV4_ADDR	0x31 +#define MPU9250_I2C_SLV4_REG	0x32 +#define MPU9250_I2C_SLV4_DO	0x33 +#define MPU9250_I2C_SLV4_CTRL	0x34 +#define  MPU9250_I2C_SLV4_CTRL_I2C_SLV4_EN	7 +#define  MPU9250_I2C_SLV4_CTRL_SLV4_DONE_INT_EN	6 +#define  MPU9250_I2C_SLV4_CTRL_I2C_SLV4_REG_DIS	5 +#define  MPU9250_I2C_SLV4_CTRL_I2C_MST_DLY	0 + +#define MPU9250_I2C_SLV4_DI	0x35 + +#define MPU9250_I2C_MST_STATUS	0x36 + +#define MPU9250_INT_PIN_CFG	0x37 + +#define MPU9250_INT_ENABLE	0x38 +#define  MPU9250_INT_ENABLE_WOM_EN		6 +#define  MPU9250_INT_ENABLE_FIFO_OFLOW_EN	4 +#define  MPU9250_INT_ENABLE_FSYNC_INT_EN	3 +#define  MPU9250_INT_ENABLE_RAW_RDY_EN		0 + +#define MPU9250_INT_STATUS	0x3a +#define  MPU9250_INT_STATUS_WOM_INT		6 +#define  MPU9250_INT_STATUS_FIFO_OFLOW_INT	4 +#define  MPU9250_INT_STATUS_FSYNC_INT		3 +#define  MPU9250_INT_STATUS_RAW_RDY_INT		0 + +#define MPU9250_ACCEL_XOUT_H		0x3b +#define MPU9250_ACCEL_XOUT_L		0x3c +#define MPU9250_ACCEL_YOUT_H		0x3d +#define MPU9250_ACCEL_YOUT_L		0x3e +#define MPU9250_ACCEL_ZOUT_H		0x3f +#define MPU9250_ACCEL_ZOUT_L		0x40 +#define MPU9250_TEMP_H			0x41 +#define MPU9250_TEMP_L			0x42 +#define MPU9250_GYRO_XOUT_H		0x43 +#define MPU9250_GYRO_XOUT_L		0x44 +#define MPU9250_GYRO_YOUT_H		0x45 +#define MPU9250_GYRO_YOUT_L		0x46 +#define MPU9250_GYRO_ZOUT_H		0x47 +#define MPU9250_GYRO_ZOUT_L		0x48 + +#define MPU9250_I2C_MST_DELAY_CTRL	0x67 + +#define  MPU9250_I2C_MST_DELAY_CTRL_DELAY_ES_SHADOW	7 +#define  MPU9250_I2C_MST_DELAY_CTRL_I2C_SLV4_DLY_EN	4 +#define  MPU9250_I2C_MST_DELAY_CTRL_I2C_SLV3_DLY_EN	3 +#define  MPU9250_I2C_MST_DELAY_CTRL_I2C_SLV2_DLY_EN	2 +#define  MPU9250_I2C_MST_DELAY_CTRL_I2C_SLV1_DLY_EN	1 +#define  MPU9250_I2C_MST_DELAY_CTRL_I2C_SLV0_DLY_EN	0 + +#define MPU9250_SIGNAL_PATH_RESET	0x68 +#define MPU9250_SIGNAL_PATH_RESET_GYRO_RESET	2 +#define MPU9250_SIGNAL_PATH_RESET_ACCEL_RESET	1 +#define MPU9250_SIGNAL_PATH_RESET_TEMP_RESET	0 + +#define MPU9250_USER_CTRL		0x6a +#define MPU9250_USER_CTRL_FIFO_EN		6 +#define MPU9250_USER_CTRL_I2C_MST_EN		5 +#define MPU9250_USER_CTRL_I2C_IF_DIS		4 +#define MPU9250_USER_CTRL_FIFO_RESET		2 +#define MPU9250_USER_CTRL_I2C_MST_RESET		1 +#define MPU9250_USER_CTRL_SIG_COND_RESET	0 + +#define MPU9250_PWR_MGMT_1	0x6b +#define MPU9250_PWR_MGMT_1_DEVICE_RESET		7 +#define MPU9250_PWR_MGMT_1_SLEEP		6 +#define MPU9250_PWR_MGMT_1_CYCLE		5 +#define MPU9250_PWR_MGMT_1_TEMP_DIS		3 +#define MPU9250_PWR_MGMT_1_CLKSEL		0 +#define MPU9250_PWR_MGMT_1_CLKSEL_INTERNAL		0 +#define MPU9250_PWR_MGMT_1_CLKSEL_PLL_X_AXIS		1 +#define MPU9250_PWR_MGMT_1_CLKSEL_PLL_Y_AXIS		2 +#define MPU9250_PWR_MGMT_1_CLKSEL_PLL_Z_AXIS		3 +#define MPU9250_PWR_MGMT_1_CLKSEL_PLL_EXTERNAL_32K	4 +#define MPU9250_PWR_MGMT_1_CLKSEL_PLL_EXTERNAL_19M	5 +#define MPU9250_PWR_MGMT_1_CLKSEL_STOP			7 +#define MPU9250_PWR_MGMT_1_CLKSEL_MASK			7 + +#define MPU9250_PWR_MGMT_2	0x6c + +#define MPU9250_WHO_AM_I	0x75 +#define MPU9250_I_AM_9250	0x71 + +/* AK8963 mag sensor on the I2C bus */ + +#define MPU9250_MAG_ADDR	0x0c + +#define MPU9250_MAG_WIA		0x00 +#define  MPU9250_MAG_WIA_VALUE		0x48 + +#define MPU9250_MAG_INFO	0x01 +#define MPU9250_MAG_ST1	0x02 +#define  MPU9250_MAG_ST1_DOR		1 +#define  MPU9250_MAG_ST1_DRDY		0 + +#define MPU9250_MAG_HXL		0x03 +#define MPU9250_MAG_HXH		0x04 +#define MPU9250_MAG_HYL		0x05 +#define MPU9250_MAG_HYH		0x06 +#define MPU9250_MAG_HZL		0x07 +#define MPU9250_MAG_HZH		0x08 +#define MPU9250_MAG_ST2		0x09 +#define  MPU9250_MAG_ST2_BITM		4 +#define  MPU9250_MAG_ST2_HOFL		3 + +#define MPU9250_MAG_CNTL1	0x0a +#define  MPU9250_MAG_CNTL1_MODE		0 +#define  MPU9250_MAG_CNTL1_MODE_POWER_DOWN	0x0 +#define  MPU9250_MAG_CNTL1_MODE_SINGLE		0x1 +#define  MPU9250_MAG_CNTL1_MODE_CONT_1		0x2	/* 8Hz */ +#define  MPU9250_MAG_CNTL1_MODE_CONT_2		0x6	/* 100Hz */ +#define  MPU9250_MAG_CNTL1_MODE_EXTERNAL	0x4 +#define  MPU9250_MAG_CNTL1_MODE_SELF_TEST	0x8 +#define  MPU9250_MAG_CNTL1_MODE_FUSE_ACCESS	0xf + +#define  MPU9250_MAG_CNTL1_BIT		4 +#define  MPU9250_MAG_CNTL1_BIT_14		0 +#define  MPU9250_MAG_CNTL1_BIT_16		1 + +#define MPU9250_MAG_CNTL2	0x0b +#define  MPU9250_MAG_CNTL2_SRST		0 + +#define MPU9250_MAG_ASTC	0x0c +#define  MPU9250_MAG_ASTC_SELF		6 + +#define MPU9250_MAG_TS1		0x0d +#define MPU9250_MAG_TS2		0x0e +#define MPU9250_MAG_I2CDIS	0x0f +#define  MPU9250_MAG_I2CDIS_VALUE	0x1d + +#define MPU9250_MAG_ASAX	0x10 +#define MPU9250_MAG_ASAY	0x11 +#define MPU9250_MAG_ASAZ	0x12 + +/* Self test acceleration is approximately 0.5g */ +#define MPU9250_ST_ACCEL(full_scale)	(32767 / ((full_scale) * 2)) + +/* Self test gyro is approximately 50°/s */ +#define MPU9250_ST_GYRO(full_scale)	((int16_t) (((int32_t) 32767 * (int32_t) 50) / (full_scale))) + +#define MPU9250_GYRO_FULLSCALE	((float) 2000 * M_PI/180.0) + +static inline float +ao_mpu9250_gyro(float sensor) { +	return sensor * ((float) (MPU9250_GYRO_FULLSCALE / 32767.0)); +} + +#define MPU9250_ACCEL_FULLSCALE	16 + +static inline float +ao_mpu9250_accel(int16_t sensor) { +	return (float) sensor * ((float) (MPU9250_ACCEL_FULLSCALE * GRAVITY / 32767.0)); +} + +struct ao_mpu9250_sample { +	int16_t		accel_x; +	int16_t		accel_y; +	int16_t		accel_z; +	int16_t		temp; +	int16_t		gyro_x; +	int16_t		gyro_y; +	int16_t		gyro_z; +	int16_t		mag_x; +	int16_t		mag_y; +	int16_t		mag_z; +}; + +extern struct ao_mpu9250_sample	ao_mpu9250_current; + +void +ao_mpu9250_init(void); + +/* Product ID Description for MPU9250 + * high 4 bits low 4 bits + * Product Name Product Revision + */ +#define MPU9250ES_REV_C4 0x14	/* 0001 0100 */ +#define MPU9250ES_REV_C5 0x15	/* 0001 0101 */ +#define MPU9250ES_REV_D6 0x16	/* 0001 0110 */ +#define MPU9250ES_REV_D7 0x17	/* 0001 0111 */ +#define MPU9250ES_REV_D8 0x18	/* 0001 1000 */ +#define MPU9250_REV_C4 0x54	/* 0101 0100 */ +#define MPU9250_REV_C5 0x55	/* 0101 0101 */ +#define MPU9250_REV_D6 0x56	/* 0101 0110 */ +#define MPU9250_REV_D7 0x57	/* 0101 0111 */ +#define MPU9250_REV_D8 0x58	/* 0101 1000 */ +#define MPU9250_REV_D9 0x59	/* 0101 1001 */ + +#endif /* _AO_MPU9250_H_ */ diff --git a/src/easymega-v1.0/ao_pins.h b/src/easymega-v1.0/ao_pins.h index 42a8b09c..b8016478 100644 --- a/src/easymega-v1.0/ao_pins.h +++ b/src/easymega-v1.0/ao_pins.h @@ -69,6 +69,8 @@  #define AO_CONFIG_MAX_SIZE                     1024  #define LOG_ERASE_MARK                         0x55  #define LOG_MAX_ERASE                          128 +#define AO_LOG_FORMAT				AO_LOG_FORMAT_TELEMEGA +  #define HAS_EEPROM		1  #define USE_INTERNAL_FLASH	0  #define USE_EEPROM_CONFIG	1 @@ -84,7 +86,7 @@  #define HAS_SPI_1		1  #define SPI_1_PA5_PA6_PA7	1	/* Barometer */  #define SPI_1_PB3_PB4_PB5	1	/* Accelerometer, Gyro */ -#define SPI_1_PE13_PE14_PE15	0	 +#define SPI_1_PE13_PE14_PE15	0  #define SPI_1_OSPEEDR		STM_OSPEEDR_10MHz  #define HAS_SPI_2		1 diff --git a/src/kernel/ao.h b/src/kernel/ao.h index e56fbb2e..139050cf 100644 --- a/src/kernel/ao.h +++ b/src/kernel/ao.h @@ -78,6 +78,7 @@ typedef AO_PORT_TYPE ao_port_t;  #define AO_PANIC_SELF_TEST_CC1120	0x40 | 1	/* Self test failure */  #define AO_PANIC_SELF_TEST_HMC5883	0x40 | 2	/* Self test failure */  #define AO_PANIC_SELF_TEST_MPU6000	0x40 | 3	/* Self test failure */ +#define AO_PANIC_SELF_TEST_MPU9250	0x40 | 3	/* Self test failure */  #define AO_PANIC_SELF_TEST_MS5607	0x40 | 4	/* Self test failure */  /* Stop the operating system, beeping and blinking the reason */ diff --git a/src/kernel/ao_cmd.c b/src/kernel/ao_cmd.c index 881f3500..c1e9cef2 100644 --- a/src/kernel/ao_cmd.c +++ b/src/kernel/ao_cmd.c @@ -304,7 +304,7 @@ version(void)  	       , ao_flight_number  #endif  #if HAS_LOG -	       , ao_log_format +	       , AO_LOG_FORMAT  #if !DISABLE_LOG_SPACE  	       , (unsigned long) ao_storage_log_max  #endif diff --git a/src/kernel/ao_data.h b/src/kernel/ao_data.h index d62852ef..88d0e916 100644 --- a/src/kernel/ao_data.h +++ b/src/kernel/ao_data.h @@ -41,6 +41,13 @@  #define AO_DATA_MPU6000	0  #endif +#if HAS_MPU9250 +#include <ao_mpu9250.h> +#define AO_DATA_MPU9250	(1 << 2) +#else +#define AO_DATA_MPU9250	0 +#endif +  #if HAS_HMC5883  #include <ao_hmc5883.h>  #define AO_DATA_HMC5883	(1 << 3) @@ -57,7 +64,7 @@  #ifdef AO_DATA_RING -#define AO_DATA_ALL	(AO_DATA_ADC|AO_DATA_MS5607|AO_DATA_MPU6000|AO_DATA_HMC5883|AO_DATA_MMA655X) +#define AO_DATA_ALL	(AO_DATA_ADC|AO_DATA_MS5607|AO_DATA_MPU6000|AO_DATA_HMC5883|AO_DATA_MMA655X|AO_DATA_MPU9250)  struct ao_data {  	uint16_t			tick; @@ -74,6 +81,9 @@ struct ao_data {  	int16_t				z_accel;  #endif  #endif +#if HAS_MPU9250 +	struct ao_mpu9250_sample	mpu9250; +#endif  #if HAS_HMC5883  	struct ao_hmc5883_sample	hmc5883;  #endif @@ -320,6 +330,47 @@ typedef int16_t angle_t;	/* in degrees */  #define ao_data_pitch(packet)	((packet)->mpu6000.gyro_x)  #define ao_data_yaw(packet)	((packet)->mpu6000.gyro_z) +static inline float ao_convert_gyro(float sensor) +{ +	return ao_mpu6000_gyro(sensor); +} + +static inline float ao_convert_accel(int16_t sensor) +{ +	return ao_mpu6000_accel(sensor); +} + +#endif + +#if !HAS_GYRO && HAS_MPU9250 + +#define HAS_GYRO	1 + +typedef int16_t	gyro_t;		/* in raw sample units */ +typedef int16_t angle_t;	/* in degrees */ + +/* Y axis is aligned with the direction of motion (along) */ +/* X axis is aligned in the other board axis (across) */ +/* Z axis is aligned perpendicular to the board (through) */ + +#define ao_data_along(packet)	((packet)->mpu9250.accel_y) +#define ao_data_across(packet)	((packet)->mpu9250.accel_x) +#define ao_data_through(packet)	((packet)->mpu9250.accel_z) + +#define ao_data_roll(packet)	((packet)->mpu9250.gyro_y) +#define ao_data_pitch(packet)	((packet)->mpu9250.gyro_x) +#define ao_data_yaw(packet)	((packet)->mpu9250.gyro_z) + +static inline float ao_convert_gyro(float sensor) +{ +	return ao_mpu9250_gyro(sensor); +} + +static inline float ao_convert_accel(int16_t sensor) +{ +	return ao_mpu9250_accel(sensor); +} +  #endif  #if !HAS_MAG && HAS_HMC5883 @@ -334,4 +385,21 @@ typedef int16_t ao_mag_t;		/* in raw sample units */  #endif +#if !HAS_MAG && HAS_MPU9250 + +#define HAS_MAG		1 + +typedef int16_t ao_mag_t;		/* in raw sample units */ + +/* Note that this order is different from the accel and gyro. For some + * reason, the mag sensor axes aren't the same as the other two + * sensors. Also, the Z axis is flipped in sign. + */ + +#define ao_data_mag_along(packet)	((packet)->mpu9250.mag_x) +#define ao_data_mag_across(packet)	((packet)->mpu9250.mag_y) +#define ao_data_mag_through(packet)	((packet)->mpu9250.mag_z) + +#endif +  #endif /* _AO_DATA_H_ */ diff --git a/src/kernel/ao_flight.c b/src/kernel/ao_flight.c index f06125cd..cb02c454 100644 --- a/src/kernel/ao_flight.c +++ b/src/kernel/ao_flight.c @@ -21,7 +21,7 @@  #include <ao_log.h>  #endif -#if HAS_MPU6000 +#if HAS_MPU6000 || HAS_MPU9250  #include <ao_quaternion.h>  #endif diff --git a/src/kernel/ao_gps_report.c b/src/kernel/ao_gps_report.c index 39688fea..75c2f367 100644 --- a/src/kernel/ao_gps_report.c +++ b/src/kernel/ao_gps_report.c @@ -45,13 +45,13 @@ ao_gps_report(void)  			gps_log.u.gps_time.minute = gps_data.minute;  			gps_log.u.gps_time.second = gps_data.second;  			gps_log.u.gps_time.flags = gps_data.flags; -			ao_log_data(&gps_log); +			ao_log_write(&gps_log);  			gps_log.type = AO_LOG_GPS_LAT;  			gps_log.u.gps_latitude = gps_data.latitude; -			ao_log_data(&gps_log); +			ao_log_write(&gps_log);  			gps_log.type = AO_LOG_GPS_LON;  			gps_log.u.gps_longitude = gps_data.longitude; -			ao_log_data(&gps_log); +			ao_log_write(&gps_log);  			gps_log.type = AO_LOG_GPS_ALT;  			gps_log.u.gps_altitude.altitude_low = gps_data.altitude_low;  #if HAS_WIDE_GPS @@ -59,14 +59,14 @@ ao_gps_report(void)  #else  			gps_log.u.gps_altitude.altitude_high = 0xffff;  #endif -			ao_log_data(&gps_log); +			ao_log_write(&gps_log);  			if (!date_reported && (gps_data.flags & AO_GPS_DATE_VALID)) {  				gps_log.type = AO_LOG_GPS_DATE;  				gps_log.u.gps_date.year = gps_data.year;  				gps_log.u.gps_date.month = gps_data.month;  				gps_log.u.gps_date.day = gps_data.day;  				gps_log.u.gps_date.extra = 0; -				date_reported = ao_log_data(&gps_log); +				date_reported = ao_log_write(&gps_log);  			}  		}  		if (new & AO_GPS_NEW_TRACKING) { @@ -78,7 +78,7 @@ ao_gps_report(void)  					if ((gps_log.u.gps_sat.svid = gps_tracking_data.sats[c].svid))  					{  						gps_log.u.gps_sat.c_n = gps_tracking_data.sats[c].c_n_1; -						ao_log_data(&gps_log); +						ao_log_write(&gps_log);  					}  			}  		} diff --git a/src/kernel/ao_gps_report_mega.c b/src/kernel/ao_gps_report_mega.c index 8a298655..85614b85 100644 --- a/src/kernel/ao_gps_report_mega.c +++ b/src/kernel/ao_gps_report_mega.c @@ -105,7 +105,7 @@ ao_gps_report_mega(void)  			gps_log.u.gps.hdop = gps_data.hdop;  			gps_log.u.gps.vdop = gps_data.vdop;  			gps_log.u.gps.mode = gps_data.mode; -			ao_log_mega(&gps_log); +			ao_log_write(&gps_log);  		}  		if ((new & AO_GPS_NEW_TRACKING) && (n = gps_tracking_data.channels) != 0) {  			gps_log.tick = ao_gps_tick; @@ -120,7 +120,7 @@ ao_gps_report_mega(void)  						break;  				}  			gps_log.u.gps_sat.channels = i; -			ao_log_mega(&gps_log); +			ao_log_write(&gps_log);  		}  	}  } diff --git a/src/kernel/ao_gps_report_metrum.c b/src/kernel/ao_gps_report_metrum.c index 508f1519..523fb17f 100644 --- a/src/kernel/ao_gps_report_metrum.c +++ b/src/kernel/ao_gps_report_metrum.c @@ -47,7 +47,7 @@ ao_gps_report_metrum(void)  			gps_log.u.gps.longitude = gps_data.longitude;  			gps_log.u.gps.altitude_low = gps_data.altitude_low;  			gps_log.u.gps.altitude_high = gps_data.altitude_high; -			ao_log_metrum(&gps_log); +			ao_log_write(&gps_log);  			gps_log.type = AO_LOG_GPS_TIME;  			gps_log.u.gps_time.hour = gps_data.hour; @@ -58,7 +58,7 @@ ao_gps_report_metrum(void)  			gps_log.u.gps_time.month = gps_data.month;  			gps_log.u.gps_time.day = gps_data.day;  			gps_log.u.gps_time.pdop = gps_data.pdop; -			ao_log_metrum(&gps_log); +			ao_log_write(&gps_log);  		}  		if ((new & AO_GPS_NEW_TRACKING) && (n = gps_tracking_data.channels)) { @@ -71,7 +71,7 @@ ao_gps_report_metrum(void)  					if (i == 4) {  						gps_log.u.gps_sat.channels = i;  						gps_log.u.gps_sat.more = 1; -						ao_log_metrum(&gps_log); +						ao_log_write(&gps_log);  						i = 0;  					}  					gps_log.u.gps_sat.sats[i].svid = svid; @@ -82,7 +82,7 @@ ao_gps_report_metrum(void)  			if (i) {  				gps_log.u.gps_sat.channels = i;  				gps_log.u.gps_sat.more = 0; -				ao_log_metrum(&gps_log); +				ao_log_write(&gps_log);  			}  		}  	} diff --git a/src/kernel/ao_host.h b/src/kernel/ao_host.h index a7fa5ec2..50583f52 100644 --- a/src/kernel/ao_host.h +++ b/src/kernel/ao_host.h @@ -111,7 +111,7 @@ ao_dump_state(void *wchan);  void  ao_sleep(void *wchan); -const char const * const ao_state_names[] = { +const char * const ao_state_names[] = {  	"startup", "idle", "pad", "boost", "fast",  	"coast", "drogue", "main", "landed", "invalid"  }; diff --git a/src/kernel/ao_log.c b/src/kernel/ao_log.c index 0589b4b0..f70c7232 100644 --- a/src/kernel/ao_log.c +++ b/src/kernel/ao_log.c @@ -29,7 +29,7 @@ __pdata uint32_t ao_log_end_pos;  __pdata uint32_t ao_log_start_pos;  __xdata uint8_t	ao_log_running;  __pdata enum ao_flight_state ao_log_state; -__xdata uint16_t ao_flight_number; +__xdata int16_t ao_flight_number;  void  ao_log_flush(void) @@ -111,6 +111,85 @@ ao_log_erase_mark(void)  	ao_config_put();  } +#ifndef AO_LOG_UNCOMMON +/* + * Common logging functions which depend on the type of the log data + * structure. + */ + +__xdata ao_log_type log; + +static uint8_t +ao_log_csum(__xdata uint8_t *b) __reentrant +{ +	uint8_t	sum = 0x5a; +	uint8_t	i; + +	for (i = 0; i < sizeof (ao_log_type); i++) +		sum += *b++; +	return -sum; +} + +uint8_t +ao_log_write(__xdata ao_log_type *log) __reentrant +{ +	uint8_t wrote = 0; +	/* set checksum */ +	log->csum = 0; +	log->csum = ao_log_csum((__xdata uint8_t *) log); +	ao_mutex_get(&ao_log_mutex); { +		if (ao_log_current_pos >= ao_log_end_pos && ao_log_running) +			ao_log_stop(); +		if (ao_log_running) { +			wrote = 1; +			ao_storage_write(ao_log_current_pos, +					 log, +					 sizeof (ao_log_type)); +			ao_log_current_pos += sizeof (ao_log_type); +		} +	} ao_mutex_put(&ao_log_mutex); +	return wrote; +} + +uint8_t +ao_log_check_data(void) +{ +	if (ao_log_csum((uint8_t *) &log) != 0) +		return 0; +	return 1; +} + +uint8_t +ao_log_check_clear(void) +{ +	uint8_t *b = (uint8_t *) &log; +	uint8_t i; + +	for (i = 0; i < sizeof (ao_log_type); i++) { +		if (*b++ != 0xff) +			return 0; +	} +	return 1; +} + +int16_t +ao_log_flight(uint8_t slot) +{ +	if (!ao_storage_read(ao_log_pos(slot), +			     &log, +			     sizeof (ao_log_type))) +		return -(int16_t) (slot + 1); + +	if (ao_log_check_clear()) +		return 0; + +	if (!ao_log_check_data() || log.type != AO_LOG_FLIGHT) +		return -(int16_t) (slot + 1); + +	return log.u.flight.flight; +} +#endif +  static uint8_t  ao_log_slots()  { @@ -123,21 +202,21 @@ ao_log_pos(uint8_t slot)  	return ((slot) * ao_config.flight_log_max);  } -static uint16_t +static int16_t  ao_log_max_flight(void)  {  	uint8_t		log_slot;  	uint8_t		log_slots; -	uint16_t	log_flight; -	uint16_t	max_flight = 0; +	int16_t		log_flight; +	int16_t		max_flight = 0;  	/* Scan the log space looking for the biggest flight number */  	log_slots = ao_log_slots();  	for (log_slot = 0; log_slot < log_slots; log_slot++) {  		log_flight = ao_log_flight(log_slot); -		if (!log_flight) +		if (log_flight <= 0)  			continue; -		if (max_flight == 0 || (int16_t) (log_flight - max_flight) > 0) +		if (max_flight == 0 || log_flight > max_flight)  			max_flight = log_flight;  	}  	return max_flight; @@ -228,24 +307,24 @@ ao_log_scan(void) __reentrant  	if (ao_flight_number) {  		uint32_t	full = ao_log_current_pos; -		uint32_t	empty = ao_log_end_pos - ao_log_size; +		uint32_t	empty = ao_log_end_pos - AO_LOG_SIZE;  		/* If there's already a flight started, then find the  		 * end of it  		 */  		for (;;) {  			ao_log_current_pos = (full + empty) >> 1; -			ao_log_current_pos -= ao_log_current_pos % ao_log_size; +			ao_log_current_pos -= ao_log_current_pos % AO_LOG_SIZE;  			if (ao_log_current_pos == full) { -				if (ao_log_check(ao_log_current_pos)) -					ao_log_current_pos += ao_log_size; +				if (ao_log_check(ao_log_current_pos) != AO_LOG_EMPTY) +					ao_log_current_pos += AO_LOG_SIZE;  				break;  			}  			if (ao_log_current_pos == empty)  				break; -			if (ao_log_check(ao_log_current_pos)) { +			if (ao_log_check(ao_log_current_pos) != AO_LOG_EMPTY) {  				full = ao_log_current_pos;  			} else {  				empty = ao_log_current_pos; @@ -259,10 +338,11 @@ ao_log_scan(void) __reentrant  	ao_wakeup(&ao_flight_number);  	return ret;  #else - -	if (ao_flight_number) -		if (++ao_flight_number == 0) +	if (ao_flight_number) { +		++ao_flight_number; +		if (ao_flight_number <= 0)  			ao_flight_number = 1; +	}  	ao_log_find_max_erase_flight(); @@ -330,7 +410,7 @@ ao_log_list(void) __reentrant  {  	uint8_t	slot;  	uint8_t slots; -	uint16_t flight; +	int16_t flight;  	slots = ao_log_slots();  	for (slot = 0; slot < slots; slot++) @@ -350,18 +430,25 @@ ao_log_delete(void) __reentrant  {  	uint8_t slot;  	uint8_t slots; +	int16_t cmd_flight = 1; +	ao_cmd_white(); +	if (ao_cmd_lex_c == '-') { +		cmd_flight = -1; +		ao_cmd_lex(); +	}  	ao_cmd_decimal();  	if (ao_cmd_status != ao_cmd_success)  		return; +	cmd_flight *= (int16_t) ao_cmd_lex_i;  	slots = ao_log_slots();  	/* Look for the flight log matching the requested flight */ -	if (ao_cmd_lex_i) { +	if (cmd_flight) {  		for (slot = 0; slot < slots; slot++) { -			if (ao_log_flight(slot) == ao_cmd_lex_i) { +			if (ao_log_flight(slot) == cmd_flight) {  #if HAS_TRACKER -				ao_tracker_erase_start(ao_cmd_lex_i); +				ao_tracker_erase_start(cmd_flight);  #endif  				ao_log_erase(slot);  #if HAS_TRACKER @@ -372,7 +459,7 @@ ao_log_delete(void) __reentrant  			}  		}  	} -	printf("No such flight: %d\n", ao_cmd_lex_i); +	printf("No such flight: %d\n", cmd_flight);  }  __code struct ao_cmds ao_log_cmds[] = { diff --git a/src/kernel/ao_log.h b/src/kernel/ao_log.h index aca669db..5f04ef9a 100644 --- a/src/kernel/ao_log.h +++ b/src/kernel/ao_log.h @@ -29,7 +29,7 @@   * the log. Tasks may wait for this to be initialized   * by sleeping on this variable.   */ -extern __xdata uint16_t ao_flight_number; +extern __xdata int16_t ao_flight_number;  extern __xdata uint8_t	ao_log_mutex;  extern __pdata uint32_t ao_log_current_pos;  extern __pdata uint32_t ao_log_end_pos; @@ -54,17 +54,28 @@ extern __pdata enum ao_flight_state ao_log_state;  #define AO_LOG_FORMAT_TELEMINI3		12	/* 16-byte MS5607 baro only, 3.3V supply, stm32f042 SoC */  #define AO_LOG_FORMAT_TELEFIRETWO	13	/* 32-byte test stand data */  #define AO_LOG_FORMAT_EASYMINI2		14	/* 16-byte MS5607 baro only, 3.3V supply, stm32f042 SoC */ +#define AO_LOG_FORMAT_TELEMEGA_3	15	/* 32 byte typed telemega records with 32 bit gyro cal and mpu9250 */  #define AO_LOG_FORMAT_NONE		127	/* No log at all */ -extern __code uint8_t ao_log_format; -extern __code uint8_t ao_log_size; +/* Return the flight number from the given log slot, 0 if none, -slot on failure */ -/* Return the flight number from the given log slot, 0 if none */ -uint16_t +int16_t  ao_log_flight(uint8_t slot); -/* Check if there is valid log data at the specified location */ +/* Checksum the loaded log record */ +uint8_t +ao_log_check_data(void); + +/* Check to see if the loaded log record is empty */  uint8_t +ao_log_check_clear(void); + +/* Check if there is valid log data at the specified location */ +#define AO_LOG_VALID	1 +#define AO_LOG_EMPTY	0 +#define AO_LOG_INVALID 	-1 + +int8_t  ao_log_check(uint32_t pos);  /* Flush the log */ @@ -463,21 +474,48 @@ struct ao_log_gps {  	} u;  }; -/* Write a record to the eeprom log */ -uint8_t -ao_log_data(__xdata struct ao_log_record *log) __reentrant; +#if AO_LOG_FORMAT == AO_LOG_FOMAT_TELEMEGA_OLD || AO_LOG_FORMAT == AO_LOG_FORMAT_TELEMEGA || AO_LOG_FORMAT == AO_LOG_FORMAT_TELEMEGA_3 +typedef struct ao_log_mega ao_log_type; +#endif -uint8_t -ao_log_mega(__xdata struct ao_log_mega *log) __reentrant; +#if AO_LOG_FORMAT == AO_LOG_FORMAT_TELEMETRUM +typedef struct ao_log_metrum ao_log_type; +#endif -uint8_t -ao_log_metrum(__xdata struct ao_log_metrum *log) __reentrant; +#if AO_LOG_FORMAT == AO_LOG_FORMAT_EASYMINI1 || AO_LOG_FORMAT == AO_LOG_FORMAT_EASYMINI2 || AO_LOG_FORMAT == AO_LOG_FORMAT_TELEMINI2 || AO_LOG_FORMAT == AO_LOG_FORMAT_TELEMINI3 +typedef struct ao_log_mini ao_log_type; +#endif -uint8_t -ao_log_mini(__xdata struct ao_log_mini *log) __reentrant; +#if AO_LOG_FORMAT == AO_LOG_FORMAT_TELEGPS +typedef struct ao_log_gps ao_log_type; +#endif + +#if AO_LOG_FORMAT == AO_LOG_FORMAT_FULL +typedef struct ao_log_record ao_log_type; +#endif + +#if AO_LOG_FORMAT == AO_LOG_FORMAT_TINY +#define AO_LOG_UNCOMMON	1 +#endif + +#if AO_LOG_FORMAT == AO_LOG_FORMAT_TELEMETRY +#define AO_LOG_UNCOMMON	1 +#endif + +#if AO_LOG_FORMAT == AO_LOG_FORMAT_TELESCIENCE +#define AO_LOG_UNCOMMON	1 +#endif + +#ifndef AO_LOG_UNCOMMON +extern __xdata ao_log_type log; + +#define AO_LOG_SIZE sizeof(ao_log_type) + +/* Write a record to the eeprom log */  uint8_t -ao_log_gps(__xdata struct ao_log_gps *log) __reentrant; +ao_log_write(__xdata ao_log_type *log) __reentrant; +#endif  void  ao_log_flush(void); diff --git a/src/kernel/ao_log_big.c b/src/kernel/ao_log_big.c index e32abd1a..28a893c7 100644 --- a/src/kernel/ao_log_big.c +++ b/src/kernel/ao_log_big.c @@ -18,50 +18,6 @@  #include "ao.h" -static __xdata struct ao_log_record log; - -__code uint8_t ao_log_format = AO_LOG_FORMAT_FULL; - -static uint8_t -ao_log_csum(__xdata uint8_t *b) __reentrant -{ -	uint8_t	sum = 0x5a; -	uint8_t	i; - -	for (i = 0; i < sizeof (struct ao_log_record); i++) -		sum += *b++; -	return -sum; -} - -uint8_t -ao_log_data(__xdata struct ao_log_record *log) __reentrant -{ -	uint8_t wrote = 0; -	/* set checksum */ -	log->csum = 0; -	log->csum = ao_log_csum((__xdata uint8_t *) log); -	ao_mutex_get(&ao_log_mutex); { -		if (ao_log_current_pos >= ao_log_end_pos && ao_log_running) -			ao_log_stop(); -		if (ao_log_running) { -			wrote = 1; -			ao_storage_write(ao_log_current_pos, -					 log, -					 sizeof (struct ao_log_record)); -			ao_log_current_pos += sizeof (struct ao_log_record); -		} -	} ao_mutex_put(&ao_log_mutex); -	return wrote; -} - -static uint8_t -ao_log_dump_check_data(void) -{ -	if (ao_log_csum((uint8_t *) &log) != 0) -		return 0; -	return 1; -} -  static __data uint8_t	ao_log_data_pos;  /* a hack to make sure that ao_log_records fill the eeprom block in even units */ @@ -91,7 +47,7 @@ ao_log(void)  	log.u.flight.ground_accel = ao_ground_accel;  #endif  	log.u.flight.flight = ao_flight_number; -	ao_log_data(&log); +	ao_log_write(&log);  	/* Write the whole contents of the ring to the log  	 * when starting up. @@ -107,7 +63,7 @@ ao_log(void)  				log.type = AO_LOG_SENSOR;  				log.u.sensor.accel = ao_data_ring[ao_log_data_pos].adc.accel;  				log.u.sensor.pres = ao_data_ring[ao_log_data_pos].adc.pres; -				ao_log_data(&log); +				ao_log_write(&log);  				if (ao_log_state <= ao_flight_coast)  					next_sensor = log.tick + AO_SENSOR_INTERVAL_ASCENT;  				else @@ -117,11 +73,11 @@ ao_log(void)  				log.type = AO_LOG_TEMP_VOLT;  				log.u.temp_volt.temp = ao_data_ring[ao_log_data_pos].adc.temp;  				log.u.temp_volt.v_batt = ao_data_ring[ao_log_data_pos].adc.v_batt; -				ao_log_data(&log); +				ao_log_write(&log);  				log.type = AO_LOG_DEPLOY;  				log.u.deploy.drogue = ao_data_ring[ao_log_data_pos].adc.sense_d;  				log.u.deploy.main = ao_data_ring[ao_log_data_pos].adc.sense_m; -				ao_log_data(&log); +				ao_log_write(&log);  				next_other = log.tick + AO_OTHER_INTERVAL;  			}  			ao_log_data_pos = ao_data_ring_next(ao_log_data_pos); @@ -133,7 +89,7 @@ ao_log(void)  			log.tick = ao_sample_tick;  			log.u.state.state = ao_log_state;  			log.u.state.reason = 0; -			ao_log_data(&log); +			ao_log_write(&log);  			if (ao_log_state == ao_flight_landed)  				ao_log_stop(); @@ -147,16 +103,3 @@ ao_log(void)  			ao_sleep(&ao_log_running);  	}  } - -uint16_t -ao_log_flight(uint8_t slot) -{ -	if (!ao_storage_read(ao_log_pos(slot), -			     &log, -			     sizeof (struct ao_log_record))) -		return 0; - -	if (ao_log_dump_check_data() && log.type == AO_LOG_FLIGHT) -		return log.u.flight.flight; -	return 0; -} diff --git a/src/kernel/ao_log_gps.c b/src/kernel/ao_log_gps.c index 02551169..a55d93f1 100644 --- a/src/kernel/ao_log_gps.c +++ b/src/kernel/ao_log_gps.c @@ -24,50 +24,13 @@  #include <ao_distance.h>  #include <ao_tracker.h> -static __xdata struct ao_log_gps log; - -__code uint8_t ao_log_format = AO_LOG_FORMAT_TELEGPS; -__code uint8_t ao_log_size = sizeof (struct ao_log_gps); - -static uint8_t -ao_log_csum(__xdata uint8_t *b) __reentrant -{ -	uint8_t	sum = 0x5a; -	uint8_t	i; - -	for (i = 0; i < sizeof (struct ao_log_gps); i++) -		sum += *b++; -	return -sum; -} - -uint8_t -ao_log_gps(__xdata struct ao_log_gps *log) __reentrant -{ -	uint8_t wrote = 0; -	/* set checksum */ -	log->csum = 0; -	log->csum = ao_log_csum((__xdata uint8_t *) log); -	ao_mutex_get(&ao_log_mutex); { -		if (ao_log_current_pos >= ao_log_end_pos && ao_log_running) -			ao_log_stop(); -		if (ao_log_running) { -			wrote = 1; -			ao_storage_write(ao_log_current_pos, -					 log, -					 sizeof (struct ao_log_gps)); -			ao_log_current_pos += sizeof (struct ao_log_gps); -		} -	} ao_mutex_put(&ao_log_mutex); -	return wrote; -} -  void  ao_log_gps_flight(void)  {  	log.type = AO_LOG_FLIGHT;  	log.tick = ao_time();  	log.u.flight.flight = ao_flight_number; -	ao_log_gps(&log); +	ao_log_write(&log);  }  void @@ -94,7 +57,7 @@ ao_log_gps_data(uint16_t tick, struct ao_telemetry_location *gps_data)  	log.u.gps.hdop = gps_data->hdop;  	log.u.gps.vdop = gps_data->vdop;  	log.u.gps.mode = gps_data->mode; -	ao_log_gps(&log); +	ao_log_write(&log);  }  void @@ -115,39 +78,21 @@ ao_log_gps_tracking(uint16_t tick, struct ao_telemetry_satellite *gps_tracking_d  				break;  		}  	log.u.gps_sat.channels = i; -	ao_log_gps(&log); +	ao_log_write(&log);  } -static uint8_t -ao_log_dump_check_data(void) -{ -	if (ao_log_csum((uint8_t *) &log) != 0) -		return 0; -	return 1; -} - -uint16_t -ao_log_flight(uint8_t slot) -{ -	if (!ao_storage_read(ao_log_pos(slot), -			     &log, -			     sizeof (struct ao_log_gps))) -		return 0; - -	if (ao_log_dump_check_data() && log.type == AO_LOG_FLIGHT) -		return log.u.flight.flight; -	return 0; -} - -uint8_t +int8_t  ao_log_check(uint32_t pos)  {  	if (!ao_storage_read(pos,  			     &log,  			     sizeof (struct ao_log_gps))) -		return 0; +		return AO_LOG_INVALID; + +	if (ao_log_check_clear()) +		return AO_LOG_EMPTY; -	if (ao_log_dump_check_data()) -		return 1; -	return 0; +	if (!ao_log_check_data()) +		return AO_LOG_INVALID; +	return AO_LOG_VALID;  } diff --git a/src/kernel/ao_log_mega.c b/src/kernel/ao_log_mega.c index b86abe7a..c6bdf1e2 100644 --- a/src/kernel/ao_log_mega.c +++ b/src/kernel/ao_log_mega.c @@ -21,50 +21,6 @@  #include <ao_data.h>  #include <ao_flight.h> -static __xdata struct ao_log_mega log; - -__code uint8_t ao_log_format = AO_LOG_FORMAT_TELEMEGA; - -static uint8_t -ao_log_csum(__xdata uint8_t *b) __reentrant -{ -	uint8_t	sum = 0x5a; -	uint8_t	i; - -	for (i = 0; i < sizeof (struct ao_log_mega); i++) -		sum += *b++; -	return -sum; -} - -uint8_t -ao_log_mega(__xdata struct ao_log_mega *log) __reentrant -{ -	uint8_t wrote = 0; -	/* set checksum */ -	log->csum = 0; -	log->csum = ao_log_csum((__xdata uint8_t *) log); -	ao_mutex_get(&ao_log_mutex); { -		if (ao_log_current_pos >= ao_log_end_pos && ao_log_running) -			ao_log_stop(); -		if (ao_log_running) { -			wrote = 1; -			ao_storage_write(ao_log_current_pos, -					 log, -					 sizeof (struct ao_log_mega)); -			ao_log_current_pos += sizeof (struct ao_log_mega); -		} -	} ao_mutex_put(&ao_log_mutex); -	return wrote; -} - -static uint8_t -ao_log_dump_check_data(void) -{ -	if (ao_log_csum((uint8_t *) &log) != 0) -		return 0; -	return 1; -} -  #if HAS_FLIGHT  static __data uint8_t	ao_log_data_pos; @@ -106,7 +62,7 @@ ao_log(void)  #endif  	log.u.flight.ground_pres = ao_ground_pres;  	log.u.flight.flight = ao_flight_number; -	ao_log_mega(&log); +	ao_log_write(&log);  #endif  	/* Write the whole contents of the ring to the log @@ -138,8 +94,19 @@ ao_log(void)  				log.u.sensor.mag_z = ao_data_ring[ao_log_data_pos].hmc5883.z;  				log.u.sensor.mag_y = ao_data_ring[ao_log_data_pos].hmc5883.y;  #endif +#if HAS_MPU9250 +				log.u.sensor.accel_x = ao_data_ring[ao_log_data_pos].mpu9250.accel_x; +				log.u.sensor.accel_y = ao_data_ring[ao_log_data_pos].mpu9250.accel_y; +				log.u.sensor.accel_z = ao_data_ring[ao_log_data_pos].mpu9250.accel_z; +				log.u.sensor.gyro_x = ao_data_ring[ao_log_data_pos].mpu9250.gyro_x; +				log.u.sensor.gyro_y = ao_data_ring[ao_log_data_pos].mpu9250.gyro_y; +				log.u.sensor.gyro_z = ao_data_ring[ao_log_data_pos].mpu9250.gyro_z; +				log.u.sensor.mag_x = ao_data_ring[ao_log_data_pos].mpu9250.mag_x; +				log.u.sensor.mag_z = ao_data_ring[ao_log_data_pos].mpu9250.mag_z; +				log.u.sensor.mag_y = ao_data_ring[ao_log_data_pos].mpu9250.mag_y; +#endif  				log.u.sensor.accel = ao_data_accel(&ao_data_ring[ao_log_data_pos]); -				ao_log_mega(&log); +				ao_log_write(&log);  				if (ao_log_state <= ao_flight_coast)  					next_sensor = log.tick + AO_SENSOR_INTERVAL_ASCENT;  				else @@ -153,7 +120,7 @@ ao_log(void)  				for (i = 0; i < AO_ADC_NUM_SENSE; i++)  					log.u.volt.sense[i] = ao_data_ring[ao_log_data_pos].adc.sense[i];  				log.u.volt.pyro = ao_pyro_fired; -				ao_log_mega(&log); +				ao_log_write(&log);  				next_other = log.tick + AO_OTHER_INTERVAL;  			}  			ao_log_data_pos = ao_data_ring_next(ao_log_data_pos); @@ -166,7 +133,7 @@ ao_log(void)  			log.tick = ao_time();  			log.u.state.state = ao_log_state;  			log.u.state.reason = 0; -			ao_log_mega(&log); +			ao_log_write(&log);  			if (ao_log_state == ao_flight_landed)  				ao_log_stop(); @@ -185,15 +152,3 @@ ao_log(void)  }  #endif /* HAS_FLIGHT */ -uint16_t -ao_log_flight(uint8_t slot) -{ -	if (!ao_storage_read(ao_log_pos(slot), -			     &log, -			     sizeof (struct ao_log_mega))) -		return 0; - -	if (ao_log_dump_check_data() && log.type == AO_LOG_FLIGHT) -		return log.u.flight.flight; -	return 0; -} diff --git a/src/kernel/ao_log_metrum.c b/src/kernel/ao_log_metrum.c index 154b1740..afb8f637 100644 --- a/src/kernel/ao_log_metrum.c +++ b/src/kernel/ao_log_metrum.c @@ -21,50 +21,6 @@  #include <ao_data.h>  #include <ao_flight.h> -static __xdata struct ao_log_metrum log; - -__code uint8_t ao_log_format = AO_LOG_FORMAT_TELEMETRUM; - -static uint8_t -ao_log_csum(__xdata uint8_t *b) __reentrant -{ -	uint8_t	sum = 0x5a; -	uint8_t	i; - -	for (i = 0; i < sizeof (struct ao_log_metrum); i++) -		sum += *b++; -	return -sum; -} - -uint8_t -ao_log_metrum(__xdata struct ao_log_metrum *log) __reentrant -{ -	uint8_t wrote = 0; -	/* set checksum */ -	log->csum = 0; -	log->csum = ao_log_csum((__xdata uint8_t *) log); -	ao_mutex_get(&ao_log_mutex); { -		if (ao_log_current_pos >= ao_log_end_pos && ao_log_running) -			ao_log_stop(); -		if (ao_log_running) { -			wrote = 1; -			ao_storage_write(ao_log_current_pos, -					 log, -					 sizeof (struct ao_log_metrum)); -			ao_log_current_pos += sizeof (struct ao_log_metrum); -		} -	} ao_mutex_put(&ao_log_mutex); -	return wrote; -} - -static uint8_t -ao_log_dump_check_data(void) -{ -	if (ao_log_csum((uint8_t *) &log) != 0) -		return 0; -	return 1; -} -  #if HAS_ADC  static __data uint8_t	ao_log_data_pos; @@ -97,7 +53,7 @@ ao_log(void)  #endif  	log.u.flight.ground_pres = ao_ground_pres;  	log.u.flight.flight = ao_flight_number; -	ao_log_metrum(&log); +	ao_log_write(&log);  #endif  	/* Write the whole contents of the ring to the log @@ -119,7 +75,7 @@ ao_log(void)  #if HAS_ACCEL  				log.u.sensor.accel = ao_data_accel(&ao_data_ring[ao_log_data_pos]);  #endif -				ao_log_metrum(&log); +				ao_log_write(&log);  				if (ao_log_state <= ao_flight_coast)  					next_sensor = log.tick + AO_SENSOR_INTERVAL_ASCENT;  				else @@ -130,7 +86,7 @@ ao_log(void)  				log.u.volt.v_batt = ao_data_ring[ao_log_data_pos].adc.v_batt;  				log.u.volt.sense_a = ao_data_ring[ao_log_data_pos].adc.sense_a;  				log.u.volt.sense_m = ao_data_ring[ao_log_data_pos].adc.sense_m; -				ao_log_metrum(&log); +				ao_log_write(&log);  				next_other = log.tick + AO_OTHER_INTERVAL;  			}  			ao_log_data_pos = ao_data_ring_next(ao_log_data_pos); @@ -143,7 +99,7 @@ ao_log(void)  			log.tick = ao_time();  			log.u.state.state = ao_log_state;  			log.u.state.reason = 0; -			ao_log_metrum(&log); +			ao_log_write(&log);  			if (ao_log_state == ao_flight_landed)  				ao_log_stop(); @@ -161,16 +117,3 @@ ao_log(void)  	}  }  #endif - -uint16_t -ao_log_flight(uint8_t slot) -{ -	if (!ao_storage_read(ao_log_pos(slot), -			     &log, -			     sizeof (struct ao_log_metrum))) -		return 0; - -	if (ao_log_dump_check_data() && log.type == AO_LOG_FLIGHT) -		return log.u.flight.flight; -	return 0; -} diff --git a/src/kernel/ao_log_mini.c b/src/kernel/ao_log_mini.c index d5735cdc..af2fa605 100644 --- a/src/kernel/ao_log_mini.c +++ b/src/kernel/ao_log_mini.c @@ -21,50 +21,6 @@  #include <ao_data.h>  #include <ao_flight.h> -static __xdata struct ao_log_mini log; - -__code uint8_t ao_log_format = AO_LOG_FORMAT; - -static uint8_t -ao_log_csum(__xdata uint8_t *b) __reentrant -{ -	uint8_t	sum = 0x5a; -	uint8_t	i; - -	for (i = 0; i < sizeof (struct ao_log_mini); i++) -		sum += *b++; -	return -sum; -} - -uint8_t -ao_log_mini(__xdata struct ao_log_mini *log) __reentrant -{ -	uint8_t wrote = 0; -	/* set checksum */ -	log->csum = 0; -	log->csum = ao_log_csum((__xdata uint8_t *) log); -	ao_mutex_get(&ao_log_mutex); { -		if (ao_log_current_pos >= ao_log_end_pos && ao_log_running) -			ao_log_stop(); -		if (ao_log_running) { -			wrote = 1; -			ao_storage_write(ao_log_current_pos, -					 log, -					 sizeof (struct ao_log_mini)); -			ao_log_current_pos += sizeof (struct ao_log_mini); -		} -	} ao_mutex_put(&ao_log_mutex); -	return wrote; -} - -static uint8_t -ao_log_dump_check_data(void) -{ -	if (ao_log_csum((uint8_t *) &log) != 0) -		return 0; -	return 1; -} -  static __data uint8_t	ao_log_data_pos;  /* a hack to make sure that ao_log_minis fill the eeprom block in even units */ @@ -92,7 +48,7 @@ ao_log(void)  	log.tick = ao_sample_tick;  	log.u.flight.flight = ao_flight_number;  	log.u.flight.ground_pres = ao_ground_pres; -	ao_log_mini(&log); +	ao_log_write(&log);  #endif  	/* Write the whole contents of the ring to the log @@ -116,7 +72,7 @@ ao_log(void)  				log.u.sensor.sense_m = ao_data_ring[ao_log_data_pos].adc.sense_m;  				log.u.sensor.v_batt = ao_data_ring[ao_log_data_pos].adc.v_batt;  #endif -				ao_log_mini(&log); +				ao_log_write(&log);  				if (ao_log_state <= ao_flight_coast)  					next_sensor = log.tick + AO_SENSOR_INTERVAL_ASCENT;  				else @@ -132,7 +88,7 @@ ao_log(void)  			log.tick = ao_time();  			log.u.state.state = ao_log_state;  			log.u.state.reason = 0; -			ao_log_mini(&log); +			ao_log_write(&log);  			if (ao_log_state == ao_flight_landed)  				ao_log_stop(); @@ -149,16 +105,3 @@ ao_log(void)  			ao_sleep(&ao_log_running);  	}  } - -uint16_t -ao_log_flight(uint8_t slot) -{ -	if (!ao_storage_read(ao_log_pos(slot), -			     &log, -			     sizeof (struct ao_log_mini))) -		return 0; - -	if (ao_log_dump_check_data() && log.type == AO_LOG_FLIGHT) -		return log.u.flight.flight; -	return 0; -} diff --git a/src/kernel/ao_log_tiny.c b/src/kernel/ao_log_tiny.c index 7769b7b5..0b8e39d6 100644 --- a/src/kernel/ao_log_tiny.c +++ b/src/kernel/ao_log_tiny.c @@ -29,8 +29,6 @@ static __data uint16_t	ao_log_tiny_interval;  #define AO_PAD_RING	2  #endif -__code uint8_t ao_log_format = AO_LOG_FORMAT_TINY; -  void  ao_log_tiny_set_interval(uint16_t ticks)  { @@ -149,7 +147,7 @@ ao_log(void)  	}  } -uint16_t +int16_t  ao_log_flight(uint8_t slot)  {  	static __xdata uint16_t flight; diff --git a/src/kernel/ao_pyro.c b/src/kernel/ao_pyro.c index 9543b3ef..e5c30eec 100644 --- a/src/kernel/ao_pyro.c +++ b/src/kernel/ao_pyro.c @@ -76,7 +76,7 @@ uint16_t	ao_pyro_fired;  #if PYRO_DBG  int pyro_dbg; -#define DBG(...)	do { if (pyro_dbg) printf("\t%d: ", (int) (pyro - ao_config.pyro)); printf(__VA_ARGS__); } while (0) +#define DBG(...)	do { if (pyro_dbg) { printf("\t%d: ", (int) (pyro - ao_config.pyro)); printf(__VA_ARGS__); } } while (0)  #else  #define DBG(...)  #endif @@ -239,11 +239,8 @@ ao_pyro_pins_fire(uint16_t fire)  	}  	ao_delay(ao_config.pyro_time);  	for (p = 0; p < AO_PYRO_NUM; p++) { -		if (fire & (1 << p)) { +		if (fire & (1 << p))  			ao_pyro_pin_set(p, 0); -			ao_config.pyro[p].fired = 1; -			ao_pyro_fired |= (1 << p); -		}  	}  	ao_delay(AO_MS_TO_TICKS(50));  } @@ -261,7 +258,7 @@ ao_pyro_check(void)  		/* Ignore igniters which have already fired  		 */ -		if (pyro->fired) +		if (ao_pyro_fired & (1 << p))  			continue;  		/* Ignore disabled igniters @@ -296,7 +293,7 @@ ao_pyro_check(void)  			 * by setting the fired bit  			 */  			if (!ao_pyro_ready(pyro)) { -				pyro->fired = 1; +				ao_pyro_fired |= (1 << p);  				continue;  			} @@ -307,8 +304,10 @@ ao_pyro_check(void)  		fire |= (1 << p);  	} -	if (fire) +	if (fire) { +		ao_pyro_fired |= fire;  		ao_pyro_pins_fire(fire); +	}  	return any_waiting;  } @@ -482,7 +481,7 @@ ao_pyro_set(void)  			break;  		for (c = 0; c < AO_PYRO_NAME_LEN - 1; c++) { -			if (ao_cmd_is_white()) +			if (ao_cmd_is_white() || ao_cmd_lex_c == '\n')  				break;  			name[c] = ao_cmd_lex_c;  			ao_cmd_lex(); diff --git a/src/kernel/ao_pyro.h b/src/kernel/ao_pyro.h index a730ef19..3ab5af3b 100644 --- a/src/kernel/ao_pyro.h +++ b/src/kernel/ao_pyro.h @@ -63,7 +63,7 @@ struct ao_pyro {  	uint8_t			state_less, state_greater_or_equal;  	int16_t			motor;  	uint16_t		delay_done; -	uint8_t			fired; +	uint8_t			_unused;	/* was 'fired' */  };  #define AO_PYRO_8_BIT_VALUE	(ao_pyro_state_less|ao_pyro_state_greater_or_equal) diff --git a/src/kernel/ao_sample.c b/src/kernel/ao_sample.c index f0ab0169..61519478 100644 --- a/src/kernel/ao_sample.c +++ b/src/kernel/ao_sample.c @@ -184,9 +184,9 @@ ao_sample_rotate(void)  #else  	static const float dt = 1/TIME_DIV;  #endif -	float	x = ao_mpu6000_gyro((float) ((ao_sample_pitch << 9) - ao_ground_pitch) / 512.0f) * dt; -	float	y = ao_mpu6000_gyro((float) ((ao_sample_yaw << 9) - ao_ground_yaw) / 512.0f) * dt; -	float	z = ao_mpu6000_gyro((float) ((ao_sample_roll << 9) - ao_ground_roll) / 512.0f) * dt; +	float	x = ao_convert_gyro((float) ((ao_sample_pitch << 9) - ao_ground_pitch) / 512.0f) * dt; +	float	y = ao_convert_gyro((float) ((ao_sample_yaw << 9) - ao_ground_yaw) / 512.0f) * dt; +	float	z = ao_convert_gyro((float) ((ao_sample_roll << 9) - ao_ground_roll) / 512.0f) * dt;  	struct ao_quaternion	rot;  	ao_quaternion_init_half_euler(&rot, x, y, z); diff --git a/src/kernel/ao_stdio.c b/src/kernel/ao_stdio.c index f0ee0a14..dc09b5c7 100644 --- a/src/kernel/ao_stdio.c +++ b/src/kernel/ao_stdio.c @@ -84,7 +84,7 @@ __pdata int8_t ao_cur_stdio;  #endif  void -putchar(char c) +ao_putchar(char c)  {  #if LOW_LEVEL_DEBUG  	if (!ao_cur_task) { @@ -110,7 +110,7 @@ flush(void)  __xdata uint8_t ao_stdin_ready;  char -getchar(void) __reentrant +ao_getchar(void) __reentrant  {  	int c;  	int8_t stdio; diff --git a/src/kernel/ao_storage.c b/src/kernel/ao_storage.c index bee9293e..400751de 100644 --- a/src/kernel/ao_storage.c +++ b/src/kernel/ao_storage.c @@ -22,6 +22,9 @@  uint8_t  ao_storage_read(ao_pos_t pos, __xdata void *buf, uint16_t len) __reentrant  { +#ifdef CC1111 +	return ao_storage_device_read(pos, buf, len); +#else  	uint16_t this_len;  	uint16_t this_off; @@ -47,11 +50,15 @@ ao_storage_read(ao_pos_t pos, __xdata void *buf, uint16_t len) __reentrant  		pos += this_len;  	}  	return 1; +#endif  }  uint8_t  ao_storage_write(ao_pos_t pos, __xdata void *buf, uint16_t len) __reentrant  { +#ifdef CC1111 +	return ao_storage_device_write(pos, buf, len); +#else  	uint16_t this_len;  	uint16_t this_off; @@ -77,9 +84,10 @@ ao_storage_write(ao_pos_t pos, __xdata void *buf, uint16_t len) __reentrant  		pos += this_len;  	}  	return 1; +#endif  } -static __xdata uint8_t storage_data[8]; +static __xdata uint8_t storage_data[128];  static void  ao_storage_dump(void) __reentrant @@ -159,6 +167,154 @@ ao_storage_zapall(void) __reentrant  		ao_storage_erase(pos);  } +#if AO_STORAGE_TEST + +static void +ao_storage_failure(uint32_t pos, char *format, ...) +{ +	va_list a; +	printf("TEST FAILURE AT %08x: ", pos); +	va_start(a, format); +	vprintf(format, a); +	va_end(a); +} + +static uint8_t +ao_storage_check_block(uint32_t pos, uint8_t value) +{ +	uint32_t	offset; +	uint32_t	byte; + +	for (offset = 0; offset < ao_storage_block; offset += sizeof (storage_data)) { +		if (!ao_storage_read(pos + offset, storage_data, sizeof (storage_data))) { +			ao_storage_failure(pos + offset, "read failed\n"); +			return 0; +		} +		for (byte = 0; byte < sizeof (storage_data); byte++) +			if (storage_data[byte] != value) { +				ao_storage_failure(pos + offset + byte, +						   "want %02x got %02x\n", +						   value, storage_data[byte]); +				return 0; +			} +	} +	return 1; +} + +static uint8_t +ao_storage_fill_block(uint32_t pos, uint8_t value) +{ +	uint32_t	offset; +	uint32_t	byte; + +	for (byte = 0; byte < sizeof (storage_data); byte++) +		storage_data[byte] = value; +	for (offset = 0; offset < ao_storage_block; offset += sizeof (storage_data)) { +		if (!ao_storage_write(pos + offset, storage_data, sizeof (storage_data))) { +			ao_storage_failure(pos + offset, "write failed\n"); +			return 0; +		} +	} +	return 1; +} + +static uint8_t +ao_storage_check_incr_block(uint32_t pos) +{ +	uint32_t	offset; +	uint32_t	byte; + +	for (offset = 0; offset < ao_storage_block; offset += sizeof (storage_data)) { +		if (!ao_storage_read(pos + offset, storage_data, sizeof (storage_data))) { +			ao_storage_failure(pos + offset, "read failed\n"); +			return 0; +		} +		for (byte = 0; byte < sizeof (storage_data); byte++) { +			uint8_t value = offset + byte; +			if (storage_data[byte] != value) { +				ao_storage_failure(pos + offset + byte, +						   "want %02x got %02x\n", +						   value, storage_data[byte]); +				return 0; +			} +		} +	} +	return 1; +} + +static uint8_t +ao_storage_fill_incr_block(uint32_t pos) +{ +	uint32_t	offset; +	uint32_t	byte; + +	for (offset = 0; offset < ao_storage_block; offset += sizeof (storage_data)) { +		for (byte = 0; byte < sizeof (storage_data); byte++) +			storage_data[byte] = offset + byte; +		if (!ao_storage_write(pos + offset, storage_data, sizeof (storage_data))) { +			ao_storage_failure(pos + offset, "write failed\n"); +			return 0; +		} +	} +	return 1; +} + +static uint8_t +ao_storage_fill_check_block(uint32_t pos, uint8_t value) +{ +	return ao_storage_fill_block(pos, value) && ao_storage_check_block(pos, value); +} + +static uint8_t +ao_storage_incr_check_block(uint32_t pos) +{ +	return ao_storage_fill_incr_block(pos) && ao_storage_check_incr_block(pos); +} + +static uint8_t +ao_storage_test_block(uint32_t pos) __reentrant +{ +	ao_storage_erase(pos); +	printf(" erase"); flush(); +	if (!ao_storage_check_block(pos, 0xff)) +		return 0; +	printf(" zero"); flush(); +	if (!ao_storage_fill_check_block(pos, 0x00)) +		return 0; +	ao_storage_erase(pos); +	printf(" 0xaa"); flush(); +	if (!ao_storage_fill_check_block(pos, 0xaa)) +		return 0; +	ao_storage_erase(pos); +	printf(" 0x55"); flush(); +	if (!ao_storage_fill_check_block(pos, 0x55)) +		return 0; +	ao_storage_erase(pos); +	printf(" increment"); flush(); +	if (!ao_storage_incr_check_block(pos)) +		return 0; +	ao_storage_erase(pos); +	printf(" pass\n"); flush(); +	return 1; +} + +static void +ao_storage_test(void) __reentrant +{ +	uint32_t	pos; + +	ao_cmd_white(); +	if (!ao_match_word("DoIt")) +		return; +	for (pos = 0; pos < ao_storage_log_max; pos += ao_storage_block) { +		printf("Testing block 0x%08x:", pos); flush(); +		if (!ao_storage_test_block(pos)) +			break; +	} +	printf("Test complete\n"); +} +#endif /* AO_STORAGE_TEST */ +  void  ao_storage_info(void) __reentrant  { @@ -176,6 +332,9 @@ __code struct ao_cmds ao_storage_cmds[] = {  #endif  	{ ao_storage_zap, "z <block>\0Erase <block>" },  	{ ao_storage_zapall,"Z <key>\0Erase all. <key> is doit with D&I" }, +#if AO_STORAGE_TEST +	{ ao_storage_test, "V <key>\0Validate flash (destructive). <key> is doit with D&I" }, +#endif  	{ 0, NULL },  }; diff --git a/src/kernel/ao_task.h b/src/kernel/ao_task.h index 30b018ff..7549b598 100644 --- a/src/kernel/ao_task.h +++ b/src/kernel/ao_task.h @@ -44,6 +44,9 @@ struct ao_task {  	ao_arch_task_members		/* any architecture-specific fields */  	uint8_t task_id;		/* unique id */  	__code char *name;		/* task name */ +#ifdef NEWLIB +	int __errno;			/* storage for errno in newlib libc */ +#endif  #if HAS_TASK_QUEUE  	struct ao_list	queue;  	struct ao_list	alarm_queue; diff --git a/src/kernel/ao_telemetry.c b/src/kernel/ao_telemetry.c index 2ae1e41b..9ed612ce 100644 --- a/src/kernel/ao_telemetry.c +++ b/src/kernel/ao_telemetry.c @@ -141,7 +141,7 @@ ao_send_mega_sensor(void)  	telemetry.generic.tick = packet->tick;  	telemetry.generic.type = AO_TELEMETRY_MEGA_SENSOR; -#if HAS_MPU6000 +#if HAS_MPU6000 || HAS_MPU9250  	telemetry.mega_sensor.orient = ao_sample_orient;  #endif  	telemetry.mega_sensor.accel = ao_data_accel(packet); @@ -164,6 +164,20 @@ ao_send_mega_sensor(void)  	telemetry.mega_sensor.mag_y = packet->hmc5883.y;  #endif +#if HAS_MPU9250 +	telemetry.mega_sensor.accel_x = packet->mpu9250.accel_x; +	telemetry.mega_sensor.accel_y = packet->mpu9250.accel_y; +	telemetry.mega_sensor.accel_z = packet->mpu9250.accel_z; + +	telemetry.mega_sensor.gyro_x = packet->mpu9250.gyro_x; +	telemetry.mega_sensor.gyro_y = packet->mpu9250.gyro_y; +	telemetry.mega_sensor.gyro_z = packet->mpu9250.gyro_z; + +	telemetry.mega_sensor.mag_x = packet->mpu9250.mag_x; +	telemetry.mega_sensor.mag_z = packet->mpu9250.mag_z; +	telemetry.mega_sensor.mag_y = packet->mpu9250.mag_y; +#endif +  	ao_telemetry_send();  } diff --git a/src/lambdakey-v1.0/Makefile b/src/lambdakey-v1.0/Makefile index 2609bea3..4eb045b6 100644 --- a/src/lambdakey-v1.0/Makefile +++ b/src/lambdakey-v1.0/Makefile @@ -5,6 +5,12 @@  include ../stmf0/Makefile.defs +include ../scheme/Makefile-inc + +NEWLIB_FULL=-lm -lc -lgcc + +LIBS=$(NEWLIB_FULL) +  INC = \  	ao.h \  	ao_arch.h \ @@ -13,9 +19,7 @@ INC = \  	ao_pins.h \  	ao_product.h \  	ao_task.h \ -	ao_lisp.h \ -	ao_lisp_const.h \ -	ao_lisp_os.h \ +	$(SCHEME_HDRS) \  	stm32f0.h \  	Makefile @@ -35,23 +39,8 @@ ALTOS_SRC = \  	ao_timer.c \  	ao_usb_stm.c \  	ao_flash_stm.c \ -	ao_lisp_lex.c \ -	ao_lisp_mem.c \ -	ao_lisp_cons.c \ -	ao_lisp_eval.c \ -	ao_lisp_string.c \ -	ao_lisp_atom.c \ -	ao_lisp_int.c \ -	ao_lisp_poly.c \ -	ao_lisp_builtin.c \ -	ao_lisp_read.c \ -	ao_lisp_rep.c \ -	ao_lisp_frame.c \ -	ao_lisp_error.c \ -	ao_lisp_lambda.c \ -	ao_lisp_save.c \ -	ao_lisp_stack.c \ -	ao_lisp_os_save.c +	$(SCHEME_SRCS) \ +	ao_scheme_os_save.c  PRODUCT=LambdaKey-v1.0  PRODUCT_DEF=-DLAMBDAKEY @@ -61,6 +50,12 @@ CFLAGS = $(PRODUCT_DEF) -I. $(STMF0_CFLAGS) -Os -g  LDFLAGS=$(CFLAGS) -L$(TOPDIR)/stmf0 -Wl,-Tlambda.ld +MAP=$(PROG).map +NEWLIB=/local/newlib-mini +MAPFILE=-Wl,-M=$(MAP) +LDFLAGS=-L../stmf0 -L$(NEWLIB)/arm-none-eabi/lib/thumb/v6-m/ -Wl,-Tlambda.ld $(MAPFILE) -nostartfiles +AO_CFLAGS=-I. -I../stmf0 -I../kernel -I../drivers -I.. -I../scheme -isystem $(NEWLIB)/arm-none-eabi/include -DNEWLIB +  PROGNAME=lambdakey-v1.0  PROG=$(PROGNAME)-$(VERSION).elf  HEX=$(PROGNAME)-$(VERSION).ihx diff --git a/src/lambdakey-v1.0/ao_lambdakey.c b/src/lambdakey-v1.0/ao_lambdakey.c index 8bd344cf..d0996eb4 100644 --- a/src/lambdakey-v1.0/ao_lambdakey.c +++ b/src/lambdakey-v1.0/ao_lambdakey.c @@ -13,14 +13,14 @@   */  #include <ao.h> -#include <ao_lisp.h> +#include <ao_scheme.h> -static void lisp_cmd() { -	ao_lisp_read_eval_print(); +static void scheme_cmd() { +	ao_scheme_read_eval_print();  }  static const struct ao_cmds blink_cmds[] = { -	{ lisp_cmd,	"l\0Run lisp interpreter" }, +	{ scheme_cmd,	"l\0Run scheme interpreter" },  	{ 0, 0 }  }; diff --git a/src/lambdakey-v1.0/ao_scheme_os.h b/src/lambdakey-v1.0/ao_scheme_os.h new file mode 100644 index 00000000..a620684f --- /dev/null +++ b/src/lambdakey-v1.0/ao_scheme_os.h @@ -0,0 +1,79 @@ +/* + * Copyright © 2016 Keith Packard <keithp@keithp.com> + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation; version 2 of the License. + * + * This program is distributed in the hope that it will be useful, but + * WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU + * General Public License for more details. + * + * You should have received a copy of the GNU General Public License along + * with this program; if not, write to the Free Software Foundation, Inc., + * 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA. + */ + +#ifndef _AO_SCHEME_OS_H_ +#define _AO_SCHEME_OS_H_ + +#include "ao.h" + +#define AO_SCHEME_SAVE	1 + +#define AO_SCHEME_POOL_TOTAL	2048 + +#ifndef __BYTE_ORDER +#define	__LITTLE_ENDIAN	1234 +#define	__BIG_ENDIAN	4321 +#define __BYTE_ORDER	__LITTLE_ENDIAN +#endif + +static inline int +ao_scheme_getc() { +	static uint8_t	at_eol; +	int c; + +	if (at_eol) { +		ao_cmd_readline(); +		at_eol = 0; +	} +	c = ao_cmd_lex(); +	if (c == '\n') +		at_eol = 1; +	return c; +} + +static inline void +ao_scheme_os_flush(void) +{ +	flush(); +} + +static inline void +ao_scheme_abort(void) +{ +	ao_panic(1); +} + +static inline void +ao_scheme_os_led(int led) +{ +	ao_led_set(led); +} + +#define AO_SCHEME_JIFFIES_PER_SECOND	AO_HERTZ + +static inline void +ao_scheme_os_delay(int delay) +{ +	ao_delay(delay); +} + +static inline int +ao_scheme_os_jiffy(void) +{ +	return ao_tick_count; +} +#endif diff --git a/src/lambdakey-v1.0/ao_lisp_os_save.c b/src/lambdakey-v1.0/ao_scheme_os_save.c index 44138398..184ddb8d 100644 --- a/src/lambdakey-v1.0/ao_lisp_os_save.c +++ b/src/lambdakey-v1.0/ao_scheme_os_save.c @@ -13,25 +13,25 @@   */  #include <ao.h> -#include <ao_lisp.h> +#include <ao_scheme.h>  #include <ao_flash.h>  extern uint8_t	__flash__[];  /* saved variables to rebuild the heap -   ao_lisp_atoms -   ao_lisp_frame_global +   ao_scheme_atoms +   ao_scheme_frame_global   */  int -ao_lisp_os_save(void) +ao_scheme_os_save(void)  {  	int i; -	for (i = 0; i < AO_LISP_POOL_TOTAL; i += 256) { -		uint32_t	*dst = (uint32_t *) &__flash__[i]; -		uint32_t	*src = (uint32_t *) &ao_lisp_pool[i]; +	for (i = 0; i < AO_SCHEME_POOL_TOTAL; i += 256) { +		void	*dst = &__flash__[i]; +		void	*src = &ao_scheme_pool[i];  		ao_flash_page(dst, src);  	} @@ -39,15 +39,15 @@ ao_lisp_os_save(void)  }  int -ao_lisp_os_restore_save(struct ao_lisp_os_save *save, int offset) +ao_scheme_os_restore_save(struct ao_scheme_os_save *save, int offset)  { -	memcpy(save, &__flash__[offset], sizeof (struct ao_lisp_os_save)); +	memcpy(save, &__flash__[offset], sizeof (struct ao_scheme_os_save));  	return 1;  }  int -ao_lisp_os_restore(void) +ao_scheme_os_restore(void)  { -	memcpy(ao_lisp_pool, __flash__, AO_LISP_POOL_TOTAL); +	memcpy(ao_scheme_pool, __flash__, AO_SCHEME_POOL_TOTAL);  	return 1;  } diff --git a/src/lisp/.gitignore b/src/lisp/.gitignore deleted file mode 100644 index 76a555ea..00000000 --- a/src/lisp/.gitignore +++ /dev/null @@ -1,2 +0,0 @@ -ao_lisp_make_const -ao_lisp_const.h diff --git a/src/lisp/Makefile b/src/lisp/Makefile deleted file mode 100644 index 25796ec5..00000000 --- a/src/lisp/Makefile +++ /dev/null @@ -1,22 +0,0 @@ -all: ao_lisp_const.h - -clean: -	rm -f ao_lisp_const.h $(OBJS) ao_lisp_make_const - -ao_lisp_const.h: ao_lisp_const.lisp ao_lisp_make_const -	./ao_lisp_make_const -o $@ ao_lisp_const.lisp - -include Makefile-inc -SRCS=$(LISP_SRCS) - -HDRS=$(LISP_HDRS) - -OBJS=$(SRCS:.c=.o) - -CFLAGS=-DAO_LISP_MAKE_CONST -O0 -g -I. -Wall -Wextra -no-pie - - -ao_lisp_make_const:  $(OBJS) -	$(CC) $(CFLAGS) -o $@ $(OBJS) - -$(OBJS): $(HDRS) diff --git a/src/lisp/Makefile-inc b/src/lisp/Makefile-inc deleted file mode 100644 index 126deeb0..00000000 --- a/src/lisp/Makefile-inc +++ /dev/null @@ -1,22 +0,0 @@ -LISP_SRCS=\ -	ao_lisp_make_const.c\ -	ao_lisp_mem.c \ -	ao_lisp_cons.c \ -	ao_lisp_string.c \ -	ao_lisp_atom.c \ -	ao_lisp_int.c \ -	ao_lisp_poly.c \ -	ao_lisp_builtin.c \ -	ao_lisp_read.c \ -	ao_lisp_frame.c \ -	ao_lisp_lambda.c \ -	ao_lisp_eval.c \ -	ao_lisp_rep.c \ -	ao_lisp_save.c \ -	ao_lisp_stack.c \ -	ao_lisp_error.c  - -LISP_HDRS=\ -	ao_lisp.h \ -	ao_lisp_os.h \ -	ao_lisp_read.h diff --git a/src/lisp/Makefile-lisp b/src/lisp/Makefile-lisp deleted file mode 100644 index 998c7673..00000000 --- a/src/lisp/Makefile-lisp +++ /dev/null @@ -1,4 +0,0 @@ -include ../lisp/Makefile-inc - -ao_lisp_const.h: $(LISP_SRCS) $(LISP_HDRS) -	+cd ../lisp && make $@ diff --git a/src/lisp/ao_lisp.h b/src/lisp/ao_lisp.h deleted file mode 100644 index 980514cc..00000000 --- a/src/lisp/ao_lisp.h +++ /dev/null @@ -1,793 +0,0 @@ -/* - * Copyright © 2016 Keith Packard <keithp@keithp.com> - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation, either version 2 of the License, or - * (at your option) any later version. - * - * This program is distributed in the hope that it will be useful, but - * WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU - * General Public License for more details. - */ - -#ifndef _AO_LISP_H_ -#define _AO_LISP_H_ - -#define DBG_MEM		0 -#define DBG_EVAL	0 - -#include <stdint.h> -#include <string.h> -#include <ao_lisp_os.h> - -typedef uint16_t	ao_poly; -typedef int16_t		ao_signed_poly; - -#ifdef AO_LISP_SAVE - -struct ao_lisp_os_save { -	ao_poly		atoms; -	ao_poly		globals; -	uint16_t	const_checksum; -	uint16_t	const_checksum_inv; -}; - -#define AO_LISP_POOL_EXTRA	(sizeof(struct ao_lisp_os_save)) -#define AO_LISP_POOL	((int) (AO_LISP_POOL_TOTAL - AO_LISP_POOL_EXTRA)) - -int -ao_lisp_os_save(void); - -int -ao_lisp_os_restore_save(struct ao_lisp_os_save *save, int offset); - -int -ao_lisp_os_restore(void); - -#endif - -#ifdef AO_LISP_MAKE_CONST -#define AO_LISP_POOL_CONST	16384 -extern uint8_t ao_lisp_const[AO_LISP_POOL_CONST] __attribute__((aligned(4))); -#define ao_lisp_pool ao_lisp_const -#define AO_LISP_POOL AO_LISP_POOL_CONST - -#define _atom(n) ao_lisp_atom_poly(ao_lisp_atom_intern(n)) - -#define _ao_lisp_atom_quote	_atom("quote") -#define _ao_lisp_atom_set 	_atom("set") -#define _ao_lisp_atom_setq 	_atom("setq") -#define _ao_lisp_atom_t 	_atom("t") -#define _ao_lisp_atom_car 	_atom("car") -#define _ao_lisp_atom_cdr	_atom("cdr") -#define _ao_lisp_atom_cons	_atom("cons") -#define _ao_lisp_atom_last	_atom("last") -#define _ao_lisp_atom_length	_atom("length") -#define _ao_lisp_atom_cond	_atom("cond") -#define _ao_lisp_atom_lambda	_atom("lambda") -#define _ao_lisp_atom_led	_atom("led") -#define _ao_lisp_atom_delay	_atom("delay") -#define _ao_lisp_atom_pack	_atom("pack") -#define _ao_lisp_atom_unpack	_atom("unpack") -#define _ao_lisp_atom_flush	_atom("flush") -#define _ao_lisp_atom_eval	_atom("eval") -#define _ao_lisp_atom_read	_atom("read") -#define _ao_lisp_atom_eof	_atom("eof") -#define _ao_lisp_atom_save	_atom("save") -#define _ao_lisp_atom_restore	_atom("restore") -#define _ao_lisp_atom_call2fcc	_atom("call/cc") -#define _ao_lisp_atom_collect	_atom("collect") -#define _ao_lisp_atom_symbolp   _atom("symbol?") -#define _ao_lisp_atom_builtin   _atom("builtin?") -#define _ao_lisp_atom_symbolp   _atom("symbol?") -#define _ao_lisp_atom_symbolp   _atom("symbol?") -#else -#include "ao_lisp_const.h" -#ifndef AO_LISP_POOL -#define AO_LISP_POOL	3072 -#endif -extern uint8_t		ao_lisp_pool[AO_LISP_POOL + AO_LISP_POOL_EXTRA] __attribute__((aligned(4))); -#endif - -/* Primitive types */ -#define AO_LISP_CONS		0 -#define AO_LISP_INT		1 -#define AO_LISP_STRING		2 -#define AO_LISP_OTHER		3 - -#define AO_LISP_TYPE_MASK	0x0003 -#define AO_LISP_TYPE_SHIFT	2 -#define AO_LISP_REF_MASK	0x7ffc -#define AO_LISP_CONST		0x8000 - -/* These have a type value at the start of the struct */ -#define AO_LISP_ATOM		4 -#define AO_LISP_BUILTIN		5 -#define AO_LISP_FRAME		6 -#define AO_LISP_LAMBDA		7 -#define AO_LISP_STACK		8 -#define AO_LISP_NUM_TYPE	9 - -/* Leave two bits for types to use as they please */ -#define AO_LISP_OTHER_TYPE_MASK	0x3f - -#define AO_LISP_NIL	0 - -extern uint16_t		ao_lisp_top; - -#define AO_LISP_OOM		0x01 -#define AO_LISP_DIVIDE_BY_ZERO	0x02 -#define AO_LISP_INVALID		0x04 -#define AO_LISP_UNDEFINED	0x08 -#define AO_LISP_EOF		0x10 - -extern uint8_t		ao_lisp_exception; - -static inline int -ao_lisp_is_const(ao_poly poly) { -	return poly & AO_LISP_CONST; -} - -#define AO_LISP_IS_CONST(a)	(ao_lisp_const <= ((uint8_t *) (a)) && ((uint8_t *) (a)) < ao_lisp_const + AO_LISP_POOL_CONST) -#define AO_LISP_IS_POOL(a)	(ao_lisp_pool <= ((uint8_t *) (a)) && ((uint8_t *) (a)) < ao_lisp_pool + AO_LISP_POOL) -#define AO_LISP_IS_INT(p)	(ao_lisp_base_type(p) == AO_LISP_INT); - -void * -ao_lisp_ref(ao_poly poly); - -ao_poly -ao_lisp_poly(const void *addr, ao_poly type); - -struct ao_lisp_type { -	int	(*size)(void *addr); -	void	(*mark)(void *addr); -	void	(*move)(void *addr); -	char	name[]; -}; - -struct ao_lisp_cons { -	ao_poly		car; -	ao_poly		cdr; -}; - -struct ao_lisp_atom { -	uint8_t		type; -	uint8_t		pad[1]; -	ao_poly		next; -	char		name[]; -}; - -struct ao_lisp_val { -	ao_poly		atom; -	ao_poly		val; -}; - -struct ao_lisp_frame { -	uint8_t			type; -	uint8_t			num; -	ao_poly			prev; -	struct ao_lisp_val	vals[]; -}; - -/* Set on type when the frame escapes the lambda */ -#define AO_LISP_FRAME_MARK	0x80 -#define AO_LISP_FRAME_PRINT	0x40 - -static inline int ao_lisp_frame_marked(struct ao_lisp_frame *f) { -	return f->type & AO_LISP_FRAME_MARK; -} - -static inline struct ao_lisp_frame * -ao_lisp_poly_frame(ao_poly poly) { -	return ao_lisp_ref(poly); -} - -static inline ao_poly -ao_lisp_frame_poly(struct ao_lisp_frame *frame) { -	return ao_lisp_poly(frame, AO_LISP_OTHER); -} - -enum eval_state { -	eval_sexpr,		/* Evaluate an sexpr */ -	eval_val,		/* Value computed */ -	eval_formal,		/* Formal computed */ -	eval_exec,		/* Start a lambda evaluation */ -	eval_cond,		/* Start next cond clause */ -	eval_cond_test,		/* Check cond condition */ -	eval_progn,		/* Start next progn entry */ -	eval_while,		/* Start while condition */ -	eval_while_test,	/* Check while condition */ -	eval_macro,		/* Finished with macro generation */ -}; - -struct ao_lisp_stack { -	uint8_t			type;		/* AO_LISP_STACK */ -	uint8_t			state;		/* enum eval_state */ -	ao_poly			prev;		/* previous stack frame */ -	ao_poly			sexprs;		/* expressions to evaluate */ -	ao_poly			values;		/* values computed */ -	ao_poly			values_tail;	/* end of the values list for easy appending */ -	ao_poly			frame;		/* current lookup frame */ -	ao_poly			list;		/* most recent function call */ -}; - -#define AO_LISP_STACK_MARK	0x80	/* set on type when a reference has been taken */ -#define AO_LISP_STACK_PRINT	0x40	/* stack is being printed */ - -static inline int ao_lisp_stack_marked(struct ao_lisp_stack *s) { -	return s->type & AO_LISP_STACK_MARK; -} - -static inline void ao_lisp_stack_mark(struct ao_lisp_stack *s) { -	s->type |= AO_LISP_STACK_MARK; -} - -static inline struct ao_lisp_stack * -ao_lisp_poly_stack(ao_poly p) -{ -	return ao_lisp_ref(p); -} - -static inline ao_poly -ao_lisp_stack_poly(struct ao_lisp_stack *stack) -{ -	return ao_lisp_poly(stack, AO_LISP_OTHER); -} - -extern ao_poly			ao_lisp_v; - -#define AO_LISP_FUNC_LAMBDA	0 -#define AO_LISP_FUNC_NLAMBDA	1 -#define AO_LISP_FUNC_MACRO	2 -#define AO_LISP_FUNC_LEXPR	3 - -#define AO_LISP_FUNC_FREE_ARGS	0x80 -#define AO_LISP_FUNC_MASK	0x7f - -#define AO_LISP_FUNC_F_LAMBDA	(AO_LISP_FUNC_FREE_ARGS | AO_LISP_FUNC_LAMBDA) -#define AO_LISP_FUNC_F_NLAMBDA	(AO_LISP_FUNC_FREE_ARGS | AO_LISP_FUNC_NLAMBDA) -#define AO_LISP_FUNC_F_MACRO	(AO_LISP_FUNC_FREE_ARGS | AO_LISP_FUNC_MACRO) -#define AO_LISP_FUNC_F_LEXPR	(AO_LISP_FUNC_FREE_ARGS | AO_LISP_FUNC_LEXPR) - -struct ao_lisp_builtin { -	uint8_t		type; -	uint8_t		args; -	uint16_t	func; -}; - -enum ao_lisp_builtin_id { -	builtin_eval, -	builtin_read, -	builtin_lambda, -	builtin_lexpr, -	builtin_nlambda, -	builtin_macro, -	builtin_car, -	builtin_cdr, -	builtin_cons, -	builtin_last, -	builtin_length, -	builtin_quote, -	builtin_set, -	builtin_setq, -	builtin_cond, -	builtin_progn, -	builtin_while, -	builtin_print, -	builtin_patom, -	builtin_plus, -	builtin_minus, -	builtin_times, -	builtin_divide, -	builtin_mod, -	builtin_equal, -	builtin_less, -	builtin_greater, -	builtin_less_equal, -	builtin_greater_equal, -	builtin_pack, -	builtin_unpack, -	builtin_flush, -	builtin_delay, -	builtin_led, -	builtin_save, -	builtin_restore, -	builtin_call_cc, -	builtin_collect, -	_builtin_last -}; - -typedef ao_poly (*ao_lisp_func_t)(struct ao_lisp_cons *cons); - -extern const ao_lisp_func_t	ao_lisp_builtins[]; - -static inline ao_lisp_func_t -ao_lisp_func(struct ao_lisp_builtin *b) -{ -	return ao_lisp_builtins[b->func]; -} - -struct ao_lisp_lambda { -	uint8_t		type; -	uint8_t		args; -	ao_poly		code; -	ao_poly		frame; -}; - -static inline struct ao_lisp_lambda * -ao_lisp_poly_lambda(ao_poly poly) -{ -	return ao_lisp_ref(poly); -} - -static inline ao_poly -ao_lisp_lambda_poly(struct ao_lisp_lambda *lambda) -{ -	return ao_lisp_poly(lambda, AO_LISP_OTHER); -} - -static inline void * -ao_lisp_poly_other(ao_poly poly) { -	return ao_lisp_ref(poly); -} - -static inline uint8_t -ao_lisp_other_type(void *other) { -#if DBG_MEM -	if ((*((uint8_t *) other) & AO_LISP_OTHER_TYPE_MASK) >= AO_LISP_NUM_TYPE) -		ao_lisp_abort(); -#endif -	return *((uint8_t *) other) & AO_LISP_OTHER_TYPE_MASK; -} - -static inline ao_poly -ao_lisp_other_poly(const void *other) -{ -	return ao_lisp_poly(other, AO_LISP_OTHER); -} - -static inline int -ao_lisp_size_round(int size) -{ -	return (size + 3) & ~3; -} - -static inline int -ao_lisp_size(const struct ao_lisp_type *type, void *addr) -{ -	return ao_lisp_size_round(type->size(addr)); -} - -#define AO_LISP_OTHER_POLY(other) ((ao_poly)(other) + AO_LISP_OTHER) - -static inline int ao_lisp_poly_base_type(ao_poly poly) { -	return poly & AO_LISP_TYPE_MASK; -} - -static inline int ao_lisp_poly_type(ao_poly poly) { -	int	type = poly & AO_LISP_TYPE_MASK; -	if (type == AO_LISP_OTHER) -		return ao_lisp_other_type(ao_lisp_poly_other(poly)); -	return type; -} - -static inline struct ao_lisp_cons * -ao_lisp_poly_cons(ao_poly poly) -{ -	return ao_lisp_ref(poly); -} - -static inline ao_poly -ao_lisp_cons_poly(struct ao_lisp_cons *cons) -{ -	return ao_lisp_poly(cons, AO_LISP_CONS); -} - -static inline int -ao_lisp_poly_int(ao_poly poly) -{ -	return (int) ((ao_signed_poly) poly >> AO_LISP_TYPE_SHIFT); -} - -static inline ao_poly -ao_lisp_int_poly(int i) -{ -	return ((ao_poly) i << 2) | AO_LISP_INT; -} - -static inline char * -ao_lisp_poly_string(ao_poly poly) -{ -	return ao_lisp_ref(poly); -} - -static inline ao_poly -ao_lisp_string_poly(char *s) -{ -	return ao_lisp_poly(s, AO_LISP_STRING); -} - -static inline struct ao_lisp_atom * -ao_lisp_poly_atom(ao_poly poly) -{ -	return ao_lisp_ref(poly); -} - -static inline ao_poly -ao_lisp_atom_poly(struct ao_lisp_atom *a) -{ -	return ao_lisp_poly(a, AO_LISP_OTHER); -} - -static inline struct ao_lisp_builtin * -ao_lisp_poly_builtin(ao_poly poly) -{ -	return ao_lisp_ref(poly); -} - -static inline ao_poly -ao_lisp_builtin_poly(struct ao_lisp_builtin *b) -{ -	return ao_lisp_poly(b, AO_LISP_OTHER); -} - -/* memory functions */ - -extern int ao_lisp_collects[2]; -extern int ao_lisp_freed[2]; -extern int ao_lisp_loops[2]; - -/* returns 1 if the object was already marked */ -int -ao_lisp_mark(const struct ao_lisp_type *type, void *addr); - -/* returns 1 if the object was already marked */ -int -ao_lisp_mark_memory(const struct ao_lisp_type *type, void *addr); - -void * -ao_lisp_move_map(void *addr); - -/* returns 1 if the object was already moved */ -int -ao_lisp_move(const struct ao_lisp_type *type, void **ref); - -/* returns 1 if the object was already moved */ -int -ao_lisp_move_memory(const struct ao_lisp_type *type, void **ref); - -void * -ao_lisp_alloc(int size); - -#define AO_LISP_COLLECT_FULL		1 -#define AO_LISP_COLLECT_INCREMENTAL	0 - -int -ao_lisp_collect(uint8_t style); - -void -ao_lisp_cons_stash(int id, struct ao_lisp_cons *cons); - -struct ao_lisp_cons * -ao_lisp_cons_fetch(int id); - -void -ao_lisp_poly_stash(int id, ao_poly poly); - -ao_poly -ao_lisp_poly_fetch(int id); - -void -ao_lisp_string_stash(int id, char *string); - -char * -ao_lisp_string_fetch(int id); - -static inline void -ao_lisp_stack_stash(int id, struct ao_lisp_stack *stack) { -	ao_lisp_poly_stash(id, ao_lisp_stack_poly(stack)); -} - -static inline struct ao_lisp_stack * -ao_lisp_stack_fetch(int id) { -	return ao_lisp_poly_stack(ao_lisp_poly_fetch(id)); -} - -/* cons */ -extern const struct ao_lisp_type ao_lisp_cons_type; - -struct ao_lisp_cons * -ao_lisp_cons_cons(ao_poly car, struct ao_lisp_cons *cdr); - -extern struct ao_lisp_cons *ao_lisp_cons_free_list; - -void -ao_lisp_cons_free(struct ao_lisp_cons *cons); - -void -ao_lisp_cons_print(ao_poly); - -void -ao_lisp_cons_patom(ao_poly); - -int -ao_lisp_cons_length(struct ao_lisp_cons *cons); - -/* string */ -extern const struct ao_lisp_type ao_lisp_string_type; - -char * -ao_lisp_string_copy(char *a); - -char * -ao_lisp_string_cat(char *a, char *b); - -ao_poly -ao_lisp_string_pack(struct ao_lisp_cons *cons); - -ao_poly -ao_lisp_string_unpack(char *a); - -void -ao_lisp_string_print(ao_poly s); - -void -ao_lisp_string_patom(ao_poly s); - -/* atom */ -extern const struct ao_lisp_type ao_lisp_atom_type; - -extern struct ao_lisp_atom	*ao_lisp_atoms; -extern struct ao_lisp_frame	*ao_lisp_frame_global; -extern struct ao_lisp_frame	*ao_lisp_frame_current; - -void -ao_lisp_atom_print(ao_poly a); - -struct ao_lisp_atom * -ao_lisp_atom_intern(char *name); - -ao_poly * -ao_lisp_atom_ref(struct ao_lisp_frame *frame, ao_poly atom); - -ao_poly -ao_lisp_atom_get(ao_poly atom); - -ao_poly -ao_lisp_atom_set(ao_poly atom, ao_poly val); - -/* int */ -void -ao_lisp_int_print(ao_poly i); - -/* prim */ -void -ao_lisp_poly_print(ao_poly p); - -void -ao_lisp_poly_patom(ao_poly p); - -int -ao_lisp_poly_mark(ao_poly p, uint8_t note_cons); - -/* returns 1 if the object has already been moved */ -int -ao_lisp_poly_move(ao_poly *p, uint8_t note_cons); - -/* eval */ - -void -ao_lisp_eval_clear_globals(void); - -int -ao_lisp_eval_restart(void); - -ao_poly -ao_lisp_eval(ao_poly p); - -ao_poly -ao_lisp_set_cond(struct ao_lisp_cons *cons); - -/* builtin */ -void -ao_lisp_builtin_print(ao_poly b); - -extern const struct ao_lisp_type ao_lisp_builtin_type; - -/* Check argument count */ -ao_poly -ao_lisp_check_argc(ao_poly name, struct ao_lisp_cons *cons, int min, int max); - -/* Check argument type */ -ao_poly -ao_lisp_check_argt(ao_poly name, struct ao_lisp_cons *cons, int argc, int type, int nil_ok); - -/* Fetch an arg (nil if off the end) */ -ao_poly -ao_lisp_arg(struct ao_lisp_cons *cons, int argc); - -char * -ao_lisp_args_name(uint8_t args); - -/* read */ -extern struct ao_lisp_cons	*ao_lisp_read_cons; -extern struct ao_lisp_cons	*ao_lisp_read_cons_tail; -extern struct ao_lisp_cons	*ao_lisp_read_stack; - -ao_poly -ao_lisp_read(void); - -/* rep */ -ao_poly -ao_lisp_read_eval_print(void); - -/* frame */ -extern const struct ao_lisp_type ao_lisp_frame_type; - -#define AO_LISP_FRAME_FREE	6 - -extern struct ao_lisp_frame	*ao_lisp_frame_free_list[AO_LISP_FRAME_FREE]; - -ao_poly -ao_lisp_frame_mark(struct ao_lisp_frame *frame); - -ao_poly * -ao_lisp_frame_ref(struct ao_lisp_frame *frame, ao_poly atom); - -struct ao_lisp_frame * -ao_lisp_frame_new(int num); - -void -ao_lisp_frame_free(struct ao_lisp_frame *frame); - -void -ao_lisp_frame_bind(struct ao_lisp_frame *frame, int num, ao_poly atom, ao_poly val); - -int -ao_lisp_frame_add(struct ao_lisp_frame **frame, ao_poly atom, ao_poly val); - -void -ao_lisp_frame_print(ao_poly p); - -/* lambda */ -extern const struct ao_lisp_type ao_lisp_lambda_type; - -extern const char *ao_lisp_state_names[]; - -struct ao_lisp_lambda * -ao_lisp_lambda_new(ao_poly cons); - -void -ao_lisp_lambda_print(ao_poly lambda); - -ao_poly -ao_lisp_lambda(struct ao_lisp_cons *cons); - -ao_poly -ao_lisp_lexpr(struct ao_lisp_cons *cons); - -ao_poly -ao_lisp_nlambda(struct ao_lisp_cons *cons); - -ao_poly -ao_lisp_macro(struct ao_lisp_cons *cons); - -ao_poly -ao_lisp_lambda_eval(void); - -/* save */ - -ao_poly -ao_lisp_save(struct ao_lisp_cons *cons); - -ao_poly -ao_lisp_restore(struct ao_lisp_cons *cons); - -/* stack */ - -extern const struct ao_lisp_type ao_lisp_stack_type; -extern struct ao_lisp_stack	*ao_lisp_stack; -extern struct ao_lisp_stack	*ao_lisp_stack_free_list; - -void -ao_lisp_stack_reset(struct ao_lisp_stack *stack); - -int -ao_lisp_stack_push(void); - -void -ao_lisp_stack_pop(void); - -void -ao_lisp_stack_clear(void); - -void -ao_lisp_stack_print(ao_poly stack); - -ao_poly -ao_lisp_stack_eval(void); - -ao_poly -ao_lisp_call_cc(struct ao_lisp_cons *cons); - -/* error */ - -void -ao_lisp_error_poly(char *name, ao_poly poly, ao_poly last); - -void -ao_lisp_error_frame(int indent, char *name, struct ao_lisp_frame *frame); - -ao_poly -ao_lisp_error(int error, char *format, ...); - -/* debugging macros */ - -#if DBG_EVAL -#define DBG_CODE	1 -int ao_lisp_stack_depth; -#define DBG_DO(a)	a -#define DBG_INDENT()	do { int _s; for(_s = 0; _s < ao_lisp_stack_depth; _s++) printf("  "); } while(0) -#define DBG_IN()	(++ao_lisp_stack_depth) -#define DBG_OUT()	(--ao_lisp_stack_depth) -#define DBG_RESET()	(ao_lisp_stack_depth = 0) -#define DBG(...) 	printf(__VA_ARGS__) -#define DBGI(...)	do { DBG("%4d: ", __LINE__); DBG_INDENT(); DBG(__VA_ARGS__); } while (0) -#define DBG_CONS(a)	ao_lisp_cons_print(ao_lisp_cons_poly(a)) -#define DBG_POLY(a)	ao_lisp_poly_print(a) -#define OFFSET(a)	((a) ? (int) ((uint8_t *) a - ao_lisp_pool) : -1) -#define DBG_STACK()	ao_lisp_stack_print(ao_lisp_stack_poly(ao_lisp_stack)) -static inline void -ao_lisp_frames_dump(void) -{ -	struct ao_lisp_stack *s; -	DBGI(".. current frame: "); DBG_POLY(ao_lisp_frame_poly(ao_lisp_frame_current)); DBG("\n"); -	for (s = ao_lisp_stack; s; s = ao_lisp_poly_stack(s->prev)) { -		DBGI(".. stack frame: "); DBG_POLY(s->frame); DBG("\n"); -	} -} -#define DBG_FRAMES()	ao_lisp_frames_dump() -#else -#define DBG_DO(a) -#define DBG_INDENT() -#define DBG_IN() -#define DBG_OUT() -#define DBG(...) -#define DBGI(...) -#define DBG_CONS(a) -#define DBG_POLY(a) -#define DBG_RESET() -#define DBG_STACK() -#define DBG_FRAMES() -#endif - -#define DBG_MEM_START	1 - -#if DBG_MEM - -#include <assert.h> -extern int dbg_move_depth; -#define MDBG_DUMP 1 -#define MDBG_OFFSET(a)	((int) ((uint8_t *) (a) - ao_lisp_pool)) - -extern int dbg_mem; - -#define MDBG_DO(a)	a -#define MDBG_MOVE(...) do { if (dbg_mem) { int d; for (d = 0; d < dbg_move_depth; d++) printf ("  "); printf(__VA_ARGS__); } } while (0) -#define MDBG_MORE(...) do { if (dbg_mem) printf(__VA_ARGS__); } while (0) -#define MDBG_MOVE_IN()	(dbg_move_depth++) -#define MDBG_MOVE_OUT()	(assert(--dbg_move_depth >= 0)) - -#else - -#define MDBG_DO(a) -#define MDBG_MOVE(...) -#define MDBG_MORE(...) -#define MDBG_MOVE_IN() -#define MDBG_MOVE_OUT() - -#endif - -#endif /* _AO_LISP_H_ */ diff --git a/src/lisp/ao_lisp_atom.c b/src/lisp/ao_lisp_atom.c deleted file mode 100644 index 8c9e8ed1..00000000 --- a/src/lisp/ao_lisp_atom.c +++ /dev/null @@ -1,165 +0,0 @@ -/* - * Copyright © 2016 Keith Packard <keithp@keithp.com> - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation; version 2 of the License. - * - * This program is distributed in the hope that it will be useful, but - * WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU - * General Public License for more details. - * - * You should have received a copy of the GNU General Public License along - * with this program; if not, write to the Free Software Foundation, Inc., - * 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA. - */ - -#include "ao_lisp.h" - -static int name_size(char *name) -{ -	return sizeof(struct ao_lisp_atom) + strlen(name) + 1; -} - -static int atom_size(void *addr) -{ -	struct ao_lisp_atom	*atom = addr; -	if (!atom) -		return 0; -	return name_size(atom->name); -} - -static void atom_mark(void *addr) -{ -	struct ao_lisp_atom	*atom = addr; - -	for (;;) { -		atom = ao_lisp_poly_atom(atom->next); -		if (!atom) -			break; -		if (ao_lisp_mark_memory(&ao_lisp_atom_type, atom)) -			break; -	} -} - -static void atom_move(void *addr) -{ -	struct ao_lisp_atom	*atom = addr; -	int			ret; - -	for (;;) { -		struct ao_lisp_atom *next = ao_lisp_poly_atom(atom->next); - -		if (!next) -			break; -		ret = ao_lisp_move_memory(&ao_lisp_atom_type, (void **) &next); -		if (next != ao_lisp_poly_atom(atom->next)) -			atom->next = ao_lisp_atom_poly(next); -		if (ret) -			break; -		atom = next; -	} -} - -const struct ao_lisp_type ao_lisp_atom_type = { -	.mark = atom_mark, -	.size = atom_size, -	.move = atom_move, -	.name = "atom" -}; - -struct ao_lisp_atom	*ao_lisp_atoms; - -struct ao_lisp_atom * -ao_lisp_atom_intern(char *name) -{ -	struct ao_lisp_atom	*atom; - -	for (atom = ao_lisp_atoms; atom; atom = ao_lisp_poly_atom(atom->next)) { -		if (!strcmp(atom->name, name)) -			return atom; -	} -#ifdef ao_builtin_atoms -	for (atom = ao_lisp_poly_atom(ao_builtin_atoms); atom; atom = ao_lisp_poly_atom(atom->next)) { -		if (!strcmp(atom->name, name)) -			return atom; -	} -#endif -	ao_lisp_string_stash(0, name); -	atom = ao_lisp_alloc(name_size(name)); -	name = ao_lisp_string_fetch(0); -	if (atom) { -		atom->type = AO_LISP_ATOM; -		atom->next = ao_lisp_atom_poly(ao_lisp_atoms); -		ao_lisp_atoms = atom; -		strcpy(atom->name, name); -	} -	return atom; -} - -struct ao_lisp_frame	*ao_lisp_frame_global; -struct ao_lisp_frame	*ao_lisp_frame_current; - -static void -ao_lisp_atom_init(void) -{ -	if (!ao_lisp_frame_global) -		ao_lisp_frame_global = ao_lisp_frame_new(0); -} - -ao_poly * -ao_lisp_atom_ref(struct ao_lisp_frame *frame, ao_poly atom) -{ -	ao_poly	*ref; -	ao_lisp_atom_init(); -	while (frame) { -		ref = ao_lisp_frame_ref(frame, atom); -		if (ref) -			return ref; -		frame = ao_lisp_poly_frame(frame->prev); -	} -	if (ao_lisp_frame_global) { -		ref = ao_lisp_frame_ref(ao_lisp_frame_global, atom); -		if (ref) -			return ref; -	} -	return NULL; -} - -ao_poly -ao_lisp_atom_get(ao_poly atom) -{ -	ao_poly *ref = ao_lisp_atom_ref(ao_lisp_frame_current, atom); - -	if (!ref && ao_lisp_frame_global) -		ref = ao_lisp_frame_ref(ao_lisp_frame_global, atom); -#ifdef ao_builtin_frame -	if (!ref) -		ref = ao_lisp_frame_ref(ao_lisp_poly_frame(ao_builtin_frame), atom); -#endif -	if (ref) -		return *ref; -	return ao_lisp_error(AO_LISP_UNDEFINED, "undefined atom %s", ao_lisp_poly_atom(atom)->name); -} - -ao_poly -ao_lisp_atom_set(ao_poly atom, ao_poly val) -{ -	ao_poly *ref = ao_lisp_atom_ref(ao_lisp_frame_current, atom); - -	if (!ref && ao_lisp_frame_global) -		ref = ao_lisp_frame_ref(ao_lisp_frame_global, atom); -	if (ref) -		*ref = val; -	else -		ao_lisp_frame_add(&ao_lisp_frame_global, atom, val); -	return val; -} - -void -ao_lisp_atom_print(ao_poly a) -{ -	struct ao_lisp_atom *atom = ao_lisp_poly_atom(a); -	printf("%s", atom->name); -} diff --git a/src/lisp/ao_lisp_builtin.c b/src/lisp/ao_lisp_builtin.c deleted file mode 100644 index 902f60e2..00000000 --- a/src/lisp/ao_lisp_builtin.c +++ /dev/null @@ -1,619 +0,0 @@ -/* - * Copyright © 2016 Keith Packard <keithp@keithp.com> - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation, either version 2 of the License, or - * (at your option) any later version. - * - * This program is distributed in the hope that it will be useful, but - * WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU - * General Public License for more details. - */ - -#include "ao_lisp.h" - -static int -builtin_size(void *addr) -{ -	(void) addr; -	return sizeof (struct ao_lisp_builtin); -} - -static void -builtin_mark(void *addr) -{ -	(void) addr; -} - -static void -builtin_move(void *addr) -{ -	(void) addr; -} - -const struct ao_lisp_type ao_lisp_builtin_type = { -	.size = builtin_size, -	.mark = builtin_mark, -	.move = builtin_move -}; - -#ifdef AO_LISP_MAKE_CONST -char *ao_lisp_builtin_name(enum ao_lisp_builtin_id b) { -	(void) b; -	return "???"; -} -char *ao_lisp_args_name(uint8_t args) { -	(void) args; -	return "???"; -} -#else -static const ao_poly builtin_names[] = { -	[builtin_eval] = _ao_lisp_atom_eval, -	[builtin_read] = _ao_lisp_atom_read, -	[builtin_lambda] = _ao_lisp_atom_lambda, -	[builtin_lexpr] = _ao_lisp_atom_lexpr, -	[builtin_nlambda] = _ao_lisp_atom_nlambda, -	[builtin_macro] = _ao_lisp_atom_macro, -	[builtin_car] = _ao_lisp_atom_car, -	[builtin_cdr] = _ao_lisp_atom_cdr, -	[builtin_cons] = _ao_lisp_atom_cons, -	[builtin_last] = _ao_lisp_atom_last, -	[builtin_length] = _ao_lisp_atom_length, -	[builtin_quote] = _ao_lisp_atom_quote, -	[builtin_set] = _ao_lisp_atom_set, -	[builtin_setq] = _ao_lisp_atom_setq, -	[builtin_cond] = _ao_lisp_atom_cond, -	[builtin_progn] = _ao_lisp_atom_progn, -	[builtin_while] = _ao_lisp_atom_while, -	[builtin_print] = _ao_lisp_atom_print, -	[builtin_patom] = _ao_lisp_atom_patom, -	[builtin_plus] = _ao_lisp_atom_2b, -	[builtin_minus] = _ao_lisp_atom_2d, -	[builtin_times] = _ao_lisp_atom_2a, -	[builtin_divide] = _ao_lisp_atom_2f, -	[builtin_mod] = _ao_lisp_atom_25, -	[builtin_equal] = _ao_lisp_atom_3d, -	[builtin_less] = _ao_lisp_atom_3c, -	[builtin_greater] = _ao_lisp_atom_3e, -	[builtin_less_equal] = _ao_lisp_atom_3c3d, -	[builtin_greater_equal] = _ao_lisp_atom_3e3d, -	[builtin_pack] = _ao_lisp_atom_pack, -	[builtin_unpack] = _ao_lisp_atom_unpack, -	[builtin_flush] = _ao_lisp_atom_flush, -	[builtin_delay] = _ao_lisp_atom_delay, -	[builtin_led] = _ao_lisp_atom_led, -	[builtin_save] = _ao_lisp_atom_save, -	[builtin_restore] = _ao_lisp_atom_restore, -	[builtin_call_cc] = _ao_lisp_atom_call2fcc, -	[builtin_collect] = _ao_lisp_atom_collect, -#if 0 -	[builtin_symbolp] = _ao_lisp_atom_symbolp, -	[builtin_listp] = _ao_lisp_atom_listp, -	[builtin_stringp] = _ao_lisp_atom_stringp, -	[builtin_numberp] = _ao_lisp_atom_numberp, -#endif -}; - -static char * -ao_lisp_builtin_name(enum ao_lisp_builtin_id b) { -	if (b < _builtin_last) -		return ao_lisp_poly_atom(builtin_names[b])->name; -	return "???"; -} - -static const ao_poly ao_lisp_args_atoms[] = { -	[AO_LISP_FUNC_LAMBDA] = _ao_lisp_atom_lambda, -	[AO_LISP_FUNC_LEXPR] = _ao_lisp_atom_lexpr, -	[AO_LISP_FUNC_NLAMBDA] = _ao_lisp_atom_nlambda, -	[AO_LISP_FUNC_MACRO] = _ao_lisp_atom_macro, -}; - -char * -ao_lisp_args_name(uint8_t args) -{ -	args &= AO_LISP_FUNC_MASK; -	if (args < sizeof ao_lisp_args_atoms / sizeof ao_lisp_args_atoms[0]) -		return ao_lisp_poly_atom(ao_lisp_args_atoms[args])->name; -	return "(unknown)"; -} -#endif - -void -ao_lisp_builtin_print(ao_poly b) -{ -	struct ao_lisp_builtin *builtin = ao_lisp_poly_builtin(b); -	printf("%s", ao_lisp_builtin_name(builtin->func)); -} - -ao_poly -ao_lisp_check_argc(ao_poly name, struct ao_lisp_cons *cons, int min, int max) -{ -	int	argc = 0; - -	while (cons && argc <= max) { -		argc++; -		cons = ao_lisp_poly_cons(cons->cdr); -	} -	if (argc < min || argc > max) -		return ao_lisp_error(AO_LISP_INVALID, "%s: invalid arg count", ao_lisp_poly_atom(name)->name); -	return _ao_lisp_atom_t; -} - -ao_poly -ao_lisp_arg(struct ao_lisp_cons *cons, int argc) -{ -	if (!cons) -		return AO_LISP_NIL; -	while (argc--) { -		if (!cons) -			return AO_LISP_NIL; -		cons = ao_lisp_poly_cons(cons->cdr); -	} -	return cons->car; -} - -ao_poly -ao_lisp_check_argt(ao_poly name, struct ao_lisp_cons *cons, int argc, int type, int nil_ok) -{ -	ao_poly car = ao_lisp_arg(cons, argc); - -	if ((!car && !nil_ok) || ao_lisp_poly_type(car) != type) -		return ao_lisp_error(AO_LISP_INVALID, "%s: invalid type for arg %d", ao_lisp_poly_atom(name)->name, argc); -	return _ao_lisp_atom_t; -} - -ao_poly -ao_lisp_car(struct ao_lisp_cons *cons) -{ -	if (!ao_lisp_check_argc(_ao_lisp_atom_car, cons, 1, 1)) -		return AO_LISP_NIL; -	if (!ao_lisp_check_argt(_ao_lisp_atom_car, cons, 0, AO_LISP_CONS, 0)) -		return AO_LISP_NIL; -	return ao_lisp_poly_cons(cons->car)->car; -} - -ao_poly -ao_lisp_cdr(struct ao_lisp_cons *cons) -{ -	if (!ao_lisp_check_argc(_ao_lisp_atom_cdr, cons, 1, 1)) -		return AO_LISP_NIL; -	if (!ao_lisp_check_argt(_ao_lisp_atom_cdr, cons, 0, AO_LISP_CONS, 0)) -		return AO_LISP_NIL; -	return ao_lisp_poly_cons(cons->car)->cdr; -} - -ao_poly -ao_lisp_cons(struct ao_lisp_cons *cons) -{ -	ao_poly	car, cdr; -	if(!ao_lisp_check_argc(_ao_lisp_atom_cons, cons, 2, 2)) -		return AO_LISP_NIL; -	if (!ao_lisp_check_argt(_ao_lisp_atom_cons, cons, 1, AO_LISP_CONS, 1)) -		return AO_LISP_NIL; -	car = ao_lisp_arg(cons, 0); -	cdr = ao_lisp_arg(cons, 1); -	return ao_lisp_cons_poly(ao_lisp_cons_cons(car, ao_lisp_poly_cons(cdr))); -} - -ao_poly -ao_lisp_last(struct ao_lisp_cons *cons) -{ -	ao_poly	l; -	if (!ao_lisp_check_argc(_ao_lisp_atom_last, cons, 1, 1)) -		return AO_LISP_NIL; -	if (!ao_lisp_check_argt(_ao_lisp_atom_last, cons, 0, AO_LISP_CONS, 1)) -		return AO_LISP_NIL; -	l = ao_lisp_arg(cons, 0); -	while (l) { -		struct ao_lisp_cons *list = ao_lisp_poly_cons(l); -		if (!list->cdr) -			return list->car; -		l = list->cdr; -	} -	return AO_LISP_NIL; -} - -ao_poly -ao_lisp_length(struct ao_lisp_cons *cons) -{ -	if (!ao_lisp_check_argc(_ao_lisp_atom_length, cons, 1, 1)) -		return AO_LISP_NIL; -	if (!ao_lisp_check_argt(_ao_lisp_atom_length, cons, 0, AO_LISP_CONS, 1)) -		return AO_LISP_NIL; -	return ao_lisp_int_poly(ao_lisp_cons_length(ao_lisp_poly_cons(ao_lisp_arg(cons, 0)))); -} - -ao_poly -ao_lisp_quote(struct ao_lisp_cons *cons) -{ -	if (!ao_lisp_check_argc(_ao_lisp_atom_quote, cons, 1, 1)) -		return AO_LISP_NIL; -	return ao_lisp_arg(cons, 0); -} - -ao_poly -ao_lisp_set(struct ao_lisp_cons *cons) -{ -	if (!ao_lisp_check_argc(_ao_lisp_atom_set, cons, 2, 2)) -		return AO_LISP_NIL; -	if (!ao_lisp_check_argt(_ao_lisp_atom_set, cons, 0, AO_LISP_ATOM, 0)) -		return AO_LISP_NIL; - -	return ao_lisp_atom_set(ao_lisp_arg(cons, 0), ao_lisp_arg(cons, 1)); -} - -ao_poly -ao_lisp_setq(struct ao_lisp_cons *cons) -{ -	struct ao_lisp_cons	*expand = 0; -	if (!ao_lisp_check_argc(_ao_lisp_atom_setq, cons, 2, 2)) -		return AO_LISP_NIL; -	expand = ao_lisp_cons_cons(_ao_lisp_atom_set, -				   ao_lisp_cons_cons(ao_lisp_cons_poly(ao_lisp_cons_cons(_ao_lisp_atom_quote, -								       ao_lisp_cons_cons(cons->car, NULL))), -						     ao_lisp_poly_cons(cons->cdr))); -	return ao_lisp_cons_poly(expand); -} - -ao_poly -ao_lisp_cond(struct ao_lisp_cons *cons) -{ -	ao_lisp_set_cond(cons); -	return AO_LISP_NIL; -} - -ao_poly -ao_lisp_progn(struct ao_lisp_cons *cons) -{ -	ao_lisp_stack->state = eval_progn; -	ao_lisp_stack->sexprs = ao_lisp_cons_poly(cons); -	return AO_LISP_NIL; -} - -ao_poly -ao_lisp_while(struct ao_lisp_cons *cons) -{ -	ao_lisp_stack->state = eval_while; -	ao_lisp_stack->sexprs = ao_lisp_cons_poly(cons); -	return AO_LISP_NIL; -} - -ao_poly -ao_lisp_print(struct ao_lisp_cons *cons) -{ -	ao_poly	val = AO_LISP_NIL; -	while (cons) { -		val = cons->car; -		ao_lisp_poly_print(val); -		cons = ao_lisp_poly_cons(cons->cdr); -		if (cons) -			printf(" "); -	} -	printf("\n"); -	return val; -} - -ao_poly -ao_lisp_patom(struct ao_lisp_cons *cons) -{ -	ao_poly	val = AO_LISP_NIL; -	while (cons) { -		val = cons->car; -		ao_lisp_poly_patom(val); -		cons = ao_lisp_poly_cons(cons->cdr); -	} -	return val; -} - -ao_poly -ao_lisp_math(struct ao_lisp_cons *cons, enum ao_lisp_builtin_id op) -{ -	ao_poly	ret = AO_LISP_NIL; - -	while (cons) { -		ao_poly		car = cons->car; -		uint8_t		rt = ao_lisp_poly_type(ret); -		uint8_t		ct = ao_lisp_poly_type(car); - -		cons = ao_lisp_poly_cons(cons->cdr); - -		if (rt == AO_LISP_NIL) -			ret = car; - -		else if (rt == AO_LISP_INT && ct == AO_LISP_INT) { -			int	r = ao_lisp_poly_int(ret); -			int	c = ao_lisp_poly_int(car); - -			switch(op) { -			case builtin_plus: -				r += c; -				break; -			case builtin_minus: -				r -= c; -				break; -			case builtin_times: -				r *= c; -				break; -			case builtin_divide: -				if (c == 0) -					return ao_lisp_error(AO_LISP_DIVIDE_BY_ZERO, "divide by zero"); -				r /= c; -				break; -			case builtin_mod: -				if (c == 0) -					return ao_lisp_error(AO_LISP_DIVIDE_BY_ZERO, "mod by zero"); -				r %= c; -				break; -			default: -				break; -			} -			ret = ao_lisp_int_poly(r); -		} - -		else if (rt == AO_LISP_STRING && ct == AO_LISP_STRING && op == builtin_plus) -			ret = ao_lisp_string_poly(ao_lisp_string_cat(ao_lisp_poly_string(ret), -								     ao_lisp_poly_string(car))); -		else -			return ao_lisp_error(AO_LISP_INVALID, "invalid args"); -	} -	return ret; -} - -ao_poly -ao_lisp_plus(struct ao_lisp_cons *cons) -{ -	return ao_lisp_math(cons, builtin_plus); -} - -ao_poly -ao_lisp_minus(struct ao_lisp_cons *cons) -{ -	return ao_lisp_math(cons, builtin_minus); -} - -ao_poly -ao_lisp_times(struct ao_lisp_cons *cons) -{ -	return ao_lisp_math(cons, builtin_times); -} - -ao_poly -ao_lisp_divide(struct ao_lisp_cons *cons) -{ -	return ao_lisp_math(cons, builtin_divide); -} - -ao_poly -ao_lisp_mod(struct ao_lisp_cons *cons) -{ -	return ao_lisp_math(cons, builtin_mod); -} - -ao_poly -ao_lisp_compare(struct ao_lisp_cons *cons, enum ao_lisp_builtin_id op) -{ -	ao_poly	left; - -	if (!cons) -		return _ao_lisp_atom_t; - -	left = cons->car; -	cons = ao_lisp_poly_cons(cons->cdr); -	while (cons) { -		ao_poly	right = cons->car; - -		if (op == builtin_equal) { -			if (left != right) -				return AO_LISP_NIL; -		} else { -			uint8_t	lt = ao_lisp_poly_type(left); -			uint8_t	rt = ao_lisp_poly_type(right); -			if (lt == AO_LISP_INT && rt == AO_LISP_INT) { -				int l = ao_lisp_poly_int(left); -				int r = ao_lisp_poly_int(right); - -				switch (op) { -				case builtin_less: -					if (!(l < r)) -						return AO_LISP_NIL; -					break; -				case builtin_greater: -					if (!(l > r)) -						return AO_LISP_NIL; -					break; -				case builtin_less_equal: -					if (!(l <= r)) -						return AO_LISP_NIL; -					break; -				case builtin_greater_equal: -					if (!(l >= r)) -						return AO_LISP_NIL; -					break; -				default: -					break; -				} -			} else if (lt == AO_LISP_STRING && rt == AO_LISP_STRING) { -				int c = strcmp(ao_lisp_poly_string(left), -					       ao_lisp_poly_string(right)); -				switch (op) { -				case builtin_less: -					if (!(c < 0)) -						return AO_LISP_NIL; -					break; -				case builtin_greater: -					if (!(c > 0)) -						return AO_LISP_NIL; -					break; -				case builtin_less_equal: -					if (!(c <= 0)) -						return AO_LISP_NIL; -					break; -				case builtin_greater_equal: -					if (!(c >= 0)) -						return AO_LISP_NIL; -					break; -				default: -					break; -				} -			} -		} -		left = right; -		cons = ao_lisp_poly_cons(cons->cdr); -	} -	return _ao_lisp_atom_t; -} - -ao_poly -ao_lisp_equal(struct ao_lisp_cons *cons) -{ -	return ao_lisp_compare(cons, builtin_equal); -} - -ao_poly -ao_lisp_less(struct ao_lisp_cons *cons) -{ -	return ao_lisp_compare(cons, builtin_less); -} - -ao_poly -ao_lisp_greater(struct ao_lisp_cons *cons) -{ -	return ao_lisp_compare(cons, builtin_greater); -} - -ao_poly -ao_lisp_less_equal(struct ao_lisp_cons *cons) -{ -	return ao_lisp_compare(cons, builtin_less_equal); -} - -ao_poly -ao_lisp_greater_equal(struct ao_lisp_cons *cons) -{ -	return ao_lisp_compare(cons, builtin_greater_equal); -} - -ao_poly -ao_lisp_pack(struct ao_lisp_cons *cons) -{ -	if (!ao_lisp_check_argc(_ao_lisp_atom_pack, cons, 1, 1)) -		return AO_LISP_NIL; -	if (!ao_lisp_check_argt(_ao_lisp_atom_pack, cons, 0, AO_LISP_CONS, 1)) -		return AO_LISP_NIL; -	return ao_lisp_string_pack(ao_lisp_poly_cons(ao_lisp_arg(cons, 0))); -} - -ao_poly -ao_lisp_unpack(struct ao_lisp_cons *cons) -{ -	if (!ao_lisp_check_argc(_ao_lisp_atom_unpack, cons, 1, 1)) -		return AO_LISP_NIL; -	if (!ao_lisp_check_argt(_ao_lisp_atom_unpack, cons, 0, AO_LISP_STRING, 0)) -		return AO_LISP_NIL; -	return ao_lisp_string_unpack(ao_lisp_poly_string(ao_lisp_arg(cons, 0))); -} - -ao_poly -ao_lisp_flush(struct ao_lisp_cons *cons) -{ -	if (!ao_lisp_check_argc(_ao_lisp_atom_flush, cons, 0, 0)) -		return AO_LISP_NIL; -	ao_lisp_os_flush(); -	return _ao_lisp_atom_t; -} - -ao_poly -ao_lisp_led(struct ao_lisp_cons *cons) -{ -	ao_poly led; -	if (!ao_lisp_check_argc(_ao_lisp_atom_led, cons, 1, 1)) -		return AO_LISP_NIL; -	if (!ao_lisp_check_argt(_ao_lisp_atom_led, cons, 0, AO_LISP_INT, 0)) -		return AO_LISP_NIL; -	led = ao_lisp_arg(cons, 0); -	ao_lisp_os_led(ao_lisp_poly_int(led)); -	return led; -} - -ao_poly -ao_lisp_delay(struct ao_lisp_cons *cons) -{ -	ao_poly delay; -	if (!ao_lisp_check_argc(_ao_lisp_atom_led, cons, 1, 1)) -		return AO_LISP_NIL; -	if (!ao_lisp_check_argt(_ao_lisp_atom_led, cons, 0, AO_LISP_INT, 0)) -		return AO_LISP_NIL; -	delay = ao_lisp_arg(cons, 0); -	ao_lisp_os_delay(ao_lisp_poly_int(delay)); -	return delay; -} - -ao_poly -ao_lisp_do_eval(struct ao_lisp_cons *cons) -{ -	if (!ao_lisp_check_argc(_ao_lisp_atom_eval, cons, 1, 1)) -		return AO_LISP_NIL; -	ao_lisp_stack->state = eval_sexpr; -	return cons->car; -} - -ao_poly -ao_lisp_do_read(struct ao_lisp_cons *cons) -{ -	if (!ao_lisp_check_argc(_ao_lisp_atom_read, cons, 0, 0)) -		return AO_LISP_NIL; -	return ao_lisp_read(); -} - -ao_poly -ao_lisp_do_collect(struct ao_lisp_cons *cons) -{ -	int	free; -	(void) cons; -	free = ao_lisp_collect(AO_LISP_COLLECT_FULL); -	return ao_lisp_int_poly(free); -} - -const ao_lisp_func_t ao_lisp_builtins[] = { -	[builtin_eval] = ao_lisp_do_eval, -	[builtin_read] = ao_lisp_do_read, -	[builtin_lambda] = ao_lisp_lambda, -	[builtin_lexpr] = ao_lisp_lexpr, -	[builtin_nlambda] = ao_lisp_nlambda, -	[builtin_macro] = ao_lisp_macro, -	[builtin_car] = ao_lisp_car, -	[builtin_cdr] = ao_lisp_cdr, -	[builtin_cons] = ao_lisp_cons, -	[builtin_last] = ao_lisp_last, -	[builtin_length] = ao_lisp_length, -	[builtin_quote] = ao_lisp_quote, -	[builtin_set] = ao_lisp_set, -	[builtin_setq] = ao_lisp_setq, -	[builtin_cond] = ao_lisp_cond, -	[builtin_progn] = ao_lisp_progn, -	[builtin_while] = ao_lisp_while, -	[builtin_print] = ao_lisp_print, -	[builtin_patom] = ao_lisp_patom, -	[builtin_plus] = ao_lisp_plus, -	[builtin_minus] = ao_lisp_minus, -	[builtin_times] = ao_lisp_times, -	[builtin_divide] = ao_lisp_divide, -	[builtin_mod] = ao_lisp_mod, -	[builtin_equal] = ao_lisp_equal, -	[builtin_less] = ao_lisp_less, -	[builtin_greater] = ao_lisp_greater, -	[builtin_less_equal] = ao_lisp_less_equal, -	[builtin_greater_equal] = ao_lisp_greater_equal, -	[builtin_pack] = ao_lisp_pack, -	[builtin_unpack] = ao_lisp_unpack, -	[builtin_flush] = ao_lisp_flush, -	[builtin_led] = ao_lisp_led, -	[builtin_delay] = ao_lisp_delay, -	[builtin_save] = ao_lisp_save, -	[builtin_restore] = ao_lisp_restore, -	[builtin_call_cc] = ao_lisp_call_cc, -	[builtin_collect] = ao_lisp_do_collect, -}; - diff --git a/src/lisp/ao_lisp_cons.c b/src/lisp/ao_lisp_cons.c deleted file mode 100644 index d2b60c9a..00000000 --- a/src/lisp/ao_lisp_cons.c +++ /dev/null @@ -1,143 +0,0 @@ -/* - * Copyright © 2016 Keith Packard <keithp@keithp.com> - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation, either version 2 of the License, or - * (at your option) any later version. - * - * This program is distributed in the hope that it will be useful, but - * WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU - * General Public License for more details. - */ - -#include "ao_lisp.h" - -static void cons_mark(void *addr) -{ -	struct ao_lisp_cons	*cons = addr; - -	for (;;) { -		ao_lisp_poly_mark(cons->car, 1); -		cons = ao_lisp_poly_cons(cons->cdr); -		if (!cons) -			break; -		if (ao_lisp_mark_memory(&ao_lisp_cons_type, cons)) -			break; -	} -} - -static int cons_size(void *addr) -{ -	(void) addr; -	return sizeof (struct ao_lisp_cons); -} - -static void cons_move(void *addr) -{ -	struct ao_lisp_cons	*cons = addr; - -	if (!cons) -		return; - -	for (;;) { -		struct ao_lisp_cons	*cdr; -		int			ret; - -		MDBG_MOVE("cons_move start %d (%d, %d)\n", -			  MDBG_OFFSET(cons), MDBG_OFFSET(ao_lisp_ref(cons->car)), MDBG_OFFSET(ao_lisp_ref(cons->cdr))); -		(void) ao_lisp_poly_move(&cons->car, 1); -		cdr = ao_lisp_poly_cons(cons->cdr); -		if (!cdr) -			break; -		ret = ao_lisp_move_memory(&ao_lisp_cons_type, (void **) &cdr); -		if (cdr != ao_lisp_poly_cons(cons->cdr)) -			cons->cdr = ao_lisp_cons_poly(cdr); -		MDBG_MOVE("cons_move end %d (%d, %d)\n", -			  MDBG_OFFSET(cons), MDBG_OFFSET(ao_lisp_ref(cons->car)), MDBG_OFFSET(ao_lisp_ref(cons->cdr))); -		if (ret) -			break; -		cons = cdr; -	} -} - -const struct ao_lisp_type ao_lisp_cons_type = { -	.mark = cons_mark, -	.size = cons_size, -	.move = cons_move, -	.name = "cons", -}; - -struct ao_lisp_cons *ao_lisp_cons_free_list; - -struct ao_lisp_cons * -ao_lisp_cons_cons(ao_poly car, struct ao_lisp_cons *cdr) -{ -	struct ao_lisp_cons	*cons; - -	if (ao_lisp_cons_free_list) { -		cons = ao_lisp_cons_free_list; -		ao_lisp_cons_free_list = ao_lisp_poly_cons(cons->cdr); -	} else { -		ao_lisp_poly_stash(0, car); -		ao_lisp_cons_stash(0, cdr); -		cons = ao_lisp_alloc(sizeof (struct ao_lisp_cons)); -		car = ao_lisp_poly_fetch(0); -		cdr = ao_lisp_cons_fetch(0); -		if (!cons) -			return NULL; -	} -	cons->car = car; -	cons->cdr = ao_lisp_cons_poly(cdr); -	return cons; -} - -void -ao_lisp_cons_free(struct ao_lisp_cons *cons) -{ -	while (cons) { -		ao_poly cdr = cons->cdr; -		cons->cdr = ao_lisp_cons_poly(ao_lisp_cons_free_list); -		ao_lisp_cons_free_list = cons; -		cons = ao_lisp_poly_cons(cdr); -	} -} - -void -ao_lisp_cons_print(ao_poly c) -{ -	struct ao_lisp_cons *cons = ao_lisp_poly_cons(c); -	int	first = 1; -	printf("("); -	while (cons) { -		if (!first) -			printf(" "); -		ao_lisp_poly_print(cons->car); -		cons = ao_lisp_poly_cons(cons->cdr); -		first = 0; -	} -	printf(")"); -} - -void -ao_lisp_cons_patom(ao_poly c) -{ -	struct ao_lisp_cons *cons = ao_lisp_poly_cons(c); - -	while (cons) { -		ao_lisp_poly_patom(cons->car); -		cons = ao_lisp_poly_cons(cons->cdr); -	} -} - -int -ao_lisp_cons_length(struct ao_lisp_cons *cons) -{ -	int	len = 0; -	while (cons) { -		len++; -		cons = ao_lisp_poly_cons(cons->cdr); -	} -	return len; -} diff --git a/src/lisp/ao_lisp_const.lisp b/src/lisp/ao_lisp_const.lisp deleted file mode 100644 index 3c8fd21b..00000000 --- a/src/lisp/ao_lisp_const.lisp +++ /dev/null @@ -1,184 +0,0 @@ -; -; Copyright © 2016 Keith Packard <keithp@keithp.com> -; -; This program is free software; you can redistribute it and/or modify -; it under the terms of the GNU General Public License as published by -; the Free Software Foundation, either version 2 of the License, or -; (at your option) any later version. -; -; This program is distributed in the hope that it will be useful, but -; WITHOUT ANY WARRANTY; without even the implied warranty of -; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU -; General Public License for more details. -; -; Lisp code placed in ROM - -					; return a list containing all of the arguments - -(set (quote list) (lexpr (l) l)) - -					; -					; Define a variable without returning the value -					; Useful when defining functions to avoid -					; having lots of output generated -					; - -(setq def (macro (name val rest) -		 (list -		  'progn -		  (list -		   'set -		   (list 'quote name) -		   val) -		  (list 'quote name) -		  ) -		 ) -      ) - -					; -					; A slightly more convenient form -					; for defining lambdas. -					; -					; (defun <name> (<params>) s-exprs) -					; - -(def defun (macro (name args exprs) -		  (list -		   def -		   name -		   (cons 'lambda (cons args exprs)) -		   ) -		  ) -     ) - -					; basic list accessors - - -(defun cadr (l) (car (cdr l))) - -(defun caddr (l) (car (cdr (cdr l)))) - -(defun nth (list n) -  (cond ((= n 0) (car list)) -	((nth (cdr list) (1- n))) -	) -  ) - -					; simple math operators - -(defun 1+ (x) (+ x 1)) -(defun 1- (x) (- x 1)) - -					; define a set of local -					; variables and then evaluate -					; a list of sexprs -					; -					; (let (var-defines) sexprs) -					; -					; where var-defines are either -					; -					; (name value) -					; -					; or -					; -					; (name) -					; -					; e.g. -					; -					; (let ((x 1) (y)) (setq y (+ x 1)) y) - -(def let (macro (vars exprs) -		((lambda (make-names make-exprs make-nils) - -					; -					; make the list of names in the let -					; - -		   (setq make-names (lambda (vars) -				      (cond (vars -					     (cons (car (car vars)) -						   (make-names (cdr vars)))) -					    ) -				      ) -			 ) - -					; the set of expressions is -					; the list of set expressions -					; pre-pended to the -					; expressions to evaluate - -		   (setq make-exprs (lambda (vars exprs) -				      (cond (vars (cons -						   (list set -							 (list quote -							       (car (car vars)) -							       ) -							 (cadr (car vars)) -							 ) -						   (make-exprs (cdr vars) exprs) -						   ) -						  ) -					    (exprs) -					    ) -				      ) -			 ) - -					; the parameters to the lambda is a list -					; of nils of the right length - -		   (setq make-nils (lambda (vars) -				     (cond (vars (cons nil (make-nils (cdr vars)))) -					   ) -				     ) -			 ) -					; prepend the set operations -					; to the expressions - -		   (setq exprs (make-exprs vars exprs)) - -					; build the lambda. - -		   (cons (cons 'lambda (cons (make-names vars) exprs)) -			 (make-nils vars) -			 ) -		   ) -		 () -		 () -		 () -		 ) -		) -     ) - -					; boolean operators - -(def or (lexpr (l) -	       (let ((ret nil)) -		 (while l -		   (cond ((setq ret (car l)) -			  (setq l nil)) -			 ((setq l (cdr l))))) -		 ret -		 ) -	       ) -     ) - -					; execute to resolve macros - -(or nil t) - -(def and (lexpr (l) -	       (let ((ret t)) -		 (while l -		   (cond ((setq ret (car l)) -			  (setq l (cdr l))) -			 ((setq ret (setq l nil))) -			 ) -		   ) -		 ret -		 ) -	       ) -     ) - -					; execute to resolve macros - -(and t nil) diff --git a/src/lisp/ao_lisp_error.c b/src/lisp/ao_lisp_error.c deleted file mode 100644 index 54a9be10..00000000 --- a/src/lisp/ao_lisp_error.c +++ /dev/null @@ -1,102 +0,0 @@ -/* - * Copyright © 2016 Keith Packard <keithp@keithp.com> - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation, either version 2 of the License, or - * (at your option) any later version. - * - * This program is distributed in the hope that it will be useful, but - * WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU - * General Public License for more details. - */ - -#include "ao_lisp.h" -#include <stdarg.h> - -void -ao_lisp_error_poly(char *name, ao_poly poly, ao_poly last) -{ -	int first = 1; -	printf("\t\t%s(", name); -	if (ao_lisp_poly_type(poly) == AO_LISP_CONS) { -		if (poly) { -			while (poly) { -				struct ao_lisp_cons *cons = ao_lisp_poly_cons(poly); -				if (!first) -					printf("\t\t         "); -				else -					first = 0; -				ao_lisp_poly_print(cons->car); -				printf("\n"); -				if (poly == last) -					break; -				poly = cons->cdr; -			} -			printf("\t\t         )\n"); -		} else -			printf(")\n"); -	} else { -		ao_lisp_poly_print(poly); -		printf("\n"); -	} -} - -static void tabs(int indent) -{ -	while (indent--) -		printf("\t"); -} - -void -ao_lisp_error_frame(int indent, char *name, struct ao_lisp_frame *frame) -{ -	int			f; - -	tabs(indent); -	printf ("%s{", name); -	if (frame) { -		if (frame->type & AO_LISP_FRAME_PRINT) -			printf("recurse..."); -		else { -			frame->type |= AO_LISP_FRAME_PRINT; -			for (f = 0; f < frame->num; f++) { -				if (f != 0) { -					tabs(indent); -					printf("         "); -				} -				ao_lisp_poly_print(frame->vals[f].atom); -				printf(" = "); -				ao_lisp_poly_print(frame->vals[f].val); -				printf("\n"); -			} -			if (frame->prev) -				ao_lisp_error_frame(indent + 1, "prev:   ", ao_lisp_poly_frame(frame->prev)); -			frame->type &= ~AO_LISP_FRAME_PRINT; -		} -		tabs(indent); -		printf("        }\n"); -	} else -		printf ("}\n"); -} - - -ao_poly -ao_lisp_error(int error, char *format, ...) -{ -	va_list	args; - -	ao_lisp_exception |= error; -	va_start(args, format); -	vprintf(format, args); -	va_end(args); -	printf("\n"); -	printf("Value: "); ao_lisp_poly_print(ao_lisp_v); printf("\n"); -	printf("Stack:\n"); -	ao_lisp_stack_print(ao_lisp_stack_poly(ao_lisp_stack)); -	printf("Globals:\n\t"); -	ao_lisp_frame_print(ao_lisp_frame_poly(ao_lisp_frame_global)); -	printf("\n"); -	return AO_LISP_NIL; -} diff --git a/src/lisp/ao_lisp_eval.c b/src/lisp/ao_lisp_eval.c deleted file mode 100644 index 3be7c9c4..00000000 --- a/src/lisp/ao_lisp_eval.c +++ /dev/null @@ -1,531 +0,0 @@ -/* - * Copyright © 2016 Keith Packard <keithp@keithp.com> - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation, either version 2 of the License, or - * (at your option) any later version. - * - * This program is distributed in the hope that it will be useful, but - * WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU - * General Public License for more details. - */ - -#include "ao_lisp.h" -#include <assert.h> - -struct ao_lisp_stack		*ao_lisp_stack; -ao_poly				ao_lisp_v; - -ao_poly -ao_lisp_set_cond(struct ao_lisp_cons *c) -{ -	ao_lisp_stack->state = eval_cond; -	ao_lisp_stack->sexprs = ao_lisp_cons_poly(c); -	return AO_LISP_NIL; -} - -static int -func_type(ao_poly func) -{ -	if (func == AO_LISP_NIL) -		return ao_lisp_error(AO_LISP_INVALID, "func is nil"); -	switch (ao_lisp_poly_type(func)) { -	case AO_LISP_BUILTIN: -		return ao_lisp_poly_builtin(func)->args & AO_LISP_FUNC_MASK; -	case AO_LISP_LAMBDA: -		return ao_lisp_poly_lambda(func)->args; -	case AO_LISP_STACK: -		return AO_LISP_FUNC_LAMBDA; -	default: -		ao_lisp_error(AO_LISP_INVALID, "not a func"); -		return -1; -	} -} - -/* - * Flattened eval to avoid stack issues - */ - -/* - * Evaluate an s-expression - * - * For a list, evaluate all of the elements and - * then execute the resulting function call. - * - * Each element of the list is evaluated in - * a clean stack context. - * - * The current stack state is set to 'formal' so that - * when the evaluation is complete, the value - * will get appended to the values list. - * - * For other types, compute the value directly. - */ - -static int -ao_lisp_eval_sexpr(void) -{ -	DBGI("sexpr: "); DBG_POLY(ao_lisp_v); DBG("\n"); -	switch (ao_lisp_poly_type(ao_lisp_v)) { -	case AO_LISP_CONS: -		if (ao_lisp_v == AO_LISP_NIL) { -			if (!ao_lisp_stack->values) { -				/* -				 * empty list evaluates to empty list -				 */ -				ao_lisp_v = AO_LISP_NIL; -				ao_lisp_stack->state = eval_val; -			} else { -				/* -				 * done with arguments, go execute it -				 */ -				ao_lisp_v = ao_lisp_poly_cons(ao_lisp_stack->values)->car; -				ao_lisp_stack->state = eval_exec; -			} -		} else { -			if (!ao_lisp_stack->values) -				ao_lisp_stack->list = ao_lisp_v; -			/* -			 * Evaluate another argument and then switch -			 * to 'formal' to add the value to the values -			 * list -			 */ -			ao_lisp_stack->sexprs = ao_lisp_v; -			ao_lisp_stack->state = eval_formal; -			if (!ao_lisp_stack_push()) -				return 0; -			/* -			 * push will reset the state to 'sexpr', which -			 * will evaluate the expression -			 */ -			ao_lisp_v = ao_lisp_poly_cons(ao_lisp_v)->car; -		} -		break; -	case AO_LISP_ATOM: -		DBGI("..frame "); DBG_POLY(ao_lisp_frame_poly(ao_lisp_frame_current)); DBG("\n"); -		ao_lisp_v = ao_lisp_atom_get(ao_lisp_v); -		/* fall through */ -	case AO_LISP_INT: -	case AO_LISP_STRING: -	case AO_LISP_BUILTIN: -	case AO_LISP_LAMBDA: -		ao_lisp_stack->state = eval_val; -		break; -	} -	DBGI(".. result "); DBG_POLY(ao_lisp_v); DBG("\n"); -	return 1; -} - -/* - * A value has been computed. - * - * If the value was computed from a macro, - * then we want to reset the current context - * to evaluate the macro result again. - * - * If not a macro, then pop the stack. - * If the stack is empty, we're done. - * Otherwise, the stack will contain - * the next state. - */ - -static int -ao_lisp_eval_val(void) -{ -	DBGI("val: "); DBG_POLY(ao_lisp_v); DBG("\n"); -	/* -	 * Value computed, pop the stack -	 * to figure out what to do with the value -	 */ -	ao_lisp_stack_pop(); -	DBGI("..state %d\n", ao_lisp_stack ? ao_lisp_stack->state : -1); -	return 1; -} - -/* - * A formal has been computed. - * - * If this is the first formal, then check to see if we've got a - * lamda/lexpr or macro/nlambda. - * - * For lambda/lexpr, go compute another formal.  This will terminate - * when the sexpr state sees nil. - * - * For macro/nlambda, we're done, so move the sexprs into the values - * and go execute it. - * - * Macros have an additional step of saving a stack frame holding the - * macro value execution context, which then gets the result of the - * macro to run - */ - -static int -ao_lisp_eval_formal(void) -{ -	ao_poly			formal; -	struct ao_lisp_stack	*prev; - -	DBGI("formal: "); DBG_POLY(ao_lisp_v); DBG("\n"); - -	/* Check what kind of function we've got */ -	if (!ao_lisp_stack->values) { -		switch (func_type(ao_lisp_v)) { -		case AO_LISP_FUNC_LAMBDA: -		case AO_LISP_FUNC_LEXPR: -			DBGI(".. lambda or lexpr\n"); -			break; -		case AO_LISP_FUNC_MACRO: -			/* Evaluate the result once more */ -			ao_lisp_stack->state = eval_macro; -			if (!ao_lisp_stack_push()) -				return 0; - -			/* After the function returns, take that -			 * value and re-evaluate it -			 */ -			prev = ao_lisp_poly_stack(ao_lisp_stack->prev); -			ao_lisp_stack->sexprs = prev->sexprs; - -			DBGI(".. start macro\n"); -			DBGI(".. sexprs       "); DBG_POLY(ao_lisp_stack->sexprs); DBG("\n"); -			DBGI(".. values       "); DBG_POLY(ao_lisp_stack->values); DBG("\n"); -			DBG_FRAMES(); - -			/* fall through ... */ -		case AO_LISP_FUNC_NLAMBDA: -			DBGI(".. nlambda or macro\n"); - -			/* use the raw sexprs as values */ -			ao_lisp_stack->values = ao_lisp_stack->sexprs; -			ao_lisp_stack->values_tail = AO_LISP_NIL; -			ao_lisp_stack->state = eval_exec; - -			/* ready to execute now */ -			return 1; -		case -1: -			return 0; -		} -	} - -	/* Append formal to list of values */ -	formal = ao_lisp_cons_poly(ao_lisp_cons_cons(ao_lisp_v, NULL)); -	if (!formal) -		return 0; - -	if (ao_lisp_stack->values_tail) -		ao_lisp_poly_cons(ao_lisp_stack->values_tail)->cdr = formal; -	else -		ao_lisp_stack->values = formal; -	ao_lisp_stack->values_tail = formal; - -	DBGI(".. values "); DBG_POLY(ao_lisp_stack->values); DBG("\n"); - -	/* -	 * Step to the next argument, if this is last, then -	 * 'sexpr' will end up switching to 'exec' -	 */ -	ao_lisp_v = ao_lisp_poly_cons(ao_lisp_stack->sexprs)->cdr; - -	ao_lisp_stack->state = eval_sexpr; - -	DBGI(".. "); DBG_POLY(ao_lisp_v); DBG("\n"); -	return 1; -} - -/* - * Start executing a function call - * - * Most builtins are easy, just call the function. - * 'cond' is magic; it sticks the list of clauses - * in 'sexprs' and switches to 'cond' state. That - * bit of magic is done in ao_lisp_set_cond. - * - * Lambdas build a new frame to hold the locals and - * then re-use the current stack context to evaluate - * the s-expression from the lambda. - */ - -static int -ao_lisp_eval_exec(void) -{ -	ao_poly v; -	struct ao_lisp_builtin	*builtin; - -	DBGI("exec: "); DBG_POLY(ao_lisp_v); DBG(" values "); DBG_POLY(ao_lisp_stack->values); DBG ("\n"); -	ao_lisp_stack->sexprs = AO_LISP_NIL; -	switch (ao_lisp_poly_type(ao_lisp_v)) { -	case AO_LISP_BUILTIN: -		ao_lisp_stack->state = eval_val; -		builtin = ao_lisp_poly_builtin(ao_lisp_v); -		v = ao_lisp_func(builtin) ( -			ao_lisp_poly_cons(ao_lisp_poly_cons(ao_lisp_stack->values)->cdr)); -		DBG_DO(if (!ao_lisp_exception && ao_lisp_poly_builtin(ao_lisp_v)->func == builtin_set) { -				struct ao_lisp_cons *cons = ao_lisp_poly_cons(ao_lisp_stack->values); -				ao_poly atom = ao_lisp_arg(cons, 1); -				ao_poly val = ao_lisp_arg(cons, 2); -				DBGI("set "); DBG_POLY(atom); DBG(" = "); DBG_POLY(val); DBG("\n"); -			}); -		builtin = ao_lisp_poly_builtin(ao_lisp_v); -		if (builtin->args & AO_LISP_FUNC_FREE_ARGS && !ao_lisp_stack_marked(ao_lisp_stack)) -			ao_lisp_cons_free(ao_lisp_poly_cons(ao_lisp_stack->values)); - -		ao_lisp_v = v; -		ao_lisp_stack->values = AO_LISP_NIL; -		ao_lisp_stack->values_tail = AO_LISP_NIL; -		DBGI(".. result "); DBG_POLY(ao_lisp_v); DBG ("\n"); -		DBGI(".. frame "); DBG_POLY(ao_lisp_frame_poly(ao_lisp_frame_current)); DBG("\n"); -		break; -	case AO_LISP_LAMBDA: -		DBGI(".. frame "); DBG_POLY(ao_lisp_frame_poly(ao_lisp_frame_current)); DBG("\n"); -		ao_lisp_stack->state = eval_progn; -		v = ao_lisp_lambda_eval(); -		ao_lisp_stack->sexprs = v; -		ao_lisp_stack->values = AO_LISP_NIL; -		ao_lisp_stack->values_tail = AO_LISP_NIL; -		DBGI(".. sexprs "); DBG_POLY(ao_lisp_stack->sexprs); DBG("\n"); -		DBGI(".. frame "); DBG_POLY(ao_lisp_frame_poly(ao_lisp_frame_current)); DBG("\n"); -		break; -	case AO_LISP_STACK: -		DBGI(".. stack "); DBG_POLY(ao_lisp_v); DBG("\n"); -		ao_lisp_v = ao_lisp_stack_eval(); -		DBGI(".. value "); DBG_POLY(ao_lisp_v); DBG("\n"); -		DBGI(".. frame "); DBG_POLY(ao_lisp_frame_poly(ao_lisp_frame_current)); DBG("\n"); -		break; -	} -	return 1; -} - -/* - * Start evaluating the next cond clause - * - * If the list of clauses is empty, then - * the result of the cond is nil. - * - * Otherwise, set the current stack state to 'cond_test' and create a - * new stack context to evaluate the test s-expression. Once that's - * complete, we'll land in 'cond_test' to finish the clause. - */ -static int -ao_lisp_eval_cond(void) -{ -	DBGI("cond: "); DBG_POLY(ao_lisp_stack->sexprs); DBG("\n"); -	DBGI(".. frame "); DBG_POLY(ao_lisp_frame_poly(ao_lisp_frame_current)); DBG("\n"); -	DBGI(".. saved frame "); DBG_POLY(ao_lisp_stack->frame); DBG("\n"); -	if (!ao_lisp_stack->sexprs) { -		ao_lisp_v = AO_LISP_NIL; -		ao_lisp_stack->state = eval_val; -	} else { -		ao_lisp_v = ao_lisp_poly_cons(ao_lisp_stack->sexprs)->car; -		if (!ao_lisp_v || ao_lisp_poly_type(ao_lisp_v) != AO_LISP_CONS) { -			ao_lisp_error(AO_LISP_INVALID, "invalid cond clause"); -			return 0; -		} -		ao_lisp_v = ao_lisp_poly_cons(ao_lisp_v)->car; -		ao_lisp_stack->state = eval_cond_test; -		if (!ao_lisp_stack_push()) -			return 0; -	} -	return 1; -} - -/* - * Finish a cond clause. - * - * Check the value from the test expression, if - * non-nil, then set up to evaluate the value expression. - * - * Otherwise, step to the next clause and go back to the 'cond' - * state - */ -static int -ao_lisp_eval_cond_test(void) -{ -	DBGI("cond_test: "); DBG_POLY(ao_lisp_v); DBG(" sexprs "); DBG_POLY(ao_lisp_stack->sexprs); DBG("\n"); -	DBGI(".. frame "); DBG_POLY(ao_lisp_frame_poly(ao_lisp_frame_current)); DBG("\n"); -	DBGI(".. saved frame "); DBG_POLY(ao_lisp_stack->frame); DBG("\n"); -	if (ao_lisp_v) { -		struct ao_lisp_cons *car = ao_lisp_poly_cons(ao_lisp_poly_cons(ao_lisp_stack->sexprs)->car); -		ao_poly c = car->cdr; - -		if (c) { -			ao_lisp_stack->state = eval_progn; -			ao_lisp_stack->sexprs = c; -		} else -			ao_lisp_stack->state = eval_val; -	} else { -		ao_lisp_stack->sexprs = ao_lisp_poly_cons(ao_lisp_stack->sexprs)->cdr; -		DBGI("next cond: "); DBG_POLY(ao_lisp_stack->sexprs); DBG("\n"); -		ao_lisp_stack->state = eval_cond; -	} -	return 1; -} - -/* - * Evaluate a list of sexprs, returning the value from the last one. - * - * ao_lisp_progn records the list in stack->sexprs, so we just need to - * walk that list. Set ao_lisp_v to the car of the list and jump to - * eval_sexpr. When that's done, it will land in eval_val. For all but - * the last, leave a stack frame with eval_progn set so that we come - * back here. For the last, don't add a stack frame so that we can - * just continue on. - */ -static int -ao_lisp_eval_progn(void) -{ -	DBGI("progn: "); DBG_POLY(ao_lisp_v); DBG(" sexprs "); DBG_POLY(ao_lisp_stack->sexprs); DBG("\n"); -	DBGI(".. frame "); DBG_POLY(ao_lisp_frame_poly(ao_lisp_frame_current)); DBG("\n"); -	DBGI(".. saved frame "); DBG_POLY(ao_lisp_stack->frame); DBG("\n"); - -	if (!ao_lisp_stack->sexprs) { -		ao_lisp_v = AO_LISP_NIL; -		ao_lisp_stack->state = eval_val; -	} else { -		ao_lisp_v = ao_lisp_poly_cons(ao_lisp_stack->sexprs)->car; -		ao_lisp_stack->sexprs = ao_lisp_poly_cons(ao_lisp_stack->sexprs)->cdr; - -		/* If there are more sexprs to do, then come back here, otherwise -		 * return the value of the last one by just landing in eval_sexpr -		 */ -		if (ao_lisp_stack->sexprs) { -			ao_lisp_stack->state = eval_progn; -			if (!ao_lisp_stack_push()) -				return 0; -		} -		ao_lisp_stack->state = eval_sexpr; -	} -	return 1; -} - -/* - * Conditionally execute a list of sexprs while the first is true - */ -static int -ao_lisp_eval_while(void) -{ -	DBGI("while: "); DBG_POLY(ao_lisp_stack->sexprs); DBG("\n"); -	DBGI(".. frame "); DBG_POLY(ao_lisp_frame_poly(ao_lisp_frame_current)); DBG("\n"); -	DBGI(".. saved frame "); DBG_POLY(ao_lisp_stack->frame); DBG("\n"); - -	ao_lisp_stack->values = ao_lisp_v; -	if (!ao_lisp_stack->sexprs) { -		ao_lisp_v = AO_LISP_NIL; -		ao_lisp_stack->state = eval_val; -	} else { -		ao_lisp_v = ao_lisp_poly_cons(ao_lisp_stack->sexprs)->car; -		ao_lisp_stack->state = eval_while_test; -		if (!ao_lisp_stack_push()) -			return 0; -	} -	return 1; -} - -/* - * Check the while condition, terminate the loop if nil. Otherwise keep going - */ -static int -ao_lisp_eval_while_test(void) -{ -	DBGI("while_test: "); DBG_POLY(ao_lisp_v); DBG(" sexprs "); DBG_POLY(ao_lisp_stack->sexprs); DBG("\n"); -	DBGI(".. frame "); DBG_POLY(ao_lisp_frame_poly(ao_lisp_frame_current)); DBG("\n"); -	DBGI(".. saved frame "); DBG_POLY(ao_lisp_stack->frame); DBG("\n"); - -	if (ao_lisp_v) { -		ao_lisp_stack->values = ao_lisp_v; -		ao_lisp_v = ao_lisp_poly_cons(ao_lisp_stack->sexprs)->cdr; -		ao_lisp_stack->state = eval_while; -		if (!ao_lisp_stack_push()) -			return 0; -		ao_lisp_stack->state = eval_progn; -		ao_lisp_stack->sexprs = ao_lisp_v; -	} -	else -	{ -		ao_lisp_stack->state = eval_val; -		ao_lisp_v = ao_lisp_stack->values; -	} -	return 1; -} - -/* - * Replace the original sexpr with the macro expansion, then - * execute that - */ -static int -ao_lisp_eval_macro(void) -{ -	DBGI("macro: "); DBG_POLY(ao_lisp_v); DBG(" sexprs "); DBG_POLY(ao_lisp_stack->sexprs); DBG("\n"); - -	if (ao_lisp_v == AO_LISP_NIL) -		ao_lisp_abort(); -	if (ao_lisp_poly_type(ao_lisp_v) == AO_LISP_CONS) { -		*ao_lisp_poly_cons(ao_lisp_stack->sexprs) = *ao_lisp_poly_cons(ao_lisp_v); -		ao_lisp_v = ao_lisp_stack->sexprs; -		DBGI("sexprs rewritten to: "); DBG_POLY(ao_lisp_v); DBG("\n"); -	} -	ao_lisp_stack->sexprs = AO_LISP_NIL; -	ao_lisp_stack->state = eval_sexpr; -	return 1; -} - -static int (*const evals[])(void) = { -	[eval_sexpr] = ao_lisp_eval_sexpr, -	[eval_val] = ao_lisp_eval_val, -	[eval_formal] = ao_lisp_eval_formal, -	[eval_exec] = ao_lisp_eval_exec, -	[eval_cond] = ao_lisp_eval_cond, -	[eval_cond_test] = ao_lisp_eval_cond_test, -	[eval_progn] = ao_lisp_eval_progn, -	[eval_while] = ao_lisp_eval_while, -	[eval_while_test] = ao_lisp_eval_while_test, -	[eval_macro] = ao_lisp_eval_macro, -}; - -const char *ao_lisp_state_names[] = { -	"sexpr", -	"val", -	"formal", -	"exec", -	"cond", -	"cond_test", -	"progn", -}; - -/* - * Called at restore time to reset all execution state - */ - -void -ao_lisp_eval_clear_globals(void) -{ -	ao_lisp_stack = NULL; -	ao_lisp_frame_current = NULL; -	ao_lisp_v = AO_LISP_NIL; -} - -int -ao_lisp_eval_restart(void) -{ -	return ao_lisp_stack_push(); -} - -ao_poly -ao_lisp_eval(ao_poly _v) -{ -	ao_lisp_v = _v; - -	if (!ao_lisp_stack_push()) -		return AO_LISP_NIL; - -	while (ao_lisp_stack) { -		if (!(*evals[ao_lisp_stack->state])() || ao_lisp_exception) { -			ao_lisp_stack_clear(); -			return AO_LISP_NIL; -		} -	} -	DBG_DO(if (ao_lisp_frame_current) {DBGI("frame left as "); DBG_POLY(ao_lisp_frame_poly(ao_lisp_frame_current)); DBG("\n");}); -	ao_lisp_frame_current = NULL; -	return ao_lisp_v; -} diff --git a/src/lisp/ao_lisp_frame.c b/src/lisp/ao_lisp_frame.c deleted file mode 100644 index 05f6d253..00000000 --- a/src/lisp/ao_lisp_frame.c +++ /dev/null @@ -1,293 +0,0 @@ -/* - * Copyright © 2016 Keith Packard <keithp@keithp.com> - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation, either version 2 of the License, or - * (at your option) any later version. - * - * This program is distributed in the hope that it will be useful, but - * WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU - * General Public License for more details. - */ - -#include "ao_lisp.h" - -static inline int -frame_num_size(int num) -{ -	return sizeof (struct ao_lisp_frame) + num * sizeof (struct ao_lisp_val); -} - -static int -frame_size(void *addr) -{ -	struct ao_lisp_frame	*frame = addr; -	return frame_num_size(frame->num); -} - -static void -frame_mark(void *addr) -{ -	struct ao_lisp_frame	*frame = addr; -	int			f; - -	for (;;) { -		MDBG_MOVE("frame mark %d\n", MDBG_OFFSET(frame)); -		if (!AO_LISP_IS_POOL(frame)) -			break; -		for (f = 0; f < frame->num; f++) { -			struct ao_lisp_val	*v = &frame->vals[f]; - -			ao_lisp_poly_mark(v->val, 0); -			MDBG_MOVE("frame mark atom %s %d val %d at %d\n", -				  ao_lisp_poly_atom(v->atom)->name, -				  MDBG_OFFSET(ao_lisp_ref(v->atom)), -				  MDBG_OFFSET(ao_lisp_ref(v->val)), f); -		} -		frame = ao_lisp_poly_frame(frame->prev); -		MDBG_MOVE("frame next %d\n", MDBG_OFFSET(frame)); -		if (!frame) -			break; -		if (ao_lisp_mark_memory(&ao_lisp_frame_type, frame)) -			break; -	} -} - -static void -frame_move(void *addr) -{ -	struct ao_lisp_frame	*frame = addr; -	int			f; - -	for (;;) { -		struct ao_lisp_frame	*prev; -		int			ret; - -		MDBG_MOVE("frame move %d\n", MDBG_OFFSET(frame)); -		if (!AO_LISP_IS_POOL(frame)) -			break; -		for (f = 0; f < frame->num; f++) { -			struct ao_lisp_val	*v = &frame->vals[f]; - -			ao_lisp_poly_move(&v->atom, 0); -			ao_lisp_poly_move(&v->val, 0); -			MDBG_MOVE("frame move atom %s %d val %d at %d\n", -				  ao_lisp_poly_atom(v->atom)->name, -				  MDBG_OFFSET(ao_lisp_ref(v->atom)), -				  MDBG_OFFSET(ao_lisp_ref(v->val)), f); -		} -		prev = ao_lisp_poly_frame(frame->prev); -		if (!prev) -			break; -		ret = ao_lisp_move_memory(&ao_lisp_frame_type, (void **) &prev); -		if (prev != ao_lisp_poly_frame(frame->prev)) { -			MDBG_MOVE("frame prev moved from %d to %d\n", -				  MDBG_OFFSET(ao_lisp_poly_frame(frame->prev)), -				  MDBG_OFFSET(prev)); -			frame->prev = ao_lisp_frame_poly(prev); -		} -		if (ret) -			break; -		frame = prev; -	} -} - -const struct ao_lisp_type ao_lisp_frame_type = { -	.mark = frame_mark, -	.size = frame_size, -	.move = frame_move, -	.name = "frame", -}; - -void -ao_lisp_frame_print(ao_poly p) -{ -	struct ao_lisp_frame	*frame = ao_lisp_poly_frame(p); -	int			f; - -	printf ("{"); -	if (frame) { -		if (frame->type & AO_LISP_FRAME_PRINT) -			printf("recurse..."); -		else { -			frame->type |= AO_LISP_FRAME_PRINT; -			for (f = 0; f < frame->num; f++) { -				if (f != 0) -					printf(", "); -				ao_lisp_poly_print(frame->vals[f].atom); -				printf(" = "); -				ao_lisp_poly_print(frame->vals[f].val); -			} -			if (frame->prev) -				ao_lisp_poly_print(frame->prev); -			frame->type &= ~AO_LISP_FRAME_PRINT; -		} -	} -	printf("}"); -} - -static int -ao_lisp_frame_find(struct ao_lisp_frame *frame, int top, ao_poly atom) -{ -	int l = 0; -	int r = top - 1; -	while (l <= r) { -		int m = (l + r) >> 1; -		if (frame->vals[m].atom < atom) -			l = m + 1; -		else -			r = m - 1; -	} -	return l; -} - -ao_poly * -ao_lisp_frame_ref(struct ao_lisp_frame *frame, ao_poly atom) -{ -	int l = ao_lisp_frame_find(frame, frame->num, atom); - -	if (l >= frame->num) -		return NULL; - -	if (frame->vals[l].atom != atom) -		return NULL; -	return &frame->vals[l].val; -} - -int -ao_lisp_frame_set(struct ao_lisp_frame *frame, ao_poly atom, ao_poly val) -{ -	while (frame) { -		if (!AO_LISP_IS_CONST(frame)) { -			ao_poly *ref = ao_lisp_frame_ref(frame, atom); -			if (ref) { -				*ref = val; -				return 1; -			} -		} -		frame = ao_lisp_poly_frame(frame->prev); -	} -	return 0; -} - -ao_poly -ao_lisp_frame_get(struct ao_lisp_frame *frame, ao_poly atom) -{ -	while (frame) { -		ao_poly *ref = ao_lisp_frame_ref(frame, atom); -		if (ref) -			return *ref; -		frame = ao_lisp_poly_frame(frame->prev); -	} -	return AO_LISP_NIL; -} - -struct ao_lisp_frame	*ao_lisp_frame_free_list[AO_LISP_FRAME_FREE]; - -struct ao_lisp_frame * -ao_lisp_frame_new(int num) -{ -	struct ao_lisp_frame	*frame; - -	if (num < AO_LISP_FRAME_FREE && (frame = ao_lisp_frame_free_list[num])) -		ao_lisp_frame_free_list[num] = ao_lisp_poly_frame(frame->prev); -	else { -		frame = ao_lisp_alloc(frame_num_size(num)); -		if (!frame) -			return NULL; -	} -	frame->type = AO_LISP_FRAME; -	frame->num = num; -	frame->prev = AO_LISP_NIL; -	memset(frame->vals, '\0', num * sizeof (struct ao_lisp_val)); -	return frame; -} - -ao_poly -ao_lisp_frame_mark(struct ao_lisp_frame *frame) -{ -	if (!frame) -		return AO_LISP_NIL; -	frame->type |= AO_LISP_FRAME_MARK; -	return ao_lisp_frame_poly(frame); -} - -void -ao_lisp_frame_free(struct ao_lisp_frame *frame) -{ -	if (!ao_lisp_frame_marked(frame)) { -		int	num = frame->num; -		if (num < AO_LISP_FRAME_FREE) { -			frame->prev = ao_lisp_frame_poly(ao_lisp_frame_free_list[num]); -			ao_lisp_frame_free_list[num] = frame; -		} -	} -} - -static struct ao_lisp_frame * -ao_lisp_frame_realloc(struct ao_lisp_frame **frame_ref, int new_num) -{ -	struct ao_lisp_frame	*frame = *frame_ref; -	struct ao_lisp_frame	*new; -	int			copy; - -	if (new_num == frame->num) -		return frame; -	new = ao_lisp_frame_new(new_num); -	if (!new) -		return NULL; -	/* -	 * Re-fetch the frame as it may have moved -	 * during the allocation -	 */ -	frame = *frame_ref; -	copy = new_num; -	if (copy > frame->num) -		copy = frame->num; -	memcpy(new->vals, frame->vals, copy * sizeof (struct ao_lisp_val)); -	new->prev = frame->prev; -	ao_lisp_frame_free(frame); -	return new; -} - -void -ao_lisp_frame_bind(struct ao_lisp_frame *frame, int num, ao_poly atom, ao_poly val) -{ -	int l = ao_lisp_frame_find(frame, num, atom); - -	memmove(&frame->vals[l+1], -		&frame->vals[l], -		(num - l) * sizeof (struct ao_lisp_val)); -	frame->vals[l].atom = atom; -	frame->vals[l].val = val; -} - -int -ao_lisp_frame_add(struct ao_lisp_frame **frame_ref, ao_poly atom, ao_poly val) -{ -	struct ao_lisp_frame *frame = *frame_ref; -	ao_poly *ref = frame ? ao_lisp_frame_ref(frame, atom) : NULL; - -	if (!ref) { -		int f; -		ao_lisp_poly_stash(0, atom); -		ao_lisp_poly_stash(1, val); -		if (frame) { -			f = frame->num; -			frame = ao_lisp_frame_realloc(frame_ref, f + 1); -		} else { -			f = 0; -			frame = ao_lisp_frame_new(1); -		} -		if (!frame) -			return 0; -		*frame_ref = frame; -		atom = ao_lisp_poly_fetch(0); -		val = ao_lisp_poly_fetch(1); -		ao_lisp_frame_bind(frame, frame->num - 1, atom, val); -	} else -		*ref = val; -	return 1; -} diff --git a/src/lisp/ao_lisp_int.c b/src/lisp/ao_lisp_int.c deleted file mode 100644 index 77f65e95..00000000 --- a/src/lisp/ao_lisp_int.c +++ /dev/null @@ -1,22 +0,0 @@ -/* - * Copyright © 2016 Keith Packard <keithp@keithp.com> - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation, either version 2 of the License, or - * (at your option) any later version. - * - * This program is distributed in the hope that it will be useful, but - * WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU - * General Public License for more details. - */ - -#include "ao_lisp.h" - -void -ao_lisp_int_print(ao_poly p) -{ -	int i = ao_lisp_poly_int(p); -	printf("%d", i); -} diff --git a/src/lisp/ao_lisp_lambda.c b/src/lisp/ao_lisp_lambda.c deleted file mode 100644 index 526863c5..00000000 --- a/src/lisp/ao_lisp_lambda.c +++ /dev/null @@ -1,196 +0,0 @@ -/* - * Copyright © 2016 Keith Packard <keithp@keithp.com> - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation; version 2 of the License. - * - * This program is distributed in the hope that it will be useful, but - * WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU - * General Public License for more details. - * - * You should have received a copy of the GNU General Public License along - * with this program; if not, write to the Free Software Foundation, Inc., - * 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA. - */ - -#include "ao_lisp.h" - -int -lambda_size(void *addr) -{ -	(void) addr; -	return sizeof (struct ao_lisp_lambda); -} - -void -lambda_mark(void *addr) -{ -	struct ao_lisp_lambda	*lambda = addr; - -	ao_lisp_poly_mark(lambda->code, 0); -	ao_lisp_poly_mark(lambda->frame, 0); -} - -void -lambda_move(void *addr) -{ -	struct ao_lisp_lambda	*lambda = addr; - -	ao_lisp_poly_move(&lambda->code, 0); -	ao_lisp_poly_move(&lambda->frame, 0); -} - -const struct ao_lisp_type ao_lisp_lambda_type = { -	.size = lambda_size, -	.mark = lambda_mark, -	.move = lambda_move, -	.name = "lambda", -}; - -void -ao_lisp_lambda_print(ao_poly poly) -{ -	struct ao_lisp_lambda	*lambda = ao_lisp_poly_lambda(poly); -	struct ao_lisp_cons	*cons = ao_lisp_poly_cons(lambda->code); - -	printf("("); -	printf("%s", ao_lisp_args_name(lambda->args)); -	while (cons) { -		printf(" "); -		ao_lisp_poly_print(cons->car); -		cons = ao_lisp_poly_cons(cons->cdr); -	} -	printf(")"); -} - -ao_poly -ao_lisp_lambda_alloc(struct ao_lisp_cons *code, int args) -{ -	ao_lisp_cons_stash(0, code); -	struct ao_lisp_lambda	*lambda = ao_lisp_alloc(sizeof (struct ao_lisp_lambda)); -	code = ao_lisp_cons_fetch(0); -	struct ao_lisp_cons	*arg; -	int			f; - -	if (!lambda) -		return AO_LISP_NIL; - -	if (!ao_lisp_check_argt(_ao_lisp_atom_lambda, code, 0, AO_LISP_CONS, 1)) -		return AO_LISP_NIL; -	f = 0; -	arg = ao_lisp_poly_cons(ao_lisp_arg(code, 0)); -	while (arg) { -		if (ao_lisp_poly_type(arg->car) != AO_LISP_ATOM) -			return ao_lisp_error(AO_LISP_INVALID, "formal %d is not an atom", f); -		arg = ao_lisp_poly_cons(arg->cdr); -		f++; -	} - -	lambda->type = AO_LISP_LAMBDA; -	lambda->args = args; -	lambda->code = ao_lisp_cons_poly(code); -	lambda->frame = ao_lisp_frame_mark(ao_lisp_frame_current); -	DBGI("build frame: "); DBG_POLY(lambda->frame); DBG("\n"); -	DBG_STACK(); -	return ao_lisp_lambda_poly(lambda); -} - -ao_poly -ao_lisp_lambda(struct ao_lisp_cons *cons) -{ -	return ao_lisp_lambda_alloc(cons, AO_LISP_FUNC_LAMBDA); -} - -ao_poly -ao_lisp_lexpr(struct ao_lisp_cons *cons) -{ -	return ao_lisp_lambda_alloc(cons, AO_LISP_FUNC_LEXPR); -} - -ao_poly -ao_lisp_nlambda(struct ao_lisp_cons *cons) -{ -	return ao_lisp_lambda_alloc(cons, AO_LISP_FUNC_NLAMBDA); -} - -ao_poly -ao_lisp_macro(struct ao_lisp_cons *cons) -{ -	return ao_lisp_lambda_alloc(cons, AO_LISP_FUNC_MACRO); -} - -ao_poly -ao_lisp_lambda_eval(void) -{ -	struct ao_lisp_lambda	*lambda = ao_lisp_poly_lambda(ao_lisp_v); -	struct ao_lisp_cons	*cons = ao_lisp_poly_cons(ao_lisp_stack->values); -	struct ao_lisp_cons	*code = ao_lisp_poly_cons(lambda->code); -	struct ao_lisp_cons	*args = ao_lisp_poly_cons(ao_lisp_arg(code, 0)); -	struct ao_lisp_frame	*next_frame; -	int			args_wanted; -	int			args_provided; -	int			f; -	struct ao_lisp_cons	*vals; - -	DBGI("lambda "); DBG_POLY(ao_lisp_lambda_poly(lambda)); DBG("\n"); - -	args_wanted = ao_lisp_cons_length(args); - -	/* Create a frame to hold the variables -	 */ -	args_provided = ao_lisp_cons_length(cons) - 1; -	if (lambda->args == AO_LISP_FUNC_LAMBDA) { -		if (args_wanted != args_provided) -			return ao_lisp_error(AO_LISP_INVALID, "need %d args, got %d", args_wanted, args_provided); -	} else { -		if (args_provided < args_wanted - 1) -			return ao_lisp_error(AO_LISP_INVALID, "need at least %d args, got %d", args_wanted, args_provided); -	} - -	next_frame = ao_lisp_frame_new(args_wanted); - -	/* Re-fetch all of the values in case something moved */ -	lambda = ao_lisp_poly_lambda(ao_lisp_v); -	cons = ao_lisp_poly_cons(ao_lisp_stack->values); -	code = ao_lisp_poly_cons(lambda->code); -	args = ao_lisp_poly_cons(ao_lisp_arg(code, 0)); -	vals = ao_lisp_poly_cons(cons->cdr); - -	next_frame->prev = lambda->frame; -	ao_lisp_frame_current = next_frame; -	ao_lisp_stack->frame = ao_lisp_frame_poly(ao_lisp_frame_current); - -	switch (lambda->args) { -	case AO_LISP_FUNC_LAMBDA: -		for (f = 0; f < args_wanted; f++) { -			DBGI("bind "); DBG_POLY(args->car); DBG(" = "); DBG_POLY(vals->car); DBG("\n"); -			ao_lisp_frame_bind(next_frame, f, args->car, vals->car); -			args = ao_lisp_poly_cons(args->cdr); -			vals = ao_lisp_poly_cons(vals->cdr); -		} -		if (!ao_lisp_stack_marked(ao_lisp_stack)) -			ao_lisp_cons_free(cons); -		cons = NULL; -		break; -	case AO_LISP_FUNC_LEXPR: -	case AO_LISP_FUNC_NLAMBDA: -	case AO_LISP_FUNC_MACRO: -		for (f = 0; f < args_wanted - 1; f++) { -			DBGI("bind "); DBG_POLY(args->car); DBG(" = "); DBG_POLY(vals->car); DBG("\n"); -			ao_lisp_frame_bind(next_frame, f, args->car, vals->car); -			args = ao_lisp_poly_cons(args->cdr); -			vals = ao_lisp_poly_cons(vals->cdr); -		} -		DBGI("bind "); DBG_POLY(args->car); DBG(" = "); DBG_POLY(ao_lisp_cons_poly(vals)); DBG("\n"); -		ao_lisp_frame_bind(next_frame, f, args->car, ao_lisp_cons_poly(vals)); -		break; -	default: -		break; -	} -	DBGI("eval frame: "); DBG_POLY(ao_lisp_frame_poly(next_frame)); DBG("\n"); -	DBG_STACK(); -	DBGI("eval code: "); DBG_POLY(code->cdr); DBG("\n"); -	return code->cdr; -} diff --git a/src/lisp/ao_lisp_make_const.c b/src/lisp/ao_lisp_make_const.c deleted file mode 100644 index 49f989e6..00000000 --- a/src/lisp/ao_lisp_make_const.c +++ /dev/null @@ -1,423 +0,0 @@ -/* - * Copyright © 2016 Keith Packard <keithp@keithp.com> - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation, either version 2 of the License, or - * (at your option) any later version. - * - * This program is distributed in the hope that it will be useful, but - * WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU - * General Public License for more details. - */ - -#include "ao_lisp.h" -#include <stdlib.h> -#include <ctype.h> -#include <unistd.h> -#include <getopt.h> - -static struct ao_lisp_builtin * -ao_lisp_make_builtin(enum ao_lisp_builtin_id func, int args) { -	struct ao_lisp_builtin *b = ao_lisp_alloc(sizeof (struct ao_lisp_builtin)); - -	b->type = AO_LISP_BUILTIN; -	b->func = func; -	b->args = args; -	return b; -} - -struct builtin_func { -	char	*name; -	int	args; -	int	func; -}; - -struct builtin_func funcs[] = { -	{ .name = "eval",	.args = AO_LISP_FUNC_F_LAMBDA,	.func = builtin_eval }, -	{ .name = "read",	.args = AO_LISP_FUNC_F_LAMBDA,	.func = builtin_read }, -	{ .name = "lambda",	.args = AO_LISP_FUNC_NLAMBDA,	.func = builtin_lambda }, -	{ .name = "lexpr",	.args = AO_LISP_FUNC_NLAMBDA,	.func = builtin_lexpr }, -	{ .name = "nlambda",	.args = AO_LISP_FUNC_NLAMBDA,	.func = builtin_nlambda }, -	{ .name = "macro",	.args = AO_LISP_FUNC_NLAMBDA,	.func = builtin_macro }, -	{ .name = "car",	.args = AO_LISP_FUNC_F_LAMBDA,	.func = builtin_car }, -	{ .name = "cdr",	.args = AO_LISP_FUNC_F_LAMBDA,	.func = builtin_cdr }, -	{ .name = "cons",	.args = AO_LISP_FUNC_F_LAMBDA,	.func = builtin_cons }, -	{ .name = "last",	.args = AO_LISP_FUNC_F_LAMBDA,	.func = builtin_last }, -	{ .name = "length",	.args = AO_LISP_FUNC_F_LAMBDA,	.func = builtin_length }, -	{ .name = "quote",	.args = AO_LISP_FUNC_NLAMBDA,	.func = builtin_quote }, -	{ .name = "set",	.args = AO_LISP_FUNC_F_LAMBDA,	.func = builtin_set }, -	{ .name = "setq",	.args = AO_LISP_FUNC_MACRO,	.func = builtin_setq }, -	{ .name = "cond",	.args = AO_LISP_FUNC_NLAMBDA,	.func = builtin_cond }, -	{ .name = "progn",	.args = AO_LISP_FUNC_NLAMBDA,	.func = builtin_progn }, -	{ .name = "while",	.args = AO_LISP_FUNC_NLAMBDA,	.func = builtin_while }, -	{ .name = "print",	.args = AO_LISP_FUNC_F_LEXPR,	.func = builtin_print }, -	{ .name = "patom",	.args = AO_LISP_FUNC_F_LEXPR,	.func = builtin_patom }, -	{ .name = "+",		.args = AO_LISP_FUNC_F_LEXPR,	.func = builtin_plus }, -	{ .name = "-",		.args = AO_LISP_FUNC_F_LEXPR,	.func = builtin_minus }, -	{ .name = "*",		.args = AO_LISP_FUNC_F_LEXPR,	.func = builtin_times }, -	{ .name = "/",		.args = AO_LISP_FUNC_F_LEXPR,	.func = builtin_divide }, -	{ .name = "%",		.args = AO_LISP_FUNC_F_LEXPR,	.func = builtin_mod }, -	{ .name = "=",		.args = AO_LISP_FUNC_F_LEXPR,	.func = builtin_equal }, -	{ .name = "<",		.args = AO_LISP_FUNC_F_LEXPR,	.func = builtin_less }, -	{ .name = ">",		.args = AO_LISP_FUNC_F_LEXPR,	.func = builtin_greater }, -	{ .name = "<=",		.args = AO_LISP_FUNC_F_LEXPR,	.func = builtin_less_equal }, -	{ .name = ">=",		.args = AO_LISP_FUNC_F_LEXPR,	.func = builtin_greater_equal }, -	{ .name = "pack",	.args = AO_LISP_FUNC_F_LAMBDA,	.func = builtin_pack }, -	{ .name = "unpack",	.args = AO_LISP_FUNC_F_LAMBDA,	.func = builtin_unpack }, -	{ .name = "flush",	.args = AO_LISP_FUNC_F_LAMBDA,	.func = builtin_flush }, -	{ .name = "delay",	.args = AO_LISP_FUNC_F_LAMBDA,	.func = builtin_delay }, -	{ .name = "led",	.args = AO_LISP_FUNC_F_LEXPR,	.func = builtin_led }, -	{ .name = "save",	.args = AO_LISP_FUNC_F_LAMBDA,	.func = builtin_save }, -	{ .name = "restore",	.args = AO_LISP_FUNC_F_LAMBDA,	.func = builtin_restore }, -	{ .name = "call/cc",	.args = AO_LISP_FUNC_F_LAMBDA,	.func = builtin_call_cc }, -	{ .name = "collect",	.args = AO_LISP_FUNC_F_LAMBDA,	.func = builtin_collect }, -}; - -#define N_FUNC (sizeof funcs / sizeof funcs[0]) - -struct ao_lisp_frame	*globals; - -static int -is_atom(int offset) -{ -	struct ao_lisp_atom *a; - -	for (a = ao_lisp_atoms; a; a = ao_lisp_poly_atom(a->next)) -		if (((uint8_t *) a->name - ao_lisp_const) == offset) -			return strlen(a->name); -	return 0; -} - -#define AO_FEC_CRC_INIT	0xffff - -static inline uint16_t -ao_fec_crc_byte(uint8_t byte, uint16_t crc) -{ -	uint8_t	bit; - -	for (bit = 0; bit < 8; bit++) { -		if (((crc & 0x8000) >> 8) ^ (byte & 0x80)) -			crc = (crc << 1) ^ 0x8005; -		else -			crc = (crc << 1); -		byte <<= 1; -	} -	return crc; -} - -uint16_t -ao_fec_crc(const uint8_t *bytes, uint8_t len) -{ -	uint16_t	crc = AO_FEC_CRC_INIT; - -	while (len--) -		crc = ao_fec_crc_byte(*bytes++, crc); -	return crc; -} - -struct ao_lisp_macro_stack { -	struct ao_lisp_macro_stack *next; -	ao_poly	p; -}; - -struct ao_lisp_macro_stack *macro_stack; - -int -ao_lisp_macro_push(ao_poly p) -{ -	struct ao_lisp_macro_stack *m = macro_stack; - -	while (m) { -		if (m->p == p) -			return 1; -		m = m->next; -	} -	m = malloc (sizeof (struct ao_lisp_macro_stack)); -	m->p = p; -	m->next = macro_stack; -	macro_stack = m; -	return 0; -} - -void -ao_lisp_macro_pop(void) -{ -	struct ao_lisp_macro_stack *m = macro_stack; - -	macro_stack = m->next; -	free(m); -} - -#define DBG_MACRO 0 -#if DBG_MACRO -int macro_scan_depth; - -void indent(void) -{ -	int i; -	for (i = 0; i < macro_scan_depth; i++) -		printf("  "); -} -#define MACRO_DEBUG(a)	a -#else -#define MACRO_DEBUG(a) -#endif - -ao_poly -ao_has_macro(ao_poly p); - -ao_poly -ao_macro_test_get(ao_poly atom) -{ -	ao_poly	*ref = ao_lisp_atom_ref(ao_lisp_frame_global, atom); -	if (ref) -		return *ref; -	return AO_LISP_NIL; -} - -ao_poly -ao_is_macro(ao_poly p) -{ -	struct ao_lisp_builtin	*builtin; -	struct ao_lisp_lambda	*lambda; -	ao_poly ret; - -	MACRO_DEBUG(indent(); printf ("is macro "); ao_lisp_poly_print(p); printf("\n"); ++macro_scan_depth); -	switch (ao_lisp_poly_type(p)) { -	case AO_LISP_ATOM: -		if (ao_lisp_macro_push(p)) -			ret = AO_LISP_NIL; -		else { -			if (ao_is_macro(ao_macro_test_get(p))) -				ret = p; -			else -				ret = AO_LISP_NIL; -			ao_lisp_macro_pop(); -		} -		break; -	case AO_LISP_CONS: -		ret = ao_has_macro(p); -		break; -	case AO_LISP_BUILTIN: -		builtin = ao_lisp_poly_builtin(p); -		if ((builtin->args & AO_LISP_FUNC_MASK) == AO_LISP_FUNC_MACRO) -			ret = p; -		else -			ret = 0; -		break; - -	case AO_LISP_LAMBDA: -		lambda = ao_lisp_poly_lambda(p); -		if (lambda->args == AO_LISP_FUNC_MACRO) -			ret = p; -		else -			ret = ao_has_macro(lambda->code); -		break; -	default: -		ret = AO_LISP_NIL; -		break; -	} -	MACRO_DEBUG(--macro_scan_depth;	indent(); printf ("... "); ao_lisp_poly_print(ret); printf("\n")); -	return ret; -} - -ao_poly -ao_has_macro(ao_poly p) -{ -	struct ao_lisp_cons	*cons; -	struct ao_lisp_lambda	*lambda; -	ao_poly			m; - -	if (p == AO_LISP_NIL) -		return AO_LISP_NIL; - -	MACRO_DEBUG(indent(); printf("has macro "); ao_lisp_poly_print(p); printf("\n"); ++macro_scan_depth); -	switch (ao_lisp_poly_type(p)) { -	case AO_LISP_LAMBDA: -		lambda = ao_lisp_poly_lambda(p); -		p = ao_has_macro(lambda->code); -		break; -	case AO_LISP_CONS: -		cons = ao_lisp_poly_cons(p); -		if ((p = ao_is_macro(cons->car))) -			break; - -		cons = ao_lisp_poly_cons(cons->cdr); -		p = AO_LISP_NIL; -		while (cons) { -			m = ao_has_macro(cons->car); -			if (m) { -				p = m; -				break; -			} -			cons = ao_lisp_poly_cons(cons->cdr); -		} -		break; - -	default: -		p = AO_LISP_NIL; -		break; -	} -	MACRO_DEBUG(--macro_scan_depth;	indent(); printf("... "); ao_lisp_poly_print(p); printf("\n")); -	return p; -} - -int -ao_lisp_read_eval_abort(void) -{ -	ao_poly	in, out = AO_LISP_NIL; -	for(;;) { -		in = ao_lisp_read(); -		if (in == _ao_lisp_atom_eof) -			break; -		out = ao_lisp_eval(in); -		if (ao_lisp_exception) -			return 0; -		ao_lisp_poly_print(out); -		putchar ('\n'); -	} -	return 1; -} - -static FILE	*in; -static FILE	*out; - -int -ao_lisp_getc(void) -{ -	return getc(in); -} - -static const struct option options[] = { -	{ .name = "out", .has_arg = 1, .val = 'o' }, -	{ 0, 0, 0, 0 } -}; - -static void usage(char *program) -{ -	fprintf(stderr, "usage: %s [--out=<output>] [input]\n", program); -	exit(1); -} - -int -main(int argc, char **argv) -{ -	int	f, o; -	ao_poly	val; -	struct ao_lisp_atom	*a; -	struct ao_lisp_builtin	*b; -	int	in_atom = 0; -	char	*out_name = NULL; -	int	c; - -	in = stdin; -	out = stdout; - -	while ((c = getopt_long(argc, argv, "o:", options, NULL)) != -1) { -		switch (c) { -		case 'o': -			out_name = optarg; -			break; -		default: -			usage(argv[0]); -			break; -		} -	} - -	for (f = 0; f < (int) N_FUNC; f++) { -		b = ao_lisp_make_builtin(funcs[f].func, funcs[f].args); -		a = ao_lisp_atom_intern(funcs[f].name); -		ao_lisp_atom_set(ao_lisp_atom_poly(a), -				 ao_lisp_builtin_poly(b)); -	} - -	/* boolean constants */ -	ao_lisp_atom_set(ao_lisp_atom_poly(ao_lisp_atom_intern("nil")), -			 AO_LISP_NIL); -	a = ao_lisp_atom_intern("t"); -	ao_lisp_atom_set(ao_lisp_atom_poly(a), -			 ao_lisp_atom_poly(a)); - -	/* end of file value */ -	a = ao_lisp_atom_intern("eof"); -	ao_lisp_atom_set(ao_lisp_atom_poly(a), -			 ao_lisp_atom_poly(a)); - -	if (argv[optind]){ -		in = fopen(argv[optind], "r"); -		if (!in) { -			perror(argv[optind]); -			exit(1); -		} -	} -	if (!ao_lisp_read_eval_abort()) { -		fprintf(stderr, "eval failed\n"); -		exit(1); -	} - -	/* Reduce to referenced values */ -	ao_lisp_collect(AO_LISP_COLLECT_FULL); - -	for (f = 0; f < ao_lisp_frame_global->num; f++) { -		val = ao_has_macro(ao_lisp_frame_global->vals[f].val); -		if (val != AO_LISP_NIL) { -			printf("error: function %s contains unresolved macro: ", -			       ao_lisp_poly_atom(ao_lisp_frame_global->vals[f].atom)->name); -			ao_lisp_poly_print(val); -			printf("\n"); -			exit(1); -		} -	} - -	if (out_name) { -		out = fopen(out_name, "w"); -		if (!out) { -			perror(out_name); -			exit(1); -		} -	} - -	fprintf(out, "/* Generated file, do not edit */\n\n"); - -	fprintf(out, "#define AO_LISP_POOL_CONST %d\n", ao_lisp_top); -	fprintf(out, "extern const uint8_t ao_lisp_const[AO_LISP_POOL_CONST] __attribute__((aligned(4)));\n"); -	fprintf(out, "#define ao_builtin_atoms 0x%04x\n", ao_lisp_atom_poly(ao_lisp_atoms)); -	fprintf(out, "#define ao_builtin_frame 0x%04x\n", ao_lisp_frame_poly(ao_lisp_frame_global)); -	fprintf(out, "#define ao_lisp_const_checksum ((uint16_t) 0x%04x)\n", ao_fec_crc(ao_lisp_const, ao_lisp_top)); - - -	for (a = ao_lisp_atoms; a; a = ao_lisp_poly_atom(a->next)) { -		char	*n = a->name, c; -		fprintf(out, "#define _ao_lisp_atom_"); -		while ((c = *n++)) { -			if (isalnum(c)) -				fprintf(out, "%c", c); -			else -				fprintf(out, "%02x", c); -		} -		fprintf(out, "  0x%04x\n", ao_lisp_atom_poly(a)); -	} -	fprintf(out, "#ifdef AO_LISP_CONST_BITS\n"); -	fprintf(out, "const uint8_t ao_lisp_const[AO_LISP_POOL_CONST] __attribute((aligned(4))) = {"); -	for (o = 0; o < ao_lisp_top; o++) { -		uint8_t	c; -		if ((o & 0xf) == 0) -			fprintf(out, "\n\t"); -		else -			fprintf(out, " "); -		c = ao_lisp_const[o]; -		if (!in_atom) -			in_atom = is_atom(o); -		if (in_atom) { -			fprintf(out, " '%c',", c); -			in_atom--; -		} else { -			fprintf(out, "0x%02x,", c); -		} -	} -	fprintf(out, "\n};\n"); -	fprintf(out, "#endif /* AO_LISP_CONST_BITS */\n"); -	exit(0); -} diff --git a/src/lisp/ao_lisp_mem.c b/src/lisp/ao_lisp_mem.c deleted file mode 100644 index d067ea07..00000000 --- a/src/lisp/ao_lisp_mem.c +++ /dev/null @@ -1,880 +0,0 @@ -/* - * Copyright © 2016 Keith Packard <keithp@keithp.com> - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation, either version 2 of the License, or - * (at your option) any later version. - * - * This program is distributed in the hope that it will be useful, but - * WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU - * General Public License for more details. - */ - -#define AO_LISP_CONST_BITS - -#include "ao_lisp.h" -#include <stdio.h> - -#ifdef AO_LISP_MAKE_CONST - -/* - * When building the constant table, it is the - * pool for allocations. - */ - -#include <stdlib.h> -uint8_t ao_lisp_const[AO_LISP_POOL_CONST] __attribute__((aligned(4))); -#define ao_lisp_pool ao_lisp_const -#undef AO_LISP_POOL -#define AO_LISP_POOL AO_LISP_POOL_CONST - -#else - -uint8_t	ao_lisp_pool[AO_LISP_POOL + AO_LISP_POOL_EXTRA] __attribute__((aligned(4))); - -#endif - -#ifndef DBG_MEM_STATS -#define DBG_MEM_STATS	DBG_MEM -#endif - -#if DBG_MEM -int dbg_move_depth; -int dbg_mem = DBG_MEM_START; -int dbg_validate = 0; - -struct ao_lisp_record { -	struct ao_lisp_record		*next; -	const struct ao_lisp_type	*type; -	void				*addr; -	int				size; -}; - -static struct ao_lisp_record	*record_head, **record_tail; - -static void -ao_lisp_record_free(struct ao_lisp_record *record) -{ -	while (record) { -		struct ao_lisp_record *next = record->next; -		free(record); -		record = next; -	} -} - -static void -ao_lisp_record_reset(void) -{ -	ao_lisp_record_free(record_head); -	record_head = NULL; -	record_tail = &record_head; -} - -static void -ao_lisp_record(const struct ao_lisp_type	*type, -	       void				*addr, -	       int				size) -{ -	struct ao_lisp_record	*r = malloc(sizeof (struct ao_lisp_record)); - -	r->next = NULL; -	r->type = type; -	r->addr = addr; -	r->size = size; -	*record_tail = r; -	record_tail = &r->next; -} - -static struct ao_lisp_record * -ao_lisp_record_save(void) -{ -	struct ao_lisp_record *r = record_head; - -	record_head = NULL; -	record_tail = &record_head; -	return r; -} - -static void -ao_lisp_record_compare(char *where, -		       struct ao_lisp_record *a, -		       struct ao_lisp_record *b) -{ -	while (a && b) { -		if (a->type != b->type || a->size != b->size) { -			printf("%s record difers %d %s %d -> %d %s %d\n", -			       where, -			       MDBG_OFFSET(a->addr), -			       a->type->name, -			       a->size, -			       MDBG_OFFSET(b->addr), -			       b->type->name, -			       b->size); -			ao_lisp_abort(); -		} -		a = a->next; -		b = b->next; -	} -	if (a) { -		printf("%s record differs %d %s %d -> NULL\n", -		       where, -		       MDBG_OFFSET(a->addr), -		       a->type->name, -		       a->size); -		ao_lisp_abort(); -	} -	if (b) { -		printf("%s record differs NULL -> %d %s %d\n", -		       where, -		       MDBG_OFFSET(b->addr), -		       b->type->name, -		       b->size); -		ao_lisp_abort(); -	} -} - -#else -#define ao_lisp_record_reset() -#endif - -uint8_t	ao_lisp_exception; - -struct ao_lisp_root { -	const struct ao_lisp_type	*type; -	void				**addr; -}; - -static struct ao_lisp_cons 	*save_cons[2]; -static char			*save_string[2]; -static ao_poly			save_poly[3]; - -static const struct ao_lisp_root	ao_lisp_root[] = { -	{ -		.type = &ao_lisp_cons_type, -		.addr = (void **) &save_cons[0], -	}, -	{ -		.type = &ao_lisp_cons_type, -		.addr = (void **) &save_cons[1], -	}, -	{ -		.type = &ao_lisp_string_type, -		.addr = (void **) &save_string[0], -	}, -	{ -		.type = &ao_lisp_string_type, -		.addr = (void **) &save_string[1], -	}, -	{ -		.type = NULL, -		.addr = (void **) (void *) &save_poly[0] -	}, -	{ -		.type = NULL, -		.addr = (void **) (void *) &save_poly[1] -	}, -	{ -		.type = NULL, -		.addr = (void **) (void *) &save_poly[2] -	}, -	{ -		.type = &ao_lisp_atom_type, -		.addr = (void **) &ao_lisp_atoms -	}, -	{ -		.type = &ao_lisp_frame_type, -		.addr = (void **) &ao_lisp_frame_global, -	}, -	{ -		.type = &ao_lisp_frame_type, -		.addr = (void **) &ao_lisp_frame_current, -	}, -	{ -		.type = &ao_lisp_stack_type, -		.addr = (void **) &ao_lisp_stack, -	}, -	{ -		.type = NULL, -		.addr = (void **) (void *) &ao_lisp_v, -	}, -	{ -		.type = &ao_lisp_cons_type, -		.addr = (void **) &ao_lisp_read_cons, -	}, -	{ -		.type = &ao_lisp_cons_type, -		.addr = (void **) &ao_lisp_read_cons_tail, -	}, -	{ -		.type = &ao_lisp_cons_type, -		.addr = (void **) &ao_lisp_read_stack, -	}, -}; - -#define AO_LISP_ROOT	(sizeof (ao_lisp_root) / sizeof (ao_lisp_root[0])) - -static const void ** const ao_lisp_cache[] = { -	(const void **) &ao_lisp_cons_free_list, -	(const void **) &ao_lisp_stack_free_list, -	(const void **) &ao_lisp_frame_free_list[0], -	(const void **) &ao_lisp_frame_free_list[1], -	(const void **) &ao_lisp_frame_free_list[2], -	(const void **) &ao_lisp_frame_free_list[3], -	(const void **) &ao_lisp_frame_free_list[4], -	(const void **) &ao_lisp_frame_free_list[5], -}; - -#if AO_LISP_FRAME_FREE != 6 -#error Unexpected AO_LISP_FRAME_FREE value -#endif - -#define AO_LISP_CACHE	(sizeof (ao_lisp_cache) / sizeof (ao_lisp_cache[0])) - -#define AO_LISP_BUSY_SIZE	((AO_LISP_POOL + 31) / 32) - -static uint8_t	ao_lisp_busy[AO_LISP_BUSY_SIZE]; -static uint8_t	ao_lisp_cons_note[AO_LISP_BUSY_SIZE]; -static uint8_t	ao_lisp_cons_last[AO_LISP_BUSY_SIZE]; -static uint8_t	ao_lisp_cons_noted; - -uint16_t	ao_lisp_top; - -struct ao_lisp_chunk { -	uint16_t		old_offset; -	union { -		uint16_t	size; -		uint16_t	new_offset; -	}; -}; - -#define AO_LISP_NCHUNK	64 - -static struct ao_lisp_chunk ao_lisp_chunk[AO_LISP_NCHUNK]; - -/* Offset of an address within the pool. */ -static inline uint16_t pool_offset(void *addr) { -#if DBG_MEM -	if (!AO_LISP_IS_POOL(addr)) -		ao_lisp_abort(); -#endif -	return ((uint8_t *) addr) - ao_lisp_pool; -} - -static inline void mark(uint8_t *tag, int offset) { -	int	byte = offset >> 5; -	int	bit = (offset >> 2) & 7; -	tag[byte] |= (1 << bit); -} - -static inline void clear(uint8_t *tag, int offset) { -	int	byte = offset >> 5; -	int	bit = (offset >> 2) & 7; -	tag[byte] &= ~(1 << bit); -} - -static inline int busy(uint8_t *tag, int offset) { -	int	byte = offset >> 5; -	int	bit = (offset >> 2) & 7; -	return (tag[byte] >> bit) & 1; -} - -static inline int min(int a, int b) { return a < b ? a : b; } -static inline int max(int a, int b) { return a > b ? a : b; } - -static inline int limit(int offset) { -	return min(AO_LISP_POOL, max(offset, 0)); -} - -static void -note_cons(uint16_t offset) -{ -	MDBG_MOVE("note cons %d\n", offset); -	ao_lisp_cons_noted = 1; -	mark(ao_lisp_cons_note, offset); -} - -static uint16_t	chunk_low, chunk_high; -static uint16_t	chunk_first, chunk_last; - -static int -find_chunk(uint16_t offset) -{ -	int l, r; -	/* Binary search for the location */ -	l = chunk_first; -	r = chunk_last - 1; -	while (l <= r) { -		int m = (l + r) >> 1; -		if (ao_lisp_chunk[m].old_offset < offset) -			l = m + 1; -		else -			r = m - 1; -	} -	return l; -} - -static void -note_chunk(uint16_t offset, uint16_t size) -{ -	int l; - -	if (offset < chunk_low || chunk_high <= offset) -		return; - -	l = find_chunk(offset); - -	/* -	 * The correct location is always in 'l', with r = l-1 being -	 * the entry before the right one -	 */ - -#if DBG_MEM -	/* Off the right side */ -	if (l >= AO_LISP_NCHUNK) -		ao_lisp_abort(); - -	/* Off the left side */ -	if (l == 0 && chunk_last && offset > ao_lisp_chunk[0].old_offset) -		ao_lisp_abort(); -#endif - -	/* Shuffle existing entries right */ -	int end = min(AO_LISP_NCHUNK, chunk_last + 1); - -	memmove(&ao_lisp_chunk[l+1], -		&ao_lisp_chunk[l], -		(end - (l+1)) * sizeof (struct ao_lisp_chunk)); - -	/* Add new entry */ -	ao_lisp_chunk[l].old_offset = offset; -	ao_lisp_chunk[l].size = size; - -	/* Increment the number of elements up to the size of the array */ -	if (chunk_last < AO_LISP_NCHUNK) -		chunk_last++; - -	/* Set the top address if the array is full */ -	if (chunk_last == AO_LISP_NCHUNK) -		chunk_high = ao_lisp_chunk[AO_LISP_NCHUNK-1].old_offset + -			ao_lisp_chunk[AO_LISP_NCHUNK-1].size; -} - -static void -reset_chunks(void) -{ -	chunk_high = ao_lisp_top; -	chunk_last = 0; -	chunk_first = 0; -} - -/* - * Walk all referenced objects calling functions on each one - */ - -static void -walk(int (*visit_addr)(const struct ao_lisp_type *type, void **addr), -     int (*visit_poly)(ao_poly *p, uint8_t do_note_cons)) -{ -	int i; - -	ao_lisp_record_reset(); -	memset(ao_lisp_busy, '\0', sizeof (ao_lisp_busy)); -	memset(ao_lisp_cons_note, '\0', sizeof (ao_lisp_cons_note)); -	ao_lisp_cons_noted = 0; -	for (i = 0; i < (int) AO_LISP_ROOT; i++) { -		if (ao_lisp_root[i].type) { -			void **a = ao_lisp_root[i].addr, *v; -			if (a && (v = *a)) { -				MDBG_MOVE("root ptr %d\n", MDBG_OFFSET(v)); -				visit_addr(ao_lisp_root[i].type, a); -			} -		} else { -			ao_poly *a = (ao_poly *) ao_lisp_root[i].addr, p; -			if (a && (p = *a)) { -				MDBG_MOVE("root poly %d\n", MDBG_OFFSET(ao_lisp_ref(p))); -				visit_poly(a, 0); -			} -		} -	} -	while (ao_lisp_cons_noted) { -		memcpy(ao_lisp_cons_last, ao_lisp_cons_note, sizeof (ao_lisp_cons_note)); -		memset(ao_lisp_cons_note, '\0', sizeof (ao_lisp_cons_note)); -		ao_lisp_cons_noted = 0; -		for (i = 0; i < AO_LISP_POOL; i += 4) { -			if (busy(ao_lisp_cons_last, i)) { -				void *v = ao_lisp_pool + i; -				MDBG_MOVE("root cons %d\n", MDBG_OFFSET(v)); -				visit_addr(&ao_lisp_cons_type, &v); -			} -		} -	} -} - -#if MDBG_DUMP -static void -dump_busy(void) -{ -	int	i; -	MDBG_MOVE("busy:"); -	for (i = 0; i < ao_lisp_top; i += 4) { -		if ((i & 0xff) == 0) { -			MDBG_MORE("\n"); -			MDBG_MOVE("%s", ""); -		} -		else if ((i & 0x1f) == 0) -			MDBG_MORE(" "); -		if (busy(ao_lisp_busy, i)) -			MDBG_MORE("*"); -		else -			MDBG_MORE("-"); -	} -	MDBG_MORE ("\n"); -} -#define DUMP_BUSY()	dump_busy() -#else -#define DUMP_BUSY() -#endif - -static const struct ao_lisp_type const *ao_lisp_types[AO_LISP_NUM_TYPE] = { -	[AO_LISP_CONS] = &ao_lisp_cons_type, -	[AO_LISP_INT] = NULL, -	[AO_LISP_STRING] = &ao_lisp_string_type, -	[AO_LISP_OTHER] = (void *) 0x1, -	[AO_LISP_ATOM] = &ao_lisp_atom_type, -	[AO_LISP_BUILTIN] = &ao_lisp_builtin_type, -	[AO_LISP_FRAME] = &ao_lisp_frame_type, -	[AO_LISP_LAMBDA] = &ao_lisp_lambda_type, -	[AO_LISP_STACK] = &ao_lisp_stack_type, -}; - -static int -ao_lisp_mark_ref(const struct ao_lisp_type *type, void **ref) -{ -	return ao_lisp_mark(type, *ref); -} - -static int -ao_lisp_poly_mark_ref(ao_poly *p, uint8_t do_note_cons) -{ -	return ao_lisp_poly_mark(*p, do_note_cons); -} - -#if DBG_MEM_STATS -int ao_lisp_collects[2]; -int ao_lisp_freed[2]; -int ao_lisp_loops[2]; -#endif - -int ao_lisp_last_top; - -int -ao_lisp_collect(uint8_t style) -{ -	int	i; -	int	top; -#if DBG_MEM_STATS -	int	loops = 0; -#endif -#if DBG_MEM -	struct ao_lisp_record	*mark_record = NULL, *move_record = NULL; - -	MDBG_MOVE("collect %d\n", ao_lisp_collects[style]); -#endif - -	/* The first time through, we're doing a full collect */ -	if (ao_lisp_last_top == 0) -		style = AO_LISP_COLLECT_FULL; - -	/* Clear references to all caches */ -	for (i = 0; i < (int) AO_LISP_CACHE; i++) -		*ao_lisp_cache[i] = NULL; -	if (style == AO_LISP_COLLECT_FULL) { -		chunk_low = top = 0; -	} else { -		chunk_low = top = ao_lisp_last_top; -	} -	for (;;) { -#if DBG_MEM_STATS -		loops++; -#endif -		MDBG_MOVE("move chunks from %d to %d\n", chunk_low, top); -		/* Find the sizes of the first chunk of objects to move */ -		reset_chunks(); -		walk(ao_lisp_mark_ref, ao_lisp_poly_mark_ref); -#if DBG_MEM - -		ao_lisp_record_free(mark_record); -		mark_record = ao_lisp_record_save(); -		if (mark_record && move_record) -			ao_lisp_record_compare("mark", move_record, mark_record); -#endif - -		DUMP_BUSY(); - -		/* Find the first moving object */ -		for (i = 0; i < chunk_last; i++) { -			uint16_t	size = ao_lisp_chunk[i].size; - -#if DBG_MEM -			if (!size) -				ao_lisp_abort(); -#endif - -			if (ao_lisp_chunk[i].old_offset > top) -				break; - -			MDBG_MOVE("chunk %d %d not moving\n", -				  ao_lisp_chunk[i].old_offset, -				  ao_lisp_chunk[i].size); -#if DBG_MEM -			if (ao_lisp_chunk[i].old_offset != top) -				ao_lisp_abort(); -#endif -			top += size; -		} - -		/* -		 * Limit amount of chunk array used in mapping moves -		 * to the active region -		 */ -		chunk_first = i; -		chunk_low = ao_lisp_chunk[i].old_offset; - -		/* Copy all of the objects */ -		for (; i < chunk_last; i++) { -			uint16_t	size = ao_lisp_chunk[i].size; - -#if DBG_MEM -			if (!size) -				ao_lisp_abort(); -#endif - -			MDBG_MOVE("chunk %d %d -> %d\n", -				  ao_lisp_chunk[i].old_offset, -				  size, -				  top); -			ao_lisp_chunk[i].new_offset = top; - -			memmove(&ao_lisp_pool[top], -				&ao_lisp_pool[ao_lisp_chunk[i].old_offset], -				size); - -			top += size; -		} - -		if (chunk_first < chunk_last) { -			/* Relocate all references to the objects */ -			walk(ao_lisp_move, ao_lisp_poly_move); - -#if DBG_MEM -			ao_lisp_record_free(move_record); -			move_record = ao_lisp_record_save(); -			if (mark_record && move_record) -				ao_lisp_record_compare("move", mark_record, move_record); -#endif -		} - -		/* If we ran into the end of the heap, then -		 * there's no need to keep walking -		 */ -		if (chunk_last != AO_LISP_NCHUNK) -			break; - -		/* Next loop starts right above this loop */ -		chunk_low = chunk_high; -	} - -#if DBG_MEM_STATS -	/* Collect stats */ -	++ao_lisp_collects[style]; -	ao_lisp_freed[style] += ao_lisp_top - top; -	ao_lisp_loops[style] += loops; -#endif - -	ao_lisp_top = top; -	if (style == AO_LISP_COLLECT_FULL) -		ao_lisp_last_top = top; - -	MDBG_DO(memset(ao_lisp_chunk, '\0', sizeof (ao_lisp_chunk)); -		walk(ao_lisp_mark_ref, ao_lisp_poly_mark_ref)); - -	return AO_LISP_POOL - ao_lisp_top; -} - -/* - * Mark interfaces for objects - */ - -/* - * Note a reference to memory and collect information about a few - * object sizes at a time - */ - -int -ao_lisp_mark_memory(const struct ao_lisp_type *type, void *addr) -{ -	int offset; -	if (!AO_LISP_IS_POOL(addr)) -		return 1; - -	offset = pool_offset(addr); -	MDBG_MOVE("mark memory %d\n", MDBG_OFFSET(addr)); -	if (busy(ao_lisp_busy, offset)) { -		MDBG_MOVE("already marked\n"); -		return 1; -	} -	mark(ao_lisp_busy, offset); -	note_chunk(offset, ao_lisp_size(type, addr)); -	return 0; -} - -/* - * Mark an object and all that it refereces - */ -int -ao_lisp_mark(const struct ao_lisp_type *type, void *addr) -{ -	int ret; -	MDBG_MOVE("mark %d\n", MDBG_OFFSET(addr)); -	MDBG_MOVE_IN(); -	ret = ao_lisp_mark_memory(type, addr); -	if (!ret) { -		MDBG_MOVE("mark recurse\n"); -		type->mark(addr); -	} -	MDBG_MOVE_OUT(); -	return ret; -} - -/* - * Mark an object, unless it is a cons cell and - * do_note_cons is set. In that case, just - * set a bit in the cons note array; those - * will be marked in a separate pass to avoid - * deep recursion in the collector - */ -int -ao_lisp_poly_mark(ao_poly p, uint8_t do_note_cons) -{ -	uint8_t type; -	void	*addr; - -	type = ao_lisp_poly_base_type(p); - -	if (type == AO_LISP_INT) -		return 1; - -	addr = ao_lisp_ref(p); -	if (!AO_LISP_IS_POOL(addr)) -		return 1; - -	if (type == AO_LISP_CONS && do_note_cons) { -		note_cons(pool_offset(addr)); -		return 1; -	} else { -		if (type == AO_LISP_OTHER) -			type = ao_lisp_other_type(addr); - -		const struct ao_lisp_type *lisp_type = ao_lisp_types[type]; -#if DBG_MEM -		if (!lisp_type) -			ao_lisp_abort(); -#endif - -		return ao_lisp_mark(lisp_type, addr); -	} -} - -/* - * Find the current location of an object - * based on the original location. For unmoved - * objects, this is simple. For moved objects, - * go search for it - */ - -static uint16_t -move_map(uint16_t offset) -{ -	int		l; - -	if (offset < chunk_low || chunk_high <= offset) -		return offset; - -	l = find_chunk(offset); - -#if DBG_MEM -	if (ao_lisp_chunk[l].old_offset != offset) -		ao_lisp_abort(); -#endif -	return ao_lisp_chunk[l].new_offset; -} - -int -ao_lisp_move_memory(const struct ao_lisp_type *type, void **ref) -{ -	void		*addr = *ref; -	uint16_t	offset, orig_offset; - -	if (!AO_LISP_IS_POOL(addr)) -		return 1; - -	(void) type; - -	MDBG_MOVE("move memory %d\n", MDBG_OFFSET(addr)); -	orig_offset = pool_offset(addr); -	offset = move_map(orig_offset); -	if (offset != orig_offset) { -		MDBG_MOVE("update ref %d %d -> %d\n", -			  AO_LISP_IS_POOL(ref) ? MDBG_OFFSET(ref) : -1, -			  orig_offset, offset); -		*ref = ao_lisp_pool + offset; -	} -	if (busy(ao_lisp_busy, offset)) { -		MDBG_MOVE("already moved\n"); -		return 1; -	} -	mark(ao_lisp_busy, offset); -	MDBG_DO(ao_lisp_record(type, addr, ao_lisp_size(type, addr))); -	return 0; -} - -int -ao_lisp_move(const struct ao_lisp_type *type, void **ref) -{ -	int ret; -	MDBG_MOVE("move object %d\n", MDBG_OFFSET(*ref)); -	MDBG_MOVE_IN(); -	ret = ao_lisp_move_memory(type, ref); -	if (!ret) { -		MDBG_MOVE("move recurse\n"); -		type->move(*ref); -	} -	MDBG_MOVE_OUT(); -	return ret; -} - -int -ao_lisp_poly_move(ao_poly *ref, uint8_t do_note_cons) -{ -	uint8_t		type; -	ao_poly		p = *ref; -	int		ret; -	void		*addr; -	uint16_t	offset, orig_offset; -	uint8_t		base_type; - -	base_type = type = ao_lisp_poly_base_type(p); - -	if (type == AO_LISP_INT) -		return 1; - -	addr = ao_lisp_ref(p); -	if (!AO_LISP_IS_POOL(addr)) -		return 1; - -	orig_offset = pool_offset(addr); -	offset = move_map(orig_offset); - -	if (type == AO_LISP_CONS && do_note_cons) { -		note_cons(orig_offset); -		ret = 1; -	} else { -		if (type == AO_LISP_OTHER) -			type = ao_lisp_other_type(ao_lisp_pool + offset); - -		const struct ao_lisp_type *lisp_type = ao_lisp_types[type]; -#if DBG_MEM -		if (!lisp_type) -			ao_lisp_abort(); -#endif - -		ret = ao_lisp_move(lisp_type, &addr); -	} - -	/* Re-write the poly value */ -	if (offset != orig_offset) { -		ao_poly np = ao_lisp_poly(ao_lisp_pool + offset, base_type); -		MDBG_MOVE("poly %d moved %d -> %d\n", -			  type, orig_offset, offset); -		*ref = np; -	} -	return ret; -} - -#if DBG_MEM -void -ao_lisp_validate(void) -{ -	chunk_low = 0; -	memset(ao_lisp_chunk, '\0', sizeof (ao_lisp_chunk)); -	walk(ao_lisp_mark_ref, ao_lisp_poly_mark_ref); -} - -int dbg_allocs; - -#endif - -void * -ao_lisp_alloc(int size) -{ -	void	*addr; - -	MDBG_DO(++dbg_allocs); -	MDBG_DO(if (dbg_validate) ao_lisp_validate()); -	size = ao_lisp_size_round(size); -	if (AO_LISP_POOL - ao_lisp_top < size && -	    ao_lisp_collect(AO_LISP_COLLECT_INCREMENTAL) < size && -	    ao_lisp_collect(AO_LISP_COLLECT_FULL) < size) -	{ -		ao_lisp_error(AO_LISP_OOM, "out of memory"); -		return NULL; -	} -	addr = ao_lisp_pool + ao_lisp_top; -	ao_lisp_top += size; -	return addr; -} - -void -ao_lisp_cons_stash(int id, struct ao_lisp_cons *cons) -{ -	save_cons[id] = cons; -} - -struct ao_lisp_cons * -ao_lisp_cons_fetch(int id) -{ -	struct ao_lisp_cons *cons = save_cons[id]; -	save_cons[id] = NULL; -	return cons; -} - -void -ao_lisp_poly_stash(int id, ao_poly poly) -{ -	save_poly[id] = poly; -} - -ao_poly -ao_lisp_poly_fetch(int id) -{ -	ao_poly poly = save_poly[id]; -	save_poly[id] = AO_LISP_NIL; -	return poly; -} - -void -ao_lisp_string_stash(int id, char *string) -{ -	save_string[id] = string; -} - -char * -ao_lisp_string_fetch(int id) -{ -	char *string = save_string[id]; -	save_string[id] = NULL; -	return string; -} - diff --git a/src/lisp/ao_lisp_poly.c b/src/lisp/ao_lisp_poly.c deleted file mode 100644 index fb3b06fe..00000000 --- a/src/lisp/ao_lisp_poly.c +++ /dev/null @@ -1,102 +0,0 @@ -/* - * Copyright © 2016 Keith Packard <keithp@keithp.com> - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation, either version 2 of the License, or - * (at your option) any later version. - * - * This program is distributed in the hope that it will be useful, but - * WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU - * General Public License for more details. - */ - -#include "ao_lisp.h" - -struct ao_lisp_funcs { -	void (*print)(ao_poly); -	void (*patom)(ao_poly); -}; - -static const struct ao_lisp_funcs ao_lisp_funcs[AO_LISP_NUM_TYPE] = { -	[AO_LISP_CONS] = { -		.print = ao_lisp_cons_print, -		.patom = ao_lisp_cons_patom, -	}, -	[AO_LISP_STRING] = { -		.print = ao_lisp_string_print, -		.patom = ao_lisp_string_patom, -	}, -	[AO_LISP_INT] = { -		.print = ao_lisp_int_print, -		.patom = ao_lisp_int_print, -	}, -	[AO_LISP_ATOM] = { -		.print = ao_lisp_atom_print, -		.patom = ao_lisp_atom_print, -	}, -	[AO_LISP_BUILTIN] = { -		.print = ao_lisp_builtin_print, -		.patom = ao_lisp_builtin_print, -	}, -	[AO_LISP_FRAME] = { -		.print = ao_lisp_frame_print, -		.patom = ao_lisp_frame_print, -	}, -	[AO_LISP_LAMBDA] = { -		.print = ao_lisp_lambda_print, -		.patom = ao_lisp_lambda_print, -	}, -	[AO_LISP_STACK] = { -		.print = ao_lisp_stack_print, -		.patom = ao_lisp_stack_print, -	}, -}; - -static const struct ao_lisp_funcs * -funcs(ao_poly p) -{ -	uint8_t	type = ao_lisp_poly_type(p); - -	if (type < AO_LISP_NUM_TYPE) -		return &ao_lisp_funcs[type]; -	return NULL; -} - -void -ao_lisp_poly_print(ao_poly p) -{ -	const struct ao_lisp_funcs *f = funcs(p); - -	if (f && f->print) -		f->print(p); -} - -void -ao_lisp_poly_patom(ao_poly p) -{ -	const struct ao_lisp_funcs *f = funcs(p); - -	if (f && f->patom) -		f->patom(p); -} - -void * -ao_lisp_ref(ao_poly poly) { -	if (poly == AO_LISP_NIL) -		return NULL; -	if (poly & AO_LISP_CONST) -		return (void *) (ao_lisp_const + (poly & AO_LISP_REF_MASK) - 4); -	return (void *) (ao_lisp_pool + (poly & AO_LISP_REF_MASK) - 4); -} - -ao_poly -ao_lisp_poly(const void *addr, ao_poly type) { -	const uint8_t	*a = addr; -	if (a == NULL) -		return AO_LISP_NIL; -	if (AO_LISP_IS_CONST(a)) -		return AO_LISP_CONST | (a - ao_lisp_const + 4) | type; -	return (a - ao_lisp_pool + 4) | type; -} diff --git a/src/lisp/ao_lisp_read.c b/src/lisp/ao_lisp_read.c deleted file mode 100644 index 84ef2a61..00000000 --- a/src/lisp/ao_lisp_read.c +++ /dev/null @@ -1,498 +0,0 @@ -/* - * Copyright © 2016 Keith Packard <keithp@keithp.com> - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation, either version 2 of the License, or - * (at your option) any later version. - * - * This program is distributed in the hope that it will be useful, but - * WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU - * General Public License for more details. - */ - -#include "ao_lisp.h" -#include "ao_lisp_read.h" - -static const uint16_t	lex_classes[128] = { -	IGNORE,		/* ^@ */ -	IGNORE,		/* ^A */ -	IGNORE,		/* ^B */ -	IGNORE,		/* ^C */ -	IGNORE,		/* ^D */ -	IGNORE,		/* ^E */ -	IGNORE,		/* ^F */ -	IGNORE,		/* ^G */ -	IGNORE,		/* ^H */ -	WHITE,		/* ^I */ -	WHITE,		/* ^J */ -	WHITE,		/* ^K */ -	WHITE,		/* ^L */ -	WHITE,		/* ^M */ -	IGNORE,		/* ^N */ -	IGNORE,		/* ^O */ -	IGNORE,		/* ^P */ -	IGNORE,		/* ^Q */ -	IGNORE,		/* ^R */ -	IGNORE,		/* ^S */ -	IGNORE,		/* ^T */ -	IGNORE,		/* ^U */ -	IGNORE,		/* ^V */ -	IGNORE,		/* ^W */ -	IGNORE,		/* ^X */ -	IGNORE,		/* ^Y */ -	IGNORE,		/* ^Z */ -	IGNORE,		/* ^[ */ -	IGNORE,		/* ^\ */ -	IGNORE,		/* ^] */ -	IGNORE,		/* ^^ */ -	IGNORE,		/* ^_ */ -	PRINTABLE|WHITE,	/*    */ - 	PRINTABLE,		/* ! */ - 	PRINTABLE|STRINGC,	/* " */ - 	PRINTABLE|COMMENT,	/* # */ - 	PRINTABLE,		/* $ */ - 	PRINTABLE,		/* % */ - 	PRINTABLE,		/* & */ - 	PRINTABLE|QUOTEC,	/* ' */ - 	PRINTABLE|BRA,		/* ( */ - 	PRINTABLE|KET,		/* ) */ - 	PRINTABLE,		/* * */ - 	PRINTABLE|SIGN,		/* + */ - 	PRINTABLE,		/* , */ - 	PRINTABLE|SIGN,		/* - */ - 	PRINTABLE,		/* . */ - 	PRINTABLE,		/* / */ - 	PRINTABLE|DIGIT,	/* 0 */ - 	PRINTABLE|DIGIT,	/* 1 */ - 	PRINTABLE|DIGIT,	/* 2 */ - 	PRINTABLE|DIGIT,	/* 3 */ - 	PRINTABLE|DIGIT,	/* 4 */ - 	PRINTABLE|DIGIT,	/* 5 */ - 	PRINTABLE|DIGIT,	/* 6 */ - 	PRINTABLE|DIGIT,	/* 7 */ - 	PRINTABLE|DIGIT,	/* 8 */ - 	PRINTABLE|DIGIT,	/* 9 */ - 	PRINTABLE,		/* : */ - 	PRINTABLE|COMMENT,	/* ; */ - 	PRINTABLE,		/* < */ - 	PRINTABLE,		/* = */ - 	PRINTABLE,		/* > */ - 	PRINTABLE,		/* ? */ -  	PRINTABLE,		/*  @ */ -	PRINTABLE,		/*  A */ -	PRINTABLE,		/*  B */ -	PRINTABLE,		/*  C */ -	PRINTABLE,		/*  D */ -	PRINTABLE,		/*  E */ -	PRINTABLE,		/*  F */ -	PRINTABLE,		/*  G */ -	PRINTABLE,		/*  H */ -	PRINTABLE,		/*  I */ -	PRINTABLE,		/*  J */ -	PRINTABLE,		/*  K */ -	PRINTABLE,		/*  L */ -	PRINTABLE,		/*  M */ -	PRINTABLE,		/*  N */ -	PRINTABLE,		/*  O */ -	PRINTABLE,		/*  P */ -	PRINTABLE,		/*  Q */ -	PRINTABLE,		/*  R */ -	PRINTABLE,		/*  S */ -	PRINTABLE,		/*  T */ -	PRINTABLE,		/*  U */ -	PRINTABLE,		/*  V */ -	PRINTABLE,		/*  W */ -	PRINTABLE,		/*  X */ -	PRINTABLE,		/*  Y */ -	PRINTABLE,		/*  Z */ -	PRINTABLE,		/*  [ */ -	PRINTABLE|BACKSLASH,	/*  \ */ -	PRINTABLE,		/*  ] */ -	PRINTABLE,		/*  ^ */ -	PRINTABLE,		/*  _ */ -  	PRINTABLE,		/*  ` */ -	PRINTABLE,		/*  a */ -	PRINTABLE,		/*  b */ -	PRINTABLE,		/*  c */ -	PRINTABLE,		/*  d */ -	PRINTABLE,		/*  e */ -	PRINTABLE,		/*  f */ -	PRINTABLE,		/*  g */ -	PRINTABLE,		/*  h */ -	PRINTABLE,		/*  i */ -	PRINTABLE,		/*  j */ -	PRINTABLE,		/*  k */ -	PRINTABLE,		/*  l */ -	PRINTABLE,		/*  m */ -	PRINTABLE,		/*  n */ -	PRINTABLE,		/*  o */ -	PRINTABLE,		/*  p */ -	PRINTABLE,		/*  q */ -	PRINTABLE,		/*  r */ -	PRINTABLE,		/*  s */ -	PRINTABLE,		/*  t */ -	PRINTABLE,		/*  u */ -	PRINTABLE,		/*  v */ -	PRINTABLE,		/*  w */ -	PRINTABLE,		/*  x */ -	PRINTABLE,		/*  y */ -	PRINTABLE,		/*  z */ -	PRINTABLE,		/*  { */ -	PRINTABLE|VBAR,		/*  | */ -	PRINTABLE,		/*  } */ -	PRINTABLE|TWIDDLE,	/*  ~ */ -	IGNORE,			/*  ^? */ -}; - -static int lex_unget_c; - -static inline int -lex_get() -{ -	int	c; -	if (lex_unget_c) { -		c = lex_unget_c; -		lex_unget_c = 0; -	} else { -		c = ao_lisp_getc(); -	} -	return c; -} - -static inline void -lex_unget(int c) -{ -	if (c != EOF) -		lex_unget_c = c; -} - -static int -lex_quoted (void) -{ -	int	c; -	int	v; -	int	count; - -	c = lex_get(); -	if (c == EOF) -		return EOF; -	c &= 0x7f; - 	switch (c) { -	case 'n': -		return '\n'; -	case 'f': -		return '\f'; -	case 'b': -		return '\b'; -	case 'r': -		return '\r'; -	case 'v': -		return '\v'; -	case 't': -		return '\t'; -	case '0': -	case '1': -	case '2': -	case '3': -	case '4': -	case '5': -	case '6': -	case '7': -		v = c - '0'; -		count = 1; -		while (count <= 3) { -			c = lex_get(); -			if (c == EOF) -				return EOF; -			c &= 0x7f; -			if (c < '0' || '7' < c) { -				lex_unget(c); -				break; -			} -			v = (v << 3) + c - '0'; -			++count; -		} -		return v; -	default: -		return c; -	} -} - -static uint16_t	lex_class; - -static int -lexc(void) -{ -	int	c; -	do { -		c = lex_get(); -		if (c == EOF) { -			lex_class = ENDOFFILE; -			c = 0; -		} else { -			c &= 0x7f; -			lex_class = lex_classes[c]; -			if (lex_class & BACKSLASH) { -				c = lex_quoted(); -				if (c == EOF) -					lex_class = ENDOFFILE; -				else -					lex_class = PRINTABLE; -			} -		} -	} while (lex_class & IGNORE); -	return c; -} - -#define AO_LISP_TOKEN_MAX	32 - -static char	token_string[AO_LISP_TOKEN_MAX]; -static int	token_int; -static int	token_len; - -static inline void add_token(int c) { -	if (c && token_len < AO_LISP_TOKEN_MAX - 1) -		token_string[token_len++] = c; -} - -static inline void end_token(void) { -	token_string[token_len] = '\0'; -} - -static int -lex(void) -{ -	int	c; - -	token_len = 0; -	for (;;) { -		c = lexc(); -		if (lex_class & ENDOFFILE) -			return END; - -		if (lex_class & WHITE) -			continue; - -		if (lex_class & COMMENT) { -			while ((c = lexc()) != '\n') { -				if (lex_class & ENDOFFILE) -					return END; -			} -			continue; -		} - -		if (lex_class & (BRA|KET|QUOTEC)) { -			add_token(c); -			end_token(); -			switch (c) { -			case '(': -				return OPEN; -			case ')': -				return CLOSE; -			case '\'': -				return QUOTE; -			} -		} -		if (lex_class & TWIDDLE) { -			token_int = lexc(); -			return NUM; -		} -		if (lex_class & STRINGC) { -			for (;;) { -				c = lexc(); -				if (lex_class & (STRINGC|ENDOFFILE)) { -					end_token(); -					return STRING; -				} -				add_token(c); -			} -		} -		if (lex_class & PRINTABLE) { -			int	isnum; -			int	hasdigit; -			int	isneg; - -			isnum = 1; -			hasdigit = 0; -			token_int = 0; -			isneg = 0; -			for (;;) { -				if (!(lex_class & NUMBER)) { -					isnum = 0; -				} else { - 					if (token_len != 0 && -					    (lex_class & SIGN)) -					{ -						isnum = 0; -					} -					if (c == '-') -						isneg = 1; -					if (lex_class & DIGIT) { -						hasdigit = 1; -						if (isnum) -							token_int = token_int * 10 + c - '0'; -					} -				} -				add_token (c); -				c = lexc (); -				if (lex_class & (NOTNAME)) { -//					if (lex_class & ENDOFFILE) -//						clearerr (f); -					lex_unget(c); -					end_token (); -					if (isnum && hasdigit) { -						if (isneg) -							token_int = -token_int; -						return NUM; -					} -					return NAME; -				} -			} - -		} -	} -} - -static int parse_token; - -struct ao_lisp_cons	*ao_lisp_read_cons; -struct ao_lisp_cons	*ao_lisp_read_cons_tail; -struct ao_lisp_cons	*ao_lisp_read_stack; - -static int -push_read_stack(int cons, int in_quote) -{ -	DBGI("push read stack %p %d\n", ao_lisp_read_cons, in_quote); -	DBG_IN(); -	if (cons) { -		ao_lisp_read_stack = ao_lisp_cons_cons(ao_lisp_cons_poly(ao_lisp_read_cons), -					       ao_lisp_cons_cons(ao_lisp_int_poly(in_quote), -								 ao_lisp_read_stack)); -		if (!ao_lisp_read_stack) -			return 0; -	} -	ao_lisp_read_cons = NULL; -	ao_lisp_read_cons_tail = NULL; -	return 1; -} - -static int -pop_read_stack(int cons) -{ -	int	in_quote = 0; -	if (cons) { -		ao_lisp_read_cons = ao_lisp_poly_cons(ao_lisp_read_stack->car); -		ao_lisp_read_stack = ao_lisp_poly_cons(ao_lisp_read_stack->cdr); -		in_quote = ao_lisp_poly_int(ao_lisp_read_stack->car); -		ao_lisp_read_stack = ao_lisp_poly_cons(ao_lisp_read_stack->cdr); -		for (ao_lisp_read_cons_tail = ao_lisp_read_cons; -		     ao_lisp_read_cons_tail && ao_lisp_read_cons_tail->cdr; -		     ao_lisp_read_cons_tail = ao_lisp_poly_cons(ao_lisp_read_cons_tail->cdr)) -			; -	} else { -		ao_lisp_read_cons = 0; -		ao_lisp_read_cons_tail = 0; -		ao_lisp_read_stack = 0; -	} -	DBG_OUT(); -	DBGI("pop read stack %p %d\n", ao_lisp_read_cons, in_quote); -	return in_quote; -} - -ao_poly -ao_lisp_read(void) -{ -	struct ao_lisp_atom	*atom; -	char			*string; -	int			cons; -	int			in_quote; -	ao_poly			v; - -	parse_token = lex(); -	DBGI("token %d (%s)\n", parse_token, token_string); - -	cons = 0; -	in_quote = 0; -	ao_lisp_read_cons = ao_lisp_read_cons_tail = ao_lisp_read_stack = 0; -	for (;;) { -		while (parse_token == OPEN) { -			if (!push_read_stack(cons, in_quote)) -				return AO_LISP_NIL; -			cons++; -			in_quote = 0; -			parse_token = lex(); -			DBGI("token %d (%s)\n", parse_token, token_string); -		} - -		switch (parse_token) { -		case END: -		default: -			if (cons) -				ao_lisp_error(AO_LISP_EOF, "unexpected end of file"); -			return _ao_lisp_atom_eof; -			break; -		case NAME: -			atom = ao_lisp_atom_intern(token_string); -			if (atom) -				v = ao_lisp_atom_poly(atom); -			else -				v = AO_LISP_NIL; -			break; -		case NUM: -			v = ao_lisp_int_poly(token_int); -			break; -		case STRING: -			string = ao_lisp_string_copy(token_string); -			if (string) -				v = ao_lisp_string_poly(string); -			else -				v = AO_LISP_NIL; -			break; -		case QUOTE: -			if (!push_read_stack(cons, in_quote)) -				return AO_LISP_NIL; -			cons++; -			in_quote = 1; -			v = _ao_lisp_atom_quote; -			break; -		case CLOSE: -			if (!cons) { -				v = AO_LISP_NIL; -				break; -			} -			v = ao_lisp_cons_poly(ao_lisp_read_cons); -			--cons; -			in_quote = pop_read_stack(cons); -			break; -		} - -		/* loop over QUOTE ends */ -		for (;;) { -			if (!cons) -				return v; - -			struct ao_lisp_cons	*read = ao_lisp_cons_cons(v, NULL); -			if (!read) -				return AO_LISP_NIL; - -			if (ao_lisp_read_cons_tail) -				ao_lisp_read_cons_tail->cdr = ao_lisp_cons_poly(read); -			else -				ao_lisp_read_cons = read; -			ao_lisp_read_cons_tail = read; - -			if (!in_quote || !ao_lisp_read_cons->cdr) -				break; - -			v = ao_lisp_cons_poly(ao_lisp_read_cons); -			--cons; -			in_quote = pop_read_stack(cons); -		} - -		parse_token = lex(); -		DBGI("token %d (%s)\n", parse_token, token_string); -	} -	return v; -} diff --git a/src/lisp/ao_lisp_read.h b/src/lisp/ao_lisp_read.h deleted file mode 100644 index 1c994d56..00000000 --- a/src/lisp/ao_lisp_read.h +++ /dev/null @@ -1,49 +0,0 @@ -/* - * Copyright © 2016 Keith Packard <keithp@keithp.com> - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation, either version 2 of the License, or - * (at your option) any later version. - * - * This program is distributed in the hope that it will be useful, but - * WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU - * General Public License for more details. - */ - -#ifndef _AO_LISP_READ_H_ -#define _AO_LISP_READ_H_ - -# define END	0 -# define NAME	1 -# define OPEN  	2 -# define CLOSE	3 -# define QUOTE	4 -# define STRING	5 -# define NUM	6 - -/* - * character classes - */ - -# define PRINTABLE	0x00000001	/* \t \n ' ' - '~' */ -# define QUOTED		0x00000002	/* \ anything */ -# define BRA		0x00000004	/* ( [ { */ -# define KET		0x00000008	/* ) ] } */ -# define WHITE		0x00000010	/* ' ' \t \n */ -# define DIGIT		0x00000020	/* [0-9] */ -# define SIGN		0x00000040	/* +- */ -# define ENDOFFILE	0x00000080	/* end of file */ -# define COMMENT	0x00000100	/* ; # */ -# define IGNORE		0x00000200	/* \0 - ' ' */ -# define QUOTEC		0x00000400	/* ' */ -# define BACKSLASH	0x00000800	/* \ */ -# define VBAR		0x00001000	/* | */ -# define TWIDDLE	0x00002000	/* ~ */ -# define STRINGC	0x00004000	/* " */ - -# define NOTNAME	(STRINGC|TWIDDLE|VBAR|QUOTEC|COMMENT|ENDOFFILE|WHITE|KET|BRA) -# define NUMBER		(DIGIT|SIGN) - -#endif /* _AO_LISP_READ_H_ */ diff --git a/src/lisp/ao_lisp_save.c b/src/lisp/ao_lisp_save.c deleted file mode 100644 index 4f850fb9..00000000 --- a/src/lisp/ao_lisp_save.c +++ /dev/null @@ -1,76 +0,0 @@ -/* - * Copyright © 2016 Keith Packard <keithp@keithp.com> - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation, either version 2 of the License, or - * (at your option) any later version. - * - * This program is distributed in the hope that it will be useful, but - * WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU - * General Public License for more details. - */ - -#include <ao_lisp.h> - -ao_poly -ao_lisp_save(struct ao_lisp_cons *cons) -{ -	if (!ao_lisp_check_argc(_ao_lisp_atom_save, cons, 0, 0)) -		return AO_LISP_NIL; - -#ifdef AO_LISP_SAVE -	struct ao_lisp_os_save *os = (struct ao_lisp_os_save *) (void *) &ao_lisp_pool[AO_LISP_POOL]; - -	ao_lisp_collect(AO_LISP_COLLECT_FULL); -	os->atoms = ao_lisp_atom_poly(ao_lisp_atoms); -	os->globals = ao_lisp_frame_poly(ao_lisp_frame_global); -	os->const_checksum = ao_lisp_const_checksum; -	os->const_checksum_inv = (uint16_t) ~ao_lisp_const_checksum; - -	if (ao_lisp_os_save()) -		return _ao_lisp_atom_t; -#endif -	return AO_LISP_NIL; -} - -ao_poly -ao_lisp_restore(struct ao_lisp_cons *cons) -{ -	if (!ao_lisp_check_argc(_ao_lisp_atom_save, cons, 0, 0)) -		return AO_LISP_NIL; - -#ifdef AO_LISP_SAVE -	struct ao_lisp_os_save save; -	struct ao_lisp_os_save *os = (struct ao_lisp_os_save *) (void *) &ao_lisp_pool[AO_LISP_POOL]; - -	if (!ao_lisp_os_restore_save(&save, AO_LISP_POOL)) -		return ao_lisp_error(AO_LISP_INVALID, "header restore failed"); - -	if (save.const_checksum != ao_lisp_const_checksum || -	    save.const_checksum_inv != (uint16_t) ~ao_lisp_const_checksum) -	{ -		return ao_lisp_error(AO_LISP_INVALID, "image is corrupted or stale"); -	} - -	if (ao_lisp_os_restore()) { - -		ao_lisp_atoms = ao_lisp_poly_atom(os->atoms); -		ao_lisp_frame_global = ao_lisp_poly_frame(os->globals); - -		/* Clear the eval global variabls */ -		ao_lisp_eval_clear_globals(); - -		/* Reset the allocator */ -		ao_lisp_top = AO_LISP_POOL; -		ao_lisp_collect(AO_LISP_COLLECT_FULL); - -		/* Re-create the evaluator stack */ -		if (!ao_lisp_eval_restart()) -			return AO_LISP_NIL; -		return _ao_lisp_atom_t; -	} -#endif -	return AO_LISP_NIL; -} diff --git a/src/lisp/ao_lisp_stack.c b/src/lisp/ao_lisp_stack.c deleted file mode 100644 index 53adf432..00000000 --- a/src/lisp/ao_lisp_stack.c +++ /dev/null @@ -1,278 +0,0 @@ -/* - * Copyright © 2016 Keith Packard <keithp@keithp.com> - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation, either version 2 of the License, or - * (at your option) any later version. - * - * This program is distributed in the hope that it will be useful, but - * WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU - * General Public License for more details. - */ - -#include "ao_lisp.h" - -const struct ao_lisp_type ao_lisp_stack_type; - -static int -stack_size(void *addr) -{ -	(void) addr; -	return sizeof (struct ao_lisp_stack); -} - -static void -stack_mark(void *addr) -{ -	struct ao_lisp_stack	*stack = addr; -	for (;;) { -		ao_lisp_poly_mark(stack->sexprs, 0); -		ao_lisp_poly_mark(stack->values, 0); -		/* no need to mark values_tail */ -		ao_lisp_poly_mark(stack->frame, 0); -		ao_lisp_poly_mark(stack->list, 0); -		stack = ao_lisp_poly_stack(stack->prev); -		if (ao_lisp_mark_memory(&ao_lisp_stack_type, stack)) -			break; -	} -} - -static void -stack_move(void *addr) -{ -	struct ao_lisp_stack	*stack = addr; - -	while (stack) { -		struct ao_lisp_stack	*prev; -		int			ret; -		(void) ao_lisp_poly_move(&stack->sexprs, 0); -		(void) ao_lisp_poly_move(&stack->values, 0); -		(void) ao_lisp_poly_move(&stack->values_tail, 0); -		(void) ao_lisp_poly_move(&stack->frame, 0); -		(void) ao_lisp_poly_move(&stack->list, 0); -		prev = ao_lisp_poly_stack(stack->prev); -		if (!prev) -			break; -		ret = ao_lisp_move_memory(&ao_lisp_stack_type, (void **) &prev); -		if (prev != ao_lisp_poly_stack(stack->prev)) -			stack->prev = ao_lisp_stack_poly(prev); -		if (ret) -			break; -		stack = prev; -	} -} - -const struct ao_lisp_type ao_lisp_stack_type = { -	.size = stack_size, -	.mark = stack_mark, -	.move = stack_move, -	.name = "stack" -}; - -struct ao_lisp_stack		*ao_lisp_stack_free_list; - -void -ao_lisp_stack_reset(struct ao_lisp_stack *stack) -{ -	stack->state = eval_sexpr; -	stack->sexprs = AO_LISP_NIL; -	stack->values = AO_LISP_NIL; -	stack->values_tail = AO_LISP_NIL; -} - -static struct ao_lisp_stack * -ao_lisp_stack_new(void) -{ -	struct ao_lisp_stack *stack; - -	if (ao_lisp_stack_free_list) { -		stack = ao_lisp_stack_free_list; -		ao_lisp_stack_free_list = ao_lisp_poly_stack(stack->prev); -	} else { -		stack = ao_lisp_alloc(sizeof (struct ao_lisp_stack)); -		if (!stack) -			return 0; -		stack->type = AO_LISP_STACK; -	} -	ao_lisp_stack_reset(stack); -	return stack; -} - -int -ao_lisp_stack_push(void) -{ -	struct ao_lisp_stack	*stack = ao_lisp_stack_new(); - -	if (!stack) -		return 0; - -	stack->prev = ao_lisp_stack_poly(ao_lisp_stack); -	stack->frame = ao_lisp_frame_poly(ao_lisp_frame_current); -	stack->list = AO_LISP_NIL; - -	ao_lisp_stack = stack; - -	DBGI("stack push\n"); -	DBG_FRAMES(); -	DBG_IN(); -	return 1; -} - -void -ao_lisp_stack_pop(void) -{ -	ao_poly			prev; -	struct ao_lisp_frame	*prev_frame; - -	if (!ao_lisp_stack) -		return; -	prev = ao_lisp_stack->prev; -	if (!ao_lisp_stack_marked(ao_lisp_stack)) { -		ao_lisp_stack->prev = ao_lisp_stack_poly(ao_lisp_stack_free_list); -		ao_lisp_stack_free_list = ao_lisp_stack; -	} - -	ao_lisp_stack = ao_lisp_poly_stack(prev); -	prev_frame = ao_lisp_frame_current; -	if (ao_lisp_stack) -		ao_lisp_frame_current = ao_lisp_poly_frame(ao_lisp_stack->frame); -	else -		ao_lisp_frame_current = NULL; -	if (ao_lisp_frame_current != prev_frame) -		ao_lisp_frame_free(prev_frame); -	DBG_OUT(); -	DBGI("stack pop\n"); -	DBG_FRAMES(); -} - -void -ao_lisp_stack_clear(void) -{ -	ao_lisp_stack = NULL; -	ao_lisp_frame_current = NULL; -	ao_lisp_v = AO_LISP_NIL; -} - -void -ao_lisp_stack_print(ao_poly poly) -{ -	struct ao_lisp_stack *s = ao_lisp_poly_stack(poly); - -	while (s) { -		if (s->type & AO_LISP_STACK_PRINT) { -			printf("[recurse...]"); -			return; -		} -		s->type |= AO_LISP_STACK_PRINT; -		printf("\t[\n"); -		printf("\t\texpr:   "); ao_lisp_poly_print(s->list); printf("\n"); -		printf("\t\tstate:  %s\n", ao_lisp_state_names[s->state]); -		ao_lisp_error_poly ("values: ", s->values, s->values_tail); -		ao_lisp_error_poly ("sexprs: ", s->sexprs, AO_LISP_NIL); -		ao_lisp_error_frame(2, "frame:  ", ao_lisp_poly_frame(s->frame)); -		printf("\t]\n"); -		s->type &= ~AO_LISP_STACK_PRINT; -		s = ao_lisp_poly_stack(s->prev); -	} -} - -/* - * Copy a stack, being careful to keep everybody referenced - */ -static struct ao_lisp_stack * -ao_lisp_stack_copy(struct ao_lisp_stack *old) -{ -	struct ao_lisp_stack *new = NULL; -	struct ao_lisp_stack *n, *prev = NULL; - -	while (old) { -		ao_lisp_stack_stash(0, old); -		ao_lisp_stack_stash(1, new); -		ao_lisp_stack_stash(2, prev); -		n = ao_lisp_stack_new(); -		prev = ao_lisp_stack_fetch(2); -		new = ao_lisp_stack_fetch(1); -		old = ao_lisp_stack_fetch(0); -		if (!n) -			return NULL; - -		ao_lisp_stack_mark(old); -		ao_lisp_frame_mark(ao_lisp_poly_frame(old->frame)); -		*n = *old; - -		if (prev) -			prev->prev = ao_lisp_stack_poly(n); -		else -			new = n; -		prev = n; - -		old = ao_lisp_poly_stack(old->prev); -	} -	return new; -} - -/* - * Evaluate a continuation invocation - */ -ao_poly -ao_lisp_stack_eval(void) -{ -	struct ao_lisp_stack	*new = ao_lisp_stack_copy(ao_lisp_poly_stack(ao_lisp_v)); -	if (!new) -		return AO_LISP_NIL; - -	struct ao_lisp_cons	*cons = ao_lisp_poly_cons(ao_lisp_stack->values); - -	if (!cons || !cons->cdr) -		return ao_lisp_error(AO_LISP_INVALID, "continuation requires a value"); - -	new->state = eval_val; - -	ao_lisp_stack = new; -	ao_lisp_frame_current = ao_lisp_poly_frame(ao_lisp_stack->frame); - -	return ao_lisp_poly_cons(cons->cdr)->car; -} - -/* - * Call with current continuation. This calls a lambda, passing - * it a single argument which is the current continuation - */ -ao_poly -ao_lisp_call_cc(struct ao_lisp_cons *cons) -{ -	struct ao_lisp_stack	*new; -	ao_poly			v; - -	/* Make sure the single parameter is a lambda */ -	if (!ao_lisp_check_argc(_ao_lisp_atom_call2fcc, cons, 1, 1)) -		return AO_LISP_NIL; -	if (!ao_lisp_check_argt(_ao_lisp_atom_call2fcc, cons, 0, AO_LISP_LAMBDA, 0)) -		return AO_LISP_NIL; - -	/* go get the lambda */ -	ao_lisp_v = ao_lisp_arg(cons, 0); - -	/* Note that the whole call chain now has -	 * a reference to it which may escape -	 */ -	new = ao_lisp_stack_copy(ao_lisp_stack); -	if (!new) -		return AO_LISP_NIL; - -	/* re-fetch cons after the allocation */ -	cons = ao_lisp_poly_cons(ao_lisp_poly_cons(ao_lisp_stack->values)->cdr); - -	/* Reset the arg list to the current stack, -	 * and call the lambda -	 */ - -	cons->car = ao_lisp_stack_poly(new); -	cons->cdr = AO_LISP_NIL; -	v = ao_lisp_lambda_eval(); -	ao_lisp_stack->sexprs = v; -	ao_lisp_stack->state = eval_progn; -	return AO_LISP_NIL; -} diff --git a/src/math/kf_rem_pio2.c b/src/math/kf_rem_pio2.c index 261c4812..1573ca9f 100644 --- a/src/math/kf_rem_pio2.c +++ b/src/math/kf_rem_pio2.c @@ -77,7 +77,8 @@ twon8  =  3.9062500000e-03; /* 0x3b800000 */      /* compute q[0],q[1],...q[jk] */  	for (i=0;i<=jk;i++) { -	    for(j=0,fw=0.0;j<=jx;j++) fw += x[j]*f[jx+i-j]; q[i] = fw; +	    for(j=0,fw=0.0;j<=jx;j++) fw += x[j]*f[jx+i-j]; +	    q[i] = fw;  	}  	jz = jk; diff --git a/src/math/sf_cos.c b/src/math/sf_cos.c index 4c0a9a53..2f46ec32 100644 --- a/src/math/sf_cos.c +++ b/src/math/sf_cos.c @@ -16,12 +16,6 @@  #include "fdlibm.h"  #ifdef __STDC__ -static const float one=1.0; -#else -static float one=1.0; -#endif - -#ifdef __STDC__  	float cosf(float x)  #else  	float cosf(x) diff --git a/src/scheme/.gitignore b/src/scheme/.gitignore new file mode 100644 index 00000000..ee72cb9d --- /dev/null +++ b/src/scheme/.gitignore @@ -0,0 +1,2 @@ +ao_scheme_const.h +ao_scheme_builtin.h diff --git a/src/scheme/Makefile b/src/scheme/Makefile new file mode 100644 index 00000000..dc36dde1 --- /dev/null +++ b/src/scheme/Makefile @@ -0,0 +1,20 @@ +all: ao_scheme_builtin.h ao_scheme_const.h test/ao_scheme_test + +clean: +	+cd make-const && make clean +	+cd test && make clean +	rm -f ao_scheme_const.h ao_scheme_builtin.h + +ao_scheme_const.h: ao_scheme_const.scheme make-const/ao_scheme_make_const +	make-const/ao_scheme_make_const -o $@ ao_scheme_const.scheme + +ao_scheme_builtin.h: ao_scheme_make_builtin ao_scheme_builtin.txt +	nickle ao_scheme_make_builtin ao_scheme_builtin.txt > $@ + +make-const/ao_scheme_make_const: FRC ao_scheme_builtin.h +	+cd make-const && make ao_scheme_make_const + +test/ao_scheme_test: FRC ao_scheme_const.h ao_scheme_builtin.h +	+cd test && make ao_scheme_test + +FRC: diff --git a/src/scheme/Makefile-inc b/src/scheme/Makefile-inc new file mode 100644 index 00000000..1a080a4e --- /dev/null +++ b/src/scheme/Makefile-inc @@ -0,0 +1,25 @@ +SCHEME_SRCS=\ +	ao_scheme_mem.c \ +	ao_scheme_cons.c \ +	ao_scheme_string.c \ +	ao_scheme_atom.c \ +	ao_scheme_int.c \ +	ao_scheme_poly.c \ +	ao_scheme_bool.c \ +	ao_scheme_float.c \ +	ao_scheme_builtin.c \ +	ao_scheme_read.c \ +	ao_scheme_frame.c \ +	ao_scheme_lambda.c \ +	ao_scheme_eval.c \ +	ao_scheme_rep.c \ +	ao_scheme_save.c \ +	ao_scheme_stack.c \ +	ao_scheme_error.c \ +	ao_scheme_vector.c + +SCHEME_HDRS=\ +	ao_scheme.h \ +	ao_scheme_os.h \ +	ao_scheme_read.h \ +	ao_scheme_builtin.h diff --git a/src/scheme/Makefile-scheme b/src/scheme/Makefile-scheme new file mode 100644 index 00000000..b9018e19 --- /dev/null +++ b/src/scheme/Makefile-scheme @@ -0,0 +1,4 @@ +include ../scheme/Makefile-inc + +ao_scheme_const.h: $(SCHEME_SRCS) $(SCHEME_HDRS) +	+cd ../scheme && make $@ diff --git a/src/scheme/README b/src/scheme/README new file mode 100644 index 00000000..a18457fd --- /dev/null +++ b/src/scheme/README @@ -0,0 +1,10 @@ +This follows the R7RS with the following known exceptions: + +* No vectors or bytevectors +* Characters are just numbers +* No dynamic-wind or exceptions +* No environments +* No ports +* No syntax-rules +* No record types +* No libraries diff --git a/src/scheme/ao_scheme.h b/src/scheme/ao_scheme.h new file mode 100644 index 00000000..2fa1ed60 --- /dev/null +++ b/src/scheme/ao_scheme.h @@ -0,0 +1,981 @@ +/* + * Copyright © 2016 Keith Packard <keithp@keithp.com> + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation, either version 2 of the License, or + * (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, but + * WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU + * General Public License for more details. + */ + +#ifndef _AO_SCHEME_H_ +#define _AO_SCHEME_H_ + +#define DBG_MEM		0 +#define DBG_EVAL	0 +#define DBG_READ	0 +#define DBG_FREE_CONS	0 +#define NDEBUG		1 + +#include <stdint.h> +#include <string.h> +#include <ao_scheme_os.h> +#ifndef __BYTE_ORDER +#include <endian.h> +#endif + +typedef uint16_t	ao_poly; +typedef int16_t		ao_signed_poly; + +#if AO_SCHEME_SAVE + +struct ao_scheme_os_save { +	ao_poly		atoms; +	ao_poly		globals; +	uint16_t	const_checksum; +	uint16_t	const_checksum_inv; +}; + +#define AO_SCHEME_POOL_EXTRA	(sizeof(struct ao_scheme_os_save)) +#define AO_SCHEME_POOL	((int) (AO_SCHEME_POOL_TOTAL - AO_SCHEME_POOL_EXTRA)) + +int +ao_scheme_os_save(void); + +int +ao_scheme_os_restore_save(struct ao_scheme_os_save *save, int offset); + +int +ao_scheme_os_restore(void); + +#endif + +#ifdef AO_SCHEME_MAKE_CONST +#define AO_SCHEME_POOL_CONST	16384 +extern uint8_t ao_scheme_const[AO_SCHEME_POOL_CONST] __attribute__((aligned(4))); +#define ao_scheme_pool ao_scheme_const +#define AO_SCHEME_POOL AO_SCHEME_POOL_CONST + +#define _atom(n) ao_scheme_atom_poly(ao_scheme_atom_intern(n)) +#define _bool(v) ao_scheme_bool_poly(ao_scheme_bool_get(v)) + +#define _ao_scheme_bool_true	_bool(1) +#define _ao_scheme_bool_false	_bool(0) + +#define _ao_scheme_atom_eof	_atom("eof") +#define _ao_scheme_atom_else	_atom("else") + +#define AO_SCHEME_BUILTIN_ATOMS +#include "ao_scheme_builtin.h" + +#else +#include "ao_scheme_const.h" +#ifndef AO_SCHEME_POOL +#define AO_SCHEME_POOL	3072 +#endif +#ifndef AO_SCHEME_POOL_EXTRA +#define AO_SCHEME_POOL_EXTRA 0 +#endif +extern uint8_t		ao_scheme_pool[AO_SCHEME_POOL + AO_SCHEME_POOL_EXTRA] __attribute__((aligned(4))); +#endif + +/* Primitive types */ +#define AO_SCHEME_CONS		0 +#define AO_SCHEME_INT		1 +#define AO_SCHEME_STRING	2 +#define AO_SCHEME_OTHER		3 + +#define AO_SCHEME_TYPE_MASK	0x0003 +#define AO_SCHEME_TYPE_SHIFT	2 +#define AO_SCHEME_REF_MASK	0x7ffc +#define AO_SCHEME_CONST		0x8000 + +/* These have a type value at the start of the struct */ +#define AO_SCHEME_ATOM		4 +#define AO_SCHEME_BUILTIN	5 +#define AO_SCHEME_FRAME		6 +#define AO_SCHEME_FRAME_VALS	7 +#define AO_SCHEME_LAMBDA	8 +#define AO_SCHEME_STACK		9 +#define AO_SCHEME_BOOL		10 +#define AO_SCHEME_BIGINT	11 +#define AO_SCHEME_FLOAT		12 +#define AO_SCHEME_VECTOR	13 +#define AO_SCHEME_NUM_TYPE	14 + +/* Leave two bits for types to use as they please */ +#define AO_SCHEME_OTHER_TYPE_MASK	0x3f + +#define AO_SCHEME_NIL	0 + +extern uint16_t		ao_scheme_top; + +#define AO_SCHEME_OOM			0x01 +#define AO_SCHEME_DIVIDE_BY_ZERO	0x02 +#define AO_SCHEME_INVALID		0x04 +#define AO_SCHEME_UNDEFINED		0x08 +#define AO_SCHEME_REDEFINED		0x10 +#define AO_SCHEME_EOF			0x20 +#define AO_SCHEME_EXIT			0x40 + +extern uint8_t		ao_scheme_exception; + +static inline int +ao_scheme_is_const(ao_poly poly) { +	return poly & AO_SCHEME_CONST; +} + +#define AO_SCHEME_IS_CONST(a)	(ao_scheme_const <= ((uint8_t *) (a)) && ((uint8_t *) (a)) < ao_scheme_const + AO_SCHEME_POOL_CONST) +#define AO_SCHEME_IS_POOL(a)	(ao_scheme_pool <= ((uint8_t *) (a)) && ((uint8_t *) (a)) < ao_scheme_pool + AO_SCHEME_POOL) +#define AO_SCHEME_IS_INT(p)	(ao_scheme_poly_base_type(p) == AO_SCHEME_INT) + +void * +ao_scheme_ref(ao_poly poly); + +ao_poly +ao_scheme_poly(const void *addr, ao_poly type); + +struct ao_scheme_type { +	int	(*size)(void *addr); +	void	(*mark)(void *addr); +	void	(*move)(void *addr); +	char	name[]; +}; + +struct ao_scheme_cons { +	ao_poly		car; +	ao_poly		cdr; +}; + +struct ao_scheme_atom { +	uint8_t		type; +	uint8_t		pad[1]; +	ao_poly		next; +	char		name[]; +}; + +struct ao_scheme_val { +	ao_poly		atom; +	ao_poly		val; +}; + +struct ao_scheme_frame_vals { +	uint8_t			type; +	uint8_t			size; +	struct ao_scheme_val	vals[]; +}; + +struct ao_scheme_frame { +	uint8_t			type; +	uint8_t			num; +	ao_poly			prev; +	ao_poly			vals; +}; + +struct ao_scheme_bool { +	uint8_t			type; +	uint8_t			value; +	uint16_t		pad; +}; + +struct ao_scheme_bigint { +	uint32_t		value; +}; + +struct ao_scheme_float { +	uint8_t			type; +	uint8_t			pad1; +	uint16_t		pad2; +	float			value; +}; + +struct ao_scheme_vector { +	uint8_t			type; +	uint8_t			pad1; +	uint16_t		length; +	ao_poly			vals[]; +}; + +#if __BYTE_ORDER == __LITTLE_ENDIAN +static inline uint32_t +ao_scheme_int_bigint(int32_t i) { +	return AO_SCHEME_BIGINT | (i << 8); +} +static inline int32_t +ao_scheme_bigint_int(uint32_t bi) { +	return (int32_t) bi >> 8; +} +#else +static inline uint32_t +ao_scheme_int_bigint(int32_t i) { +	return (uint32_t) (i & 0xffffff) | (AO_SCHEME_BIGINT << 24); +} +static inlint int32_t +ao_scheme_bigint_int(uint32_t bi) { +	return (int32_t) (bi << 8) >> 8; +} +#endif + +#define AO_SCHEME_MIN_INT	(-(1 << (15 - AO_SCHEME_TYPE_SHIFT))) +#define AO_SCHEME_MAX_INT	((1 << (15 - AO_SCHEME_TYPE_SHIFT)) - 1) +#define AO_SCHEME_MIN_BIGINT	(-(1 << 24)) +#define AO_SCHEME_MAX_BIGINT	((1 << 24) - 1) + +#define AO_SCHEME_NOT_INTEGER	0x7fffffff + +/* Set on type when the frame escapes the lambda */ +#define AO_SCHEME_FRAME_MARK	0x80 +#define AO_SCHEME_FRAME_PRINT	0x40 + +static inline int ao_scheme_frame_marked(struct ao_scheme_frame *f) { +	return f->type & AO_SCHEME_FRAME_MARK; +} + +static inline struct ao_scheme_frame * +ao_scheme_poly_frame(ao_poly poly) { +	return ao_scheme_ref(poly); +} + +static inline ao_poly +ao_scheme_frame_poly(struct ao_scheme_frame *frame) { +	return ao_scheme_poly(frame, AO_SCHEME_OTHER); +} + +static inline struct ao_scheme_frame_vals * +ao_scheme_poly_frame_vals(ao_poly poly) { +	return ao_scheme_ref(poly); +} + +static inline ao_poly +ao_scheme_frame_vals_poly(struct ao_scheme_frame_vals *vals) { +	return ao_scheme_poly(vals, AO_SCHEME_OTHER); +} + +enum eval_state { +	eval_sexpr,		/* Evaluate an sexpr */ +	eval_val,		/* Value computed */ +	eval_formal,		/* Formal computed */ +	eval_exec,		/* Start a lambda evaluation */ +	eval_apply,		/* Execute apply */ +	eval_cond,		/* Start next cond clause */ +	eval_cond_test,		/* Check cond condition */ +	eval_begin,		/* Start next begin entry */ +	eval_while,		/* Start while condition */ +	eval_while_test,	/* Check while condition */ +	eval_macro,		/* Finished with macro generation */ +}; + +struct ao_scheme_stack { +	uint8_t			type;		/* AO_SCHEME_STACK */ +	uint8_t			state;		/* enum eval_state */ +	ao_poly			prev;		/* previous stack frame */ +	ao_poly			sexprs;		/* expressions to evaluate */ +	ao_poly			values;		/* values computed */ +	ao_poly			values_tail;	/* end of the values list for easy appending */ +	ao_poly			frame;		/* current lookup frame */ +	ao_poly			list;		/* most recent function call */ +}; + +#define AO_SCHEME_STACK_MARK	0x80	/* set on type when a reference has been taken */ +#define AO_SCHEME_STACK_PRINT	0x40	/* stack is being printed */ + +static inline int ao_scheme_stack_marked(struct ao_scheme_stack *s) { +	return s->type & AO_SCHEME_STACK_MARK; +} + +static inline void ao_scheme_stack_mark(struct ao_scheme_stack *s) { +	s->type |= AO_SCHEME_STACK_MARK; +} + +static inline struct ao_scheme_stack * +ao_scheme_poly_stack(ao_poly p) +{ +	return ao_scheme_ref(p); +} + +static inline ao_poly +ao_scheme_stack_poly(struct ao_scheme_stack *stack) +{ +	return ao_scheme_poly(stack, AO_SCHEME_OTHER); +} + +extern ao_poly			ao_scheme_v; + +#define AO_SCHEME_FUNC_LAMBDA		0 +#define AO_SCHEME_FUNC_NLAMBDA		1 +#define AO_SCHEME_FUNC_MACRO		2 + +#define AO_SCHEME_FUNC_FREE_ARGS	0x80 +#define AO_SCHEME_FUNC_MASK		0x7f + +#define AO_SCHEME_FUNC_F_LAMBDA		(AO_SCHEME_FUNC_FREE_ARGS | AO_SCHEME_FUNC_LAMBDA) +#define AO_SCHEME_FUNC_F_NLAMBDA	(AO_SCHEME_FUNC_FREE_ARGS | AO_SCHEME_FUNC_NLAMBDA) +#define AO_SCHEME_FUNC_F_MACRO		(AO_SCHEME_FUNC_FREE_ARGS | AO_SCHEME_FUNC_MACRO) + +struct ao_scheme_builtin { +	uint8_t		type; +	uint8_t		args; +	uint16_t	func; +}; + +#define AO_SCHEME_BUILTIN_ID +#include "ao_scheme_builtin.h" + +typedef ao_poly (*ao_scheme_func_t)(struct ao_scheme_cons *cons); + +extern const ao_scheme_func_t	ao_scheme_builtins[]; + +static inline ao_scheme_func_t +ao_scheme_func(struct ao_scheme_builtin *b) +{ +	return ao_scheme_builtins[b->func]; +} + +struct ao_scheme_lambda { +	uint8_t		type; +	uint8_t		args; +	ao_poly		code; +	ao_poly		frame; +}; + +static inline struct ao_scheme_lambda * +ao_scheme_poly_lambda(ao_poly poly) +{ +	return ao_scheme_ref(poly); +} + +static inline ao_poly +ao_scheme_lambda_poly(struct ao_scheme_lambda *lambda) +{ +	return ao_scheme_poly(lambda, AO_SCHEME_OTHER); +} + +static inline void * +ao_scheme_poly_other(ao_poly poly) { +	return ao_scheme_ref(poly); +} + +static inline uint8_t +ao_scheme_other_type(void *other) { +#if DBG_MEM +	if ((*((uint8_t *) other) & AO_SCHEME_OTHER_TYPE_MASK) >= AO_SCHEME_NUM_TYPE) +		ao_scheme_abort(); +#endif +	return *((uint8_t *) other) & AO_SCHEME_OTHER_TYPE_MASK; +} + +static inline ao_poly +ao_scheme_other_poly(const void *other) +{ +	return ao_scheme_poly(other, AO_SCHEME_OTHER); +} + +static inline int +ao_scheme_size_round(int size) +{ +	return (size + 3) & ~3; +} + +static inline int +ao_scheme_size(const struct ao_scheme_type *type, void *addr) +{ +	return ao_scheme_size_round(type->size(addr)); +} + +#define AO_SCHEME_OTHER_POLY(other) ((ao_poly)(other) + AO_SCHEME_OTHER) + +static inline int ao_scheme_poly_base_type(ao_poly poly) { +	return poly & AO_SCHEME_TYPE_MASK; +} + +static inline int ao_scheme_poly_type(ao_poly poly) { +	int	type = poly & AO_SCHEME_TYPE_MASK; +	if (type == AO_SCHEME_OTHER) +		return ao_scheme_other_type(ao_scheme_poly_other(poly)); +	return type; +} + +static inline int +ao_scheme_is_cons(ao_poly poly) { +	return (ao_scheme_poly_base_type(poly) == AO_SCHEME_CONS); +} + +static inline int +ao_scheme_is_pair(ao_poly poly) { +	return poly != AO_SCHEME_NIL && (ao_scheme_poly_base_type(poly) == AO_SCHEME_CONS); +} + +static inline struct ao_scheme_cons * +ao_scheme_poly_cons(ao_poly poly) +{ +	return ao_scheme_ref(poly); +} + +static inline ao_poly +ao_scheme_cons_poly(struct ao_scheme_cons *cons) +{ +	return ao_scheme_poly(cons, AO_SCHEME_CONS); +} + +static inline int32_t +ao_scheme_poly_int(ao_poly poly) +{ +	return (int32_t) ((ao_signed_poly) poly >> AO_SCHEME_TYPE_SHIFT); +} + +static inline ao_poly +ao_scheme_int_poly(int32_t i) +{ +	return ((ao_poly) i << 2) | AO_SCHEME_INT; +} + +static inline struct ao_scheme_bigint * +ao_scheme_poly_bigint(ao_poly poly) +{ +	return ao_scheme_ref(poly); +} + +static inline ao_poly +ao_scheme_bigint_poly(struct ao_scheme_bigint *bi) +{ +	return ao_scheme_poly(bi, AO_SCHEME_OTHER); +} + +static inline char * +ao_scheme_poly_string(ao_poly poly) +{ +	return ao_scheme_ref(poly); +} + +static inline ao_poly +ao_scheme_string_poly(char *s) +{ +	return ao_scheme_poly(s, AO_SCHEME_STRING); +} + +static inline struct ao_scheme_atom * +ao_scheme_poly_atom(ao_poly poly) +{ +	return ao_scheme_ref(poly); +} + +static inline ao_poly +ao_scheme_atom_poly(struct ao_scheme_atom *a) +{ +	return ao_scheme_poly(a, AO_SCHEME_OTHER); +} + +static inline struct ao_scheme_builtin * +ao_scheme_poly_builtin(ao_poly poly) +{ +	return ao_scheme_ref(poly); +} + +static inline ao_poly +ao_scheme_builtin_poly(struct ao_scheme_builtin *b) +{ +	return ao_scheme_poly(b, AO_SCHEME_OTHER); +} + +static inline ao_poly +ao_scheme_bool_poly(struct ao_scheme_bool *b) +{ +	return ao_scheme_poly(b, AO_SCHEME_OTHER); +} + +static inline struct ao_scheme_bool * +ao_scheme_poly_bool(ao_poly poly) +{ +	return ao_scheme_ref(poly); +} + +static inline ao_poly +ao_scheme_float_poly(struct ao_scheme_float *f) +{ +	return ao_scheme_poly(f, AO_SCHEME_OTHER); +} + +static inline struct ao_scheme_float * +ao_scheme_poly_float(ao_poly poly) +{ +	return ao_scheme_ref(poly); +} + +float +ao_scheme_poly_number(ao_poly p); + +static inline ao_poly +ao_scheme_vector_poly(struct ao_scheme_vector *v) +{ +	return ao_scheme_poly(v, AO_SCHEME_OTHER); +} + +static inline struct ao_scheme_vector * +ao_scheme_poly_vector(ao_poly poly) +{ +	return ao_scheme_ref(poly); +} + +/* memory functions */ + +extern uint64_t ao_scheme_collects[2]; +extern uint64_t ao_scheme_freed[2]; +extern uint64_t ao_scheme_loops[2]; + +/* returns 1 if the object was already marked */ +int +ao_scheme_mark(const struct ao_scheme_type *type, void *addr); + +/* returns 1 if the object was already marked */ +int +ao_scheme_mark_memory(const struct ao_scheme_type *type, void *addr); + +void * +ao_scheme_move_map(void *addr); + +/* returns 1 if the object was already moved */ +int +ao_scheme_move(const struct ao_scheme_type *type, void **ref); + +/* returns 1 if the object was already moved */ +int +ao_scheme_move_memory(const struct ao_scheme_type *type, void **ref); + +void * +ao_scheme_alloc(int size); + +#define AO_SCHEME_COLLECT_FULL		1 +#define AO_SCHEME_COLLECT_INCREMENTAL	0 + +int +ao_scheme_collect(uint8_t style); + +#if DBG_FREE_CONS +void +ao_scheme_cons_check(struct ao_scheme_cons *cons); +#endif + +void +ao_scheme_cons_stash(int id, struct ao_scheme_cons *cons); + +struct ao_scheme_cons * +ao_scheme_cons_fetch(int id); + +void +ao_scheme_poly_stash(int id, ao_poly poly); + +ao_poly +ao_scheme_poly_fetch(int id); + +void +ao_scheme_string_stash(int id, char *string); + +char * +ao_scheme_string_fetch(int id); + +static inline void +ao_scheme_stack_stash(int id, struct ao_scheme_stack *stack) { +	ao_scheme_poly_stash(id, ao_scheme_stack_poly(stack)); +} + +static inline struct ao_scheme_stack * +ao_scheme_stack_fetch(int id) { +	return ao_scheme_poly_stack(ao_scheme_poly_fetch(id)); +} + +void +ao_scheme_frame_stash(int id, struct ao_scheme_frame *frame); + +struct ao_scheme_frame * +ao_scheme_frame_fetch(int id); + +/* bool */ + +extern const struct ao_scheme_type ao_scheme_bool_type; + +void +ao_scheme_bool_write(ao_poly v); + +#ifdef AO_SCHEME_MAKE_CONST +struct ao_scheme_bool	*ao_scheme_true, *ao_scheme_false; + +struct ao_scheme_bool * +ao_scheme_bool_get(uint8_t value); +#endif + +/* cons */ +extern const struct ao_scheme_type ao_scheme_cons_type; + +struct ao_scheme_cons * +ao_scheme_cons_cons(ao_poly car, ao_poly cdr); + +/* Return a cons or NULL for a proper list, else error */ +struct ao_scheme_cons * +ao_scheme_cons_cdr(struct ao_scheme_cons *cons); + +ao_poly +ao_scheme__cons(ao_poly car, ao_poly cdr); + +extern struct ao_scheme_cons *ao_scheme_cons_free_list; + +void +ao_scheme_cons_free(struct ao_scheme_cons *cons); + +void +ao_scheme_cons_write(ao_poly); + +void +ao_scheme_cons_display(ao_poly); + +int +ao_scheme_cons_length(struct ao_scheme_cons *cons); + +struct ao_scheme_cons * +ao_scheme_cons_copy(struct ao_scheme_cons *cons); + +/* string */ +extern const struct ao_scheme_type ao_scheme_string_type; + +char * +ao_scheme_string_copy(char *a); + +char * +ao_scheme_string_cat(char *a, char *b); + +ao_poly +ao_scheme_string_pack(struct ao_scheme_cons *cons); + +ao_poly +ao_scheme_string_unpack(char *a); + +void +ao_scheme_string_write(ao_poly s); + +void +ao_scheme_string_display(ao_poly s); + +/* atom */ +extern const struct ao_scheme_type ao_scheme_atom_type; + +extern struct ao_scheme_atom	*ao_scheme_atoms; +extern struct ao_scheme_frame	*ao_scheme_frame_global; +extern struct ao_scheme_frame	*ao_scheme_frame_current; + +void +ao_scheme_atom_write(ao_poly a); + +struct ao_scheme_atom * +ao_scheme_atom_intern(char *name); + +ao_poly * +ao_scheme_atom_ref(ao_poly atom, struct ao_scheme_frame **frame_ref); + +ao_poly +ao_scheme_atom_get(ao_poly atom); + +ao_poly +ao_scheme_atom_set(ao_poly atom, ao_poly val); + +ao_poly +ao_scheme_atom_def(ao_poly atom, ao_poly val); + +/* int */ +void +ao_scheme_int_write(ao_poly i); + +int32_t +ao_scheme_poly_integer(ao_poly p); + +ao_poly +ao_scheme_integer_poly(int32_t i); + +static inline int +ao_scheme_integer_typep(uint8_t t) +{ +	return (t == AO_SCHEME_INT) || (t == AO_SCHEME_BIGINT); +} + +void +ao_scheme_bigint_write(ao_poly i); + +extern const struct ao_scheme_type	ao_scheme_bigint_type; + +/* vector */ + +void +ao_scheme_vector_write(ao_poly v); + +void +ao_scheme_vector_display(ao_poly v); + +struct ao_scheme_vector * +ao_scheme_vector_alloc(uint16_t length, ao_poly fill); + +ao_poly +ao_scheme_vector_get(ao_poly v, ao_poly i); + +ao_poly +ao_scheme_vector_set(ao_poly v, ao_poly i, ao_poly p); + +struct ao_scheme_vector * +ao_scheme_list_to_vector(struct ao_scheme_cons *cons); + +struct ao_scheme_cons * +ao_scheme_vector_to_list(struct ao_scheme_vector *vector); + +extern const struct ao_scheme_type	ao_scheme_vector_type; + +/* prim */ +void +ao_scheme_poly_write(ao_poly p); + +void +ao_scheme_poly_display(ao_poly p); + +int +ao_scheme_poly_mark(ao_poly p, uint8_t note_cons); + +/* returns 1 if the object has already been moved */ +int +ao_scheme_poly_move(ao_poly *p, uint8_t note_cons); + +/* eval */ + +void +ao_scheme_eval_clear_globals(void); + +int +ao_scheme_eval_restart(void); + +ao_poly +ao_scheme_eval(ao_poly p); + +ao_poly +ao_scheme_set_cond(struct ao_scheme_cons *cons); + +/* float */ +extern const struct ao_scheme_type ao_scheme_float_type; + +void +ao_scheme_float_write(ao_poly p); + +ao_poly +ao_scheme_float_get(float value); + +static inline uint8_t +ao_scheme_number_typep(uint8_t t) +{ +	return ao_scheme_integer_typep(t) || (t == AO_SCHEME_FLOAT); +} + +float +ao_scheme_poly_number(ao_poly p); + +/* builtin */ +void +ao_scheme_builtin_write(ao_poly b); + +extern const struct ao_scheme_type ao_scheme_builtin_type; + +/* Check argument count */ +ao_poly +ao_scheme_check_argc(ao_poly name, struct ao_scheme_cons *cons, int min, int max); + +/* Check argument type */ +ao_poly +ao_scheme_check_argt(ao_poly name, struct ao_scheme_cons *cons, int argc, int type, int nil_ok); + +/* Fetch an arg (nil if off the end) */ +ao_poly +ao_scheme_arg(struct ao_scheme_cons *cons, int argc); + +char * +ao_scheme_args_name(uint8_t args); + +/* read */ +extern int			ao_scheme_read_list; +extern struct ao_scheme_cons	*ao_scheme_read_cons; +extern struct ao_scheme_cons	*ao_scheme_read_cons_tail; +extern struct ao_scheme_cons	*ao_scheme_read_stack; + +ao_poly +ao_scheme_read(void); + +/* rep */ +ao_poly +ao_scheme_read_eval_print(void); + +/* frame */ +extern const struct ao_scheme_type ao_scheme_frame_type; +extern const struct ao_scheme_type ao_scheme_frame_vals_type; + +#define AO_SCHEME_FRAME_FREE	6 + +extern struct ao_scheme_frame	*ao_scheme_frame_free_list[AO_SCHEME_FRAME_FREE]; + +ao_poly +ao_scheme_frame_mark(struct ao_scheme_frame *frame); + +ao_poly * +ao_scheme_frame_ref(struct ao_scheme_frame *frame, ao_poly atom); + +struct ao_scheme_frame * +ao_scheme_frame_new(int num); + +void +ao_scheme_frame_free(struct ao_scheme_frame *frame); + +void +ao_scheme_frame_bind(struct ao_scheme_frame *frame, int num, ao_poly atom, ao_poly val); + +ao_poly +ao_scheme_frame_add(struct ao_scheme_frame *frame, ao_poly atom, ao_poly val); + +void +ao_scheme_frame_write(ao_poly p); + +void +ao_scheme_frame_init(void); + +/* lambda */ +extern const struct ao_scheme_type ao_scheme_lambda_type; + +extern const char * const ao_scheme_state_names[]; + +struct ao_scheme_lambda * +ao_scheme_lambda_new(ao_poly cons); + +void +ao_scheme_lambda_write(ao_poly lambda); + +ao_poly +ao_scheme_lambda_eval(void); + +/* stack */ + +extern const struct ao_scheme_type ao_scheme_stack_type; +extern struct ao_scheme_stack	*ao_scheme_stack; +extern struct ao_scheme_stack	*ao_scheme_stack_free_list; + +void +ao_scheme_stack_reset(struct ao_scheme_stack *stack); + +int +ao_scheme_stack_push(void); + +void +ao_scheme_stack_pop(void); + +void +ao_scheme_stack_clear(void); + +void +ao_scheme_stack_write(ao_poly stack); + +ao_poly +ao_scheme_stack_eval(void); + +/* error */ + +void +ao_scheme_vprintf(char *format, va_list args); + +void +ao_scheme_printf(char *format, ...); + +void +ao_scheme_error_poly(char *name, ao_poly poly, ao_poly last); + +void +ao_scheme_error_frame(int indent, char *name, struct ao_scheme_frame *frame); + +ao_poly +ao_scheme_error(int error, char *format, ...); + +/* builtins */ + +#define AO_SCHEME_BUILTIN_DECLS +#include "ao_scheme_builtin.h" + +/* debugging macros */ + +#if DBG_EVAL || DBG_READ || DBG_MEM +#define DBG_CODE	1 +int ao_scheme_stack_depth; +#define DBG_DO(a)	a +#define DBG_INDENT()	do { int _s; for(_s = 0; _s < ao_scheme_stack_depth; _s++) printf("  "); } while(0) +#define DBG_IN()	(++ao_scheme_stack_depth) +#define DBG_OUT()	(--ao_scheme_stack_depth) +#define DBG_RESET()	(ao_scheme_stack_depth = 0) +#define DBG(...) 	ao_scheme_printf(__VA_ARGS__) +#define DBGI(...)	do { printf("%4d: ", __LINE__); DBG_INDENT(); DBG(__VA_ARGS__); } while (0) +#define DBG_CONS(a)	ao_scheme_cons_write(ao_scheme_cons_poly(a)) +#define DBG_POLY(a)	ao_scheme_poly_write(a) +#define OFFSET(a)	((a) ? (int) ((uint8_t *) a - ao_scheme_pool) : -1) +#define DBG_STACK()	ao_scheme_stack_write(ao_scheme_stack_poly(ao_scheme_stack)) +static inline void +ao_scheme_frames_dump(void) +{ +	struct ao_scheme_stack *s; +	DBGI(".. current frame: "); DBG_POLY(ao_scheme_frame_poly(ao_scheme_frame_current)); DBG("\n"); +	for (s = ao_scheme_stack; s; s = ao_scheme_poly_stack(s->prev)) { +		DBGI(".. stack frame: "); DBG_POLY(s->frame); DBG("\n"); +	} +} +#define DBG_FRAMES()	ao_scheme_frames_dump() +#else +#define DBG_DO(a) +#define DBG_INDENT() +#define DBG_IN() +#define DBG_OUT() +#define DBG(...) +#define DBGI(...) +#define DBG_CONS(a) +#define DBG_POLY(a) +#define DBG_RESET() +#define DBG_STACK() +#define DBG_FRAMES() +#endif + +#if DBG_READ +#define RDBGI(...)	DBGI(__VA_ARGS__) +#define RDBG_IN()	DBG_IN() +#define RDBG_OUT()	DBG_OUT() +#else +#define RDBGI(...) +#define RDBG_IN() +#define RDBG_OUT() +#endif + +#define DBG_MEM_START	1 + +#if DBG_MEM + +#include <assert.h> +extern int dbg_move_depth; +#define MDBG_DUMP 1 +#define MDBG_OFFSET(a)	((a) ? (int) ((uint8_t *) (a) - ao_scheme_pool) : -1) + +extern int dbg_mem; + +#define MDBG_DO(a)	DBG_DO(a) +#define MDBG_MOVE(...) do { if (dbg_mem) { int d; for (d = 0; d < dbg_move_depth; d++) printf ("  "); printf(__VA_ARGS__); } } while (0) +#define MDBG_MORE(...) do { if (dbg_mem) printf(__VA_ARGS__); } while (0) +#define MDBG_MOVE_IN()	(dbg_move_depth++) +#define MDBG_MOVE_OUT()	(assert(--dbg_move_depth >= 0)) + +#else + +#define MDBG_DO(a) +#define MDBG_MOVE(...) +#define MDBG_MORE(...) +#define MDBG_MOVE_IN() +#define MDBG_MOVE_OUT() + +#endif + +#endif /* _AO_SCHEME_H_ */ diff --git a/src/scheme/ao_scheme_atom.c b/src/scheme/ao_scheme_atom.c new file mode 100644 index 00000000..cb32b7fe --- /dev/null +++ b/src/scheme/ao_scheme_atom.c @@ -0,0 +1,167 @@ +/* + * Copyright © 2016 Keith Packard <keithp@keithp.com> + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation; version 2 of the License. + * + * This program is distributed in the hope that it will be useful, but + * WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU + * General Public License for more details. + * + * You should have received a copy of the GNU General Public License along + * with this program; if not, write to the Free Software Foundation, Inc., + * 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA. + */ + +#include "ao_scheme.h" + +static int name_size(char *name) +{ +	return sizeof(struct ao_scheme_atom) + strlen(name) + 1; +} + +static int atom_size(void *addr) +{ +	struct ao_scheme_atom	*atom = addr; +	if (!atom) +		return 0; +	return name_size(atom->name); +} + +static void atom_mark(void *addr) +{ +	struct ao_scheme_atom	*atom = addr; + +	for (;;) { +		atom = ao_scheme_poly_atom(atom->next); +		if (!atom) +			break; +		if (ao_scheme_mark_memory(&ao_scheme_atom_type, atom)) +			break; +	} +} + +static void atom_move(void *addr) +{ +	struct ao_scheme_atom	*atom = addr; +	int			ret; + +	for (;;) { +		struct ao_scheme_atom *next = ao_scheme_poly_atom(atom->next); + +		if (!next) +			break; +		ret = ao_scheme_move_memory(&ao_scheme_atom_type, (void **) &next); +		if (next != ao_scheme_poly_atom(atom->next)) +			atom->next = ao_scheme_atom_poly(next); +		if (ret) +			break; +		atom = next; +	} +} + +const struct ao_scheme_type ao_scheme_atom_type = { +	.mark = atom_mark, +	.size = atom_size, +	.move = atom_move, +	.name = "atom" +}; + +struct ao_scheme_atom	*ao_scheme_atoms; + +struct ao_scheme_atom * +ao_scheme_atom_intern(char *name) +{ +	struct ao_scheme_atom	*atom; + +	for (atom = ao_scheme_atoms; atom; atom = ao_scheme_poly_atom(atom->next)) { +		if (!strcmp(atom->name, name)) +			return atom; +	} +#ifdef ao_builtin_atoms +	for (atom = ao_scheme_poly_atom(ao_builtin_atoms); atom; atom = ao_scheme_poly_atom(atom->next)) { +		if (!strcmp(atom->name, name)) +			return atom; +	} +#endif +	ao_scheme_string_stash(0, name); +	atom = ao_scheme_alloc(name_size(name)); +	name = ao_scheme_string_fetch(0); +	if (atom) { +		atom->type = AO_SCHEME_ATOM; +		atom->next = ao_scheme_atom_poly(ao_scheme_atoms); +		ao_scheme_atoms = atom; +		strcpy(atom->name, name); +	} +	return atom; +} + +ao_poly * +ao_scheme_atom_ref(ao_poly atom, struct ao_scheme_frame **frame_ref) +{ +	ao_poly	*ref; +	struct ao_scheme_frame *frame; + +	for (frame = ao_scheme_frame_current; frame; frame = ao_scheme_poly_frame(frame->prev)) { +		ref = ao_scheme_frame_ref(frame, atom); +		if (ref) { +			if (frame_ref) +				*frame_ref = frame; +			return ref; +		} +	} +	ref = ao_scheme_frame_ref(ao_scheme_frame_global, atom); +	if (ref) +		if (frame_ref) +			*frame_ref = ao_scheme_frame_global; +	return ref; +} + +ao_poly +ao_scheme_atom_get(ao_poly atom) +{ +	ao_poly *ref = ao_scheme_atom_ref(atom, NULL); + +#ifdef ao_builtin_frame +	if (!ref) +		ref = ao_scheme_frame_ref(ao_scheme_poly_frame(ao_builtin_frame), atom); +#endif +	if (ref) +		return *ref; +	return ao_scheme_error(AO_SCHEME_UNDEFINED, "undefined atom %s", ao_scheme_poly_atom(atom)->name); +} + +ao_poly +ao_scheme_atom_set(ao_poly atom, ao_poly val) +{ +	ao_poly *ref = ao_scheme_atom_ref(atom, NULL); + +	if (!ref) +		return ao_scheme_error(AO_SCHEME_UNDEFINED, "undefined atom %s", ao_scheme_poly_atom(atom)->name); +	*ref = val; +	return val; +} + +ao_poly +ao_scheme_atom_def(ao_poly atom, ao_poly val) +{ +	struct ao_scheme_frame	*frame; +	ao_poly *ref = ao_scheme_atom_ref(atom, &frame); + +	if (ref) { +		if (frame == ao_scheme_frame_current) +			return ao_scheme_error(AO_SCHEME_REDEFINED, "attempt to redefine atom %s", ao_scheme_poly_atom(atom)->name); +		*ref = val; +		return val; +	} +	return ao_scheme_frame_add(ao_scheme_frame_current ? ao_scheme_frame_current : ao_scheme_frame_global, atom, val); +} + +void +ao_scheme_atom_write(ao_poly a) +{ +	struct ao_scheme_atom *atom = ao_scheme_poly_atom(a); +	printf("%s", atom->name); +} diff --git a/src/scheme/ao_scheme_bool.c b/src/scheme/ao_scheme_bool.c new file mode 100644 index 00000000..c1e880ca --- /dev/null +++ b/src/scheme/ao_scheme_bool.c @@ -0,0 +1,73 @@ +/* + * Copyright © 2017 Keith Packard <keithp@keithp.com> + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation, either version 2 of the License, or + * (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, but + * WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU + * General Public License for more details. + */ + +#include "ao_scheme.h" + +static void bool_mark(void *addr) +{ +	(void) addr; +} + +static int bool_size(void *addr) +{ +	(void) addr; +	return sizeof (struct ao_scheme_bool); +} + +static void bool_move(void *addr) +{ +	(void) addr; +} + +const struct ao_scheme_type ao_scheme_bool_type = { +	.mark = bool_mark, +	.size = bool_size, +	.move = bool_move, +	.name = "bool" +}; + +void +ao_scheme_bool_write(ao_poly v) +{ +	struct ao_scheme_bool	*b = ao_scheme_poly_bool(v); + +	if (b->value) +		printf("#t"); +	else +		printf("#f"); +} + +#ifdef AO_SCHEME_MAKE_CONST + +struct ao_scheme_bool	*ao_scheme_true, *ao_scheme_false; + +struct ao_scheme_bool * +ao_scheme_bool_get(uint8_t value) +{ +	struct ao_scheme_bool	**b; + +	if (value) +		b = &ao_scheme_true; +	else +		b = &ao_scheme_false; + +	if (!*b) { +		*b = ao_scheme_alloc(sizeof (struct ao_scheme_bool)); +		(*b)->type = AO_SCHEME_BOOL; +		(*b)->value = value; +	} +	return *b; +} + +#endif diff --git a/src/scheme/ao_scheme_builtin.c b/src/scheme/ao_scheme_builtin.c new file mode 100644 index 00000000..1754e677 --- /dev/null +++ b/src/scheme/ao_scheme_builtin.c @@ -0,0 +1,1096 @@ +/* + * Copyright © 2016 Keith Packard <keithp@keithp.com> + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation, either version 2 of the License, or + * (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, but + * WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU + * General Public License for more details. + */ + +#include "ao_scheme.h" +#include <limits.h> +#include <math.h> + +static int +builtin_size(void *addr) +{ +	(void) addr; +	return sizeof (struct ao_scheme_builtin); +} + +static void +builtin_mark(void *addr) +{ +	(void) addr; +} + +static void +builtin_move(void *addr) +{ +	(void) addr; +} + +const struct ao_scheme_type ao_scheme_builtin_type = { +	.size = builtin_size, +	.mark = builtin_mark, +	.move = builtin_move +}; + +#ifdef AO_SCHEME_MAKE_CONST + +#define AO_SCHEME_BUILTIN_CASENAME +#include "ao_scheme_builtin.h" + +char *ao_scheme_args_name(uint8_t args) { +	args &= AO_SCHEME_FUNC_MASK; +	switch (args) { +	case AO_SCHEME_FUNC_LAMBDA: return ao_scheme_poly_atom(_ao_scheme_atom_lambda)->name; +	case AO_SCHEME_FUNC_NLAMBDA: return ao_scheme_poly_atom(_ao_scheme_atom_nlambda)->name; +	case AO_SCHEME_FUNC_MACRO: return ao_scheme_poly_atom(_ao_scheme_atom_macro)->name; +	default: return "???"; +	} +} +#else + +#define AO_SCHEME_BUILTIN_ARRAYNAME +#include "ao_scheme_builtin.h" + +static char * +ao_scheme_builtin_name(enum ao_scheme_builtin_id b) { +	if (b < _builtin_last) +		return ao_scheme_poly_atom(builtin_names[b])->name; +	return "???"; +} + +static const ao_poly ao_scheme_args_atoms[] = { +	[AO_SCHEME_FUNC_LAMBDA] = _ao_scheme_atom_lambda, +	[AO_SCHEME_FUNC_NLAMBDA] = _ao_scheme_atom_nlambda, +	[AO_SCHEME_FUNC_MACRO] = _ao_scheme_atom_macro, +}; + +char * +ao_scheme_args_name(uint8_t args) +{ +	args &= AO_SCHEME_FUNC_MASK; +	if (args < sizeof ao_scheme_args_atoms / sizeof ao_scheme_args_atoms[0]) +		return ao_scheme_poly_atom(ao_scheme_args_atoms[args])->name; +	return "(unknown)"; +} +#endif + +void +ao_scheme_builtin_write(ao_poly b) +{ +	struct ao_scheme_builtin *builtin = ao_scheme_poly_builtin(b); +	printf("%s", ao_scheme_builtin_name(builtin->func)); +} + +ao_poly +ao_scheme_check_argc(ao_poly name, struct ao_scheme_cons *cons, int min, int max) +{ +	int	argc = 0; + +	while (cons && argc <= max) { +		argc++; +		cons = ao_scheme_cons_cdr(cons); +	} +	if (argc < min || argc > max) +		return ao_scheme_error(AO_SCHEME_INVALID, "%s: invalid arg count", ao_scheme_poly_atom(name)->name); +	return _ao_scheme_bool_true; +} + +ao_poly +ao_scheme_arg(struct ao_scheme_cons *cons, int argc) +{ +	if (!cons) +		return AO_SCHEME_NIL; +	while (argc--) { +		if (!cons) +			return AO_SCHEME_NIL; +		cons = ao_scheme_cons_cdr(cons); +	} +	return cons->car; +} + +ao_poly +ao_scheme_check_argt(ao_poly name, struct ao_scheme_cons *cons, int argc, int type, int nil_ok) +{ +	ao_poly car = ao_scheme_arg(cons, argc); + +	if ((!car && !nil_ok) || ao_scheme_poly_type(car) != type) +		return ao_scheme_error(AO_SCHEME_INVALID, "%v: arg %d invalid type %v", name, argc, car); +	return _ao_scheme_bool_true; +} + +int32_t +ao_scheme_arg_int(ao_poly name, struct ao_scheme_cons *cons, int argc) +{ +	ao_poly p = ao_scheme_arg(cons, argc); +	int32_t	i = ao_scheme_poly_integer(p); + +	if (i == AO_SCHEME_NOT_INTEGER) +		(void) ao_scheme_error(AO_SCHEME_INVALID, "%v: arg %d invalid type %v", name, argc, p); +	return i; +} + +ao_poly +ao_scheme_do_car(struct ao_scheme_cons *cons) +{ +	if (!ao_scheme_check_argc(_ao_scheme_atom_car, cons, 1, 1)) +		return AO_SCHEME_NIL; +	if (!ao_scheme_check_argt(_ao_scheme_atom_car, cons, 0, AO_SCHEME_CONS, 0)) +		return AO_SCHEME_NIL; +	return ao_scheme_poly_cons(cons->car)->car; +} + +ao_poly +ao_scheme_do_cdr(struct ao_scheme_cons *cons) +{ +	if (!ao_scheme_check_argc(_ao_scheme_atom_cdr, cons, 1, 1)) +		return AO_SCHEME_NIL; +	if (!ao_scheme_check_argt(_ao_scheme_atom_cdr, cons, 0, AO_SCHEME_CONS, 0)) +		return AO_SCHEME_NIL; +	return ao_scheme_poly_cons(cons->car)->cdr; +} + +ao_poly +ao_scheme_do_cons(struct ao_scheme_cons *cons) +{ +	ao_poly	car, cdr; +	if(!ao_scheme_check_argc(_ao_scheme_atom_cons, cons, 2, 2)) +		return AO_SCHEME_NIL; +	car = ao_scheme_arg(cons, 0); +	cdr = ao_scheme_arg(cons, 1); +	return ao_scheme__cons(car, cdr); +} + +ao_poly +ao_scheme_do_last(struct ao_scheme_cons *cons) +{ +	struct ao_scheme_cons	*list; +	if (!ao_scheme_check_argc(_ao_scheme_atom_last, cons, 1, 1)) +		return AO_SCHEME_NIL; +	if (!ao_scheme_check_argt(_ao_scheme_atom_last, cons, 0, AO_SCHEME_CONS, 1)) +		return AO_SCHEME_NIL; +	for (list = ao_scheme_poly_cons(ao_scheme_arg(cons, 0)); +	     list; +	     list = ao_scheme_cons_cdr(list)) +	{ +		if (!list->cdr) +			return list->car; +	} +	return AO_SCHEME_NIL; +} + +ao_poly +ao_scheme_do_length(struct ao_scheme_cons *cons) +{ +	if (!ao_scheme_check_argc(_ao_scheme_atom_length, cons, 1, 1)) +		return AO_SCHEME_NIL; +	if (!ao_scheme_check_argt(_ao_scheme_atom_length, cons, 0, AO_SCHEME_CONS, 1)) +		return AO_SCHEME_NIL; +	return ao_scheme_int_poly(ao_scheme_cons_length(ao_scheme_poly_cons(ao_scheme_arg(cons, 0)))); +} + +ao_poly +ao_scheme_do_list_copy(struct ao_scheme_cons *cons) +{ +	struct ao_scheme_cons *new; + +	if (!ao_scheme_check_argc(_ao_scheme_atom_length, cons, 1, 1)) +		return AO_SCHEME_NIL; +	if (!ao_scheme_check_argt(_ao_scheme_atom_length, cons, 0, AO_SCHEME_CONS, 1)) +		return AO_SCHEME_NIL; +	new = ao_scheme_cons_copy(ao_scheme_poly_cons(ao_scheme_arg(cons, 0))); +	return ao_scheme_cons_poly(new); +} + +ao_poly +ao_scheme_do_quote(struct ao_scheme_cons *cons) +{ +	if (!ao_scheme_check_argc(_ao_scheme_atom_quote, cons, 1, 1)) +		return AO_SCHEME_NIL; +	return ao_scheme_arg(cons, 0); +} + +ao_poly +ao_scheme_do_set(struct ao_scheme_cons *cons) +{ +	if (!ao_scheme_check_argc(_ao_scheme_atom_set, cons, 2, 2)) +		return AO_SCHEME_NIL; +	if (!ao_scheme_check_argt(_ao_scheme_atom_set, cons, 0, AO_SCHEME_ATOM, 0)) +		return AO_SCHEME_NIL; + +	return ao_scheme_atom_set(ao_scheme_arg(cons, 0), ao_scheme_arg(cons, 1)); +} + +ao_poly +ao_scheme_do_def(struct ao_scheme_cons *cons) +{ +	if (!ao_scheme_check_argc(_ao_scheme_atom_def, cons, 2, 2)) +		return AO_SCHEME_NIL; +	if (!ao_scheme_check_argt(_ao_scheme_atom_def, cons, 0, AO_SCHEME_ATOM, 0)) +		return AO_SCHEME_NIL; + +	return ao_scheme_atom_def(ao_scheme_arg(cons, 0), ao_scheme_arg(cons, 1)); +} + +ao_poly +ao_scheme_do_setq(struct ao_scheme_cons *cons) +{ +	ao_poly	name; +	if (!ao_scheme_check_argc(_ao_scheme_atom_set21, cons, 2, 2)) +		return AO_SCHEME_NIL; +	name = cons->car; +	if (ao_scheme_poly_type(name) != AO_SCHEME_ATOM) +		return ao_scheme_error(AO_SCHEME_INVALID, "set! of non-atom %v", name); +	if (!ao_scheme_atom_ref(name, NULL)) +		return ao_scheme_error(AO_SCHEME_INVALID, "atom %v not defined", name); +	return ao_scheme__cons(_ao_scheme_atom_set, +			     ao_scheme__cons(ao_scheme__cons(_ao_scheme_atom_quote, +							 ao_scheme__cons(name, AO_SCHEME_NIL)), +					   cons->cdr)); +} + +ao_poly +ao_scheme_do_cond(struct ao_scheme_cons *cons) +{ +	ao_scheme_set_cond(cons); +	return AO_SCHEME_NIL; +} + +ao_poly +ao_scheme_do_begin(struct ao_scheme_cons *cons) +{ +	ao_scheme_stack->state = eval_begin; +	ao_scheme_stack->sexprs = ao_scheme_cons_poly(cons); +	return AO_SCHEME_NIL; +} + +ao_poly +ao_scheme_do_while(struct ao_scheme_cons *cons) +{ +	ao_scheme_stack->state = eval_while; +	ao_scheme_stack->sexprs = ao_scheme_cons_poly(cons); +	return AO_SCHEME_NIL; +} + +ao_poly +ao_scheme_do_write(struct ao_scheme_cons *cons) +{ +	ao_poly	val = AO_SCHEME_NIL; +	while (cons) { +		val = cons->car; +		ao_scheme_poly_write(val); +		cons = ao_scheme_cons_cdr(cons); +		if (cons) +			printf(" "); +	} +	return _ao_scheme_bool_true; +} + +ao_poly +ao_scheme_do_display(struct ao_scheme_cons *cons) +{ +	ao_poly	val = AO_SCHEME_NIL; +	while (cons) { +		val = cons->car; +		ao_scheme_poly_display(val); +		cons = ao_scheme_cons_cdr(cons); +	} +	return _ao_scheme_bool_true; +} + +ao_poly +ao_scheme_math(struct ao_scheme_cons *orig_cons, enum ao_scheme_builtin_id op) +{ +	struct ao_scheme_cons *cons = cons; +	ao_poly	ret = AO_SCHEME_NIL; + +	for (cons = orig_cons; cons; cons = ao_scheme_cons_cdr(cons)) { +		ao_poly		car = cons->car; +		uint8_t		rt = ao_scheme_poly_type(ret); +		uint8_t		ct = ao_scheme_poly_type(car); + +		if (cons == orig_cons) { +			ret = car; +			ao_scheme_cons_stash(0, cons); +			if (cons->cdr == AO_SCHEME_NIL) { +				switch (op) { +				case builtin_minus: +					if (ao_scheme_integer_typep(ct)) +						ret = ao_scheme_integer_poly(-ao_scheme_poly_integer(ret)); +					else if (ct == AO_SCHEME_FLOAT) +						ret = ao_scheme_float_get(-ao_scheme_poly_number(ret)); +					break; +				case builtin_divide: +					if (ao_scheme_integer_typep(ct) && ao_scheme_poly_integer(ret) == 1) +						; +					else if (ao_scheme_number_typep(ct)) { +						float	v = ao_scheme_poly_number(ret); +						ret = ao_scheme_float_get(1/v); +					} +					break; +				default: +					break; +				} +			} +			cons = ao_scheme_cons_fetch(0); +		} else if (ao_scheme_integer_typep(rt) && ao_scheme_integer_typep(ct)) { +			int32_t	r = ao_scheme_poly_integer(ret); +			int32_t	c = ao_scheme_poly_integer(car); +			int64_t t; + +			switch(op) { +			case builtin_plus: +				r += c; +			check_overflow: +				if (r < AO_SCHEME_MIN_BIGINT || AO_SCHEME_MAX_BIGINT < r) +					goto inexact; +				break; +			case builtin_minus: +				r -= c; +				goto check_overflow; +				break; +			case builtin_times: +				t = (int64_t) r * (int64_t) c; +				if (t < AO_SCHEME_MIN_BIGINT || AO_SCHEME_MAX_BIGINT < t) +					goto inexact; +				r = (int32_t) t; +				break; +			case builtin_divide: +				if (c != 0 && (r % c) == 0) +					r /= c; +				else +					goto inexact; +				break; +			case builtin_quotient: +				if (c == 0) +					return ao_scheme_error(AO_SCHEME_DIVIDE_BY_ZERO, "quotient by zero"); +				if (r % c != 0 && (c < 0) != (r < 0)) +					r = r / c - 1; +				else +					r = r / c; +				break; +			case builtin_remainder: +				if (c == 0) +					return ao_scheme_error(AO_SCHEME_DIVIDE_BY_ZERO, "remainder by zero"); +				r %= c; +				break; +			case builtin_modulo: +				if (c == 0) +					return ao_scheme_error(AO_SCHEME_DIVIDE_BY_ZERO, "modulo by zero"); +				r %= c; +				if ((r < 0) != (c < 0)) +					r += c; +				break; +			default: +				break; +			} +			ao_scheme_cons_stash(0, cons); +			ret = ao_scheme_integer_poly(r); +			cons = ao_scheme_cons_fetch(0); +		} else if (ao_scheme_number_typep(rt) && ao_scheme_number_typep(ct)) { +			float r, c; +		inexact: +			r = ao_scheme_poly_number(ret); +			c = ao_scheme_poly_number(car); +			switch(op) { +			case builtin_plus: +				r += c; +				break; +			case builtin_minus: +				r -= c; +				break; +			case builtin_times: +				r *= c; +				break; +			case builtin_divide: +				r /= c; +				break; +			case builtin_quotient: +			case builtin_remainder: +			case builtin_modulo: +				return ao_scheme_error(AO_SCHEME_INVALID, "non-integer value in integer divide"); +			default: +				break; +			} +			ao_scheme_cons_stash(0, cons); +			ret = ao_scheme_float_get(r); +			cons = ao_scheme_cons_fetch(0); +		} +		else if (rt == AO_SCHEME_STRING && ct == AO_SCHEME_STRING && op == builtin_plus) { +			ao_scheme_cons_stash(0, cons); +			ret = ao_scheme_string_poly(ao_scheme_string_cat(ao_scheme_poly_string(ret), +									 ao_scheme_poly_string(car))); +			cons = ao_scheme_cons_fetch(0); +			if (!ret) +				return ret; +		} +		else +			return ao_scheme_error(AO_SCHEME_INVALID, "invalid args"); +	} +	return ret; +} + +ao_poly +ao_scheme_do_plus(struct ao_scheme_cons *cons) +{ +	return ao_scheme_math(cons, builtin_plus); +} + +ao_poly +ao_scheme_do_minus(struct ao_scheme_cons *cons) +{ +	return ao_scheme_math(cons, builtin_minus); +} + +ao_poly +ao_scheme_do_times(struct ao_scheme_cons *cons) +{ +	return ao_scheme_math(cons, builtin_times); +} + +ao_poly +ao_scheme_do_divide(struct ao_scheme_cons *cons) +{ +	return ao_scheme_math(cons, builtin_divide); +} + +ao_poly +ao_scheme_do_quotient(struct ao_scheme_cons *cons) +{ +	return ao_scheme_math(cons, builtin_quotient); +} + +ao_poly +ao_scheme_do_modulo(struct ao_scheme_cons *cons) +{ +	return ao_scheme_math(cons, builtin_modulo); +} + +ao_poly +ao_scheme_do_remainder(struct ao_scheme_cons *cons) +{ +	return ao_scheme_math(cons, builtin_remainder); +} + +ao_poly +ao_scheme_compare(struct ao_scheme_cons *cons, enum ao_scheme_builtin_id op) +{ +	ao_poly	left; + +	if (!cons) +		return _ao_scheme_bool_true; + +	left = cons->car; +	for (cons = ao_scheme_cons_cdr(cons); cons; cons = ao_scheme_cons_cdr(cons)) { +		ao_poly	right = cons->car; + +		if (op == builtin_equal && left == right) { +			; +		} else { +			uint8_t	lt = ao_scheme_poly_type(left); +			uint8_t	rt = ao_scheme_poly_type(right); +			if (ao_scheme_integer_typep(lt) && ao_scheme_integer_typep(rt)) { +				int32_t l = ao_scheme_poly_integer(left); +				int32_t r = ao_scheme_poly_integer(right); + +				switch (op) { +				case builtin_less: +					if (!(l < r)) +						return _ao_scheme_bool_false; +					break; +				case builtin_greater: +					if (!(l > r)) +						return _ao_scheme_bool_false; +					break; +				case builtin_less_equal: +					if (!(l <= r)) +						return _ao_scheme_bool_false; +					break; +				case builtin_greater_equal: +					if (!(l >= r)) +						return _ao_scheme_bool_false; +					break; +				case builtin_equal: +					if (!(l == r)) +						return _ao_scheme_bool_false; +				default: +					break; +				} +			} else if (ao_scheme_number_typep(lt) && ao_scheme_number_typep(rt)) { +				float l, r; + +				l = ao_scheme_poly_number(left); +				r = ao_scheme_poly_number(right); + +				switch (op) { +				case builtin_less: +					if (!(l < r)) +						return _ao_scheme_bool_false; +					break; +				case builtin_greater: +					if (!(l > r)) +						return _ao_scheme_bool_false; +					break; +				case builtin_less_equal: +					if (!(l <= r)) +						return _ao_scheme_bool_false; +					break; +				case builtin_greater_equal: +					if (!(l >= r)) +						return _ao_scheme_bool_false; +					break; +				case builtin_equal: +					if (!(l == r)) +						return _ao_scheme_bool_false; +				default: +					break; +				} +			} else if (lt == AO_SCHEME_STRING && rt == AO_SCHEME_STRING) { +				int c = strcmp(ao_scheme_poly_string(left), +					       ao_scheme_poly_string(right)); +				switch (op) { +				case builtin_less: +					if (!(c < 0)) +						return _ao_scheme_bool_false; +					break; +				case builtin_greater: +					if (!(c > 0)) +						return _ao_scheme_bool_false; +					break; +				case builtin_less_equal: +					if (!(c <= 0)) +						return _ao_scheme_bool_false; +					break; +				case builtin_greater_equal: +					if (!(c >= 0)) +						return _ao_scheme_bool_false; +					break; +				case builtin_equal: +					if (!(c == 0)) +						return _ao_scheme_bool_false; +					break; +				default: +					break; +				} +			} else +				return _ao_scheme_bool_false; +		} +		left = right; +	} +	return _ao_scheme_bool_true; +} + +ao_poly +ao_scheme_do_equal(struct ao_scheme_cons *cons) +{ +	return ao_scheme_compare(cons, builtin_equal); +} + +ao_poly +ao_scheme_do_less(struct ao_scheme_cons *cons) +{ +	return ao_scheme_compare(cons, builtin_less); +} + +ao_poly +ao_scheme_do_greater(struct ao_scheme_cons *cons) +{ +	return ao_scheme_compare(cons, builtin_greater); +} + +ao_poly +ao_scheme_do_less_equal(struct ao_scheme_cons *cons) +{ +	return ao_scheme_compare(cons, builtin_less_equal); +} + +ao_poly +ao_scheme_do_greater_equal(struct ao_scheme_cons *cons) +{ +	return ao_scheme_compare(cons, builtin_greater_equal); +} + +ao_poly +ao_scheme_do_list_to_string(struct ao_scheme_cons *cons) +{ +	if (!ao_scheme_check_argc(_ao_scheme_atom_list2d3estring, cons, 1, 1)) +		return AO_SCHEME_NIL; +	if (!ao_scheme_check_argt(_ao_scheme_atom_list2d3estring, cons, 0, AO_SCHEME_CONS, 1)) +		return AO_SCHEME_NIL; +	return ao_scheme_string_pack(ao_scheme_poly_cons(ao_scheme_arg(cons, 0))); +} + +ao_poly +ao_scheme_do_string_to_list(struct ao_scheme_cons *cons) +{ +	if (!ao_scheme_check_argc(_ao_scheme_atom_string2d3elist, cons, 1, 1)) +		return AO_SCHEME_NIL; +	if (!ao_scheme_check_argt(_ao_scheme_atom_string2d3elist, cons, 0, AO_SCHEME_STRING, 0)) +		return AO_SCHEME_NIL; +	return ao_scheme_string_unpack(ao_scheme_poly_string(ao_scheme_arg(cons, 0))); +} + +ao_poly +ao_scheme_do_string_ref(struct ao_scheme_cons *cons) +{ +	char *string; +	int32_t ref; +	if (!ao_scheme_check_argc(_ao_scheme_atom_string2dref, cons, 2, 2)) +		return AO_SCHEME_NIL; +	if (!ao_scheme_check_argt(_ao_scheme_atom_string2dref, cons, 0, AO_SCHEME_STRING, 0)) +		return AO_SCHEME_NIL; +	ref = ao_scheme_arg_int(_ao_scheme_atom_string2dref, cons, 1); +	if (ref == AO_SCHEME_NOT_INTEGER) +		return AO_SCHEME_NIL; +	string = ao_scheme_poly_string(ao_scheme_arg(cons, 0)); +	while (*string && ref) { +		++string; +		--ref; +	} +	if (!*string) +		return ao_scheme_error(AO_SCHEME_INVALID, "%v: string %v ref %v invalid", +				       _ao_scheme_atom_string2dref, +				       ao_scheme_arg(cons, 0), +				       ao_scheme_arg(cons, 1)); +	return ao_scheme_int_poly(*string); +} + +ao_poly +ao_scheme_do_string_length(struct ao_scheme_cons *cons) +{ +	char *string; + +	if (!ao_scheme_check_argc(_ao_scheme_atom_string2dlength, cons, 1, 1)) +		return AO_SCHEME_NIL; +	if (!ao_scheme_check_argt(_ao_scheme_atom_string2dlength, cons, 0, AO_SCHEME_STRING, 0)) +		return AO_SCHEME_NIL; +	string = ao_scheme_poly_string(ao_scheme_arg(cons, 0)); +	return ao_scheme_integer_poly(strlen(string)); +} + +ao_poly +ao_scheme_do_string_copy(struct ao_scheme_cons *cons) +{ +	char *string; + +	if (!ao_scheme_check_argc(_ao_scheme_atom_string2dcopy, cons, 1, 1)) +		return AO_SCHEME_NIL; +	if (!ao_scheme_check_argt(_ao_scheme_atom_string2dcopy, cons, 0, AO_SCHEME_STRING, 0)) +		return AO_SCHEME_NIL; +	string = ao_scheme_poly_string(ao_scheme_arg(cons, 0)); +	return ao_scheme_string_poly(ao_scheme_string_copy(string)); +} + +ao_poly +ao_scheme_do_string_set(struct ao_scheme_cons *cons) +{ +	char *string; +	int32_t ref; +	int32_t val; + +	if (!ao_scheme_check_argc(_ao_scheme_atom_string2dset21, cons, 3, 3)) +		return AO_SCHEME_NIL; +	if (!ao_scheme_check_argt(_ao_scheme_atom_string2dset21, cons, 0, AO_SCHEME_STRING, 0)) +		return AO_SCHEME_NIL; +	string = ao_scheme_poly_string(ao_scheme_arg(cons, 0)); +	ref = ao_scheme_arg_int(_ao_scheme_atom_string2dset21, cons, 1); +	if (ref == AO_SCHEME_NOT_INTEGER) +		return AO_SCHEME_NIL; +	val = ao_scheme_arg_int(_ao_scheme_atom_string2dset21, cons, 2); +	if (val == AO_SCHEME_NOT_INTEGER) +		return AO_SCHEME_NIL; +	while (*string && ref) { +		++string; +		--ref; +	} +	if (!*string) +		return ao_scheme_error(AO_SCHEME_INVALID, "%v: string %v ref %v invalid", +				       _ao_scheme_atom_string2dset21, +				       ao_scheme_arg(cons, 0), +				       ao_scheme_arg(cons, 1)); +	*string = val; +	return ao_scheme_int_poly(*string); +} + +ao_poly +ao_scheme_do_flush_output(struct ao_scheme_cons *cons) +{ +	if (!ao_scheme_check_argc(_ao_scheme_atom_flush2doutput, cons, 0, 0)) +		return AO_SCHEME_NIL; +	ao_scheme_os_flush(); +	return _ao_scheme_bool_true; +} + +ao_poly +ao_scheme_do_led(struct ao_scheme_cons *cons) +{ +	int32_t led; +	if (!ao_scheme_check_argc(_ao_scheme_atom_led, cons, 1, 1)) +		return AO_SCHEME_NIL; +	led = ao_scheme_arg_int(_ao_scheme_atom_led, cons, 0); +	if (led == AO_SCHEME_NOT_INTEGER) +		return AO_SCHEME_NIL; +	led = ao_scheme_arg(cons, 0); +	ao_scheme_os_led(ao_scheme_poly_int(led)); +	return led; +} + +ao_poly +ao_scheme_do_delay(struct ao_scheme_cons *cons) +{ +	int32_t delay; + +	if (!ao_scheme_check_argc(_ao_scheme_atom_delay, cons, 1, 1)) +		return AO_SCHEME_NIL; +	delay = ao_scheme_arg_int(_ao_scheme_atom_delay, cons, 0); +	if (delay == AO_SCHEME_NOT_INTEGER) +		return AO_SCHEME_NIL; +	ao_scheme_os_delay(delay); +	return delay; +} + +ao_poly +ao_scheme_do_eval(struct ao_scheme_cons *cons) +{ +	if (!ao_scheme_check_argc(_ao_scheme_atom_eval, cons, 1, 1)) +		return AO_SCHEME_NIL; +	ao_scheme_stack->state = eval_sexpr; +	return cons->car; +} + +ao_poly +ao_scheme_do_apply(struct ao_scheme_cons *cons) +{ +	if (!ao_scheme_check_argc(_ao_scheme_atom_apply, cons, 2, INT_MAX)) +		return AO_SCHEME_NIL; +	ao_scheme_stack->state = eval_apply; +	return ao_scheme_cons_poly(cons); +} + +ao_poly +ao_scheme_do_read(struct ao_scheme_cons *cons) +{ +	if (!ao_scheme_check_argc(_ao_scheme_atom_read, cons, 0, 0)) +		return AO_SCHEME_NIL; +	return ao_scheme_read(); +} + +ao_poly +ao_scheme_do_collect(struct ao_scheme_cons *cons) +{ +	int	free; +	(void) cons; +	free = ao_scheme_collect(AO_SCHEME_COLLECT_FULL); +	return ao_scheme_integer_poly(free); +} + +ao_poly +ao_scheme_do_nullp(struct ao_scheme_cons *cons) +{ +	if (!ao_scheme_check_argc(_ao_scheme_atom_led, cons, 1, 1)) +		return AO_SCHEME_NIL; +	if (ao_scheme_arg(cons, 0) == AO_SCHEME_NIL) +		return _ao_scheme_bool_true; +	else +		return _ao_scheme_bool_false; +} + +ao_poly +ao_scheme_do_not(struct ao_scheme_cons *cons) +{ +	if (!ao_scheme_check_argc(_ao_scheme_atom_led, cons, 1, 1)) +		return AO_SCHEME_NIL; +	if (ao_scheme_arg(cons, 0) == _ao_scheme_bool_false) +		return _ao_scheme_bool_true; +	else +		return _ao_scheme_bool_false; +} + +static ao_poly +ao_scheme_do_typep(int type, struct ao_scheme_cons *cons) +{ +	if (!ao_scheme_check_argc(_ao_scheme_atom_led, cons, 1, 1)) +		return AO_SCHEME_NIL; +	if (ao_scheme_poly_type(ao_scheme_arg(cons, 0)) == type) +		return _ao_scheme_bool_true; +	return _ao_scheme_bool_false; +} + +ao_poly +ao_scheme_do_pairp(struct ao_scheme_cons *cons) +{ +	ao_poly	v; +	if (!ao_scheme_check_argc(_ao_scheme_atom_led, cons, 1, 1)) +		return AO_SCHEME_NIL; +	v = ao_scheme_arg(cons, 0); +	if (v != AO_SCHEME_NIL && ao_scheme_poly_type(v) == AO_SCHEME_CONS) +		return _ao_scheme_bool_true; +	return _ao_scheme_bool_false; +} + +ao_poly +ao_scheme_do_integerp(struct ao_scheme_cons *cons) +{ +	if (!ao_scheme_check_argc(_ao_scheme_atom_led, cons, 1, 1)) +		return AO_SCHEME_NIL; +	switch (ao_scheme_poly_type(ao_scheme_arg(cons, 0))) { +	case AO_SCHEME_INT: +	case AO_SCHEME_BIGINT: +		return _ao_scheme_bool_true; +	default: +		return _ao_scheme_bool_false; +	} +} + +ao_poly +ao_scheme_do_numberp(struct ao_scheme_cons *cons) +{ +	if (!ao_scheme_check_argc(_ao_scheme_atom_led, cons, 1, 1)) +		return AO_SCHEME_NIL; +	switch (ao_scheme_poly_type(ao_scheme_arg(cons, 0))) { +	case AO_SCHEME_INT: +	case AO_SCHEME_BIGINT: +	case AO_SCHEME_FLOAT: +		return _ao_scheme_bool_true; +	default: +		return _ao_scheme_bool_false; +	} +} + +ao_poly +ao_scheme_do_stringp(struct ao_scheme_cons *cons) +{ +	return ao_scheme_do_typep(AO_SCHEME_STRING, cons); +} + +ao_poly +ao_scheme_do_symbolp(struct ao_scheme_cons *cons) +{ +	return ao_scheme_do_typep(AO_SCHEME_ATOM, cons); +} + +ao_poly +ao_scheme_do_booleanp(struct ao_scheme_cons *cons) +{ +	return ao_scheme_do_typep(AO_SCHEME_BOOL, cons); +} + +ao_poly +ao_scheme_do_procedurep(struct ao_scheme_cons *cons) +{ +	if (!ao_scheme_check_argc(_ao_scheme_atom_led, cons, 1, 1)) +		return AO_SCHEME_NIL; +	switch (ao_scheme_poly_type(ao_scheme_arg(cons, 0))) { +	case AO_SCHEME_BUILTIN: +	case AO_SCHEME_LAMBDA: +		return _ao_scheme_bool_true; +	default: +	return _ao_scheme_bool_false; +	} +} + +/* This one is special -- a list is either nil or + * a 'proper' list with only cons cells + */ +ao_poly +ao_scheme_do_listp(struct ao_scheme_cons *cons) +{ +	ao_poly	v; +	if (!ao_scheme_check_argc(_ao_scheme_atom_list3f, cons, 1, 1)) +		return AO_SCHEME_NIL; +	v = ao_scheme_arg(cons, 0); +	for (;;) { +		if (v == AO_SCHEME_NIL) +			return _ao_scheme_bool_true; +		if (ao_scheme_poly_type(v) != AO_SCHEME_CONS) +			return _ao_scheme_bool_false; +		v = ao_scheme_poly_cons(v)->cdr; +	} +} + +ao_poly +ao_scheme_do_set_car(struct ao_scheme_cons *cons) +{ +	if (!ao_scheme_check_argc(_ao_scheme_atom_led, cons, 2, 2)) +		return AO_SCHEME_NIL; +	if (!ao_scheme_check_argt(_ao_scheme_atom_led, cons, 0, AO_SCHEME_CONS, 0)) +		return AO_SCHEME_NIL; +	return ao_scheme_poly_cons(ao_scheme_arg(cons, 0))->car = ao_scheme_arg(cons, 1); +} + +ao_poly +ao_scheme_do_set_cdr(struct ao_scheme_cons *cons) +{ +	if (!ao_scheme_check_argc(_ao_scheme_atom_led, cons, 2, 2)) +		return AO_SCHEME_NIL; +	if (!ao_scheme_check_argt(_ao_scheme_atom_led, cons, 0, AO_SCHEME_CONS, 0)) +		return AO_SCHEME_NIL; +	return ao_scheme_poly_cons(ao_scheme_arg(cons, 0))->cdr = ao_scheme_arg(cons, 1); +} + +ao_poly +ao_scheme_do_symbol_to_string(struct ao_scheme_cons *cons) +{ +	if (!ao_scheme_check_argc(_ao_scheme_atom_led, cons, 1, 1)) +		return AO_SCHEME_NIL; +	if (!ao_scheme_check_argt(_ao_scheme_atom_led, cons, 0, AO_SCHEME_ATOM, 0)) +		return AO_SCHEME_NIL; +	return ao_scheme_string_poly(ao_scheme_string_copy(ao_scheme_poly_atom(ao_scheme_arg(cons, 0))->name)); +} + +ao_poly +ao_scheme_do_string_to_symbol(struct ao_scheme_cons *cons) +{ +	if (!ao_scheme_check_argc(_ao_scheme_atom_led, cons, 1, 1)) +		return AO_SCHEME_NIL; +	if (!ao_scheme_check_argt(_ao_scheme_atom_led, cons, 0, AO_SCHEME_STRING, 0)) +		return AO_SCHEME_NIL; + +	return ao_scheme_atom_poly(ao_scheme_atom_intern(ao_scheme_poly_string(ao_scheme_arg(cons, 0)))); +} + +ao_poly +ao_scheme_do_read_char(struct ao_scheme_cons *cons) +{ +	int	c; +	if (!ao_scheme_check_argc(_ao_scheme_atom_led, cons, 0, 0)) +		return AO_SCHEME_NIL; +	c = getchar(); +	return ao_scheme_int_poly(c); +} + +ao_poly +ao_scheme_do_write_char(struct ao_scheme_cons *cons) +{ +	if (!ao_scheme_check_argc(_ao_scheme_atom_led, cons, 1, 1)) +		return AO_SCHEME_NIL; +	if (!ao_scheme_check_argt(_ao_scheme_atom_led, cons, 0, AO_SCHEME_INT, 0)) +		return AO_SCHEME_NIL; +	putchar(ao_scheme_poly_integer(ao_scheme_arg(cons, 0))); +	return _ao_scheme_bool_true; +} + +ao_poly +ao_scheme_do_exit(struct ao_scheme_cons *cons) +{ +	if (!ao_scheme_check_argc(_ao_scheme_atom_led, cons, 0, 0)) +		return AO_SCHEME_NIL; +	ao_scheme_exception |= AO_SCHEME_EXIT; +	return _ao_scheme_bool_true; +} + +ao_poly +ao_scheme_do_current_jiffy(struct ao_scheme_cons *cons) +{ +	int	jiffy; + +	if (!ao_scheme_check_argc(_ao_scheme_atom_led, cons, 0, 0)) +		return AO_SCHEME_NIL; +	jiffy = ao_scheme_os_jiffy(); +	return (ao_scheme_int_poly(jiffy)); +} + +ao_poly +ao_scheme_do_current_second(struct ao_scheme_cons *cons) +{ +	int	second; + +	if (!ao_scheme_check_argc(_ao_scheme_atom_led, cons, 0, 0)) +		return AO_SCHEME_NIL; +	second = ao_scheme_os_jiffy() / AO_SCHEME_JIFFIES_PER_SECOND; +	return (ao_scheme_int_poly(second)); +} + +ao_poly +ao_scheme_do_jiffies_per_second(struct ao_scheme_cons *cons) +{ +	if (!ao_scheme_check_argc(_ao_scheme_atom_led, cons, 0, 0)) +		return AO_SCHEME_NIL; +	return (ao_scheme_int_poly(AO_SCHEME_JIFFIES_PER_SECOND)); +} + +ao_poly +ao_scheme_do_vector(struct ao_scheme_cons *cons) +{ +	return ao_scheme_vector_poly(ao_scheme_list_to_vector(cons)); +} + +ao_poly +ao_scheme_do_make_vector(struct ao_scheme_cons *cons) +{ +	int32_t	k; + +	if (!ao_scheme_check_argc(_ao_scheme_atom_make2dvector, cons, 2, 2)) +		return AO_SCHEME_NIL; +	k = ao_scheme_arg_int(_ao_scheme_atom_make2dvector, cons, 0); +	if (k == AO_SCHEME_NOT_INTEGER) +		return AO_SCHEME_NIL; +	return ao_scheme_vector_poly(ao_scheme_vector_alloc(k, ao_scheme_arg(cons, 1))); +} + +ao_poly +ao_scheme_do_vector_ref(struct ao_scheme_cons *cons) +{ +	if (!ao_scheme_check_argc(_ao_scheme_atom_vector2dref, cons, 2, 2)) +		return AO_SCHEME_NIL; +	if (!ao_scheme_check_argt(_ao_scheme_atom_vector2dref, cons, 0, AO_SCHEME_VECTOR, 0)) +		return AO_SCHEME_NIL; +	return ao_scheme_vector_get(ao_scheme_arg(cons, 0), ao_scheme_arg(cons, 1)); +} + +ao_poly +ao_scheme_do_vector_set(struct ao_scheme_cons *cons) +{ +	if (!ao_scheme_check_argc(_ao_scheme_atom_vector2dset21, cons, 3, 3)) +		return AO_SCHEME_NIL; +	if (!ao_scheme_check_argt(_ao_scheme_atom_vector2dset21, cons, 0, AO_SCHEME_VECTOR, 0)) +		return AO_SCHEME_NIL; +	return ao_scheme_vector_set(ao_scheme_arg(cons, 0), ao_scheme_arg(cons, 1), ao_scheme_arg(cons, 2)); +} + +ao_poly +ao_scheme_do_list_to_vector(struct ao_scheme_cons *cons) +{ +	if (!ao_scheme_check_argc(_ao_scheme_atom_list2d3evector, cons, 1, 1)) +		return AO_SCHEME_NIL; +	if (!ao_scheme_check_argt(_ao_scheme_atom_list2d3evector, cons, 0, AO_SCHEME_CONS, 0)) +		return AO_SCHEME_NIL; +	return ao_scheme_vector_poly(ao_scheme_list_to_vector(ao_scheme_poly_cons(ao_scheme_arg(cons, 0)))); +} + +ao_poly +ao_scheme_do_vector_to_list(struct ao_scheme_cons *cons) +{ +	if (!ao_scheme_check_argc(_ao_scheme_atom_vector2d3elist, cons, 1, 1)) +		return AO_SCHEME_NIL; +	if (!ao_scheme_check_argt(_ao_scheme_atom_vector2d3elist, cons, 0, AO_SCHEME_VECTOR, 0)) +		return AO_SCHEME_NIL; +	return ao_scheme_cons_poly(ao_scheme_vector_to_list(ao_scheme_poly_vector(ao_scheme_arg(cons, 0)))); +} + +ao_poly +ao_scheme_do_vector_length(struct ao_scheme_cons *cons) +{ +	if (!ao_scheme_check_argc(_ao_scheme_atom_vector2d3elist, cons, 1, 1)) +		return AO_SCHEME_NIL; +	if (!ao_scheme_check_argt(_ao_scheme_atom_vector2d3elist, cons, 0, AO_SCHEME_VECTOR, 0)) +		return AO_SCHEME_NIL; +	return ao_scheme_integer_poly(ao_scheme_poly_vector(ao_scheme_arg(cons, 0))->length); +} + +ao_poly +ao_scheme_do_vectorp(struct ao_scheme_cons *cons) +{ +	return ao_scheme_do_typep(AO_SCHEME_VECTOR, cons); +} + +#define AO_SCHEME_BUILTIN_FUNCS +#include "ao_scheme_builtin.h" diff --git a/src/scheme/ao_scheme_builtin.txt b/src/scheme/ao_scheme_builtin.txt new file mode 100644 index 00000000..17f5ea0c --- /dev/null +++ b/src/scheme/ao_scheme_builtin.txt @@ -0,0 +1,81 @@ +f_lambda	eval +f_lambda	read +nlambda		lambda +nlambda		nlambda +nlambda		macro +f_lambda	car +f_lambda	cdr +f_lambda	cons +f_lambda	last +f_lambda	length +f_lambda	list_copy	list-copy +nlambda		quote +atom		quasiquote +atom		unquote +atom		unquote_splicing	unquote-splicing +f_lambda	set +macro		setq		set! +f_lambda	def +nlambda		cond +nlambda		begin +nlambda		while +f_lambda	write +f_lambda	display +f_lambda	plus		+	string-append +f_lambda	minus		- +f_lambda	times		* +f_lambda	divide		/ +f_lambda	modulo		modulo	% +f_lambda	remainder +f_lambda	quotient +f_lambda	equal		=	eq?	eqv? +f_lambda	less		<	string<? +f_lambda	greater		>	string>? +f_lambda	less_equal	<=	string<=? +f_lambda	greater_equal	>=	string>=? +f_lambda	flush_output		flush-output +f_lambda	delay +f_lambda	led +f_lambda	save +f_lambda	restore +f_lambda	call_cc		call-with-current-continuation	call/cc +f_lambda	collect +f_lambda	nullp		null? +f_lambda	not +f_lambda	listp		list? +f_lambda	pairp		pair? +f_lambda	integerp	integer? exact? exact-integer? +f_lambda	numberp		number? real? +f_lambda	booleanp	boolean? +f_lambda	set_car		set-car! +f_lambda	set_cdr		set-cdr! +f_lambda	symbolp		symbol? +f_lambda	list_to_string		list->string +f_lambda	string_to_list		string->list +f_lambda	symbol_to_string	symbol->string +f_lambda	string_to_symbol	string->symbol +f_lambda	stringp		string? +f_lambda	string_ref	string-ref +f_lambda	string_set	string-set! +f_lambda	string_copy	string-copy +f_lambda	string_length	string-length +f_lambda	procedurep	procedure? +lambda		apply +f_lambda	read_char	read-char +f_lambda	write_char	write-char +f_lambda	exit +f_lambda	current_jiffy	current-jiffy +f_lambda	current_second	current-second +f_lambda	jiffies_per_second	jiffies-per-second +f_lambda	finitep		finite? +f_lambda	infinitep	infinite? +f_lambda	inexactp	inexact? +f_lambda	sqrt +f_lambda	vector_ref	vector-ref +f_lambda	vector_set	vector-set! +f_lambda	vector +f_lambda	make_vector	make-vector +f_lambda	list_to_vector	list->vector +f_lambda	vector_to_list	vector->list +f_lambda	vector_length	vector-length +f_lambda	vectorp		vector? diff --git a/src/scheme/ao_scheme_cons.c b/src/scheme/ao_scheme_cons.c new file mode 100644 index 00000000..02512e15 --- /dev/null +++ b/src/scheme/ao_scheme_cons.c @@ -0,0 +1,237 @@ +/* + * Copyright © 2016 Keith Packard <keithp@keithp.com> + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation, either version 2 of the License, or + * (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, but + * WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU + * General Public License for more details. + */ + +#include "ao_scheme.h" + +static void cons_mark(void *addr) +{ +	struct ao_scheme_cons	*cons = addr; + +	for (;;) { +		ao_poly cdr = cons->cdr; + +		ao_scheme_poly_mark(cons->car, 1); +		if (!cdr) +			break; +		if (ao_scheme_poly_type(cdr) != AO_SCHEME_CONS) { +			ao_scheme_poly_mark(cdr, 1); +			break; +		} +		cons = ao_scheme_poly_cons(cdr); +		if (ao_scheme_mark_memory(&ao_scheme_cons_type, cons)) +			break; +	} +} + +static int cons_size(void *addr) +{ +	(void) addr; +	return sizeof (struct ao_scheme_cons); +} + +static void cons_move(void *addr) +{ +	struct ao_scheme_cons	*cons = addr; + +	if (!cons) +		return; + +	for (;;) { +		ao_poly			cdr; +		struct ao_scheme_cons	*c; +		int	ret; + +		MDBG_MOVE("cons_move start %d (%d, %d)\n", +			  MDBG_OFFSET(cons), MDBG_OFFSET(ao_scheme_ref(cons->car)), MDBG_OFFSET(ao_scheme_ref(cons->cdr))); +		(void) ao_scheme_poly_move(&cons->car, 1); +		cdr = cons->cdr; +		if (!cdr) +			break; +		if (ao_scheme_poly_base_type(cdr) != AO_SCHEME_CONS) { +			(void) ao_scheme_poly_move(&cons->cdr, 0); +			break; +		} +		c = ao_scheme_poly_cons(cdr); +		ret = ao_scheme_move_memory(&ao_scheme_cons_type, (void **) &c); +		if (c != ao_scheme_poly_cons(cons->cdr)) +			cons->cdr = ao_scheme_cons_poly(c); +		MDBG_MOVE("cons_move end %d (%d, %d)\n", +			  MDBG_OFFSET(cons), MDBG_OFFSET(ao_scheme_ref(cons->car)), MDBG_OFFSET(ao_scheme_ref(cons->cdr))); +		if (ret) +			break; +		cons = c; +	} +} + +const struct ao_scheme_type ao_scheme_cons_type = { +	.mark = cons_mark, +	.size = cons_size, +	.move = cons_move, +	.name = "cons", +}; + +struct ao_scheme_cons *ao_scheme_cons_free_list; + +struct ao_scheme_cons * +ao_scheme_cons_cons(ao_poly car, ao_poly cdr) +{ +	struct ao_scheme_cons	*cons; + +	if (ao_scheme_cons_free_list) { +		cons = ao_scheme_cons_free_list; +		ao_scheme_cons_free_list = ao_scheme_poly_cons(cons->cdr); +	} else { +		ao_scheme_poly_stash(0, car); +		ao_scheme_poly_stash(1, cdr); +		cons = ao_scheme_alloc(sizeof (struct ao_scheme_cons)); +		cdr = ao_scheme_poly_fetch(1); +		car = ao_scheme_poly_fetch(0); +		if (!cons) +			return NULL; +	} +	cons->car = car; +	cons->cdr = cdr; +	return cons; +} + +struct ao_scheme_cons * +ao_scheme_cons_cdr(struct ao_scheme_cons *cons) +{ +	ao_poly	cdr = cons->cdr; +	if (cdr == AO_SCHEME_NIL) +		return NULL; +	if (ao_scheme_poly_type(cdr) != AO_SCHEME_CONS) { +		(void) ao_scheme_error(AO_SCHEME_INVALID, "improper cdr %v", cdr); +		return NULL; +	} +	return ao_scheme_poly_cons(cdr); +} + +ao_poly +ao_scheme__cons(ao_poly car, ao_poly cdr) +{ +	return ao_scheme_cons_poly(ao_scheme_cons_cons(car, cdr)); +} + +struct ao_scheme_cons * +ao_scheme_cons_copy(struct ao_scheme_cons *cons) +{ +	struct ao_scheme_cons	*head = NULL; +	struct ao_scheme_cons	*tail = NULL; + +	while (cons) { +		struct ao_scheme_cons	*new; +		ao_poly cdr; + +		ao_scheme_cons_stash(0, cons); +		ao_scheme_cons_stash(1, head); +		ao_scheme_poly_stash(0, ao_scheme_cons_poly(tail)); +		new = ao_scheme_alloc(sizeof (struct ao_scheme_cons)); +		cons = ao_scheme_cons_fetch(0); +		head = ao_scheme_cons_fetch(1); +		tail = ao_scheme_poly_cons(ao_scheme_poly_fetch(0)); +		if (!new) +			return AO_SCHEME_NIL; +		new->car = cons->car; +		new->cdr = AO_SCHEME_NIL; +		if (!head) +			head = new; +		else +			tail->cdr = ao_scheme_cons_poly(new); +		tail = new; +		cdr = cons->cdr; +		if (ao_scheme_poly_type(cdr) != AO_SCHEME_CONS) { +			tail->cdr = cdr; +			break; +		} +		cons = ao_scheme_poly_cons(cdr); +	} +	return head; +} + +void +ao_scheme_cons_free(struct ao_scheme_cons *cons) +{ +#if DBG_FREE_CONS +	ao_scheme_cons_check(cons); +#endif +	while (cons) { +		ao_poly cdr = cons->cdr; +		cons->cdr = ao_scheme_cons_poly(ao_scheme_cons_free_list); +		ao_scheme_cons_free_list = cons; +		cons = ao_scheme_poly_cons(cdr); +	} +} + +void +ao_scheme_cons_write(ao_poly c) +{ +	struct ao_scheme_cons	*cons = ao_scheme_poly_cons(c); +	ao_poly			cdr; +	int			first = 1; + +	printf("("); +	while (cons) { +		if (!first) +			printf(" "); +		ao_scheme_poly_write(cons->car); +		cdr = cons->cdr; +		if (cdr == c) { +			printf(" ..."); +			break; +		} +		if (ao_scheme_poly_type(cdr) == AO_SCHEME_CONS) { +			cons = ao_scheme_poly_cons(cdr); +			first = 0; +		} else { +			printf(" . "); +			ao_scheme_poly_write(cdr); +			cons = NULL; +		} +	} +	printf(")"); +} + +void +ao_scheme_cons_display(ao_poly c) +{ +	struct ao_scheme_cons	*cons = ao_scheme_poly_cons(c); +	ao_poly			cdr; + +	while (cons) { +		ao_scheme_poly_display(cons->car); +		cdr = cons->cdr; +		if (cdr == c) { +			printf("..."); +			break; +		} +		if (ao_scheme_poly_type(cdr) == AO_SCHEME_CONS) +			cons = ao_scheme_poly_cons(cdr); +		else { +			ao_scheme_poly_display(cdr); +			cons = NULL; +		} +	} +} + +int +ao_scheme_cons_length(struct ao_scheme_cons *cons) +{ +	int	len = 0; +	while (cons) { +		len++; +		cons = ao_scheme_cons_cdr(cons); +	} +	return len; +} diff --git a/src/scheme/ao_scheme_const.scheme b/src/scheme/ao_scheme_const.scheme new file mode 100644 index 00000000..ab6a309a --- /dev/null +++ b/src/scheme/ao_scheme_const.scheme @@ -0,0 +1,813 @@ +; +; Copyright © 2016 Keith Packard <keithp@keithp.com> +; +; This program is free software; you can redistribute it and/or modify +; it under the terms of the GNU General Public License as published by +; the Free Software Foundation, either version 2 of the License, or +; (at your option) any later version. +; +; This program is distributed in the hope that it will be useful, but +; WITHOUT ANY WARRANTY; without even the implied warranty of +; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU +; General Public License for more details. +; +; Lisp code placed in ROM + +					; return a list containing all of the arguments +(def (quote list) (lambda l l)) + +(def (quote def!) +     (macro (name value) +	    (list +	     def +	     (list quote name) +	     value) +	    ) +     ) + +(begin + (def! append +   (lambda args +	  (def! append-list +	    (lambda (a b) +	      (cond ((null? a) b) +		    (else (cons (car a) (append-list (cdr a) b))) +		    ) +	      ) +	    ) +	     +	  (def! append-lists +	    (lambda (lists) +	      (cond ((null? lists) lists) +		    ((null? (cdr lists)) (car lists)) +		    (else (append-list (car lists) (append-lists (cdr lists)))) +		    ) +	      ) +	    ) +	  (append-lists args) +	  ) +   ) + 'append) + +(append '(a b c) '(d e f) '(g h i)) + +					; boolean operators + +(begin + (def! or +   (macro l +	  (def! _or +	    (lambda (l) +	      (cond ((null? l) #f) +		    ((null? (cdr l)) +		     (car l)) +		    (else +		     (list +		      cond +		      (list +		       (car l)) +		      (list +		       'else +		       (_or (cdr l)) +		       ) +		      ) +		     ) +		    ) +	      ) +	    ) +	  (_or l))) + 'or) + +					; execute to resolve macros + +(or #f #t) + +(begin + (def! and +   (macro l +	  (def! _and +	    (lambda (l) +	      (cond ((null? l) #t) +		    ((null? (cdr l)) +		     (car l)) +		    (else +		     (list +		      cond +		      (list +		       (car l) +		       (_and (cdr l)) +		       ) +		      ) +		     ) +		    ) +	      ) +	    ) +	  (_and l) +	  ) +   ) + 'and) + +					; execute to resolve macros + +(and #t #f) + +(begin + (def! quasiquote +   (macro (x) +	  (def! constant? +					; A constant value is either a pair starting with quote, +					; or anything which is neither a pair nor a symbol + +	    (lambda (exp) +	      (cond ((pair? exp) +		     (eq? (car exp) 'quote) +		     ) +		    (else +		     (not (symbol? exp)) +		     ) +		    ) +	      ) +	    ) +	  (def! combine-skeletons +	    (lambda (left right exp) +	      (cond +	       ((and (constant? left) (constant? right))  +		(cond ((and (eqv? (eval left) (car exp)) +			    (eqv? (eval right) (cdr exp))) +		       (list 'quote exp) +		       ) +		      (else +		       (list 'quote (cons (eval left) (eval right))) +		       ) +		      ) +		) +	       ((null? right) +		(list 'list left) +		) +	       ((and (pair? right) (eq? (car right) 'list)) +		(cons 'list (cons left (cdr right))) +		) +	       (else +		(list 'cons left right) +		) +	       ) +	      ) +	    ) + +	  (def! expand-quasiquote +	    (lambda (exp nesting) +	      (cond + +					; non cons -- constants +					; themselves, others are +					; quoted + +	       ((not (pair? exp))  +		(cond ((constant? exp) +		       exp +		       ) +		      (else +		       (list 'quote exp) +		       ) +		      ) +		) + +					; check for an unquote exp and +					; add the param unquoted + +	       ((and (eq? (car exp) 'unquote) (= (length exp) 2)) +		(cond ((= nesting 0) +		       (car (cdr exp)) +		       ) +		      (else +		       (combine-skeletons ''unquote  +					  (expand-quasiquote (cdr exp) (- nesting 1)) +					  exp)) +		      ) +		) + +					; nested quasi-quote -- +					; construct the right +					; expression + +	       ((and (eq? (car exp) 'quasiquote) (= (length exp) 2)) +		(combine-skeletons ''quasiquote  +				   (expand-quasiquote (cdr exp) (+ nesting 1)) +				   exp)) + +					; check for an +					; unquote-splicing member, +					; compute the expansion of the +					; value and append the rest of +					; the quasiquote result to it + +	       ((and (pair? (car exp)) +		     (eq? (car (car exp)) 'unquote-splicing) +		     (= (length (car exp)) 2)) +		(cond ((= nesting 0) +		       (list 'append (car (cdr (car exp))) +			     (expand-quasiquote (cdr exp) nesting)) +		       ) +		      (else +		       (combine-skeletons (expand-quasiquote (car exp) (- nesting 1)) +					  (expand-quasiquote (cdr exp) nesting) +					  exp)) +		      ) +		) + +					; for other lists, just glue +					; the expansion of the first +					; element to the expansion of +					; the rest of the list + +	       (else (combine-skeletons (expand-quasiquote (car exp) nesting) +					(expand-quasiquote (cdr exp) nesting) +					exp) +		     ) +	       ) +	      ) +	    ) +	  (def! result (expand-quasiquote x 0)) +	  result +	  ) +   ) + 'quasiquote) + +					; +					; Define a variable without returning the value +					; Useful when defining functions to avoid +					; having lots of output generated. +					; +					; Also accepts the alternate +					; form for defining lambdas of +					; (define (name x y z) sexprs ...)  +					; + +(begin + (def! define +   (macro (first . rest) +					; check for alternate lambda definition form + +	  (cond ((list? first) +		 (set! rest +		       (append +			(list +			 'lambda +			 (cdr first)) +			rest)) +		 (set! first (car first)) +		 ) +		(else +		 (set! rest (car rest)) +		 ) +		) +	  (def! result `(,begin +			 (,def (,quote ,first) ,rest) +			 (,quote ,first)) +	    ) +	  result +	  ) +   ) + 'define + ) + +					; basic list accessors + +(define (caar l) (car (car l))) + +(define (cadr l) (car (cdr l))) + +(define (cdar l) (cdr (car l))) + +(define (caddr l) (car (cdr (cdr l)))) + +					; (if <condition> <if-true>) +					; (if <condition> <if-true> <if-false) + +(define if +  (macro (test . args) +	 (cond ((null? (cdr args)) +		`(cond (,test ,(car args))) +		) +	       (else +		`(cond (,test ,(car args)) +		       (else ,(cadr args))) +		) +	       ) +	 ) +  ) + +(if (> 3 2) 'yes) +(if (> 3 2) 'yes 'no) +(if (> 2 3) 'no 'yes) +(if (> 2 3) 'no) + +					; simple math operators + +(define zero? (macro (value) `(eq? ,value 0))) + +(zero? 1) +(zero? 0) +(zero? "hello") + +(define positive? (macro (value) `(> ,value 0))) + +(positive? 12) +(positive? -12) + +(define negative? (macro (value) `(< ,value 0))) + +(negative? 12) +(negative? -12) + +(define (abs x) (if (>= x 0) x (- x))) + +(abs 12) +(abs -12) + +(define max (lambda (first . rest) +		   (while (not (null? rest)) +		     (cond ((< first (car rest)) +			    (set! first (car rest))) +			   ) +		     (set! rest (cdr rest)) +		     ) +		   first) +  ) + +(max 1 2 3) +(max 3 2 1) + +(define min (lambda (first . rest) +		   (while (not (null? rest)) +		     (cond ((> first (car rest)) +			    (set! first (car rest))) +			   ) +		     (set! rest (cdr rest)) +		     ) +		   first) +  ) + +(min 1 2 3) +(min 3 2 1) + +(define (even? x) (zero? (% x 2))) + +(even? 2) +(even? -2) +(even? 3) +(even? -1) + +(define (odd? x) (not (even? x))) + +(odd? 2) +(odd? -2) +(odd? 3) +(odd? -1) + + +(define (list-tail x k) +  (if (zero? k) +      x +    (list-tail (cdr x (- k 1))) +    ) +  ) + +(define (list-ref x k) +  (car (list-tail x k)) +  ) + +					; define a set of local +					; variables all at once and +					; then evaluate a list of +					; sexprs +					; +					; (let (var-defines) sexprs) +					; +					; where var-defines are either +					; +					; (name value) +					; +					; or +					; +					; (name) +					; +					; e.g. +					; +					; (let ((x 1) (y)) (set! y (+ x 1)) y) + +(define let +  (macro (vars . exprs) +	 (define (make-names vars) +	   (cond ((not (null? vars)) +		  (cons (car (car vars)) +			(make-names (cdr vars)))) +		 (else ()) +		 ) +	   ) + +					; the parameters to the lambda is a list +					; of nils of the right length + +	 (define (make-vals vars) +	   (cond ((not (null? vars)) +		  (cons (cond ((null? (cdr (car vars))) ()) +			      (else +			       (car (cdr (car vars)))) +			      ) +			(make-vals (cdr vars)))) +		 (else ()) +		 ) +	   ) +					; prepend the set operations +					; to the expressions + +					; build the lambda. + +	 `((lambda ,(make-names vars) ,@exprs) ,@(make-vals vars)) +	 ) +     ) +		    + +(let ((x 1) (y)) (set! y 2) (+ x y)) + +					; define a set of local +					; variables one at a time and +					; then evaluate a list of +					; sexprs +					; +					; (let* (var-defines) sexprs) +					; +					; where var-defines are either +					; +					; (name value) +					; +					; or +					; +					; (name) +					; +					; e.g. +					; +					; (let* ((x 1) (y)) (set! y (+ x 1)) y) + +(define let* +  (macro (vars . exprs) + +					; +					; make the list of names in the let +					; + +	 (define (make-names vars) +	   (cond ((not (null? vars)) +		  (cons (car (car vars)) +			(make-names (cdr vars)))) +		 (else ()) +		 ) +	   ) + +					; the set of expressions is +					; the list of set expressions +					; pre-pended to the +					; expressions to evaluate + +	 (define (make-exprs vars exprs) +	   (cond ((null? vars) exprs) +		 (else +		  (cons +		   (list set +			 (list quote +			       (car (car vars)) +			       ) +			 (cond ((null? (cdr (car vars))) ()) +			       (else (cadr (car vars)))) +			 ) +		   (make-exprs (cdr vars) exprs) +		   ) +		  ) +		 ) +	   ) + +					; the parameters to the lambda is a list +					; of nils of the right length + +	 (define (make-nils vars) +	   (cond ((null? vars) ()) +		 (else (cons () (make-nils (cdr vars)))) +		 ) +	   ) +					; build the lambda. + +	 `((lambda ,(make-names vars) ,@(make-exprs vars exprs)) ,@(make-nils vars)) +	 ) +     ) + +(let* ((x 1) (y x)) (+ x y)) + +(define when (macro (test . l) `(cond (,test ,@l)))) + +(when #t (write 'when)) + +(define unless (macro (test . l) `(cond ((not ,test) ,@l)))) + +(unless #f (write 'unless)) + +(define (reverse list) +  (let ((result ())) +    (while (not (null? list)) +      (set! result (cons (car list) result)) +      (set! list (cdr list)) +      ) +    result) +  ) + +(reverse '(1 2 3)) + +(define (list-tail x k) +  (if (zero? k) +      x +    (list-tail (cdr x) (- k 1)))) + +(list-tail '(1 2 3) 2) + +(define (list-ref x k) (car (list-tail x k))) + +(list-ref '(1 2 3) 2) +     +					; recursive equality + +(define (equal? a b) +  (cond ((eq? a b) #t) +	((and (pair? a) (pair? b)) +	 (and (equal? (car a) (car b)) +	      (equal? (cdr a) (cdr b))) +	 ) +	(else #f) +	) +  ) + +(equal? '(a b c) '(a b c)) +(equal? '(a b c) '(a b b)) + +(define member (lambda (obj list . test?) +		      (cond ((null? list) +			     #f +			     ) +			    (else +			     (if (null? test?) (set! test? equal?) (set! test? (car test?))) +			     (if (test? obj (car list)) +				 list +			       (member obj (cdr list) test?)) +			     ) +			    ) +		      ) +  ) + +(member '(2) '((1) (2) (3))) + +(member '(4) '((1) (2) (3))) + +(define (memq obj list) (member obj list eq?)) + +(memq 2 '(1 2 3)) + +(memq 4 '(1 2 3)) + +(memq '(2) '((1) (2) (3))) + +(define (memv obj list) (member obj list eqv?)) + +(memv 2 '(1 2 3)) + +(memv 4 '(1 2 3)) + +(memv '(2) '((1) (2) (3))) + +(define (_assoc obj list test?) +  (if (null? list) +      #f +    (if (test? obj (caar list)) +	(car list) +      (_assoc obj (cdr list) test?) +      ) +    ) +  ) + +(define (assq obj list) (_assoc obj list eq?)) +(define (assv obj list) (_assoc obj list eqv?)) +(define (assoc obj list) (_assoc obj list equal?)) + +(assq 'a '((a 1) (b 2) (c 3))) +(assv 'b '((a 1) (b 2) (c 3))) +(assoc '(c) '((a 1) (b 2) ((c) 3))) + +(define char? integer?) + +(char? #\q) +(char? "h") + +(define (char-upper-case? c) (<= #\A c #\Z)) + +(char-upper-case? #\a) +(char-upper-case? #\B) +(char-upper-case? #\0) +(char-upper-case? #\space) + +(define (char-lower-case? c) (<= #\a c #\a)) + +(char-lower-case? #\a) +(char-lower-case? #\B) +(char-lower-case? #\0) +(char-lower-case? #\space) + +(define (char-alphabetic? c) (or (char-upper-case? c) (char-lower-case? c))) + +(char-alphabetic? #\a) +(char-alphabetic? #\B) +(char-alphabetic? #\0) +(char-alphabetic? #\space) + +(define (char-numeric? c) (<= #\0 c #\9)) + +(char-numeric? #\a) +(char-numeric? #\B) +(char-numeric? #\0) +(char-numeric? #\space) + +(define (char-whitespace? c) (or (<= #\tab c #\return) (= #\space c))) + +(char-whitespace? #\a) +(char-whitespace? #\B) +(char-whitespace? #\0) +(char-whitespace? #\space) + +(define (char->integer c) c) +(define integer->char char->integer) + +(define (char-upcase c) (if (char-lower-case? c) (+ c (- #\A #\a)) c)) + +(char-upcase #\a) +(char-upcase #\B) +(char-upcase #\0) +(char-upcase #\space) + +(define (char-downcase c) (if (char-upper-case? c) (+ c (- #\a #\A)) c)) + +(char-downcase #\a) +(char-downcase #\B) +(char-downcase #\0) +(char-downcase #\space) + +(define string (lambda chars (list->string chars))) + +(display "apply\n") +(apply cons '(a b)) + +(define map +  (lambda (proc . lists) +	 (define (args lists) +	   (cond ((null? lists) ()) +		 (else +		  (cons (caar lists) (args (cdr lists))) +		  ) +		 ) +	   ) +	 (define (next lists) +	   (cond ((null? lists) ()) +		 (else +		  (cons (cdr (car lists)) (next (cdr lists))) +		  ) +		 ) +	   ) +	 (define (domap lists) +	   (cond ((null? (car lists)) ()) +		 (else +		  (cons (apply proc (args lists)) (domap (next lists))) +		  ) +		 ) +	   ) +	 (domap lists) +	 ) +  ) + +(map cadr '((a b) (d e) (g h))) + +(define for-each (lambda (proc . lists) +			(apply map proc lists) +			#t)) + +(for-each display '("hello" " " "world" "\n")) + +(define (_string-ml strings) +  (if (null? strings) () +    (cons (string->list (car strings)) (_string-ml (cdr strings))) +    ) +  ) + +(define string-map (lambda (proc . strings) +			  (list->string (apply map proc (_string-ml strings)))))) + +(string-map (lambda (x) (+ 1 x)) "HAL") + +(define string-for-each (lambda (proc . strings) +			       (apply for-each proc (_string-ml strings)))) + +(string-for-each write-char "IBM\n") + +(define (newline) (write-char #\newline)) + +(newline) + +(call-with-current-continuation + (lambda (exit) +   (for-each (lambda (x) +	       (write "test" x) +	       (if (negative? x) +		   (exit x))) +	     '(54 0 37 -3 245 19)) +   #t)) + + +					; `q -> (quote q) +					; `(q) -> (append (quote (q))) +					; `(a ,(+ 1 2)) -> (append (quote (a)) (list (+ 1 2))) +					; `(a ,@(list 1 2 3) -> (append (quote (a)) (list 1 2 3)) + + + +`(hello ,(+ 1 2) ,@(list 1 2 3) `foo) + + +(define repeat +  (macro (count . rest) +	 (define counter '__count__) +	 (cond ((pair? count) +		(set! counter (car count)) +		(set! count (cadr count)) +		) +	       ) +	 `(let ((,counter 0) +		(__max__ ,count) +		) +	    (while (< ,counter __max__) +	      ,@rest +	      (set! ,counter (+ ,counter 1)) +	      ) +	    ) +	 ) +  ) + +(repeat 2 (write 'hello)) +(repeat (x 3) (write 'goodbye x)) + +(define case +  (macro (test . l) +					; construct the body of the +					; case, dealing with the +					; lambda version ( => lambda) + +	 (define (_unarrow l) +	   (cond ((null? l) l) +		 ((eq? (car l) '=>) `(( ,(cadr l) __key__))) +		 (else l)) +	   ) + +					; Build the case elements, which is +					; simply a list of cond clauses + +	 (define (_case l) + +	   (cond ((null? l) ()) + +					; else case + +		 ((eq? (caar l) 'else) +		  `((else ,@(_unarrow (cdr (car l)))))) + +					; regular case +		  +		 (else +		  (cons +		   `((eqv? ,(caar l) __key__) +		     ,@(_unarrow (cdr (car l)))) +		   (_case (cdr l))) +		  ) +		 ) +	   ) + +					; now construct the overall +					; expression, using a lambda +					; to hold the computed value +					; of the test expression + +	 `((lambda (__key__) +	     (cond ,@(_case l))) ,test) +	 ) +  ) + +(case 12 (1 "one") (2 "two") (3 => (lambda (x) (write "the value is" x))) (12 "twelve") (else "else")) + +;(define number->string (lambda (arg . opt) +;			      (let ((base (if (null? opt) 10 (car opt))) +					; +; +				 diff --git a/src/scheme/ao_scheme_error.c b/src/scheme/ao_scheme_error.c new file mode 100644 index 00000000..d580a2c0 --- /dev/null +++ b/src/scheme/ao_scheme_error.c @@ -0,0 +1,139 @@ +/* + * Copyright © 2016 Keith Packard <keithp@keithp.com> + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation, either version 2 of the License, or + * (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, but + * WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU + * General Public License for more details. + */ + +#include "ao_scheme.h" +#include <stdarg.h> + +void +ao_scheme_error_poly(char *name, ao_poly poly, ao_poly last) +{ +	int first = 1; +	printf("\t\t%s(", name); +	if (ao_scheme_poly_type(poly) == AO_SCHEME_CONS) { +		if (poly) { +			while (poly) { +				struct ao_scheme_cons *cons = ao_scheme_poly_cons(poly); +				if (!first) +					printf("\t\t         "); +				else +					first = 0; +				ao_scheme_poly_write(cons->car); +				printf("\n"); +				if (poly == last) +					break; +				poly = cons->cdr; +			} +			printf("\t\t         )\n"); +		} else +			printf(")\n"); +	} else { +		ao_scheme_poly_write(poly); +		printf("\n"); +	} +} + +static void tabs(int indent) +{ +	while (indent--) +		printf("\t"); +} + +void +ao_scheme_error_frame(int indent, char *name, struct ao_scheme_frame *frame) +{ +	int			f; + +	tabs(indent); +	printf ("%s{", name); +	if (frame) { +		struct ao_scheme_frame_vals	*vals = ao_scheme_poly_frame_vals(frame->vals); +		if (frame->type & AO_SCHEME_FRAME_PRINT) +			printf("recurse..."); +		else { +			frame->type |= AO_SCHEME_FRAME_PRINT; +			for (f = 0; f < frame->num; f++) { +				if (f != 0) { +					tabs(indent); +					printf("         "); +				} +				ao_scheme_poly_write(vals->vals[f].atom); +				printf(" = "); +				ao_scheme_poly_write(vals->vals[f].val); +				printf("\n"); +			} +			if (frame->prev) +				ao_scheme_error_frame(indent + 1, "prev:   ", ao_scheme_poly_frame(frame->prev)); +			frame->type &= ~AO_SCHEME_FRAME_PRINT; +		} +		tabs(indent); +		printf("        }\n"); +	} else +		printf ("}\n"); +} + +void +ao_scheme_vprintf(char *format, va_list args) +{ +	char c; + +	while ((c = *format++) != '\0') { +		if (c == '%') { +			switch (c = *format++) { +			case 'v': +				ao_scheme_poly_write((ao_poly) va_arg(args, unsigned int)); +				break; +			case 'p': +				printf("%p", va_arg(args, void *)); +				break; +			case 'd': +				printf("%d", va_arg(args, int)); +				break; +			case 's': +				printf("%s", va_arg(args, char *)); +				break; +			default: +				putchar(c); +				break; +			} +		} else +			putchar(c); +	} +} + +void +ao_scheme_printf(char *format, ...) +{ +	va_list args; +	va_start(args, format); +	ao_scheme_vprintf(format, args); +	va_end(args); +} + +ao_poly +ao_scheme_error(int error, char *format, ...) +{ +	va_list	args; + +	ao_scheme_exception |= error; +	va_start(args, format); +	ao_scheme_vprintf(format, args); +	putchar('\n'); +	va_end(args); +	ao_scheme_printf("Value:  %v\n", ao_scheme_v); +	ao_scheme_printf("Frame:  %v\n", ao_scheme_frame_poly(ao_scheme_frame_current)); +	printf("Stack:\n"); +	ao_scheme_stack_write(ao_scheme_stack_poly(ao_scheme_stack)); +	ao_scheme_printf("Globals: %v\n", ao_scheme_frame_poly(ao_scheme_frame_global)); +	return AO_SCHEME_NIL; +} diff --git a/src/scheme/ao_scheme_eval.c b/src/scheme/ao_scheme_eval.c new file mode 100644 index 00000000..907ecf0b --- /dev/null +++ b/src/scheme/ao_scheme_eval.c @@ -0,0 +1,572 @@ +/* + * Copyright © 2016 Keith Packard <keithp@keithp.com> + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation, either version 2 of the License, or + * (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, but + * WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU + * General Public License for more details. + */ + +#include "ao_scheme.h" +#include <assert.h> + +struct ao_scheme_stack		*ao_scheme_stack; +ao_poly				ao_scheme_v; +uint8_t				ao_scheme_skip_cons_free; + +ao_poly +ao_scheme_set_cond(struct ao_scheme_cons *c) +{ +	ao_scheme_stack->state = eval_cond; +	ao_scheme_stack->sexprs = ao_scheme_cons_poly(c); +	return AO_SCHEME_NIL; +} + +static int +func_type(ao_poly func) +{ +	if (func == AO_SCHEME_NIL) +		return ao_scheme_error(AO_SCHEME_INVALID, "func is nil"); +	switch (ao_scheme_poly_type(func)) { +	case AO_SCHEME_BUILTIN: +		return ao_scheme_poly_builtin(func)->args & AO_SCHEME_FUNC_MASK; +	case AO_SCHEME_LAMBDA: +		return ao_scheme_poly_lambda(func)->args; +	case AO_SCHEME_STACK: +		return AO_SCHEME_FUNC_LAMBDA; +	default: +		ao_scheme_error(AO_SCHEME_INVALID, "not a func"); +		return -1; +	} +} + +/* + * Flattened eval to avoid stack issues + */ + +/* + * Evaluate an s-expression + * + * For a list, evaluate all of the elements and + * then execute the resulting function call. + * + * Each element of the list is evaluated in + * a clean stack context. + * + * The current stack state is set to 'formal' so that + * when the evaluation is complete, the value + * will get appended to the values list. + * + * For other types, compute the value directly. + */ + +static int +ao_scheme_eval_sexpr(void) +{ +	DBGI("sexpr: %v\n", ao_scheme_v); +	switch (ao_scheme_poly_type(ao_scheme_v)) { +	case AO_SCHEME_CONS: +		if (ao_scheme_v == AO_SCHEME_NIL) { +			if (!ao_scheme_stack->values) { +				/* +				 * empty list evaluates to empty list +				 */ +				ao_scheme_v = AO_SCHEME_NIL; +				ao_scheme_stack->state = eval_val; +			} else { +				/* +				 * done with arguments, go execute it +				 */ +				ao_scheme_v = ao_scheme_poly_cons(ao_scheme_stack->values)->car; +				ao_scheme_stack->state = eval_exec; +			} +		} else { +			if (!ao_scheme_stack->values) +				ao_scheme_stack->list = ao_scheme_v; +			/* +			 * Evaluate another argument and then switch +			 * to 'formal' to add the value to the values +			 * list +			 */ +			ao_scheme_stack->sexprs = ao_scheme_v; +			ao_scheme_stack->state = eval_formal; +			if (!ao_scheme_stack_push()) +				return 0; +			/* +			 * push will reset the state to 'sexpr', which +			 * will evaluate the expression +			 */ +			ao_scheme_v = ao_scheme_poly_cons(ao_scheme_v)->car; +		} +		break; +	case AO_SCHEME_ATOM: +		DBGI("..frame "); DBG_POLY(ao_scheme_frame_poly(ao_scheme_frame_current)); DBG("\n"); +		ao_scheme_v = ao_scheme_atom_get(ao_scheme_v); +		/* fall through */ +	default: +		ao_scheme_stack->state = eval_val; +		break; +	} +	DBGI(".. result "); DBG_POLY(ao_scheme_v); DBG("\n"); +	return 1; +} + +/* + * A value has been computed. + * + * If the value was computed from a macro, + * then we want to reset the current context + * to evaluate the macro result again. + * + * If not a macro, then pop the stack. + * If the stack is empty, we're done. + * Otherwise, the stack will contain + * the next state. + */ + +static int +ao_scheme_eval_val(void) +{ +	DBGI("val: "); DBG_POLY(ao_scheme_v); DBG("\n"); +	/* +	 * Value computed, pop the stack +	 * to figure out what to do with the value +	 */ +	ao_scheme_stack_pop(); +	DBGI("..state %d\n", ao_scheme_stack ? ao_scheme_stack->state : -1); +	return 1; +} + +/* + * A formal has been computed. + * + * If this is the first formal, then check to see if we've got a + * lamda, macro or nlambda. + * + * For lambda, go compute another formal.  This will terminate + * when the sexpr state sees nil. + * + * For macro/nlambda, we're done, so move the sexprs into the values + * and go execute it. + * + * Macros have an additional step of saving a stack frame holding the + * macro value execution context, which then gets the result of the + * macro to run + */ + +static int +ao_scheme_eval_formal(void) +{ +	ao_poly			formal; +	struct ao_scheme_stack	*prev; + +	DBGI("formal: "); DBG_POLY(ao_scheme_v); DBG("\n"); + +	/* Check what kind of function we've got */ +	if (!ao_scheme_stack->values) { +		switch (func_type(ao_scheme_v)) { +		case AO_SCHEME_FUNC_LAMBDA: +			DBGI(".. lambda\n"); +			break; +		case AO_SCHEME_FUNC_MACRO: +			/* Evaluate the result once more */ +			ao_scheme_stack->state = eval_macro; +			if (!ao_scheme_stack_push()) +				return 0; + +			/* After the function returns, take that +			 * value and re-evaluate it +			 */ +			prev = ao_scheme_poly_stack(ao_scheme_stack->prev); +			ao_scheme_stack->sexprs = prev->sexprs; + +			DBGI(".. start macro\n"); +			DBGI("\t.. sexprs       "); DBG_POLY(ao_scheme_stack->sexprs); DBG("\n"); +			DBGI("\t.. values       "); DBG_POLY(ao_scheme_stack->values); DBG("\n"); +			DBG_FRAMES(); + +			/* fall through ... */ +		case AO_SCHEME_FUNC_NLAMBDA: +			DBGI(".. nlambda or macro\n"); + +			/* use the raw sexprs as values */ +			ao_scheme_stack->values = ao_scheme_stack->sexprs; +			ao_scheme_stack->values_tail = AO_SCHEME_NIL; +			ao_scheme_stack->state = eval_exec; + +			/* ready to execute now */ +			return 1; +		case -1: +			return 0; +		} +	} + +	/* Append formal to list of values */ +	formal = ao_scheme__cons(ao_scheme_v, AO_SCHEME_NIL); +	if (!formal) +		return 0; + +	if (ao_scheme_stack->values_tail) +		ao_scheme_poly_cons(ao_scheme_stack->values_tail)->cdr = formal; +	else +		ao_scheme_stack->values = formal; +	ao_scheme_stack->values_tail = formal; + +	DBGI(".. values "); DBG_POLY(ao_scheme_stack->values); DBG("\n"); + +	/* +	 * Step to the next argument, if this is last, then +	 * 'sexpr' will end up switching to 'exec' +	 */ +	ao_scheme_v = ao_scheme_poly_cons(ao_scheme_stack->sexprs)->cdr; + +	ao_scheme_stack->state = eval_sexpr; + +	DBGI(".. "); DBG_POLY(ao_scheme_v); DBG("\n"); +	return 1; +} + +/* + * Start executing a function call + * + * Most builtins are easy, just call the function. + * 'cond' is magic; it sticks the list of clauses + * in 'sexprs' and switches to 'cond' state. That + * bit of magic is done in ao_scheme_set_cond. + * + * Lambdas build a new frame to hold the locals and + * then re-use the current stack context to evaluate + * the s-expression from the lambda. + */ + +static int +ao_scheme_eval_exec(void) +{ +	ao_poly v; +	struct ao_scheme_builtin	*builtin; + +	DBGI("exec: "); DBG_POLY(ao_scheme_v); DBG(" values "); DBG_POLY(ao_scheme_stack->values); DBG ("\n"); +	ao_scheme_stack->sexprs = AO_SCHEME_NIL; +	switch (ao_scheme_poly_type(ao_scheme_v)) { +	case AO_SCHEME_BUILTIN: +		ao_scheme_stack->state = eval_val; +		builtin = ao_scheme_poly_builtin(ao_scheme_v); +		v = ao_scheme_func(builtin) ( +			ao_scheme_poly_cons(ao_scheme_poly_cons(ao_scheme_stack->values)->cdr)); +		DBG_DO(if (!ao_scheme_exception && ao_scheme_poly_builtin(ao_scheme_v)->func == builtin_set) { +				struct ao_scheme_cons *cons = ao_scheme_poly_cons(ao_scheme_stack->values); +				ao_poly atom = ao_scheme_arg(cons, 1); +				ao_poly val = ao_scheme_arg(cons, 2); +				DBGI("set "); DBG_POLY(atom); DBG(" = "); DBG_POLY(val); DBG("\n"); +			}); +		builtin = ao_scheme_poly_builtin(ao_scheme_v); +		if (builtin && (builtin->args & AO_SCHEME_FUNC_FREE_ARGS) && !ao_scheme_stack_marked(ao_scheme_stack) && !ao_scheme_skip_cons_free) { +			struct ao_scheme_cons *cons = ao_scheme_poly_cons(ao_scheme_stack->values); +			ao_scheme_stack->values = AO_SCHEME_NIL; +			ao_scheme_cons_free(cons); +		} + +		ao_scheme_v = v; +		ao_scheme_stack->values = AO_SCHEME_NIL; +		ao_scheme_stack->values_tail = AO_SCHEME_NIL; +		DBGI(".. result "); DBG_POLY(ao_scheme_v); DBG ("\n"); +		DBGI(".. frame "); DBG_POLY(ao_scheme_frame_poly(ao_scheme_frame_current)); DBG("\n"); +		break; +	case AO_SCHEME_LAMBDA: +		DBGI(".. frame "); DBG_POLY(ao_scheme_frame_poly(ao_scheme_frame_current)); DBG("\n"); +		ao_scheme_stack->state = eval_begin; +		v = ao_scheme_lambda_eval(); +		ao_scheme_stack->sexprs = v; +		ao_scheme_stack->values = AO_SCHEME_NIL; +		ao_scheme_stack->values_tail = AO_SCHEME_NIL; +		DBGI(".. sexprs "); DBG_POLY(ao_scheme_stack->sexprs); DBG("\n"); +		DBGI(".. frame "); DBG_POLY(ao_scheme_frame_poly(ao_scheme_frame_current)); DBG("\n"); +		break; +	case AO_SCHEME_STACK: +		DBGI(".. stack "); DBG_POLY(ao_scheme_v); DBG("\n"); +		ao_scheme_v = ao_scheme_stack_eval(); +		DBGI(".. value "); DBG_POLY(ao_scheme_v); DBG("\n"); +		DBGI(".. frame "); DBG_POLY(ao_scheme_frame_poly(ao_scheme_frame_current)); DBG("\n"); +		break; +	} +	ao_scheme_skip_cons_free = 0; +	return 1; +} + +/* + * Finish setting up the apply evaluation + * + * The value is the list to execute + */ +static int +ao_scheme_eval_apply(void) +{ +	struct ao_scheme_cons	*cons = ao_scheme_poly_cons(ao_scheme_v); +	struct ao_scheme_cons	*cdr, *prev; + +	/* Glue the arguments into the right shape. That's all but the last +	 * concatenated onto the last +	 */ +	cdr = cons; +	for (;;) { +		prev = cdr; +		cdr = ao_scheme_poly_cons(prev->cdr); +		if (cdr->cdr == AO_SCHEME_NIL) +			break; +	} +	DBGI("before mangling: "); DBG_POLY(ao_scheme_v); DBG("\n"); +	prev->cdr = cdr->car; +	ao_scheme_stack->values = ao_scheme_v; +	ao_scheme_v = ao_scheme_poly_cons(ao_scheme_stack->values)->car; +	DBGI("apply: "); DBG_POLY(ao_scheme_stack->values); DBG ("\n"); +	ao_scheme_stack->state = eval_exec; +	ao_scheme_skip_cons_free = 1; +	return 1; +} + +/* + * Start evaluating the next cond clause + * + * If the list of clauses is empty, then + * the result of the cond is nil. + * + * Otherwise, set the current stack state to 'cond_test' and create a + * new stack context to evaluate the test s-expression. Once that's + * complete, we'll land in 'cond_test' to finish the clause. + */ +static int +ao_scheme_eval_cond(void) +{ +	DBGI("cond: "); DBG_POLY(ao_scheme_stack->sexprs); DBG("\n"); +	DBGI(".. frame "); DBG_POLY(ao_scheme_frame_poly(ao_scheme_frame_current)); DBG("\n"); +	DBGI(".. saved frame "); DBG_POLY(ao_scheme_stack->frame); DBG("\n"); +	if (!ao_scheme_stack->sexprs) { +		ao_scheme_v = _ao_scheme_bool_false; +		ao_scheme_stack->state = eval_val; +	} else { +		ao_scheme_v = ao_scheme_poly_cons(ao_scheme_stack->sexprs)->car; +		if (!ao_scheme_v || ao_scheme_poly_type(ao_scheme_v) != AO_SCHEME_CONS) { +			ao_scheme_error(AO_SCHEME_INVALID, "invalid cond clause"); +			return 0; +		} +		ao_scheme_v = ao_scheme_poly_cons(ao_scheme_v)->car; +		if (ao_scheme_v == _ao_scheme_atom_else) +			ao_scheme_v = _ao_scheme_bool_true; +		ao_scheme_stack->state = eval_cond_test; +		if (!ao_scheme_stack_push()) +			return 0; +	} +	return 1; +} + +/* + * Finish a cond clause. + * + * Check the value from the test expression, if + * non-nil, then set up to evaluate the value expression. + * + * Otherwise, step to the next clause and go back to the 'cond' + * state + */ +static int +ao_scheme_eval_cond_test(void) +{ +	DBGI("cond_test: "); DBG_POLY(ao_scheme_v); DBG(" sexprs "); DBG_POLY(ao_scheme_stack->sexprs); DBG("\n"); +	DBGI(".. frame "); DBG_POLY(ao_scheme_frame_poly(ao_scheme_frame_current)); DBG("\n"); +	DBGI(".. saved frame "); DBG_POLY(ao_scheme_stack->frame); DBG("\n"); +	if (ao_scheme_v != _ao_scheme_bool_false) { +		struct ao_scheme_cons *car = ao_scheme_poly_cons(ao_scheme_poly_cons(ao_scheme_stack->sexprs)->car); +		ao_poly c = car->cdr; + +		if (c) { +			ao_scheme_stack->state = eval_begin; +			ao_scheme_stack->sexprs = c; +		} else +			ao_scheme_stack->state = eval_val; +	} else { +		ao_scheme_stack->sexprs = ao_scheme_poly_cons(ao_scheme_stack->sexprs)->cdr; +		DBGI("next cond: "); DBG_POLY(ao_scheme_stack->sexprs); DBG("\n"); +		ao_scheme_stack->state = eval_cond; +	} +	return 1; +} + +/* + * Evaluate a list of sexprs, returning the value from the last one. + * + * ao_scheme_begin records the list in stack->sexprs, so we just need to + * walk that list. Set ao_scheme_v to the car of the list and jump to + * eval_sexpr. When that's done, it will land in eval_val. For all but + * the last, leave a stack frame with eval_begin set so that we come + * back here. For the last, don't add a stack frame so that we can + * just continue on. + */ +static int +ao_scheme_eval_begin(void) +{ +	DBGI("begin: "); DBG_POLY(ao_scheme_v); DBG(" sexprs "); DBG_POLY(ao_scheme_stack->sexprs); DBG("\n"); +	DBGI(".. frame "); DBG_POLY(ao_scheme_frame_poly(ao_scheme_frame_current)); DBG("\n"); +	DBGI(".. saved frame "); DBG_POLY(ao_scheme_stack->frame); DBG("\n"); + +	if (!ao_scheme_stack->sexprs) { +		ao_scheme_v = AO_SCHEME_NIL; +		ao_scheme_stack->state = eval_val; +	} else { +		ao_scheme_v = ao_scheme_poly_cons(ao_scheme_stack->sexprs)->car; +		ao_scheme_stack->sexprs = ao_scheme_poly_cons(ao_scheme_stack->sexprs)->cdr; + +		/* If there are more sexprs to do, then come back here, otherwise +		 * return the value of the last one by just landing in eval_sexpr +		 */ +		if (ao_scheme_stack->sexprs) { +			ao_scheme_stack->state = eval_begin; +			if (!ao_scheme_stack_push()) +				return 0; +		} +		ao_scheme_stack->state = eval_sexpr; +	} +	return 1; +} + +/* + * Conditionally execute a list of sexprs while the first is true + */ +static int +ao_scheme_eval_while(void) +{ +	DBGI("while: "); DBG_POLY(ao_scheme_stack->sexprs); DBG("\n"); +	DBGI(".. frame "); DBG_POLY(ao_scheme_frame_poly(ao_scheme_frame_current)); DBG("\n"); +	DBGI(".. saved frame "); DBG_POLY(ao_scheme_stack->frame); DBG("\n"); + +	ao_scheme_stack->values = ao_scheme_v; +	if (!ao_scheme_stack->sexprs) { +		ao_scheme_v = AO_SCHEME_NIL; +		ao_scheme_stack->state = eval_val; +	} else { +		ao_scheme_v = ao_scheme_poly_cons(ao_scheme_stack->sexprs)->car; +		ao_scheme_stack->state = eval_while_test; +		if (!ao_scheme_stack_push()) +			return 0; +	} +	return 1; +} + +/* + * Check the while condition, terminate the loop if nil. Otherwise keep going + */ +static int +ao_scheme_eval_while_test(void) +{ +	DBGI("while_test: "); DBG_POLY(ao_scheme_v); DBG(" sexprs "); DBG_POLY(ao_scheme_stack->sexprs); DBG("\n"); +	DBGI(".. frame "); DBG_POLY(ao_scheme_frame_poly(ao_scheme_frame_current)); DBG("\n"); +	DBGI(".. saved frame "); DBG_POLY(ao_scheme_stack->frame); DBG("\n"); + +	if (ao_scheme_v != _ao_scheme_bool_false) { +		ao_scheme_stack->values = ao_scheme_v; +		ao_scheme_v = ao_scheme_poly_cons(ao_scheme_stack->sexprs)->cdr; +		ao_scheme_stack->state = eval_while; +		if (!ao_scheme_stack_push()) +			return 0; +		ao_scheme_stack->state = eval_begin; +		ao_scheme_stack->sexprs = ao_scheme_v; +	} +	else +	{ +		ao_scheme_stack->state = eval_val; +		ao_scheme_v = ao_scheme_stack->values; +	} +	return 1; +} + +/* + * Replace the original sexpr with the macro expansion, then + * execute that + */ +static int +ao_scheme_eval_macro(void) +{ +	DBGI("macro: "); DBG_POLY(ao_scheme_v); DBG(" sexprs "); DBG_POLY(ao_scheme_stack->sexprs); DBG("\n"); + +	if (ao_scheme_v == AO_SCHEME_NIL) +		ao_scheme_abort(); +	if (ao_scheme_poly_type(ao_scheme_v) == AO_SCHEME_CONS) { +		*ao_scheme_poly_cons(ao_scheme_stack->sexprs) = *ao_scheme_poly_cons(ao_scheme_v); +		ao_scheme_v = ao_scheme_stack->sexprs; +		DBGI("sexprs rewritten to: "); DBG_POLY(ao_scheme_v); DBG("\n"); +	} +	ao_scheme_stack->sexprs = AO_SCHEME_NIL; +	ao_scheme_stack->state = eval_sexpr; +	return 1; +} + +static int (*const evals[])(void) = { +	[eval_sexpr] = ao_scheme_eval_sexpr, +	[eval_val] = ao_scheme_eval_val, +	[eval_formal] = ao_scheme_eval_formal, +	[eval_exec] = ao_scheme_eval_exec, +	[eval_apply] = ao_scheme_eval_apply, +	[eval_cond] = ao_scheme_eval_cond, +	[eval_cond_test] = ao_scheme_eval_cond_test, +	[eval_begin] = ao_scheme_eval_begin, +	[eval_while] = ao_scheme_eval_while, +	[eval_while_test] = ao_scheme_eval_while_test, +	[eval_macro] = ao_scheme_eval_macro, +}; + +const char * const ao_scheme_state_names[] = { +	[eval_sexpr] = "sexpr", +	[eval_val] = "val", +	[eval_formal] = "formal", +	[eval_exec] = "exec", +	[eval_apply] = "apply", +	[eval_cond] = "cond", +	[eval_cond_test] = "cond_test", +	[eval_begin] = "begin", +	[eval_while] = "while", +	[eval_while_test] = "while_test", +	[eval_macro] = "macro", +}; + +/* + * Called at restore time to reset all execution state + */ + +void +ao_scheme_eval_clear_globals(void) +{ +	ao_scheme_stack = NULL; +	ao_scheme_frame_current = NULL; +	ao_scheme_v = AO_SCHEME_NIL; +} + +int +ao_scheme_eval_restart(void) +{ +	return ao_scheme_stack_push(); +} + +ao_poly +ao_scheme_eval(ao_poly _v) +{ +	ao_scheme_v = _v; + +	ao_scheme_frame_init(); + +	if (!ao_scheme_stack_push()) +		return AO_SCHEME_NIL; + +	while (ao_scheme_stack) { +		if (!(*evals[ao_scheme_stack->state])() || ao_scheme_exception) { +			ao_scheme_stack_clear(); +			return AO_SCHEME_NIL; +		} +	} +	DBG_DO(if (ao_scheme_frame_current) {DBGI("frame left as "); DBG_POLY(ao_scheme_frame_poly(ao_scheme_frame_current)); DBG("\n");}); +	ao_scheme_frame_current = NULL; +	return ao_scheme_v; +} diff --git a/src/scheme/ao_scheme_float.c b/src/scheme/ao_scheme_float.c new file mode 100644 index 00000000..99249030 --- /dev/null +++ b/src/scheme/ao_scheme_float.c @@ -0,0 +1,152 @@ +/* + * Copyright © 2017 Keith Packard <keithp@keithp.com> + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation, either version 2 of the License, or + * (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, but + * WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU + * General Public License for more details. + */ + +#include "ao_scheme.h" +#include <math.h> + +static void float_mark(void *addr) +{ +	(void) addr; +} + +static int float_size(void *addr) +{ +	if (!addr) +		return 0; +	return sizeof (struct ao_scheme_float); +} + +static void float_move(void *addr) +{ +	(void) addr; +} + +const struct ao_scheme_type ao_scheme_float_type = { +	.mark = float_mark, +	.size = float_size, +	.move = float_move, +	.name = "float", +}; + +#ifndef FLOAT_FORMAT +#define FLOAT_FORMAT "%g" +#endif + +void +ao_scheme_float_write(ao_poly p) +{ +	struct ao_scheme_float *f = ao_scheme_poly_float(p); +	float	v = f->value; + +	if (isnanf(v)) +		printf("+nan.0"); +	else if (isinff(v)) { +		if (v < 0) +			printf("-"); +		else +			printf("+"); +		printf("inf.0"); +	} else +		printf (FLOAT_FORMAT, v); +} + +float +ao_scheme_poly_number(ao_poly p) +{ +	switch (ao_scheme_poly_base_type(p)) { +	case AO_SCHEME_INT: +		return ao_scheme_poly_int(p); +	case AO_SCHEME_OTHER: +		switch (ao_scheme_other_type(ao_scheme_poly_other(p))) { +		case AO_SCHEME_BIGINT: +			return ao_scheme_bigint_int(ao_scheme_poly_bigint(p)->value); +		case AO_SCHEME_FLOAT: +			return ao_scheme_poly_float(p)->value; +		} +	} +	return NAN; +} + +ao_poly +ao_scheme_float_get(float value) +{ +	struct ao_scheme_float	*f; + +	f = ao_scheme_alloc(sizeof (struct ao_scheme_float)); +	f->type = AO_SCHEME_FLOAT; +	f->value = value; +	return ao_scheme_float_poly(f); +} + +ao_poly +ao_scheme_do_inexactp(struct ao_scheme_cons *cons) +{ +	if (!ao_scheme_check_argc(_ao_scheme_atom_led, cons, 1, 1)) +		return AO_SCHEME_NIL; +	if (ao_scheme_poly_type(ao_scheme_arg(cons, 0)) == AO_SCHEME_FLOAT) +		return _ao_scheme_bool_true; +	return _ao_scheme_bool_false; +} + +ao_poly +ao_scheme_do_finitep(struct ao_scheme_cons *cons) +{ +	ao_poly	value; +	float	f; + +	if (!ao_scheme_check_argc(_ao_scheme_atom_led, cons, 1, 1)) +		return AO_SCHEME_NIL; +	value = ao_scheme_arg(cons, 0); +	switch (ao_scheme_poly_type(value)) { +	case AO_SCHEME_INT: +	case AO_SCHEME_BIGINT: +		return _ao_scheme_bool_true; +	case AO_SCHEME_FLOAT: +		f = ao_scheme_poly_float(value)->value; +		if (!isnan(f) && !isinf(f)) +			return _ao_scheme_bool_true; +	} +	return _ao_scheme_bool_false; +} + +ao_poly +ao_scheme_do_infinitep(struct ao_scheme_cons *cons) +{ +	ao_poly	value; +	float	f; + +	if (!ao_scheme_check_argc(_ao_scheme_atom_led, cons, 1, 1)) +		return AO_SCHEME_NIL; +	value = ao_scheme_arg(cons, 0); +	switch (ao_scheme_poly_type(value)) { +	case AO_SCHEME_FLOAT: +		f = ao_scheme_poly_float(value)->value; +		if (isinf(f)) +			return _ao_scheme_bool_true; +	} +	return _ao_scheme_bool_false; +} + +ao_poly +ao_scheme_do_sqrt(struct ao_scheme_cons *cons) +{ +	ao_poly	value; + +	if (!ao_scheme_check_argc(_ao_scheme_atom_sqrt, cons, 1, 1)) +		return AO_SCHEME_NIL; +	value = ao_scheme_arg(cons, 0); +	if (!ao_scheme_number_typep(ao_scheme_poly_type(value))) +		return ao_scheme_error(AO_SCHEME_INVALID, "%s: non-numeric", ao_scheme_poly_atom(_ao_scheme_atom_sqrt)->name); +	return ao_scheme_float_get(sqrtf(ao_scheme_poly_number(value))); +} diff --git a/src/scheme/ao_scheme_frame.c b/src/scheme/ao_scheme_frame.c new file mode 100644 index 00000000..e5d481e7 --- /dev/null +++ b/src/scheme/ao_scheme_frame.c @@ -0,0 +1,330 @@ +/* + * Copyright © 2016 Keith Packard <keithp@keithp.com> + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation, either version 2 of the License, or + * (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, but + * WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU + * General Public License for more details. + */ + +#include "ao_scheme.h" + +static inline int +frame_vals_num_size(int num) +{ +	return sizeof (struct ao_scheme_frame_vals) + num * sizeof (struct ao_scheme_val); +} + +static int +frame_vals_size(void *addr) +{ +	struct ao_scheme_frame_vals	*vals = addr; +	return frame_vals_num_size(vals->size); +} + +static void +frame_vals_mark(void *addr) +{ +	struct ao_scheme_frame_vals	*vals = addr; +	int				f; + +	for (f = 0; f < vals->size; f++) { +		struct ao_scheme_val	*v = &vals->vals[f]; + +		ao_scheme_poly_mark(v->val, 0); +		MDBG_MOVE("frame mark atom %s %d val %d at %d    ", +			  ao_scheme_poly_atom(v->atom)->name, +			  MDBG_OFFSET(ao_scheme_ref(v->atom)), +			  MDBG_OFFSET(ao_scheme_ref(v->val)), f); +		MDBG_DO(ao_scheme_poly_write(v->val)); +		MDBG_DO(printf("\n")); +	} +} + +static void +frame_vals_move(void *addr) +{ +	struct ao_scheme_frame_vals	*vals = addr; +	int				f; + +	for (f = 0; f < vals->size; f++) { +		struct ao_scheme_val	*v = &vals->vals[f]; + +		ao_scheme_poly_move(&v->atom, 0); +		ao_scheme_poly_move(&v->val, 0); +		MDBG_MOVE("frame move atom %s %d val %d at %d\n", +			  ao_scheme_poly_atom(v->atom)->name, +			  MDBG_OFFSET(ao_scheme_ref(v->atom)), +			  MDBG_OFFSET(ao_scheme_ref(v->val)), f); +	} +} + +const struct ao_scheme_type ao_scheme_frame_vals_type = { +	.mark = frame_vals_mark, +	.size = frame_vals_size, +	.move = frame_vals_move, +	.name = "frame_vals" +}; + +static int +frame_size(void *addr) +{ +	(void) addr; +	return sizeof (struct ao_scheme_frame); +} + +static void +frame_mark(void *addr) +{ +	struct ao_scheme_frame	*frame = addr; + +	for (;;) { +		MDBG_MOVE("frame mark %d\n", MDBG_OFFSET(frame)); +		if (!AO_SCHEME_IS_POOL(frame)) +			break; +		ao_scheme_poly_mark(frame->vals, 0); +		frame = ao_scheme_poly_frame(frame->prev); +		MDBG_MOVE("frame next %d\n", MDBG_OFFSET(frame)); +		if (!frame) +			break; +		if (ao_scheme_mark_memory(&ao_scheme_frame_type, frame)) +			break; +	} +} + +static void +frame_move(void *addr) +{ +	struct ao_scheme_frame	*frame = addr; + +	for (;;) { +		struct ao_scheme_frame	*prev; +		int			ret; + +		MDBG_MOVE("frame move %d\n", MDBG_OFFSET(frame)); +		if (!AO_SCHEME_IS_POOL(frame)) +			break; +		ao_scheme_poly_move(&frame->vals, 0); +		prev = ao_scheme_poly_frame(frame->prev); +		if (!prev) +			break; +		ret = ao_scheme_move_memory(&ao_scheme_frame_type, (void **) &prev); +		if (prev != ao_scheme_poly_frame(frame->prev)) { +			MDBG_MOVE("frame prev moved from %d to %d\n", +				  MDBG_OFFSET(ao_scheme_poly_frame(frame->prev)), +				  MDBG_OFFSET(prev)); +			frame->prev = ao_scheme_frame_poly(prev); +		} +		if (ret) +			break; +		frame = prev; +	} +} + +const struct ao_scheme_type ao_scheme_frame_type = { +	.mark = frame_mark, +	.size = frame_size, +	.move = frame_move, +	.name = "frame", +}; + +void +ao_scheme_frame_write(ao_poly p) +{ +	struct ao_scheme_frame		*frame = ao_scheme_poly_frame(p); +	struct ao_scheme_frame_vals	*vals = ao_scheme_poly_frame_vals(frame->vals); +	int				f; + +	printf ("{"); +	if (frame) { +		if (frame->type & AO_SCHEME_FRAME_PRINT) +			printf("recurse..."); +		else { +			frame->type |= AO_SCHEME_FRAME_PRINT; +			for (f = 0; f < frame->num; f++) { +				if (f != 0) +					printf(", "); +				ao_scheme_poly_write(vals->vals[f].atom); +				printf(" = "); +				ao_scheme_poly_write(vals->vals[f].val); +			} +			if (frame->prev) +				ao_scheme_poly_write(frame->prev); +			frame->type &= ~AO_SCHEME_FRAME_PRINT; +		} +	} +	printf("}"); +} + +static int +ao_scheme_frame_find(struct ao_scheme_frame *frame, int top, ao_poly atom) +{ +	struct ao_scheme_frame_vals	*vals = ao_scheme_poly_frame_vals(frame->vals); +	int 				l = 0; +	int 				r = top - 1; + +	while (l <= r) { +		int m = (l + r) >> 1; +		if (vals->vals[m].atom < atom) +			l = m + 1; +		else +			r = m - 1; +	} +	return l; +} + +ao_poly * +ao_scheme_frame_ref(struct ao_scheme_frame *frame, ao_poly atom) +{ +	struct ao_scheme_frame_vals	*vals = ao_scheme_poly_frame_vals(frame->vals); +	int				l = ao_scheme_frame_find(frame, frame->num, atom); + +	if (l >= frame->num) +		return NULL; + +	if (vals->vals[l].atom != atom) +		return NULL; +	return &vals->vals[l].val; +} + +struct ao_scheme_frame	*ao_scheme_frame_free_list[AO_SCHEME_FRAME_FREE]; + +static struct ao_scheme_frame_vals * +ao_scheme_frame_vals_new(int num) +{ +	struct ao_scheme_frame_vals	*vals; + +	vals = ao_scheme_alloc(frame_vals_num_size(num)); +	if (!vals) +		return NULL; +	vals->type = AO_SCHEME_FRAME_VALS; +	vals->size = num; +	memset(vals->vals, '\0', num * sizeof (struct ao_scheme_val)); +	return vals; +} + +struct ao_scheme_frame * +ao_scheme_frame_new(int num) +{ +	struct ao_scheme_frame		*frame; +	struct ao_scheme_frame_vals	*vals; + +	if (num < AO_SCHEME_FRAME_FREE && (frame = ao_scheme_frame_free_list[num])) { +		ao_scheme_frame_free_list[num] = ao_scheme_poly_frame(frame->prev); +		vals = ao_scheme_poly_frame_vals(frame->vals); +	} else { +		frame = ao_scheme_alloc(sizeof (struct ao_scheme_frame)); +		if (!frame) +			return NULL; +		frame->type = AO_SCHEME_FRAME; +		frame->num = 0; +		frame->prev = AO_SCHEME_NIL; +		frame->vals = AO_SCHEME_NIL; +		ao_scheme_frame_stash(0, frame); +		vals = ao_scheme_frame_vals_new(num); +		frame = ao_scheme_frame_fetch(0); +		if (!vals) +			return NULL; +		frame->vals = ao_scheme_frame_vals_poly(vals); +		frame->num = num; +	} +	frame->prev = AO_SCHEME_NIL; +	return frame; +} + +ao_poly +ao_scheme_frame_mark(struct ao_scheme_frame *frame) +{ +	if (!frame) +		return AO_SCHEME_NIL; +	frame->type |= AO_SCHEME_FRAME_MARK; +	return ao_scheme_frame_poly(frame); +} + +void +ao_scheme_frame_free(struct ao_scheme_frame *frame) +{ +	if (frame && !ao_scheme_frame_marked(frame)) { +		int	num = frame->num; +		if (num < AO_SCHEME_FRAME_FREE) { +			struct ao_scheme_frame_vals	*vals; + +			vals = ao_scheme_poly_frame_vals(frame->vals); +			memset(vals->vals, '\0', vals->size * sizeof (struct ao_scheme_val)); +			frame->prev = ao_scheme_frame_poly(ao_scheme_frame_free_list[num]); +			ao_scheme_frame_free_list[num] = frame; +		} +	} +} + +static struct ao_scheme_frame * +ao_scheme_frame_realloc(struct ao_scheme_frame *frame, int new_num) +{ +	struct ao_scheme_frame_vals	*vals; +	struct ao_scheme_frame_vals	*new_vals; +	int				copy; + +	if (new_num == frame->num) +		return frame; +	ao_scheme_frame_stash(0, frame); +	new_vals = ao_scheme_frame_vals_new(new_num); +	frame = ao_scheme_frame_fetch(0); +	if (!new_vals) +		return NULL; +	vals = ao_scheme_poly_frame_vals(frame->vals); +	copy = new_num; +	if (copy > frame->num) +		copy = frame->num; +	memcpy(new_vals->vals, vals->vals, copy * sizeof (struct ao_scheme_val)); +	frame->vals = ao_scheme_frame_vals_poly(new_vals); +	frame->num = new_num; +	return frame; +} + +void +ao_scheme_frame_bind(struct ao_scheme_frame *frame, int num, ao_poly atom, ao_poly val) +{ +	struct ao_scheme_frame_vals	*vals = ao_scheme_poly_frame_vals(frame->vals); +	int 				l = ao_scheme_frame_find(frame, num, atom); + +	memmove(&vals->vals[l+1], +		&vals->vals[l], +		(num - l) * sizeof (struct ao_scheme_val)); +	vals->vals[l].atom = atom; +	vals->vals[l].val = val; +} + +ao_poly +ao_scheme_frame_add(struct ao_scheme_frame *frame, ao_poly atom, ao_poly val) +{ +	ao_poly *ref = frame ? ao_scheme_frame_ref(frame, atom) : NULL; + +	if (!ref) { +		int f = frame->num; +		ao_scheme_poly_stash(0, atom); +		ao_scheme_poly_stash(1, val); +		frame = ao_scheme_frame_realloc(frame, f + 1); +		val = ao_scheme_poly_fetch(1); +		atom = ao_scheme_poly_fetch(0); +		if (!frame) +			return AO_SCHEME_NIL; +		ao_scheme_frame_bind(frame, frame->num - 1, atom, val); +	} else +		*ref = val; +	return val; +} + +struct ao_scheme_frame	*ao_scheme_frame_global; +struct ao_scheme_frame	*ao_scheme_frame_current; + +void +ao_scheme_frame_init(void) +{ +	if (!ao_scheme_frame_global) +		ao_scheme_frame_global = ao_scheme_frame_new(0); +} diff --git a/src/scheme/ao_scheme_int.c b/src/scheme/ao_scheme_int.c new file mode 100644 index 00000000..350a5d35 --- /dev/null +++ b/src/scheme/ao_scheme_int.c @@ -0,0 +1,79 @@ +/* + * Copyright © 2016 Keith Packard <keithp@keithp.com> + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation, either version 2 of the License, or + * (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, but + * WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU + * General Public License for more details. + */ + +#include "ao_scheme.h" + +void +ao_scheme_int_write(ao_poly p) +{ +	int i = ao_scheme_poly_int(p); +	printf("%d", i); +} + +int32_t +ao_scheme_poly_integer(ao_poly p) +{ +	switch (ao_scheme_poly_base_type(p)) { +	case AO_SCHEME_INT: +		return ao_scheme_poly_int(p); +	case AO_SCHEME_OTHER: +		if (ao_scheme_other_type(ao_scheme_poly_other(p)) == AO_SCHEME_BIGINT) +			return ao_scheme_bigint_int(ao_scheme_poly_bigint(p)->value); +	} +	return AO_SCHEME_NOT_INTEGER; +} + +ao_poly +ao_scheme_integer_poly(int32_t p) +{ +	struct ao_scheme_bigint	*bi; + +	if (AO_SCHEME_MIN_INT <= p && p <= AO_SCHEME_MAX_INT) +		return ao_scheme_int_poly(p); +	bi = ao_scheme_alloc(sizeof (struct ao_scheme_bigint)); +	bi->value = ao_scheme_int_bigint(p); +	return ao_scheme_bigint_poly(bi); +} + +static void bigint_mark(void *addr) +{ +	(void) addr; +} + +static int bigint_size(void *addr) +{ +	if (!addr) +		return 0; +	return sizeof (struct ao_scheme_bigint); +} + +static void bigint_move(void *addr) +{ +	(void) addr; +} + +const struct ao_scheme_type ao_scheme_bigint_type = { +	.mark = bigint_mark, +	.size = bigint_size, +	.move = bigint_move, +	.name = "bigint", +}; + +void +ao_scheme_bigint_write(ao_poly p) +{ +	struct ao_scheme_bigint	*bi = ao_scheme_poly_bigint(p); + +	printf("%d", ao_scheme_bigint_int(bi->value)); +} diff --git a/src/scheme/ao_scheme_lambda.c b/src/scheme/ao_scheme_lambda.c new file mode 100644 index 00000000..ec6f858c --- /dev/null +++ b/src/scheme/ao_scheme_lambda.c @@ -0,0 +1,208 @@ +/* + * Copyright © 2016 Keith Packard <keithp@keithp.com> + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation; version 2 of the License. + * + * This program is distributed in the hope that it will be useful, but + * WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU + * General Public License for more details. + * + * You should have received a copy of the GNU General Public License along + * with this program; if not, write to the Free Software Foundation, Inc., + * 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA. + */ + +#include "ao_scheme.h" + +int +lambda_size(void *addr) +{ +	(void) addr; +	return sizeof (struct ao_scheme_lambda); +} + +void +lambda_mark(void *addr) +{ +	struct ao_scheme_lambda	*lambda = addr; + +	ao_scheme_poly_mark(lambda->code, 0); +	ao_scheme_poly_mark(lambda->frame, 0); +} + +void +lambda_move(void *addr) +{ +	struct ao_scheme_lambda	*lambda = addr; + +	ao_scheme_poly_move(&lambda->code, 0); +	ao_scheme_poly_move(&lambda->frame, 0); +} + +const struct ao_scheme_type ao_scheme_lambda_type = { +	.size = lambda_size, +	.mark = lambda_mark, +	.move = lambda_move, +	.name = "lambda", +}; + +void +ao_scheme_lambda_write(ao_poly poly) +{ +	struct ao_scheme_lambda	*lambda = ao_scheme_poly_lambda(poly); +	struct ao_scheme_cons	*cons = ao_scheme_poly_cons(lambda->code); + +	printf("("); +	printf("%s", ao_scheme_args_name(lambda->args)); +	while (cons) { +		printf(" "); +		ao_scheme_poly_write(cons->car); +		cons = ao_scheme_poly_cons(cons->cdr); +	} +	printf(")"); +} + +ao_poly +ao_scheme_lambda_alloc(struct ao_scheme_cons *code, int args) +{ +	struct ao_scheme_lambda	*lambda; +	ao_poly			formal; +	struct ao_scheme_cons	*cons; + +	formal = ao_scheme_arg(code, 0); +	while (formal != AO_SCHEME_NIL) { +		switch (ao_scheme_poly_type(formal)) { +		case AO_SCHEME_CONS: +			cons = ao_scheme_poly_cons(formal); +			if (ao_scheme_poly_type(cons->car) != AO_SCHEME_ATOM) +				return ao_scheme_error(AO_SCHEME_INVALID, "formal %p is not atom", cons->car); +			formal = cons->cdr; +			break; +		case AO_SCHEME_ATOM: +			formal = AO_SCHEME_NIL; +			break; +		default: +			return ao_scheme_error(AO_SCHEME_INVALID, "formal %p is not atom", formal); +		} +	} + +	ao_scheme_cons_stash(0, code); +	lambda = ao_scheme_alloc(sizeof (struct ao_scheme_lambda)); +	code = ao_scheme_cons_fetch(0); +	if (!lambda) +		return AO_SCHEME_NIL; + +	lambda->type = AO_SCHEME_LAMBDA; +	lambda->args = args; +	lambda->code = ao_scheme_cons_poly(code); +	lambda->frame = ao_scheme_frame_mark(ao_scheme_frame_current); +	DBGI("build frame: "); DBG_POLY(lambda->frame); DBG("\n"); +	DBG_STACK(); +	return ao_scheme_lambda_poly(lambda); +} + +ao_poly +ao_scheme_do_lambda(struct ao_scheme_cons *cons) +{ +	return ao_scheme_lambda_alloc(cons, AO_SCHEME_FUNC_LAMBDA); +} + +ao_poly +ao_scheme_do_nlambda(struct ao_scheme_cons *cons) +{ +	return ao_scheme_lambda_alloc(cons, AO_SCHEME_FUNC_NLAMBDA); +} + +ao_poly +ao_scheme_do_macro(struct ao_scheme_cons *cons) +{ +	return ao_scheme_lambda_alloc(cons, AO_SCHEME_FUNC_MACRO); +} + +ao_poly +ao_scheme_lambda_eval(void) +{ +	struct ao_scheme_lambda	*lambda = ao_scheme_poly_lambda(ao_scheme_v); +	struct ao_scheme_cons	*cons = ao_scheme_poly_cons(ao_scheme_stack->values); +	struct ao_scheme_cons	*code = ao_scheme_poly_cons(lambda->code); +	ao_poly			formals; +	struct ao_scheme_frame	*next_frame; +	int			args_wanted; +	ao_poly			varargs = AO_SCHEME_NIL; +	int			args_provided; +	int			f; +	struct ao_scheme_cons	*vals; + +	DBGI("lambda "); DBG_POLY(ao_scheme_lambda_poly(lambda)); DBG("\n"); + +	args_wanted = 0; +	for (formals = ao_scheme_arg(code, 0); +	     ao_scheme_is_pair(formals); +	     formals = ao_scheme_poly_cons(formals)->cdr) +		++args_wanted; +	if (formals != AO_SCHEME_NIL) { +		if (ao_scheme_poly_type(formals) != AO_SCHEME_ATOM) +			return ao_scheme_error(AO_SCHEME_INVALID, "bad lambda form"); +		varargs = formals; +	} + +	/* Create a frame to hold the variables +	 */ +	args_provided = ao_scheme_cons_length(cons) - 1; +	if (varargs == AO_SCHEME_NIL) { +		if (args_wanted != args_provided) +			return ao_scheme_error(AO_SCHEME_INVALID, "need %d args, got %d", args_wanted, args_provided); +	} else { +		if (args_provided < args_wanted) +			return ao_scheme_error(AO_SCHEME_INVALID, "need at least %d args, got %d", args_wanted, args_provided); +	} + +	ao_scheme_poly_stash(1, varargs); +	next_frame = ao_scheme_frame_new(args_wanted + (varargs != AO_SCHEME_NIL)); +	varargs = ao_scheme_poly_fetch(1); +	if (!next_frame) +		return AO_SCHEME_NIL; + +	/* Re-fetch all of the values in case something moved */ +	lambda = ao_scheme_poly_lambda(ao_scheme_v); +	cons = ao_scheme_poly_cons(ao_scheme_stack->values); +	code = ao_scheme_poly_cons(lambda->code); +	formals = ao_scheme_arg(code, 0); +	vals = ao_scheme_poly_cons(cons->cdr); + +	next_frame->prev = lambda->frame; +	ao_scheme_frame_current = next_frame; +	ao_scheme_stack->frame = ao_scheme_frame_poly(ao_scheme_frame_current); + +	for (f = 0; f < args_wanted; f++) { +		struct ao_scheme_cons *arg = ao_scheme_poly_cons(formals); +		DBGI("bind "); DBG_POLY(arg->car); DBG(" = "); DBG_POLY(vals->car); DBG("\n"); +		ao_scheme_frame_bind(next_frame, f, arg->car, vals->car); +		formals = arg->cdr; +		vals = ao_scheme_poly_cons(vals->cdr); +	} +	if (varargs) { +		DBGI("bind "); DBG_POLY(varargs); DBG(" = "); DBG_POLY(ao_scheme_cons_poly(vals)); DBG("\n"); +		/* +		 * Bind the rest of the arguments to the final parameter +		 */ +		ao_scheme_frame_bind(next_frame, f, varargs, ao_scheme_cons_poly(vals)); +	} else { +		/* +		 * Mark the cons cells from the actuals as freed for immediate re-use, unless +		 * the actuals point into the source function (nlambdas and macros), or if the +		 * stack containing them was copied as a part of a continuation +		 */ +		if (lambda->args == AO_SCHEME_FUNC_LAMBDA && !ao_scheme_stack_marked(ao_scheme_stack)) { +			ao_scheme_stack->values = AO_SCHEME_NIL; +			ao_scheme_cons_free(cons); +		} +	} +	DBGI("eval frame: "); DBG_POLY(ao_scheme_frame_poly(next_frame)); DBG("\n"); +	DBG_STACK(); +	DBGI("eval code: "); DBG_POLY(code->cdr); DBG("\n"); +	return code->cdr; +} diff --git a/src/lisp/ao_lisp_lex.c b/src/scheme/ao_scheme_lex.c index fe7c47f4..266b1fc0 100644 --- a/src/lisp/ao_lisp_lex.c +++ b/src/scheme/ao_scheme_lex.c @@ -12,5 +12,5 @@   * General Public License for more details.   */ -#include "ao_lisp.h" +#include "ao_scheme.h" diff --git a/src/scheme/ao_scheme_make_builtin b/src/scheme/ao_scheme_make_builtin new file mode 100644 index 00000000..8e9c2c0b --- /dev/null +++ b/src/scheme/ao_scheme_make_builtin @@ -0,0 +1,190 @@ +#!/usr/bin/nickle + +typedef struct { +	string	type; +	string	c_name; +	string[*]	lisp_names; +} builtin_t; + +string[string] type_map = { +	"lambda" => "LAMBDA", +	"nlambda" => "NLAMBDA", +	"macro" => "MACRO", +	"f_lambda" => "F_LAMBDA", +	"atom" => "atom", +}; + +string[*] +make_lisp(string[*] tokens) +{ +	string[...] lisp = {}; + +	if (dim(tokens) < 3) +		return (string[1]) { tokens[dim(tokens) - 1] }; +	return (string[dim(tokens)-2]) { [i] = tokens[i+2] }; +} + +builtin_t +read_builtin(file f) { +	string	line = File::fgets(f); +	string[*]	tokens = String::wordsplit(line, " \t"); + +	return (builtin_t) { +		.type = dim(tokens) > 0 ? type_map[tokens[0]] : "#", +		.c_name = dim(tokens) > 1 ? tokens[1] : "#", +		.lisp_names = make_lisp(tokens), +	}; +} + +builtin_t[*] +read_builtins(file f) { +	builtin_t[...] builtins = {}; + +	while (!File::end(f)) { +		builtin_t	b = read_builtin(f); + +		if (b.type[0] != '#') +			builtins[dim(builtins)] = b; +	} +	return builtins; +} + +bool is_atom(builtin_t b) = b.type == "atom"; + +void +dump_ids(builtin_t[*] builtins) { +	printf("#ifdef AO_SCHEME_BUILTIN_ID\n"); +	printf("#undef AO_SCHEME_BUILTIN_ID\n"); +	printf("enum ao_scheme_builtin_id {\n"); +	for (int i = 0; i < dim(builtins); i++) +		if (!is_atom(builtins[i])) +			printf("\tbuiltin_%s,\n", builtins[i].c_name); +	printf("\t_builtin_last\n"); +	printf("};\n"); +	printf("#endif /* AO_SCHEME_BUILTIN_ID */\n"); +} + +void +dump_casename(builtin_t[*] builtins) { +	printf("#ifdef AO_SCHEME_BUILTIN_CASENAME\n"); +	printf("#undef AO_SCHEME_BUILTIN_CASENAME\n"); +	printf("static char *ao_scheme_builtin_name(enum ao_scheme_builtin_id b) {\n"); +	printf("\tswitch(b) {\n"); +	for (int i = 0; i < dim(builtins); i++) +		if (!is_atom(builtins[i])) +			printf("\tcase builtin_%s: return ao_scheme_poly_atom(_atom(\"%s\"))->name;\n", +			       builtins[i].c_name, builtins[i].lisp_names[0]); +	printf("\tdefault: return \"???\";\n"); +	printf("\t}\n"); +	printf("}\n"); +	printf("#endif /* AO_SCHEME_BUILTIN_CASENAME */\n"); +} + +void +cify_lisp(string l) { +	for (int j = 0; j < String::length(l); j++) { +		int c= l[j]; +		if (Ctype::isalnum(c) || c == '_') +			printf("%c", c); +		else +			printf("%02x", c); +	} +} + +void +dump_arrayname(builtin_t[*] builtins) { +	printf("#ifdef AO_SCHEME_BUILTIN_ARRAYNAME\n"); +	printf("#undef AO_SCHEME_BUILTIN_ARRAYNAME\n"); +	printf("static const ao_poly builtin_names[] = {\n"); +	for (int i = 0; i < dim(builtins); i++) { +		if (!is_atom(builtins[i])) { +			printf("\t[builtin_%s] = _ao_scheme_atom_", +			       builtins[i].c_name); +			cify_lisp(builtins[i].lisp_names[0]); +			printf(",\n"); +		} +	} +	printf("};\n"); +	printf("#endif /* AO_SCHEME_BUILTIN_ARRAYNAME */\n"); +} + +void +dump_funcs(builtin_t[*] builtins) { +	printf("#ifdef AO_SCHEME_BUILTIN_FUNCS\n"); +	printf("#undef AO_SCHEME_BUILTIN_FUNCS\n"); +	printf("const ao_scheme_func_t ao_scheme_builtins[] = {\n"); +	for (int i = 0; i < dim(builtins); i++) { +		if (!is_atom(builtins[i])) +			printf("\t[builtin_%s] = ao_scheme_do_%s,\n", +			       builtins[i].c_name, +			       builtins[i].c_name); +	} +	printf("};\n"); +	printf("#endif /* AO_SCHEME_BUILTIN_FUNCS */\n"); +} + +void +dump_decls(builtin_t[*] builtins) { +	printf("#ifdef AO_SCHEME_BUILTIN_DECLS\n"); +	printf("#undef AO_SCHEME_BUILTIN_DECLS\n"); +	for (int i = 0; i < dim(builtins); i++) { +		if (!is_atom(builtins[i])) { +			printf("ao_poly\n"); +			printf("ao_scheme_do_%s(struct ao_scheme_cons *cons);\n", +			       builtins[i].c_name); +		} +	} +	printf("#endif /* AO_SCHEME_BUILTIN_DECLS */\n"); +} + +void +dump_consts(builtin_t[*] builtins) { +	printf("#ifdef AO_SCHEME_BUILTIN_CONSTS\n"); +	printf("#undef AO_SCHEME_BUILTIN_CONSTS\n"); +	printf("struct builtin_func funcs[] = {\n"); +	for (int i = 0; i < dim(builtins); i++) { +		if (!is_atom(builtins[i])) { +			for (int j = 0; j < dim(builtins[i].lisp_names); j++) { +				printf ("\t{ .name = \"%s\", .args = AO_SCHEME_FUNC_%s, .func = builtin_%s },\n", +					builtins[i].lisp_names[j], +					builtins[i].type, +					builtins[i].c_name); +			} +		} +	} +	printf("};\n"); +	printf("#endif /* AO_SCHEME_BUILTIN_CONSTS */\n"); +} + +void +dump_atoms(builtin_t[*] builtins) { +	printf("#ifdef AO_SCHEME_BUILTIN_ATOMS\n"); +	printf("#undef AO_SCHEME_BUILTIN_ATOMS\n"); +	for (int i = 0; i < dim(builtins); i++) { +		for (int j = 0; j < dim(builtins[i].lisp_names); j++) { +			printf("#define _ao_scheme_atom_"); +			cify_lisp(builtins[i].lisp_names[j]); +			printf(" _atom(\"%s\")\n", builtins[i].lisp_names[j]); +		} +	} +	printf("#endif /* AO_SCHEME_BUILTIN_ATOMS */\n"); +} + +void main() { +	if (dim(argv) < 2) { +		File::fprintf(stderr, "usage: %s <file>\n", argv[0]); +		exit(1); +	} +	twixt(file f = File::open(argv[1], "r"); File::close(f)) { +		builtin_t[*]	builtins = read_builtins(f); +		dump_ids(builtins); +		dump_casename(builtins); +		dump_arrayname(builtins); +		dump_funcs(builtins); +		dump_decls(builtins); +		dump_consts(builtins); +		dump_atoms(builtins); +	} +} + +main(); diff --git a/src/scheme/ao_scheme_make_const.c b/src/scheme/ao_scheme_make_const.c new file mode 100644 index 00000000..cf42ec52 --- /dev/null +++ b/src/scheme/ao_scheme_make_const.c @@ -0,0 +1,395 @@ +/* + * Copyright © 2016 Keith Packard <keithp@keithp.com> + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation, either version 2 of the License, or + * (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, but + * WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU + * General Public License for more details. + */ + +#include "ao_scheme.h" +#include <stdlib.h> +#include <ctype.h> +#include <unistd.h> +#include <getopt.h> + +static struct ao_scheme_builtin * +ao_scheme_make_builtin(enum ao_scheme_builtin_id func, int args) { +	struct ao_scheme_builtin *b = ao_scheme_alloc(sizeof (struct ao_scheme_builtin)); + +	b->type = AO_SCHEME_BUILTIN; +	b->func = func; +	b->args = args; +	return b; +} + +struct builtin_func { +	char	*name; +	int	args; +	enum ao_scheme_builtin_id	func; +}; + +#define AO_SCHEME_BUILTIN_CONSTS +#include "ao_scheme_builtin.h" + +#define N_FUNC (sizeof funcs / sizeof funcs[0]) + +struct ao_scheme_frame	*globals; + +static int +is_atom(int offset) +{ +	struct ao_scheme_atom *a; + +	for (a = ao_scheme_atoms; a; a = ao_scheme_poly_atom(a->next)) +		if (((uint8_t *) a->name - ao_scheme_const) == offset) +			return strlen(a->name); +	return 0; +} + +#define AO_FEC_CRC_INIT	0xffff + +static inline uint16_t +ao_fec_crc_byte(uint8_t byte, uint16_t crc) +{ +	uint8_t	bit; + +	for (bit = 0; bit < 8; bit++) { +		if (((crc & 0x8000) >> 8) ^ (byte & 0x80)) +			crc = (crc << 1) ^ 0x8005; +		else +			crc = (crc << 1); +		byte <<= 1; +	} +	return crc; +} + +uint16_t +ao_fec_crc(const uint8_t *bytes, uint8_t len) +{ +	uint16_t	crc = AO_FEC_CRC_INIT; + +	while (len--) +		crc = ao_fec_crc_byte(*bytes++, crc); +	return crc; +} + +struct ao_scheme_macro_stack { +	struct ao_scheme_macro_stack *next; +	ao_poly	p; +}; + +struct ao_scheme_macro_stack *macro_stack; + +int +ao_scheme_macro_push(ao_poly p) +{ +	struct ao_scheme_macro_stack *m = macro_stack; + +	while (m) { +		if (m->p == p) +			return 1; +		m = m->next; +	} +	m = malloc (sizeof (struct ao_scheme_macro_stack)); +	m->p = p; +	m->next = macro_stack; +	macro_stack = m; +	return 0; +} + +void +ao_scheme_macro_pop(void) +{ +	struct ao_scheme_macro_stack *m = macro_stack; + +	macro_stack = m->next; +	free(m); +} + +#define DBG_MACRO 0 +#if DBG_MACRO +int macro_scan_depth; + +void indent(void) +{ +	int i; +	for (i = 0; i < macro_scan_depth; i++) +		printf("  "); +} +#define MACRO_DEBUG(a)	a +#else +#define MACRO_DEBUG(a) +#endif + +ao_poly +ao_has_macro(ao_poly p); + +ao_poly +ao_macro_test_get(ao_poly atom) +{ +	ao_poly	*ref = ao_scheme_atom_ref(atom, NULL); +	if (ref) +		return *ref; +	return AO_SCHEME_NIL; +} + +ao_poly +ao_is_macro(ao_poly p) +{ +	struct ao_scheme_builtin	*builtin; +	struct ao_scheme_lambda	*lambda; +	ao_poly ret; + +	MACRO_DEBUG(indent(); printf ("is macro "); ao_scheme_poly_write(p); printf("\n"); ++macro_scan_depth); +	switch (ao_scheme_poly_type(p)) { +	case AO_SCHEME_ATOM: +		if (ao_scheme_macro_push(p)) +			ret = AO_SCHEME_NIL; +		else { +			if (ao_is_macro(ao_macro_test_get(p))) +				ret = p; +			else +				ret = AO_SCHEME_NIL; +			ao_scheme_macro_pop(); +		} +		break; +	case AO_SCHEME_CONS: +		ret = ao_has_macro(p); +		break; +	case AO_SCHEME_BUILTIN: +		builtin = ao_scheme_poly_builtin(p); +		if ((builtin->args & AO_SCHEME_FUNC_MASK) == AO_SCHEME_FUNC_MACRO) +			ret = p; +		else +			ret = 0; +		break; + +	case AO_SCHEME_LAMBDA: +		lambda = ao_scheme_poly_lambda(p); +		if (lambda->args == AO_SCHEME_FUNC_MACRO) +			ret = p; +		else +			ret = ao_has_macro(lambda->code); +		break; +	default: +		ret = AO_SCHEME_NIL; +		break; +	} +	MACRO_DEBUG(--macro_scan_depth;	indent(); printf ("... "); ao_scheme_poly_write(ret); printf("\n")); +	return ret; +} + +ao_poly +ao_has_macro(ao_poly p) +{ +	struct ao_scheme_cons	*cons; +	struct ao_scheme_lambda	*lambda; +	ao_poly			m; +	ao_poly			list; + +	if (p == AO_SCHEME_NIL) +		return AO_SCHEME_NIL; + +	MACRO_DEBUG(indent(); printf("has macro "); ao_scheme_poly_write(p); printf("\n"); ++macro_scan_depth); +	switch (ao_scheme_poly_type(p)) { +	case AO_SCHEME_LAMBDA: +		lambda = ao_scheme_poly_lambda(p); +		p = ao_has_macro(lambda->code); +		break; +	case AO_SCHEME_CONS: +		cons = ao_scheme_poly_cons(p); +		if ((p = ao_is_macro(cons->car))) +			break; + +		list = cons->cdr; +		p = AO_SCHEME_NIL; +		while (list != AO_SCHEME_NIL && ao_scheme_poly_type(list) == AO_SCHEME_CONS) { +			cons = ao_scheme_poly_cons(list); +			m = ao_has_macro(cons->car); +			if (m) { +				p = m; +				break; +			} +			list = cons->cdr; +		} +		break; + +	default: +		p = AO_SCHEME_NIL; +		break; +	} +	MACRO_DEBUG(--macro_scan_depth;	indent(); printf("... "); ao_scheme_poly_write(p); printf("\n")); +	return p; +} + +int +ao_scheme_read_eval_abort(void) +{ +	ao_poly	in, out = AO_SCHEME_NIL; +	for(;;) { +		in = ao_scheme_read(); +		if (in == _ao_scheme_atom_eof) +			break; +		out = ao_scheme_eval(in); +		if (ao_scheme_exception) +			return 0; +		ao_scheme_poly_write(out); +		putchar ('\n'); +	} +	return 1; +} + +static FILE	*in; +static FILE	*out; + +int +ao_scheme_getc(void) +{ +	return getc(in); +} + +static const struct option options[] = { +	{ .name = "out", .has_arg = 1, .val = 'o' }, +	{ 0, 0, 0, 0 } +}; + +static void usage(char *program) +{ +	fprintf(stderr, "usage: %s [--out=<output>] [input]\n", program); +	exit(1); +} + +int +main(int argc, char **argv) +{ +	int	f, o; +	ao_poly	val; +	struct ao_scheme_atom	*a; +	struct ao_scheme_builtin	*b; +	int	in_atom = 0; +	char	*out_name = NULL; +	int	c; +	enum ao_scheme_builtin_id	prev_func; + +	in = stdin; +	out = stdout; + +	while ((c = getopt_long(argc, argv, "o:", options, NULL)) != -1) { +		switch (c) { +		case 'o': +			out_name = optarg; +			break; +		default: +			usage(argv[0]); +			break; +		} +	} + +	ao_scheme_frame_init(); + +	/* Boolean values #f and #t */ +	ao_scheme_bool_get(0); +	ao_scheme_bool_get(1); + +	prev_func = _builtin_last; +	for (f = 0; f < (int) N_FUNC; f++) { +		if (funcs[f].func != prev_func) +			b = ao_scheme_make_builtin(funcs[f].func, funcs[f].args); +		a = ao_scheme_atom_intern(funcs[f].name); +		ao_scheme_atom_def(ao_scheme_atom_poly(a), +				 ao_scheme_builtin_poly(b)); +	} + +	/* end of file value */ +	a = ao_scheme_atom_intern("eof"); +	ao_scheme_atom_def(ao_scheme_atom_poly(a), +			 ao_scheme_atom_poly(a)); + +	/* 'else' */ +	a = ao_scheme_atom_intern("else"); + +	if (argv[optind]){ +		in = fopen(argv[optind], "r"); +		if (!in) { +			perror(argv[optind]); +			exit(1); +		} +	} +	if (!ao_scheme_read_eval_abort()) { +		fprintf(stderr, "eval failed\n"); +		exit(1); +	} + +	/* Reduce to referenced values */ +	ao_scheme_collect(AO_SCHEME_COLLECT_FULL); + +	for (f = 0; f < ao_scheme_frame_global->num; f++) { +		struct ao_scheme_frame_vals	*vals = ao_scheme_poly_frame_vals(ao_scheme_frame_global->vals); +		val = ao_has_macro(vals->vals[f].val); +		if (val != AO_SCHEME_NIL) { +			printf("error: function %s contains unresolved macro: ", +			       ao_scheme_poly_atom(vals->vals[f].atom)->name); +			ao_scheme_poly_write(val); +			printf("\n"); +			exit(1); +		} +	} + +	if (out_name) { +		out = fopen(out_name, "w"); +		if (!out) { +			perror(out_name); +			exit(1); +		} +	} + +	fprintf(out, "/* Generated file, do not edit */\n\n"); + +	fprintf(out, "#define AO_SCHEME_POOL_CONST %d\n", ao_scheme_top); +	fprintf(out, "extern const uint8_t ao_scheme_const[AO_SCHEME_POOL_CONST] __attribute__((aligned(4)));\n"); +	fprintf(out, "#define ao_builtin_atoms 0x%04x\n", ao_scheme_atom_poly(ao_scheme_atoms)); +	fprintf(out, "#define ao_builtin_frame 0x%04x\n", ao_scheme_frame_poly(ao_scheme_frame_global)); +	fprintf(out, "#define ao_scheme_const_checksum ((uint16_t) 0x%04x)\n", ao_fec_crc(ao_scheme_const, ao_scheme_top)); + +	fprintf(out, "#define _ao_scheme_bool_false 0x%04x\n", ao_scheme_bool_poly(ao_scheme_false)); +	fprintf(out, "#define _ao_scheme_bool_true 0x%04x\n", ao_scheme_bool_poly(ao_scheme_true)); + +	for (a = ao_scheme_atoms; a; a = ao_scheme_poly_atom(a->next)) { +		char	*n = a->name, c; +		fprintf(out, "#define _ao_scheme_atom_"); +		while ((c = *n++)) { +			if (isalnum(c)) +				fprintf(out, "%c", c); +			else +				fprintf(out, "%02x", c); +		} +		fprintf(out, "  0x%04x\n", ao_scheme_atom_poly(a)); +	} +	fprintf(out, "#ifdef AO_SCHEME_CONST_BITS\n"); +	fprintf(out, "const uint8_t ao_scheme_const[AO_SCHEME_POOL_CONST] __attribute((aligned(4))) = {"); +	for (o = 0; o < ao_scheme_top; o++) { +		uint8_t	c; +		if ((o & 0xf) == 0) +			fprintf(out, "\n\t"); +		else +			fprintf(out, " "); +		c = ao_scheme_const[o]; +		if (!in_atom) +			in_atom = is_atom(o); +		if (in_atom) { +			fprintf(out, " '%c',", c); +			in_atom--; +		} else { +			fprintf(out, "0x%02x,", c); +		} +	} +	fprintf(out, "\n};\n"); +	fprintf(out, "#endif /* AO_SCHEME_CONST_BITS */\n"); +	exit(0); +} diff --git a/src/scheme/ao_scheme_mem.c b/src/scheme/ao_scheme_mem.c new file mode 100644 index 00000000..45d4de98 --- /dev/null +++ b/src/scheme/ao_scheme_mem.c @@ -0,0 +1,969 @@ +/* + * Copyright © 2016 Keith Packard <keithp@keithp.com> + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation, either version 2 of the License, or + * (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, but + * WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU + * General Public License for more details. + */ + +#define AO_SCHEME_CONST_BITS + +#include "ao_scheme.h" +#include <stdio.h> +#include <assert.h> + +#ifdef AO_SCHEME_MAKE_CONST + +/* + * When building the constant table, it is the + * pool for allocations. + */ + +#include <stdlib.h> +uint8_t ao_scheme_const[AO_SCHEME_POOL_CONST] __attribute__((aligned(4))); +#define ao_scheme_pool ao_scheme_const +#undef AO_SCHEME_POOL +#define AO_SCHEME_POOL AO_SCHEME_POOL_CONST + +#else + +uint8_t	ao_scheme_pool[AO_SCHEME_POOL + AO_SCHEME_POOL_EXTRA] __attribute__((aligned(4))); + +#endif + +#ifndef DBG_MEM_STATS +#define DBG_MEM_STATS	DBG_MEM +#endif + +#if DBG_MEM +int dbg_move_depth; +int dbg_mem = DBG_MEM_START; +int dbg_validate = 0; + +struct ao_scheme_record { +	struct ao_scheme_record		*next; +	const struct ao_scheme_type	*type; +	void				*addr; +	int				size; +}; + +static struct ao_scheme_record	*record_head, **record_tail; + +static void +ao_scheme_record_free(struct ao_scheme_record *record) +{ +	while (record) { +		struct ao_scheme_record *next = record->next; +		free(record); +		record = next; +	} +} + +static void +ao_scheme_record_reset(void) +{ +	ao_scheme_record_free(record_head); +	record_head = NULL; +	record_tail = &record_head; +} + +static void +ao_scheme_record(const struct ao_scheme_type	*type, +	       void				*addr, +	       int				size) +{ +	struct ao_scheme_record	*r = malloc(sizeof (struct ao_scheme_record)); + +	r->next = NULL; +	r->type = type; +	r->addr = addr; +	r->size = size; +	*record_tail = r; +	record_tail = &r->next; +} + +static struct ao_scheme_record * +ao_scheme_record_save(void) +{ +	struct ao_scheme_record *r = record_head; + +	record_head = NULL; +	record_tail = &record_head; +	return r; +} + +static void +ao_scheme_record_compare(char *where, +		       struct ao_scheme_record *a, +		       struct ao_scheme_record *b) +{ +	while (a && b) { +		if (a->type != b->type || a->size != b->size) { +			printf("%s record difers %d %s %d -> %d %s %d\n", +			       where, +			       MDBG_OFFSET(a->addr), +			       a->type->name, +			       a->size, +			       MDBG_OFFSET(b->addr), +			       b->type->name, +			       b->size); +			ao_scheme_abort(); +		} +		a = a->next; +		b = b->next; +	} +	if (a) { +		printf("%s record differs %d %s %d -> NULL\n", +		       where, +		       MDBG_OFFSET(a->addr), +		       a->type->name, +		       a->size); +		ao_scheme_abort(); +	} +	if (b) { +		printf("%s record differs NULL -> %d %s %d\n", +		       where, +		       MDBG_OFFSET(b->addr), +		       b->type->name, +		       b->size); +		ao_scheme_abort(); +	} +} + +#else +#define ao_scheme_record_reset() +#endif + +uint8_t	ao_scheme_exception; + +struct ao_scheme_root { +	const struct ao_scheme_type	*type; +	void				**addr; +}; + +static struct ao_scheme_cons 	*save_cons[2]; +static char			*save_string[2]; +static struct ao_scheme_frame	*save_frame[1]; +static ao_poly			save_poly[3]; + +static const struct ao_scheme_root	ao_scheme_root[] = { +	{ +		.type = &ao_scheme_cons_type, +		.addr = (void **) &save_cons[0], +	}, +	{ +		.type = &ao_scheme_cons_type, +		.addr = (void **) &save_cons[1], +	}, +	{ +		.type = &ao_scheme_string_type, +		.addr = (void **) &save_string[0], +	}, +	{ +		.type = &ao_scheme_string_type, +		.addr = (void **) &save_string[1], +	}, +	{ +		.type = &ao_scheme_frame_type, +		.addr = (void **) &save_frame[0], +	}, +	{ +		.type = NULL, +		.addr = (void **) (void *) &save_poly[0] +	}, +	{ +		.type = NULL, +		.addr = (void **) (void *) &save_poly[1] +	}, +	{ +		.type = NULL, +		.addr = (void **) (void *) &save_poly[2] +	}, +	{ +		.type = &ao_scheme_atom_type, +		.addr = (void **) &ao_scheme_atoms +	}, +	{ +		.type = &ao_scheme_frame_type, +		.addr = (void **) &ao_scheme_frame_global, +	}, +	{ +		.type = &ao_scheme_frame_type, +		.addr = (void **) &ao_scheme_frame_current, +	}, +	{ +		.type = &ao_scheme_stack_type, +		.addr = (void **) &ao_scheme_stack, +	}, +	{ +		.type = NULL, +		.addr = (void **) (void *) &ao_scheme_v, +	}, +	{ +		.type = &ao_scheme_cons_type, +		.addr = (void **) &ao_scheme_read_cons, +	}, +	{ +		.type = &ao_scheme_cons_type, +		.addr = (void **) &ao_scheme_read_cons_tail, +	}, +	{ +		.type = &ao_scheme_cons_type, +		.addr = (void **) &ao_scheme_read_stack, +	}, +#ifdef AO_SCHEME_MAKE_CONST +	{ +		.type = &ao_scheme_bool_type, +		.addr = (void **) &ao_scheme_false, +	}, +	{ +		.type = &ao_scheme_bool_type, +		.addr = (void **) &ao_scheme_true, +	}, +#endif +}; + +#define AO_SCHEME_ROOT	(sizeof (ao_scheme_root) / sizeof (ao_scheme_root[0])) + +static const void ** const ao_scheme_cache[] = { +	(const void **) &ao_scheme_cons_free_list, +	(const void **) &ao_scheme_stack_free_list, +	(const void **) &ao_scheme_frame_free_list[0], +	(const void **) &ao_scheme_frame_free_list[1], +	(const void **) &ao_scheme_frame_free_list[2], +	(const void **) &ao_scheme_frame_free_list[3], +	(const void **) &ao_scheme_frame_free_list[4], +	(const void **) &ao_scheme_frame_free_list[5], +}; + +#if AO_SCHEME_FRAME_FREE != 6 +#error Unexpected AO_SCHEME_FRAME_FREE value +#endif + +#define AO_SCHEME_CACHE	(sizeof (ao_scheme_cache) / sizeof (ao_scheme_cache[0])) + +#define AO_SCHEME_BUSY_SIZE	((AO_SCHEME_POOL + 31) / 32) + +static uint8_t	ao_scheme_busy[AO_SCHEME_BUSY_SIZE]; +static uint8_t	ao_scheme_cons_note[AO_SCHEME_BUSY_SIZE]; +static uint8_t	ao_scheme_cons_last[AO_SCHEME_BUSY_SIZE]; +static uint8_t	ao_scheme_cons_noted; + +uint16_t	ao_scheme_top; + +struct ao_scheme_chunk { +	uint16_t		old_offset; +	union { +		uint16_t	size; +		uint16_t	new_offset; +	}; +}; + +#define AO_SCHEME_NCHUNK	64 + +static struct ao_scheme_chunk ao_scheme_chunk[AO_SCHEME_NCHUNK]; + +/* Offset of an address within the pool. */ +static inline uint16_t pool_offset(void *addr) { +#if DBG_MEM +	if (!AO_SCHEME_IS_POOL(addr)) +		ao_scheme_abort(); +#endif +	return ((uint8_t *) addr) - ao_scheme_pool; +} + +static inline void mark(uint8_t *tag, int offset) { +	int	byte = offset >> 5; +	int	bit = (offset >> 2) & 7; +	tag[byte] |= (1 << bit); +} + +static inline void clear(uint8_t *tag, int offset) { +	int	byte = offset >> 5; +	int	bit = (offset >> 2) & 7; +	tag[byte] &= ~(1 << bit); +} + +static inline int busy(uint8_t *tag, int offset) { +	int	byte = offset >> 5; +	int	bit = (offset >> 2) & 7; +	return (tag[byte] >> bit) & 1; +} + +static inline int min(int a, int b) { return a < b ? a : b; } +static inline int max(int a, int b) { return a > b ? a : b; } + +static inline int limit(int offset) { +	return min(AO_SCHEME_POOL, max(offset, 0)); +} + +static void +note_cons(uint16_t offset) +{ +	MDBG_MOVE("note cons %d\n", offset); +	ao_scheme_cons_noted = 1; +	mark(ao_scheme_cons_note, offset); +} + +static uint16_t	chunk_low, chunk_high; +static uint16_t	chunk_first, chunk_last; + +static int +find_chunk(uint16_t offset) +{ +	int l, r; +	/* Binary search for the location */ +	l = chunk_first; +	r = chunk_last - 1; +	while (l <= r) { +		int m = (l + r) >> 1; +		if (ao_scheme_chunk[m].old_offset < offset) +			l = m + 1; +		else +			r = m - 1; +	} +	return l; +} + +static void +note_chunk(uint16_t offset, uint16_t size) +{ +	int l; + +	if (offset < chunk_low || chunk_high <= offset) +		return; + +	l = find_chunk(offset); + +	/* +	 * The correct location is always in 'l', with r = l-1 being +	 * the entry before the right one +	 */ + +#if DBG_MEM +	/* Off the right side */ +	if (l >= AO_SCHEME_NCHUNK) +		ao_scheme_abort(); + +	/* Off the left side */ +	if (l == 0 && chunk_last && offset > ao_scheme_chunk[0].old_offset) +		ao_scheme_abort(); +#endif + +	/* Shuffle existing entries right */ +	int end = min(AO_SCHEME_NCHUNK, chunk_last + 1); + +	memmove(&ao_scheme_chunk[l+1], +		&ao_scheme_chunk[l], +		(end - (l+1)) * sizeof (struct ao_scheme_chunk)); + +	/* Add new entry */ +	ao_scheme_chunk[l].old_offset = offset; +	ao_scheme_chunk[l].size = size; + +	/* Increment the number of elements up to the size of the array */ +	if (chunk_last < AO_SCHEME_NCHUNK) +		chunk_last++; + +	/* Set the top address if the array is full */ +	if (chunk_last == AO_SCHEME_NCHUNK) +		chunk_high = ao_scheme_chunk[AO_SCHEME_NCHUNK-1].old_offset + +			ao_scheme_chunk[AO_SCHEME_NCHUNK-1].size; +} + +static void +reset_chunks(void) +{ +	chunk_high = ao_scheme_top; +	chunk_last = 0; +	chunk_first = 0; +} + +/* + * Walk all referenced objects calling functions on each one + */ + +static void +walk(int (*visit_addr)(const struct ao_scheme_type *type, void **addr), +     int (*visit_poly)(ao_poly *p, uint8_t do_note_cons)) +{ +	int i; + +	ao_scheme_record_reset(); +	memset(ao_scheme_busy, '\0', sizeof (ao_scheme_busy)); +	memset(ao_scheme_cons_note, '\0', sizeof (ao_scheme_cons_note)); +	ao_scheme_cons_noted = 0; +	for (i = 0; i < (int) AO_SCHEME_ROOT; i++) { +		if (ao_scheme_root[i].type) { +			void **a = ao_scheme_root[i].addr, *v; +			if (a && (v = *a)) { +				MDBG_MOVE("root ptr %d\n", MDBG_OFFSET(v)); +				visit_addr(ao_scheme_root[i].type, a); +			} +		} else { +			ao_poly *a = (ao_poly *) ao_scheme_root[i].addr, p; +			if (a && (p = *a)) { +				MDBG_MOVE("root poly %d\n", MDBG_OFFSET(ao_scheme_ref(p))); +				visit_poly(a, 0); +			} +		} +	} +	while (ao_scheme_cons_noted) { +		memcpy(ao_scheme_cons_last, ao_scheme_cons_note, sizeof (ao_scheme_cons_note)); +		memset(ao_scheme_cons_note, '\0', sizeof (ao_scheme_cons_note)); +		ao_scheme_cons_noted = 0; +		for (i = 0; i < AO_SCHEME_POOL; i += 4) { +			if (busy(ao_scheme_cons_last, i)) { +				void *v = ao_scheme_pool + i; +				MDBG_MOVE("root cons %d\n", MDBG_OFFSET(v)); +				visit_addr(&ao_scheme_cons_type, &v); +			} +		} +	} +} + +#if MDBG_DUMP +static void +dump_busy(void) +{ +	int	i; +	MDBG_MOVE("busy:"); +	for (i = 0; i < ao_scheme_top; i += 4) { +		if ((i & 0xff) == 0) { +			MDBG_MORE("\n"); +			MDBG_MOVE("%s", ""); +		} +		else if ((i & 0x1f) == 0) +			MDBG_MORE(" "); +		if (busy(ao_scheme_busy, i)) +			MDBG_MORE("*"); +		else +			MDBG_MORE("-"); +	} +	MDBG_MORE ("\n"); +} +#define DUMP_BUSY()	dump_busy() +#else +#define DUMP_BUSY() +#endif + +static const struct ao_scheme_type * const ao_scheme_types[AO_SCHEME_NUM_TYPE] = { +	[AO_SCHEME_CONS] = &ao_scheme_cons_type, +	[AO_SCHEME_INT] = NULL, +	[AO_SCHEME_STRING] = &ao_scheme_string_type, +	[AO_SCHEME_OTHER] = (void *) 0x1, +	[AO_SCHEME_ATOM] = &ao_scheme_atom_type, +	[AO_SCHEME_BUILTIN] = &ao_scheme_builtin_type, +	[AO_SCHEME_FRAME] = &ao_scheme_frame_type, +	[AO_SCHEME_FRAME_VALS] = &ao_scheme_frame_vals_type, +	[AO_SCHEME_LAMBDA] = &ao_scheme_lambda_type, +	[AO_SCHEME_STACK] = &ao_scheme_stack_type, +	[AO_SCHEME_BOOL] = &ao_scheme_bool_type, +	[AO_SCHEME_BIGINT] = &ao_scheme_bigint_type, +	[AO_SCHEME_FLOAT] = &ao_scheme_float_type, +	[AO_SCHEME_VECTOR] = &ao_scheme_vector_type, +}; + +static int +ao_scheme_mark_ref(const struct ao_scheme_type *type, void **ref) +{ +	return ao_scheme_mark(type, *ref); +} + +static int +ao_scheme_poly_mark_ref(ao_poly *p, uint8_t do_note_cons) +{ +	return ao_scheme_poly_mark(*p, do_note_cons); +} + +#if DBG_MEM_STATS +uint64_t ao_scheme_collects[2]; +uint64_t ao_scheme_freed[2]; +uint64_t ao_scheme_loops[2]; +#endif + +int ao_scheme_last_top; + +int +ao_scheme_collect(uint8_t style) +{ +	int	i; +	int	top; +#if DBG_MEM_STATS +	int	loops = 0; +#endif +#if DBG_MEM +	struct ao_scheme_record	*mark_record = NULL, *move_record = NULL; + +	MDBG_MOVE("collect %d\n", ao_scheme_collects[style]); +#endif +	MDBG_DO(ao_scheme_frame_write(ao_scheme_frame_poly(ao_scheme_frame_global))); + +	/* The first time through, we're doing a full collect */ +	if (ao_scheme_last_top == 0) +		style = AO_SCHEME_COLLECT_FULL; + +	/* Clear references to all caches */ +	for (i = 0; i < (int) AO_SCHEME_CACHE; i++) +		*ao_scheme_cache[i] = NULL; +	if (style == AO_SCHEME_COLLECT_FULL) { +		chunk_low = top = 0; +	} else { +		chunk_low = top = ao_scheme_last_top; +	} +	for (;;) { +#if DBG_MEM_STATS +		loops++; +#endif +		MDBG_MOVE("move chunks from %d to %d\n", chunk_low, top); +		/* Find the sizes of the first chunk of objects to move */ +		reset_chunks(); +		walk(ao_scheme_mark_ref, ao_scheme_poly_mark_ref); +#if DBG_MEM + +		ao_scheme_record_free(mark_record); +		mark_record = ao_scheme_record_save(); +		if (mark_record && move_record) +			ao_scheme_record_compare("mark", move_record, mark_record); +#endif + +		DUMP_BUSY(); + +		/* Find the first moving object */ +		for (i = 0; i < chunk_last; i++) { +			uint16_t	size = ao_scheme_chunk[i].size; + +#if DBG_MEM +			if (!size) +				ao_scheme_abort(); +#endif + +			if (ao_scheme_chunk[i].old_offset > top) +				break; + +			MDBG_MOVE("chunk %d %d not moving\n", +				  ao_scheme_chunk[i].old_offset, +				  ao_scheme_chunk[i].size); +#if DBG_MEM +			if (ao_scheme_chunk[i].old_offset != top) +				ao_scheme_abort(); +#endif +			top += size; +		} + +		/* +		 * Limit amount of chunk array used in mapping moves +		 * to the active region +		 */ +		chunk_first = i; +		chunk_low = ao_scheme_chunk[i].old_offset; + +		/* Copy all of the objects */ +		for (; i < chunk_last; i++) { +			uint16_t	size = ao_scheme_chunk[i].size; + +#if DBG_MEM +			if (!size) +				ao_scheme_abort(); +#endif + +			MDBG_MOVE("chunk %d %d -> %d\n", +				  ao_scheme_chunk[i].old_offset, +				  size, +				  top); +			ao_scheme_chunk[i].new_offset = top; + +			memmove(&ao_scheme_pool[top], +				&ao_scheme_pool[ao_scheme_chunk[i].old_offset], +				size); + +			top += size; +		} + +		if (chunk_first < chunk_last) { +			/* Relocate all references to the objects */ +			walk(ao_scheme_move, ao_scheme_poly_move); + +#if DBG_MEM +			ao_scheme_record_free(move_record); +			move_record = ao_scheme_record_save(); +			if (mark_record && move_record) +				ao_scheme_record_compare("move", mark_record, move_record); +#endif +		} + +		/* If we ran into the end of the heap, then +		 * there's no need to keep walking +		 */ +		if (chunk_last != AO_SCHEME_NCHUNK) +			break; + +		/* Next loop starts right above this loop */ +		chunk_low = chunk_high; +	} + +#if DBG_MEM_STATS +	/* Collect stats */ +	++ao_scheme_collects[style]; +	ao_scheme_freed[style] += ao_scheme_top - top; +	ao_scheme_loops[style] += loops; +#endif + +	ao_scheme_top = top; +	if (style == AO_SCHEME_COLLECT_FULL) +		ao_scheme_last_top = top; + +	MDBG_DO(memset(ao_scheme_chunk, '\0', sizeof (ao_scheme_chunk)); +		walk(ao_scheme_mark_ref, ao_scheme_poly_mark_ref)); + +	return AO_SCHEME_POOL - ao_scheme_top; +} + +#if DBG_FREE_CONS +void +ao_scheme_cons_check(struct ao_scheme_cons *cons) +{ +	ao_poly	cdr; +	int offset; + +	chunk_low = 0; +	reset_chunks(); +	walk(ao_scheme_mark_ref, ao_scheme_poly_mark_ref); +	while (cons) { +		if (!AO_SCHEME_IS_POOL(cons)) +			break; +		offset = pool_offset(cons); +		if (busy(ao_scheme_busy, offset)) { +			ao_scheme_printf("cons at %p offset %d poly %d is busy\n\t%v\n", cons, offset, ao_scheme_cons_poly(cons), ao_scheme_cons_poly(cons)); +			abort(); +		} +		cdr = cons->cdr; +		if (!ao_scheme_is_pair(cdr)) +			break; +		cons = ao_scheme_poly_cons(cdr); +	} +} +#endif + +/* + * Mark interfaces for objects + */ + + +/* + * Mark a block of memory with an explicit size + */ + +int +ao_scheme_mark_block(void *addr, int size) +{ +	int offset; +	if (!AO_SCHEME_IS_POOL(addr)) +		return 1; + +	offset = pool_offset(addr); +	MDBG_MOVE("mark memory %d\n", MDBG_OFFSET(addr)); +	if (busy(ao_scheme_busy, offset)) { +		MDBG_MOVE("already marked\n"); +		return 1; +	} +	mark(ao_scheme_busy, offset); +	note_chunk(offset, size); +	return 0; +} + +/* + * Note a reference to memory and collect information about a few + * object sizes at a time + */ + +int +ao_scheme_mark_memory(const struct ao_scheme_type *type, void *addr) +{ +	int offset; +	if (!AO_SCHEME_IS_POOL(addr)) +		return 1; + +	offset = pool_offset(addr); +	MDBG_MOVE("mark memory %d\n", MDBG_OFFSET(addr)); +	if (busy(ao_scheme_busy, offset)) { +		MDBG_MOVE("already marked\n"); +		return 1; +	} +	mark(ao_scheme_busy, offset); +	note_chunk(offset, ao_scheme_size(type, addr)); +	return 0; +} + +/* + * Mark an object and all that it refereces + */ +int +ao_scheme_mark(const struct ao_scheme_type *type, void *addr) +{ +	int ret; +	MDBG_MOVE("mark %d\n", MDBG_OFFSET(addr)); +	MDBG_MOVE_IN(); +	ret = ao_scheme_mark_memory(type, addr); +	if (!ret) { +		MDBG_MOVE("mark recurse\n"); +		type->mark(addr); +	} +	MDBG_MOVE_OUT(); +	return ret; +} + +/* + * Mark an object, unless it is a cons cell and + * do_note_cons is set. In that case, just + * set a bit in the cons note array; those + * will be marked in a separate pass to avoid + * deep recursion in the collector + */ +int +ao_scheme_poly_mark(ao_poly p, uint8_t do_note_cons) +{ +	uint8_t type; +	void	*addr; + +	type = ao_scheme_poly_base_type(p); + +	if (type == AO_SCHEME_INT) +		return 1; + +	addr = ao_scheme_ref(p); +	if (!AO_SCHEME_IS_POOL(addr)) +		return 1; + +	if (type == AO_SCHEME_CONS && do_note_cons) { +		note_cons(pool_offset(addr)); +		return 1; +	} else { +		if (type == AO_SCHEME_OTHER) +			type = ao_scheme_other_type(addr); + +		const struct ao_scheme_type *lisp_type = ao_scheme_types[type]; +#if DBG_MEM +		if (!lisp_type) +			ao_scheme_abort(); +#endif + +		return ao_scheme_mark(lisp_type, addr); +	} +} + +/* + * Find the current location of an object + * based on the original location. For unmoved + * objects, this is simple. For moved objects, + * go search for it + */ + +static uint16_t +move_map(uint16_t offset) +{ +	int		l; + +	if (offset < chunk_low || chunk_high <= offset) +		return offset; + +	l = find_chunk(offset); + +#if DBG_MEM +	if (ao_scheme_chunk[l].old_offset != offset) +		ao_scheme_abort(); +#endif +	return ao_scheme_chunk[l].new_offset; +} + +int +ao_scheme_move_memory(const struct ao_scheme_type *type, void **ref) +{ +	void		*addr = *ref; +	uint16_t	offset, orig_offset; + +	if (!AO_SCHEME_IS_POOL(addr)) +		return 1; + +	(void) type; + +	MDBG_MOVE("move memory %d\n", MDBG_OFFSET(addr)); +	orig_offset = pool_offset(addr); +	offset = move_map(orig_offset); +	if (offset != orig_offset) { +		MDBG_MOVE("update ref %d %d -> %d\n", +			  AO_SCHEME_IS_POOL(ref) ? MDBG_OFFSET(ref) : -1, +			  orig_offset, offset); +		*ref = ao_scheme_pool + offset; +	} +	if (busy(ao_scheme_busy, offset)) { +		MDBG_MOVE("already moved\n"); +		return 1; +	} +	mark(ao_scheme_busy, offset); +	MDBG_DO(ao_scheme_record(type, addr, ao_scheme_size(type, addr))); +	return 0; +} + +int +ao_scheme_move(const struct ao_scheme_type *type, void **ref) +{ +	int ret; +	MDBG_MOVE("move object %d\n", MDBG_OFFSET(*ref)); +	MDBG_MOVE_IN(); +	ret = ao_scheme_move_memory(type, ref); +	if (!ret) { +		MDBG_MOVE("move recurse\n"); +		type->move(*ref); +	} +	MDBG_MOVE_OUT(); +	return ret; +} + +int +ao_scheme_poly_move(ao_poly *ref, uint8_t do_note_cons) +{ +	uint8_t		type; +	ao_poly		p = *ref; +	int		ret; +	void		*addr; +	uint16_t	offset, orig_offset; +	uint8_t		base_type; + +	base_type = type = ao_scheme_poly_base_type(p); + +	if (type == AO_SCHEME_INT) +		return 1; + +	addr = ao_scheme_ref(p); +	if (!AO_SCHEME_IS_POOL(addr)) +		return 1; + +	orig_offset = pool_offset(addr); +	offset = move_map(orig_offset); + +	if (type == AO_SCHEME_CONS && do_note_cons) { +		note_cons(orig_offset); +		ret = 1; +	} else { +		if (type == AO_SCHEME_OTHER) +			type = ao_scheme_other_type(ao_scheme_pool + offset); + +		const struct ao_scheme_type *lisp_type = ao_scheme_types[type]; +#if DBG_MEM +		if (!lisp_type) +			ao_scheme_abort(); +#endif + +		ret = ao_scheme_move(lisp_type, &addr); +	} + +	/* Re-write the poly value */ +	if (offset != orig_offset) { +		ao_poly np = ao_scheme_poly(ao_scheme_pool + offset, base_type); +		MDBG_MOVE("poly %d moved %d -> %d\n", +			  type, orig_offset, offset); +		*ref = np; +	} +	return ret; +} + +#if DBG_MEM +void +ao_scheme_validate(void) +{ +	chunk_low = 0; +	memset(ao_scheme_chunk, '\0', sizeof (ao_scheme_chunk)); +	walk(ao_scheme_mark_ref, ao_scheme_poly_mark_ref); +} + +int dbg_allocs; + +#endif + +void * +ao_scheme_alloc(int size) +{ +	void	*addr; + +	MDBG_DO(++dbg_allocs); +	MDBG_DO(if (dbg_validate) ao_scheme_validate()); +	size = ao_scheme_size_round(size); +	if (AO_SCHEME_POOL - ao_scheme_top < size && +	    ao_scheme_collect(AO_SCHEME_COLLECT_INCREMENTAL) < size && +	    ao_scheme_collect(AO_SCHEME_COLLECT_FULL) < size) +	{ +		ao_scheme_error(AO_SCHEME_OOM, "out of memory"); +		return NULL; +	} +	addr = ao_scheme_pool + ao_scheme_top; +	ao_scheme_top += size; +	MDBG_MOVE("alloc %d size %d\n", MDBG_OFFSET(addr), size); +	return addr; +} + +void +ao_scheme_cons_stash(int id, struct ao_scheme_cons *cons) +{ +	assert(save_cons[id] == 0); +	save_cons[id] = cons; +} + +struct ao_scheme_cons * +ao_scheme_cons_fetch(int id) +{ +	struct ao_scheme_cons *cons = save_cons[id]; +	save_cons[id] = NULL; +	return cons; +} + +void +ao_scheme_poly_stash(int id, ao_poly poly) +{ +	assert(save_poly[id] == AO_SCHEME_NIL); +	save_poly[id] = poly; +} + +ao_poly +ao_scheme_poly_fetch(int id) +{ +	ao_poly poly = save_poly[id]; +	save_poly[id] = AO_SCHEME_NIL; +	return poly; +} + +void +ao_scheme_string_stash(int id, char *string) +{ +	assert(save_string[id] == NULL); +	save_string[id] = string; +} + +char * +ao_scheme_string_fetch(int id) +{ +	char *string = save_string[id]; +	save_string[id] = NULL; +	return string; +} + +void +ao_scheme_frame_stash(int id, struct ao_scheme_frame *frame) +{ +	assert(save_frame[id] == NULL); +	save_frame[id] = frame; +} + +struct ao_scheme_frame * +ao_scheme_frame_fetch(int id) +{ +	struct ao_scheme_frame *frame = save_frame[id]; +	save_frame[id] = NULL; +	return frame; +} diff --git a/src/scheme/ao_scheme_poly.c b/src/scheme/ao_scheme_poly.c new file mode 100644 index 00000000..553585db --- /dev/null +++ b/src/scheme/ao_scheme_poly.c @@ -0,0 +1,122 @@ +/* + * Copyright © 2016 Keith Packard <keithp@keithp.com> + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation, either version 2 of the License, or + * (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, but + * WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU + * General Public License for more details. + */ + +#include "ao_scheme.h" + +struct ao_scheme_funcs { +	void (*write)(ao_poly); +	void (*display)(ao_poly); +}; + +static const struct ao_scheme_funcs ao_scheme_funcs[AO_SCHEME_NUM_TYPE] = { +	[AO_SCHEME_CONS] = { +		.write = ao_scheme_cons_write, +		.display = ao_scheme_cons_display, +	}, +	[AO_SCHEME_STRING] = { +		.write = ao_scheme_string_write, +		.display = ao_scheme_string_display, +	}, +	[AO_SCHEME_INT] = { +		.write = ao_scheme_int_write, +		.display = ao_scheme_int_write, +	}, +	[AO_SCHEME_ATOM] = { +		.write = ao_scheme_atom_write, +		.display = ao_scheme_atom_write, +	}, +	[AO_SCHEME_BUILTIN] = { +		.write = ao_scheme_builtin_write, +		.display = ao_scheme_builtin_write, +	}, +	[AO_SCHEME_FRAME] = { +		.write = ao_scheme_frame_write, +		.display = ao_scheme_frame_write, +	}, +	[AO_SCHEME_FRAME_VALS] = { +		.write = NULL, +		.display = NULL, +	}, +	[AO_SCHEME_LAMBDA] = { +		.write = ao_scheme_lambda_write, +		.display = ao_scheme_lambda_write, +	}, +	[AO_SCHEME_STACK] = { +		.write = ao_scheme_stack_write, +		.display = ao_scheme_stack_write, +	}, +	[AO_SCHEME_BOOL] = { +		.write = ao_scheme_bool_write, +		.display = ao_scheme_bool_write, +	}, +	[AO_SCHEME_BIGINT] = { +		.write = ao_scheme_bigint_write, +		.display = ao_scheme_bigint_write, +	}, +	[AO_SCHEME_FLOAT] = { +		.write = ao_scheme_float_write, +		.display = ao_scheme_float_write, +	}, +	[AO_SCHEME_VECTOR] = { +		.write = ao_scheme_vector_write, +		.display = ao_scheme_vector_display +	}, +}; + +static const struct ao_scheme_funcs * +funcs(ao_poly p) +{ +	uint8_t	type = ao_scheme_poly_type(p); + +	if (type < AO_SCHEME_NUM_TYPE) +		return &ao_scheme_funcs[type]; +	return NULL; +} + +void +ao_scheme_poly_write(ao_poly p) +{ +	const struct ao_scheme_funcs *f = funcs(p); + +	if (f && f->write) +		f->write(p); +} + +void +ao_scheme_poly_display(ao_poly p) +{ +	const struct ao_scheme_funcs *f = funcs(p); + +	if (f && f->display) +		f->display(p); +} + +void * +ao_scheme_ref(ao_poly poly) { +	if (poly == AO_SCHEME_NIL) +		return NULL; +	if (poly & AO_SCHEME_CONST) +		return (void *) (ao_scheme_const + (poly & AO_SCHEME_REF_MASK) - 4); +	return (void *) (ao_scheme_pool + (poly & AO_SCHEME_REF_MASK) - 4); +} + +ao_poly +ao_scheme_poly(const void *addr, ao_poly type) { +	const uint8_t	*a = addr; +	if (a == NULL) +		return AO_SCHEME_NIL; +	if (AO_SCHEME_IS_CONST(a)) +		return AO_SCHEME_CONST | (a - ao_scheme_const + 4) | type; +	return (a - ao_scheme_pool + 4) | type; +} diff --git a/src/scheme/ao_scheme_read.c b/src/scheme/ao_scheme_read.c new file mode 100644 index 00000000..9ed54b9f --- /dev/null +++ b/src/scheme/ao_scheme_read.c @@ -0,0 +1,665 @@ +/* + * Copyright © 2016 Keith Packard <keithp@keithp.com> + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation, either version 2 of the License, or + * (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, but + * WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU + * General Public License for more details. + */ + +#include "ao_scheme.h" +#include "ao_scheme_read.h" +#include <math.h> +#include <stdlib.h> + +static const uint16_t	lex_classes[128] = { +	IGNORE,		/* ^@ */ +	IGNORE,		/* ^A */ +	IGNORE,		/* ^B */ +	IGNORE,		/* ^C */ +	IGNORE,		/* ^D */ +	IGNORE,		/* ^E */ +	IGNORE,		/* ^F */ +	IGNORE,		/* ^G */ +	IGNORE,		/* ^H */ +	WHITE,		/* ^I */ +	WHITE,		/* ^J */ +	WHITE,		/* ^K */ +	WHITE,		/* ^L */ +	WHITE,		/* ^M */ +	IGNORE,		/* ^N */ +	IGNORE,		/* ^O */ +	IGNORE,		/* ^P */ +	IGNORE,		/* ^Q */ +	IGNORE,		/* ^R */ +	IGNORE,		/* ^S */ +	IGNORE,		/* ^T */ +	IGNORE,		/* ^U */ +	IGNORE,		/* ^V */ +	IGNORE,		/* ^W */ +	IGNORE,		/* ^X */ +	IGNORE,		/* ^Y */ +	IGNORE,		/* ^Z */ +	IGNORE,		/* ^[ */ +	IGNORE,		/* ^\ */ +	IGNORE,		/* ^] */ +	IGNORE,		/* ^^ */ +	IGNORE,		/* ^_ */ +	PRINTABLE|WHITE,	/*    */ + 	PRINTABLE,		/* ! */ + 	PRINTABLE|STRINGC,	/* " */ + 	PRINTABLE|POUND,	/* # */ + 	PRINTABLE,		/* $ */ + 	PRINTABLE,		/* % */ + 	PRINTABLE,		/* & */ + 	PRINTABLE|SPECIAL,	/* ' */ + 	PRINTABLE|SPECIAL,	/* ( */ + 	PRINTABLE|SPECIAL,	/* ) */ + 	PRINTABLE,		/* * */ + 	PRINTABLE|SIGN,		/* + */ + 	PRINTABLE|SPECIAL,	/* , */ + 	PRINTABLE|SIGN,		/* - */ + 	PRINTABLE|DOTC|FLOATC,	/* . */ + 	PRINTABLE,		/* / */ + 	PRINTABLE|DIGIT,	/* 0 */ + 	PRINTABLE|DIGIT,	/* 1 */ + 	PRINTABLE|DIGIT,	/* 2 */ + 	PRINTABLE|DIGIT,	/* 3 */ + 	PRINTABLE|DIGIT,	/* 4 */ + 	PRINTABLE|DIGIT,	/* 5 */ + 	PRINTABLE|DIGIT,	/* 6 */ + 	PRINTABLE|DIGIT,	/* 7 */ + 	PRINTABLE|DIGIT,	/* 8 */ + 	PRINTABLE|DIGIT,	/* 9 */ + 	PRINTABLE,		/* : */ + 	PRINTABLE|COMMENT,	/* ; */ + 	PRINTABLE,		/* < */ + 	PRINTABLE,		/* = */ + 	PRINTABLE,		/* > */ + 	PRINTABLE,		/* ? */ +  	PRINTABLE,		/*  @ */ +	PRINTABLE,		/*  A */ +	PRINTABLE,		/*  B */ +	PRINTABLE,		/*  C */ +	PRINTABLE,		/*  D */ +	PRINTABLE|FLOATC,	/*  E */ +	PRINTABLE,		/*  F */ +	PRINTABLE,		/*  G */ +	PRINTABLE,		/*  H */ +	PRINTABLE,		/*  I */ +	PRINTABLE,		/*  J */ +	PRINTABLE,		/*  K */ +	PRINTABLE,		/*  L */ +	PRINTABLE,		/*  M */ +	PRINTABLE,		/*  N */ +	PRINTABLE,		/*  O */ +	PRINTABLE,		/*  P */ +	PRINTABLE,		/*  Q */ +	PRINTABLE,		/*  R */ +	PRINTABLE,		/*  S */ +	PRINTABLE,		/*  T */ +	PRINTABLE,		/*  U */ +	PRINTABLE,		/*  V */ +	PRINTABLE,		/*  W */ +	PRINTABLE,		/*  X */ +	PRINTABLE,		/*  Y */ +	PRINTABLE,		/*  Z */ +	PRINTABLE,		/*  [ */ +	PRINTABLE|BACKSLASH,	/*  \ */ +	PRINTABLE,		/*  ] */ +	PRINTABLE,		/*  ^ */ +	PRINTABLE,		/*  _ */ +  	PRINTABLE|SPECIAL,	/*  ` */ +	PRINTABLE,		/*  a */ +	PRINTABLE,		/*  b */ +	PRINTABLE,		/*  c */ +	PRINTABLE,		/*  d */ +	PRINTABLE|FLOATC,	/*  e */ +	PRINTABLE,		/*  f */ +	PRINTABLE,		/*  g */ +	PRINTABLE,		/*  h */ +	PRINTABLE,		/*  i */ +	PRINTABLE,		/*  j */ +	PRINTABLE,		/*  k */ +	PRINTABLE,		/*  l */ +	PRINTABLE,		/*  m */ +	PRINTABLE,		/*  n */ +	PRINTABLE,		/*  o */ +	PRINTABLE,		/*  p */ +	PRINTABLE,		/*  q */ +	PRINTABLE,		/*  r */ +	PRINTABLE,		/*  s */ +	PRINTABLE,		/*  t */ +	PRINTABLE,		/*  u */ +	PRINTABLE,		/*  v */ +	PRINTABLE,		/*  w */ +	PRINTABLE,		/*  x */ +	PRINTABLE,		/*  y */ +	PRINTABLE,		/*  z */ +	PRINTABLE,		/*  { */ +	PRINTABLE,		/*  | */ +	PRINTABLE,		/*  } */ +	PRINTABLE,		/*  ~ */ +	IGNORE,			/*  ^? */ +}; + +static int lex_unget_c; + +static inline int +lex_get(void) +{ +	int	c; +	if (lex_unget_c) { +		c = lex_unget_c; +		lex_unget_c = 0; +	} else { +		c = ao_scheme_getc(); +	} +	return c; +} + +static inline void +lex_unget(int c) +{ +	if (c != EOF) +		lex_unget_c = c; +} + +static uint16_t	lex_class; + +static int +lexc(void) +{ +	int	c; +	do { +		c = lex_get(); +		if (c == EOF) { +			c = 0; +			lex_class = ENDOFFILE; +		} else { +			c &= 0x7f; +			lex_class = lex_classes[c]; +		} +	} while (lex_class & IGNORE); +	return c; +} + +static int +lex_quoted(void) +{ +	int	c; +	int	v; +	int	count; + +	c = lex_get(); +	if (c == EOF) { +		lex_class = ENDOFFILE; +		return 0; +	} +	lex_class = 0; +	c &= 0x7f; + 	switch (c) { +	case 'n': +		return '\n'; +	case 'f': +		return '\f'; +	case 'b': +		return '\b'; +	case 'r': +		return '\r'; +	case 'v': +		return '\v'; +	case 't': +		return '\t'; +	case '0': +	case '1': +	case '2': +	case '3': +	case '4': +	case '5': +	case '6': +	case '7': +		v = c - '0'; +		count = 1; +		while (count <= 3) { +			c = lex_get(); +			if (c == EOF) +				return EOF; +			c &= 0x7f; +			if (c < '0' || '7' < c) { +				lex_unget(c); +				break; +			} +			v = (v << 3) + c - '0'; +			++count; +		} +		return v; +	default: +		return c; +	} +} + +#define AO_SCHEME_TOKEN_MAX	128 + +static char	token_string[AO_SCHEME_TOKEN_MAX]; +static int32_t	token_int; +static int	token_len; +static float	token_float; + +static inline void add_token(int c) { +	if (c && token_len < AO_SCHEME_TOKEN_MAX - 1) +		token_string[token_len++] = c; +} + +static inline void del_token(void) { +	if (token_len > 0) +		token_len--; +} + +static inline void end_token(void) { +	token_string[token_len] = '\0'; +} + +struct namedfloat { +	const char	*name; +	float		value; +}; + +static const struct namedfloat namedfloats[] = { +	{ .name = "+inf.0", .value = INFINITY }, +	{ .name = "-inf.0", .value = -INFINITY }, +	{ .name = "+nan.0", .value = NAN }, +	{ .name = "-nan.0", .value = NAN }, +}; + +#define NUM_NAMED_FLOATS	(sizeof namedfloats / sizeof namedfloats[0]) + +static int +_lex(void) +{ +	int	c; + +	token_len = 0; +	for (;;) { +		c = lexc(); +		if (lex_class & ENDOFFILE) +			return END; + +		if (lex_class & WHITE) +			continue; + +		if (lex_class & COMMENT) { +			while ((c = lexc()) != '\n') { +				if (lex_class & ENDOFFILE) +					return END; +			} +			continue; +		} + +		if (lex_class & (SPECIAL|DOTC)) { +			add_token(c); +			end_token(); +			switch (c) { +			case '(': +			case '[': +				return OPEN; +			case ')': +			case ']': +				return CLOSE; +			case '\'': +				return QUOTE; +			case '.': +				return DOT; +			case '`': +				return QUASIQUOTE; +			case ',': +				c = lexc(); +				if (c == '@') { +					add_token(c); +					end_token(); +					return UNQUOTE_SPLICING; +				} else { +					lex_unget(c); +					return UNQUOTE; +				} +			} +		} +		if (lex_class & POUND) { +			c = lexc(); +			switch (c) { +			case 't': +				add_token(c); +				end_token(); +				return BOOL; +			case 'f': +				add_token(c); +				end_token(); +				return BOOL; +			case '(': +				return OPEN_VECTOR; +			case '\\': +				for (;;) { +					int alphabetic; +					c = lexc(); +					alphabetic = (('a' <= c && c <= 'z') || ('A' <= c && c <= 'Z')); +					if (token_len == 0) { +						add_token(c); +						if (!alphabetic) +							break; +					} else { +						if (alphabetic) +							add_token(c); +						else { +							lex_unget(c); +							break; +						} +					} +				} +				end_token(); +				if (token_len == 1) +					token_int = token_string[0]; +				else if (!strcmp(token_string, "space")) +					token_int = ' '; +				else if (!strcmp(token_string, "newline")) +					token_int = '\n'; +				else if (!strcmp(token_string, "tab")) +					token_int = '\t'; +				else if (!strcmp(token_string, "return")) +					token_int = '\r'; +				else if (!strcmp(token_string, "formfeed")) +					token_int = '\f'; +				else { +					ao_scheme_error(AO_SCHEME_INVALID, "invalid character token #\\%s", token_string); +					continue; +				} +				return NUM; +			} +		} +		if (lex_class & STRINGC) { +			for (;;) { +				c = lexc(); +				if (lex_class & BACKSLASH) +					c = lex_quoted(); +				if (lex_class & (STRINGC|ENDOFFILE)) { +					end_token(); +					return STRING; +				} +				add_token(c); +			} +		} +		if (lex_class & PRINTABLE) { +			int	isfloat; +			int	hasdigit; +			int	isneg; +			int	isint; +			int	epos; + +			isfloat = 1; +			isint = 1; +			hasdigit = 0; +			token_int = 0; +			isneg = 0; +			epos = 0; +			for (;;) { +				if (!(lex_class & NUMBER)) { +					isint = 0; +					isfloat = 0; +				} else { +					if (!(lex_class & INTEGER)) +						isint = 0; + 					if (token_len != epos && +					    (lex_class & SIGN)) +					{ +						isint = 0; +						isfloat = 0; +					} +					if (c == '-') +						isneg = 1; +					if (c == '.' && epos != 0) +						isfloat = 0; +					if (c == 'e' || c == 'E') { +						if (token_len == 0) +							isfloat = 0; +						else +							epos = token_len + 1; +					} +					if (lex_class & DIGIT) { +						hasdigit = 1; +						if (isint) +							token_int = token_int * 10 + c - '0'; +					} +				} +				add_token (c); +				c = lexc (); +				if ((lex_class & (NOTNAME)) && (c != '.' || !isfloat)) { +					unsigned int u; +//					if (lex_class & ENDOFFILE) +//						clearerr (f); +					lex_unget(c); +					end_token (); +					if (isint && hasdigit) { +						if (isneg) +							token_int = -token_int; +						return NUM; +					} +					if (isfloat && hasdigit) { +						token_float = strtof(token_string, NULL); +						return FLOAT; +					} +					for (u = 0; u < NUM_NAMED_FLOATS; u++) +						if (!strcmp(namedfloats[u].name, token_string)) { +							token_float = namedfloats[u].value; +							return FLOAT; +						} +					return NAME; +				} +			} +		} +	} +} + +static inline int lex(void) +{ +	int	parse_token = _lex(); +	RDBGI("token %d (%s)\n", parse_token, token_string); +	return parse_token; +} + +static int parse_token; + +int			ao_scheme_read_list; +struct ao_scheme_cons	*ao_scheme_read_cons; +struct ao_scheme_cons	*ao_scheme_read_cons_tail; +struct ao_scheme_cons	*ao_scheme_read_stack; +static int		ao_scheme_read_state; + +#define READ_IN_QUOTE	0x01 +#define READ_SAW_DOT	0x02 +#define READ_DONE_DOT	0x04 +#define READ_SAW_VECTOR	0x08 + +static int +push_read_stack(int read_state) +{ +	RDBGI("push read stack %p 0x%x\n", ao_scheme_read_cons, read_state); +	RDBG_IN(); +	if (ao_scheme_read_list) { +		ao_scheme_read_stack = ao_scheme_cons_cons(ao_scheme_cons_poly(ao_scheme_read_cons), +						       ao_scheme__cons(ao_scheme_int_poly(read_state), +								     ao_scheme_cons_poly(ao_scheme_read_stack))); +		if (!ao_scheme_read_stack) +			return 0; +	} else +		ao_scheme_read_state = read_state; +	ao_scheme_read_cons = NULL; +	ao_scheme_read_cons_tail = NULL; +	return 1; +} + +static int +pop_read_stack(void) +{ +	int	read_state = 0; +	if (ao_scheme_read_list) { +		ao_scheme_read_cons = ao_scheme_poly_cons(ao_scheme_read_stack->car); +		ao_scheme_read_stack = ao_scheme_poly_cons(ao_scheme_read_stack->cdr); +		read_state = ao_scheme_poly_int(ao_scheme_read_stack->car); +		ao_scheme_read_stack = ao_scheme_poly_cons(ao_scheme_read_stack->cdr); +		for (ao_scheme_read_cons_tail = ao_scheme_read_cons; +		     ao_scheme_read_cons_tail && ao_scheme_read_cons_tail->cdr; +		     ao_scheme_read_cons_tail = ao_scheme_poly_cons(ao_scheme_read_cons_tail->cdr)) +			; +	} else { +		ao_scheme_read_cons = 0; +		ao_scheme_read_cons_tail = 0; +		ao_scheme_read_stack = 0; +		read_state = ao_scheme_read_state; +	} +	RDBG_OUT(); +	RDBGI("pop read stack %p %d\n", ao_scheme_read_cons, read_state); +	return read_state; +} + +ao_poly +ao_scheme_read(void) +{ +	struct ao_scheme_atom	*atom; +	char			*string; +	int			read_state; +	ao_poly			v = AO_SCHEME_NIL; + +	ao_scheme_read_list = 0; +	read_state = 0; +	ao_scheme_read_cons = ao_scheme_read_cons_tail = ao_scheme_read_stack = 0; +	for (;;) { +		parse_token = lex(); +		while (parse_token == OPEN || parse_token == OPEN_VECTOR) { +			if (parse_token == OPEN_VECTOR) +				read_state |= READ_SAW_VECTOR; +			if (!push_read_stack(read_state)) +				return AO_SCHEME_NIL; +			ao_scheme_read_list++; +			read_state = 0; +			parse_token = lex(); +		} + +		switch (parse_token) { +		case END: +		default: +			if (ao_scheme_read_list) +				ao_scheme_error(AO_SCHEME_EOF, "unexpected end of file"); +			return _ao_scheme_atom_eof; +			break; +		case NAME: +			atom = ao_scheme_atom_intern(token_string); +			if (atom) +				v = ao_scheme_atom_poly(atom); +			else +				v = AO_SCHEME_NIL; +			break; +		case NUM: +			v = ao_scheme_integer_poly(token_int); +			break; +		case FLOAT: +			v = ao_scheme_float_get(token_float); +			break; +		case BOOL: +			if (token_string[0] == 't') +				v = _ao_scheme_bool_true; +			else +				v = _ao_scheme_bool_false; +			break; +		case STRING: +			string = ao_scheme_string_copy(token_string); +			if (string) +				v = ao_scheme_string_poly(string); +			else +				v = AO_SCHEME_NIL; +			break; +		case QUOTE: +		case QUASIQUOTE: +		case UNQUOTE: +		case UNQUOTE_SPLICING: +			if (!push_read_stack(read_state)) +				return AO_SCHEME_NIL; +			ao_scheme_read_list++; +			read_state = READ_IN_QUOTE; +			switch (parse_token) { +			case QUOTE: +				v = _ao_scheme_atom_quote; +				break; +			case QUASIQUOTE: +				v = _ao_scheme_atom_quasiquote; +				break; +			case UNQUOTE: +				v = _ao_scheme_atom_unquote; +				break; +			case UNQUOTE_SPLICING: +				v = _ao_scheme_atom_unquote2dsplicing; +				break; +			} +			break; +		case CLOSE: +			if (!ao_scheme_read_list) { +				v = AO_SCHEME_NIL; +				break; +			} +			v = ao_scheme_cons_poly(ao_scheme_read_cons); +			--ao_scheme_read_list; +			read_state = pop_read_stack(); +			if (read_state & READ_SAW_VECTOR) +				v = ao_scheme_vector_poly(ao_scheme_list_to_vector(ao_scheme_poly_cons(v))); +			break; +		case DOT: +			if (!ao_scheme_read_list) { +				ao_scheme_error(AO_SCHEME_INVALID, ". outside of cons"); +				return AO_SCHEME_NIL; +			} +			if (!ao_scheme_read_cons) { +				ao_scheme_error(AO_SCHEME_INVALID, ". first in cons"); +				return AO_SCHEME_NIL; +			} +			read_state |= READ_SAW_DOT; +			continue; +		} + +		/* loop over QUOTE ends */ +		for (;;) { +			if (!ao_scheme_read_list) +				return v; + +			if (read_state & READ_DONE_DOT) { +				ao_scheme_error(AO_SCHEME_INVALID, ". not last in cons"); +				return AO_SCHEME_NIL; +			} + +			if (read_state & READ_SAW_DOT) { +				read_state |= READ_DONE_DOT; +				ao_scheme_read_cons_tail->cdr = v; +			} else { +				struct ao_scheme_cons	*read = ao_scheme_cons_cons(v, AO_SCHEME_NIL); +				if (!read) +					return AO_SCHEME_NIL; + +				if (ao_scheme_read_cons_tail) +					ao_scheme_read_cons_tail->cdr = ao_scheme_cons_poly(read); +				else +					ao_scheme_read_cons = read; +				ao_scheme_read_cons_tail = read; +			} + +			if (!(read_state & READ_IN_QUOTE) || !ao_scheme_read_cons->cdr) +				break; + +			v = ao_scheme_cons_poly(ao_scheme_read_cons); +			--ao_scheme_read_list; +			read_state = pop_read_stack(); +		} +	} +	return v; +} diff --git a/src/scheme/ao_scheme_read.h b/src/scheme/ao_scheme_read.h new file mode 100644 index 00000000..e10a7d05 --- /dev/null +++ b/src/scheme/ao_scheme_read.h @@ -0,0 +1,59 @@ +/* + * Copyright © 2016 Keith Packard <keithp@keithp.com> + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation, either version 2 of the License, or + * (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, but + * WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU + * General Public License for more details. + */ + +#ifndef _AO_SCHEME_READ_H_ +#define _AO_SCHEME_READ_H_ + +/* + * token classes + */ + +# define END			0 +# define NAME			1 +# define OPEN  			2 +# define CLOSE			3 +# define QUOTE			4 +# define QUASIQUOTE		5 +# define UNQUOTE		6 +# define UNQUOTE_SPLICING	7 +# define STRING			8 +# define NUM			9 +# define FLOAT			10 +# define DOT			11 +# define BOOL			12 +# define OPEN_VECTOR		13 + +/* + * character classes + */ + +# define PRINTABLE	0x0001	/* \t \n ' ' - ~ */ +# define SPECIAL	0x0002	/* ( [ { ) ] } ' ` , */ +# define DOTC		0x0004	/* . */ +# define WHITE		0x0008	/* ' ' \t \n */ +# define DIGIT		0x0010	/* [0-9] */ +# define SIGN		0x0020	/* +- */ +# define FLOATC		0x0040	/* . e E */ +# define ENDOFFILE	0x0080	/* end of file */ +# define COMMENT	0x0100	/* ; */ +# define IGNORE		0x0200	/* \0 - ' ' */ +# define BACKSLASH	0x0400	/* \ */ +# define STRINGC	0x0800	/* " */ +# define POUND		0x1000	/* # */ + +# define NOTNAME	(STRINGC|COMMENT|ENDOFFILE|WHITE|SPECIAL) +# define INTEGER	(DIGIT|SIGN) +# define NUMBER		(INTEGER|FLOATC) + +#endif /* _AO_SCHEME_READ_H_ */ diff --git a/src/lisp/ao_lisp_rep.c b/src/scheme/ao_scheme_rep.c index 3be95d44..5b94d940 100644 --- a/src/lisp/ao_lisp_rep.c +++ b/src/scheme/ao_scheme_rep.c @@ -12,21 +12,25 @@   * General Public License for more details.   */ -#include "ao_lisp.h" +#include "ao_scheme.h"  ao_poly -ao_lisp_read_eval_print(void) +ao_scheme_read_eval_print(void)  { -	ao_poly	in, out = AO_LISP_NIL; +	ao_poly	in, out = AO_SCHEME_NIL; + +	ao_scheme_exception = 0;  	for(;;) { -		in = ao_lisp_read(); -		if (in == _ao_lisp_atom_eof || in == AO_LISP_NIL) +		in = ao_scheme_read(); +		if (in == _ao_scheme_atom_eof)  			break; -		out = ao_lisp_eval(in); -		if (ao_lisp_exception) { -			ao_lisp_exception = 0; +		out = ao_scheme_eval(in); +		if (ao_scheme_exception) { +			if (ao_scheme_exception & AO_SCHEME_EXIT) +				break; +			ao_scheme_exception = 0;  		} else { -			ao_lisp_poly_print(out); +			ao_scheme_poly_write(out);  			putchar ('\n');  		}  	} diff --git a/src/scheme/ao_scheme_save.c b/src/scheme/ao_scheme_save.c new file mode 100644 index 00000000..af9345b8 --- /dev/null +++ b/src/scheme/ao_scheme_save.c @@ -0,0 +1,77 @@ +/* + * Copyright © 2016 Keith Packard <keithp@keithp.com> + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation, either version 2 of the License, or + * (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, but + * WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU + * General Public License for more details. + */ + +#include "ao_scheme.h" + +ao_poly +ao_scheme_do_save(struct ao_scheme_cons *cons) +{ +	if (!ao_scheme_check_argc(_ao_scheme_atom_save, cons, 0, 0)) +		return AO_SCHEME_NIL; + +#ifdef AO_SCHEME_SAVE +	struct ao_scheme_os_save *os = (struct ao_scheme_os_save *) (void *) &ao_scheme_pool[AO_SCHEME_POOL]; + +	ao_scheme_collect(AO_SCHEME_COLLECT_FULL); +	os->atoms = ao_scheme_atom_poly(ao_scheme_atoms); +	os->globals = ao_scheme_frame_poly(ao_scheme_frame_global); +	os->const_checksum = ao_scheme_const_checksum; +	os->const_checksum_inv = (uint16_t) ~ao_scheme_const_checksum; + +	if (ao_scheme_os_save()) +		return _ao_scheme_bool_true; +#endif +	return _ao_scheme_bool_false; +} + +ao_poly +ao_scheme_do_restore(struct ao_scheme_cons *cons) +{ +	if (!ao_scheme_check_argc(_ao_scheme_atom_save, cons, 0, 0)) +		return AO_SCHEME_NIL; + +#ifdef AO_SCHEME_SAVE +	struct ao_scheme_os_save save; +	struct ao_scheme_os_save *os = (struct ao_scheme_os_save *) (void *) &ao_scheme_pool[AO_SCHEME_POOL]; + +	if (!ao_scheme_os_restore_save(&save, AO_SCHEME_POOL)) +		return ao_scheme_error(AO_SCHEME_INVALID, "header restore failed"); + +	if (save.const_checksum != ao_scheme_const_checksum || +	    save.const_checksum_inv != (uint16_t) ~ao_scheme_const_checksum) +	{ +		return ao_scheme_error(AO_SCHEME_INVALID, "image is corrupted or stale"); +	} + +	if (ao_scheme_os_restore()) { + +		ao_scheme_atoms = ao_scheme_poly_atom(os->atoms); +		ao_scheme_frame_global = ao_scheme_poly_frame(os->globals); + +		/* Clear the eval global variabls */ +		ao_scheme_eval_clear_globals(); + +		/* Reset the allocator */ +		ao_scheme_top = AO_SCHEME_POOL; +		ao_scheme_collect(AO_SCHEME_COLLECT_FULL); + +		/* Re-create the evaluator stack */ +		if (!ao_scheme_eval_restart()) +			return _ao_scheme_bool_false; + +		return _ao_scheme_bool_true; +	} +#endif +	return _ao_scheme_bool_false; +} diff --git a/src/scheme/ao_scheme_stack.c b/src/scheme/ao_scheme_stack.c new file mode 100644 index 00000000..d19dd6d6 --- /dev/null +++ b/src/scheme/ao_scheme_stack.c @@ -0,0 +1,280 @@ +/* + * Copyright © 2016 Keith Packard <keithp@keithp.com> + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation, either version 2 of the License, or + * (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, but + * WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU + * General Public License for more details. + */ + +#include "ao_scheme.h" + +const struct ao_scheme_type ao_scheme_stack_type; + +static int +stack_size(void *addr) +{ +	(void) addr; +	return sizeof (struct ao_scheme_stack); +} + +static void +stack_mark(void *addr) +{ +	struct ao_scheme_stack	*stack = addr; +	for (;;) { +		ao_scheme_poly_mark(stack->sexprs, 0); +		ao_scheme_poly_mark(stack->values, 0); +		/* no need to mark values_tail */ +		ao_scheme_poly_mark(stack->frame, 0); +		ao_scheme_poly_mark(stack->list, 0); +		stack = ao_scheme_poly_stack(stack->prev); +		if (ao_scheme_mark_memory(&ao_scheme_stack_type, stack)) +			break; +	} +} + +static void +stack_move(void *addr) +{ +	struct ao_scheme_stack	*stack = addr; + +	while (stack) { +		struct ao_scheme_stack	*prev; +		int			ret; +		(void) ao_scheme_poly_move(&stack->sexprs, 0); +		(void) ao_scheme_poly_move(&stack->values, 0); +		(void) ao_scheme_poly_move(&stack->values_tail, 0); +		(void) ao_scheme_poly_move(&stack->frame, 0); +		(void) ao_scheme_poly_move(&stack->list, 0); +		prev = ao_scheme_poly_stack(stack->prev); +		if (!prev) +			break; +		ret = ao_scheme_move_memory(&ao_scheme_stack_type, (void **) &prev); +		if (prev != ao_scheme_poly_stack(stack->prev)) +			stack->prev = ao_scheme_stack_poly(prev); +		if (ret) +			break; +		stack = prev; +	} +} + +const struct ao_scheme_type ao_scheme_stack_type = { +	.size = stack_size, +	.mark = stack_mark, +	.move = stack_move, +	.name = "stack" +}; + +struct ao_scheme_stack		*ao_scheme_stack_free_list; + +void +ao_scheme_stack_reset(struct ao_scheme_stack *stack) +{ +	stack->state = eval_sexpr; +	stack->sexprs = AO_SCHEME_NIL; +	stack->values = AO_SCHEME_NIL; +	stack->values_tail = AO_SCHEME_NIL; +} + +static struct ao_scheme_stack * +ao_scheme_stack_new(void) +{ +	struct ao_scheme_stack *stack; + +	if (ao_scheme_stack_free_list) { +		stack = ao_scheme_stack_free_list; +		ao_scheme_stack_free_list = ao_scheme_poly_stack(stack->prev); +	} else { +		stack = ao_scheme_alloc(sizeof (struct ao_scheme_stack)); +		if (!stack) +			return 0; +		stack->type = AO_SCHEME_STACK; +	} +	ao_scheme_stack_reset(stack); +	return stack; +} + +int +ao_scheme_stack_push(void) +{ +	struct ao_scheme_stack	*stack; + +	stack = ao_scheme_stack_new(); + +	if (!stack) +		return 0; + +	stack->prev = ao_scheme_stack_poly(ao_scheme_stack); +	stack->frame = ao_scheme_frame_poly(ao_scheme_frame_current); +	stack->list = AO_SCHEME_NIL; + +	ao_scheme_stack = stack; + +	DBGI("stack push\n"); +	DBG_FRAMES(); +	DBG_IN(); +	return 1; +} + +void +ao_scheme_stack_pop(void) +{ +	ao_poly			prev; +	struct ao_scheme_frame	*prev_frame; + +	if (!ao_scheme_stack) +		return; +	prev = ao_scheme_stack->prev; +	if (!ao_scheme_stack_marked(ao_scheme_stack)) { +		ao_scheme_stack->prev = ao_scheme_stack_poly(ao_scheme_stack_free_list); +		ao_scheme_stack_free_list = ao_scheme_stack; +	} + +	ao_scheme_stack = ao_scheme_poly_stack(prev); +	prev_frame = ao_scheme_frame_current; +	if (ao_scheme_stack) +		ao_scheme_frame_current = ao_scheme_poly_frame(ao_scheme_stack->frame); +	else +		ao_scheme_frame_current = NULL; +	if (ao_scheme_frame_current != prev_frame) +		ao_scheme_frame_free(prev_frame); +	DBG_OUT(); +	DBGI("stack pop\n"); +	DBG_FRAMES(); +} + +void +ao_scheme_stack_clear(void) +{ +	ao_scheme_stack = NULL; +	ao_scheme_frame_current = NULL; +	ao_scheme_v = AO_SCHEME_NIL; +} + +void +ao_scheme_stack_write(ao_poly poly) +{ +	struct ao_scheme_stack *s = ao_scheme_poly_stack(poly); + +	while (s) { +		if (s->type & AO_SCHEME_STACK_PRINT) { +			printf("[recurse...]"); +			return; +		} +		s->type |= AO_SCHEME_STACK_PRINT; +		printf("\t[\n"); +		printf("\t\texpr:   "); ao_scheme_poly_write(s->list); printf("\n"); +		printf("\t\tstate:  %s\n", ao_scheme_state_names[s->state]); +		ao_scheme_error_poly ("values: ", s->values, s->values_tail); +		ao_scheme_error_poly ("sexprs: ", s->sexprs, AO_SCHEME_NIL); +		ao_scheme_error_frame(2, "frame:  ", ao_scheme_poly_frame(s->frame)); +		printf("\t]\n"); +		s->type &= ~AO_SCHEME_STACK_PRINT; +		s = ao_scheme_poly_stack(s->prev); +	} +} + +/* + * Copy a stack, being careful to keep everybody referenced + */ +static struct ao_scheme_stack * +ao_scheme_stack_copy(struct ao_scheme_stack *old) +{ +	struct ao_scheme_stack *new = NULL; +	struct ao_scheme_stack *n, *prev = NULL; + +	while (old) { +		ao_scheme_stack_stash(0, old); +		ao_scheme_stack_stash(1, new); +		ao_scheme_stack_stash(2, prev); +		n = ao_scheme_stack_new(); +		prev = ao_scheme_stack_fetch(2); +		new = ao_scheme_stack_fetch(1); +		old = ao_scheme_stack_fetch(0); +		if (!n) +			return NULL; + +		ao_scheme_stack_mark(old); +		ao_scheme_frame_mark(ao_scheme_poly_frame(old->frame)); +		*n = *old; + +		if (prev) +			prev->prev = ao_scheme_stack_poly(n); +		else +			new = n; +		prev = n; + +		old = ao_scheme_poly_stack(old->prev); +	} +	return new; +} + +/* + * Evaluate a continuation invocation + */ +ao_poly +ao_scheme_stack_eval(void) +{ +	struct ao_scheme_stack	*new = ao_scheme_stack_copy(ao_scheme_poly_stack(ao_scheme_v)); +	if (!new) +		return AO_SCHEME_NIL; + +	struct ao_scheme_cons	*cons = ao_scheme_poly_cons(ao_scheme_stack->values); + +	if (!cons || !cons->cdr) +		return ao_scheme_error(AO_SCHEME_INVALID, "continuation requires a value"); + +	new->state = eval_val; + +	ao_scheme_stack = new; +	ao_scheme_frame_current = ao_scheme_poly_frame(ao_scheme_stack->frame); + +	return ao_scheme_poly_cons(cons->cdr)->car; +} + +/* + * Call with current continuation. This calls a lambda, passing + * it a single argument which is the current continuation + */ +ao_poly +ao_scheme_do_call_cc(struct ao_scheme_cons *cons) +{ +	struct ao_scheme_stack	*new; +	ao_poly			v; + +	/* Make sure the single parameter is a lambda */ +	if (!ao_scheme_check_argc(_ao_scheme_atom_call2fcc, cons, 1, 1)) +		return AO_SCHEME_NIL; +	if (!ao_scheme_check_argt(_ao_scheme_atom_call2fcc, cons, 0, AO_SCHEME_LAMBDA, 0)) +		return AO_SCHEME_NIL; + +	/* go get the lambda */ +	ao_scheme_v = ao_scheme_arg(cons, 0); + +	/* Note that the whole call chain now has +	 * a reference to it which may escape +	 */ +	new = ao_scheme_stack_copy(ao_scheme_stack); +	if (!new) +		return AO_SCHEME_NIL; + +	/* re-fetch cons after the allocation */ +	cons = ao_scheme_poly_cons(ao_scheme_poly_cons(ao_scheme_stack->values)->cdr); + +	/* Reset the arg list to the current stack, +	 * and call the lambda +	 */ + +	cons->car = ao_scheme_stack_poly(new); +	cons->cdr = AO_SCHEME_NIL; +	v = ao_scheme_lambda_eval(); +	ao_scheme_stack->sexprs = v; +	ao_scheme_stack->state = eval_begin; +	return AO_SCHEME_NIL; +} diff --git a/src/lisp/ao_lisp_string.c b/src/scheme/ao_scheme_string.c index cd7b27a9..e25306cb 100644 --- a/src/lisp/ao_lisp_string.c +++ b/src/scheme/ao_scheme_string.c @@ -15,7 +15,7 @@   * 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA.   */ -#include "ao_lisp.h" +#include "ao_scheme.h"  static void string_mark(void *addr)  { @@ -34,7 +34,7 @@ static void string_move(void *addr)  	(void) addr;  } -const struct ao_lisp_type ao_lisp_string_type = { +const struct ao_scheme_type ao_scheme_string_type = {  	.mark = string_mark,  	.size = string_size,  	.move = string_move, @@ -42,13 +42,13 @@ const struct ao_lisp_type ao_lisp_string_type = {  };  char * -ao_lisp_string_copy(char *a) +ao_scheme_string_copy(char *a)  {  	int	alen = strlen(a); -	ao_lisp_string_stash(0, a); -	char	*r = ao_lisp_alloc(alen + 1); -	a = ao_lisp_string_fetch(0); +	ao_scheme_string_stash(0, a); +	char	*r = ao_scheme_alloc(alen + 1); +	a = ao_scheme_string_fetch(0);  	if (!r)  		return NULL;  	strcpy(r, a); @@ -56,16 +56,16 @@ ao_lisp_string_copy(char *a)  }  char * -ao_lisp_string_cat(char *a, char *b) +ao_scheme_string_cat(char *a, char *b)  {  	int	alen = strlen(a);  	int	blen = strlen(b); -	ao_lisp_string_stash(0, a); -	ao_lisp_string_stash(1, b); -	char	*r = ao_lisp_alloc(alen + blen + 1); -	a = ao_lisp_string_fetch(0); -	b = ao_lisp_string_fetch(1); +	ao_scheme_string_stash(0, a); +	ao_scheme_string_stash(1, b); +	char	*r = ao_scheme_alloc(alen + blen + 1); +	a = ao_scheme_string_fetch(0); +	b = ao_scheme_string_fetch(1);  	if (!r)  		return NULL;  	strcpy(r, a); @@ -74,57 +74,57 @@ ao_lisp_string_cat(char *a, char *b)  }  ao_poly -ao_lisp_string_pack(struct ao_lisp_cons *cons) +ao_scheme_string_pack(struct ao_scheme_cons *cons)  { -	int	len = ao_lisp_cons_length(cons); -	ao_lisp_cons_stash(0, cons); -	char	*r = ao_lisp_alloc(len + 1); -	cons = ao_lisp_cons_fetch(0); +	int	len = ao_scheme_cons_length(cons); +	ao_scheme_cons_stash(0, cons); +	char	*r = ao_scheme_alloc(len + 1); +	cons = ao_scheme_cons_fetch(0);  	char	*s = r;  	while (cons) { -		if (ao_lisp_poly_type(cons->car) != AO_LISP_INT) -			return ao_lisp_error(AO_LISP_INVALID, "non-int passed to pack"); -		*s++ = ao_lisp_poly_int(cons->car); -		cons = ao_lisp_poly_cons(cons->cdr); +		if (!ao_scheme_integer_typep(ao_scheme_poly_type(cons->car))) +			return ao_scheme_error(AO_SCHEME_INVALID, "non-int passed to pack"); +		*s++ = ao_scheme_poly_integer(cons->car); +		cons = ao_scheme_poly_cons(cons->cdr);  	}  	*s++ = 0; -	return ao_lisp_string_poly(r); +	return ao_scheme_string_poly(r);  }  ao_poly -ao_lisp_string_unpack(char *a) +ao_scheme_string_unpack(char *a)  { -	struct ao_lisp_cons	*cons = NULL, *tail = NULL; +	struct ao_scheme_cons	*cons = NULL, *tail = NULL;  	int			c;  	int			i;  	for (i = 0; (c = a[i]); i++) { -		ao_lisp_cons_stash(0, cons); -		ao_lisp_cons_stash(1, tail); -		ao_lisp_string_stash(0, a); -		struct ao_lisp_cons	*n = ao_lisp_cons_cons(ao_lisp_int_poly(c), NULL); -		a = ao_lisp_string_fetch(0); -		cons = ao_lisp_cons_fetch(0); -		tail = ao_lisp_cons_fetch(1); +		ao_scheme_cons_stash(0, cons); +		ao_scheme_cons_stash(1, tail); +		ao_scheme_string_stash(0, a); +		struct ao_scheme_cons	*n = ao_scheme_cons_cons(ao_scheme_int_poly(c), AO_SCHEME_NIL); +		a = ao_scheme_string_fetch(0); +		cons = ao_scheme_cons_fetch(0); +		tail = ao_scheme_cons_fetch(1);  		if (!n) {  			cons = NULL;  			break;  		}  		if (tail) -			tail->cdr = ao_lisp_cons_poly(n); +			tail->cdr = ao_scheme_cons_poly(n);  		else  			cons = n;  		tail = n;  	} -	return ao_lisp_cons_poly(cons); +	return ao_scheme_cons_poly(cons);  }  void -ao_lisp_string_print(ao_poly p) +ao_scheme_string_write(ao_poly p)  { -	char	*s = ao_lisp_poly_string(p); +	char	*s = ao_scheme_poly_string(p);  	char	c;  	putchar('"'); @@ -140,7 +140,10 @@ ao_lisp_string_print(ao_poly p)  			printf ("\\t");  			break;  		default: -			putchar(c); +			if (c < ' ') +				printf("\\%03o", c); +			else +				putchar(c);  			break;  		}  	} @@ -148,9 +151,9 @@ ao_lisp_string_print(ao_poly p)  }  void -ao_lisp_string_patom(ao_poly p) +ao_scheme_string_display(ao_poly p)  { -	char	*s = ao_lisp_poly_string(p); +	char	*s = ao_scheme_poly_string(p);  	char	c;  	while ((c = *s++)) diff --git a/src/scheme/make-const/.gitignore b/src/scheme/make-const/.gitignore new file mode 100644 index 00000000..bcd57242 --- /dev/null +++ b/src/scheme/make-const/.gitignore @@ -0,0 +1 @@ +ao_scheme_make_const diff --git a/src/scheme/make-const/Makefile b/src/scheme/make-const/Makefile new file mode 100644 index 00000000..caf7acbe --- /dev/null +++ b/src/scheme/make-const/Makefile @@ -0,0 +1,26 @@ +include ../Makefile-inc + +vpath %.o . +vpath %.c .. +vpath %.h .. + +SRCS=$(SCHEME_SRCS) ao_scheme_make_const.c +HDRS=$(SCHEME_HDRS) ao_scheme_os.h + +OBJS=$(SRCS:.c=.o) + +CC=cc +CFLAGS=-DAO_SCHEME_MAKE_CONST -O0 -g -I. -Wall -Wextra + +.c.o: +	$(CC) -c $(CFLAGS) $< -o $@ + +all: ao_scheme_make_const + +ao_scheme_make_const: $(OBJS) +	$(CC) $(CFLAGS) -o $@ $^ -lm + +clean: +	rm -f $(OBJS) ao_scheme_make_const + +$(OBJS): $(SCHEME_HDRS) diff --git a/src/test/ao_lisp_os.h b/src/scheme/make-const/ao_scheme_os.h index 9ff2e1fe..f06bbbb1 100644 --- a/src/test/ao_lisp_os.h +++ b/src/scheme/make-const/ao_scheme_os.h @@ -15,45 +15,49 @@   * 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA.   */ -#ifndef _AO_LISP_OS_H_ -#define _AO_LISP_OS_H_ +#ifndef _AO_SCHEME_OS_H_ +#define _AO_SCHEME_OS_H_  #include <stdio.h>  #include <stdlib.h>  #include <time.h> -#define AO_LISP_POOL_TOTAL	3072 -#define AO_LISP_SAVE		1 -#define DBG_MEM_STATS		1 - -extern int ao_lisp_getc(void); +extern int ao_scheme_getc(void);  static inline void -ao_lisp_os_flush() { +ao_scheme_os_flush(void) {  	fflush(stdout);  }  static inline void -ao_lisp_abort(void) +ao_scheme_abort(void)  {  	abort();  }  static inline void -ao_lisp_os_led(int led) +ao_scheme_os_led(int led)  {  	printf("leds set to 0x%x\n", led);  } +#define AO_SCHEME_JIFFIES_PER_SECOND	100 +  static inline void -ao_lisp_os_delay(int delay) +ao_scheme_os_delay(int jiffies)  { -	if (!delay) -		return;  	struct timespec ts = { -		.tv_sec = delay / 1000, -		.tv_nsec = (delay % 1000) * 1000000, +		.tv_sec = jiffies / AO_SCHEME_JIFFIES_PER_SECOND, +		.tv_nsec = (jiffies % AO_SCHEME_JIFFIES_PER_SECOND) * (1000000000L / AO_SCHEME_JIFFIES_PER_SECOND)  	};  	nanosleep(&ts, NULL);  } + +static inline int +ao_scheme_os_jiffy(void) +{ +	struct timespec tp; +	clock_gettime(CLOCK_MONOTONIC, &tp); +	return tp.tv_sec * AO_SCHEME_JIFFIES_PER_SECOND + (tp.tv_nsec / (1000000000L / AO_SCHEME_JIFFIES_PER_SECOND)); +}  #endif diff --git a/src/scheme/test/.gitignore b/src/scheme/test/.gitignore new file mode 100644 index 00000000..3cdae594 --- /dev/null +++ b/src/scheme/test/.gitignore @@ -0,0 +1 @@ +ao_scheme_test diff --git a/src/scheme/test/Makefile b/src/scheme/test/Makefile new file mode 100644 index 00000000..c48add1f --- /dev/null +++ b/src/scheme/test/Makefile @@ -0,0 +1,22 @@ +include ../Makefile-inc + +vpath %.o . +vpath %.c .. +vpath %.h .. + +SRCS=$(SCHEME_SRCS) ao_scheme_test.c + +OBJS=$(SRCS:.c=.o) + +CFLAGS=-O2 -g -Wall -Wextra -I. -I.. + +ao_scheme_test: $(OBJS) +	cc $(CFLAGS) -o $@ $(OBJS) -lm + +$(OBJS): $(SCHEME_HDRS) + +clean:: +	rm -f $(OBJS) ao_scheme_test + +install: ao_scheme_test +	cp ao_scheme_test $$HOME/bin/ao-scheme diff --git a/src/lisp/ao_lisp_os.h b/src/scheme/test/ao_scheme_os.h index 5fa3686b..ea363fb3 100644 --- a/src/lisp/ao_lisp_os.h +++ b/src/scheme/test/ao_scheme_os.h @@ -15,39 +15,54 @@   * 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA.   */ -#ifndef _AO_LISP_OS_H_ -#define _AO_LISP_OS_H_ +#ifndef _AO_SCHEME_OS_H_ +#define _AO_SCHEME_OS_H_  #include <stdio.h>  #include <stdlib.h>  #include <time.h> -extern int ao_lisp_getc(void); +#define AO_SCHEME_POOL_TOTAL	32768 +#define AO_SCHEME_SAVE		1 +#define DBG_MEM_STATS		1 + +extern int ao_scheme_getc(void);  static inline void -ao_lisp_os_flush(void) { +ao_scheme_os_flush() {  	fflush(stdout);  }  static inline void -ao_lisp_abort(void) +ao_scheme_abort(void)  {  	abort();  }  static inline void -ao_lisp_os_led(int led) +ao_scheme_os_led(int led)  {  	printf("leds set to 0x%x\n", led);  } +#define AO_SCHEME_JIFFIES_PER_SECOND	100 +  static inline void -ao_lisp_os_delay(int delay) +ao_scheme_os_delay(int jiffies)  {  	struct timespec ts = { -		.tv_sec = delay / 1000, -		.tv_nsec = (delay % 1000) * 1000000, +		.tv_sec = jiffies / AO_SCHEME_JIFFIES_PER_SECOND, +		.tv_nsec = (jiffies % AO_SCHEME_JIFFIES_PER_SECOND) * (1000000000L / AO_SCHEME_JIFFIES_PER_SECOND)  	};  	nanosleep(&ts, NULL);  } + +static inline int +ao_scheme_os_jiffy(void) +{ +	struct timespec tp; +	clock_gettime(CLOCK_MONOTONIC, &tp); +	return tp.tv_sec * AO_SCHEME_JIFFIES_PER_SECOND + (tp.tv_nsec / (1000000000L / AO_SCHEME_JIFFIES_PER_SECOND)); +} +  #endif diff --git a/src/scheme/test/ao_scheme_test.c b/src/scheme/test/ao_scheme_test.c new file mode 100644 index 00000000..0c77d8d5 --- /dev/null +++ b/src/scheme/test/ao_scheme_test.c @@ -0,0 +1,139 @@ +/* + * Copyright © 2016 Keith Packard <keithp@keithp.com> + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation, either version 2 of the License, or + * (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, but + * WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU + * General Public License for more details. + */ + +#include "ao_scheme.h" +#include <stdio.h> + +static FILE *ao_scheme_file; +static int newline = 1; + +static char save_file[] = "scheme.image"; + +int +ao_scheme_os_save(void) +{ +	FILE	*save = fopen(save_file, "w"); + +	if (!save) { +		perror(save_file); +		return 0; +	} +	fwrite(ao_scheme_pool, 1, AO_SCHEME_POOL_TOTAL, save); +	fclose(save); +	return 1; +} + +int +ao_scheme_os_restore_save(struct ao_scheme_os_save *save, int offset) +{ +	FILE	*restore = fopen(save_file, "r"); +	size_t	ret; + +	if (!restore) { +		perror(save_file); +		return 0; +	} +	fseek(restore, offset, SEEK_SET); +	ret = fread(save, sizeof (struct ao_scheme_os_save), 1, restore); +	fclose(restore); +	if (ret != 1) +		return 0; +	return 1; +} + +int +ao_scheme_os_restore(void) +{ +	FILE	*restore = fopen(save_file, "r"); +	size_t	ret; + +	if (!restore) { +		perror(save_file); +		return 0; +	} +	ret = fread(ao_scheme_pool, 1, AO_SCHEME_POOL_TOTAL, restore); +	fclose(restore); +	if (ret != AO_SCHEME_POOL_TOTAL) +		return 0; +	return 1; +} + +int +ao_scheme_getc(void) +{ +	int c; + +	if (ao_scheme_file) +		return getc(ao_scheme_file); + +	if (newline) { +		if (ao_scheme_read_list) +			printf("+ "); +		else +			printf("> "); +		newline = 0; +	} +	c = getchar(); +	if (c == '\n') +		newline = 1; +	return c; +} + +int +main (int argc, char **argv) +{ +	(void) argc; + +	while (*++argv) { +		ao_scheme_file = fopen(*argv, "r"); +		if (!ao_scheme_file) { +			perror(*argv); +			exit(1); +		} +		ao_scheme_read_eval_print(); +		fclose(ao_scheme_file); +		ao_scheme_file = NULL; +	} +	ao_scheme_read_eval_print(); + +	printf ("collects: full: %lu incremental %lu\n", +		ao_scheme_collects[AO_SCHEME_COLLECT_FULL], +		ao_scheme_collects[AO_SCHEME_COLLECT_INCREMENTAL]); + +	printf ("freed: full %lu incremental %lu\n", +		ao_scheme_freed[AO_SCHEME_COLLECT_FULL], +		ao_scheme_freed[AO_SCHEME_COLLECT_INCREMENTAL]); + +	printf("loops: full %lu incremental %lu\n", +		ao_scheme_loops[AO_SCHEME_COLLECT_FULL], +		ao_scheme_loops[AO_SCHEME_COLLECT_INCREMENTAL]); + +	printf("loops per collect: full %f incremental %f\n", +	       (double) ao_scheme_loops[AO_SCHEME_COLLECT_FULL] / +	       (double) ao_scheme_collects[AO_SCHEME_COLLECT_FULL], +	       (double) ao_scheme_loops[AO_SCHEME_COLLECT_INCREMENTAL] / +	       (double) ao_scheme_collects[AO_SCHEME_COLLECT_INCREMENTAL]); + +	printf("freed per collect: full %f incremental %f\n", +	       (double) ao_scheme_freed[AO_SCHEME_COLLECT_FULL] / +	       (double) ao_scheme_collects[AO_SCHEME_COLLECT_FULL], +	       (double) ao_scheme_freed[AO_SCHEME_COLLECT_INCREMENTAL] / +	       (double) ao_scheme_collects[AO_SCHEME_COLLECT_INCREMENTAL]); + +	printf("freed per loop: full %f incremental %f\n", +	       (double) ao_scheme_freed[AO_SCHEME_COLLECT_FULL] / +	       (double) ao_scheme_loops[AO_SCHEME_COLLECT_FULL], +	       (double) ao_scheme_freed[AO_SCHEME_COLLECT_INCREMENTAL] / +	       (double) ao_scheme_loops[AO_SCHEME_COLLECT_INCREMENTAL]); +} diff --git a/src/scheme/test/hanoi.scheme b/src/scheme/test/hanoi.scheme new file mode 100644 index 00000000..c4ae7378 --- /dev/null +++ b/src/scheme/test/hanoi.scheme @@ -0,0 +1,174 @@ +; +; Towers of Hanoi +; +; Copyright © 2016 Keith Packard <keithp@keithp.com> +; +; This program is free software; you can redistribute it and/or modify +; it under the terms of the GNU General Public License as published by +; the Free Software Foundation, either version 2 of the License, or +; (at your option) any later version. +; +; This program is distributed in the hope that it will be useful, but +; WITHOUT ANY WARRANTY; without even the implied warranty of +; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU +; General Public License for more details. +; + +					; ANSI control sequences + +(define (move-to col row) +  (for-each display (list "\033[" row ";" col "H")) +  ) + +(define (clear) +  (display "\033[2J") +  ) + +(define (display-string x y str) +  (move-to x y) +  (display str) +  ) + +(define (make-piece num max) +					; A piece for position 'num' +					; is num + 1 + num stars +					; centered in a field of max * +					; 2 + 1 characters with spaces +					; on either side. This way, +					; every piece is the same +					; number of characters + +  (define (chars n c) +    (if (zero? n) "" +      (+ c (chars (- n 1) c)) +      ) +    ) +  (+ (chars (- max num 1) " ") +     (chars (+ (* num 2) 1) "*") +     (chars (- max num 1) " ") +     ) +  ) + +(define (make-pieces max) +					; Make a list of numbers from 0 to max-1 +  (define (nums cur max) +    (if (= cur max) () +      (cons cur (nums (+ cur 1) max)) +      ) +    ) +					; Create a list of pieces + +  (map (lambda (x) (make-piece x max)) (nums 0 max)) +  ) + +					; Here's all of the towers of pieces +					; This is generated when the program is run + +(define towers ()) + +					; position of the bottom of +					; the stacks set at runtime +(define bottom-y 0) +(define left-x 0) + +(define move-delay 25) + +					; Display one tower, clearing any +					; space above it + +(define (display-tower x y clear tower) +  (cond ((= 0 clear) +	 (cond ((not (null? tower)) +		(display-string x y (car tower)) +		(display-tower x (+ y 1) 0 (cdr tower)) +		) +	       ) +	 ) +	(else  +	 (display-string x y "                    ") +	 (display-tower x (+ y 1) (- clear 1) tower) +	 ) +	) +  ) + +					; Position of the top of the tower on the screen +					; Shorter towers start further down the screen + +(define (tower-pos tower) +  (- bottom-y (length tower)) +  ) + +					; Display all of the towers, spaced 20 columns apart + +(define (display-towers x towers) +  (cond ((not (null? towers)) +	 (display-tower x 0 (tower-pos (car towers)) (car towers)) +	 (display-towers (+ x 20) (cdr towers))) +	) +  ) + +					; Display all of the towers, then move the cursor +					; out of the way and flush the output + +(define (display-hanoi) +  (display-towers left-x towers) +  (move-to 1 23) +  (flush-output) +  (delay move-delay) +  ) + +					; Reset towers to the starting state, with +					; all of the pieces in the first tower and the +					; other two empty + +(define (reset-towers len) +  (set! towers (list (make-pieces len) () ())) +  (set! bottom-y (+ len 3)) +  ) + +					; Move a piece from the top of one tower +					; to the top of another + +(define (move-piece from to) + +					; references to the cons holding the two towers + +  (define from-tower (list-tail towers from)) +  (define to-tower (list-tail towers to)) + +					; stick the car of from-tower onto to-tower + +  (set-car! to-tower (cons (caar from-tower) (car to-tower))) + +					; remove the car of from-tower + +  (set-car! from-tower (cdar from-tower)) +  ) + +					; The implementation of the game + +(define (_hanoi n from to use) +  (cond ((= 1 n) +	 (move-piece from to) +	 (display-hanoi) +	 ) +	(else +	 (_hanoi (- n 1) from use to) +	 (_hanoi 1 from to use) +	 (_hanoi (- n 1) use to from) +	 ) +	) +  ) + +					; A pretty interface which +					; resets the state of the game, +					; clears the screen and runs +					; the program + +(define (hanoi len) +  (reset-towers len) +  (clear) +  (display-hanoi) +  (_hanoi len 0 1 2) +  #t +  ) diff --git a/src/stm-scheme-newlib/.gitignore b/src/stm-scheme-newlib/.gitignore new file mode 100644 index 00000000..60d664f4 --- /dev/null +++ b/src/stm-scheme-newlib/.gitignore @@ -0,0 +1,4 @@ +*.elf +*.map +*.syms +ao_product.h diff --git a/src/stm-scheme-newlib/Makefile b/src/stm-scheme-newlib/Makefile new file mode 100644 index 00000000..a4c249a3 --- /dev/null +++ b/src/stm-scheme-newlib/Makefile @@ -0,0 +1,84 @@ +# +# AltOS build +# +# + +include ../stm/Makefile.defs +include ../scheme/Makefile-inc + +NEWLIB_FULL=-lm -lc -lgcc + +LIBS=$(NEWLIB_FULL) + +INC = \ +	ao.h \ +	ao_arch.h \ +	ao_arch_funcs.h \ +	ao_boot.h \ +	ao_pins.h \ +	ao_product.h \ +	ao_task.h \ +	$(SCHEME_HDRS) + +# +# Common AltOS sources +# +ALTOS_SRC = \ +	ao_interrupt.c \ +	ao_boot_chain.c \ +	ao_product.c \ +	ao_romconfig.c \ +	ao_cmd.c \ +	ao_task.c \ +	ao_led.c \ +	ao_stdio_newlib.c \ +	ao_panic.c \ +	ao_timer.c \ +	ao_mutex.c \ +	ao_dma_stm.c \ +	ao_usb_stm.c \ +	ao_exti_stm.c \ +	$(SCHEME_SRCS) + +PRODUCT=StmScheme-v0.0 +PRODUCT_DEF=-DSTM_SCHEME +IDPRODUCT=0x000a + +CFLAGS = $(PRODUCT_DEF) $(STM_CFLAGS) -g -Os + +PROG=stm-scheme-$(VERSION) +ELF=$(PROG).elf +IHX=$(PROG).ihx +LIBSYMS=$(PROG).syms +MAP=$(PROG).map + +NEWLIB=/local/newlib-mini +MAPFILE=-Wl,-M=$(MAP) +LDFLAGS=-L../stm -L$(NEWLIB)/arm-none-eabi/lib/thumb/v7-m/ -Wl,-Taltos.ld $(MAPFILE) -nostartfiles +AO_CFLAGS=-I. -I../stm -I../kernel -I../drivers -I.. -I../scheme -isystem $(NEWLIB)/arm-none-eabi/include -DNEWLIB + +SRC=$(ALTOS_SRC) ao_demo.c +OBJ=$(SRC:.c=.o) + +all: $(ELF) $(IHX) $(LIBSYMS) + +$(ELF): Makefile $(OBJ) +	$(call quiet,CC) $(LDFLAGS) $(CFLAGS) -o $@ $(OBJ) $(LIBS) + +$(LIBSYMS): $(ELF) +	grep '^                         ' $(MAP) | grep -v 'size before relaxing' > $@ + +ao_product.h: ao-make-product.5c ../Version +	$(call quiet,NICKLE,$<) $< -m altusmetrum.org -i $(IDPRODUCT) -p $(PRODUCT) -v $(VERSION) > $@ + +$(OBJ): $(INC) + +distclean:	clean + +clean: +	rm -f *.o *.elf *.ihx *.map *.syms +	rm -f ao_product.h + +install: + +uninstall: diff --git a/src/stm-scheme-newlib/ao_demo.c b/src/stm-scheme-newlib/ao_demo.c new file mode 100644 index 00000000..13a31288 --- /dev/null +++ b/src/stm-scheme-newlib/ao_demo.c @@ -0,0 +1,51 @@ +/* + * Copyright © 2011 Keith Packard <keithp@keithp.com> + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation; either version 2 of the License, or + * (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, but + * WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU + * General Public License for more details. + * + * You should have received a copy of the GNU General Public License along + * with this program; if not, write to the Free Software Foundation, Inc., + * 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA. + */ + +#include "ao.h" +#include <ao_exti.h> +#include <ao_boot.h> +#include <ao_scheme.h> + +static void scheme_cmd() { +	ao_scheme_read_eval_print(); +} + + +__code struct ao_cmds ao_demo_cmds[] = { +	{ scheme_cmd, "l\0Run scheme interpreter" }, +	{ 0, NULL } +}; + +int +main(void) +{ +	ao_clock_init(); + +	ao_task_init(); + +	ao_led_init(LEDS_AVAILABLE); +	ao_timer_init(); +	ao_dma_init(); +	ao_cmd_init(); +	ao_usb_init(); + +	ao_cmd_register(&ao_demo_cmds[0]); + +	ao_start_scheduler(); +	return 0; +} diff --git a/src/stm-scheme-newlib/ao_pins.h b/src/stm-scheme-newlib/ao_pins.h new file mode 100644 index 00000000..524490f7 --- /dev/null +++ b/src/stm-scheme-newlib/ao_pins.h @@ -0,0 +1,91 @@ +/* + * Copyright © 2012 Keith Packard <keithp@keithp.com> + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation; either version 2 of the License, or + * (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, but + * WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU + * General Public License for more details. + * + * You should have received a copy of the GNU General Public License along + * with this program; if not, write to the Free Software Foundation, Inc., + * 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA. + */ + +#ifndef _AO_PINS_H_ +#define _AO_PINS_H_ + +/* Bridge SB17 on the board and use the MCO from the other chip */ +#define AO_HSE		8000000 +#define AO_HSE_BYPASS		1 + +/* PLLVCO = 96MHz (so that USB will work) */ +#define AO_PLLMUL		12 +#define AO_RCC_CFGR_PLLMUL	(STM_RCC_CFGR_PLLMUL_12) + +/* SYSCLK = 32MHz */ +#define AO_PLLDIV		3 +#define AO_RCC_CFGR_PLLDIV	(STM_RCC_CFGR_PLLDIV_3) + +/* HCLK = 32MHZ (CPU clock) */ +#define AO_AHB_PRESCALER	1 +#define AO_RCC_CFGR_HPRE_DIV	STM_RCC_CFGR_HPRE_DIV_1 + +/* Run APB1 at HCLK/1 */ +#define AO_APB1_PRESCALER	1 +#define AO_RCC_CFGR_PPRE1_DIV	STM_RCC_CFGR_PPRE2_DIV_1 + +/* Run APB2 at HCLK/1 */ +#define AO_APB2_PRESCALER      	1 +#define AO_RCC_CFGR_PPRE2_DIV	STM_RCC_CFGR_PPRE2_DIV_1 + +#define HAS_SERIAL_1		0 +#define USE_SERIAL_1_STDIN	0 +#define SERIAL_1_PB6_PB7	1 +#define SERIAL_1_PA9_PA10	0 + +#define HAS_SERIAL_2		0 +#define USE_SERIAL_2_STDIN	0 +#define SERIAL_2_PA2_PA3	0 +#define SERIAL_2_PD5_PD6	1 + +#define HAS_SERIAL_3		0 +#define USE_SERIAL_3_STDIN	1 +#define SERIAL_3_PB10_PB11	0 +#define SERIAL_3_PC10_PC11	0 +#define SERIAL_3_PD8_PD9	1 + +#define HAS_SPI_1		0 +#define SPI_1_PB3_PB4_PB5	1 +#define SPI_1_OSPEEDR		STM_OSPEEDR_10MHz + +#define HAS_SPI_2		0 + +#define HAS_USB			1 +#define HAS_BEEP		0 +#define PACKET_HAS_SLAVE	0 + +#define AO_BOOT_CHAIN		1 + +#define LOW_LEVEL_DEBUG		0 + +#define LED_PORT_ENABLE		STM_RCC_AHBENR_GPIOBEN +#define LED_PORT		(&stm_gpiob) +#define LED_PIN_GREEN		7 +#define LED_PIN_BLUE		6 +#define AO_LED_GREEN		(1 << LED_PIN_GREEN) +#define AO_LED_BLUE		(1 << LED_PIN_BLUE) +#define AO_LED_PANIC		AO_LED_BLUE + +#define LEDS_AVAILABLE		(AO_LED_BLUE | AO_LED_GREEN) + +#define HAS_ADC			0 + +#define AO_TICK_TYPE		uint32_t +#define AO_TICK_SIGNED		int32_t + +#endif /* _AO_PINS_H_ */ diff --git a/src/lambdakey-v1.0/ao_lisp_os.h b/src/stm-scheme-newlib/ao_scheme_os.h index 1993ac44..21b6001a 100644 --- a/src/lambdakey-v1.0/ao_lisp_os.h +++ b/src/stm-scheme-newlib/ao_scheme_os.h @@ -15,13 +15,21 @@   * 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA.   */ -#ifndef _AO_LISP_OS_H_ -#define _AO_LISP_OS_H_ +#ifndef _AO_SCHEME_OS_H_ +#define _AO_SCHEME_OS_H_  #include "ao.h" +#define AO_SCHEME_POOL		10240 + +#ifndef __BYTE_ORDER +#define	__LITTLE_ENDIAN	1234 +#define	__BIG_ENDIAN	4321 +#define __BYTE_ORDER	__LITTLE_ENDIAN +#endif +  static inline int -ao_lisp_getc() { +ao_scheme_getc() {  	static uint8_t	at_eol;  	int c; @@ -36,27 +44,35 @@ ao_lisp_getc() {  }  static inline void -ao_lisp_os_flush(void) +ao_scheme_os_flush(void)  {  	flush();  }  static inline void -ao_lisp_abort(void) +ao_scheme_abort(void)  {  	ao_panic(1);  }  static inline void -ao_lisp_os_led(int led) +ao_scheme_os_led(int led)  {  	ao_led_set(led);  } +#define AO_SCHEME_JIFFIES_PER_SECOND	AO_HERTZ +  static inline void -ao_lisp_os_delay(int delay) +ao_scheme_os_delay(int delay) +{ +	ao_delay(delay); +} + +static inline int +ao_scheme_os_jiffy(void)  { -	ao_delay(AO_MS_TO_TICKS(delay)); +	return ao_tick_count;  }  #endif diff --git a/src/stm-scheme-newlib/ao_scheme_os_save.c b/src/stm-scheme-newlib/ao_scheme_os_save.c new file mode 100644 index 00000000..ce46f18e --- /dev/null +++ b/src/stm-scheme-newlib/ao_scheme_os_save.c @@ -0,0 +1,53 @@ +/* + * Copyright © 2016 Keith Packard <keithp@keithp.com> + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation, either version 2 of the License, or + * (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, but + * WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU + * General Public License for more details. + */ + +#include <ao.h> +#include "ao_scheme.h" +#include <ao_flash.h> + +extern uint8_t	__flash__[]; + +/* saved variables to rebuild the heap + +   ao_scheme_atoms +   ao_scheme_frame_global + */ + +int +ao_scheme_os_save(void) +{ +	int i; + +	for (i = 0; i < AO_SCHEME_POOL_TOTAL; i += 256) { +		uint32_t	*dst = (uint32_t *) (void *) &__flash__[i]; +		uint32_t	*src = (uint32_t *) (void *) &ao_scheme_pool[i]; + +		ao_flash_page(dst, src); +	} +	return 1; +} + +int +ao_scheme_os_restore_save(struct ao_scheme_os_save *save, int offset) +{ +	memcpy(save, &__flash__[offset], sizeof (struct ao_scheme_os_save)); +	return 1; +} + +int +ao_scheme_os_restore(void) +{ +	memcpy(ao_scheme_pool, __flash__, AO_SCHEME_POOL_TOTAL); +	return 1; +} diff --git a/src/stm-scheme-newlib/flash-loader/Makefile b/src/stm-scheme-newlib/flash-loader/Makefile new file mode 100644 index 00000000..4c60f317 --- /dev/null +++ b/src/stm-scheme-newlib/flash-loader/Makefile @@ -0,0 +1,8 @@ +# +# AltOS flash loader build +# +# + +TOPDIR=../.. +HARDWARE=stm-scheme +include $(TOPDIR)/stm/Makefile-flash.defs diff --git a/src/stm-scheme-newlib/flash-loader/ao_pins.h b/src/stm-scheme-newlib/flash-loader/ao_pins.h new file mode 100644 index 00000000..eb5fcb8b --- /dev/null +++ b/src/stm-scheme-newlib/flash-loader/ao_pins.h @@ -0,0 +1,36 @@ +/* + * Copyright © 2013 Keith Packard <keithp@keithp.com> + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation; either version 2 of the License, or + * (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, but + * WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU + * General Public License for more details. + * + * You should have received a copy of the GNU General Public License along + * with this program; if not, write to the Free Software Foundation, Inc., + * 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA. + */ + +#ifndef _AO_PINS_H_ +#define _AO_PINS_H_ + +/* Bridge SB17 on the board and use the MCO from the other chip */ +#define AO_HSE		8000000 +#define AO_HSE_BYPASS		1 + +#include <ao_flash_stm_pins.h> + +/* Use the 'user switch' to force boot loader on power on */ + +#define AO_BOOT_PIN			1 +#define AO_BOOT_APPLICATION_GPIO	stm_gpioa +#define AO_BOOT_APPLICATION_PIN		0 +#define AO_BOOT_APPLICATION_VALUE	0 +#define AO_BOOT_APPLICATION_MODE	0 + +#endif /* _AO_PINS_H_ */ diff --git a/src/stm/Makefile.defs b/src/stm/Makefile.defs index 66ed4be8..4d0d27c7 100644 --- a/src/stm/Makefile.defs +++ b/src/stm/Makefile.defs @@ -1,4 +1,4 @@ -vpath % ../stm:../product:../drivers:../kernel:../util:../kalman:../aes:../math:../draw:../lisp:.. +vpath % ../stm:../product:../drivers:../kernel:../util:../kalman:../aes:../math:../draw:../scheme:..  vpath make-altitude ../util  vpath make-kalman ../util  vpath kalman.5c ../kalman diff --git a/src/stm/ao_adc_stm.c b/src/stm/ao_adc_stm.c index 77f121dc..24912bb2 100644 --- a/src/stm/ao_adc_stm.c +++ b/src/stm/ao_adc_stm.c @@ -58,6 +58,9 @@ static void ao_adc_done(int index)  #if HAS_MPU6000  		ao_data_ring[ao_data_head].mpu6000 = ao_mpu6000_current;  #endif +#if HAS_MPU9250 +		ao_data_ring[ao_data_head].mpu9250 = ao_mpu9250_current; +#endif  		ao_data_ring[ao_data_head].tick = ao_tick_count;  		ao_data_head = ao_data_ring_next(ao_data_head);  		ao_wakeup((void *) &ao_data_head); @@ -377,7 +380,7 @@ ao_adc_init(void)  #if AO_NUM_ADC > 18  #error "need to finish stm_adc.sqr settings"  #endif -	 +  	/* Turn ADC on */  	stm_adc.cr2 = AO_ADC_CR2_VAL; diff --git a/src/stm/ao_exti.h b/src/stm/ao_exti.h index 4f3e6132..8aa2bdca 100644 --- a/src/stm/ao_exti.h +++ b/src/stm/ao_exti.h @@ -21,6 +21,7 @@  #define AO_EXTI_MODE_RISING	1  #define AO_EXTI_MODE_FALLING	2 +#define AO_EXTI_MODE_PULL_NONE	0  #define AO_EXTI_MODE_PULL_UP	4  #define AO_EXTI_MODE_PULL_DOWN	8  #define AO_EXTI_PRIORITY_LOW	16 diff --git a/src/stm/ao_serial_stm.c b/src/stm/ao_serial_stm.c index ef562313..2afee5b5 100644 --- a/src/stm/ao_serial_stm.c +++ b/src/stm/ao_serial_stm.c @@ -60,13 +60,13 @@ _ao_usart_cts(struct ao_stm_usart *usart)  #endif  static void -_ao_usart_rx(struct ao_stm_usart *usart, int stdin) +_ao_usart_rx(struct ao_stm_usart *usart, int is_stdin)  {  	if (usart->reg->sr & (1 << STM_USART_SR_RXNE)) {  		if (!ao_fifo_full(usart->rx_fifo)) {  			ao_fifo_insert(usart->rx_fifo, usart->reg->dr);  			ao_wakeup(&usart->rx_fifo); -			if (stdin) +			if (is_stdin)  				ao_wakeup(&ao_stdin_ready);  #if HAS_SERIAL_SW_FLOW  			/* If the fifo is nearly full, turn off RTS and wait @@ -84,9 +84,9 @@ _ao_usart_rx(struct ao_stm_usart *usart, int stdin)  }  static void -ao_usart_isr(struct ao_stm_usart *usart, int stdin) +ao_usart_isr(struct ao_stm_usart *usart, int is_stdin)  { -	_ao_usart_rx(usart, stdin); +	_ao_usart_rx(usart, is_stdin);  	if (!_ao_usart_tx_start(usart))  		usart->reg->cr1 &= ~(1<< STM_USART_CR1_TXEIE); diff --git a/src/stmf0/Makefile-stmf0.defs b/src/stmf0/Makefile-stmf0.defs index f2c53499..fa6e6e86 100644 --- a/src/stmf0/Makefile-stmf0.defs +++ b/src/stmf0/Makefile-stmf0.defs @@ -4,7 +4,7 @@ endif  include $(TOPDIR)/Makedefs -vpath % $(TOPDIR)/stmf0:$(TOPDIR)/product:$(TOPDIR)/drivers:$(TOPDIR)/kernel:$(TOPDIR)/util:$(TOPDIR)/kalman:$(TOPDIR)/aes:$(TOPDIR):$(TOPDIR)/math:$(TOPDIR)/lisp +vpath % $(TOPDIR)/stmf0:$(TOPDIR)/product:$(TOPDIR)/drivers:$(TOPDIR)/kernel:$(TOPDIR)/util:$(TOPDIR)/kalman:$(TOPDIR)/aes:$(TOPDIR):$(TOPDIR)/math:$(TOPDIR)/scheme  vpath make-altitude $(TOPDIR)/util  vpath make-kalman $(TOPDIR)/util  vpath kalman.5c $(TOPDIR)/kalman diff --git a/src/teleballoon-v2.0/ao_pins.h b/src/teleballoon-v2.0/ao_pins.h index 746bb3ee..d98e85d7 100644 --- a/src/teleballoon-v2.0/ao_pins.h +++ b/src/teleballoon-v2.0/ao_pins.h @@ -64,6 +64,7 @@  #define AO_CONFIG_MAX_SIZE			1024  #define LOG_ERASE_MARK				0x55  #define LOG_MAX_ERASE				128 +#define AO_LOG_FORMAT				AO_LOG_FORMAT_TELEMETRUM  #define HAS_EEPROM		1  #define USE_INTERNAL_FLASH	0 diff --git a/src/telegps-v0.3/ao_pins.h b/src/telegps-v0.3/ao_pins.h index 28ae30a4..873474bb 100644 --- a/src/telegps-v0.3/ao_pins.h +++ b/src/telegps-v0.3/ao_pins.h @@ -75,6 +75,7 @@  #define AO_CONFIG_DEFAULT_APRS_INTERVAL		0  #define AO_CONFIG_DEFAULT_RADIO_POWER		0xc0  #define AO_CONFIG_DEFAULT_FLIGHT_LOG_MAX	496 * 1024 +#define AO_LOG_FORMAT				AO_LOG_FORMAT_TELEGPS  /*   * GPS diff --git a/src/telegps-v1.0/ao_pins.h b/src/telegps-v1.0/ao_pins.h index 9672ab03..f3bdc0ac 100644 --- a/src/telegps-v1.0/ao_pins.h +++ b/src/telegps-v1.0/ao_pins.h @@ -77,6 +77,7 @@  #define AO_CONFIG_DEFAULT_APRS_INTERVAL		0  #define AO_CONFIG_DEFAULT_RADIO_POWER		0xc0 +#define AO_LOG_FORMAT				AO_LOG_FORMAT_TELEGPS  /*   * GPS diff --git a/src/telegps-v2.0/ao_pins.h b/src/telegps-v2.0/ao_pins.h index fa175371..a2e812fa 100644 --- a/src/telegps-v2.0/ao_pins.h +++ b/src/telegps-v2.0/ao_pins.h @@ -136,6 +136,7 @@ struct ao_adc {  #define AO_CONFIG_DEFAULT_APRS_INTERVAL		0  #define AO_CONFIG_DEFAULT_RADIO_POWER		0xc0 +#define AO_LOG_FORMAT				AO_LOG_FORMAT_TELEGPS  /*   * GPS diff --git a/src/telemega-v0.1/ao_pins.h b/src/telemega-v0.1/ao_pins.h index 11c4267c..94e77f98 100644 --- a/src/telemega-v0.1/ao_pins.h +++ b/src/telemega-v0.1/ao_pins.h @@ -69,6 +69,7 @@  #define AO_CONFIG_MAX_SIZE			1024  #define LOG_ERASE_MARK				0x55  #define LOG_MAX_ERASE				128 +#define AO_LOG_FORMAT				AO_LOG_FORMAT_TELEMEGA  #define HAS_EEPROM		1  #define USE_INTERNAL_FLASH	0 diff --git a/src/telemega-v1.0/ao_pins.h b/src/telemega-v1.0/ao_pins.h index 4decbbf7..d44394f0 100644 --- a/src/telemega-v1.0/ao_pins.h +++ b/src/telemega-v1.0/ao_pins.h @@ -69,6 +69,7 @@  #define AO_CONFIG_MAX_SIZE			1024  #define LOG_ERASE_MARK				0x55  #define LOG_MAX_ERASE				128 +#define AO_LOG_FORMAT				AO_LOG_FORMAT_TELEMEGA  #define HAS_EEPROM		1  #define USE_INTERNAL_FLASH	0 diff --git a/src/telemega-v2.0/ao_pins.h b/src/telemega-v2.0/ao_pins.h index c7c8ad19..42c00c94 100644 --- a/src/telemega-v2.0/ao_pins.h +++ b/src/telemega-v2.0/ao_pins.h @@ -69,6 +69,7 @@  #define AO_CONFIG_MAX_SIZE			1024  #define LOG_ERASE_MARK				0x55  #define LOG_MAX_ERASE				128 +#define AO_LOG_FORMAT				AO_LOG_FORMAT_TELEMEGA  #define HAS_EEPROM		1  #define USE_INTERNAL_FLASH	0 diff --git a/src/telemega-v3.0/.gitignore b/src/telemega-v3.0/.gitignore new file mode 100644 index 00000000..e67759a2 --- /dev/null +++ b/src/telemega-v3.0/.gitignore @@ -0,0 +1,2 @@ +ao_product.h +telemega-*.elf diff --git a/src/telemega-v3.0/Makefile b/src/telemega-v3.0/Makefile new file mode 100644 index 00000000..ae22bf01 --- /dev/null +++ b/src/telemega-v3.0/Makefile @@ -0,0 +1,153 @@ +# +# AltOS build +# +# + +include ../stm/Makefile.defs + +INC = \ +	ao.h \ +	ao_arch.h \ +	ao_arch_funcs.h \ +	ao_boot.h \ +	ao_companion.h \ +	ao_data.h \ +	ao_sample.h \ +	ao_pins.h \ +	altitude-pa.h \ +	ao_kalman.h \ +	ao_product.h \ +	ao_ms5607.h \ +	ao_mpu9250.h \ +	ao_mma655x.h \ +	ao_cc1200_CC1200.h \ +	ao_profile.h \ +	ao_task.h \ +	ao_whiten.h \ +	ao_sample_profile.h \ +	ao_quaternion.h \ +	math.h \ +	ao_mpu.h \ +	stm32l.h \ +	math.h \ +	ao_ms5607_convert.c \ +	Makefile + +# +# Common AltOS sources +# + +#PROFILE=ao_profile.c +#PROFILE_DEF=-DAO_PROFILE=1 + +#SAMPLE_PROFILE=ao_sample_profile.c \ +#	ao_sample_profile_timer.c +#SAMPLE_PROFILE_DEF=-DHAS_SAMPLE_PROFILE=1 + +#STACK_GUARD=ao_mpu_stm.c +#STACK_GUARD_DEF=-DHAS_STACK_GUARD=1 + +MATH_SRC=\ +	ef_acos.c \ +	ef_sqrt.c \ +	ef_rem_pio2.c \ +	kf_cos.c \ +	kf_sin.c \ +	kf_rem_pio2.c \ +	sf_copysign.c \ +	sf_cos.c \ +	sf_fabs.c \ +	sf_floor.c \ +	sf_scalbn.c \ +	sf_sin.c \ +	ef_log.c + +ALTOS_SRC = \ +	ao_boot_chain.c \ +	ao_interrupt.c \ +	ao_product.c \ +	ao_romconfig.c \ +	ao_cmd.c \ +	ao_config.c \ +	ao_task.c \ +	ao_led.c \ +	ao_stdio.c \ +	ao_panic.c \ +	ao_timer.c \ +	ao_mutex.c \ +	ao_serial_stm.c \ +	ao_gps_ublox.c \ +	ao_gps_show.c \ +	ao_gps_report_mega.c \ +	ao_ignite.c \ +	ao_freq.c \ +	ao_dma_stm.c \ +	ao_spi_stm.c \ +	ao_cc1200.c \ +	ao_data.c \ +	ao_ms5607.c \ +	ao_mma655x.c \ +	ao_adc_stm.c \ +	ao_beep_stm.c \ +	ao_eeprom_stm.c \ +	ao_storage.c \ +	ao_m25.c \ +	ao_usb_stm.c \ +	ao_exti_stm.c \ +	ao_report.c \ +	ao_i2c_stm.c \ +	ao_mpu9250.c \ +	ao_convert_pa.c \ +	ao_convert_volt.c \ +	ao_log.c \ +	ao_log_mega.c \ +	ao_sample.c \ +	ao_kalman.c \ +	ao_flight.c \ +	ao_telemetry.c \ +	ao_packet_slave.c \ +	ao_packet.c \ +	ao_companion.c \ +	ao_pyro.c \ +	ao_aprs.c \ +	ao_pwm_stm.c \ +	$(MATH_SRC) \ +	$(PROFILE) \ +	$(SAMPLE_PROFILE) \ +	$(STACK_GUARD) + +PRODUCT=TeleMega-v3.0 +PRODUCT_DEF=-DTELEMEGA +IDPRODUCT=0x0023 + +CFLAGS = $(PRODUCT_DEF) $(STM_CFLAGS) $(PROFILE_DEF) $(SAMPLE_PROFILE_DEF) $(STACK_GUARD_DEF) -Os -g + +PROGNAME=telemega-v3.0 +PROG=$(PROGNAME)-$(VERSION).elf +HEX=$(PROGNAME)-$(VERSION).ihx + +SRC=$(ALTOS_SRC) ao_telemega.c +OBJ=$(SRC:.c=.o) + +all: $(PROG) $(HEX) + +$(PROG): Makefile $(OBJ) altos.ld +	$(call quiet,CC) $(LDFLAGS) $(CFLAGS) -o $(PROG) $(OBJ) $(LIBS) + +../altitude-pa.h: make-altitude-pa +	nickle $< > $@ + +$(OBJ): $(INC) + +ao_product.h: ao-make-product.5c ../Version +	$(call quiet,NICKLE,$<) $< -m altusmetrum.org -i $(IDPRODUCT) -p $(PRODUCT) -v $(VERSION) > $@ + +distclean:	clean + +clean: +	rm -f *.o $(PROGNAME)-*.elf $(PROGNAME)-*.ihx +	rm -f ao_product.h + +install: + +uninstall: diff --git a/src/telemega-v3.0/ao_pins.h b/src/telemega-v3.0/ao_pins.h new file mode 100644 index 00000000..73278600 --- /dev/null +++ b/src/telemega-v3.0/ao_pins.h @@ -0,0 +1,402 @@ +/* + * Copyright © 2017 Keith Packard <keithp@keithp.com> + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation; either version 2 of the License, or + * (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, but + * WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU + * General Public License for more details. + * + * You should have received a copy of the GNU General Public License along + * with this program; if not, write to the Free Software Foundation, Inc., + * 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA. + */ + +#ifndef _AO_PINS_H_ +#define _AO_PINS_H_ + +#define HAS_TASK_QUEUE		1 + +/* 8MHz High speed external crystal */ +#define AO_HSE			8000000 + +/* PLLVCO = 96MHz (so that USB will work) */ +#define AO_PLLMUL		12 +#define AO_RCC_CFGR_PLLMUL	(STM_RCC_CFGR_PLLMUL_12) + +/* SYSCLK = 32MHz (no need to go faster than CPU) */ +#define AO_PLLDIV		3 +#define AO_RCC_CFGR_PLLDIV	(STM_RCC_CFGR_PLLDIV_3) + +/* HCLK = 32MHz (CPU clock) */ +#define AO_AHB_PRESCALER	1 +#define AO_RCC_CFGR_HPRE_DIV	STM_RCC_CFGR_HPRE_DIV_1 + +/* Run APB1 at 16MHz (HCLK/2) */ +#define AO_APB1_PRESCALER	2 +#define AO_RCC_CFGR_PPRE1_DIV	STM_RCC_CFGR_PPRE2_DIV_2 + +/* Run APB2 at 16MHz (HCLK/2) */ +#define AO_APB2_PRESCALER	2 +#define AO_RCC_CFGR_PPRE2_DIV	STM_RCC_CFGR_PPRE2_DIV_2 + +#define HAS_SERIAL_1		0 +#define USE_SERIAL_1_STDIN	0 +#define SERIAL_1_PB6_PB7	0 +#define SERIAL_1_PA9_PA10	1 + +#define HAS_SERIAL_2		0 +#define USE_SERIAL_2_STDIN	0 +#define SERIAL_2_PA2_PA3	0 +#define SERIAL_2_PD5_PD6	0 + +#define HAS_SERIAL_3		1 +#define USE_SERIAL_3_STDIN	0 +#define SERIAL_3_PB10_PB11	0 +#define SERIAL_3_PC10_PC11	1 +#define SERIAL_3_PD8_PD9	0 + +#define ao_gps_getchar		ao_serial3_getchar +#define ao_gps_putchar		ao_serial3_putchar +#define ao_gps_set_speed	ao_serial3_set_speed +#define ao_gps_fifo		(ao_stm_usart3.rx_fifo) + +#define AO_CONFIG_DEFAULT_FLIGHT_LOG_MAX	(1024 * 1024) +#define AO_CONFIG_MAX_SIZE			1024 +#define LOG_ERASE_MARK				0x55 +#define LOG_MAX_ERASE				128 +#define AO_LOG_FORMAT				AO_LOG_FORMAT_TELEMEGA_3 + +#define HAS_EEPROM		1 +#define USE_INTERNAL_FLASH	0 +#define USE_EEPROM_CONFIG	1 +#define USE_STORAGE_CONFIG	0 +#define HAS_USB			1 +#define HAS_BEEP		1 +#define HAS_BATTERY_REPORT	1 +#define HAS_RADIO		1 +#define HAS_TELEMETRY		1 +#define HAS_APRS		1 +#define HAS_COMPANION		1 + +#define HAS_SPI_1		1 +#define SPI_1_PA5_PA6_PA7	1	/* Barometer */ +#define SPI_1_PB3_PB4_PB5	0 +#define SPI_1_PE13_PE14_PE15	1	/* Accelerometer, Gyro */ +#define SPI_1_OSPEEDR		STM_OSPEEDR_10MHz + +#define HAS_SPI_2		1 +#define SPI_2_PB13_PB14_PB15	1	/* Flash, Companion */ +#define SPI_2_PD1_PD3_PD4	0 +#define SPI_2_OSPEEDR		STM_OSPEEDR_10MHz + +#define SPI_2_PORT		(&stm_gpiob) +#define SPI_2_SCK_PIN		13 +#define SPI_2_MISO_PIN		14 +#define SPI_2_MOSI_PIN		15 + +#define HAS_I2C_1		1 +#define I2C_1_PB8_PB9		1 + +#define HAS_I2C_2		0 +#define I2C_2_PB10_PB11		0 + +#define PACKET_HAS_SLAVE	1 +#define PACKET_HAS_MASTER	0 + +#define LOW_LEVEL_DEBUG		0 + +#define LED_PORT_ENABLE		STM_RCC_AHBENR_GPIOCEN +#define LED_PORT		(&stm_gpioc) +#define LED_PIN_RED		8 +#define LED_PIN_GREEN		9 +#define AO_LED_RED		(1 << LED_PIN_RED) +#define AO_LED_GREEN		(1 << LED_PIN_GREEN) + +#define LEDS_AVAILABLE		(AO_LED_RED | AO_LED_GREEN) + +#define HAS_GPS			1 +#define HAS_FLIGHT		1 +#define HAS_ADC			1 +#define HAS_ADC_TEMP		1 +#define HAS_LOG			1 + +/* + * Igniter + */ + +#define HAS_IGNITE		1 +#define HAS_IGNITE_REPORT	1 + +#define AO_SENSE_PYRO(p,n)	((p)->adc.sense[n]) +#define AO_SENSE_DROGUE(p)	((p)->adc.sense[4]) +#define AO_SENSE_MAIN(p)	((p)->adc.sense[5]) +#define AO_IGNITER_CLOSED	400 +#define AO_IGNITER_OPEN		60 + +/* Pyro A */ +#define AO_PYRO_PORT_0	(&stm_gpiod) +#define AO_PYRO_PIN_0	6 + +/* Pyro B */ +#define AO_PYRO_PORT_1	(&stm_gpiod) +#define AO_PYRO_PIN_1	7 + +/* Pyro C */ +#define AO_PYRO_PORT_2	(&stm_gpiob) +#define AO_PYRO_PIN_2	5 + +/* Pyro D */ +#define AO_PYRO_PORT_3	(&stm_gpioe) +#define AO_PYRO_PIN_3	4 + +/* Drogue */ +#define AO_IGNITER_DROGUE_PORT	(&stm_gpioe) +#define AO_IGNITER_DROGUE_PIN	6 + +/* Main */ +#define AO_IGNITER_MAIN_PORT	(&stm_gpioe) +#define AO_IGNITER_MAIN_PIN	5 + +/* Number of general purpose pyro channels available */ +#define AO_PYRO_NUM	4 + +#define AO_IGNITER_SET_DROGUE(v)	stm_gpio_set(AO_IGNITER_DROGUE_PORT, AO_IGNITER_DROGUE_PIN, v) +#define AO_IGNITER_SET_MAIN(v)		stm_gpio_set(AO_IGNITER_MAIN_PORT, AO_IGNITER_MAIN_PIN, v) + +/* + * ADC + */ +#define AO_DATA_RING		32 +#define AO_ADC_NUM_SENSE	6 + +struct ao_adc { +	int16_t			sense[AO_ADC_NUM_SENSE]; +	int16_t			v_batt; +	int16_t			v_pbatt; +	int16_t			temp; +}; + +#define AO_ADC_DUMP(p) \ +	printf("tick: %5u A: %5d B: %5d C: %5d D: %5d drogue: %5d main: %5d batt: %5d pbatt: %5d temp: %5d\n", \ +	       (p)->tick, \ +	       (p)->adc.sense[0], (p)->adc.sense[1], (p)->adc.sense[2], \ +	       (p)->adc.sense[3], (p)->adc.sense[4], (p)->adc.sense[5], \ +	       (p)->adc.v_batt, (p)->adc.v_pbatt, (p)->adc.temp) + +#define AO_ADC_SENSE_A		0 +#define AO_ADC_SENSE_A_PORT	(&stm_gpioa) +#define AO_ADC_SENSE_A_PIN	0 + +#define AO_ADC_SENSE_B		1 +#define AO_ADC_SENSE_B_PORT	(&stm_gpioa) +#define AO_ADC_SENSE_B_PIN	1 + +#define AO_ADC_SENSE_C		2 +#define AO_ADC_SENSE_C_PORT	(&stm_gpioa) +#define AO_ADC_SENSE_C_PIN	2 + +#define AO_ADC_SENSE_D		3 +#define AO_ADC_SENSE_D_PORT	(&stm_gpioa) +#define AO_ADC_SENSE_D_PIN	3 + +#define AO_ADC_SENSE_DROGUE	4 +#define AO_ADC_SENSE_DROGUE_PORT	(&stm_gpioa) +#define AO_ADC_SENSE_DROGUE_PIN	4 + +#define AO_ADC_SENSE_MAIN	22 +#define AO_ADC_SENSE_MAIN_PORT	(&stm_gpioe) +#define AO_ADC_SENSE_MAIN_PIN	7 + +#define AO_ADC_V_BATT		8 +#define AO_ADC_V_BATT_PORT	(&stm_gpiob) +#define AO_ADC_V_BATT_PIN	0 + +#define AO_ADC_V_PBATT		9 +#define AO_ADC_V_PBATT_PORT	(&stm_gpiob) +#define AO_ADC_V_PBATT_PIN	1 + +#define AO_ADC_TEMP		16 + +#define AO_ADC_RCC_AHBENR	((1 << STM_RCC_AHBENR_GPIOAEN) | \ +				 (1 << STM_RCC_AHBENR_GPIOEEN) | \ +				 (1 << STM_RCC_AHBENR_GPIOBEN)) + +#define AO_NUM_ADC_PIN		(AO_ADC_NUM_SENSE + 2) + +#define AO_ADC_PIN0_PORT	AO_ADC_SENSE_A_PORT +#define AO_ADC_PIN0_PIN		AO_ADC_SENSE_A_PIN +#define AO_ADC_PIN1_PORT	AO_ADC_SENSE_B_PORT +#define AO_ADC_PIN1_PIN		AO_ADC_SENSE_B_PIN +#define AO_ADC_PIN2_PORT	AO_ADC_SENSE_C_PORT +#define AO_ADC_PIN2_PIN		AO_ADC_SENSE_C_PIN +#define AO_ADC_PIN3_PORT	AO_ADC_SENSE_D_PORT +#define AO_ADC_PIN3_PIN		AO_ADC_SENSE_D_PIN +#define AO_ADC_PIN4_PORT	AO_ADC_SENSE_DROGUE_PORT +#define AO_ADC_PIN4_PIN		AO_ADC_SENSE_DROGUE_PIN +#define AO_ADC_PIN5_PORT	AO_ADC_SENSE_MAIN_PORT +#define AO_ADC_PIN5_PIN		AO_ADC_SENSE_MAIN_PIN +#define AO_ADC_PIN6_PORT	AO_ADC_V_BATT_PORT +#define AO_ADC_PIN6_PIN		AO_ADC_V_BATT_PIN +#define AO_ADC_PIN7_PORT	AO_ADC_V_PBATT_PORT +#define AO_ADC_PIN7_PIN		AO_ADC_V_PBATT_PIN + +#define AO_NUM_ADC	       	(AO_ADC_NUM_SENSE + 3) + +#define AO_ADC_SQ1		AO_ADC_SENSE_A +#define AO_ADC_SQ2		AO_ADC_SENSE_B +#define AO_ADC_SQ3		AO_ADC_SENSE_C +#define AO_ADC_SQ4		AO_ADC_SENSE_D +#define AO_ADC_SQ5		AO_ADC_SENSE_DROGUE +#define AO_ADC_SQ6		AO_ADC_SENSE_MAIN +#define AO_ADC_SQ7		AO_ADC_V_BATT +#define AO_ADC_SQ8		AO_ADC_V_PBATT +#define AO_ADC_SQ9		AO_ADC_TEMP + +/* + * Voltage divider on ADC battery sampler + */ +#define AO_BATTERY_DIV_PLUS	56	/* 5.6k */ +#define AO_BATTERY_DIV_MINUS	100	/* 10k */ + +/* + * Voltage divider on ADC igniter samplers + */ +#define AO_IGNITE_DIV_PLUS	100	/* 100k */ +#define AO_IGNITE_DIV_MINUS	27	/* 27k */ + +/* + * ADC reference in decivolts + */ +#define AO_ADC_REFERENCE_DV	33 + +/* + * Pressure sensor settings + */ +#define HAS_MS5607		1 +#define HAS_MS5611		0 +#define AO_MS5607_PRIVATE_PINS	1 +#define AO_MS5607_CS_PORT	(&stm_gpioc) +#define AO_MS5607_CS_PIN	4 +#define AO_MS5607_CS_MASK	(1 << AO_MS5607_CS) +#define AO_MS5607_MISO_PORT	(&stm_gpioa) +#define AO_MS5607_MISO_PIN	6 +#define AO_MS5607_MISO_MASK	(1 << AO_MS5607_MISO) +#define AO_MS5607_SPI_INDEX	AO_SPI_1_PA5_PA6_PA7 + +/* + * SPI Flash memory + */ + +#define M25_MAX_CHIPS		1 +#define AO_M25_SPI_CS_PORT	(&stm_gpiod) +#define AO_M25_SPI_CS_MASK	(1 << 3) +#define AO_M25_SPI_BUS		AO_SPI_2_PB13_PB14_PB15 + +/* + * Radio (cc1120) + */ + +/* gets pretty close to 434.550 */ + +#define AO_RADIO_CAL_DEFAULT 	5695733 + +#define AO_FEC_DEBUG		0 +#define AO_CC1200_SPI_CS_PORT	(&stm_gpioc) +#define AO_CC1200_SPI_CS_PIN	5 +#define AO_CC1200_SPI_BUS	AO_SPI_2_PB13_PB14_PB15 +#define AO_CC1200_SPI		stm_spi2 +#define AO_CC1200_SPI_SPEED	AO_SPI_SPEED_FAST + +#define AO_CC1200_INT_PORT		(&stm_gpioe) +#define AO_CC1200_INT_PIN		1 +#define AO_CC1200_MCU_WAKEUP_PORT	(&stm_gpioc) +#define AO_CC1200_MCU_WAKEUP_PIN	(0) + +#define AO_CC1200_INT_GPIO	2 +#define AO_CC1200_INT_GPIO_IOCFG	CC1200_IOCFG2 + +#define AO_CC1200_MARC_GPIO	3 +#define AO_CC1200_MARC_GPIO_IOCFG	CC1200_IOCFG3 + +#define HAS_BOOT_RADIO		0 + +/* + * mpu9250 + */ + +#define HAS_MPU9250		1 +#define AO_MPU9250_INT_PORT	(&stm_gpioe) +#define AO_MPU9250_INT_PIN	0 +#define AO_MPU9250_SPI_BUS	AO_SPI_1_PE13_PE14_PE15 +#define AO_MPU9250_SPI_CS_PORT	(&stm_gpiod) +#define AO_MPU9250_SPI_CS_PIN	2 +#define HAS_IMU			1 + +/* + * mma655x + */ + +#define HAS_MMA655X		1 +#define AO_MMA655X_INVERT	0 +#define AO_MMA655X_SPI_INDEX	AO_SPI_1_PE13_PE14_PE15 +#define AO_MMA655X_CS_PORT	(&stm_gpiod) +#define AO_MMA655X_CS_PIN	4 + +#define NUM_CMDS		16 + +/* + * Companion + */ + +#define AO_COMPANION_CS_PORT	(&stm_gpiob) +#define AO_COMPANION_CS_PIN_0	(6) +#define AO_COMPANION_CS_PIN	AO_COMPANION_CS_PIN_0 +#define AO_COMPANION_CS_PIN_1	(7) +#define AO_COMPANION_SPI_BUS	AO_SPI_2_PB13_PB14_PB15 + +/* + * Monitor + */ + +#define HAS_MONITOR		0 +#define LEGACY_MONITOR		0 +#define HAS_MONITOR_PUT		1 +#define AO_MONITOR_LED		0 +#define HAS_RSSI		0 + +/* + * Profiling Viterbi decoding + */ + +#ifndef AO_PROFILE +#define AO_PROFILE	       	0 +#endif + +/* + * PWM output + */ + +#define NUM_PWM			4 +#define PWM_MAX			20000 +#define AO_PWM_TIMER		stm_tim4 +#define AO_PWM_TIMER_ENABLE	STM_RCC_APB1ENR_TIM4EN +#define AO_PWM_TIMER_SCALE	32 + +#define AO_PWM_0_GPIO		(&stm_gpiod) +#define AO_PWM_0_PIN		12 + +#define AO_PWM_1_GPIO		(&stm_gpiod) +#define AO_PWM_1_PIN		13 + +#define AO_PWM_2_GPIO		(&stm_gpiod) +#define AO_PWM_2_PIN		14 + +#define AO_PWM_3_GPIO		(&stm_gpiod) +#define AO_PWM_3_PIN		15 + +#endif /* _AO_PINS_H_ */ diff --git a/src/telemega-v3.0/ao_telemega.c b/src/telemega-v3.0/ao_telemega.c new file mode 100644 index 00000000..2259c751 --- /dev/null +++ b/src/telemega-v3.0/ao_telemega.c @@ -0,0 +1,104 @@ +/* + * Copyright © 2017 Keith Packard <keithp@keithp.com> + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation; either version 2 of the License, or + * (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, but + * WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU + * General Public License for more details. + * + * You should have received a copy of the GNU General Public License along + * with this program; if not, write to the Free Software Foundation, Inc., + * 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA. + */ + +#include <ao.h> +#include <ao_mpu9250.h> +#include <ao_mma655x.h> +#include <ao_log.h> +#include <ao_exti.h> +#include <ao_packet.h> +#include <ao_companion.h> +#include <ao_profile.h> +#include <ao_eeprom.h> +#if HAS_SAMPLE_PROFILE +#include <ao_sample_profile.h> +#endif +#include <ao_pyro.h> +#if HAS_STACK_GUARD +#include <ao_mpu.h> +#endif +#include <ao_pwm.h> + +int +main(void) +{ +	ao_clock_init(); + +#if HAS_STACK_GUARD +	ao_mpu_init(); +#endif + +	ao_task_init(); +	ao_serial_init(); +	ao_led_init(LEDS_AVAILABLE); +	ao_led_on(LEDS_AVAILABLE); +	ao_timer_init(); + +	ao_i2c_init(); +	ao_spi_init(); +	ao_dma_init(); +	ao_exti_init(); + +	ao_adc_init(); +#if HAS_BEEP +	ao_beep_init(); +#endif +	ao_cmd_init(); + +#if HAS_MS5607 +	ao_ms5607_init(); +#endif +#if HAS_MPU9250 +	ao_mpu9250_init(); +#endif +#if HAS_MMA655X +	ao_mma655x_init(); +#endif + +	ao_eeprom_init(); +	ao_storage_init(); + +	ao_flight_init(); +	ao_log_init(); +	ao_report_init(); + +	ao_usb_init(); +	ao_gps_init(); +	ao_gps_report_mega_init(); +	ao_telemetry_init(); +	ao_radio_init(); +	ao_packet_slave_init(FALSE); +	ao_igniter_init(); +	ao_companion_init(); +	ao_pyro_init(); + +	ao_config_init(); +#if AO_PROFILE +	ao_profile_init(); +#endif +#if HAS_SAMPLE_PROFILE +	ao_sample_profile_init(); +#endif + +	ao_pwm_init(); + +	ao_led_off(LEDS_AVAILABLE); + +	ao_start_scheduler(); +	return 0; +} diff --git a/src/telemega-v3.0/flash-loader/Makefile b/src/telemega-v3.0/flash-loader/Makefile new file mode 100644 index 00000000..9e00293f --- /dev/null +++ b/src/telemega-v3.0/flash-loader/Makefile @@ -0,0 +1,8 @@ +# +# AltOS flash loader build +# +# + +TOPDIR=../.. +HARDWARE=telemega-v3.0 +include $(TOPDIR)/stm/Makefile-flash.defs diff --git a/src/telemega-v3.0/flash-loader/ao_pins.h b/src/telemega-v3.0/flash-loader/ao_pins.h new file mode 100644 index 00000000..6e9bba57 --- /dev/null +++ b/src/telemega-v3.0/flash-loader/ao_pins.h @@ -0,0 +1,35 @@ +/* + * Copyright © 2017 Keith Packard <keithp@keithp.com> + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation; either version 2 of the License, or + * (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, but + * WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU + * General Public License for more details. + * + * You should have received a copy of the GNU General Public License along + * with this program; if not, write to the Free Software Foundation, Inc., + * 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA. + */ + +#ifndef _AO_PINS_H_ +#define _AO_PINS_H_ + +/* External crystal at 8MHz */ +#define AO_HSE		8000000 + +#include <ao_flash_stm_pins.h> + +/* Companion port cs_companion0 PB6 */ + +#define AO_BOOT_PIN			1 +#define AO_BOOT_APPLICATION_GPIO	stm_gpiob +#define AO_BOOT_APPLICATION_PIN		6 +#define AO_BOOT_APPLICATION_VALUE	1 +#define AO_BOOT_APPLICATION_MODE	AO_EXTI_MODE_PULL_UP + +#endif /* _AO_PINS_H_ */ diff --git a/src/telemetrum-v2.0/ao_pins.h b/src/telemetrum-v2.0/ao_pins.h index d9063173..d26a5193 100644 --- a/src/telemetrum-v2.0/ao_pins.h +++ b/src/telemetrum-v2.0/ao_pins.h @@ -64,6 +64,7 @@  #define AO_CONFIG_MAX_SIZE			1024  #define LOG_ERASE_MARK				0x55  #define LOG_MAX_ERASE				128 +#define AO_LOG_FORMAT				AO_LOG_FORMAT_TELEMETRUM  #define HAS_EEPROM		1  #define USE_INTERNAL_FLASH	0 diff --git a/src/telemetrum-v3.0/ao_pins.h b/src/telemetrum-v3.0/ao_pins.h index b937b422..6d4369c9 100644 --- a/src/telemetrum-v3.0/ao_pins.h +++ b/src/telemetrum-v3.0/ao_pins.h @@ -64,6 +64,7 @@  #define AO_CONFIG_MAX_SIZE			1024  #define LOG_ERASE_MARK				0x55  #define LOG_MAX_ERASE				128 +#define AO_LOG_FORMAT				AO_LOG_FORMAT_TELEMETRUM  #define HAS_EEPROM		1  #define USE_INTERNAL_FLASH	0 diff --git a/src/telescience-v0.2/ao_pins.h b/src/telescience-v0.2/ao_pins.h index c78766cd..29f16114 100644 --- a/src/telescience-v0.2/ao_pins.h +++ b/src/telescience-v0.2/ao_pins.h @@ -111,6 +111,7 @@  #define HAS_ADC			1  #define HAS_ADC_TEMP		1  #define HAS_LOG			1 +#define AO_LOG_FORMAT		AO_LOG_FORMAT_TELESCIENCE  /*   * SPI Flash memory diff --git a/src/teleterra-v0.2/ao_pins.h b/src/teleterra-v0.2/ao_pins.h index 8d9f7a2f..5bcf2c8a 100644 --- a/src/teleterra-v0.2/ao_pins.h +++ b/src/teleterra-v0.2/ao_pins.h @@ -75,6 +75,8 @@  	#define HAS_TELEMETRY		0  	#define AO_VALUE_32		0 + +	#define AO_LOG_FORMAT		AO_LOG_FORMAT_TELEMETRY  #endif  #if DBG_ON_P1 diff --git a/src/test/Makefile b/src/test/Makefile index 08808430..7bd13db9 100644 --- a/src/test/Makefile +++ b/src/test/Makefile @@ -1,10 +1,13 @@ -vpath % ..:../kernel:../drivers:../util:../micropeak:../aes:../product:../lisp +vpath %.o . +vpath %.c ..:../kernel:../drivers:../util:../micropeak:../aes:../product +vpath %.h ..:../kernel:../drivers:../util:../micropeak:../aes:../product +vpath make-kalman ..:../kernel:../drivers:../util:../micropeak:../aes:../product  PROGS=ao_flight_test ao_flight_test_baro ao_flight_test_accel ao_flight_test_noisy_accel ao_flight_test_mm \  	ao_flight_test_metrum ao_flight_test_mini \  	ao_gps_test ao_gps_test_skytraq ao_gps_test_ublox ao_convert_test ao_convert_pa_test ao_fec_test \  	ao_aprs_test ao_micropeak_test ao_fat_test ao_aes_test ao_int64_test \ -	ao_ms5607_convert_test ao_quaternion_test ao_lisp_test +	ao_ms5607_convert_test ao_quaternion_test  INCS=ao_kalman.h ao_ms5607.h ao_log.h ao_data.h altitude-pa.h altitude.h ao_quaternion.h ao_eeprom_read.h  TEST_SRC=ao_flight_test.c @@ -17,7 +20,7 @@ CFLAGS=-I.. -I. -I../kernel -I../drivers -I../micropeak -I../product -I../lisp -  all: $(PROGS) ao_aprs_data.wav -clean: +clean::  	rm -f $(PROGS) ao_aprs_data.wav run-out.baro run-out.full  install: @@ -94,12 +97,3 @@ ao_ms5607_convert_test: ao_ms5607_convert_test.c ao_ms5607_convert_8051.c ao_int  ao_quaternion_test: ao_quaternion_test.c ao_quaternion.h  	cc $(CFLAGS) -o $@ ao_quaternion_test.c -lm -AO_LISP_OBJS = ao_lisp_test.o ao_lisp_mem.o  ao_lisp_cons.o ao_lisp_string.o \ -	ao_lisp_atom.o ao_lisp_int.o ao_lisp_eval.o ao_lisp_poly.o \ -	ao_lisp_builtin.o ao_lisp_read.o ao_lisp_rep.o ao_lisp_frame.o \ -	ao_lisp_lambda.o ao_lisp_error.o ao_lisp_save.o ao_lisp_stack.o - -ao_lisp_test: $(AO_LISP_OBJS) -	cc $(CFLAGS) -o $@ $(AO_LISP_OBJS) - -$(AO_LISP_OBJS): ao_lisp.h ao_lisp_const.h ao_lisp_os.h diff --git a/src/test/ao_flight_test.c b/src/test/ao_flight_test.c index 298848d6..2d862f82 100644 --- a/src/test/ao_flight_test.c +++ b/src/test/ao_flight_test.c @@ -25,6 +25,7 @@  #include <string.h>  #include <getopt.h>  #include <math.h> +#define log ao_log_data  #define GRAVITY 9.80665 @@ -370,7 +371,7 @@ extern int16_t ao_accel_2g;  typedef int16_t	accel_t;  uint16_t	ao_serial_number; -uint16_t	ao_flight_number; +int16_t		ao_flight_number;  extern uint16_t	ao_sample_tick; @@ -998,7 +999,7 @@ main (int argc, char **argv)  #else  	emulator_app="baro";  #endif -	while ((c = getopt_long(argc, argv, "sdi:", options, NULL)) != -1) { +	while ((c = getopt_long(argc, argv, "sdpi:", options, NULL)) != -1) {  		switch (c) {  		case 's':  			summary = 1; @@ -1006,6 +1007,11 @@ main (int argc, char **argv)  		case 'd':  			ao_flight_debug = 1;  			break; +		case 'p': +#if PYRO_DBG +			pyro_dbg = 1; +#endif +			break;  		case 'i':  			info = optarg;  			break; diff --git a/src/test/ao_lisp_test.c b/src/test/ao_lisp_test.c deleted file mode 100644 index 68e3a202..00000000 --- a/src/test/ao_lisp_test.c +++ /dev/null @@ -1,134 +0,0 @@ -/* - * Copyright © 2016 Keith Packard <keithp@keithp.com> - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation, either version 2 of the License, or - * (at your option) any later version. - * - * This program is distributed in the hope that it will be useful, but - * WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU - * General Public License for more details. - */ - -#include "ao_lisp.h" -#include <stdio.h> - -static FILE *ao_lisp_file; -static int newline = 1; - -static char save_file[] = "lisp.image"; - -int -ao_lisp_os_save(void) -{ -	FILE	*save = fopen(save_file, "w"); - -	if (!save) { -		perror(save_file); -		return 0; -	} -	fwrite(ao_lisp_pool, 1, AO_LISP_POOL_TOTAL, save); -	fclose(save); -	return 1; -} - -int -ao_lisp_os_restore_save(struct ao_lisp_os_save *save, int offset) -{ -	FILE	*restore = fopen(save_file, "r"); -	size_t	ret; - -	if (!restore) { -		perror(save_file); -		return 0; -	} -	fseek(restore, offset, SEEK_SET); -	ret = fread(save, sizeof (struct ao_lisp_os_save), 1, restore); -	fclose(restore); -	if (ret != 1) -		return 0; -	return 1; -} - -int -ao_lisp_os_restore(void) -{ -	FILE	*restore = fopen(save_file, "r"); -	size_t	ret; - -	if (!restore) { -		perror(save_file); -		return 0; -	} -	ret = fread(ao_lisp_pool, 1, AO_LISP_POOL_TOTAL, restore); -	fclose(restore); -	if (ret != AO_LISP_POOL_TOTAL) -		return 0; -	return 1; -} - -int -ao_lisp_getc(void) -{ -	int c; - -	if (ao_lisp_file) -		return getc(ao_lisp_file); - -	if (newline) { -		printf("> "); -		newline = 0; -	} -	c = getchar(); -	if (c == '\n') -		newline = 1; -	return c; -} - -int -main (int argc, char **argv) -{ -	while (*++argv) { -		ao_lisp_file = fopen(*argv, "r"); -		if (!ao_lisp_file) { -			perror(*argv); -			exit(1); -		} -		ao_lisp_read_eval_print(); -		fclose(ao_lisp_file); -		ao_lisp_file = NULL; -	} -	ao_lisp_read_eval_print(); - -	printf ("collects: full: %d incremental %d\n", -		ao_lisp_collects[AO_LISP_COLLECT_FULL], -		ao_lisp_collects[AO_LISP_COLLECT_INCREMENTAL]); - -	printf ("freed: full %d incremental %d\n", -		ao_lisp_freed[AO_LISP_COLLECT_FULL], -		ao_lisp_freed[AO_LISP_COLLECT_INCREMENTAL]); - -	printf("loops: full %d incremental %d\n", -		ao_lisp_loops[AO_LISP_COLLECT_FULL], -		ao_lisp_loops[AO_LISP_COLLECT_INCREMENTAL]); - -	printf("loops per collect: full %f incremental %f\n", -	       (double) ao_lisp_loops[AO_LISP_COLLECT_FULL] / -	       (double) ao_lisp_collects[AO_LISP_COLLECT_FULL], -	       (double) ao_lisp_loops[AO_LISP_COLLECT_INCREMENTAL] / -	       (double) ao_lisp_collects[AO_LISP_COLLECT_INCREMENTAL]); - -	printf("freed per collect: full %f incremental %f\n", -	       (double) ao_lisp_freed[AO_LISP_COLLECT_FULL] / -	       (double) ao_lisp_collects[AO_LISP_COLLECT_FULL], -	       (double) ao_lisp_freed[AO_LISP_COLLECT_INCREMENTAL] / -	       (double) ao_lisp_collects[AO_LISP_COLLECT_INCREMENTAL]); - -	printf("freed per loop: full %f incremental %f\n", -	       (double) ao_lisp_freed[AO_LISP_COLLECT_FULL] / -	       (double) ao_lisp_loops[AO_LISP_COLLECT_FULL], -	       (double) ao_lisp_freed[AO_LISP_COLLECT_INCREMENTAL] / -	       (double) ao_lisp_loops[AO_LISP_COLLECT_INCREMENTAL]); -} diff --git a/src/test/hanoi.lisp b/src/test/hanoi.lisp deleted file mode 100644 index e2eb0fa0..00000000 --- a/src/test/hanoi.lisp +++ /dev/null @@ -1,155 +0,0 @@ -; -; Towers of Hanoi -; -; Copyright © 2016 Keith Packard <keithp@keithp.com> -; -; This program is free software; you can redistribute it and/or modify -; it under the terms of the GNU General Public License as published by -; the Free Software Foundation, either version 2 of the License, or -; (at your option) any later version. -; -; This program is distributed in the hope that it will be useful, but -; WITHOUT ANY WARRANTY; without even the implied warranty of -; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU -; General Public License for more details. -; - -					; ANSI control sequences - -(defun move-to (col row) -  (patom "\033[" row ";" col "H") -  ) - -(defun clear () -  (patom "\033[2J") -  ) - -(defun display-string (x y str) -  (move-to x y) -  (patom str) -  ) - -					; Here's the pieces to display - -(setq stack '("     *     " "    ***    " "   *****   " "  *******  " " ********* " "***********")) - -					; Here's all of the stacks of pieces -					; This is generated when the program is run - -(setq stacks nil) - -					; Display one stack, clearing any -					; space above it - -(defun display-stack (x y clear stack) -  (cond ((= 0 clear) -	 (cond (stack  -		(display-string x y (car stack)) -		(display-stack x (1+ y) 0 (cdr stack)) -		) -	       ) -	 ) -	(t  -	 (display-string x y "                   ") -	 (display-stack x (1+ y) (1- clear) stack) -	 ) -	) -  ) - -					; Position of the top of the stack on the screen -					; Shorter stacks start further down the screen - -(defun stack-pos (y stack) -  (- y (length stack)) -  ) - -					; Display all of the stacks, spaced 20 columns apart - -(defun display-stacks (x y stacks) -  (cond (stacks -	 (display-stack x 0 (stack-pos y (car stacks)) (car stacks)) -	 (display-stacks (+ x 20) y (cdr stacks))) -	) -  ) - -					; Display all of the stacks, then move the cursor -					; out of the way and flush the output - -(defun display () -  (display-stacks 0 top stacks) -  (move-to 1 21) -  (flush) -  ) - -					; Reset stacks to the starting state, with -					; all of the pieces in the first stack and the -					; other two empty - -(defun reset-stacks () -  (setq stacks (list stack nil nil)) -  (setq top (+ (length stack) 3)) -  (length stack) -  ) - -					; more functions which could usefully -					; be in the rom image - -(defun min (a b) -  (cond ((< a b) a) -	(b) -	) -  ) - -					; Replace a stack in the list of stacks -					; with a new value - -(defun replace (list pos member) -  (cond ((= pos 0) (cons member (cdr list))) -	((cons (car list) (replace (cdr list) (1- pos) member))) -	) -  ) - -					; Move a piece from the top of one stack -					; to the top of another - -(setq move-delay 100) - -(defun move-piece (from to) -  (let ((from-stack (nth stacks from)) -	(to-stack (nth stacks to)) -	(piece (car from-stack))) -    (setq from-stack (cdr from-stack)) -    (setq to-stack (cons piece to-stack)) -    (setq stacks (replace stacks from from-stack)) -    (setq stacks (replace stacks to to-stack)) -    (display) -    (delay move-delay) -    ) -  ) - -; The implementation of the game - -(defun _hanoi (n from to use) -  (cond ((= 1 n) -	 (move-piece from to) -	 ) -	(t -	 (_hanoi (1- n) from use to) -	 (_hanoi 1 from to use) -	 (_hanoi (1- n) use to from) -	 ) -	) -  ) - -					; A pretty interface which -					; resets the state of the game, -					; clears the screen and runs -					; the program - -(defun hanoi () -  (setq len (reset-stacks)) -  (clear) -  (_hanoi len 0 1 2) -  (move-to 0 23) -  t -  )  | 
