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