mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-04-30 03:40:34 +02:00
These were found with: make GUILE_WARNINGS='-W1 -Wunused-module' * module/ice-9/copy-tree.scm: * module/ice-9/eval-string.scm: * module/ice-9/getopt-long.scm: * module/ice-9/poll.scm: * module/ice-9/popen.scm: * module/ice-9/sandbox.scm: * module/ice-9/threads.scm: * module/sxml/apply-templates.scm: * module/sxml/simple.scm: * module/system/base/types.scm: * module/system/repl/command.scm: * module/system/repl/common.scm: * module/system/repl/coop-server.scm: * module/system/repl/debug.scm: * module/system/repl/error-handling.scm: * module/system/repl/repl.scm: * module/system/repl/server.scm: * module/system/vm/assembler.scm: * module/system/vm/disassembler.scm: * module/system/vm/dwarf.scm: * module/system/vm/elf.scm: * module/system/vm/frame.scm: * module/system/vm/inspect.scm: * module/system/vm/linker.scm: * module/system/vm/program.scm: * module/system/vm/trace.scm: * module/system/vm/trap-state.scm: * module/system/vm/traps.scm: * module/system/xref.scm: * module/texinfo/indexing.scm: * module/texinfo/plain-text.scm: * module/texinfo/reflection.scm: * module/texinfo/string-utils.scm: * module/web/client.scm: * module/web/http.scm: * module/web/request.scm: * module/web/response.scm: Remove imports of unused modules.
86 lines
3 KiB
Scheme
86 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 (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!)))
|