#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>
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)
{
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);
/* 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);
/* 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
#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)
#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
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++)
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;
}
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)),
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);
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, ...)
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;
}
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) {
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 ... */
#include "ao_lisp.h"
#include <stdio.h>
+#include <assert.h>
#ifdef AO_LISP_MAKE_CONST
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
*/
void
ao_lisp_cons_stash(int id, struct ao_lisp_cons *cons)
{
+ assert(save_cons[id] == 0);
save_cons[id] = cons;
}
void
ao_lisp_poly_stash(int id, ao_poly poly)
{
+ assert(save_poly[id] == AO_LISP_NIL);
save_poly[id] = poly;
}
void
ao_lisp_string_stash(int id, char *string)
{
+ assert(save_string[id] == NULL);
save_string[id] = string;
}
void
ao_lisp_frame_stash(int id, struct ao_lisp_frame *frame)
{
+ assert(save_frame[id] == NULL);
save_frame[id] = frame;
}
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;
}
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),
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;
}