[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Guile-commits] 01/01: Add initial implementation of R7RS modules
|
From: |
Andy Wingo |
|
Subject: |
[Guile-commits] 01/01: Add initial implementation of R7RS modules |
|
Date: |
Sun, 13 Oct 2019 14:50:00 -0400 (EDT) |
wingo pushed a commit to branch wip-r7rs
in repository guile.
commit 392785186d87e7c542f4b9a6f64079758e3d0dd5
Author: Andy Wingo <address@hidden>
Date: Sat Oct 5 21:30:33 2019 +0200
Add initial implementation of R7RS modules
* module/Makefile.am (SOURCES): Add new files.
* module/scheme/base.scm:
* module/scheme/case-lambda.scm:
* module/scheme/char.scm:
* module/scheme/complex.scm:
* module/scheme/cxr.scm:
* module/scheme/eval.scm:
* module/scheme/file.scm:
* module/scheme/inexact.scm:
* module/scheme/lazy.scm:
* module/scheme/load.scm:
* module/scheme/process-context.scm:
* module/scheme/r5rs.scm:
* module/scheme/read.scm:
* module/scheme/repl.scm:
* module/scheme/time.scm:
* module/scheme/write.scm: New files. Thanks to Göran Weinholt for
akku-scm and OKUMURA Yuki for yuni, off of which some of these files
were based.
---
module/Makefile.am | 17 ++
module/scheme/base.scm | 400 ++++++++++++++++++++++++++++++++++++++
module/scheme/case-lambda.scm | 19 ++
module/scheme/char.scm | 81 ++++++++
module/scheme/complex.scm | 22 +++
module/scheme/cxr.scm | 42 ++++
module/scheme/eval.scm | 31 +++
module/scheme/file.scm | 24 +++
module/scheme/inexact.scm | 56 ++++++
module/scheme/lazy.scm | 24 +++
module/scheme/load.scm | 25 +++
module/scheme/process-context.scm | 58 ++++++
module/scheme/r5rs.scm | 134 +++++++++++++
module/scheme/read.scm | 19 ++
module/scheme/repl.scm | 19 ++
module/scheme/time.scm | 31 +++
module/scheme/write.scm | 23 +++
17 files changed, 1025 insertions(+)
diff --git a/module/Makefile.am b/module/Makefile.am
index fe31675..2bccfba 100644
--- a/module/Makefile.am
+++ b/module/Makefile.am
@@ -236,6 +236,23 @@ SOURCES = \
oop/goops/accessors.scm \
oop/goops/simple.scm \
\
+ scheme/base.scm \
+ scheme/case-lambda.scm \
+ scheme/char.scm \
+ scheme/complex.scm \
+ scheme/cxr.scm \
+ scheme/eval.scm \
+ scheme/file.scm \
+ scheme/inexact.scm \
+ scheme/lazy.scm \
+ scheme/load.scm \
+ scheme/process-context.scm \
+ scheme/r5rs.scm \
+ scheme/read.scm \
+ scheme/repl.scm \
+ scheme/time.scm \
+ scheme/write.scm \
+ \
scripts/compile.scm \
scripts/disassemble.scm \
scripts/display-commentary.scm \
diff --git a/module/scheme/base.scm b/module/scheme/base.scm
new file mode 100644
index 0000000..3f5dace
--- /dev/null
+++ b/module/scheme/base.scm
@@ -0,0 +1,400 @@
+;;; R7RS compatibility libraries
+;;; Copyright (C) 2019 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 program. If not, see
+;;; <http://www.gnu.org/licenses/>.
+
+;;; Based on code from https://gitlab.com/akku/akku-scm, written
+;;; 2018-2019 by Göran Weinholt <address@hidden>, as well as
+;;; https://github.com/okuoku/yuni, written 2014-2018 by OKUMURA Yuki
+;;; <address@hidden>. This code was originally released under the
+;;; following terms:
+;;;
+;;; To the extent possible under law, the author(s) have dedicated
+;;; all copyright and related and neighboring rights to this
+;;; software to the public domain worldwide. This software is
+;;; distributed without any warranty.
+;;;
+;;; See <http://creativecommons.org/publicdomain/zero/1.0/>, for a
+;;; copy of the CC0 Public Domain Dedication.
+
+(define-module (scheme base)
+ #:use-module (srfi srfi-9)
+ #:use-module (srfi srfi-11)
+ #:use-module (rnrs conditions)
+ #:use-module (rnrs exceptions)
+ #:use-module (srfi srfi-43)
+ #:use-module (ice-9 textual-ports)
+ #:use-module (ice-9 binary-ports)
+ #:use-module (rnrs bytevectors)
+ #:export (error-object?
+ error-object-message error-object-irritants
+ file-error? read-error?
+ (r7:error . error)
+ (r7:cond-expand . cond-expand)
+ (r7:include . include)
+ (r7:include-ci . include-ci)
+ (r7:let-syntax . let-syntax)
+ binary-port? textual-port?
+ open-input-bytevector
+ open-output-bytevector get-output-bytevector
+ peek-u8 read-u8 read-bytevector read-bytevector!
+ read-string read-line
+ write-u8 write-bytevector write-string flush-output-port
+ (r7:string-map . string-map)
+ bytevector bytevector-append
+ string->vector
+ (r7:string->utf8 . string->utf8)
+ (r7:vector-copy . vector-copy)
+ (r7:vector->list . vector->list)
+ vector->string
+ (r7:bytevector-copy . bytevector-copy)
+ (r7:bytevector-copy! . bytevector-copy!)
+ (r7:utf8->string . utf8->string)
+ square
+ (r7:expt . expt)
+ boolean=? symbol=?
+ call-with-port
+ features
+ input-port-open? output-port-open?)
+ #:re-export
+ (_
+ ... => else
+ * + - / < <= = > >= abs and append apply assoc assq assv begin
+ boolean?
+ bytevector-length
+ bytevector-u8-ref bytevector-u8-set! bytevector? caar cadr
+ call-with-current-continuation call-with-values
+ call/cc car case cdar cddr cdr ceiling char->integer char-ready?
+ char<=? char<? char=? char>=? char>? char? close-input-port
+ close-output-port close-port complex? cond cons
+ current-error-port current-input-port current-output-port define
+ define-record-type define-syntax define-values denominator do
+ dynamic-wind eof-object eof-object? eq? equal? eqv?
+ even?
+ (inexact->exact . exact)
+ (exact->inexact . inexact)
+ exact-integer-sqrt exact-integer? exact?
+ floor floor-quotient floor-remainder floor/
+ for-each gcd
+ get-output-string guard if inexact?
+ input-port? integer->char integer? lambda lcm
+ length let let* let*-values let-values letrec letrec*
+ letrec-syntax list list->string list->vector list-copy list-ref
+ list-set! list-tail list? make-bytevector make-list make-parameter
+ make-string make-vector map max member memq memv min modulo
+ negative? newline not null? number->string number? numerator odd?
+ open-input-string
+ open-output-string or output-port? pair?
+ parameterize peek-char port? positive? procedure?
+ quasiquote quote quotient raise raise-continuable rational?
+ rationalize read-char
+ real? remainder reverse round set!
+ set-car! set-cdr! string string->list string->number
+ string->symbol string-append
+ string-copy string-copy! string-fill! string-for-each
+ string-length string-ref string-set! string<=? string<?
+ string=? string>=? string>? string? substring symbol->string
+ symbol? syntax-error syntax-rules truncate
+ truncate-quotient truncate-remainder truncate/
+ (char-ready? . u8-ready?)
+ unless
+ unquote unquote-splicing values vector
+ vector-append vector-copy! vector-fill!
+ vector-for-each vector-length vector-map vector-ref vector-set!
+ vector? when with-exception-handler write-char
+ zero?))
+
+(define-condition-type &irritants-condition &message
+ irritants-condition?
+ (irritants condition-irritants))
+
+(define error-object? irritants-condition?)
+(define (file-error? x) #f)
+(define (read-error? x) #f)
+
+(define (error-object-message obj)
+ (and (message-condition? obj)
+ (condition-message obj)))
+
+(define (error-object-irritants obj)
+ (and (irritants-condition? obj)
+ (condition-irritants obj)))
+
+(define (r7:error message . irritants)
+ (raise (condition
+ (&irritants (message message)
+ (irritants irritants)))))
+
+(define-syntax r7:cond-expand
+ (lambda (x)
+ (define (has-req? req)
+ (syntax-case req (and or not library)
+ ((and req ...)
+ (and-map has-req? #'(req ...)))
+ ((or req ...)
+ (or-map has-req? #'(req ...)))
+ ((not req)
+ (not (has-req? #'req)))
+ ((library lib-name)
+ (->bool (resolve-interface (syntax->datum #'lib-name))))
+ (id
+ (identifier? #'id)
+ (memq (syntax->datum #'id) (features)))))
+ (syntax-case x (else)
+ ((_)
+ (syntax-violation 'cond-expand "Unfulfilled cond-expand" x))
+ ((_ (else body ...))
+ #'(begin body ...))
+ ((_ (req body ...) more-clauses ...)
+ (if (has-req? #'req)
+ #'(begin body ...)
+ #'(r7:cond-expand more-clauses ...))))))
+
+(define-syntax-rule (r7:include k fn* ...)
+ (begin (include k fn*) ...))
+
+;; FIXME
+(define-syntax-rule (r7:include-ci k fn* ...)
+ (r7:include k fn* ...))
+
+(define-syntax-rule (r7:let-syntax ((vars trans) ...) . expr)
+ (let-syntax ((vars trans) ...)
+ (let () . expr)))
+
+(define (boolean=? x y . y*)
+ (unless (boolean? x) (error "not a boolean" x))
+ (unless (boolean? y) (error "not a boolean" y))
+ (and (eq? x y)
+ (or (null? y*)
+ (apply boolean=? x y*))))
+
+(define (symbol=? x y . y*)
+ (unless (symbol? x) (error "not a symbol" x))
+ (unless (symbol? y) (error "not a symbol" y))
+ (and (symbol? x)
+ (eq? x y)
+ (or (null? y*)
+ (apply symbol=? x y*))))
+
+(define (binary-port? p) (port? p))
+(define (textual-port? p) (port? p))
+
+(define (open-input-bytevector bv) (open-bytevector-input-port bv))
+
+(define (open-output-bytevector)
+ (let-values (((p extract) (open-bytevector-output-port)))
+ (define pos 0)
+ (define buf #vu8())
+ (define (read! target target-start count)
+ (when (zero? (- (bytevector-length buf) pos))
+ (set! buf (bytevector-append buf (extract)))) ;resets p
+ (let ((count (min count (- (bytevector-length buf) pos))))
+ (bytevector-copy! buf pos
+ target target-start count)
+ (set! pos (+ pos count))
+ count))
+ (define (write! bv start count)
+ (put-bytevector p bv start count)
+ (set! pos (+ pos count))
+ count)
+ (define (get-position)
+ pos)
+ (define (set-position! new-pos)
+ (set! pos new-pos))
+ (define (close)
+ (close-port p))
+ ;; It's actually an input/output port, but only
+ ;; get-output-bytevector should ever read from it. If it was just
+ ;; an output port then there would be no good way for
+ ;; get-output-bytevector to read the data. -weinholt
+ (make-custom-binary-input/output-port
+ "bytevector" read! write! get-position set-position! close)))
+
+(define (get-output-bytevector port)
+ ;; R7RS says "It is an error if port was not created with
+ ;; open-output-bytevector.", so we can safely assume that the port
+ ;; was created by open-output-bytevector. -weinholt
+ (seek port 0 SEEK_SET)
+ (let ((bv (get-bytevector-all port)))
+ (if (eof-object? bv)
+ #vu8()
+ bv)))
+
+(define* (peek-u8 #:optional (port (current-input-port)))
+ (lookahead-u8 port))
+
+(define* (read-u8 #:optional (port (current-output-port)))
+ (get-u8 port))
+
+(define* (read-bytevector len #:optional (port (current-input-port)))
+ (get-bytevector-n port len))
+
+(define* (read-string len #:optional (port (current-input-port)))
+ (get-string-n port len))
+
+(define* (read-bytevector! bv #:optional (port (current-input-port))
+ (start 0) (end (bytevector-length bv)))
+ (get-bytevector-n! port bv start (- end start)))
+
+(define* (read-line #:optional (port (current-input-port)))
+ (get-line port))
+
+(define* (write-u8 obj #:optional (port (current-output-port)))
+ (put-u8 port obj))
+
+(define* (write-bytevector bv #:optional (port (current-output-port))
+ (start 0) (end (bytevector-length bv)))
+ (put-bytevector port bv start (- end start)))
+
+(define* (write-string str #:optional (port (current-output-port))
+ (start 0) (end (string-length str)))
+ (put-string port str start (- end start)))
+
+(define* (flush-output-port #:optional (port (current-output-port)))
+ (force-output port))
+
+(define (r7:string-map proc s . s*)
+ (if (null? s*)
+ (string-map proc s)
+ (list->string (apply map proc s (map string->list s*)))))
+
+(define (bytevector . lis)
+ (u8-list->bytevector lis))
+
+(define (call-with-bytevector-output-port proc)
+ (call-with-values (lambda () (open-output-bytevector))
+ (lambda (port get)
+ (proc port)
+ (get))))
+
+(define (bytevector-append . bvs)
+ (call-with-bytevector-output-port
+ (lambda (p)
+ (for-each (lambda (bv) (put-bytevector p bv)) bvs))))
+
+(define string->vector
+ (case-lambda
+ ((str) (list->vector (string->list str)))
+ ((str start) (string->vector (substring str start)))
+ ((str start end) (string->vector (substring str start end)))))
+
+(define r7:string->utf8
+ (case-lambda
+ ((str) (string->utf8 str))
+ ((str start) (string->utf8 (substring str start)))
+ ((str start end) (string->utf8 (substring str start end)))))
+
+;;; vector
+
+(define (%subvector v start end)
+ (define mlen (- end start))
+ (define out (make-vector (- end start)))
+ (define (itr r)
+ (if (= r mlen)
+ out
+ (begin
+ (vector-set! out r (vector-ref v (+ start r)))
+ (itr (+ r 1)))))
+ (itr 0))
+
+(define r7:vector-copy
+ (case-lambda*
+ ((v) (vector-copy v))
+ ((v start #:optional (end (vector-length v)))
+ (%subvector v start end))))
+
+(define r7:vector->list
+ (case-lambda*
+ ((v) (vector->list v))
+ ((v start #:optional (end (vector-length v)))
+ (vector->list (%subvector v start end)))))
+
+(define vector->string
+ (case-lambda*
+ ((v) (list->string (vector->list v)))
+ ((v start #:optional (end (vector-length v)))
+ (vector->string (%subvector v start end)))))
+
+(define r7:vector-fill!
+ (case-lambda*
+ ((vec fill) (vector-fill! vec fill))
+ ((vec fill start #:optional (end (vector-length vec)))
+ (let lp ((r start))
+ (unless (= r end)
+ (vector-set! vec r fill)
+ (lp (+ r 1)))))))
+
+(define (%subbytevector bv start end)
+ (define mlen (- end start))
+ (define out (make-bytevector mlen))
+ (bytevector-copy! bv start out 0 mlen)
+ out)
+
+(define (%subbytevector1 bv start)
+ (%subbytevector bv start (bytevector-length bv)))
+
+(define r7:bytevector-copy!
+ (case-lambda*
+ ((to at from #:optional
+ (start 0)
+ (end (+ start
+ (min (- (bytevector-length from) start)
+ (- (bytevector-length to) at)))))
+ (bytevector-copy! from start to at (- end start)))))
+
+(define r7:bytevector-copy
+ (case-lambda*
+ ((bv) (bytevector-copy bv))
+ ((bv start #:optional (end (bytevector-length bv)))
+ (%subbytevector bv start end))))
+
+(define r7:utf8->string
+ (case-lambda*
+ ((bv) (utf8->string bv))
+ ((bv start #:optional (end (bytevector-length bv)))
+ (utf8->string (%subbytevector bv start end)))))
+
+(define (square x) (* x x))
+
+(define (r7:expt x y)
+ (if (eqv? x 0.0)
+ (exact->inexact (expt x y))
+ (expt x y)))
+
+(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 (features)
+ (append
+ %cond-expand-features
+ (case (native-endianness)
+ ((big) '(big-endian))
+ ((little) '(little-endian))
+ (else '()))
+ '(r6rs
+ syntax-case
+ r7rs exact-closed ieee-float full-unicode ratios)))
+
+(define (input-port-open? port)
+ (and (not (port-closed? port)) (input-port? port)))
+
+(define (output-port-open? port)
+ (and (not (port-closed? port)) (output-port? port)))
diff --git a/module/scheme/case-lambda.scm b/module/scheme/case-lambda.scm
new file mode 100644
index 0000000..992d768
--- /dev/null
+++ b/module/scheme/case-lambda.scm
@@ -0,0 +1,19 @@
+;;; R7RS compatibility libraries
+;;; Copyright (C) 2019 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 program. If not, see
+;;; <http://www.gnu.org/licenses/>.
+
+(define-module (scheme case-lambda)
+ #:re-export (case-lambda))
diff --git a/module/scheme/char.scm b/module/scheme/char.scm
new file mode 100644
index 0000000..98a20f8
--- /dev/null
+++ b/module/scheme/char.scm
@@ -0,0 +1,81 @@
+;;; R7RS compatibility libraries
+;;; Copyright (C) 2019 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 program. If not, see
+;;; <http://www.gnu.org/licenses/>.
+
+;;; Based on code from https://gitlab.com/akku/akku-scm, written
+;;; 2018-2019 by Göran Weinholt <address@hidden>, as well as
+;;; https://github.com/okuoku/yuni, written 2014-2018 by OKUMURA Yuki
+;;; <address@hidden>. This code was originally released under the
+;;; following terms:
+;;;
+;;; To the extent possible under law, the author(s) have dedicated
+;;; all copyright and related and neighboring rights to this
+;;; software to the public domain worldwide. This software is
+;;; distributed without any warranty.
+;;;
+;;; See <http://creativecommons.org/publicdomain/zero/1.0/>, for a
+;;; copy of the CC0 Public Domain Dedication.
+
+(define-module (scheme char)
+ #:use-module ((srfi srfi-43) #:select (vector-binary-search))
+ #:export (char-foldcase
+ string-foldcase
+ digit-value)
+ #:re-export (char-alphabetic?
+ char-ci<=? char-ci<? char-ci=? char-ci>=?
+ char-ci>? char-downcase char-lower-case?
+ char-numeric? char-upcase char-upper-case? char-whitespace?
+ string-ci<=? string-ci<? string-ci=?
+ string-ci>=? string-ci>? string-downcase
+ string-upcase))
+
+(define (char-foldcase char)
+ (if (or (eqv? char #\460) (eqv? char #\461))
+ char (char-downcase (char-upcase char))))
+
+(define (string-foldcase str) (string-downcase (string-upcase str)))
+
+;; The table can be extracted with:
+;; awk -F ';' '/ZERO;Nd/ {print "#x"$1}' UnicodeData.txt
+;; Up to date with Unicode 11.0.0
+
+(define *decimal-zeroes* '#(#x0030 #x0660 #x06F0 #x07C0 #x0966 #x09E6
+ #x0A66 #x0AE6 #x0B66 #x0BE6 #x0C66 #x0CE6 #x0D66 #x0DE6 #x0E50
+ #x0ED0 #x0F20 #x1040 #x1090 #x17E0 #x1810 #x1946 #x19D0 #x1A80
+ #x1A90 #x1B50 #x1BB0 #x1C40 #x1C50 #xA620 #xA8D0 #xA900 #xA9D0
+ #xA9F0 #xAA50 #xABF0 #xFF10 #x104A0 #x10D30 #x11066 #x110F0 #x11136
+ #x111D0 #x112F0 #x11450 #x114D0 #x11650 #x116C0 #x11730 #x118E0
+ #x11C50 #x11D50 #x11DA0 #x16A60 #x16B50 #x1D7CE #x1D7D8 #x1D7E2
+ #x1D7EC #x1D7F6 #x1E950))
+
+(define (digit-value char)
+ (define (cmp zero ch)
+ (if (integer? ch)
+ (- (cmp zero ch))
+ (let ((i (char->integer ch)))
+ (cond ((< i zero) 1)
+ ((> i (+ zero 9)) -1)
+ (else 0)))))
+ (unless (char? char)
+ (error "Expected a char" char))
+ (cond
+ ((char<=? #\0 char #\9) ;fast case
+ (- (char->integer char) (char->integer #\0)))
+ ((vector-binary-search *decimal-zeroes* char cmp)
+ => (lambda (zero)
+ (- (char->integer char)
+ (vector-ref *decimal-zeroes* zero))))
+ (else #f)))
diff --git a/module/scheme/complex.scm b/module/scheme/complex.scm
new file mode 100644
index 0000000..c7403bc
--- /dev/null
+++ b/module/scheme/complex.scm
@@ -0,0 +1,22 @@
+;;; R7RS compatibility libraries
+;;; Copyright (C) 2019 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 program. If not, see
+;;; <http://www.gnu.org/licenses/>.
+
+(define-module (scheme complex)
+ #:re-export (make-polar
+ magnitude angle
+ make-rectangular
+ imag-part real-part))
diff --git a/module/scheme/cxr.scm b/module/scheme/cxr.scm
new file mode 100644
index 0000000..97856f2
--- /dev/null
+++ b/module/scheme/cxr.scm
@@ -0,0 +1,42 @@
+;;; R7RS compatibility libraries
+;;; Copyright (C) 2019 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 program. If not, see
+;;; <http://www.gnu.org/licenses/>.
+
+(define-module (scheme cxr)
+ #:re-export (caaaar
+ caaadr
+ caaar
+ caadar
+ caaddr
+ caadr
+ cadaar
+ cadadr
+ cadar
+ caddar
+ cadddr
+ caddr
+ cdaaar
+ cdaadr
+ cdaar
+ cdadar
+ cdaddr
+ cdadr
+ cddaar
+ cddadr
+ cddar
+ cdddar
+ cddddr
+ cdddr))
diff --git a/module/scheme/eval.scm b/module/scheme/eval.scm
new file mode 100644
index 0000000..12aaa50
--- /dev/null
+++ b/module/scheme/eval.scm
@@ -0,0 +1,31 @@
+;;; R7RS compatibility libraries
+;;; Copyright (C) 2019 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 program. If not, see
+;;; <http://www.gnu.org/licenses/>.
+
+(define-module (scheme eval)
+ #:use-module (ice-9 match)
+ #:export (environment)
+ #:re-export (eval))
+
+(define (environment . import-specs)
+ (let ((module (make-module)))
+ (beautify-user-module! module)
+ (for-each (lambda (import-spec)
+ (eval (list 'import import-spec) module))
+ import-specs)
+ (unless (member '(guile) import-specs)
+ (purify-module! module))
+ module))
diff --git a/module/scheme/file.scm b/module/scheme/file.scm
new file mode 100644
index 0000000..b92849a
--- /dev/null
+++ b/module/scheme/file.scm
@@ -0,0 +1,24 @@
+;;; R7RS compatibility libraries
+;;; Copyright (C) 2019 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 program. If not, see
+;;; <http://www.gnu.org/licenses/>.
+
+(define-module (scheme file)
+ #:re-export ((open-input-file . open-binary-input-file)
+ (open-output-file . open-binary-output-file)
+ call-with-input-file call-with-output-file
+ delete-file file-exists?
+ open-input-file open-output-file with-input-from-file
+ with-output-to-file))
diff --git a/module/scheme/inexact.scm b/module/scheme/inexact.scm
new file mode 100644
index 0000000..9d1e6db
--- /dev/null
+++ b/module/scheme/inexact.scm
@@ -0,0 +1,56 @@
+;;; R7RS compatibility libraries
+;;; Copyright (C) 2019 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 program. If not, see
+;;; <http://www.gnu.org/licenses/>.
+
+;;; Based on code from https://gitlab.com/akku/akku-scm, written
+;;; 2018-2019 by Göran Weinholt <address@hidden>, as well as
+;;; https://github.com/okuoku/yuni, written 2014-2018 by OKUMURA Yuki
+;;; <address@hidden>. This code was originally released under the
+;;; following terms:
+;;;
+;;; To the extent possible under law, the author(s) have dedicated
+;;; all copyright and related and neighboring rights to this
+;;; software to the public domain worldwide. This software is
+;;; distributed without any warranty.
+;;;
+;;; See <http://creativecommons.org/publicdomain/zero/1.0/>, for a
+;;; copy of the CC0 Public Domain Dedication.
+
+(define-module (scheme inexact)
+ #:re-export ((exact->inexact . inexact)
+ (inexact->exact . exact)
+ acos asin atan cos exp log sin sqrt tan)
+ #:export ((r7:finite? . finite?)
+ (r7:infinite? . infinite?)
+ (r7:nan? . nan?)))
+
+(define (r7:finite? z)
+ (if (complex? z)
+ (and (finite? (real-part z))
+ (finite? (imag-part z)))
+ (finite? z)))
+
+(define (r7:infinite? z)
+ (if (complex? z)
+ (or (inf? (real-part z))
+ (inf? (imag-part z)))
+ (inf? z)))
+
+(define (r7:nan? z)
+ (if (complex? z)
+ (or (nan? (real-part z))
+ (nan? (imag-part z)))
+ (nan? z)))
diff --git a/module/scheme/lazy.scm b/module/scheme/lazy.scm
new file mode 100644
index 0000000..c8cf8e1
--- /dev/null
+++ b/module/scheme/lazy.scm
@@ -0,0 +1,24 @@
+;;; R7RS compatibility libraries
+;;; Copyright (C) 2019 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 program. If not, see
+;;; <http://www.gnu.org/licenses/>.
+
+(define-module (scheme lazy)
+ #:use-module (srfi srfi-45)
+ #:re-export ((eager . make-promise)
+ (lazy . delay-force)
+ delay
+ force
+ promise?))
diff --git a/module/scheme/load.scm b/module/scheme/load.scm
new file mode 100644
index 0000000..0be8d4b
--- /dev/null
+++ b/module/scheme/load.scm
@@ -0,0 +1,25 @@
+;;; R7RS compatibility libraries
+;;; Copyright (C) 2019 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 program. If not, see
+;;; <http://www.gnu.org/licenses/>.
+
+(define-module (scheme load)
+ #:export ((r7:load . load)))
+
+(define* (r7:load fn #:optional (env (current-module)))
+ (save-module-excursion
+ (lambda ()
+ (set-current-module env)
+ (load fn))))
diff --git a/module/scheme/process-context.scm
b/module/scheme/process-context.scm
new file mode 100644
index 0000000..5119cf0
--- /dev/null
+++ b/module/scheme/process-context.scm
@@ -0,0 +1,58 @@
+;;; R7RS compatibility libraries
+;;; Copyright (C) 2019 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 program. If not, see
+;;; <http://www.gnu.org/licenses/>.
+
+;;; Based on code from https://gitlab.com/akku/akku-scm, written
+;;; 2018-2019 by Göran Weinholt <address@hidden>, as well as
+;;; https://github.com/okuoku/yuni, written 2014-2018 by OKUMURA Yuki
+;;; <address@hidden>. This code was originally released under the
+;;; following terms:
+;;;
+;;; To the extent possible under law, the author(s) have dedicated
+;;; all copyright and related and neighboring rights to this
+;;; software to the public domain worldwide. This software is
+;;; distributed without any warranty.
+;;;
+;;; See <http://creativecommons.org/publicdomain/zero/1.0/>, for a
+;;; copy of the CC0 Public Domain Dedication.
+
+(define-module (scheme process-context)
+ #:use-module (srfi srfi-98)
+ #:re-export (command-line
+ get-environment-variable
+ get-environment-variables)
+ #:export (emergency-exit
+ (r7:exit . exit)))
+
+(define (translate-status status)
+ (case status
+ ((#t) 0)
+ ((#f) 1)
+ (else status)))
+
+(define r7:exit
+ (case-lambda
+ (()
+ (exit))
+ ((status)
+ (exit (translate-status status)))))
+
+(define emergency-exit
+ (case-lambda
+ (()
+ (primitive-_exit))
+ ((status)
+ (primitive-_exit (translate-status status)))))
diff --git a/module/scheme/r5rs.scm b/module/scheme/r5rs.scm
new file mode 100644
index 0000000..6ccf511
--- /dev/null
+++ b/module/scheme/r5rs.scm
@@ -0,0 +1,134 @@
+;;; R7RS compatibility libraries
+;;; Copyright (C) 2019 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 program. If not, see
+;;; <http://www.gnu.org/licenses/>.
+
+(define-module (scheme r5rs)
+ #:use-module ((ice-9 safe-r5rs) #:select (null-environment))
+ #:use-module ((ice-9 r5rs) #:select (scheme-report-environment
+ interaction-environment))
+ #:re-export (quote
+ quasiquote
+ unquote unquote-splicing
+ define-syntax let-syntax letrec-syntax
+ define lambda let let* letrec begin do
+ if set! delay and or
+ syntax-rules _ ... else =>
+
+ eqv? eq? equal?
+ number? complex? real? rational? integer?
+ exact? inexact?
+ = < > <= >=
+ zero? positive? negative? odd? even?
+ max min
+ + * - /
+ abs
+ quotient remainder modulo
+ gcd lcm
+ numerator denominator
+ rationalize
+ floor ceiling truncate round
+ exp log sin cos tan asin acos atan
+ sqrt
+ expt
+ make-rectangular make-polar real-part imag-part magnitude angle
+ exact->inexact inexact->exact
+
+ number->string string->number
+
+ boolean?
+ not
+
+ pair?
+ cons car cdr
+ set-car! set-cdr!
+ caar cadr cdar cddr
+ caaar caadr cadar caddr cdaar cdadr cddar cdddr
+ caaaar caaadr caadar caaddr cadaar cadadr caddar cadddr
+ cdaaar cdaadr cdadar cdaddr cddaar cddadr cdddar cddddr
+ null?
+ list?
+ list
+ length
+ append
+ reverse
+ list-tail list-ref
+ memq memv member
+ assq assv assoc
+
+ symbol?
+ symbol->string string->symbol
+
+ char?
+ char=? char<? char>? char<=? char>=?
+ char-ci=? char-ci<? char-ci>? char-ci<=? char-ci>=?
+ char-alphabetic? char-numeric? char-whitespace?
+ char-upper-case? char-lower-case?
+ char->integer integer->char
+ char-upcase
+ char-downcase
+
+ string?
+ make-string
+ string
+ string-length
+ string-ref string-set!
+ string=? string-ci=?
+ string<? string>? string<=? string>=?
+ string-ci<? string-ci>? string-ci<=? string-ci>=?
+ substring
+ string-length
+ string-append
+ string->list list->string
+ string-copy string-fill!
+
+ vector?
+ make-vector
+ vector
+ vector-length
+ vector-ref vector-set!
+ vector->list list->vector
+ vector-fill!
+
+ procedure?
+ apply
+ map
+ for-each
+ force
+
+ call-with-current-continuation
+
+ values
+ call-with-values
+ dynamic-wind
+
+ eval
+
+ input-port? output-port?
+ current-input-port current-output-port
+
+ read
+ read-char
+ peek-char
+ eof-object?
+ char-ready?
+
+ write
+ display
+ newline
+ write-char
+
+ null-environment
+ scheme-report-environment interaction-environment))
diff --git a/module/scheme/read.scm b/module/scheme/read.scm
new file mode 100644
index 0000000..89f3a1b
--- /dev/null
+++ b/module/scheme/read.scm
@@ -0,0 +1,19 @@
+;;; R7RS compatibility libraries
+;;; Copyright (C) 2019 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 program. If not, see
+;;; <http://www.gnu.org/licenses/>.
+
+(define-module (scheme read)
+ #:re-export (read))
diff --git a/module/scheme/repl.scm b/module/scheme/repl.scm
new file mode 100644
index 0000000..b25efd8
--- /dev/null
+++ b/module/scheme/repl.scm
@@ -0,0 +1,19 @@
+;;; R7RS compatibility libraries
+;;; Copyright (C) 2019 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 program. If not, see
+;;; <http://www.gnu.org/licenses/>.
+
+(define-module (scheme repl)
+ #:re-export (interaction-environment))
diff --git a/module/scheme/time.scm b/module/scheme/time.scm
new file mode 100644
index 0000000..a5d43df
--- /dev/null
+++ b/module/scheme/time.scm
@@ -0,0 +1,31 @@
+;;; R7RS compatibility libraries
+;;; Copyright (C) 2019 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 program. If not, see
+;;; <http://www.gnu.org/licenses/>.
+
+(define-module (scheme time)
+ #:use-module (srfi srfi-19)
+ #:export (current-jiffy current-second jiffies-per-second))
+
+(define (jiffies-per-second)
+ internal-time-units-per-second)
+
+(define (current-jiffy)
+ (get-internal-real-time))
+
+(define (current-second)
+ (let ((t (current-time time-tai)))
+ (+ (time-second t)
+ (* 1e-9 (time-nanosecond t)))))
diff --git a/module/scheme/write.scm b/module/scheme/write.scm
new file mode 100644
index 0000000..945827b
--- /dev/null
+++ b/module/scheme/write.scm
@@ -0,0 +1,23 @@
+;;; R7RS compatibility libraries
+;;; Copyright (C) 2019 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 program. If not, see
+;;; <http://www.gnu.org/licenses/>.
+
+(define-module (scheme write)
+ #:use-module (srfi srfi-38)
+ #:re-export (display
+ write
+ (write-with-shared-structure . write-shared)
+ (write . write-simple)))