mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-06-11 22:31:12 +02:00
Code Activity

* srfi-1.scm (check-arg-type, non-negative-integer?): a couple of new

Browse source 
internal definitions.
	(list-tabulate, iota): check for bad arguments that otherwise
	give weird output.
	(filter): check for proper list, to avoid infinite recursion on
	a circular list.
This commit is contained in:
Gary Houston 2001-08-05 10:12:37 +00:00
parent 848458d990
commit 5753f02f67
2 changed files with 22 additions and 0 deletions
Download patch file Download diff file Expand all files Collapse all files

9
srfi/ChangeLog
View file

@ -1,3 +1,12 @@
2001-08-05 Gary Houston <ghouston@arglist.com>
* srfi-1.scm (check-arg-type, non-negative-integer?): a couple of new
internal definitions.
(list-tabulate, iota): check for bad arguments that otherwise
give weird output.
(filter): check for proper list, to avoid infinite recursion on
a circular list.
2001-08-04 Gary Houston <ghouston@arglist.com> 2001-08-04 Gary Houston <ghouston@arglist.com>
* srfi-1.scm (filter): replaced with a tail-recursive version. * srfi-1.scm (filter): replaced with a tail-recursive version.

13
srfi/srfi-1.scm
View file

@ -254,7 +254,18 @@
(define (xcons d a) (define (xcons d a)
(cons a d)) (cons a d))
;; internal helper, similar to (scsh utilities) check-arg.
(define (check-arg-type pred arg caller)
(if (pred arg)
arg
(scm-error 'wrong-type-arg caller
"Wrong type argument: ~S" (list arg) '())))
;; the srfi spec doesn't seem to forbid inexact integers.
(define (non-negative-integer? x) (and (integer? x) (>= x 0)))
(define (list-tabulate n init-proc) (define (list-tabulate n init-proc)
(check-arg-type non-negative-integer? n "list-tabulate")
(let lp ((n n) (acc '())) (let lp ((n n) (acc '()))
(if (<= n 0) (if (<= n 0)
acc acc
@ -272,6 +283,7 @@
(lp (cdr r) (cdr p))))))) (lp (cdr r) (cdr p)))))))
(define (iota count . rest) (define (iota count . rest)
(check-arg-type non-negative-integer? count "iota")
(let ((start (if (pair? rest) (car rest) 0)) (let ((start (if (pair? rest) (car rest) 0))
(step (if (and (pair? rest) (pair? (cdr rest))) (cadr rest) 1))) (step (if (and (pair? rest) (pair? (cdr rest))) (cadr rest) 1)))
(let lp ((n 0) (acc '())) (let lp ((n 0) (acc '()))
@ -720,6 +732,7 @@
;;; Filtering & partitioning ;;; Filtering & partitioning
(define (filter pred list) (define (filter pred list)
(check-arg-type list? list "caller") ; reject circular lists.
(letrec ((filiter (lambda (pred rest result) (letrec ((filiter (lambda (pred rest result)
(if (null? rest) (if (null? rest)
(reverse! result) (reverse! result)