* bug#74696: [PATCH 1/1] srfi-1: map!: Re-use cons cells of first argument.
@ 2024-12-04 19:20 Juliana Sims via Bug reports for GUILE, GNU's Ubiquitous Extension Language
2024-12-22 21:45 ` Ludovic Courtès
0 siblings, 1 reply; 3+ messages in thread
From: Juliana Sims via Bug reports for GUILE, GNU's Ubiquitous Extension Language @ 2024-12-04 19:20 UTC (permalink / raw)
To: 74696; +Cc: Juliana Sims
* module/srfi/srfi-1.scm (map!): Re-use cons cells of first argument.
---
Hello,
This patch rewrites map! to update its first argument in-place. I based the
implementation on the description in the Guile manual. Most of the code is
copied from regular map with different argument checking logic. I wasn't
entirely sure of the conventions around scm-error so let me know if that's not
the appropriate key.
Best,
Juli
module/srfi/srfi-1.scm | 58 ++++++++++++++++++++++++++++++++++++++++--
1 file changed, 56 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
--
2.46.0
^ permalink raw reply related [flat|nested] 3+ messages in thread
* bug#74696: [PATCH 1/1] srfi-1: map!: Re-use cons cells of first argument.
2024-12-04 19:20 bug#74696: [PATCH 1/1] srfi-1: map!: Re-use cons cells of first argument Juliana Sims via Bug reports for GUILE, GNU's Ubiquitous Extension Language
@ 2024-12-22 21:45 ` Ludovic Courtès
2025-01-31 10:20 ` bug#74696: [PATCH] " Juliana Sims via Bug reports for GUILE, GNU's Ubiquitous Extension Language
0 siblings, 1 reply; 3+ messages in thread
From: Ludovic Courtès @ 2024-12-22 21:45 UTC (permalink / raw)
To: Juliana Sims; +Cc: 74696
Hi Juliana,
Juliana Sims <juli@incana.org> skribis:
> * module/srfi/srfi-1.scm (map!): Re-use cons cells of first argument.
Could you add a couple of tests under ‘test-suite/tests/srfi-1.test’?
Apart from that it looks good to me. Thank you!
Ludo’.
^ permalink raw reply [flat|nested] 3+ messages in thread
* bug#74696: [PATCH] srfi-1: map!: Re-use cons cells of first argument.
2024-12-22 21:45 ` Ludovic Courtès
@ 2025-01-31 10:20 ` Juliana Sims via Bug reports for GUILE, GNU's Ubiquitous Extension Language
0 siblings, 0 replies; 3+ messages in thread
From: Juliana Sims via Bug reports for GUILE, GNU's Ubiquitous Extension Language @ 2025-01-31 10:20 UTC (permalink / raw)
To: 74696; +Cc: ludo, Juliana Sims
* 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
^ permalink raw reply related [flat|nested] 3+ messages in thread
end of thread, other threads:[~2025-01-31 10:20 UTC | newest]
Thread overview: 3+ messages (download: mbox.gz follow: Atom feed
-- links below jump to the message on this page --
2024-12-04 19:20 bug#74696: [PATCH 1/1] srfi-1: map!: Re-use cons cells of first argument Juliana Sims via Bug reports for GUILE, GNU's Ubiquitous Extension Language
2024-12-22 21:45 ` Ludovic Courtès
2025-01-31 10:20 ` bug#74696: [PATCH] " Juliana Sims via Bug reports for GUILE, GNU's Ubiquitous Extension Language
This is a public inbox, see mirroring instructions
for how to clone and mirror all data and code used for this inbox;
as well as URLs for read-only IMAP folder(s) and NNTP newsgroup(s).