summaryrefslogtreecommitdiff
path: root/module
diff options
context:
space:
mode:
authorAndy Wingo <wingo@pobox.com>2019-10-05 21:30:33 +0200
committerAndy Wingo <wingo@pobox.com>2019-11-16 21:09:46 +0100
commitd914652c0abf9644d3e5c9e7394861af7a3a61f1 (patch)
tree4277fa548bd2dbb12e6e2ef6435450e27e1a5e75 /module
parentaabea7394a1a809177c94fd0548b69479a1a0629 (diff)
downloadguile-d914652c0abf9644d3e5c9e7394861af7a3a61f1.tar.gz
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.
Diffstat (limited to 'module')
-rw-r--r--module/Makefile.am17
-rw-r--r--module/scheme/base.scm593
-rw-r--r--module/scheme/case-lambda.scm19
-rw-r--r--module/scheme/char.scm85
-rw-r--r--module/scheme/complex.scm22
-rw-r--r--module/scheme/cxr.scm42
-rw-r--r--module/scheme/eval.scm35
-rw-r--r--module/scheme/file.scm24
-rw-r--r--module/scheme/inexact.scm62
-rw-r--r--module/scheme/lazy.scm24
-rw-r--r--module/scheme/load.scm25
-rw-r--r--module/scheme/process-context.scm58
-rw-r--r--module/scheme/r5rs.scm135
-rw-r--r--module/scheme/read.scm19
-rw-r--r--module/scheme/repl.scm19
-rw-r--r--module/scheme/time.scm31
-rw-r--r--module/scheme/write.scm23
17 files changed, 1233 insertions, 0 deletions
diff --git a/module/Makefile.am b/module/Makefile.am
index dff2f9500..c6dff76e3 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 000000000..aec90d231
--- /dev/null
+++ b/module/scheme/base.scm
@@ -0,0 +1,593 @@
+;;; 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 <goran@weinholt.se>, as well as
+;;; https://github.com/okuoku/yuni, written 2014-2018 by OKUMURA Yuki
+;;; <mjt@cltn.org>. 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 (ice-9 exceptions)
+ #:use-module ((srfi srfi-34) #:select (guard))
+ #:use-module (ice-9 textual-ports)
+ #:use-module (ice-9 binary-ports)
+ #:use-module (rnrs bytevectors)
+ #:export (error-object-message error-object-irritants
+ file-error?
+ (r7:error . error)
+ (r7:cond-expand . cond-expand)
+ (r7:include . include)
+ (r7:include-ci . include-ci)
+ (r7:let-syntax . let-syntax)
+ member assoc list-copy map for-each
+ 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 vector->string
+ (r7:string->utf8 . string->utf8)
+ (r7:vector-copy . vector-copy)
+ (r7:vector->list . vector->list)
+ (r7:vector-fill! . vector-fill!)
+ vector-copy! vector-append vector-for-each vector-map
+ (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 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?
+ (exception? . error-object?)
+ even?
+ (inexact->exact . exact)
+ (exact->inexact . inexact)
+ exact-integer-sqrt exact-integer? exact?
+ floor floor-quotient floor-remainder floor/
+ 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-ref
+ list-set! list-tail list? make-bytevector make-list make-parameter
+ make-string make-vector max 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-exception . raise)
+ raise-continuable
+ rational?
+ rationalize read-char
+ (lexical-error? . read-error?)
+ 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-length vector-ref vector-set! vector?
+ when with-exception-handler write-char
+ zero?))
+
+(define* (member x ls #:optional (= equal?))
+ (cond
+ ((eq? = eq?) (memq x ls))
+ ((eq? = eqv?) (memv x ls))
+ (else
+ (unless (procedure? =)
+ (error "not a procedure" =))
+ (let lp ((ls ls))
+ (if (or (null? ls) (= (car ls) x))
+ ls
+ (lp (cdr ls)))))))
+
+(define* (assoc x ls #:optional (= equal?))
+ (cond
+ ((eq? = eq?) (assq x ls))
+ ((eq? = eqv?) (assv x ls))
+ (else
+ (unless (procedure? =)
+ (error "not a procedure" =))
+ (let lp ((ls ls))
+ (cond
+ ((null? ls) #f)
+ ((= (caar ls) x) (car ls))
+ (else (lp (cdr ls))))))))
+
+(define (list-copy x)
+ (if (pair? x)
+ (cons (car x) (list-copy (cdr x)))
+ x))
+
+(define (circular-list? x)
+ (and (pair? x)
+ (let lp ((hare (cdr x)) (tortoise x))
+ (and (pair? hare)
+ (let ((hare (cdr hare)))
+ (and (pair? hare)
+ (or (eq? hare tortoise)
+ (lp (cdr hare) (cdr tortoise)))))))))
+
+(define map
+ (case-lambda
+ ((f l)
+ (unless (or (list? l)
+ (circular-list? l))
+ (scm-error 'wrong-type-arg "map" "Not a list: ~S"
+ (list l) #f))
+ (let map1 ((l l))
+ (if (pair? l)
+ (cons (f (car l)) (map1 (cdr l)))
+ '())))
+
+ ((f l1 l2)
+ (cond
+ ((list? l1)
+ (unless (or (list? l2) (circular-list? l2))
+ (scm-error 'wrong-type-arg "map" "Not a list: ~S"
+ (list l2) #f)))
+ ((circular-list? l1)
+ (unless (list? l2)
+ (scm-error 'wrong-type-arg "map" "Not a finite list: ~S"
+ (list l2) #f)))
+ (else
+ (scm-error 'wrong-type-arg "map" "Not a list: ~S"
+ (list l1) #f)))
+ (let map2 ((l1 l1) (l2 l2))
+ (if (and (pair? l1) (pair? l2))
+ (cons (f (car l1) (car l2))
+ (map2 (cdr l1) (cdr l2)))
+ '())))
+
+ ((f l1 . rest)
+ (let ((lists (cons l1 rest)))
+ (unless (and-map list? lists)
+ (unless (or-map list? lists)
+ (scm-error 'wrong-type-arg "map"
+ "Arguments do not contain a finite list" '() #f))
+ (for-each (lambda (x)
+ (unless (or (list? x) (circular-list? x))
+ (scm-error 'wrong-type-arg "map" "Not a list: ~S"
+ (list x) #f)))
+ lists))
+ (let mapn ((lists lists))
+ (if (and-map pair? lists)
+ (cons (apply f (map car lists)) (mapn (map cdr lists)))
+ '()))))))
+
+(define for-each
+ (case-lambda
+ ((f l)
+ (unless (or (list? l)
+ (circular-list? l))
+ (scm-error 'wrong-type-arg "for-each" "Not a list: ~S"
+ (list l) #f))
+ (let for-each1 ((l l))
+ (when (pair? l)
+ (f (car l))
+ (for-each1 (cdr l)))))
+
+ ((f l1 l2)
+ (cond
+ ((list? l1)
+ (unless (or (list? l2) (circular-list? l2))
+ (scm-error 'wrong-type-arg "for-each" "Not a list: ~S"
+ (list l2) #f)))
+ ((circular-list? l1)
+ (unless (list? l2)
+ (scm-error 'wrong-type-arg "for-each" "Not a finite list: ~S"
+ (list l2) #f)))
+ (else
+ (scm-error 'wrong-type-arg "for-each" "Not a list: ~S"
+ (list l1) #f)))
+ (let for-each2 ((l1 l1) (l2 l2))
+ (when (and (pair? l1) (pair? l2))
+ (f (car l1) (car l2))
+ (for-each2 (cdr l1) (cdr l2)))))
+
+ ((f l1 . rest)
+ (let ((lists (cons l1 rest)))
+ (unless (and-map list? lists)
+ (unless (or-map list? lists)
+ (scm-error 'wrong-type-arg "for-each"
+ "Arguments do not contain a finite list" '() #f))
+ (for-each (lambda (x)
+ (unless (or (list? x) (circular-list? x))
+ (scm-error 'wrong-type-arg "for-each" "Not a list: ~S"
+ (list x) #f)))
+ lists))
+ (let for-eachn ((lists lists))
+ (when (and-map pair? lists)
+ (apply f (map car lists))
+ (for-eachn (map cdr lists))))))))
+
+;; FIXME.
+(define (file-error? x) #f)
+
+(define (error-object-message obj)
+ (and (exception-with-message? obj)
+ (exception-message obj)))
+
+(define (error-object-irritants obj)
+ (and (exception-with-irritants? obj)
+ (exception-irritants obj)))
+
+(define (r7:error message . irritants)
+ (raise-exception
+ (let ((exn (make-exception-with-message message)))
+ (if (null? irritants)
+ exn
+ (make-exception exn
+ (make-exception-with-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 (string->list s) (map string->list s*)))))
+
+(define (bytevector . lis)
+ (u8-list->bytevector lis))
+
+(define (call-with-bytevector-output-port proc)
+ (call-with-values (lambda () (open-bytevector-output-port))
+ (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* (vector-copy! target tstart source
+ #:optional (sstart 0) (send (vector-length source)))
+ "Copy a block of elements from SOURCE to TARGET, both of which must be
+vectors, starting in TARGET at TSTART and starting in SOURCE at SSTART,
+ending when SEND - SSTART elements have been copied. It is an error for
+TARGET to have a length less than TSTART + (SEND - SSTART). SSTART
+defaults to 0 and SEND defaults to the length of SOURCE."
+ (let ((tlen (vector-length target))
+ (slen (vector-length source)))
+ (if (< tstart sstart)
+ (vector-move-left! source sstart send target tstart)
+ (vector-move-right! source sstart send target tstart))))
+
+(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-map
+ (case-lambda*
+ ((f v)
+ (let* ((len (vector-length v))
+ (out (make-vector len #f)))
+ (let lp ((i 0))
+ (when (< i len)
+ (vector-set! out i (f (vector-ref v i)))
+ (lp (1+ i))))
+ out))
+ ((f v . v*)
+ (list->vector (apply map f (map vector->list (cons v v*)))))))
+
+(define vector-for-each
+ (case-lambda*
+ ((f v)
+ (let lp ((i 0))
+ (when (< i (vector-length v))
+ (f (vector-ref v i))
+ (lp (1+ i)))))
+ ((f v . v*)
+ (let ((len (apply min (vector-length v) (map vector-length v*))))
+ (let lp ((i 0))
+ (when (< i len)
+ (apply f (vector-ref v i) (map (lambda (v) (vector-ref v i)) v*))
+ (lp (1+ i))))))))
+
+(define (vector-append . vectors)
+ (if (null? vectors)
+ #()
+ (let* ((len (let lp ((vectors vectors))
+ (if (null? vectors)
+ 0
+ (+ (vector-length (car vectors)) (lp (cdr vectors))))))
+ (out (make-vector len #f)))
+ (let lp ((i 0) (j 0) (v (car vectors)) (v* (cdr vectors)))
+ (cond
+ ((< j (vector-length v))
+ (vector-set! out i (vector-ref v j))
+ (lp (1+ i) (1+ j) v v*))
+ ((null? v*)
+ out)
+ (else
+ (lp i 0 (car v*) (cdr v*))))))))
+
+(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 000000000..992d768d1
--- /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 000000000..b5251fae5
--- /dev/null
+++ b/module/scheme/char.scm
@@ -0,0 +1,85 @@
+;;; 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 <goran@weinholt.se>, as well as
+;;; https://github.com/okuoku/yuni, written 2014-2018 by OKUMURA Yuki
+;;; <mjt@cltn.org>. 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))
+ #:use-module (ice-9 i18n)
+ #: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-locale-downcase . string-downcase)
+ (string-locale-upcase . 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-locale-downcase (string-locale-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 000000000..c7403bc97
--- /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 000000000..97856f2c8
--- /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 000000000..e11698d27
--- /dev/null
+++ b/module/scheme/eval.scm
@@ -0,0 +1,35 @@
+;;; 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)
+ (purify-module! module)
+ (module-use! module (resolve-interface '(guile) #:select '(import)))
+ (for-each (lambda (import-spec)
+ (eval (list 'import import-spec) module))
+ import-specs)
+ ;; Remove the "import" import. FIXME: this is pretty hacky stuff :(
+ (set-module-uses! module (cdr (module-uses module)))
+ (hash-clear! (module-import-obarray module))
+ (module-modified module)
+ module))
diff --git a/module/scheme/file.scm b/module/scheme/file.scm
new file mode 100644
index 000000000..b92849a1e
--- /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 000000000..d597b1ad5
--- /dev/null
+++ b/module/scheme/inexact.scm
@@ -0,0 +1,62 @@
+;;; 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 <goran@weinholt.se>, as well as
+;;; https://github.com/okuoku/yuni, written 2014-2018 by OKUMURA Yuki
+;;; <mjt@cltn.org>. 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 sin sqrt tan)
+ #:export ((r7:finite? . finite?)
+ (r7:infinite? . infinite?)
+ (r7:nan? . nan?)
+ (r7:log . log)))
+
+(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)))
+
+(define r7:log
+ (case-lambda
+ ((x) (log x))
+ ((x y) (/ (log x) (log y)))))
diff --git a/module/scheme/lazy.scm b/module/scheme/lazy.scm
new file mode 100644
index 000000000..c8cf8e19b
--- /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 000000000..0be8d4bb0
--- /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 000000000..5119cf0ce
--- /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 <goran@weinholt.se>, as well as
+;;; https://github.com/okuoku/yuni, written 2014-2018 by OKUMURA Yuki
+;;; <mjt@cltn.org>. 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 000000000..c08c21d0a
--- /dev/null
+++ b/module/scheme/r5rs.scm
@@ -0,0 +1,135 @@
+;;; 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 ((scheme base) #:select ((expt . r7:expt)))
+ #: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
+ (r7:expt . 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 000000000..89f3a1bc2
--- /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 000000000..b25efd87b
--- /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 000000000..a5d43dfff
--- /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 000000000..945827bda
--- /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)))