diff options
Diffstat (limited to 'module')
-rw-r--r-- | module/Makefile.am | 1 | ||||
-rw-r--r-- | module/ice-9/copy-tree.scm | 87 | ||||
-rw-r--r-- | module/ice-9/deprecated.scm | 12 | ||||
-rw-r--r-- | module/oop/goops/save.scm | 13 | ||||
-rw-r--r-- | module/system/repl/common.scm | 1 | ||||
-rw-r--r-- | module/web/client.scm | 1 |
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) |