summaryrefslogtreecommitdiff
path: root/module
diff options
context:
space:
mode:
Diffstat (limited to 'module')
-rw-r--r--module/Makefile.am1
-rw-r--r--module/ice-9/copy-tree.scm87
-rw-r--r--module/ice-9/deprecated.scm12
-rw-r--r--module/oop/goops/save.scm13
-rw-r--r--module/system/repl/common.scm1
-rw-r--r--module/web/client.scm1
6 files changed, 107 insertions, 8 deletions
diff --git a/module/Makefile.am b/module/Makefile.am
index d214987b3..45113b542 100644
--- a/module/Makefile.am
+++ b/module/Makefile.am
@@ -104,6 +104,7 @@ SOURCES = \
ice-9/command-line.scm \
ice-9/common-list.scm \
ice-9/control.scm \
+ ice-9/copy-tree.scm \
ice-9/curried-definitions.scm \
ice-9/deprecated.scm \
ice-9/documentation.scm \
diff --git a/module/ice-9/copy-tree.scm b/module/ice-9/copy-tree.scm
new file mode 100644
index 000000000..e1d91ad9e
--- /dev/null
+++ b/module/ice-9/copy-tree.scm
@@ -0,0 +1,87 @@
+;;; 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!)))
diff --git a/module/ice-9/deprecated.scm b/module/ice-9/deprecated.scm
index 85be82e95..4c4a484ca 100644
--- a/module/ice-9/deprecated.scm
+++ b/module/ice-9/deprecated.scm
@@ -1,4 +1,4 @@
-;;;; Copyright (C) 2003, 2005, 2006, 2009, 2010, 2011, 2012, 2013 Free Software Foundation, Inc.
+;;;; Copyright (C) 2017, 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
@@ -15,7 +15,9 @@
;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
;;;;
-(define-module (ice-9 deprecated))
+(define-module (ice-9 deprecated)
+ #:use-module (ice-9 copy-tree)
+ #:export ((copy-tree* . copy-tree)))
(define-syntax-rule (define-deprecated name message exp)
(begin
@@ -31,3 +33,9 @@
"allow-legacy-syntax-objects? is deprecated and has no effect. Guile
3.0 has no legacy syntax objects."
%allow-legacy-syntax-objects?)
+
+(define (copy-tree* x)
+ (issue-deprecation-warning
+ "copy-tree in the default environment is deprecated. Import it
+from (ice-9 copy-tree) instead.")
+ (copy-tree x))
diff --git a/module/oop/goops/save.scm b/module/oop/goops/save.scm
index 20c3b0541..5f0d6457e 100644
--- a/module/oop/goops/save.scm
+++ b/module/oop/goops/save.scm
@@ -1,6 +1,6 @@
;;; installed-scm-file
-;;;; Copyright (C) 2000,2001,2002, 2006, 2009, 2010, 2013, 2015 Free Software Foundation, Inc.
+;;;; Copyright (C) 2000,2001,2002, 2006, 2009, 2010, 2013, 2015, 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
@@ -19,11 +19,12 @@
(define-module (oop goops save)
- :use-module (oop goops internal)
- :export (make-unbound save-objects load-objects restore
- enumerate! enumerate-component!
- write-readably write-component write-component-procedure
- literal? readable make-readable))
+ #:use-module (ice-9 copy-tree)
+ #:use-module (oop goops internal)
+ #:export (make-unbound save-objects load-objects restore
+ enumerate! enumerate-component!
+ write-readably write-component write-component-procedure
+ literal? readable make-readable))
(define (make-unbound)
*unbound*)
diff --git a/module/system/repl/common.scm b/module/system/repl/common.scm
index d487da8cd..155bc7acb 100644
--- a/module/system/repl/common.scm
+++ b/module/system/repl/common.scm
@@ -26,6 +26,7 @@
#:use-module (system vm program)
#:use-module (system vm loader)
#:use-module (ice-9 control)
+ #:use-module (ice-9 copy-tree)
#:use-module (ice-9 history)
#:export (<repl> make-repl repl-language repl-options
repl-tm-stats repl-gc-stats repl-debug
diff --git a/module/web/client.scm b/module/web/client.scm
index 3d32cadc7..540dcdd44 100644
--- a/module/web/client.scm
+++ b/module/web/client.scm
@@ -34,6 +34,7 @@
(define-module (web client)
#:use-module (rnrs bytevectors)
#:use-module (ice-9 binary-ports)
+ #:use-module (ice-9 copy-tree)
#:use-module (ice-9 iconv)
#:use-module (ice-9 rdelim)
#:use-module (web request)