diff options
Diffstat (limited to 'module/rnrs')
-rw-r--r-- | module/rnrs/arithmetic/bitwise.scm | 92 | ||||
-rw-r--r-- | module/rnrs/arithmetic/fixnums.scm | 291 | ||||
-rw-r--r-- | module/rnrs/arithmetic/flonums.scm | 203 | ||||
-rw-r--r-- | module/rnrs/base.scm | 291 | ||||
-rw-r--r-- | module/rnrs/bytevectors.scm | 83 | ||||
-rw-r--r-- | module/rnrs/conditions.scm | 225 | ||||
-rw-r--r-- | module/rnrs/control.scm | 22 | ||||
-rw-r--r-- | module/rnrs/enums.scm | 152 | ||||
-rw-r--r-- | module/rnrs/eval.scm | 39 | ||||
-rw-r--r-- | module/rnrs/exceptions.scm | 276 | ||||
-rw-r--r-- | module/rnrs/files.scm | 96 | ||||
-rw-r--r-- | module/rnrs/hashtables.scm | 190 | ||||
-rw-r--r-- | module/rnrs/io/ports.scm | 546 | ||||
-rw-r--r-- | module/rnrs/io/simple.scm | 167 | ||||
-rw-r--r-- | module/rnrs/lists.scm | 55 | ||||
-rw-r--r-- | module/rnrs/mutable-pairs.scm | 23 | ||||
-rw-r--r-- | module/rnrs/mutable-strings.scm | 23 | ||||
-rw-r--r-- | module/rnrs/programs.scm | 22 | ||||
-rw-r--r-- | module/rnrs/r5rs.scm | 34 | ||||
-rw-r--r-- | module/rnrs/records/inspection.scm | 81 | ||||
-rw-r--r-- | module/rnrs/records/procedural.scm | 291 | ||||
-rw-r--r-- | module/rnrs/records/syntactic.scm | 248 | ||||
-rw-r--r-- | module/rnrs/sorting.scm | 27 | ||||
-rw-r--r-- | module/rnrs/syntax-case.scm | 68 | ||||
-rw-r--r-- | module/rnrs/unicode.scm | 104 |
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))) +) |