Detect cycles in rlcp_tree.

This will be required when the parser becomes
capable of creating object graphs with cycles.

* parser.c (parser_callgraph_circ_check): New function.

* parser.h (struct circ_stack): New struct.
(parser_callgraph_circ_check): Declared.

* parser.y (rlcp_tree_rec): New static function.
(rlcp_tree): Reduced to wrapper for rlcp_tree_rec.

3 files changed, 34 insertions, 3 deletions

diff --git a/parser.c b/parser.c
index 6d7801c8..5f458f1e 100644
--- a/parser.c
+++ b/parser.c
@@ -200,6 +200,16 @@ void prime_parser_post(parser_t *p, enum prime_parser prim)
     p->recent_tok.yy_char = 0;
 }
 
+int parser_callgraph_circ_check(struct circ_stack *rs, val obj)
+{
+  for (; rs; rs = rs->up) {
+    if (rs->obj == obj)
+      return 0;
+  }
+
+  return 1;
+}
+
 void open_txr_file(val spec_file, val *txr_lisp_p, val *name, val *stream)
 {
   enum { none, tl, txr } suffix;
diff --git a/parser.h b/parser.h
index 31387cda..e7bc8c6d 100644
--- a/parser.h
+++ b/parser.h
@@ -41,6 +41,11 @@ struct yy_token {
   YYSTYPE yy_lval;
 };
 
+struct circ_stack {
+  struct circ_stack *up;
+  val obj;
+};
+
 struct parser {
   val parser;
   cnum lineno;
@@ -83,6 +88,9 @@ void open_txr_file(val spec_file, val *txr_lisp_p, val *name, val *stream);
 void prime_parser(parser_t *, val name, enum prime_parser);
 void prime_parser_post(parser_t *, enum prime_parser);
 void prime_scanner(scanner_t *, enum prime_parser);
+#ifdef SPACE
+int parser_callgraph_circ_check(struct circ_stack *rs, val obj);
+#endif
 void scrub_scanner(scanner_t *, int yy_char, wchar_t *lexeme);
 int parse_once(val stream, val name, parser_t *parser);
 int parse(parser_t *parser, val name, enum prime_parser);
diff --git a/parser.y b/parser.y
index c5874ed8..8ae40e82 100644
--- a/parser.y
+++ b/parser.y
@@ -1501,17 +1501,30 @@ val rlrec(parser_t *parser, val form, val line)
   return form;
 }
 
-val rlcp_tree(val to, val from)
+static val rlcp_tree_rec(val to, val from, struct circ_stack *up)
 {
   val ret = to;
 
-  for (; consp(to); to = cdr(to)) {
+  while (consp(to)) {
+    val a = car(to);
+    struct circ_stack rlcs = { up, a };
     rlcp(to, from);
-    rlcp_tree(car(to), from);
+    if (!parser_callgraph_circ_check(up, a))
+      break;
+    rlcp_tree_rec(a, from, &rlcs);
+    to = cdr(to);
+    if (!parser_callgraph_circ_check(up, to))
+      break;
   }
   return ret;
 }
 
+
+val rlcp_tree(val to, val from)
+{
+  return rlcp_tree_rec(to, from, 0);
+}
+
 static wchar_t char_from_name(const wchar_t *name)
 {
   static struct {