mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-04-29 19:30:36 +02:00
Code Activity

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

Browse source 
* 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.
This commit is contained in:
Andy Wingo 2009-11-27 23:12:35 +01:00
parent 504864b79f
commit 0f458a3725
11 changed files with 286 additions and 184 deletions
Download patch file Download diff file Expand all files Collapse all files

1
libguile.h
View file

@ -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"

4
libguile/Makefile.am
View file

@ -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 \

179
libguile/eval.c
View file

@ -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)

2
libguile/eval.h
View file

@ -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);

2
libguile/init.c
View file

@ -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 ();

3
libguile/list.h
View file

@ -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);

18
libguile/srcprop.c
View file

@ -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 ()
{

1
libguile/srcprop.h
View file

@ -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

211
libguile/trees.c Normal file
View file

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

45
libguile/trees.h Normal file
View file

@ -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:
*/

4
test-suite/tests/eval.test
View file

@ -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 '()))