mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-04-30 03:40:34 +02:00
e9c5a1719b
* doc/ref/api-data.texi (List Constructors): * doc/ref/api-utility.texi (Copying): Update docs to mention module. * libguile.h: Remove trees.h inclusion. * libguile/Makefile.am (libguile_@GUILE_EFFECTIVE_VERSION@_la_SOURCES): (DOT_X_FILES, DOT_DOC_FILES, modinclude_HEADERS): Remove trees.c, trees.h, and related files. * libguile/init.c (scm_i_init_guile): Remove trees.h and the scm_init_trees call. * libguile/trees.c: * libguile/trees.h: Remove. * module/Makefile.am (SOURCES): Add ice-9/copy-tree.scm. * module/ice-9/copy-tree.scm: New file. * module/ice-9/deprecated.scm (copy-tree*): Export as copy-tree, proxying to (ice-9 copy-tree). * module/system/repl/common.scm: * module/web/client.scm: * test-suite/tests/elisp.test: * test-suite/tests/srfi-1.test: * module/oop/goops/save.scm: Use (ice-9 copy-tree). * test-suite/Makefile.am (SCM_TESTS): Add copy-tree.test. * test-suite/tests/copy-tree.test: New file; test pulled from eval.test. * libguile/deprecated.h: * libguile/deprecated.c (scm_copy_tree): Deprecate.
87 lines
3 KiB
Scheme
87 lines
3 KiB
Scheme
;;; copy-tree
|
|
;;; Copyright (C) 1995-2010,2018,2020 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 program. If not, see
|
|
;;; <http://www.gnu.org/licenses/>.
|
|
|
|
;;; Commentary:
|
|
;;;
|
|
;;; Copying pairs and vectors of data, while detecting cycles.
|
|
;;;
|
|
;;; Code:
|
|
|
|
|
|
(define-module (ice-9 copy-tree)
|
|
#:use-module (ice-9 match)
|
|
#:use-module (srfi srfi-11)
|
|
#:replace (copy-tree))
|
|
|
|
;;; 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.
|
|
|
|
(define (make-race obj)
|
|
(define (make-race advance-tortoise? tortoise-path hare-tail)
|
|
(define (advance! hare)
|
|
(let ((tail (list hare)))
|
|
(set-cdr! hare-tail tail)
|
|
(set! hare-tail tail))
|
|
(when (eq? hare (car tortoise-path))
|
|
(scm-error 'wrong-type-arg "copy-tree"
|
|
"Expected non-circular data structure: ~S" (list hare) #f))
|
|
(when advance-tortoise?
|
|
(set! tortoise-path (cdr tortoise-path)))
|
|
(set! advance-tortoise? (not advance-tortoise?)))
|
|
(define (split!)
|
|
(make-race advance-tortoise? tortoise-path hare-tail))
|
|
(values advance! split!))
|
|
(let ((path (cons obj '())))
|
|
(make-race #f path path)))
|
|
|
|
(define (copy-tree 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 (trace? x) (or (pair? x) (vector? x)))
|
|
(define (visit obj advance! split!)
|
|
(define (visit-head obj)
|
|
(if (trace? obj)
|
|
(let-values (((advance! split!) (split!)))
|
|
(advance! obj)
|
|
(visit obj advance! split!))
|
|
obj))
|
|
(define (visit-tail obj)
|
|
(when (trace? obj) (advance! obj))
|
|
(visit obj advance! split!))
|
|
(cond
|
|
((pair? obj)
|
|
(let* ((head (visit-head (car obj)))
|
|
(tail (visit-tail (cdr obj))))
|
|
(cons head tail)))
|
|
((vector? obj)
|
|
(let* ((len (vector-length obj))
|
|
(v (make-vector len)))
|
|
(let lp ((i 0))
|
|
(when (< i len)
|
|
(vector-set! v i (visit-head (vector-ref obj i)))
|
|
(lp (1+ i))))
|
|
v))
|
|
(else
|
|
obj)))
|
|
(let-values (((advance! split!) (make-race obj)))
|
|
(visit obj advance! split!)))
|