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>

diff --git a/src/lisp/ao_lisp.h b/src/lisp/ao_lisp.h
index 7cd8b5a5959ca29f3bcea8aeda154ba789325715..d32e7dcd8da263f8d96377bd8190ded9469a5b22 100644 (file)
--- 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);
 
@@ -812,6 +830,12 @@ ao_lisp_stack_eval(void);
 
 /* error */
 
+void
+ao_lisp_vprintf(char *format, va_list args);
+
+void
+ao_lisp_printf(char *format, ...);
+
 void
 ao_lisp_error_poly(char *name, ao_poly poly, ao_poly last);
 
@@ -828,7 +852,7 @@ ao_lisp_error(int error, char *format, ...);
 
 /* debugging macros */
 
-#if DBG_EVAL
+#if DBG_EVAL || DBG_READ || DBG_MEM
 #define DBG_CODE       1
 int ao_lisp_stack_depth;
 #define DBG_DO(a)      a
@@ -836,8 +860,8 @@ int ao_lisp_stack_depth;
 #define DBG_IN()       (++ao_lisp_stack_depth)
 #define DBG_OUT()      (--ao_lisp_stack_depth)
 #define DBG_RESET()    (ao_lisp_stack_depth = 0)
-#define DBG(...)       printf(__VA_ARGS__)
-#define DBGI(...)      do { DBG("%4d: ", __LINE__); DBG_INDENT(); DBG(__VA_ARGS__); } while (0)
+#define DBG(...)       ao_lisp_printf(__VA_ARGS__)
+#define DBGI(...)      do { printf("%4d: ", __LINE__); DBG_INDENT(); DBG(__VA_ARGS__); } while (0)
 #define DBG_CONS(a)    ao_lisp_cons_write(ao_lisp_cons_poly(a))
 #define DBG_POLY(a)    ao_lisp_poly_write(a)
 #define OFFSET(a)      ((a) ? (int) ((uint8_t *) a - ao_lisp_pool) : -1)
@@ -866,6 +890,16 @@ ao_lisp_frames_dump(void)
 #define DBG_FRAMES()
 #endif
 
+#if DBG_READ
+#define RDBGI(...)     DBGI(__VA_ARGS__)
+#define RDBG_IN()      DBG_IN()
+#define RDBG_OUT()     DBG_OUT()
+#else
+#define RDBGI(...)
+#define RDBG_IN()
+#define RDBG_OUT()
+#endif
+
 #define DBG_MEM_START  1
 
 #if DBG_MEM
@@ -877,7 +911,7 @@ extern int dbg_move_depth;
 
 extern int dbg_mem;
 
-#define MDBG_DO(a)     a
+#define MDBG_DO(a)     DBG_DO(a)
 #define MDBG_MOVE(...) do { if (dbg_mem) { int d; for (d = 0; d < dbg_move_depth; d++) printf ("  "); printf(__VA_ARGS__); } } while (0)
 #define MDBG_MORE(...) do { if (dbg_mem) printf(__VA_ARGS__); } while (0)
 #define MDBG_MOVE_IN() (dbg_move_depth++)

diff --git a/src/lisp/ao_lisp_builtin.c b/src/lisp/ao_lisp_builtin.c
index ad8f4125ff8ba1f777d065fe03faa9bcc7e4fb53..fdca020849177c9d2684bc22cfd91ef2c7c20b0a 100644 (file)
--- 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 c70aa1caa0f70dacc4e3c86cdcd74fdd62c58965..06e9d361e65630bf7b35d66ca2fef0eb4416db4e 100644 (file)
--- 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 ba13583433af303e5321870b42686b534cca8945..7f9094879e7ad9241273c6a635c52592f3792f42 100644 (file)
--- 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 02329ee62be8f9e73597a3c2a5bc29305a2ae4fb..ced182f6aeddfeb9a2b617f0f4b05293c4fc2d04 100644 (file)
--- 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 3a704380d715ac53b08c7532e1edda482ff64728..5471b137ff4327f5940c5101a9d461f3e701211e 100644 (file)
--- 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 f3b627bbb70c83c1c14b732425e555c64a455594..0ca12a81f6fcc843c24ba2f046970f7e8a83a37c 100644 (file)
--- 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;
 }