diff options
Diffstat (limited to 'src')
| -rw-r--r-- | src/lisp/ao_lisp.h | 42 | ||||
| -rw-r--r-- | src/lisp/ao_lisp_builtin.c | 6 | ||||
| -rw-r--r-- | src/lisp/ao_lisp_cons.c | 3 | ||||
| -rw-r--r-- | src/lisp/ao_lisp_error.c | 48 | ||||
| -rw-r--r-- | src/lisp/ao_lisp_eval.c | 6 | ||||
| -rw-r--r-- | src/lisp/ao_lisp_mem.c | 31 | ||||
| -rw-r--r-- | src/lisp/ao_lisp_read.c | 10 |
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; } |