module/rnrs/base.scm

   1 ;;; base.scm --- The R6RS base library
   2
   3 ;;      Copyright (C) 2010, 2011 Free Software Foundation, Inc.
   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
  24           let*-values letrec letrec* begin
  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?
  40           rational-valued? integer-valued? zero? positive? negative? odd? even?
  41           nan? finite? infinite?
  42
  43           exact inexact = < > <= >=
  44
  45           number->string string->number
  46
  47           boolean=?
  48
  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
  55           symbol->string string->symbol symbol=?
  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)
  76   (import (rename (except (guile) error raise)
  77                   (log log-internal)
  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)
  84                   (inf? infinite?)
  85                   (exact->inexact inexact)
  86                   (inexact->exact exact))
  87           (srfi srfi-11))
  88
  89  (define log
  90    (case-lambda
  91      ((n)
  92       (log-internal n))
  93      ((n base)
  94       (/ (log n)
  95          (log base)))))
  96
  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
 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)))))
 126
 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
 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
 149    (@ (rnrs conditions) condition))
 150  (define-proxy make-error
 151    (@ (rnrs conditions) make-error))
 152  (define-proxy make-assertion-violation
 153    (@ (rnrs conditions) make-assertion-violation))
 154  (define-proxy make-who-condition
 155    (@ (rnrs conditions) make-who-condition))
 156  (define-proxy make-message-condition
 157    (@ (rnrs conditions) make-message-condition))
 158  (define-proxy make-irritants-condition
 159    (@ (rnrs conditions) make-irritants-condition))
 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))))))
 167
 168  (define (assertion-violation who message . irritants)
 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)
 178       (or expression
 179           (raise (condition
 180                   (make-assertion-violation)
 181                   (make-message-condition
 182                    (format #f "assertion failed: ~s" 'expression))))))))
 183
 184 )