GNU bug report logs - #74696
[PATCH 1/1] srfi-1: map!: Re-use cons cells of first argument.

Previous Next

Full log

View this message in rfc822 format

From: Juliana Sims <juli <at> incana.org>
To: 74696 <at> debbugs.gnu.org
Cc: ludo <at> gnu.org, Juliana Sims <juli <at> incana.org>
Subject: bug#74696: [PATCH] srfi-1: map!: Re-use cons cells of first argument.
Date: Fri, 31 Jan 2025 05:20:46 -0500

* module/srfi/srfi-1.scm (map!): Re-use cons cells of first argument.
* test-suite/tests/srfi-1.test: Test map!.
---

Hi Ludo,

Thanks for your patience in getting this together.  I've added some tests for
map!.  Let me know if you think there are more cases that should be tested.

As a sidenote, it looks like regular map isn't directly tested.  Maybe if I get
time I'll copy these tests for it :)

Thanks,
Juli

 module/srfi/srfi-1.scm       | 58 ++++++++++++++++++++++++++++++++++--
 test-suite/tests/srfi-1.test | 38 +++++++++++++++++++++++
 2 files changed, 94 insertions(+), 2 deletions(-)

diff --git a/module/srfi/srfi-1.scm b/module/srfi/srfi-1.scm
index b46f7be5f..c0018b188 100644
--- a/module/srfi/srfi-1.scm
+++ b/module/srfi/srfi-1.scm
@@ -791,8 +791,62 @@ has just one element then that's the return value."
 (define (append-map! f clist1 . rest)
   (concatenate! (apply map f clist1 rest)))
 
-;; OPTIMIZE-ME: Re-use cons cells of list1
-(define map! map)
+(define map!
+  (case-lambda
+    ((f lst)
+     (check-arg procedure? f map!)
+     (check-arg list? lst map!)
+     (let map1 ((l lst))
+       (if (pair? l)
+           (begin
+             (set-car! l (f (car l)))
+             (map1 (cdr l)))
+           lst)))
+
+    ((f lst1 lst2)
+     (check-arg procedure? f map!)
+     (check-arg list? lst1 map!)
+     (let* ((len1 (length lst1))
+            (len2 (length+ lst2))
+            ;; Ensure either that all lists after the first are circular or that
+            ;; they are at least as long as the first
+            (len (and (or (not len2)
+                          (<= len1 len2))
+                      len1)))
+       (unless len
+         (scm-error 'misc-error "map!"
+                    "All argument lists must be at least as long as first: ~S"
+                    (list (list lst1 lst2)) #f))
+       (let map2 ((l1 lst1) (l2 lst2) (len len))
+         (if (zero? len)
+             lst1
+             (begin
+               (set-car! l1 (f (car l1) (car l2)))
+               (map2 (cdr l1) (cdr l2) (1- len)))))))
+
+    ((f lst1 . rest)
+     (check-arg procedure? f map!)
+     (check-arg list? lst1 map!)
+     ;; Ensure either that all lists after the first are circular or that
+     ;; they are at least as long as the first
+     (let ((len (fold (lambda (ls len)
+                        (let ((ls-len (length+ ls)))
+                          (and len
+                               (or (not ls-len)
+                                   (<= len ls-len))
+                               len)))
+                      (length lst1)
+                      rest)))
+       (unless len
+         (scm-error 'misc-error "map!"
+                    "All argument lists must be at least as long as first: ~S"
+                    (list (cons lst1 rest)) #f))
+       (let mapn ((l1 lst1) (rest rest) (len len))
+         (if (zero? len)
+             lst1
+             (begin
+               (set-car! l1 (apply f (car l1) (map car rest)))
+               (mapn (cdr l1) (map cdr rest) (1- len)))))))))
 
 (define (filter-map proc list1 . rest)
   "Apply PROC to the elements of LIST1... and return a list of the
diff --git a/test-suite/tests/srfi-1.test b/test-suite/tests/srfi-1.test
index 558934df4..4263b5ac1 100644
--- a/test-suite/tests/srfi-1.test
+++ b/test-suite/tests/srfi-1.test
@@ -1921,6 +1921,44 @@
 		  '(1) '(2))
       good)))
 
+;;
+;; map!
+;;
+
+(with-test-prefix "map!"
+
+  (pass-if-exception "no args" exception:wrong-num-args
+    (map!))
+
+  (pass-if-exception "one arg" exception:wrong-num-args
+    (map! (lambda _ #t)))
+
+  (pass-if-exception "non-procedure first arg" exception:wrong-type-arg
+    (map! 'not-a-proc '(1 2 3)))
+
+  (pass-if-exception "non-list second arg" exception:wrong-type-arg
+    (map! identity '(1 2 3)))
+
+  (pass-if "1+ (1 2 3)"
+    (let ((lst '(1 2 3)))
+      (and (eq? lst (map! 1+ lst))
+           (equal? '(2 3 4) lst))))
+
+  (pass-if "+ (1 2 3) (3 2 1)"
+    (let ((l1 '(1 2 3))
+          (l2 '(3 2 1)))
+      (and (eq? l1 (map! + l1 l2))
+           (not (eq? l1 l2))
+           (equal? '(4 4 4) l1))))
+
+  (pass-if "+ (1 1 1) (2 2 2) (3 3 3)"
+    (let ((l1 '(1 1 1))
+          (l2 '(2 2 2))
+          (l3 '(3 3 3)))
+      (and (eq? l1 (map! + l1 l2 l3))
+           (not (eq? l1 l2 l3))
+           (equal? '(6 6 6) l1)))))
+
 ;;
 ;; member
 ;;
-- 
2.48.1

Previous Next

GNU bug tracking system
Copyright (C) 1999 Darren O. Benham, 1997,2003 nCipher Corporation Ltd, 1994-97 Ian Jackson.