diff --git a/README.md b/README.md index 3028a4479..e461c181a 100644 --- a/README.md +++ b/README.md @@ -48,7 +48,9 @@ Subset of R7RS-small. | [ 6](https://srfi.schemers.org/srfi-6/srfi-6.html) | Basic String Ports | [`(srfi 6)`](./basis/srfi-6.ss)
[`(scheme base)`](./basis/r7rs.ss) | R7RS 6.13 | | [ 8](https://srfi.schemers.org/srfi-8/srfi-8.html) | receive: Binding to multiple values | [`(srfi 8)`](./basis/srfi-8.ss) | | | [ 10](https://srfi.schemers.org/srfi-10/srfi-10.html) | #, external form | built-in | | +| [ 11](https://srfi.schemers.org/srfi-11/srfi-11.html) | Syntax for receiving multiple values | [`(srfi 11)`](./basis/srfi-11.ss)
[`(scheme base)`](./basis/r7rs.ss) | R7RS 4.2.2 | | [ 23](https://srfi.schemers.org/srfi-23/srfi-23.html) | Error reporting mechanism | [`(srfi 23)`](./basis/srfi-23.ss)
[`(scheme base)`](./basis/r7rs.ss) | R7RS 6.11 | +| [ 30](https://srfi.schemers.org/srfi-30/srfi-30.html) | Nested Multi-line Comments | built-in | R7RS 2.2 | | [ 34](https://srfi.schemers.org/srfi-34/srfi-34.html) | Exception Handling for Programs | [`(srfi 34)`](./basis/srfi-34.ss)
[`(scheme base)`](./basis/r7rs.ss) | R7RS 6.11 | | [ 39](https://srfi.schemers.org/srfi-39/srfi-39.html) | Parameter objects | [`(srfi 39)`](./basis/srfi-39.ss)
[`(scheme base)`](./basis/r7rs.ss) | R7RS 4.2.6 | | [ 45](https://srfi.schemers.org/srfi-45/srfi-45.html) | Primitives for Expressing Iterative Lazy Algorithms | [`(srfi 45)`](./basis/srfi-45.ss) | [#296](https://github.com/yamacir-kit/meevax/issues/296) @@ -103,9 +105,9 @@ sudo rm -rf /usr/local/share/meevax | Target Name | Description |:-------------------|:-- -| `all` (default) | Build shared-library `libmeevax.0.4.117.so` and executable `meevax`. +| `all` (default) | Build shared-library `libmeevax.0.4.166.so` and executable `meevax`. | `test` | Test executable `meevax`. -| `package` | Generate debian package `meevax_0.4.117_amd64.deb`. +| `package` | Generate debian package `meevax_0.4.166_amd64.deb`. | `install` | Copy files into `/usr/local` __(1)__. | `install.deb` | `all` + `package` + `sudo apt install .deb` | `safe-install.deb` | `all` + `test` + `package` + `sudo apt install .deb` @@ -120,7 +122,7 @@ __(1)__ Meevax installed by `make install` cannot be uninstalled by the system's ## Usage ``` -Meevax Lisp System, version 0.4.117 +Meevax Lisp System, version 0.4.166 Usage: meevax [OPTION...] [FILE...] diff --git a/VERSION b/VERSION index 1356ff810..362b83357 100644 --- a/VERSION +++ b/VERSION @@ -1 +1 @@ -0.4.117 +0.4.166 diff --git a/basis/r4rs-essential.ss b/basis/r4rs-essential.ss index 6b893bd8f..815241138 100644 --- a/basis/r4rs-essential.ss +++ b/basis/r4rs-essential.ss @@ -11,7 +11,8 @@ (meevax read) (meevax string) (meevax symbol) - (rename (meevax syntax) (call-with-current-continuation! call-with-current-continuation)) + (rename (meevax syntax) + (call-with-current-continuation! call-with-current-continuation)) (meevax vector) (meevax write) (srfi 211 explicit-renaming)) @@ -40,15 +41,13 @@ open-output-file close-input-port close-output-port read read-char peek-char eof-object? write display newline write-char load) - (begin (define (unspecified) (if #f #f)) - - (define (list . xs) xs) + (begin (define (list . xs) xs) (define-syntax cond (er-macro-transformer (lambda (form rename compare) (if (null? (cdr form)) - (unspecified) + (if #f #f) ((lambda (clause) (if (compare (rename 'else) (car clause)) (cons (rename 'begin) (cdr clause)) @@ -284,7 +283,7 @@ (else `(,(rename 'begin) ,@xs)))) (define (each-clause clauses) (cond ((null? clauses) - (unspecified)) + (if #f #f)) ((compare (rename 'else) (caar clauses)) (body (cdar clauses))) ((and (pair? (caar clauses)) @@ -566,14 +565,14 @@ (current-input-port)))) (define (read-char . port) - (%read-char (if (pair? port) - (car port) - (current-input-port)))) + (get-char! (if (pair? port) + (car port) + (current-input-port)))) (define (peek-char . port) - (%peek-char (if (pair? port) - (car port) - (current-input-port)))) + (get-char (if (pair? port) + (car port) + (current-input-port)))) (define (write x . port) (%write-simple x (if (pair? port) diff --git a/basis/r4rs.ss b/basis/r4rs.ss index 86712c318..71e161739 100644 --- a/basis/r4rs.ss +++ b/basis/r4rs.ss @@ -1,7 +1,7 @@ (define-library (scheme r4rs) (import (meevax inexact) (only (meevax number) exact-integer? expt exact inexact ratio?) - (only (meevax port) read-ready? standard-input-port standard-output-port) + (only (meevax port) get-ready? standard-input-port standard-output-port) (only (meevax string) string-copy) (only (meevax syntax) define-syntax) (only (meevax vector) vector-fill!) @@ -119,10 +119,6 @@ (atan (imag-part z) (real-part z))) - ; (define exact->inexact inexact) - ; - ; (define inexact->exact exact) - (define (list-tail x k) (let list-tail ((x x) (k k)) @@ -166,6 +162,6 @@ (set! %current-output-port previous-output-port))) (define (char-ready? . port) - (read-ready? (if (pair? port) - (car port) - (current-input-port)))))) + (get-ready? (if (pair? port) + (car port) + (current-input-port)))))) diff --git a/basis/r5rs.ss b/basis/r5rs.ss index 28b7364b7..0a61ff1ff 100644 --- a/basis/r5rs.ss +++ b/basis/r5rs.ss @@ -37,8 +37,8 @@ (apply emergency-exit normally?)))) (define-library (scheme r5rs) - (import (meevax environment) - (meevax evaluate) + (import (only (meevax environment) environment) + (only (meevax evaluate) eval) (only (meevax syntax) define-syntax let-syntax letrec-syntax) (except (scheme r4rs) call-with-current-continuation) (except (scheme r5rs continuation) exit) diff --git a/basis/r7rs.ss b/basis/r7rs.ss index 18faafef0..7ab11c823 100644 --- a/basis/r7rs.ss +++ b/basis/r7rs.ss @@ -1,32 +1,31 @@ (define-library (scheme base) - (import (only (meevax exception) error? read-error? file-error? syntax-error?) + (import (only (meevax error) error? read-error? file-error?) (only (meevax number) exact-integer?) - (only (meevax vector) vector->string) - (only (meevax port) - binary-port? - textual-port? - port? - input-port-open? - output-port-open? - standard-input-port - standard-output-port - standard-error-port - eof-object - %read-char - %peek-char - read-ready? - put-char - put-string - %flush-output-port - ) - (meevax version) + (only (meevax vector) vector-append vector-copy vector-copy! string->vector) + (only (meevax port) binary-port? + textual-port? + port? + input-port-open? + output-port-open? + standard-input-port + standard-output-port + standard-error-port + eof-object + get-ready? + get-char + get-char! + put-char + put-string + %flush-output-port) + (only (meevax string) string-copy! vector->string) + (only (meevax version) features) (scheme r5rs) - (srfi 6) ; Basic String Ports + (srfi 6) ; Basic String Ports + (srfi 11) ; Syntax for receiving multiple values (srfi 23) ; Error reporting mechanism (srfi 34) ; Exception Handling for Programs (srfi 39) ; Parameter objects - (srfi 211 explicit-renaming) - ) + (srfi 211 explicit-renaming)) (export quote lambda @@ -35,8 +34,8 @@ ; include ; include-ci cond - ; else - ; => + else + => case and or @@ -55,13 +54,13 @@ parameterize guard quasiquote - ; unquote - ; unquote-splicing + unquote + unquote-splicing let-syntax letrec-syntax syntax-rules - ; _ - ; ... + _ + ... ; syntax-error define ; define-values @@ -116,8 +115,8 @@ square ; exact-integer-sqrt expt - inexact - exact + (rename exact->inexact inexact) + (rename inexact->exact exact) number->string string->number not @@ -178,7 +177,7 @@ string->list list->string string-copy - ; string-copy! + string-copy! string-fill! vector? make-vector @@ -189,10 +188,10 @@ vector->list list->vector vector->string - ; string->vector - ; vector-copy - ; vector-copy! - ; vector-append + string->vector + vector-copy + vector-copy! + vector-append vector-fill! ; bytevector? ; make-bytevector @@ -267,9 +266,7 @@ flush-output-port features) - (begin (define (unspecified) (if #f #f)) - - (define-syntax when + (begin (define-syntax when (er-macro-transformer (lambda (form rename compare) `(,(rename 'if) ,(cadr form) @@ -306,11 +303,8 @@ (values (truncate-quotient x y) (truncate-remainder x y))) - (define (square z) (* z z)) - - (define inexact exact->inexact) - - (define exact inexact->exact) + (define (square z) + (* z z)) (define (make-list k . x) (let ((x (if (pair? x) (car x) #f))) @@ -318,8 +312,8 @@ (xs '() (cons x xs))) ((<= i 0) xs)))) - (define (list-set! x k object) - (set-car! (list-tail x k) object)) + (define (list-set! xs k x) + (set-car! (list-tail xs k) x)) (define (list-copy x) (let list-copy ((x x)) @@ -343,8 +337,7 @@ (define (error-object? x) (or (error? x) (read-error? x) - (file-error? x) - (syntax-error? x))) + (file-error? x))) ; (define (call-with-port port procedure) ; (let-values ((results (procedure port))) @@ -386,22 +379,22 @@ (define (close-port x) (cond ((input-port? x) (close-input-port x)) ((output-port? x) (close-output-port x)) - (else (unspecified)))) + (else (if #f #f)))) (define (read-char . x) - (%read-char (if (pair? x) - (car x) - (current-input-port)))) + (get-char! (if (pair? x) + (car x) + (current-input-port)))) (define (peek-char . x) - (%peek-char (if (pair? x) - (car x) - (current-input-port)))) + (get-char (if (pair? x) + (car x) + (current-input-port)))) (define (char-ready? . x) - (read-ready? (if (pair? x) - (car x) - (current-input-port)))) + (get-ready? (if (pair? x) + (car x) + (current-input-port)))) (define (write-char x . port) (put-char x (if (pair? port) @@ -422,183 +415,7 @@ (car port) (current-output-port)))) ) - - (begin (define-syntax cond - (syntax-rules (else =>) - ((cond (else result1 result2 ...)) - (begin result1 result2 ...)) - ((cond (test => result)) - (let ((temp test)) - (if temp (result temp)))) - ((cond (test => result) clause1 clause2 ...) - (let ((temp test)) - (if temp - (result temp) - (cond clause1 clause2 ...)))) - ((cond (test)) test) - ((cond (test) clause1 clause2 ...) - (let ((temp test)) - (if temp - temp - (cond clause1 clause2 ...)))) - ((cond (test result1 result2 ...)) - (if test (begin result1 result2 ...))) - ((cond (test result1 result2 ...) - clause1 clause2 ...) - (if test - (begin result1 result2 ...) - (cond clause1 clause2 ...))))) - - (define-syntax case ; errata version - (syntax-rules (else =>) - ((case (key ...) clauses ...) - (let ((atom-key (key ...))) - (case atom-key clauses ...))) - ((case key - (else => result)) - (result key)) - ((case key - (else result1 result2 ...)) - (begin result1 result2 ...)) - ((case key - ((atoms ...) => result)) - (if (memv key '(atoms ...)) - (result key))) - ((case key ((atoms ...) => result) clause clauses ...) - (if (memv key '(atoms ...)) - (result key) - (case key clause clauses ...))) - ((case key ((atoms ...) result1 result2 ...)) - (if (memv key '(atoms ...)) - (begin result1 result2 ...))) - ((case key ((atoms ...) result1 result2 ...) clause clauses ...) - (if (memv key '(atoms ...)) - (begin result1 result2 ...) - (case key clause clauses ...))))) - - (define-syntax and - (syntax-rules () - ((and) #t) - ((and test) test) - ((and test1 test2 ...) - (if test1 (and test2 ...) #f)))) - - (define-syntax or - (syntax-rules () - ((or) #f) - ((or test) test) - ((or test1 test2 ...) - (let ((x test1)) - (if x x (or test2 ...)))))) - - (define-syntax when - (syntax-rules () - ((when test result1 result2 ...) - (if test - (begin result1 result2 ...))))) - - (define-syntax unless - (syntax-rules () - ((unless test result1 result2 ...) - (if (not test) - (begin result1 result2 ...))))) - - (define-syntax let - (syntax-rules () - ((let ((name val) ...) body1 body2 ...) - ((lambda (name ...) body1 body2 ...) val ...)) - ((let tag ((name val) ...) body1 body2 ...) - ((letrec ((tag (lambda (name ...) body1 body2 ...))) tag) val ...)))) - - (define-syntax let* - (syntax-rules () - ((let* () body1 body2 ...) - (let () body1 body2 ...)) - ((let* ((name1 val1) (name2 val2) ...) body1 body2 ...) - (let ((name1 val1)) - (let* ((name2 val2) ...) body1 body2 ...))))) - - (define-syntax letrec* - (syntax-rules () - ((letrec* ((var1 init1) ...) body1 body2 ...) - (let ((var1 ) ...) - (set! var1 init1) - ... - (let () body1 body2 ...))))) - - (define-syntax let-values - (syntax-rules () - ((let-values (binding ...) body0 body1 ...) - (let-values "bind" (binding ...) () (begin body0 body1 ...))) - ((let-values "bind" () tmps body) - (let tmps body)) - ((let-values "bind" ((b0 e0) binding ...) tmps body) - (let-values "mktmp" b0 e0 () (binding ...) tmps body)) - ((let-values "mktmp" () e0 args bindings tmps body) - (call-with-values - (lambda () e0) - (lambda args - (let-values "bind" bindings tmps body)))) - ((let-values "mktmp" (a . b) e0 (arg ...) bindings (tmp ...) body) - (let-values "mktmp" b e0 (arg ... x) bindings (tmp ... (a x)) body)) - ((let-values "mktmp" a e0 (arg ...) bindings (tmp ...) body) - (call-with-values - (lambda () e0) - (lambda (arg ... . x) - (let-values "bind" bindings (tmp ... (a x)) body)))))) - - ; (define-syntax let-values - ; (er-macro-transformer - ; (lambda (form rename compare) - ; (if (null? (cadr form)) - ; `(,(rename 'let) () ,@(cddr form)) - ; `(,(rename 'call-with-values) - ; (,(rename 'lambda) () ,(cadar (cadr form))) - ; (,(rename 'lambda) ,(caar (cadr form)) - ; (,(rename 'let-values) ,(cdr (cadr form)) - ; ,@(cddr form)))))))) - - (define-syntax let*-values - (syntax-rules () - ((let*-values () body0 body1 ...) - (let () body0 body1 ...)) - ((let*-values (binding0 binding1 ...) - body0 body1 ...) - (let-values (binding0) - (let*-values (binding1 ...) - body0 body1 ...))))) - - ; (define-syntax let*-values - ; (er-macro-transformer - ; (lambda (form rename compare) - ; (if (null? (cadr form)) - ; `(,(rename 'let) () ,@(cddr form)) - ; `(,(rename 'let-values) (,(caadr form)) - ; (,(rename 'let*-values) ,(cdadr form) - ; ,@(cddr form))))))) - - (define-syntax do - (syntax-rules () - ((do ((var init step ...) ...) - (test expr ...) - command ...) - (letrec - ((loop - (lambda (var ...) - (if test - (begin - (if #f #f) - expr ...) - (begin - command - ... - (loop (do "step" var step ...) - ...)))))) - (loop init ...))) - ((do "step" x) - x) - ((do "step" x y) - y))))) + ) (define-library (scheme lazy) (import (srfi 45)) @@ -720,10 +537,9 @@ (string-map char-foldcase x)))) (define-library (scheme eval) - (export environment - eval - ) - ) + (import (only (meevax environment) environment) + (only (meevax evaluate) eval)) + (export environment eval)) (define-library (scheme file) (import (only (meevax port) open-input-file open-output-file) diff --git a/basis/srfi-11.ss b/basis/srfi-11.ss new file mode 100644 index 000000000..cae7ee306 --- /dev/null +++ b/basis/srfi-11.ss @@ -0,0 +1,32 @@ +(define-library (srfi 11) + (import (scheme r5rs) + (srfi 211 explicit-renaming)) + + (export let-values let*-values) + + (begin (define-syntax let-values + (syntax-rules () + ((let-values (binding ...) body0 body1 ...) + (let-values "bind" (binding ...) () (begin body0 body1 ...))) + ((let-values "bind" () tmps body) + (let tmps body)) + ((let-values "bind" ((b0 e0) binding ...) tmps body) + (let-values "mktmp" b0 e0 () (binding ...) tmps body)) + ((let-values "mktmp" () e0 args bindings tmps body) + (call-with-values (lambda () e0) + (lambda args + (let-values "bind" bindings tmps body)))) + ((let-values "mktmp" (a . b) e0 (arg ...) bindings (tmp ...) body) + (let-values "mktmp" b e0 (arg ... x) bindings (tmp ... (a x)) body)) + ((let-values "mktmp" a e0 (arg ...) bindings (tmp ...) body) + (call-with-values (lambda () e0) + (lambda (arg ... . x) + (let-values "bind" bindings (tmp ... (a x)) body)))))) + + (define-syntax let*-values + (syntax-rules () + ((let*-values () body0 body1 ...) + (let () body0 body1 ...)) + ((let*-values (binding0 binding1 ...) body0 body1 ...) + (let-values (binding0) + (let*-values (binding1 ...) body0 body1 ...))))))) diff --git a/basis/srfi-23.ss b/basis/srfi-23.ss index 091f35505..88aa8483b 100644 --- a/basis/srfi-23.ss +++ b/basis/srfi-23.ss @@ -1,5 +1,5 @@ (define-library (srfi 23) - (import (only (meevax exception) make-error) + (import (only (meevax error) make-error) (only (scheme r5rs) define apply) (only (srfi 34) raise)) (export error) diff --git a/basis/srfi-34.ss b/basis/srfi-34.ss index b15fe5830..9e0ffe6de 100644 --- a/basis/srfi-34.ss +++ b/basis/srfi-34.ss @@ -19,15 +19,10 @@ ; IN THE SOFTWARE. (define-library (srfi 34) - (import (only (meevax exception) throw) - (scheme r5rs) - ) + (import (only (meevax error) throw) + (scheme r5rs)) - (export with-exception-handler - raise - raise-continuable - guard - ) + (export with-exception-handler raise raise-continuable guard) (begin (define %current-exception-handlers (list throw)) diff --git a/configure/README.md b/configure/README.md index 1eb7467cf..2939d0148 100644 --- a/configure/README.md +++ b/configure/README.md @@ -48,7 +48,9 @@ Subset of R7RS-small. | [ 6](https://srfi.schemers.org/srfi-6/srfi-6.html) | Basic String Ports | [`(srfi 6)`](./basis/srfi-6.ss)
[`(scheme base)`](./basis/r7rs.ss) | R7RS 6.13 | | [ 8](https://srfi.schemers.org/srfi-8/srfi-8.html) | receive: Binding to multiple values | [`(srfi 8)`](./basis/srfi-8.ss) | | | [ 10](https://srfi.schemers.org/srfi-10/srfi-10.html) | #, external form | built-in | | +| [ 11](https://srfi.schemers.org/srfi-11/srfi-11.html) | Syntax for receiving multiple values | [`(srfi 11)`](./basis/srfi-11.ss)
[`(scheme base)`](./basis/r7rs.ss) | R7RS 4.2.2 | | [ 23](https://srfi.schemers.org/srfi-23/srfi-23.html) | Error reporting mechanism | [`(srfi 23)`](./basis/srfi-23.ss)
[`(scheme base)`](./basis/r7rs.ss) | R7RS 6.11 | +| [ 30](https://srfi.schemers.org/srfi-30/srfi-30.html) | Nested Multi-line Comments | built-in | R7RS 2.2 | | [ 34](https://srfi.schemers.org/srfi-34/srfi-34.html) | Exception Handling for Programs | [`(srfi 34)`](./basis/srfi-34.ss)
[`(scheme base)`](./basis/r7rs.ss) | R7RS 6.11 | | [ 39](https://srfi.schemers.org/srfi-39/srfi-39.html) | Parameter objects | [`(srfi 39)`](./basis/srfi-39.ss)
[`(scheme base)`](./basis/r7rs.ss) | R7RS 4.2.6 | | [ 45](https://srfi.schemers.org/srfi-45/srfi-45.html) | Primitives for Expressing Iterative Lazy Algorithms | [`(srfi 45)`](./basis/srfi-45.ss) | [#296](https://github.com/yamacir-kit/meevax/issues/296) diff --git a/include/meevax/iostream/concatenate.hpp b/include/meevax/iostream/concatenate.hpp new file mode 100644 index 000000000..7c3abc932 --- /dev/null +++ b/include/meevax/iostream/concatenate.hpp @@ -0,0 +1,35 @@ +/* + Copyright 2018-2022 Tatsuya Yamasaki. + + Licensed under the Apache License, Version 2.0 (the "License"); + you may not use this file except in compliance with the License. + You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + See the License for the specific language governing permissions and + limitations under the License. +*/ + +#ifndef INCLUDED_MEEVAX_IOSTREAM_CONCATENATE_HPP +#define INCLUDED_MEEVAX_IOSTREAM_CONCATENATE_HPP + +#include + +namespace meevax +{ +inline namespace iostream +{ + auto concatenate = [](auto&&... xs) + { + std::stringstream ss; + (ss << ... << xs); + return ss.str(); + }; +} // namespace iostream +} // namespace meevax + +#endif // INCLUDED_MEEVAX_IOSTREAM_CONCATENATE_HPP diff --git a/include/meevax/iostream/lexical_cast.hpp b/include/meevax/iostream/lexical_cast.hpp index 654a364e1..27fa81dad 100644 --- a/include/meevax/iostream/lexical_cast.hpp +++ b/include/meevax/iostream/lexical_cast.hpp @@ -25,10 +25,10 @@ namespace meevax { inline namespace iostream { - template - auto lexical_cast(From const& from) -> To + template + auto lexical_cast(Ts&&... xs) -> To { - if (std::stringstream ss; ss << from) + if (std::stringstream ss; (ss << ... << xs)) { if constexpr (std::is_same::type, std::string>::value) { @@ -51,7 +51,7 @@ inline namespace iostream else { std::stringstream what; - what << "failed to write " << typeid(From).name() << " type object to std::stringstream"; + ((what << "failed to write"), ..., (what << " " << typeid(Ts).name())) << " type object to std::stringstream"; throw std::runtime_error(what.str()); } } diff --git a/include/meevax/iostream/putback.hpp b/include/meevax/iostream/putback.hpp index 8eb6fbf47..35d59923d 100644 --- a/include/meevax/iostream/putback.hpp +++ b/include/meevax/iostream/putback.hpp @@ -23,6 +23,7 @@ namespace meevax { inline namespace iostream { + [[deprecated]] auto putback(std::istream &, std::string const&) -> std::istream &; } // namespace iostream } // namespace meevax diff --git a/include/meevax/kernel/basis.hpp b/include/meevax/kernel/basis.hpp index a0206fe8d..6129cdc0d 100644 --- a/include/meevax/kernel/basis.hpp +++ b/include/meevax/kernel/basis.hpp @@ -36,6 +36,7 @@ inline namespace kernel extern string_view const srfi_1; extern string_view const srfi_6; extern string_view const srfi_8; + extern string_view const srfi_11; extern string_view const srfi_23; extern string_view const srfi_34; extern string_view const srfi_39; diff --git a/include/meevax/kernel/character.hpp b/include/meevax/kernel/character.hpp index 730a89838..15398c519 100644 --- a/include/meevax/kernel/character.hpp +++ b/include/meevax/kernel/character.hpp @@ -27,17 +27,37 @@ inline namespace kernel { struct character { - using value_type = std::char_traits::int_type; + using char_type = char; - value_type codepoint; + using int_type = std::char_traits::int_type; + + int_type codepoint; explicit character() = default; - explicit character(value_type const); // integer->char + explicit constexpr character(int_type const& codepoint) + : codepoint { codepoint } + {} + + static constexpr auto eq(int_type const& c1, int_type const& c2) + { + return std::char_traits::eq_int_type(c1, c2); + } + + inline constexpr auto eq(int_type const& c) const + { + return std::char_traits::eq_int_type(codepoint, c); + } - explicit character(std::istream &); // read-char + static constexpr auto is_eof(int_type const& c) + { + return eq(std::char_traits::eof(), c); + } - operator value_type() const; // char->integer + inline constexpr operator int_type() const + { + return codepoint; + } explicit operator external_representation() const; // write-char (for display) }; diff --git a/include/meevax/kernel/configurator.hpp b/include/meevax/kernel/configurator.hpp index 697d82ca3..55aa7120f 100644 --- a/include/meevax/kernel/configurator.hpp +++ b/include/meevax/kernel/configurator.hpp @@ -19,6 +19,7 @@ #include +#include #include #include #include @@ -218,7 +219,7 @@ inline namespace kernel } else { - throw error(make(cat, "option -", name, " requires an argument")); + throw error(make(concatenate("option -", name, " requires an argument"))); } } else if (auto iter = short_options.find(*current_short_option); iter != std::end(short_options)) @@ -246,7 +247,7 @@ inline namespace kernel } else { - throw error(make(cat, "option --", current_long_option, " requires an argument")); + throw error(make(concatenate("option --", current_long_option, " requires an argument"))); } } else if (auto iter = long_options.find(current_long_option); iter != std::end(long_options)) diff --git a/include/meevax/kernel/environment.hpp b/include/meevax/kernel/environment.hpp index a60bdd751..b3bcabd8c 100644 --- a/include/meevax/kernel/environment.hpp +++ b/include/meevax/kernel/environment.hpp @@ -39,8 +39,8 @@ inline namespace kernel using configurator::debug; using configurator::trace; - using reader::intern; using reader::read; + using reader::string_to_symbol; explicit environment(environment &&) = default; @@ -59,7 +59,7 @@ inline namespace kernel auto operator [](symbol::value_type const& variable) -> decltype(auto) { - return (*this)[intern(variable)]; + return (*this)[string_to_symbol(variable)]; } auto define(const_reference, const_reference = undefined) -> void; diff --git a/include/meevax/kernel/miscellaneous.hpp b/include/meevax/kernel/eof.hpp similarity index 84% rename from include/meevax/kernel/miscellaneous.hpp rename to include/meevax/kernel/eof.hpp index 77c9cfad0..b81aa0168 100644 --- a/include/meevax/kernel/miscellaneous.hpp +++ b/include/meevax/kernel/eof.hpp @@ -14,8 +14,8 @@ limitations under the License. */ -#ifndef INCLUDED_MEEVAX_KERNEL_MISCELLANEOUS_HPP -#define INCLUDED_MEEVAX_KERNEL_MISCELLANEOUS_HPP +#ifndef INCLUDED_MEEVAX_KERNEL_EOF_HPP +#define INCLUDED_MEEVAX_KERNEL_EOF_HPP #include @@ -32,4 +32,4 @@ inline namespace kernel } // namespace kernel } // namespace meevax -#endif // INCLUDED_MEEVAX_KERNEL_MISCELLANEOUS_HPP +#endif // INCLUDED_MEEVAX_KERNEL_EOF_HPP diff --git a/include/meevax/kernel/number.hpp b/include/meevax/kernel/number.hpp index eea218cd5..3cc588f52 100644 --- a/include/meevax/kernel/number.hpp +++ b/include/meevax/kernel/number.hpp @@ -19,6 +19,7 @@ #include +#include #include #include #include @@ -75,7 +76,7 @@ inline namespace kernel } else { - throw error(make(cat, "no viable operation ", demangle(typeid(F)), " with ", a, " and ", b)); + throw error(make(concatenate("no viable operation ", demangle(typeid(F)), " with ", a, " and ", b))); } } @@ -111,7 +112,7 @@ inline namespace kernel } else { - throw error(make(cat, "no viable operation ", demangle(typeid(F)), " with ", a, " and ", b)); + throw error(make(concatenate("no viable operation ", demangle(typeid(F)), " with ", a, " and ", b))); } } diff --git a/include/meevax/kernel/overview.hpp b/include/meevax/kernel/overview.hpp index e17f720db..7875a2e65 100644 --- a/include/meevax/kernel/overview.hpp +++ b/include/meevax/kernel/overview.hpp @@ -34,6 +34,7 @@ inline namespace kernel struct exact_integer; // exact_integer.hpp struct pair; // pair.hpp struct ratio; // ratio.hpp + struct vector; // vector.hpp template struct floating_point; // floating_point.hpp diff --git a/include/meevax/kernel/reader.hpp b/include/meevax/kernel/reader.hpp index e3dcd44a4..a20fffd0d 100644 --- a/include/meevax/kernel/reader.hpp +++ b/include/meevax/kernel/reader.hpp @@ -17,13 +17,10 @@ #ifndef INCLUDED_MEEVAX_KERNEL_READER_HPP #define INCLUDED_MEEVAX_KERNEL_READER_HPP -#include -#include -#include #include +#include #include #include -#include // for eof #include #include #include @@ -33,205 +30,17 @@ namespace meevax { inline namespace kernel { - namespace parse - { - // using meevax::iostream::operator *; - // using meevax::iostream::operator +; - using meevax::iostream::operator |; - - // auto intraline_whitespace = satisfy([](auto c) { return std::isblank(c); }); - - // auto line_ending = sequence("\r\n") | one_of('\n', '\r'); - - // auto whitespace = intraline_whitespace | line_ending; - - // auto vertical_line = one_of('|'); - - // auto delimiter = whitespace | vertical_line | one_of('(', ')', '"', ';'); - - // auto letter = satisfy([](auto c) { return std::isalpha(c); }); - - // auto special_initial = one_of('!', '$', '%', '&', '*', '/', ':', '<', '=', '>', '?', '^', '_', '~'); - - // auto initial = letter | special_initial; - - // auto digit = satisfy([](auto c) { return std::isdigit(c); }); - - // auto hex_digit = satisfy([](auto c) { return std::isxdigit(c); }); - - // auto explicit_sign = one_of('+', '-'); - - // auto special_subsequent = explicit_sign | one_of('.', '@'); - - // auto subsequent = initial | digit | special_subsequent; - - // auto inline_hex_escape = sequence("\\x") + hex_digit + many(hex_digit); - - // TODO auto any_character_other_than_vertical_line_or_backslash - - // auto symbol_element = letter; - // // any_character_other_than_vertical_line_or_backslash - // // | inline_hex_escape - // // | mnemonic_escape - // // | s("\\|") - - // auto sign_subsequent = initial | explicit_sign | one_of('@'); - - // auto dot_subsequent = sign_subsequent | one_of('.'); - - // auto peculiar_identifier = explicit_sign - // | explicit_sign + sign_subsequent + many(subsequent) - // | explicit_sign + one_of('.') + dot_subsequent + many(subsequent) - // | one_of('.') + dot_subsequent + many(subsequent); - - // auto identifier = initial + many(subsequent) - // | vertical_line + many(symbol_element) + vertical_line - // | peculiar_identifier; - - // auto boolean = sequence("#true") | sequence("#t") | sequence("#false") | sequence("#f"); - - auto token = [](std::istream & is) // = | | | | | ( | ) | #( | #u8( | ’ | ` | , | ,@ | . - { - auto is_end = [](auto c) constexpr - { - auto one_of = [c](auto... xs) constexpr - { - return (std::char_traits::eq(c, xs) or ...); - }; - - return std::isspace(c) or one_of('"', '#', '\'', '(', ')', ',', ';', '[', ']', '`', '{', '|', '}', std::char_traits::eof()); // NOTE: What read treats specially. - }; + auto get_codepoint(std::istream &) -> character::int_type; - external_representation result; + auto get_delimited_elements(std::istream & is, character::int_type) -> string; - for (auto c = is.peek(); not is_end(c); c = is.peek()) - { - result.push_back(is.get()); - } + auto get_token(std::istream &) -> external_representation; - return result; - }; + auto ignore_nested_block_comment(std::istream &) -> std::istream &; - auto any_character = [](std::istream & is) - { - switch (auto s = token(is); std::size(s)) - { - case 0: - return make(is.get()); - - case 1: - return make(s[0]); - - default: - putback(is, s); - throw read_error(make("If in #\\ is alphabetic, then any character immediately following cannot be one that can appear in an identifier")); - } - }; + auto read_character_literal(std::istream &) -> value_type; - auto character_name = [](std::istream & is) - { - std::unordered_map static const character_names - { - { "alarm" , 0x07 }, - { "backspace", 0x08 }, - { "delete" , 0x7F }, - { "escape" , 0x1B }, - { "newline" , 0x0A }, - { "null" , 0x00 }, - { "return" , 0x0D }, - { "space" , 0x20 }, - { "tab" , 0x09 }, - }; - - auto const name = token(is); - - try - { - return make(character_names.at(name)); - } - catch (...) - { - putback(is, name); - throw read_error(make("invalid "), make("\\#" + name)); - } - }; - - auto hex_scalar_value = [](std::istream & is) - { - if (auto s = token(is); s[0] == 'x' and 1 < std::size(s)) - { - std::stringstream ss; - ss << std::hex << s.substr(1); - - character::value_type value = 0; - ss >> value; - - return make(value); - } - else - { - putback(is, s); - throw read_error(make("invalid "), make("\\#" + s)); - } - }; - - auto character = any_character | character_name | hex_scalar_value; - } - - namespace string_to - { - template , - std::is_invocable)> - auto operator |(F&& f, G&& g) - { - return [=](external_representation const& token, auto radix) - { - try - { - return f(token, radix); - } - catch (...) - { - return g(token, radix); - } - }; - } - - auto integer = [](external_representation const& token, auto radix = 10) -> value_type - { - auto const result = exact_integer(token, radix); - return make(result); - }; - - auto ratio = [](external_representation const& token, auto radix = 10) - { - return meevax::ratio(token, radix).simple(); - }; - - auto decimal = [](external_representation const& token, auto) -> value_type - { - auto const result = double_float(token); - return make(result); - }; - - auto flonum = [](external_representation const& token, auto) - { - if (auto iter = constants.find(token); iter != std::end(constants)) - { - return cdr(*iter); - } - else - { - throw read_error(make("not a number"), make(token)); - } - }; - - auto real = integer | ratio | decimal | flonum; - - auto complex = real; - - auto number = complex; - } // namespace string_to + auto read_string_literal(std::istream &) -> value_type; template class reader @@ -250,23 +59,8 @@ inline namespace kernel inline auto char_ready() const { - return standard_input.is_also() and standard_input.as(); - } - - static auto intern(external_representation const& name) -> const_reference - { - if (auto const iter = symbols.find(name); iter != std::end(symbols)) - { - return cdr(*iter); - } - else if (auto const [iter, success] = symbols.emplace(name, make(name)); success) - { - return cdr(*iter); - } - else - { - throw error(make("failed to intern a symbol"), make(name)); - } + assert(standard_input.is_also()); + return static_cast(standard_input.as()); } inline auto read(std::istream & is) -> value_type @@ -275,144 +69,146 @@ inline namespace kernel { switch (auto const c = *head) { - case ';': - is.ignore(std::numeric_limits::max(), '\n'); + case '\t': // 0x09 + case '\n': // 0x0A + case '\v': // 0x0B + case '\f': // 0x0C + case '\r': // 0x0D + case ' ': // 0x20 break; - case ' ': - case '\f': - case '\n': - case '\r': - case '\t': - case '\v': - break; - - case '(': - case '[': - case '{': - try - { - let const kar = read(is); - is.putback(c); - return cons(kar, read(is)); - } - catch (std::integral_constant const&) { return std::char_traits::eq(c, '(') ? unit : throw; } - catch (std::integral_constant const&) { return std::char_traits::eq(c, '[') ? unit : throw; } - catch (std::integral_constant const&) { return std::char_traits::eq(c, '{') ? unit : throw; } - catch (std::integral_constant const&) - { - let const kdr = read(is); - - switch (c) - { - case '(': ignore(is, [](auto c) { return not std::char_traits::eq(c, ')'); }).get(); break; - case '[': ignore(is, [](auto c) { return not std::char_traits::eq(c, ']'); }).get(); break; - case '{': ignore(is, [](auto c) { return not std::char_traits::eq(c, '}'); }).get(); break; - } - - return kdr; - } - - case ')': throw std::integral_constant(); - case ']': throw std::integral_constant(); - case '}': throw std::integral_constant(); - - case '"': - return make(is); - - case '\'': - return list(intern("quote"), read(is)); - - case '`': - return list(intern("quasiquote"), read(is)); + case '"': // 0x22 + return read_string_literal(is.putback(c)); - case ',': - switch (is.peek()) - { - case '@': - is.ignore(1); - return list(intern("unquote-splicing"), read(is)); - - default: - return list(intern("unquote"), read(is)); - } - - case '#': + case '#': // 0x23 switch (auto const c = is.get()) { - case '!': // from SRFI-22 + case '!': // SRFI 22 is.ignore(std::numeric_limits::max(), '\n'); return read(is); - case ',': // from SRFI-10 + case ',': // SRFI 10 return evaluate(read(is)); - case ';': // from SRFI-62 + case ';': // SRFI 62 return read(is), read(is); + case '"': + return string_to_symbol(get_delimited_elements(is.putback(c), c)); + case 'b': // (string->number (read) 2) - return string_to::number(is.peek() == '#' ? lexical_cast(read(is)) : parse::token(is), 2); + return string_to_number(is.peek() == '#' ? lexical_cast(read(is)) : get_token(is), 2); - case 'c': // from Common Lisp - if (let const xs = read(is); xs.is()) - { - return make(e0, e0); - } - else if (not cdr(xs).is()) - { - return make(car(xs), e0); - } - else + case 'c': // Common Lisp { - return make(car(xs), cadr(xs)); + let const xs = read(is); + return make(list_tail(xs, 0).is() ? list_ref(xs, 0) : e0, + list_tail(xs, 1).is() ? list_ref(xs, 1) : e0); } case 'd': - return string_to::number(is.peek() == '#' ? lexical_cast(read(is)) : parse::token(is), 10); + return string_to_number(is.peek() == '#' ? lexical_cast(read(is)) : get_token(is), 10); case 'e': return read(is).template as().exact(); // NOTE: Same as #,(exact (read)) case 'f': - parse::token(is); + get_token(is); return f; case 'i': return read(is).template as().inexact(); // NOTE: Same as #,(inexact (read)) case 'o': - return string_to::number(is.peek() == '#' ? lexical_cast(read(is)) : parse::token(is), 8); + return string_to_number(is.peek() == '#' ? lexical_cast(read(is)) : get_token(is), 8); case 't': - parse::token(is); + get_token(is); return t; case 'x': - return string_to::number(is.peek() == '#' ? lexical_cast(read(is)) : parse::token(is), 16); + return string_to_number(is.peek() == '#' ? lexical_cast(read(is)) : get_token(is), 16); case '(': is.putback(c); return make(read(is)); case '\\': - return parse::character(is); + return read_character_literal(is); + + case '|': // SRFI 30 + ignore_nested_block_comment(is); + return read(is); default: throw read_error(make("unknown discriminator"), make(c)); } + case '\'': // 0x27 + return list(string_to_symbol("quote"), read(is)); + + case ',': // 0x2C + switch (is.peek()) + { + case '@': + is.ignore(1); + return list(string_to_symbol("unquote-splicing"), read(is)); + + default: + return list(string_to_symbol("unquote"), read(is)); + } + + case ';': // 0x3B + is.ignore(std::numeric_limits::max(), '\n'); + break; + + case '`': // 0x60 + return list(string_to_symbol("quasiquote"), read(is)); + + case '|': // 0x7C + return string_to_symbol(get_delimited_elements(is.putback(c), c)); + + case '(': + case '[': + case '{': + try + { + let const kar = read(is); + return cons(kar, read(is.putback(c))); + } + catch (std::integral_constant const&) { return character::eq(c, '(') ? unit : throw; } + catch (std::integral_constant const&) { return character::eq(c, '[') ? unit : throw; } + catch (std::integral_constant const&) { return character::eq(c, '{') ? unit : throw; } + catch (std::integral_constant const&) + { + let const kdr = read(is); + + switch (c) + { + case '(': is.ignore(std::numeric_limits::max(), ')'); break; + case '[': is.ignore(std::numeric_limits::max(), ']'); break; + case '{': is.ignore(std::numeric_limits::max(), '}'); break; + } + + return kdr; + } + + case ')': throw std::integral_constant(); + case ']': throw std::integral_constant(); + case '}': throw std::integral_constant(); + default: - if (auto const token = c + parse::token(is); token == ".") + if (auto const token = get_token(is.putback(c)); token == ".") { throw std::integral_constant(); } else try { - return string_to::number(token, 10); + return string_to_number(token, 10); } catch (...) { - return intern(token); + return string_to_symbol(token); } } } @@ -420,31 +216,70 @@ inline namespace kernel return eof_object; } - inline auto read(std::istream && is) + inline auto read(const_reference x) -> decltype(auto) { - return read(is); + assert(x.is_also()); + return read(x.as()); } - inline auto read(const_reference x) -> value_type + inline auto read() -> decltype(auto) { - if (x.is_also()) + return read(standard_input); + } + + inline auto read(external_representation const& s) -> value_type // NOTE: Specifying `decltype(auto)` causes a `undefined reference to ...` error in GCC-7. + { + auto port = std::stringstream(s); + return read(port); + } + + static auto string_to_number(external_representation const& token, int radix = 10) + { + try { - return read(x.as()); + return make(token, radix); } - else + catch (...) { - throw read_error(make("not an input-port"), x); + try + { + return ratio(token, radix).simple(); + } + catch (...) + { + try + { + return make(token); + } + catch (...) + { + if (auto iter = constants.find(token); iter != std::end(constants)) + { + return iter->second; + } + else + { + throw read_error(make("not a number"), make(token)); + } + } + } } } - inline auto read() -> value_type - { - return read(standard_input); - } - - inline auto read(external_representation const& s) -> value_type + static auto string_to_symbol(external_representation const& name) -> const_reference { - return read(std::stringstream(s)); + if (auto const iter = symbols.find(name); iter != std::end(symbols)) + { + return iter->second; + } + else if (auto const [iter, success] = symbols.emplace(name, make(name)); success) + { + return iter->second; + } + else + { + throw error(make("failed to intern a symbol"), make(name)); + } } }; } // namespace kernel diff --git a/include/meevax/kernel/string.hpp b/include/meevax/kernel/string.hpp index 4b69beefc..279c6201e 100644 --- a/include/meevax/kernel/string.hpp +++ b/include/meevax/kernel/string.hpp @@ -23,35 +23,140 @@ namespace meevax { inline namespace kernel { - auto cat = [](auto&&... xs) + struct string { - std::stringstream ss; - (ss << ... << xs); - return ss.str(); - }; - - struct string : public std::vector - { - using std::vector::vector; // make-string - - explicit string(std::istream &, std::size_t = std::numeric_limits::max()); // read-string + std::vector codepoints; - explicit string(std::istream &&); + explicit string() = default; explicit string(external_representation const&); - template - explicit string(decltype(cat), Ts&&... xs) - : string { cat(std::forward(xs)...) } - {} - - auto list(size_type, size_type) const -> meevax::value_type; - - auto list(size_type = 0) const -> meevax::value_type; + /* + (list->string list) procedure + + It is an error if any element of list is not a character. + + The string->list procedure returns a newly allocated list of the + characters of string between start and end. list->string returns a newly + allocated string formed from the elements in the list list. In both + procedures, order is preserved. string->list and list->string are + inverses so far as equal? is concerned. + */ + explicit string(const_reference); + + /* + (make-string k) procedure + (make-string k char) procedure + + The make-string procedure returns a newly allocated string of length k. + If char is given, then all the characters of the string are initialized + to char, otherwise the contents of the string are unspecified. + */ + explicit string(const_reference, const_reference); + + /* + (vector->string vector) procedure + (vector->string vector start) procedure + (vector->string vector start end) procedure + + It is an error if any element of vector between start and end is not a + character. + + The vector->string procedure returns a newly allocated string of the + objects contained in the elements of vector between start and end. The + string->vector procedure returns a newly created vector initialized to + the elements of the string string between start and end. + + In both procedures, order is preserved. + */ + explicit string(vector const&, const_reference, const_reference); + + /* + (string-append string ...) procedure + + Returns a newly allocated string whose characters are the concatenation + of the characters in the given strings. + */ + static auto append(const_reference) -> value_type; + + /* + (string-copy string) procedure + (string-copy string start) procedure + (string-copy string start end) procedure + + Returns a newly allocated copy of the part of the given string between + start and end. + */ + auto copy(const_reference, const_reference) const -> value_type; + + /* + (string-copy! to at from) procedure + (string-copy! to at from start) procedure + (string-copy! to at from start end) procedure + + It is an error if at is less than zero or greater than the length of to. + It is also an error if (- (string-length to) at) is less than (- end + start). + + Copies the characters of string from between start and end to string to, + starting at at. The order in which characters are copied is unspecified, + except that if the source and destination overlap, copying takes place + as if the source is first copied into a temporary string and then into + the destination. This can be achieved without allocating storage by + making sure to copy in the correct direction in such circumstances. + */ + auto copy(const_reference, const_reference, const_reference, const_reference) -> void; + + /* + (string-length string) procedure + + Returns the number of characters in the given string. + */ + auto length() const -> value_type; + + /* + (string->list string) procedure + (string->list string start) procedure + (string->list string start end) procedure + + (list->string list) procedure + + It is an error if any element of list is not a character. + + The string->list procedure returns a newly allocated list of the + characters of string between start and end. list->string returns a newly + allocated string formed from the elements in the list list. In both + procedures, order is preserved. string->list and list->string are + inverses so far as equal? is concerned. + */ + auto make_list(const_reference, const_reference) const -> value_type; + + /* + (string-ref string k) procedure + + It is an error if k is not a valid index of string. + + The string-ref procedure returns character k of string using zero-origin + indexing. There is no requirement for this procedure to execute in + constant time. + */ + auto ref(const_reference) const -> value_type; + + /* + (string-set! string k char) procedure + + It is an error if k is not a valid index of string. + + The string-set! procedure stores char in element k of string. There is + no requirement for this procedure to execute in constant time. + */ + auto set(const_reference, const_reference) -> void; operator external_representation() const; // write-string (for display) }; + auto operator ==(string const&, string const&) -> bool; + auto operator <<(std::ostream &, string const&) -> std::ostream &; } // namespace kernel } // namespace meevax diff --git a/include/meevax/kernel/vector.hpp b/include/meevax/kernel/vector.hpp index b8d5e483d..b84343afd 100644 --- a/include/meevax/kernel/vector.hpp +++ b/include/meevax/kernel/vector.hpp @@ -27,10 +27,10 @@ inline namespace kernel { std::vector data; - using size_type = decltype(data)::size_type; - explicit vector() = default; + explicit vector(string const&); + /* (vector obj ...) procedure @@ -49,6 +49,43 @@ inline namespace kernel */ explicit vector(const_reference, const_reference); + /* + (vector-append vector ...) procedure + + Returns a newly allocated vector whose elements are the concatenation of + the elements of the given vectors. + */ + static auto append(const_reference) -> value_type; + + /* + (vector-copy vector) procedure + (vector-copy vector start) procedure + (vector-copy vector start end) procedure + + Returns a newly allocated copy of the elements of the given vector + between start and end. The elements of the new vector are the same (in + the sense of eqv?) as the elements of the old. + */ + auto copy(const_reference, const_reference) const -> value_type; + + /* + (vector-copy! to at from) procedure + (vector-copy! to at from start) procedure + (vector-copy! to at from start end) procedure + + It is an error if at is less than zero or greater than the length of to. + It is also an error if (- (vector-length to) at) is less than + (- end start). + + Copies the elements of vector from between start and end to vector to, + starting at at. The order in which elements are copied is unspecified, + except that if the source and destination overlap, copying takes place + as if the source is first copied into a temporary vector and then into + the destination. This can be achieved without allocating storage by + making sure to copy in the correct direction in such circumstances. + */ + auto copy(const_reference, const_reference, const_reference, const_reference) -> void; + /* (vector-fill! vector fill) procedure (vector-fill! vector fill start) procedure @@ -96,27 +133,6 @@ inline namespace kernel procedure stores obj in element k of vector. */ auto set(const_reference, const_reference) -> const_reference; - - /* - (vector->string vector) procedure - (vector->string vector start) procedure - (vector->string vector start end) procedure - - (string->vector string) procedure - (string->vector string start) procedure - (string->vector string start end) procedure - - It is an error if any element of vector between start and end is not a - character. - - The vector->string procedure returns a newly allocated string of the - objects contained in the elements of vector between start and end. The - string->vector procedure returns a newly created vector initialized to - the elements of the string string between start and end. - - In both procedures, order is preserved. - */ - auto string(const_reference, const_reference) const -> value_type; }; auto operator ==(vector const&, vector const&) -> bool; diff --git a/include/meevax/parser/combinator.hpp b/include/meevax/parser/combinator.hpp index 6664e661e..0f2bc6cd6 100644 --- a/include/meevax/parser/combinator.hpp +++ b/include/meevax/parser/combinator.hpp @@ -21,9 +21,9 @@ #include #include -#include +#include #include // for read_error -#include // for eof +#include namespace meevax { diff --git a/src/kernel/basis.cpp b/src/kernel/basis.cpp index b0f9ea6df..f2e8bb6dd 100644 --- a/src/kernel/basis.cpp +++ b/src/kernel/basis.cpp @@ -49,6 +49,7 @@ DEFINE_BINARY(r7rs); DEFINE_BINARY(srfi_1); DEFINE_BINARY(srfi_6); DEFINE_BINARY(srfi_8); +DEFINE_BINARY(srfi_11); DEFINE_BINARY(srfi_23); DEFINE_BINARY(srfi_34); DEFINE_BINARY(srfi_39); diff --git a/src/kernel/character.cpp b/src/kernel/character.cpp index 64497a514..771845438 100644 --- a/src/kernel/character.cpp +++ b/src/kernel/character.cpp @@ -15,64 +15,13 @@ */ #include +#include #include -#include // for eof namespace meevax { inline namespace kernel { - character::character(value_type const codepoint) - : codepoint { codepoint } - {} - - character::character(std::istream & is) - : codepoint {} - { - /* - 00000000 -- 0000007F: 0xxxxxxx - 00000080 -- 000007FF: 110xxxxx 10xxxxxx - 00000800 -- 0000FFFF: 1110xxxx 10xxxxxx 10xxxxxx - 00010000 -- 001FFFFF: 11110xxx 10xxxxxx 10xxxxxx 10xxxxxx - */ - - if (auto const c = is.peek(); std::char_traits::eq(std::char_traits::eof(), c)) - { - throw eof(); - } - else if (0x00 <= c and c <= 0x7F) // 7 bit - { - codepoint = is.get(); - } - else if (0xC2 <= c and c <= 0xDF) // 11 bit - { - codepoint |= is.get() bitand 0b0001'1111; codepoint <<= 6; - codepoint |= is.get() bitand 0b0011'1111; - } - else if (0xE0 <= c and c <= 0xEF) // 16 bit - { - codepoint |= is.get() bitand 0b0000'1111; codepoint <<= 6; - codepoint |= is.get() bitand 0b0011'1111; codepoint <<= 6; - codepoint |= is.get() bitand 0b0011'1111; - } - else if (0xF0 <= c and c <= 0xF4) // 21 bit - { - codepoint |= is.get() bitand 0b0000'0111; codepoint <<= 6; - codepoint |= is.get() bitand 0b0011'1111; codepoint <<= 6; - codepoint |= is.get() bitand 0b0011'1111; codepoint <<= 6; - codepoint |= is.get() bitand 0b0011'1111; - } - else - { - throw read_error(make("invalid stream"), unit); - } - } - - character::operator value_type() const - { - return codepoint; - } - character::operator external_representation() const { std::array bytes {}; @@ -135,5 +84,7 @@ inline namespace kernel static_assert(std::is_standard_layout::value); static_assert(std::is_trivial::value); + + static_assert(4 <= sizeof(character::int_type)); } // namespace kernel } // namespace meevax diff --git a/src/kernel/environment.cpp b/src/kernel/environment.cpp index a8b0bab33..0c66ccc0d 100644 --- a/src/kernel/environment.cpp +++ b/src/kernel/environment.cpp @@ -28,7 +28,7 @@ inline namespace kernel auto environment::define(external_representation const& name, const_reference value) -> void { - define(intern(name), value); + define(string_to_symbol(name), value); } auto environment::evaluate(const_reference expression) -> value_type @@ -162,8 +162,8 @@ inline namespace kernel { return map1([&](let const& identity) { - return make(intern(car(prefixes).as().value + - identity.as().symbol().as().value), + return make(string_to_symbol(car(prefixes).as().value + + identity.as().symbol().as().value), identity.as().load()); }, resolve(import_set)); diff --git a/src/kernel/miscellaneous.cpp b/src/kernel/eof.cpp similarity index 95% rename from src/kernel/miscellaneous.cpp rename to src/kernel/eof.cpp index 8a59d763a..61b0b179b 100644 --- a/src/kernel/miscellaneous.cpp +++ b/src/kernel/eof.cpp @@ -14,7 +14,7 @@ limitations under the License. */ -#include +#include namespace meevax { diff --git a/src/kernel/library.cpp b/src/kernel/library.cpp index 310bb404f..dd11043ad 100644 --- a/src/kernel/library.cpp +++ b/src/kernel/library.cpp @@ -43,7 +43,7 @@ inline namespace kernel } else { - throw invalid_application(intern("char->integer") | xs); + throw invalid_application(string_to_symbol("char->integer") | xs); } }); @@ -85,7 +85,7 @@ inline namespace kernel else [[fallthrough]]; default: - throw invalid_application(intern("emergency-exit") | xs); + throw invalid_application(string_to_symbol("emergency-exit") | xs); } }); @@ -156,7 +156,7 @@ inline namespace kernel library.export_("eval"); }); - define_library("(meevax exception)", [](library & library) + define_library("(meevax error)", [](library & library) { library.define("throw", [](let const& xs) -> value_type { @@ -183,17 +183,11 @@ inline namespace kernel return car(xs).is(); }); - library.define("syntax-error?", [](let const& xs) - { - return car(xs).is(); - }); - library.export_("throw"); library.export_("make-error"); library.export_("error?"); library.export_("read-error?"); library.export_("file-error?"); - library.export_("syntax-error?"); }); define_library("(meevax experimental)", [](library & library) @@ -297,7 +291,7 @@ inline namespace kernel return car(xs).as().log() / cadr(xs).as().log(); default: - throw invalid_application(intern("log") | xs); + throw invalid_application(string_to_symbol("log") | xs); } }); @@ -337,7 +331,7 @@ inline namespace kernel return car(xs).as().atan2(cadr(xs)); default: - throw invalid_application(intern("atan") | xs); + throw invalid_application(string_to_symbol("atan") | xs); } }); @@ -403,18 +397,6 @@ inline namespace kernel return std::accumulate(std::begin(xs), std::end(xs), unit, append2); }); - library.define("list->string", [](let const& xs) - { - string s; - - for (let const& x : car(xs)) - { - s.push_back(x.as()); - } - - return make(std::move(s)); - }); - library.define("list->vector", [](let const& xs) { return make(car(xs)); @@ -422,7 +404,6 @@ inline namespace kernel library.export_("null?"); library.export_("append"); - library.export_("list->string"); library.export_("list->vector"); }); @@ -519,14 +500,14 @@ inline namespace kernel return car(xs).is(); }); - #define DEFINE(SYMBOL, COMPARE) \ - library.define(#SYMBOL, [](let const& xs) \ - { \ - return std::adjacent_find( \ - std::begin(xs), std::end(xs), [](let const& a, let const& b) \ - { \ - return not COMPARE(a.as(), b); \ - }) == std::end(xs); \ + #define DEFINE(SYMBOL, COMPARE) \ + library.define(#SYMBOL, [](let const& xs) \ + { \ + return std::adjacent_find( \ + std::begin(xs), std::end(xs), [](let const& a, let const& b) \ + { \ + return not COMPARE(a.as(), b); \ + }) == std::end(xs); \ }) DEFINE(= , std::equal_to ()); @@ -548,25 +529,25 @@ inline namespace kernel return std::accumulate(std::begin(xs), std::end(xs), e1, std::multiplies()); }); - #define DEFINE(SYMBOL, FUNCTION, BASIS) \ - library.define(SYMBOL, [](let const& xs) \ - { \ - switch (length(xs)) \ - { \ - case 0: \ - throw invalid_application(intern(SYMBOL) | xs); \ - \ - case 1: \ - return FUNCTION(BASIS, car(xs)); \ - \ - default: \ - return std::accumulate( \ - std::next(std::begin(xs)), std::end(xs), car(xs), \ - [](let const& a, let const& b) \ - { \ - return FUNCTION(a, b); \ - }); \ - } \ + #define DEFINE(SYMBOL, FUNCTION, BASIS) \ + library.define(SYMBOL, [](let const& xs) \ + { \ + switch (length(xs)) \ + { \ + case 0: \ + throw invalid_application(string_to_symbol(SYMBOL) | xs); \ + \ + case 1: \ + return FUNCTION(BASIS, car(xs)); \ + \ + default: \ + return std::accumulate( \ + std::next(std::begin(xs)), std::end(xs), car(xs), \ + [](let const& a, let const& b) \ + { \ + return FUNCTION(a, b); \ + }); \ + } \ }) DEFINE("-", sub, e0); @@ -614,17 +595,18 @@ inline namespace kernel { if (xs.is() and car(xs).is()) { - return make(static_cast(car(xs).as())); + return make(car(xs).as()); } else { - throw invalid_application(intern("integer->char") | xs); + throw invalid_application(string_to_symbol("integer->char") | xs); } }); - library.define("number->string", [](auto&& xs) + library.define("number->string", [](let const& xs) { - return make(lexical_cast(car(xs))); + return make(lexical_cast(std::setbase(cdr(xs).is() ? cadr(xs).as() : 10), + car(xs))); }); library.export_("number?"); @@ -851,7 +833,7 @@ inline namespace kernel return make(car(xs).as()); default: - throw invalid_application(intern("open-input-string") | xs); + throw invalid_application(string_to_symbol("open-input-string") | xs); } }); @@ -866,7 +848,7 @@ inline namespace kernel return make(car(xs).as()); default: - throw invalid_application(intern("open-output-string") | xs); + throw invalid_application(string_to_symbol("open-output-string") | xs); } }); @@ -875,11 +857,19 @@ inline namespace kernel return make(car(xs).as().str()); }); - library.define("%read-char", [](let const& xs) -> value_type + library.define("get-ready?", [](let const& xs) + { + return static_cast(car(xs).as()); + }); + + library.define("get-char", [](let const& xs) -> value_type { try { - return make(car(xs).as()); + auto const g = car(xs).as().tellg(); + let const c = make(get_codepoint(car(xs).as())); + car(xs).as().seekg(g); + return c; } catch (eof const&) { @@ -891,14 +881,11 @@ inline namespace kernel } }); - library.define("%peek-char", [](let const& xs) -> value_type + library.define("get-char!", [](let const& xs) -> value_type { try { - auto const g = car(xs).as().tellg(); - let const c = make(car(xs).as()); - car(xs).as().seekg(g); - return c; + return make(get_codepoint(car(xs).as())); } catch (eof const&) { @@ -920,21 +907,21 @@ inline namespace kernel return eof_object; }); - library.define("read-ready?", [](let const& xs) - { - return static_cast(car(xs).as()); - }); - - library.define("%read-string", [](let const& xs) + library.define("get-string!", [](let const& xs) { - switch (length(xs)) + auto read_k = [](string & string, std::size_t k, std::istream & is) { - case 2: - return make(cadr(xs).as(), static_cast(car(xs).as())); + for (std::size_t i = 0; i < k and is; ++i) + { + string.codepoints.emplace_back(get_codepoint(is)); + } + }; - default: - throw invalid_application(intern("read-string") | xs); - } + let const s = make(); + + read_k(s.as(), car(xs).as(), cadr(xs).as()); + + return s; }); library.define("put-char", [](let const& xs) @@ -955,7 +942,7 @@ inline namespace kernel case 4: // TODO default: - throw invalid_application(intern("write-string") | xs); + throw invalid_application(string_to_symbol("write-string") | xs); } return unspecified; @@ -984,12 +971,12 @@ inline namespace kernel library.export_("open-input-string"); library.export_("open-output-string"); library.export_("get-output-string"); - library.export_("%read-char"); - library.export_("%peek-char"); library.export_("eof-object?"); library.export_("eof-object"); - library.export_("read-ready?"); - library.export_("%read-string"); + library.export_("get-ready?"); + library.export_("get-char"); + library.export_("get-char!"); + library.export_("get-string!"); library.export_("put-char"); library.export_("put-string"); library.export_("%flush-output-port"); @@ -1025,74 +1012,54 @@ inline namespace kernel library.define("make-string", [](let const& xs) { - switch (length(xs)) - { - case 1: - return make(static_cast(car(xs).as()), character()); - - case 2: - return make(static_cast(car(xs).as()), cadr(xs).as()); - - default: - throw invalid_application(intern("make-string") | xs); - } + return make(car(xs), cdr(xs).is() ? cadr(xs) : make()); }); library.define("string-length", [](let const& xs) { - return make(car(xs).as().size()); + return car(xs).as().length(); }); library.define("string-ref", [](let const& xs) { - return make(car(xs).as().at(static_cast(cadr(xs).as()))); + return car(xs).as().ref(cadr(xs)); }); library.define("string-set!", [](let const& xs) { - car(xs).as().at(static_cast(cadr(xs).as())) = caddr(xs).as(); + car(xs).as().set(cadr(xs), caddr(xs)); return car(xs); }); library.define("string-append", [](let const& xs) { - string result; - - for (let const& x : xs) - { - std::copy(std::cbegin(x.as()), std::cend(x.as()), std::back_inserter(result)); - } - - return make(result); + return string::append(xs); }); library.define("string-copy", [](let const& xs) { - switch (length(xs)) - { - case 1: - return make(car(xs).as()); + return car(xs).as().copy(cdr(xs).is() ? cadr(xs) : e0, + cddr(xs).is() ? caddr(xs) : car(xs).as().length()); + }); - case 2: - return make(car(xs).as().begin() + static_cast(cadr(xs).as()), - car(xs).as().end()); - case 3: - return make(car(xs).as().begin() + static_cast( cadr(xs).as()), - car(xs).as().begin() + static_cast(caddr(xs).as())); - default: - throw invalid_application(intern("string-copy") | xs); - } + library.define("string-copy!", [](let const& xs) + { + car(xs).as().copy(list_ref(xs, 1), + list_ref(xs, 2), + list_tail(xs, 3).is() ? list_ref(xs, 3) : e0, + list_tail(xs, 3).is() ? list_ref(xs, 4) : car(xs).as().length()); + return unspecified; }); - #define STRING_COMPARE(COMPARE) \ - [](let const& xs) \ - { \ - return std::adjacent_find( \ - std::begin(xs), std::end(xs), [](let const& a, let const& b) \ - { \ - return not COMPARE(a.as_const(), \ - b.as_const()); \ - }) == std::end(xs); \ + #define STRING_COMPARE(COMPARE) \ + [](let const& xs) \ + { \ + return std::adjacent_find( \ + std::begin(xs), std::end(xs), [](let const& a, let const& b) \ + { \ + return not COMPARE(a.as_const().codepoints, \ + b.as_const().codepoints); \ + }) == std::end(xs); \ } library.define("string=?", STRING_COMPARE(std::equal_to ())); @@ -1105,46 +1072,38 @@ inline namespace kernel library.define("string->number", [](let const& xs) { - switch (length(xs)) - { - case 1: - return string_to::number(car(xs).as(), 10); - - case 2: - return string_to::number(car(xs).as(), static_cast(cadr(xs).as())); - - default: - throw invalid_application(intern("string->number") | xs); - } + return string_to_number(car(xs).as(), + cdr(xs).is() ? cadr(xs).as() : 10); }); library.define("string->list", [](let const& xs) { - switch (length(xs)) - { - case 1: - return car(xs).as().list(); - - case 2: - return car(xs).as().list(static_cast(cadr(xs).as())); + return car(xs).as().make_list(cdr(xs).is() ? cadr(xs) : e0, + cddr(xs).is() ? caddr(xs) : car(xs).as().length()); + }); - case 3: - return car(xs).as().list(static_cast(cadr(xs).as()), static_cast(caddr(xs).as())); + library.define("string->symbol", [](let const& xs) + { + return string_to_symbol(car(xs).as()); + }); - default: - throw invalid_application(intern("string->list") | xs); - } + library.define("list->string", [](let const& xs) + { + return make(car(xs)); }); - library.define("string->symbol", [](let const& xs) + library.define("vector->string", [](let const& xs) { - return intern(car(xs).as()); + return make(car(xs).as(), + cdr(xs).is() ? cadr(xs) : e0, + cddr(xs).is() ? caddr(xs) : car(xs).as().length()); }); library.export_("string?"); library.export_("make-string"); library.export_("string-append"); library.export_("string-copy"); + library.export_("string-copy!"); library.export_("string-length"); library.export_("string-ref"); library.export_("string-set!"); @@ -1156,6 +1115,8 @@ inline namespace kernel library.export_("string->list"); library.export_("string->number"); library.export_("string->symbol"); + library.export_("list->string"); + library.export_("vector->string"); }); define_library("(meevax symbol)", [](library & library) @@ -1217,17 +1178,27 @@ inline namespace kernel library.define("make-vector", [](let const& xs) { - switch (length(xs)) - { - case 1: - return make(car(xs), unspecified); + return make(car(xs), cdr(xs).is() ? cadr(xs) : unspecified); + }); - case 2: - return make(car(xs), cadr(xs)); + library.define("vector-append", [](let const& xs) + { + return vector::append(xs); + }); - default: - throw invalid_application(intern("make-vector") | xs); - } + library.define("vector-copy", [](let const& xs) + { + return car(xs).as().copy(cdr(xs).is() ? cadr(xs) : e0, + cddr(xs).is() ? caddr(xs) : car(xs).as().length()); + }); + + library.define("vector-copy!", [](let const& xs) + { + car(xs).as().copy(list_ref(xs, 1), + list_ref(xs, 2), + list_tail(xs, 3).is() ? list_ref(xs, 3) : e0, + list_tail(xs, 3).is() ? list_ref(xs, 4) : car(xs).as().length()); + return unspecified; }); library.define("vector-length", [](let const& xs) @@ -1247,72 +1218,35 @@ inline namespace kernel library.define("vector-fill!", [](let const& xs) { - switch (length(xs)) - { - case 2: - car(xs).as().fill(cadr(xs), e0, car(xs).as().length()); - break; - - case 3: - car(xs).as().fill(cadr(xs), caddr(xs), car(xs).as().length()); - break; - - case 4: - car(xs).as().fill(cadr(xs), caddr(xs), cadddr(xs)); - break; - - default: - throw invalid_application(intern("vector-fill!") | xs); - } - + car(xs).as().fill(cdr(xs).is() ? cadr(xs) : unspecified, + cddr(xs).is() ? caddr(xs) : e0, + cdddr(xs).is() ? cadddr(xs) : car(xs).as().length()); return unspecified; }); library.define("vector->list", [](let const& xs) { - switch (length(xs)) - { - case 1: - return car(xs).as().list(e0, car(xs).as().length()); - - case 2: - return car(xs).as().list(cadr(xs), car(xs).as().length()); - - case 3: - return car(xs).as().list(cadr(xs), caddr(xs)); - - default: - throw invalid_application(intern("vector->list") | xs); - } + return car(xs).as().list(cdr(xs).is() ? cadr(xs) : e0, + cddr(xs).is() ? caddr(xs) : car(xs).as().length()); }); - library.define("vector->string", [](let const& xs) + library.define("string->vector", [](let const& xs) { - switch (length(xs)) - { - case 1: - return car(xs).as().string(e0, car(xs).as().length()); - - case 2: - return car(xs).as().string(cadr(xs), car(xs).as().length()); - - case 3: - return car(xs).as().string(cadr(xs), caddr(xs)); - - default: - throw invalid_application(intern("vector->string") | xs); - } + return make(car(xs).as()); }); library.export_("vector?"); library.export_("vector"); library.export_("make-vector"); + library.export_("vector-append"); + library.export_("vector-copy"); + library.export_("vector-copy!"); library.export_("vector-length"); library.export_("vector-ref"); library.export_("vector-set!"); library.export_("vector-fill!"); library.export_("vector->list"); - library.export_("vector->string"); + library.export_("string->vector"); }); define_library("(meevax version)", [](library & library) @@ -1364,6 +1298,7 @@ inline namespace kernel srfi_149, r5rs, srfi_6, // Basic String Ports + srfi_11, // Syntax for receiving multiple values srfi_34, // Exception Handling for Programs srfi_23, // Error reporting mechanism srfi_39, // Parameter objects @@ -1441,22 +1376,11 @@ inline namespace kernel if (export_spec.is() and car(export_spec).is() and car(export_spec).as().value == "rename") { - if (let const& binding = identify(cadr(export_spec), unit); binding.as().is_free()) - { - throw error(make("Exported but undefined"), cadr(export_spec)); - } - else - { - return make(caddr(export_spec), binding.as().load()); - } - } - else if (let const& binding = identify(export_spec, unit); binding.as().is_free()) - { - throw error(make("Exported but undefined"), export_spec); + return make(caddr(export_spec), (*this)[cadr(export_spec)]); } else { - return binding; + return identify(export_spec, unit); } }; diff --git a/src/kernel/reader.cpp b/src/kernel/reader.cpp index dc06106e0..6f014c903 100644 --- a/src/kernel/reader.cpp +++ b/src/kernel/reader.cpp @@ -14,11 +14,234 @@ limitations under the License. */ -// #include +#include +#include +#include namespace meevax { inline namespace kernel { + constexpr auto is_special_character(character::int_type c) + { + auto one_of = [c](auto... xs) constexpr + { + return (character::eq(c, xs) or ...); + }; + + return character::is_eof(c) or one_of('\t', // 0x09 + '\n', // 0x0A + '\v', // 0x0B + '\f', // 0x0C + '\r', // 0x0D + ' ', // 0x20 + '"', // 0x22 + '#', // 0x23 + '\'', // 0x27 + '(', // 0x28 + ')', // 0x29 + ',', // 0x2C + ';', // 0x3B + '[', // 0x5B + ']', // 0x5D + '`', // 0x60 + '{', // 0x7B + '|', // 0x7C + '}'); // 0x7D + } + + auto get_codepoint(std::istream & is) -> character::int_type /* -------------- + * + * 00000000 -- 0000007F: 0xxxxxxx + * 00000080 -- 000007FF: 110xxxxx 10xxxxxx + * 00000800 -- 0000FFFF: 1110xxxx 10xxxxxx 10xxxxxx + * 00010000 -- 001FFFFF: 11110xxx 10xxxxxx 10xxxxxx 10xxxxxx + * + * ------------------------------------------------------------------------- */ + { + character::int_type codepoint = 0; + + if (auto const c = is.peek(); character::is_eof(c)) + { + throw eof(); + } + else if (0x00 <= c and c <= 0x7F) // 7 bit + { + codepoint = is.get(); + } + else if (0xC2 <= c and c <= 0xDF) // 11 bit + { + codepoint |= is.get() bitand 0b0001'1111; codepoint <<= 6; + codepoint |= is.get() bitand 0b0011'1111; + } + else if (0xE0 <= c and c <= 0xEF) // 16 bit + { + codepoint |= is.get() bitand 0b0000'1111; codepoint <<= 6; + codepoint |= is.get() bitand 0b0011'1111; codepoint <<= 6; + codepoint |= is.get() bitand 0b0011'1111; + } + else if (0xF0 <= c and c <= 0xF4) // 21 bit + { + codepoint |= is.get() bitand 0b0000'0111; codepoint <<= 6; + codepoint |= is.get() bitand 0b0011'1111; codepoint <<= 6; + codepoint |= is.get() bitand 0b0011'1111; codepoint <<= 6; + codepoint |= is.get() bitand 0b0011'1111; + } + else + { + throw read_error(make("invalid stream"), unit); + } + + return codepoint; + } + + auto get_delimited_elements(std::istream & is, character::int_type delimiter) -> string + { + auto s = string(); + + assert(character::eq(is.peek(), delimiter)); + + is.ignore(1); + + for (auto codepoint = get_codepoint(is); not character::is_eof(codepoint); codepoint = get_codepoint(is)) + { + if (codepoint == delimiter) + { + return s; + } + else switch (codepoint) + { + case '\\': + switch (auto const codepoint = get_codepoint(is); codepoint) + { + case 'a': s.codepoints.emplace_back('\a'); break; + case 'b': s.codepoints.emplace_back('\b'); break; + case 'f': s.codepoints.emplace_back('\f'); break; + case 'n': s.codepoints.emplace_back('\n'); break; + case 'r': s.codepoints.emplace_back('\r'); break; + case 't': s.codepoints.emplace_back('\t'); break; + case 'v': s.codepoints.emplace_back('\v'); break; + case 'x': + if (auto token = external_representation(); std::getline(is, token, ';')) + { + s.codepoints.emplace_back(lexical_cast(std::hex, token)); + } + break; + + case '\n': + case '\r': + ignore(is, [](auto c) { return std::isspace(c); }); + break; + + default: + s.codepoints.emplace_back(codepoint); + break; + } + break; + + default: + s.codepoints.emplace_back(codepoint); + break; + } + } + + throw read_error(make("unterminated string"), unit); + } + + auto get_token(std::istream & is) -> std::string + { + auto token = std::string(); + + while (not is_special_character(is.peek())) + { + token.push_back(is.get()); + } + + return token; + } + + auto ignore_nested_block_comment(std::istream & is) -> std::istream & + { + while (not character::is_eof(is.peek())) switch (is.get()) + { + case '#': + switch (is.peek()) + { + case '|': + is.ignore(1); + ignore_nested_block_comment(is); + [[fallthrough]]; + + default: + continue; + } + + case '|': + switch (is.peek()) + { + case '#': + is.ignore(1); + return is; + + default: + continue; + } + + default: + continue; + } + + throw read_error(make("unterminated multi-line comment"), unit); + } + + auto read_character_literal(std::istream & is) -> value_type + { + std::unordered_map static const character_names { + { "alarm" , 0x07 }, + { "backspace", 0x08 }, + { "delete" , 0x7F }, + { "escape" , 0x1B }, + { "newline" , 0x0A }, + { "null" , 0x00 }, + { "return" , 0x0D }, + { "space" , 0x20 }, + { "tab" , 0x09 }, + }; + + switch (auto token = get_token(is); token.length()) + { + case 0: + assert(is_special_character(is.peek())); + return make(is.get()); + + case 1: + assert(std::isprint(token.front())); + return make(token.front()); + + default: + if (auto iter = character_names.find(token); iter != std::end(character_names)) + { + return make(iter->second); + } + else if (token[0] == 'x' and 1 < token.length()) + { + return make(lexical_cast(std::hex, token.substr(1))); + } + else + { + for (auto iter = std::rbegin(token); iter != std::rend(token); ++iter) + { + is.putback(*iter); + } + + throw read_error(make("not a character"), make("\\#" + token)); + } + } + } + + auto read_string_literal(std::istream & is) -> value_type + { + return make(get_delimited_elements(is, '"')); + } } // namespace kernel } // namespace meevax diff --git a/src/kernel/string.cpp b/src/kernel/string.cpp index 7fefc8ce3..49dcf3946 100644 --- a/src/kernel/string.cpp +++ b/src/kernel/string.cpp @@ -17,96 +17,106 @@ #include #include #include +#include #include +#include namespace meevax { inline namespace kernel { - string::string(std::istream & is, std::size_t k) + string::string(external_representation const& s) { - for (auto c = character(is); size() < k and not std::char_traits::eq(std::char_traits::eof(), c.codepoint); c = character(is)) + for (auto port = std::stringstream(s); not character::is_eof(port.peek()); codepoints.emplace_back(get_codepoint(port))); + } + + string::string(vector const& v, const_reference begin, const_reference end) + { + std::for_each(std::next(std::begin(v.data), begin.as()), + std::next(std::begin(v.data), end.as()), + [&](let const& c) + { + codepoints.push_back(c.as()); + }); + } + + string::string(const_reference xs) + { + for (let const& x : xs) { - switch (c.codepoint) - { - case '"': - return; + codepoints.push_back(x.as()); + } + } - case '\\': - switch (auto const c = character(is); c.codepoint) - { - case 'a': emplace_back('\a'); break; - case 'b': emplace_back('\b'); break; - case 'f': emplace_back('\f'); break; - case 'n': emplace_back('\n'); break; - case 'r': emplace_back('\r'); break; - case 't': emplace_back('\t'); break; - case 'v': emplace_back('\v'); break; - - case 'x': - if (external_representation token; std::getline(is, token, ';') and is.ignore(1)) - { - if (std::stringstream ss; ss << std::hex << token) - { - if (character::value_type value = 0; ss >> value) - { - emplace_back(value); - break; - } - } - } - throw read_error(make("invalid escape sequence")); - - case '\n': - case '\r': - ignore(is, [](auto c) { return std::isspace(c); }); - break; + string::string(const_reference k, const_reference c) + : codepoints { k.as(), c.as() } + {} - default: - push_back(c); - break; - } - break; + auto string::append(const_reference xs) -> value_type + { + let const s = make(); - default: - push_back(c); - break; - } + for (let const& x : xs) + { + std::copy(std::begin(x.as().codepoints), + std::end(x.as().codepoints), + std::back_inserter(s.as().codepoints)); } - throw read_error(make("unterminated string"), unit); + return s; } - string::string(std::istream && is) - : string { is } - {} + auto string::copy(const_reference from, const_reference to) const -> value_type + { + let const& s = make(); - string::string(external_representation const& s) - : string { std::stringstream(s + "\"") } - {} + std::copy(std::next(std::begin(codepoints), from.as()), + std::next(std::begin(codepoints), to.as()), + std::back_inserter(s.as().codepoints)); + + return s; + } - auto string::list(size_type from, size_type to) const -> meevax::value_type + auto string::copy(const_reference at, const_reference from, const_reference begin, const_reference end) -> void { - let x = unit; + codepoints.reserve(codepoints.size() + from.as().codepoints.size()); - for (auto iter = std::prev(rend(), to); iter != std::prev(rend(), from); ++iter) - { - x = cons(make(*iter), x); - } + std::copy(std::next(std::begin(from.as().codepoints), begin.as()), + std::next(std::begin(from.as().codepoints), end.as()), + std::next(std::begin(codepoints), at.as())); + } + + auto string::length() const -> value_type + { + return make(codepoints.size()); + } - return x; + auto string::make_list(const_reference from, const_reference to) const -> value_type + { + return std::accumulate(std::prev(std::rend(codepoints), to.as()), + std::prev(std::rend(codepoints), from.as()), + unit, + [](let const& xs, character const& c) + { + return cons(make(c), xs); + }); } - auto string::list(size_type from) const -> meevax::value_type + auto string::ref(const_reference k) const -> value_type { - return list(from, size()); + return make(codepoints.at(k.as())); + } + + auto string::set(const_reference k, const_reference c) -> void + { + codepoints.at(k.as()) = c.as(); } string::operator external_representation() const { external_representation result; - for (character const& each : *this) + for (character const& each : codepoints) { result.append(static_cast(each)); } @@ -114,11 +124,17 @@ inline namespace kernel return result; } + auto operator ==(string const& s1, string const& s2) -> bool + { + return std::equal(std::begin(s1.codepoints), std::end(s1.codepoints), + std::begin(s2.codepoints), std::end(s2.codepoints)); + } + auto operator <<(std::ostream & os, string const& datum) -> std::ostream & { auto write = [&](character const& c) -> decltype(auto) { - if (c.codepoint < 0x80) + if (std::isprint(c.codepoint)) { switch (c.codepoint) { @@ -143,7 +159,7 @@ inline namespace kernel os << cyan("\""); - for (auto const& each : datum) + for (auto const& each : datum.codepoints) { write(each); } diff --git a/src/kernel/symbol.cpp b/src/kernel/symbol.cpp index 17104399e..5efd81c82 100644 --- a/src/kernel/symbol.cpp +++ b/src/kernel/symbol.cpp @@ -14,6 +14,7 @@ limitations under the License. */ +#include #include namespace meevax @@ -22,7 +23,21 @@ inline namespace kernel { auto operator <<(std::ostream & os, symbol const& datum) -> std::ostream & { - return os << (datum.value.empty() ? "||" : datum.value); + if (datum.value.empty()) + { + return os << "||"; + } + else if (std::find_if(std::begin(datum.value), std::end(datum.value), [](auto c) + { + return std::iscntrl(c) or std::isspace(c); + }) != std::end(datum.value)) + { + return os << cyan("#") << string(datum.value); + } + else + { + return os << datum.value; + } } } // namespace kernel } // namespace meevax diff --git a/src/kernel/vector.cpp b/src/kernel/vector.cpp index 4e4c019fb..91e9be506 100644 --- a/src/kernel/vector.cpp +++ b/src/kernel/vector.cpp @@ -28,10 +28,52 @@ inline namespace kernel std::copy(std::begin(x), std::end(x), std::back_inserter(data)); } + vector::vector(string const& s) + { + for (auto const& c : s.codepoints) + { + data.push_back(make(c)); + } + } + vector::vector(const_reference k, const_reference fill) : data { k.as(), fill } {} + auto vector::append(const_reference xs) -> value_type + { + let const v = make(); + + for (let const& x : xs) + { + std::copy(x.as().data.begin(), + x.as().data.end(), + std::back_inserter(v.as().data)); + } + + return v; + } + + auto vector::copy(const_reference from, const_reference to) const -> value_type + { + let const& v = make(); + + std::copy(std::next(std::begin(data), from.as()), + std::next(std::begin(data), to.as()), + std::back_inserter(v.as().data)); + + return v; + } + + auto vector::copy(const_reference at, const_reference v, const_reference from, const_reference to) -> void + { + data.reserve(data.size() + v.as().data.size()); + + std::copy(std::next(std::begin(v.as().data), from.as()), + std::next(std::begin(v.as().data), to.as()), + std::next(std::begin(data), at.as())); + } + auto vector::fill(const_reference x, const_reference from, const_reference to) -> void { std::fill(std::next(std::begin(data), from.as()), @@ -62,20 +104,6 @@ inline namespace kernel return data.at(k.as()) = x; } - auto vector::string(const_reference from, const_reference to) const -> value_type - { - meevax::string s; - - std::for_each(std::next(std::begin(data), from.as()), - std::next(std::begin(data), to.as()), - [&](let const& each) - { - s.push_back(each.as()); - }); - - return make(s); - } - auto operator ==(vector const& lhs, vector const& rhs) -> bool { return std::equal(std::begin(lhs.data), std::end(lhs.data), diff --git a/test/r7rs.ss b/test/r7rs.ss index bfa1273e5..3fa3da2af 100644 --- a/test/r7rs.ss +++ b/test/r7rs.ss @@ -1,157 +1,226 @@ (import (scheme base) (scheme char) + (scheme eval) (scheme file) (scheme inexact) (scheme lazy) (scheme process-context) (scheme read) (scheme write) - (srfi 78) - ) + (only (scheme r5rs) null-environment) + (srfi 78)) -; ---- 2.1. Identifiers -------------------------------------------------------- +; ---- 1.3.4. ------------------------------------------------------------------ + +(check (* 5 8) => 40) + +; ---- 2.1. -------------------------------------------------------------------- (check (symbol? '...) => #t) + (check (symbol? '+) => #t) + (check (symbol? '+soup+) => #t) + (check (symbol? '<=?) => #t) + (check (symbol? '->string) => #t) + (check (symbol? 'a34kTMNs) => #t) + (check (symbol? 'lambda) => #t) + (check (symbol? 'list->vector) => #t) + (check (symbol? 'q) => #t) + (check (symbol? 'V17a) => #t) -; (check (symbol? |two words|) => #t) -; (check (symbol? |two\x20;words|) => #t) + +(check (symbol? '|two words|) => #t) + +(check (symbol? '|two\x20;words|) => #t) + (check (symbol? 'the-word-recursion-has-many-meanings) => #t) #!fold-case + #!no-fold-case -; ---- 2.2. Whitespace and comments -------------------------------------------- +; ---- 2.2. -------------------------------------------------------------------- -; #| -; The FACT procedure computes the factorial -; of a non-negative integer. -; |# +#| + The FACT procedure computes the factorial + of a non-negative integer. +|# (define fact (lambda (n) (if (= n 0) #;(= n 1) - 1 - ;Base case: return 1 + 1 ;Base case: return 1 (* n (fact (- n 1)))))) -; ---- 4.1.1. Variable references ---------------------------------------------- +; ---- 2.4. -------------------------------------------------------------------- + +; (check (let ((x (list 'a 'b 'c))) +; (set-cdr! (cddr x) x) +; x) => #0=(a b c . #0#)) ; TODO + +; #1=(begin (display #\x) #1#) ; MUST BE ERROR + +; ---- 4.1.1. ------------------------------------------------------------------ (define x 28) + (check x => 28) -; ---- 4.1.2. Literal expressions ---------------------------------------------- +; ---- 4.1.2. ------------------------------------------------------------------ (check (quote a) => a) + (check (quote #(a b c)) => #(a b c)) + (check (quote (+ 1 2)) => (+ 1 2)) (check 'a => a) + (check '#(a b c) => #(a b c)) + (check '() => ()) + (check '(+ 1 2) => (+ 1 2)) + (check '(quote a) => (quote a)) + (check ''a => (quote a)) (check '145932 => 145932) -(check 145932 => 145932) + +(check 145932 => 145932) + (check '"abc" => "abc") -(check "abc" => "abc") -; (check '# => #t) -; (check # => #t) + +(check "abc" => "abc") + +(check '#\a => #\a) ; R7RSSmallErrata 4. In Section 4.1.2 (Literal expressions), the examples '# and # should be '#\a and #\a respectively. + +(check #\a => #\a) ; R7RSSmallErrata 4. In Section 4.1.2 (Literal expressions), the examples '# and # should be '#\a and #\a respectively. + (check '#(a 10) => #(a 10)) -(check #(a 10) => #(a 10)) + +(check #(a 10) => #(a 10)) + ; (check '#u8(64 65) => #u8(64 65)) -; (check #u8(64 65) => #u8(64 65)) + +; (check #u8(64 65) => #u8(64 65)) + (check '#t => #t) -(check #t => #t) -; ---- 4.1.3. Procedure calls -------------------------------------------------- +(check #t => #t) + +; ---- 4.1.3. ------------------------------------------------------------------ (check (+ 3 4) => 7) + (check ((if #f + *) 3 4) => 12) -; ---- 4.1.4. Procedures ------------------------------------------------------- +; ---- 4.1.4. ------------------------------------------------------------------ + +(check (procedure? (lambda (x) (+ x x))) => #t) -(lambda (x) (+ x x)) (check ((lambda (x) (+ x x)) 4) => 8) (define reverse-subtract (lambda (x y) (- y x))) + (check (reverse-subtract 7 10) => 3) (define add4 (let ((x 4)) - (lambda (y) (+ x y)))) + (lambda (y) + (+ x y)))) + (check (add4 6) => 10) (check ((lambda x x) 3 4 5 6) => (3 4 5 6)) + (check ((lambda (x y . z) z) 3 4 5 6) => (5 6)) -; ---- 4.1.5. Conditionals ----------------------------------------------------- +; ---- 4.1.5. ------------------------------------------------------------------ (check (if (> 3 2) 'yes 'no) => yes) + (check (if (> 2 3) 'yes 'no) => no) + (check (if (> 3 2) (- 3 2) (+ 3 2)) => 1) -; ---- 4.1.6. Assignments ------------------------------------------------------ +; ---- 4.1.6. ------------------------------------------------------------------ (define x 2) + (check (+ x 1) => 3) -(set! x 4) + +(check (set! x 4) => 4) + (check (+ x 1) => 5) -; ---- 4.2.1. Conditionals ----------------------------------------------------- +; ---- 4.2.1. ------------------------------------------------------------------ (check (cond ((> 3 2) 'greater) ((< 3 2) 'less)) => greater) + (check (cond ((> 3 3) 'greater) ((< 3 3) 'less) (else 'equal)) => equal) + (check (cond ((assv 'b '((a 1) (b 2))) => cadr) (else #f)) => 2) (check (case (* 2 3) ((2 3 5 7) 'prime) ((1 4 6 8 9) 'composite)) => composite) + (check (case (car '(c d)) ((a) 'a) ((b) 'b)) => #,(if #f #f)) + (check (case (car '(c d)) ((a e i o u) 'vowel) ((w y) 'semivowel) (else => (lambda (x) x))) => c) -(check (and (= 2 2) (> 2 1)) => #t) -(check (and (= 2 2) (< 2 1)) => #f) +(check (and (= 2 2) + (> 2 1)) => #t) + +(check (and (= 2 2) + (< 2 1)) => #f) + (check (and 1 2 'c '(f g)) => (f g)) + (check (and) => #t) -(check (or (= 2 2) (> 2 1)) => #t) -(check (or (= 2 2) (< 2 1)) => #t) +(check (or (= 2 2) + (> 2 1)) => #t) + +(check (or (= 2 2) + (< 2 1)) => #t) + (check (or #f #f #f) => #f) + (check (or (memq 'b '(a b c)) (/ 3 0)) => (b c)) -(when (= 1 1.0) - (display "1") - (display "2")) +(check (when (= 1 1.0) + (display "1") + (display "2")) => #,(if #f #f)) -(unless (= 1 1.0) - (display "1") - (display "2")) +(check (unless (= 1 1.0) + (display "1") + (display "2")) => #,(if #f #f)) -; ---- 4.2.2. Binding constructs ----------------------------------------------- +; ---- 4.2.2. ------------------------------------------------------------------ (check (let ((x 2) (y 3)) @@ -171,11 +240,13 @@ (check (letrec ((even? (lambda (n) - (if (zero? n) #t + (if (zero? n) + #t (odd? (- n 1))))) (odd? (lambda (n) - (if (zero? n) #f + (if (zero? n) + #f (even? (- n 1)))))) (even? 88)) => #t) @@ -189,15 +260,19 @@ (y x)) y) => 5) -; (check (let-values (((root rem) (exact-integer-sqrt 32))) +; (check (let-values (((root rem) +; (exact-integer-sqrt 32))) ; (* root rem)) => 35) -(check (let ((a 'a) (b 'b) (x 'x) (y 'y)) +(check (let ((a 'a) + (b 'b) + (x 'x) + (y 'y)) (let*-values (((a b) (values x y)) ((x y) (values a b))) (list a b x y))) => (x y x y)) -; ---- 4.2.3. Sequencing ------------------------------------------------------- +; ---- 4.2.3. ------------------------------------------------------------------ (define x 0) @@ -205,11 +280,10 @@ (begin (set! x 5) (+ x 1))) => 6) -(check - (begin (display "4 plus 1 equals ") - (display (+ 4 1))) => #,(if #f #f)) +(check (begin (display "4 plus 1 equals ") + (display (+ 4 1))) => #,(if #f #f)) -; ---- 4.2.4. Iteration -------------------------------------------------------- +; ---- 4.2.4. ------------------------------------------------------------------ (check (do ((vec (make-vector 5)) (i 0 (+ i 1))) @@ -234,7 +308,7 @@ nonneg (cons (car numbers) neg))))) => ((6 1 3) (-5 -2))) -; ---- 4.2.5. Delayed evaluation ----------------------------------------------- +; ---- 4.2.5. ------------------------------------------------------------------ (check (force (delay (+ 1 2))) => 3) @@ -243,13 +317,17 @@ (force p))) => (3 3)) (define integers - (letrec ((next - (lambda (n) - (delay (cons n (next (+ n 1))))))) + (letrec ((next (lambda (n) + (delay (cons n (next (+ n 1))))))) (next 0))) -(define head (lambda (stream) (car (force stream)))) -(define tail (lambda (stream) (cdr (force stream)))) +(define head + (lambda (stream) + (car (force stream)))) + +(define tail + (lambda (stream) + (cdr (force stream)))) (check (head (tail (tail integers))) => 2) @@ -266,15 +344,21 @@ (check (head (tail (tail (stream-filter odd? integers)))) => 5) (define count 0) + (define p (delay (begin (set! count (+ count 1)) - (if (> count x) count + (if (> count x) + count (force p))))) (define x 5) + (check (promise? p) => #t) + (check (force p) => 6) + (check (promise? p) => #t) + (check (begin (set! x 10) (force p)) => 6) @@ -282,41 +366,48 @@ (check (pair? (delay (cons 1 2))) => #t) ; unspecified -; ---- 4.2.6. Dynamic bindings ------------------------------------------------- +; (check (+ (delay (* 3 7)) 13) => ???) + +; (check (car (list (delay (* 3 7)) 13)) => ???) + +; ---- 4.2.6. ------------------------------------------------------------------ (define radix (make-parameter 10 (lambda (x) - (if (and (exact-integer? x) (<= 2 x 16)) + (if (and (exact-integer? x) + (<= 2 x 16)) x (error "invalid radix"))))) -(define (f n) (number->string n (radix))) +(define (f n) + (number->string n (radix))) -(check (f 12) => "12") +; (check (f 12) => "12") ; (parameterize ((radix 2)) ; (check (f 12) => "1100") + ; (check (f 12) => "12") -; -; (radix 16) -; + +; (check (radix 16) => ???) + ; (parameterize ((radix 0)) ; (f 12)) ; => error -; ---- 4.2.7. Exception handling ----------------------------------------------- +; ---- 4.2.7. ------------------------------------------------------------------ ; (check (guard (condition ; ((assq 'a condition) => cdr) ; ((assq 'b condition))) -; (raise (list (cons 'a 42)))) => 42) +; (raise (list (cons 'a 42)))) => 42) ; (check (guard (condition ; ((assq 'a condition) => cdr) ; ((assq 'b condition))) -; (raise (list (cons 'b 23)))) => (b . 23)) +; (raise (list (cons 'b 23)))) => (b . 23)) -; ---- 4.2.8. Quasiquotation --------------------------------------------------- +; ---- 4.2.8. ------------------------------------------------------------------ (check `(list ,(+ 1 2) 4) => (list 3 4)) @@ -329,11 +420,11 @@ (check `#(10 5 ,(sqrt 4) ,@(map sqrt '(16 9)) 8) => #(10 5 2 4 3 8)) -; (check `(a `(b ,(+ 1 2) ,(foo ,(+ 1 3) d) e) f) => (a `(b ,(+ 1 2) ,(foo 4 d) e) f)) +(check `(a `(b ,(+ 1 2) ,(foo ,(+ 1 3) d) e) f) => (a `(b ,(+ 1 2) ,(foo 4 d) e) f)) -; (check (let ((name1 'x) -; (name2 'y)) -; `(a `(b ,,name1 ,',name2 d) e)) => (a `(b ,x ,'y d) e)) +(check (let ((name1 'x) + (name2 'y)) + `(a `(b ,,name1 ,',name2 d) e)) => (a `(b ,x ,'y d) e)) (check (let ((a 3)) `((1 2) ,a ,4 ,'five 6)) => ((1 2) 3 4 five 6)) @@ -342,7 +433,7 @@ (check '(quasiquote (list (unquote (+ 1 2)) 4)) => `(list ,(+ 1 2) 4)) -; ---- 4.2.9. Case-lambda ------------------------------------------------------ +; ---- 4.2.9. ------------------------------------------------------------------ ; (define range ; (case-lambda @@ -350,23 +441,25 @@ ; ((b e) (do ((r ’() (cons e r)) ; (e (- e 1) (- e 1))) ; ((< e b) r))))) -; + ; (check (range 3) => (0 1 2)) + ; (check (range 3 5) => (3 4)) -; ---- 4.3.1. Binding constructs for syntactic keywords ------------------------ +; ---- 4.3.1. ------------------------------------------------------------------ -; (check (let-syntax ((given-that (syntax-rules () -; ((given-that test stmt1 stmt2 ...) -; (if test -; (begin stmt1 -; stmt2 ...)))))) -; (let ((if #t)) -; (given-that if (set! if 'now)) -; if)) => now) +(check (let-syntax ((given-that (syntax-rules () + ((given-that test stmt1 stmt2 ...) + (if test + (begin stmt1 + stmt2 ...)))))) + (let ((if #t)) + (given-that if (set! if 'now)) + if)) => now) (check (let ((x 'outer)) - (let-syntax ((m (syntax-rules () ((m) x)))) + (let-syntax ((m (syntax-rules () + ((m) x)))) (let ((x 'inner)) (m)))) => outer) @@ -375,15 +468,20 @@ ((my-or e) e) ((my-or e1 e2 ...) (let ((temp e1)) - (if temp temp (my-or e2 ...))))))) + (if temp + temp + (my-or e2 ...))))))) (let ((x #f) (y 7) (temp 8) (let odd?) (if even?)) - (my-or x (let temp) (if y) y))) => 7) + (my-or x + (let temp) + (if y) + y))) => 7) -; ---- 4.3.2. Pattern language ------------------------------------------------- +; ---- 4.3.2. ------------------------------------------------------------------ (define-syntax be-like-begin (syntax-rules () @@ -400,17 +498,18 @@ (check (let ((=> #f)) (cond (#t => 'ok))) => ok) -; (define-syntax simple-let -; (syntax-rules () -; ((_ (head ... ((x . y) val) . tail) body1 body2 ...) -; (syntax-error "expected an identifier but got" (x . y))) -; ((_ ((name val) ...) body1 body2 ...) -; ((lambda (name ...) body1 body2 ...) val ...)))) +(define-syntax simple-let + (syntax-rules () + ((_ (head ... ((x . y) val) . tail) body1 body2 ...) + (syntax-error "expected an identifier but got" (x . y))) + ((_ ((name val) ...) body1 body2 ...) + ((lambda (name ...) body1 body2 ...) val ...)))) -; ---- 5.3.1. Top level definitions -------------------------------------------- +; ---- 5.3.1. ------------------------------------------------------------------ (define add3 - (lambda (x) (+ x 3))) + (lambda (x) + (+ x 3))) (check (add3 3) => 6) @@ -418,31 +517,39 @@ (check (first '(1 2)) => 1) -; ---- 5.3.2. Internal definitions --------------------------------------------- +; ---- 5.3.2. ------------------------------------------------------------------ (check (let ((x 5)) - (define foo (lambda (y) (bar x y))) - (define bar (lambda (a b) (+ (* a b) a))) + (define foo + (lambda (y) + (bar x y))) + (define bar + (lambda (a b) + (+ (* a b) a))) (foo (+ x 3))) => 45) (check (let ((x 5)) - (letrec* ((foo (lambda (y) (bar x y))) - (bar (lambda (a b) (+ (* a b) a)))) + (letrec* ((foo (lambda (y) + (bar x y))) + (bar (lambda (a b) + (+ (* a b) a)))) (foo (+ x 3)))) => 45) -; ---- 5.3.3. Multiple-value definitions --------------------------------------- +; ---- 5.3.3. ------------------------------------------------------------------ ; (define-values (x y) (integer-sqrt 17)) -; + ; (check (list x y) => (4 1)) -; + ; (check (let () -; (define-values (x y) (values 1 2)) +; (define-values (x y) +; (values 1 2)) ; (+ x y)) => 3) -; ---- 5.4. Syntax definitions ------------------------------------------------- +; ---- 5.4. -------------------------------------------------------------------- -; (check (let ((x 1) (y 2)) +; (check (let ((x 1) +; (y 2)) ; (define-syntax swap! ; (syntax-rules () ; ((swap! a b) @@ -451,391 +558,547 @@ ; (set! b tmp))))) ; (swap! x y) ; (list x y)) => (2 1)) -; + ; (define define 3) ; error -; + ; (begin (define begin list)) ; error -; + ; (check (let-syntax ((foo (syntax-rules () ; ((foo (proc args ...) body ...) ; (define proc ; (lambda (args ...) body ...)))))) ; (let ((x 3)) -; (foo (plus x y) (+ x y)) +; (foo (plus x y) +; (+ x y)) ; (define foo x) ; (plus foo x))) ; error -; ---- 5.5. Record-type definitions -------------------------------------------- +; ---- 5.5. -------------------------------------------------------------------- ; (define-record-type ; (kons x y) ; pare? ; (x kar set-kar!) ; (y kdr)) -; + ; (check (pare? (kons 1 2)) => #t) + ; (check (pare? (cons 1 2)) => #f) + ; (check (kar (kons 1 2)) => 1) + ; (check (kdr (kons 1 2)) => 2) + ; (check (let ((k (kons 1 2))) ; (set-kar! k 3) ; (kar k)) => 3) -; ---- 5.6.2. Library example -------------------------------------------------- - -; (define-library (example grid) -; (export make rows cols ref each (rename put! set!)) -; (import (scheme base)) -; (begin -; (define (make n m) ; Create an NxM grid. -; (let ((grid (make-vector n))) -; (do ((i 0 (+ i 1))) -; ((= i n) grid) -; (let ((v (make-vector m #false))) -; (vector-set! grid i v))))) -; -; (define (rows grid) -; (vector-length grid)) -; -; (define (cols grid) -; (vector-length (vector-ref grid 0))) -; -; (define (ref grid n m) ; Return #false if out of range. -; (and (< -1 n (rows grid)) -; (< -1 m (cols grid)) -; (vector-ref (vector-ref grid n) m))) -; -; (define (put! grid n m v) -; (vector-set! (vector-ref grid n) m v)) -; -; (define (each grid proc) -; (do ((j 0 (+ j 1))) -; ((= j (rows grid))) -; (do ((k 0 (+ k 1))) -; ((= k (cols grid))) -; (proc j k (ref grid j k))))))) -; -; (define-library (example life) -; (export life) -; (import (except (scheme base) set!) -; (scheme write) -; (example grid)) -; (begin -; (define (life-count grid i j) -; (define (count i j) -; (if (ref grid i j) 1 0)) -; (+ (count (- i 1) (- j 1)) -; (count (- i 1) j ) -; (count (- i 1) (+ j 1)) -; (count i (- j 1)) -; (count i (+ j 1)) -; (count (+ i 1) (- j 1)) -; (count (+ i 1) j ) -; (count (+ i 1) (+ j 1)))) -; -; (define (life-alive? grid i j) -; (case (life-count grid i j) -; ((3) #true) -; ((2) (ref grid i j)) -; (else #false))) -; -; (define (life-print grid) -; (display "\x1B;[1H\x1B;[J") ; clear vt100 -; (each grid -; (lambda (i j v) -; (display (if v "*" " ")) -; (when (= j (- (cols grid) 1)) -; (newline))))) -; -; (define (life grid iterations) -; (do ((i 0 (+ i 1)) -; (grid0 grid grid1) -; (grid1 (make (rows grid) (cols grid)) grid0)) -; ((= i iterations)) -; (each grid0 -; (lambda (j k v) -; (let ((a (life-alive? grid0 j k))) -; (set! grid1 j k a)))) -; (life-print grid1))))) -; -; (import ; (scheme base) -; (only (example life) life) -; (rename (prefix (example grid) grid-) -; (grid-make make-grid))) -; +; ---- 5.6.2. ------------------------------------------------------------------ + +(define-library (example grid) + (export make rows cols ref each (rename put! set!)) + (import (scheme base)) + (begin (define (make n m) ; Create an NxM grid. + (let ((grid (make-vector n))) + (do ((i 0 (+ i 1))) + ((= i n) grid) + (let ((v (make-vector m #false))) + (vector-set! grid i v))))) + (define (rows grid) + (vector-length grid)) + (define (cols grid) + (vector-length (vector-ref grid 0))) + (define (ref grid n m) ; Return #false if out of range. + (and (< -1 n (rows grid)) + (< -1 m (cols grid)) + (vector-ref (vector-ref grid n) m))) + (define (put! grid n m v) + (vector-set! (vector-ref grid n) m v)) + (define (each grid proc) + (do ((j 0 (+ j 1))) + ((= j (rows grid))) + (do ((k 0 (+ k 1))) + ((= k (cols grid))) + (proc j k (ref grid j k))))))) + +(define-library (example life) + (export life) + (import (except (scheme base) set!) + (scheme write) + (example grid)) + (begin (define (life-count grid i j) + (define (count i j) + (if (ref grid i j) 1 0)) + (+ (count (- i 1) (- j 1)) + (count (- i 1) j ) + (count (- i 1) (+ j 1)) + (count i (- j 1)) + (count i (+ j 1)) + (count (+ i 1) (- j 1)) + (count (+ i 1) j ) + (count (+ i 1) (+ j 1)))) + (define (life-alive? grid i j) + (case (life-count grid i j) + ((3) #true) + ((2) (ref grid i j)) + (else #false))) + (define (life-print grid) + (display "\x1B;[1H\x1B;[J") ; clear vt100 + (each grid + (lambda (i j v) + (display (if v "*" " ")) + (when (= j (- (cols grid) 1)) + (newline))))) + (define (life grid iterations) + (do ((i 0 (+ i 1)) + (grid0 grid grid1) + (grid1 (make (rows grid) (cols grid)) grid0)) + ((= i iterations)) + (each grid0 + (lambda (j k v) + (let ((a (life-alive? grid0 j k))) + (set! grid1 j k a)))) + (life-print grid1))))) + +(import ; (scheme base) + (only (example life) life) + (rename (prefix (example grid) grid-) + (grid-make make-grid))) + ; (define grid (make-grid 24 24)) -; + ; (grid-set! grid 1 1 #true) + ; (grid-set! grid 2 2 #true) + ; (grid-set! grid 3 0 #true) + ; (grid-set! grid 3 1 #true) + ; (grid-set! grid 3 2 #true) -; + ; (life grid 80) -; ---- 6.1. Equivalence predicates --------------------------------------------- +; ---- 6.1. -------------------------------------------------------------------- (check (eqv? 'a 'a) => #t) + (check (eqv? 'a 'b) => #f) + (check (eqv? 2 2) => #t) + (check (eqv? 2 2.0) => #f) + (check (eqv? '() '()) => #t) + (check (eqv? 100000000 100000000) => #t) + (check (eqv? 0.0 +nan.0) => #f) -(check (eqv? (cons 1 2) (cons 1 2)) => #f) + +(check (eqv? (cons 1 2) + (cons 1 2)) => #f) + (check (eqv? (lambda () 1) (lambda () 2)) => #f) + (check (let ((p (lambda (x) x))) (eqv? p p)) => #t) + (check (eqv? #f 'nil) => #f) (check (eqv? "" "") => #t) ; unspecified + (check (eqv? '#() '#()) => #t) ; unspecified + (check (eqv? (lambda (x) x) (lambda (x) x)) => #f) ; unspecified + (check (eqv? (lambda (x) x) (lambda (y) y)) => #f) ; unspecified -; (check (eqv? 1.0e0 1.0f0) => TODO) ; unspecified + +(check (eqv? 1.0e0 1.0f0) => #t) ; unspecified + (check (eqv? +nan.0 +nan.0) => #t) ; unspecified (define generate-counter (lambda () (let ((n 0)) - (lambda () (set! n (+ n 1)) n)))) + (lambda () + (set! n (+ n 1)) n)))) + (check (let ((g (generate-counter))) (eqv? g g)) => #t) + (check (eqv? (generate-counter) (generate-counter)) => #f) (define generate-loser (lambda () (let ((n 0)) - (lambda () (set! n (+ n 1)) 27)))) + (lambda () + (set! n (+ n 1)) 27)))) + (check (let ((g (generate-loser))) (eqv? g g)) => #t) + (check (eqv? (generate-loser) (generate-loser)) => #f) ; unspecified -(check (letrec ((f (lambda () (if (eqv? f g) 'both 'f))) - (g (lambda () (if (eqv? f g) 'both 'g)))) +(check (letrec ((f (lambda () + (if (eqv? f g) + 'both + 'f))) + (g (lambda () + (if (eqv? f g) + 'both + 'g)))) (eqv? f g)) => #f) ; unspecified -(check (letrec ((f (lambda () (if (eqv? f g) 'f 'both))) - (g (lambda () (if (eqv? f g) 'g 'both)))) +(check (letrec ((f (lambda () + (if (eqv? f g) + 'f + 'both))) + (g (lambda () + (if (eqv? f g) + 'g + 'both)))) (eqv? f g)) => #f) (check (eqv? '(a) '(a)) => #t) ; unspecified + (check (eqv? "a" "a") => #t) ; unspecified + (check (eqv? '(b) (cdr '(a b))) => #t) ; unspecified + (check (let ((x '(a))) (eqv? x x)) => #t) (check (eq? 'a 'a) => #t) + (check (eq? '(a) '(a)) => #f) ; unspecified -(check (eq? (list 'a) (list 'a)) => #f) + +(check (eq? (list 'a) + (list 'a)) => #f) + (check (eq? "a" "a") => #f) ; unspecified + (check (eq? "" "") => #f) ; unspecified + (check (eq? '() '()) => #t) + (check (eq? 2 2) => #f) ; unspecified + (check (eq? #\A #\A) => #f) ; unspecified + (check (eq? car car) => #t) + (check (let ((n (+ 2 3))) (eq? n n)) => #t) ; unspecified + (check (let ((x '(a))) (eq? x x)) => #t) + (check (let ((x '#())) (eq? x x)) => #t) + (check (let ((p (lambda (x) x))) (eq? p p)) => #t) (check (equal? 'a 'a) => #t) + (check (equal? '(a) '(a)) => #t) + (check (equal? '(a (b) c) '(a (b) c)) => #t) + (check (equal? "abc" "abc") => #t) + (check (equal? 2 2) => #t) + (check (equal? (make-vector 5 'a) (make-vector 5 'a)) => #t) + ; (check (equal? '#1=(a b . #1#) ; '#2=(a b a b . #2#)) => #t) + (check (equal? (lambda (x) x) (lambda (y) y)) => #f) ; unspecified -; ---- 6.2. Numbers ------------------------------------------------------------ +; ---- 6.2.6. ------------------------------------------------------------------ ; (check (complex? 3+4i) => #t) + (check (complex? 3) => #t) + (check (real? 3) => #t) + ; (check (real? -2.5+0i) => #t) + ; (check (real? -2.5+0.0i) => #t) + (check (real? #e1e10) => #t) + (check (real? +inf.0) => #t) + (check (real? +nan.0) => #t) + (check (rational? -inf.0) => #f) + (check (rational? 3.5) => #t) + (check (rational? 6/10) => #t) + (check (rational? 6/3) => #t) + ; (check (integer? 3+0i) => #t) + (check (integer? 3.0) => #t) + (check (integer? 8/4) => #t) (check (exact? 3.0) => #f) + (check (exact? #e3.0) => #t) + (check (inexact? 3.) => #t) (check (exact-integer? 32) => #t) + (check (exact-integer? 32.0) => #f) + (check (exact-integer? 32/5) => #f) (check (finite? 3) => #t) + (check (finite? +inf.0) => #f) + ; (check (finite? 3.0+inf.0i) => #f) (check (infinite? 3) => #f) + (check (infinite? +inf.0) => #t) + (check (infinite? +nan.0) => #f) + ; (check (infinite? 3.0+inf.0i) => #t) (check (nan? +nan.0) => #t) + (check (nan? 32) => #f) + ; (check (nan? +nan.0+5.0i) => #t) + ; (check (nan? 1+2i) => #f) (check (zero? 0/1) => #t) -(check (max 3 4) => 4) ; exact +(check (max 3 4) => 4) ; exact + (check (max 3.9 4) => 4.0) ; inexact (check (+ 3 4) => 7) + (check (+ 3) => 3) + (check (+) => 0) + (check (* 4) => 4) + (check (*) => 1) -(check (- 3 4 5) => -6) (check (- 3 4) => -1) + +(check (- 3 4 5) => -6) + (check (- 3) => -3) + (check (/ 3 4 5) => 3/20) + (check (/ 3) => 1/3) -(check (floor-quotient 5 2) => 2) (check (floor-remainder 5 2) => 1) -(check (floor-quotient -5 2) => -3) (check (floor-remainder -5 2) => 1) -(check (floor-quotient 5 -2) => -3) (check (floor-remainder 5 -2) => -1) -(check (floor-quotient -5 -2) => 2) (check (floor-remainder -5 -2) => -1) +(check (abs -7) => 7) + +(check (floor/ 5 2) => #,(values 2 1)) + +(check (floor/ -5 2) => #,(values -3 1)) + +(check (floor/ 5 -2) => #,(values -3 -1)) -(check (truncate-quotient 5 2) => 2) (check (truncate-remainder 5 2) => 1) -(check (truncate-quotient -5 2) => -2) (check (truncate-remainder -5 2) => -1) -(check (truncate-quotient 5 -2) => -2) (check (truncate-remainder 5 -2) => 1) -(check (truncate-quotient -5 -2) => 2) (check (truncate-remainder -5 -2) => -1) -(check (truncate-quotient -5.0 -2) => 2.0) (check (truncate-remainder -5.0 -2) => -1.0) +(check (floor/ -5 -2) => #,(values 2 -1)) + +(check (truncate/ 5 2) => #,(values 2 1)) + +(check (truncate/ -5 2) => #,(values -2 -1)) + +(check (truncate/ 5 -2) => #,(values -2 1)) + +(check (truncate/ -5 -2) => #,(values 2 -1)) + +(check (truncate/ -5.0 -2) => #,(values 2.0 -1.0)) (check (gcd 32 -36) => 4) + (check (gcd) => 0) -(check (lcm 32 -36) => 288) + +(check (lcm 32 -36) => 288) + (check (lcm 32.0 -36) => 288.0) ; inexact + (check (lcm) => 1) (check (numerator (/ 6 4)) => 3) + (check (denominator (/ 6 4)) => 2) -(check (denominator - (inexact (/ 6 4))) => 2.0) + +(check (denominator (inexact (/ 6 4))) => 2.0) (check (floor -4.3) => -5.0) + (check (ceiling -4.3) => -4.0) + (check (truncate -4.3) => -4.0) + (check (round -4.3) => -4.0) (check (floor 3.5) => 3.0) + (check (ceiling 3.5) => 4.0) + (check (truncate 3.5) => 3.0) + (check (round 3.5) => 4.0) ; inexact (check (round 7/2) => 4) ; exact + (check (round 7) => 7) (check (rationalize (exact .3) 1/10) => 1/3) ; exact -(check (rationalize .3 1/10) => #,(/ 1.0 3.0)) ; inexact + +(check (rationalize .3 1/10) => #i1/3) ; inexact (check (square 42) => 1764) + (check (square 2.0) => 4.0) (check (sqrt 9) => 3) + ; (check (sqrt -1) => +i) +; (check (exact-integer-sqrt 4) => #,(values 2 0)) + +; (check (exact-integer-sqrt 5) => #,(values 2 1)) + (check (string->number "100") => 100) + (check (string->number "100" 16) => 256) + (check (string->number "1e2") => 100.0) -; ---- 6.3. Booleans ----------------------------------------------------------- +; ---- 6.3. -------------------------------------------------------------------- + +(check #t => #t) + +(check #f => #f) -(check #t => #t) -(check '#t => #t) -(check #f => #f) (check '#f => #f) (check (not #t) => #f) + (check (not 3) => #f) + (check (not (list 3)) => #f) + (check (not #f) => #t) + (check (not '()) => #f) + (check (not (list)) => #f) + (check (not 'nil) => #f) (check (boolean? #f) => #t) + (check (boolean? 0) => #f) + (check (boolean? '()) => #f) -; ---- 6.4. Pairs and lists ---------------------------------------------------- +; ---- 6.4. -------------------------------------------------------------------- (check (equal? '(a b c d e) '(a . (b . (c . (d . (e . ())))))) => #t) + (check (equal? '(a b c . d) '(a . (b . (c . d)))) => #t) (define x (list 'a 'b 'c)) + (define y x) -(check x => (a b c)) + (check y => (a b c)) -(check (list? x) => #t) + (check (list? y) => #t) -(set-cdr! x 4) + +(check (set-cdr! x 4) => 4) + (check x => (a . 4)) -(check y => (a . 4)) + (check (eqv? x y) => #t) -(check (list? x) => #f) + +(check y => (a . 4)) + (check (list? y) => #f) + (set-cdr! x x) + (check (list? x) => #f) (check (pair? '(a . b)) => #t) + (check (pair? '(a b c)) => #t) + (check (pair? '()) => #f) + (check (pair? '#(a b)) => #f) (check (cons 'a '()) => (a)) + (check (cons '(a) '(b c d)) => ((a) b c d)) + (check (cons "a" '(b c)) => ("a" b c)) + (check (cons 'a 3) => (a . 3)) + (check (cons '(a b) 'c) => ((a b) . c)) (check (car '(a b c)) => a) + (check (car '((a) b c d)) => (a)) + (check (car '(1 . 2)) => 1) -; (check (car '()) => error) + +(check (car '()) => ()) (check (cdr '((a) b c d)) => (b c d)) + (check (cdr '(1 . 2)) => 2) -; (check (cdr '()) => error) -(define (f) (list 'not-a-constant-list)) +(check (cdr '()) => ()) + +(define (f) + (list 'not-a-constant-list)) + (define (g) '(constant-list)) -(set-car! (f) 3) ; => unspecified -(set-car! (g) 3) ; => error + +(check (set-car! (f) 3) => 3) + +(check (set-car! (g) 3) => 3) (check (list? '(a b c)) => #t) + (check (list? '()) => #t) -(check (list? '(a)) => #t) + (check (list? '(a . b)) => #f) + (check (let ((x (list 'a))) (set-cdr! x x) (list? x)) => #f) @@ -843,161 +1106,248 @@ (check (make-list 2 3) => (3 3)) (check (list 'a (+ 3 4) 'c) => (a 7 c)) + (check (list) => ()) (check (length '(a b c)) => 3) + (check (length '(a (b) (c d e))) => 3) + (check (length '()) => 0) (check (append '(x) '(y)) => (x y)) + (check (append '(a) '(b c d)) => (a b c d)) + (check (append '(a (b)) '((c))) => (a (b) (c))) + (check (append '(a b) '(c . d)) => (a b c . d)) + (check (append '() 'a) => a) (check (reverse '(a b c)) => (c b a)) + (check (reverse '(a (b c) d (e (f)))) => ((e (f)) d (b c) a)) (check (list-ref '(a b c d) 2) => c) + (check (list-ref '(a b c d) (exact (round 1.8))) => c) +(check (let ((ls (list 'one 'two 'five!))) + (list-set! ls 2 'three) + ls) => (one two three)) + +(check (list-set! '(0 1 2) 1 "oops") => "oops") + (check (memq 'a '(a b c)) => (a b c)) + (check (memq 'b '(a b c)) => (b c)) + (check (memq 'a '(b c d)) => #f) + (check (memq (list 'a) '(b (a) c)) => #f) + (check (member (list 'a) '(b (a) c)) => ((a) c)) + +(check (member "B" '("a" "b" "c") string-ci=?) => ("b" "c")) + (check (memq 101 '(100 101 102)) => #f) ; unspecified + (check (memv 101 '(100 101 102)) => (101 102)) (define e '((a 1) (b 2) (c 3))) + (check (assq 'a e) => (a 1)) + (check (assq 'b e) => (b 2)) -(check (assq 'c e) => (c 3)) + (check (assq 'd e) => #f) + (check (assq (list 'a) '(((a)) ((b)) ((c)))) => #f) + (check (assoc (list 'a) '(((a)) ((b)) ((c)))) => ((a))) + (check (assoc 2.0 '((1 1) (2 4) (3 9)) =) => (2 4)) + (check (assq 5 '((2 3) (5 7) (11 13))) => #f) ; unspecified + (check (assv 5 '((2 3) (5 7) (11 13))) => (5 7)) (define a '(1 8 2 8)) ; a may be immutable + (define b (list-copy a)) + (set-car! b 3) ; b is mutable + (check b => (3 8 2 8)) + (check a => (1 8 2 8)) -; ---- 6.5. Symbols ------------------------------------------------------------ +; ---- 6.5. -------------------------------------------------------------------- (check (symbol? 'foo) => #t) + (check (symbol? (car '(a b))) => #t) + (check (symbol? "bar") => #f) + (check (symbol? 'nil) => #t) + (check (symbol? '()) => #f) + (check (symbol? #f) => #f) (check (symbol->string 'flying-fish) => "flying-fish") + (check (symbol->string 'Martin) => "Martin") + (check (symbol->string (string->symbol "Malvina")) => "Malvina") (check (string->symbol "mISSISSIppi") => mISSISSIppi) + (check (eqv? 'bitBlt (string->symbol "bitBlt")) => #t) + (check (eqv? 'LollyPop (string->symbol (symbol->string 'LollyPop))) => #t) + (check (string=? "K. Harper, M.D." (symbol->string (string->symbol "K. Harper, M.D."))) => #t) -; ---- 6.6. Characters --------------------------------------------------------- +; ---- 6.6. -------------------------------------------------------------------- + +(check (char? #\alarm) => #t) ; U+0007 -(check (char? #\alarm) => #t) ; U+0007 (check (char? #\backspace) => #t) ; U+0008 -(check (char? #\delete) => #t) ; U+007F -(check (char? #\escape) => #t) ; U+001B -(check (char? #\newline) => #t) ; U+000A -(check (char? #\null) => #t) ; U+0000 -(check (char? #\return) => #t) ; U+000D -(check (char? #\space) => #t) ; U+0020 -(check (char? #\tab) => #t) ; U+0009 + +(check (char? #\delete) => #t) ; U+007F + +(check (char? #\escape) => #t) ; U+001B + +(check (char? #\newline) => #t) ; U+000A + +(check (char? #\null) => #t) ; U+0000 + +(check (char? #\return) => #t) ; U+000D + +(check (char? #\space) => #t) ; U+0020 + +(check (char? #\tab) => #t) ; U+0009 (check (char? #\a) => #t) + (check (char? #\A) => #t) + (check (char? #\() => #t) + (check (char? #\ ) => #t) + (check (char? #\x03BB) => #t) +; (check (char? #\iota) => #t) + (check (char-ci=? #\A #\a) => #t) (check (digit-value #\3) => 3) + ; (check (digit-value #\x0664) => 4) + ; (check (digit-value #\x0AE6) => 0) + ; (check (digit-value #\x0EA6) => #f) ; BUG: MEMORY-LEAK -; ---- 6.7. Strings ------------------------------------------------------------ +; ---- 6.7. -------------------------------------------------------------------- (check (string? "The word \"recursion\" has many meanings.") => #t) + (check (string? "Another example:\ntwo lines of test") => #t) + (check (string? "Here's test \ containing just one line") => #t) + (check (string? "\x03B1; is named GREEK SMALL LETTER ALPHA.") => #t) (define (f) (make-string 3 #\*)) + (define (g) "***") + (check (string-set! (f) 0 #\?) => "?**") + (check (string-set! (g) 0 #\?) => "?**") + (check (string-set! (symbol->string 'immutable) 0 #\?) => "?mmutable") -; (define a "12345") -; (define b (string-copy "abcde")) -; (string-copy! b 1 a 0 2) -; (check b => "a12de") +(define a "12345") + +(define b (string-copy "abcde")) + +(string-copy! b 1 a 0 2) + +(check b => "a12de") -; ---- 6.8. Vectors ------------------------------------------------------------ +; ---- 6.8. -------------------------------------------------------------------- (check (vector? #(0 (2 2 2 2) "Anna")) => #t) (check (vector 'a 'b 'c) => #(a b c)) (check (vector-ref '#(1 1 2 3 5 8 13 21) 5) => 8) + (check (vector-ref '#(1 1 2 3 5 8 13 21) (exact (round (* 2 (acos -1))))) => 13) (check (let ((vec (vector 0 '(2 2 2 2) "Anna"))) (vector-set! vec 1 '("Sue" "Sue")) vec) => #(0 ("Sue" "Sue") "Anna")) + (check (vector-set! '#(0 1 2) 1 "doe") => "doe") (check (vector->list '#(dah dah didah)) => (dah dah didah)) + (check (vector->list '#(dah dah didah) 1 2) => (dah)) + (check (list->vector '(dididit dah)) => #(dididit dah)) -; (check (string->vector "ABC") => #(#\A #\B #\C)) +(check (string->vector "ABC") => #(#\A #\B #\C)) + (check (vector->string #(#\1 #\2 #\3)) => "123") -; (define a #(1 8 2 8)) ; a may be immutable -; (define b (vector-copy a)) -; (vector-set! b 0 3) ; b is mutable -; (check b => #(3 8 2 8)) -; (define c (vector-copy b 1 3)) -; (check c => #(8 2)) +(define a #(1 8 2 8)) ; a may be immutable -; (define a (vector 1 2 3 4 5)) -; (define b (vector 10 20 30 40 50)) -; (vector-copy! b 1 a 0 2) -; (check b => #(10 1 2 40 50)) +(define b (vector-copy a)) -; (check (vector-append #(a b c) #(d e f)) => #(a b c d e f)) +(vector-set! b 0 3) ; b is mutable + +(check b => #(3 8 2 8)) + +(define c (vector-copy b 1 3)) + +(check c => #(8 2)) + +(define a (vector 1 2 3 4 5)) + +(define b (vector 10 20 30 40 50)) + +(vector-copy! b 1 a 0 2) + +(check b => #(10 1 2 40 50)) + +(check (vector-append #(a b c) #(d e f)) => #(a b c d e f)) (define a (vector 1 2 3 4 5)) + (vector-fill! a 'smash 2 4) + (check a => #(1 2 smash smash 5)) -; ---- 6.9. Bytevectors -------------------------------------------------------- +; ---- 6.9. -------------------------------------------------------------------- ; (check (bytevector? #u8(0 10 5)) => #t) ; (check (make-bytevector 2 12) => #u8(12 12)) ; (check (bytevector 1 3 5 1 3 5) => #u8(1 3 5 1 3 5)) + ; (check (bytevector) => #u8()) ; (check (bytevector-u8-ref '#u8(1 1 2 3 5 8 13 21) 5) => 8) @@ -1007,24 +1357,33 @@ ; bv) => #u8(1 3 3 4)) ; (define a #u8(1 2 3 4 5)) + ; (check (bytevector-copy a 2 4) => #u8(3 4)) ; (define a (bytevector 1 2 3 4 5)) + ; (define b (bytevector 10 20 30 40 50)) + ; (bytevector-copy! b 1 a 0 2) + ; (check b => #u8(10 1 2 40 50)) ; (check (bytevector-append #u8(0 1 2) #u8(3 4 5)) => #u8(0 1 2 3 4 5)) ; (check (utf8->string #u8(#x41)) => "A") + ; (check (string->utf8 "λ") => #u8(#xCE #xBB)) -; ---- 6.10. Control features -------------------------------------------------- +; ---- 6.10. ------------------------------------------------------------------- (check (procedure? car) => #t) + (check (procedure? 'car) => #f) + (check (procedure? (lambda (x) (* x x))) => #t) + (check (procedure? '(lambda (x) (* x x))) => #f) + (check (call-with-current-continuation procedure?) => #t) (check (apply + (list 3 4)) => 7) @@ -1037,7 +1396,9 @@ (check ((compose sqrt *) 12 75) => 30) (check (map cadr '((a b) (d e) (g h))) => (b e h)) + (check (map (lambda (n) (expt n n)) '(1 2 3 4 5)) => (1 4 27 256 3125)) + (check (map + '(1 2 3) '(4 5 6 7)) => (5 7 9)) (check (let ((count 0)) @@ -1048,20 +1409,22 @@ (check (string-map char-foldcase "AbdEgH") => "abdegh") -(check (string-map - (lambda (c) - (integer->char (+ 1 (char->integer c)))) - "HAL") => "IBM") +(check (string-map (lambda (c) + (integer->char (+ 1 (char->integer c)))) + "HAL") => "IBM") -; (check (string-map -; (lambda (c k) -; ((if (eqv? k #\u) char-upcase char-downcase) -; c)) -; "studlycaps xxx" -; "ululululul") => "StUdLyCaPs") +; (check (string-map (lambda (c k) +; ((if (eqv? k #\u) char-upcase char-downcase) +; c)) +; "studlycaps xxx" +; "ululululul") => "StUdLyCaPs") ; (check (vector-map cadr '#((a b) (d e) (g h))) => #(b e h)) -; (check (vector-map (lambda (n) (expt n n)) '#(1 2 3 4 5)) => (1 4 27 256 3125)) + +; (check (vector-map (lambda (n) +; (expt n n)) +; '#(1 2 3 4 5)) => (1 4 27 256 3125)) + ; (check (vector-map + '#(1 2 3) '#(4 5 6 7)) => #(5 7 9)) ; (check (let ((count 0)) @@ -1069,7 +1432,7 @@ ; (lambda (ignored) ; (set! count (+ count 1)) ; count) -; '#(a b))) => #(1 2)) +; '#(a b))) => #(1 2)) ; or #(2 1) (check (let ((v (make-vector 5))) (for-each (lambda (i) @@ -1102,19 +1465,20 @@ (lambda (object) (call-with-current-continuation (lambda (return) - (letrec ((r - (lambda (object) - (cond ((null? object) 0) - ((pair? object) - (+ (r (cdr object)) 1)) - (else (return #f)))))) + (letrec ((r (lambda (object) + (cond ((null? object) 0) + ((pair? object) + (+ (r (cdr object)) 1)) + (else (return #f)))))) (r object)))))) (check (list-length '(1 2 3 4)) => 4) + (check (list-length '(a b . c)) => #f) (check (call-with-values (lambda () (values 4 5)) (lambda (a b) b)) => 5) + (check (call-with-values * -) => -1) (check (let ((path '()) @@ -1134,19 +1498,18 @@ (reverse path)))) => (connect talk1 disconnect connect talk2 disconnect)) -; ---- 6.11. Exceptions -------------------------------------------------------- +; ---- 6.11. ------------------------------------------------------------------- -(check (eq? (call-with-current-continuation - (lambda (k) - (with-exception-handler - (lambda (x) - (display "condition: ") - (write x) - (newline) - (k 'exception)) - (lambda () - (+ 1 (raise 'an-error)))))) - 'exception) => #t) +(check (call-with-current-continuation + (lambda (k) + (with-exception-handler + (lambda (x) + (display "condition: ") + (write x) + (newline) + (k 'exception)) + (lambda () + (+ 1 (raise 'an-error)))))) => exception) ; (with-exception-handler ; (lambda (x) @@ -1169,18 +1532,17 @@ ((null? l) #t) (else (error "null-list?: argument out of domain" l)))) -; ---- 6.12. Environments and evaluation --------------------------------------- +; ---- 6.12. ------------------------------------------------------------------- -; (check (eval '(* 7 3) (environment '(scheme base))) => 21) +(check (eval '(* 7 3) (environment '(scheme base))) => 21) -; (check (let ((f (eval '(lambda (f x) (f x x)) -; (null-environment 5)))) -; (f + 10)) => 20) +(check (let ((f (eval '(lambda (f x) (f x x)) + (null-environment 5)))) + (f + 10)) => 20) -; (check (eval '(define foo 32) -; (environment '(scheme base))) => error is signaled) +(check (eval '(define foo 32) (environment '(scheme base))) => 32) -; ---- 6.13. Input and output -------------------------------------------------- +; ---- 6.13.1. ----------------------------------------------------------------- (check (parameterize ((current-output-port (open-output-string))) (display "piece") @@ -1189,12 +1551,8 @@ (newline) (get-output-string (current-output-port))) => "piece by piece by piece.\n") -; ---- 6.14. System interface -------------------------------------------------- - -; TODO - ; ------------------------------------------------------------------------------ (check-report) -(exit (check-passed? 368)) +(exit (check-passed? 383)) diff --git a/test/read-char.ss b/test/read-char.ss index 737c02294..7cf922865 100644 --- a/test/read-char.ss +++ b/test/read-char.ss @@ -1,17 +1,17 @@ (define port (open-input-string "lambdaλラムダ")) -(write (%read-char port)) ; #\l -(write (%read-char port)) ; #\a -(write (%read-char port)) ; #\m -(write (%read-char port)) ; #\b -(write (%read-char port)) ; #\d -(write (%read-char port)) ; #\a +(write (get-char! port)) ; #\l +(write (get-char! port)) ; #\a +(write (get-char! port)) ; #\m +(write (get-char! port)) ; #\b +(write (get-char! port)) ; #\d +(write (get-char! port)) ; #\a (newline) -(write (%read-char port)) ; #\λ or #\x03bb +(write (get-char! port)) ; #\λ or #\x03bb (newline) -(write (%read-char port)) ; #\ラ -(write (%read-char port)) ; #\ム -(write (%read-char port)) ; #\ダ +(write (get-char! port)) ; #\ラ +(write (get-char! port)) ; #\ム +(write (get-char! port)) ; #\ダ (newline)