mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-06-16 16:50:21 +02:00
Code Activity

Add initial implementation of R7RS modules

Browse source 
* 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.
This commit is contained in:
Andy Wingo 2019-10-05 21:30:33 +02:00
parent aabea7394a
commit d914652c0a
17 changed files with 1233 additions and 0 deletions
Download patch file Download diff file Expand all files Collapse all files

17
module/Makefile.am
View file

@ -236,6 +236,23 @@ SOURCES = \
oop/goops/accessors.scm \ oop/goops/accessors.scm \
oop/goops/simple.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/compile.scm \
scripts/disassemble.scm \ scripts/disassemble.scm \
scripts/display-commentary.scm \ scripts/display-commentary.scm \

593
module/scheme/base.scm Normal file
View file

@ -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)))

19
module/scheme/case-lambda.scm Normal file
View file

@ -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))

85
module/scheme/char.scm Normal file
View file

@ -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)))

22
module/scheme/complex.scm Normal file
View file

@ -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))

42
module/scheme/cxr.scm Normal file
View file

@ -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))

35
module/scheme/eval.scm Normal file
View file

@ -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))

24
module/scheme/file.scm Normal file
View file

@ -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))

62
module/scheme/inexact.scm Normal file
View file

@ -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)))))

24
module/scheme/lazy.scm Normal file
View file

@ -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?))

25
module/scheme/load.scm Normal file
View file

@ -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))))

58
module/scheme/process-context.scm Normal file
View file

@ -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)))))

135
module/scheme/r5rs.scm Normal file
View file

@ -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))

19
module/scheme/read.scm Normal file
View file

@ -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))

19
module/scheme/repl.scm Normal file
View file

@ -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))

31
module/scheme/time.scm Normal file
View file

@ -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)))))

23
module/scheme/write.scm Normal file
View file

@ -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)))