1;;;; Copyright (C) 1999, 2000, 2001, 2003, 2006, 2008 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., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA 16;;;; 17 18 19(define-module (oop goops util) 20 :export (mapappend find-duplicate top-level-env top-level-env? 21 map* for-each* length* improper->proper) 22 :use-module (srfi srfi-1) 23 :re-export (any every) 24 :no-backtrace 25 ) 26 27 28;;; 29;;; {Utilities} 30;;; 31 32(define mapappend append-map) 33 34(define (find-duplicate l) ; find a duplicate in a list; #f otherwise 35 (cond 36 ((null? l) #f) 37 ((memv (car l) (cdr l)) (car l)) 38 (else (find-duplicate (cdr l))))) 39 40(define (top-level-env) 41 (let ((mod (current-module))) 42 (if mod 43 (module-eval-closure mod) 44 '()))) 45 46(define (top-level-env? env) 47 (or (null? env) 48 (procedure? (car env)))) 49 50(define (map* fn . l) ; A map which accepts dotted lists (arg lists 51 (cond ; must be "isomorph" 52 ((null? (car l)) '()) 53 ((pair? (car l)) (cons (apply fn (map car l)) 54 (apply map* fn (map cdr l)))) 55 (else (apply fn l)))) 56 57(define (for-each* fn . l) ; A for-each which accepts dotted lists (arg lists 58 (cond ; must be "isomorph" 59 ((null? (car l)) '()) 60 ((pair? (car l)) (apply fn (map car l)) (apply for-each* fn (map cdr l))) 61 (else (apply fn l)))) 62 63(define (length* ls) 64 (do ((n 0 (+ 1 n)) 65 (ls ls (cdr ls))) 66 ((not (pair? ls)) n))) 67 68(define (improper->proper ls) 69 (if (pair? ls) 70 (cons (car ls) (improper->proper (cdr ls))) 71 (list ls))) 72