oop/goops/util.scm

   1 ;;;;    Copyright (C) 1999, 2000, 2001, 2003 Free Software Foundation, Inc.
   2 ;;;;
   3 ;;;; This library is free software; you can redistribute it and/or
   4 ;;;; modify it under the terms of the GNU Lesser General Public
   5 ;;;; License as published by the Free Software Foundation; either
   6 ;;;; version 2.1 of the License, or (at your option) any later version.
   7 ;;;;
   8 ;;;; This library is distributed in the hope that it will be useful,
   9 ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  10 ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  11 ;;;; Lesser General Public License for more details.
  12 ;;;;
  13 ;;;; You should have received a copy of the GNU Lesser General Public
  14 ;;;; License along with this library; if not, write to the Free Software
  15 ;;;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
  16 ;;;;
  17 \f
  18
  19 (define-module (oop goops util)
  20   :export (any every
  21            mapappend find-duplicate top-level-env top-level-env?
  22            map* for-each* length* improper->proper)
  23   :no-backtrace
  24   )
  25
  26
  27 ;;;
  28 ;;; {Utilities}
  29 ;;;
  30
  31 (define (any pred lst . rest)
  32   (if (null? rest) ;fast path
  33       (and (not (null? lst))
  34            (let loop ((head (car lst)) (tail (cdr lst)))
  35              (if (null? tail)
  36                  (pred head)
  37                  (or (pred head)
  38                      (loop (car tail) (cdr tail))))))
  39       (let ((lsts (cons lst rest)))
  40         (and (not (any null? lsts))
  41              (let loop ((heads (map car lsts)) (tails (map cdr lsts)))
  42                (if (any null? tails)
  43                    (apply pred heads)
  44                    (or (apply pred heads)
  45                        (loop (map car tails) (map cdr tails)))))))))
  46
  47 (define (every pred lst . rest)
  48   (if (null? rest) ;fast path
  49       (or (null? lst)
  50           (let loop ((head (car lst)) (tail (cdr lst)))
  51             (if (null? tail)
  52                 (pred head)
  53                 (and (pred head)
  54                      (loop (car tail) (cdr tail))))))
  55       (let ((lsts (cons lst rest)))
  56         (or (any null? lsts)
  57             (let loop ((heads (map car lsts)) (tails (map cdr lsts)))
  58               (if (any null? tails)
  59                   (apply pred heads)
  60                   (and (apply pred heads)
  61                        (loop (map car tails) (map cdr tails)))))))))
  62
  63 (define (mapappend func . args)
  64   (if (memv '()  args)
  65       '()
  66       (append (apply func (map car args))
  67               (apply mapappend func (map cdr args)))))
  68
  69 (define (find-duplicate l)      ; find a duplicate in a list; #f otherwise
  70   (cond
  71     ((null? l)                  #f)
  72     ((memv (car l) (cdr l))     (car l))
  73     (else                       (find-duplicate (cdr l)))))
  74
  75 (define (top-level-env)
  76   (let ((mod (current-module)))
  77     (if mod
  78         (module-eval-closure mod)
  79         '())))
  80
  81 (define (top-level-env? env)
  82   (or (null? env)
  83       (procedure? (car env))))
  84
  85 (define (map* fn . l)           ; A map which accepts dotted lists (arg lists
  86   (cond                         ; must be "isomorph"
  87    ((null? (car l)) '())
  88    ((pair? (car l)) (cons (apply fn      (map car l))
  89                           (apply map* fn (map cdr l))))
  90    (else            (apply fn l))))
  91
  92 (define (for-each* fn . l)      ; A for-each which accepts dotted lists (arg lists
  93   (cond                         ; must be "isomorph"
  94    ((null? (car l)) '())
  95    ((pair? (car l)) (apply fn (map car l)) (apply for-each* fn (map cdr l)))
  96    (else            (apply fn l))))
  97
  98 (define (length* ls)
  99   (do ((n 0 (+ 1 n))
 100        (ls ls (cdr ls)))
 101       ((not (pair? ls)) n)))
 102
 103 (define (improper->proper ls)
 104   (if (pair? ls)
 105       (cons (car ls) (improper->proper (cdr ls)))
 106       (list ls)))