;;; base.scm --- The R6RS base library ;; Copyright (C) 2010, 2011 Free Software Foundation, Inc. ;; ;; This library is free software; you can redistribute it and/or ;; modify it under the terms of the GNU Lesser General Public ;; License as published by the Free Software Foundation; either ;; version 3 of the License, or (at your option) any later version. ;; ;; This library is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;; Lesser General Public License for more details. ;; ;; You should have received a copy of the GNU Lesser General Public ;; License along with this library; if not, write to the Free Software ;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA (library (rnrs base (6)) (export boolean? symbol? char? vector? null? pair? number? string? procedure? define define-syntax syntax-rules lambda let let* let-values let*-values letrec letrec* begin quote lambda if set! cond case or and not eqv? equal? eq? + - * / max min abs numerator denominator gcd lcm floor ceiling truncate round rationalize real-part imag-part make-rectangular angle div mod div-and-mod div0 mod0 div0-and-mod0 expt exact-integer-sqrt sqrt exp log sin cos tan asin acos atan make-polar magnitude angle complex? real? rational? integer? exact? inexact? real-valued? rational-valued? integer-valued? zero? positive? negative? odd? even? nan? finite? infinite? exact inexact = < > <= >= number->string string->number boolean=? cons car cdr caar cadr cdar cddr caaar caadr cadar cdaar caddr cdadr cddar cdddr caaaar caaadr caadar cadaar cdaaar cddaar cdadar cdaadr cadadr caaddr caddar cadddr cdaddr cddadr cdddar cddddr list? list length append reverse list-tail list-ref map for-each symbol->string string->symbol symbol=? char->integer integer->char char=? char? char<=? char>=? make-string string string-length string-ref string=? string? string<=? string>=? substring string-append string->list list->string string-for-each string-copy vector? make-vector vector vector-length vector-ref vector-set! vector->list list->vector vector-fill! vector-map vector-for-each error assertion-violation assert call-with-current-continuation call/cc call-with-values dynamic-wind values apply quasiquote unquote unquote-splicing let-syntax letrec-syntax syntax-rules identifier-syntax) (import (rename (except (guile) error raise map string-for-each) (log log-internal) (euclidean-quotient div) (euclidean-remainder mod) (euclidean/ div-and-mod) (centered-quotient div0) (centered-remainder mod0) (centered/ div0-and-mod0) (inf? infinite?) (exact->inexact inexact) (inexact->exact exact)) (srfi srfi-11)) (define string-for-each (case-lambda ((proc string) (let ((end (string-length string))) (let loop ((i 0)) (unless (= i end) (proc (string-ref string i)) (loop (+ i 1)))))) ((proc string1 string2) (let ((end1 (string-length string1)) (end2 (string-length string2))) (unless (= end1 end2) (assertion-violation 'string-for-each "string arguments must all have the same length" string1 string2)) (let loop ((i 0)) (unless (= i end1) (proc (string-ref string1 i) (string-ref string2 i)) (loop (+ i 1)))))) ((proc string . strings) (let ((end (string-length string)) (ends (map string-length strings))) (for-each (lambda (x) (unless (= end x) (apply assertion-violation 'string-for-each "string arguments must all have the same length" string strings))) ends) (let loop ((i 0)) (unless (= i end) (apply proc (string-ref string i) (map (lambda (s) (string-ref s i)) strings)) (loop (+ i 1)))))))) (define map (case-lambda ((f l) (let map1 ((hare l) (tortoise l) (move? #f) (out '())) (if (pair? hare) (if move? (if (eq? tortoise hare) (scm-error 'wrong-type-arg "map" "Circular list: ~S" (list l) #f) (map1 (cdr hare) (cdr tortoise) #f (cons (f (car hare)) out))) (map1 (cdr hare) tortoise #t (cons (f (car hare)) out))) (if (null? hare) (reverse out) (scm-error 'wrong-type-arg "map" "Not a list: ~S" (list l) #f))))) ((f l1 l2) (let map2 ((h1 l1) (h2 l2) (t1 l1) (t2 l2) (move? #f) (out '())) (cond ((pair? h1) (cond ((not (pair? h2)) (scm-error 'wrong-type-arg "map" (if (list? h2) "List of wrong length: ~S" "Not a list: ~S") (list l2) #f)) ((not move?) (map2 (cdr h1) (cdr h2) t1 t2 #t (cons (f (car h1) (car h2)) out))) ((eq? t1 h1) (scm-error 'wrong-type-arg "map" "Circular list: ~S" (list l1) #f)) ((eq? t2 h2) (scm-error 'wrong-type-arg "map" "Circular list: ~S" (list l2) #f)) (else (map2 (cdr h1) (cdr h2) (cdr t1) (cdr t2) #f (cons (f (car h1) (car h2)) out))))) ((and (null? h1) (null? h2)) (reverse out)) ((null? h1) (scm-error 'wrong-type-arg "map" (if (list? h2) "List of wrong length: ~S" "Not a list: ~S") (list l2) #f)) (else (scm-error 'wrong-type-arg "map" "Not a list: ~S" (list l1) #f))))) ((f l1 . rest) (let ((len (length l1))) (let mapn ((rest rest)) (or (null? rest) (if (= (length (car rest)) len) (mapn (cdr rest)) (scm-error 'wrong-type-arg "map" "List of wrong length: ~S" (list (car rest)) #f))))) (let mapn ((l1 l1) (rest rest) (out '())) (if (null? l1) (reverse out) (mapn (cdr l1) (map cdr rest) (cons (apply f (car l1) (map car rest)) out))))))) (define log (case-lambda ((n) (log-internal n)) ((n base) (/ (log n) (log base))))) (define (boolean=? . bools) (define (boolean=?-internal lst last) (or (null? lst) (let ((bool (car lst))) (and (eqv? bool last) (boolean=?-internal (cdr lst) bool))))) (or (null? bools) (let ((bool (car bools))) (and (boolean? bool) (boolean=?-internal (cdr bools) bool))))) (define (symbol=? . syms) (define (symbol=?-internal lst last) (or (null? lst) (let ((sym (car lst))) (and (eq? sym last) (symbol=?-internal (cdr lst) sym))))) (or (null? syms) (let ((sym (car syms))) (and (symbol? sym) (symbol=?-internal (cdr syms) sym))))) (define (real-valued? x) (and (complex? x) (zero? (imag-part x)))) (define (rational-valued? x) (and (real-valued? x) (rational? (real-part x)))) (define (integer-valued? x) (and (rational-valued? x) (= x (floor (real-part x))))) (define (vector-for-each proc . vecs) (apply for-each (cons proc (map vector->list vecs)))) (define (vector-map proc . vecs) (list->vector (apply map (cons proc (map vector->list vecs))))) (define-syntax define-proxy (syntax-rules (@) ;; Define BINDING to point to (@ MODULE ORIGINAL). This hack is to ;; make sure MODULE is loaded lazily, at run-time, when BINDING is ;; encountered, rather than being loaded while compiling and ;; loading (rnrs base). ;; This avoids circular dependencies among modules and makes ;; (rnrs base) more lightweight. ((_ binding (@ module original)) (define-syntax binding (identifier-syntax (module-ref (resolve-interface 'module) 'original)))))) (define-proxy raise (@ (rnrs exceptions) raise)) (define-proxy condition (@ (rnrs conditions) condition)) (define-proxy make-error (@ (rnrs conditions) make-error)) (define-proxy make-assertion-violation (@ (rnrs conditions) make-assertion-violation)) (define-proxy make-who-condition (@ (rnrs conditions) make-who-condition)) (define-proxy make-message-condition (@ (rnrs conditions) make-message-condition)) (define-proxy make-irritants-condition (@ (rnrs conditions) make-irritants-condition)) (define (error who message . irritants) (raise (apply condition (append (list (make-error)) (if who (list (make-who-condition who)) '()) (list (make-message-condition message) (make-irritants-condition irritants)))))) (define (assertion-violation who message . irritants) (raise (apply condition (append (list (make-assertion-violation)) (if who (list (make-who-condition who)) '()) (list (make-message-condition message) (make-irritants-condition irritants)))))) (define-syntax assert (syntax-rules () ((_ expression) (or expression (raise (condition (make-assertion-violation) (make-message-condition (format #f "assertion failed: ~s" 'expression)))))))) )