From a68ffccdccc9023c1beb14cae2a8d2695e517da0 Mon Sep 17 00:00:00 2001 From: Leah Neukirchen Date: Fri, 16 Dec 2022 00:09:39 +0100 Subject: add dup --- mew.scm | 18 +++++++++++++++++- mew.svnwiki | 6 ++++++ tests/test.mew | 10 ++++++++++ 3 files changed, 33 insertions(+), 1 deletion(-) diff --git a/mew.scm b/mew.scm index 259f51c..8635195 100644 --- a/mew.scm +++ b/mew.scm @@ -3,7 +3,7 @@ act accumulate andloc app at boolean comp cross-product - dec def del-at div + dec def del-at div dup empty? eof esc fail fin final for fun* gconcatenate gen generator-xfold generic-for-each genumerate get @@ -395,6 +395,22 @@ ((procedure? o) (generator-count (op #t) o)) (#t (error "no len defined")))) + (define dup + (case-lambda + ((o) (dup o #t)) + ((o depth) + (if (or (eq? depth #t) (positive? depth)) + (let ((sub-depth (or (eq? depth #t) (- depth 1)))) + (cond ((list? o) (map (lambda (oo) (dup oo sub-depth)) o)) + ((vector? o) (vector-map (lambda (oo) (dup oo sub-depth)) o)) + ((hash-table? o) + (alist->hash-table (dup (hash-table->alist o) sub-depth) + (hash-table-equivalence-function o) + (hash-table-hash-function o))) + ((string? o) (string-copy o)) + (else o))) + o)))) + (define (generic-for-each obj) (cond ((list? obj) for-each) ((vector? obj) vector-for-each) diff --git a/mew.svnwiki b/mew.svnwiki index db141f4..1b8c0ae 100644 --- a/mew.svnwiki +++ b/mew.svnwiki @@ -380,6 +380,12 @@ Test if {{}} is an empty list/string/vector/hash-table. Return the length of the list/vector/string/hash-table/generator {{}}. +(dup []) + +Return a duplicate of the nested datastructure {{}}, consisting +of lists, vectors, hash-tables and strings. Create copies of values +up to a level of {{}}, or infinitely by default. + (for ( ) ...) (for (( . ) ) ...) diff --git a/tests/test.mew b/tests/test.mew index a775928..cbcf2ff 100644 --- a/tests/test.mew +++ b/tests/test.mew @@ -377,6 +377,16 @@ (test-error (len #t))) ; for +(test-group "dup" + (let* ((x (list (list "foo") "bar")) + (y1 (dup x)) + (y2 (dup x 1)) + (y3 (dup x 2))) + (test #f (eq? (car x) (car y1))) + (test #t (eq? (car x) (car y2))) + (test #f (eq? (car x) (car y3))) + (test #t (eq? (caar x) (caar y3))))) + (test-group "eof" (test-assert (eof-object? (eof)))) -- cgit 1.4.1