factor copy-tree and cons-source out of eval.[ch]

* libguile.h:
* libguile/Makefile.am
* libguile/init.c (scm_i_init_guile): Add trees.[ch] to the build.

* libguile/eval.c:
* libguile/eval.h: Remove scm_copy_tree and scm_cons_source...

* libguile/trees.h:
* libguile/trees.c:
* libguile/srcprop.h:
* libguile/srcprop.c: ... factoring them out here and here,
  respectively.

* test-suite/tests/eval.test ("memoization"): Change expected exception
  for circular data structures, given new copy-tree location.

1 files changed, 211 insertions, 0 deletions

diff --git a/libguile/trees.c b/libguile/trees.c
new file mode 100644
index 000000000..cbfd4277e
--- /dev/null
+++ b/libguile/trees.c
@@ -0,0 +1,211 @@
+/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001,2002,2003,2004,2005,2006,2007,2008,2009
+ * Free Software Foundation, Inc.
+ * 
+ * This library is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU Lesser General Public License
+ * as published by the Free Software Foundation; either version 3 of
+ * the License, or (at your option) any later version.
+ *
+ * This library is distributed in the hope that it will be useful, but
+ * WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+ * Lesser General Public License for more details.
+ *
+ * You should have received a copy of the GNU Lesser General Public
+ * License along with this library; if not, write to the Free Software
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
+ * 02110-1301 USA
+ */
+
+
+
+#ifdef HAVE_CONFIG_H
+# include <config.h>
+#endif
+
+#include "libguile/_scm.h"
+#include "libguile/eq.h"
+#include "libguile/lang.h"
+
+#include "libguile/validate.h"
+#include "libguile/list.h"
+#include "libguile/vectors.h"
+#include "libguile/srcprop.h"
+#include "libguile/trees.h"
+
+#include <stdarg.h>
+
+
+/* scm_copy_tree creates deep copies of pairs and vectors, but not of any other
+ * data types.
+ *
+ * To avoid infinite recursion due to cyclic structures, the hare-and-tortoise
+ * pattern is used to detect cycles.  In fact, the pattern is used in two
+ * dimensions, vertical (indicated in the code by the variable names 'hare'
+ * and 'tortoise') and horizontal ('rabbit' and 'turtle').  In both
+ * dimensions, the hare/rabbit will take two steps when the tortoise/turtle
+ * takes one.
+ *
+ * The vertical dimension corresponds to recursive calls to function
+ * copy_tree: This happens when descending into vector elements, into cars of
+ * lists and into the cdr of an improper list.  In this dimension, the
+ * tortoise follows the hare by using the processor stack: Every stack frame
+ * will hold an instance of struct t_trace.  These instances are connected in
+ * a way that represents the trace of the hare, which thus can be followed by
+ * the tortoise.  The tortoise will always point to struct t_trace instances
+ * relating to SCM objects that have already been copied.  Thus, a cycle is
+ * detected if the tortoise and the hare point to the same object,
+ *
+ * The horizontal dimension is within one execution of copy_tree, when the
+ * function cdr's along the pairs of a list.  This is the standard
+ * hare-and-tortoise implementation, found several times in guile.  */
+
+struct t_trace {
+  struct t_trace *trace; /* These pointers form a trace along the stack. */
+  SCM obj;               /* The object handled at the respective stack frame.*/
+};
+
+static SCM
+copy_tree (struct t_trace *const hare,
+           struct t_trace *tortoise,
+           unsigned int tortoise_delay);
+
+SCM_DEFINE (scm_copy_tree, "copy-tree", 1, 0, 0, 
+            (SCM obj),
+	    "Recursively copy the data tree that is bound to @var{obj}, and return a\n"
+	    "the new data structure.  @code{copy-tree} recurses down the\n"
+	    "contents of both pairs and vectors (since both cons cells and vector\n"
+	    "cells may point to arbitrary objects), and stops recursing when it hits\n"
+	    "any other object.")
+#define FUNC_NAME s_scm_copy_tree
+{
+  /* Prepare the trace along the stack.  */
+  struct t_trace trace;
+  trace.obj = obj;
+
+  /* In function copy_tree, if the tortoise makes its step, it will do this
+   * before the hare has the chance to move.  Thus, we have to make sure that
+   * the very first step of the tortoise will not happen after the hare has
+   * really made two steps.  This is achieved by passing '2' as the initial
+   * delay for the tortoise.  NOTE: Since cycles are unlikely, giving the hare
+   * a bigger advantage may improve performance slightly.  */
+  return copy_tree (&trace, &trace, 2);
+}
+#undef FUNC_NAME
+
+
+static SCM
+copy_tree (struct t_trace *const hare,
+           struct t_trace *tortoise,
+           unsigned int tortoise_delay)
+#define FUNC_NAME s_scm_copy_tree
+{
+  if (!scm_is_pair (hare->obj) && !scm_is_simple_vector (hare->obj))
+    {
+      return hare->obj;
+    }
+  else
+    {
+      /* Prepare the trace along the stack.  */
+      struct t_trace new_hare;
+      hare->trace = &new_hare;
+
+      /* The tortoise will make its step after the delay has elapsed.  Note
+       * that in contrast to the typical hare-and-tortoise pattern, the step
+       * of the tortoise happens before the hare takes its steps.  This is, in
+       * principle, no problem, except for the start of the algorithm: Then,
+       * it has to be made sure that the hare actually gets its advantage of
+       * two steps.  */
+      if (tortoise_delay == 0)
+        {
+          tortoise_delay = 1;
+          tortoise = tortoise->trace;
+          if (SCM_UNLIKELY (scm_is_eq (hare->obj, tortoise->obj)))
+            scm_wrong_type_arg_msg (FUNC_NAME, 1, hare->obj,
+                                    "expected non-circular data structure");
+        }
+      else
+        {
+          --tortoise_delay;
+        }
+
+      if (scm_is_simple_vector (hare->obj))
+        {
+          size_t length = SCM_SIMPLE_VECTOR_LENGTH (hare->obj);
+          SCM new_vector = scm_c_make_vector (length, SCM_UNSPECIFIED);
+
+          /* Each vector element is copied by recursing into copy_tree, having
+           * the tortoise follow the hare into the depths of the stack.  */
+          unsigned long int i;
+          for (i = 0; i < length; ++i)
+            {
+              SCM new_element;
+              new_hare.obj = SCM_SIMPLE_VECTOR_REF (hare->obj, i);
+              new_element = copy_tree (&new_hare, tortoise, tortoise_delay);
+              SCM_SIMPLE_VECTOR_SET (new_vector, i, new_element);
+            }
+
+          return new_vector;
+        }
+      else /* scm_is_pair (hare->obj) */
+        {
+          SCM result;
+          SCM tail;
+
+          SCM rabbit = hare->obj;
+          SCM turtle = hare->obj;
+
+          SCM copy;
+
+          /* The first pair of the list is treated specially, in order to
+           * preserve a potential source code position.  */
+          result = tail = scm_cons_source (rabbit, SCM_EOL, SCM_EOL);
+          new_hare.obj = SCM_CAR (rabbit);
+          copy = copy_tree (&new_hare, tortoise, tortoise_delay);
+          SCM_SETCAR (tail, copy);
+
+          /* The remaining pairs of the list are copied by, horizontally,
+           * having the turtle follow the rabbit, and, vertically, having the
+           * tortoise follow the hare into the depths of the stack.  */
+          rabbit = SCM_CDR (rabbit);
+          while (scm_is_pair (rabbit))
+            {
+              new_hare.obj = SCM_CAR (rabbit);
+              copy = copy_tree (&new_hare, tortoise, tortoise_delay);
+              SCM_SETCDR (tail, scm_cons (copy, SCM_UNDEFINED));
+              tail = SCM_CDR (tail);
+
+              rabbit = SCM_CDR (rabbit);
+              if (scm_is_pair (rabbit))
+                {
+                  new_hare.obj = SCM_CAR (rabbit);
+                  copy = copy_tree (&new_hare, tortoise, tortoise_delay);
+                  SCM_SETCDR (tail, scm_cons (copy, SCM_UNDEFINED));
+                  tail = SCM_CDR (tail);
+                  rabbit = SCM_CDR (rabbit);
+
+                  turtle = SCM_CDR (turtle);
+                  if (SCM_UNLIKELY (scm_is_eq (rabbit, turtle)))
+                    scm_wrong_type_arg_msg (FUNC_NAME, 1, rabbit,
+                                            "expected non-circular data structure");
+                }
+            }
+
+          /* We have to recurse into copy_tree again for the last cdr, in
+           * order to handle the situation that it holds a vector.  */
+          new_hare.obj = rabbit;
+          copy = copy_tree (&new_hare, tortoise, tortoise_delay);
+          SCM_SETCDR (tail, copy);
+
+          return result;
+        }
+    }
+}
+#undef FUNC_NAME
+
+
+void
+scm_init_trees ()
+{
+#include "libguile/trees.x"
+}