libguile/trees.c

   1 /* Copyright (C) 1995,1996,1997,1998,1999,2000,2001,2002,2003,2004,2005,2006,2007,2008,2009
   2  * Free Software Foundation, Inc.
   3  *
   4  * This library is free software; you can redistribute it and/or
   5  * modify it under the terms of the GNU Lesser General Public License
   6  * as published by the Free Software Foundation; either version 3 of
   7  * the License, or (at your option) any later version.
   8  *
   9  * This library is distributed in the hope that it will be useful, but
  10  * WITHOUT ANY WARRANTY; without even the implied warranty of
  11  * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  12  * Lesser General Public License for more details.
  13  *
  14  * You should have received a copy of the GNU Lesser General Public
  15  * License along with this library; if not, write to the Free Software
  16  * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
  17  * 02110-1301 USA
  18  */
  19
  20
  21 \f
  22 #ifdef HAVE_CONFIG_H
  23 # include <config.h>
  24 #endif
  25
  26 #include "libguile/_scm.h"
  27 #include "libguile/eq.h"
  28 #include "libguile/lang.h"
  29
  30 #include "libguile/validate.h"
  31 #include "libguile/list.h"
  32 #include "libguile/vectors.h"
  33 #include "libguile/srcprop.h"
  34 #include "libguile/trees.h"
  35
  36 #include <stdarg.h>
  37
  38
  39 /* scm_copy_tree creates deep copies of pairs and vectors, but not of any other
  40  * data types.
  41  *
  42  * To avoid infinite recursion due to cyclic structures, the hare-and-tortoise
  43  * pattern is used to detect cycles.  In fact, the pattern is used in two
  44  * dimensions, vertical (indicated in the code by the variable names 'hare'
  45  * and 'tortoise') and horizontal ('rabbit' and 'turtle').  In both
  46  * dimensions, the hare/rabbit will take two steps when the tortoise/turtle
  47  * takes one.
  48  *
  49  * The vertical dimension corresponds to recursive calls to function
  50  * copy_tree: This happens when descending into vector elements, into cars of
  51  * lists and into the cdr of an improper list.  In this dimension, the
  52  * tortoise follows the hare by using the processor stack: Every stack frame
  53  * will hold an instance of struct t_trace.  These instances are connected in
  54  * a way that represents the trace of the hare, which thus can be followed by
  55  * the tortoise.  The tortoise will always point to struct t_trace instances
  56  * relating to SCM objects that have already been copied.  Thus, a cycle is
  57  * detected if the tortoise and the hare point to the same object,
  58  *
  59  * The horizontal dimension is within one execution of copy_tree, when the
  60  * function cdr's along the pairs of a list.  This is the standard
  61  * hare-and-tortoise implementation, found several times in guile.  */
  62
  63 struct t_trace {
  64   struct t_trace *trace; /* These pointers form a trace along the stack. */
  65   SCM obj;               /* The object handled at the respective stack frame.*/
  66 };
  67
  68 static SCM
  69 copy_tree (struct t_trace *const hare,
  70            struct t_trace *tortoise,
  71            unsigned int tortoise_delay);
  72
  73 SCM_DEFINE (scm_copy_tree, "copy-tree", 1, 0, 0,
  74             (SCM obj),
  75             "Recursively copy the data tree that is bound to @var{obj}, and return a\n"
  76             "the new data structure.  @code{copy-tree} recurses down the\n"
  77             "contents of both pairs and vectors (since both cons cells and vector\n"
  78             "cells may point to arbitrary objects), and stops recursing when it hits\n"
  79             "any other object.")
  80 #define FUNC_NAME s_scm_copy_tree
  81 {
  82   /* Prepare the trace along the stack.  */
  83   struct t_trace trace;
  84   trace.obj = obj;
  85
  86   /* In function copy_tree, if the tortoise makes its step, it will do this
  87    * before the hare has the chance to move.  Thus, we have to make sure that
  88    * the very first step of the tortoise will not happen after the hare has
  89    * really made two steps.  This is achieved by passing '2' as the initial
  90    * delay for the tortoise.  NOTE: Since cycles are unlikely, giving the hare
  91    * a bigger advantage may improve performance slightly.  */
  92   return copy_tree (&trace, &trace, 2);
  93 }
  94 #undef FUNC_NAME
  95
  96
  97 static SCM
  98 copy_tree (struct t_trace *const hare,
  99            struct t_trace *tortoise,
 100            unsigned int tortoise_delay)
 101 #define FUNC_NAME s_scm_copy_tree
 102 {
 103   if (!scm_is_pair (hare->obj) && !scm_is_simple_vector (hare->obj))
 104     {
 105       return hare->obj;
 106     }
 107   else
 108     {
 109       /* Prepare the trace along the stack.  */
 110       struct t_trace new_hare;
 111       hare->trace = &new_hare;
 112
 113       /* The tortoise will make its step after the delay has elapsed.  Note
 114        * that in contrast to the typical hare-and-tortoise pattern, the step
 115        * of the tortoise happens before the hare takes its steps.  This is, in
 116        * principle, no problem, except for the start of the algorithm: Then,
 117        * it has to be made sure that the hare actually gets its advantage of
 118        * two steps.  */
 119       if (tortoise_delay == 0)
 120         {
 121           tortoise_delay = 1;
 122           tortoise = tortoise->trace;
 123           if (SCM_UNLIKELY (scm_is_eq (hare->obj, tortoise->obj)))
 124             scm_wrong_type_arg_msg (FUNC_NAME, 1, hare->obj,
 125                                     "expected non-circular data structure");
 126         }
 127       else
 128         {
 129           --tortoise_delay;
 130         }
 131
 132       if (scm_is_simple_vector (hare->obj))
 133         {
 134           size_t length = SCM_SIMPLE_VECTOR_LENGTH (hare->obj);
 135           SCM new_vector = scm_c_make_vector (length, SCM_UNSPECIFIED);
 136
 137           /* Each vector element is copied by recursing into copy_tree, having
 138            * the tortoise follow the hare into the depths of the stack.  */
 139           unsigned long int i;
 140           for (i = 0; i < length; ++i)
 141             {
 142               SCM new_element;
 143               new_hare.obj = SCM_SIMPLE_VECTOR_REF (hare->obj, i);
 144               new_element = copy_tree (&new_hare, tortoise, tortoise_delay);
 145               SCM_SIMPLE_VECTOR_SET (new_vector, i, new_element);
 146             }
 147
 148           return new_vector;
 149         }
 150       else /* scm_is_pair (hare->obj) */
 151         {
 152           SCM result;
 153           SCM tail;
 154
 155           SCM rabbit = hare->obj;
 156           SCM turtle = hare->obj;
 157
 158           SCM copy;
 159
 160           /* The first pair of the list is treated specially, in order to
 161            * preserve a potential source code position.  */
 162           result = tail = scm_cons_source (rabbit, SCM_EOL, SCM_EOL);
 163           new_hare.obj = SCM_CAR (rabbit);
 164           copy = copy_tree (&new_hare, tortoise, tortoise_delay);
 165           SCM_SETCAR (tail, copy);
 166
 167           /* The remaining pairs of the list are copied by, horizontally,
 168            * having the turtle follow the rabbit, and, vertically, having the
 169            * tortoise follow the hare into the depths of the stack.  */
 170           rabbit = SCM_CDR (rabbit);
 171           while (scm_is_pair (rabbit))
 172             {
 173               new_hare.obj = SCM_CAR (rabbit);
 174               copy = copy_tree (&new_hare, tortoise, tortoise_delay);
 175               SCM_SETCDR (tail, scm_cons (copy, SCM_UNDEFINED));
 176               tail = SCM_CDR (tail);
 177
 178               rabbit = SCM_CDR (rabbit);
 179               if (scm_is_pair (rabbit))
 180                 {
 181                   new_hare.obj = SCM_CAR (rabbit);
 182                   copy = copy_tree (&new_hare, tortoise, tortoise_delay);
 183                   SCM_SETCDR (tail, scm_cons (copy, SCM_UNDEFINED));
 184                   tail = SCM_CDR (tail);
 185                   rabbit = SCM_CDR (rabbit);
 186
 187                   turtle = SCM_CDR (turtle);
 188                   if (SCM_UNLIKELY (scm_is_eq (rabbit, turtle)))
 189                     scm_wrong_type_arg_msg (FUNC_NAME, 1, rabbit,
 190                                             "expected non-circular data structure");
 191                 }
 192             }
 193
 194           /* We have to recurse into copy_tree again for the last cdr, in
 195            * order to handle the situation that it holds a vector.  */
 196           new_hare.obj = rabbit;
 197           copy = copy_tree (&new_hare, tortoise, tortoise_delay);
 198           SCM_SETCDR (tail, copy);
 199
 200           return result;
 201         }
 202     }
 203 }
 204 #undef FUNC_NAME
 205
 206 \f
 207 void
 208 scm_init_trees ()
 209 {
 210 #include "libguile/trees.x"
 211 }