Commit | Line | Data |
---|---|---|
bf745816 JG |
1 | ;;; base.scm --- The R6RS base library |
2 | ||
7112615f | 3 | ;; Copyright (C) 2010, 2011 Free Software Foundation, Inc. |
bf745816 JG |
4 | ;; |
5 | ;; This library is free software; you can redistribute it and/or | |
6 | ;; modify it under the terms of the GNU Lesser General Public | |
7 | ;; License as published by the Free Software Foundation; either | |
8 | ;; version 3 of the License, or (at your option) any later version. | |
9 | ;; | |
10 | ;; This library is distributed in the hope that it will be useful, | |
11 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty of | |
12 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU | |
13 | ;; Lesser General Public License for more details. | |
14 | ;; | |
15 | ;; You should have received a copy of the GNU Lesser General Public | |
16 | ;; License along with this library; if not, write to the Free Software | |
17 | ;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA | |
18 | \f | |
19 | ||
20 | (library (rnrs base (6)) | |
21 | (export boolean? symbol? char? vector? null? pair? number? string? procedure? | |
22 | ||
23 | define define-syntax syntax-rules lambda let let* let-values | |
935c7aca | 24 | let*-values letrec letrec* begin |
bf745816 JG |
25 | |
26 | quote lambda if set! cond case | |
27 | ||
28 | or and not | |
29 | ||
30 | eqv? equal? eq? | |
31 | ||
32 | + - * / max min abs numerator denominator gcd lcm floor ceiling | |
33 | truncate round rationalize real-part imag-part make-rectangular angle | |
34 | div mod div-and-mod div0 mod0 div0-and-mod0 | |
35 | ||
36 | expt exact-integer-sqrt sqrt exp log sin cos tan asin acos atan | |
37 | make-polar magnitude angle | |
38 | ||
39 | complex? real? rational? integer? exact? inexact? real-valued? | |
b98d5a5a | 40 | rational-valued? integer-valued? zero? positive? negative? odd? even? |
bf745816 JG |
41 | nan? finite? infinite? |
42 | ||
43 | exact inexact = < > <= >= | |
44 | ||
45 | number->string string->number | |
46 | ||
b98d5a5a JG |
47 | boolean=? |
48 | ||
bf745816 JG |
49 | cons car cdr caar cadr cdar cddr caaar caadr cadar cdaar caddr cdadr |
50 | cddar cdddr caaaar caaadr caadar cadaar cdaaar cddaar cdadar cdaadr | |
51 | cadadr caaddr caddar cadddr cdaddr cddadr cdddar cddddr | |
52 | ||
53 | list? list length append reverse list-tail list-ref map for-each | |
54 | ||
b3961e7a | 55 | symbol->string string->symbol symbol=? |
bf745816 JG |
56 | |
57 | char->integer integer->char char=? char<? char>? char<=? char>=? | |
58 | ||
59 | make-string string string-length string-ref string=? string<? string>? | |
60 | string<=? string>=? substring string-append string->list list->string | |
61 | string-for-each string-copy | |
62 | ||
63 | vector? make-vector vector vector-length vector-ref vector-set! | |
64 | vector->list list->vector vector-fill! vector-map vector-for-each | |
65 | ||
66 | error assertion-violation assert | |
67 | ||
68 | call-with-current-continuation call/cc call-with-values dynamic-wind | |
69 | values apply | |
70 | ||
71 | quasiquote unquote unquote-splicing | |
72 | ||
73 | let-syntax letrec-syntax | |
74 | ||
75 | syntax-rules identifier-syntax) | |
06906f37 | 76 | (import (rename (except (guile) error raise map string-for-each) |
cf9d4a82 | 77 | (log log-internal) |
ff62c168 MW |
78 | (euclidean-quotient div) |
79 | (euclidean-remainder mod) | |
80 | (euclidean/ div-and-mod) | |
81 | (centered-quotient div0) | |
82 | (centered-remainder mod0) | |
83 | (centered/ div0-and-mod0) | |
7112615f | 84 | (inf? infinite?) |
b98d5a5a JG |
85 | (exact->inexact inexact) |
86 | (inexact->exact exact)) | |
87 | (srfi srfi-11)) | |
88 | ||
06906f37 IP |
89 | (define string-for-each |
90 | (case-lambda | |
91 | ((proc string) | |
92 | (let ((end (string-length string))) | |
93 | (let loop ((i 0)) | |
94 | (unless (= i end) | |
95 | (proc (string-ref string i)) | |
96 | (loop (+ i 1)))))) | |
97 | ((proc string1 string2) | |
98 | (let ((end1 (string-length string1)) | |
99 | (end2 (string-length string2))) | |
100 | (unless (= end1 end2) | |
101 | (assertion-violation 'string-for-each | |
102 | "string arguments must all have the same length" | |
103 | string1 string2)) | |
104 | (let loop ((i 0)) | |
105 | (unless (= i end1) | |
106 | (proc (string-ref string1 i) | |
107 | (string-ref string2 i)) | |
108 | (loop (+ i 1)))))) | |
109 | ((proc string . strings) | |
110 | (let ((end (string-length string)) | |
111 | (ends (map string-length strings))) | |
112 | (for-each (lambda (x) | |
113 | (unless (= end x) | |
114 | (apply assertion-violation | |
115 | 'string-for-each | |
116 | "string arguments must all have the same length" | |
117 | string strings))) | |
118 | ends) | |
119 | (let loop ((i 0)) | |
120 | (unless (= i end) | |
121 | (apply proc | |
122 | (string-ref string i) | |
123 | (map (lambda (s) (string-ref s i)) strings)) | |
124 | (loop (+ i 1)))))))) | |
125 | ||
b8f19196 AW |
126 | (define map |
127 | (case-lambda | |
128 | ((f l) | |
129 | (let map1 ((hare l) (tortoise l) (move? #f) (out '())) | |
130 | (if (pair? hare) | |
131 | (if move? | |
132 | (if (eq? tortoise hare) | |
133 | (scm-error 'wrong-type-arg "map" "Circular list: ~S" | |
134 | (list l) #f) | |
135 | (map1 (cdr hare) (cdr tortoise) #f | |
136 | (cons (f (car hare)) out))) | |
137 | (map1 (cdr hare) tortoise #t | |
138 | (cons (f (car hare)) out))) | |
139 | (if (null? hare) | |
140 | (reverse out) | |
141 | (scm-error 'wrong-type-arg "map" "Not a list: ~S" | |
142 | (list l) #f))))) | |
143 | ||
144 | ((f l1 l2) | |
145 | (let map2 ((h1 l1) (h2 l2) (t1 l1) (t2 l2) (move? #f) (out '())) | |
146 | (cond | |
147 | ((pair? h1) | |
148 | (cond | |
149 | ((not (pair? h2)) | |
150 | (scm-error 'wrong-type-arg "map" | |
151 | (if (list? h2) | |
152 | "List of wrong length: ~S" | |
153 | "Not a list: ~S") | |
154 | (list l2) #f)) | |
155 | ((not move?) | |
156 | (map2 (cdr h1) (cdr h2) t1 t2 #t | |
157 | (cons (f (car h1) (car h2)) out))) | |
158 | ((eq? t1 h1) | |
159 | (scm-error 'wrong-type-arg "map" "Circular list: ~S" | |
160 | (list l1) #f)) | |
161 | ((eq? t2 h2) | |
162 | (scm-error 'wrong-type-arg "map" "Circular list: ~S" | |
163 | (list l2) #f)) | |
164 | (else | |
165 | (map2 (cdr h1) (cdr h2) (cdr t1) (cdr t2) #f | |
166 | (cons (f (car h1) (car h2)) out))))) | |
167 | ||
168 | ((and (null? h1) (null? h2)) | |
169 | (reverse out)) | |
170 | ||
171 | ((null? h1) | |
172 | (scm-error 'wrong-type-arg "map" | |
173 | (if (list? h2) | |
174 | "List of wrong length: ~S" | |
175 | "Not a list: ~S") | |
176 | (list l2) #f)) | |
177 | (else | |
178 | (scm-error 'wrong-type-arg "map" | |
179 | "Not a list: ~S" | |
180 | (list l1) #f))))) | |
181 | ||
182 | ((f l1 . rest) | |
183 | (let ((len (length l1))) | |
184 | (let mapn ((rest rest)) | |
185 | (or (null? rest) | |
186 | (if (= (length (car rest)) len) | |
187 | (mapn (cdr rest)) | |
188 | (scm-error 'wrong-type-arg "map" "List of wrong length: ~S" | |
189 | (list (car rest)) #f))))) | |
190 | (let mapn ((l1 l1) (rest rest) (out '())) | |
191 | (if (null? l1) | |
192 | (reverse out) | |
193 | (mapn (cdr l1) (map cdr rest) | |
194 | (cons (apply f (car l1) (map car rest)) out))))))) | |
195 | ||
cf9d4a82 IP |
196 | (define log |
197 | (case-lambda | |
198 | ((n) | |
199 | (log-internal n)) | |
200 | ((n base) | |
201 | (/ (log n) | |
202 | (log base))))) | |
203 | ||
b98d5a5a JG |
204 | (define (boolean=? . bools) |
205 | (define (boolean=?-internal lst last) | |
206 | (or (null? lst) | |
207 | (let ((bool (car lst))) | |
208 | (and (eqv? bool last) (boolean=?-internal (cdr lst) bool))))) | |
209 | (or (null? bools) | |
210 | (let ((bool (car bools))) | |
211 | (and (boolean? bool) (boolean=?-internal (cdr bools) bool))))) | |
212 | ||
213 | (define (symbol=? . syms) | |
214 | (define (symbol=?-internal lst last) | |
215 | (or (null? lst) | |
216 | (let ((sym (car lst))) | |
217 | (and (eq? sym last) (symbol=?-internal (cdr lst) sym))))) | |
218 | (or (null? syms) | |
219 | (let ((sym (car syms))) | |
220 | (and (symbol? sym) (symbol=?-internal (cdr syms) sym))))) | |
221 | ||
8f2339c4 MW |
222 | (define (real-valued? x) |
223 | (and (complex? x) | |
224 | (zero? (imag-part x)))) | |
225 | ||
226 | (define (rational-valued? x) | |
227 | (and (real-valued? x) | |
228 | (rational? (real-part x)))) | |
229 | ||
230 | (define (integer-valued? x) | |
231 | (and (rational-valued? x) | |
232 | (= x (floor (real-part x))))) | |
b01818d7 | 233 | |
b24b7deb JG |
234 | (define (vector-for-each proc . vecs) |
235 | (apply for-each (cons proc (map vector->list vecs)))) | |
236 | (define (vector-map proc . vecs) | |
237 | (list->vector (apply map (cons proc (map vector->list vecs))))) | |
238 | ||
630b6588 LC |
239 | (define-syntax define-proxy |
240 | (syntax-rules (@) | |
241 | ;; Define BINDING to point to (@ MODULE ORIGINAL). This hack is to | |
242 | ;; make sure MODULE is loaded lazily, at run-time, when BINDING is | |
243 | ;; encountered, rather than being loaded while compiling and | |
244 | ;; loading (rnrs base). | |
245 | ;; This avoids circular dependencies among modules and makes | |
246 | ;; (rnrs base) more lightweight. | |
247 | ((_ binding (@ module original)) | |
248 | (define-syntax binding | |
249 | (identifier-syntax | |
250 | (module-ref (resolve-interface 'module) 'original)))))) | |
251 | ||
252 | (define-proxy raise | |
253 | (@ (rnrs exceptions) raise)) | |
254 | ||
255 | (define-proxy condition | |
23988e8c | 256 | (@ (rnrs conditions) condition)) |
630b6588 | 257 | (define-proxy make-error |
c0f6c163 | 258 | (@ (rnrs conditions) make-error)) |
630b6588 | 259 | (define-proxy make-assertion-violation |
23988e8c | 260 | (@ (rnrs conditions) make-assertion-violation)) |
630b6588 | 261 | (define-proxy make-who-condition |
23988e8c | 262 | (@ (rnrs conditions) make-who-condition)) |
630b6588 | 263 | (define-proxy make-message-condition |
23988e8c | 264 | (@ (rnrs conditions) make-message-condition)) |
630b6588 | 265 | (define-proxy make-irritants-condition |
23988e8c | 266 | (@ (rnrs conditions) make-irritants-condition)) |
c0f6c163 AR |
267 | |
268 | (define (error who message . irritants) | |
269 | (raise (apply condition | |
270 | (append (list (make-error)) | |
271 | (if who (list (make-who-condition who)) '()) | |
272 | (list (make-message-condition message) | |
273 | (make-irritants-condition irritants)))))) | |
23988e8c AR |
274 | |
275 | (define (assertion-violation who message . irritants) | |
c0f6c163 AR |
276 | (raise (apply condition |
277 | (append (list (make-assertion-violation)) | |
278 | (if who (list (make-who-condition who)) '()) | |
279 | (list (make-message-condition message) | |
280 | (make-irritants-condition irritants)))))) | |
281 | ||
282 | (define-syntax assert | |
283 | (syntax-rules () | |
284 | ((_ expression) | |
15993bce | 285 | (or expression |
c0f6c163 AR |
286 | (raise (condition |
287 | (make-assertion-violation) | |
288 | (make-message-condition | |
289 | (format #f "assertion failed: ~s" 'expression)))))))) | |
23988e8c | 290 | |
b01818d7 | 291 | ) |