From 37f3396c52584dda49f348621aeb73e7c98ba284 Mon Sep 17 00:00:00 2001 From: yamacir-kit Date: Mon, 2 Oct 2023 00:52:40 +0900 Subject: [PATCH 01/32] Cleanup `example.cpp` Signed-off-by: yamacir-kit --- README.md | 6 +++--- VERSION | 2 +- example/example.cpp | 11 +++++------ 3 files changed, 9 insertions(+), 10 deletions(-) diff --git a/README.md b/README.md index 91bc6528d..048f3057d 100644 --- a/README.md +++ b/README.md @@ -99,7 +99,7 @@ Procedures for each standard are provided by the following R7RS-style libraries: cmake -B build -DCMAKE_BUILD_TYPE=Release cd build make package -sudo apt install build/meevax_0.5.0_amd64.deb +sudo apt install build/meevax_0.5.1_amd64.deb ``` or @@ -131,9 +131,9 @@ sudo rm -rf /usr/local/share/meevax | Target Name | Description |-------------|------------- -| `all` | Build shared-library `libmeevax.0.5.0.so` and executable `meevax` +| `all` | Build shared-library `libmeevax.0.5.1.so` and executable `meevax` | `test` | Test executable `meevax` -| `package` | Generate debian package `meevax_0.5.0_amd64.deb` +| `package` | Generate debian package `meevax_0.5.1_amd64.deb` | `install` | Copy files into `/usr/local` directly ## Usage diff --git a/VERSION b/VERSION index 8f0916f76..4b9fcbec1 100644 --- a/VERSION +++ b/VERSION @@ -1 +1 @@ -0.5.0 +0.5.1 diff --git a/example/example.cpp b/example/example.cpp index b2f8b7a54..f4315b95c 100644 --- a/example/example.cpp +++ b/example/example.cpp @@ -1,16 +1,15 @@ -#include #include using namespace meevax; // NOTE: DIRTY HACK extern "C" { - let length_of_arguments(let const& xs) + auto length_of_arguments(object const& xs) { return make(length(xs)); } - let dummy_procedure(let const& xs) + auto dummy_procedure(object const& xs) { std::cout << "\n; calling C++ function via foreign-function-interface." << std::endl; @@ -46,17 +45,17 @@ extern "C" } }; - let make_hoge(let const& xs) + auto make_hoge(object const& xs) { return make(xs[0].as()); } - let is_hoge(let const& xs) + auto is_hoge(object const& xs) { return xs[0].is() ? t : f; } - let hoge_value(let const& xs) + auto hoge_value(object const& xs) { return make(xs[0].as().value); } From c013be411c2e2ebfdf759043551a04774bf65b17 Mon Sep 17 00:00:00 2001 From: yamacir-kit Date: Mon, 2 Oct 2023 22:52:48 +0900 Subject: [PATCH 02/32] Update library `(srfi 45)` to not depend on `(scheme r4rs essential)` Signed-off-by: yamacir-kit --- README.md | 8 ++++---- VERSION | 2 +- basis/srfi-45.ss | 12 ++++++++---- configure/README.md | 2 +- 4 files changed, 14 insertions(+), 10 deletions(-) diff --git a/README.md b/README.md index 048f3057d..14f1dc515 100644 --- a/README.md +++ b/README.md @@ -99,7 +99,7 @@ Procedures for each standard are provided by the following R7RS-style libraries: cmake -B build -DCMAKE_BUILD_TYPE=Release cd build make package -sudo apt install build/meevax_0.5.1_amd64.deb +sudo apt install build/meevax_0.5.2_amd64.deb ``` or @@ -131,9 +131,9 @@ sudo rm -rf /usr/local/share/meevax | Target Name | Description |-------------|------------- -| `all` | Build shared-library `libmeevax.0.5.1.so` and executable `meevax` +| `all` | Build shared-library `libmeevax.0.5.2.so` and executable `meevax` | `test` | Test executable `meevax` -| `package` | Generate debian package `meevax_0.5.1_amd64.deb` +| `package` | Generate debian package `meevax_0.5.2_amd64.deb` | `install` | Copy files into `/usr/local` directly ## Usage @@ -158,7 +158,7 @@ See [LICENSE](./LICENSE). ## References | Authors | Year | Title | Journal Title / Publisher | Pages | -|-------------------------------------------------------------------------------------------------------|:----:|-------------------------------------------------------------------------------------------------------------------------------------------|-----------------------------------------------------------------------------------------------------------------------------------------------------------|----------------| +|-------------------------------------------------------------------------------------------------------|:----:|-------------------------------------------------------------------------------------------------------------------------------------------|-----------------------------------------------------------------------------------------------------------------------------------------------------------|:--------------:| | John McCarthy | 1960 | [Recursive functions of symbolic expressions and their computation by machine, Part I](https://dl.acm.org/doi/10.1145/367177.367199) | [Communications of the ACM, Volume 3, Issue 4](https://dl.acm.org/toc/cacm/1960/3/4) | 184‑195 | | P. J. Landin | 1964 | [The Mechanical Evaluation of Expressions](https://academic.oup.com/comjnl/article/6/4/308/375725) | [The Computor Journal, Volume 6, Issue 4](https://academic.oup.com/comjnl/issue/6/4) | 308‑320 | | Peter Henderson | 1980 | [Functional Programming: Application and Implementation](https://archive.org/details/functionalprogra0000hend/mode/2up) | Prentice Hall | | diff --git a/VERSION b/VERSION index 4b9fcbec1..cb0c939a9 100644 --- a/VERSION +++ b/VERSION @@ -1 +1 @@ -0.5.1 +0.5.2 diff --git a/basis/srfi-45.ss b/basis/srfi-45.ss index 6e07b5634..5a550fe38 100644 --- a/basis/srfi-45.ss +++ b/basis/srfi-45.ss @@ -1,7 +1,10 @@ (define-library (srfi 45) ; Based on r7rs reference implementation. - (import (only (meevax core) define-syntax) + (import (only (meevax boolean) not) + (only (meevax comparator) eq?) + (only (meevax core) define define-syntax if lambda quote) + (only (meevax list) list) (only (meevax macro-transformer) er-macro-transformer) - (scheme r4rs essential)) + (only (meevax pair) pair? cons car cdr cadr cddr set-car! set-cdr!)) (export delay eager force lazy promise?) @@ -11,8 +14,9 @@ (cons (cons done? value))) (define (promise? x) - (and (pair? x) - (eq? (car x)))) + (if (pair? x) + (eq? (car x)) + #f)) (define promise-done? cadr) diff --git a/configure/README.md b/configure/README.md index db3661b97..7f229359f 100644 --- a/configure/README.md +++ b/configure/README.md @@ -149,7 +149,7 @@ See [LICENSE](./LICENSE). ## References | Authors | Year | Title | Journal Title / Publisher | Pages | -|-------------------------------------------------------------------------------------------------------|:----:|-------------------------------------------------------------------------------------------------------------------------------------------|-----------------------------------------------------------------------------------------------------------------------------------------------------------|----------------| +|-------------------------------------------------------------------------------------------------------|:----:|-------------------------------------------------------------------------------------------------------------------------------------------|-----------------------------------------------------------------------------------------------------------------------------------------------------------|:--------------:| | John McCarthy | 1960 | [Recursive functions of symbolic expressions and their computation by machine, Part I](https://dl.acm.org/doi/10.1145/367177.367199) | [Communications of the ACM, Volume 3, Issue 4](https://dl.acm.org/toc/cacm/1960/3/4) | 184‑195 | | P. J. Landin | 1964 | [The Mechanical Evaluation of Expressions](https://academic.oup.com/comjnl/article/6/4/308/375725) | [The Computor Journal, Volume 6, Issue 4](https://academic.oup.com/comjnl/issue/6/4) | 308‑320 | | Peter Henderson | 1980 | [Functional Programming: Application and Implementation](https://archive.org/details/functionalprogra0000hend/mode/2up) | Prentice Hall | | From 3c7b6a8898e7868a7886daf4bca7d10129f4bd21 Mon Sep 17 00:00:00 2001 From: yamacir-kit Date: Mon, 2 Oct 2023 23:00:48 +0900 Subject: [PATCH 03/32] Unify library `(scheme r4rs)` and `(scheme r4rs essential)` Signed-off-by: yamacir-kit --- README.md | 6 +- VERSION | 2 +- basis/r4rs-essential.ss | 516 ------------------------------------- basis/r4rs.ss | 547 ++++++++++++++++++++++++++++++++++++---- configure/basis.hpp | 1 - 5 files changed, 499 insertions(+), 573 deletions(-) delete mode 100644 basis/r4rs-essential.ss diff --git a/README.md b/README.md index 14f1dc515..d263145e1 100644 --- a/README.md +++ b/README.md @@ -99,7 +99,7 @@ Procedures for each standard are provided by the following R7RS-style libraries: cmake -B build -DCMAKE_BUILD_TYPE=Release cd build make package -sudo apt install build/meevax_0.5.2_amd64.deb +sudo apt install build/meevax_0.5.3_amd64.deb ``` or @@ -131,9 +131,9 @@ sudo rm -rf /usr/local/share/meevax | Target Name | Description |-------------|------------- -| `all` | Build shared-library `libmeevax.0.5.2.so` and executable `meevax` +| `all` | Build shared-library `libmeevax.0.5.3.so` and executable `meevax` | `test` | Test executable `meevax` -| `package` | Generate debian package `meevax_0.5.2_amd64.deb` +| `package` | Generate debian package `meevax_0.5.3_amd64.deb` | `install` | Copy files into `/usr/local` directly ## Usage diff --git a/VERSION b/VERSION index cb0c939a9..be14282b7 100644 --- a/VERSION +++ b/VERSION @@ -1 +1 @@ -0.5.2 +0.5.3 diff --git a/basis/r4rs-essential.ss b/basis/r4rs-essential.ss deleted file mode 100644 index fe61bb6a8..000000000 --- a/basis/r4rs-essential.ss +++ /dev/null @@ -1,516 +0,0 @@ -(define-library (scheme r4rs essential) - (import (only (meevax boolean) boolean? not) - (meevax character) - (meevax core) - (only (meevax comparator) eq? eqv? equal?) - (meevax continuation) - (prefix (meevax environment) %) - (meevax function) - (meevax list) - (only (meevax macro-transformer) er-macro-transformer identifier?) - (meevax number) - (meevax pair) - (meevax port) - (prefix (meevax read) %) - (meevax string) - (meevax symbol) - (meevax vector) - (prefix (meevax write) %)) - - (export quote lambda if set! cond case and or let letrec begin quasiquote - define not boolean? eqv? eq? equal? pair? cons car cdr set-car! - set-cdr! caar cadr cdar cddr caaar caadr cadar caddr cdaar cdadr - cddar cdddr caaaar caaadr caadar caaddr cadaar cadadr caddar cadddr - cdaaar cdaadr cdadar cdaddr cddaar cddadr cdddar cddddr null? list? - list length append reverse list-ref memq memv member assq assv assoc - symbol? symbol->string string->symbol number? complex? real? - rational? integer? exact? inexact? = < > <= >= zero? positive? - negative? odd? even? max min + * - / abs quotient remainder modulo - gcd lcm floor ceiling truncate round number->string string->number - char? char=? char? char<=? char>=? char-ci=? char-ci? char-ci<=? char-ci>=? char-alphabetic? char-numeric? - char-whitespace? char-upper-case? char-lower-case? char->integer - integer->char char-upcase char-downcase string? make-string string - string-length string-ref string-set! string=? string? - string<=? string>=? string-ci=? string-ci? string-ci<=? - string-ci>=? substring string-append string->list list->string - vector? make-vector vector vector-length vector-ref vector-set! - vector->list list->vector procedure? apply map for-each - call-with-current-continuation call-with-input-file - call-with-output-file input-port? output-port? current-input-port - current-output-port open-input-file open-output-file close-input-port - close-output-port read read-char peek-char eof-object? write display - newline write-char load) - - #| - This library contains many procedure and syntax definitions copied from - Chibi-Scheme's script lib/init-7.scm. The definitions marked - "Chibi-Scheme" in this file are those. Such definitions are subject to the - following Chibi-Scheme license. - - --- - - Copyright (c) 2009-2021 Alex Shinn - All rights reserved. - - Redistribution and use in source and binary forms, with or without - modification, are permitted provided that the following conditions are - met: - 1. Redistributions of source code must retain the above copyright notice, - this list of conditions and the following disclaimer. - 2. Redistributions in binary form must reproduce the above copyright - notice, this list of conditions and the following disclaimer in the - documentation and/or other materials provided with the distribution. - 3. The name of the author may not be used to endorse or promote products - derived from this software without specific prior written permission. - - THIS SOFTWARE IS PROVIDED BY THE AUTHOR "AS IS" AND ANY EXPRESS OR IMPLIED - WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF - MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO - EVENT SHALL THE AUTHOR BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, - SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED - TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR - PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF - LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING - NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS - SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - |# - - (begin (define-syntax cond ; Chibi-Scheme - (er-macro-transformer - (lambda (form rename compare) - (if (null? (cdr form)) - (if #f #f) - ((lambda (clause) - (if (compare (rename 'else) (car clause)) - (cons (rename 'begin) (cdr clause)) - (if (if (null? (cdr clause)) #t - (compare (rename '=>) (cadr clause))) - (list (list (rename 'lambda) - (list (rename 'result)) - (list (rename 'if) - (rename 'result) - (if (null? (cdr clause)) - (rename 'result) - (list (caddr clause) - (rename 'result))) - (cons (rename 'cond) (cddr form)))) - (car clause)) - (list (rename 'if) - (car clause) - (cons (rename 'begin) (cdr clause)) - (cons (rename 'cond) (cddr form)))))) - (cadr form)))))) - - (define-syntax and ; Chibi-Scheme - (er-macro-transformer - (lambda (form rename compare) - (cond ((null? (cdr form))) - ((null? (cddr form)) - (cadr form)) - (else (list (rename 'if) - (cadr form) - (cons (rename 'and) - (cddr form)) - #f)))))) - - (define-syntax or ; Chibi-Scheme - (er-macro-transformer - (lambda (form rename compare) - (cond ((null? (cdr form)) #f) - ((null? (cddr form)) - (cadr form)) - (else (list (list (rename 'lambda) - (list (rename 'result)) - (list (rename 'if) - (rename 'result) - (rename 'result) - (cons (rename 'or) - (cddr form)))) - (cadr form))))))) - - (define-syntax quasiquote ; Chibi-Scheme - (er-macro-transformer - (lambda (form rename compare) - (define (expand x depth) - (cond ((pair? x) - (cond ((compare (rename 'unquote) (car x)) - (if (<= depth 0) - (cadr x) - (list (rename 'list) - (list (rename 'quote) 'unquote) - (expand (cadr x) (- depth 1))))) - ((compare (rename 'unquote-splicing) (car x)) - (if (<= depth 0) - (list (rename 'cons) - (expand (car x) depth) - (expand (cdr x) depth)) - (list (rename 'list) - (list (rename 'quote) 'unquote-splicing) - (expand (cadr x) (- depth 1))))) - ((compare (rename 'quasiquote) (car x)) - (list (rename 'list) - (list (rename 'quote) 'quasiquote) - (expand (cadr x) (+ depth 1)))) - ((and (<= depth 0) - (pair? (car x)) - (compare (rename 'unquote-splicing) (caar x))) - (if (null? (cdr x)) - (cadar x) - (list (rename 'append) - (cadar x) - (expand (cdr x) depth)))) - (else (list (rename 'cons) - (expand (car x) depth) - (expand (cdr x) depth))))) - ((vector? x) - (list (rename 'list->vector) - (expand (vector->list x) depth))) - ((or (identifier? x) - (null? x)) - (list (rename 'quote) x)) - (else x))) - (expand (cadr form) 0)))) - - (define (every f xs) - (if (pair? xs) - (and (f (car xs)) - (every f (cdr xs))) - #t)) - - (define (map f x . xs) ; Chibi-Scheme - (define (map f x a) - (if (pair? x) - (map f - (cdr x) - (cons (f (car x)) a)) - (reverse a))) - (define (map* f xs a) - (if (every pair? xs) - (map* f - (map cdr xs '()) - (cons (apply f (map car xs '())) a)) - (reverse a))) - (if (null? xs) - (map f x '()) - (map* f (cons x xs) '()))) - - (define (apply f x . xs) ; Chibi-Scheme - (letrec ((apply (lambda (f xs) - (f . xs)))) - (if (null? xs) - (apply f x) - ((lambda (xs) - (apply f (append (reverse (cdr xs)) - (car xs)))) - (reverse (cons x xs)))))) - - (define-syntax let ; Chibi-Scheme - (er-macro-transformer - (lambda (form rename compare) - (if (identifier? (cadr form)) - `(,(rename 'letrec) ((,(cadr form) - (,(rename 'lambda) ,(map car (caddr form)) ,@(cdddr form)))) - (,(cadr form) ,@(map cadr (caddr form)))) - `((,(rename 'lambda) ,(map car (cadr form)) ,@(cddr form)) - ,@(map cadr (cadr form))))))) - - (define (list? x) - (let list? ((x x) - (lag x)) - (if (pair? x) - (let ((x (cdr x))) - (if (pair? x) - (let ((x (cdr x)) - (lag (cdr lag))) - (and (not (eq? x lag)) - (list? x lag))) - (null? x))) - (null? x)))) - - (define-syntax case ; Chibi-Scheme - (er-macro-transformer - (lambda (form rename compare) - (define (body xs) - (cond ((null? xs) (rename 'result)) - ((compare (rename '=>) (car xs)) `(,(cadr xs) ,(rename 'result))) - (else `(,(rename 'begin) ,@xs)))) - (define (each-clause clauses) - (cond ((null? clauses) - (if #f #f)) - ((compare (rename 'else) (caar clauses)) - (body (cdar clauses))) - ((and (pair? (caar clauses)) - (null? (cdaar clauses))) - `(,(rename 'if) (,(rename 'eqv?) ,(rename 'result) - (,(rename 'quote) ,(caaar clauses))) - ,(body (cdar clauses)) - ,(each-clause (cdr clauses)))) - (else `(,(rename 'if) (,(rename 'memv) ,(rename 'result) - (,(rename 'quote) ,(caar clauses))) - ,(body (cdar clauses)) - ,(each-clause (cdr clauses)))))) - `(,(rename 'let) ((,(rename 'result) ,(cadr form))) - ,(each-clause (cddr form)))))) - - (define (member x xs . compare) ; Chibi-Scheme - (let ((compare (if (pair? compare) (car compare) equal?))) - (let member ((xs xs)) - (and (pair? xs) - (if (compare x (car xs)) xs - (member (cdr xs))))))) - - (define (assoc key alist . compare) ; Chibi-Scheme - (let ((compare (if (pair? compare) (car compare) equal?))) - (let assoc ((alist alist)) - (if (null? alist) #f - (if (compare key (caar alist)) - (car alist) - (assoc (cdr alist))))))) - - (define (exact? z) - (define (exact-complex? x) - (and (imaginary? x) - (exact? (real-part x)) - (exact? (imag-part x)))) - (or (exact-complex? z) - (ratio? z) - (exact-integer? z))) - - (define (inexact? z) - (define (inexact-complex? x) - (and (imaginary? x) - (or (inexact? (real-part x)) - (inexact? (imag-part x))))) - (define (floating-point? z) - (or (single-float? z) - (double-float? z))) - (or (inexact-complex? z) - (floating-point? z))) - - (define (zero? n) - (= n 0)) - - (define (positive? n) - (> n 0)) - - (define (negative? n) - (< n 0)) - - (define (odd? n) - (not (even? n))) - - (define (even? n) - (= (remainder n 2) 0)) - - (define (max x . xs) ; Chibi-Scheme - (define (max-aux x xs) - (if (null? xs) - (inexact x) - (max-aux (if (< x (car xs)) (car xs) x) - (cdr xs)))) - (if (inexact? x) - (max-aux x xs) - (let rec ((x x) (xs xs)) - (cond ((null? xs) x) - ((inexact? (car xs)) (max-aux x xs)) - (else (rec (if (< x (car xs)) (car xs) x) - (cdr xs))))))) - - (define (min x . xs) ; Chibi-Scheme - (define (min-aux x xs) - (if (null? xs) - (inexact x) - (min-aux (if (< (car xs) x) (car xs) x) - (cdr xs)))) - (if (inexact? x) - (min-aux x xs) - (let rec ((x x) (xs xs)) - (cond ((null? xs) x) - ((inexact? (car xs)) (min-aux x xs)) - (else (rec (if (< (car xs) x) (car xs) x) - (cdr xs))))))) - - (define (quotient x y) - (truncate (/ x y))) - - (define remainder %) - - (define (modulo x y) - (% (+ y (% x y)) y)) - - (define (gcd . xs) ; Chibi-Scheme - (define (gcd-2 a b) - (if (zero? b) - (abs a) - (gcd b (remainder a b)))) - (if (null? xs) 0 - (let rec ((n (car xs)) - (ns (cdr xs))) - (if (null? ns) n - (rec (gcd-2 n (car ns)) (cdr ns)))))) - - (define (lcm . xs) ; Chibi-Scheme - (define (lcm-2 a b) - (abs (quotient (* a b) (gcd a b)))) - (if (null? xs) 1 - (let rec ((n (car xs)) - (ns (cdr xs))) - (if (null? ns) n - (rec (lcm-2 n (car ns)) (cdr ns)))))) - - (define (char-compare x xs compare) ; Chibi-Scheme - (let rec ((compare compare) - (lhs (char->integer x)) - (xs xs)) - (if (null? xs) #t - (let ((rhs (char->integer (car xs)))) - (and (compare lhs rhs) - (rec compare rhs (cdr xs))))))) - - (define (char=? x . xs) ; Chibi-Scheme - (char-compare x xs =)) - - (define (char? x . xs) ; Chibi-Scheme - (char-compare x xs >)) - - (define (char<=? x . xs) ; Chibi-Scheme - (char-compare x xs <=)) - - (define (char>=? x . xs) ; Chibi-Scheme - (char-compare x xs >=)) - - (define (char-ci-compare x xs compare) ; Chibi-Scheme - (let rec ((compare compare) - (lhs (char->integer (char-downcase x))) - (xs xs)) - (if (null? xs) #t - (let ((rhs (char->integer (char-downcase (car xs))))) - (and (compare lhs rhs) - (rec compare rhs (cdr xs))))))) - - (define (char-ci=? x . xs) ; Chibi-Scheme - (char-ci-compare x xs =)) - - (define (char-ci? x . xs) ; Chibi-Scheme - (char-ci-compare x xs >)) - - (define (char-ci<=? x . xs) ; Chibi-Scheme - (char-ci-compare x xs <=)) - - (define (char-ci>=? x . xs) ; Chibi-Scheme - (char-ci-compare x xs >=)) - - (define (string . xs) ; Chibi-Scheme - (list->string xs)) - - (define (string-map f x . xs) ; R7RS - (if (null? xs) - (list->string (map f (string->list x))) - (list->string (apply map f (map string->list (cons x xs)))))) - - (define (string-foldcase s) ; R7RS - (string-map char-downcase s)) - - (define (string-ci=? . xs) - (apply string=? (map string-foldcase xs))) - - (define (string-ci? . xs) - (apply string>? (map string-foldcase xs))) - - (define (string-ci<=? . xs) - (apply string<=? (map string-foldcase xs))) - - (define (string-ci>=? . xs) - (apply string>=? (map string-foldcase xs))) - - (define substring string-copy) - - (define (procedure? x) - (or (closure? x) - (continuation? x) - (foreign-function? x))) - - (define (for-each f x . xs) ; Chibi-Scheme - (if (null? xs) - (letrec ((for-each (lambda (f x) - (if (pair? x) - (begin (f (car x)) - (for-each f (cdr x))))))) - (for-each f x)) - (begin (apply map f x xs) - (if #f #f)))) - - (define (call-with-input-file path f) ; R7RS incompatible (values unsupported) - (define (call-with-input-port port f) - (let ((result (f port))) - (close-input-port port) - result)) - (call-with-input-port (open-input-file path) f)) - - (define (call-with-output-file path f) ; R7RS incompatible (values unsupported) - (define (call-with-output-port port f) - (let ((result (f port))) - (close-output-port port) - result)) - (call-with-output-port (open-output-file path) f)) - - (define current-input-port standard-input-port) - - (define current-output-port standard-output-port) - - (define close-input-port close) - - (define close-output-port close) - - (define (read . xs) - (%read (if (pair? xs) - (car xs) - (current-input-port)))) - - (define (read-char . xs) - (%get-char (if (pair? xs) - (car xs) - (current-input-port)))) - - (define (peek-char . xs) - (%peek-char (if (pair? xs) - (car xs) - (current-input-port)))) - - (define (write x . port) - (%write x (if (pair? port) - (car port) - (current-output-port)))) - - (define (write-char x . port) - (%put-char x (if (pair? port) - (car port) - (current-output-port)))) - - (define (display x . xs) - (cond ((char? x) - (apply write-char x xs)) - ((string? x) - (%put-string x (if (pair? xs) ; NOTE: The procedure write-string is not defined in R4RS. - (car xs) - (current-output-port)))) - (else (apply write x xs)))) - - (define (newline . port) - (apply write-char #\newline port)) - - (define (load filename . xs) - (%load (if (pair? xs) - (car xs) - (%interaction-environment)) - filename)))) diff --git a/basis/r4rs.ss b/basis/r4rs.ss index f5bc2eb43..b1694b54f 100644 --- a/basis/r4rs.ss +++ b/basis/r4rs.ss @@ -1,15 +1,59 @@ +#| + This library contains many procedure and syntax definitions copied from + Chibi-Scheme's script lib/init-7.scm. The definitions marked "Chibi-Scheme" + in this file are those. Such definitions are subject to the following + Chibi-Scheme license. + + --- + + Copyright (c) 2009-2021 Alex Shinn + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions are met: + + 1. Redistributions of source code must retain the above copyright notice, + this list of conditions and the following disclaimer. + + 2. Redistributions in binary form must reproduce the above copyright notice, + this list of conditions and the following disclaimer in the documentation + and/or other materials provided with the distribution. + + 3. The name of the author may not be used to endorse or promote products + derived from this software without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE AUTHOR "AS IS" AND ANY EXPRESS OR IMPLIED + WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF + MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO + EVENT SHALL THE AUTHOR BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, + SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, + PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; + OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, + WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR + OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF + ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +|# + (define-library (scheme r4rs) - (import (meevax inexact) - (only (meevax core) define-syntax) - (only (meevax list) list-tail) - (only (meevax macro-transformer) er-macro-transformer) - (only (meevax number) exact-integer? expt exact inexact ratio? ratio-numerator ratio-denominator) - (prefix (meevax port) %) + (import (only (meevax boolean) boolean? not) + (meevax character) + (meevax core) + (only (meevax comparator) eq? eqv? equal?) + (meevax continuation) + (prefix (meevax environment) %) + (meevax function) + (meevax inexact) + (meevax list) + (only (meevax macro-transformer) er-macro-transformer identifier?) + (meevax number) + (meevax pair) + (meevax port) (prefix (meevax read) %) - (only (meevax string) string-copy) - (only (meevax vector) vector-fill!) - (scheme r4rs essential) - (srfi 45)) + (meevax string) + (meevax symbol) + (meevax vector) + (prefix (meevax write) %) + (only (srfi 45) delay force)) (export quote lambda if set! cond case and or let let* letrec begin do delay quasiquote define not boolean? eqv? eq? equal? pair? cons car cdr @@ -41,41 +85,146 @@ close-output-port read read-char peek-char eof-object? char-ready? write display newline write-char load) - #| - This library contains many procedure and syntax definitions copied from - Chibi-Scheme's script lib/init-7.scm. The definitions marked - "Chibi-Scheme" in this file are those. Such definitions are subject to the - following Chibi-Scheme license. - - --- - - Copyright (c) 2009-2021 Alex Shinn - All rights reserved. - - Redistribution and use in source and binary forms, with or without - modification, are permitted provided that the following conditions are - met: - 1. Redistributions of source code must retain the above copyright notice, - this list of conditions and the following disclaimer. - 2. Redistributions in binary form must reproduce the above copyright - notice, this list of conditions and the following disclaimer in the - documentation and/or other materials provided with the distribution. - 3. The name of the author may not be used to endorse or promote products - derived from this software without specific prior written permission. - - THIS SOFTWARE IS PROVIDED BY THE AUTHOR "AS IS" AND ANY EXPRESS OR IMPLIED - WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF - MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO - EVENT SHALL THE AUTHOR BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, - SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED - TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR - PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF - LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING - NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS - SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - |# - - (begin (define-syntax let* + (begin (define-syntax cond ; Chibi-Scheme + (er-macro-transformer + (lambda (form rename compare) + (if (null? (cdr form)) + (if #f #f) + ((lambda (clause) + (if (compare (rename 'else) (car clause)) + (cons (rename 'begin) (cdr clause)) + (if (if (null? (cdr clause)) #t + (compare (rename '=>) (cadr clause))) + (list (list (rename 'lambda) + (list (rename 'result)) + (list (rename 'if) + (rename 'result) + (if (null? (cdr clause)) + (rename 'result) + (list (caddr clause) + (rename 'result))) + (cons (rename 'cond) (cddr form)))) + (car clause)) + (list (rename 'if) + (car clause) + (cons (rename 'begin) (cdr clause)) + (cons (rename 'cond) (cddr form)))))) + (cadr form)))))) + + (define-syntax and ; Chibi-Scheme + (er-macro-transformer + (lambda (form rename compare) + (cond ((null? (cdr form))) + ((null? (cddr form)) + (cadr form)) + (else (list (rename 'if) + (cadr form) + (cons (rename 'and) + (cddr form)) + #f)))))) + + (define-syntax or ; Chibi-Scheme + (er-macro-transformer + (lambda (form rename compare) + (cond ((null? (cdr form)) #f) + ((null? (cddr form)) + (cadr form)) + (else (list (list (rename 'lambda) + (list (rename 'result)) + (list (rename 'if) + (rename 'result) + (rename 'result) + (cons (rename 'or) + (cddr form)))) + (cadr form))))))) + + (define-syntax quasiquote ; Chibi-Scheme + (er-macro-transformer + (lambda (form rename compare) + (define (expand x depth) + (cond ((pair? x) + (cond ((compare (rename 'unquote) (car x)) + (if (<= depth 0) + (cadr x) + (list (rename 'list) + (list (rename 'quote) 'unquote) + (expand (cadr x) (- depth 1))))) + ((compare (rename 'unquote-splicing) (car x)) + (if (<= depth 0) + (list (rename 'cons) + (expand (car x) depth) + (expand (cdr x) depth)) + (list (rename 'list) + (list (rename 'quote) 'unquote-splicing) + (expand (cadr x) (- depth 1))))) + ((compare (rename 'quasiquote) (car x)) + (list (rename 'list) + (list (rename 'quote) 'quasiquote) + (expand (cadr x) (+ depth 1)))) + ((and (<= depth 0) + (pair? (car x)) + (compare (rename 'unquote-splicing) (caar x))) + (if (null? (cdr x)) + (cadar x) + (list (rename 'append) + (cadar x) + (expand (cdr x) depth)))) + (else (list (rename 'cons) + (expand (car x) depth) + (expand (cdr x) depth))))) + ((vector? x) + (list (rename 'list->vector) + (expand (vector->list x) depth))) + ((or (identifier? x) + (null? x)) + (list (rename 'quote) x)) + (else x))) + (expand (cadr form) 0)))) + + (define (every f xs) + (if (pair? xs) + (and (f (car xs)) + (every f (cdr xs))) + #t)) + + (define (map f x . xs) ; Chibi-Scheme + (define (map f x a) + (if (pair? x) + (map f + (cdr x) + (cons (f (car x)) a)) + (reverse a))) + (define (map* f xs a) + (if (every pair? xs) + (map* f + (map cdr xs '()) + (cons (apply f (map car xs '())) a)) + (reverse a))) + (if (null? xs) + (map f x '()) + (map* f (cons x xs) '()))) + + (define (apply f x . xs) ; Chibi-Scheme + (letrec ((apply (lambda (f xs) + (f . xs)))) + (if (null? xs) + (apply f x) + ((lambda (xs) + (apply f (append (reverse (cdr xs)) + (car xs)))) + (reverse (cons x xs)))))) + + (define-syntax let ; Chibi-Scheme + (er-macro-transformer + (lambda (form rename compare) + (if (identifier? (cadr form)) + `(,(rename 'letrec) ((,(cadr form) + (,(rename 'lambda) ,(map car (caddr form)) ,@(cdddr form)))) + (,(cadr form) ,@(map cadr (caddr form)))) + `((,(rename 'lambda) ,(map car (cadr form)) ,@(cddr form)) + ,@(map cadr (cadr form))))))) + + (define-syntax let* (er-macro-transformer (lambda (form rename compare) (if (null? (cadr form)) @@ -106,6 +255,150 @@ (,(rename 'begin) ,@(cdaddr form)) ,body))))))) + (define-syntax case ; Chibi-Scheme + (er-macro-transformer + (lambda (form rename compare) + (define (body xs) + (cond ((null? xs) (rename 'result)) + ((compare (rename '=>) (car xs)) `(,(cadr xs) ,(rename 'result))) + (else `(,(rename 'begin) ,@xs)))) + (define (each-clause clauses) + (cond ((null? clauses) + (if #f #f)) + ((compare (rename 'else) (caar clauses)) + (body (cdar clauses))) + ((and (pair? (caar clauses)) + (null? (cdaar clauses))) + `(,(rename 'if) (,(rename 'eqv?) ,(rename 'result) + (,(rename 'quote) ,(caaar clauses))) + ,(body (cdar clauses)) + ,(each-clause (cdr clauses)))) + (else `(,(rename 'if) (,(rename 'memv) ,(rename 'result) + (,(rename 'quote) ,(caar clauses))) + ,(body (cdar clauses)) + ,(each-clause (cdr clauses)))))) + `(,(rename 'let) ((,(rename 'result) ,(cadr form))) + ,(each-clause (cddr form)))))) + + (define (list? x) + (let list? ((x x) + (lag x)) + (if (pair? x) + (let ((x (cdr x))) + (if (pair? x) + (let ((x (cdr x)) + (lag (cdr lag))) + (and (not (eq? x lag)) + (list? x lag))) + (null? x))) + (null? x)))) + + (define (member x xs . compare) ; Chibi-Scheme + (let ((compare (if (pair? compare) (car compare) equal?))) + (let member ((xs xs)) + (and (pair? xs) + (if (compare x (car xs)) xs + (member (cdr xs))))))) + + (define (assoc key alist . compare) ; Chibi-Scheme + (let ((compare (if (pair? compare) (car compare) equal?))) + (let assoc ((alist alist)) + (if (null? alist) #f + (if (compare key (caar alist)) + (car alist) + (assoc (cdr alist))))))) + + (define (exact? z) + (define (exact-complex? x) + (and (imaginary? x) + (exact? (real-part x)) + (exact? (imag-part x)))) + (or (exact-complex? z) + (ratio? z) + (exact-integer? z))) + + (define (inexact? z) + (define (inexact-complex? x) + (and (imaginary? x) + (or (inexact? (real-part x)) + (inexact? (imag-part x))))) + (define (floating-point? z) + (or (single-float? z) + (double-float? z))) + (or (inexact-complex? z) + (floating-point? z))) + + (define (zero? n) + (= n 0)) + + (define (positive? n) + (> n 0)) + + (define (negative? n) + (< n 0)) + + (define (odd? n) + (not (even? n))) + + (define (even? n) + (= (remainder n 2) 0)) + + (define (max x . xs) ; Chibi-Scheme + (define (max-aux x xs) + (if (null? xs) + (inexact x) + (max-aux (if (< x (car xs)) (car xs) x) + (cdr xs)))) + (if (inexact? x) + (max-aux x xs) + (let rec ((x x) (xs xs)) + (cond ((null? xs) x) + ((inexact? (car xs)) (max-aux x xs)) + (else (rec (if (< x (car xs)) (car xs) x) + (cdr xs))))))) + + (define (min x . xs) ; Chibi-Scheme + (define (min-aux x xs) + (if (null? xs) + (inexact x) + (min-aux (if (< (car xs) x) (car xs) x) + (cdr xs)))) + (if (inexact? x) + (min-aux x xs) + (let rec ((x x) (xs xs)) + (cond ((null? xs) x) + ((inexact? (car xs)) (min-aux x xs)) + (else (rec (if (< (car xs) x) (car xs) x) + (cdr xs))))))) + + (define (quotient x y) + (truncate (/ x y))) + + (define remainder %) + + (define (modulo x y) + (% (+ y (% x y)) y)) + + (define (gcd . xs) ; Chibi-Scheme + (define (gcd-2 a b) + (if (zero? b) + (abs a) + (gcd b (remainder a b)))) + (if (null? xs) 0 + (let rec ((n (car xs)) + (ns (cdr xs))) + (if (null? ns) n + (rec (gcd-2 n (car ns)) (cdr ns)))))) + + (define (lcm . xs) ; Chibi-Scheme + (define (lcm-2 a b) + (abs (quotient (* a b) (gcd a b)))) + (if (null? xs) 1 + (let rec ((n (car xs)) + (ns (cdr xs))) + (if (null? ns) n + (rec (lcm-2 n (car ns)) (cdr ns)))))) + (define (numerator x) ; Chibi-Scheme (cond ((ratio? x) (ratio-numerator x)) ((exact? x) x) @@ -165,6 +458,82 @@ (atan (imag-part z) (real-part z))) + (define (char-compare x xs compare) ; Chibi-Scheme + (let rec ((compare compare) + (lhs (char->integer x)) + (xs xs)) + (if (null? xs) #t + (let ((rhs (char->integer (car xs)))) + (and (compare lhs rhs) + (rec compare rhs (cdr xs))))))) + + (define (char=? x . xs) ; Chibi-Scheme + (char-compare x xs =)) + + (define (char? x . xs) ; Chibi-Scheme + (char-compare x xs >)) + + (define (char<=? x . xs) ; Chibi-Scheme + (char-compare x xs <=)) + + (define (char>=? x . xs) ; Chibi-Scheme + (char-compare x xs >=)) + + (define (char-ci-compare x xs compare) ; Chibi-Scheme + (let rec ((compare compare) + (lhs (char->integer (char-downcase x))) + (xs xs)) + (if (null? xs) #t + (let ((rhs (char->integer (char-downcase (car xs))))) + (and (compare lhs rhs) + (rec compare rhs (cdr xs))))))) + + (define (char-ci=? x . xs) ; Chibi-Scheme + (char-ci-compare x xs =)) + + (define (char-ci? x . xs) ; Chibi-Scheme + (char-ci-compare x xs >)) + + (define (char-ci<=? x . xs) ; Chibi-Scheme + (char-ci-compare x xs <=)) + + (define (char-ci>=? x . xs) ; Chibi-Scheme + (char-ci-compare x xs >=)) + + (define (string . xs) ; Chibi-Scheme + (list->string xs)) + + (define (string-map f x . xs) ; R7RS + (if (null? xs) + (list->string (map f (string->list x))) + (list->string (apply map f (map string->list (cons x xs)))))) + + (define (string-foldcase s) ; R7RS + (string-map char-downcase s)) + + (define (string-ci=? . xs) + (apply string=? (map string-foldcase xs))) + + (define (string-ci? . xs) + (apply string>? (map string-foldcase xs))) + + (define (string-ci<=? . xs) + (apply string<=? (map string-foldcase xs))) + + (define (string-ci>=? . xs) + (apply string>=? (map string-foldcase xs))) + + (define substring string-copy) + (define (string-fill! s c . o) ; Chibi-Scheme (let ((start (if (and (pair? o) (exact-integer? (car o))) @@ -180,15 +549,42 @@ (begin (string-set! s k c) (rec (- k 1))))))) - (define %current-input-port (%standard-input-port)) + (define (procedure? x) + (or (closure? x) + (continuation? x) + (foreign-function? x))) + + (define (for-each f x . xs) ; Chibi-Scheme + (if (null? xs) + (letrec ((for-each (lambda (f x) + (if (pair? x) + (begin (f (car x)) + (for-each f (cdr x))))))) + (for-each f x)) + (begin (apply map f x xs) + (if #f #f)))) + + (define (call-with-input-file path f) ; R7RS incompatible (values unsupported) + (define (call-with-input-port port f) + (let ((result (f port))) + (close-input-port port) + result)) + (call-with-input-port (open-input-file path) f)) + + (define (call-with-output-file path f) ; R7RS incompatible (values unsupported) + (define (call-with-output-port port f) + (let ((result (f port))) + (close-output-port port) + result)) + (call-with-output-port (open-output-file path) f)) + + (define %current-input-port (standard-input-port)) - (define (current-input-port) - %current-input-port) + (define (current-input-port) %current-input-port) - (define %current-output-port (%standard-output-port)) + (define %current-output-port (standard-output-port)) - (define (current-output-port) - %current-output-port) + (define (current-output-port) %current-output-port) (define (with-input-from-file path thunk) (let ((previous-input-port (current-input-port))) @@ -202,7 +598,54 @@ (thunk) (set! %current-output-port previous-output-port))) + (define close-input-port close) + + (define close-output-port close) + + (define (read . xs) + (%read (if (pair? xs) + (car xs) + (current-input-port)))) + + (define (read-char . xs) + (%get-char (if (pair? xs) + (car xs) + (current-input-port)))) + + (define (peek-char . xs) + (%peek-char (if (pair? xs) + (car xs) + (current-input-port)))) + (define (char-ready? . xs) (%get-char-ready? (if (pair? xs) (car xs) - (current-input-port)))))) + (current-input-port)))) + + (define (write x . port) + (%write x (if (pair? port) + (car port) + (current-output-port)))) + + (define (write-char x . port) + (%put-char x (if (pair? port) + (car port) + (current-output-port)))) + + (define (display x . xs) + (cond ((char? x) + (apply write-char x xs)) + ((string? x) + (%put-string x (if (pair? xs) ; NOTE: The procedure write-string is not defined in R4RS. + (car xs) + (current-output-port)))) + (else (apply write x xs)))) + + (define (newline . port) + (apply write-char #\newline port)) + + (define (load filename . xs) + (%load (if (pair? xs) + (car xs) + (%interaction-environment)) + filename)))) diff --git a/configure/basis.hpp b/configure/basis.hpp index 45f978ffe..423db2e71 100644 --- a/configure/basis.hpp +++ b/configure/basis.hpp @@ -33,7 +33,6 @@ inline namespace kernel { return make_array( R"##(${CONFIGURED_meevax.ss})##", - R"##(${CONFIGURED_r4rs-essential.ss})##", R"##(${CONFIGURED_r4rs.ss})##", R"##(${CONFIGURED_r5rs.ss})##", R"##(${CONFIGURED_r7rs.ss})##", From c9943f3f8753124605d0049b43b09ef476eb6bba Mon Sep 17 00:00:00 2001 From: yamacir-kit Date: Mon, 2 Oct 2023 23:47:05 +0900 Subject: [PATCH 04/32] Rename `basis/configure.cmake` to `configure/basis.cmake` Signed-off-by: yamacir-kit --- CMakeLists.txt | 2 +- README.md | 6 +++--- VERSION | 2 +- basis/configure.cmake => configure/basis.cmake | 0 4 files changed, 5 insertions(+), 5 deletions(-) rename basis/configure.cmake => configure/basis.cmake (100%) diff --git a/CMakeLists.txt b/CMakeLists.txt index fcebcdac9..f59e8223f 100644 --- a/CMakeLists.txt +++ b/CMakeLists.txt @@ -97,7 +97,7 @@ target_link_libraries(format PRIVATE kernel) add_custom_target(basis DEPENDS format - COMMAND ${CMAKE_COMMAND} -P ${CMAKE_CURRENT_SOURCE_DIR}/basis/configure.cmake) + COMMAND ${CMAKE_COMMAND} -P ${CMAKE_CURRENT_SOURCE_DIR}/configure/basis.cmake) # ---- Target shell ------------------------------------------------------------ diff --git a/README.md b/README.md index d263145e1..7ab23a9e6 100644 --- a/README.md +++ b/README.md @@ -99,7 +99,7 @@ Procedures for each standard are provided by the following R7RS-style libraries: cmake -B build -DCMAKE_BUILD_TYPE=Release cd build make package -sudo apt install build/meevax_0.5.3_amd64.deb +sudo apt install build/meevax_0.5.4_amd64.deb ``` or @@ -131,9 +131,9 @@ sudo rm -rf /usr/local/share/meevax | Target Name | Description |-------------|------------- -| `all` | Build shared-library `libmeevax.0.5.3.so` and executable `meevax` +| `all` | Build shared-library `libmeevax.0.5.4.so` and executable `meevax` | `test` | Test executable `meevax` -| `package` | Generate debian package `meevax_0.5.3_amd64.deb` +| `package` | Generate debian package `meevax_0.5.4_amd64.deb` | `install` | Copy files into `/usr/local` directly ## Usage diff --git a/VERSION b/VERSION index be14282b7..7d8568351 100644 --- a/VERSION +++ b/VERSION @@ -1 +1 @@ -0.5.3 +0.5.4 diff --git a/basis/configure.cmake b/configure/basis.cmake similarity index 100% rename from basis/configure.cmake rename to configure/basis.cmake From 87f22186770d2ce26f7aa0d990154ebc7dbda23c Mon Sep 17 00:00:00 2001 From: yamacir-kit Date: Tue, 3 Oct 2023 00:09:10 +0900 Subject: [PATCH 05/32] Update procedure `procedure?` to built-in Signed-off-by: yamacir-kit --- README.md | 6 +++--- VERSION | 2 +- basis/r4rs.ss | 13 ++++--------- example/example.ss | 2 +- src/kernel/boot.cpp | 14 ++++++++++---- 5 files changed, 19 insertions(+), 18 deletions(-) diff --git a/README.md b/README.md index 7ab23a9e6..2deadfa01 100644 --- a/README.md +++ b/README.md @@ -99,7 +99,7 @@ Procedures for each standard are provided by the following R7RS-style libraries: cmake -B build -DCMAKE_BUILD_TYPE=Release cd build make package -sudo apt install build/meevax_0.5.4_amd64.deb +sudo apt install build/meevax_0.5.5_amd64.deb ``` or @@ -131,9 +131,9 @@ sudo rm -rf /usr/local/share/meevax | Target Name | Description |-------------|------------- -| `all` | Build shared-library `libmeevax.0.5.4.so` and executable `meevax` +| `all` | Build shared-library `libmeevax.0.5.5.so` and executable `meevax` | `test` | Test executable `meevax` -| `package` | Generate debian package `meevax_0.5.4_amd64.deb` +| `package` | Generate debian package `meevax_0.5.5_amd64.deb` | `install` | Copy files into `/usr/local` directly ## Usage diff --git a/VERSION b/VERSION index 7d8568351..d1d899fa3 100644 --- a/VERSION +++ b/VERSION @@ -1 +1 @@ -0.5.4 +0.5.5 diff --git a/basis/r4rs.ss b/basis/r4rs.ss index b1694b54f..0d155260e 100644 --- a/basis/r4rs.ss +++ b/basis/r4rs.ss @@ -37,11 +37,11 @@ (define-library (scheme r4rs) (import (only (meevax boolean) boolean? not) (meevax character) - (meevax core) + (only (meevax core) begin define define-syntax if lambda letrec quote set!) (only (meevax comparator) eq? eqv? equal?) - (meevax continuation) - (prefix (meevax environment) %) - (meevax function) + (only (meevax continuation) call-with-current-continuation) + (prefix (only (meevax environment) load) %) + (only (meevax function) procedure?) (meevax inexact) (meevax list) (only (meevax macro-transformer) er-macro-transformer identifier?) @@ -549,11 +549,6 @@ (begin (string-set! s k c) (rec (- k 1))))))) - (define (procedure? x) - (or (closure? x) - (continuation? x) - (foreign-function? x))) - (define (for-each f x . xs) ; Chibi-Scheme (if (null? xs) (letrec ((for-each (lambda (f x) diff --git a/example/example.ss b/example/example.ss index 6216a1f3e..fc4d9bb74 100644 --- a/example/example.ss +++ b/example/example.ss @@ -1,4 +1,4 @@ -(import (meevax function) +(import (only (meevax function) foreign-function? foreign-function) (scheme base) (scheme process-context) (scheme write) diff --git a/src/kernel/boot.cpp b/src/kernel/boot.cpp index b096d16fe..40df6f89f 100644 --- a/src/kernel/boot.cpp +++ b/src/kernel/boot.cpp @@ -315,6 +315,12 @@ inline namespace kernel define("(meevax function)", [](library & library) { + library.define("procedure?", [](let const& xs) + { + let const& x = xs[0]; + return x.is() or x.is() or x.is_also(); + }); + library.define("closure?", [](let const& xs) { return xs[0].is(); @@ -325,14 +331,14 @@ inline namespace kernel return xs[0].is(); }); - library.define("foreign-function", [](let const& xs) + library.define("foreign-function?", [](let const& xs) { - return make(xs[1].as(), xs[0].as()); + return xs[0].is_also(); }); - library.define("foreign-function?", [](let const& xs) + library.define("foreign-function", [](let const& xs) { - return xs[0].is_also(); + return make(xs[1].as(), xs[0].as()); }); }); From fec893537f61000efa707b50f631bd0c119872b2 Mon Sep 17 00:00:00 2001 From: yamacir-kit Date: Tue, 3 Oct 2023 00:45:16 +0900 Subject: [PATCH 06/32] Add new free function `is_exact` Signed-off-by: yamacir-kit --- README.md | 6 +++--- VERSION | 2 +- basis/r4rs.ss | 27 +++++++++++++++++++++++++-- include/meevax/kernel/number.hpp | 2 ++ src/kernel/boot.cpp | 14 ++++++++++++++ src/kernel/number.cpp | 19 +++++++++++++++++++ 6 files changed, 64 insertions(+), 6 deletions(-) diff --git a/README.md b/README.md index 2deadfa01..f1c405c0e 100644 --- a/README.md +++ b/README.md @@ -99,7 +99,7 @@ Procedures for each standard are provided by the following R7RS-style libraries: cmake -B build -DCMAKE_BUILD_TYPE=Release cd build make package -sudo apt install build/meevax_0.5.5_amd64.deb +sudo apt install build/meevax_0.5.6_amd64.deb ``` or @@ -131,9 +131,9 @@ sudo rm -rf /usr/local/share/meevax | Target Name | Description |-------------|------------- -| `all` | Build shared-library `libmeevax.0.5.5.so` and executable `meevax` +| `all` | Build shared-library `libmeevax.0.5.6.so` and executable `meevax` | `test` | Test executable `meevax` -| `package` | Generate debian package `meevax_0.5.5_amd64.deb` +| `package` | Generate debian package `meevax_0.5.6_amd64.deb` | `install` | Copy files into `/usr/local` directly ## Usage diff --git a/VERSION b/VERSION index d1d899fa3..b49b25336 100644 --- a/VERSION +++ b/VERSION @@ -1 +1 @@ -0.5.5 +0.5.6 diff --git a/basis/r4rs.ss b/basis/r4rs.ss index 0d155260e..e0d601a0b 100644 --- a/basis/r4rs.ss +++ b/basis/r4rs.ss @@ -42,10 +42,33 @@ (only (meevax continuation) call-with-current-continuation) (prefix (only (meevax environment) load) %) (only (meevax function) procedure?) - (meevax inexact) + (only (meevax inexact) exp log sqrt sin cos tan asin acos atan) (meevax list) (only (meevax macro-transformer) er-macro-transformer identifier?) - (meevax number) + (only (meevax number) + number? + complex? + real? + rational? + integer? + = < > <= >= + + * - / + abs + % ; deprecated + ratio-numerator ; deprecated + ratio-denominator ; deprecated + floor ceiling truncate round + expt + exact inexact + string->number + + ; to be removed + exact-integer? ; r7rs + imaginary? + ratio? + single-float? + double-float? + ) (meevax pair) (meevax port) (prefix (meevax read) %) diff --git a/include/meevax/kernel/number.hpp b/include/meevax/kernel/number.hpp index 6e69f4a29..ed02016c8 100644 --- a/include/meevax/kernel/number.hpp +++ b/include/meevax/kernel/number.hpp @@ -363,6 +363,8 @@ inline namespace number auto is_integer(object const&) -> bool; + auto is_exact(object const&) -> bool; + auto is_finite(object const&) -> bool; auto is_infinite(object const&) -> bool; diff --git a/src/kernel/boot.cpp b/src/kernel/boot.cpp index 40df6f89f..5cc111d01 100644 --- a/src/kernel/boot.cpp +++ b/src/kernel/boot.cpp @@ -540,26 +540,35 @@ inline namespace kernel return is_integer(xs[0]); }); + library.define("exact?", [](let const& xs) + { + return is_exact(xs[0]); + }); + library.define("exact-integer?", [](let const& xs) { return xs[0].is(); }); + // TODO REMOVE library.define("imaginary?", [](let const& xs) { return xs[0].is(); }); + // TODO REMOVE library.define("ratio?", [](let const& xs) { return xs[0].is(); }); + // TODO REMOVE library.define("single-float?", [](let const& xs) { return xs[0].is(); }); + // TODO REMOVE library.define("double-float?", [](let const& xs) { return xs[0].is(); @@ -624,6 +633,7 @@ inline namespace kernel } }); + // TODO RENAME library.define("%", [](let const& xs) { return xs[0] % xs[1]; @@ -634,6 +644,10 @@ inline namespace kernel return abs(xs[0]); }); + // TODO QUOTIENT + // TODO REMAINDER + // TODO MODULO + library.define("ratio-numerator", [](let const& xs) { return make(xs[0].as().numerator()); diff --git a/src/kernel/number.cpp b/src/kernel/number.cpp index a7930373c..4f24a7d8f 100644 --- a/src/kernel/number.cpp +++ b/src/kernel/number.cpp @@ -659,6 +659,25 @@ inline namespace number return test(f, x); } + auto is_exact(object const& x) -> bool + { + auto f = [](auto const& x) + { + using T = std::decay_t; + + if constexpr (std::is_same_v) + { + return is_exact(x.real()) and is_exact(x.imag()); + } + else + { + return std::is_same_v or std::is_same_v; + } + }; + + return test(f, x); + } + auto is_finite(object const& x) -> bool { return not is_infinite(x); From d4508939c88c5a896fb6b73358c0e89913af0b70 Mon Sep 17 00:00:00 2001 From: yamacir-kit Date: Tue, 3 Oct 2023 00:47:49 +0900 Subject: [PATCH 07/32] Update procedure `exact?` to built-in Signed-off-by: yamacir-kit --- README.md | 6 +++--- VERSION | 2 +- basis/r4rs.ss | 10 +--------- 3 files changed, 5 insertions(+), 13 deletions(-) diff --git a/README.md b/README.md index f1c405c0e..d2c054188 100644 --- a/README.md +++ b/README.md @@ -99,7 +99,7 @@ Procedures for each standard are provided by the following R7RS-style libraries: cmake -B build -DCMAKE_BUILD_TYPE=Release cd build make package -sudo apt install build/meevax_0.5.6_amd64.deb +sudo apt install build/meevax_0.5.7_amd64.deb ``` or @@ -131,9 +131,9 @@ sudo rm -rf /usr/local/share/meevax | Target Name | Description |-------------|------------- -| `all` | Build shared-library `libmeevax.0.5.6.so` and executable `meevax` +| `all` | Build shared-library `libmeevax.0.5.7.so` and executable `meevax` | `test` | Test executable `meevax` -| `package` | Generate debian package `meevax_0.5.6_amd64.deb` +| `package` | Generate debian package `meevax_0.5.7_amd64.deb` | `install` | Copy files into `/usr/local` directly ## Usage diff --git a/VERSION b/VERSION index b49b25336..d3532a107 100644 --- a/VERSION +++ b/VERSION @@ -1 +1 @@ -0.5.6 +0.5.7 diff --git a/basis/r4rs.ss b/basis/r4rs.ss index e0d601a0b..550cb0aa3 100644 --- a/basis/r4rs.ss +++ b/basis/r4rs.ss @@ -51,6 +51,7 @@ real? rational? integer? + exact? = < > <= >= + * - / abs @@ -331,15 +332,6 @@ (car alist) (assoc (cdr alist))))))) - (define (exact? z) - (define (exact-complex? x) - (and (imaginary? x) - (exact? (real-part x)) - (exact? (imag-part x)))) - (or (exact-complex? z) - (ratio? z) - (exact-integer? z))) - (define (inexact? z) (define (inexact-complex? x) (and (imaginary? x) From a49c8ece3439b01cabb51717452bdffa3861a258 Mon Sep 17 00:00:00 2001 From: yamacir-kit Date: Tue, 3 Oct 2023 00:52:08 +0900 Subject: [PATCH 08/32] Add new free function `is_inexact` Signed-off-by: yamacir-kit --- README.md | 6 +++--- VERSION | 2 +- include/meevax/kernel/number.hpp | 2 ++ src/kernel/boot.cpp | 5 +++++ src/kernel/number.cpp | 5 +++++ 5 files changed, 16 insertions(+), 4 deletions(-) diff --git a/README.md b/README.md index d2c054188..89291386f 100644 --- a/README.md +++ b/README.md @@ -99,7 +99,7 @@ Procedures for each standard are provided by the following R7RS-style libraries: cmake -B build -DCMAKE_BUILD_TYPE=Release cd build make package -sudo apt install build/meevax_0.5.7_amd64.deb +sudo apt install build/meevax_0.5.8_amd64.deb ``` or @@ -131,9 +131,9 @@ sudo rm -rf /usr/local/share/meevax | Target Name | Description |-------------|------------- -| `all` | Build shared-library `libmeevax.0.5.7.so` and executable `meevax` +| `all` | Build shared-library `libmeevax.0.5.8.so` and executable `meevax` | `test` | Test executable `meevax` -| `package` | Generate debian package `meevax_0.5.7_amd64.deb` +| `package` | Generate debian package `meevax_0.5.8_amd64.deb` | `install` | Copy files into `/usr/local` directly ## Usage diff --git a/VERSION b/VERSION index d3532a107..659914ae9 100644 --- a/VERSION +++ b/VERSION @@ -1 +1 @@ -0.5.7 +0.5.8 diff --git a/include/meevax/kernel/number.hpp b/include/meevax/kernel/number.hpp index ed02016c8..cf416a453 100644 --- a/include/meevax/kernel/number.hpp +++ b/include/meevax/kernel/number.hpp @@ -365,6 +365,8 @@ inline namespace number auto is_exact(object const&) -> bool; + auto is_inexact(object const&) -> bool; + auto is_finite(object const&) -> bool; auto is_infinite(object const&) -> bool; diff --git a/src/kernel/boot.cpp b/src/kernel/boot.cpp index 5cc111d01..970a909d4 100644 --- a/src/kernel/boot.cpp +++ b/src/kernel/boot.cpp @@ -545,6 +545,11 @@ inline namespace kernel return is_exact(xs[0]); }); + library.define("inexact?", [](let const& xs) + { + return is_inexact(xs[0]); + }); + library.define("exact-integer?", [](let const& xs) { return xs[0].is(); diff --git a/src/kernel/number.cpp b/src/kernel/number.cpp index 4f24a7d8f..bd4c91cac 100644 --- a/src/kernel/number.cpp +++ b/src/kernel/number.cpp @@ -678,6 +678,11 @@ inline namespace number return test(f, x); } + auto is_inexact(object const& x) -> bool + { + return not is_exact(x); + } + auto is_finite(object const& x) -> bool { return not is_infinite(x); From 25d48e8ac5af561b6eba0599706426ebbaaac4d9 Mon Sep 17 00:00:00 2001 From: yamacir-kit Date: Tue, 3 Oct 2023 00:55:15 +0900 Subject: [PATCH 09/32] Update procedure `inexact?` to built-in Signed-off-by: yamacir-kit --- README.md | 6 +++--- VERSION | 2 +- basis/r4rs.ss | 12 +----------- 3 files changed, 5 insertions(+), 15 deletions(-) diff --git a/README.md b/README.md index 89291386f..4b289dc3b 100644 --- a/README.md +++ b/README.md @@ -99,7 +99,7 @@ Procedures for each standard are provided by the following R7RS-style libraries: cmake -B build -DCMAKE_BUILD_TYPE=Release cd build make package -sudo apt install build/meevax_0.5.8_amd64.deb +sudo apt install build/meevax_0.5.9_amd64.deb ``` or @@ -131,9 +131,9 @@ sudo rm -rf /usr/local/share/meevax | Target Name | Description |-------------|------------- -| `all` | Build shared-library `libmeevax.0.5.8.so` and executable `meevax` +| `all` | Build shared-library `libmeevax.0.5.9.so` and executable `meevax` | `test` | Test executable `meevax` -| `package` | Generate debian package `meevax_0.5.8_amd64.deb` +| `package` | Generate debian package `meevax_0.5.9_amd64.deb` | `install` | Copy files into `/usr/local` directly ## Usage diff --git a/VERSION b/VERSION index 659914ae9..416bfb0a2 100644 --- a/VERSION +++ b/VERSION @@ -1 +1 @@ -0.5.8 +0.5.9 diff --git a/basis/r4rs.ss b/basis/r4rs.ss index 550cb0aa3..61ee03d79 100644 --- a/basis/r4rs.ss +++ b/basis/r4rs.ss @@ -52,6 +52,7 @@ rational? integer? exact? + inexact? = < > <= >= + * - / abs @@ -332,17 +333,6 @@ (car alist) (assoc (cdr alist))))))) - (define (inexact? z) - (define (inexact-complex? x) - (and (imaginary? x) - (or (inexact? (real-part x)) - (inexact? (imag-part x))))) - (define (floating-point? z) - (or (single-float? z) - (double-float? z))) - (or (inexact-complex? z) - (floating-point? z))) - (define (zero? n) (= n 0)) From 4c0df3a2c5ab91dc0e92ba016dfeabb29165ec84 Mon Sep 17 00:00:00 2001 From: yamacir-kit Date: Tue, 3 Oct 2023 01:48:39 +0900 Subject: [PATCH 10/32] Update complex number related procedures to built-in Signed-off-by: yamacir-kit --- README.md | 6 +++--- VERSION | 2 +- basis/r4rs.ss | 25 +---------------------- basis/r7rs.ss | 3 +-- include/meevax/kernel/complex.hpp | 8 ++++++++ src/kernel/boot.cpp | 34 ++++++++++++++++++------------- src/kernel/complex.cpp | 28 +++++++++++++++++++++++++ 7 files changed, 62 insertions(+), 44 deletions(-) diff --git a/README.md b/README.md index 4b289dc3b..844b2f6db 100644 --- a/README.md +++ b/README.md @@ -99,7 +99,7 @@ Procedures for each standard are provided by the following R7RS-style libraries: cmake -B build -DCMAKE_BUILD_TYPE=Release cd build make package -sudo apt install build/meevax_0.5.9_amd64.deb +sudo apt install build/meevax_0.5.10_amd64.deb ``` or @@ -131,9 +131,9 @@ sudo rm -rf /usr/local/share/meevax | Target Name | Description |-------------|------------- -| `all` | Build shared-library `libmeevax.0.5.9.so` and executable `meevax` +| `all` | Build shared-library `libmeevax.0.5.10.so` and executable `meevax` | `test` | Test executable `meevax` -| `package` | Generate debian package `meevax_0.5.9_amd64.deb` +| `package` | Generate debian package `meevax_0.5.10_amd64.deb` | `install` | Copy files into `/usr/local` directly ## Usage diff --git a/VERSION b/VERSION index 416bfb0a2..50c76ef87 100644 --- a/VERSION +++ b/VERSION @@ -1 +1 @@ -0.5.9 +0.5.10 diff --git a/basis/r4rs.ss b/basis/r4rs.ss index 61ee03d79..7ee62099d 100644 --- a/basis/r4rs.ss +++ b/basis/r4rs.ss @@ -39,6 +39,7 @@ (meevax character) (only (meevax core) begin define define-syntax if lambda letrec quote set!) (only (meevax comparator) eq? eqv? equal?) + (only (meevax complex) make-rectangular make-polar real-part imag-part magnitude angle) (only (meevax continuation) call-with-current-continuation) (prefix (only (meevax environment) load) %) (only (meevax function) procedure?) @@ -66,10 +67,7 @@ ; to be removed exact-integer? ; r7rs - imaginary? ratio? - single-float? - double-float? ) (meevax pair) (meevax port) @@ -442,27 +440,6 @@ (simplest-rational (- x e) (+ x e))) - (define (make-rectangular x y) ; Chibi-Scheme - (+ x (* y (sqrt -1)))) - - (define (make-polar radius phi) ; Chibi-Scheme - (make-rectangular (* radius (cos phi)) - (* radius (sin phi)))) - - (define (real-part z) - (if (imaginary? z) (car z) z)) - - (define (imag-part z) - (if (imaginary? z) (cdr z) 0)) - - (define (magnitude z) ; Chibi-Scheme - (sqrt (+ (square (real-part z)) - (square (imag-part z))))) - - (define (angle z) ; Chibi-Scheme - (atan (imag-part z) - (real-part z))) - (define (char-compare x xs compare) ; Chibi-Scheme (let rec ((compare compare) (lhs (char->integer x)) diff --git a/basis/r7rs.ss b/basis/r7rs.ss index 214b6b5f0..30202f986 100644 --- a/basis/r7rs.ss +++ b/basis/r7rs.ss @@ -421,8 +421,7 @@ (string-map char-foldcase x)))) (define-library (scheme complex) - (import (only (meevax complex) make-rectangular real-part imag-part) - (only (scheme r5rs) make-polar magnitude angle)) + (import (only (scheme r5rs) make-rectangular make-polar real-part imag-part magnitude angle)) (export make-rectangular make-polar real-part imag-part magnitude angle)) (define-library (scheme cxr) diff --git a/include/meevax/kernel/complex.hpp b/include/meevax/kernel/complex.hpp index 3b0a64a91..df05495bb 100644 --- a/include/meevax/kernel/complex.hpp +++ b/include/meevax/kernel/complex.hpp @@ -41,6 +41,14 @@ inline namespace kernel }; auto operator <<(std::ostream &, complex const&) -> std::ostream &; + + auto real_part(object const&) -> object const&; + + auto imag_part(object const&) -> object const&; + + auto magnitude(object const&) -> object; + + auto angle(object const&) -> object; } // namespace kernel } // namespace meevax diff --git a/src/kernel/boot.cpp b/src/kernel/boot.cpp index 970a909d4..e516505df 100644 --- a/src/kernel/boot.cpp +++ b/src/kernel/boot.cpp @@ -144,14 +144,32 @@ inline namespace kernel return make(xs[0], xs[1]); }); + library.define("make-polar", [](let const& xs) + { + let const& radius = xs[0], angle = xs[1]; + + return make(radius * cos(angle), + radius * sin(angle)); + }); + library.define("real-part", [](let const& xs) -> auto const& { - return car(xs[0]); + return real_part(xs[0]); }); library.define("imag-part", [](let const& xs) -> auto const& { - return cdr(xs[0]); + return imag_part(xs[0]); + }); + + library.define("magnitude", [](let const& xs) + { + return magnitude(xs[0]); + }); + + library.define("angle", [](let const& xs) + { + return angle(xs[0]); }); }); @@ -567,18 +585,6 @@ inline namespace kernel return xs[0].is(); }); - // TODO REMOVE - library.define("single-float?", [](let const& xs) - { - return xs[0].is(); - }); - - // TODO REMOVE - library.define("double-float?", [](let const& xs) - { - return xs[0].is(); - }); - library.define("=", [](let const& xs) { return std::adjacent_find(std::begin(xs), std::end(xs), not_equals) == std::end(xs); diff --git a/src/kernel/complex.cpp b/src/kernel/complex.cpp index f0f94998f..4e535f82d 100644 --- a/src/kernel/complex.cpp +++ b/src/kernel/complex.cpp @@ -16,6 +16,7 @@ #include +#include #include namespace meevax @@ -102,5 +103,32 @@ inline namespace kernel return os << z.real() << cyan(explicitly_signed(z.imag()), "i"); } } + + auto real_part(object const& x) -> object const& + { + return x.is() ? car(x) : x; + } + + auto imag_part(object const& x) -> object const& + { + return x.is() ? cdr(x) : e0; + } + + auto magnitude(object const& x) -> object + { + auto hypotenuse = [](let const& x, let const& y) + { + return sqrt(x * x + y * y); + }; + + return hypotenuse(real_part(x), + imag_part(x)); + }; + + auto angle(object const& x) -> object + { + return atan(real_part(x), + imag_part(x)); + } } // namespace kernel } // namespace meevax From 0e9459fe2b594b7a2a799ecb9b2d9d2296aa86ca Mon Sep 17 00:00:00 2001 From: yamacir-kit Date: Tue, 3 Oct 2023 02:04:06 +0900 Subject: [PATCH 11/32] Update procedure `numerator` and `denominator` to built-in Signed-off-by: yamacir-kit --- README.md | 6 +++--- VERSION | 2 +- basis/r4rs.ss | 24 +++------------------ include/meevax/kernel/number.hpp | 4 ++++ src/kernel/boot.cpp | 20 ++++-------------- src/kernel/number.cpp | 36 ++++++++++++++++++++++++++++++++ 6 files changed, 51 insertions(+), 41 deletions(-) diff --git a/README.md b/README.md index 844b2f6db..944a9f8e8 100644 --- a/README.md +++ b/README.md @@ -99,7 +99,7 @@ Procedures for each standard are provided by the following R7RS-style libraries: cmake -B build -DCMAKE_BUILD_TYPE=Release cd build make package -sudo apt install build/meevax_0.5.10_amd64.deb +sudo apt install build/meevax_0.5.11_amd64.deb ``` or @@ -131,9 +131,9 @@ sudo rm -rf /usr/local/share/meevax | Target Name | Description |-------------|------------- -| `all` | Build shared-library `libmeevax.0.5.10.so` and executable `meevax` +| `all` | Build shared-library `libmeevax.0.5.11.so` and executable `meevax` | `test` | Test executable `meevax` -| `package` | Generate debian package `meevax_0.5.10_amd64.deb` +| `package` | Generate debian package `meevax_0.5.11_amd64.deb` | `install` | Copy files into `/usr/local` directly ## Usage diff --git a/VERSION b/VERSION index 50c76ef87..69626fb92 100644 --- a/VERSION +++ b/VERSION @@ -1 +1 @@ -0.5.10 +0.5.11 diff --git a/basis/r4rs.ss b/basis/r4rs.ss index 7ee62099d..ecff9909c 100644 --- a/basis/r4rs.ss +++ b/basis/r4rs.ss @@ -47,19 +47,13 @@ (meevax list) (only (meevax macro-transformer) er-macro-transformer identifier?) (only (meevax number) - number? - complex? - real? - rational? - integer? - exact? - inexact? + number? complex? real? rational? integer? + exact? inexact? = < > <= >= + * - / abs % ; deprecated - ratio-numerator ; deprecated - ratio-denominator ; deprecated + numerator denominator floor ceiling truncate round expt exact inexact @@ -67,7 +61,6 @@ ; to be removed exact-integer? ; r7rs - ratio? ) (meevax pair) (meevax port) @@ -402,17 +395,6 @@ (if (null? ns) n (rec (lcm-2 n (car ns)) (cdr ns)))))) - (define (numerator x) ; Chibi-Scheme - (cond ((ratio? x) (ratio-numerator x)) - ((exact? x) x) - (else (inexact (numerator (exact x)))))) - - (define (denominator x) ; Chibi-Scheme - (cond ((ratio? x) (ratio-denominator x)) - ((exact? x) 1) - ((integer? x) 1.0) - (else (inexact (denominator (exact x)))))) - (define (rationalize x e) ; IEEE Std 1178-1990 ANNEX C.4 (define (simplest-rational x y) (define (simplest-rational-internal x y) diff --git a/include/meevax/kernel/number.hpp b/include/meevax/kernel/number.hpp index cf416a453..fb2642d1b 100644 --- a/include/meevax/kernel/number.hpp +++ b/include/meevax/kernel/number.hpp @@ -379,6 +379,10 @@ inline namespace number auto pow(object const&, object const&) -> object; + auto numerator(object const&) -> object; + + auto denominator(object const&) -> object; + auto floor(object const&) -> object; auto ceil(object const&) -> object; diff --git a/src/kernel/boot.cpp b/src/kernel/boot.cpp index e516505df..2015eae05 100644 --- a/src/kernel/boot.cpp +++ b/src/kernel/boot.cpp @@ -573,18 +573,6 @@ inline namespace kernel return xs[0].is(); }); - // TODO REMOVE - library.define("imaginary?", [](let const& xs) - { - return xs[0].is(); - }); - - // TODO REMOVE - library.define("ratio?", [](let const& xs) - { - return xs[0].is(); - }); - library.define("=", [](let const& xs) { return std::adjacent_find(std::begin(xs), std::end(xs), not_equals) == std::end(xs); @@ -659,14 +647,14 @@ inline namespace kernel // TODO REMAINDER // TODO MODULO - library.define("ratio-numerator", [](let const& xs) + library.define("numerator", [](let const& xs) { - return make(xs[0].as().numerator()); + return numerator(xs[0]); }); - library.define("ratio-denominator", [](let const& xs) + library.define("denominator", [](let const& xs) { - return make(xs[0].as().denominator()); + return denominator(xs[0]); }); library.define("floor", [](let const& xs) diff --git a/src/kernel/number.cpp b/src/kernel/number.cpp index bd4c91cac..bc78b0120 100644 --- a/src/kernel/number.cpp +++ b/src/kernel/number.cpp @@ -832,6 +832,42 @@ inline namespace number return apply(f, x, y); } + auto numerator(object const& x) -> object + { + if (x.is()) + { + return make(x.as().numerator()); + } + else if (is_exact(x)) + { + return x; + } + else + { + return inexact(numerator(exact(x))); + } + } + + auto denominator(object const& x) -> object + { + if (x.is()) + { + return make(x.as().denominator()); + } + else if (is_exact(x)) + { + return e1; + } + else if (is_integer(x)) + { + return make(1.0); + } + else + { + return inexact(denominator(exact(x))); + } + } + #define DEFINE(ROUND) \ auto ROUND(object const& x) -> object \ { \ From 532897939829e02101abec9dd1f7d3122d4ed2b0 Mon Sep 17 00:00:00 2001 From: yamacir-kit Date: Tue, 3 Oct 2023 02:18:55 +0900 Subject: [PATCH 12/32] Update procedure `quotient`, `remainder` and `modulo` to built-in Signed-off-by: yamacir-kit --- README.md | 6 +++--- VERSION | 2 +- basis/r4rs.ss | 10 +--------- include/meevax/kernel/number.hpp | 6 ++++++ src/kernel/boot.cpp | 21 +++++++++++++-------- src/kernel/number.cpp | 15 +++++++++++++++ 6 files changed, 39 insertions(+), 21 deletions(-) diff --git a/README.md b/README.md index 944a9f8e8..50195ebb0 100644 --- a/README.md +++ b/README.md @@ -99,7 +99,7 @@ Procedures for each standard are provided by the following R7RS-style libraries: cmake -B build -DCMAKE_BUILD_TYPE=Release cd build make package -sudo apt install build/meevax_0.5.11_amd64.deb +sudo apt install build/meevax_0.5.12_amd64.deb ``` or @@ -131,9 +131,9 @@ sudo rm -rf /usr/local/share/meevax | Target Name | Description |-------------|------------- -| `all` | Build shared-library `libmeevax.0.5.11.so` and executable `meevax` +| `all` | Build shared-library `libmeevax.0.5.12.so` and executable `meevax` | `test` | Test executable `meevax` -| `package` | Generate debian package `meevax_0.5.11_amd64.deb` +| `package` | Generate debian package `meevax_0.5.12_amd64.deb` | `install` | Copy files into `/usr/local` directly ## Usage diff --git a/VERSION b/VERSION index 69626fb92..9d6c1754e 100644 --- a/VERSION +++ b/VERSION @@ -1 +1 @@ -0.5.11 +0.5.12 diff --git a/basis/r4rs.ss b/basis/r4rs.ss index ecff9909c..7e5b71af3 100644 --- a/basis/r4rs.ss +++ b/basis/r4rs.ss @@ -52,7 +52,7 @@ = < > <= >= + * - / abs - % ; deprecated + quotient remainder modulo numerator denominator floor ceiling truncate round expt @@ -367,14 +367,6 @@ (else (rec (if (< (car xs) x) (car xs) x) (cdr xs))))))) - (define (quotient x y) - (truncate (/ x y))) - - (define remainder %) - - (define (modulo x y) - (% (+ y (% x y)) y)) - (define (gcd . xs) ; Chibi-Scheme (define (gcd-2 a b) (if (zero? b) diff --git a/include/meevax/kernel/number.hpp b/include/meevax/kernel/number.hpp index fb2642d1b..ea29ee295 100644 --- a/include/meevax/kernel/number.hpp +++ b/include/meevax/kernel/number.hpp @@ -375,6 +375,12 @@ inline namespace number auto abs(object const&) -> object; + auto quotient(object const&, object const&) -> object; + + auto remainder(object const&, object const&) -> object; + + auto modulo(object const&, object const&) -> object; + auto sqrt(object const&) -> object; auto pow(object const&, object const&) -> object; diff --git a/src/kernel/boot.cpp b/src/kernel/boot.cpp index 2015eae05..f26ec043d 100644 --- a/src/kernel/boot.cpp +++ b/src/kernel/boot.cpp @@ -632,20 +632,25 @@ inline namespace kernel } }); - // TODO RENAME - library.define("%", [](let const& xs) + library.define("abs", [](let const& xs) { - return xs[0] % xs[1]; + return abs(xs[0]); }); - library.define("abs", [](let const& xs) + library.define("quotient", [](let const& xs) { - return abs(xs[0]); + return quotient(xs[0], xs[1]); }); - // TODO QUOTIENT - // TODO REMAINDER - // TODO MODULO + library.define("remainder", [](let const& xs) + { + return remainder(xs[0], xs[1]); + }); + + library.define("modulo", [](let const& xs) + { + return modulo(xs[0], xs[1]); + }); library.define("numerator", [](let const& xs) { diff --git a/src/kernel/number.cpp b/src/kernel/number.cpp index bc78b0120..14192eff2 100644 --- a/src/kernel/number.cpp +++ b/src/kernel/number.cpp @@ -762,6 +762,21 @@ inline namespace number return apply(f, x); } + auto quotient(object const& x, object const& y) -> object + { + return trunc(x / y); + } + + auto remainder(object const& x, object const& y) -> object + { + return x % y; + } + + auto modulo(object const& x, object const& y) -> object + { + return ((x % y) + y) % y; + } + auto sqrt(object const& x) -> object { auto f = [](auto&& x) From c8390c1b0ef8d7c0444a1197921f2440bee4b6ab Mon Sep 17 00:00:00 2001 From: yamacir-kit Date: Tue, 3 Oct 2023 02:29:15 +0900 Subject: [PATCH 13/32] Update procedure `zero?` to built-in Signed-off-by: yamacir-kit --- README.md | 6 +++--- VERSION | 2 +- basis/r4rs.ss | 4 +--- include/meevax/kernel/number.hpp | 2 ++ src/kernel/boot.cpp | 5 +++++ src/kernel/number.cpp | 5 +++++ 6 files changed, 17 insertions(+), 7 deletions(-) diff --git a/README.md b/README.md index 50195ebb0..06fd6b4ba 100644 --- a/README.md +++ b/README.md @@ -99,7 +99,7 @@ Procedures for each standard are provided by the following R7RS-style libraries: cmake -B build -DCMAKE_BUILD_TYPE=Release cd build make package -sudo apt install build/meevax_0.5.12_amd64.deb +sudo apt install build/meevax_0.5.13_amd64.deb ``` or @@ -131,9 +131,9 @@ sudo rm -rf /usr/local/share/meevax | Target Name | Description |-------------|------------- -| `all` | Build shared-library `libmeevax.0.5.12.so` and executable `meevax` +| `all` | Build shared-library `libmeevax.0.5.13.so` and executable `meevax` | `test` | Test executable `meevax` -| `package` | Generate debian package `meevax_0.5.12_amd64.deb` +| `package` | Generate debian package `meevax_0.5.13_amd64.deb` | `install` | Copy files into `/usr/local` directly ## Usage diff --git a/VERSION b/VERSION index 9d6c1754e..964783a81 100644 --- a/VERSION +++ b/VERSION @@ -1 +1 @@ -0.5.12 +0.5.13 diff --git a/basis/r4rs.ss b/basis/r4rs.ss index 7e5b71af3..38cc7d22d 100644 --- a/basis/r4rs.ss +++ b/basis/r4rs.ss @@ -50,6 +50,7 @@ number? complex? real? rational? integer? exact? inexact? = < > <= >= + zero? + * - / abs quotient remainder modulo @@ -324,9 +325,6 @@ (car alist) (assoc (cdr alist))))))) - (define (zero? n) - (= n 0)) - (define (positive? n) (> n 0)) diff --git a/include/meevax/kernel/number.hpp b/include/meevax/kernel/number.hpp index ea29ee295..5e8671131 100644 --- a/include/meevax/kernel/number.hpp +++ b/include/meevax/kernel/number.hpp @@ -373,6 +373,8 @@ inline namespace number auto is_nan(object const&) -> bool; + auto is_zero(object const&) -> bool; + auto abs(object const&) -> object; auto quotient(object const&, object const&) -> object; diff --git a/src/kernel/boot.cpp b/src/kernel/boot.cpp index f26ec043d..6cec2b393 100644 --- a/src/kernel/boot.cpp +++ b/src/kernel/boot.cpp @@ -598,6 +598,11 @@ inline namespace kernel return std::adjacent_find(std::begin(xs), std::end(xs), less_than) == std::end(xs); }); + library.define("zero?", [](let const& xs) + { + return is_zero(xs[0]); + }); + library.define("+", [](let const& xs) { return std::accumulate(std::begin(xs), std::end(xs), e0, std::plus()); diff --git a/src/kernel/number.cpp b/src/kernel/number.cpp index 14192eff2..2482a45e2 100644 --- a/src/kernel/number.cpp +++ b/src/kernel/number.cpp @@ -736,6 +736,11 @@ inline namespace number return test(f, x); } + auto is_zero(object const& x) -> bool + { + return equals(x, e0); + } + auto abs(object const& x) -> object { auto f = [](auto&& x) From f45ff0a4de40ace2da135a23b37fdab4cae46968 Mon Sep 17 00:00:00 2001 From: yamacir-kit Date: Tue, 3 Oct 2023 02:35:44 +0900 Subject: [PATCH 14/32] Update procedure `positive?` and `negative?` to built-in Signed-off-by: yamacir-kit --- README.md | 6 +++--- VERSION | 2 +- basis/r4rs.ss | 8 +------- include/meevax/kernel/number.hpp | 4 ++++ src/kernel/boot.cpp | 10 ++++++++++ src/kernel/number.cpp | 10 ++++++++++ 6 files changed, 29 insertions(+), 11 deletions(-) diff --git a/README.md b/README.md index 06fd6b4ba..226226ced 100644 --- a/README.md +++ b/README.md @@ -99,7 +99,7 @@ Procedures for each standard are provided by the following R7RS-style libraries: cmake -B build -DCMAKE_BUILD_TYPE=Release cd build make package -sudo apt install build/meevax_0.5.13_amd64.deb +sudo apt install build/meevax_0.5.14_amd64.deb ``` or @@ -131,9 +131,9 @@ sudo rm -rf /usr/local/share/meevax | Target Name | Description |-------------|------------- -| `all` | Build shared-library `libmeevax.0.5.13.so` and executable `meevax` +| `all` | Build shared-library `libmeevax.0.5.14.so` and executable `meevax` | `test` | Test executable `meevax` -| `package` | Generate debian package `meevax_0.5.13_amd64.deb` +| `package` | Generate debian package `meevax_0.5.14_amd64.deb` | `install` | Copy files into `/usr/local` directly ## Usage diff --git a/VERSION b/VERSION index 964783a81..83ac1cc02 100644 --- a/VERSION +++ b/VERSION @@ -1 +1 @@ -0.5.13 +0.5.14 diff --git a/basis/r4rs.ss b/basis/r4rs.ss index 38cc7d22d..1bc5df205 100644 --- a/basis/r4rs.ss +++ b/basis/r4rs.ss @@ -50,7 +50,7 @@ number? complex? real? rational? integer? exact? inexact? = < > <= >= - zero? + zero? positive? negative? + * - / abs quotient remainder modulo @@ -325,12 +325,6 @@ (car alist) (assoc (cdr alist))))))) - (define (positive? n) - (> n 0)) - - (define (negative? n) - (< n 0)) - (define (odd? n) (not (even? n))) diff --git a/include/meevax/kernel/number.hpp b/include/meevax/kernel/number.hpp index 5e8671131..cc85ed62b 100644 --- a/include/meevax/kernel/number.hpp +++ b/include/meevax/kernel/number.hpp @@ -375,6 +375,10 @@ inline namespace number auto is_zero(object const&) -> bool; + auto is_positive(object const&) -> bool; + + auto is_negative(object const&) -> bool; + auto abs(object const&) -> object; auto quotient(object const&, object const&) -> object; diff --git a/src/kernel/boot.cpp b/src/kernel/boot.cpp index 6cec2b393..6e660f70f 100644 --- a/src/kernel/boot.cpp +++ b/src/kernel/boot.cpp @@ -603,6 +603,16 @@ inline namespace kernel return is_zero(xs[0]); }); + library.define("positive?", [](let const& xs) + { + return is_positive(xs[0]); + }); + + library.define("negative?", [](let const& xs) + { + return is_negative(xs[0]); + }); + library.define("+", [](let const& xs) { return std::accumulate(std::begin(xs), std::end(xs), e0, std::plus()); diff --git a/src/kernel/number.cpp b/src/kernel/number.cpp index 2482a45e2..8f80a2898 100644 --- a/src/kernel/number.cpp +++ b/src/kernel/number.cpp @@ -741,6 +741,16 @@ inline namespace number return equals(x, e0); } + auto is_positive(object const& x) -> bool + { + return less_than(e0, x); + } + + auto is_negative(object const& x) -> bool + { + return less_than(x, e0); + } + auto abs(object const& x) -> object { auto f = [](auto&& x) From 88bf5c66bd7b39291c765ee4ea7f83d64149e3f7 Mon Sep 17 00:00:00 2001 From: yamacir-kit Date: Tue, 3 Oct 2023 02:41:53 +0900 Subject: [PATCH 15/32] Update procedure `odd?` and `even?` to built-in Signed-off-by: yamacir-kit --- README.md | 6 +++--- VERSION | 2 +- basis/r4rs.ss | 8 +------- include/meevax/kernel/number.hpp | 4 ++++ src/kernel/boot.cpp | 10 ++++++++++ src/kernel/number.cpp | 11 +++++++++++ 6 files changed, 30 insertions(+), 11 deletions(-) diff --git a/README.md b/README.md index 226226ced..83f9f0a0b 100644 --- a/README.md +++ b/README.md @@ -99,7 +99,7 @@ Procedures for each standard are provided by the following R7RS-style libraries: cmake -B build -DCMAKE_BUILD_TYPE=Release cd build make package -sudo apt install build/meevax_0.5.14_amd64.deb +sudo apt install build/meevax_0.5.15_amd64.deb ``` or @@ -131,9 +131,9 @@ sudo rm -rf /usr/local/share/meevax | Target Name | Description |-------------|------------- -| `all` | Build shared-library `libmeevax.0.5.14.so` and executable `meevax` +| `all` | Build shared-library `libmeevax.0.5.15.so` and executable `meevax` | `test` | Test executable `meevax` -| `package` | Generate debian package `meevax_0.5.14_amd64.deb` +| `package` | Generate debian package `meevax_0.5.15_amd64.deb` | `install` | Copy files into `/usr/local` directly ## Usage diff --git a/VERSION b/VERSION index 83ac1cc02..c5f3c9c45 100644 --- a/VERSION +++ b/VERSION @@ -1 +1 @@ -0.5.14 +0.5.15 diff --git a/basis/r4rs.ss b/basis/r4rs.ss index 1bc5df205..5dba93414 100644 --- a/basis/r4rs.ss +++ b/basis/r4rs.ss @@ -50,7 +50,7 @@ number? complex? real? rational? integer? exact? inexact? = < > <= >= - zero? positive? negative? + zero? positive? negative? odd? even? + * - / abs quotient remainder modulo @@ -325,12 +325,6 @@ (car alist) (assoc (cdr alist))))))) - (define (odd? n) - (not (even? n))) - - (define (even? n) - (= (remainder n 2) 0)) - (define (max x . xs) ; Chibi-Scheme (define (max-aux x xs) (if (null? xs) diff --git a/include/meevax/kernel/number.hpp b/include/meevax/kernel/number.hpp index cc85ed62b..c01b8c40e 100644 --- a/include/meevax/kernel/number.hpp +++ b/include/meevax/kernel/number.hpp @@ -379,6 +379,10 @@ inline namespace number auto is_negative(object const&) -> bool; + auto is_odd(object const&) -> bool; + + auto is_even(object const&) -> bool; + auto abs(object const&) -> object; auto quotient(object const&, object const&) -> object; diff --git a/src/kernel/boot.cpp b/src/kernel/boot.cpp index 6e660f70f..a31407b35 100644 --- a/src/kernel/boot.cpp +++ b/src/kernel/boot.cpp @@ -613,6 +613,16 @@ inline namespace kernel return is_negative(xs[0]); }); + library.define("odd?", [](let const& xs) + { + return is_odd(xs[0]); + }); + + library.define("even?", [](let const& xs) + { + return is_even(xs[0]); + }); + library.define("+", [](let const& xs) { return std::accumulate(std::begin(xs), std::end(xs), e0, std::plus()); diff --git a/src/kernel/number.cpp b/src/kernel/number.cpp index 8f80a2898..834062739 100644 --- a/src/kernel/number.cpp +++ b/src/kernel/number.cpp @@ -751,6 +751,17 @@ inline namespace number return less_than(x, e0); } + auto is_odd(object const& x) -> bool + { + return not is_even(x); + } + + auto is_even(object const& x) -> bool + { + let static const e2 = make(2); + return is_zero(remainder(x, e2)); + } + auto abs(object const& x) -> object { auto f = [](auto&& x) From 15faa56008432d5ea9f7e703cad01495bd358878 Mon Sep 17 00:00:00 2001 From: yamacir-kit Date: Tue, 3 Oct 2023 03:06:58 +0900 Subject: [PATCH 16/32] Update procedure `max` and `min` to built-in Signed-off-by: yamacir-kit --- README.md | 6 +++--- VERSION | 2 +- basis/r4rs.ss | 29 +---------------------------- src/kernel/boot.cpp | 24 ++++++++++++++++++++++++ 4 files changed, 29 insertions(+), 32 deletions(-) diff --git a/README.md b/README.md index 83f9f0a0b..6b4ec5c85 100644 --- a/README.md +++ b/README.md @@ -99,7 +99,7 @@ Procedures for each standard are provided by the following R7RS-style libraries: cmake -B build -DCMAKE_BUILD_TYPE=Release cd build make package -sudo apt install build/meevax_0.5.15_amd64.deb +sudo apt install build/meevax_0.5.16_amd64.deb ``` or @@ -131,9 +131,9 @@ sudo rm -rf /usr/local/share/meevax | Target Name | Description |-------------|------------- -| `all` | Build shared-library `libmeevax.0.5.15.so` and executable `meevax` +| `all` | Build shared-library `libmeevax.0.5.16.so` and executable `meevax` | `test` | Test executable `meevax` -| `package` | Generate debian package `meevax_0.5.15_amd64.deb` +| `package` | Generate debian package `meevax_0.5.16_amd64.deb` | `install` | Copy files into `/usr/local` directly ## Usage diff --git a/VERSION b/VERSION index c5f3c9c45..3afb327e2 100644 --- a/VERSION +++ b/VERSION @@ -1 +1 @@ -0.5.15 +0.5.16 diff --git a/basis/r4rs.ss b/basis/r4rs.ss index 5dba93414..41bfc1587 100644 --- a/basis/r4rs.ss +++ b/basis/r4rs.ss @@ -51,6 +51,7 @@ exact? inexact? = < > <= >= zero? positive? negative? odd? even? + max min + * - / abs quotient remainder modulo @@ -325,34 +326,6 @@ (car alist) (assoc (cdr alist))))))) - (define (max x . xs) ; Chibi-Scheme - (define (max-aux x xs) - (if (null? xs) - (inexact x) - (max-aux (if (< x (car xs)) (car xs) x) - (cdr xs)))) - (if (inexact? x) - (max-aux x xs) - (let rec ((x x) (xs xs)) - (cond ((null? xs) x) - ((inexact? (car xs)) (max-aux x xs)) - (else (rec (if (< x (car xs)) (car xs) x) - (cdr xs))))))) - - (define (min x . xs) ; Chibi-Scheme - (define (min-aux x xs) - (if (null? xs) - (inexact x) - (min-aux (if (< (car xs) x) (car xs) x) - (cdr xs)))) - (if (inexact? x) - (min-aux x xs) - (let rec ((x x) (xs xs)) - (cond ((null? xs) x) - ((inexact? (car xs)) (min-aux x xs)) - (else (rec (if (< (car xs) x) (car xs) x) - (cdr xs))))))) - (define (gcd . xs) ; Chibi-Scheme (define (gcd-2 a b) (if (zero? b) diff --git a/src/kernel/boot.cpp b/src/kernel/boot.cpp index a31407b35..90c01db88 100644 --- a/src/kernel/boot.cpp +++ b/src/kernel/boot.cpp @@ -623,6 +623,30 @@ inline namespace kernel return is_even(xs[0]); }); + library.define("max", [](let const& xs) + { + if (auto iter = std::max_element(xs.begin(), xs.end(), less_than); iter != xs.end()) + { + return std::any_of(xs.begin(), xs.end(), is_inexact) ? inexact(*iter) : *iter; + } + else + { + throw error(make("procedure max requires at least one argument")); + } + }); + + library.define("min", [](let const& xs) + { + if (auto iter = std::min_element(xs.begin(), xs.end(), less_than); iter != xs.end()) + { + return std::any_of(xs.begin(), xs.end(), is_inexact) ? inexact(*iter) : *iter; + } + else + { + throw error(make("procedure min requires at least one argument")); + } + }); + library.define("+", [](let const& xs) { return std::accumulate(std::begin(xs), std::end(xs), e0, std::plus()); From a8504cf48636bbfc69bd9efd7962b857671695c0 Mon Sep 17 00:00:00 2001 From: yamacir-kit Date: Tue, 3 Oct 2023 21:33:27 +0900 Subject: [PATCH 17/32] Update procedure `gcd` and `lcm` to built-in Signed-off-by: yamacir-kit --- README.md | 6 ++-- VERSION | 2 +- basis/r4rs.ss | 21 +------------- include/meevax/kernel/number.hpp | 8 ++++++ src/kernel/boot.cpp | 48 +++++++++++++++++++++----------- src/kernel/number.cpp | 35 +++++++++++++++++++++++ 6 files changed, 80 insertions(+), 40 deletions(-) diff --git a/README.md b/README.md index 6b4ec5c85..b0f7f53a2 100644 --- a/README.md +++ b/README.md @@ -99,7 +99,7 @@ Procedures for each standard are provided by the following R7RS-style libraries: cmake -B build -DCMAKE_BUILD_TYPE=Release cd build make package -sudo apt install build/meevax_0.5.16_amd64.deb +sudo apt install build/meevax_0.5.17_amd64.deb ``` or @@ -131,9 +131,9 @@ sudo rm -rf /usr/local/share/meevax | Target Name | Description |-------------|------------- -| `all` | Build shared-library `libmeevax.0.5.16.so` and executable `meevax` +| `all` | Build shared-library `libmeevax.0.5.17.so` and executable `meevax` | `test` | Test executable `meevax` -| `package` | Generate debian package `meevax_0.5.16_amd64.deb` +| `package` | Generate debian package `meevax_0.5.17_amd64.deb` | `install` | Copy files into `/usr/local` directly ## Usage diff --git a/VERSION b/VERSION index 3afb327e2..d8aef8135 100644 --- a/VERSION +++ b/VERSION @@ -1 +1 @@ -0.5.16 +0.5.17 diff --git a/basis/r4rs.ss b/basis/r4rs.ss index 41bfc1587..9d49e4375 100644 --- a/basis/r4rs.ss +++ b/basis/r4rs.ss @@ -55,6 +55,7 @@ + * - / abs quotient remainder modulo + gcd lcm numerator denominator floor ceiling truncate round expt @@ -326,26 +327,6 @@ (car alist) (assoc (cdr alist))))))) - (define (gcd . xs) ; Chibi-Scheme - (define (gcd-2 a b) - (if (zero? b) - (abs a) - (gcd b (remainder a b)))) - (if (null? xs) 0 - (let rec ((n (car xs)) - (ns (cdr xs))) - (if (null? ns) n - (rec (gcd-2 n (car ns)) (cdr ns)))))) - - (define (lcm . xs) ; Chibi-Scheme - (define (lcm-2 a b) - (abs (quotient (* a b) (gcd a b)))) - (if (null? xs) 1 - (let rec ((n (car xs)) - (ns (cdr xs))) - (if (null? ns) n - (rec (lcm-2 n (car ns)) (cdr ns)))))) - (define (rationalize x e) ; IEEE Std 1178-1990 ANNEX C.4 (define (simplest-rational x y) (define (simplest-rational-internal x y) diff --git a/include/meevax/kernel/number.hpp b/include/meevax/kernel/number.hpp index c01b8c40e..5fce56d68 100644 --- a/include/meevax/kernel/number.hpp +++ b/include/meevax/kernel/number.hpp @@ -383,6 +383,10 @@ inline namespace number auto is_even(object const&) -> bool; + auto max(object const&) -> object; + + auto min(object const&) -> object; + auto abs(object const&) -> object; auto quotient(object const&, object const&) -> object; @@ -391,6 +395,10 @@ inline namespace number auto modulo(object const&, object const&) -> object; + auto gcd(object const&, object const&) -> object; + + auto lcm(object const&, object const&) -> object; + auto sqrt(object const&) -> object; auto pow(object const&, object const&) -> object; diff --git a/src/kernel/boot.cpp b/src/kernel/boot.cpp index 90c01db88..878c2793e 100644 --- a/src/kernel/boot.cpp +++ b/src/kernel/boot.cpp @@ -625,26 +625,12 @@ inline namespace kernel library.define("max", [](let const& xs) { - if (auto iter = std::max_element(xs.begin(), xs.end(), less_than); iter != xs.end()) - { - return std::any_of(xs.begin(), xs.end(), is_inexact) ? inexact(*iter) : *iter; - } - else - { - throw error(make("procedure max requires at least one argument")); - } + return max(xs); }); library.define("min", [](let const& xs) { - if (auto iter = std::min_element(xs.begin(), xs.end(), less_than); iter != xs.end()) - { - return std::any_of(xs.begin(), xs.end(), is_inexact) ? inexact(*iter) : *iter; - } - else - { - throw error(make("procedure min requires at least one argument")); - } + return min(xs); }); library.define("+", [](let const& xs) @@ -701,6 +687,36 @@ inline namespace kernel return modulo(xs[0], xs[1]); }); + library.define("gcd", [](let const& xs) + { + switch (length(xs)) + { + case 0: + return e0; + + case 1: + return xs[0]; + + default: + return std::accumulate(cdr(xs).begin(), xs.end(), xs[0], gcd); + } + }); + + library.define("lcm", [](let const& xs) + { + switch (length(xs)) + { + case 0: + return e1; + + case 1: + return xs[0]; + + default: + return std::accumulate(cdr(xs).begin(), xs.end(), xs[0], lcm); + } + }); + library.define("numerator", [](let const& xs) { return numerator(xs[0]); diff --git a/src/kernel/number.cpp b/src/kernel/number.cpp index 834062739..0b227bbb5 100644 --- a/src/kernel/number.cpp +++ b/src/kernel/number.cpp @@ -18,6 +18,7 @@ #include #include +#include #include #include @@ -762,6 +763,30 @@ inline namespace number return is_zero(remainder(x, e2)); } + auto max(object const& xs) -> object + { + if (auto iter = std::max_element(xs.begin(), xs.end(), less_than); iter != xs.end()) + { + return std::any_of(xs.begin(), xs.end(), is_inexact) ? inexact(*iter) : *iter; + } + else + { + return unspecified; + } + } + + auto min(object const& xs) -> object + { + if (auto iter = std::min_element(xs.begin(), xs.end(), less_than); iter != xs.end()) + { + return std::any_of(xs.begin(), xs.end(), is_inexact) ? inexact(*iter) : *iter; + } + else + { + return unspecified; + } + } + auto abs(object const& x) -> object { auto f = [](auto&& x) @@ -803,6 +828,16 @@ inline namespace number return ((x % y) + y) % y; } + auto gcd(object const& x, object const& y) -> object + { + return is_zero(y) ? abs(x) : gcd(y, remainder(x, y)); + } + + auto lcm(object const& x, object const& y) -> object + { + return abs(quotient(x * y, gcd(x, y))); + } + auto sqrt(object const& x) -> object { auto f = [](auto&& x) From 0904663bd02cd0ac8e11aee50e62f63c24cdd079 Mon Sep 17 00:00:00 2001 From: yamacir-kit Date: Tue, 3 Oct 2023 22:47:21 +0900 Subject: [PATCH 18/32] Update procedure `string-fill!` to built-in Signed-off-by: yamacir-kit --- README.md | 6 +-- VERSION | 2 +- basis/r4rs.ss | 35 +---------------- src/kernel/boot.cpp | 94 ++++++++++++++++++++++++++++++++++++--------- 4 files changed, 81 insertions(+), 56 deletions(-) diff --git a/README.md b/README.md index b0f7f53a2..11ad3e5a4 100644 --- a/README.md +++ b/README.md @@ -99,7 +99,7 @@ Procedures for each standard are provided by the following R7RS-style libraries: cmake -B build -DCMAKE_BUILD_TYPE=Release cd build make package -sudo apt install build/meevax_0.5.17_amd64.deb +sudo apt install build/meevax_0.5.18_amd64.deb ``` or @@ -131,9 +131,9 @@ sudo rm -rf /usr/local/share/meevax | Target Name | Description |-------------|------------- -| `all` | Build shared-library `libmeevax.0.5.17.so` and executable `meevax` +| `all` | Build shared-library `libmeevax.0.5.18.so` and executable `meevax` | `test` | Test executable `meevax` -| `package` | Generate debian package `meevax_0.5.17_amd64.deb` +| `package` | Generate debian package `meevax_0.5.18_amd64.deb` | `install` | Copy files into `/usr/local` directly ## Usage diff --git a/VERSION b/VERSION index d8aef8135..b7a8bdf37 100644 --- a/VERSION +++ b/VERSION @@ -1 +1 @@ -0.5.17 +0.5.18 diff --git a/basis/r4rs.ss b/basis/r4rs.ss index 9d49e4375..18064403f 100644 --- a/basis/r4rs.ss +++ b/basis/r4rs.ss @@ -46,25 +46,7 @@ (only (meevax inexact) exp log sqrt sin cos tan asin acos atan) (meevax list) (only (meevax macro-transformer) er-macro-transformer identifier?) - (only (meevax number) - number? complex? real? rational? integer? - exact? inexact? - = < > <= >= - zero? positive? negative? odd? even? - max min - + * - / - abs - quotient remainder modulo - gcd lcm - numerator denominator - floor ceiling truncate round - expt - exact inexact - string->number - - ; to be removed - exact-integer? ; r7rs - ) + (only (meevax number) number? complex? real? rational? integer? exact? inexact? = < > <= >= zero? positive? negative? odd? even? max min + * - / abs quotient remainder modulo gcd lcm numerator denominator floor ceiling truncate round expt exact inexact number->string string->number) (meevax pair) (meevax port) (prefix (meevax read) %) @@ -430,21 +412,6 @@ (define substring string-copy) - (define (string-fill! s c . o) ; Chibi-Scheme - (let ((start (if (and (pair? o) - (exact-integer? (car o))) - (car o) - 0)) - (end (if (and (pair? o) - (pair? (cdr o)) - (exact-integer? (cadr o))) - (cadr o) - (string-length s)))) - (let rec ((k (- end 1))) - (if (<= start k) - (begin (string-set! s k c) - (rec (- k 1))))))) - (define (for-each f x . xs) ; Chibi-Scheme (if (null? xs) (letrec ((for-each (lambda (f x) diff --git a/src/kernel/boot.cpp b/src/kernel/boot.cpp index 878c2793e..d10eb9550 100644 --- a/src/kernel/boot.cpp +++ b/src/kernel/boot.cpp @@ -770,9 +770,34 @@ inline namespace kernel return inexact(xs[0]); }); + library.define("number->string", [](let const& xs) + { + switch (length(xs)) + { + case 1: + return number_to_string(xs[0], 10); + + case 2: + return number_to_string(xs[0], xs[1].as()); + + default: + throw error(make("procedure number->string takes one or two arugments, but got"), xs); + } + }); + library.define("string->number", [](let const& xs) { - return make_number(xs[0].as(), 1 < length(xs) ? xs[1].as() : 10); + switch (length(xs)) + { + case 1: + return make_number(xs[0].as(), 10); + + case 2: + return make_number(xs[0].as(), xs[1].as()); + + default: + throw error(make("procedure string->number takes one or two arugments, but got"), xs); + } }); }); @@ -1139,6 +1164,33 @@ inline namespace kernel std::next(std::begin(s1), xs[1].as())); }); + library.define("string-fill!", [](let & xs) + { + switch (length(xs)) + { + case 2: + std::fill(xs[0].as().vector.begin(), + xs[0].as().vector.end(), + xs[1].as()); + break; + + case 3: + std::fill(std::next(xs[0].as().vector.begin(), + xs[2].as()), + xs[0].as().vector.end(), + xs[1].as()); + break; + + case 4: + std::fill(std::next(xs[0].as().vector.begin(), + xs[2].as()), + std::next(xs[0].as().vector.begin(), + xs[3].as()), + xs[1].as()); + break; + } + }); + #define STRING_COMPARE(COMPARE) \ [](let const& xs) \ { \ @@ -1168,11 +1220,6 @@ inline namespace kernel return make_symbol(xs[0].as()); }); - library.define("number->string", [](let const& xs) - { - return number_to_string(xs[0], 1 < length(xs) ? xs[1].as() : 10); - }); - library.define("string->list", [](let const& xs) { /* @@ -1449,18 +1496,29 @@ inline namespace kernel library.define("vector-fill!", [](let & xs) { - /* - (vector-fill! vector fill) procedure - (vector-fill! vector fill start) procedure - (vector-fill! vector fill start end) procedure - - The vector-fill! procedure stores fill in the elements of vector - between start and end. - */ - - std::fill(std::next(std::begin(xs[0].as().vector), 2 < length(xs) ? xs[2].as() : 0), - std::next(std::begin(xs[0].as().vector), 3 < length(xs) ? xs[3].as() : xs[0].as().vector.size()), - 1 < length(xs) ? xs[1] : unspecified); + switch (length(xs)) + { + case 2: + std::fill(xs[0].as().vector.begin(), + xs[0].as().vector.end(), + xs[1]); + break; + + case 3: + std::fill(std::next(xs[0].as().vector.begin(), + xs[2].as()), + xs[0].as().vector.end(), + xs[1]); + break; + + case 4: + std::fill(std::next(xs[0].as().vector.begin(), + xs[2].as()), + std::next(xs[0].as().vector.begin(), + xs[3].as()), + xs[1]); + break; + } }); library.define("vector->list", [](let const& xs) From 5609bc41a97409356e3f25743e80f918bd79e558 Mon Sep 17 00:00:00 2001 From: yamacir-kit Date: Tue, 3 Oct 2023 23:07:04 +0900 Subject: [PATCH 19/32] Update character comparison procedures to built-in Signed-off-by: yamacir-kit --- README.md | 6 +++--- VERSION | 2 +- basis/r4rs.ss | 32 +++++++---------------------- src/kernel/boot.cpp | 50 +++++++++++++++++++++++++++++++++++++++++++++ 4 files changed, 61 insertions(+), 29 deletions(-) diff --git a/README.md b/README.md index 11ad3e5a4..cb441be31 100644 --- a/README.md +++ b/README.md @@ -99,7 +99,7 @@ Procedures for each standard are provided by the following R7RS-style libraries: cmake -B build -DCMAKE_BUILD_TYPE=Release cd build make package -sudo apt install build/meevax_0.5.18_amd64.deb +sudo apt install build/meevax_0.5.19_amd64.deb ``` or @@ -131,9 +131,9 @@ sudo rm -rf /usr/local/share/meevax | Target Name | Description |-------------|------------- -| `all` | Build shared-library `libmeevax.0.5.18.so` and executable `meevax` +| `all` | Build shared-library `libmeevax.0.5.19.so` and executable `meevax` | `test` | Test executable `meevax` -| `package` | Generate debian package `meevax_0.5.18_amd64.deb` +| `package` | Generate debian package `meevax_0.5.19_amd64.deb` | `install` | Copy files into `/usr/local` directly ## Usage diff --git a/VERSION b/VERSION index b7a8bdf37..5ca9ac67b 100644 --- a/VERSION +++ b/VERSION @@ -1 +1 @@ -0.5.18 +0.5.19 diff --git a/basis/r4rs.ss b/basis/r4rs.ss index 18064403f..e26868255 100644 --- a/basis/r4rs.ss +++ b/basis/r4rs.ss @@ -36,7 +36,13 @@ (define-library (scheme r4rs) (import (only (meevax boolean) boolean? not) - (meevax character) + (only (meevax character) + char? + char=? char? char<=? char>=? + char-alphabetic? char-numeric? char-whitespace? char-upper-case? char-lower-case? + char->integer integer->char + char-upcase char-downcase + ) (only (meevax core) begin define define-syntax if lambda letrec quote set!) (only (meevax comparator) eq? eqv? equal?) (only (meevax complex) make-rectangular make-polar real-part imag-part magnitude angle) @@ -336,30 +342,6 @@ (simplest-rational (- x e) (+ x e))) - (define (char-compare x xs compare) ; Chibi-Scheme - (let rec ((compare compare) - (lhs (char->integer x)) - (xs xs)) - (if (null? xs) #t - (let ((rhs (char->integer (car xs)))) - (and (compare lhs rhs) - (rec compare rhs (cdr xs))))))) - - (define (char=? x . xs) ; Chibi-Scheme - (char-compare x xs =)) - - (define (char? x . xs) ; Chibi-Scheme - (char-compare x xs >)) - - (define (char<=? x . xs) ; Chibi-Scheme - (char-compare x xs <=)) - - (define (char>=? x . xs) ; Chibi-Scheme - (char-compare x xs >=)) - (define (char-ci-compare x xs compare) ; Chibi-Scheme (let rec ((compare compare) (lhs (char->integer (char-downcase x))) diff --git a/src/kernel/boot.cpp b/src/kernel/boot.cpp index d10eb9550..8e84c8b9c 100644 --- a/src/kernel/boot.cpp +++ b/src/kernel/boot.cpp @@ -82,6 +82,56 @@ inline namespace kernel return xs[0].is(); }); + library.define("char=?", [](let const& xs) + { + auto compare = [](let const& a, let const& b) + { + return not (a.as().codepoint == b.as().codepoint); + }; + + return std::adjacent_find(xs.begin(), xs.end(), compare) == xs.end(); + }); + + library.define("char().codepoint < b.as().codepoint); + }; + + return std::adjacent_find(xs.begin(), xs.end(), compare) == xs.end(); + }); + + library.define("char>?", [](let const& xs) + { + auto compare = [](let const& a, let const& b) + { + return not (a.as().codepoint > b.as().codepoint); + }; + + return std::adjacent_find(xs.begin(), xs.end(), compare) == xs.end(); + }); + + library.define("char<=?", [](let const& xs) + { + auto compare = [](let const& a, let const& b) + { + return not (a.as().codepoint <= b.as().codepoint); + }; + + return std::adjacent_find(xs.begin(), xs.end(), compare) == xs.end(); + }); + + library.define("char>=?", [](let const& xs) + { + auto compare = [](let const& a, let const& b) + { + return not (a.as().codepoint >= b.as().codepoint); + }; + + return std::adjacent_find(xs.begin(), xs.end(), compare) == xs.end(); + }); + library.define("char-alphabetic?", [](let const& xs) { return xs[0].as().property().is_letter(); From 833452edae13ed24987ec2da2d0ec00cf72108c9 Mon Sep 17 00:00:00 2001 From: yamacir-kit Date: Tue, 3 Oct 2023 23:23:56 +0900 Subject: [PATCH 20/32] Update character case-insensitive comparison procedures to built-in Signed-off-by: yamacir-kit --- README.md | 6 +++--- VERSION | 2 +- basis/r4rs.ss | 32 +---------------------------- src/kernel/boot.cpp | 50 +++++++++++++++++++++++++++++++++++++++++++++ 4 files changed, 55 insertions(+), 35 deletions(-) diff --git a/README.md b/README.md index cb441be31..a27820e2b 100644 --- a/README.md +++ b/README.md @@ -99,7 +99,7 @@ Procedures for each standard are provided by the following R7RS-style libraries: cmake -B build -DCMAKE_BUILD_TYPE=Release cd build make package -sudo apt install build/meevax_0.5.19_amd64.deb +sudo apt install build/meevax_0.5.20_amd64.deb ``` or @@ -131,9 +131,9 @@ sudo rm -rf /usr/local/share/meevax | Target Name | Description |-------------|------------- -| `all` | Build shared-library `libmeevax.0.5.19.so` and executable `meevax` +| `all` | Build shared-library `libmeevax.0.5.20.so` and executable `meevax` | `test` | Test executable `meevax` -| `package` | Generate debian package `meevax_0.5.19_amd64.deb` +| `package` | Generate debian package `meevax_0.5.20_amd64.deb` | `install` | Copy files into `/usr/local` directly ## Usage diff --git a/VERSION b/VERSION index 5ca9ac67b..50258327c 100644 --- a/VERSION +++ b/VERSION @@ -1 +1 @@ -0.5.19 +0.5.20 diff --git a/basis/r4rs.ss b/basis/r4rs.ss index e26868255..676e8af0c 100644 --- a/basis/r4rs.ss +++ b/basis/r4rs.ss @@ -36,13 +36,7 @@ (define-library (scheme r4rs) (import (only (meevax boolean) boolean? not) - (only (meevax character) - char? - char=? char? char<=? char>=? - char-alphabetic? char-numeric? char-whitespace? char-upper-case? char-lower-case? - char->integer integer->char - char-upcase char-downcase - ) + (only (meevax character) char? char=? char? char<=? char>=? char-ci=? char-ci? char-ci<=? char-ci>=? char-alphabetic? char-numeric? char-whitespace? char-upper-case? char-lower-case? char->integer integer->char char-upcase char-downcase) (only (meevax core) begin define define-syntax if lambda letrec quote set!) (only (meevax comparator) eq? eqv? equal?) (only (meevax complex) make-rectangular make-polar real-part imag-part magnitude angle) @@ -342,30 +336,6 @@ (simplest-rational (- x e) (+ x e))) - (define (char-ci-compare x xs compare) ; Chibi-Scheme - (let rec ((compare compare) - (lhs (char->integer (char-downcase x))) - (xs xs)) - (if (null? xs) #t - (let ((rhs (char->integer (char-downcase (car xs))))) - (and (compare lhs rhs) - (rec compare rhs (cdr xs))))))) - - (define (char-ci=? x . xs) ; Chibi-Scheme - (char-ci-compare x xs =)) - - (define (char-ci? x . xs) ; Chibi-Scheme - (char-ci-compare x xs >)) - - (define (char-ci<=? x . xs) ; Chibi-Scheme - (char-ci-compare x xs <=)) - - (define (char-ci>=? x . xs) ; Chibi-Scheme - (char-ci-compare x xs >=)) - (define (string . xs) ; Chibi-Scheme (list->string xs)) diff --git a/src/kernel/boot.cpp b/src/kernel/boot.cpp index 8e84c8b9c..ca43bff93 100644 --- a/src/kernel/boot.cpp +++ b/src/kernel/boot.cpp @@ -132,6 +132,56 @@ inline namespace kernel return std::adjacent_find(xs.begin(), xs.end(), compare) == xs.end(); }); + library.define("char-ci=?", [](let const& xs) + { + auto compare = [](let const& a, let const& b) + { + return not (a.as().downcase() == b.as().downcase()); + }; + + return std::adjacent_find(xs.begin(), xs.end(), compare) == xs.end(); + }); + + library.define("char-ci().downcase() < b.as().downcase()); + }; + + return std::adjacent_find(xs.begin(), xs.end(), compare) == xs.end(); + }); + + library.define("char-ci>?", [](let const& xs) + { + auto compare = [](let const& a, let const& b) + { + return not (a.as().downcase() > b.as().downcase()); + }; + + return std::adjacent_find(xs.begin(), xs.end(), compare) == xs.end(); + }); + + library.define("char-ci<=?", [](let const& xs) + { + auto compare = [](let const& a, let const& b) + { + return not (a.as().downcase() <= b.as().downcase()); + }; + + return std::adjacent_find(xs.begin(), xs.end(), compare) == xs.end(); + }); + + library.define("char-ci>=?", [](let const& xs) + { + auto compare = [](let const& a, let const& b) + { + return not (a.as().downcase() >= b.as().downcase()); + }; + + return std::adjacent_find(xs.begin(), xs.end(), compare) == xs.end(); + }); + library.define("char-alphabetic?", [](let const& xs) { return xs[0].as().property().is_letter(); From 159e7cdc025a8853b9cd14ea46e3609d7de4ffbc Mon Sep 17 00:00:00 2001 From: yamacir-kit Date: Tue, 3 Oct 2023 23:54:56 +0900 Subject: [PATCH 21/32] Update procedure `list?` to built-in Signed-off-by: yamacir-kit --- README.md | 6 +++--- VERSION | 2 +- basis/r4rs.ss | 26 ++++++++++++-------------- include/meevax/kernel/list.hpp | 2 ++ src/kernel/boot.cpp | 5 +++++ src/kernel/list.cpp | 27 +++++++++++++++++++++++++++ 6 files changed, 50 insertions(+), 18 deletions(-) diff --git a/README.md b/README.md index a27820e2b..664801a29 100644 --- a/README.md +++ b/README.md @@ -99,7 +99,7 @@ Procedures for each standard are provided by the following R7RS-style libraries: cmake -B build -DCMAKE_BUILD_TYPE=Release cd build make package -sudo apt install build/meevax_0.5.20_amd64.deb +sudo apt install build/meevax_0.5.21_amd64.deb ``` or @@ -131,9 +131,9 @@ sudo rm -rf /usr/local/share/meevax | Target Name | Description |-------------|------------- -| `all` | Build shared-library `libmeevax.0.5.20.so` and executable `meevax` +| `all` | Build shared-library `libmeevax.0.5.21.so` and executable `meevax` | `test` | Test executable `meevax` -| `package` | Generate debian package `meevax_0.5.20_amd64.deb` +| `package` | Generate debian package `meevax_0.5.21_amd64.deb` | `install` | Copy files into `/usr/local` directly ## Usage diff --git a/VERSION b/VERSION index 50258327c..72cb8685e 100644 --- a/VERSION +++ b/VERSION @@ -1 +1 @@ -0.5.20 +0.5.21 diff --git a/basis/r4rs.ss b/basis/r4rs.ss index 676e8af0c..b83708113 100644 --- a/basis/r4rs.ss +++ b/basis/r4rs.ss @@ -44,7 +44,18 @@ (prefix (only (meevax environment) load) %) (only (meevax function) procedure?) (only (meevax inexact) exp log sqrt sin cos tan asin acos atan) - (meevax list) + (only (meevax list) + null? + list? + list + length + append + reverse + list-tail + list-ref + memq memv + assq assv + ) (only (meevax macro-transformer) er-macro-transformer identifier?) (only (meevax number) number? complex? real? rational? integer? exact? inexact? = < > <= >= zero? positive? negative? odd? even? max min + * - / abs quotient remainder modulo gcd lcm numerator denominator floor ceiling truncate round expt exact inexact number->string string->number) (meevax pair) @@ -281,19 +292,6 @@ `(,(rename 'let) ((,(rename 'result) ,(cadr form))) ,(each-clause (cddr form)))))) - (define (list? x) - (let list? ((x x) - (lag x)) - (if (pair? x) - (let ((x (cdr x))) - (if (pair? x) - (let ((x (cdr x)) - (lag (cdr lag))) - (and (not (eq? x lag)) - (list? x lag))) - (null? x))) - (null? x)))) - (define (member x xs . compare) ; Chibi-Scheme (let ((compare (if (pair? compare) (car compare) equal?))) (let member ((xs xs)) diff --git a/include/meevax/kernel/list.hpp b/include/meevax/kernel/list.hpp index 357c16705..3b8b6c0cd 100644 --- a/include/meevax/kernel/list.hpp +++ b/include/meevax/kernel/list.hpp @@ -105,6 +105,8 @@ inline namespace kernel auto make_list(std::size_t, object const& = unit) -> object; + auto is_list(object const&) -> bool; + template auto tail(T&& x, std::size_t size) -> decltype(x) { diff --git a/src/kernel/boot.cpp b/src/kernel/boot.cpp index ca43bff93..415d1acc8 100644 --- a/src/kernel/boot.cpp +++ b/src/kernel/boot.cpp @@ -575,6 +575,11 @@ inline namespace kernel return xs[0].is(); }); + library.define("list?", [](let const& xs) + { + return is_list(xs[0]); + }); + library.define("list", [](let const& xs) -> auto const& { return xs; diff --git a/src/kernel/list.cpp b/src/kernel/list.cpp index 97c835531..174c8cc08 100644 --- a/src/kernel/list.cpp +++ b/src/kernel/list.cpp @@ -26,6 +26,33 @@ inline namespace kernel return 0 < size ? cons(x, make_list(--size, x)) : unit; } + auto is_list(object const& x0, object const& y0) -> bool + { + if (x0.is()) + { + if (let const& x1 = cdr(x0); x1.is()) + { + let const& x2 = cdr(x1), + y1 = cdr(y0); + + return not eq(x2, y1) and is_list(x2, y1); + } + else + { + return x1.is(); + } + } + else + { + return x0.is(); + } + } + + auto is_list(object const& xs) -> bool + { + return is_list(xs, xs); + } + auto last(object const& xs) -> object const& { return cdr(xs).is() ? last(cdr(xs)) : car(xs); From d43fbaa9fae2a0c1c802f050a96c4a2c99a57cea Mon Sep 17 00:00:00 2001 From: yamacir-kit Date: Wed, 4 Oct 2023 22:03:57 +0900 Subject: [PATCH 22/32] Cleanup library `(meevax string)` Signed-off-by: yamacir-kit --- README.md | 6 +- VERSION | 2 +- basis/r4rs.ss | 62 +++--- include/meevax/kernel/string.hpp | 5 + src/kernel/boot.cpp | 318 +++++++++++++++++-------------- 5 files changed, 212 insertions(+), 181 deletions(-) diff --git a/README.md b/README.md index 664801a29..cb3345cf3 100644 --- a/README.md +++ b/README.md @@ -99,7 +99,7 @@ Procedures for each standard are provided by the following R7RS-style libraries: cmake -B build -DCMAKE_BUILD_TYPE=Release cd build make package -sudo apt install build/meevax_0.5.21_amd64.deb +sudo apt install build/meevax_0.5.22_amd64.deb ``` or @@ -131,9 +131,9 @@ sudo rm -rf /usr/local/share/meevax | Target Name | Description |-------------|------------- -| `all` | Build shared-library `libmeevax.0.5.21.so` and executable `meevax` +| `all` | Build shared-library `libmeevax.0.5.22.so` and executable `meevax` | `test` | Test executable `meevax` -| `package` | Generate debian package `meevax_0.5.21_amd64.deb` +| `package` | Generate debian package `meevax_0.5.22_amd64.deb` | `install` | Copy files into `/usr/local` directly ## Usage diff --git a/VERSION b/VERSION index 72cb8685e..889af62fa 100644 --- a/VERSION +++ b/VERSION @@ -1 +1 @@ -0.5.21 +0.5.22 diff --git a/basis/r4rs.ss b/basis/r4rs.ss index b83708113..4369a1e93 100644 --- a/basis/r4rs.ss +++ b/basis/r4rs.ss @@ -37,33 +37,35 @@ (define-library (scheme r4rs) (import (only (meevax boolean) boolean? not) (only (meevax character) char? char=? char? char<=? char>=? char-ci=? char-ci? char-ci<=? char-ci>=? char-alphabetic? char-numeric? char-whitespace? char-upper-case? char-lower-case? char->integer integer->char char-upcase char-downcase) - (only (meevax core) begin define define-syntax if lambda letrec quote set!) (only (meevax comparator) eq? eqv? equal?) (only (meevax complex) make-rectangular make-polar real-part imag-part magnitude angle) (only (meevax continuation) call-with-current-continuation) - (prefix (only (meevax environment) load) %) + (only (meevax core) begin define define-syntax if lambda letrec quote set!) (only (meevax function) procedure?) (only (meevax inexact) exp log sqrt sin cos tan asin acos atan) - (only (meevax list) - null? - list? - list - length - append - reverse - list-tail - list-ref - memq memv - assq assv - ) + (only (meevax list) null? list? list length append reverse list-tail list-ref memq memv assq assv) (only (meevax macro-transformer) er-macro-transformer identifier?) (only (meevax number) number? complex? real? rational? integer? exact? inexact? = < > <= >= zero? positive? negative? odd? even? max min + * - / abs quotient remainder modulo gcd lcm numerator denominator floor ceiling truncate round expt exact inexact number->string string->number) - (meevax pair) + (only (meevax pair) pair? cons car cdr set-car! set-cdr! caar cadr cdar cddr caaar caadr cadar caddr cdaar cdadr cddar cdddr caaaar caaadr caadar caaddr cadaar cadadr caddar cadddr cdaaar cdaadr cdadar cdaddr cddaar cddadr cdddar cddddr) (meevax port) - (prefix (meevax read) %) - (meevax string) - (meevax symbol) + (only (meevax string) + string? + make-string string + string-length string-ref string-set! + string=? string? string<=? string>=? + ; string-ci=? + ; string-ci? + ; string-ci<=? + ; string-ci>=? + string-append + string->list list->string + string-copy string-fill! + ) + (only (meevax symbol) symbol? symbol->string string->symbol) (meevax vector) + (prefix (only (meevax environment) load) %) + (prefix (meevax read) %) (prefix (meevax write) %) (only (srfi 45) delay force)) @@ -87,15 +89,16 @@ char-downcase string? make-string string string-length string-ref string-set! string=? string? string<=? string>=? string-ci=? string-ci? string-ci<=? string-ci>=? - substring string-append string->list list->string string-copy - string-fill! vector? make-vector vector vector-length vector-ref - vector-set! vector->list list->vector vector-fill! procedure? apply - map for-each force call-with-current-continuation - call-with-input-file call-with-output-file input-port? output-port? - current-input-port current-output-port with-input-from-file - with-output-to-file open-input-file open-output-file close-input-port - close-output-port read read-char peek-char eof-object? char-ready? - write display newline write-char load) + (rename string-copy substring) string-append string->list + list->string string-copy string-fill! vector? make-vector vector + vector-length vector-ref vector-set! vector->list list->vector + vector-fill! procedure? apply map for-each force + call-with-current-continuation call-with-input-file + call-with-output-file input-port? output-port? current-input-port + current-output-port with-input-from-file with-output-to-file + open-input-file open-output-file close-input-port close-output-port + read read-char peek-char eof-object? char-ready? write display + newline write-char load) (begin (define-syntax cond ; Chibi-Scheme (er-macro-transformer @@ -334,9 +337,6 @@ (simplest-rational (- x e) (+ x e))) - (define (string . xs) ; Chibi-Scheme - (list->string xs)) - (define (string-map f x . xs) ; R7RS (if (null? xs) (list->string (map f (string->list x))) @@ -360,8 +360,6 @@ (define (string-ci>=? . xs) (apply string>=? (map string-foldcase xs))) - (define substring string-copy) - (define (for-each f x . xs) ; Chibi-Scheme (if (null? xs) (letrec ((for-each (lambda (f x) diff --git a/include/meevax/kernel/string.hpp b/include/meevax/kernel/string.hpp index 099769754..2103cf578 100644 --- a/include/meevax/kernel/string.hpp +++ b/include/meevax/kernel/string.hpp @@ -33,6 +33,11 @@ inline namespace kernel explicit string(std::size_t const, character const&); + template + explicit string(Iterator begin, Iterator end) + : vector { begin, end } + {} + operator std::string() const; }; diff --git a/src/kernel/boot.cpp b/src/kernel/boot.cpp index 415d1acc8..80d09e55a 100644 --- a/src/kernel/boot.cpp +++ b/src/kernel/boot.cpp @@ -1143,130 +1143,215 @@ inline namespace kernel library.define("make-string", [](let const& xs) { - /* - (make-string k) procedure - (make-string k char) procedure + switch (length(xs)) + { + case 1: + return make(xs[0].as(), character()); - 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. - */ + case 2: + return make(xs[0].as(), xs[1].as()); - return make(xs[0].as(), - 1 < length(xs) ? xs[1].as() : character()); + default: + throw error(make("procedure make-string takes one or two arugments, but got"), xs); + } }); - library.define("string-length", [](let const& xs) + library.define("string", [](let const& xs) { - /* - (string-length string) procedure + let s = make(); - Returns the number of characters in the given string. - */ + for (let const& x : xs) + { + s.as().vector.push_back(x.as()); + } + + return s; + }); + library.define("string-length", [](let const& xs) + { return make(xs[0].as().vector.size()); }); library.define("string-ref", [](let const& xs) { - /* - (string-ref string k) procedure + return make(xs[0].as().vector.at(xs[1].as())); + }); - It is an error if k is not a valid index of string. + library.define("string-set!", [](let & xs) + { + xs[0].as().vector.at(xs[1].as()) = xs[2].as(); + }); - 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. - */ + library.define("string=?", [](let const& xs) + { + auto compare = [](let const& a, let const& b) + { + return not (a.as().vector == b.as().vector); + }; - return make(xs[0].as().vector.at(xs[1].as())); + return std::adjacent_find(xs.begin(), xs.end(), compare) == xs.end(); }); - library.define("string-set!", [](let & xs) + library.define("string().vector < b.as().vector); + }; - It is an error if k is not a valid index of string. + return std::adjacent_find(xs.begin(), xs.end(), compare) == xs.end(); + }); - The string-set! procedure stores char in element k of string. There - is no requirement for this procedure to execute in constant time. - */ + library.define("string>?", [](let const& xs) + { + auto compare = [](let const& a, let const& b) + { + return not (a.as().vector > b.as().vector); + }; - xs[0].as().vector.at(xs[1].as()) = xs[2].as(); + return std::adjacent_find(xs.begin(), xs.end(), compare) == xs.end(); }); - library.define("string-append", [](let const& xs) + library.define("string<=?", [](let const& xs) { - /* - (string-append string ...) procedure + auto compare = [](let const& a, let const& b) + { + return not (a.as().vector <= b.as().vector); + }; - Returns a newly allocated string whose characters are the - concatenation of the characters in the given strings. - */ + return std::adjacent_find(xs.begin(), xs.end(), compare) == xs.end(); + }); + + library.define("string>=?", [](let const& xs) + { + auto compare = [](let const& a, let const& b) + { + return not (a.as().vector >= b.as().vector); + }; - auto&& s = string(); + return std::adjacent_find(xs.begin(), xs.end(), compare) == xs.end(); + }); + + library.define("string-append", [](let const& xs) + { + let s = make(); for (let const& x : xs) { - std::copy(std::begin(x.as().vector), - std::end(x.as().vector), - std::back_inserter(s.vector)); + s.as().vector.insert(s.as().vector.end(), + x.as().vector.begin(), + x.as().vector.end()); } - return make(std::forward(s)); + return s; }); - library.define("string-copy", [](let const& xs) + library.define("string->list", [](let const& xs) { - /* - (string-copy string) procedure - (string-copy string start) procedure - (string-copy string start end) procedure + auto push = [](let const& xs, character const& c) + { + return cons(make(c), xs); + }; - Returns a newly allocated copy of the part of the given string - between start and end. - */ + switch (length(xs)) + { + case 1: + return std::accumulate(xs[0].as().vector.rbegin(), + xs[0].as().vector.rend(), + unit, + push); - auto&& s = string(); + case 2: + return std::accumulate(xs[0].as().vector.rbegin(), + std::prev(xs[0].as().vector.rend(), + xs[1].as()), + unit, + push); - std::copy(std::next(std::begin(xs[0].as().vector), 1 < length(xs) ? xs[1].as() : 0), - std::next(std::begin(xs[0].as().vector), 2 < length(xs) ? xs[2].as() : xs[0].as().vector.size()), - std::back_inserter(s.vector)); + case 3: + return std::accumulate(std::prev(xs[0].as().vector.rend(), + xs[2].as()), + std::prev(xs[0].as().vector.rend(), + xs[1].as()), + unit, + push); - return make(s); + default: + throw error(make("procedure string->list takes one to three arugments, but got"), xs); + } }); - library.define("string-copy!", [](let const& xs) + library.define("list->string", [](let const& xs) { - /* - (string-copy! to at from) procedure - (string-copy! to at from start) procedure - (string-copy! to at from start end) procedure + let s = make(); - 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). + for (let const& x : xs[0]) + { + s.as().vector.push_back(x.as()); + } - 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. - */ + return s; + }); - auto&& s1 = xs[0].as().vector; + library.define("string-copy", [](let const& xs) + { + switch (length(xs)) + { + case 1: + return make(xs[0].as().vector.begin(), + xs[0].as().vector.end()); + + case 2: + return make(std::next(xs[0].as().vector.begin(), + xs[1].as()), + xs[0].as().vector.end()); - auto&& s2 = xs[2].as().vector; + case 3: + return make(std::next(xs[0].as().vector.begin(), + xs[1].as()), + std::next(xs[0].as().vector.begin(), + xs[2].as())); - s1.reserve(s1.size() + s2.size()); + default: + throw error(make("procedure string-copy takes one to three arugments, but got"), xs); + } + }); - std::copy(std::next(std::begin(s2), 3 < length(xs) ? xs[3].as() : 0), - std::next(std::begin(s2), 4 < length(xs) ? xs[4].as() : s2.size()), - std::next(std::begin(s1), xs[1].as())); + library.define("string-copy!", [](let const& xs) + { + xs[0].as().vector.reserve(xs[0].as().vector.size() + + xs[2].as().vector.size()); + + switch (length(xs)) + { + case 3: + std::copy(xs[2].as().vector.begin(), + xs[2].as().vector.end(), + std::next(xs[0].as().vector.begin(), + xs[1].as())); + break; + + case 4: + std::copy(std::next(xs[2].as().vector.begin(), + xs[3].as()), + xs[2].as().vector.end(), + std::next(xs[0].as().vector.begin(), + xs[1].as())); + break; + + case 5: + std::copy(std::next(xs[2].as().vector.begin(), + xs[3].as()), + std::next(xs[2].as().vector.begin(), + xs[4].as()), + std::next(xs[0].as().vector.begin(), + xs[1].as())); + break; + + default: + throw error(make("procedure string-copy takes three to five arugments, but got"), xs); + } }); library.define("string-fill!", [](let & xs) @@ -1293,27 +1378,19 @@ inline namespace kernel xs[3].as()), xs[1].as()); break; + + default: + throw error(make("procedure string-fill! takes one to three arugments, but got"), 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().vector, \ - b.as_const().vector); \ - }) == std::end(xs); \ - } - - library.define("string=?", STRING_COMPARE(std::equal_to )); - library.define("string("string<=?", STRING_COMPARE(std::less_equal )); - library.define("string>?", STRING_COMPARE(std::greater )); - library.define("string>=?", STRING_COMPARE(std::greater_equal)); - - #undef STRING_COMPARE + define("(meevax symbol)", [](library & library) + { + library.define("symbol?", [](let const& xs) + { + return xs[0].is(); + }); library.define("symbol->string", [](let const& xs) { @@ -1325,58 +1402,9 @@ inline namespace kernel return make_symbol(xs[0].as()); }); - library.define("string->list", [](let const& xs) - { - /* - (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. - */ - - return std::accumulate(std::prev(std::rend(xs[0].as().vector), 2 < length(xs) ? xs[2].as() : xs[0].as().vector.size()), - std::prev(std::rend(xs[0].as().vector), 1 < length(xs) ? xs[1].as() : 0), - unit, - [](let const& xs, character const& c) - { - return cons(make(c), xs); - }); - }); - - library.define("list->string", [](let const& xs) - { - auto&& s = string(); - - for (let const& x : xs[0]) - { - s.vector.push_back(x.as()); - } - - return make(std::forward(s)); - }); - }); - - define("(meevax symbol)", [](library & library) - { - library.define("symbol?", [](let const& xs) - { - return xs[0].is(); - }); - - using syntactic_closure = environment::syntactic_closure; - library.define("identifier->symbol", [](let const& xs) { - if (let const& x = xs[0]; x.is()) + if (let const& x = xs[0]; x.is()) { return cddr(x); } From f2752b837fe74ab3ccdca11fdd8fa9cda2f820e7 Mon Sep 17 00:00:00 2001 From: yamacir-kit Date: Sat, 7 Oct 2023 02:37:54 +0900 Subject: [PATCH 23/32] Update string case-insensitive comparison procedures to built-in Signed-off-by: yamacir-kit --- README.md | 6 ++-- VERSION | 2 +- basis/r4rs.ss | 38 +-------------------- src/kernel/boot.cpp | 80 +++++++++++++++++++++++++++++++++++++++++++++ 4 files changed, 85 insertions(+), 41 deletions(-) diff --git a/README.md b/README.md index cb3345cf3..e9efbd550 100644 --- a/README.md +++ b/README.md @@ -99,7 +99,7 @@ Procedures for each standard are provided by the following R7RS-style libraries: cmake -B build -DCMAKE_BUILD_TYPE=Release cd build make package -sudo apt install build/meevax_0.5.22_amd64.deb +sudo apt install build/meevax_0.5.23_amd64.deb ``` or @@ -131,9 +131,9 @@ sudo rm -rf /usr/local/share/meevax | Target Name | Description |-------------|------------- -| `all` | Build shared-library `libmeevax.0.5.22.so` and executable `meevax` +| `all` | Build shared-library `libmeevax.0.5.23.so` and executable `meevax` | `test` | Test executable `meevax` -| `package` | Generate debian package `meevax_0.5.22_amd64.deb` +| `package` | Generate debian package `meevax_0.5.23_amd64.deb` | `install` | Copy files into `/usr/local` directly ## Usage diff --git a/VERSION b/VERSION index 889af62fa..4735fa3a8 100644 --- a/VERSION +++ b/VERSION @@ -1 +1 @@ -0.5.22 +0.5.23 diff --git a/basis/r4rs.ss b/basis/r4rs.ss index 4369a1e93..7723f0117 100644 --- a/basis/r4rs.ss +++ b/basis/r4rs.ss @@ -48,20 +48,7 @@ (only (meevax number) number? complex? real? rational? integer? exact? inexact? = < > <= >= zero? positive? negative? odd? even? max min + * - / abs quotient remainder modulo gcd lcm numerator denominator floor ceiling truncate round expt exact inexact number->string string->number) (only (meevax pair) pair? cons car cdr set-car! set-cdr! caar cadr cdar cddr caaar caadr cadar caddr cdaar cdadr cddar cdddr caaaar caaadr caadar caaddr cadaar cadadr caddar cadddr cdaaar cdaadr cdadar cdaddr cddaar cddadr cdddar cddddr) (meevax port) - (only (meevax string) - string? - make-string string - string-length string-ref string-set! - string=? string? string<=? string>=? - ; string-ci=? - ; string-ci? - ; string-ci<=? - ; string-ci>=? - string-append - string->list list->string - string-copy string-fill! - ) + (only (meevax string) string? make-string string string-length string-ref string-set! string=? string? string<=? string>=? string-ci=? string-ci? string-ci<=? string-ci>=? string-append string->list list->string string-copy string-fill!) (only (meevax symbol) symbol? symbol->string string->symbol) (meevax vector) (prefix (only (meevax environment) load) %) @@ -337,29 +324,6 @@ (simplest-rational (- x e) (+ x e))) - (define (string-map f x . xs) ; R7RS - (if (null? xs) - (list->string (map f (string->list x))) - (list->string (apply map f (map string->list (cons x xs)))))) - - (define (string-foldcase s) ; R7RS - (string-map char-downcase s)) - - (define (string-ci=? . xs) - (apply string=? (map string-foldcase xs))) - - (define (string-ci? . xs) - (apply string>? (map string-foldcase xs))) - - (define (string-ci<=? . xs) - (apply string<=? (map string-foldcase xs))) - - (define (string-ci>=? . xs) - (apply string>=? (map string-foldcase xs))) - (define (for-each f x . xs) ; Chibi-Scheme (if (null? xs) (letrec ((for-each (lambda (f x) diff --git a/src/kernel/boot.cpp b/src/kernel/boot.cpp index 80d09e55a..40424db3b 100644 --- a/src/kernel/boot.cpp +++ b/src/kernel/boot.cpp @@ -1233,6 +1233,86 @@ inline namespace kernel return std::adjacent_find(xs.begin(), xs.end(), compare) == xs.end(); }); + library.define("string-ci=?", [](let const& xs) + { + auto compare = [](let const& s1, let const& s2) + { + auto compare = [](auto const& c1, auto const& c2) + { + return c1.downcase() == c2.downcase(); + }; + + return not std::lexicographical_compare(s1.as().vector.begin(), s1.as().vector.end(), + s2.as().vector.begin(), s2.as().vector.end(), compare); + }; + + return std::adjacent_find(xs.begin(), xs.end(), compare) == xs.end(); + }); + + library.define("string-ci().vector.begin(), s1.as().vector.end(), + s2.as().vector.begin(), s2.as().vector.end(), compare); + }; + + return std::adjacent_find(xs.begin(), xs.end(), compare) == xs.end(); + }); + + library.define("string-ci>?", [](let const& xs) + { + auto compare = [](let const& s1, let const& s2) + { + auto compare = [](auto const& c1, auto const& c2) + { + return c1.downcase() > c2.downcase(); + }; + + return not std::lexicographical_compare(s1.as().vector.begin(), s1.as().vector.end(), + s2.as().vector.begin(), s2.as().vector.end(), compare); + }; + + return std::adjacent_find(xs.begin(), xs.end(), compare) == xs.end(); + }); + + library.define("string-ci<=?", [](let const& xs) + { + auto compare = [](let const& s1, let const& s2) + { + auto compare = [](auto const& c1, auto const& c2) + { + return c1.downcase() <= c2.downcase(); + }; + + return not std::lexicographical_compare(s1.as().vector.begin(), s1.as().vector.end(), + s2.as().vector.begin(), s2.as().vector.end(), compare); + }; + + return std::adjacent_find(xs.begin(), xs.end(), compare) == xs.end(); + }); + + library.define("string-ci>=?", [](let const& xs) + { + auto compare = [](let const& s1, let const& s2) + { + auto compare = [](auto const& c1, auto const& c2) + { + return c1.downcase() >= c2.downcase(); + }; + + return not std::lexicographical_compare(s1.as().vector.begin(), s1.as().vector.end(), + s2.as().vector.begin(), s2.as().vector.end(), compare); + }; + + return std::adjacent_find(xs.begin(), xs.end(), compare) == xs.end(); + }); + library.define("string-append", [](let const& xs) { let s = make(); From 0710a44f63afa7bddfca597cbf2a254156d471ce Mon Sep 17 00:00:00 2001 From: yamacir-kit Date: Sat, 7 Oct 2023 03:25:30 +0900 Subject: [PATCH 24/32] Cleanup library `(meevax vector)` Signed-off-by: yamacir-kit --- README.md | 6 +- VERSION | 2 +- basis/r4rs.ss | 2 +- include/meevax/kernel/vector.hpp | 5 + src/kernel/boot.cpp | 271 +++++++++++++++++-------------- 5 files changed, 155 insertions(+), 131 deletions(-) diff --git a/README.md b/README.md index e9efbd550..bab8442ac 100644 --- a/README.md +++ b/README.md @@ -99,7 +99,7 @@ Procedures for each standard are provided by the following R7RS-style libraries: cmake -B build -DCMAKE_BUILD_TYPE=Release cd build make package -sudo apt install build/meevax_0.5.23_amd64.deb +sudo apt install build/meevax_0.5.24_amd64.deb ``` or @@ -131,9 +131,9 @@ sudo rm -rf /usr/local/share/meevax | Target Name | Description |-------------|------------- -| `all` | Build shared-library `libmeevax.0.5.23.so` and executable `meevax` +| `all` | Build shared-library `libmeevax.0.5.24.so` and executable `meevax` | `test` | Test executable `meevax` -| `package` | Generate debian package `meevax_0.5.23_amd64.deb` +| `package` | Generate debian package `meevax_0.5.24_amd64.deb` | `install` | Copy files into `/usr/local` directly ## Usage diff --git a/VERSION b/VERSION index 4735fa3a8..acdaa1ce1 100644 --- a/VERSION +++ b/VERSION @@ -1 +1 @@ -0.5.23 +0.5.24 diff --git a/basis/r4rs.ss b/basis/r4rs.ss index 7723f0117..de46431b4 100644 --- a/basis/r4rs.ss +++ b/basis/r4rs.ss @@ -50,7 +50,7 @@ (meevax port) (only (meevax string) string? make-string string string-length string-ref string-set! string=? string? string<=? string>=? string-ci=? string-ci? string-ci<=? string-ci>=? string-append string->list list->string string-copy string-fill!) (only (meevax symbol) symbol? symbol->string string->symbol) - (meevax vector) + (only (meevax vector) vector? make-vector vector vector-length vector-ref vector-set! vector->list list->vector vector-fill!) (prefix (only (meevax environment) load) %) (prefix (meevax read) %) (prefix (meevax write) %) diff --git a/include/meevax/kernel/vector.hpp b/include/meevax/kernel/vector.hpp index 2ecb4241f..fb8a7215f 100644 --- a/include/meevax/kernel/vector.hpp +++ b/include/meevax/kernel/vector.hpp @@ -33,6 +33,11 @@ inline namespace kernel explicit heterogeneous_vector(std::size_t, object const&); + template + explicit heterogeneous_vector(Iterator begin, Iterator end) + : vector { begin, end } + {} + auto operator [](std::size_t) const -> object const&; }; diff --git a/src/kernel/boot.cpp b/src/kernel/boot.cpp index 40424db3b..615dcabfa 100644 --- a/src/kernel/boot.cpp +++ b/src/kernel/boot.cpp @@ -1574,137 +1574,195 @@ inline namespace kernel library.define("vector", [](let const& xs) { - /* - (vector obj ...) procedure - - Returns a newly allocated vector whose elements contain the given - arguments. It is analogous to list. - */ - return make(xs); }); library.define("make-vector", [](let const& xs) { - /* - (make-vector k) procedure - (make-vector k fill) procedure + switch (length(xs)) + { + case 1: + return make(xs[0].as(), unspecified); - Returns a newly allocated vector of k elements. If a second argument - is given, then each element is initialized to fill. Otherwise the - initial contents of each element is unspecified. - */ + case 2: + return make(xs[0].as(), xs[1]); - return make(xs[0].as(), 1 < length(xs) ? xs[1] : unspecified); + default: + throw error(make("procedure make-vector takes one or two arugments, but got"), xs); + } }); - library.define("vector-append", [](let const& xs) + library.define("vector-length", [](let const& xs) { - /* - (vector-append vector ...) procedure + return make(xs[0].as().vector.size()); + }); - Returns a newly allocated vector whose elements are the - concatenation of the elements of the given vectors. - */ + library.define("vector-ref", [](let const& xs) -> auto const& + { + return xs[0][xs[1].as()]; + }); - auto&& v = vector(); + library.define("vector-set!", [](let & xs) + { + xs[0].as().vector[xs[1].as()] = xs[2]; + }); - for (let const& x : xs) + library.define("vector->list", [](let const& xs) + { + switch (length(xs)) { - for (let const& object : x.as().vector) - { - v.vector.push_back(object); - } + case 1: + return std::accumulate(xs[0].as().vector.rbegin(), + xs[0].as().vector.rend(), + unit, + xcons); + + case 2: + return std::accumulate(xs[0].as().vector.rbegin(), + std::prev(xs[0].as().vector.rend(), + xs[1].as()), + unit, + xcons); + + case 3: + return std::accumulate(std::prev(xs[0].as().vector.rend(), + xs[2].as()), + std::prev(xs[0].as().vector.rend(), + xs[1].as()), + unit, + xcons); + + default: + throw error(make("procedure vector->list takes one to three arugments, but got"), xs); } + }); - return make(std::forward(v)); + library.define("list->vector", [](let const& xs) + { + return make(xs[0]); }); - library.define("vector-copy", [](let const& xs) + library.define("vector->string", [](let const& xs) { - /* - (vector-copy vector) procedure - (vector-copy vector start) procedure - (vector-copy vector start end) procedure + let s = make(); - 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 push_back = [&](let const& x) + { + s.as().vector.push_back(x.as()); + }; - auto&& v = vector(); + switch (length(xs)) + { + case 1: + std::for_each(xs[0].as().vector.begin(), + xs[0].as().vector.end(), + push_back); + return s; + + case 2: + std::for_each(std::next(xs[0].as().vector.begin(), + xs[1].as()), + xs[0].as().vector.end(), + push_back); + return s; - std::copy(std::next(std::begin(xs[0].as().vector), 1 < length(xs) ? xs[1].as() : 0), - std::next(std::begin(xs[0].as().vector), 2 < length(xs) ? xs[2].as() : xs[0].as().vector.size()), - std::back_inserter(v.vector)); + case 3: + std::for_each(std::next(xs[0].as().vector.begin(), + xs[1].as()), + std::next(xs[0].as().vector.begin(), + xs[2].as()), + push_back); + return s; - return make(std::forward(v)); + default: + throw error(make("procedure vector->list takes one to three arugments, but got"), xs); + } }); - library.define("vector-copy!", [](let const& xs) + library.define("string->vector", [](let const& xs) { - /* - (vector-copy! to at from) procedure - (vector-copy! to at from start) procedure - (vector-copy! to at from start end) procedure + let v = make(); - 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). + for (auto character : xs[0].as().vector) + { + v.as().vector.push_back(make(character)); + } - 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. - */ + return v; + }); - auto&& v1 = xs[0].as().vector; + library.define("vector-copy", [](let const& xs) + { + switch (length(xs)) + { + case 1: + return make(xs[0].as().vector.begin(), + xs[0].as().vector.end()); - auto&& v2 = xs[2].as().vector; + case 2: + return make(std::next(xs[0].as().vector.begin(), + xs[1].as()), + xs[0].as().vector.end()); - v1.reserve(v1.size() + v2.size()); + case 3: + return make(std::next(xs[0].as().vector.begin(), + xs[1].as()), + std::next(xs[0].as().vector.begin(), + xs[2].as())); - std::copy(std::next(std::begin(v2), 3 < length(xs) ? xs[3].as() : 0), - std::next(std::begin(v2), 4 < length(xs) ? xs[4].as() : v1.size()), - std::next(std::begin(v1), xs[1].as())); + default: + throw error(make("procedure vector-copy takes one to three arugments, but got"), xs); + } }); - library.define("vector-length", [](let const& xs) + library.define("vector-copy!", [](let const& xs) { - /* - (vector-length vector) procedure - - Returns the number of elements in vector as an exact integer. - */ + xs[0].as().vector.reserve(xs[0].as().vector.size() + + xs[2].as().vector.size()); - return make(xs[0].as().vector.size()); - }); + switch (length(xs)) + { + case 3: + std::copy(xs[2].as().vector.begin(), + xs[2].as().vector.end(), + std::next(xs[0].as().vector.begin(), + xs[1].as())); + break; - library.define("vector-ref", [](let const& xs) -> auto const& - { - /* - (vector-ref vector k) procedure + case 4: + std::copy(std::next(xs[2].as().vector.begin(), + xs[3].as()), + xs[2].as().vector.end(), + std::next(xs[0].as().vector.begin(), + xs[1].as())); + break; - It is an error if k is not a valid index of vector. The vector-ref - procedure returns the contents of element k of vector. - */ + case 5: + std::copy(std::next(xs[2].as().vector.begin(), + xs[3].as()), + std::next(xs[2].as().vector.begin(), + xs[4].as()), + std::next(xs[0].as().vector.begin(), + xs[1].as())); + break; - return xs[0][xs[1].as()]; + default: + throw error(make("procedure vector-copy takes three to five arugments, but got"), xs); + } }); - library.define("vector-set!", [](let & xs) + library.define("vector-append", [](let const& xs) { - /* - (vector-set! vector k obj) procedure + let v = make(); - It is an error if k is not a valid index of vector. The vector-set! - procedure stores obj in element k of vector. - */ + for (let const& x : xs) + { + v.as().vector.insert(v.as().vector.end(), + x.as().vector.begin(), + x.as().vector.end()); + } - xs[0].as().vector[xs[1].as()] = xs[2]; + return v; }); library.define("vector-fill!", [](let & xs) @@ -1733,45 +1791,6 @@ inline namespace kernel break; } }); - - library.define("vector->list", [](let const& xs) - { - return std::accumulate(std::prev(std::rend(xs[0].as().vector), 2 < length(xs) ? xs[2].as() : xs[0].as().vector.size()), - std::prev(std::rend(xs[0].as().vector), 1 < length(xs) ? xs[1].as() : 0), - unit, - xcons); - }); - - library.define("list->vector", [](let const& xs) - { - return make(xs[0]); - }); - - library.define("vector->string", [](let const& xs) - { - auto s = string(); - - std::for_each(std::next(std::begin(xs[0].as().vector), 1 < length(xs) ? xs[1].as() : 0), - std::next(std::begin(xs[0].as().vector), 2 < length(xs) ? xs[2].as() : xs[0].as().vector.size()), - [&](let const& x) - { - s.vector.push_back(x.as()); - }); - - return make(s); - }); - - library.define("string->vector", [](let const& xs) - { - auto v = vector(); - - for (auto&& character : xs[0].as().vector) - { - v.vector.push_back(make(character)); - } - - return make(v); - }); }); define("(meevax vector homogeneous)", [](library & library) From 24c199dff4ebf9d12b880f6b59812ef4fd7ff42b Mon Sep 17 00:00:00 2001 From: yamacir-kit Date: Sat, 7 Oct 2023 03:37:39 +0900 Subject: [PATCH 25/32] Cleanup Signed-off-by: yamacir-kit --- README.md | 6 +++--- VERSION | 2 +- basis/r4rs.ss | 2 +- 3 files changed, 5 insertions(+), 5 deletions(-) diff --git a/README.md b/README.md index bab8442ac..3f8d13d18 100644 --- a/README.md +++ b/README.md @@ -99,7 +99,7 @@ Procedures for each standard are provided by the following R7RS-style libraries: cmake -B build -DCMAKE_BUILD_TYPE=Release cd build make package -sudo apt install build/meevax_0.5.24_amd64.deb +sudo apt install build/meevax_0.5.25_amd64.deb ``` or @@ -131,9 +131,9 @@ sudo rm -rf /usr/local/share/meevax | Target Name | Description |-------------|------------- -| `all` | Build shared-library `libmeevax.0.5.24.so` and executable `meevax` +| `all` | Build shared-library `libmeevax.0.5.25.so` and executable `meevax` | `test` | Test executable `meevax` -| `package` | Generate debian package `meevax_0.5.24_amd64.deb` +| `package` | Generate debian package `meevax_0.5.25_amd64.deb` | `install` | Copy files into `/usr/local` directly ## Usage diff --git a/VERSION b/VERSION index acdaa1ce1..c98d62af7 100644 --- a/VERSION +++ b/VERSION @@ -1 +1 @@ -0.5.24 +0.5.25 diff --git a/basis/r4rs.ss b/basis/r4rs.ss index de46431b4..2e195dc59 100644 --- a/basis/r4rs.ss +++ b/basis/r4rs.ss @@ -47,7 +47,7 @@ (only (meevax macro-transformer) er-macro-transformer identifier?) (only (meevax number) number? complex? real? rational? integer? exact? inexact? = < > <= >= zero? positive? negative? odd? even? max min + * - / abs quotient remainder modulo gcd lcm numerator denominator floor ceiling truncate round expt exact inexact number->string string->number) (only (meevax pair) pair? cons car cdr set-car! set-cdr! caar cadr cdar cddr caaar caadr cadar caddr cdaar cdadr cddar cdddr caaaar caaadr caadar caaddr cadaar cadadr caddar cadddr cdaaar cdaadr cdadar cdaddr cddaar cddadr cdddar cddddr) - (meevax port) + (only (meevax port) input-port? output-port? standard-input-port standard-output-port open-input-file open-output-file close eof-object?) (only (meevax string) string? make-string string string-length string-ref string-set! string=? string? string<=? string>=? string-ci=? string-ci? string-ci<=? string-ci>=? string-append string->list list->string string-copy string-fill!) (only (meevax symbol) symbol? symbol->string string->symbol) (only (meevax vector) vector? make-vector vector vector-length vector-ref vector-set! vector->list list->vector vector-fill!) From 256e1186e79343087359e9c02f21556e7e2ebcc9 Mon Sep 17 00:00:00 2001 From: yamacir-kit Date: Sat, 7 Oct 2023 10:46:00 +0900 Subject: [PATCH 26/32] Rename library `(meevax function)` to `(meevax procedure)` Signed-off-by: yamacir-kit --- README.md | 6 ++--- VERSION | 2 +- basis/r4rs.ss | 2 +- example/example.ss | 2 +- src/kernel/boot.cpp | 57 ++++++++++++++++++++++----------------------- test/tail-call.ss | 2 +- 6 files changed, 35 insertions(+), 36 deletions(-) diff --git a/README.md b/README.md index 3f8d13d18..8190e003b 100644 --- a/README.md +++ b/README.md @@ -99,7 +99,7 @@ Procedures for each standard are provided by the following R7RS-style libraries: cmake -B build -DCMAKE_BUILD_TYPE=Release cd build make package -sudo apt install build/meevax_0.5.25_amd64.deb +sudo apt install build/meevax_0.5.26_amd64.deb ``` or @@ -131,9 +131,9 @@ sudo rm -rf /usr/local/share/meevax | Target Name | Description |-------------|------------- -| `all` | Build shared-library `libmeevax.0.5.25.so` and executable `meevax` +| `all` | Build shared-library `libmeevax.0.5.26.so` and executable `meevax` | `test` | Test executable `meevax` -| `package` | Generate debian package `meevax_0.5.25_amd64.deb` +| `package` | Generate debian package `meevax_0.5.26_amd64.deb` | `install` | Copy files into `/usr/local` directly ## Usage diff --git a/VERSION b/VERSION index c98d62af7..0ef0d6989 100644 --- a/VERSION +++ b/VERSION @@ -1 +1 @@ -0.5.25 +0.5.26 diff --git a/basis/r4rs.ss b/basis/r4rs.ss index 2e195dc59..71a31bfff 100644 --- a/basis/r4rs.ss +++ b/basis/r4rs.ss @@ -41,13 +41,13 @@ (only (meevax complex) make-rectangular make-polar real-part imag-part magnitude angle) (only (meevax continuation) call-with-current-continuation) (only (meevax core) begin define define-syntax if lambda letrec quote set!) - (only (meevax function) procedure?) (only (meevax inexact) exp log sqrt sin cos tan asin acos atan) (only (meevax list) null? list? list length append reverse list-tail list-ref memq memv assq assv) (only (meevax macro-transformer) er-macro-transformer identifier?) (only (meevax number) number? complex? real? rational? integer? exact? inexact? = < > <= >= zero? positive? negative? odd? even? max min + * - / abs quotient remainder modulo gcd lcm numerator denominator floor ceiling truncate round expt exact inexact number->string string->number) (only (meevax pair) pair? cons car cdr set-car! set-cdr! caar cadr cdar cddr caaar caadr cadar caddr cdaar cdadr cddar cdddr caaaar caaadr caadar caaddr cadaar cadadr caddar cadddr cdaaar cdaadr cdadar cdaddr cddaar cddadr cdddar cddddr) (only (meevax port) input-port? output-port? standard-input-port standard-output-port open-input-file open-output-file close eof-object?) + (only (meevax procedure) procedure?) (only (meevax string) string? make-string string string-length string-ref string-set! string=? string? string<=? string>=? string-ci=? string-ci? string-ci<=? string-ci>=? string-append string->list list->string string-copy string-fill!) (only (meevax symbol) symbol? symbol->string string->symbol) (only (meevax vector) vector? make-vector vector vector-length vector-ref vector-set! vector->list list->vector vector-fill!) diff --git a/example/example.ss b/example/example.ss index fc4d9bb74..8cab58dbe 100644 --- a/example/example.ss +++ b/example/example.ss @@ -1,4 +1,4 @@ -(import (only (meevax function) foreign-function? foreign-function) +(import (only (meevax procedure) foreign-function? foreign-function) (scheme base) (scheme process-context) (scheme write) diff --git a/src/kernel/boot.cpp b/src/kernel/boot.cpp index 615dcabfa..7bc0255b8 100644 --- a/src/kernel/boot.cpp +++ b/src/kernel/boot.cpp @@ -431,35 +431,6 @@ inline namespace kernel }); }); - define("(meevax function)", [](library & library) - { - library.define("procedure?", [](let const& xs) - { - let const& x = xs[0]; - return x.is() or x.is() or x.is_also(); - }); - - library.define("closure?", [](let const& xs) - { - return xs[0].is(); - }); - - library.define("continuation?", [](let const& xs) - { - return xs[0].is(); - }); - - library.define("foreign-function?", [](let const& xs) - { - return xs[0].is_also(); - }); - - library.define("foreign-function", [](let const& xs) - { - return make(xs[1].as(), xs[0].as()); - }); - }); - define("(meevax garbage-collector)", [](library & library) { library.define("gc-collect", [](let const&) @@ -1081,6 +1052,34 @@ inline namespace kernel }); }); + define("(meevax procedure)", [](library & library) + { + library.define("procedure?", [](let const& xs) + { + return xs[0].is() or xs[0].is() or xs[0].is_also(); + }); + + library.define("closure?", [](let const& xs) + { + return xs[0].is(); + }); + + library.define("continuation?", [](let const& xs) + { + return xs[0].is(); + }); + + library.define("foreign-function?", [](let const& xs) + { + return xs[0].is_also(); + }); + + library.define("foreign-function", [](let const& xs) + { + return make(xs[1].as(), xs[0].as()); + }); + }); + define("(meevax read)", [](library & library) { library.define("get-char", [](let const& xs) diff --git a/test/tail-call.ss b/test/tail-call.ss index 463540ace..b9e9f06d3 100644 --- a/test/tail-call.ss +++ b/test/tail-call.ss @@ -1,5 +1,5 @@ (import (only (meevax core) call-with-current-continuation!) - (only (meevax function) closure?) + (only (meevax procedure) closure?) (scheme base) (scheme write) (scheme process-context) From b12d9a113c8b18c8531a6d2baa3ef142ce115dbe Mon Sep 17 00:00:00 2001 From: yamacir-kit Date: Sat, 7 Oct 2023 21:37:59 +0900 Subject: [PATCH 27/32] Rename struct `function` to `procedure` Signed-off-by: yamacir-kit --- README.md | 6 +- VERSION | 2 +- example/example.cpp | 2 +- example/example.ss | 22 +- include/meevax/kernel/dynamic_environment.hpp | 12 +- include/meevax/kernel/procedure.hpp | 42 ++-- src/kernel/boot.cpp | 227 +++++++++--------- src/kernel/procedure.cpp | 14 +- test/vector.cpp | 2 +- 9 files changed, 162 insertions(+), 167 deletions(-) diff --git a/README.md b/README.md index 8190e003b..d7ff32a92 100644 --- a/README.md +++ b/README.md @@ -99,7 +99,7 @@ Procedures for each standard are provided by the following R7RS-style libraries: cmake -B build -DCMAKE_BUILD_TYPE=Release cd build make package -sudo apt install build/meevax_0.5.26_amd64.deb +sudo apt install build/meevax_0.5.27_amd64.deb ``` or @@ -131,9 +131,9 @@ sudo rm -rf /usr/local/share/meevax | Target Name | Description |-------------|------------- -| `all` | Build shared-library `libmeevax.0.5.26.so` and executable `meevax` +| `all` | Build shared-library `libmeevax.0.5.27.so` and executable `meevax` | `test` | Test executable `meevax` -| `package` | Generate debian package `meevax_0.5.26_amd64.deb` +| `package` | Generate debian package `meevax_0.5.27_amd64.deb` | `install` | Copy files into `/usr/local` directly ## Usage diff --git a/VERSION b/VERSION index 0ef0d6989..c8c8ac3f2 100644 --- a/VERSION +++ b/VERSION @@ -1 +1 @@ -0.5.26 +0.5.27 diff --git a/example/example.cpp b/example/example.cpp index f4315b95c..abf0036cd 100644 --- a/example/example.cpp +++ b/example/example.cpp @@ -11,7 +11,7 @@ extern "C" auto dummy_procedure(object const& xs) { - std::cout << "\n; calling C++ function via foreign-function-interface." << std::endl; + std::cout << "\n; calling C++ function." << std::endl; std::size_t count = 0; diff --git a/example/example.ss b/example/example.ss index 8cab58dbe..8c6c94747 100644 --- a/example/example.ss +++ b/example/example.ss @@ -1,4 +1,4 @@ -(import (only (meevax procedure) foreign-function? foreign-function) +(import (only (meevax procedure) procedure) (scheme base) (scheme process-context) (scheme write) @@ -7,37 +7,37 @@ ; ------------------------------------------------------------------------------ (define dummy-procedure - (foreign-function "build/libexample.so" "dummy_procedure")) + (procedure "build/libexample.so" "dummy_procedure")) -(check (foreign-function? dummy-procedure) => #t) +(check (procedure? dummy-procedure) => #t) (check (dummy-procedure 'hoge 42 #(1 2 3) 3.14) => 43) ; ------------------------------------------------------------------------------ (define length-of-arguments - (foreign-function "build/libexample.so" "length_of_arguments")) + (procedure "build/libexample.so" "length_of_arguments")) -(check (foreign-function? length-of-arguments) => #t) +(check (procedure? length-of-arguments) => #t) (check (length-of-arguments 'hoge 42 #(1 2 3) 3.14) => 4) ; ------------------------------------------------------------------------------ (define make-hoge - (foreign-function "build/libexample.so" "make_hoge")) + (procedure "build/libexample.so" "make_hoge")) (define hoge? - (foreign-function "build/libexample.so" "is_hoge")) + (procedure "build/libexample.so" "is_hoge")) (define hoge-value - (foreign-function "build/libexample.so" "hoge_value")) + (procedure "build/libexample.so" "hoge_value")) -(check (foreign-function? make-hoge) => #t) +(check (procedure? make-hoge) => #t) -(check (foreign-function? hoge?) => #t) +(check (procedure? hoge?) => #t) -(check (foreign-function? hoge-value) => #t) +(check (procedure? hoge-value) => #t) (define h (make-hoge 100)) diff --git a/include/meevax/kernel/dynamic_environment.hpp b/include/meevax/kernel/dynamic_environment.hpp index b32497e12..aaf2f4b85 100644 --- a/include/meevax/kernel/dynamic_environment.hpp +++ b/include/meevax/kernel/dynamic_environment.hpp @@ -286,16 +286,16 @@ inline namespace kernel s = unit; goto fetch; } - else if (callee.is_also()) /* ----------------------------- + else if (callee.is_also()) /* ------------------------------ * - * ( xs . s) e (%call . c) d => (x . s) e c d + * ( xs . s) e (%call . c) d => (x . s) e c d * * where x = procedure(xs) * * ----------------------------------------------------------------- */ { assert(tail(c, 1).template is()); - s = cons(callee.as()(cadr(s)), cddr(s)); + s = cons(callee.as()(cadr(s)), cddr(s)); c = cdr(c); goto fetch; } @@ -336,9 +336,9 @@ inline namespace kernel s = unit; goto fetch; } - else if (callee.is_also()) /* ----------------------------- + else if (callee.is_also()) /* ------------------------------ * - * ( xs) e (%tail-call) (s' e' c' . d) => (x . s') e' c' d + * ( xs) e (%tail-call) (s' e' c' . d) => (x . s') e' c' d * * where x = procedure(xs) * @@ -346,7 +346,7 @@ inline namespace kernel { assert(tail(s, 2).template is()); assert(tail(c, 1).template is()); - s = cons(callee.as()(cadr(s)), car(d)); + s = cons(callee.as()(cadr(s)), car(d)); e = cadr(d); c = caddr(d); d = cdddr(d); diff --git a/include/meevax/kernel/procedure.hpp b/include/meevax/kernel/procedure.hpp index a03e71059..dc6f62ae5 100644 --- a/include/meevax/kernel/procedure.hpp +++ b/include/meevax/kernel/procedure.hpp @@ -25,31 +25,29 @@ namespace meevax { inline namespace kernel { - struct procedure + struct callable { std::string const name; - explicit procedure(std::string const& name) + explicit callable(std::string const& name) : name { name } {} virtual auto operator ()(object & = unit) const -> object = 0; }; - auto operator <<(std::ostream &, procedure const&) -> std::ostream &; + auto operator <<(std::ostream &, callable const&) -> std::ostream &; - #define FUNCTION(...) auto __VA_ARGS__(meevax::object const& xs) -> meevax::object - - struct function : public procedure + struct procedure : public callable { auto (*call)(object const&) -> object; - explicit function(std::string const& name, auto (*call)(object const&) -> object) - : procedure { name } + explicit procedure(std::string const& name, auto (*call)(object const&) -> object) + : callable { name } , call { call } {} - explicit function(std::string const&, std::string const&); + explicit procedure(std::string const&, std::string const&); auto operator ()(object & xs) const -> object override { @@ -57,12 +55,14 @@ inline namespace kernel } }; - struct functor : public procedure + struct functor : public callable { + #define FUNCTION(...) auto __VA_ARGS__(meevax::object const& xs) -> meevax::object + std::function const call; explicit functor(std::string const& name, std::function const& call) - : procedure { name } + : callable { name } , call { call } {} @@ -72,12 +72,12 @@ inline namespace kernel } }; - struct accessor : public procedure + struct accessor : public callable { auto (*call)(object const&) -> object const&; explicit accessor(std::string const& name, auto (*call)(object const&) -> object const&) - : procedure { name } + : callable { name } , call { call } {} @@ -87,12 +87,12 @@ inline namespace kernel } }; - struct predicate : public procedure + struct predicate : public callable { auto (*call)(object const&) -> bool; explicit predicate(std::string const& name, auto (*call)(object const&) -> bool) - : procedure { name } + : callable { name } , call { call } {} @@ -102,12 +102,12 @@ inline namespace kernel } }; - struct mutation : public procedure + struct mutation : public callable { auto (*call)(object &) -> void; explicit mutation(std::string const& name, auto (*call)(object &) -> void) - : procedure { name } + : callable { name } , call { call } {} @@ -118,12 +118,12 @@ inline namespace kernel } }; - struct command : public procedure + struct command : public callable { auto (*call)(object const&) -> void; explicit command(std::string const& name, auto (*call)(object const&) -> void) - : procedure { name } + : callable { name } , call { call } {} @@ -134,12 +134,12 @@ inline namespace kernel } }; - struct thunk : public procedure + struct thunk : public callable { auto (*call)() -> object; explicit thunk(std::string const& name, auto (*call)() -> object) - : procedure { name } + : callable { name } , call { call } {} diff --git a/src/kernel/boot.cpp b/src/kernel/boot.cpp index 7bc0255b8..ccc9777a4 100644 --- a/src/kernel/boot.cpp +++ b/src/kernel/boot.cpp @@ -54,7 +54,7 @@ inline namespace kernel define("(meevax box)", [](library & library) { - library.define("box", [](let const& xs) + library.define("box", [](let const& xs) { return make(car(xs)); }); @@ -207,28 +207,28 @@ inline namespace kernel return xs[0].as().property().is_lower_case(); }); - library.define("digit-value", [](let const& xs) + library.define("digit-value", [](let const& xs) { auto digit_value = xs[0].as().digit_value(); return digit_value ? make(*digit_value) : f; }); - library.define("char->integer", [](let const& xs) + library.define("char->integer", [](let const& xs) { return make(xs[0].as().codepoint); }); - library.define("integer->char", [](let const& xs) + library.define("integer->char", [](let const& xs) { return make(xs[0].as()); }); - library.define("char-upcase", [](let const& xs) + library.define("char-upcase", [](let const& xs) { return make(xs[0].as().upcase()); }); - library.define("char-downcase", [](let const& xs) + library.define("char-downcase", [](let const& xs) { return make(xs[0].as().downcase()); }); @@ -236,7 +236,7 @@ inline namespace kernel define("(meevax complex)", [](library & library) { - library.define("make-rectangular", [](let const& xs) + library.define("make-rectangular", [](let const& xs) { assert(is_real(xs[0])); assert(is_real(xs[1])); @@ -244,7 +244,7 @@ inline namespace kernel return make(xs[0], xs[1]); }); - library.define("make-polar", [](let const& xs) + library.define("make-polar", [](let const& xs) { let const& radius = xs[0], angle = xs[1]; @@ -262,12 +262,12 @@ inline namespace kernel return imag_part(xs[0]); }); - library.define("magnitude", [](let const& xs) + library.define("magnitude", [](let const& xs) { return magnitude(xs[0]); }); - library.define("angle", [](let const& xs) + library.define("angle", [](let const& xs) { return angle(xs[0]); }); @@ -347,7 +347,7 @@ inline namespace kernel define("(meevax environment)", [](library & library) { - library.define("environment", [](let const& xs) + library.define("environment", [](let const& xs) { auto e = environment(); @@ -359,7 +359,7 @@ inline namespace kernel return make(e); }); - library.define("eval", [](let const& xs) + library.define("eval", [](let const& xs) { return xs[1].as().evaluate(xs[0]); }); @@ -382,7 +382,7 @@ inline namespace kernel throw xs[0]; }); - library.define("error-object", [](let const& xs) + library.define("error-object", [](let const& xs) { return make(xs[0], cdr(xs)); }); @@ -461,79 +461,79 @@ inline namespace kernel return is_nan(xs[0]); }); - library.define("exp", [](let const& xs) + library.define("exp", [](let const& xs) { return exp(xs[0]); }); - library.define("sqrt", [](let const& xs) + library.define("sqrt", [](let const& xs) { return sqrt(xs[0]); }); - library.define("log", [](let const& xs) + library.define("log", [](let const& xs) { return 1 < length(xs) ? log(xs[0]) / log(xs[1]) : log(xs[0]); }); - library.define("sin", [](let const& xs) + library.define("sin", [](let const& xs) { return sin(xs[0]); }); - library.define("cos", [](let const& xs) + library.define("cos", [](let const& xs) { return cos(xs[0]); }); - library.define("tan", [](let const& xs) + library.define("tan", [](let const& xs) { return tan(xs[0]); }); - library.define("asin", [](let const& xs) + library.define("asin", [](let const& xs) { return asin(xs[0]); }); - library.define("acos", [](let const& xs) + library.define("acos", [](let const& xs) { return acos(xs[0]); }); - library.define("atan", [](let const& xs) + library.define("atan", [](let const& xs) { return 1 < length(xs) ? atan(xs[0], xs[1]) : atan(xs[0]); }); - library.define("sinh", [](let const& xs) + library.define("sinh", [](let const& xs) { return sinh(xs[0]); }); - library.define("cosh", [](let const& xs) + library.define("cosh", [](let const& xs) { return cosh(xs[0]); }); - library.define("tanh", [](let const& xs) + library.define("tanh", [](let const& xs) { return tanh(xs[0]); }); - library.define("asinh", [](let const& xs) + library.define("asinh", [](let const& xs) { return asinh(xs[0]); }); - library.define("acosh", [](let const& xs) + library.define("acosh", [](let const& xs) { return acosh(xs[0]); }); - library.define("atanh", [](let const& xs) + library.define("atanh", [](let const& xs) { return atanh(xs[0]); }); @@ -556,22 +556,22 @@ inline namespace kernel return xs; }); - library.define("make-list", [](let const& xs) + library.define("make-list", [](let const& xs) { return make_list(xs[0].as(), 1 < length(xs) ? xs[1] : f); }); - library.define("length", [](let const& xs) + library.define("length", [](let const& xs) { return make(length(xs[0])); }); - library.define("append", [](let const& xs) + library.define("append", [](let const& xs) { return std::accumulate(std::begin(xs), std::end(xs), unit, append); }); - library.define("reverse", [](let const& xs) + library.define("reverse", [](let const& xs) { return reverse(xs[0]); }); @@ -699,27 +699,27 @@ inline namespace kernel return is_even(xs[0]); }); - library.define("max", [](let const& xs) + library.define("max", [](let const& xs) { return max(xs); }); - library.define("min", [](let const& xs) + library.define("min", [](let const& xs) { return min(xs); }); - library.define("+", [](let const& xs) + library.define("+", [](let const& xs) { return std::accumulate(std::begin(xs), std::end(xs), e0, std::plus()); }); - library.define("*", [](let const& xs) + library.define("*", [](let const& xs) { return std::accumulate(std::begin(xs), std::end(xs), e1, std::multiplies()); }); - library.define("-", [](let const& xs) + library.define("-", [](let const& xs) { if (cdr(xs).is()) { @@ -731,7 +731,7 @@ inline namespace kernel } }); - library.define("/", [](let const& xs) + library.define("/", [](let const& xs) { if (cdr(xs).is()) { @@ -743,27 +743,27 @@ inline namespace kernel } }); - library.define("abs", [](let const& xs) + library.define("abs", [](let const& xs) { return abs(xs[0]); }); - library.define("quotient", [](let const& xs) + library.define("quotient", [](let const& xs) { return quotient(xs[0], xs[1]); }); - library.define("remainder", [](let const& xs) + library.define("remainder", [](let const& xs) { return remainder(xs[0], xs[1]); }); - library.define("modulo", [](let const& xs) + library.define("modulo", [](let const& xs) { return modulo(xs[0], xs[1]); }); - library.define("gcd", [](let const& xs) + library.define("gcd", [](let const& xs) { switch (length(xs)) { @@ -778,7 +778,7 @@ inline namespace kernel } }); - library.define("lcm", [](let const& xs) + library.define("lcm", [](let const& xs) { switch (length(xs)) { @@ -793,37 +793,37 @@ inline namespace kernel } }); - library.define("numerator", [](let const& xs) + library.define("numerator", [](let const& xs) { return numerator(xs[0]); }); - library.define("denominator", [](let const& xs) + library.define("denominator", [](let const& xs) { return denominator(xs[0]); }); - library.define("floor", [](let const& xs) + library.define("floor", [](let const& xs) { return floor(xs[0]); }); - library.define("ceiling", [](let const& xs) + library.define("ceiling", [](let const& xs) { return ceil(xs[0]); }); - library.define("truncate", [](let const& xs) + library.define("truncate", [](let const& xs) { return trunc(xs[0]); }); - library.define("round", [](let const& xs) + library.define("round", [](let const& xs) { return round(xs[0]); }); - library.define("exact-integer-square-root", [](let const& xs) + library.define("exact-integer-square-root", [](let const& xs) { auto&& [s, r] = xs[0].as().square_root(); @@ -831,22 +831,22 @@ inline namespace kernel make(std::forward(r))); }); - library.define("expt", [](let const& xs) + library.define("expt", [](let const& xs) { return pow(xs[0], xs[1]); }); - library.define("exact", [](let const& xs) + library.define("exact", [](let const& xs) { return exact(xs[0]); }); - library.define("inexact", [](let const& xs) + library.define("inexact", [](let const& xs) { return inexact(xs[0]); }); - library.define("number->string", [](let const& xs) + library.define("number->string", [](let const& xs) { switch (length(xs)) { @@ -861,7 +861,7 @@ inline namespace kernel } }); - library.define("string->number", [](let const& xs) + library.define("string->number", [](let const& xs) { switch (length(xs)) { @@ -884,7 +884,7 @@ inline namespace kernel return xs[0].is(); }); - library.define("cons", [](let const& xs) + library.define("cons", [](let const& xs) { return cons(xs[0], xs[1]); }); @@ -981,22 +981,22 @@ inline namespace kernel return make(); }); - library.define("open-input-file", [](let const& xs) + library.define("open-input-file", [](let const& xs) { return make(xs[0].as()); }); - library.define("open-output-file", [](let const& xs) + library.define("open-output-file", [](let const& xs) { return make(xs[0].as()); }); - library.define("open-binary-input-file", [](let const& xs) + library.define("open-binary-input-file", [](let const& xs) { return make(xs[0].as()); }); - library.define("open-binary-output-file", [](let const& xs) + library.define("open-binary-output-file", [](let const& xs) { return make(xs[0].as()); }); @@ -1006,32 +1006,32 @@ inline namespace kernel xs[0].as().close(); }); - library.define("open-input-string", [](let const& xs) + library.define("open-input-string", [](let const& xs) { return make(xs[0].as()); }); - library.define("open-output-string", [](let const&) + library.define("open-output-string", [](let const&) { return make(); }); - library.define("get-output-string", [](let const& xs) + library.define("get-output-string", [](let const& xs) { return make(xs[0].as().ostringstream.str()); }); - library.define("open-input-u8vector", [](let const& xs) + library.define("open-input-u8vector", [](let const& xs) { return make(xs[0].as()); }); - library.define("open-output-u8vector", [](let const&) + library.define("open-output-u8vector", [](let const&) { return make(); }); - library.define("get-output-u8vector", [](let const& xs) + library.define("get-output-u8vector", [](let const& xs) { return make(xs[0].as().vector); }); @@ -1054,11 +1054,6 @@ inline namespace kernel define("(meevax procedure)", [](library & library) { - library.define("procedure?", [](let const& xs) - { - return xs[0].is() or xs[0].is() or xs[0].is_also(); - }); - library.define("closure?", [](let const& xs) { return xs[0].is(); @@ -1069,20 +1064,20 @@ inline namespace kernel return xs[0].is(); }); - library.define("foreign-function?", [](let const& xs) + library.define("procedure?", [](let const& xs) { - return xs[0].is_also(); + return xs[0].is() or xs[0].is() or xs[0].is_also(); }); - library.define("foreign-function", [](let const& xs) + library.define("procedure", [](let const& xs) { - return make(xs[1].as(), xs[0].as()); + return make(xs[1].as(), xs[0].as()); }); }); define("(meevax read)", [](library & library) { - library.define("get-char", [](let const& xs) + library.define("get-char", [](let const& xs) { return xs[0].as().get(); }); @@ -1092,22 +1087,22 @@ inline namespace kernel return xs[0].as().get_ready(); }); - library.define("get-line", [](let const& xs) + library.define("get-line", [](let const& xs) { return xs[0].as().get_line(); }); - library.define("get-string", [](let const& xs) + library.define("get-string", [](let const& xs) { return xs[1].as().get(xs[0].as()); }); - library.define("peek-char", [](let const& xs) + library.define("peek-char", [](let const& xs) { return xs[0].as().peek(); }); - library.define("get-u8", [](let const& xs) + library.define("get-u8", [](let const& xs) { return xs[0].as().get(); }); @@ -1117,17 +1112,17 @@ inline namespace kernel return xs[0].as().get_ready(); }); - library.define("peek-u8", [](let const& xs) + library.define("peek-u8", [](let const& xs) { return xs[0].as().peek(); }); - library.define("get-u8vector", [](let const& xs) + library.define("get-u8vector", [](let const& xs) { return xs[1].as().get(xs[0].as()); }); - library.define("read", [](let const& xs) + library.define("read", [](let const& xs) { return xs[0].as().read(); }); @@ -1140,7 +1135,7 @@ inline namespace kernel return xs[0].is(); }); - library.define("make-string", [](let const& xs) + library.define("make-string", [](let const& xs) { switch (length(xs)) { @@ -1155,7 +1150,7 @@ inline namespace kernel } }); - library.define("string", [](let const& xs) + library.define("string", [](let const& xs) { let s = make(); @@ -1167,12 +1162,12 @@ inline namespace kernel return s; }); - library.define("string-length", [](let const& xs) + library.define("string-length", [](let const& xs) { return make(xs[0].as().vector.size()); }); - library.define("string-ref", [](let const& xs) + library.define("string-ref", [](let const& xs) { return make(xs[0].as().vector.at(xs[1].as())); }); @@ -1312,7 +1307,7 @@ inline namespace kernel return std::adjacent_find(xs.begin(), xs.end(), compare) == xs.end(); }); - library.define("string-append", [](let const& xs) + library.define("string-append", [](let const& xs) { let s = make(); @@ -1326,7 +1321,7 @@ inline namespace kernel return s; }); - library.define("string->list", [](let const& xs) + library.define("string->list", [](let const& xs) { auto push = [](let const& xs, character const& c) { @@ -1361,7 +1356,7 @@ inline namespace kernel } }); - library.define("list->string", [](let const& xs) + library.define("list->string", [](let const& xs) { let s = make(); @@ -1373,7 +1368,7 @@ inline namespace kernel return s; }); - library.define("string-copy", [](let const& xs) + library.define("string-copy", [](let const& xs) { switch (length(xs)) { @@ -1471,17 +1466,17 @@ inline namespace kernel return xs[0].is(); }); - library.define("symbol->string", [](let const& xs) + library.define("symbol->string", [](let const& xs) { return make(xs[0].as()); }); - library.define("string->symbol", [](let const& xs) + library.define("string->symbol", [](let const& xs) { return make_symbol(xs[0].as()); }); - library.define("identifier->symbol", [](let const& xs) + library.define("identifier->symbol", [](let const& xs) { if (let const& x = xs[0]; x.is()) { @@ -1513,7 +1508,7 @@ inline namespace kernel return xs[0].is(); }); - library.define("make-syntactic-closure", [](let const& xs) + library.define("make-syntactic-closure", [](let const& xs) { return make(xs[0], xs[1], xs[2]); }); @@ -1521,7 +1516,7 @@ inline namespace kernel define("(meevax system)", [](library & library) { - library.define("get-environment-variable", [](let const& xs) + library.define("get-environment-variable", [](let const& xs) { if (auto s = std::getenv(static_cast(xs[0].as()).c_str())) { @@ -1571,12 +1566,12 @@ inline namespace kernel return xs[0].is(); }); - library.define("vector", [](let const& xs) + library.define("vector", [](let const& xs) { return make(xs); }); - library.define("make-vector", [](let const& xs) + library.define("make-vector", [](let const& xs) { switch (length(xs)) { @@ -1591,7 +1586,7 @@ inline namespace kernel } }); - library.define("vector-length", [](let const& xs) + library.define("vector-length", [](let const& xs) { return make(xs[0].as().vector.size()); }); @@ -1606,7 +1601,7 @@ inline namespace kernel xs[0].as().vector[xs[1].as()] = xs[2]; }); - library.define("vector->list", [](let const& xs) + library.define("vector->list", [](let const& xs) { switch (length(xs)) { @@ -1636,12 +1631,12 @@ inline namespace kernel } }); - library.define("list->vector", [](let const& xs) + library.define("list->vector", [](let const& xs) { return make(xs[0]); }); - library.define("vector->string", [](let const& xs) + library.define("vector->string", [](let const& xs) { let s = make(); @@ -1678,7 +1673,7 @@ inline namespace kernel } }); - library.define("string->vector", [](let const& xs) + library.define("string->vector", [](let const& xs) { let v = make(); @@ -1690,7 +1685,7 @@ inline namespace kernel return v; }); - library.define("vector-copy", [](let const& xs) + library.define("vector-copy", [](let const& xs) { switch (length(xs)) { @@ -1750,7 +1745,7 @@ inline namespace kernel } }); - library.define("vector-append", [](let const& xs) + library.define("vector-append", [](let const& xs) { let v = make(); @@ -1800,22 +1795,22 @@ inline namespace kernel return xs[0].is(); \ }); \ \ - library.define("make-" #TAG "vector", [](let const& xs) \ + library.define("make-" #TAG "vector", [](let const& xs) \ { \ return make(xs[0].as(), 1 < length(xs) ? xs[1] : unspecified); \ }); \ \ - library.define(#TAG "vector", [](let const& xs) \ + library.define(#TAG "vector", [](let const& xs) \ { \ return make(xs); \ }); \ \ - library.define(#TAG "vector-length", [](let const& xs) \ + library.define(#TAG "vector-length", [](let const& xs) \ { \ return make(xs[0].as().valarray.size()); \ }); \ \ - library.define(#TAG "vector-ref", [](let const& xs) \ + library.define(#TAG "vector-ref", [](let const& xs) \ { \ return TAG##vector::output_cast(xs[0].as().valarray[xs[1].as()]); \ }); \ @@ -1825,7 +1820,7 @@ inline namespace kernel xs[0].as().valarray[xs[1].as()] = TAG##vector::input_cast(xs[2]); \ }); \ \ - library.define(#TAG "vector-copy", [](let const& xs) \ + library.define(#TAG "vector-copy", [](let const& xs) \ { \ return make(xs[0].as(), \ 1 < length(xs) ? xs[1].as() : std::size_t(), \ @@ -1846,13 +1841,13 @@ inline namespace kernel 4 < length(xs) ? xs[4].as() : xs[2].as().valarray.size()); \ }); \ \ - library.define(#TAG "vector-append", [](let const& xs) \ + library.define(#TAG "vector-append", [](let const& xs) \ { \ return make(xs[0].as(), \ xs[1].as()); \ }); \ \ - library.define(#TAG "vector->list", [](let const& xs) \ + library.define(#TAG "vector->list", [](let const& xs) \ { \ auto list = [](auto&& v, auto&& a, auto&& b) \ { \ @@ -1870,7 +1865,7 @@ inline namespace kernel 2 < length(xs) ? xs[2].as() : xs[0].as().valarray.size()); \ }); \ \ - library.define("list->" #TAG "vector", [](let const& xs) \ + library.define("list->" #TAG "vector", [](let const& xs) \ { \ return make(xs[0]); \ }) @@ -1886,7 +1881,7 @@ inline namespace kernel DEFINE_HOMOGENEOUS_VECTOR(u32); DEFINE_HOMOGENEOUS_VECTOR(u64); - library.define("u8vector->string", [](let const& xs) + library.define("u8vector->string", [](let const& xs) { auto buffer = std::ostringstream(); @@ -1900,7 +1895,7 @@ inline namespace kernel return input_string_port(buffer.str()).get(std::numeric_limits::max()); }); - library.define("string->u8vector", [](let const& xs) + library.define("string->u8vector", [](let const& xs) { auto convert = [](std::string const& s) { diff --git a/src/kernel/procedure.cpp b/src/kernel/procedure.cpp index f2c010d0b..7d45285de 100644 --- a/src/kernel/procedure.cpp +++ b/src/kernel/procedure.cpp @@ -31,6 +31,11 @@ namespace meevax { inline namespace kernel { + auto operator <<(std::ostream & os, callable const& datum) -> std::ostream & + { + return os << magenta("#,(") << green("procedure") << " " << symbol(datum.name) << magenta(")"); + } + auto dlopen(std::string const& libfoo_so) -> void * { auto dlclose = [](void * const handle) @@ -79,13 +84,8 @@ inline namespace kernel } } - function::function(std::string const& name, std::string const& libfoo_so) - : function { name, dlsym(name, dlopen(libfoo_so)) } + procedure::procedure(std::string const& name, std::string const& libfoo_so) + : procedure { name, dlsym(name, dlopen(libfoo_so)) } {} - - auto operator <<(std::ostream & os, procedure const& datum) -> std::ostream & - { - return os << magenta("#,(") << green("procedure") << " " << symbol(datum.name) << magenta(")"); - } } // namespace kernel } // namespace meevax diff --git a/test/vector.cpp b/test/vector.cpp index 384f2fa6f..193ce28cd 100644 --- a/test/vector.cpp +++ b/test/vector.cpp @@ -173,7 +173,7 @@ auto main() -> int { auto module = environment(); - module.define("vector", [](let const& xs) + module.define("vector", [](let const& xs) { return make(xs); }); From 80d4703e824f003bc9655869f4286a703c494012 Mon Sep 17 00:00:00 2001 From: yamacir-kit Date: Sat, 7 Oct 2023 22:25:58 +0900 Subject: [PATCH 28/32] Update procedure `procedure` receive symbol as second argument Signed-off-by: yamacir-kit --- README.md | 6 +++--- VERSION | 2 +- example/example.ss | 10 +++++----- src/kernel/boot.cpp | 2 +- src/kernel/procedure.cpp | 4 ++-- 5 files changed, 12 insertions(+), 12 deletions(-) diff --git a/README.md b/README.md index d7ff32a92..610a1d5d2 100644 --- a/README.md +++ b/README.md @@ -99,7 +99,7 @@ Procedures for each standard are provided by the following R7RS-style libraries: cmake -B build -DCMAKE_BUILD_TYPE=Release cd build make package -sudo apt install build/meevax_0.5.27_amd64.deb +sudo apt install build/meevax_0.5.28_amd64.deb ``` or @@ -131,9 +131,9 @@ sudo rm -rf /usr/local/share/meevax | Target Name | Description |-------------|------------- -| `all` | Build shared-library `libmeevax.0.5.27.so` and executable `meevax` +| `all` | Build shared-library `libmeevax.0.5.28.so` and executable `meevax` | `test` | Test executable `meevax` -| `package` | Generate debian package `meevax_0.5.27_amd64.deb` +| `package` | Generate debian package `meevax_0.5.28_amd64.deb` | `install` | Copy files into `/usr/local` directly ## Usage diff --git a/VERSION b/VERSION index c8c8ac3f2..d55306778 100644 --- a/VERSION +++ b/VERSION @@ -1 +1 @@ -0.5.27 +0.5.28 diff --git a/example/example.ss b/example/example.ss index 8c6c94747..3acedb112 100644 --- a/example/example.ss +++ b/example/example.ss @@ -7,7 +7,7 @@ ; ------------------------------------------------------------------------------ (define dummy-procedure - (procedure "build/libexample.so" "dummy_procedure")) + (procedure "build/libexample.so" 'dummy_procedure)) (check (procedure? dummy-procedure) => #t) @@ -16,7 +16,7 @@ ; ------------------------------------------------------------------------------ (define length-of-arguments - (procedure "build/libexample.so" "length_of_arguments")) + (procedure "build/libexample.so" 'length_of_arguments)) (check (procedure? length-of-arguments) => #t) @@ -25,13 +25,13 @@ ; ------------------------------------------------------------------------------ (define make-hoge - (procedure "build/libexample.so" "make_hoge")) + (procedure "build/libexample.so" 'make_hoge)) (define hoge? - (procedure "build/libexample.so" "is_hoge")) + (procedure "build/libexample.so" 'is_hoge)) (define hoge-value - (procedure "build/libexample.so" "hoge_value")) + (procedure "build/libexample.so" 'hoge_value)) (check (procedure? make-hoge) => #t) diff --git a/src/kernel/boot.cpp b/src/kernel/boot.cpp index ccc9777a4..8775071ad 100644 --- a/src/kernel/boot.cpp +++ b/src/kernel/boot.cpp @@ -1071,7 +1071,7 @@ inline namespace kernel library.define("procedure", [](let const& xs) { - return make(xs[1].as(), xs[0].as()); + return make(xs[0].as(), xs[1].as()); }); }); diff --git a/src/kernel/procedure.cpp b/src/kernel/procedure.cpp index 7d45285de..48bb892b5 100644 --- a/src/kernel/procedure.cpp +++ b/src/kernel/procedure.cpp @@ -84,8 +84,8 @@ inline namespace kernel } } - procedure::procedure(std::string const& name, std::string const& libfoo_so) - : procedure { name, dlsym(name, dlopen(libfoo_so)) } + procedure::procedure(std::string const& filename, std::string const& symbol) + : procedure { name, dlsym(symbol, dlopen(filename)) } {} } // namespace kernel } // namespace meevax From d0132c8edcab726b9e08ab48dc517842d943490a Mon Sep 17 00:00:00 2001 From: yamacir-kit Date: Sun, 8 Oct 2023 00:46:29 +0900 Subject: [PATCH 29/32] Fix struct `procedure` constructor Signed-off-by: yamacir-kit --- README.md | 6 +++--- VERSION | 2 +- example/example.cpp | 2 +- example/example.ss | 8 ++++---- src/kernel/procedure.cpp | 21 ++++++++++----------- 5 files changed, 19 insertions(+), 20 deletions(-) diff --git a/README.md b/README.md index 610a1d5d2..88ac7264b 100644 --- a/README.md +++ b/README.md @@ -99,7 +99,7 @@ Procedures for each standard are provided by the following R7RS-style libraries: cmake -B build -DCMAKE_BUILD_TYPE=Release cd build make package -sudo apt install build/meevax_0.5.28_amd64.deb +sudo apt install build/meevax_0.5.29_amd64.deb ``` or @@ -131,9 +131,9 @@ sudo rm -rf /usr/local/share/meevax | Target Name | Description |-------------|------------- -| `all` | Build shared-library `libmeevax.0.5.28.so` and executable `meevax` +| `all` | Build shared-library `libmeevax.0.5.29.so` and executable `meevax` | `test` | Test executable `meevax` -| `package` | Generate debian package `meevax_0.5.28_amd64.deb` +| `package` | Generate debian package `meevax_0.5.29_amd64.deb` | `install` | Copy files into `/usr/local` directly ## Usage diff --git a/VERSION b/VERSION index d55306778..7c96be4ee 100644 --- a/VERSION +++ b/VERSION @@ -1 +1 @@ -0.5.28 +0.5.29 diff --git a/example/example.cpp b/example/example.cpp index abf0036cd..9e7766003 100644 --- a/example/example.cpp +++ b/example/example.cpp @@ -4,7 +4,7 @@ using namespace meevax; // NOTE: DIRTY HACK extern "C" { - auto length_of_arguments(object const& xs) + auto arity(object const& xs) { return make(length(xs)); } diff --git a/example/example.ss b/example/example.ss index 3acedb112..863ece4b0 100644 --- a/example/example.ss +++ b/example/example.ss @@ -15,12 +15,12 @@ ; ------------------------------------------------------------------------------ -(define length-of-arguments - (procedure "build/libexample.so" 'length_of_arguments)) +(define arity + (procedure "build/libexample.so" 'arity)) -(check (procedure? length-of-arguments) => #t) +(check (procedure? arity) => #t) -(check (length-of-arguments 'hoge 42 #(1 2 3) 3.14) => 4) +(check (arity 'hoge 42 #(1 2 3) 3.14) => 4) ; ------------------------------------------------------------------------------ diff --git a/src/kernel/procedure.cpp b/src/kernel/procedure.cpp index 48bb892b5..2e1b09759 100644 --- a/src/kernel/procedure.cpp +++ b/src/kernel/procedure.cpp @@ -36,7 +36,7 @@ inline namespace kernel return os << magenta("#,(") << green("procedure") << " " << symbol(datum.name) << magenta(")"); } - auto dlopen(std::string const& libfoo_so) -> void * + auto dlopen(std::string const& filename) -> void * { auto dlclose = [](void * const handle) { @@ -52,18 +52,17 @@ inline namespace kernel try { - return dynamic_libraries.at(libfoo_so).get(); + return dynamic_libraries.at(filename).get(); } catch (std::out_of_range const&) { - if (auto handle = ::dlopen(libfoo_so.c_str(), RTLD_LAZY | RTLD_GLOBAL); handle) + if (auto handle = ::dlopen(filename.c_str(), RTLD_LAZY | RTLD_GLOBAL); handle) { - dynamic_libraries.emplace( - std::piecewise_construct, - std::forward_as_tuple(libfoo_so), - std::forward_as_tuple(handle, dlclose)); + dynamic_libraries.emplace(std::piecewise_construct, + std::forward_as_tuple(filename), + std::forward_as_tuple(handle, dlclose)); - return dlopen(libfoo_so); + return dlopen(filename); } else { @@ -72,9 +71,9 @@ inline namespace kernel } } - auto dlsym(std::string const& name, void * const handle) -> FUNCTION((*)) + auto dlsym(std::string const& symbol, void * const handle) -> FUNCTION((*)) { - if (auto address = ::dlsym(handle, name.c_str()); address) + if (auto address = ::dlsym(handle, symbol.c_str()); address) { return reinterpret_cast(address); } @@ -85,7 +84,7 @@ inline namespace kernel } procedure::procedure(std::string const& filename, std::string const& symbol) - : procedure { name, dlsym(symbol, dlopen(filename)) } + : procedure { filename, dlsym(symbol, dlopen(filename)) } {} } // namespace kernel } // namespace meevax From 3b909404c184e055ed207b0c0da493ad1506fd3b Mon Sep 17 00:00:00 2001 From: yamacir-kit Date: Sun, 8 Oct 2023 02:29:58 +0900 Subject: [PATCH 30/32] Unify procedure-related structures into a single template `procedure` Signed-off-by: yamacir-kit --- README.md | 6 +- VERSION | 2 +- include/meevax/kernel/configurator.hpp | 12 +- include/meevax/kernel/library.hpp | 6 + include/meevax/kernel/pair.hpp | 6 + include/meevax/kernel/procedure.hpp | 134 ++----- .../meevax/kernel/syntactic_environment.hpp | 6 + src/kernel/boot.cpp | 338 +++++++++--------- src/kernel/procedure.cpp | 8 +- 9 files changed, 237 insertions(+), 281 deletions(-) diff --git a/README.md b/README.md index 88ac7264b..9fa31ef64 100644 --- a/README.md +++ b/README.md @@ -99,7 +99,7 @@ Procedures for each standard are provided by the following R7RS-style libraries: cmake -B build -DCMAKE_BUILD_TYPE=Release cd build make package -sudo apt install build/meevax_0.5.29_amd64.deb +sudo apt install build/meevax_0.5.30_amd64.deb ``` or @@ -131,9 +131,9 @@ sudo rm -rf /usr/local/share/meevax | Target Name | Description |-------------|------------- -| `all` | Build shared-library `libmeevax.0.5.29.so` and executable `meevax` +| `all` | Build shared-library `libmeevax.0.5.30.so` and executable `meevax` | `test` | Test executable `meevax` -| `package` | Generate debian package `meevax_0.5.29_amd64.deb` +| `package` | Generate debian package `meevax_0.5.30_amd64.deb` | `install` | Copy files into `/usr/local` directly ## Usage diff --git a/VERSION b/VERSION index 7c96be4ee..9dad0d549 100644 --- a/VERSION +++ b/VERSION @@ -1 +1 @@ -0.5.29 +0.5.30 diff --git a/include/meevax/kernel/configurator.hpp b/include/meevax/kernel/configurator.hpp index 148166a3d..6cf2a7b09 100644 --- a/include/meevax/kernel/configurator.hpp +++ b/include/meevax/kernel/configurator.hpp @@ -66,7 +66,7 @@ inline namespace kernel { option("(i|interactive)", [this](auto) { - let const f = make("", [this](let const&) + let const f = make("", [this](let const&) { interactive = true; return unspecified; @@ -82,7 +82,7 @@ inline namespace kernel option("(h|help)", [](auto) { - let static const f = make("", [](let const&) + let static const f = make("", [](let const&) { std::cout << help() << std::endl; throw EXIT_SUCCESS; @@ -93,7 +93,7 @@ inline namespace kernel option("(l|load)", [this](auto read) { - let const f = make("", [this](let const& xs) + let const f = make("", [this](let const& xs) { static_cast(*this).load(xs[0].as()); return unspecified; @@ -104,7 +104,7 @@ inline namespace kernel option("(v|version)", [](auto) { - let static const f = make("", [](let const&) + let static const f = make("", [](let const&) { std::cout << version() << std::endl; throw EXIT_SUCCESS; @@ -115,7 +115,7 @@ inline namespace kernel option("(w|write)", [](auto read) { - let static const f = make("", [](let const& xs) + let static const f = make("", [](let const& xs) { std::cout << xs[0] << std::endl; }); @@ -184,7 +184,7 @@ inline namespace kernel } else { - let const f = make("", [iter](let const&) + let const f = make("", [iter](let const&) { Environment().load(*iter); return unspecified; diff --git a/include/meevax/kernel/library.hpp b/include/meevax/kernel/library.hpp index 7041c4a11..4656460b0 100644 --- a/include/meevax/kernel/library.hpp +++ b/include/meevax/kernel/library.hpp @@ -47,6 +47,12 @@ inline namespace kernel export_specs = cons(input_string_port(name).read(), export_specs); } + template