Adding a debugger. This is an experimental prototype.

* Makefile (OBJS): New object file debug.o.

* dep.mk: Updated.

* match.c (h_fun): Use debug_begin and debug_end macros
to set up a debug frame for backtracing.
(match_line, match_files): Call debug_check to give debugger a chance
to instrument call.
(v_fun): Use debug_begin and debug_end macros to set up a debug frame
for backtracing. Call debug_check to give debugger a chance to
instrument call.

* stream.c (struct strm_ops): New function pointer, flush.
(stdio_maybe_write_error): Wrong word in error message corrected.
(stdio_flush): New static function.
(stdio_ops, pipe_ops): New function entered into tables.
(flush_stream): New function.

* stream.h (flush_stream): Declared.

* txr.c (help): New options documented.
(main): call to debug_init added. New debug options parsed and
opt_debugger set accordingly.

* unwind.c (uw_push_debug, uw_current_frame): New function.

* unwind.h (uw_frtype): New enumeration member UW_DBG.
(struct uw_debug): New frame variant.
(union uw_frame): New member, db.
(uw_push_debug, uw_current_frame): Declared,

* debug.c: New file.

* debug.h: New file.

11 files changed, 295 insertions, 8 deletions

diff --git a/ChangeLog b/ChangeLog
index 95aeb3a1..1a0f3910 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,5 +1,44 @@
 2011-11-13  Kaz Kylheku  <kaz@kylheku.com>
 
+	Adding a debugger. This is an experimental prototype.
+
+	* Makefile (OBJS): New object file debug.o.
+
+	* dep.mk: Updated.
+
+	* match.c (h_fun): Use debug_begin and debug_end macros
+	to set up a debug frame for backtracing.
+	(match_line, match_files): Call debug_check to give debugger a chance
+	to instrument call.
+	(v_fun): Use debug_begin and debug_end macros to set up a debug frame
+	for backtracing. Call debug_check to give debugger a chance to
+	instrument call.
+
+	* stream.c (struct strm_ops): New function pointer, flush.
+	(stdio_maybe_write_error): Wrong word in error message corrected.
+	(stdio_flush): New static function.
+	(stdio_ops, pipe_ops): New function entered into tables.
+	(flush_stream): New function.
+
+	* stream.h (flush_stream): Declared.
+
+	* txr.c (help): New options documented.
+	(main): call to debug_init added. New debug options parsed and
+	opt_debugger set accordingly.
+
+	* unwind.c (uw_push_debug, uw_current_frame): New function.
+
+	* unwind.h (uw_frtype): New enumeration member UW_DBG.
+	(struct uw_debug): New frame variant.
+	(union uw_frame): New member, db.
+	(uw_push_debug, uw_current_frame): Declared,
+
+	* debug.c: New file.
+
+	* debug.h: New file.
+
+2011-11-13  Kaz Kylheku  <kaz@kylheku.com>
+
 	Fix regression in earlier commit:
 
 	"Eliminate line numbers from the abstract syntax
diff --git a/Makefile b/Makefile
index feb25d2e..7d091c3f 100644
--- a/Makefile
+++ b/Makefile
@@ -37,7 +37,7 @@ CFLAGS := $(filter-out -Wmissing-prototypes -Wstrict-prototypes,$(CFLAGS))
 endif
 
 OBJS := txr.o lex.yy.o y.tab.o match.o lib.o regex.o gc.o unwind.o stream.o
-OBJS += hash.o utf8.o filter.o
+OBJS += hash.o utf8.o filter.o debug.o
 
 PROG := ./txr
 
diff --git a/debug.c b/debug.c
new file mode 100644
index 00000000..f5c74188
--- /dev/null
+++ b/debug.c
@@ -0,0 +1,106 @@
+#include <stdio.h>
+#include <stdlib.h>
+#include <string.h>
+#include <errno.h>
+#include <dirent.h>
+#include <setjmp.h>
+#include <stdarg.h>
+#include <wchar.h>
+#include "config.h"
+#include "lib.h"
+#include "debug.h"
+#include "gc.h"
+#include "unwind.h"
+#include "stream.h"
+#include "parser.h"
+
+int opt_debugger;
+static int step_mode;
+val breakpoints;
+val last_command;
+
+static void help(void)
+{
+}
+
+val debug(val form, val bindings, val data, val line, val chr)
+{
+  val lineno = source_loc(form);
+
+  if (!step_mode && !memqual(lineno, breakpoints)) {
+    return nil;
+  } else {
+    format(std_output, lit("stopped at line ~a\n"), lineno, nao);
+    format(std_output, lit("form: ~s\n"), form, nao);
+    format(std_output, lit("data (~s):\n~s\n"), line, data, nao);
+    if (chr)
+       format(std_output, lit("(character ~s)\n"), chr, nao);
+
+    for (;;) {
+      val input, command;
+
+      format(std_output, lit("txr> "), nao);
+      flush_stream(std_output);
+
+      input = split_str_set(get_line(std_input), lit("\t "));
+      command = or2(first(input), last_command);
+      last_command = command;
+
+      if (equal(command, lit("?")) || equal(command, lit("help"))) {
+        help();
+        continue;
+      } else if (equal(command, lit("c"))) {
+        step_mode = 0;
+        return nil;
+      } else if (equal(command, lit("n"))) {
+        step_mode = 1;
+        return nil;
+      } else if (equal(command, lit("v"))) {
+        format(std_output, lit("bindings: ~s\n"), bindings, nao);
+      } else if (equal(command, lit("f"))) {
+        format(std_output, lit("stopped at line ~a\n"), lineno, nao);
+        format(std_output, lit("form: ~s\n"), form, nao);
+      } else if (equal(command, lit("d"))) {
+        if (data) {
+          format(std_output, lit("data (~s):\n~s\n"), line, data, nao);
+          if (chr)
+             format(std_output, lit("(character ~s)\n"), chr, nao);
+        }
+      } else if (equal(command, lit("b")) || equal(command, lit("d"))) {
+        if (!rest(input)) {
+          format(std_output, lit("b needs argument\n"), nao);
+          continue;
+        } else {
+          long n = wcstol(c_str(second(input)), NULL, 10);
+          if (equal(command, lit("b")))
+            push(num(n), &breakpoints);
+        }
+      } else if (equal(command, lit("l"))) {
+        format(std_output, lit("breakpoints: ~s\n"), breakpoints, nao);
+      } else if (equal(command, lit("w"))) {
+        format(std_output, lit("backtrace:\n"), nao);
+        {
+          uw_frame_t *iter;
+
+          for (iter = uw_current_frame(); iter != 0; iter = iter->uw.up) {
+            if (iter->uw.type == UW_DBG) {
+              format(std_output, lit("(~s ~s)\n"), iter->db.func, iter->db.args, nao);
+            }
+          }
+        }
+      } else if (equal(command, lit("q"))) {
+        uw_throwf(query_error_s, lit("terminated via debugger"), nao);
+      } else {
+        format(std_output, lit("unrecognized command: ~a\n"), command, nao);
+      }
+    }
+
+    return nil;
+  }
+}
+
+void debug_init(void)
+{
+  step_mode = 1;
+  protect(&breakpoints, &last_command, (val *) 0);
+}
diff --git a/debug.h b/debug.h
new file mode 100644
index 00000000..b7248459
--- /dev/null
+++ b/debug.h
@@ -0,0 +1,52 @@
+/* Copyright 2011
+ * Kaz Kylheku <kaz@kylheku.com>
+ * Vancouver, Canada
+ * All rights reserved.
+ *
+ * BSD License:
+ *
+ * Redistribution and use in source and binary forms, with or without
+ * modification, are permitted provided that the following conditions
+ * are met:
+ *
+ *   1. Redistributions of source code must retain the above copyright
+ *      notice, this list of conditions and the following disclaimer.
+ *   2. Redistributions in binary form must reproduce the above copyright
+ *      notice, this list of conditions and the following disclaimer in
+ *      the documentation and/or other materials provided with the
+ *      distribution.
+ *   3. The name of the author may not be used to endorse or promote
+ *      products derived from this software without specific prior
+ *      written permission.
+ *
+ * THIS SOFTWARE IS PROVIDED ``AS IS'' AND WITHOUT ANY EXPRESS OR
+ * IMPLIED WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED
+ * WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE.
+ */
+
+extern int opt_debugger;
+
+val debug(val form, val bindings, val data, val line, val chr);
+
+INLINE val debug_check(val form, val bindings, val data, val line, val chr)
+{
+  return (opt_debugger) ? debug(form, bindings, data, line, chr) : nil;
+}
+
+void debug_init(void);
+
+#define debug_begin(FUNC, ARGS, UBP,    \
+                    BINDINGS, DATA,     \
+                    LINE, CHR)          \
+  do {                                  \
+    uw_frame_t db_env;                  \
+    if (opt_debugger)                   \
+      uw_push_debug(&db_env, FUNC, ARGS,\
+                    UBP, BINDINGS, DATA,\
+                    LINE, CHR);         \
+    (void) 0
+
+#define debug_end                       \
+    if (opt_debugger)                   \
+      uw_pop_frame(&db_env);            \
+  } while (0)
diff --git a/dep.mk b/dep.mk
index 703a8d3b..ea77d1c2 100644
--- a/dep.mk
+++ b/dep.mk
@@ -1,7 +1,7 @@
-txr.o: config.h $(top_srcdir)/lib.h $(top_srcdir)/stream.h $(top_srcdir)/gc.h $(top_srcdir)/unwind.h $(top_srcdir)/parser.h $(top_srcdir)/match.h $(top_srcdir)/utf8.h $(top_srcdir)/txr.h
+txr.o: config.h $(top_srcdir)/lib.h $(top_srcdir)/stream.h $(top_srcdir)/gc.h $(top_srcdir)/unwind.h $(top_srcdir)/parser.h $(top_srcdir)/match.h $(top_srcdir)/utf8.h $(top_srcdir)/debug.h $(top_srcdir)/txr.h
 lex.yy.o: config.h $(top_srcdir)/lib.h y.tab.h $(top_srcdir)/gc.h $(top_srcdir)/stream.h $(top_srcdir)/utf8.h $(top_srcdir)/unwind.h $(top_srcdir)/hash.h $(top_srcdir)/parser.h
 y.tab.o: config.h $(top_srcdir)/lib.h $(top_srcdir)/regex.h $(top_srcdir)/utf8.h $(top_srcdir)/match.h $(top_srcdir)/hash.h $(top_srcdir)/parser.h
-match.o: config.h $(top_srcdir)/lib.h $(top_srcdir)/gc.h $(top_srcdir)/unwind.h $(top_srcdir)/regex.h $(top_srcdir)/stream.h $(top_srcdir)/parser.h $(top_srcdir)/txr.h $(top_srcdir)/utf8.h $(top_srcdir)/filter.h $(top_srcdir)/hash.h $(top_srcdir)/match.h
+match.o: config.h $(top_srcdir)/lib.h $(top_srcdir)/gc.h $(top_srcdir)/unwind.h $(top_srcdir)/regex.h $(top_srcdir)/stream.h $(top_srcdir)/parser.h $(top_srcdir)/txr.h $(top_srcdir)/utf8.h $(top_srcdir)/filter.h $(top_srcdir)/hash.h $(top_srcdir)/debug.h $(top_srcdir)/match.h
 lib.o: config.h $(top_srcdir)/lib.h $(top_srcdir)/gc.h $(top_srcdir)/hash.h $(top_srcdir)/unwind.h $(top_srcdir)/stream.h $(top_srcdir)/utf8.h $(top_srcdir)/filter.h
 regex.o: config.h $(top_srcdir)/lib.h $(top_srcdir)/unwind.h $(top_srcdir)/regex.h $(top_srcdir)/txr.h
 gc.o: config.h $(top_srcdir)/lib.h $(top_srcdir)/stream.h $(top_srcdir)/hash.h $(top_srcdir)/txr.h $(top_srcdir)/gc.h
@@ -10,3 +10,4 @@ stream.o: config.h $(top_srcdir)/lib.h $(top_srcdir)/gc.h $(top_srcdir)/unwind.h
 hash.o: config.h $(top_srcdir)/lib.h $(top_srcdir)/gc.h $(top_srcdir)/unwind.h $(top_srcdir)/hash.h
 utf8.o: config.h $(top_srcdir)/lib.h $(top_srcdir)/unwind.h $(top_srcdir)/utf8.h
 filter.o: config.h $(top_srcdir)/lib.h $(top_srcdir)/hash.h $(top_srcdir)/unwind.h $(top_srcdir)/match.h $(top_srcdir)/filter.h $(top_srcdir)/gc.h
+debug.o: config.h $(top_srcdir)/lib.h $(top_srcdir)/debug.h $(top_srcdir)/gc.h $(top_srcdir)/unwind.h $(top_srcdir)/stream.h $(top_srcdir)/parser.h
diff --git a/match.c b/match.c
index a26f8191..0948ce37 100644
--- a/match.c
+++ b/match.c
@@ -43,6 +43,7 @@
 #include "utf8.h"
 #include "filter.h"
 #include "hash.h"
+#include "debug.h"
 #include "match.h"
 
 int output_produced;
@@ -928,9 +929,11 @@ static val h_fun(match_line_ctx c, match_line_ctx *cout)
     {
       uw_block_begin(nil, result);
       uw_env_begin;
+      debug_begin(sym, args, ub_p_a_pairs, c.bindings, c.dataline, c.data_lineno, c.pos);
 
       result = match_line(ml_bindings_specline(c, bindings_cp, body));
 
+      debug_end;
       uw_env_end;
       uw_block_end;
 
@@ -995,6 +998,8 @@ static val match_line(match_line_ctx c)
 
     elem = first(c.specline);
 
+    debug_check(elem, c.bindings, c.dataline, c.data_lineno, c.pos);
+
     switch (elem ? type(elem) : 0) {
     case CONS: /* directive */
       {
@@ -2844,6 +2849,8 @@ static val v_fun(match_files_ctx *c)
     val piter, aiter;
     val bindings_cp = copy_alist(c->bindings);
 
+    debug_check(specline, c->bindings, if2(consp(c->data), car(c->data)), c->data_lineno, nil);
+
     if (!equal(length(args), length(params)))
       sem_error(specline, lit("function ~a takes ~a argument(s)"),
                 sym, length(params), nao);
@@ -2873,7 +2880,10 @@ static val v_fun(match_files_ctx *c)
     {
       uw_block_begin(nil, result);
       uw_env_begin;
+      debug_begin(sym, args, ub_p_a_pairs, c->bindings, if2(consp(c->data), car(c->data)),
+                  c->data_lineno, nil);
       result = match_files(mf_spec_bindings(*c, body, bindings_cp));
+      debug_end;
       uw_env_end;
       uw_block_end;
 
@@ -2979,7 +2989,11 @@ repeat_spec_same_data:
 
       if (entry) {
         v_match_func vmf = (v_match_func) cptr_get(entry);
-        val result = vmf(&c);
+        val result;
+
+        debug_check(first_spec, c.bindings, if2(consp(c.data), car(c.data)), c.data_lineno, nil);
+
+        result = vmf(&c);
 
         if (result == next_spec_k) {
           if ((c.spec = rest(c.spec)) == nil)
diff --git a/stream.c b/stream.c
index 6062d91e..88ea5b49 100644
--- a/stream.c
+++ b/stream.c
@@ -54,6 +54,7 @@ struct strm_ops {
   val (*get_char)(val);
   val (*get_byte)(val);
   val (*close)(val, val);
+  val (*flush)(val);
 };
 
 static void common_destroy(val obj)
@@ -103,7 +104,7 @@ static val stdio_maybe_write_error(val stream)
 {
   struct stdio_handle *h = (struct stdio_handle *) stream->co.handle;
   if (h->f == 0)
-    uw_throwf(file_error_s, lit("error reading ~a: file closed"), stream, nao);
+    uw_throwf(file_error_s, lit("error writing ~a: file closed"), stream, nao);
   clearerr(h->f);
   uw_throwf(file_error_s, lit("error writing ~a: ~a/~s"),
             stream, num(errno), string_utf8(strerror(errno)), nao);
@@ -141,6 +142,14 @@ static val stdio_put_char(val stream, val ch)
          ? t : stdio_maybe_write_error(stream);
 }
 
+static val stdio_flush(val stream)
+{
+  struct stdio_handle *h = (struct stdio_handle *) stream->co.handle;
+  if (fflush(h->f))
+    stdio_maybe_write_error(stream);
+  return t;
+}
+
 static wchar_t *snarf_line(struct stdio_handle *h)
 {
   const size_t min_size = 512;
@@ -233,7 +242,8 @@ static struct strm_ops stdio_ops = {
   stdio_get_line,
   stdio_get_char,
   stdio_get_byte,
-  stdio_close
+  stdio_close,
+  stdio_flush
 };
 
 static val pipe_close(val stream, val throw_on_error)
@@ -286,7 +296,8 @@ static struct strm_ops pipe_ops = {
   stdio_get_line,
   stdio_get_char,
   stdio_get_byte,
-  pipe_close
+  pipe_close,
+  stdio_flush,
 };
 
 static void string_in_stream_mark(val stream)
@@ -1051,6 +1062,18 @@ val put_line(val stream, val string)
   return (put_string(stream, string), put_char(stream, chr('\n')));
 }
 
+val flush_stream(val stream)
+{
+  type_check (stream, COBJ);
+  type_assert (stream->co.cls == stream_s, (lit("~a is not a stream"),
+                                            stream, nao));
+
+  {
+    struct strm_ops *ops = (struct strm_ops *) stream->co.ops;
+    return ops->flush ? ops->flush(stream) : t;
+  }
+}
+
 void stream_init(void)
 {
   protect(&std_input, &std_output, &std_error, (val *) 0);
diff --git a/stream.h b/stream.h
index 161be5da..8dbc0dd8 100644
--- a/stream.h
+++ b/stream.h
@@ -45,5 +45,6 @@ val format(val stream, val string, ...);
 val put_string(val stream, val string);
 val put_line(val stream, val string);
 val put_char(val stream, val ch);
+val flush_stream(val stream);
 
 void stream_init(void);
diff --git a/txr.c b/txr.c
index 644314f0..7a611432 100644
--- a/txr.c
+++ b/txr.c
@@ -40,6 +40,7 @@
 #include "parser.h"
 #include "match.h"
 #include "utf8.h"
+#include "debug.h"
 #include "txr.h"
 
 const wchli_t *version = wli("041");
@@ -91,6 +92,8 @@ static void help(void)
 "-q                     Quiet: don't report errors during query matching.\n"
 "-v                     Verbose: extra logging from matcher.\n"
 "-b                     Don't dump list of bindings.\n"
+"-l                     If dumping bindings, use a Lisp format.\n"
+"-d                     Debugger mode.\n"
 "-a num                 Generate array variables up to num-dimensions.\n"
 "                       Default is 1. Additional dimensions are fudged\n"
 "                       by generating numeric suffixes\n"
@@ -103,6 +106,8 @@ static void help(void)
 "                       to the utility.\n"
 "--help                 You already know!\n"
 "--version              Display program version\n"
+"--lisp-bindings        Synonym for -l\n"
+"--debugger             Synonym for -d\n"
 "\n"
 "Options that take no argument can be combined. The -q and -v options\n"
 "are mutually exclusive; the right-most one dominates.\n"
@@ -145,6 +150,7 @@ int main(int argc, char **argv)
   init(progname, oom_realloc_handler, &stack_bottom);
   match_init();
   parse_init();
+  debug_init();
   return txr_main(argc, argv);
 }
 
@@ -288,6 +294,10 @@ int txr_main(int argc, char **argv)
       opt_lisp_bindings = 1;
       argv++, argc--;
       continue;
+    } else if (!strcmp(*argv, "--debugger")) {
+      opt_debugger = 1;
+      argv++, argc--;
+      continue;
     }
 
 
@@ -307,6 +317,9 @@ int txr_main(int argc, char **argv)
         case 'l':
           opt_lisp_bindings = 1;
           break;
+        case 'd':
+          opt_debugger = 1;
+          break;
         case 'a':
         case 'c':
         case 'D':
diff --git a/unwind.c b/unwind.c
index 0d8a48e4..4bb6646c 100644
--- a/unwind.c
+++ b/unwind.c
@@ -166,6 +166,22 @@ val uw_set_match_context(val context)
   return context;
 }
 
+void uw_push_debug(uw_frame_t *fr, val func, val args,
+                   val ub_p_a_pairs, val bindings, val data,
+                   val line, val chr)
+{
+  fr->db.type = UW_DBG;
+  fr->db.func = func;
+  fr->db.args = args;
+  fr->db.ub_p_a_pairs = args;
+  fr->db.bindings = bindings;
+  fr->db.data = data;
+  fr->db.line = line;
+  fr->db.chr = chr;
+  fr->db.up = uw_stack;
+  uw_stack = fr;
+}
+
 void uw_pop_frame(uw_frame_t *fr)
 {
   assert (fr == uw_stack);
@@ -176,6 +192,11 @@ void uw_pop_frame(uw_frame_t *fr)
   }
 }
 
+uw_frame_t *uw_current_frame(void)
+{
+  return uw_stack;
+}
+
 val uw_block_return(val tag, val result)
 {
   uw_frame_t *ex;
diff --git a/unwind.h b/unwind.h
index a09df613..1ccdbaee 100644
--- a/unwind.h
+++ b/unwind.h
@@ -31,7 +31,7 @@
 #endif
 
 typedef union uw_frame uw_frame_t;
-typedef enum uw_frtype { UW_BLOCK, UW_ENV, UW_CATCH } uw_frtype_t;
+typedef enum uw_frtype { UW_BLOCK, UW_ENV, UW_CATCH, UW_DBG } uw_frtype_t;
 
 struct uw_common {
   uw_frame_t *up;
@@ -65,11 +65,24 @@ struct uw_catch {
   jmp_buf jb;
 };
 
+struct uw_debug {
+  uw_frame_t *up;
+  uw_frtype_t type;
+  val func;
+  val args;
+  val ub_p_a_pairs;
+  val bindings;
+  val data;
+  val line;
+  val chr;
+};
+
 union uw_frame {
   struct uw_common uw;
   struct uw_block bl;
   struct uw_dynamic_env ev;
   struct uw_catch ca;
+  struct uw_debug db;
 };
 
 void uw_push_block(uw_frame_t *, val tag);
@@ -86,7 +99,11 @@ noreturn val uw_errorf(val fmt, ...);
 val uw_register_subtype(val sub, val super);
 val uw_exception_subtype_p(val sub, val sup);
 void uw_continue(uw_frame_t *curr, uw_frame_t *target);
+void uw_push_debug(uw_frame_t *, val func, val args,
+                   val ub_p_a_pairs, val bindings, val data,
+                   val line, val chr);
 void uw_pop_frame(uw_frame_t *);
+uw_frame_t *uw_current_frame(void);
 void uw_init(void);
 
 noreturn val type_mismatch(val, ...);