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) | |
c0f6c163 | 76 | (import (rename (except (guile) error raise) |
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 | ||
cf9d4a82 IP |
89 | (define log |
90 | (case-lambda | |
91 | ((n) | |
92 | (log-internal n)) | |
93 | ((n base) | |
94 | (/ (log n) | |
95 | (log base))))) | |
96 | ||
b98d5a5a JG |
97 | (define (boolean=? . bools) |
98 | (define (boolean=?-internal lst last) | |
99 | (or (null? lst) | |
100 | (let ((bool (car lst))) | |
101 | (and (eqv? bool last) (boolean=?-internal (cdr lst) bool))))) | |
102 | (or (null? bools) | |
103 | (let ((bool (car bools))) | |
104 | (and (boolean? bool) (boolean=?-internal (cdr bools) bool))))) | |
105 | ||
106 | (define (symbol=? . syms) | |
107 | (define (symbol=?-internal lst last) | |
108 | (or (null? lst) | |
109 | (let ((sym (car lst))) | |
110 | (and (eq? sym last) (symbol=?-internal (cdr lst) sym))))) | |
111 | (or (null? syms) | |
112 | (let ((sym (car syms))) | |
113 | (and (symbol? sym) (symbol=?-internal (cdr syms) sym))))) | |
114 | ||
8f2339c4 MW |
115 | (define (real-valued? x) |
116 | (and (complex? x) | |
117 | (zero? (imag-part x)))) | |
118 | ||
119 | (define (rational-valued? x) | |
120 | (and (real-valued? x) | |
121 | (rational? (real-part x)))) | |
122 | ||
123 | (define (integer-valued? x) | |
124 | (and (rational-valued? x) | |
125 | (= x (floor (real-part x))))) | |
b01818d7 | 126 | |
b24b7deb JG |
127 | (define (vector-for-each proc . vecs) |
128 | (apply for-each (cons proc (map vector->list vecs)))) | |
129 | (define (vector-map proc . vecs) | |
130 | (list->vector (apply map (cons proc (map vector->list vecs))))) | |
131 | ||
630b6588 LC |
132 | (define-syntax define-proxy |
133 | (syntax-rules (@) | |
134 | ;; Define BINDING to point to (@ MODULE ORIGINAL). This hack is to | |
135 | ;; make sure MODULE is loaded lazily, at run-time, when BINDING is | |
136 | ;; encountered, rather than being loaded while compiling and | |
137 | ;; loading (rnrs base). | |
138 | ;; This avoids circular dependencies among modules and makes | |
139 | ;; (rnrs base) more lightweight. | |
140 | ((_ binding (@ module original)) | |
141 | (define-syntax binding | |
142 | (identifier-syntax | |
143 | (module-ref (resolve-interface 'module) 'original)))))) | |
144 | ||
145 | (define-proxy raise | |
146 | (@ (rnrs exceptions) raise)) | |
147 | ||
148 | (define-proxy condition | |
23988e8c | 149 | (@ (rnrs conditions) condition)) |
630b6588 | 150 | (define-proxy make-error |
c0f6c163 | 151 | (@ (rnrs conditions) make-error)) |
630b6588 | 152 | (define-proxy make-assertion-violation |
23988e8c | 153 | (@ (rnrs conditions) make-assertion-violation)) |
630b6588 | 154 | (define-proxy make-who-condition |
23988e8c | 155 | (@ (rnrs conditions) make-who-condition)) |
630b6588 | 156 | (define-proxy make-message-condition |
23988e8c | 157 | (@ (rnrs conditions) make-message-condition)) |
630b6588 | 158 | (define-proxy make-irritants-condition |
23988e8c | 159 | (@ (rnrs conditions) make-irritants-condition)) |
c0f6c163 AR |
160 | |
161 | (define (error who message . irritants) | |
162 | (raise (apply condition | |
163 | (append (list (make-error)) | |
164 | (if who (list (make-who-condition who)) '()) | |
165 | (list (make-message-condition message) | |
166 | (make-irritants-condition irritants)))))) | |
23988e8c AR |
167 | |
168 | (define (assertion-violation who message . irritants) | |
c0f6c163 AR |
169 | (raise (apply condition |
170 | (append (list (make-assertion-violation)) | |
171 | (if who (list (make-who-condition who)) '()) | |
172 | (list (make-message-condition message) | |
173 | (make-irritants-condition irritants)))))) | |
174 | ||
175 | (define-syntax assert | |
176 | (syntax-rules () | |
177 | ((_ expression) | |
15993bce | 178 | (or expression |
c0f6c163 AR |
179 | (raise (condition |
180 | (make-assertion-violation) | |
181 | (make-message-condition | |
182 | (format #f "assertion failed: ~s" 'expression)))))))) | |
23988e8c | 183 | |
b01818d7 | 184 | ) |