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

Use SRFI-1 in `(oop goops util)'.

Browse source
This commit is contained in:
Ludovic Courtès 2008-03-18 09:10:45 +00:00
parent eedcb08a25
commit cc7e01cedd
2 changed files with 11 additions and 40 deletions
Download patch file Download diff file Expand all files Collapse all files

6
oop/ChangeLog
View file

@ -1,3 +1,9 @@
2008-03-18 Ludovic Courtès <ludo@gnu.org>
* goops/util.scm (mapappend): Now an alias for SRFI-1's
`append-map', which is more efficient.
(every, any): Used and re-exported from SRFI-1.
2008-03-12 Ludovic Courtès <ludo@gnu.org> 2008-03-12 Ludovic Courtès <ludo@gnu.org>
* goops/describe.scm (describe): Provide `describe' (symbol), * goops/describe.scm (describe): Provide `describe' (symbol),

45
oop/goops/util.scm
View file

@ -1,4 +1,4 @@
;;;; Copyright (C) 1999, 2000, 2001, 2003, 2006 Free Software Foundation, Inc. ;;;; Copyright (C) 1999, 2000, 2001, 2003, 2006, 2008 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
@ -17,9 +17,10 @@
(define-module (oop goops util) (define-module (oop goops util)
:export (any every :export (mapappend find-duplicate top-level-env top-level-env?
mapappend find-duplicate top-level-env top-level-env?
map* for-each* length* improper->proper) map* for-each* length* improper->proper)
:use-module (srfi srfi-1)
:re-export (any every)
:no-backtrace :no-backtrace
) )
@ -28,43 +29,7 @@
;;; {Utilities} ;;; {Utilities}
;;; ;;;
(define (any pred lst . rest) (define mapappend append-map)
(if (null? rest) ;fast path
(and (not (null? lst))
(let loop ((head (car lst)) (tail (cdr lst)))
(if (null? tail)
(pred head)
(or (pred head)
(loop (car tail) (cdr tail))))))
(let ((lsts (cons lst rest)))
(and (not (any null? lsts))
(let loop ((heads (map car lsts)) (tails (map cdr lsts)))
(if (any null? tails)
(apply pred heads)
(or (apply pred heads)
(loop (map car tails) (map cdr tails)))))))))
(define (every pred lst . rest)
(if (null? rest) ;fast path
(or (null? lst)
(let loop ((head (car lst)) (tail (cdr lst)))
(if (null? tail)
(pred head)
(and (pred head)
(loop (car tail) (cdr tail))))))
(let ((lsts (cons lst rest)))
(or (any null? lsts)
(let loop ((heads (map car lsts)) (tails (map cdr lsts)))
(if (any null? tails)
(apply pred heads)
(and (apply pred heads)
(loop (map car tails) (map cdr tails)))))))))
(define (mapappend func . args)
(if (memv '() args)
'()
(append (apply func (map car args))
(apply mapappend func (map cdr args)))))
(define (find-duplicate l) ; find a duplicate in a list; #f otherwise (define (find-duplicate l) ; find a duplicate in a list; #f otherwise
(cond (cond