diff --git a/libguile.h b/libguile.h index 3b2f6958e..2b764d1cd 100644 --- a/libguile.h +++ b/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" diff --git a/libguile/Makefile.am b/libguile/Makefile.am index 30121fc58..0e616f23f 100644 --- a/libguile/Makefile.am +++ b/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 \ diff --git a/libguile/eval.c b/libguile/eval.c index 8f2f5d02f..30da3424b 100644 --- a/libguile/eval.c +++ b/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) diff --git a/libguile/eval.h b/libguile/eval.h index 522f639d8..0e990cf26 100644 --- a/libguile/eval.h +++ b/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); diff --git a/libguile/init.c b/libguile/init.c index 82c73f7c4..d6d9e9057 100644 --- a/libguile/init.c +++ b/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 (); diff --git a/libguile/list.h b/libguile/list.h index 427dcb84d..238926e21 100644 --- a/libguile/list.h +++ b/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); diff --git a/libguile/srcprop.c b/libguile/srcprop.c index 77430bd82..b2e4ff322 100644 --- a/libguile/srcprop.c +++ b/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 () { diff --git a/libguile/srcprop.h b/libguile/srcprop.h index ca8818ac4..a0f4772b5 100644 --- a/libguile/srcprop.h +++ b/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 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 +#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 + + +/* 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" +} diff --git a/libguile/trees.h b/libguile/trees.h new file mode 100644 index 000000000..70d32ad7d --- /dev/null +++ b/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: +*/ diff --git a/test-suite/tests/eval.test b/test-suite/tests/eval.test index a428a0778..074b9b136 100644 --- a/test-suite/tests/eval.test +++ b/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 '()))