[bpt/guile.git] / module / oop / goops / util.scm

;;;; 	Copyright (C) 1999, 2000, 2001, 2003, 2006, 2008 Free Software Foundation, Inc.
;;;; 
;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
;;;; License as published by the Free Software Foundation; either
;;;; version 2.1 of the License, or (at your option) any later version.
;;;; 
;;;; This library is distributed in the hope that it will be useful,
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
;;;; Lesser General Public License for more details.
;;;; 
;;;; You should have received a copy of the GNU Lesser General Public
;;;; License along with this library; if not, write to the Free Software
;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
;;;; 
\f

(define-module (oop goops util)
  :export (mapappend find-duplicate top-level-env top-level-env?
	   map* for-each* length* improper->proper)
  :use-module (srfi srfi-1)
  :re-export  (any every)
  :no-backtrace
  )


;;;
;;; {Utilities}
;;;

(define mapappend append-map)

(define (find-duplicate l)	; find a duplicate in a list; #f otherwise
  (cond 
    ((null? l)			#f)
    ((memv (car l) (cdr l))	(car l))
    (else 			(find-duplicate (cdr l)))))

(define (top-level-env)
  (let ((mod (current-module)))
    (if mod
	(module-eval-closure mod)
	'())))

(define (top-level-env? env)
  (or (null? env)
      (procedure? (car env))))

(define (map* fn . l) 		; A map which accepts dotted lists (arg lists  
  (cond 			; must be "isomorph"
   ((null? (car l)) '())
   ((pair? (car l)) (cons (apply fn      (map car l))
			  (apply map* fn (map cdr l))))
   (else            (apply fn l))))

(define (for-each* fn . l) 	; A for-each which accepts dotted lists (arg lists  
  (cond 			; must be "isomorph"
   ((null? (car l)) '())
   ((pair? (car l)) (apply fn (map car l)) (apply for-each* fn (map cdr l)))
   (else            (apply fn l))))

(define (length* ls)
  (do ((n 0 (+ 1 n))
       (ls ls (cdr ls)))
      ((not (pair? ls)) n)))

(define (improper->proper ls)
  (if (pair? ls)
      (cons (car ls) (improper->proper (cdr ls)))
      (list ls)))
Commit	Line	Data
cc7e01ce	1	;;;; Copyright (C) 1999, 2000, 2001, 2003, 2006, 2008 Free Software Foundation, Inc.
14f1d9fe	2	;;;;
73be1d9e MV	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.
14f1d9fe	7	;;;;
73be1d9e	8	;;;; This library is distributed in the hope that it will be useful,
14f1d9fe	9	;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
73be1d9e MV	10	;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
73be1d9e MV	11	;;;; Lesser General Public License for more details.
14f1d9fe	12	;;;;
73be1d9e MV	13	;;;; You should have received a copy of the GNU Lesser General Public
73be1d9e MV	14	;;;; License along with this library; if not, write to the Free Software
92205699	15	;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
14f1d9fe MD	16	;;;;
	17	\f
	18
	19	(define-module (oop goops util)
cc7e01ce	20	:export (mapappend find-duplicate top-level-env top-level-env?
1a179b03	21	map* for-each* length* improper->proper)
cc7e01ce LC	22	:use-module (srfi srfi-1)
cc7e01ce LC	23	:re-export (any every)
14f1d9fe MD	24	:no-backtrace
	25	)
	26
14f1d9fe MD	27
	28	;;;
	29	;;; {Utilities}
	30	;;;
	31
cc7e01ce	32	(define mapappend append-map)
14f1d9fe MD	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)
2b33d8dc MV	41	(let ((mod (current-module)))
	42	(if mod
	43	(module-eval-closure mod)
	44	'())))
14f1d9fe MD	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)))