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.

libguile.h

@@ -105,6 +105,7 @@ extern "C" {
 #include "libguile/symbols.h"
 #include "libguile/tags.h"
 #include "libguile/throw.h"
+#include "libguile/trees.h"
 #include "libguile/uniform.h"
 #include "libguile/validate.h"
 #include "libguile/values.h"

libguile/Makefile.am

@@ -192,6 +192,7 @@ libguile_la_SOURCES =				\
 	symbols.c				\
 	threads.c				\
 	throw.c					\
+	trees.c					\
 	uniform.c				\
 	values.c				\
 	variable.c				\
@@ -283,6 +284,7 @@ DOT_X_FILES =					\
 	symbols.x				\
 	threads.x				\
 	throw.x					\
+	trees.x					\
 	uniform.x				\
 	values.x				\
 	variable.x				\
@@ -378,6 +380,7 @@ DOT_DOC_FILES = 				\
 	symbols.doc				\
 	threads.doc				\
 	throw.doc				\
+	trees.doc				\
 	uniform.doc				\
 	values.doc				\
 	variable.doc				\
@@ -549,6 +552,7 @@ modinclude_HEADERS =				\
 	tags.h					\
 	threads.h				\
 	throw.h					\
+	trees.h					\
 	validate.h				\
 	uniform.h				\
 	values.h				\

libguile/eval.c

@@ -3422,185 +3422,6 @@ SCM_DEFINE (scm_promise_p, "promise?", 1, 0, 0,
 #undef FUNC_NAME
 
 
-SCM_DEFINE (scm_cons_source, "cons-source", 3, 0, 0, 
-            (SCM xorig, SCM x, SCM y),
-	    "Create and return a new pair whose car and cdr are @var{x} and @var{y}.\n"
-	    "Any source properties associated with @var{xorig} are also associated\n"
-	    "with the new pair.")
-#define FUNC_NAME s_scm_cons_source
-{
-  SCM p, z;
-  z = scm_cons (x, y);
-  /* Copy source properties possibly associated with xorig. */
-  p = scm_whash_lookup (scm_source_whash, xorig);
-  if (scm_is_true (p))
-    scm_whash_insert (scm_source_whash, z, p);
-  return z;
-}
-#undef FUNC_NAME
-
-
-/* The function scm_copy_tree is used to copy an expression tree to allow the
- * memoizer to modify the expression during memoization.  scm_copy_tree
- * creates deep copies of pairs and vectors, but not of any other data types,
- * since only pairs and vectors will be parsed by the memoizer.
- *
- * 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 )
-{
-  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;
-          ASSERT_SYNTAX (!scm_is_eq (hare->obj, tortoise->obj),
-                         s_bad_expression, hare->obj);
-        }
-      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);
-                  ASSERT_SYNTAX (!scm_is_eq (rabbit, turtle),
-                                 s_bad_expression, rabbit);
-                }
-            }
-
-          /* 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;
-        }
-    }
-}
-
-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
-
-
 /* We have three levels of EVAL here:
 
    - scm_i_eval (exp, env)

libguile/eval.h

@@ -138,8 +138,6 @@ SCM_API SCM scm_closure (SCM code, SCM env);
 SCM_API SCM scm_make_promise (SCM thunk);
 SCM_API SCM scm_force (SCM x);
 SCM_API SCM scm_promise_p (SCM x);
-SCM_API SCM scm_cons_source (SCM xorig, SCM x, SCM y);
-SCM_API SCM scm_copy_tree (SCM obj);
 SCM_API SCM scm_i_eval_x (SCM exp, SCM env) /* not internal */;
 SCM_INTERNAL SCM scm_i_eval (SCM exp, SCM env);
 SCM_API SCM scm_primitive_eval (SCM exp);

libguile/init.c

@@ -118,6 +118,7 @@
 #include "libguile/symbols.h"
 #include "libguile/throw.h"
 #include "libguile/arrays.h"
+#include "libguile/trees.h"
 #include "libguile/values.h"
 #include "libguile/variable.h"
 #include "libguile/vectors.h"
@@ -542,6 +543,7 @@ scm_i_init_guile (SCM_STACKITEM *base)
   scm_init_srfi_13 ();
   scm_init_srfi_14 ();
   scm_init_throw ();
+  scm_init_trees ();
   scm_init_version ();
   scm_init_weaks ();
   scm_init_guardians ();

libguile/list.h

@@ -3,7 +3,7 @@
 #ifndef SCM_LIST_H
 #define SCM_LIST_H
 
-/* Copyright (C) 1995,1996,1997,2000,2001,2003,2004,2005,2006,2008
+/* Copyright (C) 1995,1996,1997,2000,2001,2003,2004,2005,2006,2008,2009
  * Free Software Foundation, Inc.
  *
  * This library is free software; you can redistribute it and/or
@@ -67,6 +67,7 @@ SCM_API SCM scm_delv1_x (SCM item, SCM lst);
 SCM_API SCM scm_delete1_x (SCM item, SCM lst);
 SCM_API SCM scm_filter (SCM pred, SCM list);
 SCM_API SCM scm_filter_x (SCM pred, SCM list);
+SCM_API SCM scm_copy_tree (SCM obj);
 
 
 

libguile/srcprop.c

@@ -383,6 +383,24 @@ SCM_DEFINE (scm_set_source_property_x, "set-source-property!", 3, 0, 0,
 #undef FUNC_NAME
 
 
+SCM_DEFINE (scm_cons_source, "cons-source", 3, 0, 0, 
+            (SCM xorig, SCM x, SCM y),
+	    "Create and return a new pair whose car and cdr are @var{x} and @var{y}.\n"
+	    "Any source properties associated with @var{xorig} are also associated\n"
+	    "with the new pair.")
+#define FUNC_NAME s_scm_cons_source
+{
+  SCM p, z;
+  z = scm_cons (x, y);
+  /* Copy source properties possibly associated with xorig. */
+  p = scm_whash_lookup (scm_source_whash, xorig);
+  if (scm_is_true (p))
+    scm_whash_insert (scm_source_whash, z, p);
+  return z;
+}
+#undef FUNC_NAME
+
+
 void
 scm_init_srcprop ()
 {

libguile/srcprop.h

@@ -72,6 +72,7 @@ SCM_API SCM scm_source_property (SCM obj, SCM key);
 SCM_API SCM scm_set_source_property_x (SCM obj, SCM key, SCM datum);
 SCM_API SCM scm_source_properties (SCM obj);
 SCM_API SCM scm_set_source_properties_x (SCM obj, SCM props);
+SCM_API SCM scm_cons_source (SCM xorig, SCM x, SCM y);
 SCM_INTERNAL void scm_init_srcprop (void);
 
 #if SCM_ENABLE_DEPRECATED == 1

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"
+}

libguile/trees.h

@@ -0,0 +1,45 @@
+/* classes: h_files */
+
+#ifndef SCM_TREES_H
+#define SCM_TREES_H
+
+/* Copyright (C) 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
+ */
+
+
+
+#include "libguile/__scm.h"
+
+
+
+SCM_API SCM scm_copy_tree (SCM obj);
+
+
+
+/* Guile internal functions */
+
+SCM_INTERNAL void scm_init_trees (void);
+
+#endif  /* SCM_TREES_H */
+
+/*
+  Local Variables:
+  c-file-style: "gnu"
+  End:
+*/

test-suite/tests/eval.test

@@ -51,7 +51,7 @@
         (equal? bar '(#t . #(#t)))))
 
     (pass-if-exception "circular lists in forms"
-      exception:bad-expression
+      exception:wrong-type-arg
       (let ((foo (list #f)))
         (set-cdr! foo foo)
         (copy-tree foo))))
@@ -157,7 +157,7 @@
   (with-test-prefix "scm_tc7_subr_2o"
 
     ;; prior to guile 1.6.9 and 1.8.1 this called the function with
-    ;; SCM_UNDEFIEND, which in the case of make-vector resulted in
+    ;; SCM_UNDEFINED, which in the case of make-vector resulted in
     ;; wrong-type-arg, instead of the intended wrong-num-args
     (pass-if-exception "0 args" exception:wrong-num-args
       (apply make-vector '()))