1;;; copy-tree
2;;; Copyright (C) 1995-2010,2018,2020 Free Software Foundation, Inc.
3;;;
4;;; This library is free software: you can redistribute it and/or modify
5;;; it under the terms of the GNU Lesser General Public License as
6;;; published by the Free Software Foundation, either version 3 of the
7;;; 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 program.  If not, see
16;;; <http://www.gnu.org/licenses/>.
17
18;;; Commentary:
19;;;
20;;; Copying pairs and vectors of data, while detecting cycles.
21;;;
22;;; Code:
23
24
25(define-module (ice-9 copy-tree)
26  #:use-module (ice-9 match)
27  #:use-module (srfi srfi-11)
28  #:replace (copy-tree))
29
30;;; copy-tree creates deep copies of pairs and vectors, but not of any
31;;; other data types.
32;;;
33;;; To avoid infinite recursion due to cyclic structures, the
34;;; hare-and-tortoise pattern is used to detect cycles.
35
36(define (make-race obj)
37  (define (make-race advance-tortoise? tortoise-path hare-tail)
38    (define (advance! hare)
39      (let ((tail (list hare)))
40        (set-cdr! hare-tail tail)
41        (set! hare-tail tail))
42      (when (eq? hare (car tortoise-path))
43        (scm-error 'wrong-type-arg "copy-tree"
44                   "Expected non-circular data structure: ~S" (list hare) #f))
45      (when advance-tortoise?
46        (set! tortoise-path (cdr tortoise-path)))
47      (set! advance-tortoise? (not advance-tortoise?)))
48    (define (split!)
49      (make-race advance-tortoise? tortoise-path hare-tail))
50    (values advance! split!))
51  (let ((path (cons obj '())))
52    (make-race #f path path)))
53
54(define (copy-tree obj)
55  "Recursively copy the data tree that is bound to @var{obj}, and return a\n"
56  "the new data structure.  @code{copy-tree} recurses down the\n"
57  "contents of both pairs and vectors (since both cons cells and vector\n"
58  "cells may point to arbitrary objects), and stops recursing when it hits\n"
59  "any other object."
60  (define (trace? x) (or (pair? x) (vector? x)))
61  (define (visit obj advance! split!)
62    (define (visit-head obj)
63      (if (trace? obj)
64          (let-values (((advance! split!) (split!)))
65            (advance! obj)
66            (visit obj advance! split!))
67          obj))
68    (define (visit-tail obj)
69      (when (trace? obj) (advance! obj))
70      (visit obj advance! split!))
71    (cond
72     ((pair? obj)
73      (let* ((head (visit-head (car obj)))
74             (tail (visit-tail (cdr obj))))
75        (cons head tail)))
76     ((vector? obj)
77      (let* ((len (vector-length obj))
78             (v (make-vector len)))
79        (let lp ((i 0))
80          (when (< i len)
81            (vector-set! v i (visit-head (vector-ref obj i)))
82            (lp (1+ i))))
83        v))
84     (else
85      obj)))
86  (let-values (((advance! split!) (make-race obj)))
87    (visit obj advance! split!)))
88