mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-04-30 11:50:28 +02:00
Code Activity

SRFI-1: Use the built-in optional argument support.

Browse source 
* module/srfi/srfi-1.scm (iota, unfold, unfold-right, alist-delete,
  alist-delete!): Use `define*' and optional arguments instead of rest
  arguments.
This commit is contained in:
Ludovic Courtès 2009-12-11 15:20:12 +01:00
parent dd902692fd
commit 2cf7ff2e79
1 changed files with 23 additions and 40 deletions
Download patch file Download diff file Expand all files Collapse all files

63
module/srfi/srfi-1.scm
View file

@ -1,6 +1,6 @@
;;; srfi-1.scm --- List Library ;;; srfi-1.scm --- List Library
;; Copyright (C) 2001, 2002, 2003, 2004, 2005, 2006 Free Software Foundation, Inc. ;; Copyright (C) 2001, 2002, 2003, 2004, 2005, 2006, 2009 Free Software Foundation, Inc.
;; ;;
;; This library is free software; you can redistribute it and/or ;; This library is free software; you can redistribute it and/or
;; modify it under the terms of the GNU Lesser General Public ;; modify it under the terms of the GNU Lesser General Public
@ -242,14 +242,12 @@
(set-cdr! (last-pair elts) elts) (set-cdr! (last-pair elts) elts)
elts) elts)
(define (iota count . rest) (define* (iota count #:optional (start 0) (step 1))
(check-arg-type non-negative-integer? count "iota") (check-arg-type non-negative-integer? count "iota")
(let ((start (if (pair? rest) (car rest) 0)) (let lp ((n 0) (acc '()))
(step (if (and (pair? rest) (pair? (cdr rest))) (cadr rest) 1))) (if (= n count)
(let lp ((n 0) (acc '()))
(if (= n count)
(reverse! acc) (reverse! acc)
(lp (+ n 1) (cons (+ start (* n step)) acc)))))) (lp (+ n 1) (cons (+ start (* n step)) acc)))))
;;; Predicates ;;; Predicates
@ -381,31 +379,18 @@
knil knil
(apply kons (append! lists (list (f (map1 cdr lists))))))))) (apply kons (append! lists (list (f (map1 cdr lists)))))))))
(define (unfold p f g seed . rest) (define* (unfold p f g seed #:optional (tail-gen (lambda (x) '())))
(let ((tail-gen (if (pair? rest) (let uf ((seed seed))
(if (pair? (cdr rest)) (if (p seed)
(scm-error 'wrong-number-of-args (tail-gen seed)
"unfold" "too many arguments" '() '()) (cons (f seed)
(car rest)) (uf (g seed))))))
(lambda (x) '()))))
(let uf ((seed seed))
(if (p seed)
(tail-gen seed)
(cons (f seed)
(uf (g seed)))))))
(define (unfold-right p f g seed . rest) (define* (unfold-right p f g seed #:optional (tail '()))
(let ((tail (if (pair? rest) (let uf ((seed seed) (lis tail))
(if (pair? (cdr rest)) (if (p seed)
(scm-error 'wrong-number-of-args lis
"unfold-right" "too many arguments" '() (uf (g seed) (cons (f seed) lis)))))
'())
(car rest))
'())))
(let uf ((seed seed) (lis tail))
(if (p seed)
lis
(uf (g seed) (cons (f seed) lis))))))
;; Internal helper procedure. Map `f' over the single list `ls'. ;; Internal helper procedure. Map `f' over the single list `ls'.
@ -482,18 +467,16 @@
(define alist-cons acons) (define alist-cons acons)
(define (alist-delete key alist . rest) (define* (alist-delete key alist #:optional (k= equal?))
(let ((k= (if (pair? rest) (car rest) equal?))) (let lp ((a alist) (rl '()))
(let lp ((a alist) (rl '())) (if (null? a)
(if (null? a)
(reverse! rl) (reverse! rl)
(if (k= key (caar a)) (if (k= key (caar a))
(lp (cdr a) rl) (lp (cdr a) rl)
(lp (cdr a) (cons (car a) rl))))))) (lp (cdr a) (cons (car a) rl))))))
(define (alist-delete! key alist . rest) (define* (alist-delete! key alist #:optional (k= equal?))
(let ((k= (if (pair? rest) (car rest) equal?))) (alist-delete key alist k=)) ; XXX:optimize
(alist-delete key alist k=))) ; XXX:optimize
;;; Set operations on lists ;;; Set operations on lists