Commit | Line | Data |
---|---|---|
14f1d9fe MD |
1 | ;;;; Copyright (C) 1999, 2000 Free Software Foundation, Inc. |
2 | ;;;; | |
3 | ;;;; This program is free software; you can redistribute it and/or modify | |
4 | ;;;; it under the terms of the GNU General Public License as published by | |
5 | ;;;; the Free Software Foundation; either version 2, or (at your option) | |
6 | ;;;; any later version. | |
7 | ;;;; | |
8 | ;;;; This program 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 | |
11 | ;;;; GNU General Public License for more details. | |
12 | ;;;; | |
13 | ;;;; You should have received a copy of the GNU General Public License | |
14 | ;;;; along with this software; see the file COPYING. If not, write to | |
15 | ;;;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330, | |
16 | ;;;; Boston, MA 02111-1307 USA | |
c22adbeb MV |
17 | ;;;; |
18 | ;;;; As a special exception, the Free Software Foundation gives permission | |
19 | ;;;; for additional uses of the text contained in its release of GUILE. | |
20 | ;;;; | |
21 | ;;;; The exception is that, if you link the GUILE library with other files | |
22 | ;;;; to produce an executable, this does not by itself cause the | |
23 | ;;;; resulting executable to be covered by the GNU General Public License. | |
24 | ;;;; Your use of that executable is in no way restricted on account of | |
25 | ;;;; linking the GUILE library code into it. | |
26 | ;;;; | |
27 | ;;;; This exception does not however invalidate any other reasons why | |
28 | ;;;; the executable file might be covered by the GNU General Public License. | |
29 | ;;;; | |
30 | ;;;; This exception applies only to the code released by the | |
31 | ;;;; Free Software Foundation under the name GUILE. If you copy | |
32 | ;;;; code from other Free Software Foundation releases into a copy of | |
33 | ;;;; GUILE, as the General Public License permits, the exception does | |
34 | ;;;; not apply to the code that you add in this way. To avoid misleading | |
35 | ;;;; anyone as to the status of such modified files, you must delete | |
36 | ;;;; this exception notice from them. | |
37 | ;;;; | |
38 | ;;;; If you write modifications of your own for GUILE, it is your choice | |
39 | ;;;; whether to permit this exception to apply to your modifications. | |
40 | ;;;; If you do not wish that, delete this exception notice. | |
14f1d9fe MD |
41 | ;;;; |
42 | \f | |
43 | ||
44 | (define-module (oop goops util) | |
45 | :no-backtrace | |
46 | ) | |
47 | ||
48 | (export any every filter | |
49 | mapappend find-duplicate top-level-env top-level-env? | |
50 | map* for-each* length* improper->proper | |
51 | ) | |
52 | ||
53 | ;;; | |
54 | ;;; {Utilities} | |
55 | ;;; | |
56 | ||
57 | (define (any pred lst . rest) | |
58 | (if (null? rest) ;fast path | |
59 | (and (not (null? lst)) | |
60 | (let loop ((head (car lst)) (tail (cdr lst))) | |
61 | (if (null? tail) | |
62 | (pred head) | |
63 | (or (pred head) | |
64 | (loop (car tail) (cdr tail)))))) | |
65 | (let ((lsts (cons lst rest))) | |
66 | (and (not (any null? lsts)) | |
67 | (let loop ((heads (map car lsts)) (tails (map cdr lsts))) | |
68 | (if (any null? tails) | |
69 | (apply pred heads) | |
70 | (or (apply pred heads) | |
71 | (loop (map car tails) (map cdr tails))))))))) | |
72 | ||
73 | (define (every pred lst . rest) | |
74 | (if (null? rest) ;fast path | |
75 | (or (null? lst) | |
76 | (let loop ((head (car lst)) (tail (cdr lst))) | |
77 | (if (null? tail) | |
78 | (pred head) | |
79 | (and (pred head) | |
80 | (loop (car tail) (cdr tail)))))) | |
81 | (let ((lsts (cons lst rest))) | |
82 | (or (any null? lsts) | |
83 | (let loop ((heads (map car lsts)) (tails (map cdr lsts))) | |
84 | (if (any null? tails) | |
85 | (apply pred heads) | |
86 | (and (apply pred heads) | |
87 | (loop (map car tails) (map cdr tails))))))))) | |
88 | ||
89 | (define (filter test? list) | |
90 | (cond ((null? list) '()) | |
91 | ((test? (car list)) (cons (car list) (filter test? (cdr list)))) | |
92 | (else (filter test? (cdr list))))) | |
93 | ||
94 | (define (mapappend func . args) | |
95 | (if (memv '() args) | |
96 | '() | |
97 | (append (apply func (map car args)) | |
98 | (apply mapappend func (map cdr args))))) | |
99 | ||
100 | (define (find-duplicate l) ; find a duplicate in a list; #f otherwise | |
101 | (cond | |
102 | ((null? l) #f) | |
103 | ((memv (car l) (cdr l)) (car l)) | |
104 | (else (find-duplicate (cdr l))))) | |
105 | ||
106 | (define (top-level-env) | |
2b33d8dc MV |
107 | (let ((mod (current-module))) |
108 | (if mod | |
109 | (module-eval-closure mod) | |
110 | '()))) | |
14f1d9fe MD |
111 | |
112 | (define (top-level-env? env) | |
113 | (or (null? env) | |
114 | (procedure? (car env)))) | |
115 | ||
116 | (define (map* fn . l) ; A map which accepts dotted lists (arg lists | |
117 | (cond ; must be "isomorph" | |
118 | ((null? (car l)) '()) | |
119 | ((pair? (car l)) (cons (apply fn (map car l)) | |
120 | (apply map* fn (map cdr l)))) | |
121 | (else (apply fn l)))) | |
122 | ||
123 | (define (for-each* fn . l) ; A for-each which accepts dotted lists (arg lists | |
124 | (cond ; must be "isomorph" | |
125 | ((null? (car l)) '()) | |
126 | ((pair? (car l)) (apply fn (map car l)) (apply for-each* fn (map cdr l))) | |
127 | (else (apply fn l)))) | |
128 | ||
129 | (define (length* ls) | |
130 | (do ((n 0 (+ 1 n)) | |
131 | (ls ls (cdr ls))) | |
132 | ((not (pair? ls)) n))) | |
133 | ||
134 | (define (improper->proper ls) | |
135 | (if (pair? ls) | |
136 | (cons (car ls) (improper->proper (cdr ls))) | |
137 | (list ls))) |