diff options
author | Andy Wingo <wingo@pobox.com> | 2019-10-05 21:30:33 +0200 |
---|---|---|
committer | Andy Wingo <wingo@pobox.com> | 2019-11-16 21:09:46 +0100 |
commit | d914652c0abf9644d3e5c9e7394861af7a3a61f1 (patch) | |
tree | 4277fa548bd2dbb12e6e2ef6435450e27e1a5e75 /module | |
parent | aabea7394a1a809177c94fd0548b69479a1a0629 (diff) | |
download | guile-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.am | 17 | ||||
-rw-r--r-- | module/scheme/base.scm | 593 | ||||
-rw-r--r-- | module/scheme/case-lambda.scm | 19 | ||||
-rw-r--r-- | module/scheme/char.scm | 85 | ||||
-rw-r--r-- | module/scheme/complex.scm | 22 | ||||
-rw-r--r-- | module/scheme/cxr.scm | 42 | ||||
-rw-r--r-- | module/scheme/eval.scm | 35 | ||||
-rw-r--r-- | module/scheme/file.scm | 24 | ||||
-rw-r--r-- | module/scheme/inexact.scm | 62 | ||||
-rw-r--r-- | module/scheme/lazy.scm | 24 | ||||
-rw-r--r-- | module/scheme/load.scm | 25 | ||||
-rw-r--r-- | module/scheme/process-context.scm | 58 | ||||
-rw-r--r-- | module/scheme/r5rs.scm | 135 | ||||
-rw-r--r-- | module/scheme/read.scm | 19 | ||||
-rw-r--r-- | module/scheme/repl.scm | 19 | ||||
-rw-r--r-- | module/scheme/time.scm | 31 | ||||
-rw-r--r-- | module/scheme/write.scm | 23 |
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))) |