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 map string-for-each)
  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 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
 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
 196  (define log
 197    (case-lambda
 198      ((n)
 199       (log-internal n))
 200      ((n base)
 201       (/ (log n)
 202          (log base)))))
 203
 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
 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)))))
 233
 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
 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
 256    (@ (rnrs conditions) condition))
 257  (define-proxy make-error
 258    (@ (rnrs conditions) make-error))
 259  (define-proxy make-assertion-violation
 260    (@ (rnrs conditions) make-assertion-violation))
 261  (define-proxy make-who-condition
 262    (@ (rnrs conditions) make-who-condition))
 263  (define-proxy make-message-condition
 264    (@ (rnrs conditions) make-message-condition))
 265  (define-proxy make-irritants-condition
 266    (@ (rnrs conditions) make-irritants-condition))
 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))))))
 274
 275  (define (assertion-violation who message . irritants)
 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)
 285       (or expression
 286           (raise (condition
 287                   (make-assertion-violation)
 288                   (make-message-condition
 289                    (format #f "assertion failed: ~s" 'expression))))))))
 290
 291 )