summaryrefslogtreecommitdiff
path: root/module/rnrs
diff options
context:
space:
mode:
Diffstat (limited to 'module/rnrs')
-rw-r--r--module/rnrs/arithmetic/bitwise.scm92
-rw-r--r--module/rnrs/arithmetic/fixnums.scm291
-rw-r--r--module/rnrs/arithmetic/flonums.scm203
-rw-r--r--module/rnrs/base.scm291
-rw-r--r--module/rnrs/bytevectors.scm83
-rw-r--r--module/rnrs/conditions.scm225
-rw-r--r--module/rnrs/control.scm22
-rw-r--r--module/rnrs/enums.scm152
-rw-r--r--module/rnrs/eval.scm39
-rw-r--r--module/rnrs/exceptions.scm276
-rw-r--r--module/rnrs/files.scm96
-rw-r--r--module/rnrs/hashtables.scm190
-rw-r--r--module/rnrs/io/ports.scm546
-rw-r--r--module/rnrs/io/simple.scm167
-rw-r--r--module/rnrs/lists.scm55
-rw-r--r--module/rnrs/mutable-pairs.scm23
-rw-r--r--module/rnrs/mutable-strings.scm23
-rw-r--r--module/rnrs/programs.scm22
-rw-r--r--module/rnrs/r5rs.scm34
-rw-r--r--module/rnrs/records/inspection.scm81
-rw-r--r--module/rnrs/records/procedural.scm291
-rw-r--r--module/rnrs/records/syntactic.scm248
-rw-r--r--module/rnrs/sorting.scm27
-rw-r--r--module/rnrs/syntax-case.scm68
-rw-r--r--module/rnrs/unicode.scm104
25 files changed, 3649 insertions, 0 deletions
diff --git a/module/rnrs/arithmetic/bitwise.scm b/module/rnrs/arithmetic/bitwise.scm
new file mode 100644
index 000000000..5f66cf1c1
--- /dev/null
+++ b/module/rnrs/arithmetic/bitwise.scm
@@ -0,0 +1,92 @@
+;;; bitwise.scm --- The R6RS bitwise arithmetic operations library
+
+;; Copyright (C) 2010, 2013 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 arithmetic bitwise (6))
+ (export bitwise-not
+
+ bitwise-and
+ bitwise-ior
+ bitwise-xor
+
+ bitwise-if
+ bitwise-bit-count
+ bitwise-length
+
+ bitwise-first-bit-set
+ bitwise-bit-set?
+ bitwise-copy-bit
+ bitwise-bit-field
+ bitwise-copy-bit-field
+
+ bitwise-arithmetic-shift
+ bitwise-arithmetic-shift-left
+ bitwise-arithmetic-shift-right
+ bitwise-rotate-bit-field
+ bitwise-reverse-bit-field)
+ (import (rnrs base (6))
+ (rnrs control (6))
+ (rename (only (srfi srfi-60) bitwise-if
+ integer-length
+ first-set-bit
+ copy-bit
+ bit-field
+ copy-bit-field
+ rotate-bit-field
+ reverse-bit-field)
+ (integer-length bitwise-length)
+ (first-set-bit bitwise-first-bit-set)
+ (bit-field bitwise-bit-field)
+ (reverse-bit-field bitwise-reverse-bit-field))
+ (rename (only (guile) lognot
+ logand
+ logior
+ logxor
+ logcount
+ logbit?
+ modulo
+ ash)
+ (lognot bitwise-not)
+ (logand bitwise-and)
+ (logior bitwise-ior)
+ (logxor bitwise-xor)
+ (ash bitwise-arithmetic-shift)))
+
+ (define (bitwise-bit-count ei)
+ (if (negative? ei)
+ (bitwise-not (logcount ei))
+ (logcount ei)))
+
+ (define (bitwise-bit-set? ei1 ei2) (logbit? ei2 ei1))
+
+ (define (bitwise-copy-bit ei1 ei2 ei3)
+ ;; The specification states that ei3 should be either 0 or 1.
+ ;; However, other values have been tolerated by both Guile 2.0.x and
+ ;; the sample implementation given the R6RS library document, so for
+ ;; backward compatibility we continue to permit it.
+ (copy-bit ei2 ei1 (logbit? 0 ei3)))
+
+ (define (bitwise-copy-bit-field ei1 ei2 ei3 ei4)
+ (copy-bit-field ei1 ei4 ei2 ei3))
+
+ (define (bitwise-rotate-bit-field ei1 ei2 ei3 ei4)
+ (rotate-bit-field ei1 ei4 ei2 ei3))
+
+ (define bitwise-arithmetic-shift-left bitwise-arithmetic-shift)
+ (define (bitwise-arithmetic-shift-right ei1 ei2)
+ (bitwise-arithmetic-shift ei1 (- ei2))))
diff --git a/module/rnrs/arithmetic/fixnums.scm b/module/rnrs/arithmetic/fixnums.scm
new file mode 100644
index 000000000..4ec1cae0c
--- /dev/null
+++ b/module/rnrs/arithmetic/fixnums.scm
@@ -0,0 +1,291 @@
+;;; fixnums.scm --- The R6RS fixnums arithmetic library
+
+;; Copyright (C) 2010, 2011, 2013 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 arithmetic fixnums (6))
+ (export fixnum?
+
+ fixnum-width
+ least-fixnum
+ greatest-fixnum
+
+ fx=?
+ fx>?
+ fx<?
+ fx>=?
+ fx<=?
+
+ fxzero?
+ fxpositive?
+ fxnegative?
+ fxodd?
+ fxeven?
+
+ fxmax
+ fxmin
+
+ fx+
+ fx*
+ fx-
+
+ fxdiv-and-mod
+ fxdiv
+ fxmod
+ fxdiv0-and-mod0
+ fxdiv0
+ fxmod0
+
+ fx+/carry
+ fx-/carry
+ fx*/carry
+
+ fxnot
+ fxand
+ fxior
+ fxxor
+ fxif
+
+ fxbit-count
+ fxlength
+ fxfirst-bit-set
+ fxbit-set?
+ fxcopy-bit
+ fxbit-field
+ fxcopy-bit-field
+
+ fxarithmetic-shift
+ fxarithmetic-shift-left
+ fxarithmetic-shift-right
+
+ fxrotate-bit-field
+ fxreverse-bit-field)
+ (import (only (guile) ash
+ cons*
+ define-inlinable
+ inexact->exact
+ logand
+ logbit?
+ logcount
+ logior
+ lognot
+ logxor
+ most-positive-fixnum
+ most-negative-fixnum
+ object-address)
+ (ice-9 optargs)
+ (rnrs base (6))
+ (rnrs control (6))
+ (rnrs arithmetic bitwise (6))
+ (rnrs conditions (6))
+ (rnrs exceptions (6))
+ (rnrs lists (6)))
+
+ (define fixnum-width
+ (let ((w (do ((i 0 (+ 1 i))
+ (n 1 (* 2 n)))
+ ((> n most-positive-fixnum)
+ (+ 1 i)))))
+ (lambda () w)))
+
+ (define (greatest-fixnum) most-positive-fixnum)
+ (define (least-fixnum) most-negative-fixnum)
+
+ (define (fixnum? obj)
+ (not (= 0 (logand 2 (object-address obj)))))
+
+ (define-inlinable (inline-fixnum? obj)
+ (not (= 0 (logand 2 (object-address obj)))))
+
+ (define-syntax assert-fixnum
+ (syntax-rules ()
+ ((_ arg ...)
+ (or (and (inline-fixnum? arg) ...)
+ (raise (make-assertion-violation))))))
+
+ (define (assert-fixnums args)
+ (or (for-all inline-fixnum? args) (raise (make-assertion-violation))))
+
+ (define-syntax define-fxop*
+ (syntax-rules ()
+ ((_ name op)
+ (define name
+ (case-lambda
+ ((x y)
+ (assert-fixnum x y)
+ (op x y))
+ (args
+ (assert-fixnums args)
+ (apply op args)))))))
+
+ ;; All these predicates don't check their arguments for fixnum-ness,
+ ;; as this doesn't seem to be strictly required by R6RS.
+
+ (define fx=? =)
+ (define fx>? >)
+ (define fx<? <)
+ (define fx>=? >=)
+ (define fx<=? <=)
+
+ (define fxzero? zero?)
+ (define fxpositive? positive?)
+ (define fxnegative? negative?)
+ (define fxodd? odd?)
+ (define fxeven? even?)
+
+ (define-fxop* fxmax max)
+ (define-fxop* fxmin min)
+
+ (define (fx+ fx1 fx2)
+ (assert-fixnum fx1 fx2)
+ (let ((r (+ fx1 fx2)))
+ (or (inline-fixnum? r)
+ (raise (make-implementation-restriction-violation)))
+ r))
+
+ (define (fx* fx1 fx2)
+ (assert-fixnum fx1 fx2)
+ (let ((r (* fx1 fx2)))
+ (or (inline-fixnum? r)
+ (raise (make-implementation-restriction-violation)))
+ r))
+
+ (define* (fx- fx1 #:optional fx2)
+ (assert-fixnum fx1)
+ (if fx2
+ (begin
+ (assert-fixnum fx2)
+ (let ((r (- fx1 fx2)))
+ (or (inline-fixnum? r) (raise (make-assertion-violation)))
+ r))
+ (let ((r (- fx1)))
+ (or (inline-fixnum? r) (raise (make-assertion-violation)))
+ r)))
+
+ (define (fxdiv fx1 fx2)
+ (assert-fixnum fx1 fx2)
+ (div fx1 fx2))
+
+ (define (fxmod fx1 fx2)
+ (assert-fixnum fx1 fx2)
+ (mod fx1 fx2))
+
+ (define (fxdiv-and-mod fx1 fx2)
+ (assert-fixnum fx1 fx2)
+ (div-and-mod fx1 fx2))
+
+ (define (fxdiv0 fx1 fx2)
+ (assert-fixnum fx1 fx2)
+ (div0 fx1 fx2))
+
+ (define (fxmod0 fx1 fx2)
+ (assert-fixnum fx1 fx2)
+ (mod0 fx1 fx2))
+
+ (define (fxdiv0-and-mod0 fx1 fx2)
+ (assert-fixnum fx1 fx2)
+ (div0-and-mod0 fx1 fx2))
+
+ (define (fx+/carry fx1 fx2 fx3)
+ (assert-fixnum fx1 fx2 fx3)
+ (let* ((s (+ fx1 fx2 fx3))
+ (s0 (mod0 s (expt 2 (fixnum-width))))
+ (s1 (div0 s (expt 2 (fixnum-width)))))
+ (values s0 s1)))
+
+ (define (fx-/carry fx1 fx2 fx3)
+ (assert-fixnum fx1 fx2 fx3)
+ (let* ((d (- fx1 fx2 fx3))
+ (d0 (mod0 d (expt 2 (fixnum-width))))
+ (d1 (div0 d (expt 2 (fixnum-width)))))
+ (values d0 d1)))
+
+ (define (fx*/carry fx1 fx2 fx3)
+ (assert-fixnum fx1 fx2 fx3)
+ (let* ((s (+ (* fx1 fx2) fx3))
+ (s0 (mod0 s (expt 2 (fixnum-width))))
+ (s1 (div0 s (expt 2 (fixnum-width)))))
+ (values s0 s1)))
+
+ (define (fxnot fx) (assert-fixnum fx) (lognot fx))
+ (define-fxop* fxand logand)
+ (define-fxop* fxior logior)
+ (define-fxop* fxxor logxor)
+
+ (define (fxif fx1 fx2 fx3)
+ (assert-fixnum fx1 fx2 fx3)
+ (bitwise-if fx1 fx2 fx3))
+
+ (define (fxbit-count fx)
+ (assert-fixnum fx)
+ (if (negative? fx)
+ (bitwise-not (logcount fx))
+ (logcount fx)))
+
+ (define (fxlength fx) (assert-fixnum fx) (bitwise-length fx))
+ (define (fxfirst-bit-set fx) (assert-fixnum fx) (bitwise-first-bit-set fx))
+ (define (fxbit-set? fx1 fx2) (assert-fixnum fx1 fx2) (logbit? fx2 fx1))
+
+ (define (fxcopy-bit fx1 fx2 fx3)
+ (assert-fixnum fx1 fx2 fx3)
+ (unless (and (<= 0 fx2) (< fx2 (fixnum-width)))
+ (raise (make-assertion-violation)))
+ (bitwise-copy-bit fx1 fx2 fx3))
+
+ (define (fxbit-field fx1 fx2 fx3)
+ (assert-fixnum fx1 fx2 fx3)
+ (unless (and (<= 0 fx2 fx3) (< fx3 (fixnum-width)))
+ (raise (make-assertion-violation)))
+ (bitwise-bit-field fx1 fx2 fx3))
+
+ (define (fxcopy-bit-field fx1 fx2 fx3 fx4)
+ (assert-fixnum fx1 fx2 fx3 fx4)
+ (unless (and (<= 0 fx2 fx3) (< fx3 (fixnum-width)))
+ (raise (make-assertion-violation)))
+ (bitwise-copy-bit-field fx1 fx2 fx3 fx4))
+
+ (define (fxarithmetic-shift fx1 fx2)
+ (assert-fixnum fx1 fx2)
+ (unless (< (abs fx2) (fixnum-width))
+ (raise (make-assertion-violation)))
+ (ash fx1 fx2))
+
+ (define (fxarithmetic-shift-left fx1 fx2)
+ (assert-fixnum fx1 fx2)
+ (unless (and (<= 0 fx2) (< fx2 (fixnum-width)))
+ (raise (make-assertion-violation)))
+ (ash fx1 fx2))
+
+ (define (fxarithmetic-shift-right fx1 fx2)
+ (assert-fixnum fx1 fx2)
+ (unless (and (<= 0 fx2) (< fx2 (fixnum-width)))
+ (raise (make-assertion-violation)))
+ (ash fx1 (- fx2)))
+
+ (define (fxrotate-bit-field fx1 fx2 fx3 fx4)
+ (assert-fixnum fx1 fx2 fx3 fx4)
+ (unless (and (<= 0 fx2 fx3) (< fx3 (fixnum-width)) (< fx4 (- fx3 fx2)))
+ (raise (make-assertion-violation)))
+ (bitwise-rotate-bit-field fx1 fx2 fx3 fx4))
+
+ (define (fxreverse-bit-field fx1 fx2 fx3)
+ (assert-fixnum fx1 fx2 fx3)
+ (unless (and (<= 0 fx2 fx3) (< fx3 (fixnum-width)))
+ (raise (make-assertion-violation)))
+ (bitwise-reverse-bit-field fx1 fx2 fx3))
+
+)
diff --git a/module/rnrs/arithmetic/flonums.scm b/module/rnrs/arithmetic/flonums.scm
new file mode 100644
index 000000000..e3f3ce714
--- /dev/null
+++ b/module/rnrs/arithmetic/flonums.scm
@@ -0,0 +1,203 @@
+;;; flonums.scm --- The R6RS flonums arithmetic library
+
+;; Copyright (C) 2010, 2011, 2013 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 arithmetic flonums (6))
+ (export flonum?
+ real->flonum
+
+ fl=? fl<? fl<=? fl>? fl>=?
+
+ flinteger? flzero? flpositive? flnegative? flodd? fleven? flfinite?
+ flinfinite? flnan?
+
+ flmax flmin
+
+ fl+ fl* fl- fl/
+
+ flabs
+
+ fldiv-and-mod
+ fldiv
+ flmod
+ fldiv0-and-mod0
+ fldiv0
+ flmod0
+
+ flnumerator
+ fldenominator
+
+ flfloor flceiling fltruncate flround
+
+ flexp fllog flsin flcos fltan flacos flasin flatan
+
+ flsqrt flexpt
+
+ &no-infinities
+ make-no-infinities-violation
+ no-infinities-violation?
+
+ &no-nans
+ make-no-nans-violation
+ no-nans-violation?
+
+ fixnum->flonum)
+ (import (ice-9 optargs)
+ (only (guile) inf?)
+ (rnrs arithmetic fixnums (6))
+ (rnrs base (6))
+ (rnrs control (6))
+ (rnrs conditions (6))
+ (rnrs exceptions (6))
+ (rnrs lists (6))
+ (rnrs r5rs (6)))
+
+ (define (flonum? obj) (and (real? obj) (inexact? obj)))
+ (define (assert-flonum . args)
+ (or (for-all flonum? args) (raise (make-assertion-violation))))
+ (define (assert-iflonum . args)
+ (or (for-all (lambda (i) (and (flonum? i) (integer? i))) args)
+ (raise (make-assertion-violation))))
+
+ (define (ensure-flonum z)
+ (cond ((real? z) z)
+ ((zero? (imag-part z)) (real-part z))
+ (else +nan.0)))
+
+ (define (real->flonum x)
+ (or (real? x) (raise (make-assertion-violation)))
+ (exact->inexact x))
+
+ (define (fl=? . args) (apply assert-flonum args) (apply = args))
+ (define (fl<? . args) (apply assert-flonum args) (apply < args))
+ (define (fl<=? . args) (apply assert-flonum args) (apply <= args))
+ (define (fl>? . args) (apply assert-flonum args) (apply > args))
+ (define (fl>=? . args) (apply assert-flonum args) (apply >= args))
+
+ (define (flinteger? fl) (assert-flonum fl) (integer? fl))
+ (define (flzero? fl) (assert-flonum fl) (zero? fl))
+ (define (flpositive? fl) (assert-flonum fl) (positive? fl))
+ (define (flnegative? fl) (assert-flonum fl) (negative? fl))
+ (define (flodd? ifl) (assert-iflonum ifl) (odd? ifl))
+ (define (fleven? ifl) (assert-iflonum ifl) (even? ifl))
+ (define (flfinite? fl) (assert-flonum fl) (not (or (inf? fl) (nan? fl))))
+ (define (flinfinite? fl) (assert-flonum fl) (inf? fl))
+ (define (flnan? fl) (assert-flonum fl) (nan? fl))
+
+ (define (flmax fl1 . args)
+ (let ((flargs (cons fl1 args)))
+ (apply assert-flonum flargs)
+ (apply max flargs)))
+
+ (define (flmin fl1 . args)
+ (let ((flargs (cons fl1 args)))
+ (apply assert-flonum flargs)
+ (apply min flargs)))
+
+ (define (fl+ . args)
+ (apply assert-flonum args)
+ (if (null? args) 0.0 (apply + args)))
+
+ (define (fl* . args)
+ (apply assert-flonum args)
+ (if (null? args) 1.0 (apply * args)))
+
+ (define (fl- fl1 . args)
+ (let ((flargs (cons fl1 args)))
+ (apply assert-flonum flargs)
+ (apply - flargs)))
+
+ (define (fl/ fl1 . args)
+ (let ((flargs (cons fl1 args)))
+ (apply assert-flonum flargs)
+ (apply / flargs)))
+
+ (define (flabs fl) (assert-flonum fl) (abs fl))
+
+ (define (fldiv-and-mod fl1 fl2)
+ (assert-iflonum fl1 fl2)
+ (div-and-mod fl1 fl2))
+
+ (define (fldiv fl1 fl2)
+ (assert-iflonum fl1 fl2)
+ (div fl1 fl2))
+
+ (define (flmod fl1 fl2)
+ (assert-iflonum fl1 fl2)
+ (mod fl1 fl2))
+
+ (define (fldiv0-and-mod0 fl1 fl2)
+ (assert-iflonum fl1 fl2)
+ (div0-and-mod0 fl1 fl2))
+
+ (define (fldiv0 fl1 fl2)
+ (assert-iflonum fl1 fl2)
+ (div0 fl1 fl2))
+
+ (define (flmod0 fl1 fl2)
+ (assert-iflonum fl1 fl2)
+ (mod0 fl1 fl2))
+
+ (define (flnumerator fl) (assert-flonum fl) (numerator fl))
+ (define (fldenominator fl) (assert-flonum fl) (denominator fl))
+
+ (define (flfloor fl) (assert-flonum fl) (floor fl))
+ (define (flceiling fl) (assert-flonum fl) (ceiling fl))
+ (define (fltruncate fl) (assert-flonum fl) (truncate fl))
+ (define (flround fl) (assert-flonum fl) (round fl))
+
+ (define (flexp fl) (assert-flonum fl) (exp fl))
+ (define fllog
+ (case-lambda
+ ((fl)
+ (assert-flonum fl)
+ ;; add 0.0 to fl, to change -0.0 to 0.0,
+ ;; so that (fllog -0.0) will be -inf.0, not -inf.0+pi*i.
+ (ensure-flonum (log (+ fl 0.0))))
+ ((fl fl2)
+ (assert-flonum fl fl2)
+ (ensure-flonum (/ (log (+ fl 0.0))
+ (log (+ fl2 0.0)))))))
+
+ (define (flsin fl) (assert-flonum fl) (sin fl))
+ (define (flcos fl) (assert-flonum fl) (cos fl))
+ (define (fltan fl) (assert-flonum fl) (tan fl))
+ (define (flasin fl) (assert-flonum fl) (ensure-flonum (asin fl)))
+ (define (flacos fl) (assert-flonum fl) (ensure-flonum (acos fl)))
+ (define flatan
+ (case-lambda
+ ((fl) (assert-flonum fl) (atan fl))
+ ((fl fl2) (assert-flonum fl fl2) (atan fl fl2))))
+
+ (define (flsqrt fl) (assert-flonum fl) (ensure-flonum (sqrt fl)))
+ (define (flexpt fl1 fl2) (assert-flonum fl1 fl2) (ensure-flonum (expt fl1 fl2)))
+
+ (define-condition-type &no-infinities
+ &implementation-restriction
+ make-no-infinities-violation
+ no-infinities-violation?)
+
+ (define-condition-type &no-nans
+ &implementation-restriction
+ make-no-nans-violation
+ no-nans-violation?)
+
+ (define (fixnum->flonum fx)
+ (or (fixnum? fx) (raise (make-assertion-violation)))
+ (exact->inexact fx))
+)
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))))))))
+
+)
diff --git a/module/rnrs/bytevectors.scm b/module/rnrs/bytevectors.scm
new file mode 100644
index 000000000..9744359f0
--- /dev/null
+++ b/module/rnrs/bytevectors.scm
@@ -0,0 +1,83 @@
+;;;; bytevectors.scm --- R6RS bytevector API -*- coding: utf-8 -*-
+
+;;;; Copyright (C) 2009, 2010 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
+
+;;; Author: Ludovic Courtès <ludo@gnu.org>
+
+;;; Commentary:
+;;;
+;;; A "bytevector" is a raw bit string. This module provides procedures to
+;;; manipulate bytevectors and interpret their contents in a number of ways:
+;;; bytevector contents can be accessed as signed or unsigned integer of
+;;; various sizes and endianness, as IEEE-754 floating point numbers, or as
+;;; strings. It is a useful tool to decode binary data.
+;;;
+;;; Code:
+
+(define-module (rnrs bytevectors)
+ #:version (6)
+ #:export-syntax (endianness)
+ #:export (native-endianness bytevector?
+ make-bytevector bytevector-length bytevector=? bytevector-fill!
+ bytevector-copy! bytevector-copy
+ uniform-array->bytevector
+ bytevector-u8-ref bytevector-s8-ref
+ bytevector-u8-set! bytevector-s8-set! bytevector->u8-list
+ u8-list->bytevector
+ bytevector-uint-ref bytevector-uint-set!
+ bytevector-sint-ref bytevector-sint-set!
+ bytevector->sint-list bytevector->uint-list
+ uint-list->bytevector sint-list->bytevector
+
+ bytevector-u16-ref bytevector-s16-ref
+ bytevector-u16-set! bytevector-s16-set!
+ bytevector-u16-native-ref bytevector-s16-native-ref
+ bytevector-u16-native-set! bytevector-s16-native-set!
+
+ bytevector-u32-ref bytevector-s32-ref
+ bytevector-u32-set! bytevector-s32-set!
+ bytevector-u32-native-ref bytevector-s32-native-ref
+ bytevector-u32-native-set! bytevector-s32-native-set!
+
+ bytevector-u64-ref bytevector-s64-ref
+ bytevector-u64-set! bytevector-s64-set!
+ bytevector-u64-native-ref bytevector-s64-native-ref
+ bytevector-u64-native-set! bytevector-s64-native-set!
+
+ bytevector-ieee-single-ref
+ bytevector-ieee-single-set!
+ bytevector-ieee-single-native-ref
+ bytevector-ieee-single-native-set!
+
+ bytevector-ieee-double-ref
+ bytevector-ieee-double-set!
+ bytevector-ieee-double-native-ref
+ bytevector-ieee-double-native-set!
+
+ string->utf8 string->utf16 string->utf32
+ utf8->string utf16->string utf32->string))
+
+
+(load-extension (string-append "libguile-" (effective-version))
+ "scm_init_bytevectors")
+
+(define-macro (endianness sym)
+ (if (memq sym '(big little))
+ `(quote ,sym)
+ (error "unsupported endianness" sym)))
+
+;;; bytevector.scm ends here
diff --git a/module/rnrs/conditions.scm b/module/rnrs/conditions.scm
new file mode 100644
index 000000000..959411b9e
--- /dev/null
+++ b/module/rnrs/conditions.scm
@@ -0,0 +1,225 @@
+;;; conditions.scm --- The R6RS conditions library
+
+;; Copyright (C) 2010 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 conditions (6))
+ (export &condition
+ condition
+ simple-conditions
+ condition?
+ condition-predicate
+ condition-accessor
+ define-condition-type
+
+ &message
+ make-message-condition
+ message-condition?
+ condition-message
+
+ &warning
+ make-warning
+ warning?
+
+ &serious
+ make-serious-condition
+ serious-condition?
+
+ &error
+ make-error
+ error?
+
+ &violation
+ make-violation
+ violation?
+
+ &assertion
+ make-assertion-violation
+ assertion-violation?
+
+ &irritants
+ make-irritants-condition
+ irritants-condition?
+ condition-irritants
+
+ &who
+ make-who-condition
+ who-condition?
+ condition-who
+
+ &non-continuable
+ make-non-continuable-violation
+ non-continuable-violation?
+
+ &implementation-restriction
+ make-implementation-restriction-violation
+ implementation-restriction-violation?
+
+ &lexical
+ make-lexical-violation
+ lexical-violation?
+
+ &syntax
+ make-syntax-violation
+ syntax-violation?
+ syntax-violation-form
+ syntax-violation-subform
+
+ &undefined
+ make-undefined-violation
+ undefined-violation?)
+ (import (only (guile) and=> @@)
+ (rnrs base (6))
+ (rnrs lists (6))
+ (rnrs records procedural (6)))
+
+ (define &compound-condition (make-record-type-descriptor
+ '&compound-condition #f #f #f #f
+ '#((immutable components))))
+ (define compound-condition? (record-predicate &compound-condition))
+
+ (define make-compound-condition
+ (record-constructor (make-record-constructor-descriptor
+ &compound-condition #f #f)))
+ (define simple-conditions
+ (let ((compound-ref (record-accessor &compound-condition 0)))
+ (lambda (condition)
+ (cond ((compound-condition? condition)
+ (compound-ref condition))
+ ((condition-internal? condition)
+ (list condition))
+ (else
+ (assertion-violation 'simple-conditions
+ "not a condition"
+ condition))))))
+
+ (define (condition? obj)
+ (or (compound-condition? obj) (condition-internal? obj)))
+
+ (define condition
+ (lambda conditions
+ (define (flatten cond)
+ (if (compound-condition? cond) (simple-conditions cond) (list cond)))
+ (or (for-all condition? conditions)
+ (assertion-violation 'condition "non-condition argument" conditions))
+ (if (or (null? conditions) (> (length conditions) 1))
+ (make-compound-condition (apply append (map flatten conditions)))
+ (car conditions))))
+
+ (define-syntax define-condition-type
+ (syntax-rules ()
+ ((_ condition-type supertype constructor predicate
+ (field accessor) ...)
+ (letrec-syntax
+ ((transform-fields
+ (syntax-rules ()
+ ((_ (f a) . rest)
+ (cons '(immutable f a) (transform-fields . rest)))
+ ((_) '())))
+
+ (generate-accessors
+ (syntax-rules ()
+ ((_ counter (f a) . rest)
+ (begin (define a
+ (condition-accessor
+ condition-type
+ (record-accessor condition-type counter)))
+ (generate-accessors (+ counter 1) . rest)))
+ ((_ counter) (begin)))))
+ (begin
+ (define condition-type
+ (make-record-type-descriptor
+ 'condition-type supertype #f #f #f
+ (list->vector (transform-fields (field accessor) ...))))
+ (define constructor
+ (record-constructor
+ (make-record-constructor-descriptor condition-type #f #f)))
+ (define predicate (condition-predicate condition-type))
+ (generate-accessors 0 (field accessor) ...))))))
+
+ (define &condition (@@ (rnrs records procedural) &condition))
+ (define &condition-constructor-descriptor
+ (make-record-constructor-descriptor &condition #f #f))
+ (define condition-internal? (record-predicate &condition))
+
+ (define (condition-predicate rtd)
+ (let ((rtd-predicate (record-predicate rtd)))
+ (lambda (obj)
+ (cond ((compound-condition? obj)
+ (exists rtd-predicate (simple-conditions obj)))
+ ((condition-internal? obj) (rtd-predicate obj))
+ (else #f)))))
+
+ (define (condition-accessor rtd proc)
+ (let ((rtd-predicate (record-predicate rtd)))
+ (lambda (obj)
+ (cond ((rtd-predicate obj) (proc obj))
+ ((compound-condition? obj)
+ (and=> (find rtd-predicate (simple-conditions obj)) proc))
+ (else #f)))))
+
+ (define-condition-type &message &condition
+ make-message-condition message-condition?
+ (message condition-message))
+
+ (define-condition-type &warning &condition make-warning warning?)
+
+ (define &serious (@@ (rnrs records procedural) &serious))
+ (define make-serious-condition
+ (@@ (rnrs records procedural) make-serious-condition))
+ (define serious-condition? (condition-predicate &serious))
+
+ (define-condition-type &error &serious make-error error?)
+
+ (define &violation (@@ (rnrs records procedural) &violation))
+ (define make-violation (@@ (rnrs records procedural) make-violation))
+ (define violation? (condition-predicate &violation))
+
+ (define &assertion (@@ (rnrs records procedural) &assertion))
+ (define make-assertion-violation
+ (@@ (rnrs records procedural) make-assertion-violation))
+ (define assertion-violation? (condition-predicate &assertion))
+
+ (define-condition-type &irritants &condition
+ make-irritants-condition irritants-condition?
+ (irritants condition-irritants))
+
+ (define-condition-type &who &condition
+ make-who-condition who-condition?
+ (who condition-who))
+
+ (define-condition-type &non-continuable &violation
+ make-non-continuable-violation
+ non-continuable-violation?)
+
+ (define-condition-type &implementation-restriction
+ &violation
+ make-implementation-restriction-violation
+ implementation-restriction-violation?)
+
+ (define-condition-type &lexical &violation
+ make-lexical-violation lexical-violation?)
+
+ (define-condition-type &syntax &violation
+ make-syntax-violation syntax-violation?
+ (form syntax-violation-form)
+ (subform syntax-violation-subform))
+
+ (define-condition-type &undefined &violation
+ make-undefined-violation undefined-violation?)
+
+)
diff --git a/module/rnrs/control.scm b/module/rnrs/control.scm
new file mode 100644
index 000000000..25ffa3eec
--- /dev/null
+++ b/module/rnrs/control.scm
@@ -0,0 +1,22 @@
+;;; control.scm --- The R6RS control structures library
+
+;; Copyright (C) 2010, 2012 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 control (6))
+ (export when unless do case-lambda)
+ (import (only (guile) when unless do case-lambda)))
diff --git a/module/rnrs/enums.scm b/module/rnrs/enums.scm
new file mode 100644
index 000000000..e97be46e3
--- /dev/null
+++ b/module/rnrs/enums.scm
@@ -0,0 +1,152 @@
+;;; enums.scm --- The R6RS enumerations library
+
+;; Copyright (C) 2010 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 enums (6))
+ (export make-enumeration enum-set-universe enum-set-indexer
+ enum-set-constructor enum-set->list enum-set-member? enum-set-subset?
+ enum-set=? enum-set-union enum-set-intersection enum-set-difference
+ enum-set-complement enum-set-projection define-enumeration)
+ (import (only (guile) and=>)
+ (rnrs base (6))
+ (rnrs conditions (6))
+ (rnrs exceptions (6))
+ (rnrs records procedural (6))
+ (rnrs syntax-case (6))
+ (srfi :1))
+
+ (define enum-set-rtd (make-record-type-descriptor
+ 'enum-set #f #f #f #f '#((mutable universe)
+ (immutable set))))
+
+ (define make-enum-set
+ (record-constructor
+ (make-record-constructor-descriptor enum-set-rtd #f #f)))
+
+ (define enum-set-universe-internal (record-accessor enum-set-rtd 0))
+ (define enum-set-universe-set! (record-mutator enum-set-rtd 0))
+
+ (define enum-set-set (record-accessor enum-set-rtd 1))
+
+ (define (make-enumeration symbol-list)
+ (let ((es (make-enum-set #f symbol-list)))
+ (enum-set-universe-set! es es)))
+
+ (define (enum-set-universe enum-set)
+ (or (enum-set-universe-internal enum-set)
+ enum-set))
+
+ (define (enum-set-indexer enum-set)
+ (let* ((symbols (enum-set->list (enum-set-universe enum-set)))
+ (cardinality (length symbols)))
+ (lambda (x)
+ (and=> (memq x symbols)
+ (lambda (probe) (- cardinality (length probe)))))))
+
+ (define (enum-set-constructor enum-set)
+ (lambda (symbol-list)
+ (make-enum-set (enum-set-universe enum-set)
+ (list-copy symbol-list))))
+
+ (define (enum-set->list enum-set)
+ (lset-intersection eq?
+ (enum-set-set (enum-set-universe enum-set))
+ (enum-set-set enum-set)))
+
+ (define (enum-set-member? symbol enum-set)
+ (and (memq symbol (enum-set-set enum-set)) #t))
+
+ (define (enum-set-subset? enum-set-1 enum-set-2)
+ (and (lset<= eq?
+ (enum-set-set (enum-set-universe enum-set-1))
+ (enum-set-set (enum-set-universe enum-set-2)))
+ (lset<= eq? (enum-set-set enum-set-1) (enum-set-set enum-set-2))))
+
+ (define (enum-set=? enum-set-1 enum-set-2)
+ (and (enum-set-subset? enum-set-1 enum-set-2)
+ (enum-set-subset? enum-set-2 enum-set-1)))
+
+ (define (enum-set-union enum-set-1 enum-set-2)
+ (if (equal? (enum-set-universe enum-set-1)
+ (enum-set-universe enum-set-2))
+ (make-enum-set (enum-set-universe enum-set-1)
+ (lset-union eq?
+ (enum-set-set enum-set-1)
+ (enum-set-set enum-set-2)))
+ (raise (make-assertion-violation))))
+
+ (define (enum-set-intersection enum-set-1 enum-set-2)
+ (if (equal? (enum-set-universe enum-set-1)
+ (enum-set-universe enum-set-2))
+ (make-enum-set (enum-set-universe enum-set-1)
+ (lset-intersection eq?
+ (enum-set-set enum-set-1)
+ (enum-set-set enum-set-2)))
+ (raise (make-assertion-violation))))
+
+ (define (enum-set-difference enum-set-1 enum-set-2)
+ (if (equal? (enum-set-universe enum-set-1)
+ (enum-set-universe enum-set-2))
+ (make-enum-set (enum-set-universe enum-set-1)
+ (lset-difference eq?
+ (enum-set-set enum-set-1)
+ (enum-set-set enum-set-2)))
+ (raise (make-assertion-violation))))
+
+ (define (enum-set-complement enum-set)
+ (let ((universe (enum-set-universe enum-set)))
+ (make-enum-set universe
+ (lset-difference
+ eq? (enum-set->list universe) (enum-set-set enum-set)))))
+
+ (define (enum-set-projection enum-set-1 enum-set-2)
+ (make-enum-set (enum-set-universe enum-set-2)
+ (lset-intersection eq?
+ (enum-set-set enum-set-1)
+ (enum-set->list
+ (enum-set-universe enum-set-2)))))
+
+ (define-syntax define-enumeration
+ (syntax-rules ()
+ ((_ type-name (symbol ...) constructor-syntax)
+ (begin
+ (define-syntax type-name
+ (lambda (s)
+ (syntax-case s ()
+ ((type-name sym)
+ (if (memq (syntax->datum #'sym) '(symbol ...))
+ #'(quote sym)
+ (syntax-violation (symbol->string 'type-name)
+ "not a member of the set"
+ #f))))))
+ (define-syntax constructor-syntax
+ (lambda (s)
+ (syntax-case s ()
+ ((_ sym (... ...))
+ (let* ((universe '(symbol ...))
+ (syms (syntax->datum #'(sym (... ...))))
+ (quoted-universe
+ (datum->syntax s (list 'quote universe)))
+ (quoted-syms (datum->syntax s (list 'quote syms))))
+ (or (every (lambda (x) (memq x universe)) syms)
+ (syntax-violation (symbol->string 'constructor-syntax)
+ "not a subset of the universe"
+ #f))
+ #`((enum-set-constructor (make-enumeration #,quoted-universe))
+ #,quoted-syms))))))))))
+)
diff --git a/module/rnrs/eval.scm b/module/rnrs/eval.scm
new file mode 100644
index 000000000..d58f87768
--- /dev/null
+++ b/module/rnrs/eval.scm
@@ -0,0 +1,39 @@
+;;; eval.scm --- The R6RS `eval' library
+
+;; Copyright (C) 2010 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 eval (6))
+ (export eval environment)
+ (import (only (guile) eval
+ make-module
+ module-uses
+ beautify-user-module!
+ set-module-uses!)
+ (rnrs base (6))
+ (rnrs io simple (6))
+ (rnrs lists (6)))
+
+ (define (environment . import-specs)
+ (let ((module (make-module))
+ (needs-purify? (not (member '(guile) import-specs))))
+ (beautify-user-module! module)
+ (for-each (lambda (import-spec) (eval (list 'import import-spec) module))
+ import-specs)
+ (if needs-purify? (set-module-uses! module (cdr (module-uses module))))
+ module))
+)
diff --git a/module/rnrs/exceptions.scm b/module/rnrs/exceptions.scm
new file mode 100644
index 000000000..52f5c257f
--- /dev/null
+++ b/module/rnrs/exceptions.scm
@@ -0,0 +1,276 @@
+;;; exceptions.scm --- The R6RS exceptions library
+
+;; Copyright (C) 2010, 2011, 2013 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 exceptions (6))
+ (export guard with-exception-handler raise raise-continuable)
+ (import (rnrs base (6))
+ (rnrs control (6))
+ (rnrs conditions (6))
+ (rnrs records procedural (6))
+ (rnrs records inspection (6))
+ (only (guile)
+ format
+ newline
+ display
+ filter
+ acons
+ assv-ref
+ throw
+ set-exception-printer!
+ with-throw-handler
+ *unspecified*
+ @@))
+
+ ;; When a native guile exception is caught by an R6RS exception
+ ;; handler, we convert it to an R6RS compound condition that includes
+ ;; not only the standard condition objects expected by R6RS code, but
+ ;; also a special &guile condition that preserves the original KEY and
+ ;; ARGS passed to the native Guile catch handler.
+
+ (define-condition-type &guile &condition
+ make-guile-condition guile-condition?
+ (key guile-condition-key)
+ (args guile-condition-args))
+
+ (define (default-guile-condition-converter key args)
+ (condition (make-serious-condition)
+ (guile-common-conditions key args)))
+
+ (define (guile-common-conditions key args)
+ (apply (case-lambda
+ ((subr msg margs . _)
+ (condition (make-who-condition subr)
+ (make-message-condition msg)
+ (make-irritants-condition margs)))
+ (_ (make-irritants-condition args)))
+ args))
+
+ (define (convert-guile-condition key args)
+ (let ((converter (assv-ref guile-condition-converters key)))
+ (condition (or (and converter (converter key args))
+ (default-guile-condition-converter key args))
+ ;; Preserve the original KEY and ARGS in the R6RS
+ ;; condition object.
+ (make-guile-condition key args))))
+
+ ;; If an R6RS exception handler chooses not to handle a given
+ ;; condition, it will re-raise the condition to pass it on to the next
+ ;; handler. If the condition was converted from a native Guile
+ ;; exception, we must re-raise using the native Guile facilities and
+ ;; the original exception KEY and ARGS. We arrange for this in
+ ;; 'raise' so that native Guile exception handlers will continue to
+ ;; work when mixed with R6RS code.
+
+ (define (raise obj)
+ (if (guile-condition? obj)
+ (apply throw (guile-condition-key obj) (guile-condition-args obj))
+ ((@@ (rnrs records procedural) r6rs-raise) obj)))
+ (define raise-continuable
+ (@@ (rnrs records procedural) r6rs-raise-continuable))
+
+ (define raise-object-wrapper?
+ (@@ (rnrs records procedural) raise-object-wrapper?))
+ (define raise-object-wrapper-obj
+ (@@ (rnrs records procedural) raise-object-wrapper-obj))
+ (define raise-object-wrapper-continuation
+ (@@ (rnrs records procedural) raise-object-wrapper-continuation))
+
+ (define (with-exception-handler handler thunk)
+ (with-throw-handler #t
+ thunk
+ (lambda (key . args)
+ (cond ((not (eq? key 'r6rs:exception))
+ (let ((obj (convert-guile-condition key args)))
+ (handler obj)
+ (raise (make-non-continuable-violation))))
+ ((and (not (null? args))
+ (raise-object-wrapper? (car args)))
+ (let* ((cargs (car args))
+ (obj (raise-object-wrapper-obj cargs))
+ (continuation (raise-object-wrapper-continuation cargs))
+ (handler-return (handler obj)))
+ (if continuation
+ (continuation handler-return)
+ (raise (make-non-continuable-violation)))))))))
+
+ (define-syntax guard0
+ (syntax-rules ()
+ ((_ (variable cond-clause ...) . body)
+ (call/cc (lambda (continuation)
+ (with-exception-handler
+ (lambda (variable)
+ (continuation (cond cond-clause ...)))
+ (lambda () . body)))))))
+
+ (define-syntax guard
+ (syntax-rules (else)
+ ((_ (variable cond-clause ... . ((else else-clause ...))) . body)
+ (guard0 (variable cond-clause ... (else else-clause ...)) . body))
+ ((_ (variable cond-clause ...) . body)
+ (guard0 (variable cond-clause ... (else (raise variable))) . body))))
+
+ ;;; Exception printing
+
+ (define (exception-printer port key args punt)
+ (cond ((and (= 1 (length args))
+ (raise-object-wrapper? (car args)))
+ (let ((obj (raise-object-wrapper-obj (car args))))
+ (cond ((condition? obj)
+ (display "ERROR: R6RS exception:\n" port)
+ (format-condition port obj))
+ (else
+ (format port "ERROR: R6RS exception: `~s'" obj)))))
+ (else
+ (punt))))
+
+ (define (format-condition port condition)
+ (let ((components (simple-conditions condition)))
+ (if (null? components)
+ (format port "Empty condition object")
+ (let loop ((i 1) (components components))
+ (cond ((pair? components)
+ (format port " ~a. " i)
+ (format-simple-condition port (car components))
+ (when (pair? (cdr components))
+ (newline port))
+ (loop (+ i 1) (cdr components))))))))
+
+ (define (format-simple-condition port condition)
+ (define (print-rtd-fields rtd field-names)
+ (let ((n-fields (vector-length field-names)))
+ (do ((i 0 (+ i 1)))
+ ((>= i n-fields))
+ (format port " ~a: ~s"
+ (vector-ref field-names i)
+ ((record-accessor rtd i) condition))
+ (unless (= i (- n-fields 1))
+ (newline port)))))
+ (let ((condition-name (record-type-name (record-rtd condition))))
+ (let loop ((rtd (record-rtd condition))
+ (rtd.fields-list '())
+ (n-fields 0))
+ (cond (rtd
+ (let ((field-names (record-type-field-names rtd)))
+ (loop (record-type-parent rtd)
+ (cons (cons rtd field-names) rtd.fields-list)
+ (+ n-fields (vector-length field-names)))))
+ (else
+ (let ((rtd.fields-list
+ (filter (lambda (rtd.fields)
+ (not (zero? (vector-length (cdr rtd.fields)))))
+ (reverse rtd.fields-list))))
+ (case n-fields
+ ((0) (format port "~a" condition-name))
+ ((1) (format port "~a: ~s"
+ condition-name
+ ((record-accessor (caar rtd.fields-list) 0)
+ condition)))
+ (else
+ (format port "~a:\n" condition-name)
+ (let loop ((lst rtd.fields-list))
+ (when (pair? lst)
+ (let ((rtd.fields (car lst)))
+ (print-rtd-fields (car rtd.fields) (cdr rtd.fields))
+ (when (pair? (cdr lst))
+ (newline port))
+ (loop (cdr lst)))))))))))))
+
+ (set-exception-printer! 'r6rs:exception exception-printer)
+
+ ;; Guile condition converters
+ ;;
+ ;; Each converter is a procedure (converter KEY ARGS) that returns
+ ;; either an R6RS condition or #f. If #f is returned,
+ ;; 'default-guile-condition-converter' will be used.
+
+ (define (guile-syntax-violation-converter key args)
+ (apply (case-lambda
+ ((who what where form subform . extra)
+ (condition (make-syntax-violation form subform)
+ (make-who-condition who)
+ (make-message-condition what)))
+ (_ #f))
+ args))
+
+ (define (guile-lexical-violation-converter key args)
+ (condition (make-lexical-violation) (guile-common-conditions key args)))
+
+ (define (guile-assertion-violation-converter key args)
+ (condition (make-assertion-violation) (guile-common-conditions key args)))
+
+ (define (guile-undefined-violation-converter key args)
+ (condition (make-undefined-violation) (guile-common-conditions key args)))
+
+ (define (guile-implementation-restriction-converter key args)
+ (condition (make-implementation-restriction-violation)
+ (guile-common-conditions key args)))
+
+ (define (guile-error-converter key args)
+ (condition (make-error) (guile-common-conditions key args)))
+
+ (define (guile-system-error-converter key args)
+ (apply (case-lambda
+ ((subr msg msg-args errno . rest)
+ ;; XXX TODO we should return a more specific error
+ ;; (usually an I/O error) as expected by R6RS programs.
+ ;; Unfortunately this often requires the 'filename' (or
+ ;; other?) which is not currently provided by the native
+ ;; Guile exceptions.
+ (condition (make-error) (guile-common-conditions key args)))
+ (_ (guile-error-converter key args)))
+ args))
+
+ ;; TODO: Arrange to have the needed information included in native
+ ;; Guile I/O exceptions, and arrange here to convert them to the
+ ;; proper conditions. Remove the earlier exception conversion
+ ;; mechanism: search for 'with-throw-handler' in the 'rnrs'
+ ;; tree, e.g. 'with-i/o-filename-conditions' and
+ ;; 'with-i/o-port-error' in (rnrs io ports).
+
+ ;; XXX TODO: How should we handle the 'misc-error', 'vm-error', and
+ ;; 'signal' native Guile exceptions?
+
+ ;; XXX TODO: Should we handle the 'quit' exception specially?
+
+ ;; An alist mapping native Guile exception keys to converters.
+ (define guile-condition-converters
+ `((read-error . ,guile-lexical-violation-converter)
+ (syntax-error . ,guile-syntax-violation-converter)
+ (unbound-variable . ,guile-undefined-violation-converter)
+ (wrong-number-of-args . ,guile-assertion-violation-converter)
+ (wrong-type-arg . ,guile-assertion-violation-converter)
+ (keyword-argument-error . ,guile-assertion-violation-converter)
+ (out-of-range . ,guile-assertion-violation-converter)
+ (regular-expression-syntax . ,guile-assertion-violation-converter)
+ (program-error . ,guile-assertion-violation-converter)
+ (goops-error . ,guile-assertion-violation-converter)
+ (null-pointer-error . ,guile-assertion-violation-converter)
+ (system-error . ,guile-system-error-converter)
+ (host-not-found . ,guile-error-converter)
+ (getaddrinfo-error . ,guile-error-converter)
+ (no-data . ,guile-error-converter)
+ (no-recovery . ,guile-error-converter)
+ (try-again . ,guile-error-converter)
+ (stack-overflow . ,guile-implementation-restriction-converter)
+ (numerical-overflow . ,guile-implementation-restriction-converter)
+ (memory-allocation-error . ,guile-implementation-restriction-converter)))
+
+ (define (set-guile-condition-converter! key proc)
+ (set! guile-condition-converters
+ (acons key proc guile-condition-converters))))
diff --git a/module/rnrs/files.scm b/module/rnrs/files.scm
new file mode 100644
index 000000000..447b8b3a4
--- /dev/null
+++ b/module/rnrs/files.scm
@@ -0,0 +1,96 @@
+;;; files.scm --- The R6RS file system library
+
+;; Copyright (C) 2010 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 files (6))
+ (export file-exists?
+ delete-file
+
+ &i/o make-i/o-error i/o-error?
+ &i/o-read make-i/o-read-error i/o-read-error?
+ &i/o-write make-i/o-write-error i/o-write-error?
+
+ &i/o-invalid-position
+ make-i/o-invalid-position-error
+ i/o-invalid-position-error?
+ i/o-error-position
+
+ &i/o-filename
+ make-i/o-filename-error
+ i/o-filename-error?
+ i/o-error-filename
+
+ &i/o-file-protection
+ make-i/o-file-protection-error
+ i/o-file-protection-error?
+
+ &i/o-file-is-read-only
+ make-i/o-file-is-read-only-error
+ i/o-file-is-read-only-error?
+
+ &i/o-file-already-exists
+ make-i/o-file-already-exists-error
+ i/o-file-already-exists-error?
+
+ &i/o-file-does-not-exist
+ make-i/o-file-does-not-exist-error
+ i/o-file-does-not-exist-error?
+
+ &i/o-port
+ make-i/o-port-error
+ i/o-port-error?
+ i/o-error-port)
+
+ (import (rename (only (guile) file-exists? delete-file catch @@)
+ (delete-file delete-file-internal))
+ (rnrs base (6))
+ (rnrs conditions (6))
+ (rnrs exceptions (6)))
+
+ (define (delete-file filename)
+ (catch #t
+ (lambda () (delete-file-internal filename))
+ (lambda (key . args) (raise (make-i/o-filename-error filename)))))
+
+ ;; Condition types that are used by (rnrs files), (rnrs io ports), and
+ ;; (rnrs io simple). These are defined here so as to be easily shareable by
+ ;; these three libraries.
+
+ (define-condition-type &i/o &error make-i/o-error i/o-error?)
+ (define-condition-type &i/o-read &i/o make-i/o-read-error i/o-read-error?)
+ (define-condition-type &i/o-write &i/o make-i/o-write-error i/o-write-error?)
+ (define-condition-type &i/o-invalid-position
+ &i/o make-i/o-invalid-position-error i/o-invalid-position-error?
+ (position i/o-error-position))
+ (define-condition-type &i/o-filename
+ &i/o make-i/o-filename-error i/o-filename-error?
+ (filename i/o-error-filename))
+ (define-condition-type &i/o-file-protection
+ &i/o-filename make-i/o-file-protection-error i/o-file-protection-error?)
+ (define-condition-type &i/o-file-is-read-only
+ &i/o-file-protection make-i/o-file-is-read-only-error
+ i/o-file-is-read-only-error?)
+ (define-condition-type &i/o-file-already-exists
+ &i/o-filename make-i/o-file-already-exists-error
+ i/o-file-already-exists-error?)
+ (define-condition-type &i/o-file-does-not-exist
+ &i/o-filename make-i/o-file-does-not-exist-error
+ i/o-file-does-not-exist-error?)
+ (define-condition-type &i/o-port &i/o make-i/o-port-error i/o-port-error?
+ (port i/o-error-port))
+)
diff --git a/module/rnrs/hashtables.scm b/module/rnrs/hashtables.scm
new file mode 100644
index 000000000..22bae7f09
--- /dev/null
+++ b/module/rnrs/hashtables.scm
@@ -0,0 +1,190 @@
+;;; hashtables.scm --- The R6RS hashtables library
+
+;; Copyright (C) 2010 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 hashtables (6))
+ (export make-eq-hashtable
+ make-eqv-hashtable
+ make-hashtable
+
+ hashtable?
+ hashtable-size
+ hashtable-ref
+ hashtable-set!
+ hashtable-delete!
+ hashtable-contains?
+ hashtable-update!
+ hashtable-copy
+ hashtable-clear!
+ hashtable-keys
+ hashtable-entries
+
+ hashtable-equivalence-function
+ hashtable-hash-function
+ hashtable-mutable?
+
+ equal-hash
+ string-hash
+ string-ci-hash
+ symbol-hash)
+ (import (rename (only (guile) string-hash-ci
+ string-hash
+ hashq
+ hashv
+ modulo
+ *unspecified*
+ @@)
+ (string-hash-ci string-ci-hash))
+ (only (ice-9 optargs) define*)
+ (rename (only (srfi :69) make-hash-table
+ hash
+ hash-by-identity
+ hash-table-size
+ hash-table-ref/default
+ hash-table-set!
+ hash-table-delete!
+ hash-table-exists?
+ hash-table-update!/default
+ hash-table-copy
+ hash-table-equivalence-function
+ hash-table-hash-function
+ hash-table-keys
+ hash-table-fold)
+ (hash equal-hash)
+ (hash-by-identity symbol-hash))
+ (rnrs base (6))
+ (rnrs records procedural (6)))
+
+ (define r6rs:hashtable
+ (make-record-type-descriptor
+ 'r6rs:hashtable #f #f #t #t
+ '#((mutable wrapped-table)
+ (immutable orig-hash-function)
+ (immutable mutable)
+ (immutable type))))
+
+ (define hashtable? (record-predicate r6rs:hashtable))
+ (define make-r6rs-hashtable
+ (record-constructor (make-record-constructor-descriptor
+ r6rs:hashtable #f #f)))
+ (define r6rs:hashtable-wrapped-table (record-accessor r6rs:hashtable 0))
+ (define r6rs:hashtable-set-wrapped-table! (record-mutator r6rs:hashtable 0))
+ (define r6rs:hashtable-orig-hash-function (record-accessor r6rs:hashtable 1))
+ (define r6rs:hashtable-mutable? (record-accessor r6rs:hashtable 2))
+ (define r6rs:hashtable-type (record-accessor r6rs:hashtable 3))
+
+ (define hashtable-mutable? r6rs:hashtable-mutable?)
+
+ (define hash-by-value ((@@ (srfi srfi-69) caller-with-default-size) hashv))
+ (define (wrap-hash-function proc)
+ (lambda (key capacity) (modulo (proc key) capacity)))
+
+ (define* (make-eq-hashtable #:optional k)
+ (make-r6rs-hashtable
+ (if k (make-hash-table eq? hashq k) (make-hash-table eq? symbol-hash))
+ symbol-hash
+ #t
+ 'eq))
+
+ (define* (make-eqv-hashtable #:optional k)
+ (make-r6rs-hashtable
+ (if k (make-hash-table eqv? hashv k) (make-hash-table eqv? hash-by-value))
+ hash-by-value
+ #t
+ 'eqv))
+
+ (define* (make-hashtable hash-function equiv #:optional k)
+ (let ((wrapped-hash-function (wrap-hash-function hash-function)))
+ (make-r6rs-hashtable
+ (if k
+ (make-hash-table equiv wrapped-hash-function k)
+ (make-hash-table equiv wrapped-hash-function))
+ hash-function
+ #t
+ 'custom)))
+
+ (define (hashtable-size hashtable)
+ (hash-table-size (r6rs:hashtable-wrapped-table hashtable)))
+
+ (define (hashtable-ref hashtable key default)
+ (hash-table-ref/default
+ (r6rs:hashtable-wrapped-table hashtable) key default))
+
+ (define (hashtable-set! hashtable key obj)
+ (if (r6rs:hashtable-mutable? hashtable)
+ (hash-table-set! (r6rs:hashtable-wrapped-table hashtable) key obj)
+ (assertion-violation
+ 'hashtable-set! "Hashtable is immutable." hashtable)))
+
+ (define (hashtable-delete! hashtable key)
+ (if (r6rs:hashtable-mutable? hashtable)
+ (hash-table-delete! (r6rs:hashtable-wrapped-table hashtable) key))
+ *unspecified*)
+
+ (define (hashtable-contains? hashtable key)
+ (hash-table-exists? (r6rs:hashtable-wrapped-table hashtable) key))
+
+ (define (hashtable-update! hashtable key proc default)
+ (if (r6rs:hashtable-mutable? hashtable)
+ (hash-table-update!/default
+ (r6rs:hashtable-wrapped-table hashtable) key proc default))
+ *unspecified*)
+
+ (define* (hashtable-copy hashtable #:optional mutable)
+ (make-r6rs-hashtable
+ (hash-table-copy (r6rs:hashtable-wrapped-table hashtable))
+ (r6rs:hashtable-orig-hash-function hashtable)
+ (and mutable #t)
+ (r6rs:hashtable-type hashtable)))
+
+ (define* (hashtable-clear! hashtable #:optional k)
+ (if (r6rs:hashtable-mutable? hashtable)
+ (let* ((ht (r6rs:hashtable-wrapped-table hashtable))
+ (equiv (hash-table-equivalence-function ht))
+ (hash-function (r6rs:hashtable-orig-hash-function hashtable))
+ (wrapped-hash-function (wrap-hash-function hash-function)))
+ (r6rs:hashtable-set-wrapped-table!
+ hashtable
+ (if k
+ (make-hash-table equiv wrapped-hash-function k)
+ (make-hash-table equiv wrapped-hash-function)))))
+ *unspecified*)
+
+ (define (hashtable-keys hashtable)
+ (list->vector (hash-table-keys (r6rs:hashtable-wrapped-table hashtable))))
+
+ (define (hashtable-entries hashtable)
+ (let* ((ht (r6rs:hashtable-wrapped-table hashtable))
+ (size (hash-table-size ht))
+ (keys (make-vector size))
+ (vals (make-vector size)))
+ (hash-table-fold (r6rs:hashtable-wrapped-table hashtable)
+ (lambda (k v i)
+ (vector-set! keys i k)
+ (vector-set! vals i v)
+ (+ i 1))
+ 0)
+ (values keys vals)))
+
+ (define (hashtable-equivalence-function hashtable)
+ (hash-table-equivalence-function (r6rs:hashtable-wrapped-table hashtable)))
+
+ (define (hashtable-hash-function hashtable)
+ (case (r6rs:hashtable-type hashtable)
+ ((eq eqv) #f)
+ (else (r6rs:hashtable-orig-hash-function hashtable)))))
diff --git a/module/rnrs/io/ports.scm b/module/rnrs/io/ports.scm
new file mode 100644
index 000000000..594606785
--- /dev/null
+++ b/module/rnrs/io/ports.scm
@@ -0,0 +1,546 @@
+;;;; ports.scm --- R6RS port API -*- coding: utf-8 -*-
+
+;;;; Copyright (C) 2009, 2010, 2011, 2013 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
+
+;;; Author: Ludovic Courtès <ludo@gnu.org>
+
+;;; Commentary:
+;;;
+;;; The I/O port API of the R6RS is provided by this module. In many areas
+;;; it complements or refines Guile's own historical port API. For instance,
+;;; it allows for binary I/O with bytevectors.
+;;;
+;;; Code:
+
+(library (rnrs io ports (6))
+ (export eof-object eof-object?
+
+ ;; auxiliary types
+ file-options buffer-mode buffer-mode?
+ eol-style native-eol-style error-handling-mode
+ make-transcoder transcoder-codec transcoder-eol-style
+ transcoder-error-handling-mode native-transcoder
+ latin-1-codec utf-8-codec utf-16-codec
+
+ ;; transcoding bytevectors
+ bytevector->string string->bytevector
+
+ ;; input & output ports
+ port? input-port? output-port?
+ port-eof?
+ port-transcoder binary-port? textual-port? transcoded-port
+ port-position set-port-position!
+ port-has-port-position? port-has-set-port-position!?
+ call-with-port close-port
+
+ ;; input ports
+ open-bytevector-input-port
+ open-string-input-port
+ open-file-input-port
+ make-custom-binary-input-port
+
+ ;; binary input
+ get-u8 lookahead-u8
+ get-bytevector-n get-bytevector-n!
+ get-bytevector-some get-bytevector-all
+
+ ;; output ports
+ open-bytevector-output-port
+ open-string-output-port
+ open-file-output-port
+ make-custom-binary-output-port
+ call-with-bytevector-output-port
+ call-with-string-output-port
+ make-custom-textual-output-port
+ output-port-buffer-mode
+ flush-output-port
+
+ ;; input/output ports
+ open-file-input/output-port
+ make-custom-binary-input/output-port
+
+ ;; binary output
+ put-u8 put-bytevector
+
+ ;; textual input
+ get-char get-datum get-line get-string-all get-string-n get-string-n!
+ lookahead-char
+
+ ;; textual output
+ put-char put-datum put-string
+
+ ;; standard ports
+ standard-input-port standard-output-port standard-error-port
+ current-input-port current-output-port current-error-port
+
+ ;; condition types
+ &i/o i/o-error? make-i/o-error
+ &i/o-read i/o-read-error? make-i/o-read-error
+ &i/o-write i/o-write-error? make-i/o-write-error
+ &i/o-invalid-position i/o-invalid-position-error?
+ make-i/o-invalid-position-error
+ &i/o-filename i/o-filename-error? make-i/o-filename-error
+ i/o-error-filename
+ &i/o-file-protection i/o-file-protection-error?
+ make-i/o-file-protection-error
+ &i/o-file-is-read-only i/o-file-is-read-only-error?
+ make-i/o-file-is-read-only-error
+ &i/o-file-already-exists i/o-file-already-exists-error?
+ make-i/o-file-already-exists-error
+ &i/o-file-does-not-exist i/o-file-does-not-exist-error?
+ make-i/o-file-does-not-exist-error
+ &i/o-port i/o-port-error? make-i/o-port-error
+ i/o-error-port
+ &i/o-decoding i/o-decoding-error?
+ make-i/o-decoding-error
+ &i/o-encoding i/o-encoding-error?
+ make-i/o-encoding-error i/o-encoding-error-char)
+ (import (ice-9 binary-ports)
+ (only (rnrs base) assertion-violation)
+ (only (ice-9 ports internal)
+ port-write-buffer port-buffer-bytevector port-line-buffered?)
+ (only (rnrs bytevectors) bytevector-length)
+ (prefix (ice-9 iconv) iconv:)
+ (rnrs enums)
+ (rnrs records syntactic)
+ (rnrs exceptions)
+ (rnrs conditions)
+ (rnrs files) ;for the condition types
+ (srfi srfi-8)
+ (ice-9 rdelim)
+ (except (guile) raise display)
+ (prefix (only (guile) display)
+ guile:))
+
+
+
+;;;
+;;; Auxiliary types
+;;;
+
+(define-enumeration file-option
+ (no-create no-fail no-truncate)
+ file-options)
+
+(define-enumeration buffer-mode
+ (none line block)
+ buffer-modes)
+
+(define (buffer-mode? symbol)
+ (enum-set-member? symbol (enum-set-universe (buffer-modes))))
+
+(define-enumeration eol-style
+ (lf cr crlf nel crnel ls none)
+ eol-styles)
+
+(define (native-eol-style)
+ (eol-style none))
+
+(define-enumeration error-handling-mode
+ (ignore raise replace)
+ error-handling-modes)
+
+(define-record-type (transcoder %make-transcoder transcoder?)
+ (fields codec eol-style error-handling-mode))
+
+(define* (make-transcoder codec
+ #:optional
+ (eol-style (native-eol-style))
+ (handling-mode (error-handling-mode replace)))
+ (%make-transcoder codec eol-style handling-mode))
+
+(define (native-transcoder)
+ (make-transcoder (or (fluid-ref %default-port-encoding)
+ (latin-1-codec))))
+
+(define (latin-1-codec)
+ "ISO-8859-1")
+
+(define (utf-8-codec)
+ "UTF-8")
+
+(define (utf-16-codec)
+ "UTF-16")
+
+
+;;;
+;;; Transcoding bytevectors
+;;;
+
+(define (string->bytevector str transcoder)
+ "Encode @var{str} using @var{transcoder}, returning a bytevector."
+ (iconv:string->bytevector
+ str
+ (transcoder-codec transcoder)
+ (case (transcoder-error-handling-mode transcoder)
+ ((raise) 'error)
+ ((replace) 'substitute)
+ (else (error "unsupported error handling mode"
+ (transcoder-error-handling-mode transcoder))))))
+
+(define (bytevector->string bv transcoder)
+ "Decode @var{bv} using @var{transcoder}, returning a string."
+ (iconv:bytevector->string
+ bv
+ (transcoder-codec transcoder)
+ (case (transcoder-error-handling-mode transcoder)
+ ((raise) 'error)
+ ((replace) 'substitute)
+ (else (error "unsupported error handling mode"
+ (transcoder-error-handling-mode transcoder))))))
+
+
+;;;
+;;; Internal helpers
+;;;
+
+(define (with-i/o-filename-conditions filename thunk)
+ (with-throw-handler 'system-error
+ thunk
+ (lambda args
+ (let ((errno (system-error-errno args)))
+ (let ((construct-condition
+ (cond ((= errno EACCES)
+ make-i/o-file-protection-error)
+ ((= errno EEXIST)
+ make-i/o-file-already-exists-error)
+ ((= errno ENOENT)
+ make-i/o-file-does-not-exist-error)
+ ((= errno EROFS)
+ make-i/o-file-is-read-only-error)
+ (else
+ make-i/o-filename-error))))
+ (raise (construct-condition filename)))))))
+
+(define (with-i/o-port-error port make-primary-condition thunk)
+ (with-throw-handler 'system-error
+ thunk
+ (lambda args
+ (let ((errno (system-error-errno args)))
+ (if (memv errno (list EIO EFBIG ENOSPC EPIPE))
+ (raise (condition (make-primary-condition)
+ (make-i/o-port-error port)))
+ (apply throw args))))))
+
+(define-syntax with-textual-output-conditions
+ (syntax-rules ()
+ ((_ port body0 body ...)
+ (with-i/o-port-error port make-i/o-write-error
+ (lambda () (with-i/o-encoding-error body0 body ...))))))
+
+(define-syntax with-textual-input-conditions
+ (syntax-rules ()
+ ((_ port body0 body ...)
+ (with-i/o-port-error port make-i/o-read-error
+ (lambda () (with-i/o-decoding-error body0 body ...))))))
+
+
+;;;
+;;; Input and output ports.
+;;;
+
+(define (port-transcoder port)
+ "Return the transcoder object associated with @var{port}, or @code{#f}
+if the port has no transcoder."
+ (and (textual-port? port)
+ ;; All textual ports have transcoders.
+ (make-transcoder
+ (port-encoding port)
+ (native-eol-style)
+ (case (port-conversion-strategy port)
+ ((error) 'raise)
+ ((substitute) 'replace)
+ (else
+ (assertion-violation 'port-transcoder
+ "unsupported error handling mode"))))))
+
+(define (binary-port? port)
+ "Always returns @code{#t}, as all ports can be used for binary I/O in
+Guile."
+ (equal? (port-encoding port) "ISO-8859-1"))
+
+(define (textual-port? port)
+ "Always returns @code{#t}, as all ports can be used for textual I/O in
+Guile."
+ #t)
+
+(define (port-eof? port)
+ (eof-object? (if (binary-port? port)
+ (lookahead-u8 port)
+ (lookahead-char port))))
+
+(define (transcoded-port port transcoder)
+ "Return a new textual port based on @var{port}, using
+@var{transcoder} to encode and decode data written to or
+read from its underlying binary port @var{port}."
+ ;; Hackily get at %make-transcoded-port.
+ (let ((result ((@@ (ice-9 binary-ports) %make-transcoded-port) port)))
+ (set-port-encoding! result (transcoder-codec transcoder))
+ (case (transcoder-error-handling-mode transcoder)
+ ((raise)
+ (set-port-conversion-strategy! result 'error))
+ ((replace)
+ (set-port-conversion-strategy! result 'substitute))
+ (else
+ (error "unsupported error handling mode"
+ (transcoder-error-handling-mode transcoder))))
+ result))
+
+(define (port-position port)
+ "Return the offset (an integer) indicating where the next octet will be
+read from/written to in @var{port}."
+
+ ;; FIXME: We should raise an `&assertion' error when not supported.
+ (seek port 0 SEEK_CUR))
+
+(define (set-port-position! port offset)
+ "Set the position where the next octet will be read from/written to
+@var{port}."
+
+ ;; FIXME: We should raise an `&assertion' error when not supported.
+ (seek port offset SEEK_SET))
+
+(define (port-has-port-position? port)
+ "Return @code{#t} is @var{port} supports @code{port-position}."
+ (and (false-if-exception (port-position port)) #t))
+
+(define (port-has-set-port-position!? port)
+ "Return @code{#t} is @var{port} supports @code{set-port-position!}."
+ (and (false-if-exception (set-port-position! port (port-position port)))
+ #t))
+
+(define (call-with-port port proc)
+ "Call @var{proc}, passing it @var{port} and closing @var{port} upon exit of
+@var{proc}. Return the return values of @var{proc}."
+ (call-with-values
+ (lambda () (proc port))
+ (lambda vals
+ (close-port port)
+ (apply values vals))))
+
+(define* (call-with-bytevector-output-port proc #:optional (transcoder #f))
+ (receive (port extract) (open-bytevector-output-port transcoder)
+ (call-with-port port proc)
+ (extract)))
+
+(define (open-string-input-port str)
+ "Open an input port that will read from @var{str}."
+ (open-input-string str))
+
+(define (r6rs-open filename mode buffer-mode transcoder)
+ (let ((port (with-i/o-filename-conditions filename
+ (lambda ()
+ (with-fluids ((%default-port-encoding #f))
+ (open filename mode))))))
+ (setvbuf port buffer-mode)
+ (when transcoder
+ (set-port-encoding! port (transcoder-codec transcoder)))
+ port))
+
+(define (file-options->mode file-options base-mode)
+ (logior base-mode
+ (if (enum-set-member? 'no-create file-options)
+ 0
+ O_CREAT)
+ (if (enum-set-member? 'no-truncate file-options)
+ 0
+ O_TRUNC)
+ (if (enum-set-member? 'no-fail file-options)
+ 0
+ O_EXCL)))
+
+(define* (open-file-input-port filename
+ #:optional
+ (file-options (file-options))
+ (buffer-mode (buffer-mode block))
+ transcoder)
+ "Return an input port for reading from @var{filename}."
+ (r6rs-open filename O_RDONLY buffer-mode transcoder))
+
+(define* (open-file-input/output-port filename
+ #:optional
+ (file-options (file-options))
+ (buffer-mode (buffer-mode block))
+ transcoder)
+ "Return a port for reading from and writing to @var{filename}."
+ (r6rs-open filename
+ (file-options->mode file-options O_RDWR)
+ buffer-mode
+ transcoder))
+
+(define (open-string-output-port)
+ "Return two values: an output port that will collect characters written to it
+as a string, and a thunk to retrieve the characters associated with that port."
+ (let ((port (open-output-string)))
+ (values port
+ (lambda ()
+ (let ((s (get-output-string port)))
+ (seek port 0 SEEK_SET)
+ (truncate-file port 0)
+ s)))))
+
+(define* (open-file-output-port filename
+ #:optional
+ (file-options (file-options))
+ (buffer-mode (buffer-mode block))
+ maybe-transcoder)
+ "Return an output port for writing to @var{filename}."
+ (r6rs-open filename
+ (file-options->mode file-options O_WRONLY)
+ buffer-mode
+ maybe-transcoder))
+
+(define (call-with-string-output-port proc)
+ "Call @var{proc}, passing it a string output port. When @var{proc} returns,
+return the characters accumulated in that port."
+ (let ((port (open-output-string)))
+ (proc port)
+ (get-output-string port)))
+
+(define (make-custom-textual-output-port id
+ write!
+ get-position
+ set-position!
+ close)
+ (make-soft-port (vector (lambda (c) (write! (string c) 0 1))
+ (lambda (s) (write! s 0 (string-length s)))
+ #f ;flush
+ #f ;read character
+ close)
+ "w"))
+
+(define (output-port-buffer-mode port)
+ "Return @code{none} if @var{port} is unbuffered, @code{line} if it is
+line buffered, or @code{block} otherwise."
+ (let ((buffering (bytevector-length
+ (port-buffer-bytevector (port-write-buffer port)))))
+ (cond
+ ((= buffering 1) 'none)
+ ((port-line-buffered? port) 'line)
+ (else 'block))))
+
+(define (flush-output-port port)
+ (force-output port))
+
+
+;;;
+;;; Textual output.
+;;;
+
+(define-condition-type &i/o-encoding &i/o-port
+ make-i/o-encoding-error i/o-encoding-error?
+ (char i/o-encoding-error-char))
+
+(define-syntax with-i/o-encoding-error
+ (syntax-rules ()
+ "Convert Guile throws to `encoding-error' to `&i/o-encoding'."
+ ((_ body ...)
+ ;; XXX: This is heavyweight for small functions like `put-char'.
+ (with-throw-handler 'encoding-error
+ (lambda ()
+ (begin body ...))
+ (lambda (key subr message errno port chr)
+ (raise (make-i/o-encoding-error port chr)))))))
+
+(define (put-char port char)
+ (with-textual-output-conditions port (write-char char port)))
+
+(define (put-datum port datum)
+ (with-textual-output-conditions port (write datum port)))
+
+(define* (put-string port s #:optional start count)
+ (with-textual-output-conditions port
+ (cond ((not (string? s))
+ (assertion-violation 'put-string "expected string" s))
+ ((and start count)
+ (display (substring/shared s start (+ start count)) port))
+ (start
+ (display (substring/shared s start (string-length s)) port))
+ (else
+ (display s port)))))
+
+;; Defined here to be able to make use of `with-i/o-encoding-error', but
+;; not exported from here, but from `(rnrs io simple)'.
+(define* (display object #:optional (port (current-output-port)))
+ (with-textual-output-conditions port (guile:display object port)))
+
+
+;;;
+;;; Textual input.
+;;;
+
+(define-condition-type &i/o-decoding &i/o-port
+ make-i/o-decoding-error i/o-decoding-error?)
+
+(define-syntax with-i/o-decoding-error
+ (syntax-rules ()
+ "Convert Guile throws to `decoding-error' to `&i/o-decoding'."
+ ((_ body ...)
+ ;; XXX: This is heavyweight for small functions like `get-char' and
+ ;; `lookahead-char'.
+ (with-throw-handler 'decoding-error
+ (lambda ()
+ (begin body ...))
+ (lambda (key subr message errno port)
+ (raise (make-i/o-decoding-error port)))))))
+
+(define (get-char port)
+ (with-textual-input-conditions port (read-char port)))
+
+(define (get-datum port)
+ (with-textual-input-conditions port (read port)))
+
+(define (get-line port)
+ (with-textual-input-conditions port (read-line port 'trim)))
+
+(define (get-string-all port)
+ (with-textual-input-conditions port (read-string port)))
+
+(define (get-string-n port count)
+ "Read up to @var{count} characters from @var{port}.
+If no characters could be read before encountering the end of file,
+return the end-of-file object, otherwise return a string containing
+the characters read."
+ (let* ((s (make-string count))
+ (rv (get-string-n! port s 0 count)))
+ (cond ((eof-object? rv) rv)
+ ((= rv count) s)
+ (else (substring/shared s 0 rv)))))
+
+(define (lookahead-char port)
+ (with-textual-input-conditions port (peek-char port)))
+
+
+;;;
+;;; Standard ports.
+;;;
+
+(define (standard-input-port)
+ (with-fluids ((%default-port-encoding #f))
+ (dup->inport 0)))
+
+(define (standard-output-port)
+ (with-fluids ((%default-port-encoding #f))
+ (dup->outport 1)))
+
+(define (standard-error-port)
+ (with-fluids ((%default-port-encoding #f))
+ (dup->outport 2)))
+
+)
+
+;;; ports.scm ends here
diff --git a/module/rnrs/io/simple.scm b/module/rnrs/io/simple.scm
new file mode 100644
index 000000000..0d778a9f9
--- /dev/null
+++ b/module/rnrs/io/simple.scm
@@ -0,0 +1,167 @@
+;;; simple.scm --- The R6RS simple I/O library
+
+;; Copyright (C) 2010, 2011, 2014, 2018 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 io simple (6))
+ (export eof-object
+ eof-object?
+
+ call-with-input-file
+ call-with-output-file
+
+ input-port?
+ output-port?
+
+ current-input-port
+ current-output-port
+ current-error-port
+
+ with-input-from-file
+ with-output-to-file
+
+ open-input-file
+ open-output-file
+
+ close-input-port
+ close-output-port
+
+ read-char
+ peek-char
+ read
+ write-char
+ newline
+ display
+ write
+
+ &i/o make-i/o-error i/o-error?
+ &i/o-read make-i/o-read-error i/o-read-error?
+ &i/o-write make-i/o-write-error i/o-write-error?
+
+ &i/o-invalid-position
+ make-i/o-invalid-position-error
+ i/o-invalid-position-error?
+ i/o-error-position
+
+ &i/o-filename
+ make-i/o-filename-error
+ i/o-filename-error?
+ i/o-error-filename
+
+ &i/o-file-protection
+ make-i/o-file-protection-error
+ i/o-file-protection-error?
+
+ &i/o-file-is-read-only
+ make-i/o-file-is-read-only-error
+ i/o-file-is-read-only-error?
+
+ &i/o-file-already-exists
+ make-i/o-file-already-exists-error
+ i/o-file-already-exists-error?
+
+ &i/o-file-does-not-exist
+ make-i/o-file-does-not-exist-error
+ i/o-file-does-not-exist-error?
+
+ &i/o-port
+ make-i/o-port-error
+ i/o-port-error?
+ i/o-error-port)
+
+ (import (only (rnrs io ports)
+ call-with-port
+ close-port
+ open-file-input-port
+ open-file-output-port
+ eof-object
+ eof-object?
+ file-options
+ buffer-mode
+ native-transcoder
+ get-char
+ lookahead-char
+ get-datum
+ put-char
+ put-datum
+
+ input-port?
+ output-port?)
+ (only (guile)
+ @@
+ current-input-port
+ current-output-port
+ current-error-port
+
+ define*
+
+ with-input-from-port
+ with-output-to-port)
+ (rnrs base (6))
+ (rnrs files (6)) ;for the condition types
+ )
+
+ (define display (@@ (rnrs io ports) display))
+
+ (define (call-with-input-file filename proc)
+ (call-with-port (open-input-file filename) proc))
+
+ (define (call-with-output-file filename proc)
+ (call-with-port (open-output-file filename) proc))
+
+ (define (with-input-from-file filename thunk)
+ (call-with-input-file filename
+ (lambda (port) (with-input-from-port port thunk))))
+
+ (define (with-output-to-file filename thunk)
+ (call-with-output-file filename
+ (lambda (port) (with-output-to-port port thunk))))
+
+ (define (open-input-file filename)
+ (open-file-input-port filename
+ (file-options)
+ (buffer-mode block)
+ (native-transcoder)))
+
+ (define (open-output-file filename)
+ (open-file-output-port filename
+ (file-options)
+ (buffer-mode block)
+ (native-transcoder)))
+
+ (define close-input-port close-port)
+ (define close-output-port close-port)
+
+ (define* (read-char #:optional (port (current-input-port)))
+ (get-char port))
+
+ (define* (peek-char #:optional (port (current-input-port)))
+ (lookahead-char port))
+
+ (define* (read #:optional (port (current-input-port)))
+ (get-datum port))
+
+ (define* (write-char char #:optional (port (current-output-port)))
+ (put-char port char))
+
+ (define* (newline #:optional (port (current-output-port)))
+ (put-char port #\newline))
+
+ (define* (write object #:optional (port (current-output-port)))
+ (put-datum port object))
+
+ )
diff --git a/module/rnrs/lists.scm b/module/rnrs/lists.scm
new file mode 100644
index 000000000..0671e7753
--- /dev/null
+++ b/module/rnrs/lists.scm
@@ -0,0 +1,55 @@
+;;; lists.scm --- The R6RS list utilities library
+
+;; Copyright (C) 2010 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 lists (6))
+ (export find for-all exists filter partition fold-left fold-right remp remove
+ remv remq memp member memv memq assp assoc assv assq cons*)
+ (import (rnrs base (6))
+ (only (guile) filter member memv memq assoc assv assq cons*)
+ (rename (only (srfi srfi-1) any
+ every
+ remove
+ member
+ assoc
+ find
+ partition
+ fold-right
+ filter-map)
+ (any exists)
+ (every for-all)
+ (remove remp)
+
+ (member memp-internal)
+ (assoc assp-internal)))
+
+ (define (fold-left combine nil list . lists)
+ (define (fold nil lists)
+ (if (exists null? lists)
+ nil
+ (fold (apply combine nil (map car lists))
+ (map cdr lists))))
+ (fold nil (cons list lists)))
+
+ (define (remove obj list) (remp (lambda (elt) (equal? obj elt)) list))
+ (define (remv obj list) (remp (lambda (elt) (eqv? obj elt)) list))
+ (define (remq obj list) (remp (lambda (elt) (eq? obj elt)) list))
+
+ (define (memp pred list) (memp-internal #f list (lambda (x y) (pred y))))
+ (define (assp pred list) (assp-internal #f list (lambda (x y) (pred y))))
+)
diff --git a/module/rnrs/mutable-pairs.scm b/module/rnrs/mutable-pairs.scm
new file mode 100644
index 000000000..020debffc
--- /dev/null
+++ b/module/rnrs/mutable-pairs.scm
@@ -0,0 +1,23 @@
+;;; mutable-pairs.scm --- The R6RS mutable pair library
+
+;; Copyright (C) 2010 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 mutable-pairs (6))
+ (export set-car! set-cdr!)
+ (import (only (guile) set-car! set-cdr!)))
diff --git a/module/rnrs/mutable-strings.scm b/module/rnrs/mutable-strings.scm
new file mode 100644
index 000000000..b2b31029b
--- /dev/null
+++ b/module/rnrs/mutable-strings.scm
@@ -0,0 +1,23 @@
+;;; mutable-strings.scm --- The R6RS mutable string library
+
+;; Copyright (C) 2010 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 mutable-strings (6))
+ (export string-set! string-fill!)
+ (import (only (guile) string-set! string-fill!)))
diff --git a/module/rnrs/programs.scm b/module/rnrs/programs.scm
new file mode 100644
index 000000000..4daa781ab
--- /dev/null
+++ b/module/rnrs/programs.scm
@@ -0,0 +1,22 @@
+;;; programs.scm --- The R6RS process management library
+
+;; Copyright (C) 2010 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 programs (6))
+ (export command-line exit)
+ (import (only (guile) command-line exit)))
diff --git a/module/rnrs/r5rs.scm b/module/rnrs/r5rs.scm
new file mode 100644
index 000000000..ab7485407
--- /dev/null
+++ b/module/rnrs/r5rs.scm
@@ -0,0 +1,34 @@
+;;; r5rs.scm --- The R6RS / R5RS compatibility library
+
+;; Copyright (C) 2010 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 r5rs (6))
+ (export exact->inexact inexact->exact
+
+ quotient remainder modulo
+
+ delay force
+
+ null-environment scheme-report-environment)
+ (import (only (guile) exact->inexact inexact->exact
+
+ quotient remainder modulo
+
+ delay force)
+ (only (ice-9 r5rs) scheme-report-environment)
+ (only (ice-9 safe-r5rs) null-environment)))
diff --git a/module/rnrs/records/inspection.scm b/module/rnrs/records/inspection.scm
new file mode 100644
index 000000000..68b78a916
--- /dev/null
+++ b/module/rnrs/records/inspection.scm
@@ -0,0 +1,81 @@
+;;; inspection.scm --- Inspection support for R6RS records
+
+;; Copyright (C) 2010 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 records inspection (6))
+ (export record?
+ record-rtd
+ record-type-name
+ record-type-parent
+ record-type-uid
+ record-type-generative?
+ record-type-sealed?
+ record-type-opaque?
+ record-type-field-names
+ record-field-mutable?)
+ (import (rnrs arithmetic bitwise (6))
+ (rnrs base (6))
+ (rnrs records procedural (6))
+ (only (guile) struct-ref struct-vtable vtable-index-layout @@))
+
+ (define record-internal? (@@ (rnrs records procedural) record-internal?))
+
+ (define rtd-index-name (@@ (rnrs records procedural) rtd-index-name))
+ (define rtd-index-parent (@@ (rnrs records procedural) rtd-index-parent))
+ (define rtd-index-uid (@@ (rnrs records procedural) rtd-index-uid))
+ (define rtd-index-sealed? (@@ (rnrs records procedural) rtd-index-sealed?))
+ (define rtd-index-opaque? (@@ (rnrs records procedural) rtd-index-opaque?))
+ (define rtd-index-field-names
+ (@@ (rnrs records procedural) rtd-index-field-names))
+ (define rtd-index-field-bit-field
+ (@@ (rnrs records procedural) rtd-index-field-bit-field))
+
+ (define (record? obj)
+ (and (record-internal? obj)
+ (not (record-type-opaque? (struct-vtable obj)))))
+
+ (define (record-rtd record)
+ (or (and (record-internal? record)
+ (let ((rtd (struct-vtable record)))
+ (and (not (struct-ref rtd rtd-index-opaque?)) rtd)))
+ (assertion-violation 'record-rtd "not a record" record)))
+
+ (define (guarantee-rtd who rtd)
+ (if (record-type-descriptor? rtd)
+ rtd
+ (assertion-violation who "not a record type descriptor" rtd)))
+
+ (define (record-type-name rtd)
+ (struct-ref (guarantee-rtd 'record-type-name rtd) rtd-index-name))
+ (define (record-type-parent rtd)
+ (struct-ref (guarantee-rtd 'record-type-parent rtd) rtd-index-parent))
+ (define (record-type-uid rtd)
+ (struct-ref (guarantee-rtd 'record-type-uid rtd) rtd-index-uid))
+ (define (record-type-generative? rtd)
+ (not (record-type-uid (guarantee-rtd 'record-type-generative? rtd))))
+ (define (record-type-sealed? rtd)
+ (struct-ref (guarantee-rtd 'record-type-sealed? rtd) rtd-index-sealed?))
+ (define (record-type-opaque? rtd)
+ (struct-ref (guarantee-rtd 'record-type-opaque? rtd) rtd-index-opaque?))
+ (define (record-type-field-names rtd)
+ (struct-ref (guarantee-rtd 'record-type-field-names rtd) rtd-index-field-names))
+ (define (record-field-mutable? rtd k)
+ (bitwise-bit-set? (struct-ref (guarantee-rtd 'record-field-mutable? rtd)
+ rtd-index-field-bit-field)
+ k))
+)
diff --git a/module/rnrs/records/procedural.scm b/module/rnrs/records/procedural.scm
new file mode 100644
index 000000000..cbcd4e5ce
--- /dev/null
+++ b/module/rnrs/records/procedural.scm
@@ -0,0 +1,291 @@
+;;; procedural.scm --- Procedural interface to R6RS records
+
+;; Copyright (C) 2010, 2017 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 records procedural (6))
+ (export make-record-type-descriptor
+ record-type-descriptor?
+ make-record-constructor-descriptor
+
+ record-constructor
+ record-predicate
+ record-accessor
+ record-mutator)
+
+ (import (rnrs base (6))
+ (only (guile) cons*
+ logand
+ logior
+ ash
+
+ and=>
+ throw
+ display
+ make-struct/no-tail
+ make-vtable
+ map
+ simple-format
+ string-append
+ symbol-append
+
+ struct?
+ struct-layout
+ struct-ref
+ struct-set!
+ struct-vtable
+ vtable-index-layout
+
+ make-hash-table
+ hashq-ref
+ hashq-set!
+
+ vector->list
+
+ vtable-offset-user)
+ (ice-9 receive)
+ (only (srfi :1) fold split-at take))
+
+ (define (record-internal? obj)
+ (and (struct? obj) (record-type-descriptor? (struct-vtable obj))))
+
+ (define rtd-index-name (+ vtable-offset-user 0))
+ (define rtd-index-uid (+ vtable-offset-user 1))
+ (define rtd-index-parent (+ vtable-offset-user 2))
+ (define rtd-index-sealed? (+ vtable-offset-user 3))
+ (define rtd-index-opaque? (+ vtable-offset-user 4))
+ (define rtd-index-predicate (+ vtable-offset-user 5))
+ (define rtd-index-field-names (+ vtable-offset-user 6))
+ (define rtd-index-field-bit-field (+ vtable-offset-user 7))
+ (define rtd-index-field-binder (+ vtable-offset-user 8))
+
+ (define rctd-index-rtd 0)
+ (define rctd-index-parent 1)
+ (define rctd-index-protocol 2)
+
+ (define vtable-base-layout (symbol->string (struct-layout (make-vtable ""))))
+
+ (define record-type-vtable
+ (make-vtable (string-append vtable-base-layout "pwpwpwpwpwpwpwpwpwpw")
+ (lambda (obj port)
+ (simple-format port "#<r6rs:record-type:~A>"
+ (struct-ref obj rtd-index-name)))))
+
+ (define record-constructor-vtable
+ (make-vtable "pwpwpw"
+ (lambda (obj port)
+ (simple-format port "#<r6rs:record-constructor:~A>"
+ (struct-ref (struct-ref obj rctd-index-rtd)
+ rtd-index-name)))))
+
+ (define uid-table (make-hash-table))
+
+ (define (make-record-type-descriptor name parent uid sealed? opaque? fields)
+ (define fields-pair
+ (let loop ((field-list (vector->list fields))
+ (layout-sym 'pw)
+ (layout-bit-field 0)
+ (counter 0))
+ (if (null? field-list)
+ (cons layout-sym layout-bit-field)
+ (case (caar field-list)
+ ((immutable)
+ (loop (cdr field-list)
+ (symbol-append layout-sym 'pw)
+ layout-bit-field
+ (+ counter 1)))
+ ((mutable)
+ (loop (cdr field-list)
+ (symbol-append layout-sym 'pw)
+ (logior layout-bit-field (ash 1 counter))
+ (+ counter 1)))
+ (else (r6rs-raise (make-assertion-violation)))))))
+
+ (define fields-layout (car fields-pair))
+ (define fields-bit-field (cdr fields-pair))
+
+ (define field-names (list->vector (map cadr (vector->list fields))))
+ (define late-rtd #f)
+
+ (define (private-record-predicate obj)
+ (and (record-internal? obj)
+ (or (eq? (struct-vtable obj) late-rtd)
+ (and=> (struct-ref obj 0) private-record-predicate))))
+
+ (define (field-binder parent-struct . args)
+ (apply make-struct/no-tail late-rtd parent-struct args))
+
+ (if (and parent (struct-ref parent rtd-index-sealed?))
+ (r6rs-raise (make-assertion-violation)))
+
+ (let ((matching-rtd (and uid (hashq-ref uid-table uid)))
+ (opaque? (or opaque? (and parent (struct-ref
+ parent rtd-index-opaque?)))))
+ (if matching-rtd
+ (if (equal? (list name
+ parent
+ sealed?
+ opaque?
+ field-names
+ fields-bit-field)
+ (list (struct-ref matching-rtd rtd-index-name)
+ (struct-ref matching-rtd rtd-index-parent)
+ (struct-ref matching-rtd rtd-index-sealed?)
+ (struct-ref matching-rtd rtd-index-opaque?)
+ (struct-ref matching-rtd rtd-index-field-names)
+ (struct-ref matching-rtd
+ rtd-index-field-bit-field)))
+ matching-rtd
+ (r6rs-raise (make-assertion-violation)))
+
+ (let ((rtd (make-struct/no-tail
+ record-type-vtable
+
+ fields-layout
+ (lambda (obj port)
+ (simple-format
+ port "#<r6rs:record:~A>" name))
+
+ name
+ uid
+ parent
+ sealed?
+ opaque?
+
+ private-record-predicate
+ field-names
+ fields-bit-field
+ field-binder)))
+ (set! late-rtd rtd)
+ (if uid (hashq-set! uid-table uid rtd))
+ rtd))))
+
+ (define (record-type-descriptor? obj)
+ (and (struct? obj) (eq? (struct-vtable obj) record-type-vtable)))
+
+ (define (make-record-constructor-descriptor rtd
+ parent-constructor-descriptor
+ protocol)
+ (define rtd-arity (vector-length (struct-ref rtd rtd-index-field-names)))
+ (define (default-inherited-protocol n)
+ (lambda args
+ (receive
+ (n-args p-args)
+ (split-at args (- (length args) rtd-arity))
+ (let ((p (apply n n-args)))
+ (apply p p-args)))))
+ (define (default-protocol p) p)
+
+ (let* ((prtd (struct-ref rtd rtd-index-parent))
+ (pcd (or parent-constructor-descriptor
+ (and=> prtd (lambda (d) (make-record-constructor-descriptor
+ prtd #f #f)))))
+ (prot (or protocol (if pcd
+ default-inherited-protocol
+ default-protocol))))
+ (make-struct/no-tail record-constructor-vtable rtd pcd prot)))
+
+ (define (record-constructor rctd)
+ (let* ((rtd (struct-ref rctd rctd-index-rtd))
+ (parent-rctd (struct-ref rctd rctd-index-parent))
+ (protocol (struct-ref rctd rctd-index-protocol)))
+ (protocol
+ (if parent-rctd
+ (let ((parent-record-constructor (record-constructor parent-rctd))
+ (parent-rtd (struct-ref parent-rctd rctd-index-rtd)))
+ (lambda args
+ (let ((struct (apply parent-record-constructor args)))
+ (lambda args
+ (apply (struct-ref rtd rtd-index-field-binder)
+ (cons struct args))))))
+ (lambda args (apply (struct-ref rtd rtd-index-field-binder)
+ (cons #f args)))))))
+
+ (define (record-predicate rtd) (struct-ref rtd rtd-index-predicate))
+
+ (define (record-accessor rtd k)
+ (define (record-accessor-inner obj)
+ (if (eq? (struct-vtable obj) rtd)
+ (struct-ref obj (+ k 1))
+ (and=> (struct-ref obj 0) record-accessor-inner)))
+ (lambda (obj)
+ (if (not (record-internal? obj))
+ (r6rs-raise (make-assertion-violation)))
+ (record-accessor-inner obj)))
+
+ (define (record-mutator rtd k)
+ (define (record-mutator-inner obj val)
+ (and obj (or (and (eq? (struct-vtable obj) rtd)
+ (struct-set! obj (+ k 1) val))
+ (record-mutator-inner (struct-ref obj 0) val))))
+ (let ((bit-field (struct-ref rtd rtd-index-field-bit-field)))
+ (if (zero? (logand bit-field (ash 1 k)))
+ (r6rs-raise (make-assertion-violation))))
+ (lambda (obj val) (record-mutator-inner obj val)))
+
+ ;; Condition types that are used in the current library. These are defined
+ ;; here and not in (rnrs conditions) to avoid a circular dependency.
+
+ (define &condition (make-record-type-descriptor '&condition #f #f #f #f '#()))
+ (define &condition-constructor-descriptor
+ (make-record-constructor-descriptor &condition #f #f))
+
+ (define &serious (make-record-type-descriptor
+ '&serious &condition #f #f #f '#()))
+ (define &serious-constructor-descriptor
+ (make-record-constructor-descriptor
+ &serious &condition-constructor-descriptor #f))
+
+ (define make-serious-condition
+ (record-constructor &serious-constructor-descriptor))
+
+ (define &violation (make-record-type-descriptor
+ '&violation &serious #f #f #f '#()))
+ (define &violation-constructor-descriptor
+ (make-record-constructor-descriptor
+ &violation &serious-constructor-descriptor #f))
+ (define make-violation (record-constructor &violation-constructor-descriptor))
+
+ (define &assertion (make-record-type-descriptor
+ '&assertion &violation #f #f #f '#()))
+ (define make-assertion-violation
+ (record-constructor
+ (make-record-constructor-descriptor
+ &assertion &violation-constructor-descriptor #f)))
+
+ ;; Exception wrapper type, along with a wrapping `throw' implementation.
+ ;; These are used in the current library, and so they are defined here and not
+ ;; in (rnrs exceptions) to avoid a circular dependency.
+
+ (define &raise-object-wrapper
+ (make-record-type-descriptor '&raise-object-wrapper #f #f #f #f
+ '#((immutable obj) (immutable continuation))))
+ (define make-raise-object-wrapper
+ (record-constructor (make-record-constructor-descriptor
+ &raise-object-wrapper #f #f)))
+ (define raise-object-wrapper? (record-predicate &raise-object-wrapper))
+ (define raise-object-wrapper-obj (record-accessor &raise-object-wrapper 0))
+ (define raise-object-wrapper-continuation
+ (record-accessor &raise-object-wrapper 1))
+
+ (define (r6rs-raise obj)
+ (throw 'r6rs:exception (make-raise-object-wrapper obj #f)))
+ (define (r6rs-raise-continuable obj)
+ (define (r6rs-raise-continuable-internal continuation)
+ (throw 'r6rs:exception (make-raise-object-wrapper obj continuation)))
+ (call/cc r6rs-raise-continuable-internal))
+)
diff --git a/module/rnrs/records/syntactic.scm b/module/rnrs/records/syntactic.scm
new file mode 100644
index 000000000..bde6f9348
--- /dev/null
+++ b/module/rnrs/records/syntactic.scm
@@ -0,0 +1,248 @@
+;;; syntactic.scm --- Syntactic support for R6RS records
+
+;; Copyright (C) 2010 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 records syntactic (6))
+ (export define-record-type
+ record-type-descriptor
+ record-constructor-descriptor)
+ (import (only (guile) and=> gensym)
+ (rnrs base (6))
+ (rnrs conditions (6))
+ (rnrs exceptions (6))
+ (rnrs hashtables (6))
+ (rnrs lists (6))
+ (rnrs records procedural (6))
+ (rnrs syntax-case (6))
+ (only (srfi :1) take))
+
+ (define record-type-registry (make-eq-hashtable))
+
+ (define (guess-constructor-name record-name)
+ (string->symbol (string-append "make-" (symbol->string record-name))))
+ (define (guess-predicate-name record-name)
+ (string->symbol (string-append (symbol->string record-name) "?")))
+ (define (register-record-type name rtd rcd)
+ (hashtable-set! record-type-registry name (cons rtd rcd)))
+ (define (lookup-record-type-descriptor name)
+ (and=> (hashtable-ref record-type-registry name #f) car))
+ (define (lookup-record-constructor-descriptor name)
+ (and=> (hashtable-ref record-type-registry name #f) cdr))
+
+ (define-syntax define-record-type
+ (lambda (stx)
+ (syntax-case stx ()
+ ((_ (record-name constructor-name predicate-name) record-clause ...)
+ #'(define-record-type0
+ (record-name constructor-name predicate-name)
+ record-clause ...))
+ ((_ record-name record-clause ...)
+ (let* ((record-name-sym (syntax->datum #'record-name))
+ (constructor-name
+ (datum->syntax
+ #'record-name (guess-constructor-name record-name-sym)))
+ (predicate-name
+ (datum->syntax
+ #'record-name (guess-predicate-name record-name-sym))))
+ #`(define-record-type0
+ (record-name #,constructor-name #,predicate-name)
+ record-clause ...))))))
+
+ (define (sequence n)
+ (define (seq-inner n) (if (= n 0) '(0) (cons n (seq-inner (- n 1)))))
+ (reverse (seq-inner n)))
+ (define (number-fields fields)
+ (define (number-fields-inner fields counter)
+ (if (null? fields)
+ '()
+ (cons (cons fields counter)
+ (number-fields-inner (cdr fields) (+ counter 1)))))
+ (number-fields-inner fields 0))
+
+ (define (process-fields record-name fields)
+ (define (wrap x) (datum->syntax record-name x))
+ (define (id->string x)
+ (symbol->string (syntax->datum x)))
+ (define record-name-str (id->string record-name))
+ (define (guess-accessor-name field-name)
+ (wrap
+ (string->symbol (string-append
+ record-name-str "-" (id->string field-name)))))
+ (define (guess-mutator-name field-name)
+ (wrap
+ (string->symbol
+ (string-append
+ record-name-str "-" (id->string field-name) "-set!"))))
+ (define (f x)
+ (syntax-case x (immutable mutable)
+ [(immutable name)
+ (list (wrap `(immutable ,(syntax->datum #'name)))
+ (guess-accessor-name #'name)
+ #f)]
+ [(immutable name accessor)
+ (list (wrap `(immutable ,(syntax->datum #'name))) #'accessor #f)]
+ [(mutable name)
+ (list (wrap `(mutable ,(syntax->datum #'name)))
+ (guess-accessor-name #'name)
+ (guess-mutator-name #'name))]
+ [(mutable name accessor mutator)
+ (list (wrap `(mutable ,(syntax->datum #'name))) #'accessor #'mutator)]
+ [name
+ (identifier? #'name)
+ (list (wrap `(immutable ,(syntax->datum #'name)))
+ (guess-accessor-name #'name)
+ #f)]
+ [else
+ (syntax-violation 'define-record-type "invalid field specifier" x)]))
+ (map f fields))
+
+ (define-syntax define-record-type0
+ (lambda (stx)
+ (define *unspecified* (cons #f #f))
+ (define (unspecified? obj)
+ (eq? *unspecified* obj))
+ (syntax-case stx ()
+ ((_ (record-name constructor-name predicate-name) record-clause ...)
+ (let loop ((_fields *unspecified*)
+ (_parent *unspecified*)
+ (_protocol *unspecified*)
+ (_sealed *unspecified*)
+ (_opaque *unspecified*)
+ (_nongenerative *unspecified*)
+ (_constructor *unspecified*)
+ (_parent-rtd *unspecified*)
+ (record-clauses #'(record-clause ...)))
+ (syntax-case record-clauses
+ (fields parent protocol sealed opaque nongenerative
+ constructor parent-rtd)
+ [()
+ (let* ((fields (if (unspecified? _fields) '() _fields))
+ (field-names (list->vector (map car fields)))
+ (field-accessors
+ (fold-left (lambda (lst x c)
+ (cons #`(define #,(cadr x)
+ (record-accessor record-name #,c))
+ lst))
+ '() fields (sequence (length fields))))
+ (field-mutators
+ (fold-left (lambda (lst x c)
+ (if (caddr x)
+ (cons #`(define #,(caddr x)
+ (record-mutator record-name
+ #,c))
+ lst)
+ lst))
+ '() fields (sequence (length fields))))
+ (parent-cd (cond ((not (unspecified? _parent))
+ #`(record-constructor-descriptor
+ #,_parent))
+ ((not (unspecified? _parent-rtd))
+ (cadr _parent-rtd))
+ (else #f)))
+ (parent-rtd (cond ((not (unspecified? _parent))
+ #`(record-type-descriptor #,_parent))
+ ((not (unspecified? _parent-rtd))
+ (car _parent-rtd))
+ (else #f)))
+ (protocol (if (unspecified? _protocol) #f _protocol))
+ (uid (if (unspecified? _nongenerative) #f _nongenerative))
+ (sealed? (if (unspecified? _sealed) #f _sealed))
+ (opaque? (if (unspecified? _opaque) #f _opaque)))
+ #`(begin
+ (define record-name
+ (make-record-type-descriptor
+ (quote record-name)
+ #,parent-rtd #,uid #,sealed? #,opaque?
+ #,field-names))
+ (define constructor-name
+ (record-constructor
+ (make-record-constructor-descriptor
+ record-name #,parent-cd #,protocol)))
+ (define dummy
+ (let ()
+ (register-record-type
+ (quote record-name)
+ record-name (make-record-constructor-descriptor
+ record-name #,parent-cd #,protocol))
+ 'dummy))
+ (define predicate-name (record-predicate record-name))
+ #,@field-accessors
+ #,@field-mutators))]
+ [((fields record-fields ...) . rest)
+ (if (unspecified? _fields)
+ (loop (process-fields #'record-name #'(record-fields ...))
+ _parent _protocol _sealed _opaque _nongenerative
+ _constructor _parent-rtd #'rest)
+ (raise (make-assertion-violation)))]
+ [((parent parent-name) . rest)
+ (if (not (unspecified? _parent-rtd))
+ (raise (make-assertion-violation))
+ (if (unspecified? _parent)
+ (loop _fields #'parent-name _protocol _sealed _opaque
+ _nongenerative _constructor _parent-rtd #'rest)
+ (raise (make-assertion-violation))))]
+ [((protocol expression) . rest)
+ (if (unspecified? _protocol)
+ (loop _fields _parent #'expression _sealed _opaque
+ _nongenerative _constructor _parent-rtd #'rest)
+ (raise (make-assertion-violation)))]
+ [((sealed sealed?) . rest)
+ (if (unspecified? _sealed)
+ (loop _fields _parent _protocol #'sealed? _opaque
+ _nongenerative _constructor _parent-rtd #'rest)
+ (raise (make-assertion-violation)))]
+ [((opaque opaque?) . rest)
+ (if (unspecified? _opaque)
+ (loop _fields _parent _protocol _sealed #'opaque?
+ _nongenerative _constructor _parent-rtd #'rest)
+ (raise (make-assertion-violation)))]
+ [((nongenerative) . rest)
+ (if (unspecified? _nongenerative)
+ (loop _fields _parent _protocol _sealed _opaque
+ #`(quote #,(datum->syntax #'record-name (gensym)))
+ _constructor _parent-rtd #'rest)
+ (raise (make-assertion-violation)))]
+ [((nongenerative uid) . rest)
+ (if (unspecified? _nongenerative)
+ (loop _fields _parent _protocol _sealed
+ _opaque #''uid _constructor
+ _parent-rtd #'rest)
+ (raise (make-assertion-violation)))]
+ [((parent-rtd rtd cd) . rest)
+ (if (not (unspecified? _parent))
+ (raise (make-assertion-violation))
+ (if (unspecified? _parent-rtd)
+ (loop _fields _parent _protocol _sealed _opaque
+ _nongenerative _constructor #'(rtd cd)
+ #'rest)
+ (raise (make-assertion-violation))))]))))))
+
+ (define-syntax record-type-descriptor
+ (lambda (stx)
+ (syntax-case stx ()
+ ((_ name) #`(lookup-record-type-descriptor
+ #,(datum->syntax
+ stx (list 'quote (syntax->datum #'name))))))))
+
+ (define-syntax record-constructor-descriptor
+ (lambda (stx)
+ (syntax-case stx ()
+ ((_ name) #`(lookup-record-constructor-descriptor
+ #,(datum->syntax
+ stx (list 'quote (syntax->datum #'name))))))))
+)
diff --git a/module/rnrs/sorting.scm b/module/rnrs/sorting.scm
new file mode 100644
index 000000000..08f44b85b
--- /dev/null
+++ b/module/rnrs/sorting.scm
@@ -0,0 +1,27 @@
+;;; sorting.scm --- The R6RS sorting library
+
+;; Copyright (C) 2010 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 sorting (6))
+ (export list-sort vector-sort vector-sort!)
+ (import (rnrs base (6))
+ (only (guile) *unspecified* stable-sort sort!))
+
+ (define (list-sort proc list) (stable-sort list proc))
+ (define (vector-sort proc vector) (stable-sort vector proc))
+ (define (vector-sort! proc vector) (sort! vector proc) *unspecified*))
diff --git a/module/rnrs/syntax-case.scm b/module/rnrs/syntax-case.scm
new file mode 100644
index 000000000..9d390006d
--- /dev/null
+++ b/module/rnrs/syntax-case.scm
@@ -0,0 +1,68 @@
+;;; syntax-case.scm --- R6RS support for `syntax-case' macros
+
+;; Copyright (C) 2010 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 syntax-case (6))
+ (export make-variable-transformer
+ syntax-case
+ syntax
+
+ identifier?
+ bound-identifier=?
+ free-identifier=?
+
+ syntax->datum
+ datum->syntax
+ generate-temporaries
+ with-syntax
+
+ quasisyntax
+ unsyntax
+ unsyntax-splicing
+
+ syntax-violation)
+ (import (only (guile) make-variable-transformer
+ syntax-case
+ syntax
+
+ identifier?
+ bound-identifier=?
+ free-identifier=?
+
+ syntax->datum
+ datum->syntax
+ generate-temporaries
+ with-syntax
+
+ quasisyntax
+ unsyntax
+ unsyntax-splicing)
+ (ice-9 optargs)
+ (rnrs base (6))
+ (rnrs conditions (6))
+ (rnrs exceptions (6))
+ (rnrs records procedural (6)))
+
+ (define* (syntax-violation who message form #:optional subform)
+ (let* ((conditions (list (make-message-condition message)
+ (make-syntax-violation form subform)))
+ (conditions (if who
+ (cons (make-who-condition who) conditions)
+ conditions)))
+ (raise (apply condition conditions))))
+)
diff --git a/module/rnrs/unicode.scm b/module/rnrs/unicode.scm
new file mode 100644
index 000000000..09140b6bf
--- /dev/null
+++ b/module/rnrs/unicode.scm
@@ -0,0 +1,104 @@
+;;; unicode.scm --- The R6RS Unicode library
+
+;; Copyright (C) 2010 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 unicode (6))
+ (export char-upcase
+ char-downcase
+ char-titlecase
+ char-foldcase
+
+ char-ci=?
+ char-ci<?
+ char-ci>?
+ char-ci<=?
+ char-ci>=?
+
+ char-alphabetic?
+ char-numeric?
+ char-whitespace?
+ char-upper-case?
+ char-lower-case?
+ char-title-case?
+
+ char-general-category
+
+ string-upcase
+ string-downcase
+ string-titlecase
+ string-foldcase
+
+ string-ci=?
+ string-ci<?
+ string-ci>?
+ string-ci<=?
+ string-ci>=?
+
+ string-normalize-nfd
+ string-normalize-nfkd
+ string-normalize-nfc
+ string-normalize-nfkc)
+ (import (only (guile) char-upcase
+ char-downcase
+ char-titlecase
+
+ char-ci=?
+ char-ci<?
+ char-ci>?
+ char-ci<=?
+ char-ci>=?
+
+ char-alphabetic?
+ char-numeric?
+ char-whitespace?
+ char-upper-case?
+ char-lower-case?
+
+ char-set-contains?
+ char-set:title-case
+
+ char-general-category
+
+ char-upcase
+ char-downcase
+ char-titlecase
+
+ string-upcase
+ string-downcase
+ string-titlecase
+
+ string-ci=?
+ string-ci<?
+ string-ci>?
+ string-ci<=?
+ string-ci>=?
+
+ string-normalize-nfd
+ string-normalize-nfkd
+ string-normalize-nfc
+ string-normalize-nfkc)
+ (rnrs base (6)))
+
+ (define (char-foldcase char)
+ (if (or (eqv? char #\460) (eqv? char #\461))
+ char (char-downcase (char-upcase char))))
+
+ (define (char-title-case? char) (char-set-contains? char-set:title-case char))
+
+ (define (string-foldcase str) (string-downcase (string-upcase str)))
+)