123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211 |
- #ifdef HAVE_CONFIG_H
- # include <config.h>
- #endif
- #include "libguile/_scm.h"
- #include "libguile/eq.h"
- #include "libguile/validate.h"
- #include "libguile/list.h"
- #include "libguile/vectors.h"
- #include "libguile/srcprop.h"
- #include "libguile/trees.h"
- #include <stdarg.h>
- struct t_trace {
- struct t_trace *trace;
- SCM obj;
- };
- 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
- {
-
- struct t_trace trace;
- trace.obj = obj;
-
- 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_vector (hare->obj))
- {
- return hare->obj;
- }
- else
- {
-
- struct t_trace new_hare;
- hare->trace = &new_hare;
-
- 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_vector (hare->obj))
- {
- size_t length = SCM_SIMPLE_VECTOR_LENGTH (hare->obj);
- SCM new_vector = scm_c_make_vector (length, SCM_UNSPECIFIED);
-
- 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 result;
- SCM tail;
- SCM rabbit = hare->obj;
- SCM turtle = hare->obj;
- SCM copy;
-
- 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);
-
- 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");
- }
- }
-
- 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"
- }
|