altos/lisp: Split out read debug, add memory validation

Split read debug into a separate #define to reduce debug noise
Add some memory validation -- validate stash API, and validate
cons_free calls.

Signed-off-by: Keith Packard <keithp@keithp.com>

7 files changed, 125 insertions, 21 deletions

diff --git a/src/lisp/ao_lisp.h b/src/lisp/ao_lisp.h
index 7cd8b5a5..d32e7dcd 100644
--- a/src/lisp/ao_lisp.h
+++ b/src/lisp/ao_lisp.h
@@ -17,6 +17,9 @@
 
 #define DBG_MEM		0
 #define DBG_EVAL	0
+#define DBG_READ	0
+#define DBG_FREE_CONS	0
+#define NDEBUG		1
 
 #include <stdint.h>
 #include <string.h>
@@ -387,6 +390,16 @@ static inline int ao_lisp_poly_type(ao_poly poly) {
 	return type;
 }
 
+static inline int
+ao_lisp_is_cons(ao_poly poly) {
+	return (ao_lisp_poly_base_type(poly) == AO_LISP_CONS);
+}
+
+static inline int
+ao_lisp_is_pair(ao_poly poly) {
+	return poly != AO_LISP_NIL && (ao_lisp_poly_base_type(poly) == AO_LISP_CONS);
+}
+
 static inline struct ao_lisp_cons *
 ao_lisp_poly_cons(ao_poly poly)
 {
@@ -520,6 +533,11 @@ ao_lisp_alloc(int size);
 int
 ao_lisp_collect(uint8_t style);
 
+#if DBG_FREE_CONS
+void
+ao_lisp_cons_check(struct ao_lisp_cons *cons);
+#endif
+
 void
 ao_lisp_cons_stash(int id, struct ao_lisp_cons *cons);
 
@@ -813,6 +831,12 @@ ao_lisp_stack_eval(void);
 /* error */
 
 void
+ao_lisp_vprintf(char *format, va_list args);
+
+void
+ao_lisp_printf(char *format, ...);
+
+void
 ao_lisp_error_poly(char *name, ao_poly poly, ao_poly last);
 
 void
@@ -828,7 +852,7 @@ ao_lisp_error(int error, char *format, ...);
 
 /* debugging macros */
 
-#if DBG_EVAL
+#if DBG_EVAL || DBG_READ || DBG_MEM
 #define DBG_CODE	1
 int ao_lisp_stack_depth;
 #define DBG_DO(a)	a
@@ -836,8 +860,8 @@ int ao_lisp_stack_depth;
 #define DBG_IN()	(++ao_lisp_stack_depth)
 #define DBG_OUT()	(--ao_lisp_stack_depth)
 #define DBG_RESET()	(ao_lisp_stack_depth = 0)
-#define DBG(...) 	printf(__VA_ARGS__)
-#define DBGI(...)	do { DBG("%4d: ", __LINE__); DBG_INDENT(); DBG(__VA_ARGS__); } while (0)
+#define DBG(...) 	ao_lisp_printf(__VA_ARGS__)
+#define DBGI(...)	do { printf("%4d: ", __LINE__); DBG_INDENT(); DBG(__VA_ARGS__); } while (0)
 #define DBG_CONS(a)	ao_lisp_cons_write(ao_lisp_cons_poly(a))
 #define DBG_POLY(a)	ao_lisp_poly_write(a)
 #define OFFSET(a)	((a) ? (int) ((uint8_t *) a - ao_lisp_pool) : -1)
@@ -866,6 +890,16 @@ ao_lisp_frames_dump(void)
 #define DBG_FRAMES()
 #endif
 
+#if DBG_READ
+#define RDBGI(...)	DBGI(__VA_ARGS__)
+#define RDBG_IN()	DBG_IN()
+#define RDBG_OUT()	DBG_OUT()
+#else
+#define RDBGI(...)
+#define RDBG_IN()
+#define RDBG_OUT()
+#endif
+
 #define DBG_MEM_START	1
 
 #if DBG_MEM
@@ -877,7 +911,7 @@ extern int dbg_move_depth;
 
 extern int dbg_mem;
 
-#define MDBG_DO(a)	a
+#define MDBG_DO(a)	DBG_DO(a)
 #define MDBG_MOVE(...) do { if (dbg_mem) { int d; for (d = 0; d < dbg_move_depth; d++) printf ("  "); printf(__VA_ARGS__); } } while (0)
 #define MDBG_MORE(...) do { if (dbg_mem) printf(__VA_ARGS__); } while (0)
 #define MDBG_MOVE_IN()	(dbg_move_depth++)
diff --git a/src/lisp/ao_lisp_builtin.c b/src/lisp/ao_lisp_builtin.c
index ad8f4125..fdca0208 100644
--- a/src/lisp/ao_lisp_builtin.c
+++ b/src/lisp/ao_lisp_builtin.c
@@ -125,7 +125,7 @@ ao_lisp_check_argt(ao_poly name, struct ao_lisp_cons *cons, int argc, int type,
 	ao_poly car = ao_lisp_arg(cons, argc);
 
 	if ((!car && !nil_ok) || ao_lisp_poly_type(car) != type)
-		return ao_lisp_error(AO_LISP_INVALID, "%s: invalid type for arg %d", ao_lisp_poly_atom(name)->name, argc);
+		return ao_lisp_error(AO_LISP_INVALID, "%s: arg %d invalid type %v", ao_lisp_poly_atom(name)->name, argc, car);
 	return _ao_lisp_bool_true;
 }
 
@@ -226,9 +226,9 @@ ao_lisp_do_setq(struct ao_lisp_cons *cons)
 		return AO_LISP_NIL;
 	name = cons->car;
 	if (ao_lisp_poly_type(name) != AO_LISP_ATOM)
-		return ao_lisp_error(AO_LISP_INVALID, "set! of non-atom");
+		return ao_lisp_error(AO_LISP_INVALID, "set! of non-atom %v", name);
 	if (!ao_lisp_atom_ref(name))
-		return ao_lisp_error(AO_LISP_INVALID, "atom not defined");
+		return ao_lisp_error(AO_LISP_INVALID, "atom %v not defined", name);
 	return ao_lisp__cons(_ao_lisp_atom_set,
 			     ao_lisp__cons(ao_lisp__cons(_ao_lisp_atom_quote,
 							 ao_lisp__cons(name, AO_LISP_NIL)),
diff --git a/src/lisp/ao_lisp_cons.c b/src/lisp/ao_lisp_cons.c
index c70aa1ca..06e9d361 100644
--- a/src/lisp/ao_lisp_cons.c
+++ b/src/lisp/ao_lisp_cons.c
@@ -127,6 +127,9 @@ ao_lisp__cons(ao_poly car, ao_poly cdr)
 void
 ao_lisp_cons_free(struct ao_lisp_cons *cons)
 {
+#if DBG_FREE_CONS
+	ao_lisp_cons_check(cons);
+#endif
 	while (cons) {
 		ao_poly cdr = cons->cdr;
 		cons->cdr = ao_lisp_cons_poly(ao_lisp_cons_free_list);
diff --git a/src/lisp/ao_lisp_error.c b/src/lisp/ao_lisp_error.c
index ba135834..7f909487 100644
--- a/src/lisp/ao_lisp_error.c
+++ b/src/lisp/ao_lisp_error.c
@@ -82,6 +82,43 @@ ao_lisp_error_frame(int indent, char *name, struct ao_lisp_frame *frame)
 		printf ("}\n");
 }
 
+void
+ao_lisp_vprintf(char *format, va_list args)
+{
+	char c;
+
+	while ((c = *format++) != '\0') {
+		if (c == '%') {
+			switch (c = *format++) {
+			case 'v':
+				ao_lisp_poly_write((ao_poly) va_arg(args, unsigned int));
+				break;
+			case 'p':
+				printf("%p", va_arg(args, void *));
+				break;
+			case 'd':
+				printf("%d", va_arg(args, int));
+				break;
+			case 's':
+				printf("%s", va_arg(args, char *));
+				break;
+			default:
+				putchar(c);
+				break;
+			}
+		} else
+			putchar(c);
+	}
+}
+
+void
+ao_lisp_printf(char *format, ...)
+{
+	va_list args;
+	va_start(args, format);
+	ao_lisp_vprintf(format, args);
+	va_end(args);
+}
 
 ao_poly
 ao_lisp_error(int error, char *format, ...)
@@ -90,14 +127,13 @@ ao_lisp_error(int error, char *format, ...)
 
 	ao_lisp_exception |= error;
 	va_start(args, format);
-	vprintf(format, args);
+	ao_lisp_vprintf(format, args);
+	putchar('\n');
 	va_end(args);
-	printf("\n");
-	printf("Value: "); ao_lisp_poly_write(ao_lisp_v); printf("\n");
+	ao_lisp_printf("Value:  %v\n", ao_lisp_v);
+	ao_lisp_printf("Frame:  %v\n", ao_lisp_frame_poly(ao_lisp_frame_current));
 	printf("Stack:\n");
 	ao_lisp_stack_write(ao_lisp_stack_poly(ao_lisp_stack));
-	printf("Globals:\n\t");
-	ao_lisp_frame_write(ao_lisp_frame_poly(ao_lisp_frame_global));
-	printf("\n");
+	ao_lisp_printf("Globals: %v\n", ao_lisp_frame_poly(ao_lisp_frame_global));
 	return AO_LISP_NIL;
 }
diff --git a/src/lisp/ao_lisp_eval.c b/src/lisp/ao_lisp_eval.c
index 02329ee6..ced182f6 100644
--- a/src/lisp/ao_lisp_eval.c
+++ b/src/lisp/ao_lisp_eval.c
@@ -68,7 +68,7 @@ func_type(ao_poly func)
 static int
 ao_lisp_eval_sexpr(void)
 {
-	DBGI("sexpr: "); DBG_POLY(ao_lisp_v); DBG("\n");
+	DBGI("sexpr: %v\n", ao_lisp_v);
 	switch (ao_lisp_poly_type(ao_lisp_v)) {
 	case AO_LISP_CONS:
 		if (ao_lisp_v == AO_LISP_NIL) {
@@ -193,8 +193,8 @@ ao_lisp_eval_formal(void)
 			ao_lisp_stack->sexprs = prev->sexprs;
 
 			DBGI(".. start macro\n");
-			DBGI(".. sexprs       "); DBG_POLY(ao_lisp_stack->sexprs); DBG("\n");
-			DBGI(".. values       "); DBG_POLY(ao_lisp_stack->values); DBG("\n");
+			DBGI("\t.. sexprs       "); DBG_POLY(ao_lisp_stack->sexprs); DBG("\n");
+			DBGI("\t.. values       "); DBG_POLY(ao_lisp_stack->values); DBG("\n");
 			DBG_FRAMES();
 
 			/* fall through ... */
diff --git a/src/lisp/ao_lisp_mem.c b/src/lisp/ao_lisp_mem.c
index 3a704380..5471b137 100644
--- a/src/lisp/ao_lisp_mem.c
+++ b/src/lisp/ao_lisp_mem.c
@@ -16,6 +16,7 @@
 
 #include "ao_lisp.h"
 #include <stdio.h>
+#include <assert.h>
 
 #ifdef AO_LISP_MAKE_CONST
 
@@ -623,6 +624,32 @@ ao_lisp_collect(uint8_t style)
 	return AO_LISP_POOL - ao_lisp_top;
 }
 
+#if DBG_FREE_CONS
+void
+ao_lisp_cons_check(struct ao_lisp_cons *cons)
+{
+	ao_poly	cdr;
+	int offset;
+
+	chunk_low = 0;
+	reset_chunks();
+	walk(ao_lisp_mark_ref, ao_lisp_poly_mark_ref);
+	while (cons) {
+		if (!AO_LISP_IS_POOL(cons))
+			break;
+		offset = pool_offset(cons);
+		if (busy(ao_lisp_busy, offset)) {
+			ao_lisp_printf("cons at %p offset %d poly %d is busy\n\t%v\n", cons, offset, ao_lisp_cons_poly(cons), ao_lisp_cons_poly(cons));
+			abort();
+		}
+		cdr = cons->cdr;
+		if (!ao_lisp_is_pair(cdr))
+			break;
+		cons = ao_lisp_poly_cons(cdr);
+	}
+}
+#endif
+
 /*
  * Mark interfaces for objects
  */
@@ -883,6 +910,7 @@ ao_lisp_alloc(int size)
 void
 ao_lisp_cons_stash(int id, struct ao_lisp_cons *cons)
 {
+	assert(save_cons[id] == 0);
 	save_cons[id] = cons;
 }
 
@@ -897,6 +925,7 @@ ao_lisp_cons_fetch(int id)
 void
 ao_lisp_poly_stash(int id, ao_poly poly)
 {
+	assert(save_poly[id] == AO_LISP_NIL);
 	save_poly[id] = poly;
 }
 
@@ -911,6 +940,7 @@ ao_lisp_poly_fetch(int id)
 void
 ao_lisp_string_stash(int id, char *string)
 {
+	assert(save_string[id] == NULL);
 	save_string[id] = string;
 }
 
@@ -925,6 +955,7 @@ ao_lisp_string_fetch(int id)
 void
 ao_lisp_frame_stash(int id, struct ao_lisp_frame *frame)
 {
+	assert(save_frame[id] == NULL);
 	save_frame[id] = frame;
 }
 
diff --git a/src/lisp/ao_lisp_read.c b/src/lisp/ao_lisp_read.c
index f3b627bb..0ca12a81 100644
--- a/src/lisp/ao_lisp_read.c
+++ b/src/lisp/ao_lisp_read.c
@@ -464,7 +464,7 @@ _lex(void)
 static inline int lex(void)
 {
 	int	parse_token = _lex();
-	DBGI("token %d (%s)\n", parse_token, token_string);
+	RDBGI("token %d (%s)\n", parse_token, token_string);
 	return parse_token;
 }
 
@@ -481,8 +481,8 @@ struct ao_lisp_cons	*ao_lisp_read_stack;
 static int
 push_read_stack(int cons, int read_state)
 {
-	DBGI("push read stack %p 0x%x\n", ao_lisp_read_cons, read_state);
-	DBG_IN();
+	RDBGI("push read stack %p 0x%x\n", ao_lisp_read_cons, read_state);
+	RDBG_IN();
 	if (cons) {
 		ao_lisp_read_stack = ao_lisp_cons_cons(ao_lisp_cons_poly(ao_lisp_read_cons),
 						       ao_lisp__cons(ao_lisp_int_poly(read_state),
@@ -513,8 +513,8 @@ pop_read_stack(int cons)
 		ao_lisp_read_cons_tail = 0;
 		ao_lisp_read_stack = 0;
 	}
-	DBG_OUT();
-	DBGI("pop read stack %p %d\n", ao_lisp_read_cons, read_state);
+	RDBG_OUT();
+	RDBGI("pop read stack %p %d\n", ao_lisp_read_cons, read_state);
 	return read_state;
 }