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                   (euclidean-quotient div)
  78                   (euclidean-remainder mod)
  79                   (euclidean/ div-and-mod)
  80                   (centered-quotient div0)
  81                   (centered-remainder mod0)
  82                   (centered/ div0-and-mod0)
  83                   (inf? infinite?)
  84                   (exact->inexact inexact)
  85                   (inexact->exact exact))
  86           (srfi srfi-11))
  87
  88  (define (boolean=? . bools)
  89    (define (boolean=?-internal lst last)
  90      (or (null? lst)
  91          (let ((bool (car lst)))
  92            (and (eqv? bool last) (boolean=?-internal (cdr lst) bool)))))
  93    (or (null? bools)
  94        (let ((bool (car bools)))
  95          (and (boolean? bool) (boolean=?-internal (cdr bools) bool)))))
  96
  97  (define (symbol=? . syms)
  98    (define (symbol=?-internal lst last)
  99      (or (null? lst)
 100          (let ((sym (car lst)))
 101            (and (eq? sym last) (symbol=?-internal (cdr lst) sym)))))
 102    (or (null? syms)
 103        (let ((sym (car syms)))
 104          (and (symbol? sym) (symbol=?-internal (cdr syms) sym)))))
 105
 106  (define (exact-integer-sqrt x)
 107    (let* ((s (exact (floor (sqrt x)))) (e (- x (* s s)))) (values s e)))
 108
 109  (define (real-valued? x)
 110    (and (complex? x)
 111         (zero? (imag-part x))))
 112
 113  (define (rational-valued? x)
 114    (and (real-valued? x)
 115         (rational? (real-part x))))
 116
 117  (define (integer-valued? x)
 118    (and (rational-valued? x)
 119         (= x (floor (real-part x)))))
 120
 121  (define (vector-for-each proc . vecs)
 122    (apply for-each (cons proc (map vector->list vecs))))
 123  (define (vector-map proc . vecs)
 124    (list->vector (apply map (cons proc (map vector->list vecs)))))
 125
 126  (define raise
 127    (@ (rnrs exceptions) raise))
 128  (define condition
 129    (@ (rnrs conditions) condition))
 130  (define make-error
 131    (@ (rnrs conditions) make-error))
 132  (define make-assertion-violation
 133    (@ (rnrs conditions) make-assertion-violation))
 134  (define make-who-condition
 135    (@ (rnrs conditions) make-who-condition))
 136  (define make-message-condition
 137    (@ (rnrs conditions) make-message-condition))
 138  (define make-irritants-condition
 139    (@ (rnrs conditions) make-irritants-condition))
 140
 141  (define (error who message . irritants)
 142    (raise (apply condition
 143                  (append (list (make-error))
 144                          (if who (list (make-who-condition who)) '())
 145                          (list (make-message-condition message)
 146                                (make-irritants-condition irritants))))))
 147
 148  (define (assertion-violation who message . irritants)
 149    (raise (apply condition
 150                  (append (list (make-assertion-violation))
 151                          (if who (list (make-who-condition who)) '())
 152                          (list (make-message-condition message)
 153                                (make-irritants-condition irritants))))))
 154
 155  (define-syntax assert
 156    (syntax-rules ()
 157      ((_ expression)
 158       (if (not expression)
 159           (raise (condition
 160                   (make-assertion-violation)
 161                   (make-message-condition
 162                    (format #f "assertion failed: ~s" 'expression))))))))
 163
 164 )