* 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
