diff options
Diffstat (limited to 'module/rnrs/base.scm')
-rw-r--r-- | module/rnrs/base.scm | 291 |
1 files changed, 291 insertions, 0 deletions
diff --git a/module/rnrs/base.scm b/module/rnrs/base.scm new file mode 100644 index 000000000..9fedac01d --- /dev/null +++ b/module/rnrs/base.scm @@ -0,0 +1,291 @@ +;;; 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<=? char>=? + + make-string string string-length string-ref string=? 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)))))))) + +) |